X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flife.lisp;h=9d28fbdfc5b92a30eb97e24f27bb8d37a35f022b;hb=debae3c18d31b5222be4d5de8dcb2601336e24a4;hp=7c2a90307e5111f5ab417a0dd096536ceb67798a;hpb=581e3d62de8cb37e13ad9db63e5537c0f962be28;p=sbcl.git

diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp
index 7c2a903..9d28fbd 100644
--- a/src/compiler/life.lisp
+++ b/src/compiler/life.lisp
@@ -22,17 +22,17 @@
 ;;; block in order to keep that thread sorted.
 (defun add-global-conflict (kind tn block number)
   (declare (type (member :read :write :read-only :live) kind)
-	   (type tn tn) (type ir2-block block)
-	   (type (or local-tn-number null) number))
+           (type tn tn) (type ir2-block block)
+           (type (or local-tn-number null) number))
   (let ((new (make-global-conflicts kind tn block number)))
     (let ((last (tn-current-conflict tn)))
       (if last
-	  (shiftf (global-conflicts-next-tnwise new)
-		  (global-conflicts-next-tnwise last)
-		  new)
-	  (shiftf (global-conflicts-next-tnwise new)
-		  (tn-global-conflicts tn)
-		  new)))
+          (shiftf (global-conflicts-next-tnwise new)
+                  (global-conflicts-next-tnwise last)
+                  new)
+          (shiftf (global-conflicts-next-tnwise new)
+                  (tn-global-conflicts tn)
+                  new)))
     (setf (tn-current-conflict tn) new)
 
     (insert-block-global-conflict new block))
@@ -43,14 +43,14 @@
 (defun insert-block-global-conflict (new block)
   (let ((global-num (tn-number (global-conflicts-tn new))))
     (do ((prev nil conf)
-	 (conf (ir2-block-global-tns block)
-	       (global-conflicts-next-blockwise conf)))
-	((or (null conf)
-	     (> (tn-number (global-conflicts-tn conf)) global-num))
-	 (if prev
-	     (setf (global-conflicts-next-blockwise prev) new)
-	     (setf (ir2-block-global-tns block) new))
-	 (setf (global-conflicts-next-blockwise new) conf))))
+         (conf (ir2-block-global-tns block)
+               (global-conflicts-next-blockwise conf)))
+        ((or (null conf)
+             (> (tn-number (global-conflicts-tn conf)) global-num))
+         (if prev
+             (setf (global-conflicts-next-blockwise prev) new)
+             (setf (ir2-block-global-tns block) new))
+         (setf (global-conflicts-next-blockwise new) conf))))
   (values))
 
 ;;; Reset the CURRENT-CONFLICT slot in all packed TNs to point to the
@@ -58,6 +58,20 @@
 (defun reset-current-conflict (component)
   (do-packed-tns (tn component)
     (setf (tn-current-conflict tn) (tn-global-conflicts tn))))
+
+;;; Cache the results of BLOCK-PHYSENV during lifetime analysis.
+;;;
+;;; Fetching the home-lambda of a block (needed in block-physenv) can
+;;; be an expensive operation under some circumstances, and it needs
+;;; to be done a lot during lifetime analysis when compiling with high
+;;; DEBUG (e.g. 30% of the total compilation time for CL-PPCRE with
+;;; DEBUG 3 just for that).
+(defun cached-block-physenv (block)
+  (let ((physenv (block-physenv-cache block)))
+    (if (eq physenv :none)
+        (setf (block-physenv-cache block)
+              (block-physenv block))
+        physenv)))
 
 ;;;; pre-pass
 
@@ -68,13 +82,13 @@
 (defun convert-to-global (tn)
   (declare (type tn tn))
   (let ((block (tn-local tn))
-	(num (tn-local-number tn)))
+        (num (tn-local-number tn)))
     (add-global-conflict
      (if (zerop (sbit (ir2-block-written block) num))
-	 :read-only
-	 (if (zerop (sbit (ir2-block-live-out block) num))
-	     :write
-	     :read))
+         :read-only
+         (if (zerop (sbit (ir2-block-live-out block) num))
+             :write
+             :read))
      tn block num))
   (values))
 
@@ -105,35 +119,35 @@
 (defun find-local-references (block)
   (declare (type ir2-block block))
   (let ((kill (ir2-block-written block))
-	(live (ir2-block-live-out block))
-	(tns (ir2-block-local-tns block)))
+        (live (ir2-block-live-out block))
+        (tns (ir2-block-local-tns block)))
     (let ((ltn-num (ir2-block-local-tn-count block)))
       (do ((vop (ir2-block-last-vop block)
-		(vop-prev vop)))
-	  ((null vop))
-	(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
-	    ((null ref))
-	  (let* ((tn (tn-ref-tn ref))
-		 (local (tn-local tn))
-		 (kind (tn-kind tn)))
-	    (unless (member kind '(:component :environment :constant))
-	      (unless (eq local block)
-		(when (= ltn-num local-tn-limit)
-		  (return-from find-local-references vop))
-		(when local
-		  (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)
-		(incf ltn-num))
-
-	      (let ((num (tn-local-number tn)))
-		(if (tn-ref-write-p ref)
-		    (setf (sbit kill num) 1  (sbit live num) 0)
-		    (setf (sbit live num) 1)))))))
+                (vop-prev vop)))
+          ((null vop))
+        (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
+            ((null ref))
+          (let* ((tn (tn-ref-tn ref))
+                 (local (tn-local tn))
+                 (kind (tn-kind tn)))
+            (unless (member kind '(:component :environment :constant))
+              (unless (eq local block)
+                (when (= ltn-num local-tn-limit)
+                  (return-from find-local-references vop))
+                (when local
+                  (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)
+                (incf ltn-num))
+
+              (let ((num (tn-local-number tn)))
+                (if (tn-ref-write-p ref)
+                    (setf (sbit kill num) 1  (sbit live num) 0)
+                    (setf (sbit live num) 1)))))))
 
       (setf (ir2-block-local-tn-count block) ltn-num)))
   nil)
