1 ;;;; This file contains the lifetime analysis phase in the compiler.
3 ;;;; This software is part of the SBCL system. See the README file for
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.
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)))
29 (shiftf (global-conflicts-tn-next new)
30 (global-conflicts-tn-next last)
32 (shiftf (global-conflicts-tn-next new)
33 (tn-global-conflicts tn)
35 (setf (tn-current-conflict tn) new)
37 (insert-block-global-conflict new block))
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))))
44 (conf (ir2-block-global-tns block)
45 (global-conflicts-next conf)))
47 (> (tn-number (global-conflicts-tn conf)) global-num))
49 (setf (global-conflicts-next prev) new)
50 (setf (ir2-block-global-tns block) new))
51 (setf (global-conflicts-next new) conf))))
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))))
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)))
70 (if (zerop (sbit (ir2-block-written block) num))
72 (if (zerop (sbit (ir2-block-live-out block) num))
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.
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.
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.
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.
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)
108 (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
110 (let* ((tn (tn-ref-tn ref))
111 (local (tn-local 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))
118 (unless (tn-global-conflicts tn)
119 (convert-to-global tn))
120 (add-global-conflict :read-only tn block ltn-num))
122 (setf (tn-local tn) block)
123 (setf (tn-local-number tn) ltn-num)
124 (setf (svref tns ltn-num) tn)
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)))))))
132 (setf (ir2-block-local-tn-count block) ltn-num)))
135 ;;; Finish up the global conflicts for TNs referenced in Block according to
136 ;;; the local Kill and Live sets.
138 ;;; We set the kind for TNs already in the global-TNs. If not written at
139 ;;; all, then is :Read-Only, the default. Must have been referenced somehow,
140 ;;; or we wouldn't have conflicts for it.
142 ;;; We also iterate over all the local TNs, looking for TNs local to this
143 ;;; block that are still live at the block beginning, and thus must be global.
144 ;;; This case is only important when a TN is read in a block but not written in
145 ;;; any other, since otherwise the write would promote the TN to global. But
146 ;;; this does happen with various passing-location TNs that are magically
147 ;;; written. This also serves to propagate the lives of erroneously
148 ;;; uninitialized TNs so that consistency checks can detect them.
149 (defun init-global-conflict-kind (block)
150 (declare (type ir2-block block))
151 (let ((live (ir2-block-live-out block)))
152 (let ((kill (ir2-block-written block)))
153 (do ((conf (ir2-block-global-tns block)
154 (global-conflicts-next conf)))
156 (let ((num (global-conflicts-number conf)))
157 (unless (zerop (sbit kill num))
158 (setf (global-conflicts-kind conf)
159 (if (zerop (sbit live num))
163 (let ((ltns (ir2-block-local-tns block)))
164 (dotimes (i (ir2-block-local-tn-count block))
165 (let ((tn (svref ltns i)))
166 (unless (or (eq tn :more)
167 (tn-global-conflicts tn)
168 (zerop (sbit live i)))
169 (convert-to-global tn))))))
173 (defevent split-ir2-block "Split an IR2 block to meet Local-TN-Limit.")
175 ;;; Move the code after the VOP Lose in 2block into its own block. The
176 ;;; block is linked into the emit order following 2block. Number is the block
177 ;;; number assigned to the new block. We return the new block.
178 (defun split-ir2-blocks (2block lose number)
179 (declare (type ir2-block 2block) (type vop lose)
180 (type unsigned-byte number))
181 (event split-ir2-block (vop-node lose))
182 (let ((new (make-ir2-block (ir2-block-block 2block)))
183 (new-start (vop-next lose)))
184 (setf (ir2-block-number new) number)
185 (add-to-emit-order new 2block)
187 (do ((vop new-start (vop-next vop)))
189 (setf (vop-block vop) new))
191 (setf (ir2-block-start-vop new) new-start)
192 (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose)
194 (setf (vop-next lose) nil)
195 (setf (vop-prev new-start) nil)
199 ;;; Clear the global and local conflict info in Block so that we can
200 ;;; recompute it without any old cruft being retained. It is assumed that all
201 ;;; LTN numbers are in use.
203 ;;; First we delete all the global conflicts. The conflict we are deleting
204 ;;; must be the last in the TN's global-conflicts, but we must scan for it in
205 ;;; order to find the previous conflict.
207 ;;; Next, we scan the local TNs, nulling out the Local slot in all TNs with
208 ;;; no global conflicts. This allows these TNs to be treated as local when we
209 ;;; scan the block again.
211 ;;; If there are conflicts, then we set Local to one of the conflicting
212 ;;; blocks. This ensures that Local doesn't hold over Block as its value,
213 ;;; causing the subsequent reanalysis to think that the TN has already been
214 ;;; seen in that block.
216 ;;; This function must not be called on blocks that have :More TNs.
217 (defun clear-lifetime-info (block)
218 (declare (type ir2-block block))
219 (setf (ir2-block-local-tn-count block) 0)
221 (do ((conf (ir2-block-global-tns block)
222 (global-conflicts-next conf)))
224 (setf (ir2-block-global-tns block) nil))
225 (let ((tn (global-conflicts-tn conf)))
226 (aver (eq (tn-current-conflict tn) conf))
227 (aver (null (global-conflicts-tn-next conf)))
228 (do ((current (tn-global-conflicts tn)
229 (global-conflicts-tn-next current))
233 (setf (global-conflicts-tn-next prev) nil)
234 (setf (tn-global-conflicts tn) nil))
235 (setf (tn-current-conflict tn) prev)))))
237 (fill (ir2-block-written block) 0)
238 (let ((ltns (ir2-block-local-tns block)))
239 (dotimes (i local-tn-limit)
240 (let ((tn (svref ltns i)))
241 (aver (not (eq tn :more)))
242 (let ((conf (tn-global-conflicts tn)))
245 (global-conflicts-block conf)
250 ;;; This provides a panic mode for assigning LTN numbers when there is a VOP
251 ;;; with so many more operands that they can't all be assigned distinct
252 ;;; numbers. When this happens, we recover by assigning all the more operands
253 ;;; the same LTN number. We can get away with this, since all more args (and
254 ;;; results) are referenced simultaneously as far as conflict analysis is
257 ;;; Block is the IR2-Block that the more VOP is at the end of. Ops is the
258 ;;; full argument or result TN-Ref list. Fixed is the types of the fixed
259 ;;; operands (used only to skip those operands.)
261 ;;; What we do is grab a LTN number, then make a :Read-Only global conflict
262 ;;; for each more operand TN. We require that there be no existing global
263 ;;; conflict in Block for any of the operands. Since conflicts must be cleared
264 ;;; before the first call, this only prohibits the same TN being used both as a
265 ;;; more operand and as any other operand to the same VOP.
267 ;;; We don't have to worry about getting the correct conflict kind, since
268 ;;; Init-Global-Conflict-Kind will fix things up. Similarly,
269 ;;; FIND-LOCAL-REFERENCES will set the local conflict bit corresponding to this
272 ;;; We also set the Local and Local-Number slots in each TN. It is
273 ;;; possible that there are no operands in any given call to this function, but
274 ;;; there had better be either some more args or more results.
275 (defun coalesce-more-ltn-numbers (block ops fixed)
276 (declare (type ir2-block block) (type (or tn-ref null) ops) (list fixed))
277 (let ((num (ir2-block-local-tn-count block)))
278 (aver (< num local-tn-limit))
279 (incf (ir2-block-local-tn-count block))
280 (setf (svref (ir2-block-local-tns block) num) :more)
282 (do ((op (do ((op ops (tn-ref-across op))
284 ((= i (length fixed)) op)
285 (declare (type index i)))
288 (let ((tn (tn-ref-tn op)))
291 (do ((ref refs (tn-ref-next ref)))
293 (when (and (eq (vop-block (tn-ref-vop ref)) block)
296 (and (frob (tn-reads tn)) (frob (tn-writes tn))))
297 () "More operand ~S used more than once in its VOP." op)
298 (aver (not (find-in #'global-conflicts-next tn
299 (ir2-block-global-tns block)
300 :key #'global-conflicts-tn)))
302 (add-global-conflict :read-only tn block num)
303 (setf (tn-local tn) block)
304 (setf (tn-local-number tn) num))))
307 (defevent coalesce-more-ltn-numbers
308 "Coalesced LTN numbers for a more operand to meet Local-TN-Limit.")
310 ;;; Loop over the blocks in Component, assigning LTN numbers and recording
311 ;;; TN birth and death. The only interesting action is when we run out of
312 ;;; local TN numbers while finding local references.
314 ;;; If we run out of LTN numbers while processing a VOP within the block,
315 ;;; then we just split off the VOPs we have successfully processed into their
318 ;;; If we run out of LTN numbers while processing the our first VOP (the
319 ;;; last in the block), then it must be the case that this VOP has large more
320 ;;; operands. We split the VOP into its own block, and then call
321 ;;; Coalesce-More-Ltn-Numbers to assign all the more args/results the same LTN
324 ;;; In either case, we clear the lifetime information that we computed so
325 ;;; far, recomputing it after taking corrective action.
327 ;;; Whenever we split a block, we finish the pre-pass on the split-off block
328 ;;; by doing Find-Local-References and Init-Global-Conflict-Kind. This can't
329 ;;; run out of LTN numbers.
330 (defun lifetime-pre-pass (component)
331 (declare (type component component))
333 (declare (type fixnum counter))
334 (do-blocks-backwards (block component)
335 (let ((2block (block-info block)))
336 (do ((lose (find-local-references 2block)
337 (find-local-references 2block))
341 (init-global-conflict-kind 2block)
342 (setf (ir2-block-number 2block) (incf counter)))
344 (clear-lifetime-info 2block)
348 (aver (not (eq last-lose lose)))
349 (let ((new (split-ir2-blocks 2block lose (incf counter))))
350 (aver (not (find-local-references new)))
351 (init-global-conflict-kind new)))
353 (aver (not (eq lose coalesced)))
354 (setq coalesced lose)
355 (event coalesce-more-ltn-numbers (vop-node lose))
356 (let ((info (vop-info lose))
357 (new (if (vop-prev lose)
358 (split-ir2-blocks 2block (vop-prev lose)
361 (coalesce-more-ltn-numbers new (vop-args lose)
362 (vop-info-arg-types info))
363 (coalesce-more-ltn-numbers new (vop-results lose)
364 (vop-info-result-types info))
365 (let ((lose (find-local-references new)))
367 (init-global-conflict-kind new))))))))
371 ;;;; environment TN stuff
373 ;;; Add a :LIVE global conflict for TN in 2block if there is none
374 ;;; present. If DEBUG-P is false (a :ENVIRONMENT TN), then modify any
375 ;;; existing conflict to be :LIVE.
376 (defun setup-environment-tn-conflict (tn 2block debug-p)
377 (declare (type tn tn) (type ir2-block 2block))
378 (let ((block-num (ir2-block-number 2block)))
379 (do ((conf (tn-current-conflict tn) (global-conflicts-tn-next conf))
382 (> (ir2-block-number (global-conflicts-block conf)) block-num))
383 (setf (tn-current-conflict tn) prev)
384 (add-global-conflict :live tn 2block nil))
385 (when (eq (global-conflicts-block conf) 2block)
387 (eq (global-conflicts-kind conf) :live))
388 (setf (global-conflicts-kind conf) :live)
389 (setf (svref (ir2-block-local-tns 2block)
390 (global-conflicts-number conf))
392 (setf (global-conflicts-number conf) nil))
393 (setf (tn-current-conflict tn) conf)
397 ;;; Iterate over all the blocks in ENV, setting up :LIVE conflicts for
398 ;;; TN. We make the TN global if it isn't already. The TN must have at
399 ;;; least one reference.
400 (defun setup-environment-tn-conflicts (component tn env debug-p)
401 (declare (type component component) (type tn tn) (type physenv env))
403 (not (tn-global-conflicts tn))
405 (convert-to-global tn))
406 (setf (tn-current-conflict tn) (tn-global-conflicts tn))
407 (do-blocks-backwards (block component)
408 (when (eq (block-physenv block) env)
409 (let* ((2block (block-info block))
410 (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
412 ((not (eq (ir2-block-block b) block))
414 (do ((b last (ir2-block-prev b)))
415 ((not (eq (ir2-block-block b) block)))
416 (setup-environment-tn-conflict tn b debug-p)))))
419 ;;; Iterate over all the environment TNs, adding always-live conflicts
421 (defun setup-environment-live-conflicts (component)
422 (declare (type component component))
423 (dolist (fun (component-lambdas component))
424 (let* ((env (lambda-physenv fun))
425 (2env (physenv-info env)))
426 (dolist (tn (ir2-physenv-live-tns 2env))
427 (setup-environment-tn-conflicts component tn env nil))
428 (dolist (tn (ir2-physenv-debug-live-tns 2env))
429 (setup-environment-tn-conflicts component tn env t))))
432 ;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN. This
433 ;;; requires adding :LIVE conflicts to all blocks in TN-ENV.
434 (defun convert-to-environment-tn (tn tn-env)
435 (declare (type tn tn) (type physenv tn-env))
436 (aver (member (tn-kind tn) '(:normal :debug-environment)))
437 (when (eq (tn-kind tn) :debug-environment)
438 (aver (eq (tn-physenv tn) tn-env))
439 (let ((2env (physenv-info tn-env)))
440 (setf (ir2-physenv-debug-live-tns 2env)
441 (delete tn (ir2-physenv-debug-live-tns 2env)))))
442 (setup-environment-tn-conflicts *component-being-compiled* tn tn-env nil)
443 (setf (tn-local tn) nil)
444 (setf (tn-local-number tn) nil)
445 (setf (tn-kind tn) :environment)
446 (setf (tn-physenv tn) tn-env)
447 (push tn (ir2-physenv-live-tns (physenv-info tn-env)))
452 ;;; For each GLOBAL-TN in Block2 that is :LIVE, :READ or :READ-ONLY,
453 ;;; ensure that there is a corresponding GLOBAL-CONFLICT in BLOCK1. If
454 ;;; there is none, make a :LIVE GLOBAL-CONFLICT. If there is a
455 ;;; :READ-ONLY conflict, promote it to :LIVE.
457 ;;; If we did added a new conflict, return true, otherwise false. We
458 ;;; don't need to return true when we promote a :READ-ONLY conflict,
459 ;;; since it doesn't reveal any new information to predecessors of
462 ;;; We use the TN-CURRENT-CONFLICT to walk through the global
463 ;;; conflicts. Since the global conflicts for a TN are ordered by
464 ;;; block, we can be sure that the CURRENT-CONFLICT always points at
465 ;;; or before the block that we are looking at. This allows us to
466 ;;; quickly determine if there is a global conflict for a given TN in
469 ;;; When we scan down the conflicts, we know that there must be at
470 ;;; least one conflict for TN, since we got our hands on TN by picking
471 ;;; it out of a conflict in BLOCK2.
473 ;;; We leave the CURRENT-Conflict pointing to the conflict for BLOCK1.
474 ;;; The CURRENT-CONFLICT must be initialized to the head of the
475 ;;; GLOBAL-CONFLICTS for the TN between each flow analysis iteration.
476 (defun propagate-live-tns (block1 block2)
477 (declare (type ir2-block block1 block2))
478 (let ((live-in (ir2-block-live-in block1))
480 (do ((conf2 (ir2-block-global-tns block2)
481 (global-conflicts-next conf2)))
483 (ecase (global-conflicts-kind conf2)
484 ((:live :read :read-only)
485 (let* ((tn (global-conflicts-tn conf2))
486 (tn-conflicts (tn-current-conflict tn))
487 (number1 (ir2-block-number block1)))
489 (do ((current tn-conflicts (global-conflicts-tn-next current))
492 (> (ir2-block-number (global-conflicts-block current))
494 (setf (tn-current-conflict tn) prev)
495 (add-global-conflict :live tn block1 nil)
496 (setq did-something t))
497 (when (eq (global-conflicts-block current) block1)
498 (case (global-conflicts-kind current)
501 (setf (global-conflicts-kind current) :live)
502 (setf (svref (ir2-block-local-tns block1)
503 (global-conflicts-number current))
505 (setf (global-conflicts-number current) nil)
506 (setf (tn-current-conflict tn) current))
508 (setf (sbit live-in (global-conflicts-number current)) 1)))
513 ;;; Do backward global flow analysis to find all TNs live at each block
515 (defun lifetime-flow-analysis (component)
517 (reset-current-conflict component)
518 (let ((did-something nil))
519 (do-blocks-backwards (block component)
520 (let* ((2block (block-info block))
521 (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
523 ((not (eq (ir2-block-block b) block))
526 (dolist (b (block-succ block))
527 (when (and (block-start b)
528 (propagate-live-tns last (block-info b)))
529 (setq did-something t)))
531 (do ((b (ir2-block-prev last) (ir2-block-prev b))
533 ((not (eq (ir2-block-block b) block)))
534 (when (propagate-live-tns b prev)
535 (setq did-something t)))))
537 (unless did-something (return))))
543 ;;; Note that TN conflicts with all current live TNs. Num is TN's LTN
544 ;;; number. We bit-ior Live-Bits with TN's Local-Conflicts, and set TN's
545 ;;; number in the conflicts of all TNs in Live-List.
546 (defun note-conflicts (live-bits live-list tn num)
547 (declare (type tn tn) (type (or tn null) live-list)
548 (type local-tn-bit-vector live-bits)
549 (type local-tn-number num))
550 (let ((lconf (tn-local-conflicts tn)))
551 (bit-ior live-bits lconf lconf))
552 (do ((live live-list (tn-next* live)))
554 (setf (sbit (tn-local-conflicts live) num) 1))
557 ;;; Compute a bit vector of the TNs live after VOP that aren't results.
558 (defun compute-save-set (vop live-bits)
559 (declare (type vop vop) (type local-tn-bit-vector live-bits))
560 (let ((live (bit-vector-copy live-bits)))
561 (do ((r (vop-results vop) (tn-ref-across r)))
563 (let ((tn (tn-ref-tn r)))
565 ((:normal :debug-environment)
566 (setf (sbit live (tn-local-number tn)) 0))
567 (:environment :component))))
570 ;;; Used to determine whether a :DEBUG-ENVIRONMENT TN should be considered
571 ;;; live at block end. We return true if a VOP with non-null SAVE-P appears
572 ;;; before the first read of TN (hence is seen first in our backward scan.)
573 (defun saved-after-read (tn block)
574 (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
576 (when (vop-info-save-p (vop-info vop)) (return t))
577 (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
580 ;;; If the block has no successors, or its successor is the component tail,
581 ;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether
582 ;;; they appeared to be live. This ensures that these TNs are considered to be
583 ;;; live throughout blocks that read them, but don't have any interesting
584 ;;; successors (such as a return or tail call.) In this case, we set the
585 ;;; corresponding bit in LIVE-IN as well.
586 (defun make-debug-environment-tns-live (block live-bits live-list)
587 (let* ((1block (ir2-block-block block))
588 (live-in (ir2-block-live-in block))
589 (succ (block-succ 1block))
590 (next (ir2-block-next block)))
592 (not (eq (ir2-block-block next) 1block))
595 (component-tail (block-component 1block)))))
596 (do ((conf (ir2-block-global-tns block)
597 (global-conflicts-next conf)))
599 (let* ((tn (global-conflicts-tn conf))
600 (num (global-conflicts-number conf)))
601 (when (and num (zerop (sbit live-bits num))
602 (eq (tn-kind tn) :debug-environment)
603 (eq (tn-physenv tn) (block-physenv 1block))
604 (saved-after-read tn block))
605 (note-conflicts live-bits live-list tn num)
606 (setf (sbit live-bits num) 1)
607 (push-in tn-next* tn live-list)
608 (setf (sbit live-in num) 1))))))
610 (values live-bits live-list))
612 ;;; Return as values, a LTN bit-vector and a list (threaded by TN-Next*)
613 ;;; representing the TNs live at the end of Block (exclusive of :Live TNs).
615 ;;; We iterate over the TNs in the global conflicts that are live at the block
616 ;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
617 ;;; TN to the live list.
619 ;;; If a :MORE result is not live, we effectively fake a read to it. This is
620 ;;; part of the action described in ENSURE-RESULTS-LIVE.
622 ;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
623 ;;; environment TNs appear live when appropriate, even when they aren't.
625 ;;; ### Note: we alias the global-conflicts-conflicts here as the
626 ;;; tn-local-conflicts.
627 (defun compute-initial-conflicts (block)
628 (declare (type ir2-block block))
629 (let* ((live-in (ir2-block-live-in block))
630 (ltns (ir2-block-local-tns block))
631 (live-bits (bit-vector-copy live-in))
634 (do ((conf (ir2-block-global-tns block)
635 (global-conflicts-next conf)))
637 (let ((bits (global-conflicts-conflicts conf))
638 (tn (global-conflicts-tn conf))
639 (num (global-conflicts-number conf))
640 (kind (global-conflicts-kind conf)))
641 (setf (tn-local-number tn) num)
642 (unless (eq kind :live)
643 (cond ((not (zerop (sbit live-bits num)))
644 (bit-vector-replace bits live-bits)
645 (setf (sbit bits num) 0)
646 (push-in tn-next* tn live-list))
647 ((and (eq (svref ltns num) :more)
649 (note-conflicts live-bits live-list tn num)
650 (setf (sbit live-bits num) 1)
651 (push-in tn-next* tn live-list)
652 (setf (sbit live-in num) 1)))
654 (setf (tn-local-conflicts tn) bits))))
656 (make-debug-environment-tns-live block live-bits live-list)))
658 ;;; A function called in Conflict-Analyze-1-Block when we have a VOP with
659 ;;; SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK, force all
660 ;;; the live TNs to be stack environment TNs.
661 (defun do-save-p-stuff (vop block live-bits)
662 (declare (type vop vop) (type ir2-block block)
663 (type local-tn-bit-vector live-bits))
664 (let ((ss (compute-save-set vop live-bits)))
665 (setf (vop-save-set vop) ss)
666 (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
667 (do-live-tns (tn ss block)
668 (unless (eq (tn-kind tn) :component)
669 (force-tn-to-stack tn)
670 (unless (eq (tn-kind tn) :environment)
671 (convert-to-environment-tn
673 (block-physenv (ir2-block-block block))))))))
676 ;;; FIXME: The next 3 macros aren't needed in the target runtime.
677 ;;; Figure out some way to make them only at build time. (Just
678 ;;; (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE) (DEFMACRO ..)) isn't good enough,
679 ;;; since we need CL:DEFMACRO at build-the-cross-compiler time and
680 ;;; SB!XC:DEFMACRO at run-the-cross-compiler time.)
682 ;;; Used in SCAN-VOP-REFS to simultaneously do something to all of the TNs
683 ;;; referenced by a big more arg. We have to treat these TNs specially, since
684 ;;; when we set or clear the bit in the live TNs, the represents a change in
685 ;;; the liveness of all the more TNs. If we iterated as normal, the next more
686 ;;; ref would be thought to be not live when it was, etc. We update Ref to be
687 ;;; the last :more ref we scanned, so that the main loop will step to the next
689 (defmacro frob-more-tns (action)
690 `(when (eq (svref ltns num) :more)
692 (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
694 (let ((mtn (tn-ref-tn mref)))
695 (unless (eql (tn-local-number mtn) num)
701 ;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs for the
702 ;;; current VOP. This macro shamelessly references free variables in C-A-1-B.
703 (defmacro scan-vop-refs ()
704 '(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
706 (let* ((tn (tn-ref-tn ref))
707 (num (tn-local-number tn)))
710 ((not (zerop (sbit live-bits num)))
711 (when (tn-ref-write-p ref)
712 (setf (sbit live-bits num) 0)
713 (deletef-in tn-next* live-list tn)
714 (frob-more-tns (deletef-in tn-next* live-list mtn))))
716 (aver (not (tn-ref-write-p ref)))
717 (note-conflicts live-bits live-list tn num)
718 (frob-more-tns (note-conflicts live-bits live-list mtn num))
719 (setf (sbit live-bits num) 1)
720 (push-in tn-next* tn live-list)
721 (frob-more-tns (push-in tn-next* mtn live-list)))))))
723 ;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the current
724 ;;; VOP's results, and make any dead ones live. This is necessary, since even
725 ;;; though a result is dead after the VOP, it may be in use for an extended
726 ;;; period within the VOP (especially if it has :FROM specified.) During this
727 ;;; interval, temporaries must be noted to conflict with the result. More
728 ;;; results are finessed in COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
729 (defmacro ensure-results-live ()
730 '(do ((res (vop-results vop) (tn-ref-across res)))
732 (let* ((tn (tn-ref-tn res))
733 (num (tn-local-number tn)))
734 (when (and num (zerop (sbit live-bits num)))
735 (unless (eq (svref ltns num) :more)
736 (note-conflicts live-bits live-list tn num)
737 (setf (sbit live-bits num) 1)
738 (push-in tn-next* tn live-list))))))
740 ;;; Compute the block-local conflict information for Block. We iterate over
741 ;;; all the TN-Refs in a block in reference order, maintaining the set of live
742 ;;; TNs in both a list and a bit-vector representation.
743 (defun conflict-analyze-1-block (block)
744 (declare (type ir2-block block))
745 (multiple-value-bind (live-bits live-list)
746 (compute-initial-conflicts block)
747 (let ((ltns (ir2-block-local-tns block)))
748 (do ((vop (ir2-block-last-vop block)
751 (when (vop-info-save-p (vop-info vop))
752 (do-save-p-stuff vop block live-bits))
753 (ensure-results-live)
756 ;;; Conflict analyze each block, and also add it.
757 (defun lifetime-post-pass (component)
758 (declare (type component component))
759 (do-ir2-blocks (block component)
760 (conflict-analyze-1-block block)))
764 ;;; Destructively modify Oconf to include the conflict information in Conf.
765 (defun merge-alias-block-conflicts (conf oconf)
766 (declare (type global-conflicts conf oconf))
767 (let* ((kind (global-conflicts-kind conf))
768 (num (global-conflicts-number conf))
769 (okind (global-conflicts-kind oconf))
770 (onum (global-conflicts-number oconf))
771 (block (global-conflicts-block oconf))
772 (ltns (ir2-block-local-tns block)))
776 (setf (global-conflicts-kind oconf) :live)
777 (setf (svref ltns onum) nil)
778 (setf (global-conflicts-number oconf) nil))
780 (unless (eq kind okind)
781 (setf (global-conflicts-kind oconf) :read))
782 ;; Make original conflict with all the local TNs the alias conflicted
784 (bit-ior (global-conflicts-conflicts oconf)
785 (global-conflicts-conflicts conf)
788 (unless (zerop (sbit x num))
789 (setf (sbit x onum) 1))))
790 ;; Make all the local TNs that conflicted with the alias conflict
791 ;; with the original.
792 (dotimes (i (ir2-block-local-tn-count block))
793 (let ((tn (svref ltns i)))
794 (when (and tn (not (eq tn :more))
795 (null (tn-global-conflicts tn)))
796 (frob (tn-local-conflicts tn)))))
797 ;; Same for global TNs...
798 (do ((current (ir2-block-global-tns block)
799 (global-conflicts-next current)))
801 (unless (eq (global-conflicts-kind current) :live)
802 (frob (global-conflicts-conflicts current))))
803 ;; Make the original TN live everywhere that the alias was live.
804 (frob (ir2-block-written block))
805 (frob (ir2-block-live-in block))
806 (frob (ir2-block-live-out block))
807 (do ((vop (ir2-block-start-vop block)
810 (let ((sset (vop-save-set vop)))
811 (when sset (frob sset)))))))
812 ;; Delete the alias's conflict info.
814 (setf (svref ltns num) nil))
815 (deletef-in global-conflicts-next (ir2-block-global-tns block) conf))
819 ;;; Co-opt Conf to be a conflict for TN.
820 (defun change-global-conflicts-tn (conf new)
821 (declare (type global-conflicts conf) (type tn new))
822 (setf (global-conflicts-tn conf) new)
823 (let ((ltn-num (global-conflicts-number conf))
824 (block (global-conflicts-block conf)))
825 (deletef-in global-conflicts-next (ir2-block-global-tns block) conf)
826 (setf (global-conflicts-next conf) nil)
827 (insert-block-global-conflict conf block)
829 (setf (svref (ir2-block-local-tns block) ltn-num) new)))
832 ;;; Do CONVERT-TO-GLOBAL on TN if it has no global conflicts. Copy the
833 ;;; local conflicts into the global bit vector.
834 (defun ensure-global-tn (tn)
835 (declare (type tn tn))
836 (cond ((tn-global-conflicts tn))
838 (convert-to-global tn)
839 (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
840 (tn-local-conflicts tn)
843 (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))
846 ;;; For each :ALIAS TN, destructively merge the conflict info into the
847 ;;; original TN and replace the uses of the alias.
849 ;;; For any block that uses only the alias TN, just insert that
850 ;;; conflict into the conflicts for the original TN, changing the LTN
851 ;;; map to refer to the original TN. This gives a result
852 ;;; indistinguishable from the what there would have been if the
853 ;;; original TN had always been referenced. This leaves no sign that
854 ;;; an alias TN was ever involved.
856 ;;; If a block has references to both the alias and the original TN,
857 ;;; then we call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts
858 ;;; into the original conflict.
859 (defun merge-alias-conflicts (component)
860 (declare (type component component))
861 (do ((tn (ir2-component-alias-tns (component-info component))
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))
873 (setf (global-conflicts-tn-next oprev) conf)
874 (setf (tn-global-conflicts original) conf))
875 (do ((current conf (global-conflicts-tn-next current)))
877 (change-global-conflicts-tn current original))
879 (let* ((block (global-conflicts-block conf))
880 (num (ir2-block-number block))
881 (onum (ir2-block-number (global-conflicts-block oconf))))
884 (shiftf oprev oconf (global-conflicts-tn-next oconf)))
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))
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))))
901 (unless ref (return))
902 (setq next (tn-ref-next ref))
903 (change-tn-ref-tn ref original)
906 (frob (tn-writes tn)))
907 (setf (tn-global-conflicts tn) nil)))
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))
918 ;;;; conflict testing
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
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)))
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)
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))))
944 (macrolet ((advance (n c)
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)))))
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)
965 (advance x-num x-conf)
966 (advance y-num y-conf)))))))
968 ;;; Return true if X and Y are distinct and the lifetimes of X and Y overlap
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)))
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))
983 (and (eq (tn-local x) (tn-local y))
984 (not (zerop (sbit (tn-local-conflicts x)
985 (tn-local-number y)))))))))