1.0.30.11: autogenerate tagname information for LDB in genesis
[sbcl.git] / src / compiler / life.lisp
1 ;;;; This file contains the lifetime analysis phase in the compiler.
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!C")
13 \f
14 ;;;; utilities
15
16 ;;; Link in a GLOBAL-CONFLICTS structure for TN in BLOCK with NUMBER
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)
37
38     (insert-block-global-conflict new block))
39   (values))
40
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))
55
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))))
61
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)))
75 \f
76 ;;;; pre-pass
77
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      (if (zerop (sbit (ir2-block-written block) num))
88          :read-only
89          (if (zerop (sbit (ir2-block-live-out block) num))
90              :write
91              :read))
92      tn block num))
93   (values))
94
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
98 ;;; analysis.
99 ;;;
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.
103 ;;;
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
108 ;;; global.
109 ;;;
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.
115 ;;;
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)
126                 (vop-prev vop)))
127           ((null vop))
128         (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
129             ((null ref))
130           (let* ((tn (tn-ref-tn ref))
131                  (local (tn-local tn))
132                  (kind (tn-kind 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))
137                 (when local
138                   (unless (tn-global-conflicts tn)
139                     (convert-to-global tn))
140                   (add-global-conflict :read-only tn block ltn-num))
141
142                 (setf (tn-local tn) block)
143                 (setf (tn-local-number tn) ltn-num)
144                 (setf (svref tns ltn-num) tn)
145                 (incf ltn-num))
146
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)))))))
151
152       (setf (ir2-block-local-tn-count block) ltn-num)))
153   nil)
154
155 ;;; Finish up the global conflicts for TNs referenced in BLOCK
156 ;;; according to the local Kill and Live sets.
157 ;;;
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.
161 ;;;
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)))
176           ((null 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))
181                       :write
182                       :read))))))
183
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))))))
191
192   (values))
193
194 (defevent split-ir2-block "Split an IR2 block to meet LOCAL-TN-LIMIT.")
195
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
199 ;;; block.
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)
208
209     (do ((vop new-start (vop-next vop)))
210         ((null vop))
211       (setf (vop-block vop) new))
212
213     (setf (ir2-block-start-vop new) new-start)
214     (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose)
215
216     (setf (vop-next lose) nil)
217     (setf (vop-prev new-start) nil)
218
219     new))
220
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.
224 ;;;
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.
228 ;;;
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.
232 ;;;
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.
237 ;;;
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)
242
243   (do ((conf (ir2-block-global-tns block)
244              (global-conflicts-next-blockwise conf)))
245       ((null 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))
252            (prev nil current))
253           ((eq current conf)
254            (if prev
255                (setf (global-conflicts-next-tnwise prev) nil)
256                (setf (tn-global-conflicts tn) nil))
257            (setf (tn-current-conflict tn) prev)))))
258
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)))
265           (setf (tn-local tn)
266                 (if conf
267                     (global-conflicts-block conf)
268                     nil))))))
269
270   (values))
271
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.
278 ;;;
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.)
282 ;;;
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.
289 ;;;
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.
294 ;;;
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
298 ;;; results.
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)
305
306     (do ((op (do ((op ops (tn-ref-across op))
307                   (i 0 (1+ i)))
308                  ((= i (length fixed)) op)
309                (declare (type index i)))
310              (tn-ref-across op)))
311         ((null op))
312       (let ((tn (tn-ref-tn op)))
313         (assert
314           (flet ((frob (refs)
315                    (do ((ref refs (tn-ref-next ref)))
316                        ((null ref) t)
317                      (when (and (eq (vop-block (tn-ref-vop ref)) block)
318                                 (not (eq ref op)))
319                        (return nil)))))
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)))
325
326         (add-global-conflict :read-only tn block num)
327         (setf (tn-local tn) block)
328         (setf (tn-local-number tn) num))))
329   (values))
330
331 (defevent coalesce-more-ltn-numbers
332   "Coalesced LTN numbers for a more operand to meet LOCAL-TN-LIMIT.")
333
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.
337 ;;;
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.
341 ;;;
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).
347 ;;;
348 ;;; In either case, we clear the lifetime information that we computed
349 ;;; so far, recomputing it after taking corrective action.
350 ;;;
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))
356   (let ((counter -1))
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))
362              (last-lose nil lose)
363              (coalesced nil))
364             ((not lose)
365              (init-global-conflict-kind 2block)
366              (setf (ir2-block-number 2block) (incf counter)))
367
368           (clear-lifetime-info 2block)
369
370           (cond
371            ((vop-next lose)
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)))
376            (t
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)
383                                              (incf counter))
384                            2block)))
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)))
390                 (aver (not lose)))
391               (init-global-conflict-kind new))))))))
392
393   (values))
394 \f
395 ;;;; environment TN stuff
396
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))
404          (prev nil conf))
405         ((or (null 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)
410         (unless (or debug-p
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))
415                 nil)
416           (setf (global-conflicts-number conf) nil))
417         (setf (tn-current-conflict tn) conf)
418         (return))))
419   (values))
420
421 ;;; Iterate over all the blocks in ENV, setting up :LIVE conflicts for
422 ;;; TN. We make the TN global if it isn't already. The TN must have at
423 ;;; least one reference.
424 (defun setup-environment-tn-conflicts (component tn env debug-p)
425   (declare (type component component) (type tn tn) (type physenv env))
426   (when (and debug-p
427              (not (tn-global-conflicts tn))
428              (tn-local tn))
429     (convert-to-global tn))
430   (setf (tn-current-conflict tn) (tn-global-conflicts tn))
431   (do-blocks-backwards (block component)
432     (when (eq (cached-block-physenv block) env)
433       (let* ((2block (block-info block))
434              (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
435                         (prev 2block b))
436                        ((not (eq (ir2-block-block b) block))
437                         prev))))
438         (do ((b last (ir2-block-prev b)))
439             ((not (eq (ir2-block-block b) block)))
440           (setup-environment-tn-conflict tn b debug-p)))))
441   (values))
442
443 ;;; Iterate over all the environment TNs, adding always-live conflicts
444 ;;; as appropriate.
445 (defun setup-environment-live-conflicts (component)
446   (declare (type component component))
447   (dolist (fun (component-lambdas component))
448     (let* ((env (lambda-physenv fun))
449            (2env (physenv-info env)))
450       (dolist (tn (ir2-physenv-live-tns 2env))
451         (setup-environment-tn-conflicts component tn env nil))
452       (dolist (tn (ir2-physenv-debug-live-tns 2env))
453         (setup-environment-tn-conflicts component tn env t))))
454   (values))
455
456 ;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN.
457 ;;; This requires adding :LIVE conflicts to all blocks in TN-PHYSENV.
458 (defun convert-to-environment-tn (tn tn-physenv)
459   (declare (type tn tn) (type physenv tn-physenv))
460   (aver (member (tn-kind tn) '(:normal :debug-environment)))
461   (ecase (tn-kind tn)
462     (:debug-environment
463      (setq tn-physenv (tn-physenv tn))
464      (let* ((2env (physenv-info tn-physenv)))
465        (setf (ir2-physenv-debug-live-tns 2env)
466              (delete tn (ir2-physenv-debug-live-tns 2env)))))
467     (:normal
468      (setf (tn-local tn) nil)
469      (setf (tn-local-number tn) nil)))
470   (setup-environment-tn-conflicts *component-being-compiled* tn tn-physenv nil)
471   (setf (tn-kind tn) :environment)
472   (setf (tn-physenv tn) tn-physenv)
473   (push tn (ir2-physenv-live-tns (physenv-info tn-physenv)))
474   (values))
475 \f
476 ;;;; flow analysis
477
478 ;;; For each GLOBAL-TN in BLOCK2 that is :LIVE, :READ or :READ-ONLY,
479 ;;; ensure that there is a corresponding GLOBAL-CONFLICT in BLOCK1. If
480 ;;; there is none, make a :LIVE GLOBAL-CONFLICT. If there is a
481 ;;; :READ-ONLY conflict, promote it to :LIVE.
482 ;;;
483 ;;; If we did add a new conflict, return true, otherwise false. We
484 ;;; don't need to return true when we promote a :READ-ONLY conflict,
485 ;;; since it doesn't reveal any new information to predecessors of
486 ;;; BLOCK1.
487 ;;;
488 ;;; We use the TN-CURRENT-CONFLICT to walk through the global
489 ;;; conflicts. Since the global conflicts for a TN are ordered by
490 ;;; block, we can be sure that the CURRENT-CONFLICT always points at
491 ;;; or before the block that we are looking at. This allows us to
492 ;;; quickly determine if there is a global conflict for a given TN in
493 ;;; BLOCK1.
494 ;;;
495 ;;; When we scan down the conflicts, we know that there must be at
496 ;;; least one conflict for TN, since we got our hands on TN by picking
497 ;;; it out of a conflict in BLOCK2.
498 ;;;
499 ;;; We leave the CURRENT-CONFLICT pointing to the conflict for BLOCK1.
500 ;;; The CURRENT-CONFLICT must be initialized to the head of the
501 ;;; GLOBAL-CONFLICTS for the TN between each flow analysis iteration.
502 (defun propagate-live-tns (block1 block2)
503   (declare (type ir2-block block1 block2))
504   (let ((live-in (ir2-block-live-in block1))
505         (did-something nil))
506     (do ((conf2 (ir2-block-global-tns block2)
507                 (global-conflicts-next-blockwise conf2)))
508         ((null conf2))
509       (ecase (global-conflicts-kind conf2)
510         ((:live :read :read-only)
511          (let* ((tn (global-conflicts-tn conf2))
512                 (tn-conflicts (tn-current-conflict tn))
513                 (number1 (ir2-block-number block1)))
514            (aver tn-conflicts)
515            (do ((current tn-conflicts (global-conflicts-next-tnwise current))
516                 (prev nil current))
517                ((or (null current)
518                     (> (ir2-block-number (global-conflicts-block current))
519                        number1))
520                 (setf (tn-current-conflict tn) prev)
521                 (add-global-conflict :live tn block1 nil)
522                 (setq did-something t))
523              (when (eq (global-conflicts-block current) block1)
524                (case (global-conflicts-kind current)
525                  (:live)
526                  (:read-only
527                   (setf (global-conflicts-kind current) :live)
528                   (setf (svref (ir2-block-local-tns block1)
529                                (global-conflicts-number current))
530                         nil)
531                   (setf (global-conflicts-number current) nil))
532                  (t
533                   (setf (sbit live-in (global-conflicts-number current)) 1)))
534                (setf (tn-current-conflict tn) current)
535                (return)))))
536         (:write)))
537     did-something))
538
539 ;;; Do backward global flow analysis to find all TNs live at each
540 ;;; block boundary.
541 (defun lifetime-flow-analysis (component)
542   (loop
543     (reset-current-conflict component)
544     (let ((did-something nil))
545       (do-blocks-backwards (block component)
546         (let* ((2block (block-info block))
547                (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
548                           (prev 2block b))
549                          ((not (eq (ir2-block-block b) block))
550                           prev))))
551
552           (dolist (b (block-succ block))
553             (when (and (block-start b)
554                        (propagate-live-tns last (block-info b)))
555               (setq did-something t)))
556
557           (do ((b (ir2-block-prev last) (ir2-block-prev b))
558                (prev last b))
559               ((not (eq (ir2-block-block b) block)))
560             (when (propagate-live-tns b prev)
561               (setq did-something t)))))
562
563       (unless did-something (return))))
564
565   (values))
566 \f
567 ;;;; post-pass
568
569 ;;; Note that TN conflicts with all current live TNs. NUM is TN's LTN
570 ;;; number. We bit-ior LIVE-BITS with TN's LOCAL-CONFLICTS, and set TN's
571 ;;; number in the conflicts of all TNs in LIVE-LIST.
572 (defun note-conflicts (live-bits live-list tn num)
573   (declare (type tn tn) (type (or tn null) live-list)
574            (type local-tn-bit-vector live-bits)
575            (type local-tn-number num))
576   (let ((lconf (tn-local-conflicts tn)))
577     (bit-ior live-bits lconf lconf))
578   (do ((live live-list (tn-next* live)))
579       ((null live))
580     (setf (sbit (tn-local-conflicts live) num) 1))
581   (values))
582
583 ;;; Compute a bit vector of the TNs live after VOP that aren't results.
584 (defun compute-save-set (vop live-bits)
585   (declare (type vop vop) (type local-tn-bit-vector live-bits))
586   (let ((live (bit-vector-copy live-bits)))
587     (do ((r (vop-results vop) (tn-ref-across r)))
588         ((null r))
589       (let ((tn (tn-ref-tn r)))
590         (ecase (tn-kind tn)
591           ((:normal :debug-environment)
592            (setf (sbit live (tn-local-number tn)) 0))
593           (:environment :component))))
594     live))
595
596 ;;; This is used to determine whether a :DEBUG-ENVIRONMENT TN should
597 ;;; be considered live at block end. We return true if a VOP with
598 ;;; non-null SAVE-P appears before the first read of TN (hence is seen
599 ;;; first in our backward scan.)
600 (defun saved-after-read (tn block)
601   (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
602       ((null vop) t)
603     (when (vop-info-save-p (vop-info vop)) (return t))
604     (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
605       (return nil))))
606
607 ;;; If the block has no successors, or its successor is the component
608 ;;; tail, then all :DEBUG-ENVIRONMENT TNs are always added, regardless
609 ;;; of whether they appeared to be live. This ensures that these TNs
610 ;;; are considered to be live throughout blocks that read them, but
611 ;;; don't have any interesting successors (such as a return or tail
612 ;;; call.) In this case, we set the corresponding bit in LIVE-IN as
613 ;;; well.
614 (defun make-debug-environment-tns-live (block live-bits live-list)
615   (let* ((1block (ir2-block-block block))
616          (live-in (ir2-block-live-in block))
617          (succ (block-succ 1block))
618          (next (ir2-block-next block)))
619     (when (and next
620                (not (eq (ir2-block-block next) 1block))
621                (or (null succ)
622                    (eq (first succ)
623                        (component-tail (block-component 1block)))))
624       (do ((conf (ir2-block-global-tns block)
625                  (global-conflicts-next-blockwise conf)))
626           ((null conf))
627         (let* ((tn (global-conflicts-tn conf))
628                (num (global-conflicts-number conf)))
629           (when (and num (zerop (sbit live-bits num))
630                      (eq (tn-kind tn) :debug-environment)
631                      (eq (tn-physenv tn) (cached-block-physenv 1block))
632                      (saved-after-read tn block))
633             (note-conflicts live-bits live-list tn num)
634             (setf (sbit live-bits num) 1)
635             (push-in tn-next* tn live-list)
636             (setf (sbit live-in num) 1))))))
637
638   (values live-bits live-list))
639
640 ;;; Return as values, a LTN bit-vector and a list (threaded by
641 ;;; TN-NEXT*) representing the TNs live at the end of BLOCK (exclusive
642 ;;; of :LIVE TNs).
643 ;;;
644 ;;; We iterate over the TNs in the global conflicts that are live at
645 ;;; the block end, setting up the TN-LOCAL-CONFLICTS and
646 ;;; TN-LOCAL-NUMBER, and adding the TN to the live list.
647 ;;;
648 ;;; If a :MORE result is not live, we effectively fake a read to it.
649 ;;; This is part of the action described in ENSURE-RESULTS-LIVE.
650 ;;;
651 ;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
652 ;;; environment TNs appear live when appropriate, even when they
653 ;;; aren't.
654 ;;;
655 ;;; ### Note: we alias the global-conflicts-conflicts here as the
656 ;;; tn-local-conflicts.
657 (defun compute-initial-conflicts (block)
658   (declare (type ir2-block block))
659   (let* ((live-in (ir2-block-live-in block))
660          (ltns (ir2-block-local-tns block))
661          (live-bits (bit-vector-copy live-in))
662          (live-list nil))
663
664     (do ((conf (ir2-block-global-tns block)
665                (global-conflicts-next-blockwise conf)))
666         ((null conf))
667       (let ((bits (global-conflicts-conflicts conf))
668             (tn (global-conflicts-tn conf))
669             (num (global-conflicts-number conf))
670             (kind (global-conflicts-kind conf)))
671         (setf (tn-local-number tn) num)
672         (unless (eq kind :live)
673           (cond ((not (zerop (sbit live-bits num)))
674                  (bit-vector-replace bits live-bits)
675                  (setf (sbit bits num) 0)
676                  (push-in tn-next* tn live-list))
677                 ((and (eq (svref ltns num) :more)
678                       (eq kind :write))
679                  (note-conflicts live-bits live-list tn num)
680                  (setf (sbit live-bits num) 1)
681                  (push-in tn-next* tn live-list)
682                  (setf (sbit live-in num) 1)))
683
684           (setf (tn-local-conflicts tn) bits))))
685
686     (make-debug-environment-tns-live block live-bits live-list)))
687
688 ;;; A function called in CONFLICT-ANALYZE-1-BLOCK when we have a VOP
689 ;;; with SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK,
690 ;;; force all the live TNs to be stack environment TNs.
691 (defun conflictize-save-p-vop (vop block live-bits)
692   (declare (type vop vop) (type ir2-block block)
693            (type local-tn-bit-vector live-bits))
694   (let ((ss (compute-save-set vop live-bits)))
695     (setf (vop-save-set vop) ss)
696     (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
697       (do-live-tns (tn ss block)
698         (unless (eq (tn-kind tn) :component)
699           (force-tn-to-stack tn)
700           (unless (eq (tn-kind tn) :environment)
701             (convert-to-environment-tn
702              tn
703              (cached-block-physenv (ir2-block-block block))))))))
704   (values))
705
706 ;;; FIXME: The next 3 macros aren't needed in the target runtime.
707 ;;; Figure out some way to make them only at build time. (Just
708 ;;; (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE) (DEFMACRO ..)) isn't good enough,
709 ;;; since we need CL:DEFMACRO at build-the-cross-compiler time and
710 ;;; SB!XC:DEFMACRO at run-the-cross-compiler time.)
711
712 ;;; This is used in SCAN-VOP-REFS to simultaneously do something to
713 ;;; all of the TNs referenced by a big more arg. We have to treat
714 ;;; these TNs specially, since when we set or clear the bit in the
715 ;;; live TNs, the represents a change in the liveness of all the more
716 ;;; TNs. If we iterated as normal, the next more ref would be thought
717 ;;; to be not live when it was, etc. We update Ref to be the last
718 ;;; :more ref we scanned, so that the main loop will step to the next
719 ;;; non-more ref.
720 (defmacro frob-more-tns (action)
721   `(when (eq (svref ltns num) :more)
722      (let ((prev ref))
723        (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
724            ((null mref))
725          (let ((mtn (tn-ref-tn mref)))
726            (unless (eql (tn-local-number mtn) num)
727              (return))
728            ,action)
729          (setq prev mref))
730        (setq ref prev))))
731
732 ;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs
733 ;;; for the current VOP. This macro shamelessly references free
734 ;;; variables in C-A-1-B.
735 (defmacro scan-vop-refs ()
736   '(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
737        ((null ref))
738      (let* ((tn (tn-ref-tn ref))
739             (num (tn-local-number tn)))
740        (cond
741         ((not num))
742         ((not (zerop (sbit live-bits num)))
743          (when (tn-ref-write-p ref)
744            (setf (sbit live-bits num) 0)
745            (deletef-in tn-next* live-list tn)
746            (frob-more-tns (deletef-in tn-next* live-list mtn))))
747         (t
748          (aver (not (tn-ref-write-p ref)))
749          (note-conflicts live-bits live-list tn num)
750          (frob-more-tns (note-conflicts live-bits live-list mtn num))
751          (setf (sbit live-bits num) 1)
752          (push-in tn-next* tn live-list)
753          (frob-more-tns (push-in tn-next* mtn live-list)))))))
754
755 ;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the
756 ;;; current VOP's results, and make any dead ones live. This is
757 ;;; necessary, since even though a result is dead after the VOP, it
758 ;;; may be in use for an extended period within the VOP (especially if
759 ;;; it has :FROM specified.) During this interval, temporaries must be
760 ;;; noted to conflict with the result. More results are finessed in
761 ;;; COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
762 (defmacro ensure-results-live ()
763   '(do ((res (vop-results vop) (tn-ref-across res)))
764        ((null res))
765      (let* ((tn (tn-ref-tn res))
766             (num (tn-local-number tn)))
767        (when (and num (zerop (sbit live-bits num)))
768          (unless (eq (svref ltns num) :more)
769            (note-conflicts live-bits live-list tn num)
770            (setf (sbit live-bits num) 1)
771            (push-in tn-next* tn live-list))))))
772
773 ;;; Compute the block-local conflict information for BLOCK. We iterate
774 ;;; over all the TN-REFs in a block in reference order, maintaining
775 ;;; the set of live TNs in both a list and a bit-vector
776 ;;; representation.
777 (defun conflict-analyze-1-block (block)
778   (declare (type ir2-block block))
779   (multiple-value-bind (live-bits live-list)
780       (compute-initial-conflicts block)
781     (let ((ltns (ir2-block-local-tns block)))
782       (do ((vop (ir2-block-last-vop block)
783                 (vop-prev vop)))
784           ((null vop))
785         (when (vop-info-save-p (vop-info vop))
786           (conflictize-save-p-vop vop block live-bits))
787         (ensure-results-live)
788         (scan-vop-refs)))))
789
790 ;;; Conflict analyze each block, and also add it.
791 (defun lifetime-post-pass (component)
792   (declare (type component component))
793   (do-ir2-blocks (block component)
794     (conflict-analyze-1-block block)))
795 \f
796 ;;;; alias TN stuff
797
798 ;;; Destructively modify OCONF to include the conflict information in CONF.
799 (defun merge-alias-block-conflicts (conf oconf)
800   (declare (type global-conflicts conf oconf))
801   (let* ((kind (global-conflicts-kind conf))
802          (num (global-conflicts-number conf))
803          (okind (global-conflicts-kind oconf))
804          (onum (global-conflicts-number oconf))
805          (block (global-conflicts-block oconf))
806          (ltns (ir2-block-local-tns block)))
807     (cond
808      ((eq okind :live))
809      ((eq kind :live)
810       (setf (global-conflicts-kind oconf) :live)
811       (setf (svref ltns onum) nil)
812       (setf (global-conflicts-number oconf) nil))
813      (t
814       (unless (eq kind okind)
815         (setf (global-conflicts-kind oconf) :read))
816       ;; Make original conflict with all the local TNs the alias
817       ;; conflicted with.
818       (bit-ior (global-conflicts-conflicts oconf)
819                (global-conflicts-conflicts conf)
820                t)
821       (flet ((frob (x)
822                (unless (zerop (sbit x num))
823                  (setf (sbit x onum) 1))))
824         ;; Make all the local TNs that conflicted with the alias
825         ;; conflict with the original.
826         (dotimes (i (ir2-block-local-tn-count block))
827           (let ((tn (svref ltns i)))
828             (when (and tn (not (eq tn :more))
829                        (null (tn-global-conflicts tn)))
830               (frob (tn-local-conflicts tn)))))
831         ;; Same for global TNs...
832         (do ((current (ir2-block-global-tns block)
833                       (global-conflicts-next-blockwise current)))
834             ((null current))
835           (unless (eq (global-conflicts-kind current) :live)
836             (frob (global-conflicts-conflicts current))))
837         ;; Make the original TN live everywhere that the alias was live.
838         (frob (ir2-block-written block))
839         (frob (ir2-block-live-in block))
840         (frob (ir2-block-live-out block))
841         (do ((vop (ir2-block-start-vop block)
842                   (vop-next vop)))
843             ((null vop))
844           (let ((sset (vop-save-set vop)))
845             (when sset (frob sset)))))))
846     ;; Delete the alias's conflict info.
847     (when num
848       (setf (svref ltns num) nil))
849     (deletef-in global-conflicts-next-blockwise
850                 (ir2-block-global-tns block)
851                 conf))
852
853   (values))
854
855 ;;; Co-opt CONF to be a conflict for TN.
856 (defun change-global-conflicts-tn (conf new)
857   (declare (type global-conflicts conf) (type tn new))
858   (setf (global-conflicts-tn conf) new)
859   (let ((ltn-num (global-conflicts-number conf))
860         (block (global-conflicts-block conf)))
861     (deletef-in global-conflicts-next-blockwise
862                 (ir2-block-global-tns block)
863                 conf)
864     (setf (global-conflicts-next-blockwise conf) nil)
865     (insert-block-global-conflict conf block)
866     (when ltn-num
867       (setf (svref (ir2-block-local-tns block) ltn-num) new)))
868   (values))
869
870 ;;; Do CONVERT-TO-GLOBAL on TN if it has no global conflicts. Copy the
871 ;;; local conflicts into the global bit vector.
872 (defun ensure-global-tn (tn)
873   (declare (type tn tn))
874   (cond ((tn-global-conflicts tn))
875         ((tn-local tn)
876          (convert-to-global tn)
877          (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
878                   (tn-local-conflicts tn)
879                   t))
880         (t
881          (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))
882   (values))
883
884 ;;; For each :ALIAS TN, destructively merge the conflict info into the
885 ;;; original TN and replace the uses of the alias.
886 ;;;
887 ;;; For any block that uses only the alias TN, just insert that
888 ;;; conflict into the conflicts for the original TN, changing the LTN
889 ;;; map to refer to the original TN. This gives a result
890 ;;; indistinguishable from the what there would have been if the
891 ;;; original TN had always been referenced. This leaves no sign that
892 ;;; an alias TN was ever involved.
893 ;;;
894 ;;; If a block has references to both the alias and the original TN,
895 ;;; then we call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts
896 ;;; into the original conflict.
897 (defun merge-alias-conflicts (component)
898   (declare (type component component))
899   (do ((tn (ir2-component-alias-tns (component-info component))
900            (tn-next tn)))
901       ((null tn))
902     (let ((original (tn-save-tn tn)))
903       (ensure-global-tn tn)
904       (ensure-global-tn original)
905       (let ((conf (tn-global-conflicts tn))
906             (oconf (tn-global-conflicts original))
907             (oprev nil))
908         (loop
909           (unless oconf
910             (if oprev
911                 (setf (global-conflicts-next-tnwise oprev) conf)
912                 (setf (tn-global-conflicts original) conf))
913             (do ((current conf (global-conflicts-next-tnwise current)))
914                 ((null current))
915               (change-global-conflicts-tn current original))
916             (return))
917           (let* ((block (global-conflicts-block conf))
918                  (num (ir2-block-number block))
919                  (onum (ir2-block-number (global-conflicts-block oconf))))
920
921             (cond ((< onum num)
922                    (shiftf oprev oconf (global-conflicts-next-tnwise oconf)))
923                   ((> onum num)
924                    (if oprev
925                        (setf (global-conflicts-next-tnwise oprev) conf)
926                        (setf (tn-global-conflicts original) conf))
927                    (change-global-conflicts-tn conf original)
928                    (shiftf oprev
929                            conf
930                            (global-conflicts-next-tnwise conf)
931                            oconf))
932                   (t
933                    (merge-alias-block-conflicts conf oconf)
934                    (shiftf oprev oconf (global-conflicts-next-tnwise oconf))
935                    (setf conf (global-conflicts-next-tnwise conf)))))
936           (unless conf (return))))
937
938       (flet ((frob (refs)
939                (let ((ref refs)
940                      (next nil))
941                  (loop
942                    (unless ref (return))
943                    (setq next (tn-ref-next ref))
944                    (change-tn-ref-tn ref original)
945                    (setq ref next)))))
946         (frob (tn-reads tn))
947         (frob (tn-writes tn)))
948       (setf (tn-global-conflicts tn) nil)))
949
950   (values))
951
952 ;;; On high debug levels, for all variables that a lambda closes over
953 ;;; convert the TNs to :ENVIRONMENT TNs (in the physical environment
954 ;;; of that lambda). This way the debugger can display the variables.
955 (defun maybe-environmentalize-closure-tns (component)
956   (dolist (lambda (component-lambdas component))
957     (when (policy lambda (>= debug 2))
958       (let ((physenv (lambda-physenv lambda)))
959         (dolist (closure-var (physenv-closure physenv))
960           (let ((tn (find-in-physenv closure-var physenv)))
961             (when (member (tn-kind tn) '(:normal :debug-environment))
962               (convert-to-environment-tn tn physenv))))))))
963
964 \f
965 (defun lifetime-analyze (component)
966   (lifetime-pre-pass component)
967   (maybe-environmentalize-closure-tns component)
968   (setup-environment-live-conflicts component)
969   (lifetime-flow-analysis component)
970   (lifetime-post-pass component)
971   (merge-alias-conflicts component))
972 \f
973 ;;;; conflict testing
974
975 ;;; Test for a conflict between the local TN X and the global TN Y. We
976 ;;; just look for a global conflict of Y in X's block, and then test
977 ;;; for conflict in that block.
978 ;;;
979 ;;; [### Might be more efficient to scan Y's global conflicts. This
980 ;;; depends on whether there are more global TNs than blocks.]
981 (defun tns-conflict-local-global (x y)
982   (let ((block (tn-local x)))
983     (do ((conf (ir2-block-global-tns block)
984                (global-conflicts-next-blockwise conf)))
985         ((null conf) nil)
986       (when (eq (global-conflicts-tn conf) y)
987         (let ((num (global-conflicts-number conf)))
988           (return (or (not num)
989                       (not (zerop (sbit (tn-local-conflicts x)
990                                         num))))))))))
991
992 ;;; Test for conflict between two global TNs X and Y.
993 (defun tns-conflict-global-global (x y)
994   (declare (type tn x y))
995   (let* ((x-conf (tn-global-conflicts x))
996          (x-num (ir2-block-number (global-conflicts-block x-conf)))
997          (y-conf (tn-global-conflicts y))
998          (y-num (ir2-block-number (global-conflicts-block y-conf))))
999
1000     (macrolet ((advance (n c)
1001                  `(progn
1002                     (setq ,c (global-conflicts-next-tnwise ,c))
1003                     (unless ,c (return-from tns-conflict-global-global nil))
1004                     (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
1005                (scan (g l lc)
1006                  `(do ()
1007                       ((>= ,g ,l))
1008                     (advance ,l ,lc))))
1009
1010       (loop
1011         ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
1012         (scan x-num y-num y-conf)
1013         (scan y-num x-num x-conf)
1014         (when (= x-num y-num)
1015           (let ((ltn-num-x (global-conflicts-number x-conf)))
1016             (unless (and ltn-num-x
1017                          (global-conflicts-number y-conf)
1018                          (zerop (sbit (global-conflicts-conflicts y-conf)
1019                                       ltn-num-x)))
1020               (return t))
1021             (advance x-num x-conf)
1022             (advance y-num y-conf)))))))
1023
1024 ;;; Return true if X and Y are distinct and the lifetimes of X and Y
1025 ;;; overlap at any point.
1026 (defun tns-conflict (x y)
1027   (declare (type tn x y))
1028   (let ((x-kind (tn-kind x))
1029         (y-kind (tn-kind y)))
1030     (cond ((eq x y) nil)
1031           ((or (eq x-kind :component) (eq y-kind :component)) t)
1032           ((tn-global-conflicts x)
1033            (if (tn-global-conflicts y)
1034                (tns-conflict-global-global x y)
1035                (tns-conflict-local-global y x)))
1036           ((tn-global-conflicts y)
1037            (tns-conflict-local-global x y))
1038           (t
1039            (and (eq (tn-local x) (tn-local y))
1040                 (not (zerop (sbit (tn-local-conflicts x)
1041                                   (tn-local-number y)))))))))