From: William Harold Newman Date: Tue, 16 Oct 2001 03:12:06 +0000 (+0000) Subject: 0.pre7.67: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=edaebea5b5e6682b36f4067e3b187bd9fb4a5c25;p=sbcl.git 0.pre7.67: cleaned up miscellaneous FTYPE proclamation stuff.. ..I changed my mind: PROCLAIM-AS-FUN-NAME is appropriate in PROCLAIM INLINE and PROCLAIM NOTINLINE after all. ..got rid of separate PROCLAIM-AS-DEFSTRUCT-FUN-NAME in favor of ordinary PROCLAIM FTYPE ..moved remove-from-*FREE-FUNCTIONS* logic from %COMPILER-DEFSTRUCT to PROCLAIM-AS-FUN-NAME ..PROCLAIM-AS-FUN-NAME doesn't need to return NAME. Nor CHECK-FUN-NAME neither. ..When %COMPILER-DEFSTRUCT sets the inline expansions of slot functions, it should proclaim their ftype too. Now that %COMPILER-DEFSTRUCT wants SB!XC:PROCLAIM, I rearranged things to make SB!XC:PROCLAIM available sooner, moving src/compiler/proclaim, and the src/compiler/knownfun that it depends on, earlier in stems-and-flags --- diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 2404a83..00dd740 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -60,7 +60,7 @@ ;; all the explicit :CONSTRUCTOR specs, with name defaulted (constructors () :type list) ;; name of copying function - (copier (symbolicate "COPY-" name) :type (or symbol null)) + (copier-name (symbolicate "COPY-" name) :type (or symbol null)) ;; name of type predicate (predicate-name (symbolicate name "-P") :type (or symbol null)) ;; the arguments to the :INCLUDE option, or NIL if no included @@ -404,9 +404,9 @@ ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT. (defun typed-copier-definitions (defstruct) - (when (dd-copier defstruct) - `((setf (fdefinition ',(dd-copier defstruct)) #'copy-seq) - (declaim (ftype function ,(dd-copier defstruct)))))) + (when (dd-copier-name defstruct) + `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq) + (declaim (ftype function ,(dd-copier-name defstruct)))))) ;;; Return a list of function definitions for accessing and setting the ;;; slots of a typed DEFSTRUCT. The functions are proclaimed to be inline, @@ -461,7 +461,7 @@ (:copier (destructuring-bind (&optional (copier (symbolicate "COPY-" name))) args - (setf (dd-copier dd) copier))) + (setf (dd-copier-name dd) copier))) (:predicate (destructuring-bind (&optional (predicate-name (symbolicate name "-P"))) args @@ -807,9 +807,9 @@ (typep-to-layout object layout)))) |# - (when (dd-copier info) - (protect-cl (dd-copier info)) - (setf (symbol-function (dd-copier info)) + (when (dd-copier-name info) + (protect-cl (dd-copier-name info)) + (setf (symbol-function (dd-copier-name info)) #'(lambda (structure) (declare (optimize (speed 3) (safety 0))) (flet ((layout-test (structure) @@ -911,51 +911,42 @@ (setf (info :type :compiler-layout (dd-name dd)) layout)) - (ecase (dd-type dd) - ((vector list funcallable-structure) - ;; nothing extra to do in this case - ) - ((structure) - (let* ((name (dd-name dd)) - (class (sb!xc:find-class name))) - - (let ((copier (dd-copier dd))) - (when copier - (proclaim `(ftype (function (,name) ,name) ,copier)))) - - (dolist (dsd (dd-slots dd)) - (let* ((accessor-name (dsd-accessor-name dsd))) - (when accessor-name - (multiple-value-bind (reader-designator writer-designator) - (accessor-inline-expansion-designators dd dsd) - (proclaim-as-defstruct-fun-name accessor-name) - (setf (info :function - :inline-expansion-designator - accessor-name) - reader-designator - (info :function :inlinep accessor-name) - :inline) - (unless (dsd-read-only dsd) - (proclaim-as-defstruct-fun-name `(setf ,accessor-name)) - (let ((setf-accessor-name `(setf ,accessor-name))) - (setf (info :function - :inline-expansion-designator - setf-accessor-name) - writer-designator - (info :function :inlinep setf-accessor-name) - :inline))))))) - - ;; FIXME: Couldn't this logic be merged into - ;; PROCLAIM-AS-DEFSTRUCT-FUN-NAME? - (when (boundp 'sb!c:*free-functions*) ; when compiling - (let ((free-functions sb!c:*free-functions*)) - (dolist (slot (dd-slots dd)) - (let ((accessor-name (dsd-accessor-name slot))) - (remhash accessor-name free-functions) - (unless (dsd-read-only slot) - (remhash `(setf ,accessor-name) free-functions)))) - (remhash (dd-predicate-name dd) free-functions) - (remhash (dd-copier dd) free-functions)))))) + (let* ((dd-name (dd-name dd)) + (class (sb!xc:find-class dd-name))) + + (let ((copier-name (dd-copier-name dd))) + (when copier-name + (sb!xc:proclaim `(ftype (function (,dd-name) ,dd-name) ,copier-name)))) + + (let ((predicate-name (dd-predicate-name dd))) + (when predicate-name + (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name)))) + + (dolist (dsd (dd-slots dd)) + (let* ((accessor-name (dsd-accessor-name dsd)) + (dsd-type (dsd-type dsd))) + (when accessor-name + (multiple-value-bind (reader-designator writer-designator) + (accessor-inline-expansion-designators dd dsd) + (sb!xc:proclaim `(ftype (function (,dd-name) ,dsd-type) + ,accessor-name)) + (setf (info :function + :inline-expansion-designator + accessor-name) + reader-designator + (info :function :inlinep accessor-name) + :inline) + (unless (dsd-read-only dsd) + (let ((setf-accessor-name `(setf ,accessor-name))) + (sb!xc:proclaim + `(ftype (function (,dsd-type ,dd-name) ,dsd-type) + ,setf-accessor-name)) + (setf (info :function + :inline-expansion-designator + setf-accessor-name) + writer-designator + (info :function :inlinep setf-accessor-name) + :inline)))))))) (values)) @@ -1104,7 +1095,7 @@ (when (defstruct-description-p info) (let ((type (dd-name info))) (setf (info :type :compiler-layout type) nil) - (undefine-fun-name (dd-copier info)) + (undefine-fun-name (dd-copier-name info)) (undefine-fun-name (dd-predicate-name info)) (dolist (slot (dd-slots info)) (let ((fun (dsd-accessor-name slot))) @@ -1407,21 +1398,6 @@ (res)))) -;;;; compiler stuff - -;;; This is like PROCLAIM-AS-FUN-NAME, but we also set the kind to -;;; :DECLARED and blow away any ASSUMED-TYPE. Also, if the thing is a -;;; slot accessor currently, quietly unaccessorize it. And if there -;;; are any undefined warnings, we nuke them. -(defun proclaim-as-defstruct-fun-name (name) - (when name - (proclaim-as-fun-name name) - (note-name-defined name :function) - (setf (info :function :where-from name) :declared) - (when (info :function :assumed-type name) - (setf (info :function :assumed-type name) nil))) - (values)) - ;;;; finalizing bootstrapping ;;; early structure placeholder definitions: Set up layout and class diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 64bba8d..b74f637 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -33,12 +33,15 @@ (compiler-error "Special form is an illegal function name: ~S" name))) (t (compiler-error "illegal function name: ~S" name))) - name) + (values)) ;;; Record a new function definition, and check its legality. -(declaim (ftype (function ((or symbol cons)) t) proclaim-as-fun-name)) (defun proclaim-as-fun-name (name) + + ;; legal name? (check-fun-name name) + + ;; scrubbing old data I: possible collision with old definition (when (fboundp name) (ecase (info :function :kind name) (:function) ; happy case @@ -47,9 +50,21 @@ (compiler-style-warning "~S was previously defined as a macro." name) (setf (info :function :where-from name) :assumed) (clear-info :function :macro-function name)))) + + ;; scrubbing old data II: dangling forward references + ;; + ;; (This could happen if someone does PROCLAIM FTYPE in macroexpansion, + ;; which is bad style, or at compile time, e.g. in EVAL-WHEN (:COMPILE) + ;; inside something like DEFSTRUCT, in which case it's reasonable style. + ;; Either way, it's no longer a free function.) + (when (boundp '*free-functions*) ; when compiling + (remhash name *free-functions*)) + + ;; recording the ordinary case (setf (info :function :kind name) :function) (note-if-setf-function-and-macro name) - name) + + (values)) ;;; This is called to do something about SETF functions that overlap ;;; with SETF macros. Perhaps we should interact with the user to see diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 8cecb52..ae2acab 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -554,7 +554,8 @@ (when (or (atom def) (< (length def) 2)) (compiler-error "The ~S definition spec ~S is malformed." context def)) - (let ((name (check-fun-name (first def)))) + (let ((name (first def))) + (check-fun-name name) (names name) (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def)) (defs `(lambda ,(second def) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index c36d9e1..690fc9e 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1828,8 +1828,8 @@ ;;; define. If the function has been forward referenced, then ;;; substitute for the previous references. (defun get-defined-fun (name) - (let* ((name (proclaim-as-fun-name name)) - (found (find-free-function name "shouldn't happen! (defined-fun)"))) + (proclaim-as-fun-name name) + (let ((found (find-free-function name "shouldn't happen! (defined-fun)"))) (note-name-defined name :function) (cond ((not (defined-fun-p found)) (aver (not (info :function :inlinep name))) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index faef555..f25b899 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -151,9 +151,10 @@ ;; 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.) + ;; 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) @@ -174,9 +175,7 @@ (setq *policy* (process-optimize-decl form *policy*))) ((inline notinline maybe-inline) (dolist (name args) - ;; (CMU CL did (PROCLAIM-AS-FUN-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) diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 20cd9ee..6abbd77 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -345,23 +345,26 @@ ;; the target version of "code/defstruct". ("src/code/target-defstruct" :not-host) + ;; defines IR1-ATTRIBUTES macro, needed by proclaim.lisp + ("src/compiler/knownfun") + ;; stuff needed by "code/defstruct" ("src/code/cross-type" :not-target) ("src/compiler/generic/vm-type") + ("src/compiler/proclaim") ;; The DEFSTRUCT machinery needs SB!XC:SUBTYPEP, defined in ;; "code/late-type", and SB!XC:TYPEP, defined in "code/cross-type", - ;; and SPECIALIZE-ARRAY-TYPE, defined in "compiler/generic/vm-type". + ;; and SPECIALIZE-ARRAY-TYPE, defined in "compiler/generic/vm-type", + ;; and SB!XC:PROCLAIM, defined in "src/compiler/proclaim" ("src/code/defstruct") ;; ALIEN-VALUE has to be defined as a class (done by DEFSTRUCT ;; machinery) before we can set its superclasses here. ("src/code/alien-type") - ("src/compiler/knownfun") - - ;; needs IR1-ATTRIBUTES macro, defined in knownfun.lisp - ("src/compiler/proclaim") + ;; was here until sbcl-0.pre7.67 + #+nil ("src/compiler/knownfun") ;; This needs not just the SB!XC:DEFSTRUCT machinery, but also ;; the TYPE= stuff defined in late-type.lisp, and the diff --git a/version.lisp-expr b/version.lisp-expr index 534e6c6..217fa19 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.66" +"0.pre7.67"