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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Fri Oct 5 19:50:00 1990 UTC (23 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.15: +5 -5 lines
Inhibit substitution of let variables whenever the arg variable type is
not a subtype of the asserted type, not just when the arg *value* is 
nota subtype.  This is necessary to prevent representation selection
from being defeated.
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 implements the IR1 optimization phase of the compiler. IR1
11 ;;; optimization is a grab-bag of optimizations that don't make major changes
12 ;;; to the block-level control flow and don't use flow analysis. These
13 ;;; optimizations can mostly be classified as "meta-evaluation", but there is a
14 ;;; sizable top-down component as well.
15 ;;;
16 ;;; Written by Rob MacLachlan
17 ;;;
18 (in-package 'c)
19
20
21 ;;;; Interface for obtaining results of constant folding:
22
23 ;;; Constant-Continuation-P -- Interface
24 ;;;
25 ;;; Return true if the sole use of Cont is a reference to a constant leaf.
26 ;;;
27 (proclaim '(function constant-continuation-p (continuation) boolean))
28 (defun constant-continuation-p (cont)
29 (let ((use (continuation-use cont)))
30 (and (ref-p use)
31 (constant-p (ref-leaf use)))))
32
33
34 ;;; Continuation-Value -- Interface
35 ;;;
36 ;;; Return the constant value for a continuation whose only use is a
37 ;;; constant node.
38 ;;;
39 (proclaim '(function continuation-value (continuation) t))
40 (defun continuation-value (cont)
41 (assert (constant-continuation-p cont))
42 (constant-value (ref-leaf (continuation-use cont))))
43
44
45 ;;;; Interface for obtaining results of type inference:
46
47 ;;; CONTINUATION-PROVEN-TYPE -- Interface
48 ;;;
49 ;;; Return a (possibly values) type that describes what we have proven about
50 ;;; the type of Cont without taking any type assertions into consideration.
51 ;;; This is just the union of the NODE-DERIVED-TYPE of all the uses. Most
52 ;;; often people use CONTINUATION-DERIVED-TYPE or CONTINUATION-TYPE instead of
53 ;;; using this function directly.
54 ;;;
55 (defun continuation-proven-type (cont)
56 (declare (type continuation cont))
57 (ecase (continuation-kind cont)
58 ((:block-start :deleted-block-start)
59 (let ((uses (block-start-uses (continuation-block cont))))
60 (if uses
61 (do ((res (node-derived-type (first uses))
62 (values-type-union (node-derived-type (first current))
63 res))
64 (current (rest uses) (rest current)))
65 ((null current) res))
66 *empty-type*)))
67 (:inside-block
68 (node-derived-type (continuation-use cont)))))
69
70
71 ;;; Continuation-Derived-Type -- Interface
72 ;;;
73 ;;; Our best guess for the type of this continuation's value. Note that
74 ;;; this may be Values or Function type, which cannot be passed as an argument
75 ;;; to the normal type operations. See Continuation-Type. This may be called
76 ;;; on deleted continuations, always returning *.
77 ;;;
78 ;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the result
79 ;;; is a subtype of the assertion. If so, return the proven type and set
80 ;;; TYPE-CHECK to nil. Otherwise, return the intersection of the asserted and
81 ;;; proven types, and set TYPE-CHECK T. If TYPE-CHECK already has a non-null
82 ;;; value, then preserve it. Only in the somewhat unusual circumstance of
83 ;;; a newly discovered assertion will we change TYPE-CHECK from NIL to T.
84 ;;;
85 ;;; The result value is cached in the Continuation-%Derived-Type. If the
86 ;;; slot is true, just return that value, otherwise recompute and stash the
87 ;;; value there.
88 ;;;
89 (proclaim '(inline continuation-derived-type))
90 (defun continuation-derived-type (cont)
91 (declare (type continuation cont))
92 (or (continuation-%derived-type cont)
93 (%continuation-derived-type cont)))
94 ;;;
95 (defun %continuation-derived-type (cont)
96 (declare (type continuation cont))
97 (let ((proven (continuation-proven-type cont))
98 (asserted (continuation-asserted-type cont)))
99 (cond ((values-subtypep proven asserted)
100 (setf (continuation-%type-check cont) nil)
101 (setf (continuation-%derived-type cont) proven))
102 (t
103 (unless (or (continuation-%type-check cont)
104 (not (continuation-dest cont))
105 (eq asserted *universal-type*))
106 (setf (continuation-%type-check cont) t))
107
108 (setf (continuation-%derived-type cont)
109 (values-type-intersection asserted proven))))))
110
111
112 ;;; CONTINUATION-TYPE-CHECK -- Interface
113 ;;;
114 ;;; Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to date, then
115 ;;; return it.
116 ;;;
117 (proclaim '(inline continuation-type-check))
118 (defun continuation-type-check (cont)
119 (declare (type continuation cont))
120 (continuation-derived-type cont)
121 (continuation-%type-check cont))
122
123
124 ;;; Continuation-Type -- Interface
125 ;;;
126 ;;; Return the derived type for Cont's first value. This is guaranteed not
127 ;;; to be a Values or Function type.
128 ;;;
129 (proclaim '(function continuation-type (continuation) ctype))
130 (defun continuation-type (cont)
131 (single-value-type (continuation-derived-type cont)))
132
133
134 ;;;; Interface routines used by optimizers:
135
136 ;;; Reoptimize-Continuation -- Interface
137 ;;;
138 ;;; This function is called by optimizers to indicate that something
139 ;;; interesting has happened to the value of Cont. Optimizers must make sure
140 ;;; that they don't call for reoptimization when nothing has happened, since
141 ;;; optimization will fail to terminate.
142 ;;;
143 ;;; We clear any cached type for the continuation and set the reoptimize
144 ;;; flags on everything in sight, unless the continuation is deleted (in which
145 ;;; case we do nothing.)
146 ;;;
147 ;;; Since this can get called curing IR1 conversion, we have to be careful
148 ;;; not to fly into space when the Dest's Prev is missing.
149 ;;;
150 (defun reoptimize-continuation (cont)
151 (declare (type continuation cont))
152 (unless (eq (continuation-kind cont) :deleted)
153 (setf (continuation-%derived-type cont) nil)
154 (let ((dest (continuation-dest cont)))
155 (when dest
156 (setf (continuation-reoptimize cont) t)
157 (setf (node-reoptimize dest) t)
158 (let ((prev (node-prev dest)))
159 (when prev
160 (let* ((block (continuation-block prev))
161 (component (block-component block)))
162 (setf (block-reoptimize block) t)
163 (setf (component-reoptimize component) t))))))
164 (do-uses (node cont)
165 (setf (block-type-check (node-block node)) t)))
166 (undefined-value))
167
168
169 ;;; Derive-Node-Type -- Interface
170 ;;;
171 ;;; Annotate Node to indicate that its result has been proven to be typep to
172 ;;; RType. After IR1 conversion has happened, this is the only correct way to
173 ;;; supply information discovered about a node's type. If you fuck with the
174 ;;; Node-Derived-Type directly, then information may be lost and reoptimization
175 ;;; may not happen.
176 ;;;
177 ;;; What we do is intersect Rtype with Node's Derived-Type. If the
178 ;;; intersection is different from the old type, then we do a
179 ;;; Reoptimize-Continuation on the Node-Cont.
180 ;;;
181 (defun derive-node-type (node rtype)
182 (declare (type node node) (type ctype rtype))
183 (let ((node-type (node-derived-type node)))
184 (unless (eq node-type rtype)
185 (let ((int (values-type-intersection node-type rtype)))
186 (when (type/= node-type int)
187 (setf (node-derived-type node) int)
188 (reoptimize-continuation (node-cont node))))))
189 (undefined-value))
190
191
192 ;;; Assert-Continuation-Type -- Interface
193 ;;;
194 ;;; Similar to Derive-Node-Type, but asserts that it is an error for Cont's
195 ;;; value not to be typep to Type. If we improve the assertion, we set
196 ;;; TYPE-CHECK and TYPE-ASSERTED to guarantee that the new assertion will be
197 ;;; checked.
198 ;;;
199 (defun assert-continuation-type (cont type)
200 (declare (type continuation cont) (type ctype type))
201 (let ((cont-type (continuation-asserted-type cont)))
202 (unless (eq cont-type type)
203 (let ((int (values-type-intersection cont-type type)))
204 (when (type/= cont-type int)
205 (setf (continuation-asserted-type cont) int)
206 (do-uses (node cont)
207 (setf (block-attributep (block-flags (node-block node))
208 type-check type-asserted)
209 t))
210 (reoptimize-continuation cont)))))
211 (undefined-value))
212
213
214 ;;; Assert-Call-Type -- Interface
215 ;;;
216 ;;; Assert that Call is to a function of the specified Type. It is assumed
217 ;;; that the call is legal and has only constants in the keyword positions.
218 ;;;
219 (defun assert-call-type (call type)
220 (declare (type combination call) (type function-type type))
221 (derive-node-type call (function-type-returns type))
222 (let ((args (combination-args call)))
223 (dolist (req (function-type-required type))
224 (when (null args) (return-from assert-call-type))
225 (let ((arg (pop args)))
226 (assert-continuation-type arg req)))
227 (dolist (opt (function-type-optional type))
228 (when (null args) (return-from assert-call-type))
229 (let ((arg (pop args)))
230 (assert-continuation-type arg opt)))
231
232 (let ((rest (function-type-rest type)))
233 (when rest
234 (dolist (arg args)
235 (assert-continuation-type arg rest))))
236
237 (dolist (key (function-type-keywords type))
238 (let ((name (key-info-name key)))
239 (do ((arg args (cddr arg)))
240 ((null arg))
241 (when (eq (continuation-value (first arg)) name)
242 (assert-continuation-type
243 (second arg) (key-info-type key)))))))
244 (undefined-value))
245
246
247 ;;; IR1-Optimize -- Interface
248 ;;;
249 ;;; Do one forward pass over Component, deleting unreachable blocks and
250 ;;; doing IR1 optimizations. We can ignore all blocks that don't have the
251 ;;; Reoptimize flag set. If Component-Reoptimize is true when we are done,
252 ;;; then another iteration would be beneficial.
253 ;;;
254 ;;; We delete blocks when there is either no predecessor or the block is in
255 ;;; a lambda that has been deleted. These blocks would eventually be deleted
256 ;;; by DFO recomputation, but doing it here immediately makes the effect
257 ;;; avaliable to IR1 optimization.
258 ;;;
259 (defun ir1-optimize (component)
260 (declare (type component component))
261 (setf (component-reoptimize component) nil)
262 (do-blocks (block component)
263 (cond
264 ((or (block-delete-p block)
265 (null (block-pred block))
266 (eq (functional-kind (block-home-lambda block)) :deleted))
267 (delete-block block))
268 (t
269 (loop
270 (let ((succ (block-succ block)))
271 (unless (and succ (null (rest succ)))
272 (return)))
273
274 (let ((last (block-last block)))
275 (typecase last
276 (cif
277 (flush-dest (if-test last))
278 (when (unlink-node last) (return)))
279 (exit
280 (when (maybe-delete-exit last) (return)))))
281
282 (unless (join-successor-if-possible block)
283 (return)))
284
285 (when (and (block-reoptimize block) (block-component block))
286 (assert (not (block-delete-p block)))
287 (ir1-optimize-block block))
288
289 (when (and (block-flush-p block) (block-component block))
290 (assert (not (block-delete-p block)))
291 (flush-dead-code block)))))
292
293 (undefined-value))
294
295
296 ;;; IR1-Optimize-Block -- Internal
297 ;;;
298 ;;; Loop over the nodes in Block, looking for stuff that needs to be
299 ;;; optimized. We dispatch off of the type of each node with its reoptimize
300 ;;; flag set:
301 ;;; -- With a combination, we call Propagate-Function-Change whenever the
302 ;;; function changes, and call IR1-Optimize-Combination if any argument
303 ;;; changes.
304 ;;; -- With an Exit, we derive the node's type from the Value's type. We don't
305 ;;; propagate Cont's assertion to the Value, since if we did, this would
306 ;;; move the checking of Cont's assertion to the exit. This wouldn't work
307 ;;; with Catch and UWP, where the Exit node is just a placeholder for the
308 ;;; actual unknown exit.
309 ;;;
310 ;;; Note that we clear the node & block reoptimize flags *before* doing the
311 ;;; optimization. This ensures that the node or block will be reoptimized if
312 ;;; necessary. We leave the NODE-OPTIMIZE flag set doing into
313 ;;; IR1-OPTIMIZE-RETURN, since it wants to clear the flag itself.
314 ;;;
315 (defun ir1-optimize-block (block)
316 (declare (type cblock block))
317 (setf (block-reoptimize block) nil)
318 (do-nodes (node cont block)
319 (when (node-reoptimize node)
320 (setf (node-reoptimize node) nil)
321 (typecase node
322 (ref)
323 (combination
324 (when (continuation-reoptimize (basic-combination-fun node))
325 (propagate-function-change node))
326 (when (dolist (arg (basic-combination-args node) nil)
327 (when (and arg (continuation-reoptimize arg))
328 (return t)))
329 (ir1-optimize-combination node)))
330 (cif
331 (ir1-optimize-if node))
332 (creturn
333 (setf (node-reoptimize node) t)
334 (ir1-optimize-return node))
335 (mv-combination
336 (when (and (eq (basic-combination-kind node) :local)
337 (continuation-reoptimize
338 (first (basic-combination-args node))))
339 (ir1-optimize-mv-bind node)))
340 (exit
341 (let ((value (exit-value node)))
342 (when value
343 (derive-node-type node (continuation-derived-type value)))))
344 (cset
345 (ir1-optimize-set node)))))
346 (undefined-value))
347
348
349 ;;; Join-Successor-If-Possible -- Internal
350 ;;;
351 ;;; We cannot combine with a successor block if:
352 ;;; 1] The successor has more than one predecessor.
353 ;;; 2] The last node's Cont is also used somewhere else.
354 ;;; 3] The successor is the current block (infinite loop).
355 ;;; 4] The next block has a different cleanup, and thus we may want to insert
356 ;;; cleanup code between the two blocks at some point.
357 ;;; 5] The next block has a different home lambda, and thus the control
358 ;;; transfer is a non-local exit.
359 ;;;
360 ;;; If we succeed, we return true, otherwise false.
361 ;;;
362 ;;; Joining is easy when the successor's Start continuation is the same from
363 ;;; our Last's Cont. If they differ, then we can still join when the last
364 ;;; continuation has no next and the next continuation has no uses. In this
365 ;;; case, we replace the next continuation with the last before joining the
366 ;;; blocks.
367 ;;;
368 (defun join-successor-if-possible (block)
369 (declare (type cblock block))
370 (let ((next (first (block-succ block))))
371 (when (block-start next)
372 (let* ((last (block-last block))
373 (last-cont (node-cont last))
374 (next-cont (block-start next)))
375 (cond ((or (rest (block-pred next))
376 (not (eq (continuation-use last-cont) last))
377 (eq next block)
378 (not (eq (block-end-cleanup block)
379 (block-start-cleanup next)))
380 (not (eq (block-home-lambda block)
381 (block-home-lambda next))))
382 nil)
383 ((eq last-cont next-cont)
384 (join-blocks block next)
385 t)
386 ((and (null (block-start-uses next))
387 (eq (continuation-kind last-cont) :inside-block))
388 (let ((next-node (continuation-next next-cont)))
389 (assert (not (continuation-dest next-cont)))
390 (delete-continuation next-cont)
391 (setf (node-prev next-node) last-cont)
392 (setf (continuation-next last-cont) next-node)
393 (setf (block-start next) last-cont)
394 (join-blocks block next))
395 t)
396 (t
397 nil))))))
398
399
400 ;;; Join-Blocks -- Internal
401 ;;;
402 ;;; Join together two blocks which have the same ending/starting
403 ;;; continuation. The code in Block2 is moved into Block1 and Block2 is
404 ;;; deleted from the DFO. We combine the optimize flags for the two blocks so
405 ;;; that any indicated optimization gets done.
406 ;;;
407 (defun join-blocks (block1 block2)
408 (declare (type cblock block1 block2))
409 (let* ((last (block-last block2))
410 (last-cont (node-cont last))
411 (succ (block-succ block2))
412 (start2 (block-start block2)))
413 (do ((cont start2 (node-cont (continuation-next cont))))
414 ((eq cont last-cont)
415 (when (eq (continuation-kind last-cont) :inside-block)
416 (setf (continuation-block last-cont) block1)))
417 (setf (continuation-block cont) block1))
418
419 (unlink-blocks block1 block2)
420 (dolist (block succ)
421 (unlink-blocks block2 block)
422 (link-blocks block1 block))
423
424 (setf (block-last block1) last)
425 (setf (continuation-kind start2) :inside-block))
426
427 (setf (block-flags block1)
428 (attributes-union (block-flags block1)
429 (block-flags block2)
430 (block-attributes type-asserted test-modified)))
431
432 (let ((next (block-next block2))
433 (prev (block-prev block2)))
434 (setf (block-next prev) next)
435 (setf (block-prev next) prev))
436
437 (undefined-value))
438
439
440 ;;;; Local call return type propagation:
441
442 ;;; Find-Result-Type -- Internal
443 ;;;
444 ;;; This function is called on RETURN nodes that have their REOPTIMIZE flag
445 ;;; set. It iterates over the uses of the RESULT, looking for interesting
446 ;;; stuff to update the TAIL-SET:
447 ;;; -- If a use is a local call, then we check that the called function has
448 ;;; the tail set Tails. If we encounter any different tail set, we return
449 ;;; the second value true.
450 ;;; -- If a use isn't a local call, then we union its type together with the
451 ;;; types of other such uses. We assign to the RETURN-RESULT-TYPE the
452 ;;; intersection of this type with the RESULT's asserted type. We can make
453 ;;; this intersection now (potentially before type checking) because this
454 ;;; assertion on the result will eventually be checked (if appropriate.)
455 ;;;
456 (defun find-result-type (node tails)
457 (declare (type creturn node))
458 (let ((result (return-result node))
459 (retry nil))
460 (collect ((use-union *empty-type* values-type-union))
461 (do-uses (use result)
462 (if (and (basic-combination-p use)
463 (eq (basic-combination-kind use) :local))
464 (when (merge-tail-sets use tails)
465 (setq retry t))
466 (use-union (node-derived-type use))))
467 (let ((int (values-type-intersection
468 (continuation-asserted-type result)
469 (use-union))))
470 (setf (return-result-type node) int)))
471 retry))
472
473
474 ;;; Merge-Tail-Sets -- Internal
475 ;;;
476 ;;; This function handles merging the tail sets if Call is a call to a
477 ;;; function with a different TAIL-SET than Ret-Set. We return true if we do
478 ;;; anything.
479 ;;;
480 ;;; It is assumed that Call sends its value to a RETURN node. We
481 ;;; destructively modify the set for the returning function to represent both,
482 ;;; and then change all the functions in callee's set to reference the first.
483 ;;;
484 ;;; If the called function has no tail set, then do nothing; if it doesn't
485 ;;; return, then it can't affect the callers value.
486 ;;;
487 (defun merge-tail-sets (call ret-set)
488 (declare (type basic-combination call) (type tail-set ret-set))
489 (let ((fun-set (lambda-tail-set (combination-lambda call))))
490 (when (and fun-set (not (eq ret-set fun-set)))
491 (let ((funs (tail-set-functions fun-set)))
492 (dolist (fun funs)
493 (setf (lambda-tail-set fun) ret-set))
494 (setf (tail-set-functions ret-set)
495 (nconc (tail-set-functions ret-set) funs)))
496 t)))
497
498
499 ;;; IR1-Optimize-Return -- Internal
500 ;;;
501 ;;; Do stuff to realize that something has changed about the value delivered
502 ;;; to a return node. Since we consider the return values of all functions in
503 ;;; the tail set to be equivalent, this amounts to bringing the entire tail set
504 ;;; up to date. We iterate over the returns for all the functions in the tail
505 ;;; set, reanalyzing them all (not treating Node specially.)
506 ;;;
507 ;;; During this iteration, we may discover new functions that should be
508 ;;; added to the tail set. If this happens, we restart the iteration over the
509 ;;; TAIL-SET-FUNCTIONS. Note that this really doesn't duplicate much work, as
510 ;;; we clear the NODE-REOPTIMIZE flags in the return nodes as we go, thus we
511 ;;; don't call FIND-RESULT-TYPE on any given return more than once.
512 ;;;
513 ;;; Restarting the iteration doesn't disturb the computation of the result
514 ;;; type RES, since we will just be adding more types to the union. (or when
515 ;;; we iterate over a return multiple times, unioning in the same type more
516 ;;; than once.)
517 ;;;
518 ;;; When we are done, we check if the new type is different from the old
519 ;;; TAIL-SET-TYPE. If so, we set the type and also reoptimize all the
520 ;;; continuations for references to functions in the tail set. This will
521 ;;; cause IR1-OPTIMIZE-COMBINATION to derive the new type as the results of the
522 ;;; calls.
523 ;;;
524 (defun ir1-optimize-return (node)
525 (declare (type creturn node))
526 (let ((tails (lambda-tail-set (return-lambda node))))
527 (collect ((res *empty-type* values-type-union))
528 (loop
529 (block RETRY
530 (let ((funs (tail-set-functions tails)))
531 (dolist (fun funs)
532 (let ((return (lambda-return fun)))
533 (when (node-reoptimize return)
534 (setf (node-reoptimize node) nil)
535 (when (find-result-type return tails) (return-from RETRY)))
536 (res (return-result-type return)))))
537 (return)))
538
539 (when (type/= (res) (tail-set-type tails))
540 (setf (tail-set-type tails) (res))
541 (dolist (fun (tail-set-functions tails))
542 (dolist (ref (leaf-refs fun))
543 (reoptimize-continuation (node-cont ref)))))))
544
545 (undefined-value))
546
547
548 ;;; IR1-Optimize-If -- Internal
549 ;;;
550 ;;; If the test has multiple uses, replicate the node when possible. Also
551 ;;; check if the predicate is known to be true or false, deleting the IF node
552 ;;; in favor of the appropriate branch when this is the case.
553 ;;;
554 (defun ir1-optimize-if (node)
555 (declare (type cif node))
556 (let ((test (if-test node))
557 (block (node-block node)))
558
559 (when (and (eq (block-start block) test)
560 (eq (continuation-next test) node)
561 (rest (block-start-uses block)))
562 (do-uses (use test)
563 (when (immediately-used-p test use)
564 (convert-if-if use node)
565 (when (continuation-use test) (return)))))
566
567 (let* ((type (continuation-type test))
568 (victim
569 (cond ((constant-continuation-p test)
570 (if (continuation-value test)
571 (if-alternative node)
572 (if-consequent node)))
573 ((not (types-intersect type *null-type*))
574 (if-alternative node))
575 ((type= type *null-type*)
576 (if-consequent node)))))
577 (when victim
578 (flush-dest test)
579 (when (rest (block-succ block))
580 (unlink-blocks block victim))
581 (setf (component-reanalyze (block-component (node-block node))) t)
582 (unlink-node node))))
583 (undefined-value))
584
585
586 ;;; Convert-If-If -- Internal
587 ;;;
588 ;;; Create a new copy of an IF Node that tests the value of the node Use.
589 ;;; The test must have >1 use, and must be immediately used by Use. Node must
590 ;;; be the only node in its block (implying that block-start = if-test).
591 ;;;
592 ;;; This optimization has an effect semantically similar to the
593 ;;; source-to-source transformation:
594 ;;; (IF (IF A B C) D E) ==>
595 ;;; (IF A (IF B D E) (IF C D E))
596 ;;;
597 (defun convert-if-if (use node)
598 (declare (type node use) (type cif node))
599 (with-ir1-environment node
600 (let* ((block (node-block node))
601 (test (if-test node))
602 (cblock (if-consequent node))
603 (ablock (if-alternative node))
604 (use-block (node-block use))
605 (dummy-cont (make-continuation))
606 (new-cont (make-continuation))
607 (new-node (make-if :test new-cont
608 :consequent cblock :alternative ablock))
609 (new-block (continuation-starts-block new-cont)))
610 (prev-link new-node new-cont)
611 (setf (continuation-dest new-cont) new-node)
612 (add-continuation-use new-node dummy-cont)
613 (setf (block-last new-block) new-node)
614
615 (unlink-blocks use-block block)
616 (delete-continuation-use use)
617 (add-continuation-use use new-cont)
618 (link-blocks use-block new-block)
619
620 (link-blocks new-block cblock)
621 (link-blocks new-block ablock)
622
623 (reoptimize-continuation test)
624 (reoptimize-continuation new-cont)
625 (setf (component-reanalyze *current-component*) t)))
626 (undefined-value))
627
628
629 ;;;; Exit IR1 optimization:
630
631 ;;; Maybe-Delete-Exit -- Interface
632 ;;;
633 ;;; This function attempts to delete an exit node, returning true if it
634 ;;; deletes the block as a consequence:
635 ;;; -- If the exit is degenerate (has no Entry), then we don't do anything,
636 ;;; since there is nothing to be done.
637 ;;; -- If the exit node and its Entry have the same home lambda then we know
638 ;;; the exit is local, and can delete the exit. We change uses of the
639 ;;; Exit-Value to be uses of the original continuation, then unlink the
640 ;;; node.
641 ;;; -- If there is no value (as in a GO), then we skip the value semantics.
642 ;;;
643 ;;; This function is also called by environment analysis, since it wants all
644 ;;; exits to be optimized even if normal optimization was omitted.
645 ;;;
646 (defun maybe-delete-exit (node)
647 (declare (type exit node))
648 (let ((value (exit-value node))
649 (entry (exit-entry node))
650 (cont (node-cont node)))
651 (when (and entry
652 (eq (node-home-lambda node) (node-home-lambda entry)))
653 (setf (entry-exits entry) (delete node (entry-exits entry)))
654 (prog1
655 (unlink-node node)
656 (when value
657 (substitute-continuation-uses cont value))))))
658
659
660 ;;;; Combination IR1 optimization:
661
662 ;;; Ir1-Optimize-Combination -- Internal
663 ;;;
664 ;;; Do IR1 optimizations on a Combination node.
665 ;;;
666 (proclaim '(function ir1-optimize-combination (combination) void))
667 (defun ir1-optimize-combination (node)
668 (let ((args (basic-combination-args node))
669 (kind (basic-combination-kind node)))
670 (case kind
671 (:local
672 (let ((fun (combination-lambda node)))
673 (if (eq (functional-kind fun) :let)
674 (propagate-let-args node fun)
675 (propagate-local-call-args node fun))))
676 (:full
677 (dolist (arg args)
678 (when arg
679 (setf (continuation-reoptimize arg) nil))))
680 (t
681 (dolist (arg args)
682 (when arg
683 (setf (continuation-reoptimize arg) nil)))
684
685 (let ((attr (function-info-attributes kind)))
686 (when (and (ir1-attributep attr foldable)
687 (not (ir1-attributep attr call))
688 (every #'constant-continuation-p args)
689 (continuation-dest (node-cont node)))
690 (constant-fold-call node)
691 (return-from ir1-optimize-combination)))
692
693 (let ((fun (function-info-derive-type kind)))
694 (when fun
695 (let ((res (funcall fun node)))
696 (when res
697 (derive-node-type node res)))))
698
699 (let ((fun (function-info-optimizer kind)))
700 (unless (and fun (funcall fun node))
701 (dolist (x (function-info-transforms kind))
702 (unless (ir1-transform node (car x) (cdr x))
703 (return))))))))
704
705 (undefined-value))
706
707
708 ;;; Recognize-Known-Call -- Interface
709 ;;;
710 ;;; If Call is a call to a known function, mark it as such by setting the
711 ;;; Kind. In addition to a direct check for the function name in the table, we
712 ;;; also must check for slot accessors. If the function is a slot accessor,
713 ;;; then we set the combination kind to the function info of %Slot-Setter or
714 ;;; %Slot-Accessor, as appropriate.
715 ;;;
716 (defun recognize-known-call (call)
717 (declare (type combination call))
718 (let* ((fun (basic-combination-fun call))
719 (name (continuation-function-name fun)))
720 (when name
721 (let ((info (info function info name)))
722 (cond (info
723 (setf (basic-combination-kind call) info))
724 ((slot-accessor-p (ref-leaf (continuation-use fun)))
725 (setf (basic-combination-kind call)
726 (info function info
727 (if (consp name)
728 '%slot-setter
729 '%slot-accessor))))))))
730 (undefined-value))
731
732
733 ;;; Propagate-Function-Change -- Internal
734 ;;;
735 ;;; Called by Ir1-Optimize when the function for a call has changed.
736 ;;; If the call is to a functional, then we attempt to convert it to a local
737 ;;; call, otherwise we check the call for legality with respect to the new
738 ;;; type; if it is illegal, we mark the Ref as :Notline and punt.
739 ;;;
740 ;;; If we do have a good type for the call, we propagate type information from
741 ;;; the type to the arg and result continuations. If we discover that the call
742 ;;; is to a known global function, then we mark the combination as known.
743 ;;;
744 (defun propagate-function-change (call)
745 (declare (type combination call))
746 (let* ((fun (combination-fun call))
747 (use (continuation-use fun))
748 (type (continuation-derived-type fun))
749 (*compiler-error-context* call))
750 (setf (continuation-reoptimize fun) nil)
751 (cond ((or (not (ref-p use))
752 (eq (ref-inlinep use) :notinline)))
753 ((functional-p (ref-leaf use))
754 (let ((leaf (ref-leaf use)))
755 (cond ((eq (combination-kind call) :local)
756 (let ((tail-set (lambda-tail-set leaf)))
757 (when tail-set
758 (derive-node-type
759 call (tail-set-type tail-set)))))
760 ((not (eq (ref-inlinep use) :notinline))
761 (convert-call-if-possible use call)
762 (maybe-let-convert leaf)))))
763 ((not (function-type-p type)))
764 ((valid-function-use call type
765 :argument-test #'always-subtypep
766 :result-test #'always-subtypep
767 :error-function #'compiler-warning
768 :warning-function #'compiler-note)
769 (assert-call-type call type)
770 (recognize-known-call call))
771 (t
772 (setf (ref-inlinep use) :notinline))))
773
774 (undefined-value))
775
776
777 ;;;; Known function optimization:
778
779 ;;;
780 ;;; A hashtable from combination nodes to things describing how an
781 ;;; optimization of the node failed. The value is an alist
782 ;;; (Fun . Args), where Fun is the transformation function that failed and Args
783 ;;; is either a list for format arguments for the note or the FUNCTION-TYPE
784 ;;; that would have enabled the transformation but failed to match.
785 ;;;
786 (defvar *failed-optimizations* (make-hash-table :test #'eq))
787
788
789 ;;; RECORD-OPTIMIZATION-FAILURE -- Internal
790 ;;;
791 ;;; Add a failed optimization note to *FAILED-OPTIMZATIONS* for Node, Fun
792 ;;; and Args. If there is already a note for Node and Fun, replace it,
793 ;;; otherwise add a new one.
794 ;;;
795 (defun record-optimization-failure (node fun args)
796 (declare (type combination node) (type function fun)
797 (type (or function-type list) args))
798 (let ((found (assoc fun (gethash node *failed-optimizations*))))
799 (if found
800 (setf (cdr found) args)
801 (push (cons fun args)
802 (gethash node *failed-optimizations*))))
803 (undefined-value))
804
805
806 ;;; IR1-Transform -- Internal
807 ;;;
808 ;;; Attempt to transform Node using Function, subject to the call type
809 ;;; constraint Type. If we are inhibited from doing the transform for some
810 ;;; reason and Flame is true, then we make a note of the message in
811 ;;; *failed-optimizations* for IR1 finalize to pick up. We return true if
812 ;;; the transform failed, and thus further transformation should be
813 ;;; attempted. We return false if either the transform suceeded or was
814 ;;; aborted.
815 ;;;
816 (defun ir1-transform (node type fun)
817 (declare (type combination node) (type ctype type) (type function fun))
818 (let ((constrained (function-type-p type))
819 (flame (policy node (> speed brevity)))
820 (*compiler-error-context* node))
821 (cond ((or (not constrained)
822 (valid-function-use node type))
823 (multiple-value-bind
824 (severity args)
825 (catch 'give-up
826 (transform-call node (funcall fun node))
827 (values :none nil))
828 (ecase severity
829 (:none
830 (remhash node *failed-optimizations*)
831 nil)
832 (:aborted
833 (setf (combination-kind node) :full)
834 (setf (ref-inlinep (continuation-use (combination-fun node)))
835 :notinline)
836 (when args
837 (apply #'compiler-warning args))
838 (remhash node *failed-optimizations*)
839 nil)
840 (:failure
841 (if args
842 (when flame
843 (record-optimization-failure node fun args))
844 (setf (gethash node *failed-optimizations*)
845 (remove fun (gethash node *failed-optimizations*)
846 :key #'car)))
847 t))))
848 ((and flame
849 (valid-function-use node type
850 :argument-test #'types-intersect
851 :result-test #'values-types-intersect))
852 (record-optimization-failure node fun type)
853 t)
854 (t
855 t))))
856
857
858 ;;; GIVE-UP, ABORT-TRANSFORM -- Interface
859 ;;;
860 ;;; Just throw the severity and args...
861 ;;;
862 (proclaim '(function give-up (&rest t) nil))
863 (defun give-up (&rest args)
864 "This function is used to throw out of an IR1 transform, aborting this
865 attempt to transform the call, but admitting the possibility that this or
866 some other transform will later suceed. If arguments are supplied, they are
867 format arguments for an efficiency note."
868 (throw 'give-up (values :failure args)))
869 ;;;
870 (defun abort-transform (&rest args)
871 "This function is used to throw out of an IR1 transform and force a normal
872 call to the function at run time. No further optimizations will be
873 attempted."
874 (throw 'give-up (values :aborted args)))
875
876
877 ;;; Transform-Call -- Internal
878 ;;;
879 ;;; Take the lambda-expression Res, IR1 convert it in the proper
880 ;;; environment, and then install it as the function for the call Node. We do
881 ;;; local call analysis so that the new function is integrated into the control
882 ;;; flow. We set the Reanalyze flag in the component to cause the DFO to be
883 ;;; recomputed at soonest convenience.
884 ;;;
885 (defun transform-call (node res)
886 (declare (type combination node) (list res))
887 (with-ir1-environment node
888 (let ((new-fun (ir1-convert-global-lambda res))
889 (ref (continuation-use (combination-fun node))))
890 (change-ref-leaf ref new-fun)
891 (setf (combination-kind node) :full)
892 (local-call-analyze *current-component*)))
893 (undefined-value))
894
895
896 ;;; Constant-Fold-Call -- Internal
897 ;;;
898 ;;; Replace a call to a foldable function of constant arguments with the
899 ;;; result of evaluating the form. We insert the resulting constant node after
900 ;;; the call, stealing the call's continuation. We give the call a
901 ;;; continuation with no Dest, which should cause it and its arguments to go
902 ;;; away. If there is an error during the evaluation, we give a warning and
903 ;;; leave the call alone, making the call a full call and marking it as
904 ;;; :notinline to make sure that it stays that way.
905 ;;;
906 ;;; For now, if the result is other than one value, we don't fold it.
907 ;;;
908 (defun constant-fold-call (call)
909 (declare (type combination call))
910 (let* ((args (mapcar #'continuation-value (combination-args call)))
911 (ref (continuation-use (combination-fun call)))
912 (fun (leaf-name (ref-leaf ref))))
913
914 (multiple-value-bind (values win)
915 (careful-call fun args call "constant folding")
916 (cond
917 ((not win)
918 (setf (ref-inlinep ref) :notinline)
919 (setf (combination-kind call) :full))
920 ((= (length values) 1)
921 (with-ir1-environment call
922 (let* ((leaf (find-constant (first values)))
923 (node (make-ref (leaf-type leaf)
924 leaf
925 nil))
926 (dummy (make-continuation))
927 (cont (node-cont call))
928 (block (node-block call))
929 (next (continuation-next cont)))
930 (push node (leaf-refs leaf))
931 (setf (leaf-ever-used leaf) t)
932
933 (delete-continuation-use call)
934 (add-continuation-use call dummy)
935 (prev-link node dummy)
936 (add-continuation-use node cont)
937 (setf (continuation-next cont) next)
938 (when (eq call (block-last block))
939 (setf (block-last block) node))
940 (reoptimize-continuation cont)))))))
941
942 (undefined-value))
943
944
945 ;;;; Local call optimization:
946
947 ;;; Propagate-To-Refs -- Internal
948 ;;;
949 ;;; Propagate Type to Leaf and its Refs, marking things changed. If the
950 ;;; leaf type is a function type, then just leave it alone, since TYPE is never
951 ;;; going to be more specific than that (and TYPE-INTERSECTION would choke.)
952 ;;;
953 (defun propagate-to-refs (leaf type)
954 (declare (type leaf leaf) (type ctype type))
955 (let ((var-type (leaf-type leaf)))
956 (unless (function-type-p var-type)
957 (let ((int (type-intersection var-type type)))
958 (when (type/= int var-type)
959 (setf (leaf-type leaf) int)
960 (dolist (ref (leaf-refs leaf))
961 (derive-node-type ref int))))
962 (undefined-value))))
963
964
965 ;;; PROPAGATE-FROM-SETS -- Internal
966 ;;;
967 ;;; Figure out the type of a LET variable that has sets. We compute the
968 ;;; union of the initial value Type and the types of all the set values and to
969 ;;; a PROPAGATE-TO-REFS with this type.
970 ;;;
971 (defun propagate-from-sets (var type)
972 (collect ((res type type-union))
973 (dolist (set (basic-var-sets var))
974 (res (continuation-type (set-value set)))
975 (setf (node-reoptimize set) nil))
976 (propagate-to-refs var (res)))
977 (undefined-value))
978
979
980 ;;; IR1-OPTIMIZE-SET -- Internal
981 ;;;
982 ;;; If a let variable, find the initial value's type and do
983 ;;; PROPAGATE-FROM-SETS. We also derive the VALUE's type as the node's type.
984 ;;;
985 (defun ir1-optimize-set (node)
986 (declare (type cset node))
987 (let ((var (set-var node)))
988 (when (and (lambda-var-p var) (leaf-refs var))
989 (let ((home (lambda-var-home var)))
990 (when (eq (functional-kind home) :let)
991 (let ((iv (let-var-initial-value var)))
992 (setf (continuation-reoptimize iv) nil)
993 (propagate-from-sets var (continuation-type iv)))))))
994
995 (derive-node-type node (continuation-type (set-value node)))
996 (undefined-value))
997
998
999 ;;; CONSTANT-REFERENCE-P -- Internal
1000 ;;;
1001 ;;; Return true if the value of Ref will always be the same (and is thus
1002 ;;; legal to substitute.)
1003 ;;;
1004 (defun constant-reference-p (ref)
1005 (declare (type ref ref))
1006 (let ((leaf (ref-leaf ref)))
1007 (typecase leaf
1008 (constant t)
1009 (functional t)
1010 (lambda-var
1011 (null (lambda-var-sets leaf)))
1012 (global-var
1013 (case (global-var-kind leaf)
1014 (:global-function
1015 (not (eq (ref-inlinep ref) :notinline)))
1016 (:constant t))))))
1017
1018
1019 ;;; SUBSTITUTE-SINGLE-USE-CONTINUATION -- Internal
1020 ;;;
1021 ;;; If we have a non-set let var with a single use, then (if possible)
1022 ;;; replace the variable reference's CONT with the arg continuation. This is
1023 ;;; inhibited when:
1024 ;;; -- CONT has other uses, or
1025 ;;; -- CONT receives multiple values, or
1026 ;;; -- the reference is in a different environment from the variable, or
1027 ;;; -- either continuation has a funky TYPE-CHECK annotation.
1028 ;;;
1029 ;;; We change the Ref to be a reference to NIL with unused value, and let it
1030 ;;; be flushed as dead code. A side-effect of this substitution is to delete
1031 ;;; the variable.
1032 ;;;
1033 (defun substitute-single-use-continuation (arg var)
1034 (declare (type continuation arg) (type lambda-var var))
1035 (let* ((ref (first (leaf-refs var)))
1036 (cont (node-cont ref))
1037 (dest (continuation-dest cont)))
1038 (when (and (eq (continuation-use cont) ref)
1039 dest
1040 (not (typep dest '(or creturn exit mv-combination)))
1041 (eq (node-home-lambda ref)
1042 (lambda-home (lambda-var-home var)))
1043 (member (continuation-type-check arg) '(t nil))
1044 (member (continuation-type-check cont) '(t nil)))
1045 (assert-continuation-type arg (continuation-asserted-type cont))
1046 (change-ref-leaf ref (find-constant nil))
1047 (substitute-continuation arg cont)
1048 (reoptimize-continuation arg)
1049 t)))
1050
1051
1052 ;;; Propagate-Let-Args -- Internal
1053 ;;;
1054 ;;; This function is called when one of the arguments to a LET changes. We
1055 ;;; look at each changed argument. If the corresponding variable is set, then
1056 ;;; we call PROPAGATE-FROM-SETS. Otherwise, we consider substituting for the
1057 ;;; variable, and also propagate derived-type information for the arg to all
1058 ;;; the Var's refs.
1059 ;;;
1060 ;;; Substitution is inhibited when the arg leaf's derived type isn't a
1061 ;;; subtype of the argument's asserted type. This prevents type checking from
1062 ;;; being defeated, and also ensures that the best representation for the
1063 ;;; variable can be used.
1064 ;;;
1065 ;;; Note that we are responsible for clearing the Continuation-Reoptimize
1066 ;;; flags.
1067 ;;;
1068 (defun propagate-let-args (call fun)
1069 (declare (type combination call) (type clambda fun))
1070 (mapc #'(lambda (arg var)
1071 (when (and arg
1072 (continuation-reoptimize arg))
1073 (setf (continuation-reoptimize arg) nil)
1074 (cond
1075 ((lambda-var-sets var)
1076 (propagate-from-sets var (continuation-type arg)))
1077 ((let ((use (continuation-use arg)))
1078 (when (ref-p use)
1079 (let ((leaf (ref-leaf use)))
1080 (when (and (constant-reference-p use)
1081 (values-subtypep
1082 (leaf-type leaf)
1083 (continuation-asserted-type arg)))
1084 (propagate-to-refs var (continuation-type arg))
1085 (substitute-leaf leaf var)
1086 t)))))
1087 ((and (null (rest (leaf-refs var)))
1088 (substitute-single-use-continuation arg var)))
1089 (t
1090 (propagate-to-refs var (continuation-type arg))))))
1091 (basic-combination-args call)
1092 (lambda-vars fun))
1093 (undefined-value))
1094
1095
1096 ;;; Propagate-Local-Call-Args -- Internal
1097 ;;;
1098 ;;; This function is called when one of the args to a non-let local call
1099 ;;; changes. For each changed argument corresponding to an unset variable, we
1100 ;;; compute the union of the types across all calls and propagate this type
1101 ;;; information to the var's refs.
1102 ;;;
1103 ;;; If the function has an XEP, then we don't do anything, since we won't
1104 ;;; discover anything.
1105 ;;;
1106 ;;; We can clear the Continuation-Reoptimize flags for arguments in all calls
1107 ;;; corresponding to changed arguments in Call, since the only use in IR1
1108 ;;; optimization of the Reoptimize flag for local call args is right here.
1109 ;;;
1110 (defun propagate-local-call-args (call fun)
1111 (declare (type combination call) (type clambda fun))
1112
1113 (unless (functional-entry-function fun)
1114 (let* ((vars (lambda-vars fun))
1115 (union (mapcar #'(lambda (arg var)
1116 (when (and arg
1117 (continuation-reoptimize arg)
1118 (null (basic-var-sets var)))
1119 (continuation-type arg)))
1120 (basic-combination-args call)
1121 vars))
1122 (this-ref (continuation-use (basic-combination-fun call))))
1123
1124 (dolist (arg (basic-combination-args call))
1125 (when arg
1126 (setf (continuation-reoptimize arg) nil)))
1127
1128 (dolist (ref (leaf-refs fun))
1129 (unless (eq ref this-ref)
1130 (setq union
1131 (mapcar #'(lambda (this-arg old)
1132 (when old
1133 (setf (continuation-reoptimize this-arg) nil)
1134 (type-union (continuation-type this-arg) old)))
1135 (basic-combination-args
1136 (continuation-dest (node-cont ref)))
1137 union))))
1138
1139 (mapc #'(lambda (var type)
1140 (when type
1141 (propagate-to-refs var type)))
1142 vars union)))
1143
1144 (undefined-value))
1145
1146
1147 ;;; IR1-OPTIMIZE-MV-BIND -- Internal
1148 ;;;
1149 ;;; Propagate derived type info from the values continuation to the vars.
1150 ;;;
1151 (defun ir1-optimize-mv-bind (node)
1152 (declare (type mv-combination node))
1153 (let ((arg (first (basic-combination-args node)))
1154 (vars (lambda-vars (combination-lambda node))))
1155 (multiple-value-bind (types nvals)
1156 (values-types (continuation-derived-type arg))
1157 (unless (eq nvals :unknown)
1158 (mapc #'(lambda (var type)
1159 (if (basic-var-sets var)
1160 (propagate-from-sets var type)
1161 (propagate-to-refs var type)))
1162 vars
1163 (append types
1164 (make-list (max (- (length vars) nvals) 0)
1165 :initial-element *null-type*)))))
1166
1167 (setf (continuation-reoptimize arg) nil))
1168 (undefined-value))
1169
1170
1171 ;;; Flush-Dead-Code -- Internal
1172 ;;;
1173 ;;; Delete any nodes in Block whose value is unused and have no
1174 ;;; side-effects. We can delete sets of lexical variables when the set
1175 ;;; variable has no references.
1176 ;;;
1177 ;;; [### For now, don't delete potentially flushable calls when they have the
1178 ;;; Call attribute. Someday we should look at the funcitonal args to determine
1179 ;;; if they have any side-effects.]
1180 ;;;
1181 (defun flush-dead-code (block)
1182 (declare (type cblock block))
1183 (do-nodes-backwards (node cont block)
1184 (unless (continuation-dest cont)
1185 (typecase node
1186 (ref
1187 (delete-ref node)
1188 (unlink-node node))
1189 (combination
1190 (let ((info (combination-kind node)))
1191 (when (function-info-p info)
1192 (let ((attr (function-info-attributes info)))
1193 (when (and (ir1-attributep attr flushable)
1194 (not (ir1-attributep attr call)))
1195 (flush-dest (combination-fun node))
1196 (dolist (arg (combination-args node))
1197 (flush-dest arg))
1198 (unlink-node node))))))
1199 (exit
1200 (let ((value (exit-value node)))
1201 (when value
1202 (flush-dest value)
1203 (setf (exit-value node) nil))))
1204 (cset
1205 (let ((var (set-var node)))
1206 (when (and (lambda-var-p var)
1207 (null (leaf-refs var)))
1208 (flush-dest (set-value node))
1209 (setf (basic-var-sets var)
1210 (delete node (basic-var-sets var)))
1211 (unlink-node node)))))))
1212
1213 (setf (block-flush-p block) nil)
1214 (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5