X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=f4be0a0e2e91c2e30f679239b134a4063ccec546;hb=54da325f13fb41669869aea688ae195426c0e231;hp=b29ac89177c2e14ddf1a5b2ce85d7787c0b9e09c;hpb=d5393dd736972a5c84cd97fec9892cd3da80b669;p=sbcl.git

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index b29ac89..f4be0a0 100644
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -15,7 +15,7 @@
 (defvar *args* ()
   #!+sb-doc
   "This variable is bound to the format arguments when an error is signalled
-  by BARF or BURP.")
+by BARF or BURP.")
 
 (defvar *ignored-errors* (make-hash-table :test 'equal))
 
@@ -25,18 +25,18 @@
 (defun barf (string &rest *args*)
   (unless (gethash string *ignored-errors*)
     (restart-case
-	(apply #'error string *args*)
+        (apply #'error string *args*)
       (continue ()
-	:report "Ignore this error.")
+        :report "Ignore this error.")
       (ignore-all ()
-	:report "Ignore this and all future occurrences of this error."
-	(setf (gethash string *ignored-errors*) t))))
+        :report "Ignore this and all future occurrences of this error."
+        (setf (gethash string *ignored-errors*) t))))
   (values))
 
 (defvar *burp-action* :warn
   #!+sb-doc
   "Action taken by the BURP function when a possible compiler bug is detected.
-  One of :WARN, :ERROR or :NONE.")
+One of :WARN, :ERROR or :NONE.")
 (declaim (type (member :warn :error :none) *burp-action*))
 
 ;;; Called when something funny but possibly correct is noticed.
@@ -56,14 +56,14 @@
 ;;; 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))
+(defvar *seen-blocks*)
+(defvar *seen-funs*)
 
 ;;; 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))
 
@@ -79,78 +79,79 @@
 ;;; hashtables, looking for lossage.
 (declaim (ftype (function (list) (values)) check-ir1-consistency))
 (defun check-ir1-consistency (components)
-  (clrhash *seen-blocks*)
-  (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)))
-	(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)))
-	(setf (gethash block *seen-blocks*) t)
-	(unless (eq (block-prev block) prev)
-	  (barf "bad PREV for ~S, should be ~S" block prev))
-	(unless (or (eq block tail)
-		    (eq (block-component block) c))
-	  (barf "~S is not in ~S." block c)))
-#|
-      (when (or (loop-blocks c) (loop-inferiors c))
-	(do-blocks (block c :both)
-	  (setf (block-flag block) nil))
-	(check-loop-consistency c nil)
-	(do-blocks (block c :both)
-	  (unless (block-flag block)
-	    (barf "~S was not in any loop." block))))
-|#
-    ))
-
-  (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))))
-	       (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-FUNS* entry: ~S" v))
-	     (dolist (n (leaf-refs v))
-	       (check-node-reached n)))
-	   *free-funs*)
-  (clrhash *seen-funs*)
-  (clrhash *seen-blocks*)
-  (values))
+  (let ((*seen-blocks* (make-hash-table :test 'eq))
+        (*seen-funs* (make-hash-table :test 'eq)))
+    (unwind-protect
+         (progn
+           (dolist (c components)
+             (let* ((head (component-head c))
+                    (tail (component-tail c)))
+               (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)))
+                 (setf (gethash block *seen-blocks*) t)
+                 (unless (eq (block-prev block) prev)
+                   (barf "bad PREV for ~S, should be ~S" block prev))
+                 (unless (or (eq block tail)
+                             (eq (block-component block) c))
+                   (barf "~S is not in ~S." block c)))
+               #|
+               (when (or (loop-blocks c) (loop-inferiors c))
+               (do-blocks (block c :both)
+               (setf (block-flag block) nil))
+               (check-loop-consistency c nil)
+               (do-blocks (block c :both)
+               (unless (block-flag block)
+               (barf "~S was not in any loop." block))))
+               |#
+               ))
+           (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 :unknown))))
+                        (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-FUNS* entry: ~S" v))
+                      (dolist (n (leaf-refs v))
+                        (check-node-reached n)))
+                    *free-funs*))
+      (clrhash *seen-blocks*)
+      (clrhash *seen-funs*))
+    (values)))
 
 ;;;; function consistency checking
 
