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