X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=1bdad5baf07ed40875c28dbbefc9ab0a4d51b4a9;hb=784b195743728436795b90f95273c3535ebee9a5;hp=6463f64d1c8e9f2c68286286cfcfd6b2b3ed8153;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 6463f64..1bdad5b 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -52,10 +52,12 @@ ;;; *SEEN-BLOCKS* is a hashtable with true values for all blocks which ;;; appear in the DFO for one of the specified components. ;;; -;;; *SEEN-FUNCTIONS* is similar, but records all the lambdas we +;;; *SEEN-FUNS* is similar, but records all the lambdas we ;;; reached by recursing on top level functions. +;;; FIXME: Is it really only LAMBDAs, not e.g. FUNCTIONALs? Then +;;; shouldn't it be *SEEN-LAMBDAS*? (defvar *seen-blocks* (make-hash-table :test 'eq)) -(defvar *seen-functions* (make-hash-table :test 'eq)) +(defvar *seen-funs* (make-hash-table :test 'eq)) ;;; Barf if NODE is in a block which wasn't reached during the graph ;;; walk. @@ -68,8 +70,7 @@ ;;; Check everything that we can think of for consistency. When a ;;; definite inconsistency is detected, we BARF. Possible problems ;;; just cause us to BURP. Our argument is a list of components, but -;;; we also look at the *FREE-VARIABLES*, *FREE-FUNCTIONS* and -;;; *CONSTANTS*. +;;; we also look at the *FREE-VARS*, *FREE-FUNS* and *CONSTANTS*. ;;; ;;; First we do a pre-pass which finds all the CBLOCKs and CLAMBDAs, ;;; testing that they are linked together properly and entering them @@ -79,18 +80,19 @@ (declaim (ftype (function (list) (values)) check-ir1-consistency)) (defun check-ir1-consistency (components) (clrhash *seen-blocks*) - (clrhash *seen-functions*) + (clrhash *seen-funs*) (dolist (c components) (let* ((head (component-head c)) (tail (component-tail c))) - (unless (and (null (block-pred head)) (null (block-succ tail))) + (unless (and (null (block-pred head)) + (null (block-succ tail))) (barf "~S is malformed." c)) (do ((prev nil block) (block head (block-next block))) ((null block) (unless (eq prev tail) - (barf "wrong Tail for DFO, ~S in ~S" prev c))) + (barf "wrong TAIL for DFO, ~S in ~S" prev c))) (setf (gethash block *seen-blocks*) t) (unless (eq (block-prev block) prev) (barf "bad PREV for ~S, should be ~S" block prev)) @@ -121,13 +123,13 @@ (and (global-var-p v) (member (global-var-kind v) '(:global :special)))) - (barf "strange *FREE-VARIABLES* entry: ~S" v)) + (barf "strange *FREE-VARS* entry: ~S" v)) (dolist (n (leaf-refs v)) (check-node-reached n)) (when (basic-var-p v) (dolist (n (basic-var-sets v)) (check-node-reached n)))) - *free-variables*) + *free-vars*) (maphash (lambda (k v) (declare (ignore k)) @@ -142,11 +144,11 @@ (unless (or (functional-p v) (and (global-var-p v) (eq (global-var-kind v) :global-function))) - (barf "strange *FREE-FUNCTIONS* entry: ~S" v)) + (barf "strange *FREE-FUNS* entry: ~S" v)) (dolist (n (leaf-refs v)) (check-node-reached n))) - *free-functions*) - (clrhash *seen-functions*) + *free-funs*) + (clrhash *seen-funs*) (clrhash *seen-blocks*) (values)) @@ -154,15 +156,15 @@ (defun observe-functional (x) (declare (type functional x)) - (when (gethash x *seen-functions*) + (when (gethash x *seen-funs*) (barf "~S was seen more than once." x)) (unless (eq (functional-kind x) :deleted) - (setf (gethash x *seen-functions*) t))) + (setf (gethash x *seen-funs*) t))) ;;; Check that the specified function has been seen. (defun check-fun-reached (fun where) (declare (type functional fun)) - (unless (gethash fun *seen-functions*) + (unless (gethash fun *seen-funs*) (barf "unseen function ~S in ~S" fun where))) ;;; In a CLAMBDA, check that the associated nodes are in seen blocks. @@ -177,7 +179,7 @@ (barf "The function for XEP ~S has kind." functional)) (unless (eq (functional-entry-fun fun) functional) (barf "bad back-pointer in function for XEP ~S" functional)))) - ((:let :mv-let :assignment) + ((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P (check-fun-reached (lambda-home functional) functional) (when (functional-entry-fun functional) (barf "The LET ~S has entry function." functional)) @@ -244,7 +246,7 @@ (defun check-fun-consistency (components) (dolist (c components) - (dolist (new-fun (component-new-funs c)) + (dolist (new-fun (component-new-functionals c)) (observe-functional new-fun)) (dolist (fun (component-lambdas c)) (when (eq (functional-kind fun) :external) @@ -256,7 +258,7 @@ (observe-functional let)))) (dolist (c components) - (dolist (new-fun (component-new-funs c)) + (dolist (new-fun (component-new-functionals c)) (check-fun-stuff new-fun)) (dolist (fun (component-lambdas c)) (when (eq (functional-kind fun) :deleted) @@ -376,7 +378,7 @@ (when dest (check-node-reached dest))) - (loop + (loop (unless (eq (continuation-block this-cont) block) (barf "BLOCK in ~S should be ~S." this-cont block)) @@ -392,7 +394,7 @@ (unless fun-deleted (check-node-consistency node)) - + (let ((cont (node-cont node))) (when (not cont) (barf "~S has no CONT." node)) @@ -406,7 +408,7 @@ (unless (eq (continuation-use cont) node) (barf "USE in ~S should be ~S." cont node)) (setq this-cont cont)))) - + (check-block-successors block)) (values)) @@ -473,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 @@ -494,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) @@ -526,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 @@ -556,12 +563,12 @@ ;;;; IR2 consistency checking -;;; Check for some kind of consistency in some Refs linked together by -;;; TN-Ref-Across. VOP is the VOP that the references are in. Write-P is the -;;; value of Write-P that should be present. Count is the minimum number of -;;; operands expected. If More-P is true, then any larger number will also be -;;; accepted. What is a string describing the kind of operand in error -;;; messages. +;;; Check for some kind of consistency in some REFs linked together by +;;; TN-REF-ACROSS. VOP is the VOP that the references are in. WRITE-P +;;; is the value of WRITE-P that should be present. COUNT is the +;;; minimum number of operands expected. If MORE-P is true, then any +;;; larger number will also be accepted. WHAT is a string describing +;;; the kind of operand in error messages. (defun check-tn-refs (refs vop write-p count more-p what) (let ((vop-refs (vop-refs vop))) (do ((ref refs (tn-ref-across ref)) @@ -592,7 +599,7 @@ (unless (find-in #'tn-ref-next-ref target vop-refs) (barf "The target for ~S isn't in REFS for ~S." ref vop))))))) -;;; Verify the sanity of the VOP-Refs slot in VOP. This involves checking +;;; Verify the sanity of the VOP-REFS slot in VOP. This involves checking ;;; that each referenced TN appears as an argument, result or temp, and also ;;; basic checks for the plausibility of the specified ordering of the refs. (defun check-vop-refs (vop) @@ -619,8 +626,8 @@ (values)) ;;; Check the basic sanity of the VOP linkage, then call some other -;;; functions to check on the TN-Refs. We grab some info out of the VOP-Info -;;; to tell us what to expect. +;;; functions to check on the TN-REFS. We grab some info out of the +;;; VOP-INFO to tell us what to expect. ;;; ;;; [### Check that operand type restrictions are met?] (defun check-ir2-block-consistency (2block) @@ -657,12 +664,12 @@ (barf "wrong number of codegen info args in ~S" vop)))) (values)) -;;; Check stuff about the IR2 representation of Component. This assumes the +;;; Check stuff about the IR2 representation of COMPONENT. This assumes the ;;; sanity of the basic flow graph. ;;; ;;; [### Also grovel global TN data structures? Assume pack not -;;; done yet? Have separate check-tn-consistency for pre-pack and -;;; check-pack-consistency for post-pack?] +;;; done yet? Have separate CHECK-TN-CONSISTENCY for pre-pack and +;;; CHECK-PACK-CONSISTENCY for post-pack?] (defun check-ir2-consistency (component) (declare (type component component)) (do-ir2-blocks (block component) @@ -702,7 +709,7 @@ ((:environment :debug-environment) (incf environment)) (t (incf global))) (do ((conf (tn-global-conflicts tn) - (global-conflicts-tn-next conf))) + (global-conflicts-next-tnwise conf))) ((null conf)) (incf confs))) (t @@ -721,7 +728,7 @@ confs)) (values)) -;;; If the entry in Local-TNs for TN in Block is :More, then do some checks +;;; If the entry in Local-TNs for TN in BLOCK is :MORE, then do some checks ;;; for the validity of the usage. (defun check-more-tn-entry (tn block) (let* ((vop (ir2-block-start-vop block)) @@ -751,9 +758,9 @@ ((eq kind :component) (unless (member tn (ir2-component-component-tns (component-info component))) - (barf "~S not in Component-TNs for ~S" tn component))) + (barf "~S not in COMPONENT-TNs for ~S" tn component))) (conf - (do ((conf conf (global-conflicts-tn-next conf)) + (do ((conf conf (global-conflicts-next-tnwise conf)) (prev nil conf)) ((null conf)) (unless (eq (global-conflicts-tn conf) tn) @@ -796,7 +803,7 @@ (defun check-block-conflicts (component) (do-ir2-blocks (block component) (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf)) + (global-conflicts-next-blockwise conf)) (prev nil conf)) ((null conf)) (when prev @@ -804,7 +811,7 @@ (tn-number (global-conflicts-tn prev))) (barf "~S and ~S out of order in ~S" prev conf block))) - (unless (find-in #'global-conflicts-tn-next + (unless (find-in #'global-conflicts-next-tnwise conf (tn-global-conflicts (global-conflicts-tn conf))) @@ -833,7 +840,7 @@ (fp (ir2-physenv-old-fp 2env)) (2block (block-info (lambda-block (physenv-lambda env))))) (do ((conf (ir2-block-global-tns 2block) - (global-conflicts-next conf))) + (global-conflicts-next-blockwise conf))) ((null conf)) (let ((tn (global-conflicts-tn conf))) (unless (or (eq (global-conflicts-kind conf) :write) @@ -878,27 +885,36 @@ ;;;; data structure dumping routines -;;; When we print Continuations and TNs, we assign them small numeric IDs so -;;; that we can get a handle on anonymous objects given a printout. -(macrolet ((def-frob (counter vto vfrom fto ffrom) +;;; When we print CONTINUATIONs and TNs, we assign them small numeric +;;; IDs so that we can get a handle on anonymous objects given a +;;; printout. +;;; +;;; FIXME: +;;; * Perhaps this machinery should be #!+SB-SHOW. +;;; * Probably the hash tables should either be weak hash tables, +;;; or only allocated within a single compilation unit. Otherwise +;;; there will be a tendency for them to grow without bound and +;;; 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) (let ((num (incf ,counter))) (setf (gethash num ,vfrom) x) (setf (gethash x ,vto) num)))) - + (defun ,ffrom (num) (values (gethash num ,vfrom)))))) - (def-frob *continuation-number* *continuation-numbers* *number-continuations* cont-num num-cont) - (def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn) - (def-frob *label-id* *id-labels* *label-ids* label-id id-label)) + (def *continuation-number* *continuation-numbers* *number-continuations* + cont-num num-cont) + (def *tn-id* *tn-ids* *id-tns* tn-id id-tn) + (def *label-id* *id-labels* *label-ids* label-id id-label)) ;;; Print a terse one-line description of LEAF. (defun print-leaf (leaf &optional (stream *standard-output*)) @@ -912,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) @@ -926,7 +942,7 @@ (integer (continuation-block (num-cont thing))) (functional (lambda-block (main-entry thing))) (null (error "Bad thing: ~S." thing)) - (symbol (block-or-lose (gethash thing *free-functions*))))) + (symbol (block-or-lose (gethash thing *free-funs*))))) ;;; Print cN. (defun print-continuation (cont) @@ -938,61 +954,74 @@ ;;; representing what the code does. (defun print-nodes (block) (setq block (block-or-lose block)) - (format t "~%block start c~D" (cont-num (block-start block))) - - (let ((last (block-last block))) - (terpri) - (do ((cont (block-start block) (node-cont (continuation-next 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~) c~D" - (if (function-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 " "))))) - (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))) - (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 ")) - (t - (format t "exit ")))))) - (terpri) - (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-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 " ")) + + (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 " "))))) + (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 ")) + (t + (format t "exit "))))) + (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)))) (values)) -;;; Print a useful representation of a TN. If the TN has a leaf, then do a -;;; Print-Leaf on that, otherwise print a generated ID. -(defun print-tn (tn &optional (stream *standard-output*)) +;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T) +;;; and printers for compound objects which contain TNs) +(defun print-tn-guts (tn &optional (stream *standard-output*)) (declare (type tn tn)) (let ((leaf (tn-leaf tn))) (cond (leaf @@ -1003,8 +1032,8 @@ (when (and (tn-sc tn) (tn-offset tn)) (format stream "[~A]" (location-print-name tn))))) -;;; Print the TN-Refs representing some operands to a VOP, linked by -;;; TN-Ref-Across. +;;; Print the TN-REFs representing some operands to a VOP, linked by +;;; TN-REF-ACROSS. (defun print-operands (refs) (declare (type (or tn-ref null) refs)) (pprint-logical-block (*standard-output* nil) @@ -1013,15 +1042,15 @@ (let ((tn (tn-ref-tn ref)) (ltn (tn-ref-load-tn ref))) (cond ((not ltn) - (print-tn tn)) + (print-tn-guts tn)) (t - (print-tn tn) + (print-tn-guts tn) (princ (if (tn-ref-write-p ref) #\< #\>)) - (print-tn ltn))) + (print-tn-guts ltn))) (princ #\space) (pprint-newline :fill))))) -;;; Print the vop, putting args, info and results on separate lines, if +;;; Print the VOP, putting args, info and results on separate lines, if ;;; necessary. (defun print-vop (vop) (pprint-logical-block (*standard-output* nil) @@ -1039,27 +1068,29 @@ (when (vop-results vop) (princ "=> ") (print-operands (vop-results vop)))) - (terpri)) + (pprint-newline :mandatory)) ;;; Print the VOPs in the specified IR2 block. (defun print-ir2-block (block) (declare (type ir2-block block)) - (cond - ((eq (block-info (ir2-block-block block)) block) - (format t "~%IR2 block start c~D~%" - (cont-num (block-start (ir2-block-block block)))) - (let ((label (ir2-block-%label block))) - (when label - (format t "L~D:~%" (label-id label))))) - (t - (format t "~%"))) - - (do ((vop (ir2-block-start-vop block) - (vop-next vop)) - (number 0 (1+ number))) - ((null vop)) - (format t "~W: " number) - (print-vop vop))) + (pprint-logical-block (*standard-output* nil) + (cond + ((eq (block-info (ir2-block-block block)) block) + (format t "~:@_IR2 block ~D start c~D~:@_" + (ir2-block-number block) + (cont-num (block-start (ir2-block-block block)))) + (let ((label (ir2-block-%label block))) + (when label + (format t "L~D:~:@_" (label-id label))))) + (t + (format t "~:@_"))) + + (do ((vop (ir2-block-start-vop block) + (vop-next vop)) + (number 0 (1+ number))) + ((null vop)) + (format t "~W: " number) + (print-vop vop)))) ;;; This is like PRINT-NODES, but dumps the IR2 representation of the ;;; code in BLOCK. @@ -1073,9 +1104,24 @@ (values)) ;;; Scan the IR2 blocks in emission order. -(defun print-ir2-blocks (thing) - (do-ir2-blocks (block (block-component (block-or-lose thing))) - (print-ir2-block block)) +(defun print-ir2-blocks (thing &optional full) + (let* ((block (component-head (block-component (block-or-lose thing)))) + (2block (block-info block))) + (pprint-logical-block (nil nil) + (loop while 2block + do (setq block (ir2-block-block 2block)) + do (pprint-logical-block (*standard-output* nil) + (if full + (print-nodes block) + (format t "IR1 block ~D start c~D" + (block-number block) + (cont-num (block-start block)))) + (pprint-indent :block 4) + (pprint-newline :mandatory) + (loop while (and 2block (eq (ir2-block-block 2block) block)) + do (print-ir2-block 2block) + do (setq 2block (ir2-block-next 2block)))) + do (pprint-newline :mandatory)))) (values)) ;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by @@ -1104,12 +1150,12 @@ (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) - (global-conflicts-next conf))) + (global-conflicts-next-blockwise conf))) ((null conf)) (when (eq (global-conflicts-kind conf) :live) (let ((btn (global-conflicts-tn conf))) @@ -1117,7 +1163,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))) @@ -1143,8 +1189,12 @@ (let ((confs (tn-global-conflicts tn))) (cond (confs (clrhash *list-conflicts-table*) - (do ((conf confs (global-conflicts-tn-next conf))) + (do ((conf confs (global-conflicts-next-tnwise conf))) ((null conf)) + (format t "~&#~%" + (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) (if (eq (global-conflicts-kind conf) :live) @@ -1168,7 +1218,7 @@ (not (tn-global-conflicts tn))) (res tn))))) (do ((gtn (ir2-block-global-tns block) - (global-conflicts-next gtn))) + (global-conflicts-next-blockwise gtn))) ((null gtn)) (when (or (eq (global-conflicts-kind gtn) :live) (/= (sbit confs (global-conflicts-number gtn)) 0)) @@ -1177,7 +1227,7 @@ (defun nth-vop (thing n) #!+sb-doc - "Return the Nth VOP in the IR2-Block pointed to by Thing." + "Return the Nth VOP in the IR2-BLOCK pointed to by THING." (let ((block (block-info (block-or-lose thing)))) (do ((i 0 (1+ i)) (vop (ir2-block-start-vop block) (vop-next vop)))