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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5