/[cmucl]/src/compiler/life.lisp
ViewVC logotype

Contents of /src/compiler/life.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Mon Jul 23 14:52:33 1990 UTC (23 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.10: +4 -7 lines
Use block-environment instead of obsolete block-lambda, use block-start
to test for head/tail block instead of block-lambda.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; This file contains the lifetime analysis phase in the compiler.
11 ;;;
12 ;;; Written by Rob MacLachlan
13 ;;;
14 (in-package 'c)
15
16
17 ;;;; Utilities:
18
19 ;;; Add-Global-Conflict -- Internal
20 ;;;
21 ;;; Link in a global-conflicts structure for TN in Block with Number as the
22 ;;; LTN number. The conflict is inserted in the per-TN Global-Conflicts thread
23 ;;; after the TN's Current-Conflict. We change the Current-Conflict to point
24 ;;; to the new conflict. Since we scan the blocks in reverse DFO, this list is
25 ;;; automatically built in order. We have to actually scan the current
26 ;;; Global-TNs for the block in order to keep that thread sorted.
27 ;;;
28 (defun add-global-conflict (kind tn block number)
29 (declare (type (member :read :write :read-only :live) kind)
30 (type tn tn) (type ir2-block block)
31 (type (or local-tn-number null) number))
32 (let ((new (make-global-conflicts kind tn block number)))
33 (let ((last (tn-current-conflict tn)))
34 (if last
35 (shiftf (global-conflicts-tn-next new)
36 (global-conflicts-tn-next last)
37 new)
38 (shiftf (global-conflicts-tn-next new)
39 (tn-global-conflicts tn)
40 new)))
41 (setf (tn-current-conflict tn) new)
42
43 (let ((global-num (tn-number tn)))
44 (do ((prev nil conf)
45 (conf (ir2-block-global-tns block)
46 (global-conflicts-next conf)))
47 ((or (null conf)
48 (> (tn-number (global-conflicts-tn conf)) global-num))
49 (if prev
50 (setf (global-conflicts-next prev) new)
51 (setf (ir2-block-global-tns block) new))
52 (setf (global-conflicts-next new) conf)))))
53 (undefined-value))
54
55
56 ;;; Reset-Current-Conflict -- Internal
57 ;;;
58 ;;; Reset the Current-Conflict slot in all packed TNs to point to the head
59 ;;; of the Global-Conflicts thread.
60 ;;;
61 (defun reset-current-conflict (component)
62 (do-packed-tns (tn component)
63 (setf (tn-current-conflict tn) (tn-global-conflicts tn))))
64
65
66 ;;;; Pre-pass:
67
68 ;;; Convert-To-Global -- Internal
69 ;;;
70 ;;; Convert TN (currently local) to be a global TN, since we discovered that
71 ;;; it is referenced in more than one block. We just add a global-conflicts
72 ;;; structure with a kind derived from the Kill and Live sets.
73 ;;;
74 (defun convert-to-global (tn)
75 (declare (type tn tn))
76 (let ((block (tn-local tn))
77 (num (tn-local-number tn)))
78 (add-global-conflict
79 (if (zerop (sbit (ir2-block-written block) num))
80 :read-only
81 (if (zerop (sbit (ir2-block-live-out block) num))
82 :write
83 :read))
84 tn block num))
85 (undefined-value))
86
87
88 ;;; Find-Local-References -- Internal
89 ;;;
90 ;;; Scan all references to packed TNs in block. We assign LTN numbers to
91 ;;; each referenced TN, and also build the Kill and Live sets that summarize
92 ;;; the references to each TN for purposes of lifetime analysis.
93 ;;;
94 ;;; It is possible that we will run out of LTN numbers. If this happens,
95 ;;; then we return the VOP that we were processing at the time we ran out,
96 ;;; otherwise we return NIL.
97 ;;;
98 ;;; If a TN is referenced in more than one block, then we must represent
99 ;;; references using Global-Conflicts structures. When we first see a TN, we
100 ;;; assume it will be local. If we see a reference later on in a different
101 ;;; block, then we go back and fix the TN to global.
102 ;;;
103 ;;; We must globalize TNs that have a block other than the current one in
104 ;;; their Local slot and have no Global-Conflicts. The latter condition is
105 ;;; necessary because we always set Local and Local-Number when we process a
106 ;;; reference to a TN, even when the TN is already known to be global.
107 ;;;
108 ;;; When we see reference to global TNs during the scan, we add the
109 ;;; global-conflict as :Read-Only, since we don't know the corrent kind until
110 ;;; we are done scanning the block.
111 ;;;
112 (defun find-local-references (block)
113 (declare (type ir2-block block))
114 (let ((kill (ir2-block-written block))
115 (live (ir2-block-live-out block))
116 (tns (ir2-block-local-tns block)))
117 (let ((ltn-num (ir2-block-local-tn-count block)))
118 (do ((vop (ir2-block-last-vop block)
119 (vop-prev vop)))
120 ((null vop))
121 (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
122 ((null ref))
123 (let* ((tn (tn-ref-tn ref))
124 (local (tn-local tn))
125 (kind (tn-kind tn)))
126 (when (eq kind :normal)
127 (unless (eq local block)
128 (when (= ltn-num local-tn-limit)
129 (return-from find-local-references vop))
130 (when local
131 (unless (tn-global-conflicts tn)
132 (convert-to-global tn))
133 (add-global-conflict :read-only tn block ltn-num))
134
135 (setf (tn-local tn) block)
136 (setf (tn-local-number tn) ltn-num)
137 (setf (svref tns ltn-num) tn)
138 (incf ltn-num))
139
140 (let ((num (tn-local-number tn)))
141 (if (tn-ref-write-p ref)
142 (setf (sbit kill num) 1 (sbit live num) 0)
143 (setf (sbit live num) 1)))))))
144
145 (setf (ir2-block-local-tn-count block) ltn-num)))
146 nil)
147
148
149 ;;; Init-Global-Conflict-Kind -- Internal
150 ;;;
151 ;;; Finish up the global conflicts for TNs referenced in Block according to
152 ;;; the local Kill and Live sets.
153 ;;;
154 ;;; We set the kind for TNs already in the global-TNs. If not written at
155 ;;; all, then is :Read-Only, the default. Must have been referenced somehow,
156 ;;; or we wouldn't have conflicts for it.
157 ;;;
158 ;;; We also iterate over all the local TNs, looking for TNs local to this
159 ;;; block that are still live at the block beginning, and thus must be global.
160 ;;; This case is only important when a TN is read in a block but not written in
161 ;;; any other, since otherwise the write would promote the TN to global. But
162 ;;; this does happen with various passing-location TNs that are magically
163 ;;; written. This also serves to propagate the lives of erroneously
164 ;;; uninitialized TNs so that consistency checks can detect them.
165 ;;;
166 (defun init-global-conflict-kind (block)
167 (declare (type ir2-block block))
168 (let ((live (ir2-block-live-out block)))
169 (let ((kill (ir2-block-written block)))
170 (do ((conf (ir2-block-global-tns block)
171 (global-conflicts-next conf)))
172 ((null conf))
173 (let ((num (global-conflicts-number conf)))
174 (unless (zerop (sbit kill num))
175 (setf (global-conflicts-kind conf)
176 (if (zerop (sbit live num))
177 :write
178 :read))))))
179
180 (let ((ltns (ir2-block-local-tns block)))
181 (dotimes (i (ir2-block-local-tn-count block))
182 (let ((tn (svref ltns i)))
183 (unless (or (eq tn :more)
184 (tn-global-conflicts tn)
185 (zerop (sbit live i)))
186 (convert-to-global tn))))))
187
188 (undefined-value))
189
190
191 (defevent split-ir2-block "Split an IR2 block to meet Local-TN-Limit.")
192
193 ;;; Split-IR2-Blocks -- Internal
194 ;;;
195 ;;; Move the code after the VOP Lose in 2block into its own block. The
196 ;;; block is linked into the emit order following 2block. Number is the block
197 ;;; number assigned to the new block. We return the new block.
198 ;;;
199 (defun split-ir2-blocks (2block lose number)
200 (declare (type ir2-block 2block) (type vop lose)
201 (type unsigned-byte number))
202 (event split-ir2-block (vop-node lose))
203 (let ((new (make-ir2-block (ir2-block-block 2block)))
204 (new-start (vop-next lose)))
205 (setf (ir2-block-number new) number)
206 (add-to-emit-order new 2block)
207
208 (do ((vop new-start (vop-next vop)))
209 ((null vop))
210 (setf (vop-block vop) new))
211
212 (setf (ir2-block-start-vop new) new-start)
213 (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose)
214
215 (setf (vop-next lose) nil)
216 (setf (vop-prev new-start) nil)
217
218 new))
219
220
221 ;;; Clear-Lifetime-Info -- Internal
222 ;;;
223 ;;; Clear the global and local conflict info in Block so that we can
224 ;;; recompute it without any old cruft being retained. It is assumed that all
225 ;;; LTN numbers are in use.
226 ;;;
227 ;;; First we delete all the global conflicts. The conflict we are deleting
228 ;;; must be the last in the TN's global-conflicts, but we must scan for it in
229 ;;; order to find the previous conflict.
230 ;;;
231 ;;; Next, we scan the local TNs, nulling out the Local slot in all TNs with
232 ;;; no global conflicts. This allows these TNs to be treated as local when we
233 ;;; scan the block again.
234 ;;;
235 ;;; If there are conflicts, then we set Local to one of the conflicting
236 ;;; blocks. This ensures that Local doesn't hold over Block as its value,
237 ;;; causing the subsequent reanalysis to think that the TN has already been
238 ;;; seen in that block.
239 ;;;
240 ;;; This function must not be called on blocks that have :More TNs.
241 ;;;
242 (defun clear-lifetime-info (block)
243 (declare (type ir2-block block))
244 (setf (ir2-block-local-tn-count block) 0)
245
246 (do ((conf (ir2-block-global-tns block)
247 (global-conflicts-next conf)))
248 ((null conf)
249 (setf (ir2-block-global-tns block) nil))
250 (let ((tn (global-conflicts-tn conf)))
251 (assert (eq (tn-current-conflict tn) conf))
252 (assert (null (global-conflicts-tn-next conf)))
253 (do ((current (tn-global-conflicts tn)
254 (global-conflicts-tn-next current))
255 (prev nil current))
256 ((eq current conf)
257 (if prev
258 (setf (global-conflicts-tn-next prev) nil)
259 (setf (tn-global-conflicts tn) nil))
260 (setf (tn-current-conflict tn) prev)))))
261
262 (fill (ir2-block-written block) 0)
263 (let ((ltns (ir2-block-local-tns block)))
264 (dotimes (i local-tn-limit)
265 (let ((tn (svref ltns i)))
266 (assert (not (eq tn :more)))
267 (let ((conf (tn-global-conflicts tn)))
268 (setf (tn-local tn)
269 (if conf
270 (global-conflicts-block conf)
271 nil))))))
272
273 (undefined-value))
274
275
276 ;;; Coalesce-More-LTN-Numbers -- Internal
277 ;;;
278 ;;; This provides a panic mode for assigning LTN numbers when there is a VOP
279 ;;; with so many more operands that they can't all be assigned distinct
280 ;;; numbers. When this happens, we recover by assigning all the more operands
281 ;;; the same LTN number. We can get away with this, since all more args (and
282 ;;; results) are referenced simultaneously as far as conflict analysis is
283 ;;; concerned.
284 ;;;
285 ;;; Block is the IR2-Block that the more VOP is at the end of. Ops is the
286 ;;; full argument or result TN-Ref list. Fixed is the types of the fixed
287 ;;; operands (used only to skip those operands.)
288 ;;;
289 ;;; What we do is grab a LTN number, then make a :Read-Only global conflict
290 ;;; for each more operand TN. We require that there be no existing global
291 ;;; conflict in Block for any of the operands. Since conflicts must be cleared
292 ;;; before the first call, this only prohibits the same TN being used both as a
293 ;;; more operand and as any other operand to the same VOP.
294 ;;;
295 ;;; We don't have to worry about getting the correct conflict kind, since
296 ;;; Init-Global-Conflict-Kind will fix things up.
297 ;;;
298 ;;; We also set the Local and Local-Number slots in each TN.
299 ;;;
300 (defun coalesce-more-ltn-numbers (block ops fixed)
301 (declare (type ir2-block block) (type tn-ref ops) (list fixed))
302 (let ((num (ir2-block-local-tn-count block)))
303 (assert (< num local-tn-limit))
304 (incf (ir2-block-local-tn-count block))
305 (setf (svref (ir2-block-local-tns block) num) :more)
306
307 (do ((op (do ((op ops (tn-ref-across op))
308 (i 0 (1+ i)))
309 ((= i (length fixed)) op))
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 (assert (not (find-in #'global-conflicts-next 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 (undefined-value))
330
331
332 (defevent coalesce-more-ltn-numbers
333 "Coalesced LTN numbers for a more operand to meet Local-TN-Limit.")
334
335 ;;; Lifetime-Pre-Pass -- Internal
336 ;;;
337 ;;; Loop over the blocks in Component, assigning LTN numbers and recording
338 ;;; TN birth and death. The only interesting action is when we run out of
339 ;;; local TN numbers while finding local references.
340 ;;;
341 ;;; If we run out of LTN numbers while processing a VOP within the block,
342 ;;; then we just split off the VOPs we have successfully processed into their
343 ;;; own block.
344 ;;;
345 ;;; If we run out of LTN numbers while processing the our first VOP (the
346 ;;; last in the block), then it must be the case that this VOP has large more
347 ;;; operands. We split the VOP into its own block, and then call
348 ;;; Coalesce-More-Ltn-Numbers to assign all the more args/results the same LTN
349 ;;; number(s).
350 ;;;
351 ;;; In either case, we clear the lifetime information that we computed so
352 ;;; far, recomputing it after taking corrective action.
353 ;;;
354 ;;; Whenever we split a block, we finish the pre-pass on the split-off block
355 ;;; by doing Find-Local-References and Init-Global-Conflict-Kind. This can't
356 ;;; run out of LTN numbers.
357 ;;;
358 (defun lifetime-pre-pass (component)
359 (declare (type component component))
360 (let ((counter -1))
361 (do-blocks-backwards (block component)
362 (let ((2block (block-info block)))
363 (do ((lose (find-local-references 2block)
364 (find-local-references 2block))
365 (last-lose nil lose)
366 (coalesced nil))
367 ((not lose)
368 (init-global-conflict-kind 2block)
369 (setf (ir2-block-number 2block) (incf counter)))
370
371 (clear-lifetime-info 2block)
372
373 (cond
374 ((vop-next lose)
375 (assert (not (eq last-lose lose)))
376 (let ((new (split-ir2-blocks 2block lose (incf counter))))
377 (assert (not (find-local-references new)))
378 (init-global-conflict-kind new)))
379 (t
380 (assert (not (eq lose coalesced)))
381 (setq coalesced lose)
382 (event coalesce-more-ltn-numbers (vop-node lose))
383 (let ((info (vop-info lose))
384 (new (if (vop-prev lose)
385 (split-ir2-blocks 2block (vop-prev lose)
386 (incf counter))
387 2block)))
388 (coalesce-more-ltn-numbers new (vop-args lose)
389 (vop-info-arg-types info))
390 (coalesce-more-ltn-numbers new (vop-results lose)
391 (vop-info-result-types info))
392 (assert (not (find-local-references new)))
393 (init-global-conflict-kind new))))))))
394
395 (undefined-value))
396
397
398 ;;;; Flow analysis:
399
400 ;;; Propagate-Live-TNs -- Internal
401 ;;;
402 ;;; For each Global-TN in Block2 that is :Live, :Read or :Read-Only, ensure
403 ;;; that there is a corresponding Global-Conflict in Block1. If there is none,
404 ;;; make a :Live Global-Conflict. If there is a :Read-Only conflict, promote
405 ;;; it to :Live.
406 ;;;
407 ;;; If we did added a new conflict, return true, otherwise false. We don't
408 ;;; need to return true when we promote a :Read-Only conflict, since it doesn't
409 ;;; reveal any new information to predecessors of Block1.
410 ;;;
411 ;;; We use the Tn-Current-Conflict to walk through the global
412 ;;; conflicts. Since the global conflicts for a TN are ordered by block, we
413 ;;; can be sure that the Current-Conflict always points at or before the block
414 ;;; that we are looking at. This allows us to quickly determine if there is a
415 ;;; global conflict for a given TN in Block1.
416 ;;;
417 ;;; When we scan down the conflicts, we know that there must be at least one
418 ;;; conflict for TN, since we got our hands on TN by picking it out of a
419 ;;; conflict in Block2.
420 ;;;
421 ;;; We leave the Current-Conflict pointing to the conflict for Block1. The
422 ;;; Current-Conflict must be initialized to the head of the Global-Conflicts
423 ;;; for the TN between each flow analysis iteration.
424 ;;;
425 (defun propagate-live-tns (block1 block2)
426 (declare (type ir2-block block1 block2))
427 (let ((live-in (ir2-block-live-in block1))
428 (did-something nil))
429 (do ((conf2 (ir2-block-global-tns block2)
430 (global-conflicts-next conf2)))
431 ((null conf2))
432 (ecase (global-conflicts-kind conf2)
433 ((:live :read :read-only)
434 (let* ((tn (global-conflicts-tn conf2))
435 (tn-conflicts (tn-current-conflict tn))
436 (number1 (ir2-block-number block1)))
437 (assert tn-conflicts)
438 (do ((current tn-conflicts (global-conflicts-tn-next current))
439 (prev nil current))
440 ((or (null current)
441 (> (ir2-block-number (global-conflicts-block current))
442 number1))
443 (setf (tn-current-conflict tn) prev)
444 (add-global-conflict :live tn block1 nil)
445 (setq did-something t))
446 (when (eq (global-conflicts-block current) block1)
447 (case (global-conflicts-kind current)
448 (:live)
449 (:read-only
450 (setf (global-conflicts-kind current) :live)
451 (setf (svref (ir2-block-local-tns block1)
452 (global-conflicts-number current))
453 nil)
454 (setf (global-conflicts-number current) nil)
455 (setf (tn-current-conflict tn) current))
456 (t
457 (setf (sbit live-in (global-conflicts-number current)) 1)))
458 (return)))))
459 (:write)))
460 did-something))
461
462
463 ;;; Lifetime-Flow-Analysis -- Internal
464 ;;;
465 ;;; Do backward global flow analysis to find all TNs live at each block
466 ;;; boundary.
467 ;;;
468 (defun lifetime-flow-analysis (component)
469 (loop
470 (reset-current-conflict component)
471 (let ((did-something nil))
472 (do-blocks-backwards (block component)
473 (let* ((2block (block-info block))
474 (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
475 (prev 2block b))
476 ((not (eq (ir2-block-block b) block))
477 prev))))
478
479 (dolist (b (block-succ block))
480 (when (and (block-start b)
481 (propagate-live-tns last (block-info b)))
482 (setq did-something t)))
483
484 (do ((b (ir2-block-prev last) (ir2-block-prev b))
485 (prev last b))
486 ((not (eq (ir2-block-block b) block)))
487 (when (propagate-live-tns b prev)
488 (setq did-something t)))))
489
490 (unless did-something (return))))
491
492 (undefined-value))
493
494
495 ;;;; Post-pass:
496
497 ;;; Convert-To-Environment-TN -- Internal
498 ;;;
499 ;;; Convert a :Normal TN to an :Environment TN. This requires deleting the
500 ;;; existing conflict info.
501 ;;;
502 (defun convert-to-environment-tn (tn)
503 (declare (type tn tn))
504 (assert (eq (tn-kind tn) :normal))
505 (let ((confs (tn-global-conflicts tn)))
506 (if confs
507 (do ((conf confs (global-conflicts-tn-next conf)))
508 ((null conf))
509 (let ((block (global-conflicts-block conf)))
510 (unless (eq (global-conflicts-kind conf) :live)
511 (let ((ltns (ir2-block-local-tns block))
512 (num (global-conflicts-number conf)))
513 (assert (not (eq (svref ltns num) :more)))
514 (setf (svref ltns num) nil)))
515 (deletef-in global-conflicts-next (ir2-block-global-tns block)
516 conf)))
517 (setf (svref (ir2-block-local-tns (tn-local tn))
518 (tn-local-number tn))
519 nil))
520 (setf (tn-local tn) nil)
521 (setf (tn-local-number tn) nil)
522 (setf (tn-global-conflicts tn) nil)
523 (setf (tn-kind tn) :environment)
524 (push tn (ir2-environment-live-tns
525 (environment-info
526 (tn-environment tn)))))
527 (undefined-value))
528
529
530 ;;; Note-Conflicts -- Internal
531 ;;;
532 ;;; Note that TN conflicts with all current live TNs. Num is TN's LTN
533 ;;; number. We bit-ior Live-Bits with TN's Local-Conflicts, and set TN's
534 ;;; number in the conflicts of all TNs in Live-List.
535 ;;;
536 (defun note-conflicts (live-bits live-list tn num)
537 (declare (type tn tn) (type (or tn null) live-list)
538 (type local-tn-bit-vector live-bits)
539 (type local-tn-number num))
540 (let ((lconf (tn-local-conflicts tn)))
541 (bit-ior live-bits lconf lconf))
542 (do ((live live-list (tn-next* live)))
543 ((null live))
544 (setf (sbit (tn-local-conflicts live) num) 1))
545 (undefined-value))
546
547
548 ;;; Compute-Save-Set -- Internal
549 ;;;
550 ;;; Compute a bit vector of the TNs live after VOP that aren't results.
551 ;;;
552 (defun compute-save-set (vop live-bits)
553 (declare (type vop vop) (type local-tn-bit-vector live-list))
554 (let ((live (bit-vector-copy live-bits)))
555 (do ((r (vop-results vop) (tn-ref-across r)))
556 ((null r))
557 (let ((tn (tn-ref-tn r)))
558 (ecase (tn-kind tn)
559 (:normal (setf (sbit live (tn-local-number tn)) 0))
560 (:environment :component))))
561 live))
562
563
564 ;;; Compute-Initial-Conflicts -- Internal
565 ;;;
566 ;;; Return as values, a LTN bit-vector and a list (threaded by TN-Next*)
567 ;;; representing the TNs live at the end of Block (exclusive of :Live TNs).
568 ;;;
569 ;;; We iterate over the TNs in the global conflicts that are live at the block
570 ;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
571 ;;; TN to the live list.
572 ;;;
573 ;;; ### Note: we alias the global-conflicts-conflicts here as the
574 ;;; tn-local-conflicts.
575 ;;;
576 (defun compute-initial-conflicts (block)
577 (declare (type ir2-block block))
578 (let ((live-bits (bit-vector-copy (ir2-block-live-in block)))
579 (live-list nil))
580
581 (do ((conf (ir2-block-global-tns block)
582 (global-conflicts-next conf)))
583 ((null conf))
584 (let ((bits (global-conflicts-conflicts conf))
585 (tn (global-conflicts-tn conf))
586 (num (global-conflicts-number conf)))
587 (setf (tn-local-number tn) num)
588 (unless (eq (global-conflicts-kind conf) :live)
589 (unless (zerop (sbit live-bits num))
590 (bit-vector-replace bits live-bits)
591 (setf (sbit bits num) 0)
592 (push-in tn-next* tn live-list))
593 (setf (tn-local-conflicts tn) bits))))
594
595 (values live-bits live-list)))
596
597
598 (eval-when (compile eval)
599
600 ;;; Frob-More-TNs -- Internal
601 ;;;
602 ;;; Used in the guts of Conflict-Analyze-1-Block to simultaneously do
603 ;;; something to all of the TNs referenced by a big more arg. We have to treat
604 ;;; these TNs specially, since when we set or clear the bit in the live TNs,
605 ;;; the represents a change in the liveness of all the more TNs. If we
606 ;;; iterated as normal, the next more ref would be thought to be not live when
607 ;;; it was, etc. We return true if there where more TNs.
608 ;;;
609 (defmacro frob-more-tns (action)
610 `(when (eq (svref ltns num) :more)
611 (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
612 ((null mref))
613 (let ((mtn (tn-ref-tn mref)))
614 (unless (eql (tn-local-number mtn) num)
615 (return))
616 ,action))
617 t))
618
619 ); Eval-When (Compile Eval)
620
621
622 ;;; Conflict-Analyze-1-Block -- Internal
623 ;;;
624 ;;; Compute the block-local conflict information for Block. We iterate over
625 ;;; all the TN-Refs in a block in reference order, maintaining the set of live
626 ;;; TNs in both a list and a bit-vector representation.
627 ;;;
628 (defun conflict-analyze-1-block (block)
629 (declare (type ir2-block block))
630 (multiple-value-bind
631 (live-bits live-list)
632 (compute-initial-conflicts block)
633 (let ((ltns (ir2-block-local-tns block)))
634
635 (do ((vop (ir2-block-last-vop block)
636 (vop-prev vop)))
637 ((null vop))
638
639 (let ((save-p (vop-info-save-p (vop-info vop))))
640 (when save-p
641 (let ((ss (compute-save-set vop live-bits)))
642 (setf (vop-save-set vop) ss)
643 (when (eq save-p :force-to-stack)
644 (do-live-tns (tn ss block)
645 (unless (eq (tn-kind tn) :component)
646 (force-tn-to-stack tn)
647 (unless (eq (tn-kind tn) :environment)
648 (convert-to-environment-tn tn))))))))
649
650 (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
651 ((null ref))
652 (let* ((tn (tn-ref-tn ref))
653 (num (tn-local-number tn)))
654
655 (cond
656 ((not num))
657 ((not (zerop (sbit live-bits num)))
658 (when (tn-ref-write-p ref)
659 (setf (sbit live-bits num) 0)
660 (deletef-in tn-next* live-list tn)
661 (when (frob-more-tns (deletef-in tn-next* live-list mtn))
662 (return))))
663 ((tn-ref-write-p ref)
664 (note-conflicts live-bits live-list tn num))
665 (t
666 (note-conflicts live-bits live-list tn num)
667 (frob-more-tns (note-conflicts live-bits live-list mtn num))
668 (setf (sbit live-bits num) 1)
669 (push-in tn-next* tn live-list)
670 (when (frob-more-tns (push-in tn-next* mtn live-list))
671 (return))))))))))
672
673
674 ;;; Lifetime-Post-Pass -- Internal
675 ;;;
676 ;;; Conflict analyze each block, and also add it
677 (defun lifetime-post-pass (component)
678 (declare (type component component))
679 (do-ir2-blocks (block component)
680 (conflict-analyze-1-block block)))
681
682
683 ;;; Lifetime-Analyze -- Interface
684 ;;;
685 ;;;
686 (defun lifetime-analyze (component)
687 (lifetime-pre-pass component)
688 (lifetime-flow-analysis component)
689 (lifetime-post-pass component))
690
691
692 ;;;; Conflict testing:
693
694 ;;; TNs-Conflict-Local-Global -- Internal
695 ;;;
696 ;;; Test for a conflict between the local TN X and the global TN Y. We just
697 ;;; look for a global conflict of Y in X's block, and then test for conflict in
698 ;;; that block.
699 ;;; [### Might be more efficient to scan Y's global conflicts. This depends on
700 ;;; whether there are more global TNs than blocks.]
701 ;;;
702 (defun tns-conflict-local-global (x y)
703 (let ((block (tn-local x)))
704 (do ((conf (ir2-block-global-tns block)
705 (global-conflicts-next conf)))
706 ((null conf) nil)
707 (when (eq (global-conflicts-tn conf) y)
708 (let ((num (global-conflicts-number conf)))
709 (return (or (not num)
710 (not (zerop (sbit (tn-local-conflicts x)
711 num))))))))))
712
713
714 ;;; TNs-Conflict-Global-Global -- Internal
715 ;;;
716 ;;; Test for conflict between two global TNs X and Y.
717 ;;;
718 (defun tns-conflict-global-global (x y)
719 (declare (type tn x y))
720 (let* ((x-conf (tn-global-conflicts x))
721 (x-num (ir2-block-number (global-conflicts-block x-conf)))
722 (y-conf (tn-global-conflicts y))
723 (y-num (ir2-block-number (global-conflicts-block y-conf))))
724
725 (macrolet ((advance (n c)
726 `(progn
727 (setq ,c (global-conflicts-tn-next ,c))
728 (unless ,c (return-from tns-conflict-global-global nil))
729 (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
730 (scan (g l lc)
731 `(do ()
732 ((>= ,g ,l))
733 (advance ,l ,lc))))
734
735 (loop
736 ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
737 (scan x-num y-num y-conf)
738 (scan y-num x-num x-conf)
739 (when (= x-num y-num)
740 (let ((ltn-num-x (global-conflicts-number x-conf)))
741 (unless (and ltn-num-x
742 (global-conflicts-number y-conf)
743 (zerop (sbit (global-conflicts-conflicts y-conf)
744 ltn-num-x)))
745 (return t))
746 (advance x-num x-conf)
747 (advance y-num y-conf)))))))
748
749
750 ;;; TNs-Conflict-Environment-Global -- Interface
751 ;;;
752 ;;; Return true if any of Y's blocks are in X's environment.
753 ;;;
754 (defun tns-conflict-environment-global (x y)
755 (declare (type tn x y))
756 (let ((env (tn-environment x)))
757 (do ((conf (tn-global-conflicts y) (global-conflicts-tn-next conf)))
758 ((null conf)
759 nil)
760 (when (eq (block-environment
761 (ir2-block-block (global-conflicts-block conf)))
762 env)
763 (return t)))))
764
765
766 ;;; TNs-Conflict-Environment-Local -- Interface
767 ;;;
768 ;;; Return true if Y's block is in X's environment.
769 ;;;
770 (defun tns-conflict-environment-local (x y)
771 (declare (type tn x y))
772 (eq (block-environment (ir2-block-block (tn-local y)))
773 (tn-environment x)))
774
775
776 ;;; TNs-Conflict -- Interface
777 ;;;
778 ;;; Return true if X and Y are distinct and the lifetimes of X and Y overlap
779 ;;; at any point.
780 ;;;
781 (defun tns-conflict (x y)
782 (declare (type tn x y))
783 (let ((x-kind (tn-kind x))
784 (y-kind (tn-kind y)))
785 (cond ((eq x y) nil)
786 ((eq x-kind :environment)
787 (cond ((tn-global-conflicts y)
788 (tns-conflict-environment-global x y))
789 ((eq (tn-kind y) :environment)
790 (eq (tn-environment x) (tn-environment y)))
791 (t
792 (tns-conflict-environment-local x y))))
793 ((eq y-kind :environment)
794 (if (tn-global-conflicts x)
795 (tns-conflict-environment-global y x)
796 (tns-conflict-environment-local y x)))
797 ((or (eq x-kind :component) (eq y-kind :component)) t)
798 ((tn-global-conflicts x)
799 (if (tn-global-conflicts y)
800 (tns-conflict-global-global x y)
801 (tns-conflict-local-global y x)))
802 ((tn-global-conflicts y)
803 (tns-conflict-local-global x y))
804 (t
805 (and (eq (tn-local x) (tn-local y))
806 (not (zerop (sbit (tn-local-conflicts x)
807 (tn-local-number y)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5