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

Contents of /src/compiler/locall.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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