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

Contents of /src/compiler/locall.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Sun Feb 23 17:43:10 1992 UTC (22 years, 1 month ago) by ram
Branch: MAIN
Changes since 1.23: +3 -3 lines
When checking if the call we are about to convert is going to be deleted, look
at the block holding the combination, not the ref, since the combination may be
deleted when the ref isn't.
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/locall.lisp,v 1.24 1992/02/23 17:43:10 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file implements local call analysis. A local call is a function
15 ;;; call between functions being compiled at the same time. If we can tell at
16 ;;; compile time that such a call is legal, then we change the combination
17 ;;; to call the correct lambda, mark it as local, and add this link to our call
18 ;;; graph. Once a call is local, it is then eligible for let conversion, which
19 ;;; places the body of the function inline.
20 ;;;
21 ;;; We cannot always do a local call even when we do have the function being
22 ;;; called. Local call can be explicitly disabled by a NOTINLINE declaration.
23 ;;; Calls that cannot be shown to have legal arg counts are also not converted.
24 ;;;
25 ;;; Written by Rob MacLachlan
26 ;;;
27 (in-package 'c)
28
29
30 ;;; Propagate-To-Args -- Interface
31 ;;;
32 ;;; This function propagates information from the variables in the function
33 ;;; Fun to the actual arguments in Call. This is also called by the VALUES IR1
34 ;;; optimizer when it sleazily converts MV-BINDs to LETs.
35 ;;;
36 ;;; We flush all arguments to Call that correspond to unreferenced variables
37 ;;; in Fun. We leave NILs in the Combination-Args so that the remaining args
38 ;;; still match up with their vars.
39 ;;;
40 ;;; We also apply the declared variable type assertion to the argument
41 ;;; continuations.
42 ;;;
43 (defun propagate-to-args (call fun)
44 (declare (type combination call) (type clambda fun))
45 (do ((args (basic-combination-args call) (cdr args))
46 (vars (lambda-vars fun) (cdr vars)))
47 ((null args))
48 (let ((arg (car args))
49 (var (car vars)))
50 (cond ((leaf-refs var)
51 (assert-continuation-type arg (leaf-type var)))
52 (t
53 (flush-dest arg)
54 (setf (car args) nil)))))
55
56 (undefined-value))
57
58
59 ;;; Convert-Call -- Internal
60 ;;;
61 ;;; Convert a combination into a local call. We Propagate-To-Args, set the
62 ;;; combination kind to :Local, add Fun to the Calls of the function that the
63 ;;; call is in, then replace the function in the Ref node with the new
64 ;;; function.
65 ;;;
66 ;;; We change the Ref last, since changing the reference can trigger let
67 ;;; conversion of the new function, but will only do so if the call is local.
68 ;;;
69 (defun convert-call (ref call fun)
70 (declare (type ref ref) (type combination call) (type clambda fun))
71 (propagate-to-args call fun)
72 (setf (basic-combination-kind call) :local)
73 (pushnew fun (lambda-calls (node-home-lambda call)))
74 (change-ref-leaf ref fun)
75 (undefined-value))
76
77
78 ;;;; External entry point creation:
79
80 ;;; Make-XEP-Lambda -- Internal
81 ;;;
82 ;;; Return a Lambda form that can be used as the definition of the XEP for
83 ;;; Fun.
84 ;;;
85 ;;; If Fun is a lambda, then we check the number of arguments (conditional
86 ;;; on policy) and call Fun with all the arguments.
87 ;;;
88 ;;; If Fun is an Optional-Dispatch, then we dispatch off of the number of
89 ;;; supplied arguments by doing do an = test for each entry-point, calling the
90 ;;; entry with the appropriate prefix of the passed arguments.
91 ;;;
92 ;;; If there is a more arg, then there are a couple of optimizations that we
93 ;;; make (more for space than anything else):
94 ;;; -- If Min-Args is 0, then we make the more entry a T clause, since no
95 ;;; argument count error is possible.
96 ;;; -- We can omit the = clause for the last entry-point, allowing the case of
97 ;;; 0 more args to fall through to the more entry.
98 ;;;
99 ;;; We don't bother to policy conditionalize wrong arg errors in optional
100 ;;; dispatches, since the additional overhead is negligible compared to the
101 ;;; other hair going down.
102 ;;;
103 ;;; Note that if policy indicates it, argument type declarations in Fun will
104 ;;; be verified. Since nothing is known about the type of the XEP arg vars,
105 ;;; type checks will be emitted when the XEP's arg vars are passed to the
106 ;;; actual function.
107 ;;;
108 (defun make-xep-lambda (fun)
109 (declare (type functional fun))
110 (etypecase fun
111 (clambda
112 (let ((nargs (length (lambda-vars fun)))
113 (n-supplied (gensym)))
114 (collect ((temps))
115 (dotimes (i nargs)
116 (temps (gensym)))
117 `(lambda (,n-supplied ,@(temps))
118 (declare (fixnum ,n-supplied))
119 ,(if (policy (lambda-bind fun) (zerop safety))
120 `(declare (ignore ,n-supplied))
121 `(%verify-argument-count ,n-supplied ,nargs))
122 (%funcall ,fun ,@(temps))))))
123 (optional-dispatch
124 (let* ((min (optional-dispatch-min-args fun))
125 (max (optional-dispatch-max-args fun))
126 (more (optional-dispatch-more-entry fun))
127 (n-supplied (gensym)))
128 (collect ((temps)
129 (entries))
130 (dotimes (i max)
131 (temps (gensym)))
132
133 (do ((eps (optional-dispatch-entry-points fun) (rest eps))
134 (n min (1+ n)))
135 ((null eps))
136 (entries `((= ,n-supplied ,n)
137 (%funcall ,(first eps) ,@(subseq (temps) 0 n)))))
138
139 `(lambda (,n-supplied ,@(temps))
140 (declare (fixnum ,n-supplied))
141 (cond
142 ,@(if more (butlast (entries)) (entries))
143 ,@(when more
144 `((,(if (zerop min) 't `(>= ,n-supplied ,max))
145 ,(let ((n-context (gensym))
146 (n-count (gensym)))
147 `(multiple-value-bind
148 (,n-context ,n-count)
149 (%more-arg-context ,n-supplied ,max)
150 (%funcall ,more ,@(temps) ,n-context ,n-count))))))
151 (t
152 (%argument-count-error ,n-supplied)))))))))
153
154
155 ;;; Make-External-Entry-Point -- Internal
156 ;;;
157 ;;; Make an external entry point (XEP) for Fun and return it. We convert
158 ;;; the result of Make-XEP-Lambda in the correct environment, then associate
159 ;;; this lambda with Fun as its XEP. After the conversion, we iterate over the
160 ;;; function's associated lambdas, redoing local call analysis so that the XEP
161 ;;; calls will get converted. We also bind *lexical-environment* to change the
162 ;;; compilation policy over to the interface policy.
163 ;;;
164 ;;; We set Reanalyze and Reoptimize in the component, just in case we
165 ;;; discover an XEP after the initial local call analyze pass.
166 ;;;
167 (defun make-external-entry-point (fun)
168 (declare (type functional fun))
169 (assert (not (functional-entry-function fun)))
170 (with-ir1-environment (lambda-bind (main-entry fun))
171 (let* ((*lexical-environment*
172 (make-lexenv :cookie
173 (make-interface-cookie *lexical-environment*)))
174 (res (ir1-convert-lambda (make-xep-lambda fun))))
175 (setf (functional-kind res) :external)
176 (setf (leaf-ever-used res) t)
177 (setf (functional-entry-function res) fun)
178 (setf (functional-entry-function fun) res)
179 (setf (component-reanalyze *current-component*) t)
180 (setf (component-reoptimize *current-component*) t)
181 (etypecase fun
182 (clambda (local-call-analyze-1 fun))
183 (optional-dispatch
184 (dolist (ep (optional-dispatch-entry-points fun))
185 (local-call-analyze-1 ep))
186 (when (optional-dispatch-more-entry fun)
187 (local-call-analyze-1 (optional-dispatch-more-entry fun)))))
188 res)))
189
190
191 ;;; Reference-Entry-Point -- Internal
192 ;;;
193 ;;; Notice a Ref that is not in a local-call context. If the Ref is already
194 ;;; to an XEP, then do nothing, otherwise change it to the XEP, making an XEP
195 ;;; if necessary.
196 ;;;
197 ;;; If Ref is to a special :Cleanup or :Escape function, then we treat it as
198 ;;; though it was not an XEP reference (i.e. leave it alone.)
199 ;;;
200 (defun reference-entry-point (ref)
201 (declare (type ref ref))
202 (let ((fun (ref-leaf ref)))
203 (unless (or (external-entry-point-p fun)
204 (member (functional-kind fun) '(:escape :cleanup)))
205 (change-ref-leaf ref (or (functional-entry-function fun)
206 (make-external-entry-point fun))))))
207
208
209 ;;; Local-Call-Analyze-1 -- Interface
210 ;;;
211 ;;; Attempt to convert all references to Fun to local calls. The reference
212 ;;; cannot be :Notinline, and must be the function for a call. The function
213 ;;; continuation must be used only once, since otherwise we cannot be sure what
214 ;;; function is to be called. The call continuation would be multiply used if
215 ;;; there is hairy stuff such as conditionals in the expression that computes
216 ;;; the function.
217 ;;;
218 ;;; Except in the interpreter, we don't attempt to convert calls that appear
219 ;;; in a top-level lambda unless there is only one reference or the function is
220 ;;; a unwind-protect cleanup. This allows top-level components to contain only
221 ;;; load-time code: any references to run-time functions will be as closures.
222 ;;;
223 ;;; If we cannot convert a reference, then we mark the referenced function
224 ;;; as an entry-point, creating a new XEP if necessary.
225 ;;;
226 ;;; This is broken off from Local-Call-Analyze so that people can force
227 ;;; analysis of newly introduced calls. Note that we don't do let conversion
228 ;;; here.
229 ;;;
230 (defun local-call-analyze-1 (fun)
231 (declare (type functional fun))
232 (let ((refs (leaf-refs fun)))
233 (dolist (ref refs)
234 (let* ((cont (node-cont ref))
235 (dest (continuation-dest cont)))
236 (cond ((and (basic-combination-p dest)
237 (eq (basic-combination-fun dest) cont)
238 (eq (continuation-use cont) ref)
239 (or (null (rest refs))
240 *converting-for-interpreter*
241 (eq (functional-kind fun) :cleanup)
242 (not (eq (functional-kind (node-home-lambda ref))
243 :top-level))))
244 (ecase (ref-inlinep ref)
245 ((nil :inline :maybe-inline)
246 (convert-call-if-possible ref dest))
247 ((:notinline)))
248
249 (unless (eq (basic-combination-kind dest) :local)
250 (reference-entry-point ref)))
251 (t
252 (reference-entry-point ref))))))
253
254 (undefined-value))
255
256
257 ;;; Local-Call-Analyze -- Interface
258 ;;;
259 ;;; We examine all New-Functions in component, attempting to convert calls
260 ;;; into local calls when it is legal. We also attempt to convert each lambda
261 ;;; to a let. Let conversion is also triggered by deletion of a function
262 ;;; reference, but functions that start out eligible for conversion must be
263 ;;; noticed sometime.
264 ;;;
265 ;;; Note that there is a lot of action going on behind the scenes here,
266 ;;; triggered by reference deletion. In particular, the Component-Lambdas are
267 ;;; being hacked to remove newly deleted and let converted lambdas, so it is
268 ;;; important that the lambda is added to the Component-Lambdas when it is.
269 ;;;
270 (defun local-call-analyze (component)
271 (declare (type component component))
272 (loop
273 (unless (component-new-functions component) (return))
274 (let* ((fun (pop (component-new-functions component)))
275 (kind (functional-kind fun)))
276 (cond ((eq kind :deleted))
277 ((and (null (leaf-refs fun)) (eq kind nil)
278 (not (functional-entry-function fun)))
279 (delete-functional fun))
280 (t
281 (when (lambda-p fun)
282 (push fun (component-lambdas component)))
283 (local-call-analyze-1 fun)
284 (when (lambda-p fun)
285 (maybe-let-convert fun))))))
286
287 (undefined-value))
288
289
290 ;;; Convert-Call-If-Possible -- Interface
291 ;;;
292 ;;; Dispatch to the appropriate function to attempt to convert a call. This
293 ;;; is called in IR1 optimize as well as in local call analysis. If the call
294 ;;; is already :Local, we do nothing. If the call is in the top-level
295 ;;; component, also do nothing, since we don't want to join top-level code into
296 ;;; normal components.
297 ;;;
298 ;;; We bind *Compiler-Error-Context* to the node for the call so that
299 ;;; warnings will get the right context.
300 ;;;
301 (defun convert-call-if-possible (ref call)
302 (declare (type ref ref) (type basic-combination call))
303 (unless (eq (basic-combination-kind call) :local)
304 (let ((fun (let ((fun (ref-leaf ref)))
305 (if (external-entry-point-p fun)
306 (functional-entry-function fun)
307 fun)))
308 (*compiler-error-context* call))
309 (assert (member (functional-kind fun) '(nil :escape :cleanup :optional)))
310 (cond ((mv-combination-p call)
311 (convert-mv-call ref call fun))
312 ((lambda-p fun)
313 (convert-lambda-call ref call fun))
314 (t
315 (convert-hairy-call ref call fun)))))
316 (undefined-value))
317
318
319 ;;; Convert-MV-Call -- Internal
320 ;;;
321 ;;; Attempt to convert a multiple-value call. The only interesting case is
322 ;;; a call to a function that Looks-Like-An-MV-Bind, has exactly one reference
323 ;;; and no XEP, and is called with one values continuation.
324 ;;;
325 ;;; We change the call to be to the last optional entry point and change the
326 ;;; call to be local. Due to our preconditions, the call should eventually be
327 ;;; converted to a let, but we can't do that now, since there may be stray
328 ;;; references to the e-p lambda due to optional defaulting code.
329 ;;;
330 ;;; We also use variable types for the called function to construct an
331 ;;; assertion for the values continuation.
332 ;;;
333 (defun convert-mv-call (ref call fun)
334 (declare (type ref ref) (type mv-combination call) (type functional fun))
335 (when (and (looks-like-an-mv-bind fun)
336 (not (functional-entry-function fun))
337 (= (length (leaf-refs fun)) 1)
338 (= (length (basic-combination-args call)) 1))
339 (let ((ep (car (last (optional-dispatch-entry-points fun)))))
340 (setf (basic-combination-kind call) :local)
341 (pushnew ep (lambda-calls (node-home-lambda call)))
342 (change-ref-leaf ref ep)
343
344 (assert-continuation-type
345 (first (basic-combination-args call))
346 (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
347 :rest *universal-type*))))
348 (undefined-value))
349
350
351 ;;; Convert-Lambda-Call -- Internal
352 ;;;
353 ;;; Attempt to convert a call to a lambda. If the number of args is wrong,
354 ;;; we give a warning and mark the Ref as :Notinline to remove it from future
355 ;;; consideration. If the argcount is O.K. then we just convert it.
356 ;;;
357 (defun convert-lambda-call (ref call fun)
358 (declare (type ref ref) (type combination call) (type clambda fun))
359 (let ((nargs (length (lambda-vars fun)))
360 (call-args (length (combination-args call))))
361 (cond ((= call-args nargs)
362 (convert-call ref call fun))
363 (t
364 (compiler-warning
365 "Function called with ~R argument~:P, but wants exactly ~R."
366 call-args nargs)
367 (setf (ref-inlinep ref) :notinline)))))
368
369
370
371 ;;;; Optional, more and keyword calls:
372
373 ;;; Convert-Hairy-Call -- Internal
374 ;;;
375 ;;; Similar to Convert-Lambda-Call, but deals with Optional-Dispatches. If
376 ;;; only fixed args are supplied, then convert a call to the correct entry
377 ;;; point. If keyword args are supplied, then dispatch to a subfunction. We
378 ;;; don't convert calls to functions that have a more (or rest) arg.
379 ;;;
380 (defun convert-hairy-call (ref call fun)
381 (declare (type ref ref) (type combination call)
382 (type optional-dispatch fun))
383 (let ((min-args (optional-dispatch-min-args fun))
384 (max-args (optional-dispatch-max-args fun))
385 (call-args (length (combination-args call))))
386 (cond ((< call-args min-args)
387 (compiler-warning "Function called with ~R argument~:P, but wants at least ~R."
388 call-args min-args)
389 (setf (ref-inlinep ref) :notinline))
390 ((<= call-args max-args)
391 (convert-call ref call
392 (elt (optional-dispatch-entry-points fun)
393 (- call-args min-args))))
394 ((optional-dispatch-more-entry fun)
395 (convert-more-call ref call fun))
396 (t
397 (compiler-warning "Function called with ~R argument~:P, but wants at most ~R."
398 call-args max-args)
399 (setf (ref-inlinep ref) :notinline))))
400
401 (undefined-value))
402
403
404 ;;; Convert-Hairy-Fun-Entry -- Internal
405 ;;;
406 ;;; This function is used to convert a call to an entry point when complex
407 ;;; transformations need to be done on the original arguments. Entry is the
408 ;;; entry point function that we are calling. Vars is a list of variable names
409 ;;; which are bound to the oringinal call arguments. Ignores is the subset of
410 ;;; Vars which are ignored. Args is the list of arguments to the entry point
411 ;;; function.
412 ;;;
413 ;;; In order to avoid gruesome graph grovelling, we introduce a new function
414 ;;; that rearranges the arguments and calls the entry point. We analyze the
415 ;;; new function and the entry point immediately so that everything gets
416 ;;; converted during the single pass.
417 ;;;
418 (defun convert-hairy-fun-entry (ref call entry vars ignores args)
419 (declare (list vars ignores args) (type ref ref) (type combination call)
420 (type clambda entry))
421 (let ((new-fun
422 (with-ir1-environment call
423 (ir1-convert-lambda
424 `(lambda ,vars
425 (declare (ignorable . ,ignores))
426 (%funcall ,entry . ,args))))))
427 (convert-call ref call new-fun)
428 (dolist (ref (leaf-refs entry))
429 (convert-call-if-possible ref (continuation-dest (node-cont ref))))))
430
431
432 ;;; Convert-More-Call -- Internal
433 ;;;
434 ;;; Use Convert-Hairy-Fun-Entry to convert a more-arg call to a known
435 ;;; function into a local call to the Main-Entry.
436 ;;;
437 ;;; First we verify that all keywords are constant and legal. If there
438 ;;; aren't, then we warn the user and don't attempt to convert the call.
439 ;;;
440 ;;; We massage the supplied keyword arguments into the order expected by the
441 ;;; main entry. This is done by binding all the arguments to the keyword call
442 ;;; to variables in the introduced lambda, then passing these values variables
443 ;;; in the correct order when calling the main entry. Unused arguments
444 ;;; (such as the keywords themselves) are discarded simply by not passing them
445 ;;; along.
446 ;;;
447 ;;; If there is a rest arg, then we bundle up the args and pass them to
448 ;;; LIST.
449 ;;;
450 (defun convert-more-call (ref call fun)
451 (declare (type ref ref) (type combination call) (type optional-dispatch fun))
452 (let* ((max (optional-dispatch-max-args fun))
453 (arglist (optional-dispatch-arglist fun))
454 (args (combination-args call))
455 (more (nthcdr max args))
456 (flame (policy call (or (> speed brevity) (> space brevity))))
457 (loser nil))
458 (collect ((temps)
459 (more-temps)
460 (ignores)
461 (supplied)
462 (key-vars))
463
464 (dolist (var arglist)
465 (let ((info (lambda-var-arg-info var)))
466 (when info
467 (ecase (arg-info-kind info)
468 (:keyword
469 (key-vars var))
470 ((:rest :optional))))))
471
472 (dotimes (i max)
473 (temps (gensym "FIXED-ARG-TEMP-")))
474
475 (dotimes (i (length more))
476 (more-temps (gensym "MORE-ARG-TEMP-")))
477
478 (when (optional-dispatch-keyp fun)
479 (when (oddp (length more))
480 (compiler-warning "Function called with odd number of ~
481 arguments in keyword portion.")
482 (setf (ref-inlinep ref) :notinline)
483 (return-from convert-more-call))
484
485 (do ((key more (cddr key))
486 (temp (more-temps) (cddr temp)))
487 ((null key))
488 (let ((cont (first key)))
489 (unless (constant-continuation-p cont)
490 (when flame
491 (compiler-note "Non-constant keyword in keyword call."))
492 (setf (ref-inlinep ref) :notinline)
493 (return-from convert-more-call))
494
495 (let ((name (continuation-value cont))
496 (dummy (first temp))
497 (val (second temp)))
498 (dolist (var (key-vars)
499 (progn
500 (ignores dummy val)
501 (setq loser name)))
502 (let ((info (lambda-var-arg-info var)))
503 (when (eq (arg-info-keyword info) name)
504 (ignores dummy)
505 (supplied (cons var val))
506 (return)))))))
507
508 (when (and loser (not (optional-dispatch-allowp fun)))
509 (compiler-warning "Function called with unknown argument keyword ~S."
510 loser)
511 (setf (ref-inlinep ref) :notinline)
512 (return-from convert-more-call)))
513
514 (collect ((call-args))
515 (do ((var arglist (cdr var))
516 (temp (temps) (cdr temp)))
517 (())
518 (let ((info (lambda-var-arg-info (car var))))
519 (if info
520 (ecase (arg-info-kind info)
521 (:optional
522 (call-args (car temp))
523 (when (arg-info-supplied-p info)
524 (call-args t)))
525 (:rest
526 (call-args `(list ,@(more-temps)))
527 (return))
528 (:keyword
529 (return)))
530 (call-args (car temp)))))
531
532 (dolist (var (key-vars))
533 (let ((info (lambda-var-arg-info var))
534 (temp (cdr (assoc var (supplied)))))
535 (if temp
536 (call-args temp)
537 (call-args (arg-info-default info)))
538 (when (arg-info-supplied-p info)
539 (call-args (not (null temp))))))
540
541 (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
542 (append (temps) (more-temps))
543 (ignores) (call-args)))))
544
545 (undefined-value))
546
547
548 ;;;; Let conversion:
549 ;;;
550 ;;; Converting to a let has differing significance to various parts of the
551 ;;; compiler:
552 ;;; -- The body of a Let is spliced in immediately after the the corresponding
553 ;;; combination node, making the control transfer explicit and allowing lets
554 ;;; to mashed together into a single block. The value of the let is
555 ;;; delivered directly to the original continuation for the call,
556 ;;; eliminating the need to propagate information from the dummy result
557 ;;; continuation.
558 ;;; -- As far as IR1 optimization is concerned, it is interesting in that there
559 ;;; is only one expression that the variable can be bound to, and this is
560 ;;; easily substitited for.
561 ;;; -- Lets are interesting to environment analysis and the back end because in
562 ;;; most ways a let can be considered to be "the same function" as its home
563 ;;; function.
564 ;;; -- Let conversion has dynamic scope implications, since control transfers
565 ;;; within the same environment are local. In a local control transfer,
566 ;;; cleanup code must be emitted to remove dynamic bindings that are no
567 ;;; longer in effect.
568
569
570 ;;; Insert-Let-Body -- Internal
571 ;;;
572 ;;; Set up the control transfer to the called lambda. We split the call
573 ;;; block immediately after the call, and link the head of Fun to the call
574 ;;; block. The successor block after splitting (where we return to) is
575 ;;; returned.
576 ;;;
577 ;;; If the lambda is is a different component than the call, then we call
578 ;;; JOIN-COMPONENTS. This only happens in block compilation before
579 ;;; FIND-INITIAL-DFO.
580 ;;;
581 (defun insert-let-body (fun call)
582 (declare (type clambda fun) (type basic-combination call))
583 (let* ((call-block (node-block call))
584 (bind-block (node-block (lambda-bind fun)))
585 (component (block-component call-block)))
586 (let ((fun-component (block-component bind-block)))
587 (unless (eq fun-component component)
588 (assert (eq (component-kind component) :initial))
589 (join-components component fun-component)))
590
591 (let ((*current-component* component))
592 (node-ends-block call))
593 (assert (= (length (block-succ call-block)) 1))
594 (let ((next-block (first (block-succ call-block))))
595 (unlink-blocks call-block next-block)
596 (link-blocks call-block bind-block)
597 next-block)))
598
599
600 ;;; Merge-Lets -- Internal
601 ;;;
602 ;;; Handle the environment semantics of let conversion. We add the lambda
603 ;;; and its lets to lets for the Call's home function. We merge the calls for
604 ;;; Fun with the calls for the home function, removing Fun in the process. We
605 ;;; also merge the Entries.
606 ;;;
607 ;;; We also unlink the function head from the component head and set
608 ;;; Component-Reanalyze to true to indicate that the DFO should be recomputed.
609 ;;;
610 (defun merge-lets (fun call)
611 (declare (type clambda fun) (type basic-combination call))
612 (let ((component (block-component (node-block call))))
613 (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
614 (setf (component-lambdas component)
615 (delete fun (component-lambdas component)))
616 (setf (component-reanalyze component) t))
617 (setf (lambda-call-lexenv fun) (node-lexenv call))
618 (let ((tails (lambda-tail-set fun)))
619 (setf (tail-set-functions tails)
620 (delete fun (tail-set-functions tails))))
621 (setf (lambda-tail-set fun) nil)
622 (let* ((home (node-home-lambda call))
623 (home-env (lambda-environment home)))
624 (push fun (lambda-lets home))
625 (setf (lambda-home fun) home)
626 (setf (lambda-environment fun) home-env)
627
628 (let ((lets (lambda-lets fun)))
629 (dolist (let lets)
630 (setf (lambda-home let) home)
631 (setf (lambda-environment let) home-env))
632
633 (setf (lambda-lets home) (nconc lets (lambda-lets home)))
634 (setf (lambda-lets fun) ()))
635
636 (setf (lambda-calls home)
637 (nunion (lambda-calls fun)
638 (delete fun (lambda-calls home))))
639 (setf (lambda-calls fun) ())
640
641 (setf (lambda-entries home)
642 (nconc (lambda-entries fun) (lambda-entries home)))
643 (setf (lambda-entries fun) ()))
644 (undefined-value))
645
646
647 ;;; Move-Return-Uses -- Internal
648 ;;;
649 ;;; Handle the value semantics of let conversion. Delete Fun's return node,
650 ;;; and change the control flow to transfer to Next-Block instead. Move all
651 ;;; the uses of the result continuation to Call's Cont.
652 ;;;
653 ;;; If the actual continuation is only used by the let call, then we
654 ;;; intersect the type assertion on the dummy continuation with the assertion
655 ;;; for the actual continuation; in all other cases assertions on the dummy
656 ;;; continuation are lost.
657 ;;;
658 ;;; We also intersect the derived type of the call with the derived type of
659 ;;; all the dummy continuation's uses. This serves mainly to propagate
660 ;;; TRULY-THE through lets.
661 ;;;
662 (defun move-return-uses (fun call next-block)
663 (declare (type clambda fun) (type basic-combination call)
664 (type cblock next-block))
665 (let* ((return (lambda-return fun))
666 (return-block (node-block return)))
667 (unlink-blocks return-block
668 (component-tail (block-component return-block)))
669 (link-blocks return-block next-block)
670 (unlink-node return)
671 (delete-return return)
672 (let ((result (return-result return))
673 (cont (node-cont call))
674 (call-type (node-derived-type call)))
675 (when (eq (continuation-use cont) call)
676 (assert-continuation-type cont (continuation-asserted-type result)))
677 (unless (eq call-type *wild-type*)
678 (do-uses (use result)
679 (derive-node-type use call-type)))
680 (substitute-continuation-uses cont result)))
681 (undefined-value))
682
683
684
685 ;;; MOVE-LET-CALL-CONT -- Internal
686 ;;;
687 ;;; Change all Cont for all the calls to Fun to be the start continuation
688 ;;; for the bind node. This allows the blocks to be joined if the caller count
689 ;;; ever goes to one.
690 ;;;
691 (defun move-let-call-cont (fun)
692 (declare (type clambda fun))
693 (let ((new-cont (node-prev (lambda-bind fun))))
694 (dolist (ref (leaf-refs fun))
695 (let ((dest (continuation-dest (node-cont ref))))
696 (delete-continuation-use dest)
697 (add-continuation-use dest new-cont))))
698 (undefined-value))
699
700
701 ;;; MOVE-RETURN-STUFF -- Internal
702 ;;;
703 ;;; Deal with returning from a let or assignment that we are converting.
704 ;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK
705 ;;; is the return point for a non-tail call, or NULL if call is a tail call.
706 ;;;
707 ;;; We do different things depending on whether the caller and callee have
708 ;;; returns left:
709 ;;; -- If the callee has no return, it doesn't return, so we just do
710 ;;; MOVE-LET-CALL-CONT.
711 ;;; -- If CALL is a non-tail call, or if both have returns, then we
712 ;;; delete the callee's return, move its uses to the call's result
713 ;;; continuation, and transfer control to the appropriate return point.
714 ;;; -- If the callee has a return, but the caller doesn't, then we move the
715 ;;; return to the caller. [Note: here CALL is always TR.]
716 ;;;
717 (defun move-return-stuff (fun call next-block)
718 (declare (type clambda fun) (type basic-combination call)
719 (type (or cblock null) next-block))
720 (let* ((return (lambda-return fun))
721 (call-fun (node-home-lambda call))
722 (call-return (lambda-return call-fun)))
723 (when return
724 (cond ((or next-block call-return)
725 (unless (block-delete-p (node-block return))
726 (move-return-uses fun call
727 (or next-block (node-block call-return)))))
728 (t
729 (setf (lambda-return call-fun) return)
730 (setf (return-lambda return) call-fun))))
731 (move-let-call-cont fun))
732 (undefined-value))
733
734
735 ;;; Let-Convert -- Internal
736 ;;;
737 ;;; Actually do let conversion. We call subfunctions to do most of the
738 ;;; work. We change the Call's cont to be the continuation heading the bind
739 ;;; block, and also do Reoptimize-Continuation on the args and Cont so that
740 ;;; let-specific IR1 optimizations get a chance. We blow away any entry for
741 ;;; the function in *free-functions* so that nobody will create new reference
742 ;;; to it.
743 ;;;
744 (defun let-convert (fun call)
745 (declare (type clambda fun) (type basic-combination call))
746 (let ((next-block (if (node-tail-p call)
747 nil
748 (insert-let-body fun call))))
749 (merge-lets fun call)
750 (move-return-stuff fun call next-block))
751
752 (maybe-remove-free-function fun)
753 (dolist (arg (basic-combination-args call))
754 (when arg
755 (reoptimize-continuation arg)))
756 (reoptimize-continuation (node-cont call))
757 (undefined-value))
758
759
760 ;;; Maybe-Let-Convert -- Interface
761 ;;;
762 ;;; This function is called when there is some reason to believe that
763 ;;; the lambda Fun might be converted into a let. This is done after local
764 ;;; call analysis, and also when a reference is deleted. We only convert to a
765 ;;; let when the function is a normal local function, has no XEP, and is
766 ;;; referenced in exactly one local call. Conversion is also inhibited if the
767 ;;; only reference is in a block about to be deleted. We return true if we
768 ;;; converted.
769 ;;;
770 ;;; These rules may seem unnecessarily restrictive, since there are some
771 ;;; cases where we could do the return with a jump that don't satisfy these
772 ;;; requirements. The reason for doing things this way is that it makes the
773 ;;; concept of a let much more useful at the level of IR1 semantics. The
774 ;;; :ASSIGNMENT function kind provides another way to optimize calls to
775 ;;; single-return/multiple call functions.
776 ;;;
777 ;;; We don't attempt to convert calls to functions that have an XEP, since
778 ;;; we might be embarrassed later when we want to convert a newly discovered
779 ;;; local call.
780 ;;;
781 (defun maybe-let-convert (fun)
782 (declare (type clambda fun))
783 (let ((refs (leaf-refs fun)))
784 (when (and refs (null (rest refs))
785 (member (functional-kind fun) '(nil :assignment))
786 (not (functional-entry-function fun)))
787 (let* ((ref-cont (node-cont (first refs)))
788 (dest (continuation-dest ref-cont)))
789 (when (and (basic-combination-p dest)
790 (eq (basic-combination-fun dest) ref-cont)
791 (eq (basic-combination-kind dest) :local)
792 (not (block-delete-p (node-block dest))))
793 (let-convert fun dest)
794 (setf (functional-kind fun)
795 (if (mv-combination-p dest) :mv-let :let))))
796 t)))
797
798
799 ;;;; Tail local calls and assignments:
800
801 ;;; ONLY-HARMLESS-CLEANUPS -- Internal
802 ;;;
803 ;;; Return T if there are no cleanups between Block1 and Block2, or if they
804 ;;; definitely won't generate any cleanup code. Currently we recognize lexical
805 ;;; entry points that are only used locally (if at all).
806 ;;;
807 (defun only-harmless-cleanups (block1 block2)
808 (declare (type cblock block1 block2))
809 (or (eq block1 block2)
810 (let ((cleanup2 (block-start-cleanup block2)))
811 (do ((cleanup (block-end-cleanup block1)
812 (node-enclosing-cleanup (cleanup-mess-up cleanup))))
813 ((eq cleanup cleanup2) t)
814 (case (cleanup-kind cleanup)
815 ((:block :tagbody)
816 (unless (null (entry-exits (cleanup-mess-up cleanup)))
817 (return nil)))
818 (t (return nil)))))))
819
820
821 ;;; MAYBE-CONVERT-TAIL-LOCAL-CALL -- Interface
822 ;;;
823 ;;; If possible, convert a tail-local call to jump directly to the called
824 ;;; function. We also call MAYBE-CONVERT-TO-ASSIGNMENT. We can switch the
825 ;;; succesor (potentially deleting the RETURN node) unless:
826 ;;; -- The call is in an XEP (thus we might decide to make it non-tail so that
827 ;;; we can use known return inside the component.)
828 ;;; -- There is a change in the cleanup between the call in the return, so we
829 ;;; might need to introduce cleanup code.
830 ;;;
831 (defun maybe-convert-tail-local-call (call)
832 (declare (type combination call))
833 (let ((return (continuation-dest (node-cont call))))
834 (assert (return-p return))
835 (when (and (not (node-tail-p call))
836 (not (eq (functional-kind (node-home-lambda call))
837 :external))
838 (only-harmless-cleanups (node-block call)
839 (node-block return)))
840 (node-ends-block call)
841 (let ((block (node-block call))
842 (fun (combination-lambda call)))
843 (setf (node-tail-p call) t)
844 (unlink-blocks block (first (block-succ block)))
845 (link-blocks block (node-block (lambda-bind fun)))
846 (values t (maybe-convert-to-assignment fun))))))
847
848
849 ;;; MAYBE-CONVERT-TO-ASSIGNMENT -- Interface
850 ;;;
851 ;;; Called when we believe it might make sense to convert Fun to an
852 ;;; assignment. We can convert when:
853 ;;; -- The function is a normal, non-entry function, and
854 ;;; -- There is at most one non-tail call (which must not be recursive), and
855 ;;; -- All calls are self-recursive or appear in at most one other function (so
856 ;;; we can be sure that we can merge all the code into a single
857 ;;; environment.)
858 ;;;
859 ;;; If there is one non-tail call, then we convert exactly like a let. If
860 ;;; there are no non-tail calls, then we merge the environments and deal with
861 ;;; the return.
862 ;;;
863 (defun maybe-convert-to-assignment (fun)
864 (declare (type clambda fun))
865 (when (and (not (functional-kind fun))
866 (not (functional-entry-function fun)))
867 (let ((non-tail nil)
868 (call-fun nil))
869 (when (dolist (ref (leaf-refs fun) t)
870 (let ((dest (continuation-dest (node-cont ref))))
871 (when (block-delete-p (node-block dest)) (return nil))
872 (let ((home (node-home-lambda ref)))
873 (unless (eq home fun)
874 (when call-fun (return nil))
875 (setq call-fun home))
876 (unless (node-tail-p dest)
877 (when (or non-tail (eq home fun)) (return nil))
878 (setq non-tail dest)))))
879 (let-convert fun (or non-tail
880 (continuation-dest
881 (node-cont (first (leaf-refs fun))))))
882 (setf (functional-kind fun) :assignment)
883 t))))

  ViewVC Help
Powered by ViewVC 1.1.5