X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fdebug.lisp;h=fe81a456458b227d96c6f6623b3015bccebbd32a;hb=986ce2596822cc0871b609346aaf592348aca596;hp=ae00cdb1822fe7951de2bf256f6188df2bcae999;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index ae00cdb..fe81a45 100644 --- 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 @@ -910,12 +917,9 @@ (optional-dispatch (format stream "optional-dispatch ~S" (leaf-name leaf))) (functional - (assert (eq (functional-kind leaf) :top-level-xep)) + (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)) @@ -1141,11 +1146,10 @@ (clrhash *list-conflicts-table*) (res))) +;;; Return a list of a the TNs that conflict with TN. Sort of, kind +;;; of. For debugging use only. Probably doesn't work on :COMPONENT TNs. (defun list-conflicts (tn) - #!+sb-doc - "Return a list of a the TNs that conflict with TN. Sort of, kind of. For - debugging use only. Probably doesn't work on :COMPONENT TNs." - (assert (member (tn-kind tn) '(:normal :environment :debug-environment))) + (aver (member (tn-kind tn) '(:normal :environment :debug-environment))) (let ((confs (tn-global-conflicts tn))) (cond (confs (clrhash *list-conflicts-table*)