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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.79 - (hide annotations)
Mon Oct 6 12:39:58 2003 UTC (10 years, 6 months ago) by gerd
Branch: MAIN
Changes since 1.78: +3 -1 lines
	FIXME: Dead code elimination sometimes leaves spurious references
	to unused lambda-vars.  Unused vars are not packed, and so have a
	tn but a null tn-offset.  Some of these cases have been fixed, but
	not all of them, and since it's not sure if/when all of them will
	be fixed, add a hack for these cases.

	* src/compiler/debug-dump.lisp (dump-1-variable): If the
	tn-offset of a tn is null, set the tn to nil.

	(compile nil
          '(lambda (a b)
             (declare (optimize (speed 3) (debug 1)))
             (let ((v7
                    (let ((v2 (block b5 (return-from b5 (if t b -4)))))
                         a)))
                  -65667836)))
	 => error nil is not integer, in dump-1-variable.

	This is caused by an exit from the return-from being deleted,
	while leaving the exit's value untouched, which leads to a
	remaining reference to lambda-var b, which is unused and therefore
	not being packed.

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

  ViewVC Help
Powered by ViewVC 1.1.5