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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (show annotations)
Mon Dec 16 10:09:10 1991 UTC (22 years, 4 months ago) by wlott
Branch: MAIN
Changes since 1.36: +3 -2 lines
Only call maybe-emit-make-load-forms when we are (producing-fasl-file).
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/ir1opt.lisp,v 1.37 1991/12/16 10:09:10 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file implements the IR1 optimization phase of the compiler. IR1
15 ;;; optimization is a grab-bag of optimizations that don't make major changes
16 ;;; to the block-level control flow and don't use flow analysis. These
17 ;;; optimizations can mostly be classified as "meta-evaluation", but there is a
18 ;;; sizable top-down component as well.
19 ;;;
20 ;;; Written by Rob MacLachlan
21 ;;;
22 (in-package 'c)
23
24
25 ;;;; Interface for obtaining results of constant folding:
26
27 ;;; Constant-Continuation-P -- Interface
28 ;;;
29 ;;; Return true if the sole use of Cont is a reference to a constant leaf.
30 ;;;
31 (proclaim '(function constant-continuation-p (continuation) boolean))
32 (defun constant-continuation-p (cont)
33 (let ((use (continuation-use cont)))
34 (and (ref-p use)
35 (constant-p (ref-leaf use)))))
36
37
38 ;;; Continuation-Value -- Interface
39 ;;;
40 ;;; Return the constant value for a continuation whose only use is a
41 ;;; constant node.
42 ;;;
43 (proclaim '(function continuation-value (continuation) t))
44 (defun continuation-value (cont)
45 (assert (constant-continuation-p cont))
46 (constant-value (ref-leaf (continuation-use cont))))
47
48
49 ;;;; Interface for obtaining results of type inference:
50
51 ;;; CONTINUATION-PROVEN-TYPE -- Interface
52 ;;;
53 ;;; Return a (possibly values) type that describes what we have proven about
54 ;;; the type of Cont without taking any type assertions into consideration.
55 ;;; This is just the union of the NODE-DERIVED-TYPE of all the uses. Most
56 ;;; often people use CONTINUATION-DERIVED-TYPE or CONTINUATION-TYPE instead of
57 ;;; using this function directly.
58 ;;;
59 (defun continuation-proven-type (cont)
60 (declare (type continuation cont))
61 (ecase (continuation-kind cont)
62 ((:block-start :deleted-block-start)
63 (let ((uses (block-start-uses (continuation-block cont))))
64 (if uses
65 (do ((res (node-derived-type (first uses))
66 (values-type-union (node-derived-type (first current))
67 res))
68 (current (rest uses) (rest current)))
69 ((null current) res))
70 *empty-type*)))
71 (:inside-block
72 (node-derived-type (continuation-use cont)))))
73
74
75 ;;; Continuation-Derived-Type -- Interface
76 ;;;
77 ;;; Our best guess for the type of this continuation's value. Note that
78 ;;; this may be Values or Function type, which cannot be passed as an argument
79 ;;; to the normal type operations. See Continuation-Type. This may be called
80 ;;; on deleted continuations, always returning *.
81 ;;;
82 ;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the result
83 ;;; is a subtype of the assertion. If so, return the proven type and set
84 ;;; TYPE-CHECK to nil. Otherwise, return the intersection of the asserted and
85 ;;; proven types, and set TYPE-CHECK T. If TYPE-CHECK already has a non-null
86 ;;; value, then preserve it. Only in the somewhat unusual circumstance of
87 ;;; a newly discovered assertion will we change TYPE-CHECK from NIL to T.
88 ;;;
89 ;;; The result value is cached in the Continuation-%Derived-Type. If the
90 ;;; slot is true, just return that value, otherwise recompute and stash the
91 ;;; value there.
92 ;;;
93 (proclaim '(inline continuation-derived-type))
94 (defun continuation-derived-type (cont)
95 (declare (type continuation cont))
96 (or (continuation-%derived-type cont)
97 (%continuation-derived-type cont)))
98 ;;;
99 (defun %continuation-derived-type (cont)
100 (declare (type continuation cont))
101 (let ((proven (continuation-proven-type cont))
102 (asserted (continuation-asserted-type cont)))
103 (cond ((values-subtypep proven asserted)
104 (setf (continuation-%type-check cont) nil)
105 (setf (continuation-%derived-type cont) proven))
106 (t
107 (unless (or (continuation-%type-check cont)
108 (not (continuation-dest cont))
109 (eq asserted *universal-type*))
110 (setf (continuation-%type-check cont) t))
111
112 (setf (continuation-%derived-type cont)
113 (values-type-intersection asserted proven))))))
114
115
116 ;;; CONTINUATION-TYPE-CHECK -- Interface
117 ;;;
118 ;;; Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to date, then
119 ;;; return it.
120 ;;;
121 (proclaim '(inline continuation-type-check))
122 (defun continuation-type-check (cont)
123 (declare (type continuation cont))
124 (continuation-derived-type cont)
125 (continuation-%type-check cont))
126
127
128 ;;; Continuation-Type -- Interface
129 ;;;
130 ;;; Return the derived type for Cont's first value. This is guaranteed not
131 ;;; to be a Values or Function type.
132 ;;;
133 (proclaim '(function continuation-type (continuation) ctype))
134 (defun continuation-type (cont)
135 (single-value-type (continuation-derived-type cont)))
136
137
138 ;;;; Interface routines used by optimizers:
139
140 ;;; Reoptimize-Continuation -- Interface
141 ;;;
142 ;;; This function is called by optimizers to indicate that something
143 ;;; interesting has happened to the value of Cont. Optimizers must make sure
144 ;;; that they don't call for reoptimization when nothing has happened, since
145 ;;; optimization will fail to terminate.
146 ;;;
147 ;;; We clear any cached type for the continuation and set the reoptimize
148 ;;; flags on everything in sight, unless the continuation is deleted (in which
149 ;;; case we do nothing.)
150 ;;;
151 ;;; Since this can get called curing IR1 conversion, we have to be careful
152 ;;; not to fly into space when the Dest's Prev is missing.
153 ;;;
154 (defun reoptimize-continuation (cont)
155 (declare (type continuation cont))
156 (unless (member (continuation-kind cont) '(:deleted :unused))
157 (setf (continuation-%derived-type cont) nil)
158 (let ((dest (continuation-dest cont)))
159 (when dest
160 (setf (continuation-reoptimize cont) t)
161 (setf (node-reoptimize dest) t)
162 (let ((prev (node-prev dest)))
163 (when prev
164 (let* ((block (continuation-block prev))
165 (component (block-component block)))
166 (when (typep dest 'cif)
167 (setf (block-test-modified block) t))
168 (setf (block-reoptimize block) t)
169 (setf (component-reoptimize component) t))))))
170 (do-uses (node cont)
171 (setf (block-type-check (node-block node)) t)))
172 (undefined-value))
173
174
175 ;;; Derive-Node-Type -- Interface
176 ;;;
177 ;;; Annotate Node to indicate that its result has been proven to be typep to
178 ;;; RType. After IR1 conversion has happened, this is the only correct way to
179 ;;; supply information discovered about a node's type. If you fuck with the
180 ;;; Node-Derived-Type directly, then information may be lost and reoptimization
181 ;;; may not happen.
182 ;;;
183 ;;; What we do is intersect Rtype with Node's Derived-Type. If the
184 ;;; intersection is different from the old type, then we do a
185 ;;; Reoptimize-Continuation on the Node-Cont.
186 ;;;
187 (defun derive-node-type (node rtype)
188 (declare (type node node) (type ctype rtype))
189 (let ((node-type (node-derived-type node)))
190 (unless (eq node-type rtype)
191 (let ((int (values-type-intersection node-type rtype)))
192 (when (type/= node-type int)
193 (when (and (eq int *empty-type*)
194 (not (eq rtype *empty-type*)))
195 (let ((*compiler-error-context* node))
196 (compiler-warning
197 "New inferred type ~S conflicts with old type:~
198 ~% ~S~%*** Bug?"
199 (type-specifier rtype) (type-specifier node-type))))
200 (setf (node-derived-type node) int)
201 (reoptimize-continuation (node-cont node))))))
202 (undefined-value))
203
204
205 ;;; Assert-Continuation-Type -- Interface
206 ;;;
207 ;;; Similar to Derive-Node-Type, but asserts that it is an error for Cont's
208 ;;; value not to be typep to Type. If we improve the assertion, we set
209 ;;; TYPE-CHECK and TYPE-ASSERTED to guarantee that the new assertion will be
210 ;;; checked.
211 ;;;
212 (defun assert-continuation-type (cont type)
213 (declare (type continuation cont) (type ctype type))
214 (let ((cont-type (continuation-asserted-type cont)))
215 (unless (eq cont-type type)
216 (let ((int (values-type-intersection cont-type type)))
217 (when (type/= cont-type int)
218 (setf (continuation-asserted-type cont) int)
219 (do-uses (node cont)
220 (setf (block-attributep (block-flags (node-block node))
221 type-check type-asserted)
222 t))
223 (reoptimize-continuation cont)))))
224 (undefined-value))
225
226
227 ;;; Assert-Call-Type -- Interface
228 ;;;
229 ;;; Assert that Call is to a function of the specified Type. It is assumed
230 ;;; that the call is legal and has only constants in the keyword positions.
231 ;;;
232 (defun assert-call-type (call type)
233 (declare (type combination call) (type function-type type))
234 (derive-node-type call (function-type-returns type))
235 (let ((args (combination-args call)))
236 (dolist (req (function-type-required type))
237 (when (null args) (return-from assert-call-type))
238 (let ((arg (pop args)))
239 (assert-continuation-type arg req)))
240 (dolist (opt (function-type-optional type))
241 (when (null args) (return-from assert-call-type))
242 (let ((arg (pop args)))
243 (assert-continuation-type arg opt)))
244
245 (let ((rest (function-type-rest type)))
246 (when rest
247 (dolist (arg args)
248 (assert-continuation-type arg rest))))
249
250 (dolist (key (function-type-keywords type))
251 (let ((name (key-info-name key)))
252 (do ((arg args (cddr arg)))
253 ((null arg))
254 (when (eq (continuation-value (first arg)) name)
255 (assert-continuation-type
256 (second arg) (key-info-type key)))))))
257 (undefined-value))
258
259
260 ;;; IR1-Optimize -- Interface
261 ;;;
262 ;;; Do one forward pass over Component, deleting unreachable blocks and
263 ;;; doing IR1 optimizations. We can ignore all blocks that don't have the
264 ;;; Reoptimize flag set. If Component-Reoptimize is true when we are done,
265 ;;; then another iteration would be beneficial.
266 ;;;
267 ;;; We delete blocks when there is either no predecessor or the block is in
268 ;;; a lambda that has been deleted. These blocks would eventually be deleted
269 ;;; by DFO recomputation, but doing it here immediately makes the effect
270 ;;; avaliable to IR1 optimization.
271 ;;;
272 (defun ir1-optimize (component)
273 (declare (type component component))
274 (setf (component-reoptimize component) nil)
275 (do-blocks (block component)
276 (cond
277 ((or (block-delete-p block)
278 (null (block-pred block))
279 (eq (functional-kind (block-home-lambda block)) :deleted))
280 (delete-block block))
281 (t
282 (loop
283 (let ((succ (block-succ block)))
284 (unless (and succ (null (rest succ)))
285 (return)))
286
287 (let ((last (block-last block)))
288 (typecase last
289 (cif
290 (flush-dest (if-test last))
291 (when (unlink-node last) (return)))
292 (exit
293 (when (maybe-delete-exit last) (return)))))
294
295 (unless (join-successor-if-possible block)
296 (return)))
297
298 (when (and (block-reoptimize block) (block-component block))
299 (assert (not (block-delete-p block)))
300 (ir1-optimize-block block))
301
302 (when (and (block-flush-p block) (block-component block))
303 (assert (not (block-delete-p block)))
304 (flush-dead-code block)))))
305
306 (undefined-value))
307
308
309 ;;; IR1-Optimize-Block -- Internal
310 ;;;
311 ;;; Loop over the nodes in Block, looking for stuff that needs to be
312 ;;; optimized. We dispatch off of the type of each node with its reoptimize
313 ;;; flag set:
314 ;;; -- With a combination, we call Propagate-Function-Change whenever the
315 ;;; function changes, and call IR1-Optimize-Combination if any argument
316 ;;; changes.
317 ;;; -- With an Exit, we derive the node's type from the Value's type. We don't
318 ;;; propagate Cont's assertion to the Value, since if we did, this would
319 ;;; move the checking of Cont's assertion to the exit. This wouldn't work
320 ;;; with Catch and UWP, where the Exit node is just a placeholder for the
321 ;;; actual unknown exit.
322 ;;;
323 ;;; Note that we clear the node & block reoptimize flags *before* doing the
324 ;;; optimization. This ensures that the node or block will be reoptimized if
325 ;;; necessary. We leave the NODE-OPTIMIZE flag set going into
326 ;;; IR1-OPTIMIZE-RETURN, since it wants to clear the flag itself.
327 ;;;
328 (defun ir1-optimize-block (block)
329 (declare (type cblock block))
330 (setf (block-reoptimize block) nil)
331 (do-nodes (node cont block :restart-p t)
332 (when (node-reoptimize node)
333 (setf (node-reoptimize node) nil)
334 (typecase node
335 (ref)
336 (combination
337 (when (continuation-reoptimize (basic-combination-fun node))
338 (propagate-function-change node))
339 (ir1-optimize-combination node)
340 (unless (node-deleted node)
341 (maybe-terminate-block node nil)))
342 (cif
343 (ir1-optimize-if node))
344 (creturn
345 (setf (node-reoptimize node) t)
346 (ir1-optimize-return node))
347 (mv-combination
348 (ir1-optimize-mv-combination node))
349 (exit
350 (let ((value (exit-value node)))
351 (when value
352 (derive-node-type node (continuation-derived-type value)))))
353 (cset
354 (ir1-optimize-set node)))))
355 (undefined-value))
356
357
358 ;;; Join-Successor-If-Possible -- Internal
359 ;;;
360 ;;; We cannot combine with a successor block if:
361 ;;; 1] The successor has more than one predecessor.
362 ;;; 2] The last node's Cont is also used somewhere else.
363 ;;; 3] The successor is the current block (infinite loop).
364 ;;; 4] The next block has a different cleanup, and thus we may want to insert
365 ;;; cleanup code between the two blocks at some point.
366 ;;; 5] The next block has a different home lambda, and thus the control
367 ;;; transfer is a non-local exit.
368 ;;;
369 ;;; If we succeed, we return true, otherwise false.
370 ;;;
371 ;;; Joining is easy when the successor's Start continuation is the same from
372 ;;; our Last's Cont. If they differ, then we can still join when the last
373 ;;; continuation has no next and the next continuation has no uses. In this
374 ;;; case, we replace the next continuation with the last before joining the
375 ;;; blocks.
376 ;;;
377 (defun join-successor-if-possible (block)
378 (declare (type cblock block))
379 (let ((next (first (block-succ block))))
380 (when (block-start next)
381 (let* ((last (block-last block))
382 (last-cont (node-cont last))
383 (next-cont (block-start next)))
384 (cond ((or (rest (block-pred next))
385 (not (eq (continuation-use last-cont) last))
386 (eq next block)
387 (not (eq (block-end-cleanup block)
388 (block-start-cleanup next)))
389 (not (eq (block-home-lambda block)
390 (block-home-lambda next))))
391 nil)
392 ((eq last-cont next-cont)
393 (join-blocks block next)
394 t)
395 ((and (null (block-start-uses next))
396 (eq (continuation-kind last-cont) :inside-block))
397 (let ((next-node (continuation-next next-cont)))
398 ;;
399 ;; If next-cont does have a dest, it must be unreachable,
400 ;; since there are no uses. DELETE-CONTINUATION will mark the
401 ;; dest block as delete-p [and also this block, unless it is
402 ;; no longer backward reachable from the dest block.]
403 (delete-continuation next-cont)
404 (setf (node-prev next-node) last-cont)
405 (setf (continuation-next last-cont) next-node)
406 (setf (block-start next) last-cont)
407 (join-blocks block next))
408 t)
409 (t
410 nil))))))
411
412
413 ;;; Join-Blocks -- Internal
414 ;;;
415 ;;; Join together two blocks which have the same ending/starting
416 ;;; continuation. The code in Block2 is moved into Block1 and Block2 is
417 ;;; deleted from the DFO. We combine the optimize flags for the two blocks so
418 ;;; that any indicated optimization gets done.
419 ;;;
420 (defun join-blocks (block1 block2)
421 (declare (type cblock block1 block2))
422 (let* ((last (block-last block2))
423 (last-cont (node-cont last))
424 (succ (block-succ block2))
425 (start2 (block-start block2)))
426 (do ((cont start2 (node-cont (continuation-next cont))))
427 ((eq cont last-cont)
428 (when (eq (continuation-kind last-cont) :inside-block)
429 (setf (continuation-block last-cont) block1)))
430 (setf (continuation-block cont) block1))
431
432 (unlink-blocks block1 block2)
433 (dolist (block succ)
434 (unlink-blocks block2 block)
435 (link-blocks block1 block))
436
437 (setf (block-last block1) last)
438 (setf (continuation-kind start2) :inside-block))
439
440 (setf (block-flags block1)
441 (attributes-union (block-flags block1)
442 (block-flags block2)
443 (block-attributes type-asserted test-modified)))
444
445 (let ((next (block-next block2))
446 (prev (block-prev block2)))
447 (setf (block-next prev) next)
448 (setf (block-prev next) prev))
449
450 (undefined-value))
451
452
453 ;;;; Local call return type propagation:
454
455 ;;; Find-Result-Type -- Internal
456 ;;;
457 ;;; This function is called on RETURN nodes that have their REOPTIMIZE flag
458 ;;; set. It iterates over the uses of the RESULT, looking for interesting
459 ;;; stuff to update the TAIL-SET:
460 ;;; -- If a use is a tail local call, then we check that the called function
461 ;;; has the tail set Tails. If we encounter any different tail set, we
462 ;;; return true. If NODE-TAIL-P is not set, we also call
463 ;;; CONVERT-TAIL-LOCAL-CALL, which changes the succesor of the call to be
464 ;;; the called function and checks if the call can become an assignment.
465 ;;; -- If a use isn't a local call, then we union its type together with the
466 ;;; types of other such uses. We assign to the RETURN-RESULT-TYPE the
467 ;;; intersection of this type with the RESULT's asserted type. We can make
468 ;;; this intersection now (potentially before type checking) because this
469 ;;; assertion on the result will eventually be checked (if appropriate.)
470 ;;;
471 (defun find-result-type (node tails)
472 (declare (type creturn node))
473 (let ((result (return-result node))
474 (retry nil))
475 (collect ((use-union *empty-type* values-type-union))
476 (do-uses (use result)
477 (cond ((and (basic-combination-p use)
478 (eq (basic-combination-kind use) :local)
479 (immediately-used-p result use))
480 (when (merge-tail-sets use tails)
481 (setq retry t))
482 (maybe-convert-tail-local-call use))
483 (t
484 (use-union (node-derived-type use)))))
485 (let ((int (values-type-intersection
486 (continuation-asserted-type result)
487 (use-union))))
488 (setf (return-result-type node) int)))
489 retry))
490
491
492 ;;; Merge-Tail-Sets -- Internal
493 ;;;
494 ;;; This function handles merging the tail sets if Call is a call to a
495 ;;; function with a different TAIL-SET than Ret-Set. We return true if we do
496 ;;; anything.
497 ;;;
498 ;;; It is assumed that Call sends its value to a RETURN node. We
499 ;;; destructively modify the set for the returning function to represent both,
500 ;;; and then change all the functions in callee's set to reference the first.
501 ;;;
502 (defun merge-tail-sets (call ret-set)
503 (declare (type basic-combination call) (type tail-set ret-set))
504 (let ((fun-set (lambda-tail-set (combination-lambda call))))
505 (unless (eq ret-set fun-set)
506 (let ((funs (tail-set-functions fun-set)))
507 (dolist (fun funs)
508 (setf (lambda-tail-set fun) ret-set))
509 (setf (tail-set-functions ret-set)
510 (nconc (tail-set-functions ret-set) funs)))
511 t)))
512
513
514 ;;; IR1-Optimize-Return -- Internal
515 ;;;
516 ;;; Do stuff to realize that something has changed about the value delivered
517 ;;; to a return node. Since we consider the return values of all functions in
518 ;;; the tail set to be equivalent, this amounts to bringing the entire tail set
519 ;;; up to date. We iterate over the returns for all the functions in the tail
520 ;;; set, reanalyzing them all (not treating Node specially.)
521 ;;;
522 ;;; During this iteration, we may discover new functions that should be
523 ;;; added to the tail set. If this happens, we restart the iteration over the
524 ;;; TAIL-SET-FUNCTIONS. Note that this really doesn't duplicate much work, as
525 ;;; we clear the NODE-REOPTIMIZE flags in the return nodes as we go, thus we
526 ;;; don't call FIND-RESULT-TYPE on any given return more than once.
527 ;;;
528 ;;; Restarting the iteration doesn't disturb the computation of the result
529 ;;; type RES, since we will just be adding more types to the union. (or when
530 ;;; we iterate over a return multiple times, unioning in the same type more
531 ;;; than once.)
532 ;;;
533 ;;; When we are done, we check if the new type is different from the old
534 ;;; TAIL-SET-TYPE. If so, we set the type and also reoptimize all the
535 ;;; continuations for references to functions in the tail set. This will
536 ;;; cause IR1-OPTIMIZE-COMBINATION to derive the new type as the results of the
537 ;;; calls.
538 ;;;
539 (defun ir1-optimize-return (node)
540 (declare (type creturn node))
541 (let ((tails (lambda-tail-set (return-lambda node))))
542 (collect ((res *empty-type* values-type-union))
543 (loop
544 (block RETRY
545 (let ((funs (tail-set-functions tails)))
546 (dolist (fun funs)
547 (let ((return (lambda-return fun)))
548 (when return
549 (when (node-reoptimize return)
550 (setf (node-reoptimize node) nil)
551 (when (find-result-type return tails) (return-from RETRY)))
552 (res (return-result-type return))))))
553 (return)))
554
555 (when (type/= (res) (tail-set-type tails))
556 (setf (tail-set-type tails) (res))
557 (dolist (fun (tail-set-functions tails))
558 (dolist (ref (leaf-refs fun))
559 (reoptimize-continuation (node-cont ref)))))))
560
561 (undefined-value))
562
563
564 ;;; IR1-Optimize-If -- Internal
565 ;;;
566 ;;; If the test has multiple uses, replicate the node when possible. Also
567 ;;; check if the predicate is known to be true or false, deleting the IF node
568 ;;; in favor of the appropriate branch when this is the case.
569 ;;;
570 (defun ir1-optimize-if (node)
571 (declare (type cif node))
572 (let ((test (if-test node))
573 (block (node-block node)))
574
575 (when (and (eq (block-start block) test)
576 (eq (continuation-next test) node)
577 (rest (block-start-uses block)))
578 (do-uses (use test)
579 (when (immediately-used-p test use)
580 (convert-if-if use node)
581 (when (continuation-use test) (return)))))
582
583 (let* ((type (continuation-type test))
584 (victim
585 (cond ((constant-continuation-p test)
586 (if (continuation-value test)
587 (if-alternative node)
588 (if-consequent node)))
589 ((not (types-intersect type *null-type*))
590 (if-alternative node))
591 ((type= type *null-type*)
592 (if-consequent node)))))
593 (when victim
594 (flush-dest test)
595 (when (rest (block-succ block))
596 (unlink-blocks block victim))
597 (setf (component-reanalyze (block-component (node-block node))) t)
598 (unlink-node node))))
599 (undefined-value))
600
601
602 ;;; Convert-If-If -- Internal
603 ;;;
604 ;;; Create a new copy of an IF Node that tests the value of the node Use.
605 ;;; The test must have >1 use, and must be immediately used by Use. Node must
606 ;;; be the only node in its block (implying that block-start = if-test).
607 ;;;
608 ;;; This optimization has an effect semantically similar to the
609 ;;; source-to-source transformation:
610 ;;; (IF (IF A B C) D E) ==>
611 ;;; (IF A (IF B D E) (IF C D E))
612 ;;;
613 (defun convert-if-if (use node)
614 (declare (type node use) (type cif node))
615 (with-ir1-environment node
616 (let* ((block (node-block node))
617 (test (if-test node))
618 (cblock (if-consequent node))
619 (ablock (if-alternative node))
620 (use-block (node-block use))
621 (dummy-cont (make-continuation))
622 (new-cont (make-continuation))
623 (new-node (make-if :test new-cont
624 :consequent cblock :alternative ablock))
625 (new-block (continuation-starts-block new-cont)))
626 (prev-link new-node new-cont)
627 (setf (continuation-dest new-cont) new-node)
628 (add-continuation-use new-node dummy-cont)
629 (setf (block-last new-block) new-node)
630
631 (unlink-blocks use-block block)
632 (delete-continuation-use use)
633 (add-continuation-use use new-cont)
634 (link-blocks use-block new-block)
635
636 (link-blocks new-block cblock)
637 (link-blocks new-block ablock)
638
639 (reoptimize-continuation test)
640 (reoptimize-continuation new-cont)
641 (setf (component-reanalyze *current-component*) t)))
642 (undefined-value))
643
644
645 ;;;; Exit IR1 optimization:
646
647 ;;; Maybe-Delete-Exit -- Interface
648 ;;;
649 ;;; This function attempts to delete an exit node, returning true if it
650 ;;; deletes the block as a consequence:
651 ;;; -- If the exit is degenerate (has no Entry), then we don't do anything,
652 ;;; since there is nothing to be done.
653 ;;; -- If the exit node and its Entry have the same home lambda then we know
654 ;;; the exit is local, and can delete the exit. We change uses of the
655 ;;; Exit-Value to be uses of the original continuation, then unlink the
656 ;;; node.
657 ;;; -- If there is no value (as in a GO), then we skip the value semantics.
658 ;;;
659 ;;; This function is also called by environment analysis, since it wants all
660 ;;; exits to be optimized even if normal optimization was omitted.
661 ;;;
662 (defun maybe-delete-exit (node)
663 (declare (type exit node))
664 (let ((value (exit-value node))
665 (entry (exit-entry node))
666 (cont (node-cont node)))
667 (when (and entry
668 (eq (node-home-lambda node) (node-home-lambda entry)))
669 (setf (entry-exits entry) (delete node (entry-exits entry)))
670 (prog1
671 (unlink-node node)
672 (when value
673 (substitute-continuation-uses cont value))))))
674
675
676 ;;;; Combination IR1 optimization:
677
678 ;;; Ir1-Optimize-Combination -- Internal
679 ;;;
680 ;;; Do IR1 optimizations on a Combination node.
681 ;;;
682 (proclaim '(function ir1-optimize-combination (combination) void))
683 (defun ir1-optimize-combination (node)
684 (let ((args (basic-combination-args node))
685 (kind (basic-combination-kind node)))
686 (case kind
687 (:local
688 (let ((fun (combination-lambda node)))
689 (if (eq (functional-kind fun) :let)
690 (propagate-let-args node fun)
691 (propagate-local-call-args node fun))))
692 (:full
693 (dolist (arg args)
694 (when arg
695 (setf (continuation-reoptimize arg) nil))))
696 (t
697 (dolist (arg args)
698 (when arg
699 (setf (continuation-reoptimize arg) nil)))
700
701 (let ((attr (function-info-attributes kind)))
702 (when (and (ir1-attributep attr foldable)
703 (not (ir1-attributep attr call))
704 (every #'constant-continuation-p args)
705 (continuation-dest (node-cont node)))
706 (constant-fold-call node)
707 (return-from ir1-optimize-combination)))
708
709 (let ((fun (function-info-derive-type kind)))
710 (when fun
711 (let ((res (funcall fun node)))
712 (when res
713 (derive-node-type node res)))))
714
715 (let ((fun (function-info-optimizer kind)))
716 (unless (and fun (funcall fun node))
717 (dolist (x (function-info-transforms kind))
718 (unless (ir1-transform node x)
719 (return))))))))
720
721 (undefined-value))
722
723
724 ;;; MAYBE-TERMINATE-BLOCK -- Interface
725 ;;;
726 ;;; If Call is to a function that doesn't return (type NIL), then terminate
727 ;;; the block there, and link it to the component tail. We also change the
728 ;;; call's CONT to be a dummy continuation to prevent the use from confusing
729 ;;; things.
730 ;;;
731 ;;; Except when called during IR1, we delete the continuation if it has no
732 ;;; other uses. (If it does have other uses, we reoptimize.)
733 ;;;
734 ;;; Termination on the basis of a continuation type assertion is inhibited
735 ;;; when:
736 ;;; -- The continuation is deleted (hence the assertion is spurious), or
737 ;;; -- We are in IR1 conversion (where THE assertions are subject to
738 ;;; weakening.)
739 ;;;
740 (defun maybe-terminate-block (call ir1-p)
741 (declare (type basic-combination call))
742 (let* ((block (node-block call))
743 (cont (node-cont call))
744 (tail (component-tail (block-component block)))
745 (succ (first (block-succ block))))
746 (unless (or (and (eq call (block-last block)) (eq succ tail))
747 (block-delete-p block))
748 (when (or (and (eq (continuation-asserted-type cont) *empty-type*)
749 (not (or ir1-p (eq (continuation-kind cont) :deleted))))
750 (eq (node-derived-type call) *empty-type*))
751 (cond (ir1-p
752 (delete-continuation-use call)
753 (cond
754 ((block-last block)
755 (assert (and (eq (block-last block) call)
756 (eq (continuation-kind cont) :block-start))))
757 (t
758 (setf (block-last block) call)
759 (link-blocks block (continuation-starts-block cont)))))
760 (t
761 (node-ends-block call)
762 (delete-continuation-use call)
763 (if (eq (continuation-kind cont) :unused)
764 (delete-continuation cont)
765 (reoptimize-continuation cont))))
766
767 (unlink-blocks block (first (block-succ block)))
768 (assert (not (block-succ block)))
769 (link-blocks block tail)
770 (add-continuation-use call (make-continuation))
771 t))))
772
773
774 ;;; Recognize-Known-Call -- Interface
775 ;;;
776 ;;; If Call is a call to a known function, mark it as such by setting the
777 ;;; Kind. In addition to a direct check for the function name in the table, we
778 ;;; also must check for slot accessors. If the function is a slot accessor,
779 ;;; then we set the combination kind to the function info of %Slot-Setter or
780 ;;; %Slot-Accessor, as appropriate.
781 ;;;
782 ;;; If convert-again is true, and the function has a source-transform or
783 ;;; inline-expansion, or if the function is conditional, and the destination of
784 ;;; the value is not an IF, then instead of making the existing call known, we
785 ;;; change it to be a call to a lambda that just re-calls the function. This
786 ;;; gives IR1 transformation another go at the call, in the case where the call
787 ;;; wasn't obviously known during the initial IR1 conversion.
788 ;;;
789 (defun recognize-known-call (call &optional convert-again)
790 (declare (type combination call))
791 (let* ((fun (basic-combination-fun call))
792 (name (continuation-function-name fun)))
793 (when name
794 (let ((info (info function info name)))
795 (cond
796 ((and info convert-again
797 (or (info function source-transform name)
798 (info function inline-expansion name)
799 (and (ir1-attributep (function-info-attributes info)
800 predicate)
801 (let ((dest (continuation-dest (node-cont call))))
802 (and dest (not (if-p dest)))))))
803 (let ((dums (loop repeat (length (combination-args call))
804 collect (gensym))))
805 (transform-call call
806 `(lambda ,dums
807 (,name ,@dums)))))
808 (info
809 (setf (basic-combination-kind call) info))
810 ((slot-accessor-p (ref-leaf (continuation-use fun)))
811 (setf (basic-combination-kind call)
812 (info function info
813 (if (consp name)
814 '%slot-setter
815 '%slot-accessor))))))))
816 (undefined-value))
817
818
819 ;;; Propagate-Function-Change -- Internal
820 ;;;
821 ;;; Called by Ir1-Optimize when the function for a call has changed.
822 ;;; If the call is to a functional, then we attempt to convert it to a local
823 ;;; call, otherwise we check the call for legality with respect to the new
824 ;;; type; if it is illegal, we mark the Ref as :Notline and punt.
825 ;;;
826 ;;; If we do have a good type for the call, we propagate type information from
827 ;;; the type to the arg and result continuations. If we discover that the call
828 ;;; is to a known global function, then we mark the combination as known.
829 ;;;
830 (defun propagate-function-change (call)
831 (declare (type combination call))
832 (let* ((fun (combination-fun call))
833 (use (continuation-use fun))
834 (type (continuation-derived-type fun))
835 (*compiler-error-context* call))
836 (setf (continuation-reoptimize fun) nil)
837 (cond ((or (not (ref-p use))
838 (eq (ref-inlinep use) :notinline)))
839 ((functional-p (ref-leaf use))
840 (let ((leaf (ref-leaf use)))
841 (cond ((eq (combination-kind call) :local)
842 (unless (member (functional-kind leaf)
843 '(:let :assignment))
844 (derive-node-type
845 call (tail-set-type (lambda-tail-set leaf)))))
846 ((not (eq (ref-inlinep use) :notinline))
847 (convert-call-if-possible use call)
848 (maybe-let-convert leaf)))))
849 ((not (function-type-p type)))
850 ((valid-function-use call type
851 :argument-test #'always-subtypep
852 :result-test #'always-subtypep
853 :error-function #'compiler-warning
854 :warning-function #'compiler-note)
855 (assert-call-type call type)
856 (recognize-known-call call t))
857 (t
858 (setf (ref-inlinep use) :notinline))))
859
860 (undefined-value))
861
862
863 ;;;; Known function optimization:
864
865 ;;;
866 ;;; A hashtable from combination nodes to things describing how an
867 ;;; optimization of the node failed. The value is an alist (Transform . Args),
868 ;;; where Transform is the structure describing the transform that failed, and
869 ;;; Args is either a list of format arguments for the note, or the
870 ;;; FUNCTION-TYPE that would have enabled the transformation but failed to
871 ;;; match.
872 ;;;
873 (defvar *failed-optimizations* (make-hash-table :test #'eq))
874
875
876 ;;; RECORD-OPTIMIZATION-FAILURE -- Internal
877 ;;;
878 ;;; Add a failed optimization note to *FAILED-OPTIMZATIONS* for Node, Fun
879 ;;; and Args. If there is already a note for Node and Transform, replace it,
880 ;;; otherwise add a new one.
881 ;;;
882 (defun record-optimization-failure (node transform args)
883 (declare (type combination node) (type transform transform)
884 (type (or function-type list) args))
885 (let ((found (assoc transform (gethash node *failed-optimizations*))))
886 (if found
887 (setf (cdr found) args)
888 (push (cons transform args)
889 (gethash node *failed-optimizations*))))
890 (undefined-value))
891
892
893 ;;; IR1-Transform -- Internal
894 ;;;
895 ;;; Attempt to transform Node using Function, subject to the call type
896 ;;; constraint Type. If we are inhibited from doing the transform for some
897 ;;; reason and Flame is true, then we make a note of the message in
898 ;;; *failed-optimizations* for IR1 finalize to pick up. We return true if
899 ;;; the transform failed, and thus further transformation should be
900 ;;; attempted. We return false if either the transform suceeded or was
901 ;;; aborted.
902 ;;;
903 (defun ir1-transform (node transform)
904 (declare (type combination node) (type transform transform))
905 (let* ((type (transform-type transform))
906 (fun (transform-function transform))
907 (constrained (function-type-p type))
908 (flame (policy node (> speed brevity)))
909 (*compiler-error-context* node))
910 (cond ((or (not constrained)
911 (valid-function-use node type :strict-result t))
912 (multiple-value-bind
913 (severity args)
914 (catch 'give-up
915 (transform-call node (funcall fun node))
916 (values :none nil))
917 (ecase severity
918 (:none
919 (remhash node *failed-optimizations*)
920 nil)
921 (:aborted
922 (setf (combination-kind node) :full)
923 (setf (ref-inlinep (continuation-use (combination-fun node)))
924 :notinline)
925 (when args
926 (apply #'compiler-warning args))
927 (remhash node *failed-optimizations*)
928 nil)
929 (:failure
930 (if args
931 (when flame
932 (record-optimization-failure node transform args))
933 (setf (gethash node *failed-optimizations*)
934 (remove transform
935 (gethash node *failed-optimizations*)
936 :key #'car)))
937 t))))
938 ((and flame
939 (valid-function-use node type
940 :argument-test #'types-intersect
941 :result-test #'values-types-intersect))
942 (record-optimization-failure node transform type)
943 t)
944 (t
945 t))))
946
947
948 ;;; GIVE-UP, ABORT-TRANSFORM -- Interface
949 ;;;
950 ;;; Just throw the severity and args...
951 ;;;
952 (proclaim '(function give-up (&rest t) nil))
953 (defun give-up (&rest args)
954 "This function is used to throw out of an IR1 transform, aborting this
955 attempt to transform the call, but admitting the possibility that this or
956 some other transform will later suceed. If arguments are supplied, they are
957 format arguments for an efficiency note."
958 (throw 'give-up (values :failure args)))
959 ;;;
960 (defun abort-transform (&rest args)
961 "This function is used to throw out of an IR1 transform and force a normal
962 call to the function at run time. No further optimizations will be
963 attempted."
964 (throw 'give-up (values :aborted args)))
965
966
967 ;;; Transform-Call -- Internal
968 ;;;
969 ;;; Take the lambda-expression Res, IR1 convert it in the proper
970 ;;; environment, and then install it as the function for the call Node. We do
971 ;;; local call analysis so that the new function is integrated into the control
972 ;;; flow. We set the Reanalyze flag in the component to cause the DFO to be
973 ;;; recomputed at soonest convenience.
974 ;;;
975 (defun transform-call (node res)
976 (declare (type combination node) (list res))
977 (with-ir1-environment node
978 (let ((new-fun (ir1-convert-global-lambda res))
979 (ref (continuation-use (combination-fun node))))
980 (change-ref-leaf ref new-fun)
981 (setf (combination-kind node) :full)
982 (local-call-analyze *current-component*)))
983 (undefined-value))
984
985
986 ;;; Constant-Fold-Call -- Internal
987 ;;;
988 ;;; Replace a call to a foldable function of constant arguments with the
989 ;;; result of evaluating the form. We insert the resulting constant node after
990 ;;; the call, stealing the call's continuation. We give the call a
991 ;;; continuation with no Dest, which should cause it and its arguments to go
992 ;;; away. If there is an error during the evaluation, we give a warning and
993 ;;; leave the call alone, making the call a full call and marking it as
994 ;;; :notinline to make sure that it stays that way.
995 ;;;
996 ;;; For now, if the result is other than one value, we don't fold it.
997 ;;;
998 (defun constant-fold-call (call)
999 (declare (type combination call))
1000 (let* ((args (mapcar #'continuation-value (combination-args call)))
1001 (ref (continuation-use (combination-fun call)))
1002 (fun (leaf-name (ref-leaf ref))))
1003
1004 (multiple-value-bind (values win)
1005 (careful-call fun args call "constant folding")
1006 (cond
1007 ((not win)
1008 (setf (ref-inlinep ref) :notinline)
1009 (setf (combination-kind call) :full))
1010 ((= (length values) 1)
1011 (with-ir1-environment call
1012 (when (producing-fasl-file)
1013 (maybe-emit-make-load-forms (first values)))
1014 (let* ((leaf (find-constant (first values)))
1015 (node (make-ref (leaf-type leaf)
1016 leaf
1017 nil))
1018 (dummy (make-continuation))
1019 (cont (node-cont call))
1020 (block (node-block call))
1021 (next (continuation-next cont)))
1022 (push node (leaf-refs leaf))
1023 (setf (leaf-ever-used leaf) t)
1024
1025 (delete-continuation-use call)
1026 (add-continuation-use call dummy)
1027 (prev-link node dummy)
1028 (add-continuation-use node cont)
1029 (setf (continuation-next cont) next)
1030 (when (eq call (block-last block))
1031 (setf (block-last block) node))
1032 (reoptimize-continuation cont))))
1033 (t
1034 (let ((dummies (loop repeat (length args)
1035 collect (gensym))))
1036 (transform-call
1037 call
1038 `(lambda ,dummies
1039 (declare (ignore ,@dummies))
1040 (values ,@(mapcar #'(lambda (x) `',x) values)))))))))
1041
1042 (undefined-value))
1043
1044
1045 ;;;; Local call optimization:
1046
1047 ;;; Propagate-To-Refs -- Internal
1048 ;;;
1049 ;;; Propagate Type to Leaf and its Refs, marking things changed. If the
1050 ;;; leaf type is a function type, then just leave it alone, since TYPE is never
1051 ;;; going to be more specific than that (and TYPE-INTERSECTION would choke.)
1052 ;;;
1053 (defun propagate-to-refs (leaf type)
1054 (declare (type leaf leaf) (type ctype type))
1055 (let ((var-type (leaf-type leaf)))
1056 (unless (function-type-p var-type)
1057 (let ((int (type-intersection var-type type)))
1058 (when (type/= int var-type)
1059 (setf (leaf-type leaf) int)
1060 (dolist (ref (leaf-refs leaf))
1061 (derive-node-type ref int))))
1062 (undefined-value))))
1063
1064
1065 ;;; PROPAGATE-FROM-SETS -- Internal
1066 ;;;
1067 ;;; Figure out the type of a LET variable that has sets. We compute the
1068 ;;; union of the initial value Type and the types of all the set values and to
1069 ;;; a PROPAGATE-TO-REFS with this type.
1070 ;;;
1071 (defun propagate-from-sets (var type)
1072 (collect ((res type type-union))
1073 (dolist (set (basic-var-sets var))
1074 (res (continuation-type (set-value set)))
1075 (setf (node-reoptimize set) nil))
1076 (propagate-to-refs var (res)))
1077 (undefined-value))
1078
1079
1080 ;;; IR1-OPTIMIZE-SET -- Internal
1081 ;;;
1082 ;;; If a let variable, find the initial value's type and do
1083 ;;; PROPAGATE-FROM-SETS. We also derive the VALUE's type as the node's type.
1084 ;;;
1085 (defun ir1-optimize-set (node)
1086 (declare (type cset node))
1087 (let ((var (set-var node)))
1088 (when (and (lambda-var-p var) (leaf-refs var))
1089 (let ((home (lambda-var-home var)))
1090 (when (eq (functional-kind home) :let)
1091 (let ((iv (let-var-initial-value var)))
1092 (setf (continuation-reoptimize iv) nil)
1093 (propagate-from-sets var (continuation-type iv)))))))
1094
1095 (derive-node-type node (continuation-type (set-value node)))
1096 (undefined-value))
1097
1098
1099 ;;; CONSTANT-REFERENCE-P -- Interface
1100 ;;;
1101 ;;; Return true if the value of Ref will always be the same (and is thus
1102 ;;; legal to substitute.)
1103 ;;;
1104 (defun constant-reference-p (ref)
1105 (declare (type ref ref))
1106 (let ((leaf (ref-leaf ref)))
1107 (typecase leaf
1108 (constant t)
1109 (functional t)
1110 (lambda-var
1111 (null (lambda-var-sets leaf)))
1112 (global-var
1113 (case (global-var-kind leaf)
1114 (:global-function
1115 (not (eq (ref-inlinep ref) :notinline)))
1116 (:constant t))))))
1117
1118
1119 ;;; SUBSTITUTE-SINGLE-USE-CONTINUATION -- Internal
1120 ;;;
1121 ;;; If we have a non-set let var with a single use, then (if possible)
1122 ;;; replace the variable reference's CONT with the arg continuation. This is
1123 ;;; inhibited when:
1124 ;;; -- CONT has other uses, or
1125 ;;; -- CONT receives multiple values, or
1126 ;;; -- the reference is in a different environment from the variable, or
1127 ;;; -- either continuation has a funky TYPE-CHECK annotation.
1128 ;;; -- the var's DEST has a different policy than the ARG's (think safety).
1129 ;;;
1130 ;;; We change the Ref to be a reference to NIL with unused value, and let it
1131 ;;; be flushed as dead code. A side-effect of this substitution is to delete
1132 ;;; the variable.
1133 ;;;
1134 (defun substitute-single-use-continuation (arg var)
1135 (declare (type continuation arg) (type lambda-var var))
1136 (let* ((ref (first (leaf-refs var)))
1137 (cont (node-cont ref))
1138 (dest (continuation-dest cont)))
1139 (when (and (eq (continuation-use cont) ref)
1140 dest
1141 (not (typep dest '(or creturn exit mv-combination)))
1142 (eq (node-home-lambda ref)
1143 (lambda-home (lambda-var-home var)))
1144 (member (continuation-type-check arg) '(t nil))
1145 (member (continuation-type-check cont) '(t nil))
1146 (eq (lexenv-cookie (node-lexenv dest))
1147 (lexenv-cookie (node-lexenv (continuation-dest arg)))))
1148 (assert (member (continuation-kind arg)
1149 '(:block-start :deleted-block-start :inside-block)))
1150 (assert-continuation-type arg (continuation-asserted-type cont))
1151 (setf (node-derived-type ref) *wild-type*)
1152 (change-ref-leaf ref (find-constant nil))
1153 (substitute-continuation arg cont)
1154 (reoptimize-continuation arg)
1155 t)))
1156
1157
1158 ;;; DELETE-LET -- Interface
1159 ;;;
1160 ;;; Delete a Let, removing the call and bind nodes, and warning about any
1161 ;;; unreferenced variables. Note that FLUSH-DEAD-CODE will come along right
1162 ;;; away and delete the REF and then the lambda, since we flush the FUN
1163 ;;; continuation.
1164 ;;;
1165 (defun delete-let (fun)
1166 (declare (type clambda fun))
1167 (assert (eq (functional-kind fun) :let))
1168 (note-unreferenced-vars fun)
1169 (let ((call (let-combination fun)))
1170 (flush-dest (combination-fun call))
1171 (unlink-node call)
1172 (unlink-node (lambda-bind fun))
1173 (setf (lambda-bind fun) nil))
1174 (undefined-value))
1175
1176
1177 ;;; Propagate-Let-Args -- Internal
1178 ;;;
1179 ;;; This function is called when one of the arguments to a LET changes. We
1180 ;;; look at each changed argument. If the corresponding variable is set, then
1181 ;;; we call PROPAGATE-FROM-SETS. Otherwise, we consider substituting for the
1182 ;;; variable, and also propagate derived-type information for the arg to all
1183 ;;; the Var's refs.
1184 ;;;
1185 ;;; Substitution is inhibited when the arg leaf's derived type isn't a
1186 ;;; subtype of the argument's asserted type. This prevents type checking from
1187 ;;; being defeated, and also ensures that the best representation for the
1188 ;;; variable can be used.
1189 ;;;
1190 ;;; Substitution of individual references is inhibited if the reference is
1191 ;;; in a different component from the home. This can only happen with closures
1192 ;;; over top-level lambda vars. In such cases, the references may have already
1193 ;;; been compiled, and thus can't be retroactively modified.
1194 ;;;
1195 ;;; If all of the variables are deleted (have no references) when we are
1196 ;;; done, then we delete the let.
1197 ;;;
1198 ;;; Note that we are responsible for clearing the Continuation-Reoptimize
1199 ;;; flags.
1200 ;;;
1201 (defun propagate-let-args (call fun)
1202 (declare (type combination call) (type clambda fun))
1203 (loop for arg in (combination-args call)
1204 and var in (lambda-vars fun) do
1205 (when (and arg (continuation-reoptimize arg))
1206 (setf (continuation-reoptimize arg) nil)
1207 (cond
1208 ((lambda-var-sets var)
1209 (propagate-from-sets var (continuation-type arg)))
1210 ((let ((use (continuation-use arg)))
1211 (when (ref-p use)
1212 (let ((leaf (ref-leaf use)))
1213 (when (and (constant-reference-p use)
1214 (values-subtypep (leaf-type leaf)
1215 (continuation-asserted-type arg)))
1216 (propagate-to-refs var (continuation-type arg))
1217 (let ((this-comp (block-component (node-block use))))
1218 (substitute-leaf-if
1219 #'(lambda (ref)
1220 (cond ((eq (block-component (node-block ref))
1221 this-comp)
1222 t)
1223 (t
1224 (assert (eq (functional-kind (lambda-home fun))
1225 :top-level))
1226 nil)))
1227 leaf var))
1228 t)))))
1229 ((and (null (rest (leaf-refs var)))
1230 (substitute-single-use-continuation arg var)))
1231 (t
1232 (propagate-to-refs var (continuation-type arg))))))
1233
1234 (when (every #'null (combination-args call))
1235 (delete-let fun))
1236
1237 (undefined-value))
1238
1239
1240 ;;; Propagate-Local-Call-Args -- Internal
1241 ;;;
1242 ;;; This function is called when one of the args to a non-let local call
1243 ;;; changes. For each changed argument corresponding to an unset variable, we
1244 ;;; compute the union of the types across all calls and propagate this type
1245 ;;; information to the var's refs.
1246 ;;;
1247 ;;; If the function has an XEP, then we don't do anything, since we won't
1248 ;;; discover anything.
1249 ;;;
1250 ;;; We can clear the Continuation-Reoptimize flags for arguments in all calls
1251 ;;; corresponding to changed arguments in Call, since the only use in IR1
1252 ;;; optimization of the Reoptimize flag for local call args is right here.
1253 ;;;
1254 (defun propagate-local-call-args (call fun)
1255 (declare (type combination call) (type clambda fun))
1256
1257 (unless (functional-entry-function fun)
1258 (let* ((vars (lambda-vars fun))
1259 (union (mapcar #'(lambda (arg var)
1260 (when (and arg
1261 (continuation-reoptimize arg)
1262 (null (basic-var-sets var)))
1263 (continuation-type arg)))
1264 (basic-combination-args call)
1265 vars))
1266 (this-ref (continuation-use (basic-combination-fun call))))
1267
1268 (dolist (arg (basic-combination-args call))
1269 (when arg
1270 (setf (continuation-reoptimize arg) nil)))
1271
1272 (dolist (ref (leaf-refs fun))
1273 (unless (eq ref this-ref)
1274 (setq union
1275 (mapcar #'(lambda (this-arg old)
1276 (when old
1277 (setf (continuation-reoptimize this-arg) nil)
1278 (type-union (continuation-type this-arg) old)))
1279 (basic-combination-args
1280 (continuation-dest (node-cont ref)))
1281 union))))
1282
1283 (mapc #'(lambda (var type)
1284 (when type
1285 (propagate-to-refs var type)))
1286 vars union)))
1287
1288 (undefined-value))
1289
1290
1291 ;;;; Multiple values optimization:
1292
1293 ;;; IR1-OPTIMIZE-MV-COMBINATION -- Internal
1294 ;;;
1295 ;;; Do stuff to notice a change to a MV combination node. There are two
1296 ;;; main branches here:
1297 ;;; -- If the call is local, then it is already a MV let, or should become one.
1298 ;;; Note that although all :LOCAL MV calls must eventually be converted to
1299 ;;; :MV-LETs, there can be a window when the call is local, but has not
1300 ;;; been let converted yet. This is because the entry-point lambdas may
1301 ;;; have stray references (in other entry points) that have not been
1302 ;;; deleted yet.
1303 ;;; -- The call is full. This case is somewhat similar to the non-MV
1304 ;;; combination optimization: we propagate return type information and
1305 ;;; notice non-returning calls. We also have an optimization
1306 ;;; which tries to convert MV-CALLs into MV-binds.
1307 ;;;
1308 (defun ir1-optimize-mv-combination (node)
1309 (cond
1310 ((eq (basic-combination-kind node) :local)
1311 (let ((fun (basic-combination-fun node)))
1312 (when (continuation-reoptimize fun)
1313 (setf (continuation-reoptimize fun) nil)
1314 (maybe-let-convert (combination-lambda node))))
1315 (setf (continuation-reoptimize (first (basic-combination-args node))) nil)
1316 (when (eq (functional-kind (combination-lambda node)) :mv-let)
1317 (unless (convert-mv-bind-to-let node)
1318 (ir1-optimize-mv-bind node))))
1319 (t
1320 (let* ((fun (basic-combination-fun node))
1321 (fun-changed (continuation-reoptimize fun))
1322 (args (basic-combination-args node)))
1323 (when fun-changed
1324 (setf (continuation-reoptimize fun) nil)
1325 (let ((type (continuation-type fun)))
1326 (when (function-type-p type)
1327 (derive-node-type node (function-type-returns type))))
1328 (maybe-terminate-block node nil)
1329 (let ((use (continuation-use fun)))
1330 (when (and (ref-p use) (functional-p (ref-leaf use))
1331 (not (eq (ref-inlinep use) :notinline)))
1332 (convert-call-if-possible use node)
1333 (maybe-let-convert (ref-leaf use)))))
1334 (unless (or (eq (basic-combination-kind node) :local)
1335 (eq (continuation-function-name fun) '%throw))
1336 (ir1-optimize-mv-call node))
1337 (dolist (arg args)
1338 (setf (continuation-reoptimize arg) nil)))))
1339 (undefined-value))
1340
1341
1342 ;;; IR1-OPTIMIZE-MV-BIND -- Internal
1343 ;;;
1344 ;;; Propagate derived type info from the values continuation to the vars.
1345 ;;;
1346 (defun ir1-optimize-mv-bind (node)
1347 (declare (type mv-combination node))
1348 (let ((arg (first (basic-combination-args node)))
1349 (vars (lambda-vars (combination-lambda node))))
1350 (multiple-value-bind (types nvals)
1351 (values-types (continuation-derived-type arg))
1352 (unless (eq nvals :unknown)
1353 (mapc #'(lambda (var type)
1354 (if (basic-var-sets var)
1355 (propagate-from-sets var type)
1356 (propagate-to-refs var type)))
1357 vars
1358 (append types
1359 (make-list (max (- (length vars) nvals) 0)
1360 :initial-element *null-type*)))))
1361
1362 (setf (continuation-reoptimize arg) nil))
1363 (undefined-value))
1364
1365
1366 ;;; IR1-OPTIMIZE-MV-CALL -- Internal
1367 ;;;
1368 ;;; If possible, convert a general MV call to an MV-BIND. We can do this
1369 ;;; if:
1370 ;;; -- The call has only one argument, and
1371 ;;; -- The function has a known fixed number of arguments, or
1372 ;;; -- The argument yields a known fixed number of values.
1373 ;;;
1374 ;;; What we do is change the function in the MV-CALL to be a lambda that "looks
1375 ;;; like an MV bind", which allows IR1-OPTIMIZE-MV-COMBINATION to notice that
1376 ;;; this call can be converted (the next time around.) This new lambda just
1377 ;;; calls the actual function with the MV-BIND variables as arguments. Note
1378 ;;; that this new MV bind is not let-converted immediately, as there are going
1379 ;;; to be stray references from the entry-point functions until they get
1380 ;;; deleted.
1381 ;;;
1382 ;;; In order to avoid loss of argument count checking, we only do the
1383 ;;; transformation according to a known number of expected argument if safety
1384 ;;; is unimportant. We can always convert if we know the number of actual
1385 ;;; values, since the normal call that we build will still do any appropriate
1386 ;;; argument count checking.
1387 ;;;
1388 ;;; We only attempt the transformation if the called function is a constant
1389 ;;; reference. This allows us to just splice the leaf into the new function,
1390 ;;; instead of trying to somehow bind the function expression. The leaf must
1391 ;;; be constant because we are evaluating it again in a different place. This
1392 ;;; also has the effect of squelching multiple warnings when there is an
1393 ;;; argument count error.
1394 ;;;
1395 (defun ir1-optimize-mv-call (node)
1396 (let ((fun (basic-combination-fun node))
1397 (*compiler-error-context* node)
1398 (ref (continuation-use (basic-combination-fun node)))
1399 (args (basic-combination-args node)))
1400
1401 (unless (and (ref-p ref) (constant-reference-p ref)
1402 args (null (rest args)))
1403 (return-from ir1-optimize-mv-call))
1404
1405 (multiple-value-bind (min max)
1406 (function-type-nargs (continuation-type fun))
1407 (let ((total-nvals
1408 (multiple-value-bind
1409 (types nvals)
1410 (values-types (continuation-derived-type (first args)))
1411 (declare (ignore types))
1412 (if (eq nvals :unknown) nil nvals))))
1413
1414 (when total-nvals
1415 (when (and min (< total-nvals min))
1416 (compiler-warning
1417 "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
1418 at least ~R."
1419 total-nvals min)
1420 (setf (ref-inlinep ref) :notinline)
1421 (return-from ir1-optimize-mv-call))
1422 (when (and max (> total-nvals max))
1423 (compiler-warning
1424 "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
1425 at most ~R."
1426 total-nvals max)
1427 (setf (ref-inlinep ref) :notinline)
1428 (return-from ir1-optimize-mv-call)))
1429
1430 (let ((count (cond (total-nvals)
1431 ((and (policy node (zerop safety)) (eql min max))
1432 min)
1433 (t nil))))
1434 (when count
1435 (with-ir1-environment node
1436 (let* ((dums (loop repeat count collect (gensym)))
1437 (ignore (gensym))
1438 (fun (ir1-convert-lambda
1439 `(lambda (&optional ,@dums &rest ,ignore)
1440 (declare (ignore ,ignore))
1441 (funcall ,(ref-leaf ref) ,@dums)))))
1442 (change-ref-leaf ref fun)
1443 (assert (eq (basic-combination-kind node) :full))
1444 (local-call-analyze *current-component*)
1445 (assert (eq (basic-combination-kind node) :local)))))))))
1446 (undefined-value))
1447
1448
1449 ;;; CONVERT-MV-BIND-TO-LET -- Internal
1450 ;;;
1451 ;;; If we see:
1452 ;;; (multiple-value-bind (x y)
1453 ;;; (values xx yy)
1454 ;;; ...)
1455 ;;; Convert to:
1456 ;;; (let ((x xx)
1457 ;;; (y yy))
1458 ;;; ...)
1459 ;;;
1460 ;;; What we actually do is convert the VALUES combination into a normal let
1461 ;;; combination calling the original :MV-LET lambda. If there are extra args to
1462 ;;; VALUES, discard the corresponding continuations. If there are insufficient
1463 ;;; args, insert references to NIL.
1464 ;;;
1465 (defun convert-mv-bind-to-let (call)
1466 (declare (type mv-combination call))
1467 (let* ((arg (first (basic-combination-args call)))
1468 (use (continuation-use arg)))
1469 (when (and (combination-p use)
1470 (eq (continuation-function-name (combination-fun use))
1471 'values))
1472 (let* ((fun (combination-lambda call))
1473 (vars (lambda-vars fun))
1474 (vals (combination-args use))
1475 (nvars (length vars))
1476 (nvals (length vals)))
1477 (cond ((> nvals nvars)
1478 (mapc #'flush-dest (subseq vals nvars))
1479 (setq vals (subseq vals 0 nvars)))
1480 ((< nvals nvars)
1481 (with-ir1-environment use
1482 (let ((node-prev (node-prev use)))
1483 (setf (node-prev use) nil)
1484 (setf (continuation-next node-prev) nil)
1485 (collect ((res vals))
1486 (loop as cont = (make-continuation use)
1487 and prev = node-prev then cont
1488 repeat (- nvars nvals)
1489 do (reference-constant prev cont nil)
1490 (res cont))
1491 (setq vals (res)))
1492 (prev-link use (car (last vals)))))))
1493 (setf (combination-args use) vals)
1494 (flush-dest (combination-fun use))
1495 (let ((fun-cont (basic-combination-fun call)))
1496 (setf (continuation-dest fun-cont) use)
1497 (setf (combination-fun use) fun-cont))
1498 (setf (combination-kind use) :local)
1499 (setf (functional-kind fun) :let)
1500 (flush-dest (first (basic-combination-args call)))
1501 (unlink-node call)
1502 (when vals
1503 (reoptimize-continuation (first vals)))
1504 (propagate-to-args use fun))
1505 t)))
1506
1507
1508 ;;; VALUES-LIST IR1 optimizer -- Internal
1509 ;;;
1510 ;;; If we see:
1511 ;;; (values-list (list x y z))
1512 ;;;
1513 ;;; Convert to:
1514 ;;; (values x y z)
1515 ;;;
1516 ;;; In implementation, this is somewhat similar to CONVERT-MV-BIND-TO-LET. We
1517 ;;; grab the args of LIST and make them args of the VALUES-LIST call, flushing
1518 ;;; the old argument continuation (allowing the LIST to be flushed.)
1519 ;;;
1520 (defoptimizer (values-list optimizer) ((list) node)
1521 (let ((use (continuation-use list)))
1522 (when (and (combination-p use)
1523 (eq (continuation-function-name (combination-fun use))
1524 'list))
1525 (change-ref-leaf (continuation-use (combination-fun node))
1526 (find-free-function 'values "in a strange place"))
1527 (setf (combination-kind node) :full)
1528 (let ((args (combination-args use)))
1529 (dolist (arg args)
1530 (setf (continuation-dest arg) node))
1531 (setf (combination-args use) nil)
1532 (flush-dest list)
1533 (setf (combination-args node) args))
1534 t)))
1535
1536
1537 ;;; VALUES IR1 transform -- Internal
1538 ;;;
1539 ;;; If VALUES appears in a non-MV context, then effectively convert it to a
1540 ;;; PROG1. This allows the computation of the additional values to become dead
1541 ;;; code.
1542 ;;;
1543 (deftransform values ((&rest vals) * * :node node)
1544 (when (typep (continuation-dest (node-cont node))
1545 '(or creturn exit mv-combination))
1546 (give-up))
1547 (setf (node-derived-type node) *wild-type*)
1548 (if vals
1549 (let ((dummies (loop repeat (1- (length vals))
1550 collect (gensym))))
1551 `(lambda (val ,@dummies)
1552 (declare (ignore ,@dummies))
1553 val))
1554 'nil))
1555
1556
1557 ;;; Flush-Dead-Code -- Internal
1558 ;;;
1559 ;;; Delete any nodes in Block whose value is unused and have no
1560 ;;; side-effects. We can delete sets of lexical variables when the set
1561 ;;; variable has no references.
1562 ;;;
1563 ;;; [### For now, don't delete potentially flushable calls when they have the
1564 ;;; Call attribute. Someday we should look at the funcitonal args to determine
1565 ;;; if they have any side-effects.]
1566 ;;;
1567 (defun flush-dead-code (block)
1568 (declare (type cblock block))
1569 (do-nodes-backwards (node cont block)
1570 (unless (continuation-dest cont)
1571 (typecase node
1572 (ref
1573 (delete-ref node)
1574 (unlink-node node))
1575 (combination
1576 (let ((info (combination-kind node)))
1577 (when (function-info-p info)
1578 (let ((attr (function-info-attributes info)))
1579 (when (and (ir1-attributep attr flushable)
1580 (not (ir1-attributep attr call)))
1581 (flush-dest (combination-fun node))
1582 (dolist (arg (combination-args node))
1583 (flush-dest arg))
1584 (unlink-node node))))))
1585 (exit
1586 (let ((value (exit-value node)))
1587 (when value
1588 (flush-dest value)
1589 (setf (exit-value node) nil))))
1590 (cset
1591 (let ((var (set-var node)))
1592 (when (and (lambda-var-p var)
1593 (null (leaf-refs var)))
1594 (flush-dest (set-value node))
1595 (setf (basic-var-sets var)
1596 (delete node (basic-var-sets var)))
1597 (unlink-node node)))))))
1598
1599 (setf (block-flush-p block) nil)
1600 (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5