0.8.0.3:

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

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 7f67f0f..b9b8cb3 100644 (file)
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -528,6 +528,8 @@
        (barf "IF not at block end: ~S" node)))
     (cset
      (check-dest (set-value node) node))
+    (cast
+     (check-dest (cast-value node) node))
     (bind
      (check-fun-reached (bind-lambda node) node))
     (creturn
@@ -963,7 +965,8 @@
            (ref (print-leaf (ref-leaf node)))
            (basic-combination
             (let ((kind (basic-combination-kind node)))
-              (format t "~(~A ~A~) c~D"
+              (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)))
@@ -981,7 +984,9 @@
             (print-continuation (block-start (if-alternative node))))
            (bind
             (write-string "bind ")
-            (print-leaf (bind-lambda node)))
+            (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)))
@@ -994,7 +999,13 @@
                     ((exit-entry node)
                      (format t "exit <no value>"))
                     (t
-                     (format t "exit <degenerate>"))))))
+                     (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)))))
 
@@ -1134,8 +1145,8 @@
 
 (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)
@@ -1147,7 +1158,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)))
@@ -1176,7 +1187,8 @@
           (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)))
+                     (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)