diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 18fcecb15..10be76fd9 100644
--- a/src/compiler/fndb.lisp
+++ b/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))
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index d01112160..1277340b0 100644
--- a/src/compiler/ir2tran.lisp
+++ b/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
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 5f6676f18..cf79e4505 100644
--- a/src/compiler/node.lisp
+++ b/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)
diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp
index f5d108765..5651ee06b 100644
--- a/src/compiler/stack.lisp
+++ b/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
-                      (ir1-convert (node-prev node) ctran info
-                                   `(%dynamic-extent-start))
-                      (link-node-to-previous-ctran node ctran))))))))
+                      (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))
+                             (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)))))
diff --git a/tests/dynamic-extent.pure.lisp b/tests/dynamic-extent.pure.lisp
index 000834596..dbae0277b 100644
--- a/tests/dynamic-extent.pure.lisp
+++ b/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))))