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