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

Contents of /src/compiler/life.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5