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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5