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