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