X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=7ebf66646ab4284078cfdfe09d79cdbc74794caa;hb=7c406887c08477181e869b1b98142d99b52990ac;hp=7dcfa27b49754c89988be5b2a268a5ae02aafc8e;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 7dcfa27..7ebf666 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -14,68 +14,12 @@ (in-package "SB!C") -;;; !COLD-INIT calls this twice to initialize the cookies, once before -;;; any toplevel forms are executed, then again to undo any lingering -;;; effects of toplevel DECLAIMs. -(!begin-collecting-cold-init-forms) -(!cold-init-forms - (setf *default-cookie* - (make-cookie :safety 1 - :speed 1 - :space 1 - :cspeed 1 - :brevity 1 - ;; Note: CMU CL had a default of 2 for DEBUG and 1 for all - ;; the other qualities. SBCL uses a default of 1 for every - ;; quality, because the ANSI documentation for the - ;; OPTIMIZE declaration says that 1 is "the neutral - ;; value", and it seems natural for the neutral value to - ;; be the default. - :debug 1)) - (setf *default-interface-cookie* - (make-cookie))) -(!defun-from-collected-cold-init-forms !set-sane-cookie-defaults) - ;;; A list of UNDEFINED-WARNING structures representing references to unknown ;;; stuff which came up in a compilation unit. (defvar *undefined-warnings*) (declaim (list *undefined-warnings*)) -;;; Check that Name is a valid function name, returning the name if OK, and -;;; doing an error if not. In addition to checking for basic well-formedness, -;;; we also check that symbol names are not NIL or the name of a special form. -(defun check-function-name (name) - (typecase name - (list - (unless (and (consp name) (consp (cdr name)) - (null (cddr name)) (eq (car name) 'setf) - (symbolp (cadr name))) - (compiler-error "illegal function name: ~S" name)) - name) - (symbol - (when (eq (info :function :kind name) :special-form) - (compiler-error "Special form is an illegal function name: ~S" name)) - name) - (t - (compiler-error "illegal function name: ~S" name)))) - -;;; Called to do something about SETF functions that overlap with SETF -;;; macros. Perhaps we should interact with the user to see whether -;;; the macro should be blown away, but for now just give a warning. -;;; Due to the weak semantics of the (SETF FUNCTION) name, we can't -;;; assume that they aren't just naming a function (SETF FOO) for the -;;; heck of it. NAME is already known to be well-formed. -(defun note-if-setf-function-and-macro (name) - (when (consp name) - (when (or (info :setf :inverse name) - (info :setf :expander name)) - (compiler-style-warning - "defining as a SETF function a name that already has a SETF macro:~ - ~% ~S" - name))) - (values)) - -;;; Look up some symbols in *FREE-VARIABLES*, returning the var +;;; Look up some symbols in *FREE-VARS*, returning the var ;;; structures for any which exist. If any of the names aren't ;;; symbols, we complain. (declaim (ftype (function (list) list) get-old-vars)) @@ -83,166 +27,251 @@ (collect ((vars)) (dolist (name names (vars)) (unless (symbolp name) - (compiler-error "The name ~S is not a symbol." name)) - (let ((old (gethash name *free-variables*))) - (when old (vars old)))))) + (compiler-error "The name ~S is not a symbol." name)) + (let ((old (gethash name *free-vars*))) + (when old (vars old)))))) -;;; Return a new cookie containing the policy information represented +;;; Return a new POLICY containing the policy information represented ;;; by the optimize declaration SPEC. Any parameters not specified are -;;; defaulted from COOKIE. -(declaim (ftype (function (list cookie) cookie) process-optimize-declaration)) -(defun process-optimize-declaration (spec cookie) - (let ((res (copy-cookie cookie))) - (dolist (quality (cdr spec)) - (let ((quality (if (atom quality) (list quality 3) quality))) - (if (and (consp (cdr quality)) (null (cddr quality)) - (typep (second quality) 'real) (<= 0 (second quality) 3)) - (let ((value (rational (second quality)))) - (case (first quality) - (speed (setf (cookie-speed res) value)) - (space (setf (cookie-space res) value)) - (safety (setf (cookie-safety res) value)) - (compilation-speed (setf (cookie-cspeed res) value)) - ;; FIXME: BREVITY is an undocumented name for it, - ;; should go away. And INHIBIT-WARNINGS is a - ;; misleading name for it. Perhaps BREVITY would be - ;; better. But the ideal name would have connotations - ;; of suppressing only optimization-related notes, - ;; which I think is the behavior. Perhaps - ;; INHIBIT-NOTES? - ((inhibit-warnings brevity) (setf (cookie-brevity res) value)) - ((debug-info debug) (setf (cookie-debug res) value)) - (t - (compiler-warning "unknown optimization quality ~S in ~S" - (car quality) spec)))) - (compiler-warning - "malformed optimization quality specifier ~S in ~S" - quality spec)))) - res)) +;;; defaulted from the POLICY argument. +(declaim (ftype (function (list policy) policy) process-optimize-decl)) +(defun process-optimize-decl (spec policy) + (let ((result nil)) + ;; Add new entries from SPEC. + (dolist (q-and-v-or-just-q (cdr spec)) + (multiple-value-bind (quality raw-value) + (if (atom q-and-v-or-just-q) + (values q-and-v-or-just-q 3) + (destructuring-bind (quality raw-value) q-and-v-or-just-q + (values quality raw-value))) + (cond ((not (policy-quality-name-p quality)) + (let ((deprecation-warning (policy-quality-deprecation-warning quality spec))) + (if deprecation-warning + (compiler-warn deprecation-warning) + (compiler-warn "~@" + quality spec)))) + ((not (typep raw-value 'policy-quality)) + (compiler-warn "~@" + raw-value spec)) + (t + ;; we can't do this yet, because CLOS macros expand + ;; into code containing INHIBIT-WARNINGS. + #+nil + (when (eql quality 'sb!ext:inhibit-warnings) + (compiler-style-warn "~S is deprecated: use ~S instead" + quality 'sb!ext:muffle-conditions)) + (push (cons quality raw-value) + result))))) + ;; Add any nonredundant entries from old POLICY. + (dolist (old-entry policy) + (unless (assq (car old-entry) result) + (push old-entry result))) + ;; Voila. + (sort-policy result))) + +(declaim (ftype (function (list list) list) + process-handle-conditions-decl)) +(defun process-handle-conditions-decl (spec list) + (let ((new (copy-alist list))) + (dolist (clause (cdr spec)) + (destructuring-bind (typespec restart-name) clause + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (setf (car ospec) + (type-specifier + (type-union (specifier-type (car ospec)) + (specifier-type typespec)))) + (push (cons (type-specifier (specifier-type typespec)) + restart-name) + new))))) + new)) +(declaim (ftype (function (list list) list) + process-muffle-conditions-decl)) +(defun process-muffle-conditions-decl (spec list) + (process-handle-conditions-decl + (cons 'handle-conditions + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + list)) + +(declaim (ftype (function (list list) list) + process-unhandle-conditions-decl)) +(defun process-unhandle-conditions-decl (spec list) + (let ((new (copy-alist list))) + (dolist (clause (cdr spec)) + (destructuring-bind (typespec restart-name) clause + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (let ((type-specifier + (type-specifier + (type-intersection + (specifier-type (car ospec)) + (specifier-type `(not ,typespec)))))) + (if type-specifier + (setf (car ospec) type-specifier) + (setq new + (delete restart-name new :test #'eq :key #'cdr)))) + ;; do nothing? + nil)))) + new)) +(declaim (ftype (function (list list) list) + process-unmuffle-conditions-decl)) +(defun process-unmuffle-conditions-decl (spec list) + (process-unhandle-conditions-decl + (cons 'unhandle-conditions + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + list)) -(defun sb!xc:proclaim (form) - (unless (consp form) - (error "malformed PROCLAIM spec: ~S" form)) - (let ((kind (first form)) - (args (rest form))) +(declaim (ftype (function (list list) list) + process-package-lock-decl)) +(defun process-package-lock-decl (spec old) + (let ((decl (car spec)) + (list (cdr spec))) + (ecase decl + (disable-package-locks + (union old list :test #'equal)) + (enable-package-locks + (set-difference old list :test #'equal))))) + +;;; ANSI defines the declaration (FOO X Y) to be equivalent to +;;; (TYPE FOO X Y) when FOO is a type specifier. This function +;;; implements that by converting (FOO X Y) to (TYPE FOO X Y). +(defun canonized-decl-spec (decl-spec) + (let ((id (first decl-spec))) + (let ((id-is-type (if (symbolp id) + (info :type :kind id) + ;; A cons might not be a valid type specifier, + ;; but it can't be a declaration either. + (or (consp id) + (typep id 'class)))) + (id-is-declared-decl (info :declaration :recognized id))) + ;; FIXME: Checking ID-IS-DECLARED is probably useless these days, + ;; since we refuse to use the same symbol as both a type name and + ;; recognized declaration name. + (cond ((and id-is-type id-is-declared-decl) + (compiler-error + "ambiguous declaration ~S:~% ~ + ~S was declared as a DECLARATION, but is also a type name." + decl-spec id)) + (id-is-type + (cons 'type decl-spec)) + (t + decl-spec))))) + +(defvar *queued-proclaims*) ; initialized in !COLD-INIT-FORMS + +(!begin-collecting-cold-init-forms) +(!cold-init-forms (setf *queued-proclaims* nil)) +(!defun-from-collected-cold-init-forms !early-proclaim-cold-init) + +(defun sb!xc:proclaim (raw-form) + #+sb-xc (/show0 "entering PROCLAIM, RAW-FORM=..") + #+sb-xc (/hexstr raw-form) + (let* ((form (canonized-decl-spec raw-form)) + (kind (first form)) + (args (rest form))) (case kind (special (dolist (name args) - (unless (symbolp name) - (error "can't declare a non-symbol as SPECIAL: ~S" name)) - (when (constantp name) - (error "can't declare a constant as SPECIAL: ~S" name)) - (clear-info :variable :constant-value name) - (setf (info :variable :kind name) :special))) + (unless (symbolp name) + (error "can't declare a non-symbol as SPECIAL: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A special") + (about-to-modify-symbol-value name "proclaim ~S as SPECIAL") + (setf (info :variable :kind name) :special)))) (type - (when *type-system-initialized* - (let ((type (specifier-type (first args)))) - (dolist (name (rest args)) - (unless (symbolp name) - (error "can't declare TYPE of a non-symbol: ~S" name)) - (when (eq (info :variable :where-from name) :declared) - (let ((old-type (info :variable :type name))) - (when (type/= type old-type) - (style-warn "The new TYPE proclamation~% ~S~@ - for ~S does not match the old TYPE~@ - proclamation ~S" - type name old-type)))) - (setf (info :variable :type name) type) - (setf (info :variable :where-from name) :declared))))) + (if *type-system-initialized* + (let ((type (specifier-type (first args)))) + (dolist (name (rest args)) + (unless (symbolp name) + (error "can't declare TYPE of a non-symbol: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaring the type of ~A")) + (when (eq (info :variable :where-from name) :declared) + (let ((old-type (info :variable :type name))) + (when (type/= type old-type) + ;; FIXME: changing to TYPE-PROCLAMATION-MISMATCH + ;; broke late-proclaim.lisp. + (style-warn "The new TYPE proclamation~% ~S~@ + for ~S does not match the old TYPE~@ + proclamation ~S" + type name old-type)))) + (setf (info :variable :type name) type) + (setf (info :variable :where-from name) :declared))) + (push raw-form *queued-proclaims*))) (ftype - ;; FIXME: Since currently *TYPE-SYSTEM-INITIALIZED* is not set - ;; until many toplevel forms have run, this condition on - ;; PROCLAIM (FTYPE ..) (and on PROCLAIM (TYPE ..), above) means - ;; that valid PROCLAIMs in cold code could get lost. Probably - ;; the cleanest way to deal with this would be to initialize - ;; the type system completely in special cold init forms, - ;; before any ordinary toplevel forms run. Failing that, we - ;; could queue up PROCLAIMs to be done after the type system is - ;; initialized. Failing that, we could at least issue a warning - ;; when we have to ignore a PROCLAIM because the type system is - ;; uninitialized. - (when *type-system-initialized* - (let ((type (specifier-type (first args)))) - (unless (csubtypep type (specifier-type 'function)) - (error "not a function type: ~S" (first args))) - (dolist (name (rest args)) - (cond ((info :function :accessor-for name) - (warn "ignoring FTYPE proclamation for slot accessor:~% ~S" - name)) - (t + (if *type-system-initialized* + (let ((ctype (specifier-type (first args)))) + (unless (csubtypep ctype (specifier-type 'function)) + (error "not a function type: ~S" (first args))) + (dolist (name (rest args)) + (with-single-package-locked-error + (:symbol name "globally declaring the ftype of ~A")) + (when (eq (info :function :where-from name) :declared) + (let ((old-type (info :function :type name))) + (when (type/= ctype old-type) + ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH + ;; broke late-proclaim.lisp. + (style-warn + "new FTYPE proclamation~@ + ~S~@ + for ~S does not match old FTYPE proclamation~@ + ~S" + ctype name old-type)))) - ;; KLUDGE: Something like the commented-out TYPE/= - ;; check here would be nice, but it has been - ;; commented out because TYPE/= doesn't support - ;; function types. It could probably be made to do - ;; so, but it might take some time, since function - ;; types involve values types, which aren't - ;; supported, and since the SUBTYPEP operator for - ;; FUNCTION types is rather broken, e.g. - ;; (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL) - ;; '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T - ;; -- WHN 20000229 - #+nil - (when (eq (info :function :where-from name) :declared) - (let ((old-type (info :function :type name))) - (when (type/= type old-type) - (style-warn "new FTYPE proclamation~@ - ~S~@ - for ~S does not match old FTYPE proclamation~@ - ~S" - (list type name old-type))))) + ;; Now references to this function shouldn't be warned + ;; about as undefined, since even if we haven't seen a + ;; definition yet, we know one is planned. + ;; + ;; Other consequences of we-know-you're-a-function-now + ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. + (proclaim-as-fun-name name) + (note-name-defined name :function) - (proclaim-as-function-name name) - (note-name-defined name :function) - (setf (info :function :type name) type - (info :function :where-from name) :declared))))))) + ;; the actual type declaration + (setf (info :function :type name) ctype + (info :function :where-from name) :declared))) + (push raw-form *queued-proclaims*))) (freeze-type (dolist (type args) - (let ((class (specifier-type type))) - (when (typep class 'class) - (setf (class-state class) :sealed) - (let ((subclasses (class-subclasses class))) - (when subclasses - (dohash (subclass layout subclasses) - (declare (ignore layout)) - (setf (class-state subclass) :sealed)))))))) + (let ((class (specifier-type type))) + (when (typep class 'classoid) + (setf (classoid-state class) :sealed) + (let ((subclasses (classoid-subclasses class))) + (when subclasses + (dohash ((subclass layout) subclasses :locked t) + (declare (ignore layout)) + (setf (classoid-state subclass) :sealed)))))))) (optimize - (setq *default-cookie* - (process-optimize-declaration form *default-cookie*))) - (optimize-interface - (setq *default-interface-cookie* - (process-optimize-declaration form *default-interface-cookie*))) + (setq *policy* (process-optimize-decl form *policy*))) + (muffle-conditions + (setq *handled-conditions* + (process-muffle-conditions-decl form *handled-conditions*))) + (unmuffle-conditions + (setq *handled-conditions* + (process-unmuffle-conditions-decl form *handled-conditions*))) + ((disable-package-locks enable-package-locks) + (setq *disabled-package-locks* + (process-package-lock-decl form *disabled-package-locks*))) ((inline notinline maybe-inline) (dolist (name args) - (proclaim-as-function-name name) - (setf (info :function :inlinep name) - (case kind - (inline :inline) - (notinline :notinline) - (maybe-inline :maybe-inline))))) - (constant-function - (let ((info (make-function-info - :attributes (ir1-attributes movable foldable flushable - unsafe)))) - (dolist (name args) - (proclaim-as-function-name name) - (setf (info :function :info name) info)))) + ; since implicitly it is a function, also scrubs *FREE-FUNS* + (proclaim-as-fun-name name) + (setf (info :function :inlinep name) + (ecase kind + (inline :inline) + (notinline :notinline) + (maybe-inline :maybe-inline))))) (declaration (dolist (decl args) - (unless (symbolp decl) - (error "The declaration to be recognized is not a symbol: ~S" decl)) - (setf (info :declaration :recognized decl) t))) + (unless (symbolp decl) + (error "In~% ~S~%the declaration to be recognized is not a ~ + symbol:~% ~S" + form decl)) + (with-single-package-locked-error + (:symbol decl "globally declaring ~A as a declaration proclamation")) + (setf (info :declaration :recognized decl) t))) (t - (cond ((member kind *standard-type-names*) - (sb!xc:proclaim `(type . ,form))) ; FIXME: ,@ instead of . , - ((not (info :declaration :recognized kind)) - (warn "unrecognized proclamation: ~S" form)))))) + (unless (info :declaration :recognized kind) + (compiler-warn "unrecognized declaration ~S" raw-form))))) + #+sb-xc (/show0 "returning from PROCLAIM") (values)) - -;;; Keep the compiler from issuing warnings about SB!C::%%DEFMACRO -;;; when it compiles code which expands into calls to the function -;;; before it's actually compiled the function. -;;; -;;; (This can't be done in defmacro.lisp because PROCLAIM isn't -;;; defined when defmacro.lisp is loaded.) -#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defmacro))