X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=872144a9610124fea7af1854c66fa1136264bbe7;hb=6535ee98644b8fd1cea3581adb25d4d8bf7c1110;hp=371777f179a333c701cce3868ee805d056b7ce83;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 371777f..872144a 100644
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -39,8 +39,8 @@
   One of :WARN, :ERROR or :NONE.")
 (declaim (type (member :warn :error :none) *burp-action*))
 
-;;; Called when something funny but possibly correct is noticed. Otherwise
-;;; similar to Barf.
+;;; Called when something funny but possibly correct is noticed.
+;;; Otherwise similar to BARF.
 (declaim (ftype (function (string &rest t) (values)) burp))
 (defun burp (string &rest *args*)
   (ecase *burp-action*
@@ -49,46 +49,50 @@
     (:none))
   (values))
 
-;;; *Seen-Blocks* is a hashtable with true values for all blocks which appear
-;;; in the DFO for one of the specified components.
+;;; *SEEN-BLOCKS* is a hashtable with true values for all blocks which
+;;; appear in the DFO for one of the specified components.
+;;;
+;;; *SEEN-FUNS* is similar, but records all the lambdas we
+;;; reached by recursing on top level functions.
+;;; FIXME: Is it really only LAMBDAs, not e.g. FUNCTIONALs? Then
+;;; shouldn't it be *SEEN-LAMBDAS*?
 (defvar *seen-blocks* (make-hash-table :test 'eq))
+(defvar *seen-funs* (make-hash-table :test 'eq))
 
-;;; *Seen-Functions* is similar, but records all the lambdas we reached by
-;;; recursing on top-level functions.
-(defvar *seen-functions* (make-hash-table :test 'eq))
-
-;;; Barf if Node is in a block which wasn't reached during the graph walk.
+;;; Barf if NODE is in a block which wasn't reached during the graph
+;;; walk.
 (declaim (ftype (function (node) (values)) check-node-reached))
 (defun check-node-reached (node)
-  (unless (gethash (continuation-block (node-prev node)) *seen-blocks*)
+  (unless (gethash (ctran-block (node-prev node)) *seen-blocks*)
     (barf "~S was not reached." node))
   (values))
 
-;;; Check everything that we can think of for consistency. When a definite
-;;; inconsistency is detected, we BARF. Possible problems just cause us to
-;;; BURP. Our argument is a list of components, but we also look at the
-;;; *FREE-VARIABLES*, *FREE-FUNCTIONS* and *CONSTANTS*.
+;;; Check everything that we can think of for consistency. When a
+;;; definite inconsistency is detected, we BARF. Possible problems
+;;; just cause us to BURP. Our argument is a list of components, but
+;;; we also look at the *FREE-VARS*, *FREE-FUNS* and *CONSTANTS*.
 ;;;
-;;; First we do a pre-pass which finds all the blocks and lambdas, testing
-;;; that they are linked together properly and entering them in hashtables.
-;;; Next, we iterate over the blocks again, looking at the actual code and
-;;; control flow. Finally, we scan the global leaf hashtables, looking for
-;;; lossage.
+;;; First we do a pre-pass which finds all the CBLOCKs and CLAMBDAs,
+;;; testing that they are linked together properly and entering them
+;;; in hashtables. Next, we iterate over the blocks again, looking at
+;;; the actual code and control flow. Finally, we scan the global leaf
+;;; hashtables, looking for lossage.
 (declaim (ftype (function (list) (values)) check-ir1-consistency))
 (defun check-ir1-consistency (components)
   (clrhash *seen-blocks*)
-  (clrhash *seen-functions*)
+  (clrhash *seen-funs*)
   (dolist (c components)
     (let* ((head (component-head c))
 	   (tail (component-tail c)))
-      (unless (and (null (block-pred head)) (null (block-succ tail)))
+      (unless (and (null (block-pred head))
+		   (null (block-succ tail)))
 	(barf "~S is malformed." c))
 
       (do ((prev nil block)
 	   (block head (block-next block)))
 	  ((null block)
 	   (unless (eq prev tail)
-	     (barf "wrong Tail for DFO, ~S in ~S" prev c)))
+	     (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
 	(setf (gethash block *seen-blocks*) t)
 	(unless (eq (block-prev block) prev)
 	  (barf "bad PREV for ~S, should be ~S" block prev))
@@ -106,45 +110,45 @@
 |#
     ))
 
-  (check-function-consistency components)
+  (check-fun-consistency components)
 
   (dolist (c components)
     (do ((block (block-next (component-head c)) (block-next block)))
 	((null (block-next block)))
       (check-block-consistency block)))
 
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (unless (or (constant-p v)
-			   (and (global-var-p v)
-				(member (global-var-kind v)
-					'(:global :special :constant))))
-		 (barf "strange *FREE-VARIABLES* entry: ~S" v))
-	       (dolist (n (leaf-refs v))
-		 (check-node-reached n))
-	       (when (basic-var-p v)
-		 (dolist (n (basic-var-sets v))
-		   (check-node-reached n))))
-	   *free-variables*)
-
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (unless (constant-p v)
-		 (barf "strange *CONSTANTS* entry: ~S" v))
-	       (dolist (n (leaf-refs v))
-		 (check-node-reached n)))
+  (maphash (lambda (k v)
+	     (declare (ignore k))
+	     (unless (or (constant-p v)
+			 (and (global-var-p v)
+			      (member (global-var-kind v)
+				      '(:global :special))))
+	       (barf "strange *FREE-VARS* entry: ~S" v))
+	     (dolist (n (leaf-refs v))
+	       (check-node-reached n))
+	     (when (basic-var-p v)
+	       (dolist (n (basic-var-sets v))
+		 (check-node-reached n))))
+	   *free-vars*)
+
+  (maphash (lambda (k v)
+	     (declare (ignore k))
+	     (unless (constant-p v)
+	       (barf "strange *CONSTANTS* entry: ~S" v))
+	     (dolist (n (leaf-refs v))
+	       (check-node-reached n)))
 	   *constants*)
 
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (unless (or (functional-p v)
-			   (and (global-var-p v)
-				(eq (global-var-kind v) :global-function)))
-		 (barf "strange *FREE-FUNCTIONS* entry: ~S" v))
-	       (dolist (n (leaf-refs v))
-		 (check-node-reached n)))
-	   *free-functions*)
-  (clrhash *seen-functions*)
+  (maphash (lambda (k v)
+	     (declare (ignore k))
+	     (unless (or (functional-p v)
+			 (and (global-var-p v)
+			      (eq (global-var-kind v) :global-function)))
+	       (barf "strange *FREE-FUNS* entry: ~S" v))
+	     (dolist (n (leaf-refs v))
+	       (check-node-reached n)))
+	   *free-funs*)
+  (clrhash *seen-funs*)
   (clrhash *seen-blocks*)
   (values))
 
@@ -152,32 +156,32 @@
 
 (defun observe-functional (x)
   (declare (type functional x))
-  (when (gethash x *seen-functions*)
+  (when (gethash x *seen-funs*)
     (barf "~S was seen more than once." x))
   (unless (eq (functional-kind x) :deleted)
-    (setf (gethash x *seen-functions*) t)))
+    (setf (gethash x *seen-funs*) t)))
 
 ;;; Check that the specified function has been seen.
-(defun check-function-reached (fun where)
+(defun check-fun-reached (fun where)
   (declare (type functional fun))
-  (unless (gethash fun *seen-functions*)
+  (unless (gethash fun *seen-funs*)
     (barf "unseen function ~S in ~S" fun where)))
 
-;;; In a lambda, check that the associated nodes are in seen blocks. In an
-;;; optional dispatch, check that the entry points were seen. If the function
-;;; is deleted, ignore it.
-(defun check-function-stuff (functional)
+;;; In a CLAMBDA, check that the associated nodes are in seen blocks.
+;;; In an OPTIONAL-DISPATCH, check that the entry points were seen. If
+;;; the function is deleted, ignore it.
+(defun check-fun-stuff (functional)
   (ecase (functional-kind functional)
     (:external
-     (let ((fun (functional-entry-function functional)))
-       (check-function-reached fun functional)
+     (let ((fun (functional-entry-fun functional)))
+       (check-fun-reached fun functional)
        (when (functional-kind fun)
 	 (barf "The function for XEP ~S has kind." functional))
-       (unless (eq (functional-entry-function fun) functional)
+       (unless (eq (functional-entry-fun fun) functional)
 	 (barf "bad back-pointer in function for XEP ~S" functional))))
-    ((:let :mv-let :assignment)
-     (check-function-reached (lambda-home functional) functional)
-     (when (functional-entry-function functional)
+    ((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P
+     (check-fun-reached (lambda-home functional) functional)
+     (when (functional-entry-fun functional)
        (barf "The LET ~S has entry function." functional))
      (unless (member functional (lambda-lets (lambda-home functional)))
        (barf "The LET ~S is not in LETs for HOME." functional))
@@ -187,36 +191,37 @@
      (when (lambda-lets functional)
        (barf "LETs in a LET: ~S" functional)))
     (:optional
-     (when (functional-entry-function functional)
-       (barf ":OPTIONAL ~S has an ENTRY-FUNCTION." functional))
+     (when (functional-entry-fun functional)
+       (barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
      (let ((ef (lambda-optional-dispatch functional)))
-       (check-function-reached ef functional)
-       (unless (or (member functional (optional-dispatch-entry-points ef))
+       (check-fun-reached ef functional)
+       (unless (or (member functional (optional-dispatch-entry-points ef)
+                           :key (lambda (ep)
+                                  (when (promise-ready-p ep)
+                                    (force ep))))
 		   (eq functional (optional-dispatch-more-entry ef))
 		   (eq functional (optional-dispatch-main-entry ef)))
 	 (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
 	       functional ef))))
-    (:top-level
-     (unless (eq (functional-entry-function functional) functional)
-       (barf "The ENTRY-FUNCTION in ~S isn't a self-pointer." functional)))
+    (:toplevel
+     (unless (eq (functional-entry-fun functional) functional)
+       (barf "The ENTRY-FUN in ~S isn't a self-pointer." functional)))
     ((nil :escape :cleanup)
-     (let ((ef (functional-entry-function functional)))
+     (let ((ef (functional-entry-fun functional)))
        (when ef
-	 (check-function-reached ef functional)
+	 (check-fun-reached ef functional)
 	 (unless (eq (functional-kind ef) :external)
-	   (barf "The ENTRY-FUNCTION in ~S isn't an XEP: ~S."
-		 functional
-		 ef)))))
+	   (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
     (:deleted
-     (return-from check-function-stuff)))
+     (return-from check-fun-stuff)))
 
   (case (functional-kind functional)
-    ((nil :optional :external :top-level :escape :cleanup)
+    ((nil :optional :external :toplevel :escape :cleanup)
      (when (lambda-p functional)
        (dolist (fun (lambda-lets functional))
 	 (unless (eq (lambda-home fun) functional)
 	   (barf "The home in ~S is not ~S." fun functional))
-	 (check-function-reached fun functional))
+	 (check-fun-reached fun functional))
        (unless (eq (lambda-home functional) functional)
 	 (barf "home not self-pointer in ~S" functional)))))
 
@@ -236,19 +241,20 @@
 	 (barf "HOME in ~S should be ~S." var functional))))
     (optional-dispatch
      (dolist (ep (optional-dispatch-entry-points functional))
-       (check-function-reached ep functional))
+       (when (promise-ready-p ep)
+         (check-fun-reached (force ep) functional)))
      (let ((more (optional-dispatch-more-entry functional)))
-       (when more (check-function-reached more functional)))
-     (check-function-reached (optional-dispatch-main-entry functional)
-			     functional))))
+       (when more (check-fun-reached more functional)))
+     (check-fun-reached (optional-dispatch-main-entry functional)
+			functional))))
 
-(defun check-function-consistency (components)
+(defun check-fun-consistency (components)
   (dolist (c components)
-    (dolist (fun (component-new-functions c))
-      (observe-functional fun))
+    (dolist (new-fun (component-new-functionals c))
+      (observe-functional new-fun))
     (dolist (fun (component-lambdas c))
       (when (eq (functional-kind fun) :external)
-	(let ((ef (functional-entry-function fun)))
+	(let ((ef (functional-entry-fun fun)))
 	  (when (optional-dispatch-p ef)
 	    (observe-functional ef))))
       (observe-functional fun)
@@ -256,14 +262,14 @@
 	(observe-functional let))))
 
   (dolist (c components)
-    (dolist (fun (component-new-functions c))
-      (check-function-stuff fun))
+    (dolist (new-fun (component-new-functionals c))
+      (check-fun-stuff new-fun))
     (dolist (fun (component-lambdas c))
       (when (eq (functional-kind fun) :deleted)
 	(barf "deleted lambda ~S in Lambdas for ~S" fun c))
-      (check-function-stuff fun)
+      (check-fun-stuff fun)
       (dolist (let (lambda-lets fun))
-	(check-function-stuff let)))))
+	(check-fun-stuff let)))))
 
 ;;;; loop consistency checking
 
@@ -316,9 +322,9 @@
 
 |#
 
-;;; Check a block for consistency at the general flow-graph level, and call
-;;; Check-Node-Consistency on each node to locally check for semantic
-;;; consistency.
+;;; Check a block for consistency at the general flow-graph level, and
+;;; call CHECK-NODE-CONSISTENCY on each node to locally check for
+;;; semantic consistency.
 (declaim (ftype (function (cblock) (values)) check-block-consistency))
 (defun check-block-consistency (block)
 
@@ -330,87 +336,65 @@
 
   (let* ((fun (block-home-lambda block))
 	 (fun-deleted (eq (functional-kind fun) :deleted))
-	 (this-cont (block-start block))
+	 (this-ctran (block-start block))
 	 (last (block-last block)))
     (unless fun-deleted
-      (check-function-reached fun block))
-    (when (not this-cont)
+      (check-fun-reached fun block))
+    (when (not this-ctran)
       (barf "~S has no START." block))
     (when (not last)
       (barf "~S has no LAST." block))
-    (unless (eq (continuation-kind this-cont) :block-start)
+    (unless (eq (ctran-kind this-ctran) :block-start)
       (barf "The START of ~S has the wrong kind." block))
 
-    (let ((use (continuation-use this-cont))
-	  (uses (block-start-uses block)))
-      (when (and (null use) (= (length uses) 1))
-	(barf "~S has a unique use, but no USE." this-cont))
-      (dolist (node uses)
-	(unless (eq (node-cont node) this-cont)
-	  (barf "The USE ~S for START in ~S has wrong CONT." node block))
-	(check-node-reached node)))
-
-    (let* ((last-cont (node-cont last))
-	   (cont-block (continuation-block last-cont))
-	   (dest (continuation-dest last-cont)))
-      (ecase (continuation-kind last-cont)
-	(:deleted)
-	(:deleted-block-start
-	 (let ((dest (continuation-dest last-cont)))
-	   (when dest
-	     (check-node-reached dest)))
-	 (unless (member last (block-start-uses cont-block))
-	   (barf "LAST in ~S is missing from uses of its Cont." block)))
-	(:block-start
-	 (check-node-reached (continuation-next last-cont))
-	 (unless (member last (block-start-uses cont-block))
-	   (barf "LAST in ~S is missing from uses of its Cont." block)))
-	(:inside-block
-	 (unless (eq cont-block block)
-	   (barf "CONT of LAST in ~S is in a different BLOCK." block))
-	 (unless (eq (continuation-use last-cont) last)
-	   (barf "USE is not LAST in CONT of LAST in ~S." block))
-	 (when (continuation-next last-cont)
-	   (barf "CONT of LAST has a NEXT in ~S." block))))
-
-      (when dest
-	(check-node-reached dest)))
-
-    (loop	
-      (unless (eq (continuation-block this-cont) block)
-	(barf "BLOCK in ~S should be ~S." this-cont block))
-
-      (let ((dest (continuation-dest this-cont)))
-	(when dest
-	  (check-node-reached dest)))
-
-      (let ((node (continuation-next this-cont)))
-	(unless (node-p node)
-	  (barf "~S has strange NEXT." this-cont))
-	(unless (eq (node-prev node) this-cont)
-	  (barf "PREV in ~S should be ~S." node this-cont))
+    (when (ctran-use this-ctran)
+      (barf "The ctran ~S is used." this-ctran))
 
+    (when (node-next last)
+      (barf "Last node ~S of ~S has next ctran." last block))
+
+    (loop
+      (unless (eq (ctran-block this-ctran) block)
+	(barf "BLOCK of ~S should be ~S." this-ctran block))
+
+      (let ((node (ctran-next this-ctran)))
+	(unless (node-p node)
+	  (barf "~S has strange NEXT." this-ctran))
+	(unless (eq (node-prev node) this-ctran)
+	  (barf "PREV in ~S should be ~S." node this-ctran))
+
+        (when (valued-node-p node)
+          (binding* ((lvar (node-lvar node) :exit-if-null))
+            (unless (memq node (find-uses lvar))
+              (barf "~S is not used by its LVAR ~S." node lvar))
+            (when (singleton-p (lvar-uses lvar))
+              (barf "~S has exactly 1 use, but LVAR-USES is a list."
+                    lvar))
+            (unless (lvar-dest lvar)
+              (barf "~S does not have dest." lvar))))
+
+        (check-node-reached node)
 	(unless fun-deleted
 	  (check-node-consistency node))
-	
-	(let ((cont (node-cont node)))
-	  (when (not cont)
-	    (barf "~S has no CONT." node))
+
+	(let ((next (node-next node)))
+	  (when (and (not next) (not (eq node last)))
+	    (barf "~S has no NEXT." node))
 	  (when (eq node last) (return))
-	  (unless (eq (continuation-kind cont) :inside-block)
-	    (barf "The interior continuation ~S in ~S has the wrong kind."
-		  cont
+	  (unless (eq (ctran-kind next) :inside-block)
+	    (barf "The interior ctran ~S in ~S has the wrong kind."
+		  next
 		  block))
-	  (unless (continuation-next cont)
-	    (barf "~S has no NEXT." cont))
-	  (unless (eq (continuation-use cont) node)
-	    (barf "USE in ~S should be ~S." cont node))
-	  (setq this-cont cont))))
-	
+	  (unless (ctran-next next)
+	    (barf "~S has no NEXT." next))
+	  (unless (eq (ctran-use next) node)
+	    (barf "USE in ~S should be ~S." next node))
+	  (setq this-ctran next))))
+
     (check-block-successors block))
   (values))
 
-;;; Check that Block is properly terminated. Each successor must be
+;;; Check that BLOCK is properly terminated. Each successor must be
 ;;; accounted for by the type of the last node.
 (declaim (ftype (function (cblock) (values)) check-block-successors))
 (defun check-block-successors (block)
@@ -456,57 +440,71 @@
 
 ;;;; node consistency checking
 
-;;; Check that the Dest for Cont is the specified Node. We also mark the
-;;; block Cont is in as Seen.
-(declaim (ftype (function (continuation node) (values)) check-dest))
-(defun check-dest (cont node)
-  (let ((kind (continuation-kind cont)))
-    (ecase kind
-      (:deleted
-       (unless (block-delete-p (node-block node))
-	 (barf "DEST ~S of deleted continuation ~S is not DELETE-P."
-	       cont node)))
-      (:deleted-block-start
-       (unless (eq (continuation-dest cont) node)
-	 (barf "DEST for ~S should be ~S." cont node)))
-      ((:inside-block :block-start)
-       (unless (gethash (continuation-block cont) *seen-blocks*)
-	 (barf "~S receives ~S, which is in an unknown block." node cont))
-       (unless (eq (continuation-dest cont) node)
-	 (barf "DEST for ~S should be ~S." cont node)))))
+;;; Check that the DEST for LVAR is the specified NODE. We also mark
+;;; the block LVAR is in as SEEN.
+#+nil(declaim (ftype (function (lvar node) (values)) check-dest))
+(defun check-dest (lvar node)
+  (do-uses (use lvar)
+    (unless (gethash (node-block use) *seen-blocks*)
+      (barf "Node ~S using ~S is in an unknown block." use lvar)))
+  (unless (eq (lvar-dest lvar) node)
+    (barf "DEST for ~S should be ~S." lvar node))
+  (unless (find-uses lvar)
+    (barf "Lvar ~S has a destinatin, but no uses."
+          lvar))
   (values))
 
-;;; This function deals with checking for consistency the type-dependent
-;;; information in a node.
+;;; This function deals with checking for consistency of the
+;;; type-dependent information in a node.
 (defun check-node-consistency (node)
   (declare (type node node))
   (etypecase node
     (ref
      (let ((leaf (ref-leaf node)))
        (when (functional-p leaf)
-	 (if (eq (functional-kind leaf) :top-level-xep)
+	 (if (eq (functional-kind leaf) :toplevel-xep)
 	     (unless (eq (component-kind (block-component (node-block node)))
-			 :top-level)
-	       (barf ":TOP-LEVEL-XEP ref in non-top-level component: ~S"
+			 :toplevel)
+	       (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
 		     node))
-	     (check-function-reached leaf node)))))
+	     (check-fun-reached leaf node)))))
     (basic-combination
      (check-dest (basic-combination-fun node) node)
+     (when (and (mv-combination-p node)
+                (eq (basic-combination-kind node) :local))
+       (let ((fun-lvar (basic-combination-fun node)))
+         (unless (ref-p (lvar-uses fun-lvar))
+           (barf "function in a local mv-combination is not a LEAF: ~S" node))
+         (let ((fun (ref-leaf (lvar-use fun-lvar))))
+           (unless (lambda-p fun)
+             (barf "function ~S in a local mv-combination ~S is not local"
+                   fun node))
+           (unless (eq (functional-kind fun) :mv-let)
+             (barf "function ~S in a local mv-combination ~S is not of kind :MV-LET"
+                   fun node)))))
      (dolist (arg (basic-combination-args node))
        (cond
-	(arg (check-dest arg node))
-	((not (and (eq (basic-combination-kind node) :local)
-		   (combination-p node)))
-	 (barf "flushed arg not in local call: ~S" node))
-	(t
-	 (let ((fun (ref-leaf (continuation-use
-			       (basic-combination-fun node))))
-	       (pos (position arg (basic-combination-args node))))
-	   (check-type pos fixnum) ; to suppress warning -- WHN 19990311
-	   (when (leaf-refs (elt (lambda-vars fun) pos))
-	     (barf "flushed arg for referenced var in ~S" node))))))
-
-     (let ((dest (continuation-dest (node-cont node))))
+         (arg (check-dest arg node))
+         ((not (and (eq (basic-combination-kind node) :local)
+                    (combination-p node)))
+          (barf "flushed arg not in local call: ~S" node))
+         (t
+          (locally
+              ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
+              ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
+              ;; POSITION. It compiles it correctly, but it issues a type
+              ;; mismatch warning because it can't eliminate the
+              ;; possibility that control will flow through the
+              ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
+              (declare (notinline position))
+            (let ((fun (ref-leaf (lvar-use
+                                  (basic-combination-fun node))))
+                  (pos (position arg (basic-combination-args node))))
+              (declare (type index pos))
+              (when (leaf-refs (elt (lambda-vars fun) pos))
+                (barf "flushed arg for referenced var in ~S" node)))))))
+     (let* ((lvar (node-lvar node))
+            (dest (and lvar (lvar-dest lvar))))
        (when (and (return-p dest)
 		  (eq (basic-combination-kind node) :local)
 		  (not (eq (lambda-tail-set (combination-lambda node))
@@ -519,10 +517,12 @@
        (barf "IF not at block end: ~S" node)))
     (cset
      (check-dest (set-value node) node))
+    (cast
+     (check-dest (cast-value node) node))
     (bind
-     (check-function-reached (bind-lambda node) node))
+     (check-fun-reached (bind-lambda node) node))
     (creturn
-     (check-function-reached (return-lambda node) node)
+     (check-fun-reached (return-lambda node) node)
      (check-dest (return-result node) node)
      (unless (eq (block-last (node-block node)) node)
        (barf "RETURN not at block end: ~S" node)))
@@ -549,22 +549,22 @@
 
 ;;;; IR2 consistency checking
 
-;;; Check for some kind of consistency in some Refs linked together by
-;;; TN-Ref-Across. VOP is the VOP that the references are in. Write-P is the
-;;; value of Write-P that should be present. Count is the minimum number of
-;;; operands expected. If More-P is true, then any larger number will also be
-;;; accepted. What is a string describing the kind of operand in error
-;;; messages.
+;;; Check for some kind of consistency in some REFs linked together by
+;;; TN-REF-ACROSS. VOP is the VOP that the references are in. WRITE-P
+;;; is the value of WRITE-P that should be present. COUNT is the
+;;; minimum number of operands expected. If MORE-P is true, then any
+;;; larger number will also be accepted. WHAT is a string describing
+;;; the kind of operand in error messages.
 (defun check-tn-refs (refs vop write-p count more-p what)
   (let ((vop-refs (vop-refs vop)))
     (do ((ref refs (tn-ref-across ref))
 	 (num 0 (1+ num)))
 	((null ref)
 	 (when (< num count)
-	   (barf "There should be at least ~D ~A in ~S, but are only ~D."
+	   (barf "There should be at least ~W ~A in ~S, but there are only ~W."
 		 count what vop num))
 	 (when (and (not more-p) (> num count))
-	   (barf "There should be ~D ~A in ~S, but are ~D."
+	   (barf "There should be ~W ~A in ~S, but are ~W."
 		 count what vop num)))
       (unless (eq (tn-ref-vop ref) vop)
 	(barf "VOP is ~S isn't ~S." ref vop))
@@ -585,7 +585,7 @@
 	  (unless (find-in #'tn-ref-next-ref target vop-refs)
 	    (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
 
-;;; Verify the sanity of the VOP-Refs slot in VOP. This involves checking
+;;; Verify the sanity of the VOP-REFS slot in VOP. This involves checking
 ;;; that each referenced TN appears as an argument, result or temp, and also
 ;;; basic checks for the plausibility of the specified ordering of the refs.
 (defun check-vop-refs (vop)
@@ -612,8 +612,8 @@
   (values))
 
 ;;; Check the basic sanity of the VOP linkage, then call some other
-;;; functions to check on the TN-Refs. We grab some info out of the VOP-Info
-;;; to tell us what to expect.
+;;; functions to check on the TN-REFS. We grab some info out of the
+;;; VOP-INFO to tell us what to expect.
 ;;;
 ;;; [### Check that operand type restrictions are met?]
 (defun check-ir2-block-consistency (2block)
@@ -636,9 +636,9 @@
 	   (atypes (template-arg-types info))
 	   (rtypes (template-result-types info)))
       (check-tn-refs (vop-args vop) vop nil
-		     (count-if-not #'(lambda (x)
-				       (and (consp x)
-					    (eq (car x) :constant)))
+		     (count-if-not (lambda (x)
+				     (and (consp x)
+					  (eq (car x) :constant)))
 				   atypes)
 		     (template-more-args-type info) "args")
       (check-tn-refs (vop-results vop) vop t
@@ -650,12 +650,12 @@
 	(barf "wrong number of codegen info args in ~S" vop))))
   (values))
 
-;;; Check stuff about the IR2 representation of Component. This assumes the
+;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
 ;;; sanity of the basic flow graph.
 ;;;
 ;;; [### Also grovel global TN data structures?  Assume pack not
-;;; done yet?  Have separate check-tn-consistency for pre-pack and
-;;; check-pack-consistency for post-pack?]
+;;; done yet?  Have separate CHECK-TN-CONSISTENCY for pre-pack and
+;;; CHECK-PACK-CONSISTENCY for post-pack?]
 (defun check-ir2-consistency (component)
   (declare (type component component))
   (do-ir2-blocks (block component)
@@ -666,7 +666,7 @@
 
 ;;; Dump some info about how many TNs there, and what the conflicts data
 ;;; structures are like.
-(defun pre-pack-tn-stats (component &optional (stream *error-output*))
+(defun pre-pack-tn-stats (component &optional (stream *standard-output*))
   (declare (type component component))
   (let ((wired 0)
 	(global 0)
@@ -695,7 +695,7 @@
 	       ((:environment :debug-environment) (incf environment))
 	       (t (incf global)))
 	     (do ((conf (tn-global-conflicts tn)
-			(global-conflicts-tn-next conf)))
+			(global-conflicts-next-tnwise conf)))
 		 ((null conf))
 	       (incf confs)))
 	    (t
@@ -707,14 +707,14 @@
       (incf const))
 
     (format stream
-     "~%TNs: ~D local, ~D temps, ~D constant, ~D env, ~D comp, ~D global.~@
-       Wired: ~D, Unused: ~D. ~D block~:P, ~D global conflict~:P.~%"
+     "~%TNs: ~W local, ~W temps, ~W constant, ~W env, ~W comp, ~W global.~@
+       Wired: ~W, Unused: ~W. ~W block~:P, ~W global conflict~:P.~%"
        local temps const environment comp global wired unused
        (ir2-block-count component)
        confs))
   (values))
 
-;;; If the entry in Local-TNs for TN in Block is :More, then do some checks
+;;; If the entry in Local-TNs for TN in BLOCK is :MORE, then do some checks
 ;;; for the validity of the usage.
 (defun check-more-tn-entry (tn block)
   (let* ((vop (ir2-block-start-vop block))
@@ -744,9 +744,9 @@
        ((eq kind :component)
 	(unless (member tn (ir2-component-component-tns
 			    (component-info component)))
-	  (barf "~S not in Component-TNs for ~S" tn component)))
+	  (barf "~S not in COMPONENT-TNs for ~S" tn component)))
        (conf
-	(do ((conf conf (global-conflicts-tn-next conf))
+	(do ((conf conf (global-conflicts-next-tnwise conf))
 	     (prev nil conf))
 	    ((null conf))
 	  (unless (eq (global-conflicts-tn conf) tn)
@@ -789,7 +789,7 @@
 (defun check-block-conflicts (component)
   (do-ir2-blocks (block component)
     (do ((conf (ir2-block-global-tns block)
-	       (global-conflicts-next conf))
+	       (global-conflicts-next-blockwise conf))
 	 (prev nil conf))
 	((null conf))
       (when prev
@@ -797,7 +797,7 @@
 		   (tn-number (global-conflicts-tn prev)))
 	  (barf "~S and ~S out of order in ~S" prev conf block)))
 
-      (unless (find-in #'global-conflicts-tn-next
+      (unless (find-in #'global-conflicts-next-tnwise
 		       conf
 		       (tn-global-conflicts
 			(global-conflicts-tn conf)))
@@ -813,38 +813,35 @@
 	    (barf "strange TN ~S in LTN map for ~S" tn block)))))))
 
 ;;; All TNs live at the beginning of an environment must be passing
-;;; locations associated with that environment. We make an exception for wired
-;;; TNs in XEP functions, since we randomly reference wired TNs to access the
-;;; full call passing locations.
+;;; locations associated with that environment. We make an exception
+;;; for wired TNs in XEP functions, since we randomly reference wired
+;;; TNs to access the full call passing locations.
 (defun check-environment-lifetimes (component)
   (dolist (fun (component-lambdas component))
-    (let* ((env (lambda-environment fun))
-	   (2env (environment-info env))
+    (let* ((env (lambda-physenv fun))
+	   (2env (physenv-info env))
 	   (vars (lambda-vars fun))
-	   (closure (ir2-environment-environment 2env))
-	   (pc (ir2-environment-return-pc-pass 2env))
-	   (fp (ir2-environment-old-fp 2env))
-	   (2block (block-info
-		    (node-block
-		     (lambda-bind
-		      (environment-function env))))))
+	   (closure (ir2-physenv-closure 2env))
+	   (pc (ir2-physenv-return-pc-pass 2env))
+	   (fp (ir2-physenv-old-fp 2env))
+	   (2block (block-info (lambda-block (physenv-lambda env)))))
       (do ((conf (ir2-block-global-tns 2block)
-		 (global-conflicts-next conf)))
+		 (global-conflicts-next-blockwise conf)))
 	  ((null conf))
 	(let ((tn (global-conflicts-tn conf)))
 	  (unless (or (eq (global-conflicts-kind conf) :write)
 		      (eq tn pc)
 		      (eq tn fp)
-		      (and (external-entry-point-p fun)
-			   (tn-offset tn))
+		      (and (xep-p fun) (tn-offset tn))
 		      (member (tn-kind tn) '(:environment :debug-environment))
 		      (member tn vars :key #'leaf-info)
 		      (member tn closure :key #'cdr))
 	    (barf "strange TN live at head of ~S: ~S" env tn))))))
   (values))
 
-;;; Check for some basic sanity in the TN conflict data structures, and also
-;;; check that no TNs are unexpectedly live at environment entry.
+;;; Check for some basic sanity in the TN conflict data structures,
+;;; and also check that no TNs are unexpectedly live at environment
+;;; entry.
 (defun check-life-consistency (component)
   (check-tn-conflicts component)
   (check-block-conflicts component)
@@ -874,65 +871,64 @@
 
 ;;;; data structure dumping routines
 
-;;; When we print Continuations and TNs, we assign them small numeric IDs so
-;;; that we can get a handle on anonymous objects given a printout.
-(macrolet ((def-frob (counter vto vfrom fto ffrom)
+;;; When we print CONTINUATIONs and TNs, we assign them small numeric
+;;; IDs so that we can get a handle on anonymous objects given a
+;;; printout.
+;;;
+;;; FIXME:
+;;;   * Perhaps this machinery should be #!+SB-SHOW.
+;;;   * Probably the hash tables should either be weak hash tables,
+;;;     or only allocated within a single compilation unit. Otherwise
+;;;     there will be a tendency for them to grow without bound and
+;;;     keep garbage from being collected.
+(macrolet ((def (counter vto vfrom fto ffrom)
 	     `(progn
+		(declaim (type hash-table ,vto ,vfrom))
 		(defvar ,vto (make-hash-table :test 'eq))
 		(defvar ,vfrom (make-hash-table :test 'eql))
-		(proclaim '(hash-table ,vto ,vfrom))
+		(declaim (type fixnum ,counter))
 		(defvar ,counter 0)
-		(proclaim '(fixnum ,counter))
-		
+
 		(defun ,fto (x)
 		  (or (gethash x ,vto)
 		      (let ((num (incf ,counter)))
 			(setf (gethash num ,vfrom) x)
 			(setf (gethash x ,vto) num))))
-		
+
 		(defun ,ffrom (num)
 		  (values (gethash num ,vfrom))))))
-  (def-frob *continuation-number* *continuation-numbers* *number-continuations* cont-num num-cont)
-  (def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn)
-  (def-frob *label-id* *id-labels* *label-ids* label-id id-label))
+  (def *continuation-number* *continuation-numbers* *number-continuations*
+       cont-num num-cont)
+  (def *tn-id* *tn-ids* *id-tns* tn-id id-tn)
+  (def *label-id* *id-labels* *label-ids* label-id id-label))
 
-;;; Print out a terse one-line description of a leaf.
+;;; Print a terse one-line description of LEAF.
 (defun print-leaf (leaf &optional (stream *standard-output*))
   (declare (type leaf leaf) (type stream stream))
   (etypecase leaf
-    (lambda-var (prin1 (leaf-name leaf) stream))
+    (lambda-var (prin1 (leaf-debug-name leaf) stream))
     (constant (format stream "'~S" (constant-value leaf)))
     (global-var
-     (format stream "~S {~A}" (leaf-name leaf) (global-var-kind leaf)))
-    (clambda
-      (format stream "lambda ~S ~S" (leaf-name leaf)
-	      (mapcar #'leaf-name (lambda-vars leaf))))
-    (optional-dispatch
-     (format stream "optional-dispatch ~S" (leaf-name leaf)))
+     (format stream "~S {~A}" (leaf-debug-name leaf) (global-var-kind leaf)))
     (functional
-     (aver (eq (functional-kind leaf) :top-level-xep))
-     (format stream "TL-XEP ~S"
-	     (let ((info (leaf-info leaf)))
-	       (etypecase info
-		 (entry-info (entry-info-name info))
-		 (byte-lambda-info :byte-compiled-entry)))))))
+     (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf)))))
 
 ;;; Attempt to find a block given some thing that has to do with it.
-(declaim (ftype (function (t) cblock) block-or-lose))
+(declaim (ftype (sfunction (t) cblock) block-or-lose))
 (defun block-or-lose (thing)
   (ctypecase thing
     (cblock thing)
     (ir2-block (ir2-block-block thing))
     (vop (block-or-lose (vop-block thing)))
     (tn-ref (block-or-lose (tn-ref-vop thing)))
-    (continuation (continuation-block thing))
+    (ctran (ctran-block thing))
     (node (node-block thing))
     (component (component-head thing))
 #|    (cloop (loop-head thing))|#
-    (integer (continuation-block (num-cont thing)))
-    (functional (node-block (lambda-bind (main-entry thing))))
+    (integer (ctran-block (num-cont thing)))
+    (functional (lambda-block (main-entry thing)))
     (null (error "Bad thing: ~S." thing))
-    (symbol (block-or-lose (gethash thing *free-functions*)))))
+    (symbol (block-or-lose (gethash thing *free-funs*)))))
 
 ;;; Print cN.
 (defun print-continuation (cont)
@@ -940,65 +936,111 @@
   (format t " c~D" (cont-num cont))
   (values))
 
-;;; Print out the nodes in Block in a format oriented toward representing
-;;; what the code does.
+(defun print-ctran (cont)
+  (declare (type ctran cont))
+  (format t "c~D " (cont-num cont))
+  (values))
+(defun print-lvar (cont)
+  (declare (type lvar cont))
+  (format t "v~D " (cont-num cont))
+  (values))
+
+(defun print-lvar-stack (stack &optional (stream *standard-output*))
+  (loop for (lvar . rest) on stack
+        do (format stream "~:[u~;d~]v~D~@[ ~]"
+                   (lvar-dynamic-extent lvar) (cont-num lvar) rest)))
+
+;;; Print out the nodes in BLOCK in a format oriented toward
+;;; representing what the code does.
 (defun print-nodes (block)
   (setq block (block-or-lose block))
-  (format t "~%block start c~D" (cont-num (block-start block)))
-
-  (let ((last (block-last block)))
-    (terpri)
-    (do ((cont (block-start block) (node-cont (continuation-next cont))))
-	(())
-      (let ((node (continuation-next cont)))
-	(format t "~3D: " (cont-num (node-cont node)))
-	(etypecase node
-	  (ref (print-leaf (ref-leaf node)))
-	  (basic-combination
-	   (let ((kind (basic-combination-kind node)))
-	     (format t "~(~A ~A~) c~D"
-		     (if (function-info-p kind) "known" kind)
-		     (type-of node)
-		     (cont-num (basic-combination-fun node)))
-	     (dolist (arg (basic-combination-args node))
-	       (if arg
-		   (print-continuation arg)
-		   (format t " <none>")))))
-	  (cset
-	   (write-string "set ")
-	   (print-leaf (set-var node))
-	   (print-continuation (set-value node)))
-	  (cif
-	   (format t "if c~D" (cont-num (if-test node)))
-	   (print-continuation (block-start (if-consequent node)))
-	   (print-continuation (block-start (if-alternative node))))
-	  (bind
-	   (write-string "bind ")
-	   (print-leaf (bind-lambda node)))
-	  (creturn
-	   (format t "return c~D " (cont-num (return-result node)))
-	   (print-leaf (return-lambda node)))
-	  (entry
-	   (format t "entry ~S" (entry-exits node)))
-	  (exit
-	   (let ((value (exit-value node)))
-	     (cond (value
-		    (format t "exit c~D" (cont-num value)))
-		   ((exit-entry node)
-		    (format t "exit <no value>"))
-		   (t
-		    (format t "exit <degenerate>"))))))
-	(terpri)
-	(when (eq node last) (return)))))
-
-  (let ((succ (block-succ block)))
-    (format t "successors~{ c~D~}~%"
-	    (mapcar #'(lambda (x) (cont-num (block-start x))) succ)))
+  (pprint-logical-block (nil nil)
+    (format t "~:@_IR1 block ~D start c~D"
+            (block-number block) (cont-num (block-start block)))
+    (when (block-delete-p block)
+      (format t " <deleted>"))
+
+    (pprint-newline :mandatory)
+    (awhen (block-info block)
+      (format t "start stack: ")
+      (print-lvar-stack (ir2-block-start-stack it))
+      (pprint-newline :mandatory))
+    (do ((ctran (block-start block) (node-next (ctran-next ctran))))
+        ((not ctran))
+      (let ((node (ctran-next ctran)))
+        (format t "~3D>~:[    ~;~:*~3D:~] "
+                (cont-num ctran)
+                (when (and (valued-node-p node) (node-lvar node))
+                  (cont-num (node-lvar node))))
+        (etypecase node
+          (ref (print-leaf (ref-leaf node)))
+          (basic-combination
+           (let ((kind (basic-combination-kind node)))
+             (format t "~(~A~A ~A~) "
+                     (if (node-tail-p node) "tail " "")
+                     kind
+                     (type-of node))
+             (print-lvar (basic-combination-fun node))
+             (dolist (arg (basic-combination-args node))
+               (if arg
+                   (print-lvar arg)
+                   (format t "<none> ")))))
+          (cset
+           (write-string "set ")
+           (print-leaf (set-var node))
+           (write-char #\space)
+           (print-lvar (set-value node)))
+          (cif
+           (write-string "if ")
+           (print-lvar (if-test node))
+           (print-ctran (block-start (if-consequent node)))
+           (print-ctran (block-start (if-alternative node))))
+          (bind
+           (write-string "bind ")
+           (print-leaf (bind-lambda node))
+           (when (functional-kind (bind-lambda node))
+             (format t " ~S ~S" :kind (functional-kind (bind-lambda node)))))
+          (creturn
+           (write-string "return ")
+           (print-lvar (return-result node))
+           (print-leaf (return-lambda node)))
+          (entry
+           (let ((cleanup (entry-cleanup node)))
+             (case (cleanup-kind cleanup)
+               ((:dynamic-extent)
+                (format t "entry DX~{ v~D~}"
+                        (mapcar #'cont-num (cleanup-info cleanup))))
+               (t
+                (format t "entry ~S" (entry-exits node))))))
+          (exit
+           (let ((value (exit-value node)))
+             (cond (value
+                    (format t "exit ")
+                    (print-lvar value))
+                   ((exit-entry node)
+                    (format t "exit <no value>"))
+                   (t
+                    (format t "exit <degenerate>")))))
+          (cast
+           (let ((value (cast-value node)))
+             (format t "cast v~D ~A[~S -> ~S]" (cont-num value)
+                     (if (cast-%type-check node) #\+ #\-)
+                     (cast-type-to-check node)
+                     (cast-asserted-type node)))))
+        (pprint-newline :mandatory)))
+
+    (awhen (block-info block)
+      (format t "end stack: ")
+      (print-lvar-stack (ir2-block-end-stack it))
+      (pprint-newline :mandatory))
+    (let ((succ (block-succ block)))
+      (format t "successors~{ c~D~}~%"
+              (mapcar (lambda (x) (cont-num (block-start x))) succ))))
   (values))
 
-;;; Print a useful representation of a TN. If the TN has a leaf, then do a
-;;; Print-Leaf on that, otherwise print a generated ID.
-(defun print-tn (tn &optional (stream *standard-output*))
+;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T)
+;;; and printers for compound objects which contain TNs)
+(defun print-tn-guts (tn &optional (stream *standard-output*))
   (declare (type tn tn))
   (let ((leaf (tn-leaf tn)))
     (cond (leaf
@@ -1009,8 +1051,8 @@
     (when (and (tn-sc tn) (tn-offset tn))
       (format stream "[~A]" (location-print-name tn)))))
 
-;;; Print the TN-Refs representing some operands to a VOP, linked by
-;;; TN-Ref-Across.
+;;; Print the TN-REFs representing some operands to a VOP, linked by
+;;; TN-REF-ACROSS.
 (defun print-operands (refs)
   (declare (type (or tn-ref null) refs))
   (pprint-logical-block (*standard-output* nil)
@@ -1019,15 +1061,15 @@
       (let ((tn (tn-ref-tn ref))
 	    (ltn (tn-ref-load-tn ref)))
 	(cond ((not ltn)
-	       (print-tn tn))
+	       (print-tn-guts tn))
 	      (t
-	       (print-tn tn)
+	       (print-tn-guts tn)
 	       (princ (if (tn-ref-write-p ref) #\< #\>))
-	       (print-tn ltn)))
+	       (print-tn-guts ltn)))
 	(princ #\space)
 	(pprint-newline :fill)))))
 
-;;; Print the vop, putting args, info and results on separate lines, if
+;;; Print the VOP, putting args, info and results on separate lines, if
 ;;; necessary.
 (defun print-vop (vop)
   (pprint-logical-block (*standard-output* nil)
@@ -1045,29 +1087,32 @@
     (when (vop-results vop)
       (princ "=> ")
       (print-operands (vop-results vop))))
-  (terpri))
+  (pprint-newline :mandatory))
 
 ;;; Print the VOPs in the specified IR2 block.
 (defun print-ir2-block (block)
   (declare (type ir2-block block))
-  (cond
-   ((eq (block-info (ir2-block-block block)) block)
-    (format t "~%IR2 block start c~D~%"
-	    (cont-num (block-start (ir2-block-block block))))
-    (let ((label (ir2-block-%label block)))
-      (when label
-	(format t "L~D:~%" (label-id label)))))
-   (t
-    (format t "<overflow>~%")))
-
-  (do ((vop (ir2-block-start-vop block)
-	    (vop-next vop))
-       (number 0 (1+ number)))
-      ((null vop))
-    (format t "~D: " number)
-    (print-vop vop)))
+  (pprint-logical-block (*standard-output* nil)
+    (cond
+      ((eq (block-info (ir2-block-block block)) block)
+       (format t "~:@_IR2 block ~D start c~D~:@_"
+               (ir2-block-number block)
+               (cont-num (block-start (ir2-block-block block))))
+       (let ((label (ir2-block-%label block)))
+         (when label
+           (format t "L~D:~:@_" (label-id label)))))
+      (t
+       (format t "<overflow>~:@_")))
+
+    (do ((vop (ir2-block-start-vop block)
+              (vop-next vop))
+         (number 0 (1+ number)))
+        ((null vop))
+      (format t "~W: " number)
+      (print-vop vop))))
 
-;;; Like Print-Nodes, but dumps the IR2 representation of the code in Block.
+;;; This is like PRINT-NODES, but dumps the IR2 representation of the
+;;; code in BLOCK.
 (defun print-vops (block)
   (setq block (block-or-lose block))
   (let ((2block (block-info block)))
@@ -1078,13 +1123,28 @@
   (values))
 
 ;;; Scan the IR2 blocks in emission order.
-(defun print-ir2-blocks (thing)
-  (do-ir2-blocks (block (block-component (block-or-lose thing)))
-    (print-ir2-block block))
+(defun print-ir2-blocks (thing &optional full)
+  (let* ((block (component-head (block-component (block-or-lose thing))))
+         (2block (block-info block)))
+    (pprint-logical-block (nil nil)
+      (loop while 2block
+         do (setq block (ir2-block-block 2block))
+         do (pprint-logical-block (*standard-output* nil)
+              (if full
+                  (print-nodes block)
+                  (format t "IR1 block ~D start c~D"
+                          (block-number block)
+                          (cont-num (block-start block))))
+              (pprint-indent :block 4)
+              (pprint-newline :mandatory)
+              (loop while (and 2block (eq (ir2-block-block 2block) block))
+                 do (print-ir2-block 2block)
+                 do (setq 2block (ir2-block-next 2block))))
+         do (pprint-newline :mandatory))))
   (values))
 
-;;; Do a Print-Nodes on Block and all blocks reachable from it by successor
-;;; links.
+;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by
+;;; successor links.
 (defun print-blocks (block)
   (setq block (block-or-lose block))
   (do-blocks (block (block-component block) :both)
@@ -1099,7 +1159,7 @@
     (walk block))
   (values))
 
-;;; Print all blocks in Block's component in DFO.
+;;; Print all blocks in BLOCK's component in DFO.
 (defun print-all-blocks (thing)
   (do-blocks (block (block-component (block-or-lose thing)))
     (handler-case (print-nodes block)
@@ -1109,12 +1169,12 @@
 
 (defvar *list-conflicts-table* (make-hash-table :test 'eq))
 
-;;; Add all Always-Live TNs in Block to the conflicts. TN is ignored when
-;;; it appears in the global conflicts.
+;;; Add all ALWAYS-LIVE TNs in BLOCK to the conflicts. TN is ignored
+;;; when it appears in the global conflicts.
 (defun add-always-live-tns (block tn)
   (declare (type ir2-block block) (type tn tn))
   (do ((conf (ir2-block-global-tns block)
-	     (global-conflicts-next conf)))
+	     (global-conflicts-next-blockwise conf)))
       ((null conf))
     (when (eq (global-conflicts-kind conf) :live)
       (let ((btn (global-conflicts-tn conf)))
@@ -1122,7 +1182,7 @@
 	  (setf (gethash btn *list-conflicts-table*) t)))))
   (values))
 
-;;; Add all local TNs in block to the conflicts.
+;;; Add all local TNs in BLOCK to the conflicts.
 (defun add-all-local-tns (block)
   (declare (type ir2-block block))
   (let ((ltns (ir2-block-local-tns block)))
@@ -1133,10 +1193,10 @@
 ;;; Make a list out of all of the recorded conflicts.
 (defun listify-conflicts-table ()
   (collect ((res))
-    (maphash #'(lambda (k v)
-		 (declare (ignore v))
-		 (when k
-		   (res k)))
+    (maphash (lambda (k v)
+	       (declare (ignore v))
+	       (when k
+		 (res k)))
 	     *list-conflicts-table*)
     (clrhash *list-conflicts-table*)
     (res)))
@@ -1148,8 +1208,12 @@
   (let ((confs (tn-global-conflicts tn)))
     (cond (confs
 	   (clrhash *list-conflicts-table*)
-	   (do ((conf confs (global-conflicts-tn-next conf)))
+	   (do ((conf confs (global-conflicts-next-tnwise conf)))
 	       ((null conf))
+             (format t "~&#<block ~D kind ~S>~%"
+                     (block-number (ir2-block-block (global-conflicts-block
+						     conf)))
+                     (global-conflicts-kind conf))
 	     (let ((block (global-conflicts-block conf)))
 	       (add-always-live-tns block tn)
 	       (if (eq (global-conflicts-kind conf) :live)
@@ -1173,7 +1237,7 @@
 				(not (tn-global-conflicts tn)))
 		       (res tn)))))
 	       (do ((gtn (ir2-block-global-tns block)
-			 (global-conflicts-next gtn)))
+			 (global-conflicts-next-blockwise gtn)))
 		   ((null gtn))
 		 (when (or (eq (global-conflicts-kind gtn) :live)
 			   (/= (sbit confs (global-conflicts-number gtn)) 0))
@@ -1182,7 +1246,7 @@
 
 (defun nth-vop (thing n)
   #!+sb-doc
-  "Return the Nth VOP in the IR2-Block pointed to by Thing."
+  "Return the Nth VOP in the IR2-BLOCK pointed to by THING."
   (let ((block (block-info (block-or-lose thing))))
     (do ((i 0 (1+ i))
 	 (vop (ir2-block-start-vop block) (vop-next vop)))