stack: Make sure to not clean up nested stack values too early.

This was a regression that happened when we started only tracking
stack lvars instead of all dynamic extent values on the stack. It
turns out that the invariant that stack objects with different
lifetimes isn't true, even without SETQ, as the first test case
shows. Fix this by adding a funny function which only serves to keep
the stack fixed when dynamic extent values with different lifetimes
get pushed in an interleaved manner onto the stack. The invariant that
multiple-values and dynamic-extent lifetimes cannot be interleaved is
still true however.

Also add a test case where SETQ caused the same problem for good
measure.

src/compiler/fndb.lisp

@@ -1895,6 +1895,7 @@
 
 (defknown %cleanup-point (&rest t) t (reoptimize-when-unlinking))
 (defknown %dynamic-extent-start () t)
+(defknown %preserve-dynamic-extent () t)
 (defknown %special-bind (t t) t)
 (defknown %special-unbind (&rest symbol) t)
 (defknown %listify-rest-args (t index) list (flushable))

src/compiler/ir2tran.lisp

@@ -1855,6 +1855,10 @@
       (vop current-stack-pointer node block
            (first (ir2-lvar-locs 2lvar))))))
 
+;;; %PRESERVE-DYNAMIC-EXTENT doesn't do anything except prevent stack
+;;; %objects from getting cleaned up too early.
+(defoptimizer (%preserve-dynamic-extent ir2-convert) (()))
+
 ;;;; special binding
 
 ;;; This is trivial, given our assumption of a shallow-binding

src/compiler/node.lisp

@@ -1707,7 +1707,8 @@
   ;; extent is over the environment and hence needs no cleanup code.
   (cleanup nil :type (or cleanup null))
   ;; some kind of info used by the back end
-  (info nil))
+  (info nil)
+  (preserve-info nil))
 
 (defprinter (cdynamic-extent :conc-name dynamic-extent-
                              :identity t)

src/compiler/stack.lisp

@@ -126,7 +126,11 @@
                (do ((tail stack (cdr tail)))
                    ((null tail) (prefix))
                  (let ((lvar (car tail)))
-                   (when (memq lvar start)
+                   (when (or (memq lvar start)
+                             (and (lvar-dynamic-extent lvar)
+                                  (member (dynamic-extent-info
+                                           (lvar-dynamic-extent lvar))
+                                          start)))
                      (when (eq (ir2-lvar-kind (lvar-info lvar)) :stack)
                        (return (append (prefix) tail)))
                      (prefix lvar)))))))
@@ -178,15 +182,28 @@
           (when dynamic-extent
             (let ((info (dynamic-extent-info dynamic-extent)))
               (when info
-                (unless (memq info stack)
-                  (push info stack)
+                (unless (eq info (first stack))
                   (pushnew block (ir2-component-stack-mess-ups 2comp))
                   (setf (ctran-next (node-prev node)) nil)
                   (let ((ctran (make-ctran)))
                     (with-ir1-environment-from-node node
+                      (cond ((memq info stack)
+                             (let ((preserve (make-lvar))
+                                   (2preserve
+                                     (make-ir2-lvar *backend-t-primitive-type*)))
+                               (ir1-convert (node-prev node) ctran preserve
+                                            '(%preserve-dynamic-extent))
+                               (setf (lvar-info preserve) 2preserve)
+                               (setf (ir2-lvar-kind 2preserve) :stack)
+                               (setf (lvar-dynamic-extent preserve) dynamic-extent)
+                               (setf (lvar-dest preserve) dynamic-extent)
+                               (push preserve
+                                     (dynamic-extent-preserve-info dynamic-extent))))
+                            (t
                              (ir1-convert (node-prev node) ctran info
-                                   `(%dynamic-extent-start))
-                      (link-node-to-previous-ctran node ctran))))))))
+                                          '(%dynamic-extent-start))
+                             (push info stack))))
+                    (link-node-to-previous-ctran node ctran)))))))
         (when (entry-p node)
           (dolist (nlx-info (cleanup-nlx-info (entry-cleanup node)))
             (stack-mess-up-walk (nlx-info-target nlx-info) stack)))))

tests/dynamic-extent.pure.lisp

@@ -2053,3 +2053,42 @@
                (body)))))
      ((t) 'foo)
      ((nil) '(nil)))))
+
+(with-test (:name :dynamic-extent-nested)
+  (let ((sb-c::*check-consistency* t))
+    (checked-compile-and-assert
+     ()
+     '(lambda (a)
+       (let ((v (list (vector 0 0)
+                      (let ((x (cons 1 2)))
+                        (declare (dynamic-extent x))
+                        (print x)
+                        (list 1 2)))))
+         (declare (dynamic-extent v))
+         (elt v a)))
+     ((1) '(1 2)))))
+
+(with-test (:name :dynamic-extent-setq-nested)
+  (let ((sb-c::*check-consistency* t))
+    (checked-compile-and-assert
+     ()
+     '(lambda ()
+       (dotimes (i 2)
+         (let ((y (cons 1 2)))
+           (declare (dynamic-extent y))
+           (assert (equal y (cons 1 2)))
+           (assert (sb-ext:stack-allocated-p y))
+           (let ((z (cons 3 4)))
+             (declare (dynamic-extent z))
+             (assert (equal z (cons 3 4)))
+             (assert (sb-ext:stack-allocated-p z))
+             (setq y (cons 2 1))
+             (assert (equal y (cons 2 1)))
+             (assert (sb-ext:stack-allocated-p y)))
+           (let ((z (list 9 9 9 9 9)))
+             (declare (dynamic-extent z))
+             (assert (equal z (list 9 9 9 9 9)))
+             (assert (sb-ext:stack-allocated-p z))
+             (assert (equal y (cons 2 1)))
+             (assert (sb-ext:stack-allocated-p y))))))
+     (() nil))))