X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=2c6d8f69a0ff3568d39eed98ebf5f6416278358f;hb=49e8403800426f37a54d9b87353a31af36e7af40;hp=481ce2e35a38618d288933e83433fc1550d753e3;hpb=6dac5c9af52b4538b412b2e7c22b78863d85557a;p=sbcl.git

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index 481ce2e..2c6d8f6 100644
--- 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,43 +328,49 @@
   (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
-                               (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)))
-                                     (real-dx-lvars lvar)
-                                     (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))))))
-                   (setf (cleanup-info cleanup) (real-dx-lvars))
+          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 ((dx (car what))
+                                   (lvar (cdr what)))
+                               (cond ((lvar-good-for-dx-p lvar dx component)
+                                      ;; Since the above check does deep
+                                      ;; checks. we need to deal with the deep
+                                      ;; results in here as well.
+                                      (dolist (cell (handle-nested-dynamic-extent-lvars
+                                                     dx lvar component))
+                                        (let ((real (principal-lvar (cdr cell))))
+                                          (setf (lvar-dynamic-extent real) cleanup)
+                                          (real-dx-lvars real))))
+                                     (t
+                                      (note-no-stack-allocation lvar)
+                                      (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)))))))
+                         (append real-dx-lvars (component-dx-lvars component))))))))
   (values))
 
 ;;;; cleanup emission
@@ -407,7 +413,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)))