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

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index 481ce2e..e43bf9e 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,47 @@
   (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 ((lvar (cdr what)))
+                               (cond ((lvar-good-for-dx-p lvar (car what) component)
+                                      (let ((real (principal-lvar lvar)))
+                                        (setf (lvar-dynamic-extent real) cleanup)
+                                        (real-dx-lvars real)))
+                                     (t
+                                      (do-uses (use lvar)
+                                        (unless (ref-p use)
+                                          (let ((*compiler-error-context* use))
+                                            (compiler-notify "could not stack allocate the result of ~S"
+                                                             (find-original-source (node-source-path use))))))
+                                      (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 +411,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)))