0.8.10.57:

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

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index 1da7274..022442e 100644 (file)
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -48,8 +48,9 @@
                    (functional-has-external-references-p fun))
          (aver (member kind '(:optional :cleanup :escape)))
          (setf (functional-kind fun) nil)
-         (delete-functional fun)))))
+          (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 +233,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
@@ -246,14 +247,13 @@
   (declare (type physenv env) (type exit exit))
   (let* ((exit-block (node-block exit))
         (next-block (first (block-succ exit-block)))
-        (cleanup (entry-cleanup (exit-entry exit)))
-        (info (make-nlx-info :cleanup cleanup
-                             :continuation (node-cont exit)))
         (entry (exit-entry exit))
+        (cleanup (entry-cleanup entry))
+        (info (make-nlx-info cleanup exit))
         (new-block (insert-cleanup-code exit-block next-block
                                         entry
                                         `(%nlx-entry ',info)
-                                        (entry-cleanup entry)))
+                                        cleanup))
         (component (block-component new-block)))
     (unlink-blocks exit-block new-block)
     (link-blocks exit-block (component-tail component))
@@ -281,31 +281,34 @@
 ;;;    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 ((entry (exit-entry exit))
-       (cont (node-cont exit))
+  (let ((lvar (node-lvar exit))
        (exit-fun (node-home-lambda exit)))
-    (if (find-nlx-info entry cont)
+    (if (find-nlx-info exit)
        (let ((block (node-block exit)))
          (aver (= (length (block-succ block)) 1))
          (unlink-blocks block (first (block-succ block)))
          (link-blocks block (component-tail (block-component block))))
        (insert-nlx-entry-stub exit env))
-    (let ((info (find-nlx-info entry cont)))
+    (let ((info (find-nlx-info exit)))
       (aver info)
       (close-over info (node-physenv exit) env)
       (when (eq (functional-kind exit-fun) :escape)
        (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-continuation-use node)
-         (add-continuation-use node (nlx-info-continuation info))))))
+       (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
@@ -355,17 +358,19 @@
                       (basic-combination-args node))))
          (ecase (cleanup-kind cleanup)
            (:special-bind
-            (code `(%special-unbind ',(continuation-value (first args)))))
+            (code `(%special-unbind ',(lvar-value (first args)))))
            (:catch
             (code `(%catch-breakup)))
            (:unwind-protect
             (code `(%unwind-protect-breakup))
-            (let ((fun (ref-leaf (continuation-use (second args)))))
+            (let ((fun (ref-leaf (lvar-uses (second args)))))
               (reanalyze-funs fun)
               (code `(%funcall ,fun))))
            ((:block :tagbody)
             (dolist (nlx (cleanup-nlx-info cleanup))
-              (code `(%lexical-exit-breakup ',nlx)))))))
+              (code `(%lexical-exit-breakup ',nlx))))
+           (:dynamic-extent
+            (code `(%dynamic-extent-end))))))
 
       (when (code)
        (aver (not (node-tail-p (block-last block1))))
@@ -418,9 +423,9 @@
        (let ((result (return-result ret)))
          (do-uses (use result)
            (when (and (policy use merge-tail-calls)
+                       (basic-combination-p use)
                       (immediately-used-p result use)
                       (or (not (eq (node-derived-type use) *empty-type*))
-                          (not (basic-combination-p use))
                           (eq (basic-combination-kind use) :local)))
              (setf (node-tail-p use) t)))))))
   (values))