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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5