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

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

initial ptable was one too short; found thanks to valgrind

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