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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5