~ chicken-core (chicken-5) /c-backend.scm
Trap1;;; c-backend.scm - C-generating backend for the CHICKEN compiler2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; disclaimer in the documentation and/or other materials provided with the distribution.14; Neither the name of the author nor the names of its contributors may be used to endorse or promote15; products derived from this software without specific prior written permission.16;17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728(declare29 (unit c-backend)30 (uses data-structures extras c-platform compiler internal support))3132(module chicken.compiler.c-backend33 (generate-code34 ;; For "foreign" (aka chicken-ffi-syntax):35 foreign-type-declaration)3637(import scheme38 chicken.base39 chicken.bitwise40 chicken.fixnum41 chicken.flonum42 chicken.foreign43 chicken.format44 chicken.internal45 chicken.keyword46 chicken.platform47 chicken.sort48 chicken.string49 chicken.time50 chicken.compiler.core51 chicken.compiler.c-platform52 chicken.compiler.support)5354(include "mini-srfi-1.scm")5556;;; Write atoms to output-port:5758(define output #f)5960(define (gen . data)61 (for-each62 (lambda (x)63 (if (eq? #t x)64 (newline output)65 (display x output) ) )66 data) )6768(define (gen-list lst)69 (for-each70 (lambda (x) (display x output))71 (intersperse lst #\space) ) )7273;; Hacky procedures to make certain names more suitable for use in C.74(define (backslashify s) (string-translate* (->string s) '(("\\" . "\\\\"))))75(define (uncommentify s) (string-translate* (->string s) '(("*/" . "*_/"))))76(define (c-identifier s) (string->c-identifier (->string s)))7778;; Generate a sorted alist out of a symbol table79(define (table->sorted-alist t)80 (let ((alist '()))81 (hash-table-for-each82 (lambda (id ll)83 (set! alist84 (cons (cons id ll) alist)))85 t)8687 (sort! alist (lambda (p1 p2) (string<? (symbol->string (car p1))88 (symbol->string (car p2)))))))899091;;; Generate target code:9293(define (generate-code literals lliterals lambda-table out source-file user-supplied-options dynamic db dbg-info-table)94 (let ((lambda-table* (table->sorted-alist lambda-table)) ;; sort the symbol table to make the compiler output deterministic.95 (non-av-proc #f))9697 ;; Don't truncate floating-point precision!98 (flonum-print-precision (+ flonum-maximum-decimal-exponent 1))99100 ;; Some helper procedures101102 (define (find-lambda id)103 (or (hash-table-ref lambda-table id)104 (bomb "can't find lambda" id) ) )105106 ;; Compile a single expression107 (define (expression node temps ll)108109 (define (expr n i)110 (let ((subs (node-subexpressions n))111 (params (node-parameters n)) )112 (case (node-class n)113114 ((##core#immediate)115 (case (first params)116 ((bool) (gen (if (second params) "C_SCHEME_TRUE" "C_SCHEME_FALSE")))117 ((char) (gen "C_make_character(" (char->integer (second params)) #\)))118 ((nil) (gen "C_SCHEME_END_OF_LIST"))119 ((fix) (gen "C_fix(" (second params) #\)))120 ((eof) (gen "C_SCHEME_END_OF_FILE"))121 ((bwp) (gen "C_SCHEME_BROKEN_WEAK_PTR"))122 (else (bomb "bad immediate")) ) )123124 ((##core#literal)125 (let ((lit (first params)))126 (if (vector? lit)127 (gen "((C_word)li" (vector-ref lit 0) ")")128 (gen "lf[" (first params) #\])) ) )129130 ((##core#float)131 (let ((n (first params)))132 (gen "(double)")133 (cond ((nan? n) (gen "NAN"))134 ((infinite? n)135 (when (negative? n) (gen #\-))136 (gen "INFINITY"))137 (else (gen n)))))138139 ((if)140 (gen #t "if(C_truep(")141 (expr (car subs) i)142 (gen ")){")143 (expr (cadr subs) i)144 (gen #\} #t "else{")145 (expr (caddr subs) i)146 (gen #\}) )147148 ((##core#proc)149 (gen "(C_word)" (first params)) )150151 ((##core#bind)152 (let loop ((bs subs) (i i) (count (first params)))153 (cond [(> count 0)154 (gen #t #\t i #\=)155 (expr (car bs) i)156 (gen #\;)157 (loop (cdr bs) (add1 i) (sub1 count)) ]158 [else (expr (car bs) i)] ) ) )159160 ((##core#let_float)161 (let ((fi (first params)))162 (gen #t #\f fi #\=)163 (expr (first subs) i)164 (gen #\;)165 (expr (second subs) i)))166167 ((##core#float-variable)168 (gen #\f (first params)))169170 ((##core#unbox_float)171 (gen "C_flonum_magnitude(")172 (expr (first subs) i)173 (gen ")"))174175 ((##core#box_float)176 (gen "C_flonum(&a,")177 (expr (first subs) i)178 (gen ")"))179180 ((##core#ref)181 (gen "((C_word*)")182 (expr (car subs) i)183 (gen ")[" (+ (first params) 1) #\]) )184185 ((##core#rest-car)186 (let* ((n (lambda-literal-argument-count ll))187 (depth (second params))188 (have-av? (not (or (lambda-literal-customizable ll)189 (lambda-literal-direct ll)))))190 (if have-av?191 (gen "C_get_rest_arg(c," (+ depth n) ",av," n ",t0)")192 (gen "C_u_i_list_ref(t" (sub1 n) "," depth ")"))))193194 ((##core#rest-null?)195 (let* ((n (lambda-literal-argument-count ll))196 (depth (second params))197 (have-av? (not (or (lambda-literal-customizable ll)198 (lambda-literal-direct ll)))))199 (if have-av?200 (gen "C_rest_nullp(c," (+ depth n) ")")201 (gen "C_mk_bool(C_unfix(C_i_length(t" (sub1 n) ")) >= " depth ")"))))202203 ((##core#rest-length)204 (let* ((n (lambda-literal-argument-count ll))205 (depth (second params))206 (have-av? (not (or (lambda-literal-customizable ll)207 (lambda-literal-direct ll)))))208 (if have-av?209 (gen "C_fix(c - " (+ depth n) ")")210 (gen "C_u_i_length(t" (sub1 n) ")"))))211212 ((##core#unbox)213 (gen "((C_word*)")214 (expr (car subs) i)215 (gen ")[1]") )216217 ((##core#update_i)218 (gen "C_set_block_item(")219 (expr (car subs) i)220 (gen #\, (first params) #\,)221 (expr (cadr subs) i)222 (gen #\)) )223224 ((##core#update)225 (gen "C_mutate(((C_word *)")226 (expr (car subs) i)227 (gen ")+" (+ (first params) 1) ",")228 (expr (cadr subs) i)229 (gen #\)) )230231 ((##core#updatebox_i)232 (gen "C_set_block_item(")233 (expr (car subs) i)234 (gen ",0,")235 (expr (cadr subs) i)236 (gen #\)) )237238 ((##core#updatebox)239 (gen "C_mutate(((C_word *)")240 (expr (car subs) i)241 (gen ")+1,")242 (expr (cadr subs) i)243 (gen #\)) )244245 ((##core#closure)246 (let ((n (first params)))247 (gen "(*a=C_CLOSURE_TYPE|" n #\,)248 (for-each249 (lambda (x j)250 (gen "a[" j "]=")251 (expr x i)252 (gen #\,) )253 subs (list-tabulate n add1))254 (gen "tmp=(C_word)a,a+=" (add1 n) ",tmp)") ) )255256 ((##core#box)257 (gen "(*a=C_VECTOR_TYPE|1,a[1]=")258 (expr (car subs) i)259 (gen ",tmp=(C_word)a,a+=2,tmp)") )260261 ((##core#local) (gen #\t (first params)))262263 ((##core#setlocal)264 (gen #\t (first params) #\=)265 (expr (car subs) i) )266267 ((##core#global)268 (let ((index (first params))269 (safe (second params))270 (block (third params)) )271 (cond [block272 (if safe273 (gen "lf[" index "]")274 (gen "C_retrieve2(lf[" index "],C_text("275 (c-ify-string (##sys#symbol->string276 (fourth params))) "))"))]277 [safe (gen "*((C_word*)lf[" index "]+1)")]278 [else (gen "C_fast_retrieve(lf[" index "])")] ) ) )279280 ((##core#setglobal)281 (let ((index (first params))282 (block (second params))283 (var (third params)))284 (if block285 (gen "C_mutate(&lf[" index "]")286 (gen "C_mutate((C_word*)lf[" index "]+1"))287 (gen " /* (set! " (uncommentify (##sys#symbol->string var)) " ...) */,")288 (expr (car subs) i)289 (gen #\)) ) )290291 ((##core#setglobal_i)292 (let ((index (first params))293 (block (second params))294 (var (third params)) )295 (cond [block296 (gen "lf[" index "] /* "297 (uncommentify (##sys#symbol->string var)) " */ =")298 (expr (car subs) i)299 (gen #\;) ]300 [else301 (gen "C_set_block_item(lf[" index "] /* "302 (uncommentify (##sys#symbol->string var)) " */,0,")303 (expr (car subs) i)304 (gen #\)) ] ) ) )305306 ((##core#undefined) (gen "C_SCHEME_UNDEFINED"))307308 ((##core#call)309 (let* ((args (cdr subs))310 (n (length args))311 (nc i)312 (nf (add1 n))313 (dbi (first params))314 (safe-to-call (second params))315 (p2 (pair? (cddr params)))316 (name (and p2 (third params)))317 (name-str (source-info->string name))318 (call-id (and p2 (pair? (cdddr params)) (fourth params)))319 (customizable (and call-id (fifth params)))320 (empty-closure (and customizable (zero? (lambda-literal-closure-size (find-lambda call-id)))))321 (fn (car subs)) )322 (when name323 (if emit-trace-info324 (gen #t "C_trace(C_text(\"" (backslashify name-str) "\"));")325 (gen #t "/* " (uncommentify name-str) " */"))326 (when (and emit-debug-info dbi)327 (gen #t "C_debugger(&(C_debug_info[" dbi "]),"328 (if non-av-proc "0,NULL" "c,av") ");")))329 (cond ((eq? '##core#proc (node-class fn))330 (gen #\{)331 (push-args args i "0")332 (let ([fpars (node-parameters fn)])333 (gen #t (first fpars) #\( nf ",av2);}") ))334 (call-id335 (cond ((and (eq? call-id (lambda-literal-id ll))336 (lambda-literal-looping ll) )337 (let* ((temps (lambda-literal-temporaries ll))338 (ts (list-tabulate n (lambda (i) (+ temps nf i)))))339 (for-each340 (lambda (arg tr)341 (gen #t #\t tr #\=)342 (expr arg i)343 (gen #\;) )344 args ts)345 (for-each346 (lambda (from to) (gen #t #\t to "=t" from #\;))347 ts (list-tabulate n add1))348 (unless customizable (gen #t "c=" nf #\;))349 (gen #t "goto loop;") ) )350 (else351 (unless empty-closure352 (gen #t #\t nc #\=)353 (expr fn i)354 (gen #\;) )355 (cond (customizable356 (gen #t call-id #\()357 (unless empty-closure (gen #\t nc #\,))358 (expr-args args i)359 (gen ");") )360 (else361 (gen #\{)362 (push-args args i (and (not empty-closure) (string-append "t" (number->string nc))))363 (gen #t call-id #\()364 (unless customizable (gen nf #\,))365 (gen "av2);}") ) ) )))366 ((and (eq? '##core#global (node-class fn))367 (not unsafe)368 (not no-procedure-checks)369 (not safe-to-call))370 (let* ((gparams (node-parameters fn))371 (index (first gparams))372 (safe (second gparams))373 (block (third gparams))374 (carg #f))375 (gen #t "{C_proc tp=(C_proc)")376 (cond (no-global-procedure-checks377 (set! carg378 (if block379 (string-append "lf[" (number->string index) "]")380 (string-append "*((C_word*)lf[" (number->string index) "]+1)")))381 (gen "(void*)(*((C_word*)(" carg ")+1))"))382 (block383 (set! carg (string-append "lf[" (number->string index) "]"))384 (if safe385 (gen "C_fast_retrieve_proc(" carg ")")386 (gen "C_retrieve2_symbol_proc(" carg ",C_text("387 (c-ify-string (##sys#symbol->string (fourth gparams))) "))")))388 (safe389 (set! carg390 (string-append "*((C_word*)lf[" (number->string index) "]+1)"))391 (gen "C_fast_retrieve_proc(" carg ")"))392 (else393 (set! carg394 (string-append "*((C_word*)lf[" (number->string index) "]+1)"))395 (gen "C_fast_retrieve_symbol_proc(lf[" index "])") ))396 (gen #\;)397 (push-args args i carg)398 (gen #t "tp(" nf ",av2);}")))399 (else400 (gen #t #\t nc #\=)401 (expr fn i)402 (gen ";{")403 (push-args args i (string-append "t" (number->string nc)))404 (gen #t "((C_proc)")405 (if (or unsafe no-procedure-checks safe-to-call)406 (gen "(void*)(*((C_word*)t" nc "+1))")407 (gen "C_fast_retrieve_proc(t" nc ")") )408 (gen ")(" nf ",av2);}") ) ) ) )409410 ((##core#recurse)411 (let* ([n (length subs)]412 [nf (add1 n)]413 [tailcall (first params)]414 [call-id (second params)]415 [empty-closure (zero? (lambda-literal-closure-size ll))] )416 (cond (tailcall417 (let* ((temps (lambda-literal-temporaries ll))418 (ts (list-tabulate n (cut + temps nf <>))))419 (for-each420 (lambda (arg tr)421 (gen #t #\t tr #\=)422 (expr arg i)423 (gen #\;) )424 subs ts)425 (for-each426 (lambda (from to) (gen #t #\t to "=t" from #\;))427 ts (list-tabulate n add1))428 (gen #t "goto loop;") ) )429 (else430 (gen call-id #\()431 (unless empty-closure (gen "t0,"))432 (expr-args subs i)433 (gen #\)) ) ) ) )434435 ((##core#direct_call)436 (let* ((args (cdr subs))437 (n (length args))438 (nf (add1 n))439 (dbi (first params))440 ;; (safe-to-call (second params))441 (name (third params))442 (name-str (source-info->string name))443 (call-id (fourth params))444 (demand (fifth params))445 (allocating (not (zero? demand)))446 (empty-closure (zero? (lambda-literal-closure-size (find-lambda call-id))))447 (fn (car subs)) )448 (gen #\()449 (when name450 (if emit-trace-info451 (gen #t "C_trace(\"" (backslashify name-str) "\"),")452 (gen #t "/* " (uncommentify name-str) " */"))453 (when (and emit-debug-info dbi)454 (gen #t "C_debugger(&(C_debug_info[" dbi "]),"455 (if non-av-proc "0,NULL" "c,av") "),")))456 (gen #t " " call-id #\()457 (when allocating458 (gen "C_a_i(&a," demand #\))459 (when (or (not empty-closure) (pair? args)) (gen #\,)) )460 (unless empty-closure461 (expr fn i)462 (when (pair? args) (gen #\,)) )463 (when (pair? args) (expr-args args i))464 (gen #\)) ; function call465 (gen #t #\)))) ; complete expression466467 ((##core#provide)468 (gen "C_a_i_provide(&a,1,lf[" (first params) "])"))469470 ((##core#callunit)471 ;; The code generated here does not use the extra temporary needed for standard calls, so we have472 ;; one unused variable:473 (let* ((n (length subs))474 (nf (+ n 1)) )475 (gen #\{)476 (push-args subs i "C_SCHEME_UNDEFINED")477 (gen #t "C_" (toplevel (first params)) "(" nf ",av2);}")))478479 ((##core#return)480 (gen #t "return(")481 (expr (first subs) i)482 (gen ");") )483484 ((##core#inline)485 (gen (first params) #\()486 (expr-args subs i)487 (gen #\)) )488489 ((##core#debug-event)490 (gen "C_debugger(&(C_debug_info[" (first params) "]),"491 (if non-av-proc "0,NULL" "c,av") ")"))492493 ((##core#inline_allocate)494 (gen (first params) "(&a," (length subs))495 (if (pair? subs)496 (begin497 (gen #\,)498 (expr-args subs i) ) )499 (gen #\)) )500501 ((##core#inline_ref)502 (gen (foreign-result-conversion (second params) "a") (first params) #\)) )503504 ((##core#inline_update)505 (let ([t (second params)])506 (gen #\( (first params) "=(" (foreign-type-declaration t "") #\) (foreign-argument-conversion t))507 (expr (first subs) i)508 (gen "),C_SCHEME_UNDEFINED)") ) )509510 ((##core#inline_loc_ref)511 (let ([t (first params)])512 (gen (foreign-result-conversion t "a") "*((" (foreign-type-declaration t "") "*)C_data_pointer(")513 (expr (first subs) i)514 (gen ")))") ) )515516 ((##core#inline_loc_update)517 (let ([t (first params)])518 (gen "((*(" (foreign-type-declaration t "") "*)C_data_pointer(")519 (expr (first subs) i)520 (gen "))=" (foreign-argument-conversion t))521 (expr (second subs) i)522 (gen "),C_SCHEME_UNDEFINED)") ) )523524 ((##core#switch)525 (gen #t "switch(")526 (expr (first subs) i)527 (gen "){")528 (do ([j (first params) (sub1 j)]529 [ps (cdr subs) (cddr ps)] )530 ((zero? j)531 (gen #t "default:")532 (expr (car ps) i)533 (gen #\}) )534 (gen #t "case ")535 (expr (car ps) i)536 (gen #\:)537 (expr (cadr ps) i) ) )538539 ((##core#cond)540 (gen "(C_truep(")541 (expr (first subs) i)542 (gen ")?")543 (expr (second subs) i)544 (gen #\:)545 (expr (third subs) i)546 (gen #\)) )547548 (else (bomb "bad form" (node-class n))) ) ) )549550 (define (expr-args args i)551 (let loop ((xs args))552 (unless (null? xs)553 (unless (eq? xs args) (gen #\,))554 (expr (car xs) i)555 (loop (cdr xs)))))556557 (define (contains-restop? args)558 (let loop ((args args))559 (if (null? args)560 #f561 (let ((node (car args)))562 ;; Only rest-car accesses av563 (or (eq? (node-class node) '##core#rest-car)564 (contains-restop? (node-subexpressions node))565 (loop (cdr args)))))))566567 (define (push-args args i selfarg)568 (let* ((n (length args))569 (avl (+ n (if selfarg 1 0)))570 (caller-has-av? (not (or (lambda-literal-customizable ll)571 (lambda-literal-direct ll))))572 (caller-argcount (lambda-literal-argument-count ll))573 (caller-rest-mode (lambda-literal-rest-argument-mode ll)))574 ;; Try to re-use argvector from current function if it is575 ;; large enough. push-args gets used only for functions in576 ;; CPS context, so callee never returns to current function.577 ;; And even so, av[] is already copied into temporaries.578 (cond579 ((or (not caller-has-av?) ; Argvec missing or580 (and (< caller-argcount avl) ; known to be too small?581 (eq? caller-rest-mode 'none))582 (contains-restop? args)) ; Restops work on original av583 (gen #t "C_word av2[" avl "];"))584 ((>= caller-argcount avl) ; Argvec known to be re-usable?585 (gen #t "C_word *av2=av;")) ; Re-use our own argvector586 (else ; Need to determine dynamically. This is slower.587 (gen #t "C_word *av2;")588 (gen #t "if(c >= " avl ") {")589 (gen #t " av2=av;") ; Re-use our own argvector590 (gen #t "} else {")591 (gen #t " av2=C_alloc(" avl ");")592 (gen #t "}")))593 (when selfarg (gen #t "av2[0]=" selfarg ";"))594 (do ((j (if selfarg 1 0) (add1 j))595 (args args (cdr args)))596 ((null? args))597 (gen #t "av2[" j "]=")598 (expr (car args) i)599 (gen ";"))))600601 (expr node temps) )602603 (define (header)604 (gen "/* Generated from " source-file " by the CHICKEN compiler" #t605 " http://www.call-cc.org" #t606 (string-intersperse607 (map (cut string-append " " <> "\n")608 (string-split (chicken-version #t) "\n") )609 "")610 " command line: ")611 (gen-list user-supplied-options)612 (unless (not unit-name)613 (gen #t " unit: " unit-name))614 (unless (null? used-units)615 (gen #t " uses: ")616 (gen-list used-units))617 (gen #t "*/")618 (gen #t "#include \"" target-include-file "\"")619 (when external-protos-first620 (generate-foreign-callback-stub-prototypes foreign-callback-stubs) )621 (when (pair? foreign-declarations)622 (gen #t)623 (for-each (lambda (decl) (gen #t decl)) foreign-declarations) )624 (unless external-protos-first625 (generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) )626627 (define (trailer)628 (gen #t #t "/*" #t629 (uncommentify630 (get-output-string631 collected-debugging-output))632 "*/"633 #t "/* end of file */" #t))634635 (define (declarations)636 (let ((n (length literals)))637 (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void);")638 (for-each639 (lambda (uu)640 (gen #t "C_noret_decl(C_" uu ")"641 #t "C_externimport void C_ccall C_" uu "(C_word c,C_word *av) C_noret;"))642 (map toplevel used-units))643 (unless (zero? n)644 (gen #t #t "static C_TLS C_word lf[" n "];") )645 (gen #t "static double C_possibly_force_alignment;")646 (do ((i 0 (add1 i))647 (llits lliterals (cdr llits)))648 ((null? llits))649 (let* ((ll (##sys#lambda-info->string (car llits)))650 (llen (string-length ll)))651 (gen #t "static C_char C_TLS li" i "[] C_aligned={C_lihdr("652 (arithmetic-shift llen -16) #\,653 (bitwise-and #xff (arithmetic-shift llen -8)) #\,654 (bitwise-and #xff llen)655 #\))656 (do ((n 0 (add1 n)))657 ((>= n llen))658 (gen #\, (char->integer (string-ref ll n))) )659 (do ((n (- (bitwise-and #xfffff8 (+ llen 7)) llen) (sub1 n))) ; fill up with zeros to align following entry660 ((zero? n))661 (gen ",0") )662 (gen "};")))))663664 (define (prototypes)665 (gen #t)666 (for-each667 (lambda (p)668 (let* ((id (car p))669 (ll (cdr p))670 (n (lambda-literal-argument-count ll))671 (customizable (lambda-literal-customizable ll))672 (empty-closure (and customizable (zero? (lambda-literal-closure-size ll))))673 (varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,))674 (direct (lambda-literal-direct ll))675 (allocated (lambda-literal-allocated ll)) )676 (gen #t)677 (cond ((not (eq? 'toplevel id))678 (gen "C_noret_decl(" id ")" #t)679 (gen "static ")680 (gen (if direct "C_word " "void "))681 (if customizable682 (gen "C_fcall ")683 (gen "C_ccall ") )684 (gen id) )685 (else686 (let ((uname (toplevel unit-name)))687 (gen "C_noret_decl(C_" uname ")" #t) ;XXX what's this for?688 (gen "C_externexport void C_ccall ")689 (gen "C_" uname) ) ) )690 (gen #\()691 (unless customizable (gen "C_word c,"))692 (when (and direct (not (zero? allocated)))693 (gen "C_word *a")694 (when (pair? varlist) (gen #\,)) )695 (if (or customizable direct)696 (apply gen varlist)697 (gen "C_word *av"))698 (gen #\))699 (unless direct (gen " C_noret"))700 (gen #\;) ))701 lambda-table*) )702703 (define (trampolines)704 (let ([ns '()]705 [nsr '()]706 [nsrv '()] )707708 (define (restore n)709 (do ((i 0 (add1 i))710 (j (sub1 n) (sub1 j)))711 ((>= i n))712 (gen #t "C_word t" i "=av[" j "];")))713714 (for-each715 (lambda (p)716 (let* ([id (car p)]717 [ll (cdr p)]718 [argc (lambda-literal-argument-count ll)]719 [customizable (lambda-literal-customizable ll)]720 [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )721 (when empty-closure (set! argc (sub1 argc)))722 (when (and (not (lambda-literal-direct ll)) customizable)723 (gen #t #t "C_noret_decl(tr" id ")"724 #t "static void C_ccall tr" id "(C_word c,C_word *av) C_noret;")725 (gen #t "static void C_ccall tr" id "(C_word c,C_word *av){")726 (restore argc)727 (gen #t id #\()728 (let ([al (make-argument-list argc "t")])729 (apply gen (intersperse al #\,)) )730 (gen ");}") )))731 lambda-table*)))732733 (define (literal-frame)734 (do ([i 0 (add1 i)]735 [lits literals (cdr lits)] )736 ((null? lits))737 (gen-lit (car lits) (sprintf "lf[~s]" i)) ) )738739 (define (bad-literal lit)740 (bomb "type of literal not supported" lit) )741742 (define (literal-size lit)743 (cond ((immediate? lit) 0)744 ((big-fixnum? lit) 2) ; immediate if fixnum, bignum see below745 ((string? lit) 0) ; statically allocated746 ((bignum? lit) 2) ; internal vector statically allocated747 ((flonum? lit) words-per-flonum)748 ((symbol? lit) 7) ; size of symbol, and possibly a bucket749 ((keyword? lit) 7) ; size of keyword (symbol), and possibly a bucket750 ((pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit))))751 ((vector? lit)752 (+ 1 (vector-length lit)753 (foldl + 0 (map literal-size (vector->list lit)))))754 ((block-variable-literal? lit) 0) ; excluded from generated code755 ((##sys#immediate? lit) (bad-literal lit))756 ((##core#inline "C_lambdainfop" lit) 0) ; statically allocated757 ((##sys#bytevector? lit) (+ 2 (bytes->words (##sys#size lit))) ) ; drops "permanent" property!758 ((##sys#generic-structure? lit)759 (let ([n (##sys#size lit)])760 (let loop ([i 0] [s (+ 2 n)])761 (if (>= i n)762 s763 (loop (add1 i) (+ s (literal-size (##sys#slot lit i)))) ) ) ) )764 ;; We could access rat/cplx slots directly, but let's not.765 ((ratnum? lit) (+ (##sys#size lit)766 (literal-size (numerator lit))767 (literal-size (denominator lit))))768 ((cplxnum? lit) (+ (##sys#size lit)769 (literal-size (real-part lit))770 (literal-size (imag-part lit))))771 (else (bad-literal lit))) )772773 (define (gen-lit lit to)774 ;; we do simple immediate literals directly to avoid a function call:775 (cond ((and (fixnum? lit) (not (big-fixnum? lit)))776 (gen #t to "=C_fix(" lit ");") )777 ((block-variable-literal? lit))778 ((eq? lit (void))779 (gen #t to "=C_SCHEME_UNDEFINED;") )780 ((boolean? lit)781 (gen #t to #\= (if lit "C_SCHEME_TRUE" "C_SCHEME_FALSE") #\;) )782 ((char? lit)783 (gen #t to "=C_make_character(" (char->integer lit) ");") )784 ((or (keyword? lit) (symbol? lit)) ; handled slightly specially (see C_h_intern_in)785 (let* ((str (##sys#slot lit 1))786 (cstr (c-ify-string str))787 (len (##sys#size str))788 (intern (if (keyword? lit)789 "C_h_intern_kw"790 "C_h_intern")))791 (gen #t to "=")792 (gen intern "(&" to #\, len ", C_text(" cstr "));")))793 ((null? lit)794 (gen #t to "=C_SCHEME_END_OF_LIST;") )795 ((and (not (##sys#immediate? lit)) ; nop796 (##core#inline "C_lambdainfop" lit)))797 ((or (fixnum? lit) (not (##sys#immediate? lit)))798 (gen #t to "=C_decode_literal(C_heaptop,C_text(")799 (gen-string-constant (encode-literal lit))800 (gen "));"))801 (else (bad-literal lit))))802803 (define (gen-string-constant str)804 (let* ([len (##sys#size str)]805 [ns (fx/ len 80)]806 [srest (modulo len 80)] )807 (do ([i ns (sub1 i)]808 [offset 0 (+ offset 80)] )809 ((zero? i)810 (when (or (zero? len) (not (zero? srest)))811 (gen (c-ify-string (string-like-substring str offset len))) ) )812 (gen (c-ify-string (string-like-substring str offset (+ offset 80))) #t) ) ) )813814 (define (string-like-substring s start end)815 (let* ([len (- end start)]816 [s2 (make-string len)] )817 (##sys#copy-bytes s s2 start 0 len)818 s2) )819820 (define (procedures)821 (for-each822 (lambda (p)823 (let* ((id (car p))824 (ll (cdr p))825 (n (lambda-literal-argument-count ll))826 (rname (real-name id db))827 (demand (lambda-literal-allocated ll))828 (max-av (apply max 0 (lambda-literal-callee-signatures ll)))829 (rest (lambda-literal-rest-argument ll))830 (customizable (lambda-literal-customizable ll))831 (empty-closure (and customizable (zero? (lambda-literal-closure-size ll))))832 (nec (- n (if empty-closure 1 0)))833 (vlist0 (make-variable-list n "t"))834 (alist0 (make-argument-list n "t"))835 (varlist (intersperse (if empty-closure (cdr vlist0) vlist0) #\,))836 (arglist (intersperse (if empty-closure (cdr alist0) alist0) #\,))837 (external (lambda-literal-external ll))838 (looping (lambda-literal-looping ll))839 (direct (lambda-literal-direct ll))840 (rest-mode (lambda-literal-rest-argument-mode ll))841 (temps (lambda-literal-temporaries ll))842 (ftemps (lambda-literal-float-temporaries ll))843 (topname (toplevel unit-name)))844 (when empty-closure (debugging 'o "dropping unused closure argument" id))845 (gen #t #t)846 (gen "/* " (cleanup rname) " */" #t)847 (cond [(not (eq? 'toplevel id))848 (gen "static ")849 (gen (if direct "C_word " "void "))850 (if customizable851 (gen "C_fcall ")852 (gen "C_ccall ") )853 (gen id) ]854 [else855 (gen "static C_TLS int toplevel_initialized=0;")856 (unless unit-name857 (gen #t "C_main_entry_point") )858 (gen #t #t "void C_ccall C_" topname) ] )859 (gen #\()860 (unless customizable (gen "C_word c,"))861 (when (and direct (not (zero? demand)))862 (gen "C_word *a")863 (when (pair? varlist) (gen #\,)) )864 (if (or customizable direct)865 (apply gen varlist)866 (gen "C_word *av"))867 (gen "){")868 (when (eq? rest-mode 'none) (set! rest #f))869 (gen #t "C_word tmp;")870 (unless (or customizable direct)871 (do ((i 0 (add1 i)))872 ((>= i n))873 (gen #t "C_word t" i "=av[" i "];")))874 (if rest875 (gen #t "C_word t" n #\;) ; To hold rest-list if demand is met876 (begin877 (do ([i n (add1 i)]878 [j (+ temps (if looping (sub1 n) 0)) (sub1 j)] )879 ((zero? j))880 (gen #t "C_word t" i #\;))881 (for-each882 (lambda (i)883 (gen #t "double f" i #\;))884 ftemps)))885 (cond ((eq? 'toplevel id)886 (let ([ldemand (foldl (lambda (n lit) (+ n (literal-size lit))) 0 literals)]887 [llen (length literals)] )888 (gen #t "C_word *a;"889 #t "if(toplevel_initialized) {C_kontinue(t1,C_SCHEME_UNDEFINED);}"890 #t "else C_toplevel_entry(C_text(\"" (or unit-name topname) "\"));")891 (when emit-debug-info892 (gen #t "C_register_debug_info(C_debug_info);"))893 (when disable-stack-overflow-checking894 (gen #t "C_disable_overflow_check=1;") )895 (unless unit-name896 (when target-heap-size897 (gen #t "C_set_or_change_heap_size(" target-heap-size ",1);"898 #t "C_heap_size_is_fixed=1;"))899 (when target-stack-size900 (gen #t "C_resize_stack(" target-stack-size ");") ) )901 (gen #t "C_check_nursery_minimum(C_calculate_demand(" demand ",c," max-av "));"902 #t "if(C_unlikely(!C_demand(C_calculate_demand(" demand ",c," max-av ")))){"903 #t "C_save_and_reclaim((void*)C_" topname ",c,av);}"904 #t "toplevel_initialized=1;"905 #t "if(C_unlikely(!C_demand_2(" ldemand "))){"906 #t "C_save(t1);"907 #t "C_rereclaim2(" ldemand "*sizeof(C_word),1);"908 #t "t1=C_restore;}"909 #t "a=C_alloc(" demand ");")910 (when (not (zero? llen))911 (gen #t "C_initialize_lf(lf," llen ");")912 (literal-frame)913 (gen #t "C_register_lf2(lf," llen ",create_ptable());"))914 (gen #\{)))915 (rest916 (gen #t "C_word *a;")917 (when (and (not unsafe) (not no-argc-checks) (> n 2) (not empty-closure))918 (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);") )919 (when insert-timer-checks (gen #t "C_check_for_interrupt;"))920 (gen #t "if(C_unlikely(!C_demand(C_calculate_demand((c-" n ")*C_SIZEOF_PAIR +" demand ",c," max-av ")))){"))921 (else922 (unless direct (gen #t "C_word *a;"))923 (when (and direct (not unsafe) (not disable-stack-overflow-checking))924 (gen #t "C_stack_overflow_check;"))925 (when looping (gen #t "loop:"))926 (when (and external (not unsafe) (not no-argc-checks) (not customizable))927 ;; (not customizable) implies empty-closure928 (if (eq? rest-mode 'none)929 (when (> n 2) (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);"))930 (gen #t "if(c!=" n ") C_bad_argc_2(c," n ",t0);") ) )931 (cond ((not direct)932 ;; The interrupt handler may fill the stack, so we only933 ;; check for an interrupt when the procedure is restartable934 (when insert-timer-checks (gen #t "C_check_for_interrupt;"))935 (gen #t "if(C_unlikely(!C_demand(C_calculate_demand("936 demand937 (if customizable ",0," ",c,")938 max-av ")))){"))939 (else940 (gen #\{)))))941 (cond ((and (not (eq? 'toplevel id)) (not direct))942 (when (and looping (not customizable))943 ;; Loop will update t_n copy of av[n]; refresh av.944 (do ((i 0 (add1 i)))945 ((>= i n))946 (gen #t "av[" i "]=t" i ";")))947 (cond (rest948 (gen #t "C_save_and_reclaim((void*)" id ",c,av);}"949 #t "a=C_alloc((c-" n ")*C_SIZEOF_PAIR+" demand ");")950 (gen #t "t" n "=C_build_rest(&a,c," n ",av);")951 (do ((i (+ n 1) (+ i 1))952 (j temps (- j 1)))953 ((zero? j))954 (gen #t "C_word t" i #\;)))955 (else956 (cond ((and customizable (> nec 0))957 (gen #t "C_save_and_reclaim_args((void *)tr" id #\, nec #\,)958 (apply gen arglist)959 (gen ");}"))960 (else961 (gen #t "C_save_and_reclaim((void *)" id ",c,av);}")))962 (when (> demand 0)963 (gen #t "a=C_alloc(" demand ");")))))964 (else (gen #\})))965 (set! non-av-proc customizable)966 (expression967 (lambda-literal-body ll)968 (if rest969 (add1 n) ; One temporary is needed to hold the rest-list970 n)971 ll)972 (gen #\}) ) )973 lambda-table*) )974975 (debugging 'p "code generation phase...")976 (set! output out)977 (header)978 (declarations)979 (generate-external-variables external-variables)980 (generate-foreign-stubs foreign-lambda-stubs db)981 (prototypes)982 (generate-foreign-callback-stubs foreign-callback-stubs db)983 (trampolines)984 (when emit-debug-info985 (emit-debug-table dbg-info-table))986 (procedures)987 (emit-procedure-table lambda-table* source-file)988 (trailer) ) )989990991;;; Emit global tables for debug-info992993(define (emit-debug-table dbg-info-table)994 (gen #t #t "static C_DEBUG_INFO C_debug_info[]={")995 (for-each996 (lambda (info)997 (gen #t "{" (second info) ",0,")998 (for-each999 (lambda (x)1000 (if (not x)1001 (gen "NULL,")1002 (gen "C_text(\"" (backslashify (->string x)) "\"),")))1003 (cddr info))1004 (gen "},"))1005 (sort dbg-info-table (lambda (i1 i2) (< (car i1) (car i2)))))1006 (gen #t "{0,0,NULL,NULL}};\n"))100710081009;;; Emit procedure table:10101011(define (emit-procedure-table lambda-table* sf)1012 (gen #t #t "#ifdef C_ENABLE_PTABLES"1013 #t "static C_PTABLE_ENTRY ptable[" (add1 (length lambda-table*)) "] = {")1014 (for-each1015 (lambda (p)1016 (let ((id (car p))1017 (ll (cdr p)))1018 (gen #t "{C_text(\"" id #\: (string->c-identifier sf) "\"),(void*)")1019 (if (eq? 'toplevel id)1020 (gen "C_" (toplevel unit-name) "},")1021 (gen id "},") ) ) )1022 lambda-table*)1023 (gen #t "{NULL,NULL}};")1024 (gen #t "#endif")1025 (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void)")1026 (gen "{" #t "#ifdef C_ENABLE_PTABLES"1027 #t "return ptable;"1028 #t "#else"1029 #t "return NULL;"1030 #t "#endif"1031 #t "}") )103210331034;;; Generate top-level procedure name:10351036(define (toplevel name)1037 (if (not name)1038 "toplevel"1039 (string-append (c-identifier name) "_toplevel")))104010411042;;; Create name that is safe for C comments:10431044(define (cleanup s)1045 (let ([s2 #f]1046 [len (string-length s)] )1047 (let loop ([i 0])1048 (if (>= i len)1049 (or s2 s)1050 (let ([c (string-ref s i)])1051 (if (or (char<? c #\space)1052 (char>? c #\~)1053 (and (char=? c #\*) (< i (sub1 len)) (char=? #\/ (string-ref s (add1 i)))) )1054 (begin1055 (unless s2 (set! s2 (string-copy s)))1056 (string-set! s2 i #\~) )1057 (when s2 (string-set! s2 i c)) )1058 (loop (add1 i)) ) ) ) ) )105910601061;;; Create list of variables/parameters, interspersed with a special token:10621063(define (make-variable-list n prefix)1064 (list-tabulate1065 n1066 (lambda (i) (string-append "C_word " prefix (number->string i))) ) )10671068(define (make-argument-list n prefix)1069 (list-tabulate1070 n1071 (lambda (i) (string-append prefix (number->string i))) ) )107210731074;;; Generate external variable declarations:10751076(define (generate-external-variables vars)1077 (gen #t)1078 (for-each1079 (lambda (v)1080 (let ((name (vector-ref v 0))1081 (type (vector-ref v 1))1082 (exported (vector-ref v 2)) )1083 (gen #t (if exported "" "static ") (foreign-type-declaration type name) #\;) ) )1084 vars) )108510861087;;; Generate foreign stubs:10881089(define (generate-foreign-callback-stub-prototypes stubs)1090 (for-each1091 (lambda (stub)1092 (gen #t)1093 (generate-foreign-callback-header "C_externexport " stub)1094 (gen #\;) )1095 stubs) )10961097(define (generate-foreign-stubs stubs db)1098 (for-each1099 (lambda (stub)1100 (let* ([id (foreign-stub-id stub)]1101 [rname (real-name2 id db)]1102 [types (foreign-stub-argument-types stub)]1103 [n (length types)]1104 [rtype (foreign-stub-return-type stub)]1105 [sname (foreign-stub-name stub)]1106 [body (foreign-stub-body stub)]1107 [names (or (foreign-stub-argument-names stub) (make-list n #f))]1108 [rconv (foreign-result-conversion rtype "C_a")]1109 [cps (foreign-stub-cps stub)]1110 [callback (foreign-stub-callback stub)] )1111 (gen #t)1112 (when rname1113 (gen #t "/* from " (cleanup rname) " */") )1114 (when body1115 (gen #t "#define return(x) C_cblock C_r = (" rconv1116 "(x))); goto C_ret; C_cblockend"))1117 (cond (cps1118 (gen #t "C_noret_decl(" id ")"1119 #t "static void C_ccall " id "(C_word C_c,C_word *C_av){"1120 #t "C_word C_k=C_av[1],C_buf=C_av[2];")1121 (do ((i 0 (add1 i)))1122 ((>= i n))1123 (gen #t "C_word C_a" i "=C_av[" (+ i 3) "];")))1124 (else1125 (gen #t "C_regparm static C_word C_fcall " id #\()1126 (apply gen (intersperse (cons "C_word C_buf" (make-variable-list n "C_a")) #\,))1127 (gen "){")))1128 (gen #t "C_word C_r=C_SCHEME_UNDEFINED,*C_a=(C_word*)C_buf;")1129 (for-each1130 (lambda (type index name)1131 (gen #t1132 (foreign-type-declaration1133 type1134 (if name (symbol->string name) (sprintf "t~a" index)) )1135 "=(" (foreign-type-declaration type "") #\)1136 (foreign-argument-conversion type) "C_a" index ");") )1137 types (iota n) names)1138 (when callback (gen #t "int C_level=C_save_callback_continuation(&C_a,C_k);"))1139 (cond [body1140 (gen #t body1141 #t "C_ret:")1142 (gen #t "#undef return" #t)1143 (cond [callback1144 (gen #t "C_k=C_restore_callback_continuation2(C_level);"1145 #t "C_kontinue(C_k,C_r);") ]1146 [cps (gen #t "C_kontinue(C_k,C_r);")]1147 [else (gen #t "return C_r;")] ) ]1148 [else1149 (if (not (eq? rtype 'void))1150 (gen #t "C_r=" rconv)1151 (gen #t) )1152 (gen sname #\()1153 (apply gen (intersperse (make-argument-list n "t") #\,))1154 (unless (eq? rtype 'void) (gen #\)))1155 (gen ");")1156 (cond [callback1157 (gen #t "C_k=C_restore_callback_continuation2(C_level);"1158 #t "C_kontinue(C_k,C_r);") ]1159 [cps (gen "C_kontinue(C_k,C_r);")]1160 [else (gen #t "return C_r;")] ) ] )1161 (gen #\}) ) )1162 stubs) )11631164(define (generate-foreign-callback-stubs stubs db)1165 (for-each1166 (lambda (stub)1167 (let* ((id (foreign-callback-stub-id stub))1168 (rname (real-name2 id db))1169 (rtype (foreign-callback-stub-return-type stub))1170 (argtypes (foreign-callback-stub-argument-types stub))1171 (n (length argtypes))1172 (vlist (make-argument-list n "t")) )11731174 (define (compute-size type var ns)1175 (case type1176 ((char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int321177 byte unsigned-byte)1178 ns)1179 ((float double c-pointer nonnull-c-pointer1180 c-string-list c-string-list*)1181 (string-append ns "+3") )1182 ((unsigned-integer unsigned-integer32 long integer integer321183 unsigned-long number)1184 (string-append ns "+C_SIZEOF_FIX_BIGNUM"))1185 ((unsigned-integer64 integer64 size_t ssize_t)1186 ;; On 32-bit systems, needs 2 digits1187 (string-append ns "+C_SIZEOF_BIGNUM(2)"))1188 ((c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)1189 (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") )1190 ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)1191 (string-append ns "+2+C_bytestowords(C_strlen(" var "))") )1192 (else1193 (cond ((and (symbol? type) (lookup-foreign-type type))1194 => (lambda (t) (compute-size (vector-ref t 0) var ns) ) )1195 ((pair? type)1196 (case (car type)1197 ((ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance1198 nonnull-instance instance-ref)1199 (string-append ns "+3") )1200 ((const) (compute-size (cadr type) var ns))1201 (else ns) ) )1202 (else ns) ) ) ) )12031204 (let ((sizestr (let loop ((types argtypes) (vars vlist) (ns "0"))1205 (if (null? types)1206 ns1207 (loop (cdr types) (cdr vars)1208 (compute-size (car types) (car vars) ns))))))1209 (gen #t)1210 (when rname1211 (gen #t "/* from " (cleanup rname) " */") )1212 (generate-foreign-callback-header "" stub)1213 (gen #\{ #t "C_word x,s=" sizestr ",*a="1214 (if (string=? "0" sizestr) "C_stack_pointer;" "C_alloc(s);"))1215 (gen #t "C_callback_adjust_stack(a,s);") ; make sure content is below stack_bottom as well1216 (for-each1217 (lambda (v t)1218 (gen #t "x=" (foreign-result-conversion t "a") v ");"1219 #t "C_save(x);") )1220 (reverse vlist)1221 (reverse argtypes))1222 (unless (eq? 'void rtype)1223 (gen #t "return " (foreign-argument-conversion rtype)) )1224 (gen "C_callback_wrapper((void *)" id #\, n #\))1225 (unless (eq? 'void rtype) (gen #\)))1226 (gen ";}") ) ) )1227 stubs) )12281229(define (generate-foreign-callback-header cls stub)1230 (let* ((name (foreign-callback-stub-name stub))1231 (quals (foreign-callback-stub-qualifiers stub))1232 (rtype (foreign-callback-stub-return-type stub))1233 (argtypes (foreign-callback-stub-argument-types stub))1234 (n (length argtypes))1235 (vlist (make-argument-list n "t")) )1236 (gen #t cls #\space (foreign-type-declaration rtype "") quals #\space name #\()1237 (let loop ((vs vlist) (ts argtypes))1238 (unless (null? vs)1239 (gen (foreign-type-declaration (car ts) (car vs)))1240 (when (pair? (cdr vs)) (gen #\,))1241 (loop (cdr vs) (cdr ts))))1242 (gen #\)) ) )124312441245;; Create type declarations12461247(define (foreign-type-declaration type target)1248 (let ((err (lambda () (quit-compiling "illegal foreign type `~A'" type)))1249 (str (lambda (ts) (string-append ts " " target))) )1250 (case type1251 ((scheme-object) (str "C_word"))1252 ((char byte) (str "C_char"))1253 ((unsigned-char unsigned-byte) (str "unsigned C_char"))1254 ((unsigned-int unsigned-integer) (str "unsigned int"))1255 ((unsigned-int32 unsigned-integer32) (str "C_u32"))1256 ((int integer bool) (str "int"))1257 ((size_t) (str "size_t"))1258 ((ssize_t) (str "ssize_t"))1259 ((int32 integer32) (str "C_s32"))1260 ((integer64) (str "C_s64"))1261 ((unsigned-integer64) (str "C_u64"))1262 ((short) (str "short"))1263 ((long) (str "long"))1264 ((unsigned-short) (str "unsigned short"))1265 ((unsigned-long) (str "unsigned long"))1266 ((float) (str "float"))1267 ((double number) (str "double"))1268 ((c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer) (str "void *"))1269 ((c-string-list c-string-list*) "C_char **")1270 ((blob nonnull-blob u8vector nonnull-u8vector) (str "unsigned char *"))1271 ((u16vector nonnull-u16vector) (str "unsigned short *"))1272 ((s8vector nonnull-s8vector) (str "signed char *"))1273 ((u32vector nonnull-u32vector) (str "unsigned int *")) ;; C_u32?1274 ((u64vector nonnull-u64vector) (str "C_u64 *"))1275 ((s16vector nonnull-s16vector) (str "short *"))1276 ((s32vector nonnull-s32vector) (str "int *")) ;; C_s32?1277 ((s64vector nonnull-s64vector) (str "C_s64 *"))1278 ((f32vector nonnull-f32vector) (str "float *"))1279 ((f64vector nonnull-f64vector) (str "double *"))1280 ((pointer-vector nonnull-pointer-vector) (str "void **"))1281 ((nonnull-c-string c-string nonnull-c-string* c-string* symbol)1282 (str "char *"))1283 ((nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string unsigned-c-string*)1284 (str "unsigned char *"))1285 ((void) (str "void"))1286 (else1287 (cond ((and (symbol? type) (lookup-foreign-type type))1288 => (lambda (t)1289 (foreign-type-declaration (vector-ref t 0) target)) )1290 ((string? type) (str type))1291 ((list? type)1292 (let ((len (length type)))1293 (cond1294 ((and (= 2 len)1295 (memq (car type) '(pointer nonnull-pointer c-pointer1296 scheme-pointer nonnull-scheme-pointer1297 nonnull-c-pointer) ) )1298 (foreign-type-declaration (cadr type) (string-append "*" target)) )1299 ((and (= 2 len)1300 (eq? 'ref (car type)))1301 (foreign-type-declaration (cadr type) (string-append "&" target)) )1302 ((and (> len 2)1303 (eq? 'template (car type)))1304 (str1305 (string-append1306 (foreign-type-declaration (cadr type) "")1307 "<"1308 (string-intersperse1309 (map (cut foreign-type-declaration <> "") (cddr type))1310 ",")1311 "> ") ) )1312 ((and (= len 2) (eq? 'const (car type)))1313 (string-append "const " (foreign-type-declaration (cadr type) target)))1314 ((and (= len 2) (eq? 'struct (car type)))1315 (string-append "struct " (->string (cadr type)) " " target))1316 ((and (= len 2) (eq? 'union (car type)))1317 (string-append "union " (->string (cadr type)) " " target))1318 ((and (= len 2) (eq? 'enum (car type)))1319 (string-append "enum " (->string (cadr type)) " " target))1320 ((and (= len 3) (memq (car type) '(instance nonnull-instance)))1321 (string-append (->string (cadr type)) "*" target))1322 ((and (= len 3) (eq? 'instance-ref (car type)))1323 (string-append (->string (cadr type)) "&" target))1324 ((and (>= len 3) (eq? 'function (car type)))1325 (let ((rtype (cadr type))1326 (argtypes (caddr type))1327 (callconv (optional (cdddr type) "")))1328 (string-append1329 (foreign-type-declaration rtype "")1330 callconv1331 " (*" target ")("1332 (string-intersperse1333 (map (lambda (at)1334 (if (eq? '... at)1335 "..."1336 (foreign-type-declaration at "") ) )1337 argtypes)1338 ",")1339 ")" ) ) )1340 (else (err)) ) ) )1341 (else (err)) ) ) ) ) )134213431344;; Generate expression to convert argument from Scheme data13451346(define (foreign-argument-conversion type)1347 (let ((err (lambda ()1348 (quit-compiling "illegal foreign argument type `~A'" type))))1349 (case type1350 ((scheme-object) "(")1351 ((char unsigned-char) "C_character_code((C_word)")1352 ((byte int int32 unsigned-int unsigned-int32 unsigned-byte) "C_unfix(")1353 ((short) "C_unfix(")1354 ((unsigned-short) "(unsigned short)C_unfix(")1355 ((unsigned-long) "C_num_to_unsigned_long(")1356 ((double number float) "C_c_double(")1357 ((integer integer32) "C_num_to_int(")1358 ((integer64) "C_num_to_int64(")1359 ((size_t) "(size_t)C_num_to_uint64(")1360 ((ssize_t) "(ssize_t)C_num_to_int64(")1361 ((unsigned-integer64) "C_num_to_uint64(")1362 ((long) "C_num_to_long(")1363 ((unsigned-integer unsigned-integer32) "C_num_to_unsigned_int(")1364 ((scheme-pointer) "C_data_pointer_or_null(")1365 ((nonnull-scheme-pointer) "C_data_pointer(")1366 ((c-pointer) "C_c_pointer_or_null(")1367 ((nonnull-c-pointer) "C_c_pointer_nn(")1368 ((blob) "C_c_bytevector_or_null(")1369 ((nonnull-blob) "C_c_bytevector(")1370 ((u8vector) "C_c_u8vector_or_null(")1371 ((nonnull-u8vector) "C_c_u8vector(")1372 ((u16vector) "C_c_u16vector_or_null(")1373 ((nonnull-u16vector) "C_c_u16vector(")1374 ((u32vector) "C_c_u32vector_or_null(")1375 ((nonnull-u32vector) "C_c_u32vector(")1376 ((u64vector) "C_c_u64vector_or_null(")1377 ((nonnull-u64vector) "C_c_u64vector(")1378 ((s8vector) "C_c_s8vector_or_null(")1379 ((nonnull-s8vector) "C_c_s8vector(")1380 ((s16vector) "C_c_s16vector_or_null(")1381 ((nonnull-s16vector) "C_c_s16vector(")1382 ((s32vector) "C_c_s32vector_or_null(")1383 ((nonnull-s32vector) "C_c_s32vector(")1384 ((s64vector) "C_c_s64vector_or_null(")1385 ((nonnull-s64vector) "C_c_s64vector(")1386 ((f32vector) "C_c_f32vector_or_null(")1387 ((nonnull-f32vector) "C_c_f32vector(")1388 ((f64vector) "C_c_f64vector_or_null(")1389 ((nonnull-f64vector) "C_c_f64vector(")1390 ((pointer-vector) "C_c_pointer_vector_or_null(")1391 ((nonnull-pointer-vector) "C_c_pointer_vector(")1392 ((c-string c-string* unsigned-c-string unsigned-c-string*) "C_string_or_null(")1393 ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string1394 nonnull-unsigned-c-string* symbol) "C_c_string(")1395 ((bool) "C_truep(")1396 (else1397 (cond ((and (symbol? type) (lookup-foreign-type type))1398 => (lambda (t)1399 (foreign-argument-conversion (vector-ref t 0)) ) )1400 ((and (list? type) (>= (length type) 2))1401 (case (car type)1402 ((c-pointer) "C_c_pointer_or_null(")1403 ((nonnull-c-pointer) "C_c_pointer_nn(")1404 ((instance) "C_c_pointer_or_null(")1405 ((nonnull-instance) "C_c_pointer_nn(")1406 ((scheme-pointer) "C_data_pointer_or_null(")1407 ((nonnull-scheme-pointer) "C_data_pointer(")1408 ((function) "C_c_pointer_or_null(")1409 ((const) (foreign-argument-conversion (cadr type)))1410 ((enum) "C_num_to_int(")1411 ((ref)1412 (string-append "*(" (foreign-type-declaration (cadr type) "*")1413 ")C_c_pointer_nn("))1414 ((instance-ref)1415 (string-append "*(" (cadr type) "*)C_c_pointer_nn("))1416 (else (err)) ) )1417 (else (err)) ) ) ) ) )141814191420;; Generate suitable conversion of a result value into Scheme data14211422(define (foreign-result-conversion type dest)1423 (let ((err (lambda ()1424 (quit-compiling "illegal foreign return type `~A'" type))))1425 (case type1426 ((char unsigned-char) "C_make_character((C_word)")1427 ((int int32) "C_fix((C_word)")1428 ((unsigned-int unsigned-int32) "C_fix(C_MOST_POSITIVE_FIXNUM&(C_word)")1429 ((short) "C_fix((short)")1430 ((unsigned-short) "C_fix(0xffff&(C_word)")1431 ((byte) "C_fix((char)")1432 ((unsigned-byte) "C_fix(0xff&(C_word)")1433 ((float double) (sprintf "C_flonum(&~a," dest)) ;XXX suboptimal for int641434 ((number) (sprintf "C_number(&~a," dest))1435 ((nonnull-c-string c-string nonnull-c-pointer c-string* nonnull-c-string*1436 unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string1437 nonnull-unsigned-c-string* symbol c-string-list c-string-list*)1438 (sprintf "C_mpointer(&~a,(void*)" dest) )1439 ((c-pointer) (sprintf "C_mpointer_or_false(&~a,(void*)" dest))1440 ((integer integer32) (sprintf "C_int_to_num(&~a," dest))1441 ((integer64 ssize_t) (sprintf "C_int64_to_num(&~a," dest))1442 ((unsigned-integer64 size_t) (sprintf "C_uint64_to_num(&~a," dest))1443 ((unsigned-integer unsigned-integer32) (sprintf "C_unsigned_int_to_num(&~a," dest))1444 ((long) (sprintf "C_long_to_num(&~a," dest))1445 ((unsigned-long) (sprintf "C_unsigned_long_to_num(&~a," dest))1446 ((bool) "C_mk_bool(")1447 ((void scheme-object) "((C_word)")1448 (else1449 (cond ((and (symbol? type) (lookup-foreign-type type))1450 => (lambda (x)1451 (foreign-result-conversion (vector-ref x 0) dest)) )1452 ((and (list? type) (>= (length type) 2))1453 (case (car type)1454 ((nonnull-pointer nonnull-c-pointer)1455 (sprintf "C_mpointer(&~A,(void*)" dest) )1456 ((ref)1457 (sprintf "C_mpointer(&~A,(void*)&" dest) )1458 ((instance)1459 (sprintf "C_mpointer_or_false(&~A,(void*)" dest) )1460 ((nonnull-instance)1461 (sprintf "C_mpointer(&~A,(void*)" dest) )1462 ((instance-ref)1463 (sprintf "C_mpointer(&~A,(void*)&" dest) )1464 ((const) (foreign-result-conversion (cadr type) dest))1465 ((pointer c-pointer)1466 (sprintf "C_mpointer_or_false(&~a,(void*)" dest) )1467 ((function) (sprintf "C_mpointer(&~a,(void*)" dest))1468 ((enum) (sprintf "C_int_to_num(&~a," dest))1469 (else (err)) ) )1470 (else (err)) ) ) ) ) )147114721473;;; Encoded literals as strings, to be decoded by "C_decode_literal()"1474;;1475;; - everything hardcoded, using the FFI would be the ugly, but safer method.14761477(define (encode-literal lit)1478 (define getbits1479 (foreign-lambda* int ((scheme-object lit))1480 "1481#ifdef C_SIXTY_FOUR1482return((C_header_bits(lit) >> (24 + 32)) & 0xff);1483#else1484return((C_header_bits(lit) >> 24) & 0xff);1485#endif1486") )1487 (define getsize1488 (foreign-lambda* int ((scheme-object lit))1489 "return(C_header_size(lit));"))1490 (define (encode-size n)1491 (if (fx> (fxlen n) 24)1492 ;; Unfortunately we can't do much more to help the user.1493 ;; Printing the literal is not helpful because it's *huge*,1494 ;; and we have no line number information here.1495 (quit-compiling1496 "Encoded literal size of ~S is too large (must fit in 24 bits)" n)1497 (string1498 (integer->char (bitwise-and #xff (arithmetic-shift n -16)))1499 (integer->char (bitwise-and #xff (arithmetic-shift n -8)))1500 (integer->char (bitwise-and #xff n)))))1501 (define (finish str) ; can be taken out at a later stage1502 (string-append (string #\xfe) str))1503 (finish1504 (cond ((eq? #t lit) "\xff\x06\x01")1505 ((eq? #f lit) "\xff\x06\x00")1506 ((char? lit) (string-append "\xff\x0a" (encode-size (char->integer lit))))1507 ((null? lit) "\xff\x0e")1508 ((eof-object? lit) "\xff\x3e")1509 ((eq? (void) lit) "\xff\x1e")1510 ;; The big-fixnum? check can probably be simplified1511 ((and (fixnum? lit) (not (big-fixnum? lit)))1512 (string-append1513 "\xff\x01"1514 (string (integer->char (bitwise-and #xff (arithmetic-shift lit -24)))1515 (integer->char (bitwise-and #xff (arithmetic-shift lit -16)))1516 (integer->char (bitwise-and #xff (arithmetic-shift lit -8)))1517 (integer->char (bitwise-and #xff lit)) ) ) )1518 ((exact-integer? lit)1519 ;; Encode as hex to save space and get exact size1520 ;; calculation. We could encode as base 32 to save more1521 ;; space, but that makes debugging harder. The type tag is1522 ;; a bit of a hack: we encode as "GC forwarded" string to1523 ;; get a unique new type, as bignums don't have their own1524 ;; type tag (they're encoded as structures).1525 (let ((str (number->string lit 16)))1526 (string-append "\xc2" (encode-size (string-length str)) str)))1527 ((flonum? lit)1528 (string-append "\x55" (number->string lit) "\x00") )1529 ((or (keyword? lit) (symbol? lit))1530 (let ((str (##sys#slot lit 1)))1531 (string-append1532 "\x01"1533 (encode-size (string-length str))1534 (if (keyword? lit) "\x02" "\x01")1535 str) ) )1536 ((##sys#immediate? lit)1537 (bomb "invalid literal - cannot encode" lit))1538 ((##core#inline "C_byteblockp" lit)1539 (##sys#string-append ; relies on the fact that ##sys#string-append doesn't check1540 (string-append1541 (string (integer->char (getbits lit)))1542 (encode-size (getsize lit)) )1543 lit) )1544 (else1545 (let ((len (getsize lit)))1546 (string-intersperse1547 (cons*1548 (string (integer->char (getbits lit)))1549 (encode-size len)1550 (list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))1551 ""))))) )1552)