locall.lisp 40.4 KB
Newer Older
wlott's avatar
wlott committed
1
2
3
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
ram's avatar
ram committed
4
5
6
7
8
9
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
10
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.44 1994/01/06 18:07:06 ram Exp $")
ram's avatar
ram committed
11
;;;
wlott's avatar
wlott committed
12
13
14
15
;;; **********************************************************************
;;;
;;;    This file implements local call analysis.  A local call is a function
;;; call between functions being compiled at the same time.  If we can tell at
16
17
18
19
;;; compile time that such a call is legal, then we change the combination
;;; to call the correct lambda, mark it as local, and add this link to our call
;;; graph.  Once a call is local, it is then eligible for let conversion, which
;;; places the body of the function inline.
wlott's avatar
wlott committed
20
21
;;;
;;;    We cannot always do a local call even when we do have the function being
22
23
;;; called.  Calls that cannot be shown to have legal arg counts are not
;;; converted.
wlott's avatar
wlott committed
24
25
26
;;;
;;; Written by Rob MacLachlan
;;;
27
(in-package :c)
wlott's avatar
wlott committed
28
29


30
;;; Propagate-To-Args  --  Interface
wlott's avatar
wlott committed
31
32
;;;
;;;    This function propagates information from the variables in the function
33
34
;;; Fun to the actual arguments in Call.  This is also called by the VALUES IR1
;;; optimizer when it sleazily converts MV-BINDs to LETs.
wlott's avatar
wlott committed
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
;;;
;;;    We flush all arguments to Call that correspond to unreferenced variables
;;; in Fun.  We leave NILs in the Combination-Args so that the remaining args
;;; still match up with their vars.
;;;
;;;    We also apply the declared variable type assertion to the argument
;;; continuations.
;;;
(defun propagate-to-args (call fun)
  (declare (type combination call) (type clambda fun)) 
  (do ((args (basic-combination-args call) (cdr args))
       (vars (lambda-vars fun) (cdr vars)))
      ((null args))
    (let ((arg (car args))
	  (var (car vars)))
      (cond ((leaf-refs var)
	     (assert-continuation-type arg (leaf-type var)))
	    (t
	     (flush-dest arg)
	     (setf (car args) nil)))))
      
  (undefined-value))


59
60
61
62
63
64
65
66
67
68
69
70
71
72
;;; Merge-Tail-Sets  --  Interface
;;;
;;;    This function handles merging the tail sets if Call is potentially
;;; tail-recursive, and is a call to a function with a different TAIL-SET than
;;; Call's Fun.  This must be called whenever we alter IR1 so as to place a
;;; local call in what might be a TR context.  Note that any call which returns
;;; its value to a RETURN is considered potentially TR, since any implicit
;;; MV-PROG1 might be optimized away.
;;;
;;; We destructively modify the set for the calling function to represent both,
;;; and then change all the functions in callee's set to reference the first.
;;; If we do merge, we reoptimize the RETURN-RESULT continuation to cause
;;; IR1-OPTIMIZE-RETURN to recompute the tail set type.
;;;
73
74
(defun merge-tail-sets (call &optional (new-fun (combination-lambda call)))
  (declare (type basic-combination call) (type clambda new-fun))
75
76
77
  (let ((return (continuation-dest (node-cont call))))
    (when (return-p return)
      (let ((call-set (lambda-tail-set (node-home-lambda call)))
78
	    (fun-set (lambda-tail-set new-fun)))
79
80
81
82
83
84
85
86
87
88
	(unless (eq call-set fun-set)
	  (let ((funs (tail-set-functions fun-set)))
	    (dolist (fun funs)
	      (setf (lambda-tail-set fun) call-set))
	    (setf (tail-set-functions call-set)
		  (nconc (tail-set-functions call-set) funs)))
	  (reoptimize-continuation (return-result return))
	  t)))))


wlott's avatar
wlott committed
89
90
;;; Convert-Call  --  Internal
;;;
91
;;;    Convert a combination into a local call.  We PROPAGATE-TO-ARGS, set the
wlott's avatar
wlott committed
92
;;; combination kind to :Local, add Fun to the Calls of the function that the
93
94
;;; call is in, call MERGE-TAIL-SETS, then replace the function in the Ref node
;;; with the new function.
wlott's avatar
wlott committed
95
;;;
96
;;; We change the Ref last, since changing the reference can trigger let
wlott's avatar
wlott committed
97
;;; conversion of the new function, but will only do so if the call is local.
98
99
100
101
;;; Note that the replacement may trigger let conversion or other changes in
;;; IR1.  We must call MERGE-TAIL-SETS with NEW-FUN before the substitution,
;;; since after the substitution (and let conversion), the call may no longer
;;; be recognizable as tail-recursive.
wlott's avatar
wlott committed
102
103
104
105
106
;;;
(defun convert-call (ref call fun)
  (declare (type ref ref) (type combination call) (type clambda fun))
  (propagate-to-args call fun)
  (setf (basic-combination-kind call) :local)
107
  (pushnew fun (lambda-calls (node-home-lambda call)))
108
  (merge-tail-sets call fun)
wlott's avatar
wlott committed
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
  (change-ref-leaf ref fun)
  (undefined-value))


;;;; External entry point creation:

;;; Make-XEP-Lambda  --  Internal
;;;
;;;    Return a Lambda form that can be used as the definition of the XEP for
;;; Fun.
;;;
;;;    If Fun is a lambda, then we check the number of arguments (conditional
;;; on policy) and call Fun with all the arguments.
;;;
;;;    If Fun is an Optional-Dispatch, then we dispatch off of the number of
;;; supplied arguments by doing do an = test for each entry-point, calling the
;;; entry with the appropriate prefix of the passed arguments.
;;;
;;;    If there is a more arg, then there are a couple of optimizations that we
;;; make (more for space than anything else):
;;; -- If Min-Args is 0, then we make the more entry a T clause, since no
;;;    argument count error is possible.
;;; -- We can omit the = clause for the last entry-point, allowing the case of
;;;    0 more args to fall through to the more entry.
;;;
;;;    We don't bother to policy conditionalize wrong arg errors in optional
;;; dispatches, since the additional overhead is negligible compared to the
;;; other hair going down.
;;;
;;;    Note that if policy indicates it, argument type declarations in Fun will
;;; be verified.  Since nothing is known about the type of the XEP arg vars,
;;; type checks will be emitted when the XEP's arg vars are passed to the
;;; actual function.
;;;
(defun make-xep-lambda (fun)
  (declare (type functional fun))
  (etypecase fun
    (clambda
     (let ((nargs (length (lambda-vars fun)))
	   (n-supplied (gensym)))
       (collect ((temps))
	 (dotimes (i nargs)
	   (temps (gensym)))
	 `(lambda (,n-supplied ,@(temps))
153
	    (declare (type index ,n-supplied))
154
	    ,(if (policy nil (zerop safety))
wlott's avatar
wlott committed
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
		 `(declare (ignore ,n-supplied))
		 `(%verify-argument-count ,n-supplied ,nargs))
	    (%funcall ,fun ,@(temps))))))
    (optional-dispatch
     (let* ((min (optional-dispatch-min-args fun))
	    (max (optional-dispatch-max-args fun))
	    (more (optional-dispatch-more-entry fun))
	    (n-supplied (gensym)))
       (collect ((temps)
		 (entries))
	 (dotimes (i max)
	   (temps (gensym)))

	 (do ((eps (optional-dispatch-entry-points fun) (rest eps))
	      (n min (1+ n)))
	     ((null eps))
	   (entries `((= ,n-supplied ,n)
		      (%funcall ,(first eps) ,@(subseq (temps) 0 n)))))

	 `(lambda (,n-supplied ,@(temps))
175
	    (declare (type index ,n-supplied))
wlott's avatar
wlott committed
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
	    (cond
	     ,@(if more (butlast (entries)) (entries))
	     ,@(when more
		 `((,(if (zerop min) 't `(>= ,n-supplied ,max))
		    ,(let ((n-context (gensym))
			   (n-count (gensym)))
		       `(multiple-value-bind
			    (,n-context ,n-count)
			    (%more-arg-context ,n-supplied ,max)
			  (%funcall ,more ,@(temps) ,n-context ,n-count))))))
	     (t
	      (%argument-count-error ,n-supplied)))))))))


;;; Make-External-Entry-Point  --  Internal
;;;
;;;    Make an external entry point (XEP) for Fun and return it.  We convert
;;; the result of Make-XEP-Lambda in the correct environment, then associate
;;; this lambda with Fun as its XEP.  After the conversion, we iterate over the
;;; function's associated lambdas, redoing local call analysis so that the XEP
196
197
;;; calls will get converted.  We also bind *lexical-environment* to change the
;;; compilation policy over to the interface policy.
wlott's avatar
wlott committed
198
199
200
201
202
203
204
205
;;;
;;;    We set Reanalyze and Reoptimize in the component, just in case we
;;; discover an XEP after the initial local call analyze pass.
;;;
(defun make-external-entry-point (fun)
  (declare (type functional fun))
  (assert (not (functional-entry-function fun)))
  (with-ir1-environment (lambda-bind (main-entry fun))
206
207
208
209
    (let* ((*lexical-environment*
	    (make-lexenv :cookie
			 (make-interface-cookie *lexical-environment*)))
	   (res (ir1-convert-lambda (make-xep-lambda fun))))
wlott's avatar
wlott committed
210
      (setf (functional-kind res) :external)
211
      (setf (leaf-ever-used res) t)
wlott's avatar
wlott committed
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
      (setf (functional-entry-function res) fun)
      (setf (functional-entry-function fun) res)
      (setf (component-reanalyze *current-component*) t)
      (setf (component-reoptimize *current-component*) t)
      (etypecase fun
	(clambda (local-call-analyze-1 fun))
	(optional-dispatch
	 (dolist (ep (optional-dispatch-entry-points fun))
	   (local-call-analyze-1 ep))
	 (when (optional-dispatch-more-entry fun)
	   (local-call-analyze-1 (optional-dispatch-more-entry fun)))))
      res)))


;;; Reference-Entry-Point  --  Internal
;;;
;;;    Notice a Ref that is not in a local-call context.  If the Ref is already
;;; to an XEP, then do nothing, otherwise change it to the XEP, making an XEP
;;; if necessary.
;;;
;;;    If Ref is to a special :Cleanup or :Escape function, then we treat it as
;;; though it was not an XEP reference (i.e. leave it alone.)
;;;
(defun reference-entry-point (ref)
  (declare (type ref ref))
  (let ((fun (ref-leaf ref)))
    (unless (or (external-entry-point-p fun)
		(member (functional-kind fun) '(:escape :cleanup)))
      (change-ref-leaf ref (or (functional-entry-function fun)
			       (make-external-entry-point fun))))))

243

wlott's avatar
wlott committed
244
245
246
247

;;; Local-Call-Analyze-1  --  Interface
;;;
;;;    Attempt to convert all references to Fun to local calls.  The reference
248
249
250
251
;;; must be the function for a call, and the function continuation must be used
;;; only once, since otherwise we cannot be sure what function is to be called.
;;; The call continuation would be multiply used if there is hairy stuff such
;;; as conditionals in the expression that computes the function.
252
;;;
wlott's avatar
wlott committed
253
;;;    If we cannot convert a reference, then we mark the referenced function
254
255
;;; as an entry-point, creating a new XEP if necessary.  We don't try to
;;; convert calls that are in error (:ERROR kind.)
wlott's avatar
wlott committed
256
257
258
259
260
261
262
;;;
;;;    This is broken off from Local-Call-Analyze so that people can force
;;; analysis of newly introduced calls.  Note that we don't do let conversion
;;; here.
;;;
(defun local-call-analyze-1 (fun)
  (declare (type functional fun))
263
264
  (let ((refs (leaf-refs fun))
	(first-time t))
265
266
267
268
269
    (dolist (ref refs)
      (let* ((cont (node-cont ref))
	     (dest (continuation-dest cont)))
	(cond ((and (basic-combination-p dest)
		    (eq (basic-combination-fun dest) cont)
270
271
272
		    (eq (continuation-use cont) ref))

	       (convert-call-if-possible ref dest)
273
274
275
276
	       
	       (unless (eq (basic-combination-kind dest) :local)
		 (reference-entry-point ref)))
	      (t
277
278
	       (reference-entry-point ref))))
      (setq first-time nil)))
wlott's avatar
wlott committed
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294

  (undefined-value))


;;; Local-Call-Analyze  --  Interface
;;;
;;;    We examine all New-Functions in component, attempting to convert calls
;;; into local calls when it is legal.  We also attempt to convert each lambda
;;; to a let.  Let conversion is also triggered by deletion of a function
;;; reference, but functions that start out eligible for conversion must be
;;; noticed sometime.
;;;
;;;    Note that there is a lot of action going on behind the scenes here,
;;; triggered by reference deletion.  In particular, the Component-Lambdas are
;;; being hacked to remove newly deleted and let converted lambdas, so it is
;;; important that the lambda is added to the Component-Lambdas when it is.
295
;;; Also, the COMPONENT-NEW-FUNCTIONS may contain all sorts of drivel, since it
296
297
;;; is not updated when we delete functions, etc.  Only COMPONENT-LAMBDAS is
;;; updated.
wlott's avatar
wlott committed
298
;;;
299
300
301
;;; COMPONENT-REANALYZE-FUNCTIONS is treated similarly to NEW-FUNCTIONS, but we
;;; don't add lambdas to the LAMBDAS.
;;;
wlott's avatar
wlott committed
302
303
304
(defun local-call-analyze (component)
  (declare (type component component))
  (loop
305
306
307
308
309
310
311
312
313
314
315
316
317
318
    (let* ((new (pop (component-new-functions component)))
	   (fun (or new (pop (component-reanalyze-functions component)))))
      (unless fun (return))
      (let ((kind (functional-kind fun)))
	(cond ((member kind '(:deleted :let :mv-let :assignment)))
	      ((and (null (leaf-refs fun)) (eq kind nil)
		    (not (functional-entry-function fun)))
	       (delete-functional fun))
	      (t
	       (when (and new (lambda-p fun))
		 (push fun (component-lambdas component)))
	       (local-call-analyze-1 fun)
	       (when (lambda-p fun)
		 (maybe-let-convert fun)))))))
319
  
wlott's avatar
wlott committed
320
321
322
  (undefined-value))


323
324
325
326
327
328
329
330
331
;;; MAYBE-EXPAND-LOCAL-INLINE  --  Internal
;;;
;;;    If policy is auspicious, Call is not in an XEP, and we don't seem to be
;;; in an infinite recursive loop, then change the reference to reference a
;;; fresh copy.  We return whichever function we decide to reference.
;;;
(defun maybe-expand-local-inline (fun ref call)
  (if (and (policy call (>= speed space) (>= speed cspeed))
	   (not (eq (functional-kind (node-home-lambda call)) :external))
332
	   (not *converting-for-interpreter*)
333
334
335
	   (inline-expansion-ok call))
      (with-ir1-environment call
	(let* ((*lexical-environment* (functional-lexenv fun))
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
	       (won nil)
	       (res (catch 'local-call-lossage
		      (prog1
			  (ir1-convert-lambda (functional-inline-expansion fun))
			(setq won t)))))
	  (cond (won
		 (change-ref-leaf ref res)
		 res)
		(t
		 (let ((*compiler-error-context* call))
		   (compiler-note "Couldn't inline expand because expansion ~
				   calls this let-converted local function:~
				   ~%  ~S"
				  (leaf-name res)))
		 fun))))
351
352
353
      fun))


wlott's avatar
wlott committed
354
355
356
357
;;; Convert-Call-If-Possible  --  Interface
;;;
;;;    Dispatch to the appropriate function to attempt to convert a call.  This
;;; is called in IR1 optimize as well as in local call analysis.  If the call
358
359
360
361
362
363
364
365
366
367
368
369
370
;;; is is already :Local, we do nothing.  If the call is already scheduled for
;;; deletion, also do nothing (in addition to saving time, this also avoids
;;; some problems with optimizing collections of functions that are partially
;;; deleted.)
;;;
;;;    This is called both before and after FIND-INITIAL-DFO runs.  When called
;;; on a :INITIAL component, we don't care whether the caller and callee are in
;;; the same component.  Afterward, we must stick with whatever component
;;; division we have chosen.
;;;
;;;    Before attempting to convert a call, we see if the function is supposed
;;; to be inline expanded.  Call conversion proceeds as before after any
;;; expansion.
wlott's avatar
wlott committed
371
372
373
374
;;;
;;;    We bind *Compiler-Error-Context* to the node for the call so that
;;; warnings will get the right context.
;;;
375
;;;
wlott's avatar
wlott committed
376
377
(defun convert-call-if-possible (ref call)
  (declare (type ref ref) (type basic-combination call))
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
  (let* ((block (node-block call))
	 (component (block-component block))
	 (original-fun (ref-leaf ref)))
    (unless (or (member (basic-combination-kind call) '(:local :error))
		(block-delete-p block)
		(eq (functional-kind (block-home-lambda block)) :deleted)
		(not (or (eq (component-kind component) :initial)
			 (eq (block-component
			      (node-block
			       (lambda-bind (main-entry original-fun))))
			     component))))
      (let ((fun (if (external-entry-point-p original-fun)
		     (functional-entry-function original-fun)
		     original-fun))
	    (*compiler-error-context* call))
	
	(when (and (eq (functional-inlinep fun) :inline)
		   (rest (leaf-refs original-fun)))
	  (setq fun (maybe-expand-local-inline fun ref call)))
	
	(assert (member (functional-kind fun)
			'(nil :escape :cleanup :optional)))
	(cond ((mv-combination-p call)
	       (convert-mv-call ref call fun))
	      ((lambda-p fun)
	       (convert-lambda-call ref call fun))
	      (t
	       (convert-hairy-call ref call fun))))))

wlott's avatar
wlott committed
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
  (undefined-value))


;;; Convert-MV-Call  --  Internal
;;;
;;;    Attempt to convert a multiple-value call.  The only interesting case is
;;; a call to a function that Looks-Like-An-MV-Bind, has exactly one reference
;;; and no XEP, and is called with one values continuation.
;;;
;;;    We change the call to be to the last optional entry point and change the
;;; call to be local.  Due to our preconditions, the call should eventually be
;;; converted to a let, but we can't do that now, since there may be stray
;;; references to the e-p lambda due to optional defaulting code.
;;;
;;;    We also use variable types for the called function to construct an
;;; assertion for the values continuation.
;;;
424
425
;;; See CONVERT-CALL for additional notes on MERGE-TAIL-SETS, etc.
;;;
wlott's avatar
wlott committed
426
427
428
429
430
431
432
433
(defun convert-mv-call (ref call fun)
  (declare (type ref ref) (type mv-combination call) (type functional fun))
  (when (and (looks-like-an-mv-bind fun)
	     (not (functional-entry-function fun))
	     (= (length (leaf-refs fun)) 1)
	     (= (length (basic-combination-args call)) 1))
    (let ((ep (car (last (optional-dispatch-entry-points fun)))))
      (setf (basic-combination-kind call) :local)
434
      (pushnew ep (lambda-calls (node-home-lambda call)))
435
      (merge-tail-sets call ep)
436
      (change-ref-leaf ref ep)
437
      
wlott's avatar
wlott committed
438
439
440
441
442
443
444
445
446
447
      (assert-continuation-type
       (first (basic-combination-args call))
       (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
			 :rest *universal-type*))))
  (undefined-value))


;;; Convert-Lambda-Call  --  Internal
;;;
;;;    Attempt to convert a call to a lambda.  If the number of args is wrong,
448
;;; we give a warning and mark the call as :ERROR to remove it from future
wlott's avatar
wlott committed
449
450
451
;;; consideration.  If the argcount is O.K. then we just convert it.
;;;
(defun convert-lambda-call (ref call fun)
452
  (declare (type ref ref) (type combination call) (type clambda fun))
wlott's avatar
wlott committed
453
454
455
456
457
458
459
460
  (let ((nargs (length (lambda-vars fun)))
	(call-args (length (combination-args call))))
    (cond ((= call-args nargs)
	   (convert-call ref call fun))
	  (t
	   (compiler-warning
	    "Function called with ~R argument~:P, but wants exactly ~R."
	    call-args nargs)
461
	   (setf (basic-combination-kind call) :error)))))
wlott's avatar
wlott committed
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482



;;;; Optional, more and keyword calls:

;;; Convert-Hairy-Call  --  Internal
;;;
;;;    Similar to Convert-Lambda-Call, but deals with Optional-Dispatches.  If
;;; only fixed args are supplied, then convert a call to the correct entry
;;; point.  If keyword args are supplied, then dispatch to a subfunction.  We
;;; don't convert calls to functions that have a more (or rest) arg.
;;;
(defun convert-hairy-call (ref call fun)
  (declare (type ref ref) (type combination call)
	   (type optional-dispatch fun))
  (let ((min-args (optional-dispatch-min-args fun))
	(max-args (optional-dispatch-max-args fun))
	(call-args (length (combination-args call))))
    (cond ((< call-args min-args)
	   (compiler-warning "Function called with ~R argument~:P, but wants at least ~R."
			     call-args min-args)
483
	   (setf (basic-combination-kind call) :error))
wlott's avatar
wlott committed
484
485
486
487
	  ((<= call-args max-args)
	   (convert-call ref call
			 (elt (optional-dispatch-entry-points fun)
			      (- call-args min-args))))
488
489
490
	  ((optional-dispatch-more-entry fun)
	   (convert-more-call ref call fun))
	  (t
wlott's avatar
wlott committed
491
492
	   (compiler-warning "Function called with ~R argument~:P, but wants at most ~R."
			     call-args max-args)
493
	   (setf (basic-combination-kind call) :error))))
wlott's avatar
wlott committed
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
  (undefined-value))


;;; Convert-Hairy-Fun-Entry  --  Internal
;;;
;;;     This function is used to convert a call to an entry point when complex
;;; transformations need to be done on the original arguments.  Entry is the
;;; entry point function that we are calling.  Vars is a list of variable names
;;; which are bound to the oringinal call arguments.  Ignores is the subset of
;;; Vars which are ignored.  Args is the list of arguments to the entry point
;;; function.
;;;
;;;    In order to avoid gruesome graph grovelling, we introduce a new function
;;; that rearranges the arguments and calls the entry point.  We analyze the
;;; new function and the entry point immediately so that everything gets
;;; converted during the single pass.
;;;
(defun convert-hairy-fun-entry (ref call entry vars ignores args)
512
513
  (declare (list vars ignores args) (type ref ref) (type combination call)
	   (type clambda entry))
wlott's avatar
wlott committed
514
515
516
517
  (let ((new-fun
	 (with-ir1-environment call
	   (ir1-convert-lambda
	    `(lambda ,vars
518
	       (declare (ignorable . ,ignores))
519
	       (%funcall ,entry . ,args))))))
wlott's avatar
wlott committed
520
521
522
523
524
    (convert-call ref call new-fun)
    (dolist (ref (leaf-refs entry))
      (convert-call-if-possible ref (continuation-dest (node-cont ref))))))


525
;;; Convert-More-Call  --  Internal
wlott's avatar
wlott committed
526
;;;
527
528
;;;    Use Convert-Hairy-Fun-Entry to convert a more-arg call to a known
;;; function into a local call to the Main-Entry.
wlott's avatar
wlott committed
529
530
531
532
533
534
535
536
537
538
539
;;;
;;;    First we verify that all keywords are constant and legal.  If there
;;; aren't, then we warn the user and don't attempt to convert the call.
;;;
;;;    We massage the supplied keyword arguments into the order expected by the
;;; main entry.  This is done by binding all the arguments to the keyword call
;;; to variables in the introduced lambda, then passing these values variables
;;; in the correct order when calling the main entry.  Unused arguments
;;; (such as the keywords themselves) are discarded simply by not passing them
;;; along.
;;;
540
541
542
543
;;;    If there is a rest arg, then we bundle up the args and pass them to
;;; LIST.
;;;
(defun convert-more-call (ref call fun)
wlott's avatar
wlott committed
544
545
546
547
  (declare (type ref ref) (type combination call) (type optional-dispatch fun))
  (let* ((max (optional-dispatch-max-args fun))
	 (arglist (optional-dispatch-arglist fun))
	 (args (combination-args call))
548
	 (more (nthcdr max args))
549
	 (flame (policy call (or (> speed brevity) (> space brevity))))
wlott's avatar
wlott committed
550
551
	 (loser nil))
    (collect ((temps)
552
	      (more-temps)
wlott's avatar
wlott committed
553
554
555
556
557
558
559
560
561
562
	      (ignores)
	      (supplied)
	      (key-vars))

      (dolist (var arglist)
	(let ((info (lambda-var-arg-info var)))
	  (when info
	    (ecase (arg-info-kind info)
	      (:keyword
	       (key-vars var))
wlott's avatar
wlott committed
563
564
565
566
567
	      ((:rest :optional))
	      ((:more-context :more-count)
	       (compiler-warning "Can't local-call functions with &MORE args.")
	       (setf (basic-combination-kind call) :error)
	       (return-from convert-more-call))))))
wlott's avatar
wlott committed
568
569

      (dotimes (i max)
570
571
572
573
574
575
576
577
578
	(temps (gensym "FIXED-ARG-TEMP-")))

      (dotimes (i (length more))
	(more-temps (gensym "MORE-ARG-TEMP-")))

      (when (optional-dispatch-keyp fun)
	(when (oddp (length more))
	  (compiler-warning "Function called with odd number of ~
	  		     arguments in keyword portion.")
579
580

	  (setf (basic-combination-kind call) :error)
581
582
583
584
585
586
587
588
589
	  (return-from convert-more-call))

	(do ((key more (cddr key))
	     (temp (more-temps) (cddr temp)))
	    ((null key))
	  (let ((cont (first key)))
	    (unless (constant-continuation-p cont)
	      (when flame
		(compiler-note "Non-constant keyword in keyword call."))
590
	      (setf (basic-combination-kind call) :error)
591
592
593
594
595
596
597
598
599
600
601
	      (return-from convert-more-call))
	    
	    (let ((name (continuation-value cont))
		  (dummy (first temp))
		  (val (second temp)))
	      (dolist (var (key-vars)
			   (progn
			     (ignores dummy val)
			     (setq loser name)))
		(let ((info (lambda-var-arg-info var)))
		  (when (eq (arg-info-keyword info) name)
wlott's avatar
wlott committed
602
		    (ignores dummy)
603
604
		    (supplied (cons var val))
		    (return)))))))
605
606
607
608
	
	(when (and loser (not (optional-dispatch-allowp fun)))
	  (compiler-warning "Function called with unknown argument keyword ~S."
			    loser)
609
	  (setf (basic-combination-kind call) :error)
610
	  (return-from convert-more-call)))
wlott's avatar
wlott committed
611
612
613
614
615
616
617

      (collect ((call-args))
	(do ((var arglist (cdr var))
	     (temp (temps) (cdr temp)))
	    (())
	  (let ((info (lambda-var-arg-info (car var))))
	    (if info
618
		(ecase (arg-info-kind info)
wlott's avatar
wlott committed
619
620
621
622
		  (:optional
		   (call-args (car temp))
		   (when (arg-info-supplied-p info)
		     (call-args t)))
623
624
625
626
		  (:rest
		   (call-args `(list ,@(more-temps)))
		   (return))
		  (:keyword
wlott's avatar
wlott committed
627
628
629
630
631
632
633
634
635
636
637
638
639
		   (return)))
		(call-args (car temp)))))

	(dolist (var (key-vars))
	  (let ((info (lambda-var-arg-info var))
		(temp (cdr (assoc var (supplied)))))
	    (if temp
		(call-args temp)
		(call-args (arg-info-default info)))
	    (when (arg-info-supplied-p info)
	      (call-args (not (null temp))))))

	(convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
640
641
				 (append (temps) (more-temps))
				 (ignores) (call-args)))))
wlott's avatar
wlott committed
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667

  (undefined-value))


;;;; Let conversion:
;;;
;;;    Converting to a let has differing significance to various parts of the
;;; compiler:
;;; -- The body of a Let is spliced in immediately after the the corresponding
;;;    combination node, making the control transfer explicit and allowing lets
;;;    to mashed together into a single block.  The value of the let is
;;;    delivered directly to the original continuation for the call,
;;;    eliminating the need to propagate information from the dummy result
;;;    continuation. 
;;; -- As far as IR1 optimization is concerned, it is interesting in that there
;;;    is only one expression that the variable can be bound to, and this is
;;;    easily substitited for.
;;; -- Lets are interesting to environment analysis and the back end because in
;;;    most ways a let can be considered to be "the same function" as its home
;;;    function.
;;; -- Let conversion has dynamic scope implications, since control transfers
;;;    within the same environment are local.  In a local control transfer,
;;;    cleanup code must be emitted to remove dynamic bindings that are no
;;;    longer in effect.


668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
;;; Insert-Let-Body  --  Internal
;;;
;;;    Set up the control transfer to the called lambda.  We split the call
;;; block immediately after the call, and link the head of Fun to the call
;;; block.  The successor block after splitting (where we return to) is
;;; returned.
;;;
;;;    If the lambda is is a different component than the call, then we call
;;; JOIN-COMPONENTS.  This only happens in block compilation before
;;; FIND-INITIAL-DFO.
;;;
(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 ((fun-component (block-component bind-block)))
      (unless (eq fun-component component)
	(assert (eq (component-kind component) :initial))
	(join-components component fun-component)))

    (let ((*current-component* component))
      (node-ends-block call))
    (assert (= (length (block-succ call-block)) 1))
    (let ((next-block (first (block-succ call-block))))
      (unlink-blocks call-block next-block)
      (link-blocks call-block bind-block)
      next-block)))


698
;;; Merge-Lets  --  Internal
wlott's avatar
wlott committed
699
700
;;;
;;;    Handle the environment semantics of let conversion.  We add the lambda
701
;;; and its lets to lets for the Call's home function.  We merge the calls for
702
703
704
;;; Fun with the calls for the home function, removing Fun in the process.  We
;;; also merge the Entries.
;;;
705
706
707
;;;   We also unlink the function head from the component head and set
;;; Component-Reanalyze to true to indicate that the DFO should be recomputed.
;;;
708
(defun merge-lets (fun call)
wlott's avatar
wlott committed
709
  (declare (type clambda fun) (type basic-combination call))
710
711
712
713
714
715
716
717
718
719
720
  (let ((component (block-component (node-block call))))
    (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
    (setf (component-lambdas component)
	  (delete fun (component-lambdas component)))
    (setf (component-reanalyze component) t))
  (setf (lambda-call-lexenv fun) (node-lexenv call))
  (let ((tails (lambda-tail-set fun)))
    (setf (tail-set-functions tails)
	  (delete fun (tail-set-functions tails))))
  (setf (lambda-tail-set fun) nil)
  (let* ((home (node-home-lambda call))
721
	 (home-env (lambda-environment home)))
wlott's avatar
wlott committed
722
723
    (push fun (lambda-lets home))
    (setf (lambda-home fun) home)
724
    (setf (lambda-environment fun) home-env)
wlott's avatar
wlott committed
725
    
726
    (let ((lets (lambda-lets fun)))
wlott's avatar
wlott committed
727
      (dolist (let lets)
728
729
	(setf (lambda-home let) home)
	(setf (lambda-environment let) home-env))
wlott's avatar
wlott committed
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746

      (setf (lambda-lets home) (nconc lets (lambda-lets home)))
      (setf (lambda-lets fun) ()))

    (setf (lambda-calls home)
	  (nunion (lambda-calls fun)
		  (delete fun (lambda-calls home))))
    (setf (lambda-calls fun) ())

    (setf (lambda-entries home)
	  (nconc (lambda-entries fun) (lambda-entries home)))
    (setf (lambda-entries fun) ()))
  (undefined-value))


;;; Move-Return-Uses  --  Internal
;;;
747
748
749
;;;    Handle the value semantics of let conversion.  Delete Fun's return node,
;;; and change the control flow to transfer to Next-Block instead.  Move all
;;; the uses of the result continuation to Call's Cont.
wlott's avatar
wlott committed
750
751
752
753
754
755
;;;
;;;    If the actual continuation is only used by the let call, then we
;;; intersect the type assertion on the dummy continuation with the assertion
;;; for the actual continuation; in all other cases assertions on the dummy
;;; continuation are lost.
;;;
756
757
758
759
;;;    We also intersect the derived type of the call with the derived type of
;;; all the dummy continuation's uses.  This serves mainly to propagate
;;; TRULY-THE through lets.
;;;
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
(defun move-return-uses (fun call next-block)
  (declare (type clambda fun) (type basic-combination call)
	   (type cblock next-block))
  (let* ((return (lambda-return fun))
	 (return-block (node-block return)))
    (unlink-blocks return-block
		   (component-tail (block-component return-block)))
    (link-blocks return-block next-block)
    (unlink-node return)
    (delete-return return)
    (let ((result (return-result return))
	  (cont (node-cont call))
	  (call-type (node-derived-type call)))
      (when (eq (continuation-use cont) call)
	(assert-continuation-type cont (continuation-asserted-type result)))
      (unless (eq call-type *wild-type*)
	(do-uses (use result)
	  (derive-node-type use call-type)))
      (substitute-continuation-uses cont result)))
  (undefined-value))



;;; MOVE-LET-CALL-CONT  --  Internal
;;;
;;;    Change all Cont for all the calls to Fun to be the start continuation
;;; for the bind node.  This allows the blocks to be joined if the caller count
;;; ever goes to one.
;;;
(defun move-let-call-cont (fun)
  (declare (type clambda fun))
  (let ((new-cont (node-prev (lambda-bind fun))))
    (dolist (ref (leaf-refs fun))
      (let ((dest (continuation-dest (node-cont ref))))
	(delete-continuation-use dest)
	(add-continuation-use dest new-cont))))
  (undefined-value))

wlott's avatar
wlott committed
798

799
800
801
802
803
;;; Unconvert-Tail-Calls  --  Internal
;;;
;;;    We are converting Fun to be a let when the call is in a non-tail
;;; position.  Any previously tail calls in Fun are no longer tail calls, and
;;; must be restored to normal calls which transfer to Next-Block (Fun's
804
805
;;; return point.)  We can't do this by DO-USES on the RETURN-RESULT, because
;;; the return might have been deleted (if all calls were TR.)
806
;;;
807
808
809
810
;;;    The called function might be an assignment in the case where we are
;;; currently converting that function.  In steady-state, assignments never
;;; appear in the lambda-calls.
;;;
811
812
813
814
815
816
817
(defun unconvert-tail-calls (fun call next-block)
  (dolist (called (lambda-calls fun))
    (dolist (ref (leaf-refs called))
      (let ((this-call (continuation-dest (node-cont ref))))
	(when (and (node-tail-p this-call)
		   (eq (node-home-lambda this-call) fun))
	  (setf (node-tail-p this-call) nil)
818
819
	  (ecase (functional-kind called)
	    ((nil :cleanup :optional)
820
821
822
	     (let ((block (node-block this-call))
		   (cont (node-cont call)))
	       (ensure-block-start cont)
823
824
825
	       (unlink-blocks block (first (block-succ block)))
	       (link-blocks block next-block)
	       (delete-continuation-use this-call)
826
	       (add-continuation-use this-call cont)))
827
	    (:deleted)
828
829
	    (:assignment
	     (assert (eq called fun))))))))
830
831
832
  (undefined-value))


833
834
835
836
837
838
;;; MOVE-RETURN-STUFF  --  Internal
;;;
;;;    Deal with returning from a let or assignment that we are converting.
;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK
;;; is the return point for a non-tail call, or NULL if call is a tail call.
;;;
839
840
841
842
843
844
;;; If the call is not a tail call, then we must do UNCONVERT-TAIL-CALLS, since
;;; a tail call is a call which returns its value out of the enclosing non-let
;;; function.  When call is non-TR, we must convert it back to an ordinary
;;; local call, since the value must be delivered to the receiver of CALL's
;;; value.
;;;
845
846
;;; We do different things depending on whether the caller and callee have
;;; returns left:
847
848
849
;;; -- If the callee has no return we just do MOVE-LET-CALL-CONT.  Either the
;;;    function doesn't return, or all returns are via tail-recursive local
;;;    calls.
850
851
852
853
;;; -- If CALL is a non-tail call, or if both have returns, then we
;;;    delete the callee's return, move its uses to the call's result
;;;    continuation, and transfer control to the appropriate return point.
;;; -- If the callee has a return, but the caller doesn't, then we move the
854
;;;    return to the caller.
855
856
857
858
;;;
(defun move-return-stuff (fun call next-block)
  (declare (type clambda fun) (type basic-combination call)
	   (type (or cblock null) next-block))
859
860
  (when next-block
    (unconvert-tail-calls fun call next-block))
861
862
863
  (let* ((return (lambda-return fun))
	 (call-fun (node-home-lambda call))
	 (call-return (lambda-return call-fun)))
864
865
866
867
868
869
870
871
872
873
    (cond ((not return))
	  ((or next-block call-return)
	   (unless (block-delete-p (node-block return))
	     (move-return-uses fun call
			       (or next-block (node-block call-return)))))
	  (t
	   (assert (node-tail-p call))
	   (setf (lambda-return call-fun) return)
	   (setf (return-lambda return) call-fun))))
  (move-let-call-cont fun)
wlott's avatar
wlott committed
874
875
876
877
878
879
880
881
  (undefined-value))


;;; Let-Convert  --  Internal
;;;
;;;    Actually do let conversion.  We call subfunctions to do most of the
;;; work.  We change the Call's cont to be the continuation heading the bind
;;; block, and also do Reoptimize-Continuation on the args and Cont so that
882
883
884
;;; let-specific IR1 optimizations get a chance.  We blow away any entry for
;;; the function in *free-functions* so that nobody will create new reference
;;; to it.
wlott's avatar
wlott committed
885
886
887
;;;
(defun let-convert (fun call)
  (declare (type clambda fun) (type basic-combination call))
888
889
890
  (let ((next-block (if (node-tail-p call)
			nil
			(insert-let-body fun call))))
891
    (move-return-stuff fun call next-block)
892
    (merge-lets fun call)))
893

894
895
896
897
898
899
900

;;; REOPTIMIZE-CALL  --  Internal
;;;
;;;    Reoptimize all of Call's args and its result.
;;;
(defun reoptimize-call (call)
  (declare (type basic-combination call))
wlott's avatar
wlott committed
901
902
903
904
905
906
  (dolist (arg (basic-combination-args call))
    (when arg
      (reoptimize-continuation arg)))
  (reoptimize-continuation (node-cont call))
  (undefined-value))

907
908
909
910
911
912
913
914
915
916
917
918
919
920
;;;  OK-INITIAL-CONVERT-P  --  Internal
;;;
;;; We also don't convert calls to named functions which appear in the initial
;;; component, delaying this until optimization.  This minimizes the likelyhood
;;; that we well let-convert a function which may have references added due to
;;; later local inline expansion
;;;
(defun ok-initial-convert-p (fun)
  (not (and (leaf-name fun)
	    (eq (component-kind
		 (block-component
		  (node-block (lambda-bind fun))))
		:initial))))

wlott's avatar
wlott committed
921
922
923
924
925
926
927
928

;;; Maybe-Let-Convert  --  Interface
;;;
;;;    This function is called when there is some reason to believe that
;;; the lambda Fun might be converted into a let.  This is done after local
;;; call analysis, and also when a reference is deleted.  We only convert to a
;;; let when the function is a normal local function, has no XEP, and is
;;; referenced in exactly one local call.  Conversion is also inhibited if the
929
930
;;; only reference is in a block about to be deleted.  We return true if we
;;; converted.
wlott's avatar
wlott committed
931
932
933
934
;;;
;;;    These rules may seem unnecessarily restrictive, since there are some
;;; cases where we could do the return with a jump that don't satisfy these
;;; requirements.  The reason for doing things this way is that it makes the
935
936
937
;;; concept of a let much more useful at the level of IR1 semantics.  The
;;; :ASSIGNMENT function kind provides another way to optimize calls to
;;; single-return/multiple call functions.
wlott's avatar
wlott committed
938
939
940
;;;
;;;    We don't attempt to convert calls to functions that have an XEP, since
;;; we might be embarrassed later when we want to convert a newly discovered
941
;;; local call.  Also, see OK-INITIAL-CONVERT-P.
wlott's avatar
wlott committed
942
943
944
945
946
;;;
(defun maybe-let-convert (fun)
  (declare (type clambda fun))
  (let ((refs (leaf-refs fun)))
    (when (and refs (null (rest refs))
947
	       (member (functional-kind fun) '(nil :assignment))
wlott's avatar
wlott committed
948
949
950
951
952
	       (not (functional-entry-function fun)))
      (let* ((ref-cont (node-cont (first refs)))
	     (dest (continuation-dest ref-cont)))
	(when (and (basic-combination-p dest)
		   (eq (basic-combination-fun dest) ref-cont)
953
		   (eq (basic-combination-kind dest) :local)
954
		   (not (block-delete-p (node-block dest)))
955
956
		   (cond ((ok-initial-convert-p fun) t)
			 (t
957
			  (reoptimize-continuation ref-cont)
958
959
960
961
			  nil)))
	  (unless (eq (functional-kind fun) :assignment)
	    (let-convert fun dest))
	  (reoptimize-call dest)
wlott's avatar
wlott committed
962
	  (setf (functional-kind fun)
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
		(if (mv-combination-p dest) :mv-let :let))))
      t)))


;;;; Tail local calls and assignments:

;;; ONLY-HARMLESS-CLEANUPS  --  Internal
;;;
;;;    Return T if there are no cleanups between Block1 and Block2, or if they
;;; definitely won't generate any cleanup code.  Currently we recognize lexical
;;; entry points that are only used locally (if at all).
;;;
(defun only-harmless-cleanups (block1 block2)
  (declare (type cblock block1 block2))
  (or (eq block1 block2)
      (let ((cleanup2 (block-start-cleanup block2)))
	(do ((cleanup (block-end-cleanup block1)
		      (node-enclosing-cleanup (cleanup-mess-up cleanup))))
	    ((eq cleanup cleanup2) t)
	  (case (cleanup-kind cleanup)
	    ((:block :tagbody)
	     (unless (null (entry-exits (cleanup-mess-up cleanup)))
	       (return nil)))
	    (t (return nil)))))))


;;; MAYBE-CONVERT-TAIL-LOCAL-CALL  --  Interface
;;;
991
992
;;;    If a potentially TR local call really is TR, then convert it to jump
;;; directly to the called function.  We also call MAYBE-CONVERT-TO-ASSIGNMENT.
ram's avatar
ram committed
993
994
995
;;; The first value is true if we tail-convert.  The second is the value of
;;; M-C-T-A.  We can switch the succesor (potentially deleting the RETURN node)
;;; unless:
996
997
;;; -- The call has already been converted.
;;; -- The call isn't TR (random implicit MV PROG1.)
998
999
1000
1001
1002
1003
1004
1005
1006
1007
;;; -- The call is in an XEP (thus we might decide to make it non-tail so that
;;;    we can use known return inside the component.)
;;; -- There is a change in the cleanup between the call in the return, so we
;;;    might need to introduce cleanup code.
;;;
(defun maybe-convert-tail-local-call (call)
  (declare (type combination call))
  (let ((return (continuation-dest (node-cont call))))
    (assert (return-p return))
    (when (and (not (node-tail-p call))
1008
	       (immediately-used-p (return-result return) call)
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
	       (not (eq (functional-kind (node-home-lambda call))
			:external))
	       (only-harmless-cleanups (node-block call)
				       (node-block return)))
      (node-ends-block call)
      (let ((block (node-block call))
	    (fun (combination-lambda call)))
	(setf (node-tail-p call) t)
	(unlink-blocks block (first (block-succ block)))
	(link-blocks block (node-block (lambda-bind fun)))
	(values t (maybe-convert-to-assignment fun))))))


;;; MAYBE-CONVERT-TO-ASSIGNMENT  --  Interface
;;;
;;;    Called when we believe it might make sense to convert Fun to an
1025
1026
1027
;;; assignment.  All this function really does is determine when a function
;;; with more than one call can still be combined with the calling function's
;;; environment.  We can convert when:
1028
;;; -- The function is a normal, non-entry function, and
1029
1030
;;; -- Except for one call, all calls must be tail recursive calls in the
;;;    called function (i.e. are self-recursive tail calls)
1031
;;; -- OK-INITIAL-CONVERT-P is true.
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
;;;
;;;    There may be one outside call, and it need not be tail-recursive.  Since
;;; all tail local calls have already been converted to direct transfers, the
;;; only control semantics needed are to splice in the body at the non-tail
;;; call.  If there is no non-tail call, then we need only merge the
;;; environments.  Both cases are handled by LET-CONVERT.
;;;
;;; ### It would actually be possible to allow any number of outside calls as
;;; long as they all return to the same place (i.e. have the same conceptual
;;; continuation.)  A special case of this would be when all of the outside
;;; calls are tail recursive.
1043
1044
1045
1046
1047
1048
1049
;;;
(defun maybe-convert-to-assignment (fun)
  (declare (type clambda fun))
  (when (and (not (functional-kind fun))
	     (not (functional-entry-function fun)))
    (let ((non-tail nil)
	  (call-fun nil))
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
      (when (and (dolist (ref (leaf-refs fun) t)
		   (let ((dest (continuation-dest (node-cont ref))))
		     (when (block-delete-p (node-block dest)) (return nil))
		     (let ((home (node-home-lambda ref)))
		       (unless (eq home fun)
			 (when call-fun (return nil))
			 (setq call-fun home))
		       (unless (node-tail-p dest)
			 (when (or non-tail (eq home fun)) (return nil))
			 (setq non-tail dest)))))
		 (ok-initial-convert-p fun))
1061
	(setf (functional-kind fun) :assignment)
1062
1063
1064
	(let-convert fun (or non-tail
			     (continuation-dest
			      (node-cont (first (leaf-refs fun))))))
1065
	(when non-tail (reoptimize-call non-tail))
1066
	t))))