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