From 1dd20e25cece8c023b2c751a6553573d00aac7ce Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 8 May 2008 11:52:04 +0000 Subject: [PATCH] 1.0.16.26: dx allocation thru CAST nodes * Allow DX allocation of LVARs thru cast nodes without type checks. * Since it is not obvious to me that all uses of CAST-VALUE must be in the same component as the cast itself, AVER that. * Results of MAKE-ARRAY can once more be stack allocated. Regression caused by different handling of TRULY-THE introducing cast nodes where there previously were none. * Tests. --- NEWS | 2 ++ src/compiler/ir1util.lisp | 48 +++++++++++++++++++++++++++++++--------- src/compiler/locall.lisp | 14 +++++++----- src/compiler/physenvanal.lisp | 20 ++++++++--------- tests/dynamic-extent.impure.lisp | 11 ++++++++- version.lisp-expr | 2 +- 6 files changed, 70 insertions(+), 27 deletions(-) diff --git a/NEWS b/NEWS index c1bef9ec1..808956ea0 100644 --- a/NEWS +++ b/NEWS @@ -7,6 +7,8 @@ changes in sbcl-1.0.17 relative to 1.0.16: in normal SPEED policies. * optimization: NCONC no longer needs to heap cons its &REST list in normal SPEED policies. + * bug fix: result of MAKE-ARRAY can be stack allocated - regression + since 1.0.15.36. (thanks to Paul Khuong) * bug fix: bogus errors when generating certain code sequences, due to the compiler not accepting ANY-REG for primitive type T on x86 and x86-64. (reported by Stelian Ionescu.) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 915727f87..6add01045 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -62,6 +62,15 @@ uses (list uses)))) +(declaim (ftype (sfunction (lvar) lvar) principal-lvar)) +(defun principal-lvar (lvar) + (labels ((pl (lvar) + (let ((use (lvar-uses lvar))) + (if (cast-p use) + (pl (cast-value use)) + lvar)))) + (pl lvar))) + (defun principal-lvar-use (lvar) (labels ((plu (lvar) (declare (type lvar lvar)) @@ -382,18 +391,37 @@ (awhen (node-lvar node) (lvar-dynamic-extent it))) -(defun use-good-for-dx-p (use) - (and (combination-p use) - (eq (combination-kind use) :known) - (awhen (fun-info-stack-allocate-result - (combination-fun-info use)) - (funcall it use)))) - -(defun lvar-good-for-dx-p (lvar) +(declaim (ftype (sfunction (node &optional (or null component)) boolean) + use-good-for-dx-p)) +(declaim (ftype (sfunction (lvar &optional (or null component)) boolean) + lvar-good-for-dx-p)) +(defun use-good-for-dx-p (use &optional component) + ;; FIXME: Can casts point to LVARs in other components? + ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that + ;; is, that the PRINCIPAL-LVAR is always in the same component + ;; as the original one. It would be either good to have an + ;; explanation of why casts don't point across components, or an + ;; explanation of when they do it. ...in the meanwhile AVER that + ;; our expactation holds true. + (aver (or (not component) (eq component (node-component use)))) + (or (and (combination-p use) + (eq (combination-kind use) :known) + (awhen (fun-info-stack-allocate-result + (combination-fun-info use)) + (funcall it use)) + t) + (and (cast-p use) + (not (cast-type-check use)) + (lvar-good-for-dx-p (cast-value use) component) + t))) + +(defun lvar-good-for-dx-p (lvar &optional component) (let ((uses (lvar-uses lvar))) (if (listp uses) - (every #'use-good-for-dx-p uses) - (use-good-for-dx-p uses)))) + (every (lambda (use) + (use-good-for-dx-p use component)) + uses) + (use-good-for-dx-p uses component)))) (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 3b57132bb..31e813631 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -50,12 +50,16 @@ ;; so we just need to process used-once LVARs. (when (node-p uses) (node-ends-block uses)) - ;; If this LVAR's USE is good for DX, it must be a regular - ;; combination, and its arguments are potentially DX as well. + ;; 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) - (loop for arg in (combination-args use) - when (lvar-good-for-dx-p arg) - append (handle-nested-dynamic-extent-lvars arg)))) + (etypecase use + (cast + (handle-nested-dynamic-extent-lvars (cast-value use))) + (combination + (loop for arg in (combination-args use) + when (lvar-good-for-dx-p arg) + append (handle-nested-dynamic-extent-lvars arg)))))) (cons lvar (if (listp uses) (loop for use in uses diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 835c7c5d7..ff9fc4285 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -334,11 +334,10 @@ (loop for what in (cleanup-info cleanup) do (etypecase what (lvar - (if (let ((uses (lvar-uses what))) - (if (listp uses) - (every #'use-good-for-dx-p uses) - (use-good-for-dx-p uses))) - (real-dx-lvars what) + (if (lvar-good-for-dx-p what component) + (let ((real (principal-lvar what))) + (setf (lvar-dynamic-extent real) cleanup) + (real-dx-lvars real)) (setf (lvar-dynamic-extent what) nil))) (node ; DX closure (let* ((call what) @@ -347,9 +346,9 @@ (dx nil)) (dolist (fun funs) (binding* ((() (leaf-dynamic-extent fun) - :exit-if-null) + :exit-if-null) (xep (functional-entry-fun fun) - :exit-if-null) + :exit-if-null) (closure (physenv-closure (get-lambda-physenv xep)))) (cond (closure @@ -359,9 +358,10 @@ (when dx (setf (lvar-dynamic-extent arg) cleanup) (real-dx-lvars arg)))))) - (setf (cleanup-info cleanup) (real-dx-lvars)) - (setf (component-dx-lvars component) - (append (real-dx-lvars) (component-dx-lvars component))))))) + (let ((real-dx-lvars (delete-duplicates (real-dx-lvars)))) + (setf (cleanup-info cleanup) real-dx-lvars) + (setf (component-dx-lvars component) + (append real-dx-lvars (component-dx-lvars component)))))))) (values)) ;;;; cleanup emission diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index d82513d2c..a6034c7ce 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -146,6 +146,14 @@ (true cons) nil)) +;;; MAKE-ARRAY + +(defun-with-dx make-array-on-stack () + (let ((v (make-array '(42) :element-type 'single-float))) + (declare (dynamic-extent v)) + (true v) + nil)) + ;;; Nested DX (defun-with-dx nested-dx-lists () @@ -240,6 +248,7 @@ (assert-no-consing (test-lvar-subst 11)) (assert-no-consing (dx-value-cell 13)) (assert-no-consing (cons-on-stack 42)) + (assert-no-consing (make-array-on-stack)) (assert-no-consing (nested-dx-conses)) (assert-no-consing (nested-dx-lists)) (assert-consing (nested-dx-not-used *a-cons*)) @@ -289,7 +298,7 @@ (let ((a (make-array 11 :initial-element 0))) (declare (dynamic-extent a)) (assert (every (lambda (x) (eql x 0)) a)))) -(bdowning-2005-iv-16) +(assert-no-consing (bdowning-2005-iv-16)) (defun-with-dx let-converted-vars-dx-allocated-bug (x y z) diff --git a/version.lisp-expr b/version.lisp-expr index 2ebc92700..bc61bdcf3 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.16.25" +"1.0.16.26" -- 2.11.4.GIT