From: Nikodemus Siivola Date: Wed, 14 Jan 2009 18:37:20 +0000 (+0000) Subject: 1.0.24.42: fix bug 235a X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7c406887c08477181e869b1b98142d99b52990ac;p=sbcl.git 1.0.24.42: fix bug 235a AKA https://bugs.launchpad.net/sbcl/+bug/309141 * Replace DEFINED-FUN-FUNCTIONAL with DEFINED-FUN-FUNCTIONALS, and reuse the functional only if policy matches. --- diff --git a/BUGS b/BUGS index a032032..0c6e139 100644 --- a/BUGS +++ b/BUGS @@ -597,25 +597,6 @@ WORKAROUND: This is probably the same bug as 162 -235: "type system and inline expansion" - a. - (declaim (ftype (function (cons) number) acc)) - (declaim (inline acc)) - (defun acc (c) - (the number (car c))) - - (defun foo (x y) - (values (locally (declare (optimize (safety 0))) - (acc x)) - (locally (declare (optimize (safety 3))) - (acc y)))) - - (foo '(nil) '(t)) => NIL, T. - - As of 0.9.15.41 this seems to be due to ACC being inlined only once - inside FOO, which results in the second call reusing the FUNCTIONAL - resulting from the first -- which doesn't check the type. - 237: "Environment arguments to type functions" a. Functions SUBTYPEP, TYPEP, UPGRADED-ARRAY-ELEMENT-TYPE, and UPGRADED-COMPLEX-PART-TYPE now have an optional environment diff --git a/NEWS b/NEWS index 0c86bf1..1631dc2 100644 --- a/NEWS +++ b/NEWS @@ -24,6 +24,8 @@ changes in sbcl-1.0.25 relative to 1.0.24: computes the right offset for the memory copy. * bug fix: compilation problem involving inlined calls to aliens with result type VOID. (reported by Ken Olum) + * bug fix: #235a; sequential inline expasion in different policies no + longer reuses the functional from the previous expansion site. changes in sbcl-1.0.24 relative to 1.0.23: * new feature: ARRAY-STORAGE-VECTOR provides access to the underlying data diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index a5a8969..d1d9e68 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -879,9 +879,9 @@ leaf inlinep (info :function :info name)))) - ;; allow backward references to this function from - ;; following top level forms - (setf (defined-fun-functional leaf) res) + ;; Allow backward references to this function from following + ;; forms. (Reused only if policy matches.) + (push res (defined-fun-functionals leaf)) (change-ref-leaf ref res)))) (let ((fun (defined-fun-functional leaf))) (if (or (not fun) @@ -892,7 +892,8 @@ (with-ir1-environment-from-node call (frob) (locall-analyze-component *current-component*))) - ;; If we've already converted, change ref to the converted functional. + ;; If we've already converted, change ref to the converted + ;; functional. (change-ref-leaf ref fun)))) (values (ref-leaf ref) nil)) (t diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 5bb387b..b107a41 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -1016,7 +1016,7 @@ :maybe-add-debug-catch t :source-name name))) (assert-global-function-definition-type name res) - (setf (defined-fun-functional defined-fun-res) res) + (push res (defined-fun-functionals defined-fun-res)) (unless (eq (defined-fun-inlinep defined-fun-res) :notinline) (substitute-leaf-if (lambda (ref) @@ -1088,7 +1088,7 @@ (setf (gethash name *free-funs*) res))) ;; If *FREE-FUNS* has a previously converted definition ;; for this name, then blow it away and try again. - ((defined-fun-functional found) + ((defined-fun-functionals found) (remhash name *free-funs*) (get-defined-fun name)) (t found)))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ca8904d..0839501 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -132,48 +132,51 @@ *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 @@ -184,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 @@ -1257,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)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index d23bc01..9259405 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1141,6 +1141,14 @@ (eq (defined-fun-functional defined-fun) fun)) (remhash name *free-funs*)))))) +;;; Return functional for DEFINED-FUN which has been converted in policy +;;; corresponding to the current one, or NIL if no such functional exists. +(defun defined-fun-functional (defined-fun) + (let ((policy (lexenv-%policy *lexenv*))) + (dolist (functional (defined-fun-functionals defined-fun)) + (when (equal policy (lexenv-%policy (functional-lexenv functional))) + (return functional))))) + ;;; Do stuff to delete the semantic attachments of a REF node. When ;;; this leaves zero or one reference, we do a type dispatch off of ;;; the leaf to determine if a special action is appropriate. diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index ed0676e..3554d01 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -711,16 +711,16 @@ ;; global environment. (inlinep nil :type inlinep) (inline-expansion nil :type (or cons null)) - ;; the block-local definition of this function (either because it - ;; was semi-inline, or because it was defined in this block). If - ;; this function is not an entry point, then this may be deleted or - ;; LET-converted. Null if we haven't converted the expansion yet. - (functional nil :type (or functional null))) + ;; List of functionals corresponding to this DEFINED-FUN: either from the + ;; conversion of a NAMED-LAMBDA, or from inline-expansion (see + ;; RECOGNIZE-KNOWN-CALL) - we need separate functionals for each policy in + ;; which the function is used. + (functionals nil :type list)) (defprinter (defined-fun :identity t) %source-name #!+sb-show id inlinep - (functional :test functional)) + (functionals :test functionals)) ;;;; function stuff @@ -1163,7 +1163,7 @@ (%source-name (missing-arg) :type symbol :read-only t)) (defprinter (ref :identity t) #!+sb-show id - %source-name + (%source-name :test (neq %source-name '.anonymous.)) leaf) ;;; Naturally, the IF node always appears at the end of a block. diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index d5fe59d..37ba0a7 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -89,6 +89,11 @@ EXPERIMENTAL INTERFACE: Subject to change." (declaim (type policy *policy*)) (defvar *policy*) ; initialized in cold init +(defun sort-policy (policy) + ;; We occasionally want to compare policies using EQL, hence we + ;; canonize the order. + (sort policy #'string< :key #'car)) + ;;; This is to be called early in cold init to set things up, and may ;;; also be called again later in cold init in order to reset default ;;; optimization policy back to default values after toplevel PROCLAIM @@ -111,12 +116,12 @@ EXPERIMENTAL INTERFACE: Subject to change." ;; Perhaps INHIBIT-NOTES? inhibit-warnings)) (setf *policy* - (mapcar (lambda (name) - ;; CMU CL didn't use 1 as the default for - ;; everything, but since ANSI says 1 is the ordinary - ;; value, we do. - (cons name 1)) - *policy-qualities*)) + (sort-policy (mapcar (lambda (name) + ;; CMU CL didn't use 1 as the default for + ;; everything, but since ANSI says 1 is the ordinary + ;; value, we do. + (cons name 1)) + *policy-qualities*))) (setf *policy-restrictions* nil) ;; not actually POLICY, but very similar (setf *handled-conditions* nil diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 2f36e28..7ebf666 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -67,7 +67,7 @@ (unless (assq (car old-entry) result) (push old-entry result))) ;; Voila. - result)) + (sort-policy result))) (declaim (ftype (function (list list) list) process-handle-conditions-decl)) @@ -254,7 +254,8 @@ (process-package-lock-decl form *disabled-package-locks*))) ((inline notinline maybe-inline) (dolist (name args) - (proclaim-as-fun-name name) ; since implicitly it is a function + ; since implicitly it is a function, also scrubs *FREE-FUNS* + (proclaim-as-fun-name name) (setf (info :function :inlinep name) (ecase kind (inline :inline) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 3a2ce24..c15216a 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1035,6 +1035,26 @@ (flet ((i (x) (frob x (bug-405-foo-bar foo)))) (i :five)))))) +;;; bug 235a +(declaim (ftype (function (cons) number) bug-235a-aux)) +(declaim (inline bug-235a-aux)) +(defun bug-235a-aux (c) + (the number (car c))) +(with-test (:name :bug-235a) + (let ((fun (compile nil + `(lambda (x y) + (values (locally (declare (optimize (safety 0))) + (bug-235a-aux x)) + (locally (declare (optimize (safety 3))) + (bug-235a-aux y))))))) + (assert + (eq :error + (handler-case + (funcall fun '(:one) '(:two)) + (type-error (e) + (assert (eq :two (type-error-datum e))) + (assert (eq 'number (type-error-expected-type e))) + :error)))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/version.lisp-expr b/version.lisp-expr index 9b55977..e19dfb1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.24.41" +"1.0.24.42"