0.pre7.113:

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

diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp
index 68469c8..d128011 100644 (file)
--- a/src/compiler/dfo.lisp
+++ b/src/compiler/dfo.lisp
@@ -255,27 +255,44 @@
          (unlink-blocks return-block (component-tail old-lambda-component))))
       (let ((res (find-initial-dfo-aux bind-block component)))
        (declare (type component res))
-       ;; Scavenge call relationships.
-       (let ((calls (if (eq (lambda-kind clambda) :external)
-                        (append (find-reference-funs clambda)
-                                (lambda-calls clambda))
-                        (lambda-calls clambda))))
-         (dolist (call calls)
-           (let ((call-home (lambda-home call)))
-             (setf res (dfo-scavenge-dependency-graph call-home res)))))
-       ;; Scavenge closure-over relationships: if FUN refers to a
-       ;; variable whose home lambda is not FUN, then the home lambda
-       ;; should be in the same component as FUN. (sbcl-0.6.13, and
-       ;; CMU CL, didn't do this, leading to the occasional failure
-       ;; when physenv analysis, which is local to each component,
-       ;; would bogusly conclude that a closed-over variable was
-       ;; unused and thus delete it. See e.g. cmucl-imp 2001-11-29.)
-       (dolist (var (lambda-refers-to-vars clambda))
-         (unless (null (lambda-var-refs var)) ; i.e. unless deleted
-           (let ((var-home-home (lambda-home (lambda-var-home var))))
-             (unless (eql (lambda-kind var-home-home) :deleted)
-               (setf res
-                     (dfo-scavenge-dependency-graph var-home-home res))))))
+       ;; Scavenge related lambdas.
+       (labels ((scavenge-lambda (clambda)
+                  (setf res
+                        (dfo-scavenge-dependency-graph (lambda-home clambda)
+                                                       res)))
+                (scavenge-possibly-deleted-lambda (clambda)
+                  (unless (eql (lambda-kind clambda) :deleted)
+                    (scavenge-lambda clambda)))
+                ;; Scavenge call relationship.
+                (scavenge-call (called-lambda)
+                  (scavenge-lambda called-lambda))
+                ;; Scavenge closure over a variable: if CLAMBDA
+                ;; refers to a variable whose home lambda is not
+                ;; CLAMBDA, then the home lambda should be in the
+                ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
+                ;; CL, didn't do this, leading to the occasional
+                ;; failure when physenv analysis, which is local to
+                ;; each component, would bogusly conclude that a
+                ;; closed-over variable was unused and thus delete
+                ;; it. See e.g. cmucl-imp 2001-11-29.)
+                (scavenge-closure-var (var)
+                  (unless (null (lambda-var-refs var)) ; unless var deleted
+                    (let ((var-home-home (lambda-home (lambda-var-home var))))
+                      (scavenge-possibly-deleted-lambda var-home-home))))
+                ;; Scavenge closure over an entry for nonlocal exit.
+                ;; This is basically parallel to closure over a
+                ;; variable above.
+                (scavenge-entry (entry)
+                  (declare (type entry entry))
+                  (let ((entry-home (node-home-lambda entry)))
+                    (scavenge-possibly-deleted-lambda entry-home))))
+         (dolist (cc (lambda-calls-or-closes clambda))
+           (etypecase cc
+             (clambda (scavenge-call cc))
+             (lambda-var (scavenge-closure-var cc))
+             (entry (scavenge-entry cc))))
+         (when (eq (lambda-kind clambda) :external)
+           (mapc #'scavenge-call (find-reference-funs clambda))))
        ;; Voila.
        res)))))
 
@@ -367,8 +384,7 @@
     ;; initial component tail (due NIL function terminated blocks)
     ;; are moved to the appropriate new component tail.
     (dolist (toplevel-lambda toplevel-lambdas)
-      (let* ((block (lambda-block toplevel-lambda))
-            (old-component (block-component block))
+      (let* ((old-component (lambda-component toplevel-lambda))
             (old-component-lambdas (component-lambdas old-component))
             (new-component nil))
        (aver (member toplevel-lambda old-component-lambdas))