0.8.15.15: Removing non-ANSI FTYPE proclaims and TYPE declarares from PCL

[sbcl.git] / src / compiler / physenvanal.lisp

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index cf43865..037060d 100644 (file)
--- 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))
 \f
+;;;; 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))
+\f
 ;;;; cleanup emission
 
 ;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating
@@ -366,7 +393,8 @@
             (dolist (nlx (cleanup-nlx-info cleanup))
               (code `(%lexical-exit-breakup ',nlx))))
            (:dynamic-extent
-            (code `(%dynamic-extent-end))))))
+            (when (not (null (cleanup-info cleanup)))
+               (code `(%cleanup-point)))))))
 
       (when (code)
        (aver (not (node-tail-p (block-last block1))))