@@ -176,9 +177,9 @@
      (let ((fun (functional-entry-fun functional)))
        (check-fun-reached fun functional)
        (when (functional-kind fun)
-	 (barf "The function for XEP ~S has kind." functional))
+         (barf "The function for XEP ~S has kind." functional))
        (unless (eq (functional-entry-fun fun) functional)
-	 (barf "bad back-pointer in function for XEP ~S" functional))))
+         (barf "bad back-pointer in function for XEP ~S" functional))))
     ((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P
      (check-fun-reached (lambda-home functional) functional)
      (when (functional-entry-fun functional)
@@ -187,7 +188,7 @@
        (barf "The LET ~S is not in LETs for HOME." functional))
      (unless (eq (functional-kind functional) :assignment)
        (when (rest (leaf-refs functional))
-	 (barf "The LET ~S has multiple references." functional)))
+         (barf "The LET ~S has multiple references." functional)))
      (when (lambda-lets functional)
        (barf "LETs in a LET: ~S" functional)))
     (:optional
@@ -195,20 +196,23 @@
        (barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
      (let ((ef (lambda-optional-dispatch functional)))
        (check-fun-reached ef functional)
-       (unless (or (member functional (optional-dispatch-entry-points ef))
-		   (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))))
+       (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))))
     (: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-fun functional)))
        (when ef
-	 (check-fun-reached ef functional)
-	 (unless (eq (functional-kind ef) :external)
-	   (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
+         (check-fun-reached ef functional)
+         (unless (eq (functional-kind ef) :external)
+           (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
     (:deleted
      (return-from check-fun-stuff)))
 
@@ -216,11 +220,11 @@
     ((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-fun-reached fun functional))
+         (unless (eq (lambda-home fun) functional)
+           (barf "The home in ~S is not ~S." fun functional))
+         (check-fun-reached fun functional))
        (unless (eq (lambda-home functional) functional)
-	 (barf "home not self-pointer in ~S" functional)))))
+         (barf "home not self-pointer in ~S" functional)))))
 
   (etypecase functional
     (clambda
@@ -231,18 +235,19 @@
 
      (dolist (var (lambda-vars functional))
        (dolist (ref (leaf-refs var))
-	 (check-node-reached ref))
+         (check-node-reached ref))
        (dolist (set (basic-var-sets var))
-	 (check-node-reached set))
+         (check-node-reached set))
        (unless (eq (lambda-var-home var) functional)
-	 (barf "HOME in ~S should be ~S." var functional))))
+         (barf "HOME in ~S should be ~S." var functional))))
     (optional-dispatch
      (dolist (ep (optional-dispatch-entry-points functional))
-       (check-fun-reached ep functional))
+       (when (promise-ready-p ep)
+         (check-fun-reached (force ep) functional)))
      (let ((more (optional-dispatch-more-entry functional)))
        (when more (check-fun-reached more functional)))
      (check-fun-reached (optional-dispatch-main-entry functional)
-			functional))))
+                        functional))))
 
 (defun check-fun-consistency (components)
   (dolist (c components)
@@ -250,22 +255,22 @@
       (observe-functional new-fun))
     (dolist (fun (component-lambdas c))
       (when (eq (functional-kind fun) :external)
-	(let ((ef (functional-entry-fun fun)))
-	  (when (optional-dispatch-p ef)
-	    (observe-functional ef))))
+        (let ((ef (functional-entry-fun fun)))
+          (when (optional-dispatch-p ef)
+            (observe-functional ef))))
       (observe-functional fun)
       (dolist (let (lambda-lets fun))
-	(observe-functional let))))
+        (observe-functional let))))
 
   (dolist (c components)
     (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))
+        (barf "deleted lambda ~S in Lambdas for ~S" fun c))
       (check-fun-stuff fun)
       (dolist (let (lambda-lets fun))
-	(check-fun-stuff let)))))
+        (check-fun-stuff let)))))
 
 ;;;; loop consistency checking
 
@@ -279,7 +284,7 @@
   (unless (eq (loop-superior loop) superior)
     (barf "wrong superior in ~S, should be ~S" loop superior))
   (when (and superior
-	     (/= (loop-depth loop) (1+ (loop-depth superior))))
+             (/= (loop-depth loop) (1+ (loop-depth superior))))
     (barf "wrong depth in ~S" loop))
 
   (dolist (tail (loop-tail loop))
@@ -308,10 +313,10 @@
   (unless (gethash block *seen-blocks*)
     (barf "unseen block ~S in loop info for ~S" block loop))
   (labels ((walk (l)
-	     (if (eq (block-loop block) l)
-		 t
-		 (dolist (inferior (loop-inferiors l) nil)
-		   (when (walk inferior) (return t))))))
+             (if (eq (block-loop block) l)
+                 t
+                 (dolist (inferior (loop-inferiors l) nil)
+                   (when (walk inferior) (return t))))))
     (unless (walk loop)
       (barf "~S is in loop info for ~S but not in the loop." block loop)))
   (values))
@@ -331,83 +336,61 @@
       (barf "bad predecessor link ~S in ~S" pred block)))
 
   (let* ((fun (block-home-lambda block))
-	 (fun-deleted (eq (functional-kind fun) :deleted))
-	 (this-cont (block-start block))
-	 (last (block-last block)))
+         (fun-deleted (eq (functional-kind fun) :deleted))
+         (this-ctran (block-start block))
+         (last (block-last block)))
     (unless fun-deleted
       (check-fun-reached fun block))
