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