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

Contents of /src/compiler/life.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5