0.pre7.55:

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

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 371777f..fe81a45 100644 (file)
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -316,9 +316,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)
 
@@ -499,13 +499,20 @@
                   (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))))))
-
+        (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)
@@ -818,16 +825,16 @@
 ;;; 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))
+          (closure (ir2-physenv-environment 2env))
+          (pc (ir2-physenv-return-pc-pass 2env))
+          (fp (ir2-physenv-old-fp 2env))
           (2block (block-info
                    (node-block
                     (lambda-bind
-                     (environment-function env))))))
+                     (physenv-function env))))))
       (do ((conf (ir2-block-global-tns 2block)
                 (global-conflicts-next conf)))
          ((null conf))
@@ -896,7 +903,7 @@
   (def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn)
   (def-frob *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
@@ -912,10 +919,7 @@
     (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)))))))
+            (entry-info-name (leaf-info leaf))))))
 
 ;;; Attempt to find a block given some thing that has to do with it.
 (declaim (ftype (function (t) cblock) block-or-lose))
@@ -1067,7 +1071,8 @@
     (format t "~D: " 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)))
@@ -1083,8 +1088,8 @@
     (print-ir2-block block))
   (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 +1104,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,7 +1114,7 @@
 
 (defvar *list-conflicts-table* (make-hash-table :test 'eq))
 
-;;; Add all Always-Live TNs in Block to the conflicts. TN is ignored when
+;;; 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))