From 149c89ad95baabf2db61f9a14941c0acd27eb4eb Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 15 Sep 2007 21:06:17 +0300 Subject: [PATCH] multiply-used DX LVARS * HANDLE-NESTED-DYNAMIC-EXTENT maps over all the uses of the LVAR, collecting their argument lvars as well. * RECHECK-DYNAMIC-EXTENT-LVARS accepts multiply-used DX LVARs, checking that all uses support stack allocation. * UPDATE-UVL-LIVE-SETS accepts multiply-used DX LVARs, doing that lifetime merging with all uses. diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS index 47a7e41..0308f85 100644 --- a/OPTIMIZATIONS +++ b/OPTIMIZATIONS @@ -162,15 +162,6 @@ through TYPEP UNBOXED-ARRAY, within the compiler itself. rather than either constant-folding or manipulating NIL-VALUE or NULL-TN directly. -------------------------------------------------------------------------------- -#19 - (let ((dx (if (foo) - (list x) - (list y z)))) - (declare (dynamic-extent dx)) - ...) - -DX is not allocated on stack. --------------------------------------------------------------------------------- #20 (defun-with-dx foo (x) (flet ((make (x) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 4fe1a0e..f9b8849 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -45,20 +45,21 @@ (defun handle-nested-dynamic-extent-lvars (arg) - (let ((use (lvar-uses arg))) + (let ((uses (lvar-uses arg))) ;; Stack analysis wants DX value generators to end their ;; blocks. Uses of mupltiple used LVARs already end their blocks, ;; so we just need to process used-once LVARs. - (when (node-p use) - (node-ends-block use)) + (when (node-p uses) + (node-ends-block uses) + (setf uses (list uses))) ;; If the function result is DX, so are its arguments... This ;; assumes that all our DX functions do not store their arguments ;; anywhere -- just use, and maybe return. - (if (basic-combination-p use) - (cons arg (funcall (lambda (lists) - (reduce #'append lists)) - (mapcar #'handle-nested-dynamic-extent-lvars (basic-combination-args use)))) - (list arg)))) + (cons arg + (loop for use in uses + when (basic-combination-p use) + nconc (loop for a in (basic-combination-args use) + append (handle-nested-dynamic-extent-lvars a)))))) (defun recognize-dynamic-extent-lvars (call fun) (declare (type combination call) (type clambda fun)) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 481ce2e..af8fec3 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -335,14 +335,16 @@ do (etypecase what (lvar (let* ((lvar what) - (use (lvar-uses lvar))) - (if (and (combination-p use) - (eq (basic-combination-kind use) :known) - (awhen (fun-info-stack-allocate-result - (basic-combination-fun-info use)) - (funcall it use))) + (uses (lvar-uses lvar))) + (if (every (lambda (use) + (and (combination-p use) + (eq (basic-combination-kind use) :known) + (awhen (fun-info-stack-allocate-result + (basic-combination-fun-info use)) + (funcall it use)))) + (if (listp uses) uses (list uses))) (real-dx-lvars lvar) - (setf (lvar-dynamic-extent lvar) nil)))) + (setf (lvar-dynamic-extent lvar) nil)))) (node ; DX closure (let* ((call what) (arg (first (basic-combination-args call))) diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index 4ac4c7a..00730cb 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -61,6 +61,7 @@ ;;; been changed. (defun merge-uvl-live-sets (early late) (declare (type list early late)) + ;; FIXME: O(N^2) (dolist (e late early) (pushnew e early))) @@ -93,21 +94,23 @@ block (lambda (dx-cleanup) (dolist (lvar (cleanup-info dx-cleanup)) - (let* ((generator (lvar-use lvar)) - (block (node-block generator)) - (2block (block-info block))) - ;; DX objects, living in the LVAR, are - ;; alive in the environment, protected by - ;; the CLEANUP. We also cannot move them - ;; (because, in general, we cannot track - ;; all references to them). Therefore, - ;; everything, allocated deeper than a DX - ;; object, should be kept alive until the - ;; object is deallocated. - (setq new-end (merge-uvl-live-sets - new-end (ir2-block-end-stack 2block))) - (setq new-end (merge-uvl-live-sets - new-end (ir2-block-pushed 2block))))))) + (let ((uses (lvar-uses lvar))) + (dolist (generator (if (listp uses) uses (list uses))) + (let* ((block (node-block generator)) + (2block (block-info block))) + ;; DX objects, living in the LVAR, are + ;; alive in the environment, protected + ;; by the CLEANUP. We also cannot move + ;; them (because, in general, we cannot + ;; track all references to + ;; them). Therefore, everything, + ;; allocated deeper than a DX object, + ;; should be kept alive until the + ;; object is deallocated. + (setq new-end (merge-uvl-live-sets + new-end (ir2-block-end-stack 2block))) + (setq new-end (merge-uvl-live-sets + new-end (ir2-block-pushed 2block))))))))) (setf (ir2-block-end-stack 2block) new-end) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 4ec3d4d..78923f3 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -160,6 +160,16 @@ (true dx) nil)) +;;; multiple uses for dx lvar + +(defun-with-dx multiple-dx-uses () + (let ((dx (if (true t) + (list 1 2 3) + (list 2 3 4)))) + (declare (dynamic-extent dx)) + (true dx) + nil)) + ;;; with-spinlock should use DX and not cons (defvar *slock* (sb-thread::make-spinlock :name "slocklock")) @@ -201,6 +211,7 @@ (assert-no-consing (cons-on-stack 42)) (assert-no-consing (nested-dx-conses)) (assert-no-consing (nested-dx-lists)) + (assert-no-consing (multiple-dx-uses)) ;; Not strictly DX.. (assert-no-consing (test-hash-table)) #+sb-thread -- 1.5.3.1