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

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 5f2c6e1..1bdad5b 100644
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -475,7 +475,10 @@
        (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)))))
+	 (barf "DEST for ~S should be ~S." cont node))
+       (unless (find-uses cont)
+         (barf "Continuation ~S has a destinatin, but no uses."
+               cont)))))
   (values))
 
 ;;; This function deals with checking for consistency of the
@@ -496,25 +499,25 @@
      (check-dest (basic-combination-fun node) 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)))))))
+         (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))))
        (when (and (return-p dest)
 		  (eq (basic-combination-kind node) :local)
@@ -528,6 +531,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
@@ -892,11 +897,11 @@
 ;;;     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)
@@ -923,7 +928,7 @@
      (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)
@@ -952,6 +957,8 @@
   (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>"))
 
     (let ((last (block-last block)))
      (pprint-newline :mandatory)
@@ -997,7 +1004,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)))))