src/compiler/life.lisp

   1 ;;;; This file contains the lifetime analysis phase in the compiler.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13 \f
  14 ;;;; utilities
  15
  16 ;;; Link in a GLOBAL-CONFLICTS structure for TN in BLOCK with NUMBER
  17 ;;; as the LTN number. The conflict is inserted in the per-TN
  18 ;;; GLOBAL-CONFLICTS thread after the TN's CURRENT-CONFLICT. We change
  19 ;;; the CURRENT-CONFLICT to point to the new conflict. Since we scan
  20 ;;; the blocks in reverse DFO, this list is automatically built in
  21 ;;; order. We have to actually scan the current GLOBAL-TNs for the
  22 ;;; block in order to keep that thread sorted.
  23 (defun add-global-conflict (kind tn block number)
  24   (declare (type (member :read :write :read-only :live) kind)
  25            (type tn tn) (type ir2-block block)
  26            (type (or local-tn-number null) number))
  27   (let ((new (make-global-conflicts kind tn block number)))
  28     (let ((last (tn-current-conflict tn)))
  29       (if last
  30           (shiftf (global-conflicts-next-tnwise new)
  31                   (global-conflicts-next-tnwise last)
  32                   new)
  33           (shiftf (global-conflicts-next-tnwise new)
  34                   (tn-global-conflicts tn)
  35                   new)))
  36     (setf (tn-current-conflict tn) new)
  37
  38     (insert-block-global-conflict new block))
  39   (values))
  40
  41 ;;; Do the actual insertion of the conflict NEW into BLOCK's global
  42 ;;; conflicts.
  43 (defun insert-block-global-conflict (new block)
  44   (let ((global-num (tn-number (global-conflicts-tn new))))
  45     (do ((prev nil conf)
  46          (conf (ir2-block-global-tns block)
  47                (global-conflicts-next-blockwise conf)))
  48         ((or (null conf)
  49              (> (tn-number (global-conflicts-tn conf)) global-num))
  50          (if prev
  51              (setf (global-conflicts-next-blockwise prev) new)
  52              (setf (ir2-block-global-tns block) new))
  53          (setf (global-conflicts-next-blockwise new) conf))))
  54   (values))
  55
  56 ;;; Reset the CURRENT-CONFLICT slot in all packed TNs to point to the
  57 ;;; head of the GLOBAL-CONFLICTS thread.
  58 (defun reset-current-conflict (component)
  59   (do-packed-tns (tn component)
  60     (setf (tn-current-conflict tn) (tn-global-conflicts tn))))
  61
  62 ;;; Cache the results of BLOCK-PHYSENV during lifetime analysis.
  63 ;;;
  64 ;;; Fetching the home-lambda of a block (needed in block-physenv) can
  65 ;;; be an expensive operation under some circumstances, and it needs
  66 ;;; to be done a lot during lifetime analysis when compiling with high
  67 ;;; DEBUG (e.g. 30% of the total compilation time for CL-PPCRE with
  68 ;;; DEBUG 3 just for that).
  69 (defun cached-block-physenv (block)
  70   (let ((physenv (block-physenv-cache block)))
  71     (if (eq physenv :none)
  72         (setf (block-physenv-cache block)
  73               (block-physenv block))
  74         physenv)))
  75 \f
  76 ;;;; pre-pass
  77
  78 ;;; Convert TN (currently local) to be a global TN, since we
  79 ;;; discovered that it is referenced in more than one block. We just
  80 ;;; add a global-conflicts structure with a kind derived from the KILL
  81 ;;; and LIVE sets.
  82 (defun convert-to-global (tn)
  83   (declare (type tn tn))
  84   (let ((block (tn-local tn))
  85         (num (tn-local-number tn)))
  86     (add-global-conflict
  87      (if (zerop (sbit (ir2-block-written block) num))
  88          :read-only
  89          (if (zerop (sbit (ir2-block-live-out block) num))
  90              :write
  91              :read))
  92      tn block num))
  93   (values))
  94
  95 ;;; Scan all references to packed TNs in block. We assign LTN numbers
  96 ;;; to each referenced TN, and also build the Kill and Live sets that
  97 ;;; summarize the references to each TN for purposes of lifetime
  98 ;;; analysis.
  99 ;;;
 100 ;;; It is possible that we will run out of LTN numbers. If this
 101 ;;; happens, then we return the VOP that we were processing at the
 102 ;;; time we ran out, otherwise we return NIL.
 103 ;;;
 104 ;;; If a TN is referenced in more than one block, then we must
 105 ;;; represent references using GLOBAL-CONFLICTS structures. When we
 106 ;;; first see a TN, we assume it will be local. If we see a reference
 107 ;;; later on in a different block, then we go back and fix the TN to
 108 ;;; global.
 109 ;;;
 110 ;;; We must globalize TNs that have a block other than the current one
 111 ;;; in their LOCAL slot and have no GLOBAL-CONFLICTS. The latter
 112 ;;; condition is necessary because we always set Local and
 113 ;;; LOCAL-NUMBER when we process a reference to a TN, even when the TN
 114 ;;; is already known to be global.
 115 ;;;
 116 ;;; When we see reference to global TNs during the scan, we add the
 117 ;;; global-conflict as :READ-ONLY, since we don't know the correct
 118 ;;; kind until we are done scanning the block.
 119 (defun find-local-references (block)
 120   (declare (type ir2-block block))
 121   (let ((kill (ir2-block-written block))
 122         (live (ir2-block-live-out block))
 123         (tns (ir2-block-local-tns block)))
 124     (let ((ltn-num (ir2-block-local-tn-count block)))
 125       (do ((vop (ir2-block-last-vop block)
 126                 (vop-prev vop)))
 127           ((null vop))
 128         (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
 129             ((null ref))
 130           (let* ((tn (tn-ref-tn ref))
 131                  (local (tn-local tn))
 132                  (kind (tn-kind tn)))
 133             (unless (member kind '(:component :environment :constant))
 134               (unless (eq local block)
 135                 (when (= ltn-num local-tn-limit)
 136                   (return-from find-local-references vop))
 137                 (when local
 138                   (unless (tn-global-conflicts tn)
 139                     (convert-to-global tn))
 140                   (add-global-conflict :read-only tn block ltn-num))
 141
 142                 (setf (tn-local tn) block)
 143                 (setf (tn-local-number tn) ltn-num)
 144                 (setf (svref tns ltn-num) tn)
 145                 (incf ltn-num))
 146
 147               (let ((num (tn-local-number tn)))
 148                 (if (tn-ref-write-p ref)
 149                     (setf (sbit kill num) 1  (sbit live num) 0)
 150                     (setf (sbit live num) 1)))))))
 151
 152       (setf (ir2-block-local-tn-count block) ltn-num)))
 153   nil)
 154
 155 ;;; Finish up the global conflicts for TNs referenced in BLOCK
 156 ;;; according to the local Kill and Live sets.
 157 ;;;
 158 ;;; We set the kind for TNs already in the global-TNs. If not written
 159 ;;; at all, then is :READ-ONLY, the default. Must have been referenced
 160 ;;; somehow, or we wouldn't have conflicts for it.
 161 ;;;
 162 ;;; We also iterate over all the local TNs, looking for TNs local to
 163 ;;; this block that are still live at the block beginning, and thus
 164 ;;; must be global. This case is only important when a TN is read in a
 165 ;;; block but not written in any other, since otherwise the write
 166 ;;; would promote the TN to global. But this does happen with various
 167 ;;; passing-location TNs that are magically written. This also serves
 168 ;;; to propagate the lives of erroneously uninitialized TNs so that
 169 ;;; consistency checks can detect them.
 170 (defun init-global-conflict-kind (block)
 171   (declare (type ir2-block block))
 172   (let ((live (ir2-block-live-out block)))
 173     (let ((kill (ir2-block-written block)))
 174       (do ((conf (ir2-block-global-tns block)
 175                  (global-conflicts-next-blockwise conf)))
 176           ((null conf))
 177         (let ((num (global-conflicts-number conf)))
 178           (unless (zerop (sbit kill num))
 179             (setf (global-conflicts-kind conf)
 180                   (if (zerop (sbit live num))
 181                       :write
 182                       :read))))))
 183
 184     (let ((ltns (ir2-block-local-tns block)))
 185       (dotimes (i (ir2-block-local-tn-count block))
 186         (let ((tn (svref ltns i)))
 187           (unless (or (eq tn :more)
 188                       (tn-global-conflicts tn)
 189                       (zerop (sbit live i)))
 190             (convert-to-global tn))))))
 191
 192   (values))
 193
 194 (defevent split-ir2-block "Split an IR2 block to meet LOCAL-TN-LIMIT.")
 195
 196 ;;; Move the code after the VOP LOSE in 2BLOCK into its own block. The
 197 ;;; block is linked into the emit order following 2BLOCK. NUMBER is
 198 ;;; the block number assigned to the new block. We return the new
 199 ;;; block.
 200 (defun split-ir2-blocks (2block lose number)
 201   (declare (type ir2-block 2block) (type vop lose)
 202            (type unsigned-byte number))
 203   (event split-ir2-block (vop-node lose))
 204   (let ((new (make-ir2-block (ir2-block-block 2block)))
 205         (new-start (vop-next lose)))
 206     (setf (ir2-block-number new) number)
 207     (add-to-emit-order new 2block)
 208
 209     (do ((vop new-start (vop-next vop)))
 210         ((null vop))
 211       (setf (vop-block vop) new))
 212
 213     (setf (ir2-block-start-vop new) new-start)
 214     (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose)
 215
 216     (setf (vop-next lose) nil)
 217     (setf (vop-prev new-start) nil)
 218
 219     new))
 220
 221 ;;; Clear the global and local conflict info in BLOCK so that we can
 222 ;;; recompute it without any old cruft being retained. It is assumed
 223 ;;; that all LTN numbers are in use.
 224 ;;;
 225 ;;; First we delete all the global conflicts. The conflict we are
 226 ;;; deleting must be the last in the TN's GLOBAL-CONFLICTS, but we
 227 ;;; must scan for it in order to find the previous conflict.
 228 ;;;
 229 ;;; Next, we scan the local TNs, nulling out the LOCAL slot in all TNs
 230 ;;; with no global conflicts. This allows these TNs to be treated as
 231 ;;; local when we scan the block again.
 232 ;;;
 233 ;;; If there are conflicts, then we set LOCAL to one of the
 234 ;;; conflicting blocks. This ensures that LOCAL doesn't hold over
 235 ;;; BLOCK as its value, causing the subsequent reanalysis to think
 236 ;;; that the TN has already been seen in that block.
 237 ;;;
 238 ;;; This function must not be called on blocks that have :MORE TNs.
 239 (defun clear-lifetime-info (block)
 240   (declare (type ir2-block block))
 241   (setf (ir2-block-local-tn-count block) 0)
 242
 243   (do ((conf (ir2-block-global-tns block)
 244              (global-conflicts-next-blockwise conf)))
 245       ((null conf)
 246        (setf (ir2-block-global-tns block) nil))
 247     (let ((tn (global-conflicts-tn conf)))
 248       (aver (eq (tn-current-conflict tn) conf))
 249       (aver (null (global-conflicts-next-tnwise conf)))
 250       (do ((current (tn-global-conflicts tn)
 251                     (global-conflicts-next-tnwise current))
 252            (prev nil current))
 253           ((eq current conf)
 254            (if prev
 255                (setf (global-conflicts-next-tnwise prev) nil)
 256                (setf (tn-global-conflicts tn) nil))
 257            (setf (tn-current-conflict tn) prev)))))
 258
 259   (fill (ir2-block-written block) 0)
 260   (let ((ltns (ir2-block-local-tns block)))
 261     (dotimes (i local-tn-limit)
 262       (let ((tn (svref ltns i)))
 263         (aver (not (eq tn :more)))
 264         (let ((conf (tn-global-conflicts tn)))
 265           (setf (tn-local tn)
 266                 (if conf
 267                     (global-conflicts-block conf)
 268                     nil))))))
 269
 270   (values))
 271
 272 ;;; This provides a panic mode for assigning LTN numbers when there is
 273 ;;; a VOP with so many more operands that they can't all be assigned
 274 ;;; distinct numbers. When this happens, we recover by assigning all
 275 ;;; the &MORE operands the same LTN number. We can get away with this,
 276 ;;; since all &MORE args (and results) are referenced simultaneously
 277 ;;; as far as conflict analysis is concerned.
 278 ;;;
 279 ;;; BLOCK is the IR2-BLOCK that the MORE VOP is at the end of. OPS is
 280 ;;; the full argument or result TN-REF list. Fixed is the types of the
 281 ;;; fixed operands (used only to skip those operands.)
 282 ;;;
 283 ;;; What we do is grab a LTN number, then make a :READ-ONLY global
 284 ;;; conflict for each more operand TN. We require that there be no
 285 ;;; existing global conflict in BLOCK for any of the operands. Since
 286 ;;; conflicts must be cleared before the first call, this only
 287 ;;; prohibits the same TN being used both as a more operand and as any
 288 ;;; other operand to the same VOP.
 289 ;;;
 290 ;;; We don't have to worry about getting the correct conflict kind,
 291 ;;; since INIT-GLOBAL-CONFLICT-KIND will fix things up. Similarly,
 292 ;;; FIND-LOCAL-REFERENCES will set the local conflict bit
 293 ;;; corresponding to this call.
 294 ;;;
 295 ;;; We also set the LOCAL and LOCAL-NUMBER slots in each TN. It is
 296 ;;; possible that there are no operands in any given call to this
 297 ;;; function, but there had better be either some more args or more
 298 ;;; results.
 299 (defun coalesce-more-ltn-numbers (block ops fixed)
 300   (declare (type ir2-block block) (type (or tn-ref null) ops) (list fixed))
 301   (let ((num (ir2-block-local-tn-count block)))
 302     (aver (< num local-tn-limit))
 303     (incf (ir2-block-local-tn-count block))
 304     (setf (svref (ir2-block-local-tns block) num) :more)
 305
 306     (do ((op (do ((op ops (tn-ref-across op))
 307                   (i 0 (1+ i)))
 308                  ((= i (length fixed)) op)
 309                (declare (type index i)))
 310              (tn-ref-across op)))
 311         ((null op))
 312       (let ((tn (tn-ref-tn op)))
 313         (assert
 314           (flet ((frob (refs)
 315                    (do ((ref refs (tn-ref-next ref)))
 316                        ((null ref) t)
 317                      (when (and (eq (vop-block (tn-ref-vop ref)) block)
 318                                 (not (eq ref op)))
 319                        (return nil)))))
 320             (and (frob (tn-reads tn)) (frob (tn-writes tn))))
 321           () "More operand ~S used more than once in its VOP." op)
 322         (aver (not (find-in #'global-conflicts-next-blockwise tn
 323                             (ir2-block-global-tns block)
 324                             :key #'global-conflicts-tn)))
 325
 326         (add-global-conflict :read-only tn block num)
 327         (setf (tn-local tn) block)
 328         (setf (tn-local-number tn) num))))
 329   (values))
 330
 331 (defevent coalesce-more-ltn-numbers
 332   "Coalesced LTN numbers for a more operand to meet LOCAL-TN-LIMIT.")
 333
 334 ;;; Loop over the blocks in COMPONENT, assigning LTN numbers and
 335 ;;; recording TN birth and death. The only interesting action is when
 336 ;;; we run out of local TN numbers while finding local references.
 337 ;;;
 338 ;;; If we run out of LTN numbers while processing a VOP within the
 339 ;;; block, then we just split off the VOPs we have successfully
 340 ;;; processed into their own block.
 341 ;;;
 342 ;;; If we run out of LTN numbers while processing the our first VOP
 343 ;;; (the last in the block), then it must be the case that this VOP
 344 ;;; has large more operands. We split the VOP into its own block, and
 345 ;;; then call COALESCE-MORE-LTN-NUMBERS to assign all the more
 346 ;;; args/results the same LTN number(s).
 347 ;;;
 348 ;;; In either case, we clear the lifetime information that we computed
 349 ;;; so far, recomputing it after taking corrective action.
 350 ;;;
 351 ;;; Whenever we split a block, we finish the pre-pass on the split-off
 352 ;;; block by doing FIND-LOCAL-REFERENCES and
 353 ;;; INIT-GLOBAL-CONFLICT-KIND. This can't run out of LTN numbers.
 354 (defun lifetime-pre-pass (component)
 355   (declare (type component component))
 356   (let ((counter -1))
 357     (declare (type fixnum counter))
 358     (do-blocks-backwards (block component)
 359       (let ((2block (block-info block)))
 360         (do ((lose (find-local-references 2block)
 361                    (find-local-references 2block))
 362              (last-lose nil lose)
 363              (coalesced nil))
 364             ((not lose)
 365              (init-global-conflict-kind 2block)
 366              (setf (ir2-block-number 2block) (incf counter)))
 367
 368           (clear-lifetime-info 2block)
 369
 370           (cond
 371            ((vop-next lose)
 372             (aver (not (eq last-lose lose)))
 373             (let ((new (split-ir2-blocks 2block lose (incf counter))))
 374               (aver (not (find-local-references new)))
 375               (init-global-conflict-kind new)))
 376            (t
 377             (aver (not (eq lose coalesced)))
 378             (setq coalesced lose)
 379             (event coalesce-more-ltn-numbers (vop-node lose))
 380             (let ((info (vop-info lose))
 381                   (new (if (vop-prev lose)
 382                            (split-ir2-blocks 2block (vop-prev lose)
 383                                              (incf counter))
 384                            2block)))
 385               (coalesce-more-ltn-numbers new (vop-args lose)
 386                                          (vop-info-arg-types info))
 387               (coalesce-more-ltn-numbers new (vop-results lose)
 388                                          (vop-info-result-types info))
 389               (let ((lose (find-local-references new)))
 390                 (aver (not lose)))
 391               (init-global-conflict-kind new))))))))
 392
 393   (values))
 394 \f
 395 ;;;; environment TN stuff
 396
 397 ;;; Add a :LIVE global conflict for TN in 2BLOCK if there is none
 398 ;;; present. If DEBUG-P is false (a :ENVIRONMENT TN), then modify any
 399 ;;; existing conflict to be :LIVE.
 400 (defun setup-environment-tn-conflict (tn 2block debug-p)
 401   (declare (type tn tn) (type ir2-block 2block))
 402   (let ((block-num (ir2-block-number 2block)))
 403     (do ((conf (tn-current-conflict tn) (global-conflicts-next-tnwise conf))
 404          (prev nil conf))
 405         ((or (null conf)
 406              (> (ir2-block-number (global-conflicts-block conf)) block-num))
 407          (setf (tn-current-conflict tn) prev)
 408          (add-global-conflict :live tn 2block nil))
 409       (when (eq (global-conflicts-block conf) 2block)
 410         (unless (or debug-p
 411                     (eq (global-conflicts-kind conf) :live))
 412           (setf (global-conflicts-kind conf) :live)
 413           (setf (svref (ir2-block-local-tns 2block)
 414                        (global-conflicts-number conf))
 415                 nil)
 416           (setf (global-conflicts-number conf) nil))
 417         (setf (tn-current-conflict tn) conf)
 418         (return))))
 419   (values))
 420
 421 ;;; Return true if TN represents a closed-over variable with an
 422 ;;; "implicit" value-cell.
 423 (defun implicit-value-cell-tn-p (tn)
 424   (let ((leaf (tn-leaf tn)))
 425     (and (lambda-var-p leaf)
 426          (lambda-var-indirect leaf)
 427          (not (lambda-var-explicit-value-cell leaf)))))
 428
 429 ;;; If BLOCK ends with a TAIL LOCAL COMBINATION, the function called.
 430 ;;; Otherwise, NIL.
 431 (defun block-tail-local-call-fun (block)
 432   (let ((node (block-last block)))
 433     (when (and (combination-p node)
 434                (eq :local (combination-kind node))
 435                (combination-tail-p node))
 436       (ref-leaf (lvar-uses (combination-fun node))))))
 437
 438 ;;; Iterate over all the blocks in ENV, setting up :LIVE conflicts for
 439 ;;; TN. We make the TN global if it isn't already. The TN must have at
 440 ;;; least one reference.
 441 (defun setup-environment-tn-conflicts (component tn env debug-p &optional parent-envs)
 442   (declare (type component component) (type tn tn) (type physenv env) (type list parent-envs))
 443   (when (member env parent-envs)
 444     ;; Prevent infinite recursion due to recursive tail calls.
 445     (return-from setup-environment-tn-conflicts (values)))
 446   (when (and debug-p
 447              (not (tn-global-conflicts tn))
 448              (tn-local tn))
 449     (convert-to-global tn))
 450   (setf (tn-current-conflict tn) (tn-global-conflicts tn))
 451   (do-blocks-backwards (block component)
 452     (when (eq (cached-block-physenv block) env)
 453       (let* ((2block (block-info block))
 454              (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
 455                         (prev 2block b))
 456                        ((not (eq (ir2-block-block b) block))
 457                         prev))))
 458         (do ((b last (ir2-block-prev b)))
 459             ((not (eq (ir2-block-block b) block)))
 460           (setup-environment-tn-conflict tn b debug-p)))
 461       ;; If BLOCK ends with a TAIL LOCAL COMBINATION and TN is an
 462       ;; "implicit value cell" then setup conflicts for the callee
 463       ;; function as well.
 464       (let ((fun (and (implicit-value-cell-tn-p tn)
 465                       (block-tail-local-call-fun block))))
 466         (when fun
 467           (setup-environment-tn-conflicts component tn (lambda-physenv fun) debug-p
 468                                           (list* env parent-envs))))))
 469   (values))
 470
 471 ;;; Iterate over all the environment TNs, adding always-live conflicts
 472 ;;; as appropriate.
 473 (defun setup-environment-live-conflicts (component)
 474   (declare (type component component))
 475   (dolist (fun (component-lambdas component))
 476     (let* ((env (lambda-physenv fun))
 477            (2env (physenv-info env)))
 478       (dolist (tn (ir2-physenv-live-tns 2env))
 479         (setup-environment-tn-conflicts component tn env nil))
 480       (dolist (tn (ir2-physenv-debug-live-tns 2env))
 481         (setup-environment-tn-conflicts component tn env t))))
 482   (values))
 483
 484 ;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN.
 485 ;;; This requires adding :LIVE conflicts to all blocks in TN-PHYSENV.
 486 (defun convert-to-environment-tn (tn tn-physenv)
 487   (declare (type tn tn) (type physenv tn-physenv))
 488   (aver (member (tn-kind tn) '(:normal :debug-environment)))
 489   (ecase (tn-kind tn)
 490     (:debug-environment
 491      (setq tn-physenv (tn-physenv tn))
 492      (let* ((2env (physenv-info tn-physenv)))
 493        (setf (ir2-physenv-debug-live-tns 2env)
 494              (delete tn (ir2-physenv-debug-live-tns 2env)))))
 495     (:normal
 496      (setf (tn-local tn) nil)
 497      (setf (tn-local-number tn) nil)))
 498   (setup-environment-tn-conflicts *component-being-compiled* tn tn-physenv nil)
 499   (setf (tn-kind tn) :environment)
 500   (setf (tn-physenv tn) tn-physenv)
 501   (push tn (ir2-physenv-live-tns (physenv-info tn-physenv)))
 502   (values))
 503 \f
 504 ;;;; flow analysis
 505
 506 ;;; For each GLOBAL-TN in BLOCK2 that is :LIVE, :READ or :READ-ONLY,
 507 ;;; ensure that there is a corresponding GLOBAL-CONFLICT in BLOCK1. If
 508 ;;; there is none, make a :LIVE GLOBAL-CONFLICT. If there is a
 509 ;;; :READ-ONLY conflict, promote it to :LIVE.
 510 ;;;
 511 ;;; If we did add a new conflict, return true, otherwise false. We
 512 ;;; don't need to return true when we promote a :READ-ONLY conflict,
 513 ;;; since it doesn't reveal any new information to predecessors of
 514 ;;; BLOCK1.
 515 ;;;
 516 ;;; We use the TN-CURRENT-CONFLICT to walk through the global
 517 ;;; conflicts. Since the global conflicts for a TN are ordered by
 518 ;;; block, we can be sure that the CURRENT-CONFLICT always points at
 519 ;;; or before the block that we are looking at. This allows us to
 520 ;;; quickly determine if there is a global conflict for a given TN in
 521 ;;; BLOCK1.
 522 ;;;
 523 ;;; When we scan down the conflicts, we know that there must be at
 524 ;;; least one conflict for TN, since we got our hands on TN by picking
 525 ;;; it out of a conflict in BLOCK2.
 526 ;;;
 527 ;;; We leave the CURRENT-CONFLICT pointing to the conflict for BLOCK1.
 528 ;;; The CURRENT-CONFLICT must be initialized to the head of the
 529 ;;; GLOBAL-CONFLICTS for the TN between each flow analysis iteration.
 530
 531 ;;; FASTP is a KLUDGE: SBCL used to update the current-conflict only
 532 ;;; for the read-only case, but switched at one point to always
 533 ;;; updating it. This generally speeds up the compiler nicely, but
 534 ;;; sometimes it causes an infinite loop in the updating machinery,
 535 ;;; We cheat by switching of the fast path if it seems we're looping
 536 ;;; longer then expected.
 537 (defun propagate-live-tns (block1 block2 fastp)
 538   (declare (type ir2-block block1 block2))
 539   (let ((live-in (ir2-block-live-in block1))
 540         (did-something nil))
 541     (do ((conf2 (ir2-block-global-tns block2)
 542                 (global-conflicts-next-blockwise conf2)))
 543         ((null conf2))
 544       (ecase (global-conflicts-kind conf2)
 545         ((:live :read :read-only)
 546          (let* ((tn (global-conflicts-tn conf2))
 547                 (tn-conflicts (tn-current-conflict tn))
 548                 (number1 (ir2-block-number block1)))
 549            (aver tn-conflicts)
 550            (do ((current tn-conflicts (global-conflicts-next-tnwise current))
 551                 (prev nil current))
 552                ((or (null current)
 553                     (> (ir2-block-number (global-conflicts-block current))
 554                        number1))
 555                 (setf (tn-current-conflict tn) prev)
 556                 (add-global-conflict :live tn block1 nil)
 557                 (setq did-something t))
 558              (when (eq (global-conflicts-block current) block1)
 559                (case (global-conflicts-kind current)
 560                  (:live)
 561                  (:read-only
 562                   (setf (global-conflicts-kind current) :live)
 563                   (setf (svref (ir2-block-local-tns block1)
 564                                (global-conflicts-number current))
 565                         nil)
 566                   (setf (global-conflicts-number current) nil)
 567                   (unless fastp
 568                     (setf (tn-current-conflict tn) current)))
 569                  (t
 570                   (setf (sbit live-in (global-conflicts-number current)) 1)))
 571                (when fastp
 572                  (setf (tn-current-conflict tn) current))
 573                (return)))))
 574         (:write)))
 575     did-something))
 576
 577 ;;; Do backward global flow analysis to find all TNs live at each
 578 ;;; block boundary.
 579 (defun lifetime-flow-analysis (component)
 580   ;; KLUDGE: This is the second part of the FASTP kludge in
 581   ;; propagate-live-tns: we pass fastp for ten first attempts,
 582   ;; and then switch to the works-for-sure version.
 583   ;;
 584   ;; The upstream uses the fast version always, but sometimes
 585   ;; that gets stuck in a loop...
 586   (loop for i = 0 then (1+ i)
 587         do
 588     (reset-current-conflict component)
 589     (let ((did-something nil))
 590       (do-blocks-backwards (block component)
 591         (let* ((2block (block-info block))
 592                (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
 593                           (prev 2block b))
 594                          ((not (eq (ir2-block-block b) block))
 595                           prev))))
 596
 597           (dolist (b (block-succ block))
 598             (when (and (block-start b)
 599                        (propagate-live-tns last (block-info b) (< i 10)))
 600               (setq did-something t)))
 601
 602           (do ((b (ir2-block-prev last) (ir2-block-prev b))
 603                (prev last b))
 604               ((not (eq (ir2-block-block b) block)))
 605             (when (propagate-live-tns b prev (< i 10))
 606               (setq did-something t)))))
 607
 608       (unless did-something (return))))
 609
 610   (values))
 611 \f
 612 ;;;; post-pass
 613
 614 ;;; Note that TN conflicts with all current live TNs. NUM is TN's LTN
 615 ;;; number. We bit-ior LIVE-BITS with TN's LOCAL-CONFLICTS, and set TN's
 616 ;;; number in the conflicts of all TNs in LIVE-LIST.
 617 (defun note-conflicts (live-bits live-list tn num)
 618   (declare (type tn tn) (type (or tn null) live-list)
 619            (type local-tn-bit-vector live-bits)
 620            (type local-tn-number num))
 621   (let ((lconf (tn-local-conflicts tn)))
 622     (bit-ior live-bits lconf lconf))
 623   (do ((live live-list (tn-next* live)))
 624       ((null live))
 625     (setf (sbit (tn-local-conflicts live) num) 1))
 626   (values))
 627
 628 ;;; Compute a bit vector of the TNs live after VOP that aren't results.
 629 (defun compute-save-set (vop live-bits)
 630   (declare (type vop vop) (type local-tn-bit-vector live-bits))
 631   (let ((live (bit-vector-copy live-bits)))
 632     (do ((r (vop-results vop) (tn-ref-across r)))
 633         ((null r))
 634       (let ((tn (tn-ref-tn r)))
 635         (ecase (tn-kind tn)
 636           ((:normal :debug-environment)
 637            (setf (sbit live (tn-local-number tn)) 0))
 638           (:environment :component))))
 639     live))
 640
 641 ;;; This is used to determine whether a :DEBUG-ENVIRONMENT TN should
 642 ;;; be considered live at block end. We return true if a VOP with
 643 ;;; non-null SAVE-P appears before the first read of TN (hence is seen
 644 ;;; first in our backward scan.)
 645 (defun saved-after-read (tn block)
 646   (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
 647       ((null vop) t)
 648     (when (vop-info-save-p (vop-info vop)) (return t))
 649     (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
 650       (return nil))))
 651
 652 ;;; If the block has no successors, or its successor is the component
 653 ;;; tail, then all :DEBUG-ENVIRONMENT TNs are always added, regardless
 654 ;;; of whether they appeared to be live. This ensures that these TNs
 655 ;;; are considered to be live throughout blocks that read them, but
 656 ;;; don't have any interesting successors (such as a return or tail
 657 ;;; call.) In this case, we set the corresponding bit in LIVE-IN as
 658 ;;; well.
 659 (defun make-debug-environment-tns-live (block live-bits live-list)
 660   (let* ((1block (ir2-block-block block))
 661          (live-in (ir2-block-live-in block))
 662          (succ (block-succ 1block))
 663          (next (ir2-block-next block)))
 664     (when (and next
 665                (not (eq (ir2-block-block next) 1block))
 666                (or (null succ)
 667                    (eq (first succ)
 668                        (component-tail (block-component 1block)))))
 669       (do ((conf (ir2-block-global-tns block)
 670                  (global-conflicts-next-blockwise conf)))
 671           ((null conf))
 672         (let* ((tn (global-conflicts-tn conf))
 673                (num (global-conflicts-number conf)))
 674           (when (and num (zerop (sbit live-bits num))
 675                      (eq (tn-kind tn) :debug-environment)
 676                      (eq (tn-physenv tn) (cached-block-physenv 1block))
 677                      (saved-after-read tn block))
 678             (note-conflicts live-bits live-list tn num)
 679             (setf (sbit live-bits num) 1)
 680             (push-in tn-next* tn live-list)
 681             (setf (sbit live-in num) 1))))))
 682
 683   (values live-bits live-list))
 684
 685 ;;; Return as values, a LTN bit-vector and a list (threaded by
 686 ;;; TN-NEXT*) representing the TNs live at the end of BLOCK (exclusive
 687 ;;; of :LIVE TNs).
 688 ;;;
 689 ;;; We iterate over the TNs in the global conflicts that are live at
 690 ;;; the block end, setting up the TN-LOCAL-CONFLICTS and
 691 ;;; TN-LOCAL-NUMBER, and adding the TN to the live list.
 692 ;;;
 693 ;;; If a :MORE result is not live, we effectively fake a read to it.
 694 ;;; This is part of the action described in ENSURE-RESULTS-LIVE.
 695 ;;;
 696 ;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
 697 ;;; environment TNs appear live when appropriate, even when they
 698 ;;; aren't.
 699 ;;;
 700 ;;; ### Note: we alias the global-conflicts-conflicts here as the
 701 ;;; tn-local-conflicts.
 702 (defun compute-initial-conflicts (block)
 703   (declare (type ir2-block block))
 704   (let* ((live-in (ir2-block-live-in block))
 705          (ltns (ir2-block-local-tns block))
 706          (live-bits (bit-vector-copy live-in))
 707          (live-list nil))
 708
 709     (do ((conf (ir2-block-global-tns block)
 710                (global-conflicts-next-blockwise conf)))
 711         ((null conf))
 712       (let ((bits (global-conflicts-conflicts conf))
 713             (tn (global-conflicts-tn conf))
 714             (num (global-conflicts-number conf))
 715             (kind (global-conflicts-kind conf)))
 716         (setf (tn-local-number tn) num)
 717         (unless (eq kind :live)
 718           (cond ((not (zerop (sbit live-bits num)))
 719                  (bit-vector-replace bits live-bits)
 720                  (setf (sbit bits num) 0)
 721                  (push-in tn-next* tn live-list))
 722                 ((and (eq (svref ltns num) :more)
 723                       (eq kind :write))
 724                  (note-conflicts live-bits live-list tn num)
 725                  (setf (sbit live-bits num) 1)
 726                  (push-in tn-next* tn live-list)
 727                  (setf (sbit live-in num) 1)))
 728
 729           (setf (tn-local-conflicts tn) bits))))
 730
 731     (make-debug-environment-tns-live block live-bits live-list)))
 732
 733 ;;; A function called in CONFLICT-ANALYZE-1-BLOCK when we have a VOP
 734 ;;; with SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK,
 735 ;;; force all the live TNs to be stack environment TNs.
 736 (defun conflictize-save-p-vop (vop block live-bits)
 737   (declare (type vop vop) (type ir2-block block)
 738            (type local-tn-bit-vector live-bits))
 739   (let ((ss (compute-save-set vop live-bits)))
 740     (setf (vop-save-set vop) ss)
 741     (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
 742       (do-live-tns (tn ss block)
 743         (unless (eq (tn-kind tn) :component)
 744           (force-tn-to-stack tn)
 745           (unless (eq (tn-kind tn) :environment)
 746             (convert-to-environment-tn
 747              tn
 748              (cached-block-physenv (ir2-block-block block))))))))
 749   (values))
 750
 751 ;;; FIXME: The next 3 macros aren't needed in the target runtime.
 752 ;;; Figure out some way to make them only at build time. (Just
 753 ;;; (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE) (DEFMACRO ..)) isn't good enough,
 754 ;;; since we need CL:DEFMACRO at build-the-cross-compiler time and
 755 ;;; SB!XC:DEFMACRO at run-the-cross-compiler time.)
 756
 757 ;;; This is used in SCAN-VOP-REFS to simultaneously do something to
 758 ;;; all of the TNs referenced by a big more arg. We have to treat
 759 ;;; these TNs specially, since when we set or clear the bit in the
 760 ;;; live TNs, the represents a change in the liveness of all the more
 761 ;;; TNs. If we iterated as normal, the next more ref would be thought
 762 ;;; to be not live when it was, etc. We update Ref to be the last
 763 ;;; :more ref we scanned, so that the main loop will step to the next
 764 ;;; non-more ref.
 765 (defmacro frob-more-tns (action)
 766   `(when (eq (svref ltns num) :more)
 767      (let ((prev ref))
 768        (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
 769            ((null mref))
 770          (let ((mtn (tn-ref-tn mref)))
 771            (unless (eql (tn-local-number mtn) num)
 772              (return))
 773            ,action)
 774          (setq prev mref))
 775        (setq ref prev))))
 776
 777 ;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs
 778 ;;; for the current VOP. This macro shamelessly references free
 779 ;;; variables in C-A-1-B.
 780 (defmacro scan-vop-refs ()
 781   '(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
 782        ((null ref))
 783      (let* ((tn (tn-ref-tn ref))
 784             (num (tn-local-number tn)))
 785        (cond
 786         ((not num))
 787         ((not (zerop (sbit live-bits num)))
 788          (when (tn-ref-write-p ref)
 789            (setf (sbit live-bits num) 0)
 790            (deletef-in tn-next* live-list tn)
 791            (frob-more-tns (deletef-in tn-next* live-list mtn))))
 792         (t
 793          (aver (not (tn-ref-write-p ref)))
 794          (note-conflicts live-bits live-list tn num)
 795          (frob-more-tns (note-conflicts live-bits live-list mtn num))
 796          (setf (sbit live-bits num) 1)
 797          (push-in tn-next* tn live-list)
 798          (frob-more-tns (push-in tn-next* mtn live-list)))))))
 799
 800 ;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the
 801 ;;; current VOP's results, and make any dead ones live. This is
 802 ;;; necessary, since even though a result is dead after the VOP, it
 803 ;;; may be in use for an extended period within the VOP (especially if
 804 ;;; it has :FROM specified.) During this interval, temporaries must be
 805 ;;; noted to conflict with the result. More results are finessed in
 806 ;;; COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
 807 (defmacro ensure-results-live ()
 808   '(do ((res (vop-results vop) (tn-ref-across res)))
 809        ((null res))
 810      (let* ((tn (tn-ref-tn res))
 811             (num (tn-local-number tn)))
 812        (when (and num (zerop (sbit live-bits num)))
 813          (unless (eq (svref ltns num) :more)
 814            (note-conflicts live-bits live-list tn num)
 815            (setf (sbit live-bits num) 1)
 816            (push-in tn-next* tn live-list))))))
 817
 818 ;;; Compute the block-local conflict information for BLOCK. We iterate
 819 ;;; over all the TN-REFs in a block in reference order, maintaining
 820 ;;; the set of live TNs in both a list and a bit-vector
 821 ;;; representation.
 822 (defun conflict-analyze-1-block (block)
 823   (declare (type ir2-block block))
 824   (multiple-value-bind (live-bits live-list)
 825       (compute-initial-conflicts block)
 826     (let ((ltns (ir2-block-local-tns block)))
 827       (do ((vop (ir2-block-last-vop block)
 828                 (vop-prev vop)))
 829           ((null vop))
 830         (when (vop-info-save-p (vop-info vop))
 831           (conflictize-save-p-vop vop block live-bits))
 832         (ensure-results-live)
 833         (scan-vop-refs)))))
 834
 835 ;;; Conflict analyze each block, and also add it.
 836 (defun lifetime-post-pass (component)
 837   (declare (type component component))
 838   (do-ir2-blocks (block component)
 839     (conflict-analyze-1-block block)))
 840 \f
 841 ;;;; alias TN stuff
 842
 843 ;;; Destructively modify OCONF to include the conflict information in CONF.
 844 (defun merge-alias-block-conflicts (conf oconf)
 845   (declare (type global-conflicts conf oconf))
 846   (let* ((kind (global-conflicts-kind conf))
 847          (num (global-conflicts-number conf))
 848          (okind (global-conflicts-kind oconf))
 849          (onum (global-conflicts-number oconf))
 850          (block (global-conflicts-block oconf))
 851          (ltns (ir2-block-local-tns block)))
 852     (cond
 853      ((eq okind :live))
 854      ((eq kind :live)
 855       (setf (global-conflicts-kind oconf) :live)
 856       (setf (svref ltns onum) nil)
 857       (setf (global-conflicts-number oconf) nil))
 858      (t
 859       (unless (eq kind okind)
 860         (setf (global-conflicts-kind oconf) :read))
 861       ;; Make original conflict with all the local TNs the alias
 862       ;; conflicted with.
 863       (bit-ior (global-conflicts-conflicts oconf)
 864                (global-conflicts-conflicts conf)
 865                t)
 866       (flet ((frob (x)
 867                (unless (zerop (sbit x num))
 868                  (setf (sbit x onum) 1))))
 869         ;; Make all the local TNs that conflicted with the alias
 870         ;; conflict with the original.
 871         (dotimes (i (ir2-block-local-tn-count block))
 872           (let ((tn (svref ltns i)))
 873             (when (and tn (not (eq tn :more))
 874                        (null (tn-global-conflicts tn)))
 875               (frob (tn-local-conflicts tn)))))
 876         ;; Same for global TNs...
 877         (do ((current (ir2-block-global-tns block)
 878                       (global-conflicts-next-blockwise current)))
 879             ((null current))
 880           (unless (eq (global-conflicts-kind current) :live)
 881             (frob (global-conflicts-conflicts current))))
 882         ;; Make the original TN live everywhere that the alias was live.
 883         (frob (ir2-block-written block))
 884         (frob (ir2-block-live-in block))
 885         (frob (ir2-block-live-out block))
 886         (do ((vop (ir2-block-start-vop block)
 887                   (vop-next vop)))
 888             ((null vop))
 889           (let ((sset (vop-save-set vop)))
 890             (when sset (frob sset)))))))
 891     ;; Delete the alias's conflict info.
 892     (when num
 893       (setf (svref ltns num) nil))
 894     (deletef-in global-conflicts-next-blockwise
 895                 (ir2-block-global-tns block)
 896                 conf))
 897
 898   (values))
 899
 900 ;;; Co-opt CONF to be a conflict for TN.
 901 (defun change-global-conflicts-tn (conf new)
 902   (declare (type global-conflicts conf) (type tn new))
 903   (setf (global-conflicts-tn conf) new)
 904   (let ((ltn-num (global-conflicts-number conf))
 905         (block (global-conflicts-block conf)))
 906     (deletef-in global-conflicts-next-blockwise
 907                 (ir2-block-global-tns block)
 908                 conf)
 909     (setf (global-conflicts-next-blockwise conf) nil)
 910     (insert-block-global-conflict conf block)
 911     (when ltn-num
 912       (setf (svref (ir2-block-local-tns block) ltn-num) new)))
 913   (values))
 914
 915 ;;; Do CONVERT-TO-GLOBAL on TN if it has no global conflicts. Copy the
 916 ;;; local conflicts into the global bit vector.
 917 (defun ensure-global-tn (tn)
 918   (declare (type tn tn))
 919   (cond ((tn-global-conflicts tn))
 920         ((tn-local tn)
 921          (convert-to-global tn)
 922          (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
 923                   (tn-local-conflicts tn)
 924                   t))
 925         (t
 926          (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))
 927   (values))
 928
 929 ;;; For each :ALIAS TN, destructively merge the conflict info into the
 930 ;;; original TN and replace the uses of the alias.
 931 ;;;
 932 ;;; For any block that uses only the alias TN, just insert that
 933 ;;; conflict into the conflicts for the original TN, changing the LTN
 934 ;;; map to refer to the original TN. This gives a result
 935 ;;; indistinguishable from the what there would have been if the
 936 ;;; original TN had always been referenced. This leaves no sign that
 937 ;;; an alias TN was ever involved.
 938 ;;;
 939 ;;; If a block has references to both the alias and the original TN,
 940 ;;; then we call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts
 941 ;;; into the original conflict.
 942 (defun merge-alias-conflicts (component)
 943   (declare (type component component))
 944   (do ((tn (ir2-component-alias-tns (component-info component))
 945            (tn-next tn)))
 946       ((null tn))
 947     (let ((original (tn-save-tn tn)))
 948       (ensure-global-tn tn)
 949       (ensure-global-tn original)
 950       (let ((conf (tn-global-conflicts tn))
 951             (oconf (tn-global-conflicts original))
 952             (oprev nil))
 953         (loop
 954           (unless oconf
 955             (if oprev
 956                 (setf (global-conflicts-next-tnwise oprev) conf)
 957                 (setf (tn-global-conflicts original) conf))
 958             (do ((current conf (global-conflicts-next-tnwise current)))
 959                 ((null current))
 960               (change-global-conflicts-tn current original))
 961             (return))
 962           (let* ((block (global-conflicts-block conf))
 963                  (num (ir2-block-number block))
 964                  (onum (ir2-block-number (global-conflicts-block oconf))))
 965
 966             (cond ((< onum num)
 967                    (shiftf oprev oconf (global-conflicts-next-tnwise oconf)))
 968                   ((> onum num)
 969                    (if oprev
 970                        (setf (global-conflicts-next-tnwise oprev) conf)
 971                        (setf (tn-global-conflicts original) conf))
 972                    (change-global-conflicts-tn conf original)
 973                    (shiftf oprev
 974                            conf
 975                            (global-conflicts-next-tnwise conf)
 976                            oconf))
 977                   (t
 978                    (merge-alias-block-conflicts conf oconf)
 979                    (shiftf oprev oconf (global-conflicts-next-tnwise oconf))
 980                    (setf conf (global-conflicts-next-tnwise conf)))))
 981           (unless conf (return))))
 982
 983       (flet ((frob (refs)
 984                (let ((ref refs)
 985                      (next nil))
 986                  (loop
 987                    (unless ref (return))
 988                    (setq next (tn-ref-next ref))
 989                    (change-tn-ref-tn ref original)
 990                    (setq ref next)))))
 991         (frob (tn-reads tn))
 992         (frob (tn-writes tn)))
 993       (setf (tn-global-conflicts tn) nil)))
 994
 995   (values))
 996
 997 ;;; On high debug levels, for all variables that a lambda closes over
 998 ;;; convert the TNs to :ENVIRONMENT TNs (in the physical environment
 999 ;;; of that lambda). This way the debugger can display the variables.
1000 (defun maybe-environmentalize-closure-tns (component)
1001   (dolist (lambda (component-lambdas component))
1002     (when (policy lambda (>= debug 2))
1003       (let ((physenv (lambda-physenv lambda)))
1004         (dolist (closure-var (physenv-closure physenv))
1005           (let ((tn (find-in-physenv closure-var physenv)))
1006             (when (member (tn-kind tn) '(:normal :debug-environment))
1007               (convert-to-environment-tn tn physenv))))))))
1008
1009 \f
1010 (defun lifetime-analyze (component)
1011   (lifetime-pre-pass component)
1012   (maybe-environmentalize-closure-tns component)
1013   (setup-environment-live-conflicts component)
1014   (lifetime-flow-analysis component)
1015   (lifetime-post-pass component)
1016   (merge-alias-conflicts component))
1017 \f
1018 ;;;; conflict testing
1019
1020 ;;; Test for a conflict between the local TN X and the global TN Y. We
1021 ;;; just look for a global conflict of Y in X's block, and then test
1022 ;;; for conflict in that block.
1023 ;;;
1024 ;;; [### Might be more efficient to scan Y's global conflicts. This
1025 ;;; depends on whether there are more global TNs than blocks.]
1026 (defun tns-conflict-local-global (x y)
1027   (let ((block (tn-local x)))
1028     (do ((conf (ir2-block-global-tns block)
1029                (global-conflicts-next-blockwise conf)))
1030         ((null conf) nil)
1031       (when (eq (global-conflicts-tn conf) y)
1032         (let ((num (global-conflicts-number conf)))
1033           (return (or (not num)
1034                       (not (zerop (sbit (tn-local-conflicts x)
1035                                         num))))))))))
1036
1037 ;;; Test for conflict between two global TNs X and Y.
1038 (defun tns-conflict-global-global (x y)
1039   (declare (type tn x y))
1040   (let* ((x-conf (tn-global-conflicts x))
1041          (x-num (ir2-block-number (global-conflicts-block x-conf)))
1042          (y-conf (tn-global-conflicts y))
1043          (y-num (ir2-block-number (global-conflicts-block y-conf))))
1044
1045     (macrolet ((advance (n c)
1046                  `(progn
1047                     (setq ,c (global-conflicts-next-tnwise ,c))
1048                     (unless ,c (return-from tns-conflict-global-global nil))
1049                     (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
1050                (scan (g l lc)
1051                  `(do ()
1052                       ((>= ,g ,l))
1053                     (advance ,l ,lc))))
1054
1055       (loop
1056         ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
1057         (scan x-num y-num y-conf)
1058         (scan y-num x-num x-conf)
1059         (when (= x-num y-num)
1060           (let ((ltn-num-x (global-conflicts-number x-conf)))
1061             (unless (and ltn-num-x
1062                          (global-conflicts-number y-conf)
1063                          (zerop (sbit (global-conflicts-conflicts y-conf)
1064                                       ltn-num-x)))
1065               (return t))
1066             (advance x-num x-conf)
1067             (advance y-num y-conf)))))))
1068
1069 ;;; Return true if X and Y are distinct and the lifetimes of X and Y
1070 ;;; overlap at any point.
1071 (defun tns-conflict (x y)
1072   (declare (type tn x y))
1073   (let ((x-kind (tn-kind x))
1074         (y-kind (tn-kind y)))
1075     (cond ((eq x y) nil)
1076           ((or (eq x-kind :component) (eq y-kind :component)) t)
1077           ((tn-global-conflicts x)
1078            (if (tn-global-conflicts y)
1079                (tns-conflict-global-global x y)
1080                (tns-conflict-local-global y x)))
1081           ((tn-global-conflicts y)
1082            (tns-conflict-local-global x y))
1083           (t
1084            (and (eq (tn-local x) (tn-local y))
1085                 (not (zerop (sbit (tn-local-conflicts x)
1086                                   (tn-local-number y)))))))))