source: project/chicken/trunk/c-backend.scm @ 15246

Last change on this file since 15246 was 15246, checked in by felix winkelmann, 12 years ago

-debug v; compile-file; all namespace decls in one file

File size: 48.0 KB
Line 
1;;; c-backend.scm - C-generating backend for the CHICKEN compiler
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare (unit backend))
29
30
31(include "compiler-namespace")
32(include "tweaks")
33
34
35;;; Write atoms to output-port:
36
37(define output #f)
38
39(define (gen . data)
40  (for-each
41   (lambda (x) 
42     (if (eq? #t x)
43         (newline output)
44         (display x output) ) )
45   data) )
46
47(define (gen-list lst)
48  (for-each
49   (lambda (x) (display x output))
50   (intersperse lst #\space) ) )
51
52
53;;; Unique id/prefix:
54
55(define unique-id
56  (string->c-identifier
57   (sprintf "C_~X_~A_" (random #x1000000) (current-seconds)) ) )
58
59
60;;; Generate target code:
61
62(define (generate-code literals lliterals lambdas out source-file dynamic db)
63  (let ()
64
65    ;; Some helper procedures
66
67    (define (find-lambda id)
68      (or (find (lambda (ll) (eq? id (lambda-literal-id ll))) lambdas)
69          (bomb "can't find lambda" id) ) )
70
71    (define (slashify s) (string-translate (->string s) "\\" "/"))
72    (define (uncommentify s) (string-translate* (->string s) '(("*/" . "* /"))))
73 
74    ;; Compile a single expression
75    (define (expression node temps ll)
76
77      (define (expr n i)
78        (let ((subs (node-subexpressions n))
79              (params (node-parameters n)) )
80          (case (node-class n)
81
82            ((##core#immediate)
83             (case (first params)
84               ((bool) (gen (if (second params) "C_SCHEME_TRUE" "C_SCHEME_FALSE")))
85               ((char) (gen "C_make_character(" (char->integer (second params)) #\)))
86               ((nil) (gen "C_SCHEME_END_OF_LIST"))
87               ((fix) (gen "C_fix(" (second params) #\)))
88               ((eof) (gen "C_SCHEME_END_OF_FILE"))
89               (else (bomb "bad immediate")) ) )
90
91            ((##core#literal) 
92             (let ((lit (first params)))
93               (if (vector? lit)
94                   (gen "((C_word)li" (vector-ref lit 0) ")") 
95                   (gen "lf[" (first params) #\])) ) )
96
97            ((if)
98             (gen #t "if(C_truep(")
99             (expr (car subs) i)
100             (gen ")){")
101             (expr (cadr subs) i)
102             (gen #\} #t "else{")
103             (expr (caddr subs) i)
104             (gen #\}) )
105
106            ((##core#proc)
107             (gen "(C_word)" (first params)) )
108
109            ((##core#bind) 
110             (let loop ((bs subs) (i i) (count (first params)))
111               (cond [(> count 0)
112                      (gen #t #\t i #\=)
113                      (expr (car bs) i)
114                      (gen #\;)
115                      (loop (cdr bs) (add1 i) (sub1 count)) ]
116                     [else (expr (car bs) i)] ) ) )
117
118            ((##core#ref) 
119             (gen "((C_word*)")
120             (expr (car subs) i)
121             (gen ")[" (+ (first params) 1) #\]) )
122
123            ((##core#unbox) 
124             (gen "((C_word*)")
125             (expr (car subs) i)
126             (gen ")[1]") )
127
128            ((##core#update_i)
129             (gen "C_set_block_item(")
130             (expr (car subs) i)
131             (gen #\, (first params) #\,)
132             (expr (cadr subs) i) 
133             (gen #\)) )
134
135            ((##core#update)
136             (gen "C_mutate(((C_word *)")
137             (expr (car subs) i)
138             (gen ")+" (+ (first params) 1) ",")
139             (expr (cadr subs) i) 
140             (gen #\)) )
141
142            ((##core#updatebox_i)
143             (gen "C_set_block_item(")
144             (expr (car subs) i)
145             (gen ",0,")
146             (expr (cadr subs) i) 
147             (gen #\)) )
148
149            ((##core#updatebox)
150             (gen "C_mutate(((C_word *)")
151             (expr (car subs) i)
152             (gen ")+1,")
153             (expr (cadr subs) i) 
154             (gen #\)) )
155
156            ((##core#closure)
157             (let ((n (first params)))
158               (gen "(*a=C_CLOSURE_TYPE|" n #\,)
159               (for-each
160                (lambda (x j)
161                  (gen "a[" j "]=")
162                  (expr x i)
163                  (gen #\,) )
164                subs (iota n 1 1) )
165               (gen "tmp=(C_word)a,a+=" (add1 n) ",tmp)") ) )
166
167            ((##core#box) 
168             (gen "(*a=C_VECTOR_TYPE|1,a[1]=")
169             (expr (car subs) i)
170             (gen ",tmp=(C_word)a,a+=2,tmp)") )
171
172            ((##core#local) (gen #\t (first params)))
173
174            ((##core#setlocal) 
175             (gen #\t (first params) #\=)
176             (expr (car subs) i) )
177
178            ((##core#global)
179             (let ((index (first params))
180                   (safe (second params)) 
181                   (block (third params)) )
182               (cond [block
183                      (if safe
184                          (gen "lf[" index "]")
185                          (gen "C_retrieve2(lf[" index "]," (c-ify-string (symbol->string (fourth params))) #\)) ) ]
186                     [safe (gen "*((C_word*)lf[" index "]+1)")]
187                     [else (gen "C_retrieve(lf[" index "])")] ) ) )
188
189            ((##core#setglobal)
190             (let ((index (first params))
191                   (block (second params)) 
192                   (var (third params)))
193               (if block
194                   (gen "C_mutate(&lf[" index "]")
195                   (gen "C_mutate((C_word*)lf[" index "]+1") )
196               (gen " /* (set! " (uncommentify (symbol->string var)) " ...) */,")
197               (expr (car subs) i)
198               (gen #\)) ) )
199
200            ((##core#setglobal_i)
201             (let ((index (first params))
202                   (block (second params)) 
203                   (var (third params)) )
204               (cond [block
205                      (gen "lf[" index "] /* "
206                           (uncommentify (symbol->string var)) " */ =")
207                      (expr (car subs) i)
208                      (gen #\;) ]
209                     [else
210                      (gen "C_set_block_item(lf[" index "] /* "
211                           (uncommentify (symbol->string var)) " */,0,")
212                      (expr (car subs) i)
213                      (gen #\)) ] ) ) )
214
215            ((##core#undefined) (gen "C_SCHEME_UNDEFINED"))
216
217            ((##core#call) 
218             (let* ((args (cdr subs))
219                    (n (length args))
220                    (nc i)
221                    (nf (add1 n)) 
222                    (p2 (pair? (cdr params)))
223                    (name (and p2 (second params)))
224                    (name-str (source-info->string name))
225                    (call-id (and p2 (pair? (cddr params)) (third params))) 
226                    (customizable (and call-id (fourth params)))
227                    (empty-closure (and customizable (zero? (lambda-literal-closure-size (find-lambda call-id)))))
228                    (fn (car subs)) )
229               (when name
230                 (if emit-trace-info
231                     (gen #t "C_trace(\"" (slashify name-str) "\");")
232                     (gen #t "/* " (uncommentify name-str) " */") ) )
233               (cond ((eq? '##core#proc (node-class fn))
234                      (let ([fpars (node-parameters fn)])
235                        (gen #t (first fpars) #\( nf ",0,") )
236                      (expr-args args i)
237                      (gen ");") )
238                     (call-id
239                      (cond ((and (eq? call-id (lambda-literal-id ll))
240                                  (lambda-literal-looping ll) )
241                             (let* ([temps (lambda-literal-temporaries ll)]
242                                    [ts (iota n (+ temps nf) 1)] )
243                               (for-each
244                                (lambda (arg tr)
245                                  (gen #t #\t tr #\=)
246                                  (expr arg i) 
247                                  (gen #\;) )
248                                args ts)
249                               (for-each
250                                (lambda (from to) (gen #t #\t to "=t" from #\;))
251                                ts (iota n 1 1) )
252                               (unless customizable (gen #t "c=" nf #\;))
253                               (gen #t "goto loop;") ) )
254                            (else
255                             (unless empty-closure
256                               (gen #t #\t nc #\=)
257                               (expr fn i)
258                               (gen #\;) )
259                             (gen #t call-id #\()
260                             (unless customizable (gen nf #\,))
261                             (unless empty-closure (gen #\t nc #\,))
262                             (expr-args args i)
263                             (gen ");") ) ) )
264                     ((and (eq? '##core#global (node-class fn))
265                           (not unsafe) 
266                           (not no-procedure-checks)
267                           (not (first params)))
268                      (let* ((gparams (node-parameters fn))
269                             (index (first gparams))
270                             (safe (second gparams)) 
271                             (block (third gparams)) 
272                             (carg #f))
273                        (gen #t "((C_proc" nf ")")
274                        (cond (block
275                               (set! carg (string-append "lf[" (number->string index) "]"))
276                               (if safe
277                                   (gen "C_retrieve_proc(" carg ")")
278                                   (gen "C_retrieve2_symbol_proc(" carg "," 
279                                        (c-ify-string (symbol->string (fourth gparams))) #\)) ) )
280                              (safe 
281                               (set! carg 
282                                 (string-append "*((C_word*)lf[" (number->string index) "]+1)"))
283                               (gen "C_retrieve_proc(" carg ")"))
284                              (else
285                               (set! carg 
286                                 (string-append "*((C_word*)lf[" (number->string index) "]+1)"))
287                               (gen "C_retrieve_symbol_proc(lf[" index "])") ))
288                        (gen ")(" nf #\, carg #\,)
289                        (expr-args args i)
290                        (gen ");") ) )
291                     (else
292                      (gen #t #\t nc #\=)
293                      (expr fn i)
294                      (gen #\; #t
295                           "((C_proc" nf ")")
296                      (if (or unsafe no-procedure-checks (first params))
297                          (gen "(void*)(*((C_word*)t" nc "+1))")
298                          (gen "C_retrieve_proc(t" nc ")") )
299                      (gen ")(" nf ",t" nc #\,)
300                      (expr-args args i)
301                      (gen ");") ) ) ) )
302         
303            ((##core#recurse) 
304             (let* ([n (length subs)]
305                    [nf (add1 n)]
306                    [tailcall (first params)]
307                    [call-id (second params)] 
308                    [empty-closure (zero? (lambda-literal-closure-size ll))] )
309               (cond (tailcall
310                      (let* ([temps (lambda-literal-temporaries ll)]
311                             [ts (iota n (+ temps nf) 1)] )
312                        (for-each
313                         (lambda (arg tr)
314                           (gen #t #\t tr #\=)
315                           (expr arg i) 
316                           (gen #\;) )
317                         subs ts)
318                        (for-each
319                         (lambda (from to) (gen #t #\t to "=t" from #\;))
320                         ts (iota n 1 1) )
321                        (gen #t "goto loop;") ) )
322                     (else
323                      (gen call-id #\()
324                      (unless empty-closure (gen "t0,"))
325                      (expr-args subs i)
326                      (gen #\)) ) ) ) )
327
328            ((##core#direct_call) 
329             (let* ((args (cdr subs))
330                    (n (length args))
331                    (nf (add1 n)) 
332                    ;;(name (second params))
333                    (call-id (third params))
334                    (demand (fourth params))
335                    (allocating (not (zero? demand)))
336                    (empty-closure (zero? (lambda-literal-closure-size (find-lambda call-id))))
337                    (fn (car subs)) )
338               (gen call-id #\()
339               (when allocating 
340                 (gen "C_a_i(&a," demand #\))
341                 (when (or (not empty-closure) (pair? args)) (gen #\,)) )
342               (unless empty-closure
343                 (expr fn i)
344                 (when (pair? args) (gen #\,)) )
345               (when (pair? args) (expr-args args i))
346               (gen #\)) ) )
347
348            ((##core#callunit)
349             ;; The code generated here does not use the extra temporary needed for standard calls, so we have
350             ;;  one unused varable:
351             (let* ((n (length subs))
352                    (nf (+ n 1)) )
353               (gen #t "C_" (first params) "_toplevel(" nf ",C_SCHEME_UNDEFINED,")
354               (expr-args subs i)
355               (gen ");") ) )
356
357            ((##core#return)
358             (gen #t "return(")
359             (expr (first subs) i)
360             (gen ");") )
361
362            ((##core#inline)
363             (gen "(C_word)" (first params) #\()
364             (expr-args subs i)
365             (gen #\)) )
366
367            ((##core#inline_allocate)
368             (gen "(C_word)" (first params) "(&a," (length subs))
369             (if (pair? subs)
370                 (begin
371                   (gen #\,)
372                   (expr-args subs i) ) )
373             (gen #\)) )
374
375            ((##core#inline_ref)
376             (gen (foreign-result-conversion (second params) "a") (first params) #\)) )
377
378            ((##core#inline_update)
379             (let ([t (second params)])
380               (gen #\( (first params) "=(" (foreign-type-declaration t "") #\) (foreign-argument-conversion t)) 
381               (expr (first subs) i)
382               (gen "),C_SCHEME_UNDEFINED)") ) )
383
384            ((##core#inline_loc_ref)
385             (let ([t (first params)])
386               (gen (foreign-result-conversion t "a") "*((" (foreign-type-declaration t "") "*)C_data_pointer(")
387               (expr (first subs) i)
388               (gen ")))") ) )
389
390            ((##core#inline_loc_update)
391             (let ([t (first params)])
392               (gen "((*(" (foreign-type-declaration t "") "*)C_data_pointer(")
393               (expr (first subs) i)
394               (gen "))=" (foreign-argument-conversion t))
395               (expr (second subs) i) 
396               (gen "),C_SCHEME_UNDEFINED)") ) )
397
398            ((##core#switch)
399             (gen #t "switch(")
400             (expr (first subs) i)
401             (gen "){")
402             (do ([j (first params) (sub1 j)]
403                  [ps (cdr subs) (cddr ps)] )
404                 ((zero? j)
405                  (gen #t "default:")
406                  (expr (car ps) i)
407                  (gen #\}) )
408               (gen #t "case ")
409               (expr (car ps) i)
410               (gen #\:)
411               (expr (cadr ps) i) ) )
412
413            ((##core#cond)
414             (gen "(C_truep(")
415             (expr (first subs) i)
416             (gen ")?")
417             (expr (second subs) i)
418             (gen #\:)
419             (expr (third subs) i)
420             (gen #\)) )
421
422            (else (bomb "bad form")) ) ) )
423   
424      (define (expr-args args i)
425        (pair-for-each
426         (lambda (xs)
427           (if (not (eq? xs args)) (gen #\,))
428           (expr (car xs) i) )
429         args) )
430
431      (expr node temps) )
432 
433    (define (header)
434      (define (pad0 n)
435        (if (< n 10)
436            (string-append "0" (number->string n))
437            n) )
438      (let* ((tm (##sys#decode-seconds (current-seconds) #f))
439             (min (vector-ref tm 1))
440             (hour (vector-ref tm 2))
441             (mday (vector-ref tm 3))
442             (mon (vector-ref tm 4))
443             (year (vector-ref tm 5)) )
444        (gen "/* Generated from " source-file " by the CHICKEN compiler" #t
445             "   http://www.call-with-current-continuation.org" #t
446             "   " (+ 1900 year) #\- (pad0 (add1 mon)) #\- (pad0 mday) #\space (pad0 hour) #\: (pad0 min) #t
447             (string-intersperse
448              (map (cut string-append "   " <> "\n") 
449                   (string-split (chicken-version #t) "\n") ) 
450              "")
451             "   command line: ")
452        (gen-list compiler-arguments)
453        (gen #t)
454        (cond [unit-name (gen "   unit: " unit-name)]
455              [else
456               (gen "   used units: ")
457               (gen-list used-units) ] )
458        (gen #t "*/" #t #t "#include \"" target-include-file "\"")
459        (when external-protos-first
460          (generate-foreign-callback-stub-prototypes foreign-callback-stubs) )
461        (when (pair? foreign-declarations)
462          (gen #t)
463          (for-each (lambda (decl) (gen #t decl)) foreign-declarations) )
464        (unless external-protos-first
465          (generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) ) )
466 
467    (define (trailer)
468      (gen #t "/* end of file */" #t) )
469 
470    (define (declarations)
471      (let ((n (length literals)))
472        (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void);")
473        (for-each
474         (lambda (uu) 
475           (gen #t "C_noret_decl(C_" uu "_toplevel)"
476                #t "C_externimport void C_ccall C_" uu "_toplevel(C_word c,C_word d,C_word k) C_noret;"))
477         used-units)
478        (unless (zero? n)
479          (gen #t #t "static C_TLS C_word lf[" n "];") )
480        (gen #t "static double C_possibly_force_alignment;")
481        (do ((i 0 (add1 i))
482             (llits lliterals (cdr llits)))
483            ((null? llits))
484          (let* ((ll (##sys#lambda-info->string (car llits)))
485                 (llen (string-length ll)))
486            (gen #t "static C_char C_TLS li" i "[] C_aligned={C_lihdr(" 
487                 (arithmetic-shift llen -16) #\,
488                 (bitwise-and #xff (arithmetic-shift llen -8)) #\,
489                 (bitwise-and #xff llen)
490                 #\))
491            (do ((n 0 (add1 n)))
492                ((>= n llen))
493              (gen #\, (char->integer (string-ref ll n))) )
494            (do ((n (- (bitwise-and #xfffff8 (+ llen 7)) llen) (sub1 n))) ; fill up with zeros to align following entry
495                ((zero? n))
496              (gen ",0") )
497            (gen "};")))))
498 
499    (define (prototypes)
500      (let ([large-signatures '()])
501        (gen #t)
502        (for-each
503         (lambda (ll)
504           (let* ([n (lambda-literal-argument-count ll)]
505                  [customizable (lambda-literal-customizable ll)] 
506                  [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))]
507                  [varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,)]
508                  [id (lambda-literal-id ll)]
509                  [rest (lambda-literal-rest-argument ll)]
510                  [rest-mode (lambda-literal-rest-argument-mode ll)]
511                  [direct (lambda-literal-direct ll)] 
512                  [allocated (lambda-literal-allocated ll)] )
513             (when (>= n small-parameter-limit)
514               (set! large-signatures (lset-adjoin = large-signatures (add1 n))) )
515             (gen #t)
516             (for-each
517              (lambda (s) 
518                (when (>= s small-parameter-limit)
519                  (set! large-signatures (lset-adjoin = large-signatures (add1 s))) ) )
520              (lambda-literal-callee-signatures ll) )
521             (cond [(not (eq? 'toplevel id))
522                    (gen "C_noret_decl(" id ")" #t)
523                    (gen "static ")
524                    (gen (if direct "C_word " "void "))
525                    (if customizable
526                        (gen "C_fcall ")
527                        (gen "C_ccall ") )
528                    (gen id) ]
529                   [else
530                    (let ((uname (if unit-name (string-append unit-name "_toplevel") "toplevel")))
531                      (gen "C_noret_decl(C_" uname ")" #t)
532                      (when emit-unsafe-marker
533                        (gen "C_externexport void C_dynamic_and_unsafe(void) {}" #t) )
534                      (gen "C_externexport void C_ccall ")
535                      (gen "C_" uname) ) ] )
536             (gen #\()
537             (unless customizable (gen "C_word c,"))
538             (when (and direct (not (zero? allocated)))
539               (gen "C_word *a")
540               (when (pair? varlist) (gen #\,)) )
541             (apply gen varlist)
542             (cond [rest
543                    (gen ",...) C_noret;")
544                    (if (not (eq? rest-mode 'none))
545                        (begin
546                          (gen #t "C_noret_decl(" id ")" 
547                               #t "static void C_ccall " id "r(")
548                          (apply gen varlist)
549                          (gen ",C_word t" (+ n 1) ") C_noret;") ) ) ]
550                   [else
551                    (gen #\))
552                    ;;(when customizable (gen " C_c_regparm"))
553                    (unless direct (gen " C_noret"))
554                    (gen #\;) ] ) ) )
555         lambdas) 
556        (for-each
557         (lambda (s)
558           (gen #t "typedef void (*C_proc" s ")(C_word")
559           (for-each gen (make-list s ",C_word"))
560           (gen ") C_noret;") )
561         large-signatures) ) )
562 
563    (define (trampolines)
564      (let ([ns '()]
565            [nsr '()] 
566            [nsrv '()] )
567
568        (define (restore n)
569          (do ((i (- n 1) (- i 1))
570               (j 0 (+ j 1)) )
571              ((negative? i))
572            (gen #t "C_word t" i "=C_pick(" j ");") ) 
573          (gen #t "C_adjust_stack(-" n ");") )
574
575        (define (emitter vflag)
576          (lambda (n)
577            (gen #t #t "C_noret_decl(tr" n #\r (if vflag #\v "") ")"
578                 #t "static void C_fcall tr" n #\r (if vflag #\v ""))
579            (gen "(C_proc" n " k) C_regparm C_noret;")
580            (gen #t "C_regparm static void C_fcall tr" n #\r)
581            (when vflag (gen #\v))
582            (gen "(C_proc" n " k){"
583                 #t "int n;"
584                 #t "C_word *a,t" n #\;)
585            (restore n)
586            (gen #t "n=C_rest_count(0);")
587            (if vflag
588                (gen #t "a=C_alloc(n+1);")
589                (gen #t "a=C_alloc(n*3);") )
590            (gen #t #\t n "=C_restore_rest")
591            (when vflag (gen "_vector"))
592            (gen "(a,n);")
593            (gen #t "(k)(")
594            (apply gen (intersperse (make-argument-list (+ n 1) "t") #\,))
595            (gen ");}") ) )
596
597        (for-each
598         (lambda (ll)
599           (let* ([argc (lambda-literal-argument-count ll)]
600                  [rest (lambda-literal-rest-argument ll)]
601                  [rest-mode (lambda-literal-rest-argument-mode ll)]
602                  [id (lambda-literal-id ll)]
603                  [customizable (lambda-literal-customizable ll)]
604                  [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
605             (when empty-closure (set! argc (sub1 argc)))
606             (unless (lambda-literal-direct ll)
607               (cond [customizable
608                      (gen #t #t "C_noret_decl(tr" id ")"
609                           #t "static void C_fcall tr" id "(void *dummy) C_regparm C_noret;")
610                      (gen #t "C_regparm static void C_fcall tr" id "(void *dummy){")
611                      (restore argc)
612                      (gen #t id #\()
613                      (let ([al (make-argument-list argc "t")])
614                        (apply gen (intersperse al #\,)) )
615                      (gen ");}") ]
616                     [(or rest (> (lambda-literal-allocated ll) 0) (lambda-literal-external ll))
617                      (if (and rest (not (eq? rest-mode 'none)))
618                          (if (eq? rest-mode 'vector)
619                              (set! nsrv (lset-adjoin = nsrv argc))
620                              (set! nsr (lset-adjoin = nsr argc)) ) 
621                          (set! ns (lset-adjoin = ns argc)) ) ] ) ) ) )
622         lambdas)
623        (for-each
624         (lambda (n)
625           (gen #t #t "C_noret_decl(tr" n ")"
626                #t "static void C_fcall tr" n "(C_proc" n " k) C_regparm C_noret;")
627           (gen #t "C_regparm static void C_fcall tr" n "(C_proc" n " k){")
628           (restore n)
629           (gen #t "(k)(" n #\,)
630           (apply gen (intersperse (make-argument-list n "t") #\,))
631           (gen ");}") )
632         ns)
633        (for-each (emitter #f) nsr)
634        (for-each (emitter #t) nsrv) ) )
635 
636    (define (literal-frame)
637      (do ([i 0 (add1 i)]
638           [lits literals (cdr lits)] )
639          ((null? lits))
640        (gen-lit (car lits) (sprintf "lf[~s]" i)) ) )
641
642    (define (bad-literal lit)
643      (bomb "type of literal not supported" lit) )
644
645    (define (literal-size lit)
646      (cond [(immediate? lit) 0]
647            [(string? lit) 0]
648            [(number? lit) words-per-flonum]
649            [(symbol? lit) 10]          ; size of symbol, and possibly a bucket
650            [(pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit)))]
651            [(vector? lit) (+ 1 (vector-length lit) (reduce + 0 (map literal-size (vector->list lit))))]
652            [(block-variable-literal? lit) 0]
653            [(##sys#immediate? lit) (bad-literal lit)]
654            [(##core#inline "C_lambdainfop" lit) 0]
655            [(##sys#bytevector? lit) (+ 2 (words (##sys#size lit))) ] ; drops "permanent" property!
656            [(##sys#generic-structure? lit)
657             (let ([n (##sys#size lit)])
658               (let loop ([i 0] [s (+ 2 n)])
659                 (if (>= i n)
660                     s
661                     (loop (add1 i) (+ s (literal-size (##sys#slot lit i)))) ) ) ) ]
662            [else (bad-literal lit)] ) )
663
664    (define (gen-lit lit to)
665      ;; we do simple immediate literals directly to avoid a function call:
666      (cond ((and (fixnum? lit) (not (big-fixnum? lit)))
667             (gen #t to "=C_fix(" lit ");") )
668            ((block-variable-literal? lit))
669            ((eq? lit (void))
670             (gen #t to "=C_SCHEME_UNDEFINED;") )
671            ((boolean? lit) 
672             (gen #t to #\= (if lit "C_SCHEME_TRUE" "C_SCHEME_FALSE") #\;) )
673            ((char? lit)
674             (gen #t to "=C_make_character(" (char->integer lit) ");") )
675            ((symbol? lit)              ; handled slightly specially (see C_h_intern_in)
676             (let* ([str (##sys#slot lit 1)]
677                    [cstr (c-ify-string str)]
678                    [len (##sys#size str)] )
679               (gen #t to "=")
680               (gen "C_h_intern(&" to #\, len #\, cstr ");") ) )
681            ((null? lit) 
682             (gen #t to "=C_SCHEME_END_OF_LIST;") )
683            ((and (not (##sys#immediate? lit))
684                  (##core#inline "C_lambdainfop" lit)))
685            ((or (fixnum? lit) (not (##sys#immediate? lit)))
686             (gen #t to "=C_decode_literal(C_heaptop,")
687             (gen-string-constant (encode-literal lit))
688             (gen ");") )
689            (else (bad-literal lit))))
690
691    (define (gen-string-constant str)
692      (let* ([len (##sys#size str)]
693             [ns (fx/ len 80)]
694             [srest (modulo len 80)] )
695        (do ([i ns (sub1 i)]
696             [offset 0 (+ offset 80)] )
697            ((zero? i)
698             (when (or (zero? len) (not (zero? srest)))
699               (gen (c-ify-string (string-like-substring str offset len))) ) )
700          (gen (c-ify-string (string-like-substring str offset (+ offset 80))) #t) ) ) )
701 
702    (define (string-like-substring s start end)
703      (let* ([len (- end start)]
704             [s2 (make-string len)] )
705        (##sys#copy-bytes s s2 start 0 len)
706        s2) )
707
708    (define (procedures)
709      (for-each
710       (lambda (ll)
711         (let* ([n (lambda-literal-argument-count ll)]
712                [id (lambda-literal-id ll)]
713                [rname (real-name id db)]
714                [demand (lambda-literal-allocated ll)]
715                [rest (lambda-literal-rest-argument ll)]
716                [customizable (lambda-literal-customizable ll)]
717                [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))]
718                [nec (- n (if empty-closure 1 0))]
719                [vlist0 (make-variable-list n "t")]
720                [alist0 (make-argument-list n "t")]
721                [varlist (intersperse (if empty-closure (cdr vlist0) vlist0) #\,)]
722                [arglist (intersperse (if empty-closure (cdr alist0) alist0) #\,)]
723                [external (lambda-literal-external ll)]
724                [looping (lambda-literal-looping ll)]
725                [direct (lambda-literal-direct ll)]
726                [rest-mode (lambda-literal-rest-argument-mode ll)]
727                [temps (lambda-literal-temporaries ll)]
728                [topname (if unit-name
729                             (string-append unit-name "_toplevel")
730                             "toplevel") ] )
731           (when empty-closure (debugging 'o "dropping unused closure argument" id))
732           (gen #t #t)
733           (gen "/* " (cleanup rname) " */" #t)
734           (cond [(not (eq? 'toplevel id)) 
735                  (gen "static ")
736                  (gen (if direct "C_word " "void "))
737                  (if customizable
738                      (gen "C_fcall ")
739                      (gen "C_ccall ") )
740                  (gen id) ]
741                 [else
742                  (gen "static C_TLS int toplevel_initialized=0;")
743                  (unless unit-name
744                    (gen #t "C_main_entry_point") )
745                  (gen #t "C_noret_decl(toplevel_trampoline)"
746                       #t "static void C_fcall toplevel_trampoline(void *dummy) C_regparm C_noret;"
747                       #t "C_regparm static void C_fcall toplevel_trampoline(void *dummy){"
748                       #t "C_" topname "(2,C_SCHEME_UNDEFINED,C_restore);}"
749                       #t #t "void C_ccall C_" topname) ] )
750           (gen #\()
751           (unless customizable (gen "C_word c,"))
752           (when (and direct (not (zero? demand))) 
753             (gen "C_word *a")
754             (when (pair? varlist) (gen #\,)) )
755           (apply gen varlist)
756           (when rest (gen ",..."))
757           (gen "){")
758           (when (eq? rest-mode 'none) (set! rest #f))
759           (gen #t "C_word tmp;")
760           (if rest
761               (gen #t "C_word t" n #\;) ; To hold rest-list if demand is met
762               (do ([i n (add1 i)]
763                    [j (+ temps (if looping (sub1 n) 0)) (sub1 j)] )
764                   ((zero? j))
765                 (gen #t "C_word t" i #\;) ) )
766           (cond [(eq? 'toplevel id) 
767                  (let ([ldemand (fold (lambda (lit n) (+ n (literal-size lit))) 0 literals)]
768                        [llen (length literals)] )
769                    (gen #t "C_word *a;"
770                         #t "if(toplevel_initialized) C_kontinue(t1,C_SCHEME_UNDEFINED);"
771                         #t "else C_toplevel_entry(C_text(\"" topname "\"));")
772                    (when disable-stack-overflow-checking
773                      (gen #t "C_disable_overflow_check=1;") )
774                    (unless unit-name
775                      (cond [target-initial-heap-size
776                             (gen #t "C_set_or_change_heap_size(" target-initial-heap-size ",1);") ]
777                            [target-heap-size
778                             (gen #t "C_set_or_change_heap_size(" target-heap-size ",1);"
779                                  #t "C_heap_size_is_fixed=1;") ] )
780                      (when target-heap-growth
781                        (gen #t "C_heap_growth=" target-heap-growth #\;) )
782                      (when target-heap-shrinkage
783                        (gen #t "C_heap_shrinkage=" target-heap-shrinkage #\;) )
784                      (when target-stack-size
785                        (gen #t "C_resize_stack(" target-stack-size ");") ) )
786                    (gen #t "C_check_nursery_minimum(" demand ");"
787                         #t "if(!C_demand(" demand ")){"
788                         #t "C_save(t1);"
789                         #t "C_reclaim((void*)toplevel_trampoline,NULL);}"
790                         #t "toplevel_initialized=1;")
791                    (gen #t "if(!C_demand_2(" ldemand ")){"
792                         #t "C_save(t1);"
793                         #t "C_rereclaim2(" ldemand "*sizeof(C_word), 1);"
794                         #t "t1=C_restore;}")
795                    (gen #t "a=C_alloc(" demand ");")
796                    (when (not (zero? llen))
797                      (gen #t "C_initialize_lf(lf," llen ");")
798                      (literal-frame)
799                      (gen #t "C_register_lf2(lf," llen ",create_ptable());") ) ) ]
800                 [rest
801                  (gen #t "va_list v;")
802                  (gen #t "C_word *a,c2=c;")
803                  (gen #t "C_save_rest(")
804                  (if (> n 0)
805                      (gen #\t (- n 1))
806                      (gen "c") )
807                  (gen ",c2," n ");")
808                  (when (and (not unsafe) (not no-argc-checks) (> n 2) (not empty-closure))
809                    (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);") )
810                  (when insert-timer-checks (gen #t "C_check_for_interrupt;"))
811                  (gen #t "if(!C_demand(c*C_SIZEOF_PAIR+" demand ")){") ]
812                 [else
813                  (cond [(and (not direct) (> demand 0))
814                         (if looping
815                             (gen #t "C_word *a;"
816                                  #t "loop:"
817                                  #t "a=C_alloc(" demand ");")
818                             (gen #t "C_word ab[" demand "],*a=ab;") ) ]
819                        [else
820                         (unless direct (gen #t "C_word *a;"))
821                         (when looping (gen #t "loop:")) 
822                         (when (and direct (not unsafe) (not disable-stack-overflow-checking))
823                           (gen #t "C_stack_check;") ) ] )
824                  (when (and external (not unsafe) (not no-argc-checks) (not customizable))
825                    ;; (not customizable) implies empty-closure
826                    (if (eq? rest-mode 'none)
827                        (when (> n 2) (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);"))
828                        (gen #t "if(c!=" n ") C_bad_argc_2(c," n ",t0);") ) )
829                  (when (and (not direct) (or external (> demand 0)))
830                    (when insert-timer-checks (gen #t "C_check_for_interrupt;"))
831                    (if (and looping (> demand 0))
832                        (gen #t "if(!C_stack_probe(a)){")
833                        (gen #t "if(!C_stack_probe(&a)){") ) ) ] )
834           (when (and (not (eq? 'toplevel id))
835                      (not direct)
836                      (or rest external (> demand 0)) )
837;;           (cond [(> nec 1)
838;;                  (gen #t "C_adjust_stack(" nec ");")
839;;                  (do ([i (if empty-closure 1 0) (+ i 1)])
840;;                      ((>= i n))
841;;                    (gen #t "C_rescue(t" i #\, (- n i 1) ");") ) ]
842;;                 [(= nec 1) (gen #t "C_save(" (if empty-closure "t1" "t0") ");")] )
843             (cond [rest
844                    (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr" n #\r)
845                    (when (eq? rest-mode 'vector) (gen #\v))
846                    (gen ",(void*)" id "r")
847                    (when (> nec 0)
848                      (gen #\, nec #\,)
849                      (apply gen arglist) )
850                    (gen ");}"
851                         #t "else{"
852                         #t "a=C_alloc((c-" n ")*3);")
853                    (case rest-mode
854                      [(list #f) (gen #t "t" n "=C_restore_rest(a,C_rest_count(0));")]
855                      [(vector) (gen #t "t" n "=C_restore_rest_vector(a,C_rest_count(0));")] )
856                    (gen #t id "r(")
857                    (apply gen (intersperse (make-argument-list n "t") #\,))
858                    (gen ",t" n ");}}")
859                    ;; Create secondary routine (no demand-check or argument-count-parameter):
860                    (gen #t #t "static void C_ccall " id "r(")
861                    (apply gen varlist)
862                    (gen ",C_word t" n "){")
863                    (gen #t "C_word tmp;")
864                    (do ([i (+ n 1) (+ i 1)]
865                         [j temps (- j 1)] )
866                        ((zero? j))
867                      (gen #t "C_word t" i #\;) )
868                    (when (> demand 0) (gen #t "C_word *a=C_alloc(" demand ");")) ]
869                   [else
870                    (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr")
871                    (if customizable 
872                        (gen id ",NULL")
873                        (gen n ",(void*)" id) )
874                    (when (> nec 0)
875                      (gen #\, nec #\,)
876                      (apply gen arglist) )
877                    (gen ");}") ] ) )
878           (expression
879            (lambda-literal-body ll)
880            (if rest
881                (add1 n) ; One temporary is needed to hold the rest-list
882                n)
883            ll)
884           (gen #\}) ) )
885       lambdas) )
886
887    (debugging 'p "code generation phase...")
888    (set! output out)
889    (header)
890    (declarations)
891    (generate-external-variables external-variables)
892    (generate-foreign-stubs foreign-lambda-stubs db)
893    (prototypes)
894    (generate-foreign-callback-stubs foreign-callback-stubs db)
895    (trampolines)
896    (procedures)
897    (emit-procedure-table-info lambdas source-file)
898    (trailer) ) )
899
900
901;;; Emit procedure table:
902
903(define (emit-procedure-table-info lambdas sf)
904  (gen #t #t "#ifdef C_ENABLE_PTABLES"
905       #t "static C_PTABLE_ENTRY ptable[" (add1 (length lambdas)) "] = {")
906  (do ((ll lambdas (cdr ll)))
907      ((null? ll)
908       (gen #t "{NULL,NULL}};") )
909    (let ((id (lambda-literal-id (car ll))))
910      (gen #t "{\"" id #\: (string->c-identifier sf) "\",(void*)")
911      (if (eq? 'toplevel id)
912          (if unit-name
913              (gen "C_" unit-name "_toplevel},")
914              (gen "C_toplevel},") )
915          (gen id "},") ) ) )
916  (gen #t "#endif")
917  (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void)")
918  (gen "{" #t "#ifdef C_ENABLE_PTABLES"
919       #t "return ptable;"
920       #t "#else"
921       #t "return NULL;"
922       #t "#endif"
923       #t "}") )
924
925
926;;; Create name that is safe for C comments:
927
928(define (cleanup s)
929  (let ([s2 #f] 
930        [len (string-length s)] )
931    (let loop ([i 0])
932      (if (>= i len)
933          (or s2 s)
934          (let ([c (string-ref s i)])
935            (if (or (char<? c #\space)
936                    (char>? c #\~)
937                    (and (char=? c #\*) (< i (sub1 len)) (char=? #\/ (string-ref s (add1 i)))) )
938                (begin
939                  (unless s2 (set! s2 (string-copy s)))
940                  (string-set! s2 i #\~) )
941                (when s2 (string-set! s2 i c)) ) 
942            (loop (add1 i)) ) ) ) ) )
943
944
945;;; Create list of variables/parameters, interspersed with a special token:
946
947(define (make-variable-list n prefix)
948  (list-tabulate
949   n
950   (lambda (i) (string-append "C_word " prefix (number->string i))) ) )
951 
952(define (make-argument-list n prefix)
953  (list-tabulate
954   n
955   (lambda (i) (string-append prefix (number->string i))) ) )
956
957
958;;; Generate external variable declarations:
959
960(define (generate-external-variables vars)
961  (gen #t)
962  (for-each
963   (lambda (v)
964     (let ((name (vector-ref v 0))
965           (type (vector-ref v 1))
966           (exported (vector-ref v 2)) )
967       (gen #t (if exported "" "static ") (foreign-type-declaration type name) #\;) ) )
968   vars) )
969
970
971;;; Generate foreign stubs:
972
973(define (generate-foreign-callback-stub-prototypes stubs)
974  (for-each
975   (lambda (stub)
976     (gen #t)
977     (generate-foreign-callback-header "C_externexport " stub)
978     (gen #\;) )
979   stubs) )
980
981(define (generate-foreign-stubs stubs db)
982  (for-each
983   (lambda (stub)
984     (let* ([id (foreign-stub-id stub)]
985            [rname (real-name2 id db)]
986            [types (foreign-stub-argument-types stub)]
987            [n (length types)]
988            [varlist (intersperse (cons "C_word C_buf" (make-variable-list n "C_a")) #\,)]
989            [rtype (foreign-stub-return-type stub)] 
990            [sname (foreign-stub-name stub)] 
991            [body (foreign-stub-body stub)]
992            [names (or (foreign-stub-argument-names stub) (make-list n #f))]
993            [rconv (foreign-result-conversion rtype "C_a")] 
994            [cps (foreign-stub-cps stub)]
995            [callback (foreign-stub-callback stub)] )
996       (gen #t)
997       (when rname
998         (gen #t "/* from " (cleanup rname) " */") )
999       (when body
1000         (gen #t "#define return(x) C_cblock C_r = (" rconv 
1001              "(x))); goto C_ret; C_cblockend"))
1002       (if cps
1003           (gen #t "C_noret_decl(" id ")"
1004                #t "static void C_ccall " id "(C_word C_c,C_word C_self,C_word C_k,")
1005           (gen #t "static C_word C_fcall " id #\() )
1006       (apply gen varlist)
1007       (if cps
1008           (gen ") C_noret;" #t "static void C_ccall " id "(C_word C_c,C_word C_self,C_word C_k,")
1009           (gen ") C_regparm;" #t "C_regparm static C_word C_fcall " id #\() )
1010       (apply gen varlist)
1011       (gen "){")
1012       (gen #t "C_word C_r=C_SCHEME_UNDEFINED,*C_a=(C_word*)C_buf;")
1013       (for-each
1014        (lambda (type index name)
1015          (gen #t 
1016               (foreign-type-declaration 
1017                type
1018                (if name (symbol->string name) (sprintf "t~a" index)) )
1019               "=(" (foreign-type-declaration type "") #\)
1020               (foreign-argument-conversion type) "C_a" index ");") )
1021        types (iota n) names)
1022       (when callback (gen #t "int C_level=C_save_callback_continuation(&C_a,C_k);"))
1023       (cond [body
1024              (gen #t body
1025                   #t "C_ret:")
1026              (gen #t "#undef return" #t)
1027              (cond [callback
1028                     (gen #t "C_k=C_restore_callback_continuation2(C_level);"
1029                          #t "C_kontinue(C_k,C_r);") ]
1030                    [cps (gen #t "C_kontinue(C_k,C_r);")]
1031                    [else (gen #t "return C_r;")] ) ]
1032             [else
1033              (if (not (eq? rtype 'void))
1034                  (gen #t "C_r=" rconv)
1035                  (gen #t) )
1036              (gen sname #\()
1037              (apply gen (intersperse (make-argument-list n "t") #\,))
1038              (unless (eq? rtype 'void) (gen #\)))
1039              (gen ");")
1040              (cond [callback
1041                     (gen #t "C_k=C_restore_callback_continuation2(C_level);"
1042                          #t "C_kontinue(C_k,C_r);") ]
1043                    [cps (gen "C_kontinue(C_k,C_r);")]
1044                    [else (gen #t "return C_r;")] ) ] )
1045       (gen #\}) ) )
1046   stubs) )
1047
1048(define (generate-foreign-callback-stubs stubs db)
1049  (for-each
1050   (lambda (stub)
1051     (let* ([id (foreign-callback-stub-id stub)]
1052            [rname (real-name2 id db)]
1053            [rtype (foreign-callback-stub-return-type stub)]
1054            [argtypes (foreign-callback-stub-argument-types stub)]
1055            [n (length argtypes)]
1056            [vlist (make-argument-list n "t")] )
1057
1058       (define (compute-size type var ns)
1059         (case type
1060           [(char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32
1061                  byte unsigned-byte)
1062            ns]
1063           [(float double c-pointer unsigned-integer unsigned-integer32 long integer integer32 unsigned-long 
1064                   nonnull-c-pointer number integer64 c-string-list c-string-list*)
1065            (string-append ns "+3") ]
1066           [(c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)
1067            (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") ]
1068           [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)
1069            (string-append ns "+2+C_bytestowords(C_strlen(" var "))") ]
1070           [else
1071            (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type)) 
1072                   => (lambda (t)
1073                        (compute-size (if (vector? t) (vector-ref t 0) t) var ns) ) ]
1074                  [(pair? type)
1075                   (case (car type)
1076                     [(ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance 
1077                           nonnull-instance instance-ref)
1078                      (string-append ns "+3") ]
1079                     [(const) (compute-size (cadr type) var ns)]
1080                     [else ns] ) ]
1081                  [else ns] ) ] ) )
1082
1083       (let ([sizestr (fold compute-size "0" argtypes vlist)])
1084         (gen #t)
1085         (when rname
1086           (gen #t "/* from " (cleanup rname) " */") )
1087         (generate-foreign-callback-header "" stub)
1088         (gen #\{ #t "C_word x,s=" sizestr ",*a=C_alloc(s);")
1089         (gen #t "C_callback_adjust_stack(a,s);") ; make sure content is below stack_bottom as well
1090         (for-each
1091          (lambda (v t)
1092            (gen #t "x=" (foreign-result-conversion t "a") v ");"
1093                 #t "C_save(x);") )
1094          vlist 
1095          argtypes)
1096         (unless (eq? 'void rtype)
1097           (gen #t "return " (foreign-argument-conversion rtype)) )
1098         (gen "C_callback_wrapper((void *)" id #\, n #\))
1099         (unless (eq? 'void rtype) (gen #\)))
1100         (gen ";}") ) ) )
1101   stubs) )
1102
1103(define (generate-foreign-callback-header cls stub)
1104  (let* ([name (foreign-callback-stub-name stub)]
1105         [quals (foreign-callback-stub-qualifiers stub)]
1106         [rtype (foreign-callback-stub-return-type stub)]
1107         [argtypes (foreign-callback-stub-argument-types stub)]
1108         [n (length argtypes)]
1109         [vlist (make-argument-list n "t")] )
1110    (gen #t cls #\space (foreign-type-declaration rtype "") quals #\space name #\()
1111    (pair-for-each
1112     (lambda (vs ts)
1113       (gen (foreign-type-declaration (car ts) (car vs)))
1114       (when (pair? (cdr vs)) (gen #\,)) )
1115     vlist argtypes)
1116    (gen #\)) ) )
1117
1118
1119;; Create type declarations
1120
1121(define (foreign-type-declaration type target)
1122  (let ([err (lambda () (quit "illegal foreign type `~A'" type))]
1123        [str (lambda (ts) (string-append ts " " target))] )
1124    (case type
1125      [(scheme-object) (str "C_word")]
1126      [(char byte) (str "C_char")]
1127      [(unsigned-char unsigned-byte) (str "unsigned C_char")]
1128      [(unsigned-int unsigned-integer) (str "unsigned int")]
1129      [(unsigned-int32 unsigned-integer32) (str "C_u32")]
1130      [(int integer bool) (str "int")]
1131      [(int32 integer32) (str "C_s32")]
1132      [(integer64) (str "C_s64")]
1133      [(short) (str "short")]
1134      [(long) (str "long")]
1135      [(unsigned-short) (str "unsigned short")]
1136      [(unsigned-long) (str "unsigned long")]
1137      [(float) (str "float")]
1138      [(double number) (str "double")]
1139      ;; pointer and nonnull-pointer are DEPRECATED
1140      [(pointer nonnull-pointer) (str "void *")]
1141      [(c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer) (str "void *")]
1142      [(c-string-list c-string-list*) "C_char **"]
1143      ;; byte-vector and nonnull-byte-vector are DEPRECATED
1144      [(byte-vector nonnull-byte-vector) (str "unsigned char *")]
1145      [(blob nonnull-blob u8vector nonnull-u8vector) (str "unsigned char *")]
1146      [(u16vector nonnull-u16vector) (str "unsigned short *")]
1147      [(s8vector nonnull-s8vector) (str "char *")]
1148      [(u32vector nonnull-u32vector) (str "unsigned int *")]
1149      [(s16vector nonnull-s16vector) (str "short *")]
1150      [(s32vector nonnull-s32vector) (str "int *")]
1151      [(f32vector nonnull-f32vector) (str "float *")]
1152      [(f64vector nonnull-f64vector) (str "double *")]
1153      [(nonnull-c-string c-string nonnull-c-string* c-string* symbol) 
1154       (str "char *")]
1155      [(nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string unsigned-c-string*)
1156       (str "unsigned char *")]
1157      [(void) (str "void")]
1158      [else
1159       (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
1160              => (lambda (t)
1161                   (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ]
1162             [(string? type) (str type)]
1163             [(list? type)
1164              (let ((len (length type)))
1165                (cond
1166                 ((and (= 2 len)
1167                       (memq (car type) '(pointer nonnull-pointer c-pointer 
1168                                                  nonnull-c-pointer) ) )
1169                  (foreign-type-declaration (cadr type) (string-append "*" target)) )
1170                 ((and (= 2 len)
1171                       (eq? 'ref (car type)))
1172                  (foreign-type-declaration (cadr type) (string-append "&" target)) )
1173                 ((and (> len 2)
1174                       (eq? 'template (car type)))
1175                  (str
1176                   (string-append
1177                    (foreign-type-declaration (cadr type) "")
1178                    "<"
1179                    (string-intersperse
1180                     (map (cut foreign-type-declaration <> "") (cddr type))
1181                     ",")
1182                    "> ") ) )
1183                 ((and (= len 2) (eq? 'const (car type)))
1184                  (string-append "const " (foreign-type-declaration (cadr type) target)))
1185                 ((and (= len 2) (eq? 'struct (car type)))
1186                  (string-append "struct " (->string (cadr type)) " " target))
1187                 ((and (= len 2) (eq? 'union (car type)))
1188                  (string-append "union " (->string (cadr type)) " " target))
1189                 ((and (= len 2) (eq? 'enum (car type)))
1190                  (string-append "enum " (->string (cadr type)) " " target))
1191                 ((and (= len 3) (memq (car type) '(instance nonnull-instance)))
1192                  (string-append (->string (cadr type)) "*" target))
1193                 ((and (= len 3) (eq? 'instance-ref (car type)))
1194                  (string-append (->string (cadr type)) "&" target))
1195                 ((and (>= len 3) (eq? 'function (car type)))
1196                  (let ((rtype (cadr type))
1197                        (argtypes (caddr type))
1198                        (callconv (optional (cdddr type) "")))
1199                    (string-append
1200                     (foreign-type-declaration rtype "")
1201                     callconv
1202                     " (*" target ")("
1203                     (string-intersperse
1204                      (map (lambda (at)
1205                             (if (eq? '... at) 
1206                                 "..."
1207                                 (foreign-type-declaration at "") ) )
1208                           argtypes) 
1209                      ",")
1210                     ")" ) ) )
1211                 (else (err)) ) ) ]
1212             [else (err)] ) ] ) ) )
1213
1214
1215;; Generate expression to convert argument from Scheme data
1216
1217(define (foreign-argument-conversion type)
1218  (let ([err (lambda () (quit "illegal foreign argument type `~A'" type))])
1219    (case type
1220      ((scheme-object) "(")
1221      ((char unsigned-char) "C_character_code((C_word)")
1222      ((byte int unsigned-int unsigned-int32 unsigned-byte) "C_unfix(")
1223      ((short) "C_unfix(")
1224      ((unsigned-short) "(unsigned short)C_unfix(")
1225      ((unsigned-long) "C_num_to_unsigned_long(")
1226      ((double number float) "C_c_double(")
1227      ((integer integer32) "C_num_to_int(")
1228      ((integer64) "C_num_to_int64(")
1229      ((long) "C_num_to_long(")
1230      ((unsigned-integer unsigned-integer32) "C_num_to_unsigned_int(")
1231      ;; pointer and nonnull-pointer are DEPRECATED
1232      ((pointer) "C_data_pointer_or_null(")
1233      ((nonnull-pointer) "C_data_pointer(")
1234      ((scheme-pointer) "C_data_pointer_or_null(")
1235      ((nonnull-scheme-pointer) "C_data_pointer(")
1236      ((c-pointer) "C_c_pointer_or_null(")
1237      ((nonnull-c-pointer) "C_c_pointer_nn(")
1238      ((blob) "C_c_bytevector_or_null(")
1239      ((nonnull-blob) "C_c_bytevector(")
1240      ;; byte-vector and nonnull-byte-vector are DEPRECATED
1241      ((byte-vector) "C_c_bytevector_or_null(")
1242      ((nonnull-byte-vector) "C_c_bytevector(")
1243      ((u8vector) "C_c_u8vector_or_null(")
1244      ((nonnull-u8vector) "C_c_u8vector(")
1245      ((u16vector) "C_c_u16vector_or_null(")
1246      ((nonnull-u16vector) "C_c_u16vector(")
1247      ((u32vector) "C_c_u32vector_or_null(")
1248      ((nonnull-u32vector) "C_c_u32vector(")
1249      ((s8vector) "C_c_s8vector_or_null(")
1250      ((nonnull-s8vector) "C_c_s8vector(")
1251      ((s16vector) "C_c_s16vector_or_null(")
1252      ((nonnull-s16vector) "C_c_s16vector(")
1253      ((s32vector) "C_c_s32vector_or_null(")
1254      ((nonnull-s32vector) "C_c_s32vector(")
1255      ((f32vector) "C_c_f32vector_or_null(")
1256      ((nonnull-f32vector) "C_c_f32vector(")
1257      ((f64vector) "C_c_f64vector_or_null(")
1258      ((nonnull-f64vector) "C_c_f64vector(")
1259      ((c-string c-string* unsigned-c-string unsigned-c-string*) "C_string_or_null(")
1260      ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string 
1261                         nonnull-unsigned-c-string* symbol) "C_c_string(")
1262      ((bool) "C_truep(")
1263      (else
1264       (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
1265              => (lambda (t)
1266                   (foreign-argument-conversion (if (vector? t) (vector-ref t 0) t)) ) ]
1267             [(and (list? type) (>= (length type) 2))
1268              (case (car type)
1269               ;; pointer and nonnull-pointer are DEPRECATED
1270               ((pointer) "C_c_pointer_or_null(")
1271               ((nonnull-pointer) "C_c_pointer_nn(")
1272               ((c-pointer) "C_c_pointer_or_null(")
1273               ((nonnull-c-pointer) "C_c_pointer_nn(")
1274               ((instance) "C_c_pointer_or_null(")
1275               ((nonnull-instance) "C_c_pointer_nn(")
1276               ((function) "C_c_pointer_or_null(")
1277               ((const) (foreign-argument-conversion (cadr type)))
1278               ((enum) "C_num_to_int(")
1279               ((ref)
1280                (string-append "*(" (foreign-type-declaration (car type) "*")
1281                               ")C_c_pointer_nn("))
1282               ((instance-ref)
1283                (string-append "*(" (cadr type) "*)C_c_pointer_nn("))
1284               (else (err)) ) ]
1285             [else (err)] ) ) ) ) )
1286
1287
1288;; Generate suitable conversion of a result value into Scheme data
1289           
1290(define (foreign-result-conversion type dest)
1291  (let ([err (lambda () (quit "illegal foreign return type `~A'" type))])
1292    (case type
1293      ((char unsigned-char) "C_make_character((C_word)")
1294      ((int int32) "C_fix((C_word)")
1295      ((unsigned-int unsigned-int32) "C_fix(C_MOST_POSITIVE_FIXNUM&(C_word)")
1296      ((short) "C_fix((short)")
1297      ((unsigned-short) "C_fix(0xffff&(C_word)")
1298      ((byte) "C_fix((char)")
1299      ((unsigned-byte) "C_fix(0xff&(C_word)")
1300      ((float double) (sprintf "C_flonum(&~a," dest))   ;*** suboptimal for int64
1301      ((number) (sprintf "C_number(&~a," dest))
1302      ((nonnull-c-string c-string nonnull-c-pointer c-string* nonnull-c-string* 
1303                         unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string
1304                         nonnull-unsigned-c-string* symbol c-string-list c-string-list*) 
1305       (sprintf "C_mpointer(&~a,(void*)" dest) )
1306      ((c-pointer) (sprintf "C_mpointer_or_false(&~a,(void*)" dest))
1307      ((integer integer32) (sprintf "C_int_to_num(&~a," dest))
1308      ((integer64) (sprintf "C_a_double_to_num(&~a," dest))
1309      ((unsigned-integer unsigned-integer32) (sprintf "C_unsigned_int_to_num(&~a," dest))
1310      ((long) (sprintf "C_long_to_num(&~a," dest))
1311      ((unsigned-long) (sprintf "C_unsigned_long_to_num(&~a," dest))
1312      ((bool) "C_mk_bool(")
1313      ((void scheme-object) "((C_word)")
1314      (else
1315       (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
1316              => (lambda (x)
1317                   (foreign-result-conversion (if (vector? x) (vector-ref x 0) x) dest)) ]
1318             [(and (list? type) (>= (length type) 2))
1319              (case (car type)
1320                ((nonnull-pointer nonnull-c-pointer)
1321                 (sprintf "C_mpointer(&~A,(void*)" dest) )
1322                ((ref)
1323                 (sprintf "C_mpointer(&~A,(void*)&" dest) )
1324                ((instance)
1325                 (sprintf "C_mpointer_or_false(&~A,(void*)" dest) )
1326                ((nonnull-instance)
1327                 (sprintf "C_mpointer(&~A,(void*)" dest) )
1328                ((instance-ref)
1329                 (sprintf "C_mpointer(&~A,(void*)&" dest) )
1330                ((const) (foreign-result-conversion (cadr type) dest))
1331                ((pointer c-pointer)
1332                 (sprintf "C_mpointer_or_false(&~a,(void*)" dest) )
1333                ((function) (sprintf "C_mpointer(&~a,(void*)" dest))
1334                ((enum) (sprintf "C_int_to_num(&~a," dest))
1335                (else (err)) ) ]
1336             [else (err)] ) ) ) ) )
1337
1338
1339;;; Encoded literals as strings, to be decoded by "C_decode_literal()"
1340;;
1341;; - everything hardcoded, using the FFI would be the ugly, but safer method.
1342
1343(define (encode-literal lit)
1344  (define getbits
1345    (foreign-lambda* int ((scheme-object lit))
1346      "
1347#ifdef C_SIXTY_FOUR
1348return((C_header_bits(lit) >> (24 + 32)) & 0xff);
1349#else
1350return((C_header_bits(lit) >> 24) & 0xff);
1351#endif
1352") )
1353  (define getsize
1354    (foreign-lambda* int ((scheme-object lit))
1355      "return(C_header_size(lit));"))
1356  (define (encode-size n)
1357    ;; only handles sizes in the 24-bit range!
1358    (string (integer->char (bitwise-and #xff (arithmetic-shift n -16)))
1359            (integer->char (bitwise-and #xff (arithmetic-shift n -8)))
1360            (integer->char (bitwise-and #xff n))))
1361  (define (finish str)             ; can be taken out at a later stage
1362    (string-append (string #\xfe) str))
1363  (finish
1364   (cond ((eq? #t lit) "\xff\x06\x01")
1365         ((eq? #f lit) "\xff\x06\x00")
1366         ((char? lit) (string-append "\xff\x0a" (encode-size (char->integer lit))))
1367         ((null? lit) "\xff\x0e")
1368         ((eof-object? lit) "\xff\x3e")
1369         ((eq? (void) lit) "\xff\x1e")
1370         ((fixnum? lit)
1371          (if (not (big-fixnum? lit))
1372              (string-append
1373               "\xff\x01"
1374               (string (integer->char (bitwise-and #xff (arithmetic-shift lit -24)))
1375                       (integer->char (bitwise-and #xff (arithmetic-shift lit -16)))
1376                       (integer->char (bitwise-and #xff (arithmetic-shift lit -8)))
1377                       (integer->char (bitwise-and #xff lit)) ) )
1378              (string-append "\xff\x55" (number->string lit) "\x00") ) )
1379         ((number? lit)
1380          (string-append "\x55" (number->string lit) "\x00") )
1381         ((symbol? lit)
1382          (let ((str (##sys#slot lit 1)))
1383            (string-append
1384             "\x01" 
1385             (encode-size (string-length str))
1386             str) ) )
1387         ((##sys#immediate? lit)
1388          (bomb "invalid literal - cannot encode" lit))
1389         ((##core#inline "C_byteblockp" lit)
1390          (##sys#string-append ; relies on the fact that ##sys#string-append doesn't check
1391           (string-append
1392            (string (integer->char (getbits lit)))
1393            (encode-size (getsize lit)) )
1394           lit) )
1395         (else
1396          (let ((len (getsize lit)))
1397            (string-intersperse
1398             (cons*
1399              (string (integer->char (getbits lit)))
1400              (encode-size len)
1401              (list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))
1402             ""))))) )
Note: See TracBrowser for help on using the repository browser.