@@ -158,22 +172,22 @@
   (let ((live (ir2-block-live-out block)))
     (let ((kill (ir2-block-written block)))
       (do ((conf (ir2-block-global-tns block)
-		 (global-conflicts-next-blockwise conf)))
-	  ((null conf))
-	(let ((num (global-conflicts-number conf)))
-	  (unless (zerop (sbit kill num))
-	    (setf (global-conflicts-kind conf)
-		  (if (zerop (sbit live num))
-		      :write
-		      :read))))))
+                 (global-conflicts-next-blockwise conf)))
+          ((null conf))
+        (let ((num (global-conflicts-number conf)))
+          (unless (zerop (sbit kill num))
+            (setf (global-conflicts-kind conf)
+                  (if (zerop (sbit live num))
+                      :write
+                      :read))))))
 
     (let ((ltns (ir2-block-local-tns block)))
       (dotimes (i (ir2-block-local-tn-count block))
-	(let ((tn (svref ltns i)))
-	  (unless (or (eq tn :more)
-		      (tn-global-conflicts tn)
-		      (zerop (sbit live i)))
-	    (convert-to-global tn))))))
+        (let ((tn (svref ltns i)))
+          (unless (or (eq tn :more)
+                      (tn-global-conflicts tn)
+                      (zerop (sbit live i)))
+            (convert-to-global tn))))))
 
   (values))
 
@@ -185,15 +199,15 @@
 ;;; block.
 (defun split-ir2-blocks (2block lose number)
   (declare (type ir2-block 2block) (type vop lose)
-	   (type unsigned-byte number))
+           (type unsigned-byte number))
   (event split-ir2-block (vop-node lose))
   (let ((new (make-ir2-block (ir2-block-block 2block)))
-	(new-start (vop-next lose)))
+        (new-start (vop-next lose)))
     (setf (ir2-block-number new) number)
     (add-to-emit-order new 2block)
 
     (do ((vop new-start (vop-next vop)))
-	((null vop))
+        ((null vop))
       (setf (vop-block vop) new))
 
     (setf (ir2-block-start-vop new) new-start)
@@ -217,7 +231,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.
 ;;;
@@ -227,31 +241,31 @@
   (setf (ir2-block-local-tn-count block) 0)
 
   (do ((conf (ir2-block-global-tns block)
-	     (global-conflicts-next-blockwise conf)))
+             (global-conflicts-next-blockwise conf)))
       ((null conf)
        (setf (ir2-block-global-tns block) nil))
     (let ((tn (global-conflicts-tn conf)))
       (aver (eq (tn-current-conflict tn) conf))
       (aver (null (global-conflicts-next-tnwise conf)))
       (do ((current (tn-global-conflicts tn)
-		    (global-conflicts-next-tnwise current))
-	   (prev nil current))
-	  ((eq current conf)
-	   (if prev
-	       (setf (global-conflicts-next-tnwise prev) nil)
-	       (setf (tn-global-conflicts tn) nil))
-	   (setf (tn-current-conflict tn) prev)))))
+                    (global-conflicts-next-tnwise current))
+           (prev nil current))
+          ((eq current conf)
+           (if prev
+               (setf (global-conflicts-next-tnwise prev) nil)
+               (setf (tn-global-conflicts tn) nil))
+           (setf (tn-current-conflict tn) prev)))))
 
   (fill (ir2-block-written block) 0)
   (let ((ltns (ir2-block-local-tns block)))
     (dotimes (i local-tn-limit)
       (let ((tn (svref ltns i)))
-	(aver (not (eq tn :more)))
-	(let ((conf (tn-global-conflicts tn)))
-	  (setf (tn-local tn)
-		(if conf
-		    (global-conflicts-block conf)
-		    nil))))))
+        (aver (not (eq tn :more)))
+        (let ((conf (tn-global-conflicts tn)))
+          (setf (tn-local tn)
+                (if conf
+                    (global-conflicts-block conf)
+                    nil))))))
 
   (values))
 
