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
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.
17 "This variable is bound to the format arguments when an error is signalled
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*)
28 (apply #'error string *args*)
30 :report "Ignore this error.")
32 :report "Ignore this and all future occurrences of this error."
33 (setf (gethash string *ignored-errors*) t))))
36 (defvar *burp-action* :warn
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*)
47 (:warn (apply #'warn string *args*))
48 (:error (apply #'cerror "press on anyway." string *args*))
52 ;;; *SEEN-BLOCKS* is a hashtable with true values for all blocks which
53 ;;; appear in the DFO for one of the specified components.
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* (make-hash-table :test 'eq))
60 (defvar *seen-funs* (make-hash-table :test 'eq))
62 ;;; Barf if NODE is in a block which wasn't reached during the graph
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))
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*.
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 (clrhash *seen-blocks*)
84 (dolist (c components)
85 (let* ((head (component-head c))
86 (tail (component-tail c)))
87 (unless (and (null (block-pred head))
88 (null (block-succ tail)))
89 (barf "~S is malformed." c))
92 (block head (block-next block)))
94 (unless (eq prev tail)
95 (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
96 (setf (gethash block *seen-blocks*) t)
97 (unless (eq (block-prev block) prev)
98 (barf "bad PREV for ~S, should be ~S" block prev))
99 (unless (or (eq block tail)
100 (eq (block-component block) c))
101 (barf "~S is not in ~S." block c)))
103 (when (or (loop-blocks c) (loop-inferiors c))
104 (do-blocks (block c :both)
105 (setf (block-flag block) nil))
106 (check-loop-consistency c nil)
107 (do-blocks (block c :both)
108 (unless (block-flag block)
109 (barf "~S was not in any loop." block))))
113 (check-fun-consistency components)
115 (dolist (c components)
116 (do ((block (block-next (component-head c)) (block-next block)))
117 ((null (block-next block)))
118 (check-block-consistency block)))
120 (maphash (lambda (k v)
122 (unless (or (constant-p v)
123 (and (global-var-p v)
124 (member (global-var-kind v)
125 '(:global :special))))
126 (barf "strange *FREE-VARS* entry: ~S" v))
127 (dolist (n (leaf-refs v))
128 (check-node-reached n))
129 (when (basic-var-p v)
130 (dolist (n (basic-var-sets v))
131 (check-node-reached n))))
134 (maphash (lambda (k v)
136 (unless (constant-p v)
137 (barf "strange *CONSTANTS* entry: ~S" v))
138 (dolist (n (leaf-refs v))
139 (check-node-reached n)))
142 (maphash (lambda (k v)
144 (unless (or (functional-p v)
145 (and (global-var-p v)
146 (eq (global-var-kind v) :global-function)))
147 (barf "strange *FREE-FUNS* entry: ~S" v))
148 (dolist (n (leaf-refs v))
149 (check-node-reached n)))
151 (clrhash *seen-funs*)
152 (clrhash *seen-blocks*)
155 ;;;; function consistency checking
157 (defun observe-functional (x)
158 (declare (type functional x))
159 (when (gethash x *seen-funs*)
160 (barf "~S was seen more than once." x))
161 (unless (eq (functional-kind x) :deleted)
162 (setf (gethash x *seen-funs*) t)))
164 ;;; Check that the specified function has been seen.
165 (defun check-fun-reached (fun where)
166 (declare (type functional fun))
167 (unless (gethash fun *seen-funs*)
168 (barf "unseen function ~S in ~S" fun where)))
170 ;;; In a CLAMBDA, check that the associated nodes are in seen blocks.
171 ;;; In an OPTIONAL-DISPATCH, check that the entry points were seen. If
172 ;;; the function is deleted, ignore it.
173 (defun check-fun-stuff (functional)
174 (ecase (functional-kind functional)
176 (let ((fun (functional-entry-fun functional)))
177 (check-fun-reached fun functional)
178 (when (functional-kind fun)
179 (barf "The function for XEP ~S has kind." functional))
180 (unless (eq (functional-entry-fun fun) functional)
181 (barf "bad back-pointer in function for XEP ~S" functional))))
182 ((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P
183 (check-fun-reached (lambda-home functional) functional)
184 (when (functional-entry-fun functional)
185 (barf "The LET ~S has entry function." functional))
186 (unless (member functional (lambda-lets (lambda-home functional)))
187 (barf "The LET ~S is not in LETs for HOME." functional))
188 (unless (eq (functional-kind functional) :assignment)
189 (when (rest (leaf-refs functional))
190 (barf "The LET ~S has multiple references." functional)))
191 (when (lambda-lets functional)
192 (barf "LETs in a LET: ~S" functional)))
194 (when (functional-entry-fun functional)
195 (barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
196 (let ((ef (lambda-optional-dispatch functional)))
197 (check-fun-reached ef functional)
198 (unless (or (member functional (optional-dispatch-entry-points ef))
199 (eq functional (optional-dispatch-more-entry ef))
200 (eq functional (optional-dispatch-main-entry ef)))
201 (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
204 (unless (eq (functional-entry-fun functional) functional)
205 (barf "The ENTRY-FUN in ~S isn't a self-pointer." functional)))
206 ((nil :escape :cleanup)
207 (let ((ef (functional-entry-fun functional)))
209 (check-fun-reached ef functional)
210 (unless (eq (functional-kind ef) :external)
211 (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
213 (return-from check-fun-stuff)))
215 (case (functional-kind functional)
216 ((nil :optional :external :toplevel :escape :cleanup)
217 (when (lambda-p functional)
218 (dolist (fun (lambda-lets functional))
219 (unless (eq (lambda-home fun) functional)
220 (barf "The home in ~S is not ~S." fun functional))
221 (check-fun-reached fun functional))
222 (unless (eq (lambda-home functional) functional)
223 (barf "home not self-pointer in ~S" functional)))))
225 (etypecase functional
227 (when (lambda-bind functional)
228 (check-node-reached (lambda-bind functional)))
229 (when (lambda-return functional)
230 (check-node-reached (lambda-return functional)))
232 (dolist (var (lambda-vars functional))
233 (dolist (ref (leaf-refs var))
234 (check-node-reached ref))
235 (dolist (set (basic-var-sets var))
236 (check-node-reached set))
237 (unless (eq (lambda-var-home var) functional)
238 (barf "HOME in ~S should be ~S." var functional))))
240 (dolist (ep (optional-dispatch-entry-points functional))
241 (check-fun-reached ep functional))
242 (let ((more (optional-dispatch-more-entry functional)))
243 (when more (check-fun-reached more functional)))
244 (check-fun-reached (optional-dispatch-main-entry functional)
247 (defun check-fun-consistency (components)
248 (dolist (c components)
249 (dolist (new-fun (component-new-functionals c))
250 (observe-functional new-fun))
251 (dolist (fun (component-lambdas c))
252 (when (eq (functional-kind fun) :external)
253 (let ((ef (functional-entry-fun fun)))
254 (when (optional-dispatch-p ef)
255 (observe-functional ef))))
256 (observe-functional fun)
257 (dolist (let (lambda-lets fun))
258 (observe-functional let))))
260 (dolist (c components)
261 (dolist (new-fun (component-new-functionals c))
262 (check-fun-stuff new-fun))
263 (dolist (fun (component-lambdas c))
264 (when (eq (functional-kind fun) :deleted)
265 (barf "deleted lambda ~S in Lambdas for ~S" fun c))
266 (check-fun-stuff fun)
267 (dolist (let (lambda-lets fun))
268 (check-fun-stuff let)))))
270 ;;;; loop consistency checking
273 ;;; Descend through the loop nesting and check that the tree is well-formed
274 ;;; and that all blocks in the loops are known blocks. We also mark each block
275 ;;; that we see so that we can do a check later to detect blocks that weren't
277 (declaim (ftype (function (loop (or loop null)) (values)) check-loop-consistency))
278 (defun check-loop-consistency (loop superior)
279 (unless (eq (loop-superior loop) superior)
280 (barf "wrong superior in ~S, should be ~S" loop superior))
282 (/= (loop-depth loop) (1+ (loop-depth superior))))
283 (barf "wrong depth in ~S" loop))
285 (dolist (tail (loop-tail loop))
286 (check-loop-block tail loop))
287 (dolist (exit (loop-exits loop))
288 (check-loop-block exit loop))
289 (check-loop-block (loop-head loop) loop)
290 (unless (eq (block-loop (loop-head loop)) loop)
291 (barf "The head of ~S is not directly in the loop." loop))
293 (do ((block (loop-blocks loop) (block-loop-next block)))
295 (setf (block-flag block) t)
296 (unless (gethash block *seen-blocks*)
297 (barf "unseen block ~S in Blocks for ~S" block loop))
298 (unless (eq (block-loop block) loop)
299 (barf "wrong loop in ~S, should be ~S" block loop)))
301 (dolist (inferior (loop-inferiors loop))
302 (check-loop-consistency inferior loop))
305 ;;; Check that Block is either in Loop or an inferior.
306 (declaim (ftype (function (block loop) (values)) check-loop-block))
307 (defun check-loop-block (block loop)
308 (unless (gethash block *seen-blocks*)
309 (barf "unseen block ~S in loop info for ~S" block loop))
311 (if (eq (block-loop block) l)
313 (dolist (inferior (loop-inferiors l) nil)
314 (when (walk inferior) (return t))))))
316 (barf "~S is in loop info for ~S but not in the loop." block loop)))
321 ;;; Check a block for consistency at the general flow-graph level, and
322 ;;; call CHECK-NODE-CONSISTENCY on each node to locally check for
323 ;;; semantic consistency.
324 (declaim (ftype (function (cblock) (values)) check-block-consistency))
325 (defun check-block-consistency (block)
327 (dolist (pred (block-pred block))
328 (unless (gethash pred *seen-blocks*)
329 (barf "unseen predecessor ~S in ~S" pred block))
330 (unless (member block (block-succ pred))
331 (barf "bad predecessor link ~S in ~S" pred block)))
333 (let* ((fun (block-home-lambda block))
334 (fun-deleted (eq (functional-kind fun) :deleted))
335 (this-ctran (block-start block))
336 (last (block-last block)))
338 (check-fun-reached fun block))
339 (when (not this-ctran)
340 (barf "~S has no START." block))
342 (barf "~S has no LAST." block))
343 (unless (eq (ctran-kind this-ctran) :block-start)
344 (barf "The START of ~S has the wrong kind." block))
346 (when (ctran-use this-ctran)
347 (barf "The ctran ~S is used." this-ctran))
349 (when (node-next last)
350 (barf "Last node ~S of ~S has next ctran." last block))
353 (unless (eq (ctran-block this-ctran) block)
354 (barf "BLOCK of ~S should be ~S." this-ctran block))
356 (let ((node (ctran-next this-ctran)))
357 (unless (node-p node)
358 (barf "~S has strange NEXT." this-ctran))
359 (unless (eq (node-prev node) this-ctran)
360 (barf "PREV in ~S should be ~S." node this-ctran))
362 (when (valued-node-p node)
363 (binding* ((lvar (node-lvar node) :exit-if-null))
364 (unless (memq node (find-uses lvar))
365 (barf "~S is not used by its LVAR ~S." node lvar))
366 (when (singleton-p (lvar-uses lvar))
367 (barf "~S has exactly 1 use, but LVAR-USES is a list."
369 (unless (lvar-dest lvar)
370 (barf "~S does not have dest." lvar))))
372 (check-node-reached node)
374 (check-node-consistency node))
376 (let ((next (node-next node)))
377 (when (and (not next) (not (eq node last)))
378 (barf "~S has no NEXT." node))
379 (when (eq node last) (return))
380 (unless (eq (ctran-kind next) :inside-block)
381 (barf "The interior ctran ~S in ~S has the wrong kind."
384 (unless (ctran-next next)
385 (barf "~S has no NEXT." next))
386 (unless (eq (ctran-use next) node)
387 (barf "USE in ~S should be ~S." next node))
388 (setq this-ctran next))))
390 (check-block-successors block))
393 ;;; Check that BLOCK is properly terminated. Each successor must be
394 ;;; accounted for by the type of the last node.
395 (declaim (ftype (function (cblock) (values)) check-block-successors))
396 (defun check-block-successors (block)
397 (let ((last (block-last block))
398 (succ (block-succ block)))
400 (let* ((comp (block-component block)))
402 (unless (gethash b *seen-blocks*)
403 (barf "unseen successor ~S in ~S" b block))
404 (unless (member block (block-pred b))
405 (barf "bad successor link ~S in ~S" b block))
406 (unless (eq (block-component b) comp)
407 (barf "The successor ~S in ~S is in a different component."
413 (unless (proper-list-of-length-p succ 1 2)
414 (barf "~S ends in an IF, but doesn't have one or two succesors."
416 (unless (member (if-consequent last) succ)
417 (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
418 (unless (member (if-alternative last) succ)
419 (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
421 (unless (if (eq (functional-kind (return-lambda last)) :deleted)
423 (and (= (length succ) 1)
425 (component-tail (block-component block)))))
426 (barf "strange successors for RETURN in ~S" block)))
428 (unless (proper-list-of-length-p succ 0 1)
429 (barf "EXIT node with strange number of successors: ~S" last)))
431 (unless (or (= (length succ) 1) (node-tail-p last)
432 (and (block-delete-p block) (null succ)))
433 (barf "~S ends in normal node, but doesn't have one successor."
437 ;;;; node consistency checking
439 ;;; Check that the DEST for LVAR is the specified NODE. We also mark
440 ;;; the block LVAR is in as SEEN.
441 #+nil(declaim (ftype (function (lvar node) (values)) check-dest))
442 (defun check-dest (lvar node)
444 (unless (gethash (node-block use) *seen-blocks*)
445 (barf "Node ~S using ~S is in an unknown block." use lvar)))
446 (unless (eq (lvar-dest lvar) node)
447 (barf "DEST for ~S should be ~S." lvar node))
448 (unless (find-uses lvar)
449 (barf "Lvar ~S has a destinatin, but no uses."
453 ;;; This function deals with checking for consistency of the
454 ;;; type-dependent information in a node.
455 (defun check-node-consistency (node)
456 (declare (type node node))
459 (let ((leaf (ref-leaf node)))
460 (when (functional-p leaf)
461 (if (eq (functional-kind leaf) :toplevel-xep)
462 (unless (eq (component-kind (block-component (node-block node)))
464 (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
466 (check-fun-reached leaf node)))))
468 (check-dest (basic-combination-fun node) node)
469 (dolist (arg (basic-combination-args node))
471 (arg (check-dest arg node))
472 ((not (and (eq (basic-combination-kind node) :local)
473 (combination-p node)))
474 (barf "flushed arg not in local call: ~S" node))
477 ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
478 ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
479 ;; POSITION. It compiles it correctly, but it issues a type
480 ;; mismatch warning because it can't eliminate the
481 ;; possibility that control will flow through the
482 ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
483 (declare (notinline position))
484 (let ((fun (ref-leaf (lvar-use
485 (basic-combination-fun node))))
486 (pos (position arg (basic-combination-args node))))
487 (declare (type index pos))
488 (when (leaf-refs (elt (lambda-vars fun) pos))
489 (barf "flushed arg for referenced var in ~S" node)))))))
490 (let* ((lvar (node-lvar node))
491 (dest (and lvar (lvar-dest lvar))))
492 (when (and (return-p dest)
493 (eq (basic-combination-kind node) :local)
494 (not (eq (lambda-tail-set (combination-lambda node))
495 (lambda-tail-set (return-lambda dest)))))
496 (barf "tail local call to function with different tail set:~% ~S"
499 (check-dest (if-test node) node)
500 (unless (eq (block-last (node-block node)) node)
501 (barf "IF not at block end: ~S" node)))
503 (check-dest (set-value node) node))
505 (check-dest (cast-value node) node))
507 (check-fun-reached (bind-lambda node) node))
509 (check-fun-reached (return-lambda node) node)
510 (check-dest (return-result node) node)
511 (unless (eq (block-last (node-block node)) node)
512 (barf "RETURN not at block end: ~S" node)))
514 (unless (member node (lambda-entries (node-home-lambda node)))
515 (barf "~S is not in ENTRIES for its home LAMBDA." node))
516 (dolist (exit (entry-exits node))
517 (unless (node-deleted exit)
518 (check-node-reached node))))
520 (let ((entry (exit-entry node))
521 (value (exit-value node)))
523 (check-node-reached entry)
524 (unless (member node (entry-exits entry))
525 (barf "~S is not in its ENTRY's EXITS." node))
527 (check-dest value node)))
530 (barf "~S has VALUE but no ENTRY." node)))))))
534 ;;;; IR2 consistency checking
536 ;;; Check for some kind of consistency in some REFs linked together by
537 ;;; TN-REF-ACROSS. VOP is the VOP that the references are in. WRITE-P
538 ;;; is the value of WRITE-P that should be present. COUNT is the
539 ;;; minimum number of operands expected. If MORE-P is true, then any
540 ;;; larger number will also be accepted. WHAT is a string describing
541 ;;; the kind of operand in error messages.
542 (defun check-tn-refs (refs vop write-p count more-p what)
543 (let ((vop-refs (vop-refs vop)))
544 (do ((ref refs (tn-ref-across ref))
548 (barf "There should be at least ~W ~A in ~S, but there are only ~W."
550 (when (and (not more-p) (> num count))
551 (barf "There should be ~W ~A in ~S, but are ~W."
552 count what vop num)))
553 (unless (eq (tn-ref-vop ref) vop)
554 (barf "VOP is ~S isn't ~S." ref vop))
555 (unless (eq (tn-ref-write-p ref) write-p)
556 (barf "The WRITE-P in ~S isn't ~S." vop write-p))
557 (unless (find-in #'tn-ref-next-ref ref vop-refs)
558 (barf "~S not found in REFS for ~S" ref vop))
559 (unless (find-in #'tn-ref-next ref
560 (if (tn-ref-write-p ref)
561 (tn-writes (tn-ref-tn ref))
562 (tn-reads (tn-ref-tn ref))))
563 (barf "~S not found in reads/writes for its TN" ref))
565 (let ((target (tn-ref-target ref)))
567 (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
568 (barf "The target for ~S isn't complementary WRITE-P." ref))
569 (unless (find-in #'tn-ref-next-ref target vop-refs)
570 (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
572 ;;; Verify the sanity of the VOP-REFS slot in VOP. This involves checking
573 ;;; that each referenced TN appears as an argument, result or temp, and also
574 ;;; basic checks for the plausibility of the specified ordering of the refs.
575 (defun check-vop-refs (vop)
576 (declare (type vop vop))
577 (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
580 ((find-in #'tn-ref-across ref (vop-args vop)))
581 ((find-in #'tn-ref-across ref (vop-results vop)))
582 ((not (eq (tn-ref-vop ref) vop))
583 (barf "VOP in ~S isn't ~S." ref vop))
584 ((find-in #'tn-ref-across ref (vop-temps vop)))
585 ((tn-ref-write-p ref)
586 (barf "stray ref that isn't a READ: ~S" ref))
588 (let* ((tn (tn-ref-tn ref))
589 (temp (find-in #'tn-ref-across tn (vop-temps vop)
592 (barf "stray ref with no corresponding temp write: ~S" ref))
593 (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
594 (barf "Read is after write for temp ~S in refs of ~S."
598 ;;; Check the basic sanity of the VOP linkage, then call some other
599 ;;; functions to check on the TN-REFS. We grab some info out of the
600 ;;; VOP-INFO to tell us what to expect.
602 ;;; [### Check that operand type restrictions are met?]
603 (defun check-ir2-block-consistency (2block)
604 (declare (type ir2-block 2block))
605 (do ((vop (ir2-block-start-vop 2block)
609 (unless (eq prev (ir2-block-last-vop 2block))
610 (barf "The last VOP in ~S should be ~S." 2block prev)))
611 (unless (eq (vop-prev vop) prev)
612 (barf "PREV in ~S should be ~S." vop prev))
614 (unless (eq (vop-block vop) 2block)
615 (barf "BLOCK in ~S should be ~S." vop 2block))
619 (let* ((info (vop-info vop))
620 (atypes (template-arg-types info))
621 (rtypes (template-result-types info)))
622 (check-tn-refs (vop-args vop) vop nil
623 (count-if-not (lambda (x)
625 (eq (car x) :constant)))
627 (template-more-args-type info) "args")
628 (check-tn-refs (vop-results vop) vop t
629 (if (eq rtypes :conditional) 0 (length rtypes))
630 (template-more-results-type info) "results")
631 (check-tn-refs (vop-temps vop) vop t 0 t "temps")
632 (unless (= (length (vop-codegen-info vop))
633 (template-info-arg-count info))
634 (barf "wrong number of codegen info args in ~S" vop))))
637 ;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
638 ;;; sanity of the basic flow graph.
640 ;;; [### Also grovel global TN data structures? Assume pack not
641 ;;; done yet? Have separate CHECK-TN-CONSISTENCY for pre-pack and
642 ;;; CHECK-PACK-CONSISTENCY for post-pack?]
643 (defun check-ir2-consistency (component)
644 (declare (type component component))
645 (do-ir2-blocks (block component)
646 (check-ir2-block-consistency block))
649 ;;;; lifetime analysis checking
651 ;;; Dump some info about how many TNs there, and what the conflicts data
652 ;;; structures are like.
653 (defun pre-pack-tn-stats (component &optional (stream *error-output*))
654 (declare (type component component))
664 (do-packed-tns (tn component)
665 (let ((reads (tn-reads tn))
666 (writes (tn-writes tn)))
667 (when (and reads writes
668 (not (tn-ref-next reads)) (not (tn-ref-next writes))
669 (eq (tn-ref-vop reads) (tn-ref-vop writes)))
673 (unless (or (tn-reads tn) (tn-writes tn))
675 (cond ((eq (tn-kind tn) :component)
677 ((tn-global-conflicts tn)
679 ((:environment :debug-environment) (incf environment))
681 (do ((conf (tn-global-conflicts tn)
682 (global-conflicts-next-tnwise conf)))
688 (do ((tn (ir2-component-constant-tns (component-info component))
694 "~%TNs: ~W local, ~W temps, ~W constant, ~W env, ~W comp, ~W global.~@
695 Wired: ~W, Unused: ~W. ~W block~:P, ~W global conflict~:P.~%"
696 local temps const environment comp global wired unused
697 (ir2-block-count component)
701 ;;; If the entry in Local-TNs for TN in BLOCK is :MORE, then do some checks
702 ;;; for the validity of the usage.
703 (defun check-more-tn-entry (tn block)
704 (let* ((vop (ir2-block-start-vop block))
705 (info (vop-info vop)))
706 (macrolet ((frob (more-p ops)
708 (find-in #'tn-ref-across tn (,ops vop)
710 (unless (and (eq vop (ir2-block-last-vop block))
711 (or (frob template-more-args-type vop-args)
712 (frob template-more-results-type vop-results)))
713 (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
716 (defun check-tn-conflicts (component)
717 (do-packed-tns (tn component)
718 (unless (or (not (eq (tn-kind tn) :normal))
721 (barf "no references to ~S" tn))
723 (unless (tn-sc tn) (barf "~S has no SC." tn))
725 (let ((conf (tn-global-conflicts tn))
728 ((eq kind :component)
729 (unless (member tn (ir2-component-component-tns
730 (component-info component)))
731 (barf "~S not in COMPONENT-TNs for ~S" tn component)))
733 (do ((conf conf (global-conflicts-next-tnwise conf))
736 (unless (eq (global-conflicts-tn conf) tn)
737 (barf "TN in ~S should be ~S." conf tn))
739 (unless (eq (global-conflicts-kind conf) :live)
740 (let* ((block (global-conflicts-block conf))
741 (ltn (svref (ir2-block-local-tns block)
742 (global-conflicts-number conf))))
744 ((eq ltn :more) (check-more-tn-entry tn block))
746 (barf "~S wrong in LTN map for ~S" conf tn)))))
749 (unless (> (ir2-block-number (global-conflicts-block conf))
750 (ir2-block-number (global-conflicts-block prev)))
751 (barf "~s and ~s out of order" prev conf)))))
752 ((member (tn-kind tn) '(:constant :specified-save)))
754 (let ((local (tn-local tn)))
756 (barf "~S has no global conflicts, but isn't local either." tn))
757 (unless (eq (svref (ir2-block-local-tns local)
758 (tn-local-number tn))
760 (barf "~S wrong in LTN map" tn))
761 (do ((ref (tn-reads tn) (tn-ref-next ref)))
763 (unless (eq (vop-block (tn-ref-vop ref)) local)
764 (barf "~S has references in blocks other than its LOCAL block."
766 (do ((ref (tn-writes tn) (tn-ref-next ref)))
768 (unless (eq (vop-block (tn-ref-vop ref)) local)
769 (barf "~S has references in blocks other than its LOCAL block."
773 (defun check-block-conflicts (component)
774 (do-ir2-blocks (block component)
775 (do ((conf (ir2-block-global-tns block)
776 (global-conflicts-next-blockwise conf))
780 (unless (> (tn-number (global-conflicts-tn conf))
781 (tn-number (global-conflicts-tn prev)))
782 (barf "~S and ~S out of order in ~S" prev conf block)))
784 (unless (find-in #'global-conflicts-next-tnwise
787 (global-conflicts-tn conf)))
788 (barf "~S missing from global conflicts of its TN" conf)))
790 (let ((map (ir2-block-local-tns block)))
791 (dotimes (i (ir2-block-local-tn-count block))
792 (let ((tn (svref map i)))
793 (unless (or (eq tn :more)
795 (tn-global-conflicts tn)
796 (eq (tn-local tn) block))
797 (barf "strange TN ~S in LTN map for ~S" tn block)))))))
799 ;;; All TNs live at the beginning of an environment must be passing
800 ;;; locations associated with that environment. We make an exception
801 ;;; for wired TNs in XEP functions, since we randomly reference wired
802 ;;; TNs to access the full call passing locations.
803 (defun check-environment-lifetimes (component)
804 (dolist (fun (component-lambdas component))
805 (let* ((env (lambda-physenv fun))
806 (2env (physenv-info env))
807 (vars (lambda-vars fun))
808 (closure (ir2-physenv-closure 2env))
809 (pc (ir2-physenv-return-pc-pass 2env))
810 (fp (ir2-physenv-old-fp 2env))
811 (2block (block-info (lambda-block (physenv-lambda env)))))
812 (do ((conf (ir2-block-global-tns 2block)
813 (global-conflicts-next-blockwise conf)))
815 (let ((tn (global-conflicts-tn conf)))
816 (unless (or (eq (global-conflicts-kind conf) :write)
819 (and (xep-p fun) (tn-offset tn))
820 (member (tn-kind tn) '(:environment :debug-environment))
821 (member tn vars :key #'leaf-info)
822 (member tn closure :key #'cdr))
823 (barf "strange TN live at head of ~S: ~S" env tn))))))
826 ;;; Check for some basic sanity in the TN conflict data structures,
827 ;;; and also check that no TNs are unexpectedly live at environment
829 (defun check-life-consistency (component)
830 (check-tn-conflicts component)
831 (check-block-conflicts component)
832 (check-environment-lifetimes component))
834 ;;;; pack consistency checking
836 (defun check-pack-consistency (component)
837 (flet ((check (scs ops)
838 (do ((scs scs (cdr scs))
839 (op ops (tn-ref-across op)))
841 (let ((load-tn (tn-ref-load-tn op)))
842 (unless (eq (svref (car scs)
845 (or load-tn (tn-ref-tn op)))))
847 (barf "operand restriction not satisfied: ~S" op))))))
848 (do-ir2-blocks (block component)
849 (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
851 (let ((info (vop-info vop)))
852 (check (vop-info-result-load-scs info) (vop-results vop))
853 (check (vop-info-arg-load-scs info) (vop-args vop))))))
856 ;;;; data structure dumping routines
858 ;;; When we print CONTINUATIONs and TNs, we assign them small numeric
859 ;;; IDs so that we can get a handle on anonymous objects given a
863 ;;; * Perhaps this machinery should be #!+SB-SHOW.
864 ;;; * Probably the hash tables should either be weak hash tables,
865 ;;; or only allocated within a single compilation unit. Otherwise
866 ;;; there will be a tendency for them to grow without bound and
867 ;;; keep garbage from being collected.
868 (macrolet ((def (counter vto vfrom fto ffrom)
870 (declaim (type hash-table ,vto ,vfrom))
871 (defvar ,vto (make-hash-table :test 'eq))
872 (defvar ,vfrom (make-hash-table :test 'eql))
873 (declaim (type fixnum ,counter))
878 (let ((num (incf ,counter)))
879 (setf (gethash num ,vfrom) x)
880 (setf (gethash x ,vto) num))))
883 (values (gethash num ,vfrom))))))
884 (def *continuation-number* *continuation-numbers* *number-continuations*
886 (def *tn-id* *tn-ids* *id-tns* tn-id id-tn)
887 (def *label-id* *id-labels* *label-ids* label-id id-label))
889 ;;; Print a terse one-line description of LEAF.
890 (defun print-leaf (leaf &optional (stream *standard-output*))
891 (declare (type leaf leaf) (type stream stream))
893 (lambda-var (prin1 (leaf-debug-name leaf) stream))
894 (constant (format stream "'~S" (constant-value leaf)))
896 (format stream "~S {~A}" (leaf-debug-name leaf) (global-var-kind leaf)))
898 (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf)))))
900 ;;; Attempt to find a block given some thing that has to do with it.
901 (declaim (ftype (sfunction (t) cblock) block-or-lose))
902 (defun block-or-lose (thing)
905 (ir2-block (ir2-block-block thing))
906 (vop (block-or-lose (vop-block thing)))
907 (tn-ref (block-or-lose (tn-ref-vop thing)))
908 (ctran (ctran-block thing))
909 (node (node-block thing))
910 (component (component-head thing))
911 #| (cloop (loop-head thing))|#
912 (integer (ctran-block (num-cont thing)))
913 (functional (lambda-block (main-entry thing)))
914 (null (error "Bad thing: ~S." thing))
915 (symbol (block-or-lose (gethash thing *free-funs*)))))
918 (defun print-continuation (cont)
919 (declare (type continuation cont))
920 (format t " c~D" (cont-num cont))
923 (defun print-ctran (cont)
924 (declare (type ctran cont))
925 (format t "c~D " (cont-num cont))
927 (defun print-lvar (cont)
928 (declare (type lvar cont))
929 (format t "v~D " (cont-num cont))
932 ;;; Print out the nodes in BLOCK in a format oriented toward
933 ;;; representing what the code does.
934 (defun print-nodes (block)
935 (setq block (block-or-lose block))
936 (pprint-logical-block (nil nil)
937 (format t "~:@_IR1 block ~D start c~D"
938 (block-number block) (cont-num (block-start block)))
939 (when (block-delete-p block)
940 (format t " <deleted>"))
942 (pprint-newline :mandatory)
943 (do ((ctran (block-start block) (node-next (ctran-next ctran))))
945 (let ((node (ctran-next ctran)))
946 (format t "~:[ ~;~:*~3D:~] "
947 (when (and (valued-node-p node) (node-lvar node))
948 (cont-num (node-lvar node))))
950 (ref (print-leaf (ref-leaf node)))
952 (let ((kind (basic-combination-kind node)))
953 (format t "~(~A~A ~A~) "
954 (if (node-tail-p node) "tail " "")
955 (if (fun-info-p kind) "known" kind)
957 (print-lvar (basic-combination-fun node))
958 (dolist (arg (basic-combination-args node))
961 (format t "<none> ")))))
963 (write-string "set ")
964 (print-leaf (set-var node))
966 (print-lvar (set-value node)))
969 (print-lvar (if-test node))
970 (print-ctran (block-start (if-consequent node)))
971 (print-ctran (block-start (if-alternative node))))
973 (write-string "bind ")
974 (print-leaf (bind-lambda node))
975 (when (functional-kind (bind-lambda node))
976 (format t " ~S ~S" :kind (functional-kind (bind-lambda node)))))
978 (write-string "return ")
979 (print-lvar (return-result node))
980 (print-leaf (return-lambda node)))
982 (format t "entry ~S" (entry-exits node)))
984 (let ((value (exit-value node)))
989 (format t "exit <no value>"))
991 (format t "exit <degenerate>")))))
993 (let ((value (cast-value node)))
994 (format t "cast v~D ~A[~S -> ~S]" (cont-num value)
995 (if (cast-%type-check node) #\+ #\-)
996 (cast-type-to-check node)
997 (cast-asserted-type node)))))
998 (pprint-newline :mandatory)))
1000 (let ((succ (block-succ block)))
1001 (format t "successors~{ c~D~}~%"
1002 (mapcar (lambda (x) (cont-num (block-start x))) succ))))
1005 ;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T)
1006 ;;; and printers for compound objects which contain TNs)
1007 (defun print-tn-guts (tn &optional (stream *standard-output*))
1008 (declare (type tn tn))
1009 (let ((leaf (tn-leaf tn)))
1011 (print-leaf leaf stream)
1012 (format stream "!~D" (tn-id tn)))
1014 (format stream "t~D" (tn-id tn))))
1015 (when (and (tn-sc tn) (tn-offset tn))
1016 (format stream "[~A]" (location-print-name tn)))))
1018 ;;; Print the TN-REFs representing some operands to a VOP, linked by
1020 (defun print-operands (refs)
1021 (declare (type (or tn-ref null) refs))
1022 (pprint-logical-block (*standard-output* nil)
1023 (do ((ref refs (tn-ref-across ref)))
1025 (let ((tn (tn-ref-tn ref))
1026 (ltn (tn-ref-load-tn ref)))
1031 (princ (if (tn-ref-write-p ref) #\< #\>))
1032 (print-tn-guts ltn)))
1034 (pprint-newline :fill)))))
1036 ;;; Print the VOP, putting args, info and results on separate lines, if
1038 (defun print-vop (vop)
1039 (pprint-logical-block (*standard-output* nil)
1040 (princ (vop-info-name (vop-info vop)))
1042 (pprint-indent :current 0)
1043 (print-operands (vop-args vop))
1044 (pprint-newline :linear)
1045 (when (vop-codegen-info vop)
1046 (princ (with-output-to-string (stream)
1047 (let ((*print-level* 1)
1049 (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
1050 (pprint-newline :linear))
1051 (when (vop-results vop)
1053 (print-operands (vop-results vop))))
1054 (pprint-newline :mandatory))
1056 ;;; Print the VOPs in the specified IR2 block.
1057 (defun print-ir2-block (block)
1058 (declare (type ir2-block block))
1059 (pprint-logical-block (*standard-output* nil)
1061 ((eq (block-info (ir2-block-block block)) block)
1062 (format t "~:@_IR2 block ~D start c~D~:@_"
1063 (ir2-block-number block)
1064 (cont-num (block-start (ir2-block-block block))))
1065 (let ((label (ir2-block-%label block)))
1067 (format t "L~D:~:@_" (label-id label)))))
1069 (format t "<overflow>~:@_")))
1071 (do ((vop (ir2-block-start-vop block)
1073 (number 0 (1+ number)))
1075 (format t "~W: " number)
1078 ;;; This is like PRINT-NODES, but dumps the IR2 representation of the
1080 (defun print-vops (block)
1081 (setq block (block-or-lose block))
1082 (let ((2block (block-info block)))
1083 (print-ir2-block 2block)
1084 (do ((b (ir2-block-next 2block) (ir2-block-next b)))
1085 ((not (eq (ir2-block-block b) block)))
1086 (print-ir2-block b)))
1089 ;;; Scan the IR2 blocks in emission order.
1090 (defun print-ir2-blocks (thing &optional full)
1091 (let* ((block (component-head (block-component (block-or-lose thing))))
1092 (2block (block-info block)))
1093 (pprint-logical-block (nil nil)
1095 do (setq block (ir2-block-block 2block))
1096 do (pprint-logical-block (*standard-output* nil)
1099 (format t "IR1 block ~D start c~D"
1100 (block-number block)
1101 (cont-num (block-start block))))
1102 (pprint-indent :block 4)
1103 (pprint-newline :mandatory)
1104 (loop while (and 2block (eq (ir2-block-block 2block) block))
1105 do (print-ir2-block 2block)
1106 do (setq 2block (ir2-block-next 2block))))
1107 do (pprint-newline :mandatory))))
1110 ;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by
1111 ;;; successor links.
1112 (defun print-blocks (block)
1113 (setq block (block-or-lose block))
1114 (do-blocks (block (block-component block) :both)
1115 (setf (block-flag block) nil))
1116 (labels ((walk (block)
1117 (unless (block-flag block)
1118 (setf (block-flag block) t)
1119 (when (block-start block)
1120 (print-nodes block))
1121 (dolist (block (block-succ block))
1126 ;;; Print all blocks in BLOCK's component in DFO.
1127 (defun print-all-blocks (thing)
1128 (do-blocks (block (block-component (block-or-lose thing)))
1129 (handler-case (print-nodes block)
1131 (format t "~&~A...~%" condition))))
1134 (defvar *list-conflicts-table* (make-hash-table :test 'eq))
1136 ;;; Add all ALWAYS-LIVE TNs in BLOCK to the conflicts. TN is ignored
1137 ;;; when it appears in the global conflicts.
1138 (defun add-always-live-tns (block tn)
1139 (declare (type ir2-block block) (type tn tn))
1140 (do ((conf (ir2-block-global-tns block)
1141 (global-conflicts-next-blockwise conf)))
1143 (when (eq (global-conflicts-kind conf) :live)
1144 (let ((btn (global-conflicts-tn conf)))
1146 (setf (gethash btn *list-conflicts-table*) t)))))
1149 ;;; Add all local TNs in BLOCK to the conflicts.
1150 (defun add-all-local-tns (block)
1151 (declare (type ir2-block block))
1152 (let ((ltns (ir2-block-local-tns block)))
1153 (dotimes (i (ir2-block-local-tn-count block))
1154 (setf (gethash (svref ltns i) *list-conflicts-table*) t)))
1157 ;;; Make a list out of all of the recorded conflicts.
1158 (defun listify-conflicts-table ()
1160 (maphash (lambda (k v)
1161 (declare (ignore v))
1164 *list-conflicts-table*)
1165 (clrhash *list-conflicts-table*)
1168 ;;; Return a list of a the TNs that conflict with TN. Sort of, kind
1169 ;;; of. For debugging use only. Probably doesn't work on :COMPONENT TNs.
1170 (defun list-conflicts (tn)
1171 (aver (member (tn-kind tn) '(:normal :environment :debug-environment)))
1172 (let ((confs (tn-global-conflicts tn)))
1174 (clrhash *list-conflicts-table*)
1175 (do ((conf confs (global-conflicts-next-tnwise conf)))
1177 (format t "~&#<block ~D kind ~S>~%"
1178 (block-number (ir2-block-block (global-conflicts-block
1180 (global-conflicts-kind conf))
1181 (let ((block (global-conflicts-block conf)))
1182 (add-always-live-tns block tn)
1183 (if (eq (global-conflicts-kind conf) :live)
1184 (add-all-local-tns block)
1185 (let ((bconf (global-conflicts-conflicts conf))
1186 (ltns (ir2-block-local-tns block)))
1187 (dotimes (i (ir2-block-local-tn-count block))
1188 (when (/= (sbit bconf i) 0)
1189 (setf (gethash (svref ltns i) *list-conflicts-table*)
1191 (listify-conflicts-table))
1193 (let* ((block (tn-local tn))
1194 (ltns (ir2-block-local-tns block))
1195 (confs (tn-local-conflicts tn)))
1197 (dotimes (i (ir2-block-local-tn-count block))
1198 (when (/= (sbit confs i) 0)
1199 (let ((tn (svref ltns i)))
1200 (when (and tn (not (eq tn :more))
1201 (not (tn-global-conflicts tn)))
1203 (do ((gtn (ir2-block-global-tns block)
1204 (global-conflicts-next-blockwise gtn)))
1206 (when (or (eq (global-conflicts-kind gtn) :live)
1207 (/= (sbit confs (global-conflicts-number gtn)) 0))
1208 (res (global-conflicts-tn gtn))))
1211 (defun nth-vop (thing n)
1213 "Return the Nth VOP in the IR2-BLOCK pointed to by THING."
1214 (let ((block (block-info (block-or-lose thing))))
1216 (vop (ir2-block-start-vop block) (vop-next vop)))