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. Otherwise
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 appear
53 ;;; in the DFO for one of the specified components.
54 (defvar *seen-blocks* (make-hash-table :test 'eq))
56 ;;; *Seen-Functions* is similar, but records all the lambdas we reached by
57 ;;; recursing on top-level functions.
58 (defvar *seen-functions* (make-hash-table :test 'eq))
60 ;;; Barf if Node is in a block which wasn't reached during the graph walk.
61 (declaim (ftype (function (node) (values)) check-node-reached))
62 (defun check-node-reached (node)
63 (unless (gethash (continuation-block (node-prev node)) *seen-blocks*)
64 (barf "~S was not reached." node))
67 ;;; Check everything that we can think of for consistency. When a definite
68 ;;; inconsistency is detected, we BARF. Possible problems just cause us to
69 ;;; BURP. Our argument is a list of components, but we also look at the
70 ;;; *FREE-VARIABLES*, *FREE-FUNCTIONS* and *CONSTANTS*.
72 ;;; First we do a pre-pass which finds all the blocks and lambdas, testing
73 ;;; that they are linked together properly and entering them in hashtables.
74 ;;; Next, we iterate over the blocks again, looking at the actual code and
75 ;;; control flow. Finally, we scan the global leaf hashtables, looking for
77 (declaim (ftype (function (list) (values)) check-ir1-consistency))
78 (defun check-ir1-consistency (components)
79 (clrhash *seen-blocks*)
80 (clrhash *seen-functions*)
81 (dolist (c components)
82 (let* ((head (component-head c))
83 (tail (component-tail c)))
84 (unless (and (null (block-pred head)) (null (block-succ tail)))
85 (barf "~S is malformed." c))
88 (block head (block-next block)))
90 (unless (eq prev tail)
91 (barf "wrong Tail for DFO, ~S in ~S" prev c)))
92 (setf (gethash block *seen-blocks*) t)
93 (unless (eq (block-prev block) prev)
94 (barf "bad PREV for ~S, should be ~S" block prev))
95 (unless (or (eq block tail)
96 (eq (block-component block) c))
97 (barf "~S is not in ~S." block c)))
99 (when (or (loop-blocks c) (loop-inferiors c))
100 (do-blocks (block c :both)
101 (setf (block-flag block) nil))
102 (check-loop-consistency c nil)
103 (do-blocks (block c :both)
104 (unless (block-flag block)
105 (barf "~S was not in any loop." block))))
109 (check-function-consistency components)
111 (dolist (c components)
112 (do ((block (block-next (component-head c)) (block-next block)))
113 ((null (block-next block)))
114 (check-block-consistency block)))
116 (maphash #'(lambda (k v)
118 (unless (or (constant-p v)
119 (and (global-var-p v)
120 (member (global-var-kind v)
121 '(:global :special :constant))))
122 (barf "strange *FREE-VARIABLES* entry: ~S" v))
123 (dolist (n (leaf-refs v))
124 (check-node-reached n))
125 (when (basic-var-p v)
126 (dolist (n (basic-var-sets v))
127 (check-node-reached n))))
130 (maphash #'(lambda (k v)
132 (unless (constant-p v)
133 (barf "strange *CONSTANTS* entry: ~S" v))
134 (dolist (n (leaf-refs v))
135 (check-node-reached n)))
138 (maphash #'(lambda (k v)
140 (unless (or (functional-p v)
141 (and (global-var-p v)
142 (eq (global-var-kind v) :global-function)))
143 (barf "strange *FREE-FUNCTIONS* entry: ~S" v))
144 (dolist (n (leaf-refs v))
145 (check-node-reached n)))
147 (clrhash *seen-functions*)
148 (clrhash *seen-blocks*)
151 ;;;; function consistency checking
153 (defun observe-functional (x)
154 (declare (type functional x))
155 (when (gethash x *seen-functions*)
156 (barf "~S was seen more than once." x))
157 (unless (eq (functional-kind x) :deleted)
158 (setf (gethash x *seen-functions*) t)))
160 ;;; Check that the specified function has been seen.
161 (defun check-function-reached (fun where)
162 (declare (type functional fun))
163 (unless (gethash fun *seen-functions*)
164 (barf "unseen function ~S in ~S" fun where)))
166 ;;; In a lambda, check that the associated nodes are in seen blocks. In an
167 ;;; optional dispatch, check that the entry points were seen. If the function
168 ;;; is deleted, ignore it.
169 (defun check-function-stuff (functional)
170 (ecase (functional-kind functional)
172 (let ((fun (functional-entry-function functional)))
173 (check-function-reached fun functional)
174 (when (functional-kind fun)
175 (barf "The function for XEP ~S has kind." functional))
176 (unless (eq (functional-entry-function fun) functional)
177 (barf "bad back-pointer in function for XEP ~S" functional))))
178 ((:let :mv-let :assignment)
179 (check-function-reached (lambda-home functional) functional)
180 (when (functional-entry-function functional)
181 (barf "The LET ~S has entry function." functional))
182 (unless (member functional (lambda-lets (lambda-home functional)))
183 (barf "The LET ~S is not in LETs for HOME." functional))
184 (unless (eq (functional-kind functional) :assignment)
185 (when (rest (leaf-refs functional))
186 (barf "The LET ~S has multiple references." functional)))
187 (when (lambda-lets functional)
188 (barf "LETs in a LET: ~S" functional)))
190 (when (functional-entry-function functional)
191 (barf ":OPTIONAL ~S has an ENTRY-FUNCTION." functional))
192 (let ((ef (lambda-optional-dispatch functional)))
193 (check-function-reached ef functional)
194 (unless (or (member functional (optional-dispatch-entry-points ef))
195 (eq functional (optional-dispatch-more-entry ef))
196 (eq functional (optional-dispatch-main-entry ef)))
197 (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
200 (unless (eq (functional-entry-function functional) functional)
201 (barf "The ENTRY-FUNCTION in ~S isn't a self-pointer." functional)))
202 ((nil :escape :cleanup)
203 (let ((ef (functional-entry-function functional)))
205 (check-function-reached ef functional)
206 (unless (eq (functional-kind ef) :external)
207 (barf "The ENTRY-FUNCTION in ~S isn't an XEP: ~S."
211 (return-from check-function-stuff)))
213 (case (functional-kind functional)
214 ((nil :optional :external :top-level :escape :cleanup)
215 (when (lambda-p functional)
216 (dolist (fun (lambda-lets functional))
217 (unless (eq (lambda-home fun) functional)
218 (barf "The home in ~S is not ~S." fun functional))
219 (check-function-reached fun functional))
220 (unless (eq (lambda-home functional) functional)
221 (barf "home not self-pointer in ~S" functional)))))
223 (etypecase functional
225 (when (lambda-bind functional)
226 (check-node-reached (lambda-bind functional)))
227 (when (lambda-return functional)
228 (check-node-reached (lambda-return functional)))
230 (dolist (var (lambda-vars functional))
231 (dolist (ref (leaf-refs var))
232 (check-node-reached ref))
233 (dolist (set (basic-var-sets var))
234 (check-node-reached set))
235 (unless (eq (lambda-var-home var) functional)
236 (barf "HOME in ~S should be ~S." var functional))))
238 (dolist (ep (optional-dispatch-entry-points functional))
239 (check-function-reached ep functional))
240 (let ((more (optional-dispatch-more-entry functional)))
241 (when more (check-function-reached more functional)))
242 (check-function-reached (optional-dispatch-main-entry functional)
245 (defun check-function-consistency (components)
246 (dolist (c components)
247 (dolist (fun (component-new-functions c))
248 (observe-functional fun))
249 (dolist (fun (component-lambdas c))
250 (when (eq (functional-kind fun) :external)
251 (let ((ef (functional-entry-function fun)))
252 (when (optional-dispatch-p ef)
253 (observe-functional ef))))
254 (observe-functional fun)
255 (dolist (let (lambda-lets fun))
256 (observe-functional let))))
258 (dolist (c components)
259 (dolist (fun (component-new-functions c))
260 (check-function-stuff fun))
261 (dolist (fun (component-lambdas c))
262 (when (eq (functional-kind fun) :deleted)
263 (barf "deleted lambda ~S in Lambdas for ~S" fun c))
264 (check-function-stuff fun)
265 (dolist (let (lambda-lets fun))
266 (check-function-stuff let)))))
268 ;;;; loop consistency checking
271 ;;; Descend through the loop nesting and check that the tree is well-formed
272 ;;; and that all blocks in the loops are known blocks. We also mark each block
273 ;;; that we see so that we can do a check later to detect blocks that weren't
275 (declaim (ftype (function (loop (or loop null)) (values)) check-loop-consistency))
276 (defun check-loop-consistency (loop superior)
277 (unless (eq (loop-superior loop) superior)
278 (barf "wrong superior in ~S, should be ~S" loop superior))
280 (/= (loop-depth loop) (1+ (loop-depth superior))))
281 (barf "wrong depth in ~S" loop))
283 (dolist (tail (loop-tail loop))
284 (check-loop-block tail loop))
285 (dolist (exit (loop-exits loop))
286 (check-loop-block exit loop))
287 (check-loop-block (loop-head loop) loop)
288 (unless (eq (block-loop (loop-head loop)) loop)
289 (barf "The head of ~S is not directly in the loop." loop))
291 (do ((block (loop-blocks loop) (block-loop-next block)))
293 (setf (block-flag block) t)
294 (unless (gethash block *seen-blocks*)
295 (barf "unseen block ~S in Blocks for ~S" block loop))
296 (unless (eq (block-loop block) loop)
297 (barf "wrong loop in ~S, should be ~S" block loop)))
299 (dolist (inferior (loop-inferiors loop))
300 (check-loop-consistency inferior loop))
303 ;;; Check that Block is either in Loop or an inferior.
304 (declaim (ftype (function (block loop) (values)) check-loop-block))
305 (defun check-loop-block (block loop)
306 (unless (gethash block *seen-blocks*)
307 (barf "unseen block ~S in loop info for ~S" block loop))
309 (if (eq (block-loop block) l)
311 (dolist (inferior (loop-inferiors l) nil)
312 (when (walk inferior) (return t))))))
314 (barf "~S is in loop info for ~S but not in the loop." block loop)))
319 ;;; Check a block for consistency at the general flow-graph level, and
320 ;;; call CHECK-NODE-CONSISTENCY on each node to locally check for
321 ;;; semantic consistency.
322 (declaim (ftype (function (cblock) (values)) check-block-consistency))
323 (defun check-block-consistency (block)
325 (dolist (pred (block-pred block))
326 (unless (gethash pred *seen-blocks*)
327 (barf "unseen predecessor ~S in ~S" pred block))
328 (unless (member block (block-succ pred))
329 (barf "bad predecessor link ~S in ~S" pred block)))
331 (let* ((fun (block-home-lambda block))
332 (fun-deleted (eq (functional-kind fun) :deleted))
333 (this-cont (block-start block))
334 (last (block-last block)))
336 (check-function-reached fun block))
337 (when (not this-cont)
338 (barf "~S has no START." block))
340 (barf "~S has no LAST." block))
341 (unless (eq (continuation-kind this-cont) :block-start)
342 (barf "The START of ~S has the wrong kind." block))
344 (let ((use (continuation-use this-cont))
345 (uses (block-start-uses block)))
346 (when (and (null use) (= (length uses) 1))
347 (barf "~S has a unique use, but no USE." this-cont))
349 (unless (eq (node-cont node) this-cont)
350 (barf "The USE ~S for START in ~S has wrong CONT." node block))
351 (check-node-reached node)))
353 (let* ((last-cont (node-cont last))
354 (cont-block (continuation-block last-cont))
355 (dest (continuation-dest last-cont)))
356 (ecase (continuation-kind last-cont)
358 (:deleted-block-start
359 (let ((dest (continuation-dest last-cont)))
361 (check-node-reached dest)))
362 (unless (member last (block-start-uses cont-block))
363 (barf "LAST in ~S is missing from uses of its Cont." block)))
365 (check-node-reached (continuation-next last-cont))
366 (unless (member last (block-start-uses cont-block))
367 (barf "LAST in ~S is missing from uses of its Cont." block)))
369 (unless (eq cont-block block)
370 (barf "CONT of LAST in ~S is in a different BLOCK." block))
371 (unless (eq (continuation-use last-cont) last)
372 (barf "USE is not LAST in CONT of LAST in ~S." block))
373 (when (continuation-next last-cont)
374 (barf "CONT of LAST has a NEXT in ~S." block))))
377 (check-node-reached dest)))
380 (unless (eq (continuation-block this-cont) block)
381 (barf "BLOCK in ~S should be ~S." this-cont block))
383 (let ((dest (continuation-dest this-cont)))
385 (check-node-reached dest)))
387 (let ((node (continuation-next this-cont)))
388 (unless (node-p node)
389 (barf "~S has strange NEXT." this-cont))
390 (unless (eq (node-prev node) this-cont)
391 (barf "PREV in ~S should be ~S." node this-cont))
394 (check-node-consistency node))
396 (let ((cont (node-cont node)))
398 (barf "~S has no CONT." node))
399 (when (eq node last) (return))
400 (unless (eq (continuation-kind cont) :inside-block)
401 (barf "The interior continuation ~S in ~S has the wrong kind."
404 (unless (continuation-next cont)
405 (barf "~S has no NEXT." cont))
406 (unless (eq (continuation-use cont) node)
407 (barf "USE in ~S should be ~S." cont node))
408 (setq this-cont cont))))
410 (check-block-successors block))
413 ;;; Check that Block is properly terminated. Each successor must be
414 ;;; accounted for by the type of the last node.
415 (declaim (ftype (function (cblock) (values)) check-block-successors))
416 (defun check-block-successors (block)
417 (let ((last (block-last block))
418 (succ (block-succ block)))
420 (let* ((comp (block-component block)))
422 (unless (gethash b *seen-blocks*)
423 (barf "unseen successor ~S in ~S" b block))
424 (unless (member block (block-pred b))
425 (barf "bad successor link ~S in ~S" b block))
426 (unless (eq (block-component b) comp)
427 (barf "The successor ~S in ~S is in a different component."
433 (unless (proper-list-of-length-p succ 1 2)
434 (barf "~S ends in an IF, but doesn't have one or two succesors."
436 (unless (member (if-consequent last) succ)
437 (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
438 (unless (member (if-alternative last) succ)
439 (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
441 (unless (if (eq (functional-kind (return-lambda last)) :deleted)
443 (and (= (length succ) 1)
445 (component-tail (block-component block)))))
446 (barf "strange successors for RETURN in ~S" block)))
448 (unless (proper-list-of-length-p succ 0 1)
449 (barf "EXIT node with strange number of successors: ~S" last)))
451 (unless (or (= (length succ) 1) (node-tail-p last)
452 (and (block-delete-p block) (null succ)))
453 (barf "~S ends in normal node, but doesn't have one successor."
457 ;;;; node consistency checking
459 ;;; Check that the Dest for Cont is the specified Node. We also mark the
460 ;;; block Cont is in as Seen.
461 (declaim (ftype (function (continuation node) (values)) check-dest))
462 (defun check-dest (cont node)
463 (let ((kind (continuation-kind cont)))
466 (unless (block-delete-p (node-block node))
467 (barf "DEST ~S of deleted continuation ~S is not DELETE-P."
469 (:deleted-block-start
470 (unless (eq (continuation-dest cont) node)
471 (barf "DEST for ~S should be ~S." cont node)))
472 ((:inside-block :block-start)
473 (unless (gethash (continuation-block cont) *seen-blocks*)
474 (barf "~S receives ~S, which is in an unknown block." node cont))
475 (unless (eq (continuation-dest cont) node)
476 (barf "DEST for ~S should be ~S." cont node)))))
479 ;;; This function deals with checking for consistency the type-dependent
480 ;;; information in a node.
481 (defun check-node-consistency (node)
482 (declare (type node node))
485 (let ((leaf (ref-leaf node)))
486 (when (functional-p leaf)
487 (if (eq (functional-kind leaf) :top-level-xep)
488 (unless (eq (component-kind (block-component (node-block node)))
490 (barf ":TOP-LEVEL-XEP ref in non-top-level component: ~S"
492 (check-function-reached leaf node)))))
494 (check-dest (basic-combination-fun node) node)
495 (dolist (arg (basic-combination-args node))
497 (arg (check-dest arg node))
498 ((not (and (eq (basic-combination-kind node) :local)
499 (combination-p node)))
500 (barf "flushed arg not in local call: ~S" node))
503 ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
504 ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
505 ;; POSITION. It compiles it correctly, but it issues a type
506 ;; mismatch warning because it can't eliminate the
507 ;; possibility that control will flow through the
508 ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
509 (declare (notinline position))
510 (let ((fun (ref-leaf (continuation-use
511 (basic-combination-fun node))))
512 (pos (position arg (basic-combination-args node))))
513 (declare (type index pos))
514 (when (leaf-refs (elt (lambda-vars fun) pos))
515 (barf "flushed arg for referenced var in ~S" node)))))))
516 (let ((dest (continuation-dest (node-cont node))))
517 (when (and (return-p dest)
518 (eq (basic-combination-kind node) :local)
519 (not (eq (lambda-tail-set (combination-lambda node))
520 (lambda-tail-set (return-lambda dest)))))
521 (barf "tail local call to function with different tail set:~% ~S"
524 (check-dest (if-test node) node)
525 (unless (eq (block-last (node-block node)) node)
526 (barf "IF not at block end: ~S" node)))
528 (check-dest (set-value node) node))
530 (check-function-reached (bind-lambda node) node))
532 (check-function-reached (return-lambda node) node)
533 (check-dest (return-result node) node)
534 (unless (eq (block-last (node-block node)) node)
535 (barf "RETURN not at block end: ~S" node)))
537 (unless (member node (lambda-entries (node-home-lambda node)))
538 (barf "~S is not in ENTRIES for its home LAMBDA." node))
539 (dolist (exit (entry-exits node))
540 (unless (node-deleted exit)
541 (check-node-reached node))))
543 (let ((entry (exit-entry node))
544 (value (exit-value node)))
546 (check-node-reached entry)
547 (unless (member node (entry-exits entry))
548 (barf "~S is not in its ENTRY's EXITS." node))
550 (check-dest value node)))
553 (barf "~S has VALUE but no ENTRY." node)))))))
557 ;;;; IR2 consistency checking
559 ;;; Check for some kind of consistency in some Refs linked together by
560 ;;; TN-Ref-Across. VOP is the VOP that the references are in. Write-P is the
561 ;;; value of Write-P that should be present. Count is the minimum number of
562 ;;; operands expected. If More-P is true, then any larger number will also be
563 ;;; accepted. What is a string describing the kind of operand in error
565 (defun check-tn-refs (refs vop write-p count more-p what)
566 (let ((vop-refs (vop-refs vop)))
567 (do ((ref refs (tn-ref-across ref))
571 (barf "There should be at least ~D ~A in ~S, but are only ~D."
573 (when (and (not more-p) (> num count))
574 (barf "There should be ~D ~A in ~S, but are ~D."
575 count what vop num)))
576 (unless (eq (tn-ref-vop ref) vop)
577 (barf "VOP is ~S isn't ~S." ref vop))
578 (unless (eq (tn-ref-write-p ref) write-p)
579 (barf "The WRITE-P in ~S isn't ~S." vop write-p))
580 (unless (find-in #'tn-ref-next-ref ref vop-refs)
581 (barf "~S not found in REFS for ~S" ref vop))
582 (unless (find-in #'tn-ref-next ref
583 (if (tn-ref-write-p ref)
584 (tn-writes (tn-ref-tn ref))
585 (tn-reads (tn-ref-tn ref))))
586 (barf "~S not found in reads/writes for its TN" ref))
588 (let ((target (tn-ref-target ref)))
590 (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
591 (barf "The target for ~S isn't complementary WRITE-P." ref))
592 (unless (find-in #'tn-ref-next-ref target vop-refs)
593 (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
595 ;;; Verify the sanity of the VOP-Refs slot in VOP. This involves checking
596 ;;; that each referenced TN appears as an argument, result or temp, and also
597 ;;; basic checks for the plausibility of the specified ordering of the refs.
598 (defun check-vop-refs (vop)
599 (declare (type vop vop))
600 (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
603 ((find-in #'tn-ref-across ref (vop-args vop)))
604 ((find-in #'tn-ref-across ref (vop-results vop)))
605 ((not (eq (tn-ref-vop ref) vop))
606 (barf "VOP in ~S isn't ~S." ref vop))
607 ((find-in #'tn-ref-across ref (vop-temps vop)))
608 ((tn-ref-write-p ref)
609 (barf "stray ref that isn't a READ: ~S" ref))
611 (let* ((tn (tn-ref-tn ref))
612 (temp (find-in #'tn-ref-across tn (vop-temps vop)
615 (barf "stray ref with no corresponding temp write: ~S" ref))
616 (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
617 (barf "Read is after write for temp ~S in refs of ~S."
621 ;;; Check the basic sanity of the VOP linkage, then call some other
622 ;;; functions to check on the TN-Refs. We grab some info out of the VOP-Info
623 ;;; to tell us what to expect.
625 ;;; [### Check that operand type restrictions are met?]
626 (defun check-ir2-block-consistency (2block)
627 (declare (type ir2-block 2block))
628 (do ((vop (ir2-block-start-vop 2block)
632 (unless (eq prev (ir2-block-last-vop 2block))
633 (barf "The last VOP in ~S should be ~S." 2block prev)))
634 (unless (eq (vop-prev vop) prev)
635 (barf "PREV in ~S should be ~S." vop prev))
637 (unless (eq (vop-block vop) 2block)
638 (barf "BLOCK in ~S should be ~S." vop 2block))
642 (let* ((info (vop-info vop))
643 (atypes (template-arg-types info))
644 (rtypes (template-result-types info)))
645 (check-tn-refs (vop-args vop) vop nil
646 (count-if-not #'(lambda (x)
648 (eq (car x) :constant)))
650 (template-more-args-type info) "args")
651 (check-tn-refs (vop-results vop) vop t
652 (if (eq rtypes :conditional) 0 (length rtypes))
653 (template-more-results-type info) "results")
654 (check-tn-refs (vop-temps vop) vop t 0 t "temps")
655 (unless (= (length (vop-codegen-info vop))
656 (template-info-arg-count info))
657 (barf "wrong number of codegen info args in ~S" vop))))
660 ;;; Check stuff about the IR2 representation of Component. This assumes the
661 ;;; sanity of the basic flow graph.
663 ;;; [### Also grovel global TN data structures? Assume pack not
664 ;;; done yet? Have separate check-tn-consistency for pre-pack and
665 ;;; check-pack-consistency for post-pack?]
666 (defun check-ir2-consistency (component)
667 (declare (type component component))
668 (do-ir2-blocks (block component)
669 (check-ir2-block-consistency block))
672 ;;;; lifetime analysis checking
674 ;;; Dump some info about how many TNs there, and what the conflicts data
675 ;;; structures are like.
676 (defun pre-pack-tn-stats (component &optional (stream *error-output*))
677 (declare (type component component))
687 (do-packed-tns (tn component)
688 (let ((reads (tn-reads tn))
689 (writes (tn-writes tn)))
690 (when (and reads writes
691 (not (tn-ref-next reads)) (not (tn-ref-next writes))
692 (eq (tn-ref-vop reads) (tn-ref-vop writes)))
696 (unless (or (tn-reads tn) (tn-writes tn))
698 (cond ((eq (tn-kind tn) :component)
700 ((tn-global-conflicts tn)
702 ((:environment :debug-environment) (incf environment))
704 (do ((conf (tn-global-conflicts tn)
705 (global-conflicts-tn-next conf)))
711 (do ((tn (ir2-component-constant-tns (component-info component))
717 "~%TNs: ~D local, ~D temps, ~D constant, ~D env, ~D comp, ~D global.~@
718 Wired: ~D, Unused: ~D. ~D block~:P, ~D global conflict~:P.~%"
719 local temps const environment comp global wired unused
720 (ir2-block-count component)
724 ;;; If the entry in Local-TNs for TN in Block is :More, then do some checks
725 ;;; for the validity of the usage.
726 (defun check-more-tn-entry (tn block)
727 (let* ((vop (ir2-block-start-vop block))
728 (info (vop-info vop)))
729 (macrolet ((frob (more-p ops)
731 (find-in #'tn-ref-across tn (,ops vop)
733 (unless (and (eq vop (ir2-block-last-vop block))
734 (or (frob template-more-args-type vop-args)
735 (frob template-more-results-type vop-results)))
736 (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
739 (defun check-tn-conflicts (component)
740 (do-packed-tns (tn component)
741 (unless (or (not (eq (tn-kind tn) :normal))
744 (barf "no references to ~S" tn))
746 (unless (tn-sc tn) (barf "~S has no SC." tn))
748 (let ((conf (tn-global-conflicts tn))
751 ((eq kind :component)
752 (unless (member tn (ir2-component-component-tns
753 (component-info component)))
754 (barf "~S not in Component-TNs for ~S" tn component)))
756 (do ((conf conf (global-conflicts-tn-next conf))
759 (unless (eq (global-conflicts-tn conf) tn)
760 (barf "TN in ~S should be ~S." conf tn))
762 (unless (eq (global-conflicts-kind conf) :live)
763 (let* ((block (global-conflicts-block conf))
764 (ltn (svref (ir2-block-local-tns block)
765 (global-conflicts-number conf))))
767 ((eq ltn :more) (check-more-tn-entry tn block))
769 (barf "~S wrong in LTN map for ~S" conf tn)))))
772 (unless (> (ir2-block-number (global-conflicts-block conf))
773 (ir2-block-number (global-conflicts-block prev)))
774 (barf "~s and ~s out of order" prev conf)))))
775 ((member (tn-kind tn) '(:constant :specified-save)))
777 (let ((local (tn-local tn)))
779 (barf "~S has no global conflicts, but isn't local either." tn))
780 (unless (eq (svref (ir2-block-local-tns local)
781 (tn-local-number tn))
783 (barf "~S wrong in LTN map" tn))
784 (do ((ref (tn-reads tn) (tn-ref-next ref)))
786 (unless (eq (vop-block (tn-ref-vop ref)) local)
787 (barf "~S has references in blocks other than its LOCAL block."
789 (do ((ref (tn-writes tn) (tn-ref-next ref)))
791 (unless (eq (vop-block (tn-ref-vop ref)) local)
792 (barf "~S has references in blocks other than its LOCAL block."
796 (defun check-block-conflicts (component)
797 (do-ir2-blocks (block component)
798 (do ((conf (ir2-block-global-tns block)
799 (global-conflicts-next conf))
803 (unless (> (tn-number (global-conflicts-tn conf))
804 (tn-number (global-conflicts-tn prev)))
805 (barf "~S and ~S out of order in ~S" prev conf block)))
807 (unless (find-in #'global-conflicts-tn-next
810 (global-conflicts-tn conf)))
811 (barf "~S missing from global conflicts of its TN" conf)))
813 (let ((map (ir2-block-local-tns block)))
814 (dotimes (i (ir2-block-local-tn-count block))
815 (let ((tn (svref map i)))
816 (unless (or (eq tn :more)
818 (tn-global-conflicts tn)
819 (eq (tn-local tn) block))
820 (barf "strange TN ~S in LTN map for ~S" tn block)))))))
822 ;;; All TNs live at the beginning of an environment must be passing
823 ;;; locations associated with that environment. We make an exception for wired
824 ;;; TNs in XEP functions, since we randomly reference wired TNs to access the
825 ;;; full call passing locations.
826 (defun check-environment-lifetimes (component)
827 (dolist (fun (component-lambdas component))
828 (let* ((env (lambda-environment fun))
829 (2env (environment-info env))
830 (vars (lambda-vars fun))
831 (closure (ir2-environment-environment 2env))
832 (pc (ir2-environment-return-pc-pass 2env))
833 (fp (ir2-environment-old-fp 2env))
837 (environment-function env))))))
838 (do ((conf (ir2-block-global-tns 2block)
839 (global-conflicts-next conf)))
841 (let ((tn (global-conflicts-tn conf)))
842 (unless (or (eq (global-conflicts-kind conf) :write)
845 (and (external-entry-point-p fun)
847 (member (tn-kind tn) '(:environment :debug-environment))
848 (member tn vars :key #'leaf-info)
849 (member tn closure :key #'cdr))
850 (barf "strange TN live at head of ~S: ~S" env tn))))))
853 ;;; Check for some basic sanity in the TN conflict data structures, and also
854 ;;; check that no TNs are unexpectedly live at environment entry.
855 (defun check-life-consistency (component)
856 (check-tn-conflicts component)
857 (check-block-conflicts component)
858 (check-environment-lifetimes component))
860 ;;;; pack consistency checking
862 (defun check-pack-consistency (component)
863 (flet ((check (scs ops)
864 (do ((scs scs (cdr scs))
865 (op ops (tn-ref-across op)))
867 (let ((load-tn (tn-ref-load-tn op)))
868 (unless (eq (svref (car scs)
871 (or load-tn (tn-ref-tn op)))))
873 (barf "operand restriction not satisfied: ~S" op))))))
874 (do-ir2-blocks (block component)
875 (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
877 (let ((info (vop-info vop)))
878 (check (vop-info-result-load-scs info) (vop-results vop))
879 (check (vop-info-arg-load-scs info) (vop-args vop))))))
882 ;;;; data structure dumping routines
884 ;;; When we print Continuations and TNs, we assign them small numeric IDs so
885 ;;; that we can get a handle on anonymous objects given a printout.
886 (macrolet ((def-frob (counter vto vfrom fto ffrom)
888 (defvar ,vto (make-hash-table :test 'eq))
889 (defvar ,vfrom (make-hash-table :test 'eql))
890 (proclaim '(hash-table ,vto ,vfrom))
892 (proclaim '(fixnum ,counter))
896 (let ((num (incf ,counter)))
897 (setf (gethash num ,vfrom) x)
898 (setf (gethash x ,vto) num))))
901 (values (gethash num ,vfrom))))))
902 (def-frob *continuation-number* *continuation-numbers* *number-continuations* cont-num num-cont)
903 (def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn)
904 (def-frob *label-id* *id-labels* *label-ids* label-id id-label))
906 ;;; Print out a terse one-line description of a leaf.
907 (defun print-leaf (leaf &optional (stream *standard-output*))
908 (declare (type leaf leaf) (type stream stream))
910 (lambda-var (prin1 (leaf-name leaf) stream))
911 (constant (format stream "'~S" (constant-value leaf)))
913 (format stream "~S {~A}" (leaf-name leaf) (global-var-kind leaf)))
915 (format stream "lambda ~S ~S" (leaf-name leaf)
916 (mapcar #'leaf-name (lambda-vars leaf))))
918 (format stream "optional-dispatch ~S" (leaf-name leaf)))
920 (aver (eq (functional-kind leaf) :top-level-xep))
921 (format stream "TL-XEP ~S"
922 (let ((info (leaf-info leaf)))
924 (entry-info (entry-info-name info))
925 (byte-lambda-info :byte-compiled-entry)))))))
927 ;;; Attempt to find a block given some thing that has to do with it.
928 (declaim (ftype (function (t) cblock) block-or-lose))
929 (defun block-or-lose (thing)
932 (ir2-block (ir2-block-block thing))
933 (vop (block-or-lose (vop-block thing)))
934 (tn-ref (block-or-lose (tn-ref-vop thing)))
935 (continuation (continuation-block thing))
936 (node (node-block thing))
937 (component (component-head thing))
938 #| (cloop (loop-head thing))|#
939 (integer (continuation-block (num-cont thing)))
940 (functional (node-block (lambda-bind (main-entry thing))))
941 (null (error "Bad thing: ~S." thing))
942 (symbol (block-or-lose (gethash thing *free-functions*)))))
945 (defun print-continuation (cont)
946 (declare (type continuation cont))
947 (format t " c~D" (cont-num cont))
950 ;;; Print out the nodes in Block in a format oriented toward representing
951 ;;; what the code does.
952 (defun print-nodes (block)
953 (setq block (block-or-lose block))
954 (format t "~%block start c~D" (cont-num (block-start block)))
956 (let ((last (block-last block)))
958 (do ((cont (block-start block) (node-cont (continuation-next cont))))
960 (let ((node (continuation-next cont)))
961 (format t "~3D: " (cont-num (node-cont node)))
963 (ref (print-leaf (ref-leaf node)))
965 (let ((kind (basic-combination-kind node)))
966 (format t "~(~A ~A~) c~D"
967 (if (function-info-p kind) "known" kind)
969 (cont-num (basic-combination-fun node)))
970 (dolist (arg (basic-combination-args node))
972 (print-continuation arg)
973 (format t " <none>")))))
975 (write-string "set ")
976 (print-leaf (set-var node))
977 (print-continuation (set-value node)))
979 (format t "if c~D" (cont-num (if-test node)))
980 (print-continuation (block-start (if-consequent node)))
981 (print-continuation (block-start (if-alternative node))))
983 (write-string "bind ")
984 (print-leaf (bind-lambda node)))
986 (format t "return c~D " (cont-num (return-result node)))
987 (print-leaf (return-lambda node)))
989 (format t "entry ~S" (entry-exits node)))
991 (let ((value (exit-value node)))
993 (format t "exit c~D" (cont-num value)))
995 (format t "exit <no value>"))
997 (format t "exit <degenerate>"))))))
999 (when (eq node last) (return)))))
1001 (let ((succ (block-succ block)))
1002 (format t "successors~{ c~D~}~%"
1003 (mapcar #'(lambda (x) (cont-num (block-start x))) succ)))
1006 ;;; Print a useful representation of a TN. If the TN has a leaf, then do a
1007 ;;; Print-Leaf on that, otherwise print a generated ID.
1008 (defun print-tn (tn &optional (stream *standard-output*))
1009 (declare (type tn tn))
1010 (let ((leaf (tn-leaf tn)))
1012 (print-leaf leaf stream)
1013 (format stream "!~D" (tn-id tn)))
1015 (format stream "t~D" (tn-id tn))))
1016 (when (and (tn-sc tn) (tn-offset tn))
1017 (format stream "[~A]" (location-print-name tn)))))
1019 ;;; Print the TN-Refs representing some operands to a VOP, linked by
1021 (defun print-operands (refs)
1022 (declare (type (or tn-ref null) refs))
1023 (pprint-logical-block (*standard-output* nil)
1024 (do ((ref refs (tn-ref-across ref)))
1026 (let ((tn (tn-ref-tn ref))
1027 (ltn (tn-ref-load-tn ref)))
1032 (princ (if (tn-ref-write-p ref) #\< #\>))
1035 (pprint-newline :fill)))))
1037 ;;; Print the vop, putting args, info and results on separate lines, if
1039 (defun print-vop (vop)
1040 (pprint-logical-block (*standard-output* nil)
1041 (princ (vop-info-name (vop-info vop)))
1043 (pprint-indent :current 0)
1044 (print-operands (vop-args vop))
1045 (pprint-newline :linear)
1046 (when (vop-codegen-info vop)
1047 (princ (with-output-to-string (stream)
1048 (let ((*print-level* 1)
1050 (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
1051 (pprint-newline :linear))
1052 (when (vop-results vop)
1054 (print-operands (vop-results vop))))
1057 ;;; Print the VOPs in the specified IR2 block.
1058 (defun print-ir2-block (block)
1059 (declare (type ir2-block block))
1061 ((eq (block-info (ir2-block-block block)) block)
1062 (format t "~%IR2 block start c~D~%"
1063 (cont-num (block-start (ir2-block-block block))))
1064 (let ((label (ir2-block-%label block)))
1066 (format t "L~D:~%" (label-id label)))))
1068 (format t "<overflow>~%")))
1070 (do ((vop (ir2-block-start-vop block)
1072 (number 0 (1+ number)))
1074 (format t "~D: " number)
1077 ;;; Like Print-Nodes, but dumps the IR2 representation of the code in Block.
1078 (defun print-vops (block)
1079 (setq block (block-or-lose block))
1080 (let ((2block (block-info block)))
1081 (print-ir2-block 2block)
1082 (do ((b (ir2-block-next 2block) (ir2-block-next b)))
1083 ((not (eq (ir2-block-block b) block)))
1084 (print-ir2-block b)))
1087 ;;; Scan the IR2 blocks in emission order.
1088 (defun print-ir2-blocks (thing)
1089 (do-ir2-blocks (block (block-component (block-or-lose thing)))
1090 (print-ir2-block block))
1093 ;;; Do a Print-Nodes on Block and all blocks reachable from it by successor
1095 (defun print-blocks (block)
1096 (setq block (block-or-lose block))
1097 (do-blocks (block (block-component block) :both)
1098 (setf (block-flag block) nil))
1099 (labels ((walk (block)
1100 (unless (block-flag block)
1101 (setf (block-flag block) t)
1102 (when (block-start block)
1103 (print-nodes block))
1104 (dolist (block (block-succ block))
1109 ;;; Print all blocks in Block's component in DFO.
1110 (defun print-all-blocks (thing)
1111 (do-blocks (block (block-component (block-or-lose thing)))
1112 (handler-case (print-nodes block)
1114 (format t "~&~A...~%" condition))))
1117 (defvar *list-conflicts-table* (make-hash-table :test 'eq))
1119 ;;; Add all Always-Live TNs in Block to the conflicts. TN is ignored when
1120 ;;; it appears in the global conflicts.
1121 (defun add-always-live-tns (block tn)
1122 (declare (type ir2-block block) (type tn tn))
1123 (do ((conf (ir2-block-global-tns block)
1124 (global-conflicts-next conf)))
1126 (when (eq (global-conflicts-kind conf) :live)
1127 (let ((btn (global-conflicts-tn conf)))
1129 (setf (gethash btn *list-conflicts-table*) t)))))
1132 ;;; Add all local TNs in block to the conflicts.
1133 (defun add-all-local-tns (block)
1134 (declare (type ir2-block block))
1135 (let ((ltns (ir2-block-local-tns block)))
1136 (dotimes (i (ir2-block-local-tn-count block))
1137 (setf (gethash (svref ltns i) *list-conflicts-table*) t)))
1140 ;;; Make a list out of all of the recorded conflicts.
1141 (defun listify-conflicts-table ()
1143 (maphash #'(lambda (k v)
1144 (declare (ignore v))
1147 *list-conflicts-table*)
1148 (clrhash *list-conflicts-table*)
1151 ;;; Return a list of a the TNs that conflict with TN. Sort of, kind
1152 ;;; of. For debugging use only. Probably doesn't work on :COMPONENT TNs.
1153 (defun list-conflicts (tn)
1154 (aver (member (tn-kind tn) '(:normal :environment :debug-environment)))
1155 (let ((confs (tn-global-conflicts tn)))
1157 (clrhash *list-conflicts-table*)
1158 (do ((conf confs (global-conflicts-tn-next conf)))
1160 (let ((block (global-conflicts-block conf)))
1161 (add-always-live-tns block tn)
1162 (if (eq (global-conflicts-kind conf) :live)
1163 (add-all-local-tns block)
1164 (let ((bconf (global-conflicts-conflicts conf))
1165 (ltns (ir2-block-local-tns block)))
1166 (dotimes (i (ir2-block-local-tn-count block))
1167 (when (/= (sbit bconf i) 0)
1168 (setf (gethash (svref ltns i) *list-conflicts-table*)
1170 (listify-conflicts-table))
1172 (let* ((block (tn-local tn))
1173 (ltns (ir2-block-local-tns block))
1174 (confs (tn-local-conflicts tn)))
1176 (dotimes (i (ir2-block-local-tn-count block))
1177 (when (/= (sbit confs i) 0)
1178 (let ((tn (svref ltns i)))
1179 (when (and tn (not (eq tn :more))
1180 (not (tn-global-conflicts tn)))
1182 (do ((gtn (ir2-block-global-tns block)
1183 (global-conflicts-next gtn)))
1185 (when (or (eq (global-conflicts-kind gtn) :live)
1186 (/= (sbit confs (global-conflicts-number gtn)) 0))
1187 (res (global-conflicts-tn gtn))))
1190 (defun nth-vop (thing n)
1192 "Return the Nth VOP in the IR2-Block pointed to by Thing."
1193 (let ((block (block-info (block-or-lose thing))))
1195 (vop (ir2-block-start-vop block) (vop-next vop)))