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

Contents of /src/compiler/locall.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (show annotations)
Thu Oct 2 19:23:11 2003 UTC (10 years, 6 months ago) by gerd
Branch: MAIN
Changes since 1.54: +28 -26 lines
	(compile nil
	  '(lambda (c) (declare (optimize (speed 3) (debug 1)))
	     (flet ((%f18 () -36))
	        (flet ((%f13 () (let () (block b8 (return-from b8 c)))))
	          (%f18)))))
	 => error nil is not an integer, in dump-1-variable

	Found by Paul Dietz.

	This is caused by a lambda-var being passed to dump-1-variable
	which hasn't been packed, and so has a null tn-offset.  A ref to
	this lambda-var remains at this point because it is referenced
	from a different component.  The ref is deleted when that
	component is compiled.  The problem is that there shouldn't have
	been two components to begin with, which we prevent by recording
	additional DFO dependencies for closed-over variables and entries.

	Port from SBCL, basically.

	Does not require a bootstrap file, but a full build is necessary
	due to the renamed clambda structure slot.

	* src/compiler/dfo.lisp (dfo-walk-call-graph): Process
	new dfo dependencies.

	* src/compiler/node.lisp (clambda): Rename slot `calls'
	to `dfo-dependencies'.

	* src/compiler/locall.lisp (convert-call, convert-mv-call):
	Call note-dfo-dependency.
	(merge-lets): Change for new clambda slot name.
	(unconvert-tail-calls): Handle the case of non-clambdas in
	the dfo dependencies.

	* src/compiler/ir1util.lisp (continuation-home-lambda)
	(note-dfo-dependency): New functions.

	* src/compiler/ir1tran.lisp (ir1-convert-variable)
	(return-from, go, setq): Call note-dfo-dependency.

	* src/compiler/xref.lisp (lambda-called-p): New function.
	(prettiest-caller-name): Use lambda-called-p instead of
	lambda-calls.
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.55 2003/10/02 19:23:11 gerd 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 (setq loser name))))
615 (let ((info (lambda-var-arg-info var)))
616 (when (eq (arg-info-keyword info) name)
617 (ignores dummy)
618 (supplied (cons var val))
619 (return)))))))
620
621 (when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
622 (compiler-warning "Function called with unknown argument keyword ~S."
623 loser)
624 (setf (basic-combination-kind call) :error)
625 (return-from convert-more-call)))
626
627 (collect ((call-args))
628 (do ((var arglist (cdr var))
629 (temp (temps) (cdr temp)))
630 ((null var))
631 (let ((info (lambda-var-arg-info (car var))))
632 (if info
633 (ecase (arg-info-kind info)
634 (:optional
635 (call-args (car temp))
636 (when (arg-info-supplied-p info)
637 (call-args t)))
638 (:rest
639 ;;
640 ;; We could do something here if the variable is
641 ;; declared dynamic-extent.
642 (call-args `(list ,@(more-temps)))
643 (return))
644 (:keyword
645 (return)))
646 (call-args (car temp)))))
647
648 (dolist (var (key-vars))
649 (let ((info (lambda-var-arg-info var))
650 (temp (cdr (assoc var (supplied)))))
651 (if temp
652 (call-args temp)
653 (call-args (arg-info-default info)))
654 (when (arg-info-supplied-p info)
655 (call-args (not (null temp))))))
656
657 (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
658 (append (temps) (more-temps))
659 (ignores) (call-args)))))
660
661 (undefined-value))
662
663
664 ;;;; Let conversion:
665 ;;;
666 ;;; Converting to a let has differing significance to various parts of the
667 ;;; compiler:
668 ;;; -- The body of a Let is spliced in immediately after the corresponding
669 ;;; combination node, making the control transfer explicit and allowing lets
670 ;;; to mashed together into a single block. The value of the let is
671 ;;; delivered directly to the original continuation for the call,
672 ;;; eliminating the need to propagate information from the dummy result
673 ;;; continuation.
674 ;;; -- As far as IR1 optimization is concerned, it is interesting in that there
675 ;;; is only one expression that the variable can be bound to, and this is
676 ;;; easily substitited for.
677 ;;; -- Lets are interesting to environment analysis and the back end because in
678 ;;; most ways a let can be considered to be "the same function" as its home
679 ;;; function.
680 ;;; -- Let conversion has dynamic scope implications, since control transfers
681 ;;; within the same environment are local. In a local control transfer,
682 ;;; cleanup code must be emitted to remove dynamic bindings that are no
683 ;;; longer in effect.
684
685
686 ;;; Insert-Let-Body -- Internal
687 ;;;
688 ;;; Set up the control transfer to the called lambda. We split the call
689 ;;; block immediately after the call, and link the head of Fun to the call
690 ;;; block. The successor block after splitting (where we return to) is
691 ;;; returned.
692 ;;;
693 ;;; If the lambda is is a different component than the call, then we call
694 ;;; JOIN-COMPONENTS. This only happens in block compilation before
695 ;;; FIND-INITIAL-DFO.
696 ;;;
697 (defun insert-let-body (fun call)
698 (declare (type clambda fun) (type basic-combination call))
699 (let* ((call-block (node-block call))
700 (bind-block (node-block (lambda-bind fun)))
701 (component (block-component call-block)))
702 (let ((fun-component (block-component bind-block)))
703 (unless (eq fun-component component)
704 (assert (eq (component-kind component) :initial))
705 (join-components component fun-component)))
706
707 (let ((*current-component* component))
708 (node-ends-block call))
709 (assert (= (length (block-succ call-block)) 1))
710 (let ((next-block (first (block-succ call-block))))
711 (unlink-blocks call-block next-block)
712 (link-blocks call-block bind-block)
713 next-block)))
714
715
716 ;;; Merge-Lets -- Internal
717 ;;;
718 ;;; Handle the environment semantics of let conversion. We add the lambda
719 ;;; and its lets to lets for the Call's home function. We merge the calls for
720 ;;; Fun with the calls for the home function, removing Fun in the process. We
721 ;;; also merge the Entries.
722 ;;;
723 ;;; We also unlink the function head from the component head and set
724 ;;; Component-Reanalyze to true to indicate that the DFO should be recomputed.
725 ;;;
726 (defun merge-lets (fun call)
727 (declare (type clambda fun) (type basic-combination call))
728 (let ((component (block-component (node-block call))))
729 (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
730 (setf (component-lambdas component)
731 (delete fun (component-lambdas component)))
732 (setf (component-reanalyze component) t))
733 (setf (lambda-call-lexenv fun) (node-lexenv call))
734 (let ((tails (lambda-tail-set fun)))
735 (setf (tail-set-functions tails)
736 (delete fun (tail-set-functions tails))))
737 (setf (lambda-tail-set fun) nil)
738 (let* ((home (node-home-lambda call))
739 (home-env (lambda-environment home)))
740
741 (assert (not (eq home fun)))
742
743 ;; FUN belongs to HOME now.
744 (push fun (lambda-lets home))
745 (setf (lambda-home fun) home)
746 (setf (lambda-environment fun) home-env)
747
748 ;; All of FUN's LETs belong to HOME now
749 (let ((lets (lambda-lets fun)))
750 (dolist (let lets)
751 (setf (lambda-home let) home)
752 (setf (lambda-environment let) home-env))
753
754 (setf (lambda-lets home) (nconc lets (lambda-lets home)))
755 ;; FUN no longer has an independent existence as an entity which
756 ;; has LETs.
757 (setf (lambda-lets fun) ()))
758
759 ;; HOME no longer calls FUN, and owns all of FUN's old DFO
760 ;; dependencies
761 (setf (lambda-dfo-dependencies home)
762 (delete fun (nunion (lambda-dfo-dependencies fun)
763 (lambda-dfo-dependencies home))))
764 ;; FUN no longer has an independent existence as an entity
765 ;; which calls things or has DFO dependencies.
766 (setf (lambda-dfo-dependencies fun) ())
767
768 ;; All of FUN's ENTRIES belong to HOME now.
769 (setf (lambda-entries home)
770 (nconc (lambda-entries fun) (lambda-entries home)))
771 ;; FUN no longer has an independent existence as an entity
772 ;; with ENTRIES.
773 (setf (lambda-entries fun) ()))
774 (undefined-value))
775
776
777 ;;; Move-Return-Uses -- Internal
778 ;;;
779 ;;; Handle the value semantics of let conversion. Delete Fun's return node,
780 ;;; and change the control flow to transfer to Next-Block instead. Move all
781 ;;; the uses of the result continuation to Call's Cont.
782 ;;;
783 ;;; If the actual continuation is only used by the let call, then we
784 ;;; intersect the type assertion on the dummy continuation with the assertion
785 ;;; for the actual continuation; in all other cases assertions on the dummy
786 ;;; continuation are lost.
787 ;;;
788 ;;; We also intersect the derived type of the call with the derived type of
789 ;;; all the dummy continuation's uses. This serves mainly to propagate
790 ;;; TRULY-THE through lets.
791 ;;;
792 (defun move-return-uses (fun call next-block)
793 (declare (type clambda fun) (type basic-combination call)
794 (type cblock next-block))
795 (let* ((return (lambda-return fun))
796 (return-block (node-block return)))
797 (unlink-blocks return-block
798 (component-tail (block-component return-block)))
799 (link-blocks return-block next-block)
800 (unlink-node return)
801 (delete-return return)
802 (let ((result (return-result return))
803 (cont (node-cont call))
804 (call-type (node-derived-type call)))
805 (when (eq (continuation-use cont) call)
806 (assert-continuation-type cont (continuation-asserted-type result)))
807 (unless (eq call-type *wild-type*)
808 (do-uses (use result)
809 (derive-node-type use call-type)))
810 (substitute-continuation-uses cont result)))
811 (undefined-value))
812
813
814
815 ;;; MOVE-LET-CALL-CONT -- Internal
816 ;;;
817 ;;; Change all Cont for all the calls to Fun to be the start continuation
818 ;;; for the bind node. This allows the blocks to be joined if the caller count
819 ;;; ever goes to one.
820 ;;;
821 (defun move-let-call-cont (fun)
822 (declare (type clambda fun))
823 (let ((new-cont (node-prev (lambda-bind fun))))
824 (dolist (ref (leaf-refs fun))
825 (let ((dest (continuation-dest (node-cont ref))))
826 (delete-continuation-use dest)
827 (add-continuation-use dest new-cont))))
828 (undefined-value))
829
830
831 ;;; Unconvert-Tail-Calls -- Internal
832 ;;;
833 ;;; We are converting Fun to be a let when the call is in a non-tail
834 ;;; position. Any previously tail calls in Fun are no longer tail calls, and
835 ;;; must be restored to normal calls which transfer to Next-Block (Fun's
836 ;;; return point.) We can't do this by DO-USES on the RETURN-RESULT, because
837 ;;; the return might have been deleted (if all calls were TR.)
838 ;;;
839 ;;; The called function might be an assignment in the case where we are
840 ;;; currently converting that function. In steady-state, assignments never
841 ;;; appear in the lambda-dfo-dependencies.
842 ;;;
843 (defun unconvert-tail-calls (fun call next-block)
844 (dolist (called (lambda-dfo-dependencies fun))
845 (when (lambda-p called)
846 (dolist (ref (leaf-refs called))
847 (let ((this-call (continuation-dest (node-cont ref))))
848 (when (and (node-tail-p this-call)
849 (eq (node-home-lambda this-call) fun))
850 (setf (node-tail-p this-call) nil)
851 (ecase (functional-kind called)
852 ((nil :cleanup :optional)
853 (let ((block (node-block this-call))
854 (cont (node-cont call)))
855 (ensure-block-start cont)
856 (unlink-blocks block (first (block-succ block)))
857 (link-blocks block next-block)
858 (delete-continuation-use this-call)
859 (add-continuation-use this-call cont)))
860 (:deleted)
861 (:assignment
862 (assert (eq called fun)))))))))
863 (values))
864
865
866 ;;; MOVE-RETURN-STUFF -- Internal
867 ;;;
868 ;;; Deal with returning from a let or assignment that we are converting.
869 ;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK
870 ;;; is the return point for a non-tail call, or NULL if call is a tail call.
871 ;;;
872 ;;; If the call is not a tail call, then we must do UNCONVERT-TAIL-CALLS, since
873 ;;; a tail call is a call which returns its value out of the enclosing non-let
874 ;;; function. When call is non-TR, we must convert it back to an ordinary
875 ;;; local call, since the value must be delivered to the receiver of CALL's
876 ;;; value.
877 ;;;
878 ;;; We do different things depending on whether the caller and callee have
879 ;;; returns left:
880 ;;; -- If the callee has no return we just do MOVE-LET-CALL-CONT. Either the
881 ;;; function doesn't return, or all returns are via tail-recursive local
882 ;;; calls.
883 ;;; -- If CALL is a non-tail call, or if both have returns, then we
884 ;;; delete the callee's return, move its uses to the call's result
885 ;;; continuation, and transfer control to the appropriate return point.
886 ;;; -- If the callee has a return, but the caller doesn't, then we move the
887 ;;; return to the caller.
888 ;;;
889 (defun move-return-stuff (fun call next-block)
890 (declare (type clambda fun) (type basic-combination call)
891 (type (or cblock null) next-block))
892 (when next-block
893 (unconvert-tail-calls fun call next-block))
894 (let* ((return (lambda-return fun))
895 (call-fun (node-home-lambda call))
896 (call-return (lambda-return call-fun)))
897 (cond ((not return))
898 ((or next-block call-return)
899 (unless (block-delete-p (node-block return))
900 (move-return-uses fun call
901 (or next-block (node-block call-return)))))
902 (t
903 (assert (node-tail-p call))
904 (setf (lambda-return call-fun) return)
905 (setf (return-lambda return) call-fun))))
906 (move-let-call-cont fun)
907 (undefined-value))
908
909
910 ;;; Let-Convert -- Internal
911 ;;;
912 ;;; Actually do let conversion. We call subfunctions to do most of the
913 ;;; work. We change the Call's cont to be the continuation heading the bind
914 ;;; block, and also do Reoptimize-Continuation on the args and Cont so that
915 ;;; let-specific IR1 optimizations get a chance. We blow away any entry for
916 ;;; the function in *free-functions* so that nobody will create new reference
917 ;;; to it.
918 ;;;
919 (defun let-convert (fun call)
920 (declare (type clambda fun) (type basic-combination call))
921 (let ((next-block (if (node-tail-p call)
922 nil
923 (insert-let-body fun call))))
924 (move-return-stuff fun call next-block)
925 (merge-lets fun call)))
926
927
928 ;;; REOPTIMIZE-CALL -- Internal
929 ;;;
930 ;;; Reoptimize all of Call's args and its result.
931 ;;;
932 (defun reoptimize-call (call)
933 (declare (type basic-combination call))
934 (dolist (arg (basic-combination-args call))
935 (when arg
936 (reoptimize-continuation arg)))
937 (reoptimize-continuation (node-cont call))
938 (undefined-value))
939
940 ;;; OK-INITIAL-CONVERT-P -- Internal
941 ;;;
942 ;;; We also don't convert calls to named functions which appear in the initial
943 ;;; component, delaying this until optimization. This minimizes the likelyhood
944 ;;; that we well let-convert a function which may have references added due to
945 ;;; later local inline expansion
946 ;;;
947 (defun ok-initial-convert-p (fun)
948 (not (and (leaf-name fun)
949 (eq (component-kind
950 (block-component
951 (node-block (lambda-bind fun))))
952 :initial))))
953
954
955 ;;; Maybe-Let-Convert -- Interface
956 ;;;
957 ;;; This function is called when there is some reason to believe that
958 ;;; the lambda Fun might be converted into a let. This is done after local
959 ;;; call analysis, and also when a reference is deleted. We only convert to a
960 ;;; let when the function is a normal local function, has no XEP, and is
961 ;;; referenced in exactly one local call. Conversion is also inhibited if the
962 ;;; only reference is in a block about to be deleted. We return true if we
963 ;;; converted.
964 ;;;
965 ;;; These rules may seem unnecessarily restrictive, since there are some
966 ;;; cases where we could do the return with a jump that don't satisfy these
967 ;;; requirements. The reason for doing things this way is that it makes the
968 ;;; concept of a let much more useful at the level of IR1 semantics. The
969 ;;; :ASSIGNMENT function kind provides another way to optimize calls to
970 ;;; single-return/multiple call functions.
971 ;;;
972 ;;; We don't attempt to convert calls to functions that have an XEP, since
973 ;;; we might be embarrassed later when we want to convert a newly discovered
974 ;;; local call. Also, see OK-INITIAL-CONVERT-P.
975 ;;;
976 (defun maybe-let-convert (fun)
977 (declare (type clambda fun))
978 (let ((refs (leaf-refs fun)))
979 (when (and refs (null (rest refs))
980 (member (functional-kind fun) '(nil :assignment))
981 (not (functional-entry-function fun)))
982 (let* ((ref-cont (node-cont (first refs)))
983 (dest (continuation-dest ref-cont)))
984 (when (and dest
985 (basic-combination-p dest)
986 (eq (basic-combination-fun dest) ref-cont)
987 (eq (basic-combination-kind dest) :local)
988 (not (block-delete-p (node-block dest)))
989 (cond ((ok-initial-convert-p fun) t)
990 (t
991 (reoptimize-continuation ref-cont)
992 nil)))
993 (when (eq fun (node-home-lambda dest))
994 (delete-lambda fun)
995 (return-from maybe-let-convert nil))
996 (unless (eq (functional-kind fun) :assignment)
997 (let-convert fun dest))
998 (reoptimize-call dest)
999 (setf (functional-kind fun)
1000 (if (mv-combination-p dest) :mv-let :let))))
1001 t)))
1002
1003
1004 ;;;; Tail local calls and assignments:
1005
1006 ;;; ONLY-HARMLESS-CLEANUPS -- Internal
1007 ;;;
1008 ;;; Return T if there are no cleanups between Block1 and Block2, or if they
1009 ;;; definitely won't generate any cleanup code. Currently we recognize lexical
1010 ;;; entry points that are only used locally (if at all).
1011 ;;;
1012 (defun only-harmless-cleanups (block1 block2)
1013 (declare (type cblock block1 block2))
1014 (or (eq block1 block2)
1015 (let ((cleanup2 (block-start-cleanup block2)))
1016 (do ((cleanup (block-end-cleanup block1)
1017 (node-enclosing-cleanup (cleanup-mess-up cleanup))))
1018 ((eq cleanup cleanup2) t)
1019 (case (cleanup-kind cleanup)
1020 ((:block :tagbody)
1021 (unless (null (entry-exits (cleanup-mess-up cleanup)))
1022 (return nil)))
1023 (t (return nil)))))))
1024
1025
1026 ;;; MAYBE-CONVERT-TAIL-LOCAL-CALL -- Interface
1027 ;;;
1028 ;;; If a potentially TR local call really is TR, then convert it to jump
1029 ;;; directly to the called function. We also call MAYBE-CONVERT-TO-ASSIGNMENT.
1030 ;;; The first value is true if we tail-convert. The second is the value of
1031 ;;; M-C-T-A. We can switch the succesor (potentially deleting the RETURN node)
1032 ;;; unless:
1033 ;;; -- The call has already been converted.
1034 ;;; -- The call isn't TR (random implicit MV PROG1.)
1035 ;;; -- The call is in an XEP (thus we might decide to make it non-tail so that
1036 ;;; we can use known return inside the component.)
1037 ;;; -- There is a change in the cleanup between the call in the return, so we
1038 ;;; might need to introduce cleanup code.
1039 ;;;
1040 (defun maybe-convert-tail-local-call (call)
1041 (declare (type combination call))
1042 (let ((return (continuation-dest (node-cont call))))
1043 (assert (return-p return))
1044 (when (and (not (node-tail-p call))
1045 (immediately-used-p (return-result return) call)
1046 (not (eq (functional-kind (node-home-lambda call))
1047 :external))
1048 (only-harmless-cleanups (node-block call)
1049 (node-block return)))
1050 (node-ends-block call)
1051 (let ((block (node-block call))
1052 (fun (combination-lambda call)))
1053 (setf (node-tail-p call) t)
1054 (unlink-blocks block (first (block-succ block)))
1055 (link-blocks block (node-block (lambda-bind fun)))
1056 (values t (maybe-convert-to-assignment fun))))))
1057
1058
1059 ;;; MAYBE-CONVERT-TO-ASSIGNMENT -- Interface
1060 ;;;
1061 ;;; Called when we believe it might make sense to convert Fun to an
1062 ;;; assignment. All this function really does is determine when a function
1063 ;;; with more than one call can still be combined with the calling function's
1064 ;;; environment. We can convert when:
1065 ;;; -- The function is a normal, non-entry function, and
1066 ;;; -- Except for one call, all calls must be tail recursive calls in the
1067 ;;; called function (i.e. are self-recursive tail calls)
1068 ;;; -- OK-INITIAL-CONVERT-P is true.
1069 ;;;
1070 ;;; There may be one outside call, and it need not be tail-recursive. Since
1071 ;;; all tail local calls have already been converted to direct transfers, the
1072 ;;; only control semantics needed are to splice in the body at the non-tail
1073 ;;; call. If there is no non-tail call, then we need only merge the
1074 ;;; environments. Both cases are handled by LET-CONVERT.
1075 ;;;
1076 ;;; ### It would actually be possible to allow any number of outside calls as
1077 ;;; long as they all return to the same place (i.e. have the same conceptual
1078 ;;; continuation.) A special case of this would be when all of the outside
1079 ;;; calls are tail recursive.
1080 ;;;
1081 (defun maybe-convert-to-assignment (fun)
1082 (declare (type clambda fun))
1083 (when (and (not (functional-kind fun))
1084 (not (functional-entry-function fun)))
1085 (let ((outside-non-tail-call nil)
1086 (outside-call nil))
1087 (when (and (dolist (ref (leaf-refs fun) t)
1088 (let ((dest (continuation-dest (node-cont ref))))
1089 (when (or (not dest)
1090 (block-delete-p (node-block dest)))
1091 (return nil))
1092 (let ((home (node-home-lambda ref)))
1093 (unless (eq home fun)
1094 (when outside-call
1095 (return nil))
1096 (setq outside-call dest))
1097 (unless (node-tail-p dest)
1098 (when (or outside-non-tail-call (eq home fun))
1099 (return nil))
1100 (setq outside-non-tail-call dest)))))
1101 (ok-initial-convert-p fun))
1102 (setf (functional-kind fun) :assignment)
1103 (cond (outside-call
1104 (setf (functional-kind fun) :assignment)
1105 (let-convert fun outside-call)
1106 (when outside-non-tail-call
1107 (reoptimize-call outside-non-tail-call))
1108 t)
1109 (t
1110 (delete-lambda fun)
1111 nil))))))

  ViewVC Help
Powered by ViewVC 1.1.5