source: project/chicken/branches/prerelease/c-backend.scm @ 9381

Last change on this file since 9381 was 9381, checked in by Ivan Raikov, 12 years ago

Merged trunk into prerelease

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