@@ -290,28 +304,28 @@
     (setf (svref (ir2-block-local-tns block) num) :more)
 
     (do ((op (do ((op ops (tn-ref-across op))
-		  (i 0 (1+ i)))
-		 ((= i (length fixed)) op)
-	       (declare (type index i)))
-	     (tn-ref-across op)))
-	((null op))
+                  (i 0 (1+ i)))
+                 ((= i (length fixed)) op)
+               (declare (type index i)))
+             (tn-ref-across op)))
+        ((null op))
       (let ((tn (tn-ref-tn op)))
-	(assert
-	  (flet ((frob (refs)
-		   (do ((ref refs (tn-ref-next ref)))
-		       ((null ref) t)
-		     (when (and (eq (vop-block (tn-ref-vop ref)) block)
-				(not (eq ref op)))
-		       (return nil)))))
-	    (and (frob (tn-reads tn)) (frob (tn-writes tn))))
-	  () "More operand ~S used more than once in its VOP." op)
-	(aver (not (find-in #'global-conflicts-next-blockwise tn
-			    (ir2-block-global-tns block)
-			    :key #'global-conflicts-tn)))
-
-	(add-global-conflict :read-only tn block num)
-	(setf (tn-local tn) block)
-	(setf (tn-local-number tn) num))))
+        (assert
+          (flet ((frob (refs)
+                   (do ((ref refs (tn-ref-next ref)))
+                       ((null ref) t)
+                     (when (and (eq (vop-block (tn-ref-vop ref)) block)
+                                (not (eq ref op)))
+                       (return nil)))))
+            (and (frob (tn-reads tn)) (frob (tn-writes tn))))
+          () "More operand ~S used more than once in its VOP." op)
+        (aver (not (find-in #'global-conflicts-next-blockwise tn
+                            (ir2-block-global-tns block)
+                            :key #'global-conflicts-tn)))
+
+        (add-global-conflict :read-only tn block num)
+        (setf (tn-local tn) block)
+        (setf (tn-local-number tn) num))))
   (values))
 
 (defevent coalesce-more-ltn-numbers
@@ -343,38 +357,38 @@
     (declare (type fixnum counter))
     (do-blocks-backwards (block component)
       (let ((2block (block-info block)))
-	(do ((lose (find-local-references 2block)
-		   (find-local-references 2block))
-	     (last-lose nil lose)
-	     (coalesced nil))
-	    ((not lose)
-	     (init-global-conflict-kind 2block)
-	     (setf (ir2-block-number 2block) (incf counter)))
-
-	  (clear-lifetime-info 2block)
-
-	  (cond
-	   ((vop-next lose)
-	    (aver (not (eq last-lose lose)))
-	    (let ((new (split-ir2-blocks 2block lose (incf counter))))
-	      (aver (not (find-local-references new)))
-	      (init-global-conflict-kind new)))
-	   (t
-	    (aver (not (eq lose coalesced)))
-	    (setq coalesced lose)
-	    (event coalesce-more-ltn-numbers (vop-node lose))
-	    (let ((info (vop-info lose))
-		  (new (if (vop-prev lose)
-			   (split-ir2-blocks 2block (vop-prev lose)
-					     (incf counter))
-			   2block)))
-	      (coalesce-more-ltn-numbers new (vop-args lose)
-					 (vop-info-arg-types info))
-	      (coalesce-more-ltn-numbers new (vop-results lose)
-					 (vop-info-result-types info))
-	      (let ((lose (find-local-references new)))
-		(aver (not lose)))
-	      (init-global-conflict-kind new))))))))
+        (do ((lose (find-local-references 2block)
+                   (find-local-references 2block))
+             (last-lose nil lose)
+             (coalesced nil))
+            ((not lose)
+             (init-global-conflict-kind 2block)
+             (setf (ir2-block-number 2block) (incf counter)))
+
+          (clear-lifetime-info 2block)
+
+          (cond
+           ((vop-next lose)
+            (aver (not (eq last-lose lose)))
+            (let ((new (split-ir2-blocks 2block lose (incf counter))))
+              (aver (not (find-local-references new)))
+              (init-global-conflict-kind new)))
+           (t
+            (aver (not (eq lose coalesced)))
+            (setq coalesced lose)
+            (event coalesce-more-ltn-numbers (vop-node lose))
+            (let ((info (vop-info lose))
+                  (new (if (vop-prev lose)
+                           (split-ir2-blocks 2block (vop-prev lose)
+                                             (incf counter))
+                           2block)))
+              (coalesce-more-ltn-numbers new (vop-args lose)
+                                         (vop-info-arg-types info))
+              (coalesce-more-ltn-numbers new (vop-results lose)
+                                         (vop-info-result-types info))
+              (let ((lose (find-local-references new)))
+                (aver (not lose)))
+              (init-global-conflict-kind new))))))))
 
   (values))
 
@@ -387,43 +401,71 @@
   (declare (type tn tn) (type ir2-block 2block))
   (let ((block-num (ir2-block-number 2block)))
     (do ((conf (tn-current-conflict tn) (global-conflicts-next-tnwise conf))
-	 (prev nil conf))
-	((or (null conf)
-	     (> (ir2-block-number (global-conflicts-block conf)) block-num))
-	 (setf (tn-current-conflict tn) prev)
-	 (add-global-conflict :live tn 2block nil))
+         (prev nil conf))
+        ((or (null conf)
+             (> (ir2-block-number (global-conflicts-block conf)) block-num))
+         (setf (tn-current-conflict tn) prev)
+         (add-global-conflict :live tn 2block nil))
       (when (eq (global-conflicts-block conf) 2block)
-	(unless (or debug-p
-		    (eq (global-conflicts-kind conf) :live))
-	  (setf (global-conflicts-kind conf) :live)
-	  (setf (svref (ir2-block-local-tns 2block)
-		       (global-conflicts-number conf))
-		nil)
-	  (setf (global-conflicts-number conf) nil))
-	(setf (tn-current-conflict tn) conf)
-	(return))))
+        (unless (or debug-p
+                    (eq (global-conflicts-kind conf) :live))
+          (setf (global-conflicts-kind conf) :live)
+          (setf (svref (ir2-block-local-tns 2block)
+                       (global-conflicts-number conf))
+                nil)
+          (setf (global-conflicts-number conf) nil))
+        (setf (tn-current-conflict tn) conf)
+        (return))))
   (values))
 
+;;; Return true if TN represents a closed-over variable with an
+;;; "implicit" value-cell.
+(defun implicit-value-cell-tn-p (tn)
+  (let ((leaf (tn-leaf tn)))
+    (and (lambda-var-p leaf)
+         (lambda-var-indirect leaf)
+         (not (lambda-var-explicit-value-cell leaf)))))
+
+;;; If BLOCK ends with a TAIL LOCAL COMBINATION, the function called.
+;;; Otherwise, NIL.
+(defun block-tail-local-call-fun (block)
+  (let ((node (block-last block)))
+    (when (and (combination-p node)
+               (eq :local (combination-kind node))
+               (combination-tail-p node))
+      (ref-leaf (lvar-uses (combination-fun node))))))
+
 ;;; Iterate over all the blocks in ENV, setting up :LIVE conflicts for
 ;;; TN. We make the TN global if it isn't already. The TN must have at
 ;;; least one reference.
