;;;; -*- 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
(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))
(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
(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
(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))
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)
(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)
(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
(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)))))
(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))
(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)
(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)))))
\f
;;; 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"
projects / sbcl.git / commitdiff