-    (when (not this-cont)
+    (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)))
+    (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 (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))
-
-	(unless fun-deleted
-	  (check-node-consistency node))
-
-	(let ((cont (node-cont node)))
-	  (when (not cont)
-	    (barf "~S has no CONT." 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
-		  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 (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 ((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 (ctran-kind next) :inside-block)
+            (barf "The interior ctran ~S in ~S has the wrong kind."
+                  next
+                  block))
+          (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))
@@ -417,65 +400,59 @@
 (declaim (ftype (function (cblock) (values)) check-block-successors))
 (defun check-block-successors (block)
   (let ((last (block-last block))
-	(succ (block-succ block)))
+        (succ (block-succ block)))
 
     (let* ((comp (block-component block)))
       (dolist (b succ)
-	(unless (gethash b *seen-blocks*)
-	  (barf "unseen successor ~S in ~S" b block))
-	(unless (member block (block-pred b))
-	  (barf "bad successor link ~S in ~S" b block))
-	(unless (eq (block-component b) comp)
-	  (barf "The successor ~S in ~S is in a different component."
-		b
-		block))))
+        (unless (gethash b *seen-blocks*)
+          (barf "unseen successor ~S in ~S" b block))
+        (unless (member block (block-pred b))
+          (barf "bad successor link ~S in ~S" b block))
+        (unless (eq (block-component b) comp)
+          (barf "The successor ~S in ~S is in a different component."
+                b
+                block))))
 
     (typecase last
       (cif
        (unless (proper-list-of-length-p succ 1 2)
-	 (barf "~S ends in an IF, but doesn't have one or two succesors."
-	       block))
+         (barf "~S ends in an IF, but doesn't have one or two successors."
+               block))
        (unless (member (if-consequent last) succ)
-	 (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
+         (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
        (unless (member (if-alternative last) succ)
-	 (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
+         (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
       (creturn
        (unless (if (eq (functional-kind (return-lambda last)) :deleted)
-		   (null succ)
-		   (and (= (length succ) 1)
-			(eq (first succ)
-			    (component-tail (block-component block)))))
-	 (barf "strange successors for RETURN in ~S" block)))
+                   (null succ)
+                   (and (= (length succ) 1)
+                        (eq (first succ)
+                            (component-tail (block-component block)))))
+         (barf "strange successors for RETURN in ~S" block)))
       (exit
        (unless (proper-list-of-length-p succ 0 1)
-	 (barf "EXIT node with strange number of successors: ~S" last)))
+         (barf "EXIT node with strange number of successors: ~S" last)))
       (t
        (unless (or (= (length succ) 1) (node-tail-p last)
-		   (and (block-delete-p block) (null succ)))
-	 (barf "~S ends in normal node, but doesn't have one successor."
-	       block)))))
+                   (and (block-delete-p block) (null succ)))
+         (barf "~S ends in normal node, but doesn't have one successor."
+               block)))))
   (values))
 
 ;;;; 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 of the
@@ -486,42 +463,54 @@
     (ref
      (let ((leaf (ref-leaf node)))
        (when (functional-p leaf)
-	 (if (eq (functional-kind leaf) :toplevel-xep)
-	     (unless (eq (component-kind (block-component (node-block node)))
-			 :toplevel)
-	       (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
-		     node))
-	     (check-fun-reached leaf node)))))
+         (if (eq (functional-kind leaf) :toplevel-xep)
+             (unless (component-toplevelish-p (block-component (node-block node)))
+               (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
+                     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
-	 (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 (continuation-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 ((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))
-			   (lambda-tail-set (return-lambda dest)))))
-	 (barf "tail local call to function with different tail set:~%  ~S"
-	       node))))
+                  (eq (basic-combination-kind node) :local)
+                  (not (eq (lambda-tail-set (combination-lambda node))
+                           (lambda-tail-set (return-lambda dest)))))
+         (barf "tail local call to function with different tail set:~%  ~S"
+               node))))
     (cif
      (check-dest (if-test node) node)
      (unless (eq (block-last (node-block node)) node)
@@ -542,19 +531,19 @@
        (barf "~S is not in ENTRIES for its home LAMBDA." node))
      (dolist (exit (entry-exits node))
        (unless (node-deleted exit)
-	 (check-node-reached node))))
+         (check-node-reached node))))
     (exit
      (let ((entry (exit-entry node))
-	   (value (exit-value node)))
+           (value (exit-value node)))
        (cond (entry
-	      (check-node-reached entry)
-	      (unless (member node (entry-exits entry))
-		(barf "~S is not in its ENTRY's EXITS." node))
-	      (when value
-		(check-dest value node)))
-	     (t
-	      (when value
-		(barf "~S has VALUE but no ENTRY." node)))))))
+              (check-node-reached entry)
+              (unless (member node (entry-exits entry))
+                (barf "~S is not in its ENTRY's EXITS." node))
+              (when value
+                (check-dest value node)))
+             (t
+              (when value
+                (barf "~S has VALUE but no ENTRY." node)))))))
 
   (values))
 
