1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Timo Harter, Mike Sperber
4
5(define-c-generator let #f
6  (lambda (call port indent)
7    (let ((args (call-args call))
8	  (vars (lambda-variables (call-arg call 0))))
9      (do ((i 1 (+ i 1))
10	   (vars vars (cdr vars)))
11	  ((null? vars))
12	(let ((val (vector-ref args i)))
13	  (if (not (lambda-node? val))
14	      (c-assignment (car vars) val port indent)))))))
15
16(define-c-generator letrec1 #f
17  (lambda (call port indent)
18    (values)))
19
20(define-c-generator letrec2 #f
21  (lambda (call port indent)
22    (values)))
23
24(define-c-generator jump #f
25  (lambda (call port indent)
26    (let ((proc (called-lambda call)))
27      (assign-argument-vars (lambda-variables proc) call 1 port indent)
28      (indent-to port indent)
29      (display "goto " port)
30      (writec port #\L)
31      (display (lambda-id proc) port)
32      (write-char #\; port)
33      (note-jump-generated! proc)
34      (values))))
35
36(define (assign-argument-vars vars call start port indent)
37  (really-assign-argument-vars vars call start "arg" port indent))
38
39(define (assign-merged-argument-vars vars call start port indent)
40  (really-assign-argument-vars vars call start "merged_arg" port indent))
41
42(define (assign-global-argument-vars vars call start port indent)
43  (really-assign-argument-vars vars call start "goto_arg" port indent))
44
45(define (really-assign-argument-vars vars call start name port indent)
46  (let ((args (call-args call)))
47    (do ((i start (+ i 1))
48	 (vars vars (cdr vars)))
49	((>= i (vector-length args)))
50      (if (not (or (undefined-value-node? (vector-ref args i))
51		   (eq? type/unit (get-variable-type (car vars)))))
52	  (c-assignment (c-argument-var name
53					(get-variable-type (car vars))
54					(- i start)
55					port)
56			(vector-ref args i)
57			port indent)))))
58
59; Calls
60
61; Unknown calls have a first argument of 'goto if they are supposed to be
62; tail-recursive.  For known calls the protocol field of the lambda node
63; is set to 'tail-called if any of the calls are supposed to be tail-recursive.
64;
65; Calls to non-tail-called procedures are just regular C calls.  For tail-
66; called procedures there are two kinds of calls:
67;  Tail-call from a tail-called procedure: proceed through the driver loop
68;  All others: start a driver loop
69;
70; Known and unknown calls are handled identically, except that known calls
71; may be to merged procedures.
72;
73; Merged procedures with GOTO calls:
74;  This works if we merge the return points as well.  Possibly there should be
75; one return switch per C procedure.  There do have to be separate return point
76; variables (and one global one for the switch).
77
78(define-c-generator call #f
79  (lambda (call port indent)
80    (cond ((merged-procedure-reference (call-arg call 1))
81	   => (lambda (form)
82		(generate-merged-call call 2 form port indent)))
83	  (else
84           (generate-c-call call 2 port indent)))))
85
86(define-c-generator tail-call #f
87  (lambda (call port indent)
88    (cond ((merged-procedure-reference (call-arg call 1))
89	   => (lambda (form)
90		(generate-merged-goto-call call 2 form port indent)))
91	  (else
92           (generate-c-tail-call call 2 port indent)))))
93
94(define-c-generator unknown-call #f
95  (lambda (call port indent)
96    (if (goto-protocol? (literal-value (call-arg call 2)))
97	(user-warning "ignoring GOTO declaration for non-tail-recursive call to"
98		      (variable-name (reference-variable
99				      (call-arg call 1)))))
100    (generate-c-call call 3 port indent)))
101
102(define-c-generator unknown-tail-call #f
103  (lambda (call port indent)
104    (generate-c-tail-call call 3 port indent)))
105
106(define (generate-merged-goto-call call start form port indent)
107  (let ((proc (form-value form)))
108    (assign-merged-argument-vars (cdr (lambda-variables proc))
109				 call start
110				 port indent)
111    (indent-to port indent)
112    (display "goto " port)
113    (display (form-c-name form) port)
114    (write-char #\; port)
115    (values)))
116
117(define (generate-goto-call call start port indent)
118  (let ((proc (call-arg call 1)))
119    (if (not (global-reference? proc))
120	(bug "incorrect procedure in goto call ~S" call))
121    (assign-global-argument-vars (cdr (lambda-variables
122				       (global-lambda
123					(reference-variable proc))))
124				 call start
125				 port indent)
126    ; T is the marker for the tail-call version of the procedure
127    (indent-to port indent)
128    (display "return((long)T" port)
129    (c-value proc port)
130    (display ");" port)))
131
132(define (global-lambda var)
133  (let ((form (maybe-variable->form var)))
134    (if (and form
135	     (or (eq? 'lambda (form-type form))
136		 (eq? 'merged (form-type form))))
137	(form-value form)
138	(bug "value of ~S, called using goto, is not a known procedure"
139	       var))))
140
141; C requires that we dereference all but calls to global functions.
142; Calls to literals are macros that must take care of themselves.
143
144(define (generate-c-call call start port indent)
145  (let ((vars (lambda-variables (call-arg call 0)))
146        (args (call-args call))
147        (proc (call-arg call 1)))
148    (if (and (global-reference? proc)
149	     (memq? 'tail-called (variable-flags (reference-variable proc))))
150	(call-with-driver-loop call start port indent (car vars))
151	(let ((deref? (or (and (reference-node? proc)
152			       (variable-binder (reference-variable proc)))
153			  (call-node? proc))))
154	  (if (used? (car vars))
155	      (c-assign-to-variable (car vars) port indent))
156	  (if deref?
157	      (display "(*" port))
158	  (c-value proc port)
159	  (if deref?
160	      (writec port #\)))
161	  (write-value+result-var-list args start (cdr vars) port)))
162    (writec port #\;)
163    (values)))
164
165(define (generate-c-tail-call call start port indent)
166  (let ((proc (call-arg call 1))
167	(args (call-args call))
168	(cont (call-arg call 0)))
169    (cond ((not (and (global-reference? proc)
170		     (memq? 'tail-called
171			    (variable-flags (reference-variable proc)))))
172	   (let* ((type (get-variable-type (reference-variable cont)))
173		  (void? (or (eq? type type/unit)
174			     (eq? type type/null))))
175	     (indent-to port indent)
176	     (if (not void?)
177		 (display "return " port))
178	     (c-value proc port)
179	     (write-value-list-with-extras args start *extra-tail-call-args* port)
180	     (if void?
181		 (begin
182		   (display ";" port)
183		   (indent-to port indent)
184		   (display "return" port)))))
185	  (*doing-tail-called-procedure?*
186	   (generate-goto-call call start port indent))
187	  (else
188	   (call-with-driver-loop call start port indent #f)))
189    (writec port #\;)
190    (values)))
191
192(define (global-reference? node)
193  (and (reference-node? node)
194       (global-variable? (reference-variable node))))
195
196(define (call-with-driver-loop call start port indent result-var)
197  (let* ((proc-var (reference-variable (call-arg call 1)))
198	 (vars (lambda-variables (global-lambda proc-var))))
199    (assign-global-argument-vars (cdr vars) call start port indent)
200    (if result-var
201	(c-assign-to-variable result-var port indent)
202	(begin
203	  (indent-to port indent)
204	  (display "return " port)))
205    (display "TTrun_machine((long)" port)
206    (display "T" port)
207    (write-c-identifier (variable-name proc-var) port)
208    (display ")" port)))
209
210(define (generate-merged-call call start form port indent)
211  (let ((return-index (form-return-count form))
212	(name (form-c-name form))
213	(res (lambda-variables (call-arg call 0))))
214    (set-form-return-count! form (+ 1 return-index))
215    (assign-merged-argument-vars (cdr (lambda-variables (form-value form)))
216				 call start port indent)
217    (format port "~%#ifdef USE_DIRECT_THREADING~%")
218    (indent-to port indent)
219    (format port "~A_return_address = &&~A_return_~S;~%#else~%" name name return-index)
220    (indent-to port indent)
221    (format port "~A_return_tag = ~D;~%#endif~%" name return-index)
222    (indent-to port indent)
223    (format port "goto ~A;" name)
224    (indent-to port (- indent 1))
225    (format port "~A_return_~S:" name return-index)
226    (do ((i 0 (+ i 1))
227	 (res res (cdr res)))
228	((null? res))
229      (let ((var (car res)))
230	(cond ((and (used? var)
231		    (let ((type (get-variable-type var)))
232		      (and (not (eq? type type/unit))
233			   (not (eq? type type/null)))))
234	       (c-assign-to-variable var port indent)
235	       (format port "~A~D_return_value;" name i)))))))
236
237; Returns
238
239(define-c-generator return #f
240  (lambda (call port indent)
241    (if *current-merged-procedure*
242	(generate-return-from-merged-call call 1 port indent)
243	(really-generate-c-return call 1 port indent))))
244
245(define-c-generator unknown-return #f
246  (lambda (call port indent)
247    (cond (*doing-tail-called-procedure?*
248	   (generate-return-from-tail-call call port indent))
249	  (*current-merged-procedure*
250	   (generate-return-from-merged-call call 1 port indent))
251	  (else
252	   (really-generate-c-return call 1 port indent)))))
253
254(define (generate-return-from-tail-call call port indent)
255  (if (not (no-value-node? (call-arg call 1)))
256      (c-assignment "TTreturn_value" (call-arg call 1) port indent))
257  (indent-to port indent)
258  (display "return(0L);" port))
259
260(define (generate-return-from-merged-call call start port indent)
261  (let ((name *current-merged-procedure*))
262    (do ((i start (+ i 1)))
263	((= i (call-arg-count call)))
264      (let ((arg (call-arg call i)))
265	(if (not (no-value-node? arg))
266	    (c-assignment (format #f "~A~D_return_value" name (- i start))
267			  arg port indent))))
268    (format port "~%#ifdef USE_DIRECT_THREADING~%")
269    (indent-to port indent)
270    (format port "goto *~A_return_address;~%#else~%" name)
271    (indent-to port indent)
272    (format port "goto ~A_return;~%#endif~%" name)))
273
274(define (really-generate-c-return call start port indent)
275  (do ((i (+ start 1) (+ i 1)))
276      ((= i (call-arg-count call)))
277    (let ((arg (call-arg call i)))
278      (if (not (no-value-node? arg))
279	  (begin
280	    (indent-to port indent)
281	    (format port "*TT~D = " (- (- i start) 1))
282	    (c-value arg port)
283	    (write-char #\; port)))))
284  (let ((result (call-arg call start)))
285    (cond
286     ((and (not (no-value-node? result))
287	   (let ((type (get-variable-type
288			(reference-variable (call-arg call 0)))))
289	     (and (not (eq? type type/unit))
290		  (not (eq? type type/null)))))
291
292      (indent-to port indent)
293      (display "return" port)
294      (write-char #\space port)
295      (c-value result port)
296      (display ";" port))
297     (else
298      (if (call-node? result)
299	  ;; emit for the side effects
300	  (begin
301	    (indent-to port indent)
302	    (primop-generate-c (call-primop result) result port 0)
303	    (display ";" port)
304	    (newline port)))
305      (indent-to port indent)
306      (display "return" port)
307      (display ";" port))))
308  (values))
309
310; Allocate
311
312;(define-c-generator allocate #f
313;  (lambda (call port indent)
314;    (let ((cont (call-arg call 0))
315;          (size (call-arg call 1)))
316;      (c-assign-to-variable (car (lambda-variables cont)) port indent)
317;      (display "(long) malloc(" port)
318;      (c-value size port)
319;      (display "* sizeof(char));" port))))
320
321(define-c-generator global-ref #t
322  (lambda (call port indent)
323    (c-value (call-arg call 0) port)))
324
325(define-c-generator global-set! #f
326  (lambda (call port indent)
327    (let ((value (call-arg call 2)))
328      (if (not (and (literal-node? value)
329		    (unspecific? (literal-value value))))
330	  (c-assignment (reference-variable (call-arg call 1))
331			value
332			port indent)))))
333
334; if (ARG1 OP ARG2) {
335;   cont1 }
336; else {
337;   cont2 }
338
339(define-c-generator test #f
340  (lambda (call port indent)
341    (destructure ((#(cont1 cont2 value) (call-args call)))
342      (generate-c-conditional-prelude port indent)
343      (c-value value port)
344      (generate-c-conditional-jumps cont1 cont2 port indent))))
345
346(define (generate-c-conditional-prelude port indent)
347  (indent-to port indent)
348  (display "if " port)
349  (writec port #\())
350
351(define (generate-c-conditional-jumps cont1 cont2 port indent)
352  (display ") {" port)
353  (write-c-block (lambda-body cont1) port (+ indent 2))
354  (newline port)
355  (indent-to port indent)
356  (display "else {" port)
357  (write-c-block (lambda-body cont2) port (+ indent 2)))
358
359(define-c-generator unspecific #t
360  (lambda (call port indent)
361    (bug "generating code for undefined value ~S" call)))
362
363(define-c-generator uninitialized-value #t
364  (lambda (call port indent)
365    (bug "generating code for uninitialized value ~S" call)))
366
367(define-c-generator null-pointer? #t
368  (lambda (call port indent)
369    (display "NULL == " port)
370    (c-value (call-arg call 0) port)))
371
372(define-c-generator null-pointer #t
373  (lambda (call port indent)
374    (display "NULL" port)))
375
376(define-c-generator eq? #t
377  (lambda (call port indent)
378    (simple-c-primop "==" call port)))
379
380