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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5