X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=4b3519103a5ac36a7dd339e6dfc107d05a6ddf70;hb=e27303999070c06c788a0e1359ee4b0900186aa1;hp=6232e725d94486d3cb65b075c6141650fc61341f;hpb=f1bd97fb5f536b9ac7195aaa20bf02c829793f6a;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 6232e72..4b35191 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -14,36 +14,15 @@ (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. +;;; 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 @@ -59,12 +38,12 @@ (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. +;;; This is 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) @@ -87,44 +66,59 @@ (let ((old (gethash name *free-variables*))) (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)) + (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)) + (t + (push (cons quality (rational 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. + result)) + +;;; 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))) + (unless (symbolp id) + (error "The declaration identifier is not a symbol: ~S" id)) + (let ((id-is-type (info :type :kind id)) + (id-is-declared-decl (info :declaration :recognized id))) + (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))))) -(defun sb!xc:proclaim (form) - (unless (consp form) - (error "malformed PROCLAIM spec: ~S" form)) - (let ((kind (first form)) - (args (rest form))) +(defun sb!xc:proclaim (raw-form) + (let* ((form (canonized-decl-spec raw-form)) + (kind (first form)) + (args (rest form))) (case kind (special (dolist (name args) @@ -202,11 +196,12 @@ (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))))) + (style-warn + "new FTYPE proclamation~@ + ~S~@ + for ~S does not match old FTYPE proclamation~@ + ~S" + (list type name old-type))))) (proclaim-as-function-name name) (note-name-defined name :function) @@ -215,7 +210,7 @@ (freeze-type (dolist (type args) (let ((class (specifier-type type))) - (when (typep class 'class) + (when (typep class 'sb!xc:class) (setf (class-state class) :sealed) (let ((subclasses (class-subclasses class))) (when subclasses @@ -223,42 +218,25 @@ (declare (ignore layout)) (setf (class-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*))) ((inline notinline maybe-inline) (dolist (name args) - (proclaim-as-function-name name) + ;; (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.) (setf (info :function :inlinep name) - (case kind + (ecase 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)))) (declaration (dolist (decl args) (unless (symbolp decl) - (error "The declaration to be recognized is not a symbol: ~S" decl)) + (error "In~% ~S~%the declaration to be recognized is not a ~ + symbol:~% ~S" + form decl)) (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-warning "unrecognized declaration ~S" raw-form))))) (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))