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