X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=1609080cc615f3e8e0a05ac1fc4a15c81b076223;hb=b956ed4f9cef685d1b49be28dcd2aec1e082d994;hp=3bedcb539461ecb03f5a6d8c08e98d7739e76804;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 3bedcb5..1609080 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -19,7 +19,7 @@ (defvar *undefined-warnings*) (declaim (list *undefined-warnings*)) -;;; 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)) @@ -28,7 +28,7 @@ (dolist (name names (vars)) (unless (symbolp name) (compiler-error "The name ~S is not a symbol." name)) - (let ((old (gethash name *free-variables*))) + (let ((old (gethash name *free-vars*))) (when old (vars old)))))) ;;; Return a new POLICY containing the policy information represented @@ -45,14 +45,14 @@ (destructuring-bind (quality raw-value) q-and-v-or-just-q (values quality raw-value))) (cond ((not (policy-quality-name-p quality)) - (compiler-warning "ignoring unknown optimization quality ~ - ~S in ~S" - quality spec)) - ((not (and (typep raw-value 'real) (<= 0 raw-value 3))) - (compiler-warning "ignoring bad optimization value ~S in ~S" - raw-value spec)) + (compiler-warn "ignoring unknown optimization quality ~ + ~S in ~S" + quality spec)) + ((not (typep raw-value 'policy-quality)) + (compiler-warn "ignoring bad optimization value ~S in ~S" + raw-value spec)) (t - (push (cons quality (rational raw-value)) + (push (cons quality raw-value) result))))) ;; Add any nonredundant entries from old POLICY. (dolist (old-entry policy) @@ -80,7 +80,13 @@ (t decl-spec))))) +(!begin-collecting-cold-init-forms) +(!cold-init-forms (defvar *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))) @@ -94,90 +100,65 @@ (clear-info :variable :constant-value name) (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)) + (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))) + (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)) - - ;; 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 - #| - (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))))) - |# + (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)) + (when (eq (info :function :where-from name) :declared) + (let ((old-type (info :function :type name))) + (when (type/= ctype old-type) + (style-warn + "new FTYPE proclamation~@ + ~S~@ + for ~S does not match old FTYPE proclamation~@ + ~S" + ctype 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. (But if this - ;; function name was already declared as a structure - ;; accessor, then that was already been taken care of.) - (unless (info :function :accessor-for name) - (proclaim-as-function-name name) - (note-name-defined name :function)) + ;; 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) - ;; the actual type declaration - (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 'sb!xc:class) - (setf (class-state class) :sealed) - (let ((subclasses (class-subclasses class))) + (when (typep class 'classoid) + (setf (classoid-state class) :sealed) + (let ((subclasses (classoid-subclasses class))) (when subclasses (dohash (subclass layout subclasses) (declare (ignore layout)) - (setf (class-state subclass) :sealed)))))))) + (setf (classoid-state subclass) :sealed)))))))) (optimize (setq *policy* (process-optimize-decl form *policy*))) ((inline notinline maybe-inline) (dolist (name args) - ;; (CMU CL did (PROCLAIM-AS-FUNCTION-NAME NAME) here, but that - ;; seems more likely to surprise the user than to help him, so - ;; we don't do it.) + (proclaim-as-fun-name name) ; since implicitly it is a function (setf (info :function :inlinep name) (ecase kind (inline :inline) @@ -192,5 +173,6 @@ (setf (info :declaration :recognized decl) t))) (t (unless (info :declaration :recognized kind) - (compiler-warning "unrecognized declaration ~S" raw-form))))) + (compiler-warn "unrecognized declaration ~S" raw-form))))) + #+sb-xc (/show0 "returning from PROCLAIM") (values))