X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=ae59919ed9941b9ba7b583f753a93211d5234124;hb=5ecef987f3847ed5de8c03f66ef9d8ab468af993;hp=1bdad5baf07ed40875c28dbbefc9ab0a4d51b4a9;hpb=784b195743728436795b90f95273c3535ebee9a5;p=sbcl.git

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 1bdad5b..ae59919 100644
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -63,7 +63,7 @@
 ;;; 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))
 
@@ -332,82 +332,60 @@
 
   (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-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))
 
-    (loop
-      (unless (eq (continuation-block this-cont) block)
-	(barf "BLOCK in ~S should be ~S." this-cont block))
+    (when (node-next last)
+      (barf "Last node ~S of ~S has next ctran." last block))
 
-      (let ((dest (continuation-dest this-cont)))
-	(when dest
-	  (check-node-reached dest)))
+    (loop
+      (unless (eq (ctran-block this-ctran) block)
+	(barf "BLOCK of ~S should be ~S." this-ctran block))
 
-      (let ((node (continuation-next this-cont)))
+      (let ((node (ctran-next this-ctran)))
 	(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))
-
+	  (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))
@@ -458,27 +436,18 @@
 
 ;;;; 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))
-       (unless (find-uses cont)
-         (barf "Continuation ~S has a destinatin, but no uses."
-               cont)))))
+;;; 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
@@ -497,6 +466,18 @@
 	     (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))
@@ -512,13 +493,14 @@
               ;; 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
+            (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 ((dest (continuation-dest (node-cont 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))
@@ -680,7 +662,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)
@@ -935,11 +917,11 @@
     (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*)))))
@@ -950,73 +932,106 @@
   (format t " c~D" (cont-num cont))
   (values))
 
+(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))
   (pprint-logical-block (nil nil)
     (format t "~:@_IR1 block ~D start c~D"
-           (block-number block) (cont-num (block-start block)))
+            (block-number block) (cont-num (block-start block)))
     (when (block-delete-p block)
       (format t " <deleted>"))
 
-    (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))))
+    (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 the guts of a TN. (logic shared between PRINT-OBJECT (TN T)