From: Nikodemus Siivola Date: Sat, 18 Jul 2009 16:58:37 +0000 (+0000) Subject: 1.0.30.1: correct nested DX handling X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b3c5951a9d24468a2a471fd6769d0e6b687c08f3;p=sbcl.git 1.0.30.1: correct nested DX handling * RECHECK-DYNAMIC-EXTENT-LVARS must deal with nested lvars as well: LVAR-GOOD-FOR-DX-P may return true because a nested call is actually good for DX, not because the lvar itself _is_ automatically DX. So, if the compiler has rearranged things a bit, we RECHECK-DYNAMIC-EXTENT-LVARS may believe that something is DX without the LVAR of the actual value producer being marked as such: compiler confusion and miscompilation follows. (And no stack-allocation failure note even though the value is actually heap allocated.) Fixing this is just a matter of using HANDLE-NESTED-DYNAMIC-EXTENT-LVARS in during the rechecking as well. * ...however, doing _that_ also makes us stack allocate values from non-DX single-use variables substituted into DX expressions (the "otherwise inaccessible" vs "otherwise inaccessed" distinction) -- which is not good, so disable single-use variable substitution when the target is DX unless the source is as well. One ASSERT-NO-CONSING test case needs to be removed because of this: (let* ((a (list 1 2 3)) (b (the list a))) (declare (dynamic-extent b)) ...) should not stack allocate A! * It's not all whack-a-mole: this takes care of many previous cases where the compiler refused to stack allocate in the presence of non-trivial nested inline expansions, _and_ allows us the get rid of MAYBE-PROPAGATE-DYNAMIC-EXTENT, since the recheck pass now catches all the cases that was needed for. --- diff --git a/NEWS b/NEWS index ddc4f4e..5085627 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,16 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes relative to sbcl-1.0.30: + * improvement: stack allocation is should now be possible in all nested + inlining cases: failure to stack allocate when equivalent code is manually + open coded is now considered a bug. + * bug fix: moderately complex combinations of inline expansions could + be miscompiled if the result was declared to be dynamic extent. + * bug fix: in some cases no compiler note about failure to stack allocate + was emitted, even if the objects were in fact heap allocated. + * bug fix: minor violation of "otherwise inaccessible" rule for stack + allocation could cause objects users might reasonably expect to + be heap allocated to be stack allocated. + changes in sbcl-1.0.30 relative to sbcl-1.0.29: * minor incompatible change: SB-THREAD:JOIN-THREAD-ERROR-THREAD and SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD have been deprecated in favor diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index b26cb65..62f019a 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1277,7 +1277,6 @@ (ref (lvar-use (combination-fun call)))) (change-ref-leaf ref new-fun) (setf (combination-kind call) :full) - (maybe-propagate-dynamic-extent call new-fun) (locall-analyze-component *current-component*)))) (values)) @@ -1549,13 +1548,19 @@ (declare (type lvar arg) (type lambda-var var)) (binding* ((ref (first (leaf-refs var))) (lvar (node-lvar ref) :exit-if-null) - (dest (lvar-dest lvar))) + (dest (lvar-dest lvar)) + (dest-lvar (when (valued-node-p dest) (node-lvar dest)))) (when (and ;; Think about (LET ((A ...)) (IF ... A ...)): two ;; LVAR-USEs should not be met on one path. Another problem ;; is with dynamic-extent. (eq (lvar-uses lvar) ref) (not (block-delete-p (node-block ref))) + ;; If the destinatation is dynamic extent, don't substitute unless + ;; the source is as well. + (or (not dest-lvar) + (not (lvar-dynamic-extent dest-lvar)) + (lvar-dynamic-extent lvar)) (typecase dest ;; we should not change lifetime of unknown values lvars (cast diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 046c7bf..1e0d6ed 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -444,6 +444,8 @@ (ir1-attributep attr unsafely-flushable))) t))))) +;;;; DYNAMIC-EXTENT related + (defun note-no-stack-allocation (lvar &key flush) (do-uses (use (principal-lvar lvar)) (unless (or @@ -455,7 +457,6 @@ (compiler-notify "could not stack allocate the result of ~S" (find-original-source (node-source-path use))))))) - (declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component)) boolean) use-good-for-dx-p)) (declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component)) @@ -566,6 +567,43 @@ when (eq var this) return arg))))) +;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends. +(defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component) + (let ((uses (lvar-uses lvar))) + ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS. + ;; Uses of mupltiple-use LVARs already end their blocks, so we just need + ;; to process uses of single-use LVARs. + (when (node-p uses) + (node-ends-block uses)) + ;; If this LVAR's USE is good for DX, it is either a CAST, or it + ;; must be a regular combination whose arguments are potentially DX as well. + (flet ((recurse (use) + (etypecase use + (cast + (handle-nested-dynamic-extent-lvars + dx (cast-value use) recheck-component)) + (combination + (loop for arg in (combination-args use) + ;; deleted args show up as NIL here + when (and arg + (lvar-good-for-dx-p arg dx recheck-component)) + append (handle-nested-dynamic-extent-lvars + dx arg recheck-component))) + (ref + (let* ((other (trivial-lambda-var-ref-lvar use))) + (unless (eq other lvar) + (handle-nested-dynamic-extent-lvars + dx other recheck-component))))))) + (cons (cons dx lvar) + (if (listp uses) + (loop for use in uses + when (use-good-for-dx-p use dx recheck-component) + nconc (recurse use)) + (when (use-good-for-dx-p uses dx recheck-component) + (recurse uses))))))) + +;;;;; BLOCK UTILS + (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) (or (block-delete-p block) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index ed3e34f..b274db3 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -43,36 +43,6 @@ (setf (car args) nil))) (values)) -(defun handle-nested-dynamic-extent-lvars (dx lvar) - (let ((uses (lvar-uses lvar))) - ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS. - ;; Uses of mupltiple-use LVARs already end their blocks, so we just need - ;; to process uses of single-use LVARs. - (when (node-p uses) - (node-ends-block uses)) - ;; If this LVAR's USE is good for DX, it is either a CAST, or it - ;; must be a regular combination whose arguments are potentially DX as well. - (flet ((recurse (use) - (etypecase use - (cast - (handle-nested-dynamic-extent-lvars dx (cast-value use))) - (combination - (loop for arg in (combination-args use) - ;; deleted args show up as NIL here - when (and arg (lvar-good-for-dx-p arg dx)) - append (handle-nested-dynamic-extent-lvars dx arg))) - (ref - (let* ((other (trivial-lambda-var-ref-lvar use))) - (unless (eq other lvar) - (handle-nested-dynamic-extent-lvars dx other))))))) - (cons (cons dx lvar) - (if (listp uses) - (loop for use in uses - when (use-good-for-dx-p use dx) - nconc (recurse use)) - (when (use-good-for-dx-p uses dx) - (recurse uses))))))) - (defun recognize-dynamic-extent-lvars (call fun) (declare (type combination call) (type clambda fun)) (loop for arg in (basic-combination-args call) @@ -99,37 +69,6 @@ (setf (lvar-dynamic-extent (cdr cell)) cleanup))))) (values)) -;;; Called after a transform has been applied to CALL: if the call has a DX -;;; result, propagate the DXness to the new functional as well. -;;; -;;; This is needed in case an earlier call to LOCALL-ANALYZE-COMPONENT -;;; collected DX information before the transformation, in which case a later -;;; call to LOCALL-ANALYZE-COMPONENT would not pick up the DX declaration -;;; again, since the call has already been converted. (In other words, work -;;; around the fact that optimization iterates, and locall analysis may have -;;; already run by the time we are able to transform something.) -(defun maybe-propagate-dynamic-extent (call fun) - (when (lambda-p fun) - (let* ((lvar (combination-lvar call)) - (cleanup (or (and lvar (lvar-dynamic-extent lvar)) - (return-from maybe-propagate-dynamic-extent))) - (ret (lambda-return fun)) - (res (if ret - (return-result ret) - (return-from maybe-propagate-dynamic-extent))) - (dx (car (rassoc lvar (cleanup-info cleanup) :test #'eq))) - (new-dx-lvars (if (and dx res) - (handle-nested-dynamic-extent-lvars dx res) - (return-from maybe-propagate-dynamic-extent)))) - (when new-dx-lvars - ;; This builds on what RECOGNIZE-DYNAMIC-EXTENT-LVARS does above. - (aver (eq call (block-last (node-block call)))) - (dolist (cell new-dx-lvars) - (let ((lvar (cdr cell))) - (aver (not (lvar-dynamic-extent lvar))) - (push cell (cleanup-info cleanup)) - (setf (lvar-dynamic-extent (cdr cell)) cleanup))))))) - ;;; This function handles merging the tail sets if CALL is potentially ;;; tail-recursive, and is a call to a function with a different ;;; TAIL-SET than CALL's FUN. This must be called whenever we alter diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index ec527cf..2c6d8f6 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -334,11 +334,17 @@ (loop for what in (cleanup-info cleanup) do (etypecase what (cons - (let ((lvar (cdr what))) - (cond ((lvar-good-for-dx-p lvar (car what) component) - (let ((real (principal-lvar lvar))) - (setf (lvar-dynamic-extent real) cleanup) - (real-dx-lvars real))) + (let ((dx (car what)) + (lvar (cdr what))) + (cond ((lvar-good-for-dx-p lvar dx component) + ;; Since the above check does deep + ;; checks. we need to deal with the deep + ;; results in here as well. + (dolist (cell (handle-nested-dynamic-extent-lvars + dx lvar component)) + (let ((real (principal-lvar (cdr cell)))) + (setf (lvar-dynamic-extent real) cleanup) + (real-dx-lvars real)))) (t (note-no-stack-allocation lvar) (setf (lvar-dynamic-extent lvar) nil))))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 4c1bf57..769ce5d 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -513,7 +513,6 @@ (assert-no-consing (dxlength)) (assert-no-consing (dxcaller 1 2 3 4 5 6 7)) (assert-no-consing (test-nip-values)) - (assert-no-consing (test-let-var-subst1 17)) (assert-no-consing (test-let-var-subst2 17)) (assert-no-consing (test-lvar-subst 11)) (assert-no-consing (nested-dx-lists)) @@ -597,13 +596,26 @@ (assert-no-consing (bdowning-2005-iv-16)) (bdowning-2005-iv-16)) +(declaim (inline my-nconc)) +(defun-with-dx my-nconc (&rest lists) + (declare (dynamic-extent lists)) + (apply #'nconc lists)) +(defun-with-dx my-nconc-caller (a b c) + (let ((l1 (list a b c)) + (l2 (list a b c))) + (my-nconc l1 l2))) +(with-test (:name :rest-stops-the-buck) + (let ((list1 (my-nconc-caller 1 2 3)) + (list2 (my-nconc-caller 9 8 7))) + (assert (equal list1 '(1 2 3 1 2 3))) + (assert (equal list2 '(9 8 7 9 8 7))))) + (defun-with-dx let-converted-vars-dx-allocated-bug (x y z) (let* ((a (list x y z)) (b (list x y z)) (c (list a b))) (declare (dynamic-extent c)) (values (first c) (second c)))) - (with-test (:name :let-converted-vars-dx-allocated-bug) (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3) (assert (and (equal i j) @@ -796,4 +808,26 @@ (setf sp (sb-c::%primitive sb-c:current-stack-pointer)))))) (with-test (:name :handler-case-eating-stack) (assert-no-consing (handler-case-eating-stack))) + +;;; A nasty bug where RECHECK-DYNAMIC-EXTENT-LVARS thought something was going +;;; to be stack allocated when it was not, leading to a bogus %NIP-VALUES. +;;; Fixed by making RECHECK-DYNAMIC-EXTENT-LVARS deal properly with nested DX. +(deftype vec () + `(simple-array single-float (3))) +(declaim (ftype (function (t t t) vec) vec)) +(declaim (inline vec)) +(defun vec (a b c) + (make-array 3 :element-type 'single-float :initial-contents (list a b c))) +(defun bad-boy (vec) + (declare (type vec vec)) + (lambda (fun) + (let ((vec (vec (aref vec 0) (aref vec 1) (aref vec 2)))) + (declare (dynamic-extent vec)) + (funcall fun vec)))) +(with-test (:name :recheck-nested-dx-bug) + (assert (funcall (bad-boy (vec 1.0 2.0 3.3)) + (lambda (vec) (equalp vec (vec 1.0 2.0 3.3))))) + (flet ((foo (x) (declare (ignore x)))) + (let ((bad-boy (bad-boy (vec 2.0 3.0 4.0)))) + (assert-no-consing (funcall bad-boy #'foo))))) diff --git a/version.lisp-expr b/version.lisp-expr index 2cf0ad8..66b8672 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.30" +"1.0.30.1"