Fix comment about *code-coverage-info*.
[sbcl.git] / src / compiler / debug.lisp
blobf218fbcd6841185e835c20107bb4c5088095b0f9
1 ;;;; This file contains utilities for debugging the compiler --
2 ;;;; currently only stuff for checking the consistency of the IR1.
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!C")
15 (defvar *args* ()
16 #!+sb-doc
17 "This variable is bound to the format arguments when an error is signalled
18 by BARF or BURP.")
20 (defvar *ignored-errors* (make-hash-table :test 'equal))
22 ;;; A definite inconsistency has been detected. Signal an error with
23 ;;; *args* bound to the list of the format args.
24 (declaim (ftype (function (string &rest t) (values)) barf))
25 (defun barf (string &rest *args*)
26 (unless (gethash string *ignored-errors*)
27 (restart-case
28 (apply #'error string *args*)
29 (continue ()
30 :report "Ignore this error.")
31 (ignore-all ()
32 :report "Ignore this and all future occurrences of this error."
33 (setf (gethash string *ignored-errors*) t))))
34 (values))
36 (defvar *burp-action* :warn
37 #!+sb-doc
38 "Action taken by the BURP function when a possible compiler bug is detected.
39 One of :WARN, :ERROR or :NONE.")
40 (declaim (type (member :warn :error :none) *burp-action*))
42 ;;; Called when something funny but possibly correct is noticed.
43 ;;; Otherwise similar to BARF.
44 (declaim (ftype (function (string &rest t) (values)) burp))
45 (defun burp (string &rest *args*)
46 (ecase *burp-action*
47 (:warn (apply #'warn string *args*))
48 (:error (apply #'cerror "press on anyway." string *args*))
49 (:none))
50 (values))
52 ;;; *SEEN-BLOCKS* is a hashtable with true values for all blocks which
53 ;;; appear in the DFO for one of the specified components.
54 ;;;
55 ;;; *SEEN-FUNS* is similar, but records all the lambdas we
56 ;;; reached by recursing on top level functions.
57 ;;; FIXME: Is it really only LAMBDAs, not e.g. FUNCTIONALs? Then
58 ;;; shouldn't it be *SEEN-LAMBDAS*?
59 (defvar *seen-blocks*)
60 (defvar *seen-funs*)
62 ;;; Barf if NODE is in a block which wasn't reached during the graph
63 ;;; walk.
64 (declaim (ftype (function (node) (values)) check-node-reached))
65 (defun check-node-reached (node)
66 (unless (gethash (ctran-block (node-prev node)) *seen-blocks*)
67 (barf "~S was not reached." node))
68 (values))
70 ;;; Check everything that we can think of for consistency. When a
71 ;;; definite inconsistency is detected, we BARF. Possible problems
72 ;;; just cause us to BURP. Our argument is a list of components, but
73 ;;; we also look at the *FREE-VARS*, *FREE-FUNS* and *CONSTANTS*.
74 ;;;
75 ;;; First we do a pre-pass which finds all the CBLOCKs and CLAMBDAs,
76 ;;; testing that they are linked together properly and entering them
77 ;;; in hashtables. Next, we iterate over the blocks again, looking at
78 ;;; the actual code and control flow. Finally, we scan the global leaf
79 ;;; hashtables, looking for lossage.
80 (declaim (ftype (function (list) (values)) check-ir1-consistency))
81 (defun check-ir1-consistency (components)
82 (let ((*seen-blocks* (make-hash-table :test 'eq))
83 (*seen-funs* (make-hash-table :test 'eq)))
84 (unwind-protect
85 (progn
86 (dolist (c components)
87 (let* ((head (component-head c))
88 (tail (component-tail c)))
89 (unless (and (null (block-pred head))
90 (null (block-succ tail)))
91 (barf "~S is malformed." c))
93 (do ((prev nil block)
94 (block head (block-next block)))
95 ((null block)
96 (unless (eq prev tail)
97 (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
98 (setf (gethash block *seen-blocks*) t)
99 (unless (eq (block-prev block) prev)
100 (barf "bad PREV for ~S, should be ~S" block prev))
101 (unless (or (eq block tail)
102 (eq (block-component block) c))
103 (barf "~S is not in ~S." block c)))
105 (when (or (loop-blocks c) (loop-inferiors c))
106 (do-blocks (block c :both)
107 (setf (block-flag block) nil))
108 (check-loop-consistency c nil)
109 (do-blocks (block c :both)
110 (unless (block-flag block)
111 (barf "~S was not in any loop." block))))
114 (check-fun-consistency components)
116 (dolist (c components)
117 (do ((block (block-next (component-head c)) (block-next block)))
118 ((null (block-next block)))
119 (check-block-consistency block)))
121 (maphash (lambda (k v)
122 (declare (ignore k))
123 (unless (or (constant-p v)
124 (and (global-var-p v)
125 (member (global-var-kind v)
126 '(:global :special :unknown))))
127 (barf "strange *FREE-VARS* entry: ~S" v))
128 (dolist (n (leaf-refs v))
129 (check-node-reached n))
130 (when (basic-var-p v)
131 (dolist (n (basic-var-sets v))
132 (check-node-reached n))))
133 *free-vars*)
135 (maphash (lambda (k v)
136 (declare (ignore k))
137 (unless (constant-p v)
138 (barf "strange *CONSTANTS* entry: ~S" v))
139 (dolist (n (leaf-refs v))
140 (check-node-reached n)))
141 *constants*)
143 (maphash (lambda (k v)
144 (declare (ignore k))
145 (unless (or (functional-p v)
146 (and (global-var-p v)
147 (eq (global-var-kind v) :global-function)))
148 (barf "strange *FREE-FUNS* entry: ~S" v))
149 (dolist (n (leaf-refs v))
150 (check-node-reached n)))
151 *free-funs*))
152 (clrhash *seen-blocks*)
153 (clrhash *seen-funs*))
154 (values)))
156 ;;;; function consistency checking
158 (defun observe-functional (x)
159 (declare (type functional x))
160 (when (gethash x *seen-funs*)
161 (barf "~S was seen more than once." x))
162 (unless (eq (functional-kind x) :deleted)
163 (setf (gethash x *seen-funs*) t)))
165 ;;; Check that the specified function has been seen.
166 (defun check-fun-reached (fun where)
167 (declare (type functional fun))
168 (unless (gethash fun *seen-funs*)
169 (barf "unseen function ~S in ~S" fun where)))
171 ;;; In a CLAMBDA, check that the associated nodes are in seen blocks.
172 ;;; In an OPTIONAL-DISPATCH, check that the entry points were seen. If
173 ;;; the function is deleted, ignore it.
174 (defun check-fun-stuff (functional)
175 (ecase (functional-kind functional)
176 (:external
177 (let ((fun (functional-entry-fun functional)))
178 (check-fun-reached fun functional)
179 (when (functional-kind fun)
180 (barf "The function for XEP ~S has kind." functional))
181 (unless (eq (functional-entry-fun fun) functional)
182 (barf "bad back-pointer in function for XEP ~S" functional))))
183 ((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P
184 (check-fun-reached (lambda-home functional) functional)
185 (when (functional-entry-fun functional)
186 (barf "The LET ~S has entry function." functional))
187 (unless (member functional (lambda-lets (lambda-home functional)))
188 (barf "The LET ~S is not in LETs for HOME." functional))
189 (unless (eq (functional-kind functional) :assignment)
190 (when (rest (leaf-refs functional))
191 (barf "The LET ~S has multiple references." functional)))
192 (when (lambda-lets functional)
193 (barf "LETs in a LET: ~S" functional)))
194 (:optional
195 (when (functional-entry-fun functional)
196 (barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
197 (let ((ef (lambda-optional-dispatch functional)))
198 (check-fun-reached ef functional)
199 (unless (or (member functional (optional-dispatch-entry-points ef)
200 :key (lambda (ep)
201 (when (promise-ready-p ep)
202 (force ep))))
203 (eq functional (optional-dispatch-more-entry ef))
204 (eq functional (optional-dispatch-main-entry ef)))
205 (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
206 functional ef))))
207 (:toplevel
208 (unless (eq (functional-entry-fun functional) functional)
209 (barf "The ENTRY-FUN in ~S isn't a self-pointer." functional)))
210 ((nil :escape :cleanup)
211 (let ((ef (functional-entry-fun functional)))
212 (when ef
213 (check-fun-reached ef functional)
214 (unless (eq (functional-kind ef) :external)
215 (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
216 (:deleted
217 (return-from check-fun-stuff)))
219 (case (functional-kind functional)
220 ((nil :optional :external :toplevel :escape :cleanup)
221 (when (lambda-p functional)
222 (dolist (fun (lambda-lets functional))
223 (unless (eq (lambda-home fun) functional)
224 (barf "The home in ~S is not ~S." fun functional))
225 (check-fun-reached fun functional))
226 (unless (eq (lambda-home functional) functional)
227 (barf "home not self-pointer in ~S" functional)))))
229 (etypecase functional
230 (clambda
231 (when (lambda-bind functional)
232 (check-node-reached (lambda-bind functional)))
233 (when (lambda-return functional)
234 (check-node-reached (lambda-return functional)))
236 (dolist (var (lambda-vars functional))
237 (dolist (ref (leaf-refs var))
238 (check-node-reached ref))
239 (dolist (set (basic-var-sets var))
240 (check-node-reached set))
241 (unless (eq (lambda-var-home var) functional)
242 (barf "HOME in ~S should be ~S." var functional))))
243 (optional-dispatch
244 (dolist (ep (optional-dispatch-entry-points functional))
245 (when (promise-ready-p ep)
246 (check-fun-reached (force ep) functional)))
247 (let ((more (optional-dispatch-more-entry functional)))
248 (when more (check-fun-reached more functional)))
249 (check-fun-reached (optional-dispatch-main-entry functional)
250 functional))))
252 (defun check-fun-consistency (components)
253 (dolist (c components)
254 (dolist (new-fun (component-new-functionals c))
255 (observe-functional new-fun))
256 (dolist (fun (component-lambdas c))
257 (when (eq (functional-kind fun) :external)
258 (let ((ef (functional-entry-fun fun)))
259 (when (optional-dispatch-p ef)
260 (observe-functional ef))))
261 (observe-functional fun)
262 (dolist (let (lambda-lets fun))
263 (observe-functional let))))
265 (dolist (c components)
266 (dolist (new-fun (component-new-functionals c))
267 (check-fun-stuff new-fun))
268 (dolist (fun (component-lambdas c))
269 (when (eq (functional-kind fun) :deleted)
270 (barf "deleted lambda ~S in Lambdas for ~S" fun c))
271 (check-fun-stuff fun)
272 (dolist (let (lambda-lets fun))
273 (check-fun-stuff let)))))
275 ;;;; loop consistency checking
278 ;;; Descend through the loop nesting and check that the tree is well-formed
279 ;;; and that all blocks in the loops are known blocks. We also mark each block
280 ;;; that we see so that we can do a check later to detect blocks that weren't
281 ;;; in any loop.
282 (declaim (ftype (function (loop (or loop null)) (values)) check-loop-consistency))
283 (defun check-loop-consistency (loop superior)
284 (unless (eq (loop-superior loop) superior)
285 (barf "wrong superior in ~S, should be ~S" loop superior))
286 (when (and superior
287 (/= (loop-depth loop) (1+ (loop-depth superior))))
288 (barf "wrong depth in ~S" loop))
290 (dolist (tail (loop-tail loop))
291 (check-loop-block tail loop))
292 (dolist (exit (loop-exits loop))
293 (check-loop-block exit loop))
294 (check-loop-block (loop-head loop) loop)
295 (unless (eq (block-loop (loop-head loop)) loop)
296 (barf "The head of ~S is not directly in the loop." loop))
298 (do ((block (loop-blocks loop) (block-loop-next block)))
299 ((null block))
300 (setf (block-flag block) t)
301 (unless (gethash block *seen-blocks*)
302 (barf "unseen block ~S in Blocks for ~S" block loop))
303 (unless (eq (block-loop block) loop)
304 (barf "wrong loop in ~S, should be ~S" block loop)))
306 (dolist (inferior (loop-inferiors loop))
307 (check-loop-consistency inferior loop))
308 (values))
310 ;;; Check that Block is either in Loop or an inferior.
311 (declaim (ftype (function (block loop) (values)) check-loop-block))
312 (defun check-loop-block (block loop)
313 (unless (gethash block *seen-blocks*)
314 (barf "unseen block ~S in loop info for ~S" block loop))
315 (labels ((walk (l)
316 (if (eq (block-loop block) l)
318 (dolist (inferior (loop-inferiors l) nil)
319 (when (walk inferior) (return t))))))
320 (unless (walk loop)
321 (barf "~S is in loop info for ~S but not in the loop." block loop)))
322 (values))
326 ;;; Check a block for consistency at the general flow-graph level, and
327 ;;; call CHECK-NODE-CONSISTENCY on each node to locally check for
328 ;;; semantic consistency.
329 (declaim (ftype (function (cblock) (values)) check-block-consistency))
330 (defun check-block-consistency (block)
332 (dolist (pred (block-pred block))
333 (unless (gethash pred *seen-blocks*)
334 (barf "unseen predecessor ~S in ~S" pred block))
335 (unless (member block (block-succ pred))
336 (barf "bad predecessor link ~S in ~S" pred block)))
338 (let* ((fun (block-home-lambda block))
339 (fun-deleted (eq (functional-kind fun) :deleted))
340 (this-ctran (block-start block))
341 (last (block-last block)))
342 (unless fun-deleted
343 (check-fun-reached fun block))
344 (when (not this-ctran)
345 (barf "~S has no START." block))
346 (when (not last)
347 (barf "~S has no LAST." block))
348 (unless (eq (ctran-kind this-ctran) :block-start)
349 (barf "The START of ~S has the wrong kind." block))
351 (when (ctran-use this-ctran)
352 (barf "The ctran ~S is used." this-ctran))
354 (when (node-next last)
355 (barf "Last node ~S of ~S has next ctran." last block))
357 (loop
358 (unless (eq (ctran-block this-ctran) block)
359 (barf "BLOCK of ~S should be ~S." this-ctran block))
361 (let ((node (ctran-next this-ctran)))
362 (unless (node-p node)
363 (barf "~S has strange NEXT." this-ctran))
364 (unless (eq (node-prev node) this-ctran)
365 (barf "PREV in ~S should be ~S." node this-ctran))
367 (when (valued-node-p node)
368 (binding* ((lvar (node-lvar node) :exit-if-null))
369 (unless (memq node (find-uses lvar))
370 (barf "~S is not used by its LVAR ~S." node lvar))
371 (when (singleton-p (lvar-uses lvar))
372 (barf "~S has exactly 1 use, but LVAR-USES is a list."
373 lvar))
374 (unless (lvar-dest lvar)
375 (barf "~S does not have dest." lvar))))
377 (check-node-reached node)
378 (unless fun-deleted
379 (check-node-consistency node))
381 (let ((next (node-next node)))
382 (when (and (not next) (not (eq node last)))
383 (barf "~S has no NEXT." node))
384 (when (eq node last) (return))
385 (unless (eq (ctran-kind next) :inside-block)
386 (barf "The interior ctran ~S in ~S has the wrong kind."
387 next
388 block))
389 (unless (ctran-next next)
390 (barf "~S has no NEXT." next))
391 (unless (eq (ctran-use next) node)
392 (barf "USE in ~S should be ~S." next node))
393 (setq this-ctran next))))
395 (check-block-successors block))
396 (values))
398 ;;; Check that BLOCK is properly terminated. Each successor must be
399 ;;; accounted for by the type of the last node.
400 (declaim (ftype (function (cblock) (values)) check-block-successors))
401 (defun check-block-successors (block)
402 (let ((last (block-last block))
403 (succ (block-succ block)))
405 (let* ((comp (block-component block)))
406 (dolist (b succ)
407 (unless (gethash b *seen-blocks*)
408 (barf "unseen successor ~S in ~S" b block))
409 (unless (member block (block-pred b))
410 (barf "bad successor link ~S in ~S" b block))
411 (unless (eq (block-component b) comp)
412 (barf "The successor ~S in ~S is in a different component."
414 block))))
416 (typecase last
417 (cif
418 (unless (proper-list-of-length-p succ 1 2)
419 (barf "~S ends in an IF, but doesn't have one or two successors."
420 block))
421 (unless (member (if-consequent last) succ)
422 (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
423 (unless (member (if-alternative last) succ)
424 (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
425 (creturn
426 (unless (if (eq (functional-kind (return-lambda last)) :deleted)
427 (null succ)
428 (and (= (length succ) 1)
429 (eq (first succ)
430 (component-tail (block-component block)))))
431 (barf "strange successors for RETURN in ~S" block)))
432 (exit
433 (unless (proper-list-of-length-p succ 0 1)
434 (barf "EXIT node with strange number of successors: ~S" last)))
436 (unless (or (= (length succ) 1) (node-tail-p last)
437 (and (block-delete-p block) (null succ)))
438 (barf "~S ends in normal node, but doesn't have one successor."
439 block)))))
440 (values))
442 ;;;; node consistency checking
444 ;;; Check that the DEST for LVAR is the specified NODE. We also mark
445 ;;; the block LVAR is in as SEEN.
446 #+nil(declaim (ftype (function (lvar node) (values)) check-dest))
447 (defun check-dest (lvar node)
448 (do-uses (use lvar)
449 (unless (gethash (node-block use) *seen-blocks*)
450 (barf "Node ~S using ~S is in an unknown block." use lvar)))
451 (unless (eq (lvar-dest lvar) node)
452 (barf "DEST for ~S should be ~S." lvar node))
453 (unless (find-uses lvar)
454 (barf "Lvar ~S has a destinatin, but no uses."
455 lvar))
456 (values))
458 ;;; This function deals with checking for consistency of the
459 ;;; type-dependent information in a node.
460 (defun check-node-consistency (node)
461 (declare (type node node))
462 (etypecase node
463 (ref
464 (let ((leaf (ref-leaf node)))
465 (when (functional-p leaf)
466 (if (eq (functional-kind leaf) :toplevel-xep)
467 (unless (component-toplevelish-p (block-component (node-block node)))
468 (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
469 node))
470 (check-fun-reached leaf node)))))
471 (basic-combination
472 (check-dest (basic-combination-fun node) node)
473 (when (and (mv-combination-p node)
474 (eq (basic-combination-kind node) :local))
475 (let ((fun-lvar (basic-combination-fun node)))
476 (unless (ref-p (lvar-uses fun-lvar))
477 (barf "function in a local mv-combination is not a LEAF: ~S" node))
478 (let ((fun (ref-leaf (lvar-use fun-lvar))))
479 (unless (lambda-p fun)
480 (barf "function ~S in a local mv-combination ~S is not local"
481 fun node))
482 (unless (eq (functional-kind fun) :mv-let)
483 (barf "function ~S in a local mv-combination ~S is not of kind :MV-LET"
484 fun node)))))
485 (dolist (arg (basic-combination-args node))
486 (cond
487 (arg (check-dest arg node))
488 ((not (and (eq (basic-combination-kind node) :local)
489 (combination-p node)))
490 (barf "flushed arg not in local call: ~S" node))
492 (locally
493 ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
494 ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
495 ;; POSITION. It compiles it correctly, but it issues a type
496 ;; mismatch warning because it can't eliminate the
497 ;; possibility that control will flow through the
498 ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
499 (declare (notinline position))
500 (let ((fun (ref-leaf (lvar-use
501 (basic-combination-fun node))))
502 (pos (position arg (basic-combination-args node))))
503 (declare (type index pos))
504 (when (leaf-refs (elt (lambda-vars fun) pos))
505 (barf "flushed arg for referenced var in ~S" node)))))))
506 (let* ((lvar (node-lvar node))
507 (dest (and lvar (lvar-dest lvar))))
508 (when (and (return-p dest)
509 (eq (basic-combination-kind node) :local)
510 (not (eq (lambda-tail-set (combination-lambda node))
511 (lambda-tail-set (return-lambda dest)))))
512 (barf "tail local call to function with different tail set:~% ~S"
513 node))))
514 (cif
515 (check-dest (if-test node) node)
516 (unless (eq (block-last (node-block node)) node)
517 (barf "IF not at block end: ~S" node)))
518 (cset
519 (check-dest (set-value node) node))
520 (cast
521 (check-dest (cast-value node) node))
522 (bind
523 (check-fun-reached (bind-lambda node) node))
524 (creturn
525 (check-fun-reached (return-lambda node) node)
526 (check-dest (return-result node) node)
527 (unless (eq (block-last (node-block node)) node)
528 (barf "RETURN not at block end: ~S" node)))
529 (entry
530 (unless (member node (lambda-entries (node-home-lambda node)))
531 (barf "~S is not in ENTRIES for its home LAMBDA." node))
532 (dolist (exit (entry-exits node))
533 (unless (node-deleted exit)
534 (check-node-reached node))))
535 (exit
536 (let ((entry (exit-entry node))
537 (value (exit-value node)))
538 (cond (entry
539 (check-node-reached entry)
540 (unless (member node (entry-exits entry))
541 (barf "~S is not in its ENTRY's EXITS." node))
542 (when value
543 (check-dest value node)))
545 (when value
546 (barf "~S has VALUE but no ENTRY." node)))))))
548 (values))
550 ;;;; IR2 consistency checking
552 ;;; Check for some kind of consistency in some REFs linked together by
553 ;;; TN-REF-ACROSS. VOP is the VOP that the references are in. WRITE-P
554 ;;; is the value of WRITE-P that should be present. COUNT is the
555 ;;; minimum number of operands expected. If MORE-P is true, then any
556 ;;; larger number will also be accepted. WHAT is a string describing
557 ;;; the kind of operand in error messages.
558 (defun check-tn-refs (refs vop write-p count more-p what)
559 (let ((vop-refs (vop-refs vop)))
560 (do ((ref refs (tn-ref-across ref))
561 (num 0 (1+ num)))
562 ((null ref)
563 (when (< num count)
564 (barf "There should be at least ~W ~A in ~S, but there are only ~W."
565 count what vop num))
566 (when (and (not more-p) (> num count))
567 (barf "There should be ~W ~A in ~S, but are ~W."
568 count what vop num)))
569 (unless (eq (tn-ref-vop ref) vop)
570 (barf "VOP is ~S isn't ~S." ref vop))
571 (unless (eq (tn-ref-write-p ref) write-p)
572 (barf "The WRITE-P in ~S isn't ~S." vop write-p))
573 (unless (find-in #'tn-ref-next-ref ref vop-refs)
574 (barf "~S not found in REFS for ~S" ref vop))
575 (unless (find-in #'tn-ref-next ref
576 (if (tn-ref-write-p ref)
577 (tn-writes (tn-ref-tn ref))
578 (tn-reads (tn-ref-tn ref))))
579 (barf "~S not found in reads/writes for its TN" ref))
581 (let ((target (tn-ref-target ref)))
582 (when target
583 (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
584 (barf "The target for ~S isn't complementary WRITE-P." ref))
585 (unless (find-in #'tn-ref-next-ref target vop-refs)
586 (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
588 ;;; Verify the sanity of the VOP-REFS slot in VOP. This involves checking
589 ;;; that each referenced TN appears as an argument, result or temp, and also
590 ;;; basic checks for the plausibility of the specified ordering of the refs.
591 (defun check-vop-refs (vop)
592 (declare (type vop vop))
593 (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
594 ((null ref))
595 (cond
596 ((find-in #'tn-ref-across ref (vop-args vop)))
597 ((find-in #'tn-ref-across ref (vop-results vop)))
598 ((not (eq (tn-ref-vop ref) vop))
599 (barf "VOP in ~S isn't ~S." ref vop))
600 ((find-in #'tn-ref-across ref (vop-temps vop)))
601 ((tn-ref-write-p ref)
602 (barf "stray ref that isn't a READ: ~S" ref))
604 (let* ((tn (tn-ref-tn ref))
605 (temp (find-in #'tn-ref-across tn (vop-temps vop)
606 :key #'tn-ref-tn)))
607 (unless temp
608 (barf "stray ref with no corresponding temp write: ~S" ref))
609 (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
610 (barf "Read is after write for temp ~S in refs of ~S."
611 tn vop))))))
612 (values))
614 ;;; Check the basic sanity of the VOP linkage, then call some other
615 ;;; functions to check on the TN-REFS. We grab some info out of the
616 ;;; VOP-INFO to tell us what to expect.
618 ;;; [### Check that operand type restrictions are met?]
619 (defun check-ir2-block-consistency (2block)
620 (declare (type ir2-block 2block))
621 (do ((vop (ir2-block-start-vop 2block)
622 (vop-next vop))
623 (prev nil vop))
624 ((null vop)
625 (unless (eq prev (ir2-block-last-vop 2block))
626 (barf "The last VOP in ~S should be ~S." 2block prev)))
627 (unless (eq (vop-prev vop) prev)
628 (barf "PREV in ~S should be ~S." vop prev))
630 (unless (eq (vop-block vop) 2block)
631 (barf "BLOCK in ~S should be ~S." vop 2block))
633 (check-vop-refs vop)
635 (let* ((info (vop-info vop))
636 (atypes (template-arg-types info))
637 (rtypes (template-result-types info)))
638 (check-tn-refs (vop-args vop) vop nil
639 (count-if-not (lambda (x)
640 (and (consp x)
641 (eq (car x) :constant)))
642 atypes)
643 (template-more-args-type info) "args")
644 (check-tn-refs (vop-results vop) vop t
645 (if (template-conditional-p info) 0 (length rtypes))
646 (template-more-results-type info) "results")
647 (check-tn-refs (vop-temps vop) vop t 0 t "temps")
648 (unless (= (length (vop-codegen-info vop))
649 (template-info-arg-count info))
650 (barf "wrong number of codegen info args in ~S" vop))))
651 (values))
653 ;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
654 ;;; sanity of the basic flow graph.
656 ;;; [### Also grovel global TN data structures? Assume pack not
657 ;;; done yet? Have separate CHECK-TN-CONSISTENCY for pre-pack and
658 ;;; CHECK-PACK-CONSISTENCY for post-pack?]
659 (defun check-ir2-consistency (component)
660 (declare (type component component))
661 (do-ir2-blocks (block component)
662 (check-ir2-block-consistency block))
663 (values))
665 ;;;; lifetime analysis checking
667 ;;; Dump some info about how many TNs there, and what the conflicts data
668 ;;; structures are like.
669 (defun pre-pack-tn-stats (component &optional (stream *standard-output*))
670 (declare (type component component))
671 (let ((wired 0)
672 (global 0)
673 (local 0)
674 (confs 0)
675 (unused 0)
676 (const 0)
677 (temps 0)
678 (environment 0)
679 (comp 0))
680 (do-packed-tns (tn component)
681 (let ((reads (tn-reads tn))
682 (writes (tn-writes tn)))
683 (when (and reads writes
684 (not (tn-ref-next reads)) (not (tn-ref-next writes))
685 (eq (tn-ref-vop reads) (tn-ref-vop writes)))
686 (incf temps)))
687 (when (tn-offset tn)
688 (incf wired))
689 (unless (or (tn-reads tn) (tn-writes tn))
690 (incf unused))
691 (cond ((eq (tn-kind tn) :component)
692 (incf comp))
693 ((tn-global-conflicts tn)
694 (case (tn-kind tn)
695 ((:environment :debug-environment) (incf environment))
696 (t (incf global)))
697 (do ((conf (tn-global-conflicts tn)
698 (global-conflicts-next-tnwise conf)))
699 ((null conf))
700 (incf confs)))
702 (incf local))))
704 (do ((tn (ir2-component-constant-tns (component-info component))
705 (tn-next tn)))
706 ((null tn))
707 (incf const))
709 (format stream
710 "~%TNs: ~W local, ~W temps, ~W constant, ~W env, ~W comp, ~W global.~@
711 Wired: ~W, Unused: ~W. ~W block~:P, ~W global conflict~:P.~%"
712 local temps const environment comp global wired unused
713 (ir2-block-count component)
714 confs))
715 (values))
717 ;;; If the entry in Local-TNs for TN in BLOCK is :MORE, then do some checks
718 ;;; for the validity of the usage.
719 (defun check-more-tn-entry (tn block)
720 (let* ((vop (ir2-block-start-vop block))
721 (info (vop-info vop)))
722 (macrolet ((frob (more-p ops)
723 `(and (,more-p info)
724 (find-in #'tn-ref-across tn (,ops vop)
725 :key #'tn-ref-tn))))
726 (unless (and (eq vop (ir2-block-last-vop block))
727 (or (frob template-more-args-type vop-args)
728 (frob template-more-results-type vop-results)))
729 (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
730 (values))
732 (defun check-tn-conflicts (component)
733 (do-packed-tns (tn component)
734 (unless (or (not (eq (tn-kind tn) :normal))
735 (tn-reads tn)
736 (tn-writes tn))
737 (barf "no references to ~S" tn))
739 (unless (tn-sc tn) (barf "~S has no SC." tn))
741 (let ((conf (tn-global-conflicts tn))
742 (kind (tn-kind tn)))
743 (cond
744 ((eq kind :component)
745 (unless (member tn (ir2-component-component-tns
746 (component-info component)))
747 (barf "~S not in COMPONENT-TNs for ~S" tn component)))
748 (conf
749 (do ((conf conf (global-conflicts-next-tnwise conf))
750 (prev nil conf))
751 ((null conf))
752 (unless (eq (global-conflicts-tn conf) tn)
753 (barf "TN in ~S should be ~S." conf tn))
755 (unless (eq (global-conflicts-kind conf) :live)
756 (let* ((block (global-conflicts-block conf))
757 (ltn (svref (ir2-block-local-tns block)
758 (global-conflicts-number conf))))
759 (cond ((eq ltn tn))
760 ((eq ltn :more) (check-more-tn-entry tn block))
762 (barf "~S wrong in LTN map for ~S" conf tn)))))
764 (when prev
765 (unless (> (ir2-block-number (global-conflicts-block conf))
766 (ir2-block-number (global-conflicts-block prev)))
767 (barf "~s and ~s out of order" prev conf)))))
768 ((member (tn-kind tn) '(:constant :specified-save)))
770 (let ((local (tn-local tn)))
771 (unless local
772 (barf "~S has no global conflicts, but isn't local either." tn))
773 (unless (eq (svref (ir2-block-local-tns local)
774 (tn-local-number tn))
776 (barf "~S wrong in LTN map" tn))
777 (do ((ref (tn-reads tn) (tn-ref-next ref)))
778 ((null ref))
779 (unless (eq (vop-block (tn-ref-vop ref)) local)
780 (barf "~S has references in blocks other than its LOCAL block."
781 tn)))
782 (do ((ref (tn-writes tn) (tn-ref-next ref)))
783 ((null ref))
784 (unless (eq (vop-block (tn-ref-vop ref)) local)
785 (barf "~S has references in blocks other than its LOCAL block."
786 tn))))))))
787 (values))
789 (defun check-block-conflicts (component)
790 (do-ir2-blocks (block component)
791 (do ((conf (ir2-block-global-tns block)
792 (global-conflicts-next-blockwise conf))
793 (prev nil conf))
794 ((null conf))
795 (when prev
796 (unless (> (tn-number (global-conflicts-tn conf))
797 (tn-number (global-conflicts-tn prev)))
798 (barf "~S and ~S out of order in ~S" prev conf block)))
800 (unless (find-in #'global-conflicts-next-tnwise
801 conf
802 (tn-global-conflicts
803 (global-conflicts-tn conf)))
804 (barf "~S missing from global conflicts of its TN" conf)))
806 (let ((map (ir2-block-local-tns block)))
807 (dotimes (i (ir2-block-local-tn-count block))
808 (let ((tn (svref map i)))
809 (unless (or (eq tn :more)
810 (null tn)
811 (tn-global-conflicts tn)
812 (eq (tn-local tn) block))
813 (barf "strange TN ~S in LTN map for ~S" tn block)))))))
815 ;;; All TNs live at the beginning of an environment must be passing
816 ;;; locations associated with that environment. We make an exception
817 ;;; for wired TNs in XEP functions, since we randomly reference wired
818 ;;; TNs to access the full call passing locations.
819 (defun check-environment-lifetimes (component)
820 (dolist (fun (component-lambdas component))
821 (let* ((env (lambda-physenv fun))
822 (2env (physenv-info env))
823 (vars (lambda-vars fun))
824 (closure (ir2-physenv-closure 2env))
825 (pc (ir2-physenv-return-pc-pass 2env))
826 (fp (ir2-physenv-old-fp 2env))
827 (2block (block-info (lambda-block (physenv-lambda env)))))
828 (do ((conf (ir2-block-global-tns 2block)
829 (global-conflicts-next-blockwise conf)))
830 ((null conf))
831 (let ((tn (global-conflicts-tn conf)))
832 (unless (or (eq (global-conflicts-kind conf) :write)
833 (eq tn pc)
834 (eq tn fp)
835 (and (xep-p fun) (tn-offset tn))
836 (member (tn-kind tn) '(:environment :debug-environment))
837 (member tn vars :key #'leaf-info)
838 (member tn closure :key #'cdr))
839 (barf "strange TN live at head of ~S: ~S" env tn))))))
840 (values))
842 ;;; Check for some basic sanity in the TN conflict data structures,
843 ;;; and also check that no TNs are unexpectedly live at environment
844 ;;; entry.
845 (defun check-life-consistency (component)
846 (check-tn-conflicts component)
847 (check-block-conflicts component)
848 (check-environment-lifetimes component))
850 ;;;; pack consistency checking
852 (defun check-pack-consistency (component)
853 (flet ((check (scs ops)
854 (do ((scs scs (cdr scs))
855 (op ops (tn-ref-across op)))
856 ((null scs))
857 (let ((load-tn (tn-ref-load-tn op)))
858 (unless (eq (svref (car scs)
859 (sc-number
860 (tn-sc
861 (or load-tn (tn-ref-tn op)))))
863 (barf "operand restriction not satisfied: ~S" op))))))
864 (do-ir2-blocks (block component)
865 (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
866 ((null vop))
867 (let ((info (vop-info vop)))
868 (check (vop-info-result-load-scs info) (vop-results vop))
869 (check (vop-info-arg-load-scs info) (vop-args vop))))))
870 (values))
872 ;;;; data structure dumping routines
874 ;;; When we print CONTINUATIONs and TNs, we assign them small numeric
875 ;;; IDs so that we can get a handle on anonymous objects given a
876 ;;; printout.
877 (macrolet ((def (array-getter fto ffrom) ; "to" = to number/id, resp. "from"
878 `(progn
879 (defun ,fto (x)
880 (let* ((map *compiler-ir-obj-map*)
881 (ht (objmap-obj-to-id map)))
882 (or (values (gethash x ht))
883 (let ((array (,array-getter map))
884 (num (incf (,(symbolicate "OBJMAP-" fto) map))))
885 (when (>= num (length array))
886 (let ((new (adjust-array array (* (length array) 2))))
887 (fill array nil)
888 (setf array new (,array-getter map) array)))
889 (setf (svref array num) x)
890 (setf (gethash x ht) num)))))
892 (defun ,ffrom (num)
893 (let ((array (,array-getter *compiler-ir-obj-map*)))
894 (and (< num (length array)) (svref array num)))))))
895 (def objmap-id-to-cont cont-num num-cont)
896 (def objmap-id-to-tn tn-id id-tn)
897 (def objmap-id-to-label label-id id-label))
899 ;;; Print a terse one-line description of LEAF.
900 (defun print-leaf (leaf &optional (stream *standard-output*))
901 (declare (type leaf leaf) (type stream stream))
902 (etypecase leaf
903 (lambda-var (prin1 (leaf-debug-name leaf) stream))
904 (constant (format stream "'~S" (constant-value leaf)))
905 (global-var
906 (format stream "~S {~A}" (leaf-debug-name leaf) (global-var-kind leaf)))
907 (functional
908 (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf)))))
910 ;;; Attempt to find a block given some thing that has to do with it.
911 (declaim (ftype (sfunction (t) cblock) block-or-lose))
912 (defun block-or-lose (thing)
913 (ctypecase thing
914 (cblock thing)
915 (ir2-block (ir2-block-block thing))
916 (vop (block-or-lose (vop-block thing)))
917 (tn-ref (block-or-lose (tn-ref-vop thing)))
918 (ctran (ctran-block thing))
919 (node (node-block thing))
920 (component (component-head thing))
921 #| (cloop (loop-head thing))|#
922 (integer (ctran-block (num-cont thing)))
923 (functional (lambda-block (main-entry thing)))
924 (null (error "Bad thing: ~S." thing))
925 (symbol (block-or-lose (gethash thing *free-funs*)))))
927 ;;; Print cN.
928 (defun print-ctran (cont)
929 (declare (type ctran cont))
930 (format t "c~D " (cont-num cont))
931 (values))
932 (defun print-lvar (cont)
933 (declare (type lvar cont))
934 (format t "v~D " (cont-num cont))
935 (values))
937 (defun print-lvar-stack (stack &optional (stream *standard-output*))
938 (loop for (lvar . rest) on stack
939 do (format stream "~:[u~;d~]v~D~@[ ~]"
940 (lvar-dynamic-extent lvar) (cont-num lvar) rest)))
942 ;;; Print out the nodes in BLOCK in a format oriented toward
943 ;;; representing what the code does.
944 (defun print-nodes (block)
945 (setq block (block-or-lose block))
946 (pprint-logical-block (nil nil)
947 (format t "~:@_IR1 block ~D start c~D"
948 (block-number block) (cont-num (block-start block)))
949 (when (block-delete-p block)
950 (format t " <deleted>"))
952 (pprint-newline :mandatory)
953 (awhen (block-info block)
954 (format t "start stack: ")
955 (print-lvar-stack (ir2-block-start-stack it))
956 (pprint-newline :mandatory))
957 (do ((ctran (block-start block) (node-next (ctran-next ctran))))
958 ((not ctran))
959 (let ((node (ctran-next ctran)))
960 (format t "~3D>~:[ ~;~:*~3D:~] "
961 (cont-num ctran)
962 (when (and (valued-node-p node) (node-lvar node))
963 (cont-num (node-lvar node))))
964 (etypecase node
965 (ref (print-leaf (ref-leaf node)))
966 (basic-combination
967 (let ((kind (basic-combination-kind node)))
968 (format t "~(~A~A ~A~) "
969 (if (node-tail-p node) "tail " "")
970 kind
971 (type-of node))
972 (print-lvar (basic-combination-fun node))
973 (dolist (arg (basic-combination-args node))
974 (if arg
975 (print-lvar arg)
976 (format t "<none> ")))))
977 (cset
978 (write-string "set ")
979 (print-leaf (set-var node))
980 (write-char #\space)
981 (print-lvar (set-value node)))
982 (cif
983 (write-string "if ")
984 (print-lvar (if-test node))
985 (print-ctran (block-start (if-consequent node)))
986 (print-ctran (block-start (if-alternative node))))
987 (bind
988 (write-string "bind ")
989 (print-leaf (bind-lambda node))
990 (when (functional-kind (bind-lambda node))
991 (format t " ~S ~S" :kind (functional-kind (bind-lambda node)))))
992 (creturn
993 (write-string "return ")
994 (print-lvar (return-result node))
995 (print-leaf (return-lambda node)))
996 (entry
997 (let ((cleanup (entry-cleanup node)))
998 (case (cleanup-kind cleanup)
999 ((:dynamic-extent)
1000 (format t "entry DX~{ v~D~}"
1001 (mapcar (lambda (lvar-or-cell)
1002 (if (consp lvar-or-cell)
1003 (cons (car lvar-or-cell)
1004 (cont-num (cdr lvar-or-cell)))
1005 (cont-num lvar-or-cell)))
1006 (cleanup-info cleanup))))
1008 (format t "entry ~S" (entry-exits node))))))
1009 (exit
1010 (let ((value (exit-value node)))
1011 (cond (value
1012 (format t "exit ")
1013 (print-lvar value))
1014 ((exit-entry node)
1015 (format t "exit <no value>"))
1017 (format t "exit <degenerate>")))))
1018 (cast
1019 (let ((value (cast-value node)))
1020 (format t "cast v~D ~A[~S -> ~S]" (cont-num value)
1021 (if (cast-%type-check node) #\+ #\-)
1022 (cast-type-to-check node)
1023 (cast-asserted-type node)))))
1024 (pprint-newline :mandatory)))
1026 (awhen (block-info block)
1027 (format t "end stack: ")
1028 (print-lvar-stack (ir2-block-end-stack it))
1029 (pprint-newline :mandatory))
1030 (let ((succ (block-succ block)))
1031 (format t "successors~{ c~D~}~%"
1032 (mapcar (lambda (x) (cont-num (block-start x))) succ))))
1033 (values))
1035 ;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T)
1036 ;;; and printers for compound objects which contain TNs)
1037 (defun print-tn-guts (tn &optional (stream *standard-output*))
1038 (declare (type tn tn))
1039 (let ((leaf (tn-leaf tn)))
1040 (cond (leaf
1041 (print-leaf leaf stream)
1042 (format stream "!~D" (tn-id tn)))
1044 (format stream "t~D" (tn-id tn))))
1045 (when (and (tn-sc tn) (tn-offset tn))
1046 (format stream "[~A]" (location-print-name tn)))))
1048 ;;; Print the TN-REFs representing some operands to a VOP, linked by
1049 ;;; TN-REF-ACROSS.
1050 (defun print-operands (refs)
1051 (declare (type (or tn-ref null) refs))
1052 (pprint-logical-block (*standard-output* nil)
1053 (do ((ref refs (tn-ref-across ref)))
1054 ((null ref))
1055 (let ((tn (tn-ref-tn ref))
1056 (ltn (tn-ref-load-tn ref)))
1057 (cond ((not ltn)
1058 (print-tn-guts tn))
1060 (print-tn-guts tn)
1061 (princ (if (tn-ref-write-p ref) #\< #\>))
1062 (print-tn-guts ltn)))
1063 (princ #\space)
1064 (pprint-newline :fill)))))
1066 ;;; Print the VOP, putting args, info and results on separate lines, if
1067 ;;; necessary.
1068 (defun print-vop (vop)
1069 (pprint-logical-block (*standard-output* nil)
1070 (princ (vop-info-name (vop-info vop)))
1071 (princ #\space)
1072 (pprint-indent :current 0)
1073 (print-operands (vop-args vop))
1074 (pprint-newline :linear)
1075 (when (vop-codegen-info vop)
1076 (princ (with-simple-output-to-string (stream)
1077 (let ((*print-level* 1)
1078 (*print-length* 3))
1079 (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
1080 (pprint-newline :linear))
1081 (when (vop-results vop)
1082 (princ "=> ")
1083 (print-operands (vop-results vop))))
1084 (pprint-newline :mandatory))
1086 ;;; Print the VOPs in the specified IR2 block.
1087 (defun print-ir2-block (block)
1088 (declare (type ir2-block block))
1089 (pprint-logical-block (*standard-output* nil)
1090 (cond
1091 ((eq (block-info (ir2-block-block block)) block)
1092 (format t "~:@_IR2 block ~D start c~D~:@_"
1093 (ir2-block-number block)
1094 (cont-num (block-start (ir2-block-block block))))
1095 (let ((label (ir2-block-%label block)))
1096 (when label
1097 (format t "L~D:~:@_" (label-id label)))))
1099 (format t "<overflow>~:@_")))
1101 (do ((vop (ir2-block-start-vop block)
1102 (vop-next vop))
1103 (number 0 (1+ number)))
1104 ((null vop))
1105 (format t "~W: " number)
1106 (print-vop vop))))
1108 ;;; This is like PRINT-NODES, but dumps the IR2 representation of the
1109 ;;; code in BLOCK.
1110 (defun print-vops (block)
1111 (setq block (block-or-lose block))
1112 (let ((2block (block-info block)))
1113 (print-ir2-block 2block)
1114 (do ((b (ir2-block-next 2block) (ir2-block-next b)))
1115 ((not (eq (ir2-block-block b) block)))
1116 (print-ir2-block b)))
1117 (values))
1119 ;;; Scan the IR2 blocks in emission order.
1120 (defun print-ir2-blocks (thing &optional full)
1121 (let* ((block (component-head (block-component (block-or-lose thing))))
1122 (2block (block-info block)))
1123 (pprint-logical-block (nil nil)
1124 (loop while 2block
1125 do (setq block (ir2-block-block 2block))
1126 do (pprint-logical-block (*standard-output* nil)
1127 (if full
1128 (print-nodes block)
1129 (format t "IR1 block ~D start c~D"
1130 (block-number block)
1131 (cont-num (block-start block))))
1132 (pprint-indent :block 4)
1133 (pprint-newline :mandatory)
1134 (loop while (and 2block (eq (ir2-block-block 2block) block))
1135 do (print-ir2-block 2block)
1136 do (setq 2block (ir2-block-next 2block))))
1137 do (pprint-newline :mandatory))))
1138 (values))
1140 ;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by
1141 ;;; successor links.
1142 (defun print-blocks (block)
1143 (setq block (block-or-lose block))
1144 (do-blocks (block (block-component block) :both)
1145 (setf (block-flag block) nil))
1146 (labels ((walk (block)
1147 (unless (block-flag block)
1148 (setf (block-flag block) t)
1149 (when (block-start block)
1150 (print-nodes block))
1151 (dolist (block (block-succ block))
1152 (walk block)))))
1153 (walk block))
1154 (values))
1156 ;;; Print all blocks in BLOCK's component in DFO.
1157 (defun print-all-blocks (thing)
1158 (do-blocks (block (block-component (block-or-lose thing)))
1159 (handler-case (print-nodes block)
1160 (error (condition)
1161 (format t "~&~A...~%" condition))))
1162 (values))
1164 (defvar *list-conflicts-table* (make-hash-table :test 'eq))
1166 ;;; Add all ALWAYS-LIVE TNs in BLOCK to the conflicts. TN is ignored
1167 ;;; when it appears in the global conflicts.
1168 (defun add-always-live-tns (block tn)
1169 (declare (type ir2-block block) (type tn tn))
1170 (do ((conf (ir2-block-global-tns block)
1171 (global-conflicts-next-blockwise conf)))
1172 ((null conf))
1173 (when (eq (global-conflicts-kind conf) :live)
1174 (let ((btn (global-conflicts-tn conf)))
1175 (unless (eq btn tn)
1176 (setf (gethash btn *list-conflicts-table*) t)))))
1177 (values))
1179 ;;; Add all local TNs in BLOCK to the conflicts.
1180 (defun add-all-local-tns (block)
1181 (declare (type ir2-block block))
1182 (let ((ltns (ir2-block-local-tns block)))
1183 (dotimes (i (ir2-block-local-tn-count block))
1184 (setf (gethash (svref ltns i) *list-conflicts-table*) t)))
1185 (values))
1187 ;;; Make a list out of all of the recorded conflicts.
1188 (defun listify-conflicts-table ()
1189 (collect ((res))
1190 (maphash (lambda (k v)
1191 (declare (ignore v))
1192 (when k
1193 (res k)))
1194 *list-conflicts-table*)
1195 (res)))
1197 ;;; Return a list of a the TNs that conflict with TN. Sort of, kind
1198 ;;; of. For debugging use only. Probably doesn't work on :COMPONENT TNs.
1199 (defun list-conflicts (tn)
1200 (aver (member (tn-kind tn) '(:normal :environment :debug-environment)))
1201 (let ((confs (tn-global-conflicts tn)))
1202 (cond (confs
1203 (let ((*list-conflicts-table* (make-hash-table :test 'eq)))
1204 (unwind-protect
1205 (do ((conf confs (global-conflicts-next-tnwise conf)))
1206 ((null conf)
1207 (listify-conflicts-table))
1208 (format t "~&#<block ~D kind ~S>~%"
1209 (block-number (ir2-block-block (global-conflicts-block
1210 conf)))
1211 (global-conflicts-kind conf))
1212 (let ((block (global-conflicts-block conf)))
1213 (add-always-live-tns block tn)
1214 (if (eq (global-conflicts-kind conf) :live)
1215 (add-all-local-tns block)
1216 (let ((bconf (global-conflicts-conflicts conf))
1217 (ltns (ir2-block-local-tns block)))
1218 (dotimes (i (ir2-block-local-tn-count block))
1219 (when (/= (sbit bconf i) 0)
1220 (setf (gethash (svref ltns i) *list-conflicts-table*)
1221 t)))))))
1222 (clrhash *list-conflicts-table*))))
1224 (let* ((block (tn-local tn))
1225 (ltns (ir2-block-local-tns block))
1226 (confs (tn-local-conflicts tn)))
1227 (collect ((res))
1228 (dotimes (i (ir2-block-local-tn-count block))
1229 (when (/= (sbit confs i) 0)
1230 (let ((tn (svref ltns i)))
1231 (when (and tn (not (eq tn :more))
1232 (not (tn-global-conflicts tn)))
1233 (res tn)))))
1234 (do ((gtn (ir2-block-global-tns block)
1235 (global-conflicts-next-blockwise gtn)))
1236 ((null gtn))
1237 (when (or (eq (global-conflicts-kind gtn) :live)
1238 (/= (sbit confs (global-conflicts-number gtn)) 0))
1239 (res (global-conflicts-tn gtn))))
1240 (res)))))))
1242 (defun nth-vop (thing n)
1243 #!+sb-doc
1244 "Return the Nth VOP in the IR2-BLOCK pointed to by THING."
1245 (let ((block (block-info (block-or-lose thing))))
1246 (do ((i 0 (1+ i))
1247 (vop (ir2-block-start-vop block) (vop-next vop)))
1248 ((= i n) vop))))