@@ -569,32 +558,32 @@
 (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 ~W ~A in ~S, but there are only ~W."
-		 count what vop num))
-	 (when (and (not more-p) (> num count))
-	   (barf "There should be ~W ~A in ~S, but are ~W."
-		 count what vop num)))
+         (num 0 (1+ num)))
+        ((null ref)
+         (when (< num count)
+           (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 ~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))
+        (barf "VOP is ~S isn't ~S." ref vop))
       (unless (eq (tn-ref-write-p ref) write-p)
-	(barf "The WRITE-P in ~S isn't ~S." vop write-p))
+        (barf "The WRITE-P in ~S isn't ~S." vop write-p))
       (unless (find-in #'tn-ref-next-ref ref vop-refs)
-	(barf "~S not found in REFS for ~S" ref vop))
+        (barf "~S not found in REFS for ~S" ref vop))
       (unless (find-in #'tn-ref-next ref
-		       (if (tn-ref-write-p ref)
-			   (tn-writes (tn-ref-tn ref))
-			   (tn-reads (tn-ref-tn ref))))
-	(barf "~S not found in reads/writes for its TN" ref))
+                       (if (tn-ref-write-p ref)
+                           (tn-writes (tn-ref-tn ref))
+                           (tn-reads (tn-ref-tn ref))))
+        (barf "~S not found in reads/writes for its TN" ref))
 
       (let ((target (tn-ref-target ref)))
-	(when target
-	  (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
-	    (barf "The target for ~S isn't complementary WRITE-P." ref))
-	  (unless (find-in #'tn-ref-next-ref target vop-refs)
-	    (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
+        (when target
+          (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
+            (barf "The target for ~S isn't complementary WRITE-P." ref))
+          (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
 ;;; that each referenced TN appears as an argument, result or temp, and also
@@ -613,13 +602,13 @@
       (barf "stray ref that isn't a READ: ~S" ref))
      (t
       (let* ((tn (tn-ref-tn ref))
-	     (temp (find-in #'tn-ref-across tn (vop-temps vop)
-			    :key #'tn-ref-tn)))
-	(unless temp
-	  (barf "stray ref with no corresponding temp write: ~S" ref))
-	(unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
-	  (barf "Read is after write for temp ~S in refs of ~S."
-		tn vop))))))
+             (temp (find-in #'tn-ref-across tn (vop-temps vop)
+                            :key #'tn-ref-tn)))
+        (unless temp
+          (barf "stray ref with no corresponding temp write: ~S" ref))
+        (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
+          (barf "Read is after write for temp ~S in refs of ~S."
+                tn vop))))))
   (values))
 
 ;;; Check the basic sanity of the VOP linkage, then call some other
@@ -630,11 +619,11 @@
 (defun check-ir2-block-consistency (2block)
   (declare (type ir2-block 2block))
   (do ((vop (ir2-block-start-vop 2block)
-	    (vop-next vop))
+            (vop-next vop))
        (prev nil vop))
       ((null vop)
        (unless (eq prev (ir2-block-last-vop 2block))
-	 (barf "The last VOP in ~S should be ~S." 2block prev)))
+         (barf "The last VOP in ~S should be ~S." 2block prev)))
     (unless (eq (vop-prev vop) prev)
       (barf "PREV in ~S should be ~S." vop prev))
 
@@ -644,21 +633,21 @@
     (check-vop-refs vop)
 
     (let* ((info (vop-info vop))
-	   (atypes (template-arg-types info))
-	   (rtypes (template-result-types info)))
+           (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)))
-				   atypes)
-		     (template-more-args-type info) "args")
+                     (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
-		     (if (eq rtypes :conditional) 0 (length rtypes))
-		     (template-more-results-type info) "results")
+                     (if (template-conditional-p info) 0 (length rtypes))
+                     (template-more-results-type info) "results")
       (check-tn-refs (vop-temps vop) vop t 0 t "temps")
       (unless (= (length (vop-codegen-info vop))
-		 (template-info-arg-count info))
-	(barf "wrong number of codegen info args in ~S" vop))))
+                 (template-info-arg-count info))
+        (barf "wrong number of codegen info args in ~S" vop))))
   (values))
 
 ;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
@@ -677,44 +666,44 @@
 
 ;;; 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)
