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

Contents of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5