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

Contents of /src/compiler/locall.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5.1.2 - (hide annotations) (vendor branch)
Fri Jun 15 15:40:26 1990 UTC (23 years, 10 months ago) by ram
Branch: eval_debug
Changes since 1.5.1.1: +12 -26 lines
*** empty log message ***
1 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of Spice Lisp, please contact
7     ;;; Scott Fahlman (FAHLMAN@CMUC).
8     ;;; **********************************************************************
9     ;;;
10     ;;; This file implements local call analysis. A local call is a function
11     ;;; call between functions being compiled at the same time. If we can tell at
12     ;;; compile time that such a call is legal, then we modify the flow graph to
13     ;;; represent the control transfers previously implicit in the call. This
14     ;;; change allows us to do inter-routine flow analysis.
15     ;;;
16     ;;; We cannot always do a local call even when we do have the function being
17     ;;; called. Local call can be explicitly disabled by a NOTINLINE declaration.
18     ;;; Calls that cannot be shown to have legal arg counts are also not converted.
19     ;;;
20     ;;; Written by Rob MacLachlan
21     ;;;
22     (in-package 'c)
23    
24    
25     ;;; Propagate-To-Args -- Internal
26     ;;;
27     ;;; This function propagates information from the variables in the function
28     ;;; Fun to the actual arguments in Call.
29     ;;;
30     ;;; We flush all arguments to Call that correspond to unreferenced variables
31     ;;; in Fun. We leave NILs in the Combination-Args so that the remaining args
32     ;;; still match up with their vars.
33     ;;;
34     ;;; We also apply the declared variable type assertion to the argument
35     ;;; continuations.
36     ;;;
37     (defun propagate-to-args (call fun)
38     (declare (type combination call) (type clambda fun))
39     (do ((args (basic-combination-args call) (cdr args))
40     (vars (lambda-vars fun) (cdr vars)))
41     ((null args))
42     (let ((arg (car args))
43     (var (car vars)))
44     (cond ((leaf-refs var)
45     (assert-continuation-type arg (leaf-type var)))
46     (t
47     (flush-dest arg)
48     (setf (car args) nil)))))
49    
50     (undefined-value))
51    
52    
53     ;;; Convert-Call -- Internal
54     ;;;
55     ;;; Convert a combination into a local call. We Propagate-To-Args, set the
56     ;;; combination kind to :Local, add Fun to the Calls of the function that the
57     ;;; call is in, then replace the function in the Ref node with the new
58     ;;; function.
59     ;;;
60     ;;; We change the Ref last, since changing the reference can trigger let
61     ;;; conversion of the new function, but will only do so if the call is local.
62     ;;;
63     (defun convert-call (ref call fun)
64     (declare (type ref ref) (type combination call) (type clambda fun))
65     (propagate-to-args call fun)
66     (setf (basic-combination-kind call) :local)
67 ram 1.5.1.2 (pushnew fun (lambda-calls (node-home-lambda call)))
68 wlott 1.1 (change-ref-leaf ref fun)
69     (undefined-value))
70    
71    
72     ;;;; External entry point creation:
73    
74     ;;; Make-XEP-Lambda -- Internal
75     ;;;
76     ;;; Return a Lambda form that can be used as the definition of the XEP for
77     ;;; Fun.
78     ;;;
79     ;;; If Fun is a lambda, then we check the number of arguments (conditional
80     ;;; on policy) and call Fun with all the arguments.
81     ;;;
82     ;;; If Fun is an Optional-Dispatch, then we dispatch off of the number of
83     ;;; supplied arguments by doing do an = test for each entry-point, calling the
84     ;;; entry with the appropriate prefix of the passed arguments.
85     ;;;
86     ;;; If there is a more arg, then there are a couple of optimizations that we
87     ;;; make (more for space than anything else):
88     ;;; -- If Min-Args is 0, then we make the more entry a T clause, since no
89     ;;; argument count error is possible.
90     ;;; -- We can omit the = clause for the last entry-point, allowing the case of
91     ;;; 0 more args to fall through to the more entry.
92     ;;;
93     ;;; We don't bother to policy conditionalize wrong arg errors in optional
94     ;;; dispatches, since the additional overhead is negligible compared to the
95     ;;; other hair going down.
96     ;;;
97     ;;; Note that if policy indicates it, argument type declarations in Fun will
98     ;;; be verified. Since nothing is known about the type of the XEP arg vars,
99     ;;; type checks will be emitted when the XEP's arg vars are passed to the
100     ;;; actual function.
101     ;;;
102     (defun make-xep-lambda (fun)
103     (declare (type functional fun))
104     (etypecase fun
105     (clambda
106     (let ((nargs (length (lambda-vars fun)))
107     (n-supplied (gensym)))
108     (collect ((temps))
109     (dotimes (i nargs)
110     (temps (gensym)))
111     `(lambda (,n-supplied ,@(temps))
112     (declare (fixnum ,n-supplied))
113 ram 1.4 ,(if (policy (lambda-bind fun) (zerop safety))
114 wlott 1.1 `(declare (ignore ,n-supplied))
115     `(%verify-argument-count ,n-supplied ,nargs))
116     (%funcall ,fun ,@(temps))))))
117     (optional-dispatch
118     (let* ((min (optional-dispatch-min-args fun))
119     (max (optional-dispatch-max-args fun))
120     (more (optional-dispatch-more-entry fun))
121     (n-supplied (gensym)))
122     (collect ((temps)
123     (entries))
124     (dotimes (i max)
125     (temps (gensym)))
126    
127     (do ((eps (optional-dispatch-entry-points fun) (rest eps))
128     (n min (1+ n)))
129     ((null eps))
130     (entries `((= ,n-supplied ,n)
131     (%funcall ,(first eps) ,@(subseq (temps) 0 n)))))
132    
133     `(lambda (,n-supplied ,@(temps))
134     (declare (fixnum ,n-supplied))
135     (cond
136     ,@(if more (butlast (entries)) (entries))
137     ,@(when more
138     `((,(if (zerop min) 't `(>= ,n-supplied ,max))
139     ,(let ((n-context (gensym))
140     (n-count (gensym)))
141     `(multiple-value-bind
142     (,n-context ,n-count)
143     (%more-arg-context ,n-supplied ,max)
144     (%funcall ,more ,@(temps) ,n-context ,n-count))))))
145     (t
146     (%argument-count-error ,n-supplied)))))))))
147    
148    
149     ;;; Make-External-Entry-Point -- Internal
150     ;;;
151     ;;; Make an external entry point (XEP) for Fun and return it. We convert
152     ;;; the result of Make-XEP-Lambda in the correct environment, then associate
153     ;;; this lambda with Fun as its XEP. After the conversion, we iterate over the
154     ;;; function's associated lambdas, redoing local call analysis so that the XEP
155     ;;; calls will get converted.
156     ;;;
157     ;;; We set Reanalyze and Reoptimize in the component, just in case we
158     ;;; discover an XEP after the initial local call analyze pass.
159     ;;;
160     (defun make-external-entry-point (fun)
161     (declare (type functional fun))
162     (assert (not (functional-entry-function fun)))
163     (with-ir1-environment (lambda-bind (main-entry fun))
164     (let ((res (ir1-convert-lambda (make-xep-lambda fun))))
165     (setf (functional-kind res) :external)
166     (setf (functional-entry-function res) fun)
167     (setf (functional-entry-function fun) res)
168     (setf (component-reanalyze *current-component*) t)
169     (setf (component-reoptimize *current-component*) t)
170     (etypecase fun
171     (clambda (local-call-analyze-1 fun))
172     (optional-dispatch
173     (dolist (ep (optional-dispatch-entry-points fun))
174     (local-call-analyze-1 ep))
175     (when (optional-dispatch-more-entry fun)
176     (local-call-analyze-1 (optional-dispatch-more-entry fun)))))
177     res)))
178    
179    
180     ;;; Reference-Entry-Point -- Internal
181     ;;;
182     ;;; Notice a Ref that is not in a local-call context. If the Ref is already
183     ;;; to an XEP, then do nothing, otherwise change it to the XEP, making an XEP
184     ;;; if necessary.
185     ;;;
186     ;;; If Ref is to a special :Cleanup or :Escape function, then we treat it as
187     ;;; though it was not an XEP reference (i.e. leave it alone.)
188     ;;;
189     (defun reference-entry-point (ref)
190     (declare (type ref ref))
191     (let ((fun (ref-leaf ref)))
192     (unless (or (external-entry-point-p fun)
193     (member (functional-kind fun) '(:escape :cleanup)))
194     (change-ref-leaf ref (or (functional-entry-function fun)
195     (make-external-entry-point fun))))))
196    
197    
198     ;;; Local-Call-Analyze-1 -- Interface
199     ;;;
200     ;;; Attempt to convert all references to Fun to local calls. The reference
201     ;;; cannot be :Notinline, and must be the function for a call. The function
202     ;;; continuation must be used only once, since otherwise we cannot be sure what
203     ;;; function is to be called. The call continuation would be multiply used if
204     ;;; there is hairy stuff such as conditionals in the expression that computes
205     ;;; the function.
206     ;;;
207 ram 1.5 ;;; Except in the interpreter, we don't attempt to convert calls that appear
208     ;;; in a top-level lambda unless there is only one reference. This ensures
209     ;;; that top-level components will contain only load-time code: any references
210     ;;; to run-time functions will be as closures.
211 ram 1.3 ;;;
212 wlott 1.1 ;;; If we cannot convert a reference, then we mark the referenced function
213     ;;; as an entry-point, creating a new XEP if necessary.
214     ;;;
215     ;;; This is broken off from Local-Call-Analyze so that people can force
216     ;;; analysis of newly introduced calls. Note that we don't do let conversion
217     ;;; here.
218     ;;;
219     (defun local-call-analyze-1 (fun)
220     (declare (type functional fun))
221 ram 1.3 (let ((refs (leaf-refs fun)))
222     (dolist (ref refs)
223     (let* ((cont (node-cont ref))
224     (dest (continuation-dest cont)))
225     (cond ((and (basic-combination-p dest)
226     (eq (basic-combination-fun dest) cont)
227     (eq (continuation-use cont) ref)
228     (or (null (rest refs))
229 ram 1.5 *converting-for-interpreter*
230 ram 1.5.1.2 (not (eq (functional-kind (node-home-lambda ref))
231 ram 1.3 :top-level))))
232     (ecase (ref-inlinep ref)
233     ((nil :inline)
234     (convert-call-if-possible ref dest))
235     ((:notinline)))
236    
237     (unless (eq (basic-combination-kind dest) :local)
238     (reference-entry-point ref)))
239     (t
240     (reference-entry-point ref))))))
241 wlott 1.1
242     (undefined-value))
243    
244    
245     ;;; Local-Call-Analyze -- Interface
246     ;;;
247     ;;; We examine all New-Functions in component, attempting to convert calls
248     ;;; into local calls when it is legal. We also attempt to convert each lambda
249     ;;; to a let. Let conversion is also triggered by deletion of a function
250     ;;; reference, but functions that start out eligible for conversion must be
251     ;;; noticed sometime.
252     ;;;
253     ;;; Note that there is a lot of action going on behind the scenes here,
254     ;;; triggered by reference deletion. In particular, the Component-Lambdas are
255     ;;; being hacked to remove newly deleted and let converted lambdas, so it is
256     ;;; important that the lambda is added to the Component-Lambdas when it is.
257     ;;;
258     (defun local-call-analyze (component)
259     (declare (type component component))
260     (loop
261     (unless (component-new-functions component) (return))
262     (let ((fun (pop (component-new-functions component))))
263     (unless (eq (functional-kind fun) :deleted)
264     (when (lambda-p fun)
265     (push fun (component-lambdas component)))
266     (local-call-analyze-1 fun)
267     (when (lambda-p fun)
268     (maybe-let-convert fun)))))
269    
270     (undefined-value))
271    
272    
273     ;;; Convert-Call-If-Possible -- Interface
274     ;;;
275     ;;; Dispatch to the appropriate function to attempt to convert a call. This
276     ;;; is called in IR1 optimize as well as in local call analysis. If the call
277     ;;; is already :Local, we do nothing. If the call is in the top-level
278     ;;; component, also do nothing, since we don't want to join top-level code into
279     ;;; normal components.
280     ;;;
281     ;;; We bind *Compiler-Error-Context* to the node for the call so that
282     ;;; warnings will get the right context.
283     ;;;
284     (defun convert-call-if-possible (ref call)
285     (declare (type ref ref) (type basic-combination call))
286     (let ((fun (let ((fun (ref-leaf ref)))
287     (if (external-entry-point-p fun)
288     (functional-entry-function fun)
289     fun)))
290     (*compiler-error-context* call))
291     (cond ((eq (basic-combination-kind call) :local))
292     ((mv-combination-p call)
293     (convert-mv-call ref call fun))
294     ((lambda-p fun)
295     (convert-lambda-call ref call fun))
296     (t
297     (convert-hairy-call ref call fun))))
298     (undefined-value))
299    
300    
301     ;;; Convert-MV-Call -- Internal
302     ;;;
303     ;;; Attempt to convert a multiple-value call. The only interesting case is
304     ;;; a call to a function that Looks-Like-An-MV-Bind, has exactly one reference
305     ;;; and no XEP, and is called with one values continuation.
306     ;;;
307     ;;; We change the call to be to the last optional entry point and change the
308     ;;; call to be local. Due to our preconditions, the call should eventually be
309     ;;; converted to a let, but we can't do that now, since there may be stray
310     ;;; references to the e-p lambda due to optional defaulting code.
311     ;;;
312     ;;; We also use variable types for the called function to construct an
313     ;;; assertion for the values continuation.
314     ;;;
315     (defun convert-mv-call (ref call fun)
316     (declare (type ref ref) (type mv-combination call) (type functional fun))
317     (when (and (looks-like-an-mv-bind fun)
318     (not (functional-entry-function fun))
319     (= (length (leaf-refs fun)) 1)
320     (= (length (basic-combination-args call)) 1))
321     (let ((ep (car (last (optional-dispatch-entry-points fun)))))
322     (change-ref-leaf ref ep)
323     (setf (basic-combination-kind call) :local)
324 ram 1.5.1.2 (pushnew ep (lambda-calls (node-home-lambda call)))
325 wlott 1.1
326     (assert-continuation-type
327     (first (basic-combination-args call))
328     (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
329     :rest *universal-type*))))
330     (undefined-value))
331    
332    
333     ;;; Convert-Lambda-Call -- Internal
334     ;;;
335     ;;; Attempt to convert a call to a lambda. If the number of args is wrong,
336     ;;; we give a warning and mark the Ref as :Notinline to remove it from future
337     ;;; consideration. If the argcount is O.K. then we just convert it.
338     ;;;
339     (proclaim '(function convert-lambda-call (ref combination lambda) void))
340     (defun convert-lambda-call (ref call fun)
341     (let ((nargs (length (lambda-vars fun)))
342     (call-args (length (combination-args call))))
343     (cond ((= call-args nargs)
344     (convert-call ref call fun))
345     (t
346     (compiler-warning
347     "Function called with ~R argument~:P, but wants exactly ~R."
348     call-args nargs)
349     (setf (ref-inlinep ref) :notinline)))))
350    
351    
352    
353     ;;;; Optional, more and keyword calls:
354    
355     ;;; Convert-Hairy-Call -- Internal
356     ;;;
357     ;;; Similar to Convert-Lambda-Call, but deals with Optional-Dispatches. If
358     ;;; only fixed args are supplied, then convert a call to the correct entry
359     ;;; point. If keyword args are supplied, then dispatch to a subfunction. We
360     ;;; don't convert calls to functions that have a more (or rest) arg.
361     ;;;
362     (defun convert-hairy-call (ref call fun)
363     (declare (type ref ref) (type combination call)
364     (type optional-dispatch fun))
365     (let ((min-args (optional-dispatch-min-args fun))
366     (max-args (optional-dispatch-max-args fun))
367     (call-args (length (combination-args call))))
368     (cond ((< call-args min-args)
369     (compiler-warning "Function called with ~R argument~:P, but wants at least ~R."
370     call-args min-args)
371     (setf (ref-inlinep ref) :notinline))
372     ((<= call-args max-args)
373     (convert-call ref call
374     (elt (optional-dispatch-entry-points fun)
375     (- call-args min-args))))
376     ((not (optional-dispatch-more-entry fun))
377     (compiler-warning "Function called with ~R argument~:P, but wants at most ~R."
378     call-args max-args)
379     (setf (ref-inlinep ref) :notinline))
380     ((optional-dispatch-keyp fun)
381     (cond ((oddp (- call-args max-args))
382     (compiler-warning "Function called with odd number of ~
383     arguments in keyword portion."))
384     (t
385     (convert-keyword-call ref call fun))))))
386    
387     (undefined-value))
388    
389    
390     ;;; Convert-Hairy-Fun-Entry -- Internal
391     ;;;
392     ;;; This function is used to convert a call to an entry point when complex
393     ;;; transformations need to be done on the original arguments. Entry is the
394     ;;; entry point function that we are calling. Vars is a list of variable names
395     ;;; which are bound to the oringinal call arguments. Ignores is the subset of
396     ;;; Vars which are ignored. Args is the list of arguments to the entry point
397     ;;; function.
398     ;;;
399     ;;; In order to avoid gruesome graph grovelling, we introduce a new function
400     ;;; that rearranges the arguments and calls the entry point. We analyze the
401     ;;; new function and the entry point immediately so that everything gets
402     ;;; converted during the single pass.
403     ;;;
404     (proclaim '(function convert-hairy-fun-entry
405     (ref combination lambda list list list)))
406     (defun convert-hairy-fun-entry (ref call entry vars ignores args)
407     (let ((new-fun
408     (with-ir1-environment call
409     (ir1-convert-lambda
410     `(lambda ,vars
411     (declare (ignore . ,ignores))
412 ram 1.5.1.2 (%funcall ,entry . ,args))))))
413 wlott 1.1 (convert-call ref call new-fun)
414     (dolist (ref (leaf-refs entry))
415     (convert-call-if-possible ref (continuation-dest (node-cont ref))))))
416    
417    
418     ;;; Convert-Keyword-Call -- Internal
419     ;;;
420     ;;; Use Convert-Hairy-Fun-Entry to convert a keyword call to a known
421     ;;; functions into a local call to the Main-Entry.
422     ;;;
423     ;;; First we verify that all keywords are constant and legal. If there
424     ;;; aren't, then we warn the user and don't attempt to convert the call.
425     ;;;
426     ;;; We massage the supplied keyword arguments into the order expected by the
427     ;;; main entry. This is done by binding all the arguments to the keyword call
428     ;;; to variables in the introduced lambda, then passing these values variables
429     ;;; in the correct order when calling the main entry. Unused arguments
430     ;;; (such as the keywords themselves) are discarded simply by not passing them
431     ;;; along.
432     ;;;
433     (defun convert-keyword-call (ref call fun)
434     (declare (type ref ref) (type combination call) (type optional-dispatch fun))
435     (let* ((max (optional-dispatch-max-args fun))
436     (arglist (optional-dispatch-arglist fun))
437     (args (combination-args call))
438     (keys (nthcdr max args))
439     (loser nil))
440     (collect ((temps)
441     (ignores)
442     (supplied)
443     (key-vars))
444    
445     (dolist (var arglist)
446     (let ((info (lambda-var-arg-info var)))
447     (when info
448     (ecase (arg-info-kind info)
449     (:rest
450     (setf (ref-inlinep ref) :notinline)
451     (return-from convert-keyword-call))
452     (:keyword
453     (key-vars var))
454     (:optional)))))
455    
456     (dotimes (i max)
457     (temps (gensym)))
458    
459     (do ((key keys (cddr key)))
460     ((null key))
461     (let ((cont (first key)))
462     (unless (constant-continuation-p cont)
463     (when (policy call (or (> speed brevity) (> space brevity)))
464     (compiler-note "Non-constant keyword in keyword call."))
465     (setf (ref-inlinep ref) :notinline)
466     (return-from convert-keyword-call))
467    
468     (let ((name (continuation-value cont)))
469     (dolist (var (key-vars)
470     (let ((dummy1 (gensym))
471     (dummy2 (gensym)))
472     (temps dummy1 dummy2)
473     (ignores dummy1 dummy2)
474     (setq loser name)))
475     (let ((info (lambda-var-arg-info var)))
476     (when (eq (arg-info-keyword info) name)
477     (let ((dummy (gensym))
478     (temp (gensym)))
479     (temps dummy temp)
480     (ignores dummy)
481     (supplied (cons var temp)))
482     (return)))))))
483    
484     (when (and loser (not (optional-dispatch-allowp fun)))
485     (compiler-warning "Function called with unknown argument keyword ~S."
486     loser)
487     (setf (ref-inlinep ref) :notinline)
488     (return-from convert-keyword-call))
489    
490     (collect ((call-args))
491     (do ((var arglist (cdr var))
492     (temp (temps) (cdr temp)))
493     (())
494     (let ((info (lambda-var-arg-info (car var))))
495     (if info
496     (case (arg-info-kind info)
497     (:optional
498     (call-args (car temp))
499     (when (arg-info-supplied-p info)
500     (call-args t)))
501     (t
502     (return)))
503     (call-args (car temp)))))
504    
505     (dolist (var (key-vars))
506     (let ((info (lambda-var-arg-info var))
507     (temp (cdr (assoc var (supplied)))))
508     (if temp
509     (call-args temp)
510     (call-args (arg-info-default info)))
511     (when (arg-info-supplied-p info)
512     (call-args (not (null temp))))))
513    
514     (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
515     (temps) (ignores) (call-args)))))
516    
517     (undefined-value))
518    
519    
520     ;;;; Let conversion:
521     ;;;
522     ;;; Converting to a let has differing significance to various parts of the
523     ;;; compiler:
524     ;;; -- The body of a Let is spliced in immediately after the the corresponding
525     ;;; combination node, making the control transfer explicit and allowing lets
526     ;;; to mashed together into a single block. The value of the let is
527     ;;; delivered directly to the original continuation for the call,
528     ;;; eliminating the need to propagate information from the dummy result
529     ;;; continuation.
530     ;;; -- As far as IR1 optimization is concerned, it is interesting in that there
531     ;;; is only one expression that the variable can be bound to, and this is
532     ;;; easily substitited for.
533     ;;; -- Lets are interesting to environment analysis and the back end because in
534     ;;; most ways a let can be considered to be "the same function" as its home
535     ;;; function.
536     ;;; -- Let conversion has dynamic scope implications, since control transfers
537     ;;; within the same environment are local. In a local control transfer,
538     ;;; cleanup code must be emitted to remove dynamic bindings that are no
539     ;;; longer in effect.
540    
541    
542 ram 1.5.1.2 ;;; Merge-Lets -- Internal
543 wlott 1.1 ;;;
544     ;;; Handle the environment semantics of let conversion. We add the lambda
545 ram 1.5.1.2 ;;; and its lets to lets for the call's home function. We merge the calls for
546     ;;; Fun with the calls for the home function, removing Fun in the process. We
547     ;;; also merge the Entries.
548 wlott 1.1 ;;;
549 ram 1.5.1.2 (defun merge-lets (fun call)
550 wlott 1.1 (declare (type clambda fun) (type basic-combination call))
551     (let* ((prev (node-prev call))
552 ram 1.5.1.2 (home (block-home-lambda (continuation-block prev)))
553 ram 1.3 (home-env (lambda-environment home)))
554 wlott 1.1 (push fun (lambda-lets home))
555     (setf (lambda-home fun) home)
556 ram 1.3 (setf (lambda-environment fun) home-env)
557 wlott 1.1
558 ram 1.5.1.2 (let ((lets (lambda-lets fun)))
559 wlott 1.1 (dolist (let lets)
560 ram 1.3 (setf (lambda-home let) home)
561     (setf (lambda-environment let) home-env))
562 wlott 1.1
563     (setf (lambda-lets home) (nconc lets (lambda-lets home)))
564     (setf (lambda-lets fun) ()))
565    
566     (setf (lambda-calls home)
567     (nunion (lambda-calls fun)
568     (delete fun (lambda-calls home))))
569     (setf (lambda-calls fun) ())
570    
571     (setf (lambda-entries home)
572     (nconc (lambda-entries fun) (lambda-entries home)))
573     (setf (lambda-entries fun) ()))
574     (undefined-value))
575    
576    
577     ;;; Insert-Let-Body -- Internal
578     ;;;
579     ;;; Handle the control semantics of let conversion. We split the call block
580     ;;; immediately after the call, and link the head and tail of Fun to the call
581     ;;; block and the following block. We also unlink the function head and tail
582     ;;; from the component head and tail and flush the function from the
583     ;;; Component-Lambdas. We set Component-Reanalyze to true to indicate that the
584     ;;; DFO should be recomputed.
585     ;;;
586     (defun insert-let-body (fun call)
587     (declare (type clambda fun) (type basic-combination call))
588     (let* ((call-block (node-block call))
589     (bind-block (node-block (lambda-bind fun)))
590     (component (block-component call-block)))
591     (let ((*current-component* component))
592     (node-ends-block call))
593     (setf (component-lambdas component)
594     (delete fun (component-lambdas component)))
595     (assert (= (length (block-succ call-block)) 1))
596     (let ((next-block (first (block-succ call-block))))
597     (unlink-blocks call-block next-block)
598     (unlink-blocks (component-head component) bind-block)
599     (link-blocks call-block bind-block)
600     (let ((return (lambda-return fun)))
601     (when return
602     (let ((return-block (node-block return)))
603     (unlink-blocks return-block (component-tail component))
604     (link-blocks return-block next-block)))))
605     (setf (component-reanalyze component) t))
606     (undefined-value))
607    
608    
609     ;;; Move-Return-Uses -- Internal
610     ;;;
611     ;;; Handle the value semantics of let conversion. When Fun has a return
612     ;;; node, we delete it and move all the uses of the result continuation to
613     ;;; Call's Cont.
614     ;;;
615     ;;; If the actual continuation is only used by the let call, then we
616     ;;; intersect the type assertion on the dummy continuation with the assertion
617     ;;; for the actual continuation; in all other cases assertions on the dummy
618     ;;; continuation are lost.
619     ;;;
620     (defun move-return-uses (fun call)
621     (declare (type clambda fun) (type basic-combination call))
622     (let ((return (lambda-return fun)))
623     (when return
624     (unlink-node return)
625     (delete-return return)
626    
627     (let ((result (return-result return))
628     (cont (node-cont call)))
629     (when (eq (continuation-use cont) call)
630     (assert-continuation-type cont (continuation-asserted-type result)))
631     (delete-continuation-use call)
632     (add-continuation-use call (node-prev (lambda-bind fun)))
633     (substitute-continuation-uses cont result))))
634    
635     (undefined-value))
636    
637    
638     ;;; Let-Convert -- Internal
639     ;;;
640     ;;; Actually do let conversion. We call subfunctions to do most of the
641     ;;; work. We change the Call's cont to be the continuation heading the bind
642     ;;; block, and also do Reoptimize-Continuation on the args and Cont so that
643 ram 1.5 ;;; let-specific IR1 optimizations get a chance. We blow away any entry for
644     ;;; the function in *free-functions* so that nobody will create new reference
645     ;;; to it.
646 wlott 1.1 ;;;
647     (defun let-convert (fun call)
648     (declare (type clambda fun) (type basic-combination call))
649 ram 1.2 (insert-let-body fun call)
650 ram 1.5.1.2 (merge-lets fun call)
651 wlott 1.1 (move-return-uses fun call)
652 ram 1.5
653     (let* ((fun (or (lambda-optional-dispatch fun) fun))
654     (entry (gethash (leaf-name fun) *free-functions*)))
655     (when (eq entry fun)
656     (remhash (leaf-name fun) *free-functions*)))
657 wlott 1.1
658     (dolist (arg (basic-combination-args call))
659     (when arg
660     (reoptimize-continuation arg)))
661     (reoptimize-continuation (node-cont call))
662     (undefined-value))
663    
664    
665     ;;; Maybe-Let-Convert -- Interface
666     ;;;
667     ;;; This function is called when there is some reason to believe that
668     ;;; the lambda Fun might be converted into a let. This is done after local
669     ;;; call analysis, and also when a reference is deleted. We only convert to a
670     ;;; let when the function is a normal local function, has no XEP, and is
671     ;;; referenced in exactly one local call. Conversion is also inhibited if the
672     ;;; only reference is in a block about to be deleted.
673     ;;;
674     ;;; These rules may seem unnecessarily restrictive, since there are some
675     ;;; cases where we could do the return with a jump that don't satisfy these
676     ;;; requirements. The reason for doing things this way is that it makes the
677     ;;; concept of a let much more useful at the level of IR1 semantics. Low-level
678     ;;; control and environment optimizations can always be done later on.
679     ;;;
680     ;;; We don't attempt to convert calls to functions that have an XEP, since
681     ;;; we might be embarrassed later when we want to convert a newly discovered
682     ;;; local call.
683     ;;;
684     (defun maybe-let-convert (fun)
685     (declare (type clambda fun))
686     (let ((refs (leaf-refs fun)))
687     (when (and refs (null (rest refs))
688     (not (block-delete-p (node-block (first refs))))
689     (not (functional-kind fun))
690     (not (functional-entry-function fun)))
691     (let* ((ref-cont (node-cont (first refs)))
692     (dest (continuation-dest ref-cont)))
693     (when (and (basic-combination-p dest)
694     (eq (basic-combination-fun dest) ref-cont)
695     (eq (basic-combination-kind dest) :local))
696     (let-convert fun dest)
697     (setf (functional-kind fun)
698     (if (mv-combination-p dest) :mv-let :let))))))
699     (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5