-	(local 0)
-	(confs 0)
-	(unused 0)
-	(const 0)
-	(temps 0)
-	(environment 0)
-	(comp 0))
+        (global 0)
+        (local 0)
+        (confs 0)
+        (unused 0)
+        (const 0)
+        (temps 0)
+        (environment 0)
+        (comp 0))
     (do-packed-tns (tn component)
       (let ((reads (tn-reads tn))
-	    (writes (tn-writes tn)))
-	(when (and reads writes
-		   (not (tn-ref-next reads)) (not (tn-ref-next writes))
-		   (eq (tn-ref-vop reads) (tn-ref-vop writes)))
-	  (incf temps)))
+            (writes (tn-writes tn)))
+        (when (and reads writes
+                   (not (tn-ref-next reads)) (not (tn-ref-next writes))
+                   (eq (tn-ref-vop reads) (tn-ref-vop writes)))
+          (incf temps)))
       (when (tn-offset tn)
-	(incf wired))
+        (incf wired))
       (unless (or (tn-reads tn) (tn-writes tn))
-	(incf unused))
+        (incf unused))
       (cond ((eq (tn-kind tn) :component)
-	     (incf comp))
-	    ((tn-global-conflicts tn)
-	     (case (tn-kind tn)
-	       ((:environment :debug-environment) (incf environment))
-	       (t (incf global)))
-	     (do ((conf (tn-global-conflicts tn)
-			(global-conflicts-next-tnwise conf)))
-		 ((null conf))
-	       (incf confs)))
-	    (t
-	     (incf local))))
+             (incf comp))
+            ((tn-global-conflicts tn)
+             (case (tn-kind tn)
+               ((:environment :debug-environment) (incf environment))
+               (t (incf global)))
+             (do ((conf (tn-global-conflicts tn)
+                        (global-conflicts-next-tnwise conf)))
+                 ((null conf))
+               (incf confs)))
+            (t
+             (incf local))))
 
     (do ((tn (ir2-component-constant-tns (component-info component))
-	     (tn-next tn)))
-	((null tn))
+             (tn-next tn)))
+        ((null tn))
       (incf const))
 
     (format stream
@@ -729,99 +718,99 @@
 ;;; for the validity of the usage.
 (defun check-more-tn-entry (tn block)
   (let* ((vop (ir2-block-start-vop block))
-	 (info (vop-info vop)))
+         (info (vop-info vop)))
     (macrolet ((frob (more-p ops)
-		 `(and (,more-p info)
-		       (find-in #'tn-ref-across tn (,ops vop)
-				:key #'tn-ref-tn))))
+                 `(and (,more-p info)
+                       (find-in #'tn-ref-across tn (,ops vop)
+                                :key #'tn-ref-tn))))
       (unless (and (eq vop (ir2-block-last-vop block))
-		   (or (frob template-more-args-type vop-args)
-		       (frob template-more-results-type vop-results)))
-	(barf "strange :MORE LTN entry for ~S in ~S" tn block))))
+                   (or (frob template-more-args-type vop-args)
+                       (frob template-more-results-type vop-results)))
+        (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
   (values))
 
 (defun check-tn-conflicts (component)
   (do-packed-tns (tn component)
     (unless (or (not (eq (tn-kind tn) :normal))
-		(tn-reads tn)
-		(tn-writes tn))
+                (tn-reads tn)
+                (tn-writes tn))
       (barf "no references to ~S" tn))
 
     (unless (tn-sc tn) (barf "~S has no SC." tn))
 
     (let ((conf (tn-global-conflicts tn))
-	  (kind (tn-kind tn)))
+          (kind (tn-kind tn)))
       (cond
        ((eq kind :component)
-	(unless (member tn (ir2-component-component-tns
-			    (component-info component)))
-	  (barf "~S not in COMPONENT-TNs for ~S" tn component)))
+        (unless (member tn (ir2-component-component-tns
+                            (component-info component)))
+          (barf "~S not in COMPONENT-TNs for ~S" tn component)))
        (conf
-	(do ((conf conf (global-conflicts-next-tnwise conf))
-	     (prev nil conf))
-	    ((null conf))
-	  (unless (eq (global-conflicts-tn conf) tn)
-	    (barf "TN in ~S should be ~S." conf tn))
-
-	  (unless (eq (global-conflicts-kind conf) :live)
-	    (let* ((block (global-conflicts-block conf))
-		   (ltn (svref (ir2-block-local-tns block)
-			       (global-conflicts-number conf))))
-	      (cond ((eq ltn tn))
-		    ((eq ltn :more) (check-more-tn-entry tn block))
-		    (t
-		     (barf "~S wrong in LTN map for ~S" conf tn)))))
-
-	  (when prev
-	    (unless (> (ir2-block-number (global-conflicts-block conf))
-		       (ir2-block-number (global-conflicts-block prev)))
-	      (barf "~s and ~s out of order" prev conf)))))
+        (do ((conf conf (global-conflicts-next-tnwise conf))
+             (prev nil conf))
+            ((null conf))
+          (unless (eq (global-conflicts-tn conf) tn)
+            (barf "TN in ~S should be ~S." conf tn))
+
+          (unless (eq (global-conflicts-kind conf) :live)
+            (let* ((block (global-conflicts-block conf))
+                   (ltn (svref (ir2-block-local-tns block)
+                               (global-conflicts-number conf))))
+              (cond ((eq ltn tn))
+                    ((eq ltn :more) (check-more-tn-entry tn block))
+                    (t
+                     (barf "~S wrong in LTN map for ~S" conf tn)))))
+
+          (when prev
+            (unless (> (ir2-block-number (global-conflicts-block conf))
+                       (ir2-block-number (global-conflicts-block prev)))
+              (barf "~s and ~s out of order" prev conf)))))
        ((member (tn-kind tn) '(:constant :specified-save)))
        (t
-	(let ((local (tn-local tn)))
-	  (unless local
-	    (barf "~S has no global conflicts, but isn't local either." tn))
-	  (unless (eq (svref (ir2-block-local-tns local)
-			     (tn-local-number tn))
-		      tn)
-	    (barf "~S wrong in LTN map" tn))
-	  (do ((ref (tn-reads tn) (tn-ref-next ref)))
-	      ((null ref))
-	    (unless (eq (vop-block (tn-ref-vop ref)) local)
-	      (barf "~S has references in blocks other than its LOCAL block."
-		    tn)))
-	  (do ((ref (tn-writes tn) (tn-ref-next ref)))
-	      ((null ref))
-	    (unless (eq (vop-block (tn-ref-vop ref)) local)
-	      (barf "~S has references in blocks other than its LOCAL block."
-		    tn))))))))
+        (let ((local (tn-local tn)))
+          (unless local
+            (barf "~S has no global conflicts, but isn't local either." tn))
+          (unless (eq (svref (ir2-block-local-tns local)
+                             (tn-local-number tn))
+                      tn)
+            (barf "~S wrong in LTN map" tn))
+          (do ((ref (tn-reads tn) (tn-ref-next ref)))
+              ((null ref))
+            (unless (eq (vop-block (tn-ref-vop ref)) local)
+              (barf "~S has references in blocks other than its LOCAL block."
+                    tn)))
+          (do ((ref (tn-writes tn) (tn-ref-next ref)))
+              ((null ref))
+            (unless (eq (vop-block (tn-ref-vop ref)) local)
+              (barf "~S has references in blocks other than its LOCAL block."
+                    tn))))))))
   (values))
 
 (defun check-block-conflicts (component)
   (do-ir2-blocks (block component)
     (do ((conf (ir2-block-global-tns block)
-	       (global-conflicts-next-blockwise conf))
-	 (prev nil conf))
-	((null conf))
+               (global-conflicts-next-blockwise conf))
+         (prev nil conf))
+        ((null conf))
       (when prev
-	(unless (> (tn-number (global-conflicts-tn conf))
-		   (tn-number (global-conflicts-tn prev)))
-	  (barf "~S and ~S out of order in ~S" prev conf block)))
+        (unless (> (tn-number (global-conflicts-tn conf))
+                   (tn-number (global-conflicts-tn prev)))
+          (barf "~S and ~S out of order in ~S" prev conf block)))
 
       (unless (find-in #'global-conflicts-next-tnwise
-		       conf
-		       (tn-global-conflicts
-			(global-conflicts-tn conf)))
-	(barf "~S missing from global conflicts of its TN" conf)))
+                       conf
+                       (tn-global-conflicts
+                        (global-conflicts-tn conf)))
+        (barf "~S missing from global conflicts of its TN" conf)))
 
     (let ((map (ir2-block-local-tns block)))
       (dotimes (i (ir2-block-local-tn-count block))
-	(let ((tn (svref map i)))
-	  (unless (or (eq tn :more)
-		      (null tn)
-		      (tn-global-conflicts tn)
-		      (eq (tn-local tn) block))
-	    (barf "strange TN ~S in LTN map for ~S" tn block)))))))
+        (let ((tn (svref map i)))
+          (unless (or (eq tn :more)
+                      (null tn)
+                      (tn-global-conflicts tn)
+                      (eq (tn-local tn) block))
+            (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
@@ -830,24 +819,24 @@
 (defun check-environment-lifetimes (component)
   (dolist (fun (component-lambdas component))
     (let* ((env (lambda-physenv fun))
-	   (2env (physenv-info env))
-	   (vars (lambda-vars fun))
-	   (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)))))
+           (2env (physenv-info env))
+           (vars (lambda-vars fun))
+           (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-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 (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))))))
+                 (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 (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,
@@ -862,22 +851,22 @@
 
 (defun check-pack-consistency (component)
   (flet ((check (scs ops)
-	   (do ((scs scs (cdr scs))
-		(op ops (tn-ref-across op)))
-	       ((null scs))
-	     (let ((load-tn (tn-ref-load-tn op)))
-	       (unless (eq (svref (car scs)
-				  (sc-number
-				   (tn-sc
-				    (or load-tn (tn-ref-tn op)))))
-			   t)
-		 (barf "operand restriction not satisfied: ~S" op))))))
+           (do ((scs scs (cdr scs))
+                (op ops (tn-ref-across op)))
+               ((null scs))
+             (let ((load-tn (tn-ref-load-tn op)))
+               (unless (eq (svref (car scs)
+                                  (sc-number
+                                   (tn-sc
+                                    (or load-tn (tn-ref-tn op)))))
+                           t)
+                 (barf "operand restriction not satisfied: ~S" op))))))
     (do-ir2-blocks (block component)
       (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
-	  ((null vop))
-	(let ((info (vop-info vop)))
-	  (check (vop-info-result-load-scs info) (vop-results vop))
-	  (check (vop-info-arg-load-scs info) (vop-args vop))))))
+          ((null vop))
+        (let ((info (vop-info vop)))
+          (check (vop-info-result-load-scs info) (vop-results vop))
+          (check (vop-info-arg-load-scs info) (vop-args vop))))))
   (values))
 
 ;;;; data structure dumping routines
