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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5