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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5