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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.81 - (hide annotations)
Mon Oct 13 09:57:10 2003 UTC (10 years, 6 months ago) by gerd
Branch: MAIN
Changes since 1.80: +14 -11 lines
	(compile nil
	    '(lambda (a c)
		(if nil (unwind-protect (max 521739 (unwind-protect c)))
		  (logandc2 3942 a))))
	 => nil is not of type ref

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

  ViewVC Help
Powered by ViewVC 1.1.5