-(defun setup-environment-tn-conflicts (component tn env debug-p)
-  (declare (type component component) (type tn tn) (type physenv env))
+(defun setup-environment-tn-conflicts (component tn env debug-p &optional parent-envs)
+  (declare (type component component) (type tn tn) (type physenv env) (type list parent-envs))
+  (when (member env parent-envs)
+    ;; Prevent infinite recursion due to recursive tail calls.
+    (return-from setup-environment-tn-conflicts (values)))
   (when (and debug-p
-	     (not (tn-global-conflicts tn))
-	     (tn-local tn))
+             (not (tn-global-conflicts tn))
+             (tn-local tn))
     (convert-to-global tn))
   (setf (tn-current-conflict tn) (tn-global-conflicts tn))
   (do-blocks-backwards (block component)
-    (when (eq (block-physenv block) env)
+    (when (eq (cached-block-physenv block) env)
       (let* ((2block (block-info block))
-	     (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
-			(prev 2block b))
-		       ((not (eq (ir2-block-block b) block))
-			prev))))
-	(do ((b last (ir2-block-prev b)))
-	    ((not (eq (ir2-block-block b) block)))
-	  (setup-environment-tn-conflict tn b debug-p)))))
+             (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
+                        (prev 2block b))
+                       ((not (eq (ir2-block-block b) block))
+                        prev))))
+        (do ((b last (ir2-block-prev b)))
+            ((not (eq (ir2-block-block b) block)))
+          (setup-environment-tn-conflict tn b debug-p)))
+      ;; If BLOCK ends with a TAIL LOCAL COMBINATION and TN is an
+      ;; "implicit value cell" then setup conflicts for the callee
+      ;; function as well.
+      (let ((fun (and (implicit-value-cell-tn-p tn)
+                      (block-tail-local-call-fun block))))
+        (when fun
+          (setup-environment-tn-conflicts component tn (lambda-physenv fun) debug-p
+                                          (list* env parent-envs))))))
   (values))
 
 ;;; Iterate over all the environment TNs, adding always-live conflicts
@@ -432,29 +474,31 @@
   (declare (type component component))
   (dolist (fun (component-lambdas component))
     (let* ((env (lambda-physenv fun))
-	   (2env (physenv-info env)))
+           (2env (physenv-info env)))
       (dolist (tn (ir2-physenv-live-tns 2env))
-	(setup-environment-tn-conflicts component tn env nil))
+        (setup-environment-tn-conflicts component tn env nil))
       (dolist (tn (ir2-physenv-debug-live-tns 2env))
-	(setup-environment-tn-conflicts component tn env t))))
+        (setup-environment-tn-conflicts component tn env t))))
   (values))
 
 ;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN.
-;;; This requires adding :LIVE conflicts to all blocks in TN-ENV.
-(defun convert-to-environment-tn (tn tn-env)
-  (declare (type tn tn) (type physenv tn-env))
+;;; This requires adding :LIVE conflicts to all blocks in TN-PHYSENV.
+(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-env))
-    (let ((2env (physenv-info tn-env)))
-      (setf (ir2-physenv-debug-live-tns 2env)
-	    (delete tn (ir2-physenv-debug-live-tns 2env)))))
-  (setup-environment-tn-conflicts *component-being-compiled* tn tn-env nil)
-  (setf (tn-local tn) nil)
-  (setf (tn-local-number tn) nil)
+  (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-kind tn) :environment)
-  (setf (tn-physenv tn) tn-env)
-  (push tn (ir2-physenv-live-tns (physenv-info tn-env)))
+  (setf (tn-physenv tn) tn-physenv)
+  (push tn (ir2-physenv-live-tns (physenv-info tn-physenv)))
   (values))
 
 ;;;; flow analysis
@@ -483,66 +527,83 @@
 ;;; 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.
-(defun propagate-live-tns (block1 block2)
+
+;;; FASTP is a KLUDGE: SBCL used to update the current-conflict only
+;;; for the read-only case, but switched at one point to always
+;;; updating it. This generally speeds up the compiler nicely, but
+;;; sometimes it causes an infinite loop in the updating machinery,
+;;; We cheat by switching of the fast path if it seems we're looping
+;;; longer then expected.
+(defun propagate-live-tns (block1 block2 fastp)
   (declare (type ir2-block block1 block2))
   (let ((live-in (ir2-block-live-in block1))
-	(did-something nil))
+        (did-something nil))
     (do ((conf2 (ir2-block-global-tns block2)
-		(global-conflicts-next-blockwise conf2)))
-	((null conf2))
+                (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)))
+        ((: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)
+                  (unless fastp
+                    (setf (tn-current-conflict tn) current)))
+                 (t
+                  (setf (sbit live-in (global-conflicts-number current)) 1)))
+               (when fastp
+                 (setf (tn-current-conflict tn) current))
+               (return)))))
+        (:write)))
     did-something))
 
 ;;; Do backward global flow analysis to find all TNs live at each
 ;;; block boundary.
 (defun lifetime-flow-analysis (component)
-  (loop
+  ;; KLUDGE: This is the second part of the FASTP kludge in
+  ;; propagate-live-tns: we pass fastp for ten first attempts,
+  ;; and then switch to the works-for-sure version.
+  ;;
+  ;; The upstream uses the fast version always, but sometimes
+  ;; that gets stuck in a loop...
+  (loop for i = 0 then (1+ i)
+        do
     (reset-current-conflict component)
     (let ((did-something nil))
       (do-blocks-backwards (block component)
-	(let* ((2block (block-info block))
-	       (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
-			  (prev 2block b))
-			 ((not (eq (ir2-block-block b) block))
-			  prev))))
-
-	  (dolist (b (block-succ block))
-	    (when (and (block-start b)
-		       (propagate-live-tns last (block-info b)))
-	      (setq did-something t)))
-
-	  (do ((b (ir2-block-prev last) (ir2-block-prev b))
-	       (prev last b))
-	      ((not (eq (ir2-block-block b) block)))
-	    (when (propagate-live-tns b prev)
-	      (setq did-something t)))))
+        (let* ((2block (block-info block))
+               (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
+                          (prev 2block b))
+                         ((not (eq (ir2-block-block b) block))
+                          prev))))
+
+          (dolist (b (block-succ block))
+            (when (and (block-start b)
+                       (propagate-live-tns last (block-info b) (< i 10)))
+              (setq did-something t)))
+
+          (do ((b (ir2-block-prev last) (ir2-block-prev b))
+               (prev last b))
+              ((not (eq (ir2-block-block b) block)))
+            (when (propagate-live-tns b prev (< i 10))
+              (setq did-something t)))))
 
       (unless did-something (return))))
 
