X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=ee3874e4693b541792c8d4b3997fce9b244716e0;hb=2b0851c405b494143009f68e2bc7e91017a809d4;hp=e006827a52e7ffbd56c2a695d663b88706fbf344;hpb=6822034325136cde4e14773c83c3769b42721306;p=sbcl.git

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index e006827..ee3874e 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,40 +328,46 @@
   (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)))
-                                     (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))))))))
+          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)
+                                          (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))))))))
   (values))
 
 ;;;; cleanup emission
@@ -404,7 +410,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)))