1.0.18.10: Record filenames in DEBUG-SOURCEs during EVAL-WHEN, LOAD.

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

diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp
index b2b8a11..00730cb 100644 (file)
--- a/src/compiler/stack.lisp
+++ b/src/compiler/stack.lisp
@@ -22,17 +22,17 @@
 ;;; invariant that all pushes come after the last pop.
 (defun find-pushed-lvars (block)
   (let* ((2block (block-info block))
-        (popped (ir2-block-popped 2block))
-        (last-pop (if popped
-                      (lvar-dest (car (last popped)))
-                      nil)))
+         (popped (ir2-block-popped 2block))
+         (last-pop (if popped
+                       (lvar-dest (car (last popped)))
+                       nil)))
     (collect ((pushed))
       (let ((saw-last nil))
-       (do-nodes (node lvar block)
-         (when (eq node last-pop)
-           (setq saw-last t))
+        (do-nodes (node lvar block)
+          (when (eq node last-pop)
+            (setq saw-last t))
 
-         (when (and lvar
+          (when (and lvar
                      (or (lvar-dynamic-extent lvar)
                          (let ((dest (lvar-dest lvar))
                                (2lvar (lvar-info lvar)))
@@ -61,6 +61,7 @@
 ;;; been changed.
 (defun merge-uvl-live-sets (early late)
   (declare (type list early late))
+  ;; FIXME: O(N^2)
   (dolist (e late early)
     (pushnew e early)))
 
@@ -93,21 +94,23 @@
                      block
                      (lambda (dx-cleanup)
                        (dolist (lvar (cleanup-info dx-cleanup))
-                         (let* ((generator (lvar-use lvar))
-                                (block (node-block generator))
-                                (2block (block-info block)))
-                           ;; DX objects, living in the LVAR, are
-                           ;; alive in the environment, protected by
-                           ;; the CLEANUP. We also cannot move them
-                           ;; (because, in general, we cannot track
-                           ;; all references to them). Therefore,
-                           ;; everything, allocated deeper than a DX
-                           ;; object, should be kept alive until the
-                           ;; object is deallocated.
-                           (setq new-end (merge-uvl-live-sets
-                                          new-end (ir2-block-end-stack 2block)))
-                           (setq new-end (merge-uvl-live-sets
-                                          new-end (ir2-block-pushed 2block)))))))
+                         (let ((uses (lvar-uses lvar)))
+                           (dolist (generator (if (listp uses) uses (list uses)))
+                             (let* ((block (node-block generator))
+                                    (2block (block-info block)))
+                               ;; DX objects, living in the LVAR, are
+                               ;; alive in the environment, protected
+                               ;; by the CLEANUP. We also cannot move
+                               ;; them (because, in general, we cannot
+                               ;; track all references to
+                               ;; them). Therefore, everything,
+                               ;; allocated deeper than a DX object,
+                               ;; should be kept alive until the
+                               ;; object is deallocated.
+                               (setq new-end (merge-uvl-live-sets
+                                              new-end (ir2-block-end-stack 2block)))
+                               (setq new-end (merge-uvl-live-sets
+                                              new-end (ir2-block-pushed 2block)))))))))
 
     (setf (ir2-block-end-stack 2block) new-end)
 
@@ -277,9 +280,9 @@
   (collect ((res nil adjoin))
     (dolist (rec receivers)
       (dolist (pop (ir2-block-popped (block-info rec)))
-       (do-uses (use pop)
-         (unless (exit-p use)
-           (res (node-block use))))))
+        (do-uses (use pop)
+          (unless (exit-p use)
+            (res (node-block use))))))
     (dolist (dx-lvar dx-lvars)
       (do-uses (use dx-lvar)
         (res (node-block use))))
@@ -293,8 +296,8 @@
 (defun stack-analyze (component)
   (declare (type component component))
   (let* ((2comp (component-info component))
-        (receivers (ir2-component-values-receivers 2comp))
-        (generators (find-pushing-blocks receivers
+         (receivers (ir2-component-values-receivers 2comp))
+         (generators (find-pushing-blocks receivers
                                           (component-dx-lvars component))))
 
     (dolist (block generators)
@@ -311,10 +314,10 @@
 
     (do-blocks (block component)
       (let ((top (ir2-block-end-stack (block-info block))))
-       (dolist (succ (block-succ block))
-         (when (and (block-start succ)
-                    (not (eq (ir2-block-start-stack (block-info succ))
-                             top)))
-           (discard-unused-values block succ))))))
+        (dolist (succ (block-succ block))
+          (when (and (block-start succ)
+                     (not (eq (ir2-block-start-stack (block-info succ))
+                              top)))
+            (discard-unused-values block succ))))))
 
   (values))