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