Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-08 13:37:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

WIP

Browse source
This commit is contained in:
Justin Ethier 2020-05-04 22:45:44 -04:00
parent 41e6aedb25
commit cdeeef8b27
3 changed files with 74 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
libs/cyclone/foreign.sld
View file

@ -9,7 +9,7 @@
(define-library (cyclone foreign) (define-library (cyclone foreign)
(import (import
(scheme base) (scheme base)
;(scheme write) ;; TODO: debugging only! (scheme write) ;; TODO: debugging only!
;(scheme cyclone pretty-print) ;(scheme cyclone pretty-print)
(scheme cyclone util) (scheme cyclone util)
) )
@ -34,7 +34,7 @@
; (if (not (string? arg)) ; (if (not (string? arg))
; (error "c-value" "Invalid argument: string expected, received " arg))) ; (error "c-value" "Invalid argument: string expected, received " arg)))
; (cdr expr)) ; (cdr expr))
`((lambda () (Cyc-foreign-value ,code-arg (quote ,type-arg)))))))) `((lambda () (Cyc-foreign-value ,code-arg ,(symbol->string type-arg))))))))
(define-syntax c-code (define-syntax c-code
(er-macro-transformer (er-macro-transformer
@ -78,7 +78,7 @@
(string-append "symbol_desc(" ,code ")")) (string-append "symbol_desc(" ,code ")"))
((bytevector) ((bytevector)
(string-append "(((bytevector_type *)" ,code ")->data)")) (string-append "(((bytevector_type *)" ,code ")->data)"))
((opaque ((opaque)
(string-append "opaque_ptr(" ,code ")")) (string-append "opaque_ptr(" ,code ")"))
(else (else
(error "scm->c unable to convert scheme object of type " ,type))))))) (error "scm->c unable to convert scheme object of type " ,type)))))))
@ -98,7 +98,9 @@
(lambda (expr rename compare) (lambda (expr rename compare)
(let ((code (cadr expr)) (let ((code (cadr expr))
(type (caddr expr))) (type (caddr expr)))
`(case ,type `(case (if (string? ,type)
(string->symbol ,type)
,type)
((int integer) ((int integer)
(cons (cons
"" ""
@ -125,10 +127,6 @@
"make_double(" var ", " ,code ");") "make_double(" var ", " ,code ");")
(string-append "&" var) (string-append "&" var)
))) )))
; TODO: how to handle the allocation here?
; may need to return a c-code pair???
; (string-append "
; ))
; /*bytevector_tag */ , "bytevector" ; /*bytevector_tag */ , "bytevector"
; /*c_opaque_tag */ , "opaque" ; /*c_opaque_tag */ , "opaque"
; /*bignum_tag */ , "bignum" ; /*bignum_tag */ , "bignum"

2
libs/test-foreign.scm
View file

@ -27,7 +27,7 @@
) )
;; Must be top-level ;; Must be top-level
(c-define scm-strlen int "strlen" string) (c-define scm-strlen "int" "strlen" string)
(c-define scm-strlend double "strlen" string) (c-define scm-strlend double "strlen" string)
(test-group "foreign lambda" (test-group "foreign lambda"

132
scheme/cyclone/cgen.sld
View file

@ -13,6 +13,7 @@
(scheme eval) (scheme eval)
(scheme inexact) (scheme inexact)
(scheme write) (scheme write)
(cyclone foreign)
(scheme cyclone primitives) (scheme cyclone primitives)
(scheme cyclone transforms) (scheme cyclone transforms)
(scheme cyclone ast) (scheme cyclone ast)
@ -283,12 +284,12 @@
;;; Compilation routines. ;;; Compilation routines.
;; Return generated code that also requests allocation of C variables on stack ;; Return generated code that also requests allocation of C variables on stack
(define (c-code/vars str cvars) (define (c:code/vars str cvars)
(list str (list str
cvars)) cvars))
;; Return generated code with no C variables allocated on the stack ;; Return generated code with no C variables allocated on the stack
(define (c-code str) (c-code/vars str (list))) (define (c:code str) (c:code/vars str (list)))
;; Append arg count to a C code pair ;; Append arg count to a C code pair
(define (c:tuple/args cp num-args) (define (c:tuple/args cp num-args)
@ -327,12 +328,12 @@
c-allocs)) c-allocs))
(define (c:append cp1 cp2) (define (c:append cp1 cp2)
(c-code/vars (c:code/vars
(string-append (c:body cp1) (c:body cp2)) (string-append (c:body cp1) (c:body cp2))
(append (c:allocs cp1) (c:allocs cp2)))) (append (c:allocs cp1) (c:allocs cp2))))
(define (c:append/prefix prefix cp1 cp2) (define (c:append/prefix prefix cp1 cp2)
(c-code/vars (c:code/vars
(string-append prefix (c:body cp1) (c:body cp2)) (string-append prefix (c:body cp1) (c:body cp2))
(append (c:allocs cp1) (c:allocs cp2)))) (append (c:allocs cp1) (c:allocs cp2))))
@ -390,7 +391,7 @@
((const? exp) (c-compile-const exp (alloca? ast-id trace) #f)) ;; TODO: OK to hardcode immutable to false here?? ((const? exp) (c-compile-const exp (alloca? ast-id trace) #f)) ;; TODO: OK to hardcode immutable to false here??
((prim? exp) ((prim? exp)
;; TODO: this needs to be more refined, probably w/a lookup table ;; TODO: this needs to be more refined, probably w/a lookup table
(c-code (string-append "primitive_" (mangle exp)))) (c:code (string-append "primitive_" (mangle exp))))
((ref? exp) (c-compile-ref exp)) ((ref? exp) (c-compile-ref exp))
((quote? exp) (c-compile-quote exp (alloca? ast-id trace))) ((quote? exp) (c-compile-quote exp (alloca? ast-id trace)))
((if? exp) (c-compile-if exp append-preamble cont ast-id trace cps?)) ((if? exp) (c-compile-if exp append-preamble cont ast-id trace cps?))
@ -436,7 +437,7 @@
(num-args 0) (num-args 0)
(create-cons (create-cons
(lambda (cvar a b) (lambda (cvar a b)
(c-code/vars (c:code/vars
(string-append (string-append
c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");" c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");"
(c-set-immutable-field cvar use-alloca immutable)) (c-set-immutable-field cvar use-alloca immutable))
@ -445,7 +446,7 @@
(lambda (args) (lambda (args)
(cond (cond
((null? args) ((null? args)
(c-code "NULL")) (c:code "NULL"))
((not (pair? args)) ((not (pair? args))
(c-compile-const args use-alloca immutable)) (c-compile-const args use-alloca immutable))
(else (else
@ -455,7 +456,7 @@
(c-compile-const (car args) use-alloca immutable) (c-compile-const (car args) use-alloca immutable)
(_c-compile-scalars (cdr args))))) (_c-compile-scalars (cdr args)))))
(set! num-args (+ 1 num-args)) (set! num-args (+ 1 num-args))
(c-code/vars (c:code/vars
(string-append addr-op cvar-name) (string-append addr-op cvar-name)
(append (append
(c:allocs cell) (c:allocs cell)
@ -484,7 +485,7 @@
(let ((idx-code (c-compile-const (vector-ref exp i) use-alloca immutable))) (let ((idx-code (c-compile-const (vector-ref exp i) use-alloca immutable)))
(loop (loop
(+ i 1) (+ i 1)
(c-code/vars (c:code/vars
;; The vector's C variable ;; The vector's C variable
(c:body code) (c:body code)
;; Allocations ;; Allocations
@ -498,7 +499,7 @@
";")))))))))) ";"))))))))))
(cond (cond
((zero? len) ((zero? len)
(c-code/vars (c:code/vars
(string-append addr-op cvar-name) ; Code is just the variable name (string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate empty vector (list ; Allocate empty vector
(string-append (string-append
@ -506,7 +507,7 @@
(c-set-immutable-field cvar-name use-alloca immutable))))) (c-set-immutable-field cvar-name use-alloca immutable)))))
(else (else
(let ((code (let ((code
(c-code/vars (c:code/vars
(string-append addr-op cvar-name) ; Code body is just var name (string-append addr-op cvar-name) ; Code body is just var name
(list ; Allocate the vector (list ; Allocate the vector
(string-append (string-append
@ -532,7 +533,7 @@
(let ((byte-val (number->string (bytevector-u8-ref exp i)))) (let ((byte-val (number->string (bytevector-u8-ref exp i))))
(loop (loop
(+ i 1) (+ i 1)
(c-code/vars (c:code/vars
;; The bytevector's C variable ;; The bytevector's C variable
(c:body code) (c:body code)
;; Allocations ;; Allocations
@ -545,7 +546,7 @@
";")))))))))) ";"))))))))))
(cond (cond
((zero? len) ((zero? len)
(c-code/vars (c:code/vars
(string-append addr-op cvar-name) ; Code is just the variable name (string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate empty vector (list ; Allocate empty vector
(string-append (string-append
@ -554,7 +555,7 @@
)))) ))))
(else (else
(let ((code (let ((code
(c-code/vars (c:code/vars
(string-append addr-op cvar-name) ; Code body is just var name (string-append addr-op cvar-name) ; Code body is just var name
(list ; Allocate the vector (list ; Allocate the vector
(string-append (string-append
@ -572,7 +573,7 @@
(use-alloca (use-alloca
(let ((tmp-name (mangle (gensym 'tmp))) (let ((tmp-name (mangle (gensym 'tmp)))
(blen (number->string (string-byte-length exp)))) (blen (number->string (string-byte-length exp))))
(c-code/vars (c:code/vars
(string-append "" cvar-name) ; Code is just the variable name (string-append "" cvar-name) ; Code is just the variable name
(list ; Allocate integer on the C stack (list ; Allocate integer on the C stack
(string-append (string-append
@ -595,7 +596,7 @@
use-alloca immutable) use-alloca immutable)
))))) )))))
(else (else
(c-code/vars (c:code/vars
(string-append "&" cvar-name) ; Code is just the variable name (string-append "&" cvar-name) ; Code is just the variable name
(list ; Allocate integer on the C stack (list ; Allocate integer on the C stack
(string-append (string-append
@ -623,7 +624,7 @@
(define (c-compile-const exp use-alloca immutable) (define (c-compile-const exp use-alloca immutable)
(cond (cond
((null? exp) ((null? exp)
(c-code "NULL")) (c:code "NULL"))
((pair? exp) ((pair? exp)
(c-compile-scalars exp use-alloca immutable)) (c-compile-scalars exp use-alloca immutable))
((vector? exp) ((vector? exp)
@ -635,7 +636,7 @@
(num2str (cond (num2str (cond
(else (else
(number->string exp))))) (number->string exp)))))
(c-code/vars (c:code/vars
(string-append "" cvar-name) ; Code is just the variable name (string-append "" cvar-name) ; Code is just the variable name
(list ; Allocate pointer on the C stack (list ; Allocate pointer on the C stack
(string-append (string-append
@ -656,14 +657,14 @@
(inum (num2str (imag-part exp))) (inum (num2str (imag-part exp)))
(addr-op (if use-alloca "" "&")) (addr-op (if use-alloca "" "&"))
(c-make-macro (if use-alloca "alloca_complex_num" "make_complex_num"))) (c-make-macro (if use-alloca "alloca_complex_num" "make_complex_num")))
(c-code/vars (c:code/vars
(string-append addr-op cvar-name) ; Code is just the variable name (string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate on the C stack (list ; Allocate on the C stack
(string-append (string-append
c-make-macro "(" cvar-name ", " rnum ", " inum ");"))))) c-make-macro "(" cvar-name ", " rnum ", " inum ");")))))
((and (integer? exp) ((and (integer? exp)
(exact? exp)) (exact? exp))
(c-code (string-append "obj_int2obj(" (c:code (string-append "obj_int2obj("
(number->string exp) ")"))) (number->string exp) ")")))
((real? exp) ((real? exp)
(let ((cvar-name (mangle (gensym 'c))) (let ((cvar-name (mangle (gensym 'c)))
@ -676,22 +677,22 @@
(number->string exp)))) (number->string exp))))
(addr-op (if use-alloca "" "&")) (addr-op (if use-alloca "" "&"))
(c-make-macro (if use-alloca "alloca_double" "make_double"))) (c-make-macro (if use-alloca "alloca_double" "make_double")))
(c-code/vars (c:code/vars
(string-append addr-op cvar-name) ; Code is just the variable name (string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate on the C stack (list ; Allocate on the C stack
(string-append (string-append
c-make-macro "(" cvar-name ", " num2str ");"))))) c-make-macro "(" cvar-name ", " num2str ");")))))
((boolean? exp) ((boolean? exp)
(c-code (string-append (c:code (string-append
(if exp "boolean_t" "boolean_f")))) (if exp "boolean_t" "boolean_f"))))
((char? exp) ((char? exp)
(c-code (string-append "obj_char2obj(" (c:code (string-append "obj_char2obj("
(number->string (char->integer exp)) ")"))) (number->string (char->integer exp)) ")")))
((string? exp) ((string? exp)
(c-compile-string exp use-alloca immutable)) (c-compile-string exp use-alloca immutable))
((symbol? exp) ((symbol? exp)
(allocate-symbol exp) (allocate-symbol exp)
(c-code (string-append "quote_" (mangle exp)))) (c:code (string-append "quote_" (mangle exp))))
(else (else
(error "unknown constant: " exp)))) (error "unknown constant: " exp))))
@ -783,7 +784,7 @@
(c-var-assign (c-var-assign
(lambda (type) (lambda (type)
(let ((cv-name (mangle (gensym 'c)))) (let ((cv-name (mangle (gensym 'c))))
(c-code/vars (c:code/vars
(string-append (string-append
(if (or (prim:cont? p) (if (or (prim:cont? p)
(equal? (prim/c-var-assign p) "object") (equal? (prim/c-var-assign p) "object")
@ -830,7 +831,7 @@
;; the logic ;; the logic
;; ;;
(let ((cv-name (mangle (gensym 'c)))) (let ((cv-name (mangle (gensym 'c))))
(c-code/vars (c:code/vars
(if (or (prim:allocates-object? p use-alloca?) (if (or (prim:allocates-object? p use-alloca?)
(prim->c-func-uses-alloca? p use-alloca?)) (prim->c-func-uses-alloca? p use-alloca?))
cv-name ; Already a pointer cv-name ; Already a pointer
@ -838,7 +839,7 @@
(list (list
(string-append c-func "(" cv-name tdata-comma tdata))))) (string-append c-func "(" cv-name tdata-comma tdata)))))
(else (else
(c-code/vars (c:code/vars
(string-append c-func "(" tdata tptr-comma tptr) (string-append c-func "(" tdata tptr-comma tptr)
(list tptr-decl)))))) (list tptr-decl))))))
@ -869,7 +870,7 @@
;; c-compile-ref : ref-exp -> string ;; c-compile-ref : ref-exp -> string
(define (c-compile-ref exp) (define (c-compile-ref exp)
(c-code (c:code
(if (member exp *global-syms*) (if (member exp *global-syms*)
(cgen:mangle-global exp) (cgen:mangle-global exp)
(mangle exp)))) (mangle exp))))
@ -882,7 +883,7 @@
(lambda (args append-preamble prefix cont) (lambda (args append-preamble prefix cont)
(cond (cond
((not (pair? args)) ((not (pair? args))
(c-code "")) (c:code ""))
(else (else
;; (trace:debug `(c-compile-args ,(car args))) ;; (trace:debug `(c-compile-args ,(car args)))
(let ((cp (c-compile-exp (car args) (let ((cp (c-compile-exp (car args)
@ -929,7 +930,7 @@
cps?)) cps?))
(num-cargs (c:num-args cgen))) (num-cargs (c:num-args cgen)))
(set-c-call-arity! num-cargs) (set-c-call-arity! num-cargs)
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cgen)) (c:allocs->str (c:allocs cgen))
"return_direct" (number->string num-cargs) "return_direct" (number->string num-cargs)
@ -978,7 +979,7 @@
parent-args parent-args
cgen-lis)))) cgen-lis))))
;;(trace:info `(loop ,args ,(cadr args) ,cgen-lis ,parent-args)) ;;(trace:info `(loop ,args ,(cadr args) ,cgen-lis ,parent-args))
(c-code (c:code
(string-append (string-append
cgen-allocs ; (c:allocs->str (c:allocs cgen)) cgen-allocs ; (c:allocs->str (c:allocs cgen))
"\n" "\n"
@ -987,17 +988,18 @@
"continue;")))) "continue;"))))
((eq? 'Cyc-foreign-code fun) ((eq? 'Cyc-foreign-code fun)
(c-code/vars (c:code/vars
(string-append (string-append
"") "")
args)) args))
((eq? 'Cyc-foreign-value fun) ((eq? 'Cyc-foreign-value fun)
;; TODO: take type into account, do not hardcode int (c->scm (car args) (cadr args))
(c-code/vars ;(c:code/vars
(string-append ; (string-append
"obj_int2obj(" (car args) ")") ; "obj_int2obj(" (car args) ")")
(list))) ; (list))
)
((prim? fun) ((prim? fun)
(let* ((c-fun (let* ((c-fun
@ -1010,7 +1012,7 @@
(number->string num-args) (number->string num-args)
(if (> num-args 0) "," ""))) (if (> num-args 0) "," "")))
(c-args* (if (prim:arg-count? fun) (c-args* (if (prim:arg-count? fun)
(c:append (c-code num-args-str) c-args) (c:append (c:code num-args-str) c-args)
c-args))) c-args)))
;; Emit symbol when mutating global variables, so we can look ;; Emit symbol when mutating global variables, so we can look
;; up the cvar ;; up the cvar
@ -1029,7 +1031,7 @@
(if (prim/cvar? fun) (if (prim/cvar? fun)
;; Args need to go with alloc function ;; Args need to go with alloc function
(c-code/vars (c:code/vars
(c:body c-fun) (c:body c-fun)
(append (append
(c:allocs c-args*) ; fun alloc depends upon arg allocs (c:allocs c-args*) ; fun alloc depends upon arg allocs
@ -1055,12 +1057,12 @@
(and (prim:udf? fun) (and (prim:udf? fun)
(zero? num-args))) (zero? num-args)))
c-fun c-fun
(c:append c-fun (c-code ", ")))) (c:append c-fun (c:code ", "))))
c-args*) c-args*)
(c-code ")"))))) (c:code ")")))))
((equal? '%closure-ref fun) ((equal? '%closure-ref fun)
(c-code (apply string-append (list (c:code (apply string-append (list
(c-compile-closure-element-ref (c-compile-closure-element-ref
ast-id ast-id
(car args) (car args)
@ -1082,7 +1084,7 @@
(num-cargs (c:num-args cargs))) (num-cargs (c:num-args cargs)))
(cond (cond
((not cps?) ((not cps?)
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1138,7 +1140,7 @@
(string-append " " p " = " tmp "; ")) (string-append " " p " = " tmp "; "))
params tmp-params)))) params tmp-params))))
;; (trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs))) ;; (trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs)))
(c-code/vars (c:code/vars
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1163,7 +1165,7 @@
(let* ((lid (ast:lambda-id wkf)) (let* ((lid (ast:lambda-id wkf))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid))) (c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
(c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid)))) (c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid))))
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1184,7 +1186,7 @@
((and wkf fnc) ((and wkf fnc)
(let* ((lid (ast:lambda-id wkf)) (let* ((lid (ast:lambda-id wkf))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))) (c-lambda-fnc-str (string-append "__lambda_" (number->string lid))))
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1197,7 +1199,7 @@
(c:body cargs) (c:body cargs)
");")))) ");"))))
(else (else
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1217,7 +1219,7 @@
(num-cargs (c:num-args cargs))) (num-cargs (c:num-args cargs)))
(cond (cond
((not cps?) ((not cps?)
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1237,7 +1239,7 @@
(let* ((lid (ast:lambda-id (closure->lam fun))) (let* ((lid (ast:lambda-id (closure->lam fun)))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid))) (c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
(c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid)))) (c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid))))
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1254,7 +1256,7 @@
((adbf:well-known fnc) ((adbf:well-known fnc)
(let* ((lid (ast:lambda-id (closure->lam fun))) (let* ((lid (ast:lambda-id (closure->lam fun)))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))) (c-lambda-fnc-str (string-append "__lambda_" (number->string lid))))
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1267,7 +1269,7 @@
(c:body cargs) (c:body cargs)
");")))) ");"))))
(else (else
(c-code (c:code
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
@ -1284,25 +1286,25 @@
;; Join expressions; based on c:append ;; Join expressions; based on c:append
(let ((cp1 (if (ref? expr) (let ((cp1 (if (ref? expr)
;; Ignore lone ref to avoid C warning ;; Ignore lone ref to avoid C warning
(c-code/vars "" '()) (c:code/vars "" '())
(c-compile-exp expr append-preamble cont ast-id trace cps?))) (c-compile-exp expr append-preamble cont ast-id trace cps?)))
(cp2 acc)) (cp2 acc))
(c-code/vars (c:code/vars
(let ((cp1-body (c:body cp1))) (let ((cp1-body (c:body cp1)))
(if (zero? (string-length cp1-body)) (if (zero? (string-length cp1-body))
(c:body cp2) ; Ignore cp1 if necessary (c:body cp2) ; Ignore cp1 if necessary
(string-append cp1-body ";" (c:body cp2)))) (string-append cp1-body ";" (c:body cp2))))
(append (c:allocs cp1) (c:allocs cp2))))) (append (c:allocs cp1) (c:allocs cp2)))))
(c-code "") (c:code "")
args))) args)))
exps)) exps))
((equal? 'Cyc-local-set! fun) ((equal? 'Cyc-local-set! fun)
;:(trace:error `(JAE DEBUG Cyc-local-set ,exp)) ;:(trace:error `(JAE DEBUG Cyc-local-set ,exp))
(let ((val-exp (c-compile-exp (caddr exp) append-preamble cont ast-id trace cps?))) (let ((val-exp (c-compile-exp (caddr exp) append-preamble cont ast-id trace cps?)))
(c-code/vars (c:code/vars
(string-append (mangle (cadr exp)) " = " (c:body val-exp) ";") (string-append (mangle (cadr exp)) " = " (c:body val-exp) ";")
(c:allocs val-exp))) (c:allocs val-exp)))
;; (c-code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";")) ;; (c:code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";"))
) )
((equal? 'let fun) ((equal? 'let fun)
(let* ((vars/vals (cadr exp)) (let* ((vars/vals (cadr exp))
@ -1314,14 +1316,14 @@
(let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?)) (let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?))
(cp2 acc)) (cp2 acc))
(set-use-alloca! #f) ; Revert flag (set-use-alloca! #f) ; Revert flag
(c-code/vars (c:code/vars
(let ((cp1-body (c:body cp1))) (let ((cp1-body (c:body cp1)))
(string-append cp1-body ";" (c:body cp2))) (string-append cp1-body ";" (c:body cp2)))
(append (append
(list (string-append "object " (mangle (car var/val)) ";")) (list (string-append "object " (mangle (car var/val)) ";"))
(c:allocs cp1) (c:allocs cp1)
(c:allocs cp2))))) (c:allocs cp2)))))
(c-code "") (c:code "")
vars/vals)) vars/vals))
(body-exp (c-compile-exp (body-exp (c-compile-exp
body append-preamble cont ast-id trace cps?))) body append-preamble cont ast-id trace cps?)))
@ -1337,7 +1339,7 @@
(test (compile (if->condition exp))) (test (compile (if->condition exp)))
(then (compile (if->then exp))) (then (compile (if->then exp)))
(els (compile (if->else exp)))) (els (compile (if->else exp))))
(c-code (string-append (c:code (string-append
(c:allocs->str (c:allocs test) " ") (c:allocs->str (c:allocs test) " ")
"if( (boolean_f != " "if( (boolean_f != "
(c:body test) (c:body test)
@ -1405,7 +1407,7 @@
#f ; inline, so disable CPS on this pass #f ; inline, so disable CPS on this pass
))) )))
(c-code/vars "" (list "")))) (c:code/vars "" (list ""))))
(define (c-compile-raw-global-lambda exp append-preamble cont trace . cps?) (define (c-compile-raw-global-lambda exp append-preamble cont trace . cps?)
(let* ((precompiled-sym (let* ((precompiled-sym
@ -1447,14 +1449,14 @@
(define->var exp) (define->var exp)
#t ; (lambda? body) #t ; (lambda? body)
(let ((cv-name (mangle (gensym 'c)))) (let ((cv-name (mangle (gensym 'c))))
(c-code/vars (c:code/vars
(string-append "&" cv-name) (string-append "&" cv-name)
(list (list
(string-append "mclosure0(" cv-name ", (function_type)__lambda_" (string-append "mclosure0(" cv-name ", (function_type)__lambda_"
(number->string lid) ");" cv-name ".num_args = " (number->string lid) ");" cv-name ".num_args = "
(number->string num-args) (number->string num-args)
";"))))) ";")))))
(c-code/vars "" (list "")))) (c:code/vars "" (list ""))))
;; Symbol compilation ;; Symbol compilation
@ -1655,7 +1657,7 @@
(create-object (lambda () (create-object (lambda ()
;; JAE - this is fine, now need to handle other side (actually reading the value without a closure obj ;; JAE - this is fine, now need to handle other side (actually reading the value without a closure obj
;; (trace:error `(create-object free-vars ,free-vars ,(car free-vars))) ;; (trace:error `(create-object free-vars ,free-vars ,(car free-vars)))
(c-code/vars (c:code/vars
(car free-vars) (car free-vars)
(list)))) (list))))
(create-nclosure (lambda () (create-nclosure (lambda ()
@ -1713,7 +1715,7 @@
(use-obj-instead-of-closure? (use-obj-instead-of-closure?
(create-object)) (create-object))
(else (else
(c-code/vars (c:code/vars
(if (and use-alloca? (if (and use-alloca?
(> (length free-vars) 0)) (> (length free-vars) 0))
cv-name cv-name
@ -1819,7 +1821,7 @@
"") ; No varargs, skip "") ; No varargs, skip
(c:serialize (c:serialize
(c:append (c:append
(c-code (c:code
;; Only trace when entering initial defined function ;; Only trace when entering initial defined function
(cond (cond
(has-closure? (has-closure?