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