@@ -888,30 +877,26 @@
 ;;;
 ;;; 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))
-		(declaim (type fixnum ,counter))
-		(defvar ,counter 0)
-
-		(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))))))
+             `(progn
+                (declaim (type hash-table ,vto ,vfrom))
+                (defvar ,vto)
+                (defvar ,vfrom)
+                (declaim (type fixnum ,counter))
+                (defvar ,counter 0)
+
+                (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 *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))
+  (def *label-id* *label-ids* *id-labels* label-id id-label))
 
 ;;; Print a terse one-line description of LEAF.
 (defun print-leaf (leaf &optional (stream *standard-output*))
@@ -932,20 +917,29 @@
     (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)))
+    (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-funs*)))))
 
 ;;; Print cN.
-(defun print-continuation (cont)
-  (declare (type continuation cont))
-  (format t " c~D" (cont-num cont))
+(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.
@@ -953,65 +947,91 @@
   (setq block (block-or-lose block))
   (pprint-logical-block (nil nil)
     (format t "~:@_IR1 block ~D start c~D"
-           (block-number block) (cont-num (block-start block)))
-
-    (let ((last (block-last block)))
-     (pprint-newline :mandatory)
-     (do ((cont (block-start block) (node-cont (continuation-next cont))))
-         ((not 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 ~A~) c~D"
-                      (if (node-tail-p node) "tail " "")
-                      (if (fun-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))
-            (when (functional-kind (bind-lambda node))
-              (format t " ~S ~S" :kind (functional-kind (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>")))))
-           (cast
-            (let ((value (cast-value node)))
-              (format t "cast c~D ~A[~S -> ~S]" (cont-num value)
-                      (if (cast-%type-check node) #\+ #\-)
-                      (cast-type-to-check node)
-                      (cast-asserted-type node)))))
-         (pprint-newline :mandatory)
-         (when (eq node last) (return)))))
-
-   (let ((succ (block-succ block)))
-     (format t "successors~{ c~D~}~%"
-             (mapcar (lambda (x) (cont-num (block-start x))) succ))))
+            (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 (lambda (lvar-or-cell)
+                                  (if (consp lvar-or-cell)
+                                      (cons (car lvar-or-cell)
+                                            (cont-num (cdr lvar-or-cell)))
+                                      (cont-num lvar-or-cell)))
+                                (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 the guts of a TN. (logic shared between PRINT-OBJECT (TN T)
@@ -1020,10 +1040,10 @@
   (declare (type tn tn))
   (let ((leaf (tn-leaf tn)))
     (cond (leaf
-	   (print-leaf leaf stream)
-	   (format stream "!~D" (tn-id tn)))
-	  (t
-	   (format stream "t~D" (tn-id tn))))
+           (print-leaf leaf stream)
+           (format stream "!~D" (tn-id tn)))
+          (t
+           (format stream "t~D" (tn-id tn))))
     (when (and (tn-sc tn) (tn-offset tn))
       (format stream "[~A]" (location-print-name tn)))))
 
@@ -1033,17 +1053,17 @@
   (declare (type (or tn-ref null) refs))
   (pprint-logical-block (*standard-output* nil)
     (do ((ref refs (tn-ref-across ref)))
-	((null ref))
+        ((null ref))
       (let ((tn (tn-ref-tn ref))
-	    (ltn (tn-ref-load-tn ref)))
-	(cond ((not ltn)
-	       (print-tn-guts tn))
-	      (t
-	       (print-tn-guts tn)
-	       (princ (if (tn-ref-write-p ref) #\< #\>))
-	       (print-tn-guts ltn)))
-	(princ #\space)
-	(pprint-newline :fill)))))
+            (ltn (tn-ref-load-tn ref)))
+        (cond ((not ltn)
+               (print-tn-guts tn))
+              (t
+               (print-tn-guts tn)
+               (princ (if (tn-ref-write-p ref) #\< #\>))
+               (print-tn-guts ltn)))
+        (princ #\space)
+        (pprint-newline :fill)))))
 
 ;;; Print the VOP, putting args, info and results on separate lines, if
 ;;; necessary.
@@ -1056,9 +1076,9 @@
     (pprint-newline :linear)
     (when (vop-codegen-info vop)
       (princ (with-output-to-string (stream)
-	       (let ((*print-level* 1)
-		     (*print-length* 3))
-		 (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
+               (let ((*print-level* 1)
+                     (*print-length* 3))
+                 (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
       (pprint-newline :linear))
     (when (vop-results vop)
       (princ "=> ")
@@ -1094,7 +1114,7 @@
   (let ((2block (block-info block)))
     (print-ir2-block 2block)
     (do ((b (ir2-block-next 2block) (ir2-block-next b)))
-	((not (eq (ir2-block-block b) block)))
+        ((not (eq (ir2-block-block b) block)))
       (print-ir2-block b)))
   (values))
 
@@ -1126,12 +1146,12 @@
   (do-blocks (block (block-component block) :both)
     (setf (block-flag block) nil))
   (labels ((walk (block)
-	     (unless (block-flag block)
-	       (setf (block-flag block) t)
-	       (when (block-start block)
-		 (print-nodes block))
-	       (dolist (block (block-succ block))
-		 (walk block)))))
+             (unless (block-flag block)
+               (setf (block-flag block) t)
+               (when (block-start block)
+                 (print-nodes block))
+               (dolist (block (block-succ block))
+                 (walk block)))))
     (walk block))
   (values))
 
@@ -1140,7 +1160,7 @@
   (do-blocks (block (block-component (block-or-lose thing)))
     (handler-case (print-nodes block)
       (error (condition)
-	(format t "~&~A...~%" condition))))
+        (format t "~&~A...~%" condition))))
   (values))
 
 (defvar *list-conflicts-table* (make-hash-table :test 'eq))
@@ -1150,12 +1170,12 @@
 (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-blockwise conf)))
+             (global-conflicts-next-blockwise conf)))
       ((null conf))
     (when (eq (global-conflicts-kind conf) :live)
       (let ((btn (global-conflicts-tn conf)))
-	(unless (eq btn tn)
-	  (setf (gethash btn *list-conflicts-table*) t)))))
+        (unless (eq btn tn)
+          (setf (gethash btn *list-conflicts-table*) t)))))
   (values))
 
 ;;; Add all local TNs in BLOCK to the conflicts.
@@ -1170,11 +1190,10 @@
 (defun listify-conflicts-table ()
   (collect ((res))
     (maphash (lambda (k v)
-	       (declare (ignore v))
-	       (when k
-		 (res k)))
-	     *list-conflicts-table*)
-    (clrhash *list-conflicts-table*)
+               (declare (ignore v))
+               (when k
+                 (res k)))
+             *list-conflicts-table*)
     (res)))
 
 ;;; Return a list of a the TNs that conflict with TN. Sort of, kind
@@ -1183,47 +1202,49 @@
   (aver (member (tn-kind tn) '(:normal :environment :debug-environment)))
   (let ((confs (tn-global-conflicts tn)))
     (cond (confs
-	   (clrhash *list-conflicts-table*)
-	   (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)
-		   (add-all-local-tns block)
-		   (let ((bconf (global-conflicts-conflicts conf))
-			 (ltns (ir2-block-local-tns block)))
-		     (dotimes (i (ir2-block-local-tn-count block))
-		       (when (/= (sbit bconf i) 0)
-			 (setf (gethash (svref ltns i) *list-conflicts-table*)
-			       t)))))))
-	   (listify-conflicts-table))
-	  (t
-	   (let* ((block (tn-local tn))
-		  (ltns (ir2-block-local-tns block))
-		  (confs (tn-local-conflicts tn)))
-	     (collect ((res))
-	       (dotimes (i (ir2-block-local-tn-count block))
-		 (when (/= (sbit confs i) 0)
-		   (let ((tn (svref ltns i)))
-		     (when (and tn (not (eq tn :more))
-				(not (tn-global-conflicts tn)))
-		       (res tn)))))
-	       (do ((gtn (ir2-block-global-tns block)
-			 (global-conflicts-next-blockwise gtn)))
-		   ((null gtn))
-		 (when (or (eq (global-conflicts-kind gtn) :live)
-			   (/= (sbit confs (global-conflicts-number gtn)) 0))
-		   (res (global-conflicts-tn gtn))))
-	       (res)))))))
+           (let ((*list-conflicts-table* (make-hash-table :test 'eq)))
+             (unwind-protect
+                  (do ((conf confs (global-conflicts-next-tnwise conf)))
+                      ((null conf)
+                       (listify-conflicts-table))
+                    (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)
+                          (add-all-local-tns block)
+                          (let ((bconf (global-conflicts-conflicts conf))
+                                (ltns (ir2-block-local-tns block)))
+                            (dotimes (i (ir2-block-local-tn-count block))
+                              (when (/= (sbit bconf i) 0)
+                                (setf (gethash (svref ltns i) *list-conflicts-table*)
+                                      t)))))))
+               (clrhash *list-conflicts-table*))))
+          (t
+           (let* ((block (tn-local tn))
+                  (ltns (ir2-block-local-tns block))
+                  (confs (tn-local-conflicts tn)))
+             (collect ((res))
+               (dotimes (i (ir2-block-local-tn-count block))
+                 (when (/= (sbit confs i) 0)
+                   (let ((tn (svref ltns i)))
+                     (when (and tn (not (eq tn :more))
+                                (not (tn-global-conflicts tn)))
+                       (res tn)))))
+               (do ((gtn (ir2-block-global-tns block)
+                         (global-conflicts-next-blockwise gtn)))
+                   ((null gtn))
+                 (when (or (eq (global-conflicts-kind gtn) :live)
+                           (/= (sbit confs (global-conflicts-number gtn)) 0))
+                   (res (global-conflicts-tn gtn))))
+               (res)))))))
 
 (defun nth-vop (thing n)
   #!+sb-doc
   "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)))
-	((= i n) vop))))
+         (vop (ir2-block-start-vop block) (vop-next vop)))
+        ((= i n) vop))))