src/compiler/debug.lisp

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