1.0.10.8: correct nested DX implementation

* Instead of just checking for BASIC-COMBINATION-P,
  HANDLE-NESTED-DYNAMIC-EXTENT needs to do the same check for each USE
  as RECHECK-DYNAMIC-EXTENT-LVARS does.

* Tests.

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 9658ac8..cba2914 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -382,6 +382,13 @@
   (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))))
+
 (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 f9b8849..d3eadd8 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -43,23 +43,25 @@
              (setf (car args) nil)))
   (values))
 
-
-(defun handle-nested-dynamic-extent-lvars (arg)
-  (let ((uses (lvar-uses arg)))
+(defun handle-nested-dynamic-extent-lvars (lvar)
+  (let ((uses (lvar-uses lvar)))
     ;; 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 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.
-    (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))))))
+      (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.
+    (flet ((recurse (use)
+             (loop for arg in (combination-args use)
+                   append (handle-nested-dynamic-extent-lvars arg))))
+      (cons lvar
+            (if (listp uses)
+                (loop for use in uses
+                      when (use-good-for-dx-p use)
+                      nconc (recurse use))
+                (when (use-good-for-dx-p uses)
+                  (recurse uses)))))))
 
 (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 af8fec3..835c7c5 100644 (file)
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -334,17 +334,12 @@
                    (loop for what in (cleanup-info cleanup)
                          do (etypecase what
                               (lvar
-                               (let* ((lvar what)
-                                      (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))))
+                               (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)
+                                   (setf (lvar-dynamic-extent what) nil)))
                               (node ; DX closure
                                (let* ((call what)
                                       (arg (first (basic-combination-args call)))

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 78923f3..d22342d 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -160,6 +160,25 @@
     (true dx)
     nil))
 
+(defun-with-dx nested-dx-not-used (x)
+  (declare (list x))
+  (let ((l (setf (car x) (list x x x))))
+    (declare (dynamic-extent l))
+    (true l)
+    (true (length l))
+    nil))
+
+(defun-with-dx nested-evil-dx-used (x)
+  (declare (list x))
+  (let ((l (list x x x)))
+    (declare (dynamic-extent l))
+    (unwind-protect
+         (progn
+           (setf (car x) l)
+           (true l))
+      (setf (car x) nil))
+    nil))
+
 ;;; multiple uses for dx lvar
 
 (defun-with-dx multiple-dx-uses ()
@@ -196,6 +215,18 @@
       (funcall thunk))
     (assert (< (- (get-bytes-consed) before) times))))
 
+(defmacro assert-consing (form &optional times)
+  `(%assert-consing (lambda () ,form) ,times))
+(defun %assert-consing (thunk &optional times)
+  (let ((before (get-bytes-consed))
+        (times (or times 10000)))
+    (declare (type (integer 1 *) times))
+    (dotimes (i times)
+      (funcall thunk))
+    (assert (not (< (- (get-bytes-consed) before) times)))))
+
+(defvar *a-cons* (cons nil nil))
+
 #+(or x86 x86-64 alpha ppc sparc mips)
 (progn
   (assert-no-consing (dxclosure 42))
@@ -211,6 +242,8 @@
   (assert-no-consing (cons-on-stack 42))
   (assert-no-consing (nested-dx-conses))
   (assert-no-consing (nested-dx-lists))
+  (assert-consing (nested-dx-not-used *a-cons*))
+  (assert-no-consing (nested-evil-dx-used *a-cons*))
   (assert-no-consing (multiple-dx-uses))
   ;; Not strictly DX..
   (assert-no-consing (test-hash-table))

diff --git a/version.lisp-expr b/version.lisp-expr
index a98686c..4cea42f 100644 (file)
--- 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.10.7"
+"1.0.10.8"