1.0.28.18: better TRULY-DYNAMIC-EXTENT handling

   Since RECHECK-DYNAMIC-EXTENT-LVARS passes T as the DX type,
   TRULY-DYNAMIC-EXTENT did not unconditionally allow DX allocation
   regardless of policy, as was the intention.

   Save the LVARs initially along with the DX type (T or :TRULY),
   so that R-D-E-L can use the correct DX type when rechecking.

   Test case.

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 7e21398..155b847 100644 (file)
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -1009,7 +1009,12 @@
              (case (cleanup-kind cleanup)
                ((:dynamic-extent)
                 (format t "entry DX~{ v~D~}"
-                        (mapcar #'cont-num (cleanup-info cleanup))))
+                        (mapcar (lambda (lvar-or-cell)
+                                  (if (consp lvar-or-cell)
+                                      (cons (car lvar-or-cell)
+                                            (cont-num (cdr lvar-or-cell)))
+                                      (cont-num lvar-or-cell)))
+                                (cleanup-info cleanup))))
                (t
                 (format t "entry ~S" (entry-exits node))))))
           (exit

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 34a9a58..64182a2 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -191,7 +191,7 @@
            (setf (lvar-dynamic-extent old) nil)
            (unless (lvar-dynamic-extent new)
              (setf (lvar-dynamic-extent new) it)
-             (setf (cleanup-info it) (substitute new old (cleanup-info it)))))
+             (setf (cleanup-info it) (subst new old (cleanup-info it)))))
          (when (lvar-dynamic-extent new)
            (do-uses (node new)
              (node-ends-block node))))

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index fe8af57..1c6db26 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -65,7 +65,7 @@
                 (let* ((other (trivial-lambda-var-ref-lvar use)))
                   (unless (eq other lvar)
                     (handle-nested-dynamic-extent-lvars dx other)))))))
-      (cons lvar
+      (cons (cons dx lvar)
             (if (listp uses)
                 (loop for use in uses
                       when (use-good-for-dx-p use dx)
@@ -95,8 +95,8 @@
                           (make-lexenv :default (node-lexenv call)
                                        :cleanup cleanup))
                     (push entry (lambda-entries (node-home-lambda entry)))
-                    (dolist (lvar dx-lvars)
-                      (setf (lvar-dynamic-extent lvar) cleanup)))))
+                    (dolist (cell dx-lvars)
+                      (setf (lvar-dynamic-extent (cdr cell)) cleanup)))))
   (values))
 
 ;;; This function handles merging the tail sets if CALL is potentially

diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 3554d01..cb167fd 100644 (file)
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -465,8 +465,6 @@
   kind
   mess-up
   (info :test info))
-(defmacro cleanup-nlx-info (cleanup)
-  `(cleanup-info ,cleanup))
 
 ;;; A PHYSENV represents the result of physical environment analysis.
 ;;;

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index e006827..592c002 100644 (file)
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -251,7 +251,7 @@
     (setf (nlx-info-target info) new-block)
     (setf (nlx-info-safe-p info) (exit-should-check-tag-p exit))
     (push info (physenv-nlx-info env))
-    (push info (cleanup-nlx-info cleanup))
+    (push info (cleanup-info cleanup))
     (when (member (cleanup-kind cleanup) '(:catch :unwind-protect))
       (setf (node-lexenv (block-last new-block))
             (node-lexenv entry))))
@@ -328,40 +328,41 @@
   (declare (type component component))
   (dolist (lambda (component-lambdas component))
     (loop for entry in (lambda-entries lambda)
-            for cleanup = (entry-cleanup entry)
-            do (when (eq (cleanup-kind cleanup) :dynamic-extent)
-                 (collect ((real-dx-lvars))
-                   (loop for what in (cleanup-info cleanup)
-                         do (etypecase what
-                              (lvar
-                               (if (lvar-good-for-dx-p what t component)
-                                   (let ((real (principal-lvar what)))
+          for cleanup = (entry-cleanup entry)
+          do (when (eq (cleanup-kind cleanup) :dynamic-extent)
+               (collect ((real-dx-lvars))
+                 (loop for what in (cleanup-info cleanup)
+                       do (etypecase what
+                            (cons
+                             (let ((lvar (cdr what)))
+                               (if (lvar-good-for-dx-p lvar (car what) component)
+                                   (let ((real (principal-lvar lvar)))
                                      (setf (lvar-dynamic-extent real) cleanup)
                                      (real-dx-lvars real))
-                                   (setf (lvar-dynamic-extent what) nil)))
-                              (node ; DX closure
-                               (let* ((call what)
-                                      (arg (first (basic-combination-args call)))
-                                      (funs (lvar-value arg))
-                                      (dx nil))
-                                 (dolist (fun funs)
-                                   (binding* ((() (leaf-dynamic-extent fun)
-                                               :exit-if-null)
-                                              (xep (functional-entry-fun fun)
-                                               :exit-if-null)
-                                              (closure (physenv-closure
-                                                        (get-lambda-physenv xep))))
-                                     (cond (closure
-                                            (setq dx t))
-                                           (t
-                                            (setf (leaf-dynamic-extent fun) nil)))))
-                                 (when dx
-                                   (setf (lvar-dynamic-extent arg) cleanup)
-                                   (real-dx-lvars arg))))))
-                   (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))))))))
+                                   (setf (lvar-dynamic-extent lvar) nil))))
+                            (node       ; DX closure
+                             (let* ((call what)
+                                    (arg (first (basic-combination-args call)))
+                                    (funs (lvar-value arg))
+                                    (dx nil))
+                               (dolist (fun funs)
+                                 (binding* ((() (leaf-dynamic-extent fun)
+                                             :exit-if-null)
+                                            (xep (functional-entry-fun fun)
+                                                 :exit-if-null)
+                                            (closure (physenv-closure
+                                                      (get-lambda-physenv xep))))
+                                   (cond (closure
+                                          (setq dx t))
+                                         (t
+                                          (setf (leaf-dynamic-extent fun) nil)))))
+                               (when dx
+                                 (setf (lvar-dynamic-extent arg) cleanup)
+                                 (real-dx-lvars arg))))))
+                 (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
@@ -404,7 +405,7 @@
                (reanalyze-funs fun)
                (code `(%funcall ,fun))))
             ((:block :tagbody)
-             (dolist (nlx (cleanup-nlx-info cleanup))
+             (dolist (nlx (cleanup-info cleanup))
                (code `(%lexical-exit-breakup ',nlx))))
             (:dynamic-extent
              (when (not (null (cleanup-info cleanup)))

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index aba5a18..ae9a31c 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -153,6 +153,13 @@
     (true v)
     nil))
 
+(defun force-make-array-on-stack (n)
+  (declare (optimize safety))
+  (let ((v (make-array (min n 1))))
+    (declare (sb-int:truly-dynamic-extent v))
+    (true v)
+    nil))
+
 ;;; MAKE-STRUCTURE
 
 (declaim (inline make-fp-struct-1))
@@ -477,6 +484,7 @@
   (assert-no-consing (dx-value-cell 13))
   (assert-no-consing (cons-on-stack 42))
   (assert-no-consing (make-array-on-stack))
+  (assert-no-consing (force-make-array-on-stack 128))
   (assert-no-consing (make-foo1-on-stack 123))
   (assert-no-consing (nested-good 42))
   (#+raw-instance-init-vops assert-no-consing

diff --git a/version.lisp-expr b/version.lisp-expr
index b64c0f1..24dc46d 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.28.17"
+"1.0.28.18"