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 (continuation-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-cont (block-start block
))
336 (last (block-last block
)))
338 (check-fun-reached fun block
))
339 (when (not this-cont
)
340 (barf "~S has no START." block
))
342 (barf "~S has no LAST." block
))
343 (unless (eq (continuation-kind this-cont
) :block-start
)
344 (barf "The START of ~S has the wrong kind." block
))
346 (let ((use (continuation-use this-cont
))
347 (uses (block-start-uses block
)))
348 (when (and (null use
) (= (length uses
) 1))
349 (barf "~S has a unique use, but no USE." this-cont
))
351 (unless (eq (node-cont node
) this-cont
)
352 (barf "The USE ~S for START in ~S has wrong CONT." node block
))
353 (check-node-reached node
)))
355 (let* ((last-cont (node-cont last
))
356 (cont-block (continuation-block last-cont
))
357 (dest (continuation-dest last-cont
)))
358 (ecase (continuation-kind last-cont
)
360 (:deleted-block-start
361 (let ((dest (continuation-dest last-cont
)))
363 (check-node-reached dest
)))
364 (unless (member last
(block-start-uses cont-block
))
365 (barf "LAST in ~S is missing from uses of its Cont." block
)))
367 (check-node-reached (continuation-next last-cont
))
368 (unless (member last
(block-start-uses cont-block
))
369 (barf "LAST in ~S is missing from uses of its Cont." block
)))
371 (unless (eq cont-block block
)
372 (barf "CONT of LAST in ~S is in a different BLOCK." block
))
373 (unless (eq (continuation-use last-cont
) last
)
374 (barf "USE is not LAST in CONT of LAST in ~S." block
))
375 (when (continuation-next last-cont
)
376 (barf "CONT of LAST has a NEXT in ~S." block
))))
379 (check-node-reached dest
)))
382 (unless (eq (continuation-block this-cont
) block
)
383 (barf "BLOCK in ~S should be ~S." this-cont block
))
385 (let ((dest (continuation-dest this-cont
)))
387 (check-node-reached dest
)))
389 (let ((node (continuation-next this-cont
)))
390 (unless (node-p node
)
391 (barf "~S has strange NEXT." this-cont
))
392 (unless (eq (node-prev node
) this-cont
)
393 (barf "PREV in ~S should be ~S." node this-cont
))
396 (check-node-consistency node
))
398 (let ((cont (node-cont node
)))
400 (barf "~S has no CONT." node
))
401 (when (eq node last
) (return))
402 (unless (eq (continuation-kind cont
) :inside-block
)
403 (barf "The interior continuation ~S in ~S has the wrong kind."
406 (unless (continuation-next cont
)
407 (barf "~S has no NEXT." cont
))
408 (unless (eq (continuation-use cont
) node
)
409 (barf "USE in ~S should be ~S." cont node
))
410 (setq this-cont cont
))))
412 (check-block-successors block
))
415 ;;; Check that BLOCK is properly terminated. Each successor must be
416 ;;; accounted for by the type of the last node.
417 (declaim (ftype (function (cblock) (values)) check-block-successors
))
418 (defun check-block-successors (block)
419 (let ((last (block-last block
))
420 (succ (block-succ block
)))
422 (let* ((comp (block-component block
)))
424 (unless (gethash b
*seen-blocks
*)
425 (barf "unseen successor ~S in ~S" b block
))
426 (unless (member block
(block-pred b
))
427 (barf "bad successor link ~S in ~S" b block
))
428 (unless (eq (block-component b
) comp
)
429 (barf "The successor ~S in ~S is in a different component."
435 (unless (proper-list-of-length-p succ
1 2)
436 (barf "~S ends in an IF, but doesn't have one or two succesors."
438 (unless (member (if-consequent last
) succ
)
439 (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block
))
440 (unless (member (if-alternative last
) succ
)
441 (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block
)))
443 (unless (if (eq (functional-kind (return-lambda last
)) :deleted
)
445 (and (= (length succ
) 1)
447 (component-tail (block-component block
)))))
448 (barf "strange successors for RETURN in ~S" block
)))
450 (unless (proper-list-of-length-p succ
0 1)
451 (barf "EXIT node with strange number of successors: ~S" last
)))
453 (unless (or (= (length succ
) 1) (node-tail-p last
)
454 (and (block-delete-p block
) (null succ
)))
455 (barf "~S ends in normal node, but doesn't have one successor."
459 ;;;; node consistency checking
461 ;;; Check that the DEST for CONT is the specified NODE. We also mark
462 ;;; the block CONT is in as SEEN.
463 (declaim (ftype (function (continuation node
) (values)) check-dest
))
464 (defun check-dest (cont node
)
465 (let ((kind (continuation-kind cont
)))
468 (unless (block-delete-p (node-block node
))
469 (barf "DEST ~S of deleted continuation ~S is not DELETE-P."
471 (:deleted-block-start
472 (unless (eq (continuation-dest cont
) node
)
473 (barf "DEST for ~S should be ~S." cont node
)))
474 ((:inside-block
:block-start
)
475 (unless (gethash (continuation-block cont
) *seen-blocks
*)
476 (barf "~S receives ~S, which is in an unknown block." node cont
))
477 (unless (eq (continuation-dest cont
) node
)
478 (barf "DEST for ~S should be ~S." cont node
)))))
481 ;;; This function deals with checking for consistency of the
482 ;;; type-dependent information in a node.
483 (defun check-node-consistency (node)
484 (declare (type node node
))
487 (let ((leaf (ref-leaf node
)))
488 (when (functional-p leaf
)
489 (if (eq (functional-kind leaf
) :toplevel-xep
)
490 (unless (eq (component-kind (block-component (node-block node
)))
492 (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
494 (check-fun-reached leaf node
)))))
496 (check-dest (basic-combination-fun node
) node
)
497 (dolist (arg (basic-combination-args node
))
499 (arg (check-dest arg node
))
500 ((not (and (eq (basic-combination-kind node
) :local
)
501 (combination-p node
)))
502 (barf "flushed arg not in local call: ~S" node
))
505 ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
506 ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
507 ;; POSITION. It compiles it correctly, but it issues a type
508 ;; mismatch warning because it can't eliminate the
509 ;; possibility that control will flow through the
510 ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
511 (declare (notinline position
))
512 (let ((fun (ref-leaf (continuation-use
513 (basic-combination-fun node
))))
514 (pos (position arg
(basic-combination-args node
))))
515 (declare (type index pos
))
516 (when (leaf-refs (elt (lambda-vars fun
) pos
))
517 (barf "flushed arg for referenced var in ~S" node
)))))))
518 (let ((dest (continuation-dest (node-cont node
))))
519 (when (and (return-p dest
)
520 (eq (basic-combination-kind node
) :local
)
521 (not (eq (lambda-tail-set (combination-lambda node
))
522 (lambda-tail-set (return-lambda dest
)))))
523 (barf "tail local call to function with different tail set:~% ~S"
526 (check-dest (if-test node
) node
)
527 (unless (eq (block-last (node-block node
)) node
)
528 (barf "IF not at block end: ~S" node
)))
530 (check-dest (set-value node
) node
))
532 (check-fun-reached (bind-lambda node
) node
))
534 (check-fun-reached (return-lambda node
) node
)
535 (check-dest (return-result node
) node
)
536 (unless (eq (block-last (node-block node
)) node
)
537 (barf "RETURN not at block end: ~S" node
)))
539 (unless (member node
(lambda-entries (node-home-lambda node
)))
540 (barf "~S is not in ENTRIES for its home LAMBDA." node
))
541 (dolist (exit (entry-exits node
))
542 (unless (node-deleted exit
)
543 (check-node-reached node
))))
545 (let ((entry (exit-entry node
))
546 (value (exit-value node
)))
548 (check-node-reached entry
)
549 (unless (member node
(entry-exits entry
))
550 (barf "~S is not in its ENTRY's EXITS." node
))
552 (check-dest value node
)))
555 (barf "~S has VALUE but no ENTRY." node
)))))))
559 ;;;; IR2 consistency checking
561 ;;; Check for some kind of consistency in some REFs linked together by
562 ;;; TN-REF-ACROSS. VOP is the VOP that the references are in. WRITE-P
563 ;;; is the value of WRITE-P that should be present. COUNT is the
564 ;;; minimum number of operands expected. If MORE-P is true, then any
565 ;;; larger number will also be accepted. WHAT is a string describing
566 ;;; the kind of operand in error messages.
567 (defun check-tn-refs (refs vop write-p count more-p what
)
568 (let ((vop-refs (vop-refs vop
)))
569 (do ((ref refs
(tn-ref-across ref
))
573 (barf "There should be at least ~W ~A in ~S, but there are only ~W."
575 (when (and (not more-p
) (> num count
))
576 (barf "There should be ~W ~A in ~S, but are ~W."
577 count what vop num
)))
578 (unless (eq (tn-ref-vop ref
) vop
)
579 (barf "VOP is ~S isn't ~S." ref vop
))
580 (unless (eq (tn-ref-write-p ref
) write-p
)
581 (barf "The WRITE-P in ~S isn't ~S." vop write-p
))
582 (unless (find-in #'tn-ref-next-ref ref vop-refs
)
583 (barf "~S not found in REFS for ~S" ref vop
))
584 (unless (find-in #'tn-ref-next ref
585 (if (tn-ref-write-p ref
)
586 (tn-writes (tn-ref-tn ref
))
587 (tn-reads (tn-ref-tn ref
))))
588 (barf "~S not found in reads/writes for its TN" ref
))
590 (let ((target (tn-ref-target ref
)))
592 (unless (eq (tn-ref-write-p target
) (not (tn-ref-write-p ref
)))
593 (barf "The target for ~S isn't complementary WRITE-P." ref
))
594 (unless (find-in #'tn-ref-next-ref target vop-refs
)
595 (barf "The target for ~S isn't in REFS for ~S." ref vop
)))))))
597 ;;; Verify the sanity of the VOP-REFS slot in VOP. This involves checking
598 ;;; that each referenced TN appears as an argument, result or temp, and also
599 ;;; basic checks for the plausibility of the specified ordering of the refs.
600 (defun check-vop-refs (vop)
601 (declare (type vop vop
))
602 (do ((ref (vop-refs vop
) (tn-ref-next-ref ref
)))
605 ((find-in #'tn-ref-across ref
(vop-args vop
)))
606 ((find-in #'tn-ref-across ref
(vop-results vop
)))
607 ((not (eq (tn-ref-vop ref
) vop
))
608 (barf "VOP in ~S isn't ~S." ref vop
))
609 ((find-in #'tn-ref-across ref
(vop-temps vop
)))
610 ((tn-ref-write-p ref
)
611 (barf "stray ref that isn't a READ: ~S" ref
))
613 (let* ((tn (tn-ref-tn ref
))
614 (temp (find-in #'tn-ref-across tn
(vop-temps vop
)
617 (barf "stray ref with no corresponding temp write: ~S" ref
))
618 (unless (find-in #'tn-ref-next-ref temp
(tn-ref-next-ref ref
))
619 (barf "Read is after write for temp ~S in refs of ~S."
623 ;;; Check the basic sanity of the VOP linkage, then call some other
624 ;;; functions to check on the TN-REFS. We grab some info out of the
625 ;;; VOP-INFO to tell us what to expect.
627 ;;; [### Check that operand type restrictions are met?]
628 (defun check-ir2-block-consistency (2block)
629 (declare (type ir2-block
2block
))
630 (do ((vop (ir2-block-start-vop 2block
)
634 (unless (eq prev
(ir2-block-last-vop 2block
))
635 (barf "The last VOP in ~S should be ~S." 2block prev
)))
636 (unless (eq (vop-prev vop
) prev
)
637 (barf "PREV in ~S should be ~S." vop prev
))
639 (unless (eq (vop-block vop
) 2block
)
640 (barf "BLOCK in ~S should be ~S." vop
2block
))
644 (let* ((info (vop-info vop
))
645 (atypes (template-arg-types info
))
646 (rtypes (template-result-types info
)))
647 (check-tn-refs (vop-args vop
) vop nil
648 (count-if-not (lambda (x)
650 (eq (car x
) :constant
)))
652 (template-more-args-type info
) "args")
653 (check-tn-refs (vop-results vop
) vop t
654 (if (eq rtypes
:conditional
) 0 (length rtypes
))
655 (template-more-results-type info
) "results")
656 (check-tn-refs (vop-temps vop
) vop t
0 t
"temps")
657 (unless (= (length (vop-codegen-info vop
))
658 (template-info-arg-count info
))
659 (barf "wrong number of codegen info args in ~S" vop
))))
662 ;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
663 ;;; sanity of the basic flow graph.
665 ;;; [### Also grovel global TN data structures? Assume pack not
666 ;;; done yet? Have separate CHECK-TN-CONSISTENCY for pre-pack and
667 ;;; CHECK-PACK-CONSISTENCY for post-pack?]
668 (defun check-ir2-consistency (component)
669 (declare (type component component
))
670 (do-ir2-blocks (block component
)
671 (check-ir2-block-consistency block
))
674 ;;;; lifetime analysis checking
676 ;;; Dump some info about how many TNs there, and what the conflicts data
677 ;;; structures are like.
678 (defun pre-pack-tn-stats (component &optional
(stream *error-output
*))
679 (declare (type component component
))
689 (do-packed-tns (tn component
)
690 (let ((reads (tn-reads tn
))
691 (writes (tn-writes tn
)))
692 (when (and reads writes
693 (not (tn-ref-next reads
)) (not (tn-ref-next writes
))
694 (eq (tn-ref-vop reads
) (tn-ref-vop writes
)))
698 (unless (or (tn-reads tn
) (tn-writes tn
))
700 (cond ((eq (tn-kind tn
) :component
)
702 ((tn-global-conflicts tn
)
704 ((:environment
:debug-environment
) (incf environment
))
706 (do ((conf (tn-global-conflicts tn
)
707 (global-conflicts-next-tnwise conf
)))
713 (do ((tn (ir2-component-constant-tns (component-info component
))
719 "~%TNs: ~W local, ~W temps, ~W constant, ~W env, ~W comp, ~W global.~@
720 Wired: ~W, Unused: ~W. ~W block~:P, ~W global conflict~:P.~%"
721 local temps const environment comp global wired unused
722 (ir2-block-count component
)
726 ;;; If the entry in Local-TNs for TN in BLOCK is :MORE, then do some checks
727 ;;; for the validity of the usage.
728 (defun check-more-tn-entry (tn block
)
729 (let* ((vop (ir2-block-start-vop block
))
730 (info (vop-info vop
)))
731 (macrolet ((frob (more-p ops
)
733 (find-in #'tn-ref-across tn
(,ops vop
)
735 (unless (and (eq vop
(ir2-block-last-vop block
))
736 (or (frob template-more-args-type vop-args
)
737 (frob template-more-results-type vop-results
)))
738 (barf "strange :MORE LTN entry for ~S in ~S" tn block
))))
741 (defun check-tn-conflicts (component)
742 (do-packed-tns (tn component
)
743 (unless (or (not (eq (tn-kind tn
) :normal
))
746 (barf "no references to ~S" tn
))
748 (unless (tn-sc tn
) (barf "~S has no SC." tn
))
750 (let ((conf (tn-global-conflicts tn
))
753 ((eq kind
:component
)
754 (unless (member tn
(ir2-component-component-tns
755 (component-info component
)))
756 (barf "~S not in COMPONENT-TNs for ~S" tn component
)))
758 (do ((conf conf
(global-conflicts-next-tnwise conf
))
761 (unless (eq (global-conflicts-tn conf
) tn
)
762 (barf "TN in ~S should be ~S." conf tn
))
764 (unless (eq (global-conflicts-kind conf
) :live
)
765 (let* ((block (global-conflicts-block conf
))
766 (ltn (svref (ir2-block-local-tns block
)
767 (global-conflicts-number conf
))))
769 ((eq ltn
:more
) (check-more-tn-entry tn block
))
771 (barf "~S wrong in LTN map for ~S" conf tn
)))))
774 (unless (> (ir2-block-number (global-conflicts-block conf
))
775 (ir2-block-number (global-conflicts-block prev
)))
776 (barf "~s and ~s out of order" prev conf
)))))
777 ((member (tn-kind tn
) '(:constant
:specified-save
)))
779 (let ((local (tn-local tn
)))
781 (barf "~S has no global conflicts, but isn't local either." tn
))
782 (unless (eq (svref (ir2-block-local-tns local
)
783 (tn-local-number tn
))
785 (barf "~S wrong in LTN map" tn
))
786 (do ((ref (tn-reads tn
) (tn-ref-next ref
)))
788 (unless (eq (vop-block (tn-ref-vop ref
)) local
)
789 (barf "~S has references in blocks other than its LOCAL block."
791 (do ((ref (tn-writes tn
) (tn-ref-next ref
)))
793 (unless (eq (vop-block (tn-ref-vop ref
)) local
)
794 (barf "~S has references in blocks other than its LOCAL block."
798 (defun check-block-conflicts (component)
799 (do-ir2-blocks (block component
)
800 (do ((conf (ir2-block-global-tns block
)
801 (global-conflicts-next-blockwise conf
))
805 (unless (> (tn-number (global-conflicts-tn conf
))
806 (tn-number (global-conflicts-tn prev
)))
807 (barf "~S and ~S out of order in ~S" prev conf block
)))
809 (unless (find-in #'global-conflicts-next-tnwise
812 (global-conflicts-tn conf
)))
813 (barf "~S missing from global conflicts of its TN" conf
)))
815 (let ((map (ir2-block-local-tns block
)))
816 (dotimes (i (ir2-block-local-tn-count block
))
817 (let ((tn (svref map i
)))
818 (unless (or (eq tn
:more
)
820 (tn-global-conflicts tn
)
821 (eq (tn-local tn
) block
))
822 (barf "strange TN ~S in LTN map for ~S" tn block
)))))))
824 ;;; All TNs live at the beginning of an environment must be passing
825 ;;; locations associated with that environment. We make an exception
826 ;;; for wired TNs in XEP functions, since we randomly reference wired
827 ;;; TNs to access the full call passing locations.
828 (defun check-environment-lifetimes (component)
829 (dolist (fun (component-lambdas component
))
830 (let* ((env (lambda-physenv fun
))
831 (2env (physenv-info env
))
832 (vars (lambda-vars fun
))
833 (closure (ir2-physenv-closure 2env
))
834 (pc (ir2-physenv-return-pc-pass 2env
))
835 (fp (ir2-physenv-old-fp 2env
))
836 (2block (block-info (lambda-block (physenv-lambda env
)))))
837 (do ((conf (ir2-block-global-tns 2block
)
838 (global-conflicts-next-blockwise conf
)))
840 (let ((tn (global-conflicts-tn conf
)))
841 (unless (or (eq (global-conflicts-kind conf
) :write
)
844 (and (xep-p fun
) (tn-offset tn
))
845 (member (tn-kind tn
) '(:environment
:debug-environment
))
846 (member tn vars
:key
#'leaf-info
)
847 (member tn closure
:key
#'cdr
))
848 (barf "strange TN live at head of ~S: ~S" env tn
))))))
851 ;;; Check for some basic sanity in the TN conflict data structures,
852 ;;; and also check that no TNs are unexpectedly live at environment
854 (defun check-life-consistency (component)
855 (check-tn-conflicts component
)
856 (check-block-conflicts component
)
857 (check-environment-lifetimes component
))
859 ;;;; pack consistency checking
861 (defun check-pack-consistency (component)
862 (flet ((check (scs ops
)
863 (do ((scs scs
(cdr scs
))
864 (op ops
(tn-ref-across op
)))
866 (let ((load-tn (tn-ref-load-tn op
)))
867 (unless (eq (svref (car scs
)
870 (or load-tn
(tn-ref-tn op
)))))
872 (barf "operand restriction not satisfied: ~S" op
))))))
873 (do-ir2-blocks (block component
)
874 (do ((vop (ir2-block-last-vop block
) (vop-prev vop
)))
876 (let ((info (vop-info vop
)))
877 (check (vop-info-result-load-scs info
) (vop-results vop
))
878 (check (vop-info-arg-load-scs info
) (vop-args vop
))))))
881 ;;;; data structure dumping routines
883 ;;; When we print CONTINUATIONs and TNs, we assign them small numeric
884 ;;; IDs so that we can get a handle on anonymous objects given a
888 ;;; * Perhaps this machinery should be #!+SB-SHOW.
889 ;;; * Probably the hash tables should either be weak hash tables,
890 ;;; or only allocated within a single compilation unit. Otherwise
891 ;;; there will be a tendency for them to grow without bound and
892 ;;; keep garbage from being collected.
893 (macrolet ((def (counter vto vfrom fto ffrom
)
895 (defvar ,vto
(make-hash-table :test
'eq
))
896 (defvar ,vfrom
(make-hash-table :test
'eql
))
897 (proclaim '(hash-table ,vto
,vfrom
))
899 (proclaim '(fixnum ,counter
))
903 (let ((num (incf ,counter
)))
904 (setf (gethash num
,vfrom
) x
)
905 (setf (gethash x
,vto
) num
))))
908 (values (gethash num
,vfrom
))))))
909 (def *continuation-number
* *continuation-numbers
* *number-continuations
*
911 (def *tn-id
* *tn-ids
* *id-tns
* tn-id id-tn
)
912 (def *label-id
* *id-labels
* *label-ids
* label-id id-label
))
914 ;;; Print a terse one-line description of LEAF.
915 (defun print-leaf (leaf &optional
(stream *standard-output
*))
916 (declare (type leaf leaf
) (type stream stream
))
918 (lambda-var (prin1 (leaf-debug-name leaf
) stream
))
919 (constant (format stream
"'~S" (constant-value leaf
)))
921 (format stream
"~S {~A}" (leaf-debug-name leaf
) (global-var-kind leaf
)))
923 (format stream
"~S ~S" (type-of leaf
) (functional-debug-name leaf
)))))
925 ;;; Attempt to find a block given some thing that has to do with it.
926 (declaim (ftype (function (t) cblock
) block-or-lose
))
927 (defun block-or-lose (thing)
930 (ir2-block (ir2-block-block thing
))
931 (vop (block-or-lose (vop-block thing
)))
932 (tn-ref (block-or-lose (tn-ref-vop thing
)))
933 (continuation (continuation-block thing
))
934 (node (node-block thing
))
935 (component (component-head thing
))
936 #|
(cloop (loop-head thing
))|
#
937 (integer (continuation-block (num-cont thing
)))
938 (functional (lambda-block (main-entry thing
)))
939 (null (error "Bad thing: ~S." thing
))
940 (symbol (block-or-lose (gethash thing
*free-funs
*)))))
943 (defun print-continuation (cont)
944 (declare (type continuation cont
))
945 (format t
" c~D" (cont-num cont
))
948 ;;; Print out the nodes in BLOCK in a format oriented toward
949 ;;; representing what the code does.
950 (defun print-nodes (block)
951 (setq block
(block-or-lose block
))
952 (pprint-logical-block (nil nil
)
953 (format t
"~:@_IR1 block ~D start c~D"
954 (block-number block
) (cont-num (block-start block
)))
956 (let ((last (block-last block
)))
957 (pprint-newline :mandatory
)
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 (fun-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>"))))))
998 (pprint-newline :mandatory
)
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 the guts of a TN. (logic shared between PRINT-OBJECT (TN T)
1007 ;;; and printers for compound objects which contain TNs)
1008 (defun print-tn-guts (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
) #\
< #\
>))
1033 (print-tn-guts ltn
)))
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
))))
1055 (pprint-newline :mandatory
))
1057 ;;; Print the VOPs in the specified IR2 block.
1058 (defun print-ir2-block (block)
1059 (declare (type ir2-block block
))
1060 (pprint-logical-block (*standard-output
* nil
)
1062 ((eq (block-info (ir2-block-block block
)) block
)
1063 (format t
"~:@_IR2 block ~D start c~D~:@_"
1064 (ir2-block-number block
)
1065 (cont-num (block-start (ir2-block-block block
))))
1066 (let ((label (ir2-block-%label block
)))
1068 (format t
"L~D:~:@_" (label-id label
)))))
1070 (format t
"<overflow>~:@_")))
1072 (do ((vop (ir2-block-start-vop block
)
1074 (number 0 (1+ number
)))
1076 (format t
"~W: " number
)
1079 ;;; This is like PRINT-NODES, but dumps the IR2 representation of the
1081 (defun print-vops (block)
1082 (setq block
(block-or-lose block
))
1083 (let ((2block (block-info block
)))
1084 (print-ir2-block 2block
)
1085 (do ((b (ir2-block-next 2block
) (ir2-block-next b
)))
1086 ((not (eq (ir2-block-block b
) block
)))
1087 (print-ir2-block b
)))
1090 ;;; Scan the IR2 blocks in emission order.
1091 (defun print-ir2-blocks (thing &optional full
)
1092 (let* ((block (component-head (block-component (block-or-lose thing
))))
1093 (2block (block-info block
)))
1094 (pprint-logical-block (nil nil
)
1096 do
(setq block
(ir2-block-block 2block
))
1097 do
(pprint-logical-block (*standard-output
* nil
)
1100 (format t
"IR1 block ~D start c~D"
1101 (block-number block
)
1102 (cont-num (block-start block
))))
1103 (pprint-indent :block
4)
1104 (pprint-newline :mandatory
)
1105 (loop while
(and 2block
(eq (ir2-block-block 2block
) block
))
1106 do
(print-ir2-block 2block
)
1107 do
(setq 2block
(ir2-block-next 2block
))))
1108 do
(pprint-newline :mandatory
))))
1111 ;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by
1112 ;;; successor links.
1113 (defun print-blocks (block)
1114 (setq block
(block-or-lose block
))
1115 (do-blocks (block (block-component block
) :both
)
1116 (setf (block-flag block
) nil
))
1117 (labels ((walk (block)
1118 (unless (block-flag block
)
1119 (setf (block-flag block
) t
)
1120 (when (block-start block
)
1121 (print-nodes block
))
1122 (dolist (block (block-succ block
))
1127 ;;; Print all blocks in BLOCK's component in DFO.
1128 (defun print-all-blocks (thing)
1129 (do-blocks (block (block-component (block-or-lose thing
)))
1130 (handler-case (print-nodes block
)
1132 (format t
"~&~A...~%" condition
))))
1135 (defvar *list-conflicts-table
* (make-hash-table :test
'eq
))
1137 ;;; Add all ALWAYS-LIVE TNs in Block to the conflicts. TN is ignored when
1138 ;;; it appears in the global conflicts.
1139 (defun add-always-live-tns (block tn
)
1140 (declare (type ir2-block block
) (type tn tn
))
1141 (do ((conf (ir2-block-global-tns block
)
1142 (global-conflicts-next-blockwise conf
)))
1144 (when (eq (global-conflicts-kind conf
) :live
)
1145 (let ((btn (global-conflicts-tn conf
)))
1147 (setf (gethash btn
*list-conflicts-table
*) t
)))))
1150 ;;; Add all local TNs in block to the conflicts.
1151 (defun add-all-local-tns (block)
1152 (declare (type ir2-block block
))
1153 (let ((ltns (ir2-block-local-tns block
)))
1154 (dotimes (i (ir2-block-local-tn-count block
))
1155 (setf (gethash (svref ltns i
) *list-conflicts-table
*) t
)))
1158 ;;; Make a list out of all of the recorded conflicts.
1159 (defun listify-conflicts-table ()
1161 (maphash (lambda (k v
)
1162 (declare (ignore v
))
1165 *list-conflicts-table
*)
1166 (clrhash *list-conflicts-table
*)
1169 ;;; Return a list of a the TNs that conflict with TN. Sort of, kind
1170 ;;; of. For debugging use only. Probably doesn't work on :COMPONENT TNs.
1171 (defun list-conflicts (tn)
1172 (aver (member (tn-kind tn
) '(:normal
:environment
:debug-environment
)))
1173 (let ((confs (tn-global-conflicts tn
)))
1175 (clrhash *list-conflicts-table
*)
1176 (do ((conf confs
(global-conflicts-next-tnwise conf
)))
1178 (format t
"~&#<block ~D kind ~S>~%"
1179 (block-number (ir2-block-block (global-conflicts-block conf
)))
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
)))