@@ -555,8 +616,8 @@
 ;;; number in the conflicts of all TNs in LIVE-LIST.
 (defun note-conflicts (live-bits live-list tn num)
   (declare (type tn tn) (type (or tn null) live-list)
-	   (type local-tn-bit-vector live-bits)
-	   (type local-tn-number num))
+           (type local-tn-bit-vector live-bits)
+           (type local-tn-number num))
   (let ((lconf (tn-local-conflicts tn)))
     (bit-ior live-bits lconf lconf))
   (do ((live live-list (tn-next* live)))
@@ -569,12 +630,12 @@
   (declare (type vop vop) (type local-tn-bit-vector live-bits))
   (let ((live (bit-vector-copy live-bits)))
     (do ((r (vop-results vop) (tn-ref-across r)))
-	((null r))
+        ((null r))
       (let ((tn (tn-ref-tn r)))
-	(ecase (tn-kind tn)
-	  ((:normal :debug-environment)
-	   (setf (sbit live (tn-local-number tn)) 0))
-	  (:environment :component))))
+        (ecase (tn-kind tn)
+          ((:normal :debug-environment)
+           (setf (sbit live (tn-local-number tn)) 0))
+          (:environment :component))))
     live))
 
 ;;; This is used to determine whether a :DEBUG-ENVIRONMENT TN should
@@ -597,27 +658,27 @@
 ;;; well.
 (defun make-debug-environment-tns-live (block live-bits live-list)
   (let* ((1block (ir2-block-block block))
-	 (live-in (ir2-block-live-in block))
-	 (succ (block-succ 1block))
-	 (next (ir2-block-next block)))
+         (live-in (ir2-block-live-in block))
+         (succ (block-succ 1block))
+         (next (ir2-block-next block)))
     (when (and next
-	       (not (eq (ir2-block-block next) 1block))
-	       (or (null succ)
-		   (eq (first succ)
-		       (component-tail (block-component 1block)))))
+               (not (eq (ir2-block-block next) 1block))
+               (or (null succ)
+                   (eq (first succ)
+                       (component-tail (block-component 1block)))))
       (do ((conf (ir2-block-global-tns block)
-		 (global-conflicts-next-blockwise conf)))
-	  ((null conf))
-	(let* ((tn (global-conflicts-tn conf))
-	       (num (global-conflicts-number conf)))
-	  (when (and num (zerop (sbit live-bits num))
-		     (eq (tn-kind tn) :debug-environment)
-		     (eq (tn-physenv tn) (block-physenv 1block))
-		     (saved-after-read tn block))
-	    (note-conflicts live-bits live-list tn num)
-	    (setf (sbit live-bits num) 1)
-	    (push-in tn-next* tn live-list)
-	    (setf (sbit live-in num) 1))))))
+                 (global-conflicts-next-blockwise conf)))
+          ((null conf))
+        (let* ((tn (global-conflicts-tn conf))
+               (num (global-conflicts-number conf)))
+          (when (and num (zerop (sbit live-bits num))
+                     (eq (tn-kind tn) :debug-environment)
+                     (eq (tn-physenv tn) (cached-block-physenv 1block))
+                     (saved-after-read tn block))
+            (note-conflicts live-bits live-list tn num)
+            (setf (sbit live-bits num) 1)
+            (push-in tn-next* tn live-list)
+            (setf (sbit live-in num) 1))))))
 
   (values live-bits live-list))
 
@@ -641,31 +702,31 @@
 (defun compute-initial-conflicts (block)
   (declare (type ir2-block block))
   (let* ((live-in (ir2-block-live-in block))
-	 (ltns (ir2-block-local-tns block))
-	 (live-bits (bit-vector-copy live-in))
-	 (live-list nil))
+         (ltns (ir2-block-local-tns block))
+         (live-bits (bit-vector-copy live-in))
+         (live-list nil))
 
     (do ((conf (ir2-block-global-tns block)
-	       (global-conflicts-next-blockwise conf)))
-	((null conf))
+               (global-conflicts-next-blockwise conf)))
+        ((null conf))
       (let ((bits (global-conflicts-conflicts conf))
-	    (tn (global-conflicts-tn conf))
-	    (num (global-conflicts-number conf))
-	    (kind (global-conflicts-kind conf)))
-	(setf (tn-local-number tn) num)
-	(unless (eq kind :live)
-	  (cond ((not (zerop (sbit live-bits num)))
-		 (bit-vector-replace bits live-bits)
-		 (setf (sbit bits num) 0)
-		 (push-in tn-next* tn live-list))
-		((and (eq (svref ltns num) :more)
-		      (eq kind :write))
-		 (note-conflicts live-bits live-list tn num)
-		 (setf (sbit live-bits num) 1)
-		 (push-in tn-next* tn live-list)
-		 (setf (sbit live-in num) 1)))
-
-	  (setf (tn-local-conflicts tn) bits))))
+            (tn (global-conflicts-tn conf))
+            (num (global-conflicts-number conf))
+            (kind (global-conflicts-kind conf)))
+        (setf (tn-local-number tn) num)
+        (unless (eq kind :live)
+          (cond ((not (zerop (sbit live-bits num)))
+                 (bit-vector-replace bits live-bits)
+                 (setf (sbit bits num) 0)
+                 (push-in tn-next* tn live-list))
+                ((and (eq (svref ltns num) :more)
+                      (eq kind :write))
+                 (note-conflicts live-bits live-list tn num)
+                 (setf (sbit live-bits num) 1)
+                 (push-in tn-next* tn live-list)
+                 (setf (sbit live-in num) 1)))
+
+          (setf (tn-local-conflicts tn) bits))))
 
     (make-debug-environment-tns-live block live-bits live-list)))
 
@@ -674,17 +735,17 @@
 ;;; force all the live TNs to be stack environment TNs.
 (defun conflictize-save-p-vop (vop block live-bits)
   (declare (type vop vop) (type ir2-block block)
-	   (type local-tn-bit-vector live-bits))
+           (type local-tn-bit-vector live-bits))
   (let ((ss (compute-save-set vop live-bits)))
     (setf (vop-save-set vop) ss)
     (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
       (do-live-tns (tn ss block)
-	(unless (eq (tn-kind tn) :component)
-	  (force-tn-to-stack tn)
-	  (unless (eq (tn-kind tn) :environment)
-	    (convert-to-environment-tn
-	     tn
-	     (block-physenv (ir2-block-block block))))))))
+        (unless (eq (tn-kind tn) :component)
+          (force-tn-to-stack tn)
+          (unless (eq (tn-kind tn) :environment)
+            (convert-to-environment-tn
+             tn
+             (cached-block-physenv (ir2-block-block block))))))))
   (values))
 
 ;;; FIXME: The next 3 macros aren't needed in the target runtime.
@@ -705,12 +766,12 @@
   `(when (eq (svref ltns num) :more)
      (let ((prev ref))
        (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
-	   ((null mref))
-	 (let ((mtn (tn-ref-tn mref)))
-	   (unless (eql (tn-local-number mtn) num)
-	     (return))
-	   ,action)
-	 (setq prev mref))
+           ((null mref))
+         (let ((mtn (tn-ref-tn mref)))
+           (unless (eql (tn-local-number mtn) num)
+             (return))
+           ,action)
+         (setq prev mref))
        (setq ref prev))))
 
 ;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs
@@ -720,21 +781,21 @@
   '(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
        ((null ref))
      (let* ((tn (tn-ref-tn ref))
-	    (num (tn-local-number tn)))
+            (num (tn-local-number tn)))
        (cond
-	((not num))
-	((not (zerop (sbit live-bits num)))
-	 (when (tn-ref-write-p ref)
-	   (setf (sbit live-bits num) 0)
-	   (deletef-in tn-next* live-list tn)
-	   (frob-more-tns (deletef-in tn-next* live-list mtn))))
-	(t
-	 (aver (not (tn-ref-write-p ref)))
-	 (note-conflicts live-bits live-list tn num)
-	 (frob-more-tns (note-conflicts live-bits live-list mtn num))
-	 (setf (sbit live-bits num) 1)
-	 (push-in tn-next* tn live-list)
-	 (frob-more-tns (push-in tn-next* mtn live-list)))))))
+        ((not num))
+        ((not (zerop (sbit live-bits num)))
+         (when (tn-ref-write-p ref)
+           (setf (sbit live-bits num) 0)
+           (deletef-in tn-next* live-list tn)
+           (frob-more-tns (deletef-in tn-next* live-list mtn))))
+        (t
+         (aver (not (tn-ref-write-p ref)))
+         (note-conflicts live-bits live-list tn num)
+         (frob-more-tns (note-conflicts live-bits live-list mtn num))
+         (setf (sbit live-bits num) 1)
+         (push-in tn-next* tn live-list)
+         (frob-more-tns (push-in tn-next* mtn live-list)))))))
 
 ;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the
 ;;; current VOP's results, and make any dead ones live. This is
@@ -747,12 +808,12 @@
   '(do ((res (vop-results vop) (tn-ref-across res)))
        ((null res))
      (let* ((tn (tn-ref-tn res))
-	    (num (tn-local-number tn)))
+            (num (tn-local-number tn)))
        (when (and num (zerop (sbit live-bits num)))
-	 (unless (eq (svref ltns num) :more)
-	   (note-conflicts live-bits live-list tn num)
-	   (setf (sbit live-bits num) 1)
-	   (push-in tn-next* tn live-list))))))
+         (unless (eq (svref ltns num) :more)
+           (note-conflicts live-bits live-list tn num)
+           (setf (sbit live-bits num) 1)
+           (push-in tn-next* tn live-list))))))
 
 ;;; Compute the block-local conflict information for BLOCK. We iterate
 ;;; over all the TN-REFs in a block in reference order, maintaining
@@ -764,12 +825,12 @@
       (compute-initial-conflicts block)
     (let ((ltns (ir2-block-local-tns block)))
       (do ((vop (ir2-block-last-vop block)
-		(vop-prev vop)))
-	  ((null vop))
-	(when (vop-info-save-p (vop-info vop))
-	  (conflictize-save-p-vop vop block live-bits))
-	(ensure-results-live)
-	(scan-vop-refs)))))
+                (vop-prev vop)))
+          ((null vop))
+        (when (vop-info-save-p (vop-info vop))
+          (conflictize-save-p-vop vop block live-bits))
+        (ensure-results-live)
+        (scan-vop-refs)))))
 
 ;;; Conflict analyze each block, and also add it.
 (defun lifetime-post-pass (component)
@@ -783,11 +844,11 @@
 (defun merge-alias-block-conflicts (conf oconf)
   (declare (type global-conflicts conf oconf))
   (let* ((kind (global-conflicts-kind conf))
-	 (num (global-conflicts-number conf))
-	 (okind (global-conflicts-kind oconf))
-	 (onum (global-conflicts-number oconf))
-	 (block (global-conflicts-block oconf))
-	 (ltns (ir2-block-local-tns block)))
+         (num (global-conflicts-number conf))
+         (okind (global-conflicts-kind oconf))
+         (onum (global-conflicts-number oconf))
+         (block (global-conflicts-block oconf))
+         (ltns (ir2-block-local-tns block)))
     (cond
      ((eq okind :live))
      ((eq kind :live)
@@ -796,43 +857,43 @@
       (setf (global-conflicts-number oconf) nil))
      (t
       (unless (eq kind okind)
-	(setf (global-conflicts-kind oconf) :read))
+        (setf (global-conflicts-kind oconf) :read))
       ;; Make original conflict with all the local TNs the alias
       ;; conflicted with.
       (bit-ior (global-conflicts-conflicts oconf)
-	       (global-conflicts-conflicts conf)
-	       t)
+               (global-conflicts-conflicts conf)
+               t)
       (flet ((frob (x)
-	       (unless (zerop (sbit x num))
-		 (setf (sbit x onum) 1))))
-	;; Make all the local TNs that conflicted with the alias
-	;; conflict with the original.
-	(dotimes (i (ir2-block-local-tn-count block))
-	  (let ((tn (svref ltns i)))
-	    (when (and tn (not (eq tn :more))
-		       (null (tn-global-conflicts tn)))
-	      (frob (tn-local-conflicts tn)))))
-	;; Same for global TNs...
-	(do ((current (ir2-block-global-tns block)
-		      (global-conflicts-next-blockwise current)))
-	    ((null current))
-	  (unless (eq (global-conflicts-kind current) :live)
-	    (frob (global-conflicts-conflicts current))))
-	;; Make the original TN live everywhere that the alias was live.
-	(frob (ir2-block-written block))
-	(frob (ir2-block-live-in block))
-	(frob (ir2-block-live-out block))
-	(do ((vop (ir2-block-start-vop block)
-		  (vop-next vop)))
-	    ((null vop))
-	  (let ((sset (vop-save-set vop)))
-	    (when sset (frob sset)))))))
+               (unless (zerop (sbit x num))
+                 (setf (sbit x onum) 1))))
+        ;; Make all the local TNs that conflicted with the alias
+        ;; conflict with the original.
+        (dotimes (i (ir2-block-local-tn-count block))
+          (let ((tn (svref ltns i)))
+            (when (and tn (not (eq tn :more))
+                       (null (tn-global-conflicts tn)))
+              (frob (tn-local-conflicts tn)))))
+        ;; Same for global TNs...
+        (do ((current (ir2-block-global-tns block)
+                      (global-conflicts-next-blockwise current)))
+            ((null current))
+          (unless (eq (global-conflicts-kind current) :live)
+            (frob (global-conflicts-conflicts current))))
+        ;; Make the original TN live everywhere that the alias was live.
+        (frob (ir2-block-written block))
+        (frob (ir2-block-live-in block))
+        (frob (ir2-block-live-out block))
+        (do ((vop (ir2-block-start-vop block)
+                  (vop-next vop)))
+            ((null vop))
+          (let ((sset (vop-save-set vop)))
+            (when sset (frob sset)))))))
     ;; Delete the alias's conflict info.
     (when num
       (setf (svref ltns num) nil))
     (deletef-in global-conflicts-next-blockwise
-		(ir2-block-global-tns block)
-		conf))
+                (ir2-block-global-tns block)
+                conf))
 
   (values))
 
@@ -841,10 +902,10 @@
   (declare (type global-conflicts conf) (type tn new))
   (setf (global-conflicts-tn conf) new)
   (let ((ltn-num (global-conflicts-number conf))
-	(block (global-conflicts-block conf)))
+        (block (global-conflicts-block conf)))
     (deletef-in global-conflicts-next-blockwise
-		(ir2-block-global-tns block)
-		conf)
+                (ir2-block-global-tns block)
+                conf)
     (setf (global-conflicts-next-blockwise conf) nil)
     (insert-block-global-conflict conf block)
     (when ltn-num
@@ -856,13 +917,13 @@
 (defun ensure-global-tn (tn)
   (declare (type tn tn))
   (cond ((tn-global-conflicts tn))
-	((tn-local tn)
-	 (convert-to-global tn)
-	 (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
-		  (tn-local-conflicts tn)
-		  t))
-	(t
-	 (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))
+        ((tn-local tn)
+         (convert-to-global tn)
+         (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
+                  (tn-local-conflicts tn)
+                  t))
+        (t
+         (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))
   (values))
 
 ;;; For each :ALIAS TN, destructively merge the conflict info into the
@@ -881,60 +942,74 @@
 (defun merge-alias-conflicts (component)
   (declare (type component component))
   (do ((tn (ir2-component-alias-tns (component-info component))
-	   (tn-next tn)))
+           (tn-next tn)))
       ((null tn))
     (let ((original (tn-save-tn tn)))
       (ensure-global-tn tn)
       (ensure-global-tn original)
       (let ((conf (tn-global-conflicts tn))
-	    (oconf (tn-global-conflicts original))
-	    (oprev nil))
-	(loop
-	  (unless oconf
-	    (if oprev
-		(setf (global-conflicts-next-tnwise oprev) conf)
-		(setf (tn-global-conflicts original) conf))
-	    (do ((current conf (global-conflicts-next-tnwise current)))
-		((null current))
-	      (change-global-conflicts-tn current original))
-	    (return))
-	  (let* ((block (global-conflicts-block conf))
-		 (num (ir2-block-number block))
-		 (onum (ir2-block-number (global-conflicts-block oconf))))
-
-	    (cond ((< onum num)
-		   (shiftf oprev oconf (global-conflicts-next-tnwise oconf)))
-		  ((> onum num)
-		   (if oprev
-		       (setf (global-conflicts-next-tnwise oprev) conf)
-		       (setf (tn-global-conflicts original) conf))
-		   (change-global-conflicts-tn conf original)
-		   (shiftf oprev
-			   conf
-			   (global-conflicts-next-tnwise conf)
-			   oconf))
-		  (t
-		   (merge-alias-block-conflicts conf oconf)
-		   (shiftf oprev oconf (global-conflicts-next-tnwise oconf))
-		   (setf conf (global-conflicts-next-tnwise conf)))))
-	  (unless conf (return))))
+            (oconf (tn-global-conflicts original))
+            (oprev nil))
+        (loop
+          (unless oconf
+            (if oprev
+                (setf (global-conflicts-next-tnwise oprev) conf)
+                (setf (tn-global-conflicts original) conf))
+            (do ((current conf (global-conflicts-next-tnwise current)))
+                ((null current))
+              (change-global-conflicts-tn current original))
+            (return))
+          (let* ((block (global-conflicts-block conf))
+                 (num (ir2-block-number block))
+                 (onum (ir2-block-number (global-conflicts-block oconf))))
+
+            (cond ((< onum num)
+                   (shiftf oprev oconf (global-conflicts-next-tnwise oconf)))
+                  ((> onum num)
+                   (if oprev
+                       (setf (global-conflicts-next-tnwise oprev) conf)
+                       (setf (tn-global-conflicts original) conf))
+                   (change-global-conflicts-tn conf original)
+                   (shiftf oprev
+                           conf
+                           (global-conflicts-next-tnwise conf)
+                           oconf))
+                  (t
+                   (merge-alias-block-conflicts conf oconf)
+                   (shiftf oprev oconf (global-conflicts-next-tnwise oconf))
+                   (setf conf (global-conflicts-next-tnwise conf)))))
+          (unless conf (return))))
 
       (flet ((frob (refs)
-	       (let ((ref refs)
-		     (next nil))
-		 (loop
-		   (unless ref (return))
-		   (setq next (tn-ref-next ref))
-		   (change-tn-ref-tn ref original)
-		   (setq ref next)))))
-	(frob (tn-reads tn))
-	(frob (tn-writes tn)))
+               (let ((ref refs)
+                     (next nil))
+                 (loop
+                   (unless ref (return))
+                   (setq next (tn-ref-next ref))
+                   (change-tn-ref-tn ref original)
+                   (setq ref next)))))
+        (frob (tn-reads tn))
+        (frob (tn-writes tn)))
       (setf (tn-global-conflicts tn) nil)))
 
   (values))
+
+;;; On high debug levels, for all variables that a lambda closes over
+;;; convert the TNs to :ENVIRONMENT TNs (in the physical environment
+;;; of that lambda). This way the debugger can display the variables.
+(defun maybe-environmentalize-closure-tns (component)
+  (dolist (lambda (component-lambdas component))
+    (when (policy lambda (>= debug 2))
+      (let ((physenv (lambda-physenv lambda)))
+        (dolist (closure-var (physenv-closure physenv))
+          (let ((tn (find-in-physenv closure-var physenv)))
+            (when (member (tn-kind tn) '(:normal :debug-environment))
+              (convert-to-environment-tn tn physenv))))))))
+
 
 (defun lifetime-analyze (component)
   (lifetime-pre-pass component)
+  (maybe-environmentalize-closure-tns component)
   (setup-environment-live-conflicts component)
   (lifetime-flow-analysis component)
   (lifetime-post-pass component)
@@ -951,61 +1026,61 @@
 (defun tns-conflict-local-global (x y)
   (let ((block (tn-local x)))
     (do ((conf (ir2-block-global-tns block)
-	       (global-conflicts-next-blockwise conf)))
-	((null conf) nil)
+               (global-conflicts-next-blockwise conf)))
+        ((null conf) nil)
       (when (eq (global-conflicts-tn conf) y)
-	(let ((num (global-conflicts-number conf)))
-	  (return (or (not num)
-		      (not (zerop (sbit (tn-local-conflicts x)
-					num))))))))))
+        (let ((num (global-conflicts-number conf)))
+          (return (or (not num)
+                      (not (zerop (sbit (tn-local-conflicts x)
+                                        num))))))))))
 
 ;;; Test for conflict between two global TNs X and Y.
 (defun tns-conflict-global-global (x y)
   (declare (type tn x y))
   (let* ((x-conf (tn-global-conflicts x))
-	 (x-num (ir2-block-number (global-conflicts-block x-conf)))
-	 (y-conf (tn-global-conflicts y))
-	 (y-num (ir2-block-number (global-conflicts-block y-conf))))
+         (x-num (ir2-block-number (global-conflicts-block x-conf)))
+         (y-conf (tn-global-conflicts y))
+         (y-num (ir2-block-number (global-conflicts-block y-conf))))
 
     (macrolet ((advance (n c)
-		 `(progn
-		    (setq ,c (global-conflicts-next-tnwise ,c))
-		    (unless ,c (return-from tns-conflict-global-global nil))
-		    (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
-	       (scan (g l lc)
-		 `(do ()
-		      ((>= ,g ,l))
-		    (advance ,l ,lc))))
+                 `(progn
+                    (setq ,c (global-conflicts-next-tnwise ,c))
+                    (unless ,c (return-from tns-conflict-global-global nil))
+                    (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
+               (scan (g l lc)
+                 `(do ()
+                      ((>= ,g ,l))
+                    (advance ,l ,lc))))
 
       (loop
-	;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
-	(scan x-num y-num y-conf)
-	(scan y-num x-num x-conf)
-	(when (= x-num y-num)
-	  (let ((ltn-num-x (global-conflicts-number x-conf)))
-	    (unless (and ltn-num-x
-			 (global-conflicts-number y-conf)
-			 (zerop (sbit (global-conflicts-conflicts y-conf)
-				      ltn-num-x)))
-	      (return t))
-	    (advance x-num x-conf)
-	    (advance y-num y-conf)))))))
+        ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
+        (scan x-num y-num y-conf)
+        (scan y-num x-num x-conf)
+        (when (= x-num y-num)
+          (let ((ltn-num-x (global-conflicts-number x-conf)))
+            (unless (and ltn-num-x
+                         (global-conflicts-number y-conf)
+                         (zerop (sbit (global-conflicts-conflicts y-conf)
+                                      ltn-num-x)))
+              (return t))
+            (advance x-num x-conf)
+            (advance y-num y-conf)))))))
 
 ;;; Return true if X and Y are distinct and the lifetimes of X and Y
 ;;; overlap at any point.
 (defun tns-conflict (x y)
   (declare (type tn x y))
   (let ((x-kind (tn-kind x))
-	(y-kind (tn-kind y)))
+        (y-kind (tn-kind y)))
     (cond ((eq x y) nil)
-	  ((or (eq x-kind :component) (eq y-kind :component)) t)
-	  ((tn-global-conflicts x)
-	   (if (tn-global-conflicts y)
-	       (tns-conflict-global-global x y)
-	       (tns-conflict-local-global y x)))
-	  ((tn-global-conflicts y)
-	   (tns-conflict-local-global x y))
-	  (t
-	   (and (eq (tn-local x) (tn-local y))
-		(not (zerop (sbit (tn-local-conflicts x)
-				  (tn-local-number y)))))))))
+          ((or (eq x-kind :component) (eq y-kind :component)) t)
+          ((tn-global-conflicts x)
+           (if (tn-global-conflicts y)
+               (tns-conflict-global-global x y)
+               (tns-conflict-local-global y x)))
+          ((tn-global-conflicts y)
+           (tns-conflict-local-global x y))
+          (t
+           (and (eq (tn-local x) (tn-local y))
+                (not (zerop (sbit (tn-local-conflicts x)
+                                  (tn-local-number y)))))))))