source: project/chicken/branches/release/c-backend.scm @ 7276

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

merged trunk

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