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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Sun Jan 13 13:48:12 1991 UTC (23 years, 3 months ago) by ram
Branch: MAIN
Changes since 1.19: +2 -2 lines
Fixed VALUES IR1 optimizer to do the REOPTIMIZE-CONTINUATION before
PROPAGATE-TO-ARGS so that we know that the first arg won't be deleted
yet.
1 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice 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 Spice Lisp, please contact
7     ;;; Scott Fahlman (FAHLMAN@CMUC).
8     ;;; **********************************************************************
9     ;;;
10     ;;; This file implements the IR1 optimization phase of the compiler. IR1
11     ;;; optimization is a grab-bag of optimizations that don't make major changes
12     ;;; to the block-level control flow and don't use flow analysis. These
13     ;;; optimizations can mostly be classified as "meta-evaluation", but there is a
14     ;;; sizable top-down component as well.
15     ;;;
16     ;;; Written by Rob MacLachlan
17     ;;;
18     (in-package 'c)
19    
20    
21     ;;;; Interface for obtaining results of constant folding:
22    
23     ;;; Constant-Continuation-P -- Interface
24     ;;;
25     ;;; Return true if the sole use of Cont is a reference to a constant leaf.
26     ;;;
27     (proclaim '(function constant-continuation-p (continuation) boolean))
28     (defun constant-continuation-p (cont)
29     (let ((use (continuation-use cont)))
30     (and (ref-p use)
31     (constant-p (ref-leaf use)))))
32    
33    
34     ;;; Continuation-Value -- Interface
35     ;;;
36     ;;; Return the constant value for a continuation whose only use is a
37     ;;; constant node.
38     ;;;
39     (proclaim '(function continuation-value (continuation) t))
40     (defun continuation-value (cont)
41 ram 1.10 (assert (constant-continuation-p cont))
42 wlott 1.1 (constant-value (ref-leaf (continuation-use cont))))
43    
44    
45     ;;;; Interface for obtaining results of type inference:
46    
47     ;;; CONTINUATION-PROVEN-TYPE -- Interface
48     ;;;
49     ;;; Return a (possibly values) type that describes what we have proven about
50     ;;; the type of Cont without taking any type assertions into consideration.
51     ;;; This is just the union of the NODE-DERIVED-TYPE of all the uses. Most
52     ;;; often people use CONTINUATION-DERIVED-TYPE or CONTINUATION-TYPE instead of
53     ;;; using this function directly.
54     ;;;
55     (defun continuation-proven-type (cont)
56     (declare (type continuation cont))
57     (ecase (continuation-kind cont)
58     ((:block-start :deleted-block-start)
59     (let ((uses (block-start-uses (continuation-block cont))))
60     (if uses
61     (do ((res (node-derived-type (first uses))
62     (values-type-union (node-derived-type (first current))
63     res))
64     (current (rest uses) (rest current)))
65     ((null current) res))
66     *empty-type*)))
67     (:inside-block
68     (node-derived-type (continuation-use cont)))))
69    
70    
71     ;;; Continuation-Derived-Type -- Interface
72     ;;;
73     ;;; Our best guess for the type of this continuation's value. Note that
74     ;;; this may be Values or Function type, which cannot be passed as an argument
75     ;;; to the normal type operations. See Continuation-Type. This may be called
76     ;;; on deleted continuations, always returning *.
77     ;;;
78     ;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the result
79     ;;; is a subtype of the assertion. If so, return the proven type and set
80     ;;; TYPE-CHECK to nil. Otherwise, return the intersection of the asserted and
81     ;;; proven types, and set TYPE-CHECK T. If TYPE-CHECK already has a non-null
82     ;;; value, then preserve it. Only in the somewhat unusual circumstance of
83     ;;; a newly discovered assertion will we change TYPE-CHECK from NIL to T.
84     ;;;
85     ;;; The result value is cached in the Continuation-%Derived-Type. If the
86     ;;; slot is true, just return that value, otherwise recompute and stash the
87     ;;; value there.
88     ;;;
89     (proclaim '(inline continuation-derived-type))
90     (defun continuation-derived-type (cont)
91     (declare (type continuation cont))
92     (or (continuation-%derived-type cont)
93     (%continuation-derived-type cont)))
94     ;;;
95     (defun %continuation-derived-type (cont)
96     (declare (type continuation cont))
97     (let ((proven (continuation-proven-type cont))
98     (asserted (continuation-asserted-type cont)))
99     (cond ((values-subtypep proven asserted)
100     (setf (continuation-%type-check cont) nil)
101     (setf (continuation-%derived-type cont) proven))
102     (t
103     (unless (or (continuation-%type-check cont)
104     (not (continuation-dest cont))
105     (eq asserted *universal-type*))
106     (setf (continuation-%type-check cont) t))
107    
108     (setf (continuation-%derived-type cont)
109     (values-type-intersection asserted proven))))))
110    
111    
112     ;;; CONTINUATION-TYPE-CHECK -- Interface
113     ;;;
114     ;;; Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to date, then
115     ;;; return it.
116     ;;;
117     (proclaim '(inline continuation-type-check))
118     (defun continuation-type-check (cont)
119     (declare (type continuation cont))
120     (continuation-derived-type cont)
121     (continuation-%type-check cont))
122    
123    
124     ;;; Continuation-Type -- Interface
125     ;;;
126     ;;; Return the derived type for Cont's first value. This is guaranteed not
127     ;;; to be a Values or Function type.
128     ;;;
129 wlott 1.14 (proclaim '(function continuation-type (continuation) ctype))
130 wlott 1.1 (defun continuation-type (cont)
131     (single-value-type (continuation-derived-type cont)))
132    
133    
134     ;;;; Interface routines used by optimizers:
135    
136     ;;; Reoptimize-Continuation -- Interface
137     ;;;
138     ;;; This function is called by optimizers to indicate that something
139     ;;; interesting has happened to the value of Cont. Optimizers must make sure
140     ;;; that they don't call for reoptimization when nothing has happened, since
141     ;;; optimization will fail to terminate.
142     ;;;
143     ;;; We clear any cached type for the continuation and set the reoptimize
144     ;;; flags on everything in sight, unless the continuation is deleted (in which
145     ;;; case we do nothing.)
146     ;;;
147     ;;; Since this can get called curing IR1 conversion, we have to be careful
148     ;;; not to fly into space when the Dest's Prev is missing.
149     ;;;
150     (defun reoptimize-continuation (cont)
151     (declare (type continuation cont))
152     (unless (eq (continuation-kind cont) :deleted)
153     (setf (continuation-%derived-type cont) nil)
154     (let ((dest (continuation-dest cont)))
155     (when dest
156     (setf (continuation-reoptimize cont) t)
157     (setf (node-reoptimize dest) t)
158     (let ((prev (node-prev dest)))
159     (when prev
160     (let* ((block (continuation-block prev))
161     (component (block-component block)))
162 ram 1.18 (when (typep dest 'cif)
163     (setf (block-test-modified block) t))
164 wlott 1.1 (setf (block-reoptimize block) t)
165     (setf (component-reoptimize component) t))))))
166     (do-uses (node cont)
167     (setf (block-type-check (node-block node)) t)))
168     (undefined-value))
169    
170    
171     ;;; Derive-Node-Type -- Interface
172     ;;;
173     ;;; Annotate Node to indicate that its result has been proven to be typep to
174     ;;; RType. After IR1 conversion has happened, this is the only correct way to
175     ;;; supply information discovered about a node's type. If you fuck with the
176     ;;; Node-Derived-Type directly, then information may be lost and reoptimization
177     ;;; may not happen.
178     ;;;
179     ;;; What we do is intersect Rtype with Node's Derived-Type. If the
180     ;;; intersection is different from the old type, then we do a
181     ;;; Reoptimize-Continuation on the Node-Cont.
182     ;;;
183     (defun derive-node-type (node rtype)
184     (declare (type node node) (type ctype rtype))
185     (let ((node-type (node-derived-type node)))
186     (unless (eq node-type rtype)
187     (let ((int (values-type-intersection node-type rtype)))
188     (when (type/= node-type int)
189     (setf (node-derived-type node) int)
190     (reoptimize-continuation (node-cont node))))))
191     (undefined-value))
192    
193    
194     ;;; Assert-Continuation-Type -- Interface
195     ;;;
196     ;;; Similar to Derive-Node-Type, but asserts that it is an error for Cont's
197     ;;; value not to be typep to Type. If we improve the assertion, we set
198 ram 1.11 ;;; TYPE-CHECK and TYPE-ASSERTED to guarantee that the new assertion will be
199     ;;; checked.
200 wlott 1.1 ;;;
201     (defun assert-continuation-type (cont type)
202     (declare (type continuation cont) (type ctype type))
203     (let ((cont-type (continuation-asserted-type cont)))
204     (unless (eq cont-type type)
205     (let ((int (values-type-intersection cont-type type)))
206     (when (type/= cont-type int)
207     (setf (continuation-asserted-type cont) int)
208     (do-uses (node cont)
209 ram 1.11 (setf (block-attributep (block-flags (node-block node))
210     type-check type-asserted)
211     t))
212 wlott 1.1 (reoptimize-continuation cont)))))
213     (undefined-value))
214    
215    
216     ;;; Assert-Call-Type -- Interface
217     ;;;
218     ;;; Assert that Call is to a function of the specified Type. It is assumed
219     ;;; that the call is legal and has only constants in the keyword positions.
220     ;;;
221     (defun assert-call-type (call type)
222     (declare (type combination call) (type function-type type))
223     (derive-node-type call (function-type-returns type))
224     (let ((args (combination-args call)))
225     (dolist (req (function-type-required type))
226     (when (null args) (return-from assert-call-type))
227     (let ((arg (pop args)))
228     (assert-continuation-type arg req)))
229     (dolist (opt (function-type-optional type))
230     (when (null args) (return-from assert-call-type))
231     (let ((arg (pop args)))
232     (assert-continuation-type arg opt)))
233    
234     (let ((rest (function-type-rest type)))
235     (when rest
236     (dolist (arg args)
237     (assert-continuation-type arg rest))))
238    
239     (dolist (key (function-type-keywords type))
240     (let ((name (key-info-name key)))
241     (do ((arg args (cddr arg)))
242     ((null arg))
243     (when (eq (continuation-value (first arg)) name)
244     (assert-continuation-type
245     (second arg) (key-info-type key)))))))
246     (undefined-value))
247    
248    
249     ;;; IR1-Optimize -- Interface
250     ;;;
251     ;;; Do one forward pass over Component, deleting unreachable blocks and
252 ram 1.11 ;;; doing IR1 optimizations. We can ignore all blocks that don't have the
253     ;;; Reoptimize flag set. If Component-Reoptimize is true when we are done,
254 wlott 1.1 ;;; then another iteration would be beneficial.
255     ;;;
256     ;;; We delete blocks when there is either no predecessor or the block is in
257     ;;; a lambda that has been deleted. These blocks would eventually be deleted
258     ;;; by DFO recomputation, but doing it here immediately makes the effect
259     ;;; avaliable to IR1 optimization.
260     ;;;
261     (defun ir1-optimize (component)
262     (declare (type component component))
263     (setf (component-reoptimize component) nil)
264     (do-blocks (block component)
265     (cond
266     ((or (block-delete-p block)
267     (null (block-pred block))
268 ram 1.11 (eq (functional-kind (block-home-lambda block)) :deleted))
269 wlott 1.1 (delete-block block))
270     (t
271     (loop
272     (let ((succ (block-succ block)))
273     (unless (and succ (null (rest succ)))
274     (return)))
275    
276     (let ((last (block-last block)))
277     (typecase last
278     (cif
279     (flush-dest (if-test last))
280     (when (unlink-node last) (return)))
281     (exit
282     (when (maybe-delete-exit last) (return)))))
283    
284     (unless (join-successor-if-possible block)
285     (return)))
286    
287 ram 1.11 (when (and (block-reoptimize block) (block-component block))
288 wlott 1.1 (assert (not (block-delete-p block)))
289     (ir1-optimize-block block))
290    
291 ram 1.11 (when (and (block-flush-p block) (block-component block))
292 wlott 1.1 (assert (not (block-delete-p block)))
293     (flush-dead-code block)))))
294    
295     (undefined-value))
296    
297    
298     ;;; IR1-Optimize-Block -- Internal
299     ;;;
300     ;;; Loop over the nodes in Block, looking for stuff that needs to be
301     ;;; optimized. We dispatch off of the type of each node with its reoptimize
302     ;;; flag set:
303     ;;; -- With a combination, we call Propagate-Function-Change whenever the
304     ;;; function changes, and call IR1-Optimize-Combination if any argument
305     ;;; changes.
306     ;;; -- With an Exit, we derive the node's type from the Value's type. We don't
307     ;;; propagate Cont's assertion to the Value, since if we did, this would
308     ;;; move the checking of Cont's assertion to the exit. This wouldn't work
309     ;;; with Catch and UWP, where the Exit node is just a placeholder for the
310     ;;; actual unknown exit.
311     ;;;
312     ;;; Note that we clear the node & block reoptimize flags *before* doing the
313     ;;; optimization. This ensures that the node or block will be reoptimized if
314 ram 1.19 ;;; necessary. We leave the NODE-OPTIMIZE flag set going into
315 wlott 1.1 ;;; IR1-OPTIMIZE-RETURN, since it wants to clear the flag itself.
316     ;;;
317     (defun ir1-optimize-block (block)
318     (declare (type cblock block))
319     (setf (block-reoptimize block) nil)
320 ram 1.19 (do-nodes (node cont block :restart-p t)
321 wlott 1.1 (when (node-reoptimize node)
322     (setf (node-reoptimize node) nil)
323     (typecase node
324     (ref)
325     (combination
326     (when (continuation-reoptimize (basic-combination-fun node))
327     (propagate-function-change node))
328     (when (dolist (arg (basic-combination-args node) nil)
329     (when (and arg (continuation-reoptimize arg))
330     (return t)))
331     (ir1-optimize-combination node)))
332     (cif
333     (ir1-optimize-if node))
334     (creturn
335     (setf (node-reoptimize node) t)
336     (ir1-optimize-return node))
337 ram 1.6 (mv-combination
338     (when (and (eq (basic-combination-kind node) :local)
339     (continuation-reoptimize
340     (first (basic-combination-args node))))
341     (ir1-optimize-mv-bind node)))
342 wlott 1.1 (exit
343     (let ((value (exit-value node)))
344     (when value
345     (derive-node-type node (continuation-derived-type value)))))
346     (cset
347     (ir1-optimize-set node)))))
348     (undefined-value))
349    
350    
351     ;;; Join-Successor-If-Possible -- Internal
352     ;;;
353     ;;; We cannot combine with a successor block if:
354     ;;; 1] The successor has more than one predecessor.
355     ;;; 2] The last node's Cont is also used somewhere else.
356     ;;; 3] The successor is the current block (infinite loop).
357     ;;; 4] The next block has a different cleanup, and thus we may want to insert
358     ;;; cleanup code between the two blocks at some point.
359     ;;; 5] The next block has a different home lambda, and thus the control
360     ;;; transfer is a non-local exit.
361     ;;;
362     ;;; If we succeed, we return true, otherwise false.
363     ;;;
364     ;;; Joining is easy when the successor's Start continuation is the same from
365     ;;; our Last's Cont. If they differ, then we can still join when the last
366     ;;; continuation has no next and the next continuation has no uses. In this
367 ram 1.5 ;;; case, we replace the next continuation with the last before joining the
368 wlott 1.1 ;;; blocks.
369     ;;;
370     (defun join-successor-if-possible (block)
371     (declare (type cblock block))
372     (let ((next (first (block-succ block))))
373 ram 1.11 (when (block-start next)
374 wlott 1.1 (let* ((last (block-last block))
375     (last-cont (node-cont last))
376 ram 1.11 (next-cont (block-start next)))
377 wlott 1.1 (cond ((or (rest (block-pred next))
378 ram 1.5 (not (eq (continuation-use last-cont) last))
379 wlott 1.1 (eq next block)
380 ram 1.11 (not (eq (block-end-cleanup block)
381     (block-start-cleanup next)))
382     (not (eq (block-home-lambda block)
383     (block-home-lambda next))))
384 wlott 1.1 nil)
385 ram 1.5 ((eq last-cont next-cont)
386 wlott 1.1 (join-blocks block next)
387     t)
388 ram 1.5 ((and (null (block-start-uses next))
389     (eq (continuation-kind last-cont) :inside-block))
390     (let ((next-node (continuation-next next-cont)))
391     (assert (not (continuation-dest next-cont)))
392     (delete-continuation next-cont)
393     (setf (node-prev next-node) last-cont)
394     (setf (continuation-next last-cont) next-node)
395     (setf (block-start next) last-cont)
396     (join-blocks block next))
397 wlott 1.1 t)
398     (t
399     nil))))))
400    
401    
402     ;;; Join-Blocks -- Internal
403     ;;;
404     ;;; Join together two blocks which have the same ending/starting
405     ;;; continuation. The code in Block2 is moved into Block1 and Block2 is
406 ram 1.11 ;;; deleted from the DFO. We combine the optimize flags for the two blocks so
407     ;;; that any indicated optimization gets done.
408 wlott 1.1 ;;;
409     (defun join-blocks (block1 block2)
410     (declare (type cblock block1 block2))
411     (let* ((last (block-last block2))
412     (last-cont (node-cont last))
413     (succ (block-succ block2))
414     (start2 (block-start block2)))
415     (do ((cont start2 (node-cont (continuation-next cont))))
416     ((eq cont last-cont)
417     (when (eq (continuation-kind last-cont) :inside-block)
418     (setf (continuation-block last-cont) block1)))
419     (setf (continuation-block cont) block1))
420    
421     (unlink-blocks block1 block2)
422     (dolist (block succ)
423     (unlink-blocks block2 block)
424     (link-blocks block1 block))
425    
426     (setf (block-last block1) last)
427     (setf (continuation-kind start2) :inside-block))
428    
429 ram 1.11 (setf (block-flags block1)
430     (attributes-union (block-flags block1)
431     (block-flags block2)
432     (block-attributes type-asserted test-modified)))
433 wlott 1.1
434     (let ((next (block-next block2))
435     (prev (block-prev block2)))
436     (setf (block-next prev) next)
437     (setf (block-prev next) prev))
438    
439     (undefined-value))
440    
441    
442     ;;;; Local call return type propagation:
443    
444     ;;; Find-Result-Type -- Internal
445     ;;;
446     ;;; This function is called on RETURN nodes that have their REOPTIMIZE flag
447     ;;; set. It iterates over the uses of the RESULT, looking for interesting
448     ;;; stuff to update the TAIL-SET:
449     ;;; -- If a use is a local call, then we check that the called function has
450     ;;; the tail set Tails. If we encounter any different tail set, we return
451     ;;; the second value true.
452     ;;; -- If a use isn't a local call, then we union its type together with the
453     ;;; types of other such uses. We assign to the RETURN-RESULT-TYPE the
454     ;;; intersection of this type with the RESULT's asserted type. We can make
455     ;;; this intersection now (potentially before type checking) because this
456     ;;; assertion on the result will eventually be checked (if appropriate.)
457     ;;;
458     (defun find-result-type (node tails)
459     (declare (type creturn node))
460     (let ((result (return-result node))
461     (retry nil))
462     (collect ((use-union *empty-type* values-type-union))
463     (do-uses (use result)
464     (if (and (basic-combination-p use)
465     (eq (basic-combination-kind use) :local))
466     (when (merge-tail-sets use tails)
467     (setq retry t))
468     (use-union (node-derived-type use))))
469     (let ((int (values-type-intersection
470     (continuation-asserted-type result)
471     (use-union))))
472     (setf (return-result-type node) int)))
473     retry))
474    
475    
476     ;;; Merge-Tail-Sets -- Internal
477     ;;;
478     ;;; This function handles merging the tail sets if Call is a call to a
479     ;;; function with a different TAIL-SET than Ret-Set. We return true if we do
480     ;;; anything.
481     ;;;
482     ;;; It is assumed that Call sends its value to a RETURN node. We
483     ;;; destructively modify the set for the returning function to represent both,
484     ;;; and then change all the functions in callee's set to reference the first.
485     ;;;
486     ;;; If the called function has no tail set, then do nothing; if it doesn't
487     ;;; return, then it can't affect the callers value.
488     ;;;
489     (defun merge-tail-sets (call ret-set)
490     (declare (type basic-combination call) (type tail-set ret-set))
491     (let ((fun-set (lambda-tail-set (combination-lambda call))))
492     (when (and fun-set (not (eq ret-set fun-set)))
493     (let ((funs (tail-set-functions fun-set)))
494     (dolist (fun funs)
495     (setf (lambda-tail-set fun) ret-set))
496     (setf (tail-set-functions ret-set)
497     (nconc (tail-set-functions ret-set) funs)))
498     t)))
499    
500    
501     ;;; IR1-Optimize-Return -- Internal
502     ;;;
503     ;;; Do stuff to realize that something has changed about the value delivered
504     ;;; to a return node. Since we consider the return values of all functions in
505     ;;; the tail set to be equivalent, this amounts to bringing the entire tail set
506     ;;; up to date. We iterate over the returns for all the functions in the tail
507     ;;; set, reanalyzing them all (not treating Node specially.)
508     ;;;
509     ;;; During this iteration, we may discover new functions that should be
510     ;;; added to the tail set. If this happens, we restart the iteration over the
511     ;;; TAIL-SET-FUNCTIONS. Note that this really doesn't duplicate much work, as
512     ;;; we clear the NODE-REOPTIMIZE flags in the return nodes as we go, thus we
513     ;;; don't call FIND-RESULT-TYPE on any given return more than once.
514     ;;;
515     ;;; Restarting the iteration doesn't disturb the computation of the result
516     ;;; type RES, since we will just be adding more types to the union. (or when
517     ;;; we iterate over a return multiple times, unioning in the same type more
518     ;;; than once.)
519     ;;;
520     ;;; When we are done, we check if the new type is different from the old
521     ;;; TAIL-SET-TYPE. If so, we set the type and also reoptimize all the
522     ;;; continuations for references to functions in the tail set. This will
523     ;;; cause IR1-OPTIMIZE-COMBINATION to derive the new type as the results of the
524     ;;; calls.
525     ;;;
526     (defun ir1-optimize-return (node)
527     (declare (type creturn node))
528     (let ((tails (lambda-tail-set (return-lambda node))))
529     (collect ((res *empty-type* values-type-union))
530     (loop
531     (block RETRY
532     (let ((funs (tail-set-functions tails)))
533     (dolist (fun funs)
534     (let ((return (lambda-return fun)))
535     (when (node-reoptimize return)
536     (setf (node-reoptimize node) nil)
537     (when (find-result-type return tails) (return-from RETRY)))
538     (res (return-result-type return)))))
539     (return)))
540    
541     (when (type/= (res) (tail-set-type tails))
542     (setf (tail-set-type tails) (res))
543     (dolist (fun (tail-set-functions tails))
544     (dolist (ref (leaf-refs fun))
545     (reoptimize-continuation (node-cont ref)))))))
546    
547     (undefined-value))
548    
549    
550     ;;; IR1-Optimize-If -- Internal
551     ;;;
552     ;;; If the test has multiple uses, replicate the node when possible. Also
553     ;;; check if the predicate is known to be true or false, deleting the IF node
554     ;;; in favor of the appropriate branch when this is the case.
555     ;;;
556     (defun ir1-optimize-if (node)
557     (declare (type cif node))
558     (let ((test (if-test node))
559     (block (node-block node)))
560    
561     (when (and (eq (block-start block) test)
562     (eq (continuation-next test) node)
563     (rest (block-start-uses block)))
564     (do-uses (use test)
565     (when (immediately-used-p test use)
566     (convert-if-if use node)
567     (when (continuation-use test) (return)))))
568    
569     (let* ((type (continuation-type test))
570     (victim
571     (cond ((constant-continuation-p test)
572     (if (continuation-value test)
573     (if-alternative node)
574     (if-consequent node)))
575     ((not (types-intersect type *null-type*))
576     (if-alternative node))
577     ((type= type *null-type*)
578     (if-consequent node)))))
579     (when victim
580     (flush-dest test)
581     (when (rest (block-succ block))
582     (unlink-blocks block victim))
583     (setf (component-reanalyze (block-component (node-block node))) t)
584     (unlink-node node))))
585     (undefined-value))
586    
587    
588     ;;; Convert-If-If -- Internal
589     ;;;
590     ;;; Create a new copy of an IF Node that tests the value of the node Use.
591     ;;; The test must have >1 use, and must be immediately used by Use. Node must
592     ;;; be the only node in its block (implying that block-start = if-test).
593     ;;;
594     ;;; This optimization has an effect semantically similar to the
595     ;;; source-to-source transformation:
596     ;;; (IF (IF A B C) D E) ==>
597     ;;; (IF A (IF B D E) (IF C D E))
598     ;;;
599     (defun convert-if-if (use node)
600     (declare (type node use) (type cif node))
601     (with-ir1-environment node
602     (let* ((block (node-block node))
603     (test (if-test node))
604     (cblock (if-consequent node))
605     (ablock (if-alternative node))
606     (use-block (node-block use))
607     (dummy-cont (make-continuation))
608     (new-cont (make-continuation))
609 ram 1.11 (new-node (make-if :test new-cont
610 wlott 1.1 :consequent cblock :alternative ablock))
611     (new-block (continuation-starts-block new-cont)))
612     (prev-link new-node new-cont)
613     (setf (continuation-dest new-cont) new-node)
614     (add-continuation-use new-node dummy-cont)
615     (setf (block-last new-block) new-node)
616    
617     (unlink-blocks use-block block)
618     (delete-continuation-use use)
619     (add-continuation-use use new-cont)
620     (link-blocks use-block new-block)
621    
622     (link-blocks new-block cblock)
623     (link-blocks new-block ablock)
624    
625     (reoptimize-continuation test)
626     (reoptimize-continuation new-cont)
627     (setf (component-reanalyze *current-component*) t)))
628     (undefined-value))
629    
630    
631     ;;;; Exit IR1 optimization:
632    
633     ;;; Maybe-Delete-Exit -- Interface
634     ;;;
635     ;;; This function attempts to delete an exit node, returning true if it
636     ;;; deletes the block as a consequence:
637     ;;; -- If the exit is degenerate (has no Entry), then we don't do anything,
638     ;;; since there is nothing to be done.
639     ;;; -- If the exit node and its Entry have the same home lambda then we know
640     ;;; the exit is local, and can delete the exit. We change uses of the
641     ;;; Exit-Value to be uses of the original continuation, then unlink the
642     ;;; node.
643     ;;; -- If there is no value (as in a GO), then we skip the value semantics.
644     ;;;
645     ;;; This function is also called by environment analysis, since it wants all
646     ;;; exits to be optimized even if normal optimization was omitted.
647     ;;;
648     (defun maybe-delete-exit (node)
649     (declare (type exit node))
650     (let ((value (exit-value node))
651     (entry (exit-entry node))
652     (cont (node-cont node)))
653     (when (and entry
654 ram 1.11 (eq (node-home-lambda node) (node-home-lambda entry)))
655     (setf (entry-exits entry) (delete node (entry-exits entry)))
656 wlott 1.1 (prog1
657     (unlink-node node)
658     (when value
659     (substitute-continuation-uses cont value))))))
660    
661    
662     ;;;; Combination IR1 optimization:
663    
664     ;;; Ir1-Optimize-Combination -- Internal
665     ;;;
666     ;;; Do IR1 optimizations on a Combination node.
667     ;;;
668     (proclaim '(function ir1-optimize-combination (combination) void))
669     (defun ir1-optimize-combination (node)
670     (let ((args (basic-combination-args node))
671     (kind (basic-combination-kind node)))
672     (case kind
673     (:local
674     (let ((fun (combination-lambda node)))
675     (if (eq (functional-kind fun) :let)
676     (propagate-let-args node fun)
677     (propagate-local-call-args node fun))))
678     (:full
679     (dolist (arg args)
680     (when arg
681     (setf (continuation-reoptimize arg) nil))))
682     (t
683     (dolist (arg args)
684     (when arg
685     (setf (continuation-reoptimize arg) nil)))
686    
687     (let ((attr (function-info-attributes kind)))
688     (when (and (ir1-attributep attr foldable)
689     (not (ir1-attributep attr call))
690     (every #'constant-continuation-p args)
691     (continuation-dest (node-cont node)))
692     (constant-fold-call node)
693     (return-from ir1-optimize-combination)))
694 ram 1.18
695 wlott 1.1 (let ((fun (function-info-derive-type kind)))
696     (when fun
697     (let ((res (funcall fun node)))
698     (when res
699     (derive-node-type node res)))))
700 ram 1.18
701 wlott 1.1 (let ((fun (function-info-optimizer kind)))
702     (unless (and fun (funcall fun node))
703     (dolist (x (function-info-transforms kind))
704 wlott 1.2 (unless (ir1-transform node (car x) (cdr x))
705     (return))))))))
706 wlott 1.1
707     (undefined-value))
708    
709    
710     ;;; Recognize-Known-Call -- Interface
711     ;;;
712     ;;; If Call is a call to a known function, mark it as such by setting the
713     ;;; Kind. In addition to a direct check for the function name in the table, we
714     ;;; also must check for slot accessors. If the function is a slot accessor,
715     ;;; then we set the combination kind to the function info of %Slot-Setter or
716     ;;; %Slot-Accessor, as appropriate.
717     ;;;
718 ram 1.19 ;;; If convert-again is true, and the function has a source-transform or
719     ;;; inline-expansion, or if the function is conditional, and the destination of
720     ;;; the value is not an IF, then instead of making the existing call known, we
721     ;;; change it to be a call to a lambda that just re-calls the function. This
722     ;;; gives IR1 transformation another go at the call, in the case where the call
723     ;;; wasn't obviously known during the initial IR1 conversion.
724     ;;;
725     (defun recognize-known-call (call &optional convert-again)
726 wlott 1.1 (declare (type combination call))
727     (let* ((fun (basic-combination-fun call))
728     (name (continuation-function-name fun)))
729     (when name
730     (let ((info (info function info name)))
731 ram 1.19 (cond
732     ((and info convert-again
733     (or (info function source-transform name)
734     (info function inline-expansion name)
735     (and (ir1-attributep (function-info-attributes info)
736     predicate)
737     (let ((dest (continuation-dest (node-cont call))))
738     (and dest (not (if-p dest)))))))
739     (let ((dums (loop repeat (length (combination-args call))
740     collect (gensym))))
741     (transform-call call
742     `(lambda ,dums
743     (,name ,@dums)))))
744     (info
745     (setf (basic-combination-kind call) info))
746     ((slot-accessor-p (ref-leaf (continuation-use fun)))
747     (setf (basic-combination-kind call)
748     (info function info
749     (if (consp name)
750     '%slot-setter
751     '%slot-accessor))))))))
752 wlott 1.1 (undefined-value))
753    
754    
755     ;;; Propagate-Function-Change -- Internal
756     ;;;
757     ;;; Called by Ir1-Optimize when the function for a call has changed.
758     ;;; If the call is to a functional, then we attempt to convert it to a local
759     ;;; call, otherwise we check the call for legality with respect to the new
760     ;;; type; if it is illegal, we mark the Ref as :Notline and punt.
761     ;;;
762     ;;; If we do have a good type for the call, we propagate type information from
763     ;;; the type to the arg and result continuations. If we discover that the call
764     ;;; is to a known global function, then we mark the combination as known.
765     ;;;
766     (defun propagate-function-change (call)
767     (declare (type combination call))
768     (let* ((fun (combination-fun call))
769     (use (continuation-use fun))
770     (type (continuation-derived-type fun))
771     (*compiler-error-context* call))
772     (setf (continuation-reoptimize fun) nil)
773     (cond ((or (not (ref-p use))
774     (eq (ref-inlinep use) :notinline)))
775     ((functional-p (ref-leaf use))
776     (let ((leaf (ref-leaf use)))
777     (cond ((eq (combination-kind call) :local)
778     (let ((tail-set (lambda-tail-set leaf)))
779     (when tail-set
780     (derive-node-type
781     call (tail-set-type tail-set)))))
782     ((not (eq (ref-inlinep use) :notinline))
783     (convert-call-if-possible use call)
784     (maybe-let-convert leaf)))))
785     ((not (function-type-p type)))
786     ((valid-function-use call type
787     :argument-test #'always-subtypep
788     :result-test #'always-subtypep
789     :error-function #'compiler-warning
790     :warning-function #'compiler-note)
791     (assert-call-type call type)
792 ram 1.19 (recognize-known-call call t))
793 wlott 1.1 (t
794     (setf (ref-inlinep use) :notinline))))
795    
796     (undefined-value))
797    
798    
799     ;;;; Known function optimization:
800    
801 ram 1.15 ;;;
802     ;;; A hashtable from combination nodes to things describing how an
803     ;;; optimization of the node failed. The value is an alist
804     ;;; (Fun . Args), where Fun is the transformation function that failed and Args
805     ;;; is either a list for format arguments for the note or the FUNCTION-TYPE
806     ;;; that would have enabled the transformation but failed to match.
807     ;;;
808     (defvar *failed-optimizations* (make-hash-table :test #'eq))
809    
810    
811     ;;; RECORD-OPTIMIZATION-FAILURE -- Internal
812     ;;;
813     ;;; Add a failed optimization note to *FAILED-OPTIMZATIONS* for Node, Fun
814     ;;; and Args. If there is already a note for Node and Fun, replace it,
815     ;;; otherwise add a new one.
816     ;;;
817     (defun record-optimization-failure (node fun args)
818     (declare (type combination node) (type function fun)
819     (type (or function-type list) args))
820     (let ((found (assoc fun (gethash node *failed-optimizations*))))
821     (if found
822     (setf (cdr found) args)
823     (push (cons fun args)
824     (gethash node *failed-optimizations*))))
825     (undefined-value))
826    
827    
828 wlott 1.1 ;;; IR1-Transform -- Internal
829     ;;;
830     ;;; Attempt to transform Node using Function, subject to the call type
831     ;;; constraint Type. If we are inhibited from doing the transform for some
832     ;;; reason and Flame is true, then we make a note of the message in
833 wlott 1.2 ;;; *failed-optimizations* for IR1 finalize to pick up. We return true if
834     ;;; the transform failed, and thus further transformation should be
835     ;;; attempted. We return false if either the transform suceeded or was
836     ;;; aborted.
837 wlott 1.1 ;;;
838     (defun ir1-transform (node type fun)
839 wlott 1.2 (declare (type combination node) (type ctype type) (type function fun))
840 wlott 1.1 (let ((constrained (function-type-p type))
841     (flame (policy node (> speed brevity)))
842     (*compiler-error-context* node))
843     (cond ((or (not constrained)
844 ram 1.19 (valid-function-use node type :strict-result t))
845 wlott 1.1 (multiple-value-bind
846     (severity args)
847     (catch 'give-up
848     (transform-call node (funcall fun node))
849     (values :none nil))
850     (ecase severity
851 ram 1.15 (:none
852     (remhash node *failed-optimizations*)
853     nil)
854 wlott 1.1 (:aborted
855     (setf (combination-kind node) :full)
856     (setf (ref-inlinep (continuation-use (combination-fun node)))
857     :notinline)
858     (when args
859 wlott 1.2 (apply #'compiler-warning args))
860 ram 1.15 (remhash node *failed-optimizations*)
861 wlott 1.2 nil)
862 wlott 1.1 (:failure
863 ram 1.15 (if args
864     (when flame
865     (record-optimization-failure node fun args))
866     (setf (gethash node *failed-optimizations*)
867     (remove fun (gethash node *failed-optimizations*)
868     :key #'car)))
869 wlott 1.2 t))))
870 wlott 1.1 ((and flame
871     (valid-function-use node type
872     :argument-test #'types-intersect
873     :result-test #'values-types-intersect))
874 ram 1.15 (record-optimization-failure node fun type)
875 wlott 1.13 t)
876     (t
877 wlott 1.2 t))))
878 wlott 1.1
879    
880     ;;; GIVE-UP, ABORT-TRANSFORM -- Interface
881     ;;;
882     ;;; Just throw the severity and args...
883     ;;;
884     (proclaim '(function give-up (&rest t) nil))
885     (defun give-up (&rest args)
886     "This function is used to throw out of an IR1 transform, aborting this
887     attempt to transform the call, but admitting the possibility that this or
888     some other transform will later suceed. If arguments are supplied, they are
889     format arguments for an efficiency note."
890     (throw 'give-up (values :failure args)))
891     ;;;
892     (defun abort-transform (&rest args)
893     "This function is used to throw out of an IR1 transform and force a normal
894     call to the function at run time. No further optimizations will be
895     attempted."
896     (throw 'give-up (values :aborted args)))
897    
898    
899     ;;; Transform-Call -- Internal
900     ;;;
901     ;;; Take the lambda-expression Res, IR1 convert it in the proper
902     ;;; environment, and then install it as the function for the call Node. We do
903     ;;; local call analysis so that the new function is integrated into the control
904     ;;; flow. We set the Reanalyze flag in the component to cause the DFO to be
905     ;;; recomputed at soonest convenience.
906     ;;;
907     (defun transform-call (node res)
908     (declare (type combination node) (list res))
909     (with-ir1-environment node
910 ram 1.11 (let ((new-fun (ir1-convert-global-lambda res))
911 wlott 1.1 (ref (continuation-use (combination-fun node))))
912     (change-ref-leaf ref new-fun)
913     (setf (combination-kind node) :full)
914     (local-call-analyze *current-component*)))
915     (undefined-value))
916    
917    
918     ;;; Constant-Fold-Call -- Internal
919     ;;;
920     ;;; Replace a call to a foldable function of constant arguments with the
921     ;;; result of evaluating the form. We insert the resulting constant node after
922     ;;; the call, stealing the call's continuation. We give the call a
923     ;;; continuation with no Dest, which should cause it and its arguments to go
924     ;;; away. If there is an error during the evaluation, we give a warning and
925     ;;; leave the call alone, making the call a full call and marking it as
926     ;;; :notinline to make sure that it stays that way.
927     ;;;
928     ;;; For now, if the result is other than one value, we don't fold it.
929     ;;;
930     (defun constant-fold-call (call)
931     (declare (type combination call))
932     (let* ((args (mapcar #'continuation-value (combination-args call)))
933     (ref (continuation-use (combination-fun call)))
934     (fun (leaf-name (ref-leaf ref))))
935    
936     (multiple-value-bind (values win)
937     (careful-call fun args call "constant folding")
938     (cond
939     ((not win)
940     (setf (ref-inlinep ref) :notinline)
941     (setf (combination-kind call) :full))
942     ((= (length values) 1)
943     (with-ir1-environment call
944     (let* ((leaf (find-constant (first values)))
945     (node (make-ref (leaf-type leaf)
946     leaf
947     nil))
948     (dummy (make-continuation))
949     (cont (node-cont call))
950     (block (node-block call))
951     (next (continuation-next cont)))
952     (push node (leaf-refs leaf))
953     (setf (leaf-ever-used leaf) t)
954    
955     (delete-continuation-use call)
956     (add-continuation-use call dummy)
957     (prev-link node dummy)
958     (add-continuation-use node cont)
959     (setf (continuation-next cont) next)
960     (when (eq call (block-last block))
961     (setf (block-last block) node))
962 ram 1.19 (reoptimize-continuation cont))))
963     (t
964     (let ((dummies (loop repeat (length args)
965     collect (gensym))))
966     (transform-call
967     call
968     `(lambda ,dummies
969     (declare (ignore ,@dummies))
970     (values ,@(mapcar #'(lambda (x) `',x) values)))))))))
971 wlott 1.1
972     (undefined-value))
973    
974    
975     ;;;; Local call optimization:
976    
977     ;;; Propagate-To-Refs -- Internal
978     ;;;
979     ;;; Propagate Type to Leaf and its Refs, marking things changed. If the
980     ;;; leaf type is a function type, then just leave it alone, since TYPE is never
981     ;;; going to be more specific than that (and TYPE-INTERSECTION would choke.)
982     ;;;
983     (defun propagate-to-refs (leaf type)
984     (declare (type leaf leaf) (type ctype type))
985     (let ((var-type (leaf-type leaf)))
986     (unless (function-type-p var-type)
987     (let ((int (type-intersection var-type type)))
988     (when (type/= int var-type)
989     (setf (leaf-type leaf) int)
990     (dolist (ref (leaf-refs leaf))
991     (derive-node-type ref int))))
992     (undefined-value))))
993    
994    
995     ;;; PROPAGATE-FROM-SETS -- Internal
996     ;;;
997     ;;; Figure out the type of a LET variable that has sets. We compute the
998     ;;; union of the initial value Type and the types of all the set values and to
999     ;;; a PROPAGATE-TO-REFS with this type.
1000     ;;;
1001     (defun propagate-from-sets (var type)
1002 ram 1.6 (collect ((res type type-union))
1003 wlott 1.1 (dolist (set (basic-var-sets var))
1004     (res (continuation-type (set-value set)))
1005     (setf (node-reoptimize set) nil))
1006     (propagate-to-refs var (res)))
1007     (undefined-value))
1008    
1009    
1010     ;;; IR1-OPTIMIZE-SET -- Internal
1011     ;;;
1012     ;;; If a let variable, find the initial value's type and do
1013     ;;; PROPAGATE-FROM-SETS. We also derive the VALUE's type as the node's type.
1014     ;;;
1015     (defun ir1-optimize-set (node)
1016     (declare (type cset node))
1017     (let ((var (set-var node)))
1018     (when (and (lambda-var-p var) (leaf-refs var))
1019     (let ((home (lambda-var-home var)))
1020     (when (eq (functional-kind home) :let)
1021     (let ((iv (let-var-initial-value var)))
1022     (setf (continuation-reoptimize iv) nil)
1023     (propagate-from-sets var (continuation-type iv)))))))
1024    
1025     (derive-node-type node (continuation-type (set-value node)))
1026     (undefined-value))
1027    
1028    
1029 ram 1.17 ;;; CONSTANT-REFERENCE-P -- Interface
1030 ram 1.7 ;;;
1031     ;;; Return true if the value of Ref will always be the same (and is thus
1032     ;;; legal to substitute.)
1033     ;;;
1034     (defun constant-reference-p (ref)
1035     (declare (type ref ref))
1036     (let ((leaf (ref-leaf ref)))
1037     (typecase leaf
1038     (constant t)
1039     (functional t)
1040     (lambda-var
1041     (null (lambda-var-sets leaf)))
1042     (global-var
1043     (case (global-var-kind leaf)
1044     (:global-function
1045     (not (eq (ref-inlinep ref) :notinline)))
1046     (:constant t))))))
1047    
1048    
1049     ;;; SUBSTITUTE-SINGLE-USE-CONTINUATION -- Internal
1050     ;;;
1051     ;;; If we have a non-set let var with a single use, then (if possible)
1052     ;;; replace the variable reference's CONT with the arg continuation. This is
1053     ;;; inhibited when:
1054     ;;; -- CONT has other uses, or
1055     ;;; -- CONT receives multiple values, or
1056 ram 1.9 ;;; -- the reference is in a different environment from the variable, or
1057     ;;; -- either continuation has a funky TYPE-CHECK annotation.
1058 ram 1.7 ;;;
1059     ;;; We change the Ref to be a reference to NIL with unused value, and let it
1060     ;;; be flushed as dead code. A side-effect of this substitution is to delete
1061     ;;; the variable.
1062     ;;;
1063     (defun substitute-single-use-continuation (arg var)
1064     (declare (type continuation arg) (type lambda-var var))
1065     (let* ((ref (first (leaf-refs var)))
1066     (cont (node-cont ref))
1067     (dest (continuation-dest cont)))
1068     (when (and (eq (continuation-use cont) ref)
1069     dest
1070     (not (typep dest '(or creturn exit mv-combination)))
1071 ram 1.11 (eq (node-home-lambda ref)
1072 ram 1.9 (lambda-home (lambda-var-home var)))
1073     (member (continuation-type-check arg) '(t nil))
1074     (member (continuation-type-check cont) '(t nil)))
1075 ram 1.7 (assert-continuation-type arg (continuation-asserted-type cont))
1076     (change-ref-leaf ref (find-constant nil))
1077     (substitute-continuation arg cont)
1078     (reoptimize-continuation arg)
1079     t)))
1080    
1081    
1082 ram 1.19 ;;; DELETE-LET -- Interface
1083     ;;;
1084     ;;; Delete a Let, removing the call and bind nodes, and warning about any
1085     ;;; unreferenced variables. Note that FLUSH-DEAD-CODE will come along right
1086     ;;; away and delete the REF and then the lambda, since we flush the FUN
1087     ;;; continuation.
1088     ;;;
1089     (defun delete-let (fun)
1090     (declare (type clambda fun))
1091     (assert (eq (functional-kind fun) :let))
1092     (note-unreferenced-vars fun)
1093     (let ((call (let-combination fun)))
1094     (flush-dest (combination-fun call))
1095     (unlink-node call)
1096     (unlink-node (lambda-bind fun))
1097     (setf (lambda-bind fun) nil))
1098     (undefined-value))
1099    
1100    
1101 wlott 1.1 ;;; Propagate-Let-Args -- Internal
1102     ;;;
1103     ;;; This function is called when one of the arguments to a LET changes. We
1104     ;;; look at each changed argument. If the corresponding variable is set, then
1105     ;;; we call PROPAGATE-FROM-SETS. Otherwise, we consider substituting for the
1106     ;;; variable, and also propagate derived-type information for the arg to all
1107     ;;; the Var's refs.
1108     ;;;
1109 ram 1.16 ;;; Substitution is inhibited when the arg leaf's derived type isn't a
1110     ;;; subtype of the argument's asserted type. This prevents type checking from
1111     ;;; being defeated, and also ensures that the best representation for the
1112     ;;; variable can be used.
1113 wlott 1.1 ;;;
1114 ram 1.19 ;;; If all of the variables are deleted (have no references) when we are
1115     ;;; done, then we delete the let.
1116     ;;;
1117 wlott 1.1 ;;; Note that we are responsible for clearing the Continuation-Reoptimize
1118     ;;; flags.
1119     ;;;
1120     (defun propagate-let-args (call fun)
1121     (declare (type combination call) (type clambda fun))
1122 ram 1.19 (loop for arg in (combination-args call)
1123     and var in (lambda-vars fun) do
1124     (when (and arg (continuation-reoptimize arg))
1125     (setf (continuation-reoptimize arg) nil)
1126     (cond
1127     ((lambda-var-sets var)
1128     (propagate-from-sets var (continuation-type arg)))
1129     ((let ((use (continuation-use arg)))
1130     (when (ref-p use)
1131     (let ((leaf (ref-leaf use)))
1132     (when (and (constant-reference-p use)
1133     (values-subtypep (leaf-type leaf)
1134     (continuation-asserted-type arg)))
1135     (propagate-to-refs var (continuation-type arg))
1136     (substitute-leaf leaf var)
1137     t)))))
1138     ((and (null (rest (leaf-refs var)))
1139     (substitute-single-use-continuation arg var)))
1140     (t
1141     (propagate-to-refs var (continuation-type arg))))))
1142    
1143     (when (every #'null (combination-args call))
1144     (delete-let fun))
1145    
1146 wlott 1.1 (undefined-value))
1147    
1148    
1149     ;;; Propagate-Local-Call-Args -- Internal
1150     ;;;
1151     ;;; This function is called when one of the args to a non-let local call
1152     ;;; changes. For each changed argument corresponding to an unset variable, we
1153     ;;; compute the union of the types across all calls and propagate this type
1154     ;;; information to the var's refs.
1155     ;;;
1156     ;;; If the function has an XEP, then we don't do anything, since we won't
1157     ;;; discover anything.
1158     ;;;
1159     ;;; We can clear the Continuation-Reoptimize flags for arguments in all calls
1160     ;;; corresponding to changed arguments in Call, since the only use in IR1
1161     ;;; optimization of the Reoptimize flag for local call args is right here.
1162     ;;;
1163     (defun propagate-local-call-args (call fun)
1164     (declare (type combination call) (type clambda fun))
1165    
1166     (unless (functional-entry-function fun)
1167     (let* ((vars (lambda-vars fun))
1168     (union (mapcar #'(lambda (arg var)
1169     (when (and arg
1170     (continuation-reoptimize arg)
1171     (null (basic-var-sets var)))
1172     (continuation-type arg)))
1173     (basic-combination-args call)
1174     vars))
1175     (this-ref (continuation-use (basic-combination-fun call))))
1176    
1177     (dolist (arg (basic-combination-args call))
1178     (when arg
1179     (setf (continuation-reoptimize arg) nil)))
1180    
1181     (dolist (ref (leaf-refs fun))
1182     (unless (eq ref this-ref)
1183     (setq union
1184     (mapcar #'(lambda (this-arg old)
1185     (when old
1186     (setf (continuation-reoptimize this-arg) nil)
1187     (type-union (continuation-type this-arg) old)))
1188     (basic-combination-args
1189     (continuation-dest (node-cont ref)))
1190     union))))
1191    
1192     (mapc #'(lambda (var type)
1193     (when type
1194     (propagate-to-refs var type)))
1195     vars union)))
1196    
1197 ram 1.6 (undefined-value))
1198    
1199    
1200 ram 1.19 ;;;; Multiple values optimization:
1201    
1202 ram 1.6 ;;; IR1-OPTIMIZE-MV-BIND -- Internal
1203     ;;;
1204     ;;; Propagate derived type info from the values continuation to the vars.
1205     ;;;
1206     (defun ir1-optimize-mv-bind (node)
1207     (declare (type mv-combination node))
1208     (let ((arg (first (basic-combination-args node)))
1209     (vars (lambda-vars (combination-lambda node))))
1210     (multiple-value-bind (types nvals)
1211     (values-types (continuation-derived-type arg))
1212     (unless (eq nvals :unknown)
1213     (mapc #'(lambda (var type)
1214     (if (basic-var-sets var)
1215     (propagate-from-sets var type)
1216     (propagate-to-refs var type)))
1217     vars
1218     (append types
1219     (make-list (max (- (length vars) nvals) 0)
1220     :initial-element *null-type*)))))
1221    
1222     (setf (continuation-reoptimize arg) nil))
1223 wlott 1.1 (undefined-value))
1224 ram 1.19
1225    
1226     ;;; VALUES IR1 optimizer -- Internal
1227     ;;;
1228     ;;; If we see:
1229     ;;; (multiple-value-bind (x y)
1230     ;;; (values xx yy)
1231     ;;; ...)
1232     ;;; Convert to:
1233     ;;; (let ((x xx)
1234     ;;; (y yy))
1235     ;;; ...)
1236     ;;;
1237     ;;; What we actually do is convert the VALUES combination into a normal let
1238     ;;; combination calling the orignal :MV-LET lambda. If there are extra args to
1239     ;;; VALUES, discard the corresponding continuations. If there are insufficient
1240     ;;; args, insert references to NIL.
1241     ;;;
1242     (defoptimizer (values optimizer) ((&rest ignore) node)
1243     (declare (ignore ignore))
1244     (let ((dest (continuation-dest (node-cont node))))
1245     (when (and (mv-combination-p dest)
1246     (eq (basic-combination-kind dest) :local)
1247     (eq (continuation-use (first (basic-combination-args dest)))
1248     node))
1249     (let* ((fun (combination-lambda dest))
1250     (vars (lambda-vars fun))
1251     (vals (combination-args node))
1252     (nvars (length vars))
1253     (nvals (length vals)))
1254     (cond ((> nvals nvars)
1255     (mapc #'flush-dest (subseq vals nvars))
1256     (setq vals (subseq vals 0 nvars)))
1257     ((< nvals nvars)
1258     (with-ir1-environment node
1259     (let ((node-prev (node-prev node)))
1260     (setf (node-prev node) nil)
1261     (setf (continuation-next node-prev) nil)
1262     (collect ((res vals))
1263     (loop as cont = (make-continuation node)
1264     and prev = node-prev then cont
1265     repeat (- nvars nvals)
1266     do (reference-constant prev cont nil)
1267     (res cont))
1268     (setq vals (res)))
1269     (prev-link node (car (last vals)))))))
1270     (setf (combination-args node) vals)
1271     (flush-dest (combination-fun node))
1272     (let ((fun-cont (basic-combination-fun dest)))
1273     (setf (continuation-dest fun-cont) node)
1274     (setf (combination-fun node) fun-cont))
1275     (setf (combination-kind node) :local)
1276     (setf (functional-kind fun) :let)
1277     (flush-dest (first (basic-combination-args dest)))
1278     (unlink-node dest)
1279     (when vals
1280 ram 1.20 (reoptimize-continuation (first vals)))
1281     (propagate-to-args node fun))
1282 ram 1.19 t)))
1283    
1284    
1285     ;;; VALUES IR1 transform -- Internal
1286     ;;;
1287     ;;; If VALUES appears in a non-MV context, then effectively convert it to a
1288     ;;; PROG1. This allows the computation of the additional values to become dead
1289     ;;; code.
1290     ;;;
1291     (deftransform values ((&rest vals) * * :node node)
1292     (when (typep (continuation-dest (node-cont node))
1293     '(or creturn exit mv-combination))
1294     (give-up))
1295     (let ((dummies (loop repeat (1- (length vals))
1296     collect (gensym))))
1297     `(lambda (val ,@dummies)
1298     (declare (ignore ,@dummies))
1299     val)))
1300 wlott 1.1
1301    
1302     ;;; Flush-Dead-Code -- Internal
1303     ;;;
1304     ;;; Delete any nodes in Block whose value is unused and have no
1305     ;;; side-effects. We can delete sets of lexical variables when the set
1306     ;;; variable has no references.
1307     ;;;
1308     ;;; [### For now, don't delete potentially flushable calls when they have the
1309     ;;; Call attribute. Someday we should look at the funcitonal args to determine
1310     ;;; if they have any side-effects.]
1311     ;;;
1312     (defun flush-dead-code (block)
1313     (declare (type cblock block))
1314     (do-nodes-backwards (node cont block)
1315     (unless (continuation-dest cont)
1316     (typecase node
1317     (ref
1318     (delete-ref node)
1319     (unlink-node node))
1320     (combination
1321     (let ((info (combination-kind node)))
1322     (when (function-info-p info)
1323     (let ((attr (function-info-attributes info)))
1324     (when (and (ir1-attributep attr flushable)
1325     (not (ir1-attributep attr call)))
1326     (flush-dest (combination-fun node))
1327     (dolist (arg (combination-args node))
1328     (flush-dest arg))
1329     (unlink-node node))))))
1330     (exit
1331     (let ((value (exit-value node)))
1332     (when value
1333     (flush-dest value)
1334     (setf (exit-value node) nil))))
1335     (cset
1336     (let ((var (set-var node)))
1337     (when (and (lambda-var-p var)
1338     (null (leaf-refs var)))
1339     (flush-dest (set-value node))
1340     (setf (basic-var-sets var)
1341     (delete node (basic-var-sets var)))
1342     (unlink-node node)))))))
1343    
1344     (setf (block-flush-p block) nil)
1345     (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5