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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5