0.pre8.100:

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

diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp
index 3550d8f..6aecbcc 100644 (file)
--- a/src/compiler/life.lisp
+++ b/src/compiler/life.lisp
@@ -124,7 +124,7 @@
                  (unless (tn-global-conflicts tn)
                    (convert-to-global tn))
                  (add-global-conflict :read-only tn block ltn-num))
-               
+
                (setf (tn-local tn) block)
                (setf (tn-local-number tn) ltn-num)
                (setf (svref tns ltn-num) tn)
@@ -217,7 +217,7 @@
 ;;; local when we scan the block again.
 ;;;
 ;;; If there are conflicts, then we set LOCAL to one of the
-;;; conflicting blocks. This ensures that Local doesn't hold over
+;;; conflicting blocks. This ensures that LOCAL doesn't hold over
 ;;; BLOCK as its value, causing the subsequent reanalysis to think
 ;;; that the TN has already been seen in that block.
 ;;;
@@ -444,14 +444,16 @@
 (defun convert-to-environment-tn (tn tn-physenv)
   (declare (type tn tn) (type physenv tn-physenv))
   (aver (member (tn-kind tn) '(:normal :debug-environment)))
-  (when (eq (tn-kind tn) :debug-environment)
-    (aver (eq (tn-physenv tn) tn-physenv))
-    (let ((2env (physenv-info tn-physenv)))
-      (setf (ir2-physenv-debug-live-tns 2env)
-           (delete tn (ir2-physenv-debug-live-tns 2env)))))
+  (ecase (tn-kind tn)
+    (:debug-environment
+     (setq tn-physenv (tn-physenv tn))
+     (let* ((2env (physenv-info tn-physenv)))
+       (setf (ir2-physenv-debug-live-tns 2env)
+             (delete tn (ir2-physenv-debug-live-tns 2env)))))
+    (:normal
+     (setf (tn-local tn) nil)
+     (setf (tn-local-number tn) nil)))
   (setup-environment-tn-conflicts *component-being-compiled* tn tn-physenv nil)
-  (setf (tn-local tn) nil)
-  (setf (tn-local-number tn) nil)
   (setf (tn-kind tn) :environment)
   (setf (tn-physenv tn) tn-physenv)
   (push tn (ir2-physenv-live-tns (physenv-info tn-physenv)))
@@ -483,47 +485,41 @@
 ;;; We leave the CURRENT-CONFLICT pointing to the conflict for BLOCK1.
 ;;; The CURRENT-CONFLICT must be initialized to the head of the
 ;;; GLOBAL-CONFLICTS for the TN between each flow analysis iteration.
-;;;
-;;; :DEBUG-ENVIRONMENT TN might be :LIVE before being assigned, so we
-;;; must be careful to not propagate its liveness into another
-;;; environment (see bug 115).
 (defun propagate-live-tns (block1 block2)
   (declare (type ir2-block block1 block2))
   (let ((live-in (ir2-block-live-in block1))
        (did-something nil))
     (do ((conf2 (ir2-block-global-tns block2)
-                (global-conflicts-next-blockwise conf2)))
-        ((null conf2))
-      (let ((tn (global-conflicts-tn conf2)))
-        (unless (and (not (eq (ir2-block-physenv block1) (ir2-block-physenv block2)))
-                     (member (tn-kind tn) '(:environment :debug-environment)))
-          (ecase (global-conflicts-kind conf2)
-            ((:live :read :read-only)
-             (let* ((tn-conflicts (tn-current-conflict tn))
-                    (number1 (ir2-block-number block1)))
-               (aver tn-conflicts)
-               (do ((current tn-conflicts (global-conflicts-next-tnwise current))
-                    (prev nil current))
-                   ((or (null current)
-                        (> (ir2-block-number (global-conflicts-block current))
-                           number1))
-                    (setf (tn-current-conflict tn) prev)
-                    (add-global-conflict :live tn block1 nil)
-                    (setq did-something t))
-                 (when (eq (global-conflicts-block current) block1)
-                   (case (global-conflicts-kind current)
-                     (:live)
-                     (:read-only
-                      (setf (global-conflicts-kind current) :live)
-                      (setf (svref (ir2-block-local-tns block1)
-                                   (global-conflicts-number current))
-                            nil)
-                      (setf (global-conflicts-number current) nil)
-                      (setf (tn-current-conflict tn) current))
-                     (t
-                      (setf (sbit live-in (global-conflicts-number current)) 1)))
-                   (return)))))
-            (:write)))))
+               (global-conflicts-next-blockwise conf2)))
+       ((null conf2))
+      (ecase (global-conflicts-kind conf2)
+       ((:live :read :read-only)
+        (let* ((tn (global-conflicts-tn conf2))
+               (tn-conflicts (tn-current-conflict tn))
+               (number1 (ir2-block-number block1)))
+          (aver tn-conflicts)
+          (do ((current tn-conflicts (global-conflicts-next-tnwise current))
+               (prev nil current))
+              ((or (null current)
+                   (> (ir2-block-number (global-conflicts-block current))
+                      number1))
+               (setf (tn-current-conflict tn) prev)
+               (add-global-conflict :live tn block1 nil)
+               (setq did-something t))
+            (when (eq (global-conflicts-block current) block1)
+              (case (global-conflicts-kind current)
+                (:live)
+                (:read-only
+                 (setf (global-conflicts-kind current) :live)
+                 (setf (svref (ir2-block-local-tns block1)
+                              (global-conflicts-number current))
+                       nil)
+                 (setf (global-conflicts-number current) nil)
+                 (setf (tn-current-conflict tn) current))
+                (t
+                 (setf (sbit live-in (global-conflicts-number current)) 1)))
+              (return)))))
+       (:write)))
     did-something))
 
 ;;; Do backward global flow analysis to find all TNs live at each