X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1tran.lisp;h=083950175dad79781698008b176b5a2fb9ded55e;hb=7c406887c08477181e869b1b98142d99b52990ac;hp=e78d86b14f96692e5484cf7e59b9aeff76954f7f;hpb=6822034325136cde4e14773c83c3769b42721306;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index e78d86b..0839501 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -87,6 +87,12 @@ (eq (defined-fun-inlinep fun) :notinline) (eq (info :function :inlinep name) :notinline)))) +;; This will get redefined in PCL boot. +(declaim (notinline update-info-for-gf)) +(defun maybe-update-info-for-gf (name) + (declare (ignorable name)) + (values)) + ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. (defun find-global-fun (name latep) @@ -110,61 +116,67 @@ (make-global-var :kind :global-function :%source-name name - :type (if (and (not latep) - (or *derive-function-types* - (eq where :declared) - (and (member name *fun-names-in-this-file* - :test #'equal) - (not (fun-lexically-notinline-p name))))) - (info :function :type name) + :type (if (or (eq where :declared) + (and (not latep) + (or *derive-function-types* + (eq where :defined-method) + (and (not (fun-lexically-notinline-p name)) + (member name *fun-names-in-this-file* + :test #'equal))))) + (progn + (maybe-update-info-for-gf name) + (info :function :type name)) (specifier-type 'function)) :defined-type (if (eq where :defined) (info :function :type name) *universal-type*) :where-from where))) -;;; Has the *FREE-FUNS* entry FREE-FUN become invalid? +;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid? +;;; Drop 'em. ;;; -;;; In CMU CL, the answer was implicitly always true, so this -;;; predicate didn't exist. -;;; -;;; This predicate was added to fix bug 138 in SBCL. In some obscure -;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a -;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1 -;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka -;;; "dead") component. When this IR1 stuff was reused in a new -;;; component, under further obscure circumstances it could be used by +;;; This was added to fix bug 138 in SBCL. It is possible for a *FREE-FUNS* +;;; entry to contain a DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object +;;; contained IR1 stuff (NODEs, BLOCKs...) referring to an already compiled +;;; (aka "dead") component. When this IR1 stuff was reused in a new component, +;;; under further obscure circumstances it could be used by ;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for -;;; *CURRENT-COMPONENT*. At that point things got all confused, since -;;; IR1 conversion was sending code to a component which had already -;;; been compiled and would never be compiled again. -(defun invalid-free-fun-p (free-fun) +;;; *CURRENT-COMPONENT*. At that point things got all confused, since IR1 +;;; conversion was sending code to a component which had already been compiled +;;; and would never be compiled again. +;;; +;;; Note: as of 1.0.24.41 this seems to happen only in XC, and the original +;;; BUGS entry also makes it seem like this might not be an issue at all on +;;; target. +(defun clear-invalid-functionals (free-fun) ;; There might be other reasons that *FREE-FUN* entries could ;; become invalid, but the only one we've been bitten by so far ;; (sbcl-0.pre7.118) is this one: - (and (defined-fun-p free-fun) - (let ((functional (defined-fun-functional free-fun))) - (or (and functional - (eql (functional-kind functional) :deleted)) - (and (lambda-p functional) - (or - ;; (The main reason for this first test is to bail - ;; out early in cases where the LAMBDA-COMPONENT - ;; call in the second test would fail because links - ;; it needs are uninitialized or invalid.) - ;; - ;; If the BIND node for this LAMBDA is null, then - ;; according to the slot comments, the LAMBDA has - ;; been deleted or its call has been deleted. In - ;; that case, it seems rather questionable to reuse - ;; it, and certainly it shouldn't be necessary to - ;; reuse it, so we cheerfully declare it invalid. - (null (lambda-bind functional)) - ;; If this IR1 stuff belongs to a dead component, - ;; then we can't reuse it without getting into - ;; bizarre confusion. - (eql (component-info (lambda-component functional)) - :dead))))))) + (when (defined-fun-p free-fun) + (setf (defined-fun-functionals free-fun) + (delete-if (lambda (functional) + (or (eq (functional-kind functional) :deleted) + (when (lambda-p functional) + (or + ;; (The main reason for this first test is to bail + ;; out early in cases where the LAMBDA-COMPONENT + ;; call in the second test would fail because links + ;; it needs are uninitialized or invalid.) + ;; + ;; If the BIND node for this LAMBDA is null, then + ;; according to the slot comments, the LAMBDA has + ;; been deleted or its call has been deleted. In + ;; that case, it seems rather questionable to reuse + ;; it, and certainly it shouldn't be necessary to + ;; reuse it, so we cheerfully declare it invalid. + (not (lambda-bind functional)) + ;; If this IR1 stuff belongs to a dead component, + ;; then we can't reuse it without getting into + ;; bizarre confusion. + (eq (component-info (lambda-component functional)) + :dead))))) + (defined-fun-functionals free-fun))) + nil)) ;;; If NAME already has a valid entry in *FREE-FUNS*, then return ;;; the value. Otherwise, make a new GLOBAL-VAR using information from @@ -175,8 +187,9 @@ (declaim (ftype (sfunction (t string) global-var) find-free-fun)) (defun find-free-fun (name context) (or (let ((old-free-fun (gethash name *free-funs*))) - (and (not (invalid-free-fun-p old-free-fun)) - old-free-fun)) + (when old-free-fun + (clear-invalid-functionals old-free-fun) + old-free-fun)) (ecase (info :function :kind name) ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged. (:macro @@ -1138,7 +1151,9 @@ (type-specifier old-type) (type-specifier type) var-name)))) - (bound-var (setf (leaf-type bound-var) int)) + (bound-var + (setf (leaf-type bound-var) int + (leaf-where-from bound-var) :declared)) (t (restr (cons var int))))))) (process-var var bound-var) @@ -1246,8 +1261,8 @@ (when (defined-fun-p var) (setf (defined-fun-inline-expansion res) (defined-fun-inline-expansion var)) - (setf (defined-fun-functional res) - (defined-fun-functional var))) + (setf (defined-fun-functionals res) + (defined-fun-functionals var))) ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL ;; to the original global-var? res))