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

Last change on this file since 13240 was 13240, checked in by felix winkelmann, 11 years ago

merged trunk svn rev. 13239 into prerelease

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