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

Contents of /src/compiler/life.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (hide annotations)
Mon Oct 31 04:27:28 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, RELENG_18, unicode-string-buffer-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.22: +1 -3 lines
Fix headed boilerplate.
1 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.19 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 ram 1.23 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/life.lisp,v 1.23 1994/10/31 04:27:28 ram Rel $")
9 ram 1.19 ;;;
10 wlott 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains the lifetime analysis phase in the compiler.
13     ;;;
14     ;;; Written by Rob MacLachlan
15     ;;;
16 ram 1.22 (in-package "C")
17 wlott 1.1
18    
19     ;;;; Utilities:
20    
21     ;;; Add-Global-Conflict -- Internal
22     ;;;
23     ;;; Link in a global-conflicts structure for TN in Block with Number as the
24     ;;; LTN number. The conflict is inserted in the per-TN Global-Conflicts thread
25     ;;; after the TN's Current-Conflict. We change the Current-Conflict to point
26     ;;; to the new conflict. Since we scan the blocks in reverse DFO, this list is
27     ;;; automatically built in order. We have to actually scan the current
28     ;;; Global-TNs for the block in order to keep that thread sorted.
29     ;;;
30     (defun add-global-conflict (kind tn block number)
31     (declare (type (member :read :write :read-only :live) kind)
32     (type tn tn) (type ir2-block block)
33     (type (or local-tn-number null) number))
34     (let ((new (make-global-conflicts kind tn block number)))
35     (let ((last (tn-current-conflict tn)))
36     (if last
37     (shiftf (global-conflicts-tn-next new)
38     (global-conflicts-tn-next last)
39     new)
40     (shiftf (global-conflicts-tn-next new)
41     (tn-global-conflicts tn)
42     new)))
43     (setf (tn-current-conflict tn) new)
44    
45 ram 1.12 (insert-block-global-conflict new block))
46 wlott 1.1 (undefined-value))
47    
48    
49 ram 1.12 ;;; INSERT-BLOCK-GLOBAL-CONFLICT -- Internal
50     ;;;
51     ;;; Do the actual insertion of the conflict New into Block's global
52     ;;; conflicts.
53     ;;;
54     (defun insert-block-global-conflict (new block)
55     (let ((global-num (tn-number (global-conflicts-tn new))))
56     (do ((prev nil conf)
57     (conf (ir2-block-global-tns block)
58     (global-conflicts-next conf)))
59     ((or (null conf)
60     (> (tn-number (global-conflicts-tn conf)) global-num))
61     (if prev
62     (setf (global-conflicts-next prev) new)
63     (setf (ir2-block-global-tns block) new))
64     (setf (global-conflicts-next new) conf))))
65     (undefined-value))
66    
67    
68 wlott 1.1 ;;; Reset-Current-Conflict -- Internal
69     ;;;
70     ;;; Reset the Current-Conflict slot in all packed TNs to point to the head
71     ;;; of the Global-Conflicts thread.
72     ;;;
73     (defun reset-current-conflict (component)
74     (do-packed-tns (tn component)
75     (setf (tn-current-conflict tn) (tn-global-conflicts tn))))
76    
77    
78     ;;;; Pre-pass:
79    
80     ;;; Convert-To-Global -- Internal
81     ;;;
82     ;;; Convert TN (currently local) to be a global TN, since we discovered that
83     ;;; it is referenced in more than one block. We just add a global-conflicts
84     ;;; structure with a kind derived from the Kill and Live sets.
85     ;;;
86     (defun convert-to-global (tn)
87     (declare (type tn tn))
88     (let ((block (tn-local tn))
89     (num (tn-local-number tn)))
90     (add-global-conflict
91     (if (zerop (sbit (ir2-block-written block) num))
92     :read-only
93     (if (zerop (sbit (ir2-block-live-out block) num))
94     :write
95     :read))
96     tn block num))
97     (undefined-value))
98    
99    
100     ;;; Find-Local-References -- Internal
101     ;;;
102     ;;; Scan all references to packed TNs in block. We assign LTN numbers to
103     ;;; each referenced TN, and also build the Kill and Live sets that summarize
104     ;;; the references to each TN for purposes of lifetime analysis.
105     ;;;
106     ;;; It is possible that we will run out of LTN numbers. If this happens,
107     ;;; then we return the VOP that we were processing at the time we ran out,
108     ;;; otherwise we return NIL.
109     ;;;
110     ;;; If a TN is referenced in more than one block, then we must represent
111     ;;; references using Global-Conflicts structures. When we first see a TN, we
112     ;;; assume it will be local. If we see a reference later on in a different
113     ;;; block, then we go back and fix the TN to global.
114     ;;;
115     ;;; We must globalize TNs that have a block other than the current one in
116     ;;; their Local slot and have no Global-Conflicts. The latter condition is
117     ;;; necessary because we always set Local and Local-Number when we process a
118     ;;; reference to a TN, even when the TN is already known to be global.
119     ;;;
120     ;;; When we see reference to global TNs during the scan, we add the
121     ;;; global-conflict as :Read-Only, since we don't know the corrent kind until
122     ;;; we are done scanning the block.
123     ;;;
124     (defun find-local-references (block)
125     (declare (type ir2-block block))
126     (let ((kill (ir2-block-written block))
127     (live (ir2-block-live-out block))
128     (tns (ir2-block-local-tns block)))
129     (let ((ltn-num (ir2-block-local-tn-count block)))
130     (do ((vop (ir2-block-last-vop block)
131     (vop-prev vop)))
132     ((null vop))
133     (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
134     ((null ref))
135     (let* ((tn (tn-ref-tn ref))
136     (local (tn-local tn))
137     (kind (tn-kind tn)))
138 ram 1.12 (unless (member kind '(:component :environment :constant))
139 wlott 1.1 (unless (eq local block)
140     (when (= ltn-num local-tn-limit)
141     (return-from find-local-references vop))
142     (when local
143     (unless (tn-global-conflicts tn)
144     (convert-to-global tn))
145     (add-global-conflict :read-only tn block ltn-num))
146    
147     (setf (tn-local tn) block)
148     (setf (tn-local-number tn) ltn-num)
149     (setf (svref tns ltn-num) tn)
150     (incf ltn-num))
151    
152     (let ((num (tn-local-number tn)))
153     (if (tn-ref-write-p ref)
154     (setf (sbit kill num) 1 (sbit live num) 0)
155     (setf (sbit live num) 1)))))))
156    
157     (setf (ir2-block-local-tn-count block) ltn-num)))
158     nil)
159    
160    
161     ;;; Init-Global-Conflict-Kind -- Internal
162     ;;;
163     ;;; Finish up the global conflicts for TNs referenced in Block according to
164     ;;; the local Kill and Live sets.
165     ;;;
166     ;;; We set the kind for TNs already in the global-TNs. If not written at
167     ;;; all, then is :Read-Only, the default. Must have been referenced somehow,
168     ;;; or we wouldn't have conflicts for it.
169     ;;;
170     ;;; We also iterate over all the local TNs, looking for TNs local to this
171     ;;; block that are still live at the block beginning, and thus must be global.
172     ;;; This case is only important when a TN is read in a block but not written in
173     ;;; any other, since otherwise the write would promote the TN to global. But
174     ;;; this does happen with various passing-location TNs that are magically
175     ;;; written. This also serves to propagate the lives of erroneously
176     ;;; uninitialized TNs so that consistency checks can detect them.
177     ;;;
178     (defun init-global-conflict-kind (block)
179     (declare (type ir2-block block))
180     (let ((live (ir2-block-live-out block)))
181     (let ((kill (ir2-block-written block)))
182     (do ((conf (ir2-block-global-tns block)
183     (global-conflicts-next conf)))
184     ((null conf))
185     (let ((num (global-conflicts-number conf)))
186     (unless (zerop (sbit kill num))
187     (setf (global-conflicts-kind conf)
188     (if (zerop (sbit live num))
189     :write
190     :read))))))
191    
192     (let ((ltns (ir2-block-local-tns block)))
193     (dotimes (i (ir2-block-local-tn-count block))
194     (let ((tn (svref ltns i)))
195     (unless (or (eq tn :more)
196     (tn-global-conflicts tn)
197     (zerop (sbit live i)))
198 ram 1.6 (convert-to-global tn))))))
199 wlott 1.1
200     (undefined-value))
201    
202    
203     (defevent split-ir2-block "Split an IR2 block to meet Local-TN-Limit.")
204    
205     ;;; Split-IR2-Blocks -- Internal
206     ;;;
207     ;;; Move the code after the VOP Lose in 2block into its own block. The
208     ;;; block is linked into the emit order following 2block. Number is the block
209     ;;; number assigned to the new block. We return the new block.
210     ;;;
211     (defun split-ir2-blocks (2block lose number)
212     (declare (type ir2-block 2block) (type vop lose)
213     (type unsigned-byte number))
214     (event split-ir2-block (vop-node lose))
215     (let ((new (make-ir2-block (ir2-block-block 2block)))
216     (new-start (vop-next lose)))
217     (setf (ir2-block-number new) number)
218     (add-to-emit-order new 2block)
219    
220     (do ((vop new-start (vop-next vop)))
221     ((null vop))
222     (setf (vop-block vop) new))
223    
224     (setf (ir2-block-start-vop new) new-start)
225     (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose)
226    
227     (setf (vop-next lose) nil)
228     (setf (vop-prev new-start) nil)
229    
230     new))
231    
232    
233     ;;; Clear-Lifetime-Info -- Internal
234     ;;;
235     ;;; Clear the global and local conflict info in Block so that we can
236     ;;; recompute it without any old cruft being retained. It is assumed that all
237     ;;; LTN numbers are in use.
238     ;;;
239     ;;; First we delete all the global conflicts. The conflict we are deleting
240     ;;; must be the last in the TN's global-conflicts, but we must scan for it in
241     ;;; order to find the previous conflict.
242     ;;;
243     ;;; Next, we scan the local TNs, nulling out the Local slot in all TNs with
244     ;;; no global conflicts. This allows these TNs to be treated as local when we
245     ;;; scan the block again.
246     ;;;
247     ;;; If there are conflicts, then we set Local to one of the conflicting
248     ;;; blocks. This ensures that Local doesn't hold over Block as its value,
249     ;;; causing the subsequent reanalysis to think that the TN has already been
250     ;;; seen in that block.
251     ;;;
252     ;;; This function must not be called on blocks that have :More TNs.
253     ;;;
254     (defun clear-lifetime-info (block)
255     (declare (type ir2-block block))
256     (setf (ir2-block-local-tn-count block) 0)
257    
258     (do ((conf (ir2-block-global-tns block)
259     (global-conflicts-next conf)))
260     ((null conf)
261     (setf (ir2-block-global-tns block) nil))
262     (let ((tn (global-conflicts-tn conf)))
263     (assert (eq (tn-current-conflict tn) conf))
264     (assert (null (global-conflicts-tn-next conf)))
265     (do ((current (tn-global-conflicts tn)
266     (global-conflicts-tn-next current))
267     (prev nil current))
268     ((eq current conf)
269     (if prev
270     (setf (global-conflicts-tn-next prev) nil)
271     (setf (tn-global-conflicts tn) nil))
272     (setf (tn-current-conflict tn) prev)))))
273    
274     (fill (ir2-block-written block) 0)
275     (let ((ltns (ir2-block-local-tns block)))
276     (dotimes (i local-tn-limit)
277     (let ((tn (svref ltns i)))
278     (assert (not (eq tn :more)))
279     (let ((conf (tn-global-conflicts tn)))
280     (setf (tn-local tn)
281     (if conf
282     (global-conflicts-block conf)
283 ram 1.6 nil))))))
284 wlott 1.1
285     (undefined-value))
286    
287    
288     ;;; Coalesce-More-LTN-Numbers -- Internal
289     ;;;
290     ;;; This provides a panic mode for assigning LTN numbers when there is a VOP
291     ;;; with so many more operands that they can't all be assigned distinct
292     ;;; numbers. When this happens, we recover by assigning all the more operands
293     ;;; the same LTN number. We can get away with this, since all more args (and
294     ;;; results) are referenced simultaneously as far as conflict analysis is
295     ;;; concerned.
296     ;;;
297     ;;; Block is the IR2-Block that the more VOP is at the end of. Ops is the
298     ;;; full argument or result TN-Ref list. Fixed is the types of the fixed
299     ;;; operands (used only to skip those operands.)
300     ;;;
301     ;;; What we do is grab a LTN number, then make a :Read-Only global conflict
302     ;;; for each more operand TN. We require that there be no existing global
303     ;;; conflict in Block for any of the operands. Since conflicts must be cleared
304     ;;; before the first call, this only prohibits the same TN being used both as a
305     ;;; more operand and as any other operand to the same VOP.
306     ;;;
307     ;;; We don't have to worry about getting the correct conflict kind, since
308 ram 1.21 ;;; Init-Global-Conflict-Kind will fix things up. Similarly,
309     ;;; FIND-LOCAL-REFERENCES will set the local conflict bit corresponding to this
310     ;;; call.
311 wlott 1.1 ;;;
312 ram 1.20 ;;; We also set the Local and Local-Number slots in each TN. It is
313     ;;; possible that there are no operands in any given call to this function, but
314     ;;; there had better be either some more args or more results.
315 wlott 1.1 ;;;
316     (defun coalesce-more-ltn-numbers (block ops fixed)
317 ram 1.20 (declare (type ir2-block block) (type (or tn-ref null) ops) (list fixed))
318 wlott 1.1 (let ((num (ir2-block-local-tn-count block)))
319     (assert (< num local-tn-limit))
320     (incf (ir2-block-local-tn-count block))
321     (setf (svref (ir2-block-local-tns block) num) :more)
322    
323     (do ((op (do ((op ops (tn-ref-across op))
324     (i 0 (1+ i)))
325 ram 1.17 ((= i (length fixed)) op)
326     (declare (type index i)))
327 wlott 1.1 (tn-ref-across op)))
328     ((null op))
329     (let ((tn (tn-ref-tn op)))
330     (assert
331     (flet ((frob (refs)
332     (do ((ref refs (tn-ref-next ref)))
333     ((null ref) t)
334     (when (and (eq (vop-block (tn-ref-vop ref)) block)
335     (not (eq ref op)))
336     (return nil)))))
337     (and (frob (tn-reads tn)) (frob (tn-writes tn))))
338     () "More operand ~S used more than once in its VOP." op)
339     (assert (not (find-in #'global-conflicts-next tn
340     (ir2-block-global-tns block)
341     :key #'global-conflicts-tn)))
342    
343     (add-global-conflict :read-only tn block num)
344     (setf (tn-local tn) block)
345     (setf (tn-local-number tn) num))))
346     (undefined-value))
347    
348    
349     (defevent coalesce-more-ltn-numbers
350     "Coalesced LTN numbers for a more operand to meet Local-TN-Limit.")
351    
352     ;;; Lifetime-Pre-Pass -- Internal
353     ;;;
354     ;;; Loop over the blocks in Component, assigning LTN numbers and recording
355     ;;; TN birth and death. The only interesting action is when we run out of
356     ;;; local TN numbers while finding local references.
357     ;;;
358     ;;; If we run out of LTN numbers while processing a VOP within the block,
359     ;;; then we just split off the VOPs we have successfully processed into their
360     ;;; own block.
361     ;;;
362     ;;; If we run out of LTN numbers while processing the our first VOP (the
363     ;;; last in the block), then it must be the case that this VOP has large more
364     ;;; operands. We split the VOP into its own block, and then call
365     ;;; Coalesce-More-Ltn-Numbers to assign all the more args/results the same LTN
366     ;;; number(s).
367     ;;;
368     ;;; In either case, we clear the lifetime information that we computed so
369     ;;; far, recomputing it after taking corrective action.
370     ;;;
371     ;;; Whenever we split a block, we finish the pre-pass on the split-off block
372     ;;; by doing Find-Local-References and Init-Global-Conflict-Kind. This can't
373     ;;; run out of LTN numbers.
374     ;;;
375     (defun lifetime-pre-pass (component)
376     (declare (type component component))
377     (let ((counter -1))
378 ram 1.16 (declare (type fixnum counter))
379 wlott 1.1 (do-blocks-backwards (block component)
380     (let ((2block (block-info block)))
381     (do ((lose (find-local-references 2block)
382     (find-local-references 2block))
383     (last-lose nil lose)
384     (coalesced nil))
385     ((not lose)
386     (init-global-conflict-kind 2block)
387     (setf (ir2-block-number 2block) (incf counter)))
388    
389     (clear-lifetime-info 2block)
390    
391     (cond
392     ((vop-next lose)
393     (assert (not (eq last-lose lose)))
394     (let ((new (split-ir2-blocks 2block lose (incf counter))))
395     (assert (not (find-local-references new)))
396     (init-global-conflict-kind new)))
397     (t
398     (assert (not (eq lose coalesced)))
399     (setq coalesced lose)
400     (event coalesce-more-ltn-numbers (vop-node lose))
401     (let ((info (vop-info lose))
402     (new (if (vop-prev lose)
403     (split-ir2-blocks 2block (vop-prev lose)
404     (incf counter))
405     2block)))
406     (coalesce-more-ltn-numbers new (vop-args lose)
407     (vop-info-arg-types info))
408     (coalesce-more-ltn-numbers new (vop-results lose)
409     (vop-info-result-types info))
410 ram 1.21 (let ((lose (find-local-references new)))
411     (assert (not lose)))
412 wlott 1.1 (init-global-conflict-kind new))))))))
413    
414     (undefined-value))
415    
416    
417 ram 1.12 ;;;; Environment TN stuff:
418    
419    
420     ;;; SETUP-ENVIRONMENT-TN-CONFLICT -- Internal
421     ;;;
422     ;;; Add a :LIVE global conflict for TN in 2block if there is none present.
423     ;;; If Debug-P is false (a :ENVIRONMENT TN), then modify any existing conflict
424     ;;; to be :LIVE.
425     ;;;
426     (defun setup-environment-tn-conflict (tn 2block debug-p)
427     (declare (type tn tn) (type ir2-block 2block))
428     (let ((block-num (ir2-block-number 2block)))
429     (do ((conf (tn-current-conflict tn) (global-conflicts-tn-next conf))
430     (prev nil conf))
431     ((or (null conf)
432     (> (ir2-block-number (global-conflicts-block conf)) block-num))
433     (setf (tn-current-conflict tn) prev)
434     (add-global-conflict :live tn 2block nil))
435     (when (eq (global-conflicts-block conf) 2block)
436     (unless (or debug-p
437     (eq (global-conflicts-kind conf) :live))
438     (setf (global-conflicts-kind conf) :live)
439     (setf (svref (ir2-block-local-tns 2block)
440     (global-conflicts-number conf))
441     nil)
442     (setf (global-conflicts-number conf) nil))
443     (setf (tn-current-conflict tn) conf)
444     (return))))
445     (undefined-value))
446    
447    
448     ;;; SETUP-ENVIRONMENT-TN-CONFLICTS -- Internal
449     ;;;
450     ;;; Iterate over all the blocks in Env, setting up :LIVE conflicts for TN.
451     ;;; We make the TN global if it isn't already. The TN must have at least one
452     ;;; reference.
453     ;;;
454     (defun setup-environment-tn-conflicts (component tn env debug-p)
455     (declare (type component component) (type tn tn) (type environment env))
456 ram 1.14 (when (and debug-p
457     (not (tn-global-conflicts tn))
458     (tn-local tn))
459 ram 1.12 (convert-to-global tn))
460     (setf (tn-current-conflict tn) (tn-global-conflicts tn))
461     (do-blocks-backwards (block component)
462     (when (eq (block-environment block) env)
463     (let* ((2block (block-info block))
464     (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
465     (prev 2block b))
466     ((not (eq (ir2-block-block b) block))
467     prev))))
468     (do ((b last (ir2-block-prev b)))
469     ((not (eq (ir2-block-block b) block)))
470     (setup-environment-tn-conflict tn b debug-p)))))
471     (undefined-value))
472    
473    
474 ram 1.14 ;;; SETUP-ENVIRONMENT-LIVE-CONFLICTS -- Internal
475 ram 1.12 ;;;
476     ;;; Iterate over all the environment TNs, adding always-live conflicts as
477     ;;; appropriate.
478     ;;;
479     (defun setup-environment-live-conflicts (component)
480     (declare (type component component))
481     (dolist (fun (component-lambdas component))
482 ram 1.14 (let* ((env (lambda-environment fun))
483     (2env (environment-info env)))
484     (dolist (tn (ir2-environment-live-tns 2env))
485     (setup-environment-tn-conflicts component tn env nil))
486     (dolist (tn (ir2-environment-debug-live-tns 2env))
487 ram 1.12 (setup-environment-tn-conflicts component tn env t))))
488     (undefined-value))
489    
490    
491     ;;; Convert-To-Environment-TN -- Internal
492     ;;;
493     ;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN. This
494     ;;; requires adding :LIVE conflicts to all blocks in TN-ENV.
495     ;;;
496     (defun convert-to-environment-tn (tn tn-env)
497     (declare (type tn tn) (type environment tn-env))
498     (assert (member (tn-kind tn) '(:normal :debug-environment)))
499     (when (eq (tn-kind tn) :debug-environment)
500     (assert (eq (tn-environment tn) tn-env))
501     (let ((2env (environment-info tn-env)))
502     (setf (ir2-environment-debug-live-tns 2env)
503     (delete tn (ir2-environment-debug-live-tns 2env)))))
504     (setup-environment-tn-conflicts *compile-component* tn tn-env nil)
505     (setf (tn-local tn) nil)
506     (setf (tn-local-number tn) nil)
507     (setf (tn-kind tn) :environment)
508     (setf (tn-environment tn) tn-env)
509     (push tn (ir2-environment-live-tns (environment-info tn-env)))
510     (undefined-value))
511    
512    
513 wlott 1.1 ;;;; Flow analysis:
514    
515     ;;; Propagate-Live-TNs -- Internal
516     ;;;
517     ;;; For each Global-TN in Block2 that is :Live, :Read or :Read-Only, ensure
518     ;;; that there is a corresponding Global-Conflict in Block1. If there is none,
519     ;;; make a :Live Global-Conflict. If there is a :Read-Only conflict, promote
520     ;;; it to :Live.
521     ;;;
522     ;;; If we did added a new conflict, return true, otherwise false. We don't
523     ;;; need to return true when we promote a :Read-Only conflict, since it doesn't
524     ;;; reveal any new information to predecessors of Block1.
525     ;;;
526     ;;; We use the Tn-Current-Conflict to walk through the global
527     ;;; conflicts. Since the global conflicts for a TN are ordered by block, we
528     ;;; can be sure that the Current-Conflict always points at or before the block
529     ;;; that we are looking at. This allows us to quickly determine if there is a
530     ;;; global conflict for a given TN in Block1.
531     ;;;
532     ;;; When we scan down the conflicts, we know that there must be at least one
533     ;;; conflict for TN, since we got our hands on TN by picking it out of a
534     ;;; conflict in Block2.
535     ;;;
536     ;;; We leave the Current-Conflict pointing to the conflict for Block1. The
537     ;;; Current-Conflict must be initialized to the head of the Global-Conflicts
538     ;;; for the TN between each flow analysis iteration.
539     ;;;
540     (defun propagate-live-tns (block1 block2)
541     (declare (type ir2-block block1 block2))
542     (let ((live-in (ir2-block-live-in block1))
543     (did-something nil))
544     (do ((conf2 (ir2-block-global-tns block2)
545     (global-conflicts-next conf2)))
546     ((null conf2))
547     (ecase (global-conflicts-kind conf2)
548     ((:live :read :read-only)
549     (let* ((tn (global-conflicts-tn conf2))
550     (tn-conflicts (tn-current-conflict tn))
551     (number1 (ir2-block-number block1)))
552     (assert tn-conflicts)
553     (do ((current tn-conflicts (global-conflicts-tn-next current))
554     (prev nil current))
555     ((or (null current)
556     (> (ir2-block-number (global-conflicts-block current))
557     number1))
558     (setf (tn-current-conflict tn) prev)
559     (add-global-conflict :live tn block1 nil)
560     (setq did-something t))
561     (when (eq (global-conflicts-block current) block1)
562     (case (global-conflicts-kind current)
563     (:live)
564     (:read-only
565     (setf (global-conflicts-kind current) :live)
566     (setf (svref (ir2-block-local-tns block1)
567     (global-conflicts-number current))
568     nil)
569     (setf (global-conflicts-number current) nil)
570     (setf (tn-current-conflict tn) current))
571     (t
572     (setf (sbit live-in (global-conflicts-number current)) 1)))
573     (return)))))
574     (:write)))
575     did-something))
576    
577    
578     ;;; Lifetime-Flow-Analysis -- Internal
579     ;;;
580     ;;; Do backward global flow analysis to find all TNs live at each block
581     ;;; boundary.
582     ;;;
583     (defun lifetime-flow-analysis (component)
584     (loop
585     (reset-current-conflict component)
586     (let ((did-something nil))
587     (do-blocks-backwards (block component)
588     (let* ((2block (block-info block))
589     (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
590     (prev 2block b))
591     ((not (eq (ir2-block-block b) block))
592     prev))))
593    
594     (dolist (b (block-succ block))
595 ram 1.11 (when (and (block-start b)
596 wlott 1.1 (propagate-live-tns last (block-info b)))
597     (setq did-something t)))
598    
599     (do ((b (ir2-block-prev last) (ir2-block-prev b))
600     (prev last b))
601     ((not (eq (ir2-block-block b) block)))
602     (when (propagate-live-tns b prev)
603     (setq did-something t)))))
604    
605     (unless did-something (return))))
606    
607     (undefined-value))
608    
609    
610     ;;;; Post-pass:
611    
612     ;;; Note-Conflicts -- Internal
613     ;;;
614     ;;; Note that TN conflicts with all current live TNs. Num is TN's LTN
615     ;;; number. We bit-ior Live-Bits with TN's Local-Conflicts, and set TN's
616     ;;; number in the conflicts of all TNs in Live-List.
617     ;;;
618     (defun note-conflicts (live-bits live-list tn num)
619     (declare (type tn tn) (type (or tn null) live-list)
620     (type local-tn-bit-vector live-bits)
621     (type local-tn-number num))
622     (let ((lconf (tn-local-conflicts tn)))
623     (bit-ior live-bits lconf lconf))
624     (do ((live live-list (tn-next* live)))
625     ((null live))
626     (setf (sbit (tn-local-conflicts live) num) 1))
627     (undefined-value))
628    
629    
630     ;;; Compute-Save-Set -- Internal
631     ;;;
632 ram 1.5 ;;; Compute a bit vector of the TNs live after VOP that aren't results.
633 wlott 1.1 ;;;
634 ram 1.6 (defun compute-save-set (vop live-bits)
635 ram 1.12 (declare (type vop vop) (type local-tn-bit-vector live-bits))
636 ram 1.5 (let ((live (bit-vector-copy live-bits)))
637     (do ((r (vop-results vop) (tn-ref-across r)))
638     ((null r))
639 ram 1.6 (let ((tn (tn-ref-tn r)))
640     (ecase (tn-kind tn)
641 ram 1.12 ((:normal :debug-environment)
642     (setf (sbit live (tn-local-number tn)) 0))
643 ram 1.7 (:environment :component))))
644 ram 1.5 live))
645 wlott 1.1
646    
647 ram 1.12 ;;; SAVED-AFTER-READ -- Internal
648     ;;;
649     ;;; Used to determine whether a :DEBUG-ENVIRONMENT TN should be considered
650     ;;; live at block end. We return true if a VOP with non-null SAVE-P appears
651     ;;; before the first read of TN (hence is seen first in our backward scan.)
652     ;;;
653     (defun saved-after-read (tn block)
654     (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
655     ((null vop) t)
656     (when (vop-info-save-p (vop-info vop)) (return t))
657     (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
658     (return nil))))
659    
660 ram 1.18 ;;; MAKE-DEBUG-ENVIRONMENT-TNS-LIVE -- Internal
661     ;;;
662     ;;; If the block has no successors, or its successor is the component tail,
663     ;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether
664     ;;; they appeared to be live. This ensures that these TNs are considered to be
665     ;;; live throughout blocks that read them, but don't have any interesting
666     ;;; successors (such as a return or tail call.) In this case, we set the
667     ;;; corresponding bit in LIVE-IN as well.
668     ;;;
669     (defun make-debug-environment-tns-live (block live-bits live-list)
670     (let* ((1block (ir2-block-block block))
671     (live-in (ir2-block-live-in block))
672     (succ (block-succ 1block))
673     (next (ir2-block-next block)))
674     (when (and next
675     (not (eq (ir2-block-block next) 1block))
676     (or (null succ)
677     (eq (first succ)
678     (component-tail (block-component 1block)))))
679     (do ((conf (ir2-block-global-tns block)
680     (global-conflicts-next conf)))
681     ((null conf))
682     (let* ((tn (global-conflicts-tn conf))
683     (num (global-conflicts-number conf)))
684     (when (and num (zerop (sbit live-bits num))
685     (eq (tn-kind tn) :debug-environment)
686     (eq (tn-environment tn) (block-environment 1block))
687     (saved-after-read tn block))
688     (note-conflicts live-bits live-list tn num)
689     (setf (sbit live-bits num) 1)
690     (push-in tn-next* tn live-list)
691     (setf (sbit live-in num) 1))))))
692    
693     (values live-bits live-list))
694 ram 1.12
695 ram 1.18
696 wlott 1.1 ;;; Compute-Initial-Conflicts -- Internal
697     ;;;
698     ;;; Return as values, a LTN bit-vector and a list (threaded by TN-Next*)
699     ;;; representing the TNs live at the end of Block (exclusive of :Live TNs).
700     ;;;
701     ;;; We iterate over the TNs in the global conflicts that are live at the block
702     ;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
703     ;;; TN to the live list.
704     ;;;
705 ram 1.18 ;;; If a :MORE result is not live, we effectively fake a read to it. This is
706     ;;; part of the action described in ENSURE-RESULTS-LIVE.
707 ram 1.12 ;;;
708 ram 1.18 ;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
709     ;;; environment TNs appear live when appropriate, even when they aren't.
710     ;;;
711 wlott 1.1 ;;; ### Note: we alias the global-conflicts-conflicts here as the
712     ;;; tn-local-conflicts.
713     ;;;
714     (defun compute-initial-conflicts (block)
715     (declare (type ir2-block block))
716 ram 1.12 (let* ((live-in (ir2-block-live-in block))
717 ram 1.18 (ltns (ir2-block-local-tns block))
718 ram 1.12 (live-bits (bit-vector-copy live-in))
719     (live-list nil))
720 wlott 1.1
721     (do ((conf (ir2-block-global-tns block)
722     (global-conflicts-next conf)))
723     ((null conf))
724     (let ((bits (global-conflicts-conflicts conf))
725     (tn (global-conflicts-tn conf))
726 ram 1.18 (num (global-conflicts-number conf))
727     (kind (global-conflicts-kind conf)))
728 wlott 1.1 (setf (tn-local-number tn) num)
729 ram 1.18 (unless (eq kind :live)
730     (cond ((not (zerop (sbit live-bits num)))
731     (bit-vector-replace bits live-bits)
732     (setf (sbit bits num) 0)
733     (push-in tn-next* tn live-list))
734     ((and (eq (svref ltns num) :more)
735     (eq kind :write))
736     (note-conflicts live-bits live-list tn num)
737     (setf (sbit live-bits num) 1)
738     (push-in tn-next* tn live-list)
739     (setf (sbit live-in num) 1)))
740    
741 wlott 1.1 (setf (tn-local-conflicts tn) bits))))
742    
743 ram 1.18 (make-debug-environment-tns-live block live-bits live-list)))
744 ram 1.12
745 wlott 1.1
746 ram 1.18 ;;; DO-SAVE-P-STUFF -- Internal
747     ;;;
748     ;;; A function called in Conflict-Analyze-1-Block when we have a VOP with
749     ;;; SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK, force all
750     ;;; the live TNs to be stack environment TNs.
751     ;;;
752     (defun do-save-p-stuff (vop block live-bits)
753     (declare (type vop vop) (type ir2-block block)
754     (type local-tn-bit-vector live-bits))
755     (let ((ss (compute-save-set vop live-bits)))
756     (setf (vop-save-set vop) ss)
757     (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
758     (do-live-tns (tn ss block)
759     (unless (eq (tn-kind tn) :component)
760     (force-tn-to-stack tn)
761     (unless (eq (tn-kind tn) :environment)
762     (convert-to-environment-tn
763     tn
764     (block-environment (ir2-block-block block))))))))
765     (undefined-value))
766 wlott 1.1
767 ram 1.18
768 wlott 1.1 (eval-when (compile eval)
769    
770     ;;; Frob-More-TNs -- Internal
771     ;;;
772 ram 1.18 ;;; Used in SCAN-VOP-REFS to simultaneously do something to all of the TNs
773     ;;; referenced by a big more arg. We have to treat these TNs specially, since
774     ;;; when we set or clear the bit in the live TNs, the represents a change in
775     ;;; the liveness of all the more TNs. If we iterated as normal, the next more
776 ram 1.21 ;;; ref would be thought to be not live when it was, etc. We update Ref to be
777     ;;; the last :more ref we scanned, so that the main loop will step to the next
778     ;;; non-more ref.
779 wlott 1.1 ;;;
780     (defmacro frob-more-tns (action)
781     `(when (eq (svref ltns num) :more)
782 ram 1.21 (let ((prev ref))
783     (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
784     ((null mref))
785     (let ((mtn (tn-ref-tn mref)))
786     (unless (eql (tn-local-number mtn) num)
787     (return))
788     ,action)
789     (setq prev mref))
790     (setq ref prev))))
791 wlott 1.1
792 ram 1.21
793 ram 1.18 ;;; SCAN-VOP-REFS -- Internal
794     ;;;
795     ;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs for the
796     ;;; current VOP. This macro shamelessly references free variables in C-A-1-B.
797     ;;;
798     (defmacro scan-vop-refs ()
799     '(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
800     ((null ref))
801     (let* ((tn (tn-ref-tn ref))
802     (num (tn-local-number tn)))
803     (cond
804     ((not num))
805     ((not (zerop (sbit live-bits num)))
806     (when (tn-ref-write-p ref)
807     (setf (sbit live-bits num) 0)
808     (deletef-in tn-next* live-list tn)
809 ram 1.21 (frob-more-tns (deletef-in tn-next* live-list mtn))))
810 ram 1.18 (t
811     (assert (not (tn-ref-write-p ref)))
812     (note-conflicts live-bits live-list tn num)
813     (frob-more-tns (note-conflicts live-bits live-list mtn num))
814     (setf (sbit live-bits num) 1)
815     (push-in tn-next* tn live-list)
816 ram 1.21 (frob-more-tns (push-in tn-next* mtn live-list)))))))
817    
818 ram 1.18
819     ;;; ENSURE-RESULTS-LIVE -- Internal
820     ;;;
821     ;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the current
822     ;;; VOP's results, and make any dead ones live. This is necessary, since even
823     ;;; though a result is dead after the VOP, it may be in use for an extended
824     ;;; period within the VOP (especially if it has :FROM specified.) During this
825     ;;; interval, temporaries must be noted to conflict with the result. More
826     ;;; results are finessed in COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
827     ;;;
828     (defmacro ensure-results-live ()
829     '(do ((res (vop-results vop) (tn-ref-across res)))
830     ((null res))
831     (let* ((tn (tn-ref-tn res))
832     (num (tn-local-number tn)))
833     (when (and num (zerop (sbit live-bits num)))
834     (unless (eq (svref ltns num) :more)
835     (note-conflicts live-bits live-list tn num)
836     (setf (sbit live-bits num) 1)
837     (push-in tn-next* tn live-list))))))
838    
839 wlott 1.1 ); Eval-When (Compile Eval)
840    
841    
842     ;;; Conflict-Analyze-1-Block -- Internal
843     ;;;
844     ;;; Compute the block-local conflict information for Block. We iterate over
845     ;;; all the TN-Refs in a block in reference order, maintaining the set of live
846     ;;; TNs in both a list and a bit-vector representation.
847     ;;;
848     (defun conflict-analyze-1-block (block)
849     (declare (type ir2-block block))
850     (multiple-value-bind
851     (live-bits live-list)
852     (compute-initial-conflicts block)
853     (let ((ltns (ir2-block-local-tns block)))
854     (do ((vop (ir2-block-last-vop block)
855     (vop-prev vop)))
856     ((null vop))
857 ram 1.18 (when (vop-info-save-p (vop-info vop))
858     (do-save-p-stuff vop block live-bits))
859     (ensure-results-live)
860     (scan-vop-refs)))))
861 wlott 1.1
862    
863     ;;; Lifetime-Post-Pass -- Internal
864     ;;;
865     ;;; Conflict analyze each block, and also add it
866     (defun lifetime-post-pass (component)
867     (declare (type component component))
868     (do-ir2-blocks (block component)
869     (conflict-analyze-1-block block)))
870    
871    
872 ram 1.12 ;;;; Alias TN stuff:
873    
874     ;;; MERGE-ALIAS-BLOCK-CONFLICTS -- Internal
875     ;;;
876     ;;; Destructively modify Oconf to include the conflict information in Conf.
877     ;;;
878     (defun merge-alias-block-conflicts (conf oconf)
879     (declare (type global-conflicts conf oconf))
880     (let* ((kind (global-conflicts-kind conf))
881     (num (global-conflicts-number conf))
882     (okind (global-conflicts-kind oconf))
883     (onum (global-conflicts-number oconf))
884     (block (global-conflicts-block oconf))
885     (ltns (ir2-block-local-tns block)))
886     (cond
887     ((eq okind :live))
888     ((eq kind :live)
889     (setf (global-conflicts-kind oconf) :live)
890     (setf (svref ltns onum) nil)
891     (setf (global-conflicts-number oconf) nil))
892     (t
893     (unless (eq kind okind)
894     (setf (global-conflicts-kind oconf) :read))
895     ;;
896     ;; Make original conflict with all the local TNs the alias conflicted
897     ;; with.
898     (bit-ior (global-conflicts-conflicts oconf)
899     (global-conflicts-conflicts conf)
900     t)
901     (flet ((frob (x)
902     (unless (zerop (sbit x num))
903     (setf (sbit x onum) 1))))
904     ;;
905     ;; Make all the local TNs that conflicted with the alias conflict
906     ;; with the original.
907     (dotimes (i (ir2-block-local-tn-count block))
908     (let ((tn (svref ltns i)))
909     (when (and tn (not (eq tn :more))
910     (null (tn-global-conflicts tn)))
911     (frob (tn-local-conflicts tn)))))
912     ;;
913     ;; Same for global TNs...
914     (do ((current (ir2-block-global-tns block)
915     (global-conflicts-next current)))
916     ((null current))
917     (unless (eq (global-conflicts-kind current) :live)
918     (frob (global-conflicts-conflicts current))))
919     ;;
920     ;; Make the original TN live everywhere that the alias was live.
921     (frob (ir2-block-written block))
922     (frob (ir2-block-live-in block))
923     (frob (ir2-block-live-out block))
924     (do ((vop (ir2-block-start-vop block)
925     (vop-next vop)))
926     ((null vop))
927     (let ((sset (vop-save-set vop)))
928     (when sset (frob sset)))))))
929     ;;
930     ;; Delete the alias's conflict info.
931     (when num
932     (setf (svref ltns num) nil))
933     (deletef-in global-conflicts-next (ir2-block-global-tns block) conf))
934    
935     (undefined-value))
936    
937    
938     ;;; CHANGE-GLOBAL-CONFLICTS-TN -- Internal
939     ;;;
940     ;;; Co-opt Conf to be a conflict for TN.
941     ;;;
942     (defun change-global-conflicts-tn (conf new)
943     (declare (type global-conflicts conf) (type tn new))
944     (setf (global-conflicts-tn conf) new)
945     (let ((ltn-num (global-conflicts-number conf))
946     (block (global-conflicts-block conf)))
947     (deletef-in global-conflicts-next (ir2-block-global-tns block) conf)
948     (setf (global-conflicts-next conf) nil)
949     (insert-block-global-conflict conf block)
950     (when ltn-num
951     (setf (svref (ir2-block-local-tns block) ltn-num) new)))
952     (undefined-value))
953    
954    
955     ;;; ENSURE-GLOBAL-TN -- Internal
956     ;;;
957     ;;; Do CONVERT-TO-GLOBAL on TN if it has no global conflicts. Copy the
958     ;;; local conflicts into the global bit vector.
959     ;;;
960     (defun ensure-global-tn (tn)
961     (declare (type tn tn))
962 ram 1.14 (cond ((tn-global-conflicts tn))
963     ((tn-local tn)
964     (convert-to-global tn)
965     (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
966     (tn-local-conflicts tn)
967     t))
968     (t
969     (assert (and (null (tn-reads tn)) (null (tn-writes tn))))))
970 ram 1.12 (undefined-value))
971    
972    
973     ;;; MERGE-ALIAS-CONFLICTS -- Internal
974     ;;;
975     ;;; For each :ALIAS TN, destructively merge the conflict info into the
976     ;;; original TN and replace the uses of the alias.
977     ;;;
978     ;;; For any block that uses only the alias TN, just insert that conflict into
979     ;;; the conflicts for the original TN, changing the LTN map to refer to the
980     ;;; original TN. This gives a result indistinguishable from the what there
981     ;;; would have been if the original TN had always been referenced. This leaves
982     ;;; no sign that an alias TN was ever involved.
983     ;;;
984     ;;; If a block has references to both the alias and the original TN, then we
985     ;;; call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts into the original
986     ;;; conflict.
987     ;;;
988     (defun merge-alias-conflicts (component)
989     (declare (type component component))
990     (do ((tn (ir2-component-alias-tns (component-info component))
991     (tn-next tn)))
992     ((null tn))
993     (let ((original (tn-save-tn tn)))
994     (ensure-global-tn tn)
995     (ensure-global-tn original)
996     (let ((conf (tn-global-conflicts tn))
997     (oconf (tn-global-conflicts original))
998     (oprev nil))
999     (loop
1000 ram 1.14 (unless oconf
1001     (if oprev
1002     (setf (global-conflicts-tn-next oprev) conf)
1003     (setf (tn-global-conflicts original) conf))
1004     (do ((current conf (global-conflicts-tn-next current)))
1005     ((null current))
1006     (change-global-conflicts-tn current original))
1007     (return))
1008 ram 1.12 (let* ((block (global-conflicts-block conf))
1009     (num (ir2-block-number block))
1010     (onum (ir2-block-number (global-conflicts-block oconf))))
1011    
1012     (cond ((< onum num)
1013     (shiftf oprev oconf (global-conflicts-tn-next oconf)))
1014     ((> onum num)
1015     (if oprev
1016     (setf (global-conflicts-tn-next oprev) conf)
1017     (setf (tn-global-conflicts original) conf))
1018     (change-global-conflicts-tn conf original)
1019 ram 1.15 (shiftf oprev conf (global-conflicts-tn-next conf) oconf))
1020 ram 1.12 (t
1021     (merge-alias-block-conflicts conf oconf)
1022     (shiftf oprev oconf (global-conflicts-tn-next oconf))
1023     (setf conf (global-conflicts-tn-next conf)))))
1024     (unless conf (return))))
1025    
1026     (flet ((frob (refs)
1027     (let ((ref refs)
1028     (next nil))
1029     (loop
1030     (unless ref (return))
1031     (setq next (tn-ref-next ref))
1032     (change-tn-ref-tn ref original)
1033     (setq ref next)))))
1034     (frob (tn-reads tn))
1035     (frob (tn-writes tn)))
1036     (setf (tn-global-conflicts tn) nil)))
1037    
1038     (undefined-value))
1039    
1040    
1041 wlott 1.1 ;;; Lifetime-Analyze -- Interface
1042     ;;;
1043     ;;;
1044     (defun lifetime-analyze (component)
1045     (lifetime-pre-pass component)
1046 ram 1.12 (setup-environment-live-conflicts component)
1047 wlott 1.1 (lifetime-flow-analysis component)
1048 ram 1.12 (lifetime-post-pass component)
1049     (merge-alias-conflicts component))
1050 wlott 1.1
1051    
1052     ;;;; Conflict testing:
1053    
1054     ;;; TNs-Conflict-Local-Global -- Internal
1055     ;;;
1056     ;;; Test for a conflict between the local TN X and the global TN Y. We just
1057     ;;; look for a global conflict of Y in X's block, and then test for conflict in
1058     ;;; that block.
1059     ;;; [### Might be more efficient to scan Y's global conflicts. This depends on
1060     ;;; whether there are more global TNs than blocks.]
1061     ;;;
1062     (defun tns-conflict-local-global (x y)
1063     (let ((block (tn-local x)))
1064     (do ((conf (ir2-block-global-tns block)
1065     (global-conflicts-next conf)))
1066     ((null conf) nil)
1067     (when (eq (global-conflicts-tn conf) y)
1068     (let ((num (global-conflicts-number conf)))
1069     (return (or (not num)
1070     (not (zerop (sbit (tn-local-conflicts x)
1071     num))))))))))
1072    
1073    
1074     ;;; TNs-Conflict-Global-Global -- Internal
1075     ;;;
1076     ;;; Test for conflict between two global TNs X and Y.
1077     ;;;
1078     (defun tns-conflict-global-global (x y)
1079     (declare (type tn x y))
1080     (let* ((x-conf (tn-global-conflicts x))
1081     (x-num (ir2-block-number (global-conflicts-block x-conf)))
1082     (y-conf (tn-global-conflicts y))
1083     (y-num (ir2-block-number (global-conflicts-block y-conf))))
1084    
1085     (macrolet ((advance (n c)
1086     `(progn
1087     (setq ,c (global-conflicts-tn-next ,c))
1088     (unless ,c (return-from tns-conflict-global-global nil))
1089     (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
1090     (scan (g l lc)
1091     `(do ()
1092     ((>= ,g ,l))
1093     (advance ,l ,lc))))
1094    
1095     (loop
1096     ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
1097     (scan x-num y-num y-conf)
1098     (scan y-num x-num x-conf)
1099     (when (= x-num y-num)
1100     (let ((ltn-num-x (global-conflicts-number x-conf)))
1101     (unless (and ltn-num-x
1102     (global-conflicts-number y-conf)
1103     (zerop (sbit (global-conflicts-conflicts y-conf)
1104     ltn-num-x)))
1105     (return t))
1106     (advance x-num x-conf)
1107     (advance y-num y-conf)))))))
1108    
1109    
1110     ;;; TNs-Conflict -- Interface
1111     ;;;
1112 ram 1.7 ;;; Return true if X and Y are distinct and the lifetimes of X and Y overlap
1113     ;;; at any point.
1114 wlott 1.1 ;;;
1115     (defun tns-conflict (x y)
1116     (declare (type tn x y))
1117 ram 1.7 (let ((x-kind (tn-kind x))
1118     (y-kind (tn-kind y)))
1119     (cond ((eq x y) nil)
1120     ((or (eq x-kind :component) (eq y-kind :component)) t)
1121     ((tn-global-conflicts x)
1122     (if (tn-global-conflicts y)
1123     (tns-conflict-global-global x y)
1124     (tns-conflict-local-global y x)))
1125     ((tn-global-conflicts y)
1126     (tns-conflict-local-global x y))
1127     (t
1128     (and (eq (tn-local x) (tn-local y))
1129     (not (zerop (sbit (tn-local-conflicts x)
1130     (tn-local-number y)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5