X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=037060dc3456f40959452e90c2be8bc51bad4e59;hb=f705c517d8606a9a72edd11a96725f9c4e4be93d;hp=86e41ed3f015f423093ad13d51e86e4ccccef12a;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index 86e41ed..037060d 100644
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -38,6 +38,7 @@
 	(component-lambdas component))
 
   (find-non-local-exits component)
+  (recheck-dynamic-extent-lvars component)
   (find-cleanup-points component)
   (tail-annotate component)
 
@@ -50,6 +51,7 @@
 	  (setf (functional-kind fun) nil)
           (delete-functional fun)))))
 
+  (setf (component-nlx-info-generated-p component) t)
   (values))
 
 ;;; This is to be called on a COMPONENT with top level LAMBDAs before
@@ -232,8 +234,8 @@
 ;;; knows what entry is being done.
 ;;;
 ;;; The link from the EXIT block to the entry stub is changed to be a
-;;; link to the component head. Similarly, the EXIT block is linked to
-;;; the component tail. This leaves the entry stub reachable, but
+;;; link from the component head. Similarly, the EXIT block is linked
+;;; to the component tail. This leaves the entry stub reachable, but
 ;;; makes the flow graph less confusing to flow analysis.
 ;;;
 ;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the
@@ -280,9 +282,10 @@
 ;;;    function reference. This will cause the escape function to
 ;;;    be deleted (although not removed from the DFO.)  The escape
 ;;;    function is no longer needed, and we don't want to emit code
-;;;    for it. We then also change the %NLX-ENTRY call to use the
-;;;    NLX continuation so that there will be a use to represent
-;;;    the NLX use.
+;;;    for it.
+;;; -- Change the %NLX-ENTRY call to use the NLX lvar so that 1) there
+;;;    will be a use to represent the NLX use; 2) make life easier for
+;;;    the stack analysis.
 (defun note-non-local-exit (env exit)
   (declare (type physenv env) (type exit exit))
   (let ((lvar (node-lvar exit))
@@ -300,11 +303,13 @@
 	(mapc (lambda (x)
 		(setf (node-derived-type x) *wild-type*))
 	      (leaf-refs exit-fun))
-	(substitute-leaf (find-constant info) exit-fun)
-	(let ((node (block-last (nlx-info-target info))))
-	  (delete-lvar-use node)
-          (aver (eq lvar (node-lvar exit)))
-	  (add-lvar-use node lvar)))))
+	(substitute-leaf (find-constant info) exit-fun))
+      (when lvar
+        (let ((node (block-last (nlx-info-target info))))
+          (unless (node-lvar node)
+            (aver (eq lvar (node-lvar exit)))
+            (setf (node-derived-type node) (lvar-derived-type lvar))
+            (add-lvar-use node lvar))))))
   (values))
 
 ;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT
@@ -323,6 +328,28 @@
 	      (note-non-local-exit target-physenv exit))))))
   (values))
 
+;;;; final decision on stack allocation of dynamic-extent structores
+(defun recheck-dynamic-extent-lvars (component)
+  (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 lvar in (cleanup-info cleanup)
+                         do (let ((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))))
+                   (setf (cleanup-info cleanup) (real-dx-lvars))
+                   (setf (component-dx-lvars component)
+                         (append (real-dx-lvars) (component-dx-lvars component)))))))
+  (values))
+
 ;;;; cleanup emission
 
 ;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating
@@ -364,7 +391,10 @@
 	       (code `(%funcall ,fun))))
 	    ((:block :tagbody)
 	     (dolist (nlx (cleanup-nlx-info cleanup))
-	       (code `(%lexical-exit-breakup ',nlx)))))))
+	       (code `(%lexical-exit-breakup ',nlx))))
+	    (:dynamic-extent
+	     (when (not (null (cleanup-info cleanup)))
+               (code `(%cleanup-point)))))))
 
       (when (code)
 	(aver (not (node-tail-p (block-last block1))))