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

Contents of /src/compiler/locall.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.59 - (show annotations)
Tue Oct 2 15:21:26 2007 UTC (6 years, 6 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2007-12, snapshot-2007-10, snapshot-2007-11
Changes since 1.58: +4 -1 lines
compiler/locall.lisp
o In MAYBE-CONVERT-TAIL-LOCAL-CALL, honor the notinline declaration
  when deciding if we can let convert a tail call.  This is useful for
  tracing of local functions.

code/debug-int.lisp:
o If we can't find a debug function, print a note that the (local)
  function might have been inlined.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/locall.lisp,v 1.59 2007/10/02 15:21:26 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file implements local call analysis. A local call is a function
13 ;;; call between functions being compiled at the same time. If we can tell at
14 ;;; compile time that such a call is legal, then we change the combination
15 ;;; to call the correct lambda, mark it as local, and add this link to our call
16 ;;; graph. Once a call is local, it is then eligible for let conversion, which
17 ;;; places the body of the function inline.
18 ;;;
19 ;;; We cannot always do a local call even when we do have the function being
20 ;;; called. Calls that cannot be shown to have legal arg counts are not
21 ;;; converted.
22 ;;;
23 ;;; Written by Rob MacLachlan
24 ;;;
25 (in-package :c)
26
27
28 ;;; Propagate-To-Args -- Interface
29 ;;;
30 ;;; This function propagates information from the variables in the function
31 ;;; Fun to the actual arguments in Call. This is also called by the VALUES IR1
32 ;;; optimizer when it sleazily converts MV-BINDs to LETs.
33 ;;;
34 ;;; We flush all arguments to Call that correspond to unreferenced variables
35 ;;; in Fun. We leave NILs in the Combination-Args so that the remaining args
36 ;;; still match up with their vars.
37 ;;;
38 ;;; We also apply the declared variable type assertion to the argument
39 ;;; continuations.
40 ;;;
41 (defun propagate-to-args (call fun)
42 (declare (type combination call) (type clambda fun))
43 (do ((args (basic-combination-args call) (cdr args))
44 (vars (lambda-vars fun) (cdr vars)))
45 ((null args))
46 (let ((arg (car args))
47 (var (car vars)))
48 (cond ((leaf-refs var)
49 (assert-continuation-optional-type arg (leaf-type var)))
50 (t
51 (flush-dest arg)
52 (setf (car args) nil)))))
53
54 (undefined-value))
55
56
57 ;;; Merge-Tail-Sets -- Interface
58 ;;;
59 ;;; This function handles merging the tail sets if Call is potentially
60 ;;; tail-recursive, and is a call to a function with a different TAIL-SET than
61 ;;; Call's Fun. This must be called whenever we alter IR1 so as to place a
62 ;;; local call in what might be a TR context. Note that any call which returns
63 ;;; its value to a RETURN is considered potentially TR, since any implicit
64 ;;; MV-PROG1 might be optimized away.
65 ;;;
66 ;;; We destructively modify the set for the calling function to represent both,
67 ;;; and then change all the functions in callee's set to reference the first.
68 ;;; If we do merge, we reoptimize the RETURN-RESULT continuation to cause
69 ;;; IR1-OPTIMIZE-RETURN to recompute the tail set type.
70 ;;;
71 (defun merge-tail-sets (call &optional (new-fun (combination-lambda call)))
72 (declare (type basic-combination call) (type clambda new-fun))
73 (let ((return (continuation-dest (node-cont call))))
74 (when (return-p return)
75 (let ((call-set (lambda-tail-set (node-home-lambda call)))
76 (fun-set (lambda-tail-set new-fun)))
77 (unless (eq call-set fun-set)
78 (let ((funs (tail-set-functions fun-set)))
79 (dolist (fun funs)
80 (setf (lambda-tail-set fun) call-set))
81 (setf (tail-set-functions call-set)
82 (nconc (tail-set-functions call-set) funs)))
83 (reoptimize-continuation (return-result return))
84 t)))))
85
86
87 ;;; Convert-Call -- Internal
88 ;;;
89 ;;; Convert a combination into a local call. We PROPAGATE-TO-ARGS, set the
90 ;;; combination kind to :Local, add Fun to the Calls of the function that the
91 ;;; call is in, call MERGE-TAIL-SETS, then replace the function in the Ref node
92 ;;; with the new function.
93 ;;;
94 ;;; We change the Ref last, since changing the reference can trigger let
95 ;;; conversion of the new function, but will only do so if the call is local.
96 ;;; Note that the replacement may trigger let conversion or other changes in
97 ;;; IR1. We must call MERGE-TAIL-SETS with NEW-FUN before the substitution,
98 ;;; since after the substitution (and let conversion), the call may no longer
99 ;;; be recognizable as tail-recursive.
100 ;;;
101 (defun convert-call (ref call fun)
102 (declare (type ref ref) (type combination call) (type clambda fun))
103 (propagate-to-args call fun)
104 (setf (basic-combination-kind call) :local)
105 (note-dfo-dependency call fun)
106 (merge-tail-sets call fun)
107 (change-ref-leaf ref fun)
108 (undefined-value))
109
110
111 ;;;; External entry point creation:
112
113 ;;; Make-XEP-Lambda -- Internal
114 ;;;
115 ;;; Return a Lambda form that can be used as the definition of the XEP for
116 ;;; Fun.
117 ;;;
118 ;;; If Fun is a lambda, then we check the number of arguments (conditional
119 ;;; on policy) and call Fun with all the arguments.
120 ;;;
121 ;;; If Fun is an Optional-Dispatch, then we dispatch off of the number of
122 ;;; supplied arguments by doing do an = test for each entry-point, calling the
123 ;;; entry with the appropriate prefix of the passed arguments.
124 ;;;
125 ;;; If there is a more arg, then there are a couple of optimizations that we
126 ;;; make (more for space than anything else):
127 ;;; -- If Min-Args is 0, then we make the more entry a T clause, since no
128 ;;; argument count error is possible.
129 ;;; -- We can omit the = clause for the last entry-point, allowing the case of
130 ;;; 0 more args to fall through to the more entry.
131 ;;;
132 ;;; We don't bother to policy conditionalize wrong arg errors in optional
133 ;;; dispatches, since the additional overhead is negligible compared to the
134 ;;; other hair going down.
135 ;;;
136 ;;; Note that if policy indicates it, argument type declarations in Fun will
137 ;;; be verified. Since nothing is known about the type of the XEP arg vars,
138 ;;; type checks will be emitted when the XEP's arg vars are passed to the
139 ;;; actual function.
140 ;;;
141 (defun make-xep-lambda (fun)
142 (declare (type functional fun))
143 (etypecase fun
144 (clambda
145 (let ((nargs (length (lambda-vars fun)))
146 (n-supplied (gensym)))
147 (collect ((temps))
148 (dotimes (i nargs)
149 (temps (gensym)))
150 `(lambda (,n-supplied ,@(temps))
151 (declare (type index ,n-supplied))
152 ,(if (policy nil (zerop safety))
153 `(declare (ignore ,n-supplied))
154 `(%verify-argument-count ,n-supplied ,nargs))
155 (%funcall ,fun ,@(temps))))))
156 (optional-dispatch
157 (let* ((min (optional-dispatch-min-args fun))
158 (max (optional-dispatch-max-args fun))
159 (more (optional-dispatch-more-entry fun))
160 (n-supplied (gensym)))
161 (collect ((temps)
162 (entries))
163 (dotimes (i max)
164 (temps (gensym)))
165
166 (do ((eps (optional-dispatch-entry-points fun) (rest eps))
167 (n min (1+ n)))
168 ((null eps))
169 (entries `((= ,n-supplied ,n)
170 (%funcall ,(first eps) ,@(subseq (temps) 0 n)))))
171
172 `(lambda (,n-supplied ,@(temps))
173 (declare (type index ,n-supplied))
174 (cond
175 ,@(if more (butlast (entries)) (entries))
176 ,@(when more
177 `((,(if (zerop min) 't `(>= ,n-supplied ,max))
178 ,(let ((n-context (gensym))
179 (n-count (gensym)))
180 `(multiple-value-bind
181 (,n-context ,n-count)
182 (%more-arg-context ,n-supplied ,max)
183 (%funcall ,more ,@(temps) ,n-context ,n-count))))))
184 (t
185 (%argument-count-error ,n-supplied)))))))))
186
187
188 ;;; Make-External-Entry-Point -- Internal
189 ;;;
190 ;;; Make an external entry point (XEP) for Fun and return it. We convert
191 ;;; the result of Make-XEP-Lambda in the correct environment, then associate
192 ;;; this lambda with Fun as its XEP. After the conversion, we iterate over the
193 ;;; function's associated lambdas, redoing local call analysis so that the XEP
194 ;;; calls will get converted. We also bind *lexical-environment* to change the
195 ;;; compilation policy over to the interface policy.
196 ;;;
197 ;;; We set Reanalyze and Reoptimize in the component, just in case we
198 ;;; discover an XEP after the initial local call analyze pass.
199 ;;;
200 (defun make-external-entry-point (fun)
201 (declare (type functional fun))
202 (assert (not (functional-entry-function fun)))
203 (with-ir1-environment (lambda-bind (main-entry fun))
204 (let* ((*lexical-environment*
205 (make-lexenv :cookie
206 (make-interface-cookie *lexical-environment*)))
207 (res (ir1-convert-lambda (make-xep-lambda fun))))
208 (setf (functional-kind res) :external)
209 (setf (leaf-ever-used res) t)
210 (setf (functional-entry-function res) fun)
211 (setf (functional-entry-function fun) res)
212 (setf (component-reanalyze *current-component*) t)
213 (setf (component-reoptimize *current-component*) t)
214 (etypecase fun
215 (clambda (local-call-analyze-1 fun))
216 (optional-dispatch
217 (dolist (ep (optional-dispatch-entry-points fun))
218 (local-call-analyze-1 ep))
219 (when (optional-dispatch-more-entry fun)
220 (local-call-analyze-1 (optional-dispatch-more-entry fun)))))
221 res)))
222
223
224 ;;; Reference-Entry-Point -- Internal
225 ;;;
226 ;;; Notice a Ref that is not in a local-call context. If the Ref is already
227 ;;; to an XEP, then do nothing, otherwise change it to the XEP, making an XEP
228 ;;; if necessary.
229 ;;;
230 ;;; If Ref is to a special :Cleanup or :Escape function, then we treat it as
231 ;;; though it was not an XEP reference (i.e. leave it alone.)
232 ;;;
233 (defun reference-entry-point (ref)
234 (declare (type ref ref))
235 (let ((fun (ref-leaf ref)))
236 (unless (or (external-entry-point-p fun)
237 (member (functional-kind fun) '(:escape :cleanup)))
238 (change-ref-leaf ref (or (functional-entry-function fun)
239 (make-external-entry-point fun))))))
240
241
242
243 ;;; Local-Call-Analyze-1 -- Interface
244 ;;;
245 ;;; Attempt to convert all references to Fun to local calls. The reference
246 ;;; must be the function for a call, and the function continuation must be used
247 ;;; only once, since otherwise we cannot be sure what function is to be called.
248 ;;; The call continuation would be multiply used if there is hairy stuff such
249 ;;; as conditionals in the expression that computes the function.
250 ;;;
251 ;;; If we cannot convert a reference, then we mark the referenced function
252 ;;; as an entry-point, creating a new XEP if necessary. We don't try to
253 ;;; convert calls that are in error (:ERROR kind.)
254 ;;;
255 ;;; This is broken off from Local-Call-Analyze so that people can force
256 ;;; analysis of newly introduced calls. Note that we don't do let conversion
257 ;;; here.
258 ;;;
259 (defun local-call-analyze-1 (fun)
260 (declare (type functional fun))
261 (let ((refs (leaf-refs fun))
262 (first-time t))
263 (dolist (ref refs)
264 (let* ((cont (node-cont ref))
265 (dest (continuation-dest cont)))
266 (cond ((and (basic-combination-p dest)
267 (eq (basic-combination-fun dest) cont)
268 (eq (continuation-use cont) ref))
269
270 (convert-call-if-possible ref dest)
271
272 (unless (eq (basic-combination-kind dest) :local)
273 (reference-entry-point ref)))
274 (t
275 (reference-entry-point ref))))
276 (setq first-time nil)))
277
278 (undefined-value))
279
280
281 ;;; Local-Call-Analyze -- Interface
282 ;;;
283 ;;; We examine all New-Functions in component, attempting to convert calls
284 ;;; into local calls when it is legal. We also attempt to convert each lambda
285 ;;; to a let. Let conversion is also triggered by deletion of a function
286 ;;; reference, but functions that start out eligible for conversion must be
287 ;;; noticed sometime.
288 ;;;
289 ;;; Note that there is a lot of action going on behind the scenes here,
290 ;;; triggered by reference deletion. In particular, the Component-Lambdas are
291 ;;; being hacked to remove newly deleted and let converted lambdas, so it is
292 ;;; important that the lambda is added to the Component-Lambdas when it is.
293 ;;; Also, the COMPONENT-NEW-FUNCTIONS may contain all sorts of drivel, since it
294 ;;; is not updated when we delete functions, etc. Only COMPONENT-LAMBDAS is
295 ;;; updated.
296 ;;;
297 ;;; COMPONENT-REANALYZE-FUNCTIONS is treated similarly to NEW-FUNCTIONS, but we
298 ;;; don't add lambdas to the LAMBDAS.
299 ;;;
300 (defun local-call-analyze (component)
301 (declare (type component component))
302 (loop
303 (let* ((new (pop (component-new-functions component)))
304 (fun (or new (pop (component-reanalyze-functions component)))))
305 (unless fun (return))
306 (let ((kind (functional-kind fun)))
307 (cond ((member kind '(:deleted :let :mv-let :assignment)))
308 ((and (null (leaf-refs fun)) (eq kind nil)
309 (not (functional-entry-function fun)))
310 (delete-functional fun))
311 (t
312 (when (and new (lambda-p fun))
313 (push fun (component-lambdas component)))
314 (local-call-analyze-1 fun)
315 (when (lambda-p fun)
316 (maybe-let-convert fun)))))))
317
318 (undefined-value))
319
320
321 ;;; MAYBE-EXPAND-LOCAL-INLINE -- Internal
322 ;;;
323 ;;; If policy is auspicious, Call is not in an XEP, and we don't seem to be
324 ;;; in an infinite recursive loop, then change the reference to reference a
325 ;;; fresh copy. We return whichever function we decide to reference.
326 ;;;
327 (defun maybe-expand-local-inline (fun ref call)
328 (if (and (policy call (>= speed space) (>= speed cspeed))
329 (not (eq (functional-kind (node-home-lambda call)) :external))
330 (not *converting-for-interpreter*)
331 (inline-expansion-ok call))
332 (with-ir1-environment call
333 (let* ((*lexical-environment* (functional-lexenv fun))
334 (won nil)
335 (res (catch 'local-call-lossage
336 (prog1
337 (ir1-convert-lambda (functional-inline-expansion fun))
338 (setq won t)))))
339 (cond (won
340 (change-ref-leaf ref res)
341 res)
342 (t
343 (let ((*compiler-error-context* call))
344 (compiler-note "Couldn't inline expand because expansion ~
345 calls this let-converted local function:~
346 ~% ~S"
347 (leaf-name res)))
348 fun))))
349 fun))
350
351
352 ;;; Convert-Call-If-Possible -- Interface
353 ;;;
354 ;;; Dispatch to the appropriate function to attempt to convert a call. Ref
355 ;;; most be a reference to a FUNCTIONAL. This is called in IR1 optimize as
356 ;;; well as in local call analysis. If the call is is already :Local, we do
357 ;;; nothing. If the call is already scheduled for deletion, also do nothing
358 ;;; (in addition to saving time, this also avoids some problems with optimizing
359 ;;; collections of functions that are partially deleted.)
360 ;;;
361 ;;; This is called both before and after FIND-INITIAL-DFO runs. When called
362 ;;; on a :INITIAL component, we don't care whether the caller and callee are in
363 ;;; the same component. Afterward, we must stick with whatever component
364 ;;; division we have chosen.
365 ;;;
366 ;;; Before attempting to convert a call, we see if the function is supposed
367 ;;; to be inline expanded. Call conversion proceeds as before after any
368 ;;; expansion.
369 ;;;
370 ;;; We bind *Compiler-Error-Context* to the node for the call so that
371 ;;; warnings will get the right context.
372 ;;;
373 ;;;
374 (defun convert-call-if-possible (ref call)
375 (declare (type ref ref) (type basic-combination call))
376 (let* ((block (node-block call))
377 (component (block-component block))
378 (original-fun (ref-leaf ref)))
379 (assert (functional-p original-fun))
380 (unless (or (member (basic-combination-kind call) '(:local :error))
381 (block-delete-p block)
382 (eq (functional-kind (block-home-lambda block)) :deleted)
383 (member (functional-kind original-fun)
384 '(:top-level-xep :deleted))
385 (not (or (eq (component-kind component) :initial)
386 (eq (block-component
387 (node-block
388 (lambda-bind (main-entry original-fun))))
389 component))))
390 (let ((fun (if (external-entry-point-p original-fun)
391 (functional-entry-function original-fun)
392 original-fun))
393 (*compiler-error-context* call))
394
395 (when (and (eq (functional-inlinep fun) :inline)
396 (rest (leaf-refs original-fun)))
397 (setq fun (maybe-expand-local-inline fun ref call)))
398
399 (assert (member (functional-kind fun)
400 '(nil :escape :cleanup :optional)))
401 (cond ((mv-combination-p call)
402 (convert-mv-call ref call fun))
403 ((lambda-p fun)
404 (convert-lambda-call ref call fun))
405 (t
406 (convert-hairy-call ref call fun))))))
407
408 (undefined-value))
409
410
411 ;;; Convert-MV-Call -- Internal
412 ;;;
413 ;;; Attempt to convert a multiple-value call. The only interesting case is
414 ;;; a call to a function that Looks-Like-An-MV-Bind, has exactly one reference
415 ;;; and no XEP, and is called with one values continuation.
416 ;;;
417 ;;; We change the call to be to the last optional entry point and change the
418 ;;; call to be local. Due to our preconditions, the call should eventually be
419 ;;; converted to a let, but we can't do that now, since there may be stray
420 ;;; references to the e-p lambda due to optional defaulting code.
421 ;;;
422 ;;; We also use variable types for the called function to construct an
423 ;;; assertion for the values continuation.
424 ;;;
425 ;;; See CONVERT-CALL for additional notes on MERGE-TAIL-SETS, etc.
426 ;;;
427 (defun convert-mv-call (ref call fun)
428 (declare (type ref ref) (type mv-combination call) (type functional fun))
429 (when (and (looks-like-an-mv-bind fun)
430 (not (functional-entry-function fun))
431 (= (length (leaf-refs fun)) 1)
432 (= (length (basic-combination-args call)) 1))
433 (let ((ep (car (last (optional-dispatch-entry-points fun)))))
434 (setf (basic-combination-kind call) :local)
435 (note-dfo-dependency call ep)
436 (merge-tail-sets call ep)
437 (change-ref-leaf ref ep)
438
439 (assert-continuation-type
440 (first (basic-combination-args call))
441 (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
442 :rest *universal-type*))))
443 (undefined-value))
444
445
446 ;;; Convert-Lambda-Call -- Internal
447 ;;;
448 ;;; Attempt to convert a call to a lambda. If the number of args is wrong,
449 ;;; we give a warning and mark the call as :ERROR to remove it from future
450 ;;; consideration. If the argcount is O.K. then we just convert it.
451 ;;;
452 (defun convert-lambda-call (ref call fun)
453 (declare (type ref ref) (type combination call) (type clambda fun))
454 (let ((nargs (length (lambda-vars fun)))
455 (call-args (length (combination-args call))))
456 (cond ((= call-args nargs)
457 (convert-call ref call fun))
458 (t
459 (compiler-warning
460 "Function called with ~R argument~:P, but wants exactly ~R."
461 call-args nargs)
462 (setf (basic-combination-kind call) :error)))))
463
464
465
466 ;;;; Optional, more and keyword calls:
467
468 ;;; Convert-Hairy-Call -- Internal
469 ;;;
470 ;;; Similar to Convert-Lambda-Call, but deals with Optional-Dispatches. If
471 ;;; only fixed args are supplied, then convert a call to the correct entry
472 ;;; point. If keyword args are supplied, then dispatch to a subfunction. We
473 ;;; don't convert calls to functions that have a more (or rest) arg.
474 ;;;
475 (defun convert-hairy-call (ref call fun)
476 (declare (type ref ref) (type combination call)
477 (type optional-dispatch fun))
478 (let ((min-args (optional-dispatch-min-args fun))
479 (max-args (optional-dispatch-max-args fun))
480 (call-args (length (combination-args call))))
481 (cond ((< call-args min-args)
482 (compiler-warning "Function called with ~R argument~:P, but wants at least ~R."
483 call-args min-args)
484 (setf (basic-combination-kind call) :error))
485 ((<= call-args max-args)
486 (convert-call ref call
487 (elt (optional-dispatch-entry-points fun)
488 (- call-args min-args))))
489 ((optional-dispatch-more-entry fun)
490 (convert-more-call ref call fun))
491 (t
492 (compiler-warning "Function called with ~R argument~:P, but wants at most ~R."
493 call-args max-args)
494 (setf (basic-combination-kind call) :error))))
495 (undefined-value))
496
497
498 ;;; Convert-Hairy-Fun-Entry -- Internal
499 ;;;
500 ;;; This function is used to convert a call to an entry point when complex
501 ;;; transformations need to be done on the original arguments. Entry is the
502 ;;; entry point function that we are calling. Vars is a list of variable names
503 ;;; which are bound to the oringinal call arguments. Ignores is the subset of
504 ;;; Vars which are ignored. Args is the list of arguments to the entry point
505 ;;; function.
506 ;;;
507 ;;; In order to avoid gruesome graph grovelling, we introduce a new function
508 ;;; that rearranges the arguments and calls the entry point. We analyze the
509 ;;; new function and the entry point immediately so that everything gets
510 ;;; converted during the single pass.
511 ;;;
512 (defun convert-hairy-fun-entry (ref call entry vars ignores args)
513 (declare (list vars ignores args) (type ref ref) (type combination call)
514 (type clambda entry))
515 (let ((new-fun
516 (with-ir1-environment call
517 (ir1-convert-lambda
518 `(lambda ,vars
519 (declare (ignorable . ,ignores))
520 (%funcall ,entry . ,args))))))
521 (convert-call ref call new-fun)
522 (dolist (ref (leaf-refs entry))
523 (convert-call-if-possible ref (continuation-dest (node-cont ref))))))
524
525
526 ;;; Convert-More-Call -- Internal
527 ;;;
528 ;;; Use Convert-Hairy-Fun-Entry to convert a more-arg call to a known
529 ;;; function into a local call to the Main-Entry.
530 ;;;
531 ;;; First we verify that all keywords are constant and legal. If there
532 ;;; aren't, then we warn the user and don't attempt to convert the call.
533 ;;;
534 ;;; We massage the supplied keyword arguments into the order expected by the
535 ;;; main entry. This is done by binding all the arguments to the keyword call
536 ;;; to variables in the introduced lambda, then passing these values variables
537 ;;; in the correct order when calling the main entry. Unused arguments
538 ;;; (such as the keywords themselves) are discarded simply by not passing them
539 ;;; along.
540 ;;;
541 ;;; If there is a rest arg, then we bundle up the args and pass them to
542 ;;; LIST.
543 ;;;
544 (defun convert-more-call (ref call fun)
545 (declare (type ref ref) (type combination call) (type optional-dispatch fun))
546 (let* ((max (optional-dispatch-max-args fun))
547 (arglist (optional-dispatch-arglist fun))
548 (args (combination-args call))
549 (more (nthcdr max args))
550 (flame (policy call (or (> speed brevity) (> space brevity))))
551 (loser nil)
552 (allowp nil)
553 (allow-found nil))
554 (collect ((temps)
555 (more-temps)
556 (ignores)
557 (supplied)
558 (key-vars))
559
560 (dolist (var arglist)
561 (let ((info (lambda-var-arg-info var)))
562 (when info
563 (ecase (arg-info-kind info)
564 (:keyword
565 (key-vars var))
566 ((:rest :optional))
567 ((:more-context :more-count)
568 (compiler-warning "Can't local-call functions with &MORE args.")
569 (setf (basic-combination-kind call) :error)
570 (return-from convert-more-call))))))
571
572 (dotimes (i max)
573 (temps (gensym "FIXED-ARG-TEMP-")))
574
575 (dotimes (i (length more))
576 (more-temps (gensym "MORE-ARG-TEMP-")))
577
578 (when (optional-dispatch-keyp fun)
579 (when (oddp (length more))
580 (compiler-warning "Function called with odd number of ~
581 arguments in keyword portion.")
582
583 (setf (basic-combination-kind call) :error)
584 (return-from convert-more-call))
585
586 (do ((key more (cddr key))
587 (temp (more-temps) (cddr temp)))
588 ((null key))
589 (let ((cont (first key)))
590 (unless (constant-continuation-p cont)
591 (when flame
592 (compiler-note "Non-constant keyword in keyword call."))
593 (setf (basic-combination-kind call) :error)
594 (return-from convert-more-call))
595
596 (let ((name (continuation-value cont))
597 (dummy (first temp))
598 (val (second temp)))
599 ;; FIXME: check whether KEY was supplied earlier
600 (when (and (eq name :allow-other-keys) (not allow-found))
601 (let ((val (second key)))
602 (cond ((constant-continuation-p val)
603 (setq allow-found t
604 allowp (continuation-value val)))
605 (t
606 (when flame
607 (compiler-note "non-constant :ALLOW-OTHER-KEYS value"))
608 (setf (basic-combination-kind call) :error)
609 (return-from convert-more-call)))))
610 (dolist (var (key-vars)
611 (progn
612 (ignores dummy val)
613 (unless (eq name :allow-other-keys)
614 ;; Listify the name in case the keyword
615 ;; name is nil, so we can distinguish
616 ;; between NIL as a keyword and loser
617 ;; being empty.
618 (setq loser (list name)))))
619 (let ((info (lambda-var-arg-info var)))
620 (when (eq (arg-info-keyword info) name)
621 (ignores dummy)
622 (supplied (cons var val))
623 (return)))))))
624
625 (when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
626 (compiler-warning "Function called with unknown argument keyword ~S."
627 (car loser))
628 (setf (basic-combination-kind call) :error)
629 (return-from convert-more-call)))
630
631 (collect ((call-args))
632 (do ((var arglist (cdr var))
633 (temp (temps) (cdr temp)))
634 ((null var))
635 (let ((info (lambda-var-arg-info (car var))))
636 (if info
637 (ecase (arg-info-kind info)
638 (:optional
639 (call-args (car temp))
640 (when (arg-info-supplied-p info)
641 (call-args t)))
642 (:rest
643 ;;
644 ;; We could do something here if the variable is
645 ;; declared dynamic-extent.
646 (call-args `(list ,@(more-temps)))
647 (return))
648 (:keyword
649 (return)))
650 (call-args (car temp)))))
651
652 (dolist (var (key-vars))
653 (let ((info (lambda-var-arg-info var))
654 (temp (cdr (assoc var (supplied)))))
655 (if temp
656 (call-args temp)
657 (call-args (arg-info-default info)))
658 (when (arg-info-supplied-p info)
659 (call-args (not (null temp))))))
660
661 (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
662 (append (temps) (more-temps))
663 (ignores) (call-args)))))
664
665 (undefined-value))
666
667
668 ;;;; Let conversion:
669 ;;;
670 ;;; Converting to a let has differing significance to various parts of the
671 ;;; compiler:
672 ;;; -- The body of a Let is spliced in immediately after the corresponding
673 ;;; combination node, making the control transfer explicit and allowing lets
674 ;;; to mashed together into a single block. The value of the let is
675 ;;; delivered directly to the original continuation for the call,
676 ;;; eliminating the need to propagate information from the dummy result
677 ;;; continuation.
678 ;;; -- As far as IR1 optimization is concerned, it is interesting in that there
679 ;;; is only one expression that the variable can be bound to, and this is
680 ;;; easily substitited for.
681 ;;; -- Lets are interesting to environment analysis and the back end because in
682 ;;; most ways a let can be considered to be "the same function" as its home
683 ;;; function.
684 ;;; -- Let conversion has dynamic scope implications, since control transfers
685 ;;; within the same environment are local. In a local control transfer,
686 ;;; cleanup code must be emitted to remove dynamic bindings that are no
687 ;;; longer in effect.
688
689
690 ;;; Insert-Let-Body -- Internal
691 ;;;
692 ;;; Set up the control transfer to the called lambda. We split the call
693 ;;; block immediately after the call, and link the head of Fun to the call
694 ;;; block. The successor block after splitting (where we return to) is
695 ;;; returned.
696 ;;;
697 ;;; If the lambda is is a different component than the call, then we call
698 ;;; JOIN-COMPONENTS. This only happens in block compilation before
699 ;;; FIND-INITIAL-DFO.
700 ;;;
701 (defun insert-let-body (fun call)
702 (declare (type clambda fun) (type basic-combination call))
703 (let* ((call-block (node-block call))
704 (bind-block (node-block (lambda-bind fun)))
705 (component (block-component call-block)))
706 (let ((fun-component (block-component bind-block)))
707 (unless (eq fun-component component)
708 (assert (eq (component-kind component) :initial))
709 (join-components component fun-component)))
710
711 (let ((*current-component* component))
712 (node-ends-block call))
713 (assert (= (length (block-succ call-block)) 1))
714 (let ((next-block (first (block-succ call-block))))
715 (unlink-blocks call-block next-block)
716 (link-blocks call-block bind-block)
717 next-block)))
718
719
720 ;;; Merge-Lets -- Internal
721 ;;;
722 ;;; Handle the environment semantics of let conversion. We add the lambda
723 ;;; and its lets to lets for the Call's home function. We merge the calls for
724 ;;; Fun with the calls for the home function, removing Fun in the process. We
725 ;;; also merge the Entries.
726 ;;;
727 ;;; We also unlink the function head from the component head and set
728 ;;; Component-Reanalyze to true to indicate that the DFO should be recomputed.
729 ;;;
730 (defun merge-lets (fun call)
731 (declare (type clambda fun) (type basic-combination call))
732 (let ((component (block-component (node-block call))))
733 (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
734 (setf (component-lambdas component)
735 (delete fun (component-lambdas component)))
736 (setf (component-reanalyze component) t))
737 (setf (lambda-call-lexenv fun) (node-lexenv call))
738 (let ((tails (lambda-tail-set fun)))
739 (setf (tail-set-functions tails)
740 (delete fun (tail-set-functions tails))))
741 (setf (lambda-tail-set fun) nil)
742 (let* ((home (node-home-lambda call))
743 (home-env (lambda-environment home)))
744
745 (assert (not (eq home fun)))
746
747 ;; FUN belongs to HOME now.
748 (push fun (lambda-lets home))
749 (setf (lambda-home fun) home)
750 (setf (lambda-environment fun) home-env)
751
752 ;; All of FUN's LETs belong to HOME now
753 (let ((lets (lambda-lets fun)))
754 (dolist (let lets)
755 (setf (lambda-home let) home)
756 (setf (lambda-environment let) home-env))
757
758 (setf (lambda-lets home) (nconc lets (lambda-lets home)))
759 ;; FUN no longer has an independent existence as an entity which
760 ;; has LETs.
761 (setf (lambda-lets fun) ()))
762
763 ;; HOME no longer calls FUN, and owns all of FUN's old DFO
764 ;; dependencies
765 (setf (lambda-dfo-dependencies home)
766 (delete fun (nunion (lambda-dfo-dependencies fun)
767 (lambda-dfo-dependencies home))))
768 ;; FUN no longer has an independent existence as an entity
769 ;; which calls things or has DFO dependencies.
770 (setf (lambda-dfo-dependencies fun) ())
771
772 ;; All of FUN's ENTRIES belong to HOME now.
773 (setf (lambda-entries home)
774 (nconc (lambda-entries fun) (lambda-entries home)))
775 ;; FUN no longer has an independent existence as an entity
776 ;; with ENTRIES.
777 (setf (lambda-entries fun) ()))
778 (undefined-value))
779
780
781 ;;; Move-Return-Uses -- Internal
782 ;;;
783 ;;; Handle the value semantics of let conversion. Delete Fun's return node,
784 ;;; and change the control flow to transfer to Next-Block instead. Move all
785 ;;; the uses of the result continuation to Call's Cont.
786 ;;;
787 ;;; If the actual continuation is only used by the let call, then we
788 ;;; intersect the type assertion on the dummy continuation with the assertion
789 ;;; for the actual continuation; in all other cases assertions on the dummy
790 ;;; continuation are lost.
791 ;;;
792 ;;; We also intersect the derived type of the call with the derived type of
793 ;;; all the dummy continuation's uses. This serves mainly to propagate
794 ;;; TRULY-THE through lets.
795 ;;;
796 (defun move-return-uses (fun call next-block)
797 (declare (type clambda fun) (type basic-combination call)
798 (type cblock next-block))
799 (let* ((return (lambda-return fun))
800 (return-block (node-block return)))
801 (unlink-blocks return-block
802 (component-tail (block-component return-block)))
803 (link-blocks return-block next-block)
804 (unlink-node return)
805 (delete-return return)
806 (let ((result (return-result return))
807 (cont (node-cont call))
808 (call-type (node-derived-type call)))
809 (when (eq (continuation-use cont) call)
810 (assert-continuation-type cont (continuation-asserted-type result)))
811 (unless (eq call-type *wild-type*)
812 (do-uses (use result)
813 (derive-node-type use call-type)))
814 (substitute-continuation-uses cont result)))
815 (undefined-value))
816
817
818
819 ;;; MOVE-LET-CALL-CONT -- Internal
820 ;;;
821 ;;; Change all Cont for all the calls to Fun to be the start continuation
822 ;;; for the bind node. This allows the blocks to be joined if the caller count
823 ;;; ever goes to one.
824 ;;;
825 (defun move-let-call-cont (fun)
826 (declare (type clambda fun))
827 (let ((new-cont (node-prev (lambda-bind fun))))
828 (dolist (ref (leaf-refs fun))
829 (let ((dest (continuation-dest (node-cont ref))))
830 (delete-continuation-use dest)
831 (add-continuation-use dest new-cont))))
832 (undefined-value))
833
834
835 ;;; Unconvert-Tail-Calls -- Internal
836 ;;;
837 ;;; We are converting Fun to be a let when the call is in a non-tail
838 ;;; position. Any previously tail calls in Fun are no longer tail calls, and
839 ;;; must be restored to normal calls which transfer to Next-Block (Fun's
840 ;;; return point.) We can't do this by DO-USES on the RETURN-RESULT, because
841 ;;; the return might have been deleted (if all calls were TR.)
842 ;;;
843 ;;; The called function might be an assignment in the case where we are
844 ;;; currently converting that function. In steady-state, assignments never
845 ;;; appear in the lambda-dfo-dependencies.
846 ;;;
847 (defun unconvert-tail-calls (fun call next-block)
848 (dolist (called (lambda-dfo-dependencies fun))
849 (when (lambda-p called)
850 (dolist (ref (leaf-refs called))
851 (let ((this-call (continuation-dest (node-cont ref))))
852 (when (and this-call
853 (node-tail-p this-call)
854 (eq (node-home-lambda this-call) fun))
855 (setf (node-tail-p this-call) nil)
856 (ecase (functional-kind called)
857 ((nil :cleanup :optional)
858 (let ((block (node-block this-call))
859 (cont (node-cont call)))
860 (ensure-block-start cont)
861 (unlink-blocks block (first (block-succ block)))
862 (link-blocks block next-block)
863 (delete-continuation-use this-call)
864 (add-continuation-use this-call cont)))
865 (:deleted)
866 (:assignment
867 (assert (eq called fun)))))))))
868 (values))
869
870
871 ;;; MOVE-RETURN-STUFF -- Internal
872 ;;;
873 ;;; Deal with returning from a let or assignment that we are converting.
874 ;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK
875 ;;; is the return point for a non-tail call, or NULL if call is a tail call.
876 ;;;
877 ;;; If the call is not a tail call, then we must do UNCONVERT-TAIL-CALLS, since
878 ;;; a tail call is a call which returns its value out of the enclosing non-let
879 ;;; function. When call is non-TR, we must convert it back to an ordinary
880 ;;; local call, since the value must be delivered to the receiver of CALL's
881 ;;; value.
882 ;;;
883 ;;; We do different things depending on whether the caller and callee have
884 ;;; returns left:
885 ;;; -- If the callee has no return we just do MOVE-LET-CALL-CONT. Either the
886 ;;; function doesn't return, or all returns are via tail-recursive local
887 ;;; calls.
888 ;;; -- If CALL is a non-tail call, or if both have returns, then we
889 ;;; delete the callee's return, move its uses to the call's result
890 ;;; continuation, and transfer control to the appropriate return point.
891 ;;; -- If the callee has a return, but the caller doesn't, then we move the
892 ;;; return to the caller.
893 ;;;
894 (defun move-return-stuff (fun call next-block)
895 (declare (type clambda fun) (type basic-combination call)
896 (type (or cblock null) next-block))
897 (when next-block
898 (unconvert-tail-calls fun call next-block))
899 (let* ((return (lambda-return fun))
900 (call-fun (node-home-lambda call))
901 (call-return (lambda-return call-fun)))
902 (cond ((not return))
903 ((or next-block call-return)
904 (unless (block-delete-p (node-block return))
905 (move-return-uses fun call
906 (or next-block (node-block call-return)))))
907 (t
908 (assert (node-tail-p call))
909 (setf (lambda-return call-fun) return)
910 (setf (return-lambda return) call-fun))))
911 (move-let-call-cont fun)
912 (undefined-value))
913
914
915 ;;; Let-Convert -- Internal
916 ;;;
917 ;;; Actually do let conversion. We call subfunctions to do most of the
918 ;;; work. We change the Call's cont to be the continuation heading the bind
919 ;;; block, and also do Reoptimize-Continuation on the args and Cont so that
920 ;;; let-specific IR1 optimizations get a chance. We blow away any entry for
921 ;;; the function in *free-functions* so that nobody will create new reference
922 ;;; to it.
923 ;;;
924 (defun let-convert (fun call)
925 (declare (type clambda fun) (type basic-combination call))
926 (let ((next-block (if (node-tail-p call)
927 nil
928 (insert-let-body fun call))))
929 (move-return-stuff fun call next-block)
930 (merge-lets fun call)))
931
932
933 ;;; REOPTIMIZE-CALL -- Internal
934 ;;;
935 ;;; Reoptimize all of Call's args and its result.
936 ;;;
937 (defun reoptimize-call (call)
938 (declare (type basic-combination call))
939 (dolist (arg (basic-combination-args call))
940 (when arg
941 (reoptimize-continuation arg)))
942 (reoptimize-continuation (node-cont call))
943 (undefined-value))
944
945 ;;; OK-INITIAL-CONVERT-P -- Internal
946 ;;;
947 ;;; We also don't convert calls to named functions which appear in the initial
948 ;;; component, delaying this until optimization. This minimizes the likelyhood
949 ;;; that we well let-convert a function which may have references added due to
950 ;;; later local inline expansion
951 ;;;
952 (defun ok-initial-convert-p (fun)
953 (not (and (leaf-name fun)
954 (eq (component-kind
955 (block-component
956 (node-block (lambda-bind fun))))
957 :initial))))
958
959
960 ;;; Maybe-Let-Convert -- Interface
961 ;;;
962 ;;; This function is called when there is some reason to believe that
963 ;;; the lambda Fun might be converted into a let. This is done after local
964 ;;; call analysis, and also when a reference is deleted. We only convert to a
965 ;;; let when the function is a normal local function, has no XEP, and is
966 ;;; referenced in exactly one local call. Conversion is also inhibited if the
967 ;;; only reference is in a block about to be deleted. We return true if we
968 ;;; converted.
969 ;;;
970 ;;; These rules may seem unnecessarily restrictive, since there are some
971 ;;; cases where we could do the return with a jump that don't satisfy these
972 ;;; requirements. The reason for doing things this way is that it makes the
973 ;;; concept of a let much more useful at the level of IR1 semantics. The
974 ;;; :ASSIGNMENT function kind provides another way to optimize calls to
975 ;;; single-return/multiple call functions.
976 ;;;
977 ;;; We don't attempt to convert calls to functions that have an XEP, since
978 ;;; we might be embarrassed later when we want to convert a newly discovered
979 ;;; local call. Also, see OK-INITIAL-CONVERT-P.
980 ;;;
981 (defun maybe-let-convert (fun)
982 (declare (type clambda fun))
983 (let ((refs (leaf-refs fun)))
984 (when (and refs (null (rest refs))
985 (member (functional-kind fun) '(nil :assignment))
986 (not (functional-entry-function fun)))
987 (let* ((ref-cont (node-cont (first refs)))
988 (call (continuation-dest ref-cont)))
989 (when (and call
990 (basic-combination-p call)
991 (eq (basic-combination-fun call) ref-cont)
992 (eq (basic-combination-kind call) :local)
993 (not (block-delete-p (node-block call)))
994 ;;
995 ;; Gross hack. Shouldn't happen that the call has
996 ;; no successors, but it does happen when Python
997 ;; eliminates dead code, and the interpreter doesn't
998 ;; like if we don't let-convert in such a case.
999 (or *converting-for-interpreter*
1000 (block-succ (node-block call)))
1001 (cond ((ok-initial-convert-p fun) t)
1002 (t
1003 (reoptimize-continuation ref-cont)
1004 nil)))
1005 (when (eq fun (node-home-lambda call))
1006 (delete-lambda fun)
1007 (return-from maybe-let-convert nil))
1008 (unless (eq (functional-kind fun) :assignment)
1009 (let-convert fun call))
1010 (reoptimize-call call)
1011 (setf (functional-kind fun)
1012 (if (mv-combination-p call) :mv-let :let))))
1013 t)))
1014
1015
1016 ;;;; Tail local calls and assignments:
1017
1018 ;;; ONLY-HARMLESS-CLEANUPS -- Internal
1019 ;;;
1020 ;;; Return T if there are no cleanups between Block1 and Block2, or if they
1021 ;;; definitely won't generate any cleanup code. Currently we recognize lexical
1022 ;;; entry points that are only used locally (if at all).
1023 ;;;
1024 (defun only-harmless-cleanups (block1 block2)
1025 (declare (type cblock block1 block2))
1026 (or (eq block1 block2)
1027 (let ((cleanup2 (block-start-cleanup block2)))
1028 (do ((cleanup (block-end-cleanup block1)
1029 (node-enclosing-cleanup (cleanup-mess-up cleanup))))
1030 ((eq cleanup cleanup2) t)
1031 (case (cleanup-kind cleanup)
1032 ((:block :tagbody)
1033 (unless (null (entry-exits (cleanup-mess-up cleanup)))
1034 (return nil)))
1035 (t (return nil)))))))
1036
1037
1038 ;;; MAYBE-CONVERT-TAIL-LOCAL-CALL -- Interface
1039 ;;;
1040 ;;; If a potentially TR local call really is TR, then convert it to jump
1041 ;;; directly to the called function. We also call MAYBE-CONVERT-TO-ASSIGNMENT.
1042 ;;; The first value is true if we tail-convert. The second is the value of
1043 ;;; M-C-T-A. We can switch the succesor (potentially deleting the RETURN node)
1044 ;;; unless:
1045 ;;; -- The call has already been converted.
1046 ;;; -- The call isn't TR (random implicit MV PROG1.)
1047 ;;; -- The call is in an XEP (thus we might decide to make it non-tail so that
1048 ;;; we can use known return inside the component.)
1049 ;;; -- There is a change in the cleanup between the call in the return, so we
1050 ;;; might need to introduce cleanup code.
1051 ;;;
1052 ;;; If the the function is declared notinline, we don't convert the tail
1053 ;;; call either, so that we can trace the local call, if desired.
1054 (defun maybe-convert-tail-local-call (call)
1055 (declare (type combination call))
1056 (let ((return (continuation-dest (node-cont call))))
1057 (assert (return-p return))
1058 (when (and (not (node-tail-p call))
1059 (immediately-used-p (return-result return) call)
1060 (not (eq (functional-kind (node-home-lambda call))
1061 :external))
1062 (not (functional-inlinep (node-home-lambda call)))
1063 (only-harmless-cleanups (node-block call)
1064 (node-block return)))
1065 (node-ends-block call)
1066 (let ((block (node-block call))
1067 (fun (combination-lambda call)))
1068 (setf (node-tail-p call) t)
1069 (unlink-blocks block (first (block-succ block)))
1070 (link-blocks block (node-block (lambda-bind fun)))
1071 (values t (maybe-convert-to-assignment fun))))))
1072
1073
1074 ;;; MAYBE-CONVERT-TO-ASSIGNMENT -- Interface
1075 ;;;
1076 ;;; Called when we believe it might make sense to convert Fun to an
1077 ;;; assignment. All this function really does is determine when a function
1078 ;;; with more than one call can still be combined with the calling function's
1079 ;;; environment. We can convert when:
1080 ;;; -- The function is a normal, non-entry function, and
1081 ;;; -- Except for one call, all calls must be tail recursive calls in the
1082 ;;; called function (i.e. are self-recursive tail calls)
1083 ;;; -- OK-INITIAL-CONVERT-P is true.
1084 ;;;
1085 ;;; There may be one outside call, and it need not be tail-recursive. Since
1086 ;;; all tail local calls have already been converted to direct transfers, the
1087 ;;; only control semantics needed are to splice in the body at the non-tail
1088 ;;; call. If there is no non-tail call, then we need only merge the
1089 ;;; environments. Both cases are handled by LET-CONVERT.
1090 ;;;
1091 ;;; ### It would actually be possible to allow any number of outside calls as
1092 ;;; long as they all return to the same place (i.e. have the same conceptual
1093 ;;; continuation.) A special case of this would be when all of the outside
1094 ;;; calls are tail recursive.
1095 ;;;
1096 (defun maybe-convert-to-assignment (fun)
1097 (declare (type clambda fun))
1098 (when (and (not (functional-kind fun))
1099 (not (functional-entry-function fun)))
1100 (let ((outside-non-tail-call nil)
1101 (outside-call nil))
1102 (when (and (dolist (ref (leaf-refs fun) t)
1103 (let ((dest (continuation-dest (node-cont ref))))
1104 (when (or (not dest)
1105 (block-delete-p (node-block dest)))
1106 (return nil))
1107 (let ((home (node-home-lambda ref)))
1108 (unless (eq home fun)
1109 (when outside-call
1110 (return nil))
1111 (setq outside-call dest))
1112 (unless (node-tail-p dest)
1113 (when (or outside-non-tail-call (eq home fun))
1114 (return nil))
1115 (setq outside-non-tail-call dest)))))
1116 (ok-initial-convert-p fun))
1117 (setf (functional-kind fun) :assignment)
1118 (cond (outside-call
1119 (setf (functional-kind fun) :assignment)
1120 (let-convert fun outside-call)
1121 (when outside-non-tail-call
1122 (reoptimize-call outside-non-tail-call))
1123 t)
1124 (t
1125 (delete-lambda fun)
1126 nil))))))

  ViewVC Help
Powered by ViewVC 1.1.5