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

Contents of /src/compiler/life.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5