~ chicken-core (master) /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)53(import (only (scheme base) open-output-string get-output-string))5455(include "mini-srfi-1.scm")5657;;; Write atoms to output-port:5859(define output #f)6061(define (gen . data)62 (for-each63 (lambda (x)64 (cond ((eq? #t x) (newline output))65 (else (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->string/shared276 (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/shared 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/shared var)) " */ =")298 (expr (car subs) i)299 (gen #\;) ]300 [else301 (gen "C_set_block_item(lf[" index "] /* "302 (uncommentify (##sys#symbol->string/shared 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/shared (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_extern 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_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 (car llits))650 (llen (##sys#size ll)))651 (gen #t "static C_char 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 #\, (##sys#byte 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 (unless customizable (gen "C_ccall "))682 (gen id) )683 (else684 (let ((uname (toplevel unit-name)))685 (gen "C_noret_decl(C_" uname ")" #t) ;XXX what's this for?686 (gen "C_extern void C_ccall ")687 (gen "C_" uname) ) ) )688 (gen #\()689 (unless customizable (gen "C_word c,"))690 (when (and direct (not (zero? allocated)))691 (gen "C_word *a")692 (when (pair? varlist) (gen #\,)) )693 (if (or customizable direct)694 (apply gen varlist)695 (gen "C_word *av"))696 (gen #\))697 (unless direct (gen " C_noret"))698 (gen #\;) ))699 lambda-table*) )700701 (define (trampolines)702 (let ([ns '()]703 [nsr '()]704 [nsrv '()] )705706 (define (restore n)707 (do ((i 0 (add1 i))708 (j (sub1 n) (sub1 j)))709 ((>= i n))710 (gen #t "C_word t" i "=av[" j "];")))711712 (for-each713 (lambda (p)714 (let* ([id (car p)]715 [ll (cdr p)]716 [argc (lambda-literal-argument-count ll)]717 [customizable (lambda-literal-customizable ll)]718 [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )719 (when empty-closure (set! argc (sub1 argc)))720 (when (and (not (lambda-literal-direct ll)) customizable)721 (gen #t #t "C_noret_decl(tr" id ")"722 #t "static void C_ccall tr" id "(C_word c,C_word *av) C_noret;")723 (gen #t "static void C_ccall tr" id "(C_word c,C_word *av){")724 (restore argc)725 (gen #t id #\()726 (let ([al (make-argument-list argc "t")])727 (apply gen (intersperse al #\,)) )728 (gen ");}") )))729 lambda-table*)))730731 (define (literal-frame)732 (do ([i 0 (add1 i)]733 [lits literals (cdr lits)] )734 ((null? lits))735 (gen-lit (car lits) (sprintf "lf[~s]" i)) ) )736737 (define (bad-literal lit)738 (bomb "type of literal not supported" lit) )739740 (define (literal-size lit)741 (cond ((immediate? lit) 0)742 ((big-fixnum? lit) 2) ; immediate if fixnum, bignum see below743 ((string? lit) 0) ; statically allocated744 ((bignum? lit) 2) ; internal vector statically allocated745 ((flonum? lit) words-per-flonum)746 ((symbol? lit) 7) ; size of symbol, and possibly a bucket747 ((keyword? lit) 7) ; size of keyword (symbol), and possibly a bucket748 ((pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit))))749 ((vector? lit)750 (+ 1 (vector-length lit)751 (foldl + 0 (map literal-size (vector->list lit)))))752 ((block-variable-literal? lit) 0) ; excluded from generated code753 ((##sys#immediate? lit) (bad-literal lit))754 ((##core#inline "C_lambdainfop" lit) 0) ; statically allocated755 ((##sys#bytevector? lit) (+ 2 (bytes->words (##sys#size lit))) ) ; drops "permanent" property!756 ((##sys#generic-structure? lit)757 (let ([n (##sys#size lit)])758 (let loop ([i 0] [s (+ 2 n)])759 (if (>= i n)760 s761 (loop (add1 i) (+ s (literal-size (##sys#slot lit i)))) ) ) ) )762 ;; We could access rat/cplx slots directly, but let's not.763 ((ratnum? lit) (+ (##sys#size lit)764 (literal-size (numerator lit))765 (literal-size (denominator lit))))766 ((cplxnum? lit) (+ (##sys#size lit)767 (literal-size (real-part lit))768 (literal-size (imag-part lit))))769 (else (bad-literal lit))) )770771 (define (gen-lit lit to)772 ;; we do simple immediate literals directly to avoid a function call:773 (cond ((and (fixnum? lit) (not (big-fixnum? lit)))774 (gen #t to "=C_fix(" lit ");") )775 ((block-variable-literal? lit))776 ((eq? lit (void))777 (gen #t to "=C_SCHEME_UNDEFINED;") )778 ((boolean? lit)779 (gen #t to #\= (if lit "C_SCHEME_TRUE" "C_SCHEME_FALSE") #\;) )780 ((char? lit)781 (gen #t to "=C_make_character(" (char->integer lit) ");") )782 ((or (keyword? lit) (symbol? lit)) ; handled slightly specially (see C_h_intern_in)783 (let* ((str (##sys#symbol->string/shared lit))784 (cstr (c-ify-string str))785 (len (fx- (##sys#size (##sys#slot lit 1)) 1))786 (intern (if (keyword? lit)787 "C_h_intern_kw"788 "C_h_intern")))789 (gen #t to "=")790 (gen intern "(&" to #\, len ", C_text(" cstr "));")))791 ((null? lit)792 (gen #t to "=C_SCHEME_END_OF_LIST;") )793 ((and (not (##sys#immediate? lit)) ; nop794 (##core#inline "C_lambdainfop" lit)))795 ((or (fixnum? lit) (not (##sys#immediate? lit)))796 (gen #t to "=C_decode_literal(C_heaptop,C_text(\"")797 (gen (encode-literal lit))798 (gen "\"));"))799 (else (bad-literal lit))))800801 (define (procedures)802 (for-each803 (lambda (p)804 (let* ((id (car p))805 (ll (cdr p))806 (n (lambda-literal-argument-count ll))807 (rname (real-name id db))808 (demand (lambda-literal-allocated ll))809 (max-av (apply max 0 (lambda-literal-callee-signatures ll)))810 (rest (lambda-literal-rest-argument ll))811 (customizable (lambda-literal-customizable ll))812 (empty-closure (and customizable (zero? (lambda-literal-closure-size ll))))813 (nec (- n (if empty-closure 1 0)))814 (vlist0 (make-variable-list n "t"))815 (alist0 (make-argument-list n "t"))816 (varlist (intersperse (if empty-closure (cdr vlist0) vlist0) #\,))817 (arglist (intersperse (if empty-closure (cdr alist0) alist0) #\,))818 (external (lambda-literal-external ll))819 (looping (lambda-literal-looping ll))820 (direct (lambda-literal-direct ll))821 (rest-mode (lambda-literal-rest-argument-mode ll))822 (temps (lambda-literal-temporaries ll))823 (ftemps (lambda-literal-float-temporaries ll))824 (topname (toplevel unit-name)))825 (when empty-closure (debugging 'o "dropping unused closure argument" id))826 (gen #t #t)827 (gen "/* " (cleanup rname) " */" #t)828 (cond [(not (eq? 'toplevel id))829 (gen "static ")830 (gen (if direct "C_word " "void "))831 (unless customizable (gen "C_ccall "))832 (gen id) ]833 [else834 (gen "static int toplevel_initialized=0;")835 (unless unit-name836 (gen #t "C_main_entry_point") )837 (gen #t #t "void C_ccall C_" topname) ] )838 (gen #\()839 (unless customizable (gen "C_word c,"))840 (when (and direct (not (zero? demand)))841 (gen "C_word *a")842 (when (pair? varlist) (gen #\,)) )843 (if (or customizable direct)844 (apply gen varlist)845 (gen "C_word *av"))846 (gen "){")847 (when (eq? rest-mode 'none) (set! rest #f))848 (gen #t "C_word tmp;")849 (unless (or customizable direct)850 (do ((i 0 (add1 i)))851 ((>= i n))852 (gen #t "C_word t" i "=av[" i "];")))853 (if rest854 (gen #t "C_word t" n #\;) ; To hold rest-list if demand is met855 (begin856 (do ([i n (add1 i)]857 [j (+ temps (if looping (sub1 n) 0)) (sub1 j)] )858 ((zero? j))859 (gen #t "C_word t" i #\;))860 (for-each861 (lambda (i)862 (gen #t "double f" i #\;))863 ftemps)))864 (cond ((eq? 'toplevel id)865 (let ([ldemand (foldl (lambda (n lit) (+ n (literal-size lit))) 0 literals)]866 [llen (length literals)] )867 (gen #t "C_word *a;"868 #t "if(toplevel_initialized) {C_kontinue(t1,C_SCHEME_UNDEFINED);}"869 #t "else C_toplevel_entry(C_text(\"" (or unit-name topname) "\"));")870 (when emit-debug-info871 (gen #t "C_register_debug_info(C_debug_info);"))872 (when disable-stack-overflow-checking873 (gen #t "C_disable_overflow_check=1;") )874 (unless unit-name875 (when target-heap-size876 (gen #t "C_set_or_change_heap_size(" target-heap-size ",1);"877 #t "C_heap_size_is_fixed=1;"))878 (when target-stack-size879 (gen #t "C_resize_stack(" target-stack-size ");") ) )880 (gen #t "C_check_nursery_minimum(C_calculate_demand(" demand ",c," max-av "));"881 #t "if(C_unlikely(!C_demand(C_calculate_demand(" demand ",c," max-av ")))){"882 #t "C_save_and_reclaim((void*)C_" topname ",c,av);}"883 #t "toplevel_initialized=1;"884 #t "if(C_unlikely(!C_demand_2(" ldemand "))){"885 #t "C_save(t1);"886 #t "C_rereclaim2(" ldemand "*sizeof(C_word),1);"887 #t "t1=C_restore;}"888 #t "a=C_alloc(" demand ");")889 (when (not (zero? llen))890 (gen #t "C_initialize_lf(lf," llen ");")891 (literal-frame)892 (gen #t "C_register_lf2(lf," llen ",create_ptable());"))893 (gen #\{)))894 (rest895 (gen #t "C_word *a;")896 (when (and (not unsafe) (not no-argc-checks) (> n 2) (not empty-closure))897 (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);") )898 (when insert-timer-checks (gen #t "C_check_for_interrupt;"))899 (gen #t "if(C_unlikely(!C_demand(C_calculate_demand((c-" n ")*C_SIZEOF_PAIR +" demand ",c," max-av ")))){"))900 (else901 (unless direct (gen #t "C_word *a;"))902 (when (and direct (not unsafe) (not disable-stack-overflow-checking))903 (gen #t "C_stack_overflow_check;"))904 (when looping (gen #t "loop:"))905 (when (and external (not unsafe) (not no-argc-checks) (not customizable))906 ;; (not customizable) implies empty-closure907 (if (eq? rest-mode 'none)908 (when (> n 2) (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);"))909 (gen #t "if(c!=" n ") C_bad_argc_2(c," n ",t0);") ) )910 (cond ((not direct)911 ;; The interrupt handler may fill the stack, so we only912 ;; check for an interrupt when the procedure is restartable913 (when insert-timer-checks (gen #t "C_check_for_interrupt;"))914 (gen #t "if(C_unlikely(!C_demand(C_calculate_demand("915 demand916 (if customizable ",0," ",c,")917 max-av ")))){"))918 (else919 (gen #\{)))))920 (cond ((and (not (eq? 'toplevel id)) (not direct))921 (when (and looping (not customizable))922 ;; Loop will update t_n copy of av[n]; refresh av.923 (do ((i 0 (add1 i)))924 ((>= i n))925 (gen #t "av[" i "]=t" i ";")))926 (cond (rest927 (gen #t "C_save_and_reclaim((void*)" id ",c,av);}"928 #t "a=C_alloc((c-" n ")*C_SIZEOF_PAIR+" demand ");")929 (gen #t "t" n "=C_build_rest(&a,c," n ",av);")930 (do ((i (+ n 1) (+ i 1))931 (j temps (- j 1)))932 ((zero? j))933 (gen #t "C_word t" i #\;)))934 (else935 (cond ((and customizable (> nec 0))936 (gen #t "C_save_and_reclaim_args((void *)tr" id #\, nec #\,)937 (apply gen arglist)938 (gen ");}"))939 (else940 (gen #t "C_save_and_reclaim((void *)" id ",c,av);}")))941 (when (> demand 0)942 (gen #t "a=C_alloc(" demand ");")))))943 (else (gen #\})))944 (set! non-av-proc customizable)945 (expression946 (lambda-literal-body ll)947 (if rest948 (add1 n) ; One temporary is needed to hold the rest-list949 n)950 ll)951 (gen #\}) ) )952 lambda-table*) )953954 (debugging 'p "code generation phase...")955 (set! output out)956 (header)957 (declarations)958 (generate-external-variables external-variables)959 (generate-foreign-stubs foreign-lambda-stubs db)960 (prototypes)961 (generate-foreign-callback-stubs foreign-callback-stubs db)962 (trampolines)963 (when emit-debug-info964 (emit-debug-table dbg-info-table))965 (procedures)966 (emit-procedure-table lambda-table* source-file)967 (trailer) ) )968969970;;; Emit global tables for debug-info971972(define (emit-debug-table dbg-info-table)973 (gen #t #t "static C_DEBUG_INFO C_debug_info[]={")974 (for-each975 (lambda (info)976 (gen #t "{" (second info) ",0,")977 (for-each978 (lambda (x)979 (if (not x)980 (gen "NULL,")981 (gen "C_text(\"" (backslashify (->string x)) "\"),")))982 (cddr info))983 (gen "},"))984 (sort dbg-info-table (lambda (i1 i2) (< (car i1) (car i2)))))985 (gen #t "{0,0,NULL,NULL}};\n"))986987988;;; Emit procedure table:989990(define (emit-procedure-table lambda-table* sf)991 (gen #t #t "#ifdef C_ENABLE_PTABLES"992 #t "static C_PTABLE_ENTRY ptable[" (add1 (length lambda-table*)) "] = {")993 (for-each994 (lambda (p)995 (let ((id (car p))996 (ll (cdr p)))997 (gen #t "{C_text(\"" id #\: (string->c-identifier sf) "\"),(void*)")998 (if (eq? 'toplevel id)999 (gen "C_" (toplevel unit-name) "},")1000 (gen id "},") ) ) )1001 lambda-table*)1002 (gen #t "{NULL,NULL}};")1003 (gen #t "#endif")1004 (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void)")1005 (gen "{" #t "#ifdef C_ENABLE_PTABLES"1006 #t "return ptable;"1007 #t "#else"1008 #t "return NULL;"1009 #t "#endif"1010 #t "}") )101110121013;;; Generate top-level procedure name:10141015(define (toplevel name)1016 (if (not name)1017 "toplevel"1018 (string-append (c-identifier name) "_toplevel")))101910201021;;; Create name that is safe for C comments:10221023(define (cleanup s)1024 (let ([s2 #f]1025 [len (string-length s)] )1026 (let loop ([i 0])1027 (if (>= i len)1028 (or s2 s)1029 (let ([c (string-ref s i)])1030 (if (or (char<? c #\space)1031 (char>? c #\~)1032 (and (char=? c #\*) (< i (sub1 len)) (char=? #\/ (string-ref s (add1 i)))) )1033 (begin1034 (unless s2 (set! s2 (string-copy s)))1035 (string-set! s2 i #\~) )1036 (when s2 (string-set! s2 i c)) )1037 (loop (add1 i)) ) ) ) ) )103810391040;;; Create list of variables/parameters, interspersed with a special token:10411042(define (make-variable-list n prefix)1043 (list-tabulate1044 n1045 (lambda (i) (string-append "C_word " prefix (number->string i))) ) )10461047(define (make-argument-list n prefix)1048 (list-tabulate1049 n1050 (lambda (i) (string-append prefix (number->string i))) ) )105110521053;;; Generate external variable declarations:10541055(define (generate-external-variables vars)1056 (gen #t)1057 (for-each1058 (lambda (v)1059 (let ((name (vector-ref v 0))1060 (type (vector-ref v 1))1061 (exported (vector-ref v 2)) )1062 (gen #t (if exported "" "static ") (foreign-type-declaration type name) #\;) ) )1063 vars) )106410651066;;; Generate foreign stubs:10671068(define (generate-foreign-callback-stub-prototypes stubs)1069 (for-each1070 (lambda (stub)1071 (gen #t)1072 (generate-foreign-callback-header "C_extern " stub)1073 (gen #\;) )1074 stubs) )10751076(define (generate-foreign-stubs stubs db)1077 (for-each1078 (lambda (stub)1079 (let* ([id (foreign-stub-id stub)]1080 [rname (real-name2 id db)]1081 [types (foreign-stub-argument-types stub)]1082 [n (length types)]1083 [rtype (foreign-stub-return-type stub)]1084 [sname (foreign-stub-name stub)]1085 [body (foreign-stub-body stub)]1086 [names (or (foreign-stub-argument-names stub) (make-list n #f))]1087 [rconv (foreign-result-conversion rtype "C_a")]1088 [cps (foreign-stub-cps stub)]1089 [callback (foreign-stub-callback stub)] )1090 (gen #t)1091 (when rname1092 (gen #t "/* from " (cleanup rname) " */") )1093 (when body1094 (gen #t "#define return(x) C_cblock C_r = (" rconv1095 "(x))); goto C_ret; C_cblockend"))1096 (cond (cps1097 (gen #t "C_noret_decl(" id ")"1098 #t "static void C_ccall " id "(C_word C_c,C_word *C_av){"1099 #t "C_word C_k=C_av[1],C_buf=C_av[2];")1100 (do ((i 0 (add1 i)))1101 ((>= i n))1102 (gen #t "C_word C_a" i "=C_av[" (+ i 3) "];")))1103 (else1104 (gen #t "C_regparm static C_word " id #\()1105 (apply gen (intersperse (cons "C_word C_buf" (make-variable-list n "C_a")) #\,))1106 (gen "){")))1107 (gen #t "C_word C_r=C_SCHEME_UNDEFINED,*C_a=(C_word*)C_buf;")1108 (for-each1109 (lambda (type index name)1110 (gen #t1111 (foreign-type-declaration1112 type1113 (if name (symbol->string name) (sprintf "t~a" index)) )1114 "=(" (foreign-type-declaration type "") #\)1115 (foreign-argument-conversion type) "C_a" index ");") )1116 types (iota n) names)1117 (when callback (gen #t "int C_level=C_save_callback_continuation(&C_a,C_k);"))1118 (cond [body1119 (gen #t body1120 #t "C_ret:")1121 (gen #t "#undef return" #t)1122 (cond [callback1123 (gen #t "C_k=C_restore_callback_continuation2(C_level);"1124 #t "C_kontinue(C_k,C_r);") ]1125 [cps (gen #t "C_kontinue(C_k,C_r);")]1126 [else (gen #t "return C_r;")] ) ]1127 [else1128 (if (not (eq? rtype 'void))1129 (gen #t "C_r=" rconv)1130 (gen #t) )1131 (gen sname #\()1132 (apply gen (intersperse (make-argument-list n "t") #\,))1133 (unless (eq? rtype 'void) (gen #\)))1134 (gen ");")1135 (cond [callback1136 (gen #t "C_k=C_restore_callback_continuation2(C_level);"1137 #t "C_kontinue(C_k,C_r);") ]1138 [cps (gen "C_kontinue(C_k,C_r);")]1139 [else (gen #t "return C_r;")] ) ] )1140 (gen #\}) ) )1141 stubs) )11421143(define (generate-foreign-callback-stubs stubs db)1144 (for-each1145 (lambda (stub)1146 (let* ((id (foreign-callback-stub-id stub))1147 (rname (real-name2 id db))1148 (rtype (foreign-callback-stub-return-type stub))1149 (argtypes (foreign-callback-stub-argument-types stub))1150 (n (length argtypes))1151 (vlist (make-argument-list n "t")) )11521153 (define (compute-size type var ns)1154 (case type1155 ((char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int321156 byte unsigned-byte)1157 ns)1158 ((float double c-pointer nonnull-c-pointer1159 c-string-list c-string-list*)1160 (string-append ns "+3") )1161 ((complex cplxnum)1162 (string-append ns "+5") )1163 ((unsigned-integer unsigned-integer32 long integer integer321164 unsigned-long number)1165 (string-append ns "+C_SIZEOF_FIX_BIGNUM"))1166 ((unsigned-integer64 integer64 size_t ssize_t)1167 ;; On 32-bit systems, needs 2 digits1168 (string-append ns "+C_SIZEOF_BIGNUM(2)"))1169 ((c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)1170 (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") )1171 ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)1172 (string-append ns "+2+C_bytestowords(C_strlen(" var "))") )1173 (else1174 (cond ((and (symbol? type) (lookup-foreign-type type))1175 => (lambda (t) (compute-size (vector-ref t 0) var ns) ) )1176 ((pair? type)1177 (case (car type)1178 ((ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance1179 nonnull-instance instance-ref)1180 (string-append ns "+3") )1181 ((const) (compute-size (cadr type) var ns))1182 (else ns) ) )1183 (else ns) ) ) ) )11841185 (let ((sizestr (let loop ((types argtypes) (vars vlist) (ns "0"))1186 (if (null? types)1187 ns1188 (loop (cdr types) (cdr vars)1189 (compute-size (car types) (car vars) ns))))))1190 (gen #t)1191 (when rname1192 (gen #t "/* from " (cleanup rname) " */") )1193 (generate-foreign-callback-header "" stub)1194 (gen #\{ #t "C_word x,s=" sizestr ",*a="1195 (if (string=? "0" sizestr) "C_stack_pointer;" "C_alloc(s);"))1196 (gen #t "C_callback_adjust_stack(a,s);") ; make sure content is below stack_bottom as well1197 (for-each1198 (lambda (v t)1199 (gen #t "x=" (foreign-result-conversion t "a") v ");"1200 #t "C_save(x);") )1201 (reverse vlist)1202 (reverse argtypes))1203 (unless (eq? 'void rtype)1204 (gen #t "return " (foreign-argument-conversion rtype)) )1205 (gen "C_callback_wrapper((void *)" id #\, n #\))1206 (unless (eq? 'void rtype) (gen #\)))1207 (gen ";}") ) ) )1208 stubs) )12091210(define (generate-foreign-callback-header cls stub)1211 (let* ((name (foreign-callback-stub-name stub))1212 (quals (foreign-callback-stub-qualifiers stub))1213 (rtype (foreign-callback-stub-return-type stub))1214 (argtypes (foreign-callback-stub-argument-types stub))1215 (n (length argtypes))1216 (vlist (make-argument-list n "t")) )1217 (gen #t cls #\space (foreign-type-declaration rtype "") quals #\space name #\()1218 (let loop ((vs vlist) (ts argtypes))1219 (unless (null? vs)1220 (gen (foreign-type-declaration (car ts) (car vs)))1221 (when (pair? (cdr vs)) (gen #\,))1222 (loop (cdr vs) (cdr ts))))1223 (gen #\)) ) )122412251226;; Create type declarations12271228(define (foreign-type-declaration type target)1229 (let ((err (lambda () (quit-compiling "illegal foreign type `~A'" type)))1230 (str (lambda (ts) (string-append ts " " target))) )1231 (case type1232 ((scheme-object) (str "C_word"))1233 ((char byte) (str "C_char"))1234 ((unsigned-char unsigned-byte) (str "unsigned C_char"))1235 ((unsigned-int unsigned-integer) (str "unsigned int"))1236 ((unsigned-int32 unsigned-integer32) (str "C_u32"))1237 ((int integer bool) (str "int"))1238 ((size_t) (str "size_t"))1239 ((ssize_t) (str "ssize_t"))1240 ((int32 integer32) (str "C_s32"))1241 ((integer64) (str "C_s64"))1242 ((unsigned-integer64) (str "C_u64"))1243 ((short) (str "short"))1244 ((long) (str "long"))1245 ((unsigned-short) (str "unsigned short"))1246 ((unsigned-long) (str "unsigned long"))1247 ((float) (str "float"))1248 ((double number) (str "double"))1249 ((complex cplxnum) (str "double complex"))1250 ((c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer) (str "void *"))1251 ((c-string-list c-string-list*) "C_char **")1252 ((bytevector nonnull-bytevector u8vector nonnull-u8vector) (str "unsigned char *"))1253 ((blob nonnull-blob) (str "unsigned char *")) ; DEPRECATED1254 ((u16vector nonnull-u16vector) (str "unsigned short *"))1255 ((s8vector nonnull-s8vector) (str "signed char *"))1256 ((u32vector nonnull-u32vector) (str "unsigned int *")) ;; C_u32?1257 ((u64vector nonnull-u64vector) (str "C_u64 *"))1258 ((s16vector nonnull-s16vector) (str "short *"))1259 ((s32vector nonnull-s32vector) (str "int *")) ;; C_s32?1260 ((s64vector nonnull-s64vector) (str "C_s64 *"))1261 ((f32vector nonnull-f32vector) (str "float *"))1262 ((f64vector nonnull-f64vector) (str "double *"))1263 ((pointer-vector nonnull-pointer-vector) (str "void **"))1264 ((nonnull-c-string c-string nonnull-c-string* c-string* symbol)1265 (str "char *"))1266 ((nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string unsigned-c-string*)1267 (str "unsigned char *"))1268 ((void) (str "void"))1269 (else1270 (cond ((and (symbol? type) (lookup-foreign-type type))1271 => (lambda (t)1272 (foreign-type-declaration (vector-ref t 0) target)) )1273 ((string? type) (str type))1274 ((list? type)1275 (let ((len (length type)))1276 (cond1277 ((and (= 2 len)1278 (memq (car type) '(pointer nonnull-pointer c-pointer1279 scheme-pointer nonnull-scheme-pointer1280 nonnull-c-pointer) ) )1281 (foreign-type-declaration (cadr type) (string-append "*" target)) )1282 ((and (= 2 len)1283 (eq? 'ref (car type)))1284 (foreign-type-declaration (cadr type) (string-append "&" target)) )1285 ((and (> len 2)1286 (eq? 'template (car type)))1287 (str1288 (string-append1289 (foreign-type-declaration (cadr type) "")1290 "<"1291 (string-intersperse1292 (map (cut foreign-type-declaration <> "") (cddr type))1293 ",")1294 "> ") ) )1295 ((and (= len 2) (eq? 'const (car type)))1296 (string-append "const " (foreign-type-declaration (cadr type) target)))1297 ((and (= len 2) (eq? 'struct (car type)))1298 (if (list? (cadr type))1299 (string-append (->string (caadr type)) " " target)1300 (string-append "struct " (->string (cadr type)) " " target)))1301 ((and (= len 2) (eq? 'union (car type)))1302 (if (list? (cadr type))1303 (string-append (->string (caadr type)) " " target)1304 (string-append "union " (->string (cadr type)) " " target)))1305 ((and (= len 2) (eq? 'enum (car type)))1306 (string-append "enum " (->string (cadr type)) " " target))1307 ((and (= len 3) (memq (car type) '(instance nonnull-instance)))1308 (string-append (->string (cadr type)) "*" target))1309 ((and (= len 3) (eq? 'instance-ref (car type)))1310 (string-append (->string (cadr type)) "&" target))1311 ((and (>= len 3) (eq? 'function (car type)))1312 (let ((rtype (cadr type))1313 (argtypes (caddr type))1314 (callconv (optional (cdddr type) "")))1315 (string-append1316 (foreign-type-declaration rtype "")1317 callconv1318 " (*" target ")("1319 (string-intersperse1320 (map (lambda (at)1321 (if (eq? '... at)1322 "..."1323 (foreign-type-declaration at "") ) )1324 argtypes)1325 ",")1326 ")" ) ) )1327 (else (err)) ) ) )1328 (else (err)) ) ) ) ) )132913301331;; Generate expression to convert argument from Scheme data13321333(define (foreign-argument-conversion type)1334 (let ((err (lambda ()1335 (quit-compiling "illegal foreign argument type `~A'" type))))1336 (case type1337 ((scheme-object) "(")1338 ((char unsigned-char) "C_character_code((C_word)")1339 ((byte int int32 unsigned-int unsigned-int32 unsigned-byte) "C_unfix(")1340 ((short) "C_unfix(")1341 ((unsigned-short) "(unsigned short)C_unfix(")1342 ((unsigned-long) "C_num_to_unsigned_long(")1343 ((double number float) "C_c_double(")1344 ((complex cplxnum) "C_c_cplxnum(")1345 ((integer integer32) "C_num_to_int(")1346 ((integer64) "C_num_to_int64(")1347 ((size_t) "(size_t)C_num_to_uint64(")1348 ((ssize_t) "(ssize_t)C_num_to_int64(")1349 ((unsigned-integer64) "C_num_to_uint64(")1350 ((long) "C_num_to_long(")1351 ((unsigned-integer unsigned-integer32) "C_num_to_unsigned_int(")1352 ((scheme-pointer) "C_data_pointer_or_null(")1353 ((nonnull-scheme-pointer) "C_data_pointer(")1354 ((c-pointer) "C_c_pointer_or_null(")1355 ((nonnull-c-pointer) "C_c_pointer_nn(")1356 ((u8vector bytevector) "C_c_bytevector_or_null(")1357 ((nonnull-bytevector nonnull-u8vector) "C_c_bytevector(")1358 ((blob) "C_c_bytevector_or_null(") ; DEPRECATED1359 ((nonnull-blob) "C_c_bytevector(") ; DEPRECATED1360 ((u16vector) "C_c_u16vector_or_null(")1361 ((nonnull-u16vector) "C_c_u16vector(")1362 ((u32vector) "C_c_u32vector_or_null(")1363 ((nonnull-u32vector) "C_c_u32vector(")1364 ((u64vector) "C_c_u64vector_or_null(")1365 ((nonnull-u64vector) "C_c_u64vector(")1366 ((s8vector) "C_c_s8vector_or_null(")1367 ((nonnull-s8vector) "C_c_s8vector(")1368 ((s16vector) "C_c_s16vector_or_null(")1369 ((nonnull-s16vector) "C_c_s16vector(")1370 ((s32vector) "C_c_s32vector_or_null(")1371 ((nonnull-s32vector) "C_c_s32vector(")1372 ((s64vector) "C_c_s64vector_or_null(")1373 ((nonnull-s64vector) "C_c_s64vector(")1374 ((f32vector) "C_c_f32vector_or_null(")1375 ((nonnull-f32vector) "C_c_f32vector(")1376 ((f64vector) "C_c_f64vector_or_null(")1377 ((nonnull-f64vector) "C_c_f64vector(")1378 ((pointer-vector) "C_c_pointer_vector_or_null(")1379 ((nonnull-pointer-vector) "C_c_pointer_vector(")1380 ((c-string c-string* unsigned-c-string unsigned-c-string*) "C_string_or_null(")1381 ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string1382 nonnull-unsigned-c-string* symbol) "C_c_string(")1383 ((bool) "C_truep(")1384 (else1385 (cond ((and (symbol? type) (lookup-foreign-type type))1386 => (lambda (t)1387 (foreign-argument-conversion (vector-ref t 0)) ) )1388 ((and (list? type) (>= (length type) 2))1389 (case (car type)1390 ((c-pointer) "C_c_pointer_or_null(")1391 ((nonnull-c-pointer) "C_c_pointer_nn(")1392 ((instance) "C_c_pointer_or_null(")1393 ((nonnull-instance) "C_c_pointer_nn(")1394 ((scheme-pointer) "C_data_pointer_or_null(")1395 ((nonnull-scheme-pointer) "C_data_pointer(")1396 ((function) "C_c_pointer_or_null(")1397 ((const) (foreign-argument-conversion (cadr type)))1398 ((enum) "C_num_to_int(")1399 ((struct union)1400 (if (list? (cadr type))1401 (sprintf "C_build_struct(~a," (caadr type))1402 (sprintf "C_build_struct(~a ~a," (car type) (cadr type))))1403 ((ref)1404 (string-append "*(" (foreign-type-declaration (cadr type) "*")1405 ")C_c_pointer_nn("))1406 ((instance-ref)1407 (string-append "*(" (cadr type) "*)C_c_pointer_nn("))1408 (else (err)) ) )1409 (else (err)) ) ) ) ) )141014111412;; Generate suitable conversion of a result value into Scheme data14131414(define (foreign-result-conversion type dest)1415 (let ((err (lambda ()1416 (quit-compiling "illegal foreign return type `~A'" type))))1417 (case type1418 ((char unsigned-char) "C_make_character((C_word)")1419 ((int int32) "C_fix((C_word)")1420 ((unsigned-int unsigned-int32) "C_fix(C_MOST_POSITIVE_FIXNUM&(C_word)")1421 ((short) "C_fix((short)")1422 ((unsigned-short) "C_fix(0xffff&(C_word)")1423 ((byte) "C_fix((char)")1424 ((unsigned-byte) "C_fix(0xff&(C_word)")1425 ((float double) (sprintf "C_flonum(&~a," dest)) ;XXX suboptimal for int641426 ((complex cplxnum) (sprintf "C_inexact_cplxnum(&~a," dest))1427 ((number) (sprintf "C_number(&~a," dest))1428 ((nonnull-c-string c-string nonnull-c-pointer c-string* nonnull-c-string*1429 unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string1430 nonnull-unsigned-c-string* symbol c-string-list c-string-list*)1431 (sprintf "C_mpointer(&~a,(void*)" dest) )1432 ((c-pointer) (sprintf "C_mpointer_or_false(&~a,(void*)" dest))1433 ((integer integer32) (sprintf "C_int_to_num(&~a," dest))1434 ((integer64 ssize_t) (sprintf "C_int64_to_num(&~a," dest))1435 ((unsigned-integer64 size_t) (sprintf "C_uint64_to_num(&~a," dest))1436 ((unsigned-integer unsigned-integer32) (sprintf "C_unsigned_int_to_num(&~a," dest))1437 ((long) (sprintf "C_long_to_num(&~a," dest))1438 ((unsigned-long) (sprintf "C_unsigned_long_to_num(&~a," dest))1439 ((bool) "C_mk_bool(")1440 ((void scheme-object) "((C_word)")1441 (else1442 (cond ((and (symbol? type) (lookup-foreign-type type))1443 => (lambda (x)1444 (foreign-result-conversion (vector-ref x 0) dest)) )1445 ((and (list? type) (>= (length type) 2))1446 (case (car type)1447 ((nonnull-pointer nonnull-c-pointer)1448 (sprintf "C_mpointer(&~A,(void*)" dest) )1449 ((ref)1450 (sprintf "C_mpointer(&~A,(void*)&" dest) )1451 ((struct union)1452 (if (list? (cadr type))1453 (sprintf "C_a_extract_struct(&~A,~A," dest (caadr type))1454 (sprintf "C_a_extract_struct(&~A,~A ~A," dest (car type) (cadr type))))1455 ((instance)1456 (sprintf "C_mpointer_or_false(&~A,(void*)" dest) )1457 ((nonnull-instance)1458 (sprintf "C_mpointer(&~A,(void*)" dest) )1459 ((instance-ref)1460 (sprintf "C_mpointer(&~A,(void*)&" dest) )1461 ((const) (foreign-result-conversion (cadr type) dest))1462 ((pointer c-pointer)1463 (sprintf "C_mpointer_or_false(&~a,(void*)" dest) )1464 ((function) (sprintf "C_mpointer(&~a,(void*)" dest))1465 ((enum) (sprintf "C_int_to_num(&~a," dest))1466 (else (err)) ) )1467 (else (err)) ) ) ) ) )146814691470;;; Encoded literals as strings, to be decoded by "C_decode_literal()"1471;;1472;; - everything hardcoded, using the FFI would be the ugly, but safer method.14731474(define (oct n)1475 (string-append1476 (cond ((< n 8) "\\00")1477 ((< n 64) "\\0")1478 (else "\\"))1479 (number->string n 8)))14801481(define (encode-literal lit)1482 (define getbits1483 (foreign-lambda* int ((scheme-object lit))1484 "1485#ifdef C_SIXTY_FOUR1486return((C_header_bits(lit) >> (24 + 32)) & 0xff);1487#else1488return((C_header_bits(lit) >> 24) & 0xff);1489#endif1490") )1491 (define getsize1492 (foreign-lambda* int ((scheme-object lit))1493 "return(C_header_size(lit));"))1494 (define (encode-size n)1495 (if (fx> (fxlen n) 24)1496 ;; Unfortunately we can't do much more to help the user.1497 ;; Printing the literal is not helpful because it's *huge*,1498 ;; and we have no line number information here.1499 (quit-compiling1500 "Encoded literal size of ~S is too large (must fit in 24 bits)" n)1501 (string-append1502 (oct (bitwise-and #xff (arithmetic-shift n -16)))1503 (oct (bitwise-and #xff (arithmetic-shift n -8)))1504 (oct (bitwise-and #xff n)))))1505 (define (finish str) ; can be taken out at a later stage1506 (string-append "\\376" str))1507 (finish1508 (cond ((eq? #t lit) "\\377\\006\\001")1509 ((eq? #f lit) "\\377\\006\\000")1510 ((char? lit) (string-append "\\377\\012" (encode-size (char->integer lit))))1511 ((null? lit) "\\377\\016")1512 ((eof-object? lit) "\\377\\076")1513 ((eq? (void) lit) "\\377\\036")1514 ;; The big-fixnum? check can probably be simplified1515 ((and (fixnum? lit) (not (big-fixnum? lit)))1516 (string-append1517 "\\377\\001"1518 (oct (bitwise-and #xff (arithmetic-shift lit -24)))1519 (oct (bitwise-and #xff (arithmetic-shift lit -16)))1520 (oct (bitwise-and #xff (arithmetic-shift lit -8)))1521 (oct (bitwise-and #xff lit)) ) )1522 ((exact-integer? lit)1523 ;; Encode as hex to save space and get exact size1524 ;; calculation. We could encode as base 32 to save more1525 ;; space, but that makes debugging harder. The type tag is1526 ;; a bit of a hack: we encode as "GC forwarded" string to1527 ;; get a unique new type, as bignums don't have their own1528 ;; type tag (they're encoded as structures).1529 (let ((str (number->string lit 16)))1530 (string-append "\\320" (encode-size (fx- (##sys#size (##sys#slot str 0)) 1)) str)))1531 ((flonum? lit)1532 (string-append "\\125" (number->string lit) "\\000") )1533 ((keyword? lit)1534 (let* ((str (keyword->string lit))1535 (bv (##sys#slot str 0)))1536 (string-append1537 "\\001" (encode-size (fx- (##sys#size bv) 1)) "\\002"1538 (byteblock->string bv -1)) ) )1539 ((symbol? lit)1540 (let* ((str (##sys#symbol->string/shared lit))1541 (bv (##sys#slot str 0)))1542 (string-append1543 "\\001" (encode-size (fx- (##sys#size bv) 1)) "\\001"1544 (byteblock->string bv -1) ) ))1545 ((string? lit)1546 (string-append1547 (oct (getbits lit))1548 (encode-size (##sys#size (##sys#slot lit 0)))1549 (byteblock->string (##sys#slot lit 0) 0) ))1550 ((##core#inline "C_byteblockp" lit)1551 (string-append1552 (oct (getbits lit))1553 (encode-size (getsize lit))1554 (byteblock->string lit 0) ))1555 ((##sys#immediate? lit)1556 (bomb "invalid literal - cannot encode" lit))1557 (else1558 (let ((len (getsize lit)))1559 (string-intersperse1560 (cons*1561 (oct (getbits lit))1562 (encode-size len)1563 (list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))1564 ""))))) )15651566(define (byteblock->string bb mlen)1567 (let ((out (open-output-string))1568 (len (fx+ (##sys#size bb) mlen)))1569 (do ((i 0 (fx+ i 1)))1570 ((fx>= i len) (get-output-string out))1571 (display (oct (##sys#byte bb i)) out))))15721573(define (c-ify-string str)1574 (list->string1575 (cons1576 #\"1577 (let loop ((bytes (##sys#bytevector->list (##sys#slot str 0))))1578 (if (or (null? bytes)1579 (null? (cdr bytes)))1580 '(#\")1581 (let ((code (car bytes)))1582 (if (or (< code 32)1583 (>= code 127)1584 (memq code '(#\" #\' #\\ #\? #\*)))1585 (append '(#\\)1586 (cond ((< code 8) '(#\0 #\0))1587 ((< code 64) '(#\0))1588 (else '()))1589 (string->list (number->string code 8))1590 (loop (cdr bytes)) )1591 (cons (integer->char code)1592 (loop (cdr bytes))))))))))15931594)