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

Contents of /src/compiler/life.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10.1.1 - (hide annotations) (vendor branch)
Mon Jun 11 18:34:30 1990 UTC (23 years, 10 months ago) by ram
Branch: eval_debug
Changes since 1.10: +0 -0 lines
*** empty log message ***
1 wlott 1.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 ram 1.7 (when (eq kind :normal)
127 wlott 1.1 (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 ram 1.6 (convert-to-global tn))))))
187 wlott 1.1
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 ram 1.6 nil))))))
272 wlott 1.1
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-lambda 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 ram 1.7 ;;; Convert a :Normal TN to an :Environment TN. This requires deleting the
500     ;;; existing conflict info.
501 wlott 1.1 ;;;
502     (defun convert-to-environment-tn (tn)
503     (declare (type tn tn))
504 ram 1.7 (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 wlott 1.1 (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 ram 1.5 ;;; Compute a bit vector of the TNs live after VOP that aren't results.
551 wlott 1.1 ;;;
552 ram 1.6 (defun compute-save-set (vop live-bits)
553     (declare (type vop vop) (type local-tn-bit-vector live-list))
554 ram 1.5 (let ((live (bit-vector-copy live-bits)))
555     (do ((r (vop-results vop) (tn-ref-across r)))
556     ((null r))
557 ram 1.6 (let ((tn (tn-ref-tn r)))
558     (ecase (tn-kind tn)
559     (:normal (setf (sbit live (tn-local-number tn)) 0))
560 ram 1.7 (:environment :component))))
561 ram 1.5 live))
562 wlott 1.1
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 ram 1.10 (let ((live-bits (bit-vector-copy (ir2-block-live-in block)))
579 wlott 1.1 (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 ram 1.3
635 wlott 1.1 (do ((vop (ir2-block-last-vop block)
636     (vop-prev vop)))
637     ((null vop))
638 ram 1.3
639 wlott 1.1 (let ((save-p (vop-info-save-p (vop-info vop))))
640     (when save-p
641 ram 1.6 (let ((ss (compute-save-set vop live-bits)))
642 ram 1.5 (setf (vop-save-set vop) ss)
643     (when (eq save-p :force-to-stack)
644     (do-live-tns (tn ss block)
645 ram 1.8 (unless (eq (tn-kind tn) :component)
646 ram 1.7 (force-tn-to-stack tn)
647 ram 1.9 (unless (eq (tn-kind tn) :environment)
648     (convert-to-environment-tn tn))))))))
649 ram 1.3
650 wlott 1.1 (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 ram 1.3
655 wlott 1.1 (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 ram 1.3 (note-conflicts live-bits live-list tn num)
667 wlott 1.1 (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 ram 1.7 (when (eq (lambda-environment
761     (block-lambda
762     (ir2-block-block (global-conflicts-block conf))))
763 wlott 1.1 env)
764     (return t)))))
765    
766    
767     ;;; TNs-Conflict-Environment-Local -- Interface
768     ;;;
769     ;;; Return true if Y's block is in X's environment.
770     ;;;
771     (defun tns-conflict-environment-local (x y)
772     (declare (type tn x y))
773 ram 1.7 (eq (lambda-environment
774     (block-lambda
775     (ir2-block-block (tn-local y))))
776 wlott 1.1 (tn-environment x)))
777    
778    
779     ;;; TNs-Conflict -- Interface
780     ;;;
781 ram 1.7 ;;; Return true if X and Y are distinct and the lifetimes of X and Y overlap
782     ;;; at any point.
783 wlott 1.1 ;;;
784     (defun tns-conflict (x y)
785     (declare (type tn x y))
786 ram 1.7 (let ((x-kind (tn-kind x))
787     (y-kind (tn-kind y)))
788     (cond ((eq x y) nil)
789     ((eq x-kind :environment)
790     (cond ((tn-global-conflicts y)
791     (tns-conflict-environment-global x y))
792     ((eq (tn-kind y) :environment)
793     (eq (tn-environment x) (tn-environment y)))
794     (t
795     (tns-conflict-environment-local x y))))
796     ((eq y-kind :environment)
797     (if (tn-global-conflicts x)
798     (tns-conflict-environment-global y x)
799     (tns-conflict-environment-local y x)))
800     ((or (eq x-kind :component) (eq y-kind :component)) t)
801     ((tn-global-conflicts x)
802     (if (tn-global-conflicts y)
803     (tns-conflict-global-global x y)
804     (tns-conflict-local-global y x)))
805     ((tn-global-conflicts y)
806     (tns-conflict-local-global x y))
807     (t
808     (and (eq (tn-local x) (tn-local y))
809     (not (zerop (sbit (tn-local-conflicts x)
810     (tn-local-number y)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5