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

Diff of /src/compiler/locall.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5.1.2 by ram, Fri Jun 15 15:40:26 1990 UTC revision 1.61 by rtoy, Fri Mar 19 15:19:00 2010 UTC
# Line 1  Line 1 
1  ;;; -*- Package: C; Log: C.Log -*-  ;;; -*- Package: C; Log: C.Log -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; 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.  ;;; 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).  (ext:file-comment
8      "$Header$")
9    ;;;
10  ;;; **********************************************************************  ;;; **********************************************************************
11  ;;;  ;;;
12  ;;;    This file implements local call analysis.  A local call is a function  ;;;    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  ;;; 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 modify the flow graph to  ;;; compile time that such a call is legal, then we change the combination
15  ;;; represent the control transfers previously implicit in the call.  This  ;;; to call the correct lambda, mark it as local, and add this link to our call
16  ;;; change allows us to do inter-routine flow analysis.  ;;; 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  ;;;    We cannot always do a local call even when we do have the function being
20  ;;; called.  Local call can be explicitly disabled by a NOTINLINE declaration.  ;;; called.  Calls that cannot be shown to have legal arg counts are not
21  ;;; Calls that cannot be shown to have legal arg counts are also not converted.  ;;; converted.
22  ;;;  ;;;
23  ;;; Written by Rob MacLachlan  ;;; Written by Rob MacLachlan
24  ;;;  ;;;
25  (in-package 'c)  (in-package :c)
26    (intl:textdomain "cmucl")
27    
28    
29  ;;; Propagate-To-Args  --  Internal  ;;; Propagate-To-Args  --  Interface
30  ;;;  ;;;
31  ;;;    This function propagates information from the variables in the function  ;;;    This function propagates information from the variables in the function
32  ;;; Fun to the actual arguments in Call.  ;;; 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  ;;;  ;;;
35  ;;;    We flush all arguments to Call that correspond to unreferenced variables  ;;;    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  ;;; in Fun.  We leave NILs in the Combination-Args so that the remaining args
# Line 42  Line 47 
47      (let ((arg (car args))      (let ((arg (car args))
48            (var (car vars)))            (var (car vars)))
49        (cond ((leaf-refs var)        (cond ((leaf-refs var)
50               (assert-continuation-type arg (leaf-type var)))               (assert-continuation-optional-type arg (leaf-type var)))
51              (t              (t
52               (flush-dest arg)               (flush-dest arg)
53               (setf (car args) nil)))))               (setf (car args) nil)))))
# Line 50  Line 55 
55    (undefined-value))    (undefined-value))
56    
57    
58    ;;; 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    (defun merge-tail-sets (call &optional (new-fun (combination-lambda call)))
73      (declare (type basic-combination call) (type clambda new-fun))
74      (let ((return (continuation-dest (node-cont call))))
75        (when (return-p return)
76          (let ((call-set (lambda-tail-set (node-home-lambda call)))
77                (fun-set (lambda-tail-set new-fun)))
78            (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  ;;; Convert-Call  --  Internal  ;;; Convert-Call  --  Internal
89  ;;;  ;;;
90  ;;;    Convert a combination into a local call.  We Propagate-To-Args, set the  ;;;    Convert a combination into a local call.  We PROPAGATE-TO-ARGS, set the
91  ;;; combination kind to :Local, add Fun to the Calls of the function that the  ;;; combination kind to :Local, add Fun to the Calls of the function that the
92  ;;; call is in, then replace the function in the Ref node with the new  ;;; call is in, call MERGE-TAIL-SETS, then replace the function in the Ref node
93  ;;; function.  ;;; with the new function.
94  ;;;  ;;;
95  ;;;    We change the Ref last, since changing the reference can trigger let  ;;; We change the Ref last, since changing the reference can trigger let
96  ;;; conversion of the new function, but will only do so if the call is local.  ;;; conversion of the new function, but will only do so if the call is local.
97    ;;; 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  ;;;  ;;;
102  (defun convert-call (ref call fun)  (defun convert-call (ref call fun)
103    (declare (type ref ref) (type combination call) (type clambda fun))    (declare (type ref ref) (type combination call) (type clambda fun))
104    (propagate-to-args call fun)    (propagate-to-args call fun)
105    (setf (basic-combination-kind call) :local)    (setf (basic-combination-kind call) :local)
106    (pushnew fun (lambda-calls (node-home-lambda call)))    (note-dfo-dependency call fun)
107      (merge-tail-sets call fun)
108    (change-ref-leaf ref fun)    (change-ref-leaf ref fun)
109    (undefined-value))    (undefined-value))
110    
# Line 109  Line 149 
149           (dotimes (i nargs)           (dotimes (i nargs)
150             (temps (gensym)))             (temps (gensym)))
151           `(lambda (,n-supplied ,@(temps))           `(lambda (,n-supplied ,@(temps))
152              (declare (fixnum ,n-supplied))              (declare (type index ,n-supplied))
153              ,(if (policy (lambda-bind fun) (zerop safety))              ,(if (policy nil (zerop safety))
154                   `(declare (ignore ,n-supplied))                   `(declare (ignore ,n-supplied))
155                   `(%verify-argument-count ,n-supplied ,nargs))                   `(%verify-argument-count ,n-supplied ,nargs))
156              (%funcall ,fun ,@(temps))))))              (%funcall ,fun ,@(temps))))))
# Line 131  Line 171 
171                        (%funcall ,(first eps) ,@(subseq (temps) 0 n)))))                        (%funcall ,(first eps) ,@(subseq (temps) 0 n)))))
172    
173           `(lambda (,n-supplied ,@(temps))           `(lambda (,n-supplied ,@(temps))
174              (declare (fixnum ,n-supplied))              (declare (type index ,n-supplied))
175              (cond              (cond
176               ,@(if more (butlast (entries)) (entries))               ,@(if more (butlast (entries)) (entries))
177               ,@(when more               ,@(when more
# Line 152  Line 192 
192  ;;; the result of Make-XEP-Lambda in the correct environment, then associate  ;;; 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  ;;; 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  ;;; function's associated lambdas, redoing local call analysis so that the XEP
195  ;;; calls will get converted.  ;;; calls will get converted.  We also bind *lexical-environment* to change the
196    ;;; compilation policy over to the interface policy.
197  ;;;  ;;;
198  ;;;    We set Reanalyze and Reoptimize in the component, just in case we  ;;;    We set Reanalyze and Reoptimize in the component, just in case we
199  ;;; discover an XEP after the initial local call analyze pass.  ;;; discover an XEP after the initial local call analyze pass.
# Line 161  Line 202 
202    (declare (type functional fun))    (declare (type functional fun))
203    (assert (not (functional-entry-function fun)))    (assert (not (functional-entry-function fun)))
204    (with-ir1-environment (lambda-bind (main-entry fun))    (with-ir1-environment (lambda-bind (main-entry fun))
205      (let ((res (ir1-convert-lambda (make-xep-lambda fun))))      (let* ((*lexical-environment*
206                (make-lexenv :cookie
207                             (make-interface-cookie *lexical-environment*)))
208               (res (ir1-convert-lambda (make-xep-lambda fun))))
209        (setf (functional-kind res) :external)        (setf (functional-kind res) :external)
210          (setf (leaf-ever-used res) t)
211        (setf (functional-entry-function res) fun)        (setf (functional-entry-function res) fun)
212        (setf (functional-entry-function fun) res)        (setf (functional-entry-function fun) res)
213        (setf (component-reanalyze *current-component*) t)        (setf (component-reanalyze *current-component*) t)
# Line 194  Line 239 
239        (change-ref-leaf ref (or (functional-entry-function fun)        (change-ref-leaf ref (or (functional-entry-function fun)
240                                 (make-external-entry-point fun))))))                                 (make-external-entry-point fun))))))
241    
242    
243    
244  ;;; Local-Call-Analyze-1  --  Interface  ;;; Local-Call-Analyze-1  --  Interface
245  ;;;  ;;;
246  ;;;    Attempt to convert all references to Fun to local calls.  The reference  ;;;    Attempt to convert all references to Fun to local calls.  The reference
247  ;;; cannot be :Notinline, and must be the function for a call.  The function  ;;; must be the function for a call, and the function continuation must be used
248  ;;; continuation must be used only once, since otherwise we cannot be sure what  ;;; only once, since otherwise we cannot be sure what function is to be called.
249  ;;; function is to be called.  The call continuation would be multiply used if  ;;; The call continuation would be multiply used if there is hairy stuff such
250  ;;; there is hairy stuff such as conditionals in the expression that computes  ;;; as conditionals in the expression that computes the function.
 ;;; the function.  
 ;;;  
 ;;;    Except in the interpreter, we don't attempt to convert calls that appear  
 ;;; in a top-level lambda unless there is only one reference.  This ensures  
 ;;; that top-level components will contain only load-time code: any references  
 ;;; to run-time functions will be as closures.  
251  ;;;  ;;;
252  ;;;    If we cannot convert a reference, then we mark the referenced function  ;;;    If we cannot convert a reference, then we mark the referenced function
253  ;;; as an entry-point, creating a new XEP if necessary.  ;;; 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  ;;;  ;;;
256  ;;;    This is broken off from Local-Call-Analyze so that people can force  ;;;    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  ;;; analysis of newly introduced calls.  Note that we don't do let conversion
# Line 218  Line 259 
259  ;;;  ;;;
260  (defun local-call-analyze-1 (fun)  (defun local-call-analyze-1 (fun)
261    (declare (type functional fun))    (declare (type functional fun))
262    (let ((refs (leaf-refs fun)))    (let ((refs (leaf-refs fun))
263            (first-time t))
264      (dolist (ref refs)      (dolist (ref refs)
265        (let* ((cont (node-cont ref))        (let* ((cont (node-cont ref))
266               (dest (continuation-dest cont)))               (dest (continuation-dest cont)))
267          (cond ((and (basic-combination-p dest)          (cond ((and (basic-combination-p dest)
268                      (eq (basic-combination-fun dest) cont)                      (eq (basic-combination-fun dest) cont)
269                      (eq (continuation-use cont) ref)                      (eq (continuation-use cont) ref))
270                      (or (null (rest refs))  
271                          *converting-for-interpreter*                 (convert-call-if-possible ref dest)
                         (not (eq (functional-kind (node-home-lambda ref))  
                                  :top-level))))  
                (ecase (ref-inlinep ref)  
                  ((nil :inline)  
                   (convert-call-if-possible ref dest))  
                  ((:notinline)))  
272    
273                 (unless (eq (basic-combination-kind dest) :local)                 (unless (eq (basic-combination-kind dest) :local)
274                   (reference-entry-point ref)))                   (reference-entry-point ref)))
275                (t                (t
276                 (reference-entry-point ref))))))                 (reference-entry-point ref))))
277          (setq first-time nil)))
278    
279    (undefined-value))    (undefined-value))
280    
# Line 254  Line 291 
291  ;;; triggered by reference deletion.  In particular, the Component-Lambdas are  ;;; triggered by reference deletion.  In particular, the Component-Lambdas are
292  ;;; being hacked to remove newly deleted and let converted lambdas, so it is  ;;; 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.  ;;; important that the lambda is added to the Component-Lambdas when it is.
294    ;;; Also, the COMPONENT-NEW-FUNCTIONS may contain all sorts of drivel, since it
295    ;;; is not updated when we delete functions, etc.  Only COMPONENT-LAMBDAS is
296    ;;; updated.
297    ;;;
298    ;;; COMPONENT-REANALYZE-FUNCTIONS is treated similarly to NEW-FUNCTIONS, but we
299    ;;; don't add lambdas to the LAMBDAS.
300  ;;;  ;;;
301  (defun local-call-analyze (component)  (defun local-call-analyze (component)
302    (declare (type component component))    (declare (type component component))
303    (loop    (loop
304      (unless (component-new-functions component) (return))      (let* ((new (pop (component-new-functions component)))
305      (let ((fun (pop (component-new-functions component))))             (fun (or new (pop (component-reanalyze-functions component)))))
306        (unless (eq (functional-kind fun) :deleted)        (unless fun (return))
307          (when (lambda-p fun)        (let ((kind (functional-kind fun)))
308            (push fun (component-lambdas component)))          (cond ((member kind '(:deleted :let :mv-let :assignment)))
309          (local-call-analyze-1 fun)                ((and (null (leaf-refs fun)) (eq kind nil)
310          (when (lambda-p fun)                      (not (functional-entry-function fun)))
311            (maybe-let-convert fun)))))                 (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    
319    (undefined-value))    (undefined-value))
320    
321    
322    ;;; 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               (not *converting-for-interpreter*)
332               (inline-expansion-ok call))
333          (with-ir1-environment call
334            (let* ((*lexical-environment* (functional-lexenv fun))
335                   (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                       (compiler-note _N"Couldn't inline expand because expansion ~
346                                       calls this let-converted local function:~
347                                       ~%  ~S"
348                                      (leaf-name res)))
349                     fun))))
350          fun))
351    
352    
353  ;;; Convert-Call-If-Possible  --  Interface  ;;; Convert-Call-If-Possible  --  Interface
354  ;;;  ;;;
355  ;;;    Dispatch to the appropriate function to attempt to convert a call.  This  ;;;    Dispatch to the appropriate function to attempt to convert a call.  Ref
356  ;;; is called in IR1 optimize as well as in local call analysis.  If the call  ;;; most be a reference to a FUNCTIONAL.  This is called in IR1 optimize as
357  ;;; is already :Local, we do nothing.  If the call is in the top-level  ;;; well as in local call analysis.  If the call is is already :Local, we do
358  ;;; component, also do nothing, since we don't want to join top-level code into  ;;; nothing.  If the call is already scheduled for deletion, also do nothing
359  ;;; normal components.  ;;; (in addition to saving time, this also avoids some problems with optimizing
360    ;;; collections of functions that are partially deleted.)
361    ;;;
362    ;;;    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  ;;;    We bind *Compiler-Error-Context* to the node for the call so that  ;;;    We bind *Compiler-Error-Context* to the node for the call so that
372  ;;; warnings will get the right context.  ;;; warnings will get the right context.
373  ;;;  ;;;
374    ;;;
375  (defun convert-call-if-possible (ref call)  (defun convert-call-if-possible (ref call)
376    (declare (type ref ref) (type basic-combination call))    (declare (type ref ref) (type basic-combination call))
377    (let ((fun (let ((fun (ref-leaf ref)))    (let* ((block (node-block call))
378                 (if (external-entry-point-p fun)           (component (block-component block))
379                     (functional-entry-function fun)           (original-fun (ref-leaf ref)))
380                     fun)))      (assert (functional-p original-fun))
381          (*compiler-error-context* call))      (unless (or (member (basic-combination-kind call) '(:local :error))
382        (cond ((eq (basic-combination-kind call) :local))                  (block-delete-p block)
383              ((mv-combination-p call)                  (eq (functional-kind (block-home-lambda block)) :deleted)
384               (convert-mv-call ref call fun))                  (member (functional-kind original-fun)
385              ((lambda-p fun)                          '(:top-level-xep :deleted))
386               (convert-lambda-call ref call fun))                  (not (or (eq (component-kind component) :initial)
387              (t                           (eq (block-component
388               (convert-hairy-call ref call fun))))                                (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    (undefined-value))    (undefined-value))
410    
411    
# Line 312  Line 423 
423  ;;;    We also use variable types for the called function to construct an  ;;;    We also use variable types for the called function to construct an
424  ;;; assertion for the values continuation.  ;;; assertion for the values continuation.
425  ;;;  ;;;
426    ;;; See CONVERT-CALL for additional notes on MERGE-TAIL-SETS, etc.
427    ;;;
428  (defun convert-mv-call (ref call fun)  (defun convert-mv-call (ref call fun)
429    (declare (type ref ref) (type mv-combination call) (type functional fun))    (declare (type ref ref) (type mv-combination call) (type functional fun))
430    (when (and (looks-like-an-mv-bind fun)    (when (and (looks-like-an-mv-bind fun)
# Line 319  Line 432 
432               (= (length (leaf-refs fun)) 1)               (= (length (leaf-refs fun)) 1)
433               (= (length (basic-combination-args call)) 1))               (= (length (basic-combination-args call)) 1))
434      (let ((ep (car (last (optional-dispatch-entry-points fun)))))      (let ((ep (car (last (optional-dispatch-entry-points fun)))))
       (change-ref-leaf ref ep)  
435        (setf (basic-combination-kind call) :local)        (setf (basic-combination-kind call) :local)
436        (pushnew ep (lambda-calls (node-home-lambda call)))        (note-dfo-dependency call ep)
437          (merge-tail-sets call ep)
438          (change-ref-leaf ref ep)
439    
440        (assert-continuation-type        (assert-continuation-type
441         (first (basic-combination-args call))         (first (basic-combination-args call))
442         (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))         (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
# Line 333  Line 447 
447  ;;; Convert-Lambda-Call  --  Internal  ;;; Convert-Lambda-Call  --  Internal
448  ;;;  ;;;
449  ;;;    Attempt to convert a call to a lambda.  If the number of args is wrong,  ;;;    Attempt to convert a call to a lambda.  If the number of args is wrong,
450  ;;; we give a warning and mark the Ref as :Notinline to remove it from future  ;;; we give a warning and mark the call as :ERROR to remove it from future
451  ;;; consideration.  If the argcount is O.K. then we just convert it.  ;;; consideration.  If the argcount is O.K. then we just convert it.
452  ;;;  ;;;
 (proclaim '(function convert-lambda-call (ref combination lambda) void))  
453  (defun convert-lambda-call (ref call fun)  (defun convert-lambda-call (ref call fun)
454      (declare (type ref ref) (type combination call) (type clambda fun))
455    (let ((nargs (length (lambda-vars fun)))    (let ((nargs (length (lambda-vars fun)))
456          (call-args (length (combination-args call))))          (call-args (length (combination-args call))))
457      (cond ((= call-args nargs)      (cond ((= call-args nargs)
458             (convert-call ref call fun))             (convert-call ref call fun))
459            (t            (t
460             (compiler-warning             (compiler-warning
461              "Function called with ~R argument~:P, but wants exactly ~R."              _N"Function called with ~R argument~:P, but wants exactly ~R."
462              call-args nargs)              call-args nargs)
463             (setf (ref-inlinep ref) :notinline)))))             (setf (basic-combination-kind call) :error)))))
464    
465    
466    
# Line 366  Line 480 
480          (max-args (optional-dispatch-max-args fun))          (max-args (optional-dispatch-max-args fun))
481          (call-args (length (combination-args call))))          (call-args (length (combination-args call))))
482      (cond ((< call-args min-args)      (cond ((< call-args min-args)
483             (compiler-warning "Function called with ~R argument~:P, but wants at least ~R."             (compiler-warning _N"Function called with ~R argument~:P, but wants at least ~R."
484                               call-args min-args)                               call-args min-args)
485             (setf (ref-inlinep ref) :notinline))             (setf (basic-combination-kind call) :error))
486            ((<= call-args max-args)            ((<= call-args max-args)
487             (convert-call ref call             (convert-call ref call
488                           (elt (optional-dispatch-entry-points fun)                           (elt (optional-dispatch-entry-points fun)
489                                (- call-args min-args))))                                (- call-args min-args))))
490            ((not (optional-dispatch-more-entry fun))            ((optional-dispatch-more-entry fun)
491             (compiler-warning "Function called with ~R argument~:P, but wants at most ~R."             (convert-more-call ref call fun))
492              (t
493               (compiler-warning _N"Function called with ~R argument~:P, but wants at most ~R."
494                               call-args max-args)                               call-args max-args)
495             (setf (ref-inlinep ref) :notinline))             (setf (basic-combination-kind call) :error))))
           ((optional-dispatch-keyp fun)  
            (cond ((oddp (- call-args max-args))  
                   (compiler-warning "Function called with odd number of ~  
                                     arguments in keyword portion."))  
                  (t  
                   (convert-keyword-call ref call fun))))))  
   
496    (undefined-value))    (undefined-value))
497    
498    
# Line 401  Line 510 
510  ;;; new function and the entry point immediately so that everything gets  ;;; new function and the entry point immediately so that everything gets
511  ;;; converted during the single pass.  ;;; converted during the single pass.
512  ;;;  ;;;
 (proclaim '(function convert-hairy-fun-entry  
                      (ref combination lambda list list list)))  
513  (defun convert-hairy-fun-entry (ref call entry vars ignores args)  (defun convert-hairy-fun-entry (ref call entry vars ignores args)
514      (declare (list vars ignores args) (type ref ref) (type combination call)
515               (type clambda entry))
516    (let ((new-fun    (let ((new-fun
517           (with-ir1-environment call           (with-ir1-environment call
518             (ir1-convert-lambda             (ir1-convert-lambda
519              `(lambda ,vars              `(lambda ,vars
520                 (declare (ignore . ,ignores))                 (declare (ignorable . ,ignores))
521                 (%funcall ,entry . ,args))))))                 (%funcall ,entry . ,args))))))
522      (convert-call ref call new-fun)      (convert-call ref call new-fun)
523      (dolist (ref (leaf-refs entry))      (dolist (ref (leaf-refs entry))
524        (convert-call-if-possible ref (continuation-dest (node-cont ref))))))        (convert-call-if-possible ref (continuation-dest (node-cont ref))))))
525    
526    
527  ;;; Convert-Keyword-Call  --  Internal  ;;; Convert-More-Call  --  Internal
528  ;;;  ;;;
529  ;;;    Use Convert-Hairy-Fun-Entry to convert a keyword call to a known  ;;;    Use Convert-Hairy-Fun-Entry to convert a more-arg call to a known
530  ;;; functions into a local call to the Main-Entry.  ;;; function into a local call to the Main-Entry.
531  ;;;  ;;;
532  ;;;    First we verify that all keywords are constant and legal.  If there  ;;;    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.  ;;; aren't, then we warn the user and don't attempt to convert the call.
# Line 430  Line 539 
539  ;;; (such as the keywords themselves) are discarded simply by not passing them  ;;; (such as the keywords themselves) are discarded simply by not passing them
540  ;;; along.  ;;; along.
541  ;;;  ;;;
542  (defun convert-keyword-call (ref call fun)  ;;;    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    (declare (type ref ref) (type combination call) (type optional-dispatch fun))    (declare (type ref ref) (type combination call) (type optional-dispatch fun))
547    (let* ((max (optional-dispatch-max-args fun))    (let* ((max (optional-dispatch-max-args fun))
548           (arglist (optional-dispatch-arglist fun))           (arglist (optional-dispatch-arglist fun))
549           (args (combination-args call))           (args (combination-args call))
550           (keys (nthcdr max args))           (more (nthcdr max args))
551           (loser nil))           (flame (policy call (or (> speed brevity) (> space brevity))))
552             (loser nil)
553             (allowp nil)
554             (allow-found nil))
555      (collect ((temps)      (collect ((temps)
556                  (more-temps)
557                (ignores)                (ignores)
558                (supplied)                (supplied)
559                (key-vars))                (key-vars))
# Line 446  Line 562 
562          (let ((info (lambda-var-arg-info var)))          (let ((info (lambda-var-arg-info var)))
563            (when info            (when info
564              (ecase (arg-info-kind info)              (ecase (arg-info-kind info)
               (:rest  
                (setf (ref-inlinep ref) :notinline)  
                (return-from convert-keyword-call))  
565                (:keyword                (:keyword
566                 (key-vars var))                 (key-vars var))
567                (:optional)))))                ((:rest :optional))
568                  ((:more-context :more-count)
569                   (compiler-warning _N"Can't local-call functions with &MORE args.")
570                   (setf (basic-combination-kind call) :error)
571                   (return-from convert-more-call))))))
572    
573        (dotimes (i max)        (dotimes (i max)
574          (temps (gensym)))          (temps (gensym "FIXED-ARG-TEMP-")))
575    
576        (do ((key keys (cddr key)))        (dotimes (i (length more))
577            ((null key))          (more-temps (gensym "MORE-ARG-TEMP-")))
         (let ((cont (first key)))  
           (unless (constant-continuation-p cont)  
             (when (policy call (or (> speed brevity) (> space brevity)))  
               (compiler-note "Non-constant keyword in keyword call."))  
             (setf (ref-inlinep ref) :notinline)  
             (return-from convert-keyword-call))  
   
           (let ((name (continuation-value cont)))  
             (dolist (var (key-vars)  
                          (let ((dummy1 (gensym))  
                                (dummy2 (gensym)))  
                            (temps dummy1 dummy2)  
                            (ignores dummy1 dummy2)  
                            (setq loser name)))  
               (let ((info (lambda-var-arg-info var)))  
                 (when (eq (arg-info-keyword info) name)  
                   (let ((dummy (gensym))  
                         (temp (gensym)))  
                     (temps dummy temp)  
                     (ignores dummy)  
                     (supplied (cons var temp)))  
                   (return)))))))  
578    
579        (when (and loser (not (optional-dispatch-allowp fun)))        (when (optional-dispatch-keyp fun)
580          (compiler-warning "Function called with unknown argument keyword ~S."          (when (oddp (length more))
581                            loser)            (compiler-warning _N"Function called with odd number of ~
582          (setf (ref-inlinep ref) :notinline)                               arguments in keyword portion.")
583          (return-from convert-keyword-call))  
584              (setf (basic-combination-kind call) :error)
585              (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                    (compiler-note _N"Non-constant keyword in keyword call."))
594                  (setf (basic-combination-kind call) :error)
595                  (return-from convert-more-call))
596    
597                (let ((name (continuation-value cont))
598                      (dummy (first temp))
599                      (val (second temp)))
600                  ;; 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                               (compiler-note _N"non-constant :ALLOW-OTHER-KEYS value"))
609                             (setf (basic-combination-kind call) :error)
610                             (return-from convert-more-call)))))
611                  (dolist (var (key-vars)
612                               (progn
613                                 (ignores dummy val)
614                                 (unless (eq name :allow-other-keys)
615                                   ;; 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                    (let ((info (lambda-var-arg-info var)))
621                      (when (eq (arg-info-keyword info) name)
622                        (ignores dummy)
623                        (supplied (cons var val))
624                        (return)))))))
625    
626            (when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
627              (compiler-warning _N"Function called with unknown argument keyword ~S."
628                                (car loser))
629              (setf (basic-combination-kind call) :error)
630              (return-from convert-more-call)))
631    
632        (collect ((call-args))        (collect ((call-args))
633          (do ((var arglist (cdr var))          (do ((var arglist (cdr var))
634               (temp (temps) (cdr temp)))               (temp (temps) (cdr temp)))
635              (())              ((null var))
636            (let ((info (lambda-var-arg-info (car var))))            (let ((info (lambda-var-arg-info (car var))))
637              (if info              (if info
638                  (case (arg-info-kind info)                  (ecase (arg-info-kind info)
639                    (:optional                    (:optional
640                     (call-args (car temp))                     (call-args (car temp))
641                     (when (arg-info-supplied-p info)                     (when (arg-info-supplied-p info)
642                       (call-args t)))                       (call-args t)))
643                    (t                    (:rest
644                       ;;
645                       ;; We could do something here if the variable is
646                       ;; declared dynamic-extent.
647                       (call-args `(list ,@(more-temps)))
648                       (return))
649                      (:keyword
650                     (return)))                     (return)))
651                  (call-args (car temp)))))                  (call-args (car temp)))))
652    
# Line 512  Line 660 
660                (call-args (not (null temp))))))                (call-args (not (null temp))))))
661    
662          (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)          (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
663                                   (temps) (ignores) (call-args)))))                                   (append (temps) (more-temps))
664                                     (ignores) (call-args)))))
665    
666    (undefined-value))    (undefined-value))
667    
# Line 521  Line 670 
670  ;;;  ;;;
671  ;;;    Converting to a let has differing significance to various parts of the  ;;;    Converting to a let has differing significance to various parts of the
672  ;;; compiler:  ;;; compiler:
673  ;;; -- The body of a Let is spliced in immediately after the the corresponding  ;;; -- The body of a Let is spliced in immediately after the corresponding
674  ;;;    combination node, making the control transfer explicit and allowing lets  ;;;    combination node, making the control transfer explicit and allowing lets
675  ;;;    to mashed together into a single block.  The value of the let is  ;;;    to mashed together into a single block.  The value of the let is
676  ;;;    delivered directly to the original continuation for the call,  ;;;    delivered directly to the original continuation for the call,
# Line 539  Line 688 
688  ;;;    longer in effect.  ;;;    longer in effect.
689    
690    
691    ;;; 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  ;;; Merge-Lets  --  Internal  ;;; Merge-Lets  --  Internal
722  ;;;  ;;;
723  ;;;    Handle the environment semantics of let conversion.  We add the lambda  ;;;    Handle the environment semantics of let conversion.  We add the lambda
724  ;;; and its lets to lets for the call's home function.  We merge the calls for  ;;; and its lets to lets for the Call's home function.  We merge the calls for
725  ;;; Fun with the calls for the home function, removing Fun in the process.  We  ;;; Fun with the calls for the home function, removing Fun in the process.  We
726  ;;; also merge the Entries.  ;;; also merge the Entries.
727  ;;;  ;;;
728    ;;;   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  (defun merge-lets (fun call)  (defun merge-lets (fun call)
732    (declare (type clambda fun) (type basic-combination call))    (declare (type clambda fun) (type basic-combination call))
733    (let* ((prev (node-prev call))    (let ((component (block-component (node-block call))))
734           (home (block-home-lambda (continuation-block prev)))      (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           (home-env (lambda-environment home)))           (home-env (lambda-environment home)))
745    
746        (assert (not (eq home fun)))
747    
748        ;; FUN belongs to HOME now.
749      (push fun (lambda-lets home))      (push fun (lambda-lets home))
750      (setf (lambda-home fun) home)      (setf (lambda-home fun) home)
751      (setf (lambda-environment fun) home-env)      (setf (lambda-environment fun) home-env)
752    
753        ;; All of FUN's LETs belong to HOME now
754      (let ((lets (lambda-lets fun)))      (let ((lets (lambda-lets fun)))
755        (dolist (let lets)        (dolist (let lets)
756          (setf (lambda-home let) home)          (setf (lambda-home let) home)
757          (setf (lambda-environment let) home-env))          (setf (lambda-environment let) home-env))
758    
759        (setf (lambda-lets home) (nconc lets (lambda-lets home)))        (setf (lambda-lets home) (nconc lets (lambda-lets home)))
760          ;; FUN no longer has an independent existence as an entity which
761          ;; has LETs.
762        (setf (lambda-lets fun) ()))        (setf (lambda-lets fun) ()))
763    
764      (setf (lambda-calls home)      ;; HOME no longer calls FUN, and owns all of FUN's old DFO
765            (nunion (lambda-calls fun)      ;; dependencies
766                    (delete fun (lambda-calls home))))      (setf (lambda-dfo-dependencies home)
767      (setf (lambda-calls fun) ())            (delete fun (nunion (lambda-dfo-dependencies fun)
768                                  (lambda-dfo-dependencies home))))
769        ;; FUN no longer has an independent existence as an entity
770        ;; which calls things or has DFO dependencies.
771        (setf (lambda-dfo-dependencies fun) ())
772    
773        ;; All of FUN's ENTRIES belong to HOME now.
774      (setf (lambda-entries home)      (setf (lambda-entries home)
775            (nconc (lambda-entries fun) (lambda-entries home)))            (nconc (lambda-entries fun) (lambda-entries home)))
776        ;; FUN no longer has an independent existence as an entity
777        ;; with ENTRIES.
778      (setf (lambda-entries fun) ()))      (setf (lambda-entries fun) ()))
779    (undefined-value))    (undefined-value))
780    
781    
 ;;; Insert-Let-Body  --  Internal  
 ;;;  
 ;;;    Handle the control semantics of let conversion.  We split the call block  
 ;;; immediately after the call, and link the head and tail of Fun to the call  
 ;;; block and the following block.  We also unlink the function head and tail  
 ;;; from the component head and tail and flush the function from the  
 ;;; Component-Lambdas.  We set Component-Reanalyze to true to indicate that the  
 ;;; DFO should be recomputed.  
 ;;;  
 (defun insert-let-body (fun call)  
   (declare (type clambda fun) (type basic-combination call))  
   (let* ((call-block (node-block call))  
          (bind-block (node-block (lambda-bind fun)))  
          (component (block-component call-block)))  
     (let ((*current-component* component))  
       (node-ends-block call))  
     (setf (component-lambdas component)  
           (delete fun (component-lambdas component)))  
     (assert (= (length (block-succ call-block)) 1))  
     (let ((next-block (first (block-succ call-block))))  
       (unlink-blocks call-block next-block)  
       (unlink-blocks (component-head component) bind-block)  
       (link-blocks call-block bind-block)  
       (let ((return (lambda-return fun)))  
         (when return  
           (let ((return-block (node-block return)))  
             (unlink-blocks return-block (component-tail component))  
             (link-blocks return-block next-block)))))  
     (setf (component-reanalyze component) t))  
   (undefined-value))  
   
   
782  ;;; Move-Return-Uses  --  Internal  ;;; Move-Return-Uses  --  Internal
783  ;;;  ;;;
784  ;;;    Handle the value semantics of let conversion.  When Fun has a return  ;;;    Handle the value semantics of let conversion.  Delete Fun's return node,
785  ;;; node, we delete it and move all the uses of the result continuation to  ;;; and change the control flow to transfer to Next-Block instead.  Move all
786  ;;; Call's Cont.  ;;; the uses of the result continuation to Call's Cont.
787  ;;;  ;;;
788  ;;;    If the actual continuation is only used by the let call, then we  ;;;    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  ;;; intersect the type assertion on the dummy continuation with the assertion
790  ;;; for the actual continuation; in all other cases assertions on the dummy  ;;; for the actual continuation; in all other cases assertions on the dummy
791  ;;; continuation are lost.  ;;; continuation are lost.
792  ;;;  ;;;
793  (defun move-return-uses (fun call)  ;;;    We also intersect the derived type of the call with the derived type of
794    (declare (type clambda fun) (type basic-combination call))  ;;; all the dummy continuation's uses.  This serves mainly to propagate
795    (let ((return (lambda-return fun)))  ;;; TRULY-THE through lets.
796      (when return  ;;;
797        (unlink-node return)  (defun move-return-uses (fun call next-block)
798        (delete-return return)    (declare (type clambda fun) (type basic-combination call)
799               (type cblock next-block))
800        (let ((result (return-result return))    (let* ((return (lambda-return fun))
801              (cont (node-cont call)))           (return-block (node-block return)))
802          (when (eq (continuation-use cont) call)      (unlink-blocks return-block
803            (assert-continuation-type cont (continuation-asserted-type result)))                     (component-tail (block-component return-block)))
804          (delete-continuation-use call)      (link-blocks return-block next-block)
805          (add-continuation-use call (node-prev (lambda-bind fun)))      (unlink-node return)
806          (substitute-continuation-uses cont result))))      (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    
818    
819    
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      (undefined-value))
834    
835    
836    ;;; 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    ;;; 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    ;;;
844    ;;;    The called function might be an assignment in the case where we are
845    ;;; currently converting that function.  In steady-state, assignments never
846    ;;; appear in the lambda-dfo-dependencies.
847    ;;;
848    (defun unconvert-tail-calls (fun call next-block)
849      (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              (when (and this-call
854                         (node-tail-p this-call)
855                         (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    
871    
872    ;;; 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    ;;; 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    ;;; We do different things depending on whether the caller and callee have
885    ;;; returns left:
886    ;;; -- 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    ;;; -- 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    ;;;    return to the caller.
894    ;;;
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      (when next-block
899        (unconvert-tail-calls fun call next-block))
900      (let* ((return (lambda-return fun))
901             (call-fun (node-home-lambda call))
902             (call-return (lambda-return call-fun)))
903        (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    (undefined-value))    (undefined-value))
914    
915    
# Line 646  Line 924 
924  ;;;  ;;;
925  (defun let-convert (fun call)  (defun let-convert (fun call)
926    (declare (type clambda fun) (type basic-combination call))    (declare (type clambda fun) (type basic-combination call))
927    (insert-let-body fun call)    (let ((next-block (if (node-tail-p call)
928    (merge-lets fun call)                          nil
929    (move-return-uses fun call)                          (insert-let-body fun call))))
930        (move-return-stuff fun call next-block)
931    (let* ((fun (or (lambda-optional-dispatch fun) fun))      (merge-lets fun call)))
          (entry (gethash (leaf-name fun) *free-functions*)))  
     (when (eq entry fun)  
       (remhash (leaf-name fun) *free-functions*)))  
932    
933    
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    (dolist (arg (basic-combination-args call))    (dolist (arg (basic-combination-args call))
941      (when arg      (when arg
942        (reoptimize-continuation arg)))        (reoptimize-continuation arg)))
943    (reoptimize-continuation (node-cont call))    (reoptimize-continuation (node-cont call))
944    (undefined-value))    (undefined-value))
945    
946    ;;;  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    
960    
961  ;;; Maybe-Let-Convert  --  Interface  ;;; Maybe-Let-Convert  --  Interface
962  ;;;  ;;;
# Line 669  Line 965 
965  ;;; call analysis, and also when a reference is deleted.  We only convert to a  ;;; 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  ;;; 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  ;;; referenced in exactly one local call.  Conversion is also inhibited if the
968  ;;; only reference is in a block about to be deleted.  ;;; only reference is in a block about to be deleted.  We return true if we
969    ;;; converted.
970  ;;;  ;;;
971  ;;;    These rules may seem unnecessarily restrictive, since there are some  ;;;    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  ;;; 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  ;;; requirements.  The reason for doing things this way is that it makes the
974  ;;; concept of a let much more useful at the level of IR1 semantics.  Low-level  ;;; concept of a let much more useful at the level of IR1 semantics.  The
975  ;;; control and environment optimizations can always be done later on.  ;;; :ASSIGNMENT function kind provides another way to optimize calls to
976    ;;; single-return/multiple call functions.
977  ;;;  ;;;
978  ;;;    We don't attempt to convert calls to functions that have an XEP, since  ;;;    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  ;;; we might be embarrassed later when we want to convert a newly discovered
980  ;;; local call.  ;;; local call.  Also, see OK-INITIAL-CONVERT-P.
981  ;;;  ;;;
982  (defun maybe-let-convert (fun)  (defun maybe-let-convert (fun)
983    (declare (type clambda fun))    (declare (type clambda fun))
984    (let ((refs (leaf-refs fun)))    (let ((refs (leaf-refs fun)))
985      (when (and refs (null (rest refs))      (when (and refs (null (rest refs))
986                 (not (block-delete-p (node-block (first refs))))                 (member (functional-kind fun) '(nil :assignment))
                (not (functional-kind fun))  
987                 (not (functional-entry-function fun)))                 (not (functional-entry-function fun)))
988        (let* ((ref-cont (node-cont (first refs)))        (let* ((ref-cont (node-cont (first refs)))
989               (dest (continuation-dest ref-cont)))               (call (continuation-dest ref-cont)))
990          (when (and (basic-combination-p dest)          (when (and call
991                     (eq (basic-combination-fun dest) ref-cont)                     (basic-combination-p call)
992                     (eq (basic-combination-kind dest) :local))                     (eq (basic-combination-fun call) ref-cont)
993            (let-convert fun dest)                     (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                       (cond ((ok-initial-convert-p fun) t)
1003                             (t
1004                              (reoptimize-continuation ref-cont)
1005                              nil)))
1006              (when (eq fun (node-home-lambda call))
1007                (delete-lambda fun)
1008                (return-from maybe-let-convert nil))
1009              (unless (eq (functional-kind fun) :assignment)
1010                (let-convert fun call))
1011              (reoptimize-call call)
1012            (setf (functional-kind fun)            (setf (functional-kind fun)
1013                  (if (mv-combination-p dest) :mv-let :let))))))                  (if (mv-combination-p call) :mv-let :let))))
1014    (undefined-value))        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    ;;;    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    ;;; 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    ;;; -- The call has already been converted.
1047    ;;; -- The call isn't TR (random implicit MV PROG1.)
1048    ;;; -- 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    ;;;    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    (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                   (immediately-used-p (return-result return) call)
1061                   (not (eq (functional-kind (node-home-lambda call))
1062                            :external))
1063                   (not (functional-inlinep (node-home-lambda call)))
1064                   (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    ;;; 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    ;;; -- The function is a normal, non-entry function, and
1082    ;;; -- Except for one call, all calls must be tail recursive calls in the
1083    ;;;    called function (i.e. are self-recursive tail calls)
1084    ;;; -- OK-INITIAL-CONVERT-P is true.
1085    ;;;
1086    ;;;    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    ;;;
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        (let ((outside-non-tail-call nil)
1102              (outside-call nil))
1103          (when (and (dolist (ref (leaf-refs fun) t)
1104                       (let ((dest (continuation-dest (node-cont ref))))
1105                         (when (or (not dest)
1106                                   (block-delete-p (node-block dest)))
1107                           (return nil))
1108                         (let ((home (node-home-lambda ref)))
1109                           (unless (eq home fun)
1110                             (when outside-call
1111                               (return nil))
1112                             (setq outside-call dest))
1113                           (unless (node-tail-p dest)
1114                             (when (or outside-non-tail-call (eq home fun))
1115                               (return nil))
1116                             (setq outside-non-tail-call dest)))))
1117                     (ok-initial-convert-p fun))
1118            (cond (outside-call
1119                   (setf (functional-kind fun) :assignment)
1120                   (let-convert fun outside-call)
1121                   (when outside-non-tail-call
1122                     (reoptimize-call outside-non-tail-call))
1123                   t)
1124                  (t
1125                   (delete-lambda fun)
1126                   nil))))))

Legend:
Removed from v.1.5.1.2  
changed lines
  Added in v.1.61

  ViewVC Help
Powered by ViewVC 1.1.5