src/compiler/proclaim.lisp

   1 ;;;; This file contains load-time support for declaration processing.
   2 ;;;; In CMU CL it was split off from the compiler so that the compiler
   3 ;;;; doesn't have to be in the cold load, but in SBCL the compiler is
   4 ;;;; in the cold load again, so this might not be valuable.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!C")
  16
  17 (file-comment
  18   "$Header$")
  19
  20 ;;; !COLD-INIT calls this twice to initialize the cookies, once before
  21 ;;; any toplevel forms are executed, then again to undo any lingering
  22 ;;; effects of toplevel DECLAIMs.
  23 (!begin-collecting-cold-init-forms)
  24 (!cold-init-forms
  25   (setf *default-cookie*
  26         (make-cookie :safety 1
  27                      :speed 1
  28                      :space 1
  29                      :cspeed 1
  30                      :brevity 1
  31                      ;; Note: CMU CL had a default of 2 for DEBUG and 1 for all
  32                      ;; the other qualities. SBCL uses a default of 1 for every
  33                      ;; quality, because the ANSI documentation for the
  34                      ;; OPTIMIZE declaration says that 1 is "the neutral
  35                      ;; value", and it seems natural for the neutral value to
  36                      ;; be the default.
  37                      :debug 1))
  38   (setf *default-interface-cookie*
  39         (make-cookie)))
  40 (!defun-from-collected-cold-init-forms !set-sane-cookie-defaults)
  41
  42 ;;; A list of UNDEFINED-WARNING structures representing references to unknown
  43 ;;; stuff which came up in a compilation unit.
  44 (defvar *undefined-warnings*)
  45 (declaim (list *undefined-warnings*))
  46
  47 ;;; Check that Name is a valid function name, returning the name if OK, and
  48 ;;; doing an error if not. In addition to checking for basic well-formedness,
  49 ;;; we also check that symbol names are not NIL or the name of a special form.
  50 (defun check-function-name (name)
  51   (typecase name
  52     (list
  53      (unless (and (consp name) (consp (cdr name))
  54                   (null (cddr name)) (eq (car name) 'setf)
  55                   (symbolp (cadr name)))
  56        (compiler-error "illegal function name: ~S" name))
  57      name)
  58     (symbol
  59      (when (eq (info :function :kind name) :special-form)
  60        (compiler-error "Special form is an illegal function name: ~S" name))
  61      name)
  62     (t
  63      (compiler-error "illegal function name: ~S" name))))
  64
  65 ;;; Called to do something about SETF functions that overlap with SETF
  66 ;;; macros. Perhaps we should interact with the user to see whether
  67 ;;; the macro should be blown away, but for now just give a warning.
  68 ;;; Due to the weak semantics of the (SETF FUNCTION) name, we can't
  69 ;;; assume that they aren't just naming a function (SETF FOO) for the
  70 ;;; heck of it. NAME is already known to be well-formed.
  71 (defun note-if-setf-function-and-macro (name)
  72   (when (consp name)
  73     (when (or (info :setf :inverse name)
  74               (info :setf :expander name))
  75       (compiler-style-warning
  76        "defining as a SETF function a name that already has a SETF macro:~
  77        ~%  ~S"
  78        name)))
  79   (values))
  80
  81 ;;; Look up some symbols in *FREE-VARIABLES*, returning the var
  82 ;;; structures for any which exist. If any of the names aren't
  83 ;;; symbols, we complain.
  84 (declaim (ftype (function (list) list) get-old-vars))
  85 (defun get-old-vars (names)
  86   (collect ((vars))
  87     (dolist (name names (vars))
  88       (unless (symbolp name)
  89         (compiler-error "The name ~S is not a symbol." name))
  90       (let ((old (gethash name *free-variables*)))
  91         (when old (vars old))))))
  92
  93 ;;; Return a new cookie containing the policy information represented
  94 ;;; by the optimize declaration SPEC. Any parameters not specified are
  95 ;;; defaulted from COOKIE.
  96 (declaim (ftype (function (list cookie) cookie) process-optimize-declaration))
  97 (defun process-optimize-declaration (spec cookie)
  98   (let ((res (copy-cookie cookie)))
  99     (dolist (quality (cdr spec))
 100       (let ((quality (if (atom quality) (list quality 3) quality)))
 101         (if (and (consp (cdr quality)) (null (cddr quality))
 102                  (typep (second quality) 'real) (<= 0 (second quality) 3))
 103             (let ((value (rational (second quality))))
 104               (case (first quality)
 105                 (speed (setf (cookie-speed res) value))
 106                 (space (setf (cookie-space res) value))
 107                 (safety (setf (cookie-safety res) value))
 108                 (compilation-speed (setf (cookie-cspeed res) value))
 109                 ;; FIXME: BREVITY is an undocumented name for it,
 110                 ;; should go away. And INHIBIT-WARNINGS is a
 111                 ;; misleading name for it. Perhaps BREVITY would be
 112                 ;; better. But the ideal name would have connotations
 113                 ;; of suppressing only optimization-related notes,
 114                 ;; which I think is the behavior. Perhaps
 115                 ;; INHIBIT-NOTES?
 116                 ((inhibit-warnings brevity) (setf (cookie-brevity res) value))
 117                 ((debug-info debug) (setf (cookie-debug res) value))
 118                 (t
 119                  (compiler-warning "unknown optimization quality ~S in ~S"
 120                                    (car quality) spec))))
 121             (compiler-warning
 122              "malformed optimization quality specifier ~S in ~S"
 123              quality spec))))
 124     res))
 125
 126 (defun sb!xc:proclaim (form)
 127   (unless (consp form)
 128     (error "malformed PROCLAIM spec: ~S" form))
 129   (let ((kind (first form))
 130         (args (rest form)))
 131     (case kind
 132       (special
 133        (dolist (name args)
 134          (unless (symbolp name)
 135            (error "can't declare a non-symbol as SPECIAL: ~S" name))
 136          (clear-info :variable :constant-value name)
 137          (setf (info :variable :kind name) :special)))
 138       (type
 139        (when *type-system-initialized*
 140          (let ((type (specifier-type (first args))))
 141            (dolist (name (rest args))
 142              (unless (symbolp name)
 143                (error "can't declare TYPE of a non-symbol: ~S" name))
 144              (when (eq (info :variable :where-from name) :declared)
 145                (let ((old-type (info :variable :type name)))
 146                  (when (type/= type old-type)
 147                    (style-warn "The new TYPE proclamation~%  ~S~@
 148                                for ~S does not match the old TYPE~@
 149                                proclamation ~S"
 150                                type name old-type))))
 151              (setf (info :variable :type name) type)
 152              (setf (info :variable :where-from name) :declared)))))
 153       (ftype
 154        ;; FIXME: Since currently *TYPE-SYSTEM-INITIALIZED* is not set
 155        ;; until many toplevel forms have run, this condition on
 156        ;; PROCLAIM (FTYPE ..) (and on PROCLAIM (TYPE ..), above) means
 157        ;; that valid PROCLAIMs in cold code could get lost. Probably
 158        ;; the cleanest way to deal with this would be to initialize
 159        ;; the type system completely in special cold init forms,
 160        ;; before any ordinary toplevel forms run. Failing that, we
 161        ;; could queue up PROCLAIMs to be done after the type system is
 162        ;; initialized. Failing that, we could at least issue a warning
 163        ;; when we have to ignore a PROCLAIM because the type system is
 164        ;; uninitialized.
 165        (when *type-system-initialized*
 166          (let ((type (specifier-type (first args))))
 167            (unless (csubtypep type (specifier-type 'function))
 168              (error "not a function type: ~S" (first args)))
 169            (dolist (name (rest args))
 170              (cond ((info :function :accessor-for name)
 171                     (warn "ignoring FTYPE proclamation for slot accessor:~%  ~S"
 172                           name))
 173                    (t
 174
 175                     ;; KLUDGE: Something like the commented-out TYPE/=
 176                     ;; check here would be nice, but it has been
 177                     ;; commented out because TYPE/= doesn't support
 178                     ;; function types. It could probably be made to do
 179                     ;; so, but it might take some time, since function
 180                     ;; types involve values types, which aren't
 181                     ;; supported, and since the SUBTYPEP operator for
 182                     ;; FUNCTION types is rather broken, e.g.
 183                     ;;   (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL)
 184                     ;;             '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T
 185                     ;; -- WHN 20000229
 186                     #+nil
 187                     (when (eq (info :function :where-from name) :declared)
 188                       (let ((old-type (info :function :type name)))
 189                         (when (type/= type old-type)
 190                           (style-warn "new FTYPE proclamation~@
 191                                        ~S~@
 192                                        for ~S does not match old FTYPE proclamation~@
 193                                        ~S"
 194                                       (list type name old-type)))))
 195
 196                     (proclaim-as-function-name name)
 197                     (note-name-defined name :function)
 198                     (setf (info :function :type name) type
 199                           (info :function :where-from name) :declared)))))))
 200       (freeze-type
 201        (dolist (type args)
 202          (let ((class (specifier-type type)))
 203            (when (typep class 'class)
 204              (setf (class-state class) :sealed)
 205              (let ((subclasses (class-subclasses class)))
 206                (when subclasses
 207                  (dohash (subclass layout subclasses)
 208                    (declare (ignore layout))
 209                    (setf (class-state subclass) :sealed))))))))
 210       (optimize
 211        (setq *default-cookie*
 212              (process-optimize-declaration form *default-cookie*)))
 213       (optimize-interface
 214        (setq *default-interface-cookie*
 215              (process-optimize-declaration form *default-interface-cookie*)))
 216       ((inline notinline maybe-inline)
 217        (dolist (name args)
 218          (proclaim-as-function-name name)
 219          (setf (info :function :inlinep name)
 220                (case kind
 221                  (inline :inline)
 222                  (notinline :notinline)
 223                  (maybe-inline :maybe-inline)))))
 224       (constant-function
 225        (let ((info (make-function-info
 226                     :attributes (ir1-attributes movable foldable flushable
 227                                                 unsafe))))
 228          (dolist (name args)
 229            (proclaim-as-function-name name)
 230            (setf (info :function :info name) info))))
 231       (declaration
 232        (dolist (decl args)
 233          (unless (symbolp decl)
 234            (error "The declaration to be recognized is not a symbol: ~S" decl))
 235          (setf (info :declaration :recognized decl) t)))
 236       (t
 237        (cond ((member kind *standard-type-names*)
 238               (sb!xc:proclaim `(type . ,form))) ; FIXME: ,@ instead of . ,
 239              ((not (info :declaration :recognized kind))
 240               (warn "unrecognized proclamation: ~S" form))))))
 241   (values))
 242
 243 ;;; Keep the compiler from issuing warnings about SB!C::%%DEFMACRO
 244 ;;; when it compiles code which expands into calls to the function
 245 ;;; before it's actually compiled the function.
 246 ;;;
 247 ;;; (This can't be done in defmacro.lisp because PROCLAIM isn't
 248 ;;; defined when defmacro.lisp is loaded.)
 249 #+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defmacro))