Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-24 04:25:06 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions
cyclone/scheme/cyclone/cgen.sld
Justin Ethier 1f1b032641 Support alloca for all literals
2018-11-21 19:19:00 -05:00

2281 lines
84 KiB
Scheme
Raw Blame History

;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2016, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This module compiles scheme code to a Cheney-on-the-MTA C runtime.
;;;;
(define-library (scheme cyclone cgen)
(import (scheme base)
(scheme char)
(scheme complex)
(scheme eval)
(scheme inexact)
(scheme write)
(scheme cyclone primitives)
(scheme cyclone transforms)
(scheme cyclone ast)
(scheme cyclone cps-optimizations)
(scheme cyclone util)
(scheme cyclone libraries)
)
(export
mta:code-gen
autogen
autogen:defprimitives
autogen:primitive-procedures
;c-compile-program
emit
emit*
emits
emits*
emit-newline
;; Helpers
self-closure-call?
)
(inline
global-not-lambda?
global-lambda?
c:num-args
c:allocs
st:->var
)
(begin
(define *optimize-well-known-lambdas* #f)
(define (emit line)
(display line)
(newline))
(define (emit* . strs)
(for-each emits strs)
(newline))
(define (emits str)
(display str))
(define (emits* . strs)
(for-each emits strs))
(define (emit-newline)
(newline))
;; Escape chars in a C-string, so it can be safely written to a C file
(define (cstr:escape-chars str)
(letrec ((next (lambda (head tail)
(cond
((null? head) (list->string (reverse tail)))
((equal? (car head) #\")
(next (cdr head) (cons #\" (cons #\\ tail))))
((equal? (car head) #\\)
(next (cdr head) (cons #\\ (cons #\\ tail))))
((equal? (car head) #\newline)
(next (cdr head)
(cons #\n (cons #\\ tail))))
((equal? (car head) #\alarm)
(next (cdr head) (cons #\a (cons #\\ tail))))
((equal? (car head) #\backspace)
(next (cdr head) (cons #\b (cons #\\ tail))))
((equal? (car head) #\return)
(next (cdr head) (cons #\r (cons #\\ tail))))
((equal? (car head) #\tab)
(next (cdr head) (cons #\t (cons #\\ tail))))
(else
(next (cdr head) (cons (car head) tail)))))))
(next (string->list str) '())))
(define *c-main-function*
"int main(int argc, char **argv, char **envp)
{gc_thread_data *thd;
long stack_size = global_stack_size = STACK_SIZE;
long heap_size = global_heap_size = HEAP_SIZE;
mclosure0(clos_halt,&Cyc_halt); // Halt if final closure is reached
mclosure0(entry_pt,&c_entry_pt); // First function to execute
_cyc_argc = argc;
_cyc_argv = argv;
set_env_variables(envp);
gc_initialize();
thd = malloc(sizeof(gc_thread_data));
gc_thread_data_init(thd, 0, (char *) &stack_size, stack_size);
thd->gc_cont = &entry_pt;
thd->gc_args[0] = &clos_halt;
thd->gc_num_args = 1;
thd->thread_id = pthread_self();
gc_add_mutator(thd);
Cyc_heap_init(heap_size);
thd->thread_state = CYC_THREAD_STATE_RUNNABLE;
Cyc_start_trampoline(thd);
return 0;}")
;;; Auto-generation of C macros
(define *c-call-max-args* 128)
(define *c-call-arity* (make-vector (+ 1 *c-call-max-args*) #f))
(define (set-c-call-arity! arity)
(cond
((not (number? arity))
(error `(Non-numeric number of arguments received ,arity)))
((> arity *c-call-max-args*)
(error "Only support up to 128 arguments. Received: " arity))
(else
(vector-set! *c-call-arity* arity #t))))
(define (emit-c-arity-macros arity)
(when (<= arity *c-call-max-args*)
(cond
((or (= arity 1) (= arity 2)
(vector-ref *c-call-arity* arity))
(emit (c-macro-closcall arity))
(emit (c-macro-return-closcall arity))
(emit (c-macro-continue-or-gc arity))
(emit (c-macro-return-direct arity))
(emit (c-macro-return-direct-with-closure arity))
(when *optimize-well-known-lambdas*
(emit (c-macro-return-direct-with-object arity)))
)
)
(emit-c-arity-macros (+ arity 1))))
;; Generate macros to call a closures
(define (c-macro-return-closcall num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
(n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
;"/* Check for GC, then call given continuation closure */\n"
"#define return_closcall" n "(td, clo" args ") { \\\n"
" char top; \\\n"
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign "\\\n"
" GC(td, clo, buf, " n "); \\\n"
" return; \\\n"
" } else {\\\n"
" closcall" n "(td, (closure) (clo)" args "); \\\n"
" return;\\\n"
" } \\\n"
"}\n")))
;; Generate macros invoke a GC if necessary, otherwise do nothing.
;; This will be used to support C iteration.
(define (c-macro-continue-or-gc num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
(n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
;"/* Check for GC, then call given continuation closure */\n"
"#define continue_or_gc" n "(td, clo" args ") { \\\n"
" char *top = alloca(sizeof(char)); \\\n" ;; TODO: consider speeding up by passing in a var already allocated
" if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign "\\\n"
" GC(td, clo, buf, " n "); \\\n"
" return; \\\n"
" } else {\\\n"
" continue;\\\n"
" } \\\n"
"}\n")))
;; Generate macros to directly call a lambda function
(define (c-macro-return-direct num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
(n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
;"/* Check for GC, then call C function directly */\n"
"#define return_direct" n "(td, _fn" args ") { \\\n"
" char top; \\\n"
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign " \\\n"
" mclosure0(c1, (function_type) _fn); \\\n"
" GC(td, &c1, buf, " n "); \\\n"
" return; \\\n"
" } else { \\\n"
" (_fn)(td, " n ", (closure)_fn" args "); \\\n"
" }}\n")))
(define (c-macro-return-direct-with-closure num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
(n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
;"/* Check for GC, then call C function directly */\n"
"#define return_direct_with_clo" n "(td, clo, _fn" args ") { \\\n"
" char top; \\\n"
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign "\\\n"
" GC(td, clo, buf, " n "); \\\n"
" return; \\\n"
" } else { \\\n"
" (_fn)(td, " n ", (closure)(clo)" args "); \\\n"
" }}\n")))
;; Generate hybrid macros that can call a function directly but also receives
;; an object instead of a closure (closure optimized-out)
(define (c-macro-return-direct-with-object num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
(n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
;"/* Check for GC, then call C function directly */\n"
"#define return_direct_with_obj" n "(td, clo, _clo_fn, _fn" args ") { \\\n"
" char top; \\\n"
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign "\\\n"
" mclosure1(c1, (function_type) _clo_fn, clo); \\\n"
" GC(td, (closure)(&c1), buf, " n "); \\\n"
" return; \\\n"
" } else { \\\n"
" (_fn)(td, " n ", (closure)(clo)" args "); \\\n"
" }}\n")))
(define (c-macro-closcall num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
(n (number->string num-args))
(n-1 (number->string (if (> num-args 0) (- num-args 1) 0)))
(wrap (lambda (s) (if (> num-args 0) s ""))))
(string-append
"#define closcall" n "(td, clo" args ") \\\n"
(wrap (string-append "if (type_is_pair_prim(clo)) { \\\n"
" Cyc_apply(td, " n-1 ", (closure)(a1), clo" (if (> num-args 1) (substring args 3 (string-length args)) "") "); \\\n"
"}"))
(wrap " else { \\\n")
" ((clo)->fn)(td, " n ", clo" args ")"
(wrap ";\\\n}")
)))
(define (c-macro-n-prefix n prefix)
(if (> n 0)
(string-append
(c-macro-n-prefix (- n 1) prefix)
(string-append prefix (number->string n)))
""))
(define (c-macro-array-assign n prefix assign)
(if (> n 0)
(string-append
(c-macro-array-assign (- n 1) prefix assign)
prefix "[" (number->string (- n 1)) "] = "
assign (number->string n) ";")
""))
;;; Stack trace (call history) helpers
;; Add function to trace, if not already set
(define (st:add-function! trace fnc)
(if (null? (cdr trace))
(cons (car trace) fnc)
trace))
(define (st:->code trace)
(if (or (not (pair? trace))
(null? (cdr trace)))
""
(string-append
"Cyc_st_add(data, \""
(car trace)
":"
;; TODO: escape backslashes
(symbol->string (cdr trace))
"\");\n"
)))
(define (st:->var trace)
(cdr trace))
;; END st helpers
;;; Compilation routines.
;; Return generated code that also requests allocation of C variables on stack
(define (c-code/vars str cvars)
(list str
cvars))
;; Return generated code with no C variables allocated on the stack
(define (c-code str) (c-code/vars str (list)))
;; Append arg count to a C code pair
(define (c:tuple/args cp num-args)
(append cp (list num-args)))
;; Functions to work with data structures that contain C code:
;;
;; body - The actual body of C code
;; allocs - Allocations made by C code, eg "int c"
;; num-args - Number of function arguments combined in the tuple (optional)
;;
(define (c:body c-pair) (car c-pair))
(define (c:allocs c-pair) (cadr c-pair))
(define (c:num-args c-tuple) (caddr c-tuple))
(define (c:allocs->str c-allocs . prefix)
(foldr
(lambda (x y)
(string-append
(string-append
(if (null? prefix)
""
(car prefix))
x
"\n")
y))
""
c-allocs))
(define (c:allocs->str2 c-allocs prefix suffix)
(foldr
(lambda (x y)
(string-append
(string-append prefix x suffix)))
""
c-allocs))
(define (c:append cp1 cp2)
(c-code/vars
(string-append (c:body cp1) (c:body cp2))
(append (c:allocs cp1) (c:allocs cp2))))
(define (c:append/prefix prefix cp1 cp2)
(c-code/vars
(string-append prefix (c:body cp1) (c:body cp2))
(append (c:allocs cp1) (c:allocs cp2))))
(define (c:serialize cp prefix)
(string-append
(c:allocs->str (c:allocs cp) prefix)
prefix
(c:body cp)))
;; c-compile-program : exp -> string
(define (c-compile-program exp src-file)
(let* ((preamble "")
(append-preamble (lambda (s)
(set! preamble (string-append preamble " " s "\n"))))
(body (c-compile-exp exp append-preamble "cont" -1 (list src-file) #t)))
;(write `(DEBUG ,body))
(string-append
preamble
(c:serialize body " ") ;" ;\n"
; "int main (int argc, char* argv[]) {\n"
; " return 0;\n"
; " }\n"
)))
;; c-compile-exp : exp (string -> void) -> string
;;
;; exp - expression to compiler
;; append-preamble - ??
;; cont - name of the next continuation
;; this is experimental and probably needs refinement
;; ast-id - The AST lambda ID of the function containing the expression
;; trace - trace information. presently a pair containing:
;; * source file
;; * function name (or NULL if none)
;; cps? - Determine whether to compile using continuation passing style.
;; Normally this is always enabled, but sometimes a function has a
;; version that can be inlined (as an optimization), so this will
;; be set to false to change the type of compilation.
;; NOTE: this field is not passed everywhere because a lot of forms
;; require CPS, so this flag is not applicable to them.
(define (c-compile-exp exp append-preamble cont ast-id trace cps?)
(cond
; Special case - global function w/out a closure. Create an empty closure
((ast:lambda? exp)
(c-compile-exp
`(%closure ,exp)
append-preamble
cont
ast-id
trace
cps?))
; Core forms:
((const? exp) (c-compile-const exp (alloca? ast-id)))
((prim? exp)
;; TODO: this needs to be more refined, probably w/a lookup table
(c-code (string-append "primitive_" (mangle exp))))
((ref? exp) (c-compile-ref exp))
((quote? exp) (c-compile-quote exp (alloca? ast-id)))
((if? exp) (c-compile-if exp append-preamble cont ast-id trace cps?))
; IR (2):
((tagged-list? '%closure exp)
(c-compile-closure exp append-preamble cont ast-id trace cps?))
; Global definition
((define? exp)
(c-compile-global exp append-preamble cont trace))
((define-c? exp)
(c-compile-raw-global-lambda exp append-preamble cont trace))
; Application:
((app? exp) (c-compile-app exp append-preamble cont ast-id trace cps?))
(else (error "unknown exp in c-compile-exp: " exp))))
(define (c-compile-quote qexp use-alloca)
(let ((exp (cadr qexp)))
(c-compile-scalars exp use-alloca)))
(define (c-compile-scalars args use-alloca)
(letrec (
(addr-op (if use-alloca "" "&"))
;(deref-op (if use-alloca "->" "."))
(c-make-macro (if use-alloca "alloca_pair" "make_pair"))
(num-args 0)
(create-cons
(lambda (cvar a b)
(c-code/vars
(string-append c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");")
(append (c:allocs a) (c:allocs b))))
)
(_c-compile-scalars
(lambda (args)
(cond
((null? args)
(c-code "NULL"))
((not (pair? args))
(c-compile-const args use-alloca))
(else
(let* ((cvar-name (mangle (gensym 'c)))
(cell (create-cons
cvar-name
(c-compile-const (car args) use-alloca)
(_c-compile-scalars (cdr args)))))
(set! num-args (+ 1 num-args))
(c-code/vars
(string-append addr-op cvar-name)
(append
(c:allocs cell)
(list (c:body cell))))))))))
(c:tuple/args
(_c-compile-scalars args)
num-args)))
(define (c-compile-vector exp use-alloca)
(letrec ((cvar-name (mangle (gensym 'vec)))
(len (vector-length exp))
(addr-op (if use-alloca "" "&"))
(deref-op (if use-alloca "->" "."))
(c-make-macro (if use-alloca "alloca_empty_vector" "make_empty_vector"))
;; Generate code for each member of the vector
(loop
(lambda (i code)
(if (= i len)
code
(let ((idx-code (c-compile-const (vector-ref exp i) use-alloca)))
(loop
(+ i 1)
(c-code/vars
;; The vector's C variable
(c:body code)
;; Allocations
(append
(c:allocs code) ;; Vector alloc
(c:allocs idx-code) ;; Member alloc at index i
(list ;; Assign this member to vector
(string-append
cvar-name deref-op "elements[" (number->string i) "] = "
(c:body idx-code)
";")))))))))
)
(cond
((zero? len)
(c-code/vars
(string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate empty vector
(string-append
c-make-macro "(" cvar-name ");"))))
(else
(let ((code
(c-code/vars
(string-append addr-op cvar-name) ; Code body is just var name
(list ; Allocate the vector
(string-append
c-make-macro "(" cvar-name ");"
cvar-name deref-op "num_elements = " (number->string len) ";"
cvar-name deref-op "elements = (object *)alloca(sizeof(object) * "
(number->string len) ");")))))
(loop 0 code))))))
(define (c-compile-bytevector exp use-alloca)
(letrec ((cvar-name (mangle (gensym 'vec)))
(len (bytevector-length exp))
(addr-op (if use-alloca "" "&"))
(deref-op (if use-alloca "->" "."))
(c-make-macro (if use-alloca "alloca_empty_bytevector" "make_empty_bytevector"))
;; Generate code for each member of the vector
(loop
(lambda (i code)
(if (= i len)
code
(let ((byte-val (number->string (bytevector-u8-ref exp i))))
(loop
(+ i 1)
(c-code/vars
;; The bytevector's C variable
(c:body code)
;; Allocations
(append
(c:allocs code) ;; Vector alloc
(list ;; Assign this member to vector
(string-append
cvar-name deref-op "data[" (number->string i) "] = (unsigned char)"
byte-val
";"))))
))))
)
)
(cond
((zero? len)
(c-code/vars
(string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate empty vector
(string-append
c-make-macro "(" cvar-name ");"))))
(else
(let ((code
(c-code/vars
(string-append addr-op cvar-name) ; Code body is just var name
(list ; Allocate the vector
(string-append
c-make-macro "(" cvar-name ");"
cvar-name deref-op "len = " (number->string len) ";"
cvar-name deref-op "data = alloca(sizeof(char) * "
(number->string len) ");")))))
(loop 0 code))))))
(define (c-compile-string exp use-alloca)
(let ((cvar-name (mangle (gensym 'c))))
(cond
(use-alloca
(let ((tmp-name (mangle (gensym 'tmp)))
(blen (number->string (string-byte-length exp)))
)
(c-code/vars
(string-append "" cvar-name) ; Code is just the variable name
(list ; Allocate integer on the C stack
(string-append
"object " cvar-name ";\n "
"alloc_string(data,"
cvar-name
", "
blen
", "
(number->string (string-length exp))
");\n"
"char " tmp-name "[] = "
(->cstr exp)
";\n"
"memcpy(((string_type *)" cvar-name ")->str, " tmp-name "," blen ");\n"
"((string_type *)" cvar-name ")->str[" blen "] = '\\0';"
)))))
(else
(c-code/vars
(string-append "&" cvar-name) ; Code is just the variable name
(list ; Allocate integer on the C stack
(string-append
"make_utf8_string_with_len("
cvar-name
", "
(->cstr exp)
", "
(number->string (string-byte-length exp))
", "
(number->string (string-length exp))
");")))))))
;; c-compile-const : const-exp -> c-pair
;;
;; Typically this function is used to compile constant values such as
;; a single number, boolean, etc. However, it can be passed a quoted
;; item such as a list, to compile as a literal.
(define (c-compile-const exp use-alloca)
(cond
((null? exp)
(c-code "NULL"))
((pair? exp)
(c-compile-scalars exp use-alloca))
((vector? exp)
(c-compile-vector exp use-alloca))
((bytevector? exp)
(c-compile-bytevector exp use-alloca))
((bignum? exp)
(let ((cvar-name (mangle (gensym 'c)))
(num2str (cond
(else
(number->string exp)))))
(c-code/vars
(string-append "" cvar-name) ; Code is just the variable name
(list ; Allocate pointer on the C stack
(string-append
"alloc_bignum(data, " cvar-name "); "
;; TODO: need error checking, this is just a first cut:
"mp_read_radix(&bignum_value(" cvar-name "), \"" num2str "\", 10);"))))
)
((complex? exp)
(let* ((cvar-name (mangle (gensym 'c)))
(num2str (lambda (n)
(cond
;; The following two may not be very portable,
;; may be better to use C99:
((nan? n) "(0./0.)")
((infinite? n) "(1./0.)")
(else
(number->string n)))))
(rnum (num2str (real-part exp)))
(inum (num2str (imag-part exp)))
(addr-op (if use-alloca "" "&"))
(c-make-macro (if use-alloca "alloca_complex_num" "make_complex_num"))
)
(c-code/vars
(string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate on the C stack
(string-append
c-make-macro "(" cvar-name ", " rnum ", " inum ");")))))
((integer? exp)
(c-code (string-append "obj_int2obj("
(number->string exp) ")")))
((real? exp)
(let ((cvar-name (mangle (gensym 'c)))
(num2str (cond
;; The following two may not be very portable,
;; may be better to use C99:
((nan? exp) "(0./0.)")
((infinite? exp) "(1./0.)")
(else
(number->string exp))))
(addr-op (if use-alloca "" "&"))
(c-make-macro (if use-alloca "alloca_double" "make_double"))
)
(c-code/vars
(string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate on the C stack
(string-append
c-make-macro "(" cvar-name ", " num2str ");")))))
((boolean? exp)
(c-code (string-append
(if exp "boolean_t" "boolean_f"))))
((char? exp)
(c-code (string-append "obj_char2obj("
(number->string (char->integer exp)) ")")))
((string? exp)
(c-compile-string exp use-alloca))
;TODO: not good enough, need to store new symbols in a table so they can
;be inserted into the C program
((symbol? exp)
(allocate-symbol exp)
(c-code (string-append "quote_" (mangle exp))))
(else
(error "unknown constant: " exp))))
;; Convert a "scheme" string to a corresponding representation in C.
;; Keep in mind scheme strings can span lines, contain chars that
;; might not be allowed in C, etc.
(define (->cstr str)
(string-append "\"" (cstr:escape-chars str) "\""))
(define-c string-byte-length
"(void *data, int argc, closure _, object k, object s)"
" return_closcall1(data, k, Cyc_string_byte_length(data, s)); ")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Primitives
;; Does string end with the given substring?
;; EG: ("test(" "(") ==> #t
(define (str-ending? str end)
(let ((len (string-length str)))
(and (> len 0)
(equal? end (substring str (- len 1) len)))))
(define *use-alloca* #f)
(define (set-use-alloca! v)
(set! *use-alloca* v))
;; Use alloca() for stack allocations?
(define (alloca? ast-id)
(or *use-alloca*
(let ((adbf:fnc (adb:get/default ast-id #f)))
(and adbf:fnc
(adbf:calls-self? adbf:fnc)))))
;; c-compile-prim : prim-exp -> string -> string
(define (c-compile-prim p cont ast-id)
(let* ((use-alloca? (alloca? ast-id))
(c-func
(if (prim:udf? p)
(string-append
"((inline_function_type)
((closure)"
(cgen:mangle-global p)
")->fn)")
(prim->c-func p use-alloca?)))
;; Following closure defs are only used for prim:cont? to
;; create a new closure for the continuation, if needed.
;;
;; Each prim:cont? function is different in that it takes a continuation so that it can
;; allocate arbitrary data as needed using alloca, and then call into
;; the cont so allocations can remain on stack until GC.
(closure-sym (mangle (gensym 'c)))
(closure-def
(cond
((and (prim:cont? p)
(> (string-length cont) (string-length "__lambda_"))
(equal? (substring cont 0 9) "__lambda_"))
(string-append
"mclosure0(" closure-sym
"," cont "); "))
(else #f)))
;; END apply defs
(tdata (cond
((prim/data-arg? p) "data")
(else "")))
(tdata-comma (if (> (string-length tdata) 0) "," ""))
(tptr-type (prim/c-var-pointer p))
(tptr-comma
(cond
((and tptr-type use-alloca?) ",")
(tptr-type ",&")
(else "")))
(tptr (cond
(tptr-type (mangle (gensym 'local)))
(else "")))
(tptr-decl
(cond
((and tptr-type use-alloca?) (string-append "object " tptr " = alloca(sizeof(" tptr-type ")); "))
(tptr-type (string-append tptr-type " " tptr "; "))
(else "")))
(c-var-assign
(lambda (type)
(let ((cv-name (mangle (gensym 'c))))
(c-code/vars
(string-append
(if (or (prim:cont? p)
(equal? (prim/c-var-assign p) "object")
(prim/c-var-pointer p)) ;; Assume returns object
""
"&")
cv-name)
(list
(string-append
;; Define closure if necessary (apply only)
(cond
(closure-def closure-def)
(else ""))
;; Emit C variables
tptr-decl
type " " cv-name " = " c-func "("
;; Emit closure as first arg, if necessary (apply only)
(cond
(closure-def
(string-append
tdata
tptr-comma tptr
",&" closure-sym))
((prim:cont? p)
(string-append
tdata
tptr-comma tptr
","
cont))
(else
(string-append
tdata tptr-comma tptr))))))))))
(cond
((prim/c-var-assign p)
(c-var-assign (prim/c-var-assign p)))
((prim/cvar? p)
;;
;; TODO: look at functions that would actually fall into this
;; branch, I think they are just the macro's like list->vector???
;; may be able to remove this using prim:cont? and simplify
;; the logic
;;
(let ((cv-name (mangle (gensym 'c))))
(c-code/vars
(if (prim:allocates-object? p use-alloca?)
cv-name ;; Already a pointer
(string-append "&" cv-name)) ;; Point to data
(list
(string-append c-func "(" cv-name tdata-comma tdata)))))
(else
(c-code (string-append c-func "(" tdata))))))
;; END primitives
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; self-closure-call? :: sexp -> symbol -> integer -> boolean
;;
;; Determine whether we have a closure call of the form:
;; (%closure-ref
;; (cell-get (%closure-ref self$249 1))
;; 0)
;;
;; Parameters:
;; ast - S-expression to analyze
;; self - Identifier for the function's "self" closure
;; closure-index - Index of the function's "self" closure in outer closure
(define (self-closure-call? ast self closure-index)
;(trace:error `(JAE self-closure-call? ,ast ,self ,closure-index))
(and-let* (((tagged-list? '%closure-ref ast))
((tagged-list? 'cell-get (cadr ast)))
(inner-cref (cadadr ast))
((tagged-list? '%closure-ref inner-cref))
(equal? self (cadr inner-cref))
((equal? 0 (caddr ast)))
((equal? closure-index (caddr inner-cref)))
)
#t))
; c-compile-ref : ref-exp -> string
(define (c-compile-ref exp)
(c-code
(if (member exp *global-syms*)
(cgen:mangle-global exp)
(mangle exp))))
; c-compile-args : list[exp] (string -> void) -> string
(define (c-compile-args args append-preamble prefix cont ast-id trace cps?)
(letrec ((num-args 0)
(cp-lis '())
(_c-compile-args
(lambda (args append-preamble prefix cont)
(cond
((not (pair? args))
(c-code ""))
(else
;(trace:debug `(c-compile-args ,(car args)))
(let ((cp (c-compile-exp (car args)
append-preamble cont ast-id trace cps?)))
(set! num-args (+ 1 num-args))
(set! cp-lis (cons cp cp-lis))
(c:append/prefix
prefix
cp
(_c-compile-args (cdr args)
append-preamble ", " cont))))))))
;; Pass back a container with:
;; - Appened body (string)
;; - Appended allocs (string)
;; - Number of args (numeric)
;; - Remaining args - Actual CP objects (lists of body/alloc) from above
(append
(c:tuple/args
(_c-compile-args args
append-preamble prefix cont)
num-args)
(reverse cp-lis))))
;; c-compile-app : app-exp (string -> void) -> string
(define (c-compile-app exp append-preamble cont ast-id trace cps?)
;;(trace:info `(c-compile-app: ,exp ,trace))
(let (($tmp (mangle (gensym 'tmp))))
(let* ((args (app->args exp))
(fun (app->fun exp)))
(cond
((ast:lambda? fun)
(let* ((lid (allocate-lambda fun (c-compile-lambda fun trace #t))) ;; TODO: pass in free vars? may be needed to track closures
;; properly, wait until this comes up in an example
(this-cont (string-append "__lambda_" (number->string lid)))
(cgen
(c-compile-args
args
append-preamble
""
this-cont
ast-id
trace
cps?))
(num-cargs (c:num-args cgen)))
(set-c-call-arity! num-cargs)
(c-code
(string-append
(c:allocs->str (c:allocs cgen))
"return_direct" (number->string num-cargs)
"(data," this-cont
(if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
(c:body cgen) ");"))))
;; Direct recursive call of top-level function
((and (pair? trace)
(not (null? (cdr trace)))
(adbv:direct-rec-call? (adb:get (cdr trace)))
(tagged-list? '%closure-ref fun)
(equal? (cadr fun) (cdr trace)) ;; Needed?
(equal? (car args) (cdr trace))
;; Make sure continuation is not a lambda, because
;; that means a closure may be allocated
(ref? (cadr args))
)
(let* ((cgen-lis
(map
(lambda (e)
(c-compile-exp e append-preamble "" ast-id "" cps?))
(cddr args)) ;; Skip the closure
)
(cgen-allocs
(apply string-append
(map (lambda (a) (c:allocs->str (c:allocs a))) cgen-lis)))
(parent-fnc (adbv:assigned-value (adb:get (cdr trace))))
(parent-args
(cdr ;; Skip continuation
(ast:lambda-args
(if (pair? parent-fnc)
(car parent-fnc)
parent-fnc))))
(cgen-body
(apply
string-append
(map
(lambda (arg body-exp)
(string-append
(mangle arg)
" = "
(c:body body-exp)
";"
)
)
parent-args
cgen-lis)))
)
;;(trace:info `(loop ,args ,(cadr args) ,cgen-lis ,parent-args))
(c-code
(string-append
cgen-allocs ;(c:allocs->str (c:allocs cgen))
"\n"
cgen-body ;; TODO: (c:body cgen) ;; TODO: re-assign function args, longer-term using temp variables
"\n"
"continue;")))
)
((prim? fun)
(let* ((c-fun
(c-compile-prim fun cont ast-id))
(c-args
(c-compile-args args append-preamble "" "" ast-id trace cps?))
(num-args (length args))
(num-args-str
(string-append
(number->string num-args)
(if (> num-args 0) "," "")))
(c-args* (if (prim:arg-count? fun)
(c:append (c-code num-args-str) c-args)
c-args)))
(if (prim/cvar? fun)
;; Args need to go with alloc function
(c-code/vars
(c:body c-fun)
(append
(c:allocs c-args*) ;; fun alloc depends upon arg allocs
(list (string-append
(car (c:allocs c-fun))
(if (prim/c-var-assign fun)
;; Add a comma if there were any args to the func added by comp-prim
(if (or (str-ending? (car (c:allocs c-fun)) "(")
(prim:cont/no-args? fun)
(and (prim:udf? fun)
(zero? num-args)))
""
",")
",")
(c:body c-args*) ");"))))
;; Args stay with body
(c:append
(c:append
(let ()
;; Add a comma if necessary
(if (or (str-ending? (c:body c-fun) "(")
(prim:cont/no-args? fun))
c-fun
(c:append c-fun (c-code ", "))))
c-args*)
(c-code ")")))))
((equal? '%closure-ref fun)
(c-code (apply string-append (list
(c-compile-closure-element-ref
ast-id
(car args)
(number->string (- (cadr args) 1)))
;"("
;;; TODO: probably not the ideal solution, but works for now
;"(closureN)"
;(mangle (car args))
;")->elements["
;(number->string (- (cadr args) 1))"]"
))))
;; TODO: may not be good enough, closure app could be from an element
((tagged-list? '%closure-ref fun)
(let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont ast-id trace cps?))
(this-cont (c:body cfun))
(cargs (c-compile-args (cdr args) append-preamble " " this-cont ast-id trace cps?))
(raw-cargs (cdddr cargs)) ;; Same as above but with lists instead of appended strings
(num-cargs (c:num-args cargs)))
(cond
((not cps?)
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_copy(ptr,"
(c:body cargs)
");")))
(else
;;TODO: Consolidate with corresponding %closure code??
(set-c-call-arity! (c:num-args cargs))
(let* ((wkf (well-known-lambda (car args)))
(fnc (if wkf (adb:get/default (ast:lambda-id wkf) #f) #f))
(adbf:fnc (adb:get/default ast-id #f))
)
(cond
;; Handle recursive calls via iteration, if possible
((and adbf:fnc
;#f ;; TODO: temporarily disabled
(adbf:calls-self? adbf:fnc)
(self-closure-call?
fun
(car (adbf:all-params adbf:fnc))
(adbf:self-closure-index adbf:fnc)
)
)
(let* ((params (map mangle (cdr (adbf:all-params adbf:fnc))))
(args (map car raw-cargs))
(reassignments
;; TODO: may need to detect cases where an arg is reassigned before
;; another one is assigned to that arg's old value, for example:
;; a = 1, b = 2, c = a
;; In this case the code would need to assign to a temporary variable
(apply string-append
(map
(lambda (param arg)
(cond
((equal? param arg) "") ;; No need to reassign
(else
(string-append
param " = " arg ";\n"))))
params
args))))
;(trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs)))
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
reassignments
;; TODO: consider passing in a "top" instead of always calling alloca in macro below:
"continue_or_gc" (number->string (c:num-args cargs))
"(data,"
(mangle (car (adbf:all-params adbf:fnc))) ;; Call back into self after GC
(if (> (c:num-args cargs) 0) "," "")
(string-join params ", ")
");"
)))
)
((and wkf fnc
*optimize-well-known-lambdas*
(adbf:well-known fnc) ;; not really needed
(equal? (adbf:closure-size fnc) 1))
(let* ((lid (ast:lambda-id wkf))
(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-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_direct_with_obj" (number->string num-cargs)
"(data,"
this-cont
","
c-lambda-fnc-gc-ret-str
","
c-lambda-fnc-str
(if (> num-cargs 0) "," "")
(c:body cargs)
");"))
)
)
;; TODO: here and in other case, if well-known but closure size does not match, use
;; other macro to at least call out the __lambda_ function directly. seemed to
;; speed up C compile times (let's test that!)
;; ;;"#define return_direct_with_clo" n "(td, clo, _fn" args ") { \\\n"
((and wkf fnc)
(let* ((lid (ast:lambda-id wkf))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
)
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_direct_with_clo" (number->string num-cargs)
"(data,"
this-cont
","
c-lambda-fnc-str
(if (> num-cargs 0) "," "")
(c:body cargs)
");"))))
(else
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string (c:num-args cargs))
"(data,"
this-cont
(if (> (c:num-args cargs) 0) "," "")
(c:body cargs)
");")))))))))
((tagged-list? '%closure fun)
(let* ((cfun (c-compile-closure
fun append-preamble cont ast-id trace cps?))
(this-cont (string-append "(closure)" (c:body cfun)))
(cargs (c-compile-args
args append-preamble " " this-cont ast-id trace cps?))
(num-cargs (c:num-args cargs)))
(cond
((not cps?)
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_copy(ptr,"
(c:body cargs)
");")))
(else ;; CPS, IE normal behavior
(set-c-call-arity! num-cargs)
;TODO: see corresponding code in %closure-ref that outputs return_closcall.
;need to use (well-known-lambda) to check the ref to see if it is a WKL.
;if so, lookup ast and use cgen-id to map back to emit the lambda_gc_ret there
(with-fnc (ast:lambda-id (closure->lam fun)) (lambda (fnc)
(cond
((and *optimize-well-known-lambdas*
(adbf:well-known fnc)
(equal? (adbf:closure-size fnc) 1))
(let* ((lid (ast:lambda-id (closure->lam fun)))
(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-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_direct_with_obj" (number->string num-cargs)
"(data,"
this-cont
","
c-lambda-fnc-gc-ret-str
","
c-lambda-fnc-str
(if (> num-cargs 0) "," "")
(c:body cargs)
");"))
))
((adbf:well-known fnc)
(let* ((lid (ast:lambda-id (closure->lam fun)))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
)
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_direct_with_clo" (number->string num-cargs)
"(data,"
this-cont
","
c-lambda-fnc-str
(if (> num-cargs 0) "," "")
(c:body cargs)
");"))))
(else
(c-code
(string-append
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string num-cargs)
"(data,"
this-cont
(if (> num-cargs 0) "," "")
(c:body cargs)
");"))))))))))
((equal? 'Cyc-seq fun)
(let ((exps (foldr
(lambda (expr acc)
;; Join expressions; based on c:append
(let ((cp1 (if (ref? expr)
; Ignore lone ref to avoid C warning
(c-code/vars "" '())
(c-compile-exp expr append-preamble cont ast-id trace cps?)))
(cp2 acc))
(c-code/vars
(let ((cp1-body (c:body cp1)))
(if (zero? (string-length cp1-body))
(c:body cp2) ;; Ignore cp1 if necessary
(string-append cp1-body ";" (c:body cp2))))
(append (c:allocs cp1) (c:allocs cp2)))))
(c-code "")
args)))
exps))
((equal? 'Cyc-local-set! fun)
;:(trace:error `(JAE DEBUG Cyc-local-set ,exp))
(let ((val-exp (c-compile-exp (caddr exp) append-preamble cont ast-id trace cps?)))
(c-code/vars
(string-append (mangle (cadr exp)) " = " (c:body val-exp) ";")
(c:allocs val-exp)))
;(c-code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";"))
)
((equal? 'let fun)
(let* ((vars/vals (cadr exp))
(body (caddr exp))
(vexps (foldr
(lambda (var/val acc)
(set-use-alloca! #t) ;; Force alloca to ensure safe c stack allocs
;; Join expressions; based on c:append
(let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?))
(cp2 acc))
(set-use-alloca! #f) ;; Revert flag
(c-code/vars
(let ((cp1-body (c:body cp1)))
(string-append cp1-body ";" (c:body cp2)))
(append
(list (string-append "object " (mangle (car var/val)) ";"))
(c:allocs cp1)
(c:allocs cp2)))))
(c-code "")
vars/vals))
(body-exp (c-compile-exp
body append-preamble cont ast-id trace cps?))
)
;;(trace:error `(JAE DEBUG body ,body ,vars/vals ,exp))
(c:append vexps body-exp)
)
)
(else
(error `(Unsupported function application ,exp)))))))
; c-compile-if : if-exp -> string
(define (c-compile-if exp append-preamble cont ast-id trace cps?)
(let* ((compile (lambda (exp)
(c-compile-exp exp append-preamble cont ast-id trace cps?)))
(test (compile (if->condition exp)))
(then (compile (if->then exp)))
(els (compile (if->else exp))))
(c-code (string-append
(c:allocs->str (c:allocs test) " ")
"if( (boolean_f != "
(c:body test)
") ){ \n"
(c:serialize then " ")
"\n} else { \n"
(c:serialize els " ")
"}\n"))))
;; Global inlinable functions
(define *global-inlines* '())
(define (add-global-inline orig-sym inline-sym)
(set! *global-inlines* (cons (cons orig-sym inline-sym) *global-inlines*)))
;; Add a global inlinable function that is written in Scheme.
;; This is more challenging than define-c forms since the
;; code must be compiled again to work without CPS.
;(define *global-inline-scms* '())
;(define (add-global-inline-scm-lambda var-sym code)
; (add-global-inline var-sym )
; (set! *global-inline-scms*
; (cons (list var-sym code) *global-inline-scms*)))
;; Global compilation
(define *globals* '())
(define *global-syms* '())
(define (global-lambda? global) (cadr global))
(define (global-not-lambda? global) (not (cadr global)))
(define (add-global var-sym lambda? code)
;(write `(add-global ,var-sym ,code))
(set! *globals* (cons (list var-sym lambda? code) *globals*)))
(define (c-compile-global exp append-preamble cont trace)
(let ((var (define->var exp))
(body (if (equal? 4 (length exp)) ; Simple var assignment contains superfluous %closure-ref
(cadddr exp)
(car (define->exp exp)))))
(add-global
var
(ast:lambda? body)
(c-compile-exp
body append-preamble cont
(if (ast:lambda? body)
(ast:lambda-id body)
-1)
(st:add-function! trace var) #t))
;; Add inline global definition also, if applicable
; (trace:error `(JAE DEBUG ,var
; ,(lambda? body)
; ,(define-c->inline-var exp)
; ,(prim:udf? (define-c->inline-var exp))
; ))
(when (and (ast:lambda? body)
(prim:udf? (define-c->inline-var exp)))
(add-global-inline
var
(define-c->inline-var exp))
(add-global
(define-c->inline-var exp)
#t ;; always a lambda
(c-compile-exp
body append-preamble cont
(ast:lambda-id body)
(st:add-function! trace var)
#f ;; inline, so disable CPS on this pass
)
))
(c-code/vars "" (list ""))))
(define (c-compile-raw-global-lambda exp append-preamble cont trace . cps?)
(let* ((precompiled-sym
(if (equal? cps? '(#f))
'precompiled-inline-lambda
'precompiled-lambda))
(lambda-data
`(,precompiled-sym
,(caddr exp) ;; Args
,(cadddr exp) ;; Body
))
(lid (allocate-lambda #f lambda-data))
(total-num-args
(let ((count 1)) ;; Start at 1 because there will be one less comma than args
(string-for-each
(lambda (c)
(if (equal? #\, c) (set! count (+ count 1))))
(caddr exp))
count)) ;; args
;; Subtract "internal" args added for runtime
(num-args
(- total-num-args 4))
)
;; Is the function also defined inline?
;(trace:error `(JAE define-c ,exp))
(cond
((> (length exp) 4)
;(trace:error `(JAE define-c inline detected))
(let ((fnc-sym
(define-c->inline-var exp)))
;(trace:error `(JAE define-c inline detected ,fnc-sym))
(add-global-inline (define->var exp) fnc-sym)
(c-compile-raw-global-lambda
`(define-c ,fnc-sym ,@(cddddr exp))
append-preamble
cont
trace
#f)))) ;; Inline this one; CPS will not be used
;; Add this define-c
(add-global
(define->var exp)
#t ;(lambda? body)
(let ((cv-name (mangle (gensym 'c))))
(c-code/vars
(string-append "&" cv-name)
(list
(string-append "mclosure0(" cv-name ", (function_type)__lambda_"
(number->string lid) ");" cv-name ".num_args = "
(number->string num-args)
";")))
)
)
(c-code/vars "" (list ""))))
;; Symbol compilation
(define *symbols* '())
(define (allocate-symbol sym)
(if (not (member sym *symbols*))
;(not (Cyc-reserved-symbol? sym)))
(set! *symbols* (cons sym *symbols*))))
;; Lambda compilation.
;; Lambdas get compiled into procedures that,
;; once given a C name, produce a C function
;; definition with that name.
;; These procedures are stored up and eventually
;; emitted.
; type lambda-id = natural
; num-lambdas : natural
(define num-lambdas 0)
; lambdas : alist[lambda-id,string -> string]
(define lambdas '())
(define inline-lambdas '())
;; allocate-lambda : (Either ast:lambda boolean) -> (string -> string) -> integer
;; Create/store/return a unique lambda-id for the given function.
(define (allocate-lambda ast:lam lam . cps?)
(let ((id num-lambdas))
(cond
((and ast:lam (not (equal? cps? '(#f))))
(set! id (ast:lambda-id ast:lam)))
(else
(set! num-lambdas (+ 1 num-lambdas))))
(set! lambdas (cons (list id lam ast:lam) lambdas))
(if (equal? cps? '(#f))
(set! inline-lambdas (cons id inline-lambdas)))
;(when ast:lam
; (with-fnc! (ast:lambda-id ast:lam) (lambda (fnc)
; (adbf:set-cgen-id! fnc id))))
id))
; get-lambda : lambda-id -> (symbol -> string)
;(define (get-lambda id)
; (cdr (assv id lambdas)))
(define (lambda->env exp)
(let ((formals (ast:lambda-formals->list exp)))
(if (pair? formals)
(car formals)
'unused)))
; (tmp-ident (if (> (length (lambda-formals->list exp)) 0)
; (mangle (if (pair? (lambda->formals exp))
; (car (lambda->formals exp))
; (lambda->formals exp)))
; ""))
; (has-closure?
; (and
; (> (string-length tmp-ident) 3)
; (equal? "self" (substring tmp-ident 0 4))))
;; Compute the minimum number of arguments a function expects.
;; Note this must be the count before additional closure/CPS arguments
;; are added, so we need to detect those and not include them.
(define (compute-num-args lam)
(let ((count (ast:lambda-num-args lam))) ;; Current arg count, may be too high
(cond
((< count 0) -1) ;; Unlimited
(else
(let ((formals (ast:lambda-formals->list lam)))
(- count
(if (fl/closure? formals) 1 0)
(if (fl/cont? formals) 1 0)))))))
;; Minimum number of required arguments for a lambda
(define (ast:lambda-num-args exp)
(let ((type (ast:lambda-formals-type exp))
(num (length (ast:lambda-formals->list exp))))
(cond
((equal? type 'args:varargs)
-1) ;; Unlimited
((equal? type 'args:fixed-with-varargs)
(- num 1)) ;; Last arg is optional
(else
num))))
;; Formal list with a closure?
(define (fl/closure? lis)
(cond
((null? lis) #f)
(else
(let ((arg (symbol->string (car lis))))
(and
(> (string-length arg) 4)
(equal? "self$" (substring arg 0 5)))))))
;; Formal list with a continuation (k)?
(define (fl/cont? lis)
(let ((check (lambda (lis)
(cond
((null? lis) #f)
(else
(let ((arg (symbol->string (car lis))))
(and
(> (string-length arg) 1)
(equal? "k$" (substring arg 0 2)))))))))
;; Find the cont arg; if there is a closure it is always first
(if (fl/closure? lis)
(check (cdr lis))
(check lis))))
;; c-compile-closure-element-ref :: integer -> symbol -> integer -> string
;;
;; Compile a reference to an element of a closure.
(define (c-compile-closure-element-ref ast-id var idx)
(with-fnc ast-id (lambda (fnc)
;(trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc))
(cond
((and *optimize-well-known-lambdas*
(adbf:well-known fnc)
;(pair? (adbf:all-params fnc))
(equal? (adbf:closure-size fnc) 1))
(mangle (car (adbf:all-params fnc))))
(else
(string-append
"((closureN)" (mangle var) ")->elements[" idx "]"))))))
;; Analyze closure members and assign index of the function's "self" closure, if found
;; Parameters:
;; ast-fnc - Function to check for, in AST lambda form
;; closure-args - Members of the closure to scan
(define (find-closure-assigned-var-index! ast-fnc closure-args)
(let ((index 0)
(fnc (adb:get/default (ast:lambda-id ast-fnc) #f)))
;(trace:info `(find-closure-assigned-var-index! ,ast-fnc ,fnc ,closure-args))
(cond
((and fnc
(pair? (adbf:assigned-to-var fnc)))
(for-each
(lambda (arg)
(when (and (ref? arg) (member arg (adbf:assigned-to-var fnc)))
;(trace:error `(JAE closure for ,(ast:lambda-id ast-fnc) self ref is index ,index))
(adbf:set-self-closure-index! fnc index)
(adb:set! (ast:lambda-id ast-fnc) fnc)
)
(set! index (+ index 1))
)
closure-args)
)
(else #f))))
;; c-compile-closure : closure-exp (string -> void) -> string
;;
;; This function compiles closures generated earlier in the
;; compilation process. Each closure is of the form:
;;
;; (%closure lambda arg ...)
;;
;; Where:
;; - `%closure` is the identifying tag
;; - `lambda` is the function to execute
;; - Each `arg` is a free variable that must be stored within
;; the closure. The closure conversion phase tags each access
;; to one with the corresponding index so `lambda` can use them.
;;
(define (c-compile-closure exp append-preamble cont ast-id trace cps?)
(find-closure-assigned-var-index! (closure->lam exp) (cdr exp))
(let* ((lam (closure->lam exp))
(use-alloca? (alloca? ast-id))
(free-vars
(map
(lambda (free-var)
(if (tagged-list? '%closure-ref free-var)
(let ((var (cadr free-var))
(idx (number->string (- (caddr free-var) 1))))
(c-compile-closure-element-ref ast-id var idx)
;(string-append
; "((closureN)" (mangle var) ")->elements[" idx "]")
)
(mangle free-var)))
(closure->fv exp))) ; Note these are not necessarily symbols, but in cc form
(cv-name (mangle (gensym 'c)))
(lid (allocate-lambda lam (c-compile-lambda lam trace cps?) cps?))
(use-obj-instead-of-closure?
(with-fnc (ast:lambda-id lam) (lambda (fnc)
(and *optimize-well-known-lambdas*
(adbf:well-known fnc) ;; Only optimize well-known functions
;(equal? (length free-vars) 1) ;; Sanity check
(equal? (adbf:closure-size fnc) 1) ;; From closure conv
))))
(macro? (assoc (st:->var trace) (get-macros)))
(call/cc? (and (equal? (car trace) "scheme/base.sld")
(equal? (st:->var trace) 'call/cc)))
(num-args-str
(if call/cc?
"1" ;; Special case, need to change runtime checks for call/cc
(number->string (compute-num-args lam))))
(create-object (lambda ()
;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)))
(c-code/vars
(car free-vars)
(list))))
(create-nclosure (lambda ()
(let ((decl (if use-alloca?
(string-append "closureN_type * " cv-name " = alloca(sizeof(closureN_type));\n")
(string-append "closureN_type " cv-name ";\n")))
(sep (if use-alloca? "->" "."))
)
(string-append
decl
;; Not ideal, but one more special case to type check call/cc
(if call/cc? "Cyc_check_proc(data, f);\n" "")
cv-name sep "hdr.mark = gc_color_red;\n "
cv-name sep "hdr.grayed = 0;\n"
cv-name sep "tag = closureN_tag;\n "
cv-name sep "fn = (function_type)__lambda_" (number->string lid) ";\n"
cv-name sep "num_args = " num-args-str ";\n"
cv-name sep "num_elements = " (number->string (length free-vars)) ";\n"
cv-name sep "elements = (object *)alloca(sizeof(object) * "
(number->string (length free-vars)) ");\n"
(let loop ((i 0)
(vars free-vars))
(if (null? vars)
""
(string-append
cv-name sep "elements[" (number->string i) "] = "
(car vars) ";\n"
(loop (+ i 1) (cdr vars)))))))))
(create-mclosure (lambda ()
(let ((prefix
(if macro?
"mmacro"
(string-append
"mclosure"
(number->string (length free-vars))))))
(string-append
prefix
"(" cv-name ", "
;; NOTE:
;; Hopefully will not cause issues with varargs when casting to
;; generic function type below. Works fine in gcc, not sure if
;; this is portable to other compilers though
"(function_type)__lambda_" (number->string lid)
(if (> (length free-vars) 0) "," "")
(string-join free-vars ", ")
");"
cv-name ".num_args = " (number->string (compute-num-args lam)) ";"
)))))
;(trace:info (list 'JAE-DEBUG trace macro?))
(cond
(use-obj-instead-of-closure?
(create-object))
(else
(c-code/vars
(if (and use-alloca?
(> (length free-vars) 0))
cv-name
(string-append "&" cv-name))
(list
(if (> (length free-vars) 0)
(create-nclosure)
(create-mclosure))))))))
; c-compile-formals : list[symbol] -> string
(define (c-compile-formals formals type)
(cond
((and (not (pair? formals))
(equal? type 'args:varargs))
(string-append "object " (mangle formals) "_raw, ..."))
((not (pair? formals))
"")
(else
(string-append
"object "
(mangle (car formals))
(cond
((pair? (cdr formals))
(string-append ", " (c-compile-formals (cdr formals) type)))
((not (equal? 'args:fixed type))
(string-append ", object " (mangle (cdr formals)) "_raw, ..."))
(else
""))))))
; c-compile-lambda : lamda-exp (string -> void) -> (string -> string)
(define (c-compile-lambda exp trace cps?)
(let* ((preamble "")
(append-preamble (lambda (s)
(set! preamble (string-append preamble " " s "\n")))))
(let* ((formals (c-compile-formals
(if (not cps?)
;; Ignore continuation (k) arg for non-CPS funcs
(cdr (ast:lambda-args exp))
(ast:lambda-args exp))
(ast:lambda-formals-type exp)))
(tmp-ident (if (> (length (ast:lambda-formals->list exp)) 0)
(mangle (if (pair? (ast:lambda-args exp))
(car (ast:lambda-args exp))
(ast:lambda-args exp)))
""))
(return-type
(if cps? "void" "object"))
(arg-argc (if cps? "int argc, " ""))
(arg-closure
(if cps?
"closure _"
"object ptr"))
(has-closure?
(and
(> (string-length tmp-ident) 3)
(equal? "self" (substring tmp-ident 0 4))))
(has-loop?
(or
(adbf:calls-self? (adb:get/default (ast:lambda-id exp) (adb:make-fnc)))
;; Older direct recursive logic
(and (not has-closure?) ;; Only top-level functions for now
(pair? trace)
(not (null? (cdr trace)))
(adbv:direct-rec-call? (adb:get (cdr trace))))
)
)
(formals*
(string-append
(if has-closure?
""
(if (equal? "" formals)
arg-closure
(string-append arg-closure ",")))
formals))
(env-closure (lambda->env exp))
(body (c-compile-exp
(car (ast:lambda-body exp)) ;; car ==> assume single expr in lambda body after CPS
append-preamble
(mangle env-closure)
(ast:lambda-id exp)
trace
cps?)))
(cons
(lambda (name)
(string-append "static " return-type " " name
"(void *data, " arg-argc
formals*
") {\n"
preamble
(if (ast:lambda-varargs? exp)
;; Load varargs from C stack into Scheme list
(string-append
; DEBUGGING:
;"printf(\"%d %d\\n\", argc, "
; (number->string (length (ast:lambda-formals->list exp))) ");"
"load_varargs("
(mangle (ast:lambda-varargs-var exp))
", "
(mangle (ast:lambda-varargs-var exp))
"_raw, argc - " (number->string
(- (length (ast:lambda-formals->list exp))
1
(if has-closure? 1 0)))
");\n");
"") ; No varargs, skip
(c:serialize
(c:append
(c-code
;; Only trace when entering initial defined function
(cond
(has-closure?
(if has-loop? "\n while(1) {\n" "")
)
(else
(string-append
(st:->code trace)
(if has-loop? "\n while(1) {\n" "")
))))
body)
" ")
"; \n"
(if has-loop? "}\n" "")
"}\n"))
formals*))))
(define cgen:mangle-global #f)
(define (ast:lambda-varargs-var exp)
(if (ast:lambda-varargs? exp)
(if (equal? (ast:lambda-formals-type exp) 'args:varargs)
(ast:lambda-args exp) ; take symbol directly
(car (reverse (ast:lambda-formals->list exp)))) ; Last arg is varargs
#f))
(define (ast:lambda-varargs? exp)
(let ((type (ast:lambda-formals-type exp)))
(or (equal? type 'args:varargs)
(equal? type 'args:fixed-with-varargs))))
;; Convert a library name to string, so it can be
;; appended to the identifiers it exports.
(define (import->string import)
(foldr (lambda (id s)
(string-append "_" (mangle id) s))
""
(lib:list->import-set import)))
;; Identifier exported by another library
(define (mangle-exported-ident import-db ident error?)
(let ((idb-entry (lib:idb:lookup import-db ident)))
(cond
((not idb-entry)
(if error?
(error `(Unable to find a library importing ,ident))
#f))
(else
(let ((suffix (import->string
(lib:idb:entry->library-name idb-entry)))
(prefix (mangle-global
(lib:idb:entry->library-id idb-entry))))
(string-append prefix suffix))))))
(define (mta:code-gen input-program
program?
lib-name
lib-pass-thru-exports
import-db
globals
c-headers
required-libs
src-file)
(set! *global-syms* (append globals (lib:idb:ids import-db)))
(set! num-lambdas (+ (adb:max-lambda-id) 1))
(set! cgen:mangle-global
(lambda (ident)
(cond
;; Do not perform additional mangling for top-level globals
((and program?
(member ident globals))
(mangle-global ident))
;; Identifier exported by the library being compiled
((or (member ident globals)
(member ident lib-pass-thru-exports))
(let ((suffix (import->string lib-name))
(prefix (mangle-global ident)))
(string-append prefix suffix)))
;; Identifier exported by another library
(else
(let ((idb-entry (lib:idb:lookup import-db ident)))
(cond
((not idb-entry)
(error `(Unable to find a library importing ,ident)))
(else
(let ((suffix (import->string
(lib:idb:entry->library-name idb-entry)))
(prefix (mangle-global
(lib:idb:entry->library-id idb-entry))))
(string-append prefix suffix)))))))))
(let ((compiled-program-lst '())
(compiled-program #f))
;; Compile program, using for-each to guarantee execution order,
;; since c-compile-program has side-effects.
(for-each
(lambda (expr)
(set! compiled-program-lst
(cons (c-compile-program expr src-file) compiled-program-lst)))
input-program)
;; Get top-level string
(set! compiled-program
(foldr string-append "" (reverse compiled-program-lst)))
(emit-c-arity-macros 0)
(for-each
(lambda (h)
(cond
((and (string? h)
(> (string-length h) 0)
(equal? (string-ref h 0) #\<))
(emit* "#include " h ""))
(else
(emit* "#include \"" h "\""))))
c-headers)
(emit "#include \"cyclone/types.h\"")
;; Globals defined in this module
(for-each
(lambda (global)
(emits "object ")
(emits (cgen:mangle-global (car global)))
(emits " = NULL;\n"))
*globals*)
;; "Pass-through"'s - exports from this module
;; that are actually defined by another.
(for-each
(lambda (global)
(emits "object ")
(emits (cgen:mangle-global global))
(emits " = NULL;\n")
(let ((extern (mangle-exported-ident import-db global #f)))
(cond
(extern
(emits "extern object ")
(emits extern)
(emits ";\n")))))
lib-pass-thru-exports)
;; Globals defined by another module
(for-each
(lambda (global)
(emits "extern object ")
(emits (cgen:mangle-global global))
(emits ";\n"))
(lib:idb:ids import-db))
(emit "#include \"cyclone/runtime.h\"")
(if program?
(emit "#include \"cyclone/runtime-main.h\""))
;; Emit symbol definitions
(for-each
(lambda (sym)
(emit* "defsymbol(" (mangle sym) ");"))
*symbols*)
;; Emit lambdas:
; Print the prototypes:
(for-each
(lambda (l)
(cond
((equal? 'precompiled-lambda (caadr l))
(emit*
"static void __lambda_"
(number->string (car l))
(cadadr l)
" ;"))
((equal? 'precompiled-inline-lambda (caadr l))
(emit*
"static object __lambda_"
(number->string (car l))
(cadadr l)
" ;"))
((member (car l) inline-lambdas)
(emit*
"static object __lambda_"
(number->string (car l)) "(void *data, "
(cdadr l)
") ;"))
(else
(emit*
"static void __lambda_"
(number->string (car l)) "(void *data, int argc, "
(cdadr l)
") ;"))))
lambdas)
(emit "")
; Print GC return wrappers
(for-each
(lambda (l)
(let ((ast (caddr l)))
(when (ast:lambda? ast)
(with-fnc (ast:lambda-id ast) (lambda (fnc)
;;(when (and
;; (adbf:well-known fnc)
;; (equal? (adbf:closure-size fnc) 1))
;; (trace:error `(JAE ,(car l) ,l ,fnc)))
(when (and *optimize-well-known-lambdas*
(adbf:well-known fnc)
(equal? (adbf:closure-size fnc) 1))
;(trace:error `(JAE ,(car l) ,l ,fnc))
(let* ((params-str (cdadr l))
(args-str
(string-join
(cdr
(string-split
(string-replace-all params-str "object" "")
#\,))
#\,))
)
(emit*
"static void __lambda_gc_ret_"
(number->string (car l))
"(void *data, int argc,"
params-str
")"
"{"
"\nobject obj = "
"((closure1)" (mangle (car (adbf:all-params fnc))) ")->element;\n"
"__lambda_"
(number->string (car l))
"(data, argc, obj"
(if (> (string-length args-str) 0)
(string-append "," args-str))
");"
"}"))))))))
lambdas)
; Print the definitions:
(for-each
(lambda (l)
(cond
((equal? 'precompiled-lambda (caadr l))
(emit*
"static void __lambda_"
(number->string (car l))
(cadadr l)
" {"
(car (cddadr l))
" }"
))
((equal? 'precompiled-inline-lambda (caadr l))
(emit*
"static object __lambda_"
(number->string (car l))
(cadadr l)
" {"
(car (cddadr l))
" }"
))
((member (car l) inline-lambdas)
(emit ((caadr l) (string-append "__lambda_" (number->string (car l))))))
(else
(emit ((caadr l) (string-append "__lambda_" (number->string (car l))))))))
lambdas)
; Emit inlinable function list
(cond
((not program?)
(emit* "void c_" (lib:name->string lib-name) "_inlinable_lambdas(void *data, int argc, closure _, object cont){ ")
(let ((pairs '())
(head-pair #f))
(for-each
(lambda (g)
(let ((pair-sym (mangle (gensym 'pair))))
(emits*
"make_pair(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g))
"\"), find_or_add_symbol(\"" (symbol->string (cdr g)) "\"));\n")
(set! pairs (cons pair-sym pairs))))
*global-inlines*)
;; Link the pairs
(let loop ((code '())
(ps pairs)
(cs (map (lambda (_) (mangle (gensym 'c))) pairs)))
(cond
((null? ps)
(for-each
(lambda (str)
(emits str))
code))
((null? (cdr ps))
(if (not head-pair)
(set! head-pair (car cs)))
(loop (cons (string-append "make_pair(" (car cs) ", &" (car ps) ", NULL);\n") code)
(cdr ps)
(cdr cs)))
(else
(if (not head-pair)
(set! head-pair (car cs)))
(loop (cons (string-append "make_pair(" (car cs) ", &" (car ps) ", &" (cadr cs) ");\n") code)
(cdr ps)
(cdr cs)))))
(if head-pair
(emit* "(((closure)cont)->fn)(data, 1, cont, &" head-pair ");")
(emit* "(((closure)cont)->fn)(data, 1, cont, NULL);"))
(emit* " } "))
))
; Emit entry point
(cond
(program?
(emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value);")
(for-each
(lambda (lib-name)
(emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(void *data, int argc, closure cont, object value);"))
required-libs)
(emit "static void c_entry_pt(data, argc, env,cont) void *data; int argc; closure env,cont; { "))
(else
(emit* "void c_" (lib:name->string lib-name) "_entry_pt_first_lambda(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ")
; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");"))
))
;; Set global-changed indicator
(emit "Cyc_set_globals_changed((gc_thread_data *)data);")
;; Initialize symbols
(for-each
(lambda (sym)
(emit*
" quote_" (mangle sym) " = find_or_add_symbol(\""
(symbol->string sym) "\");"))
*symbols*)
;; Initialize global table
(for-each
(lambda (global)
(emits "\n add_global((object *) &")
(emits (cgen:mangle-global (car global)))
(emits ");"))
*globals*)
(emit "")
;; Initialize symbol table
(for-each
(lambda (sym)
(emit* " add_symbol(quote_" (mangle sym) ");"))
*symbols*)
;; Initialize globals
(let* ((prefix " ")
(emit-global
(lambda (global)
(emits (c:allocs->str2 (c:allocs (caddr global)) prefix " \n"))
(emits prefix)
(emits (cgen:mangle-global (car global)))
(emits " = ")
(emits (c:body (caddr global)))
(emit "; "))))
(for-each emit-global (filter global-lambda? *globals*))
(for-each emit-global (filter global-not-lambda? *globals*))
(emit ""))
;; Initialize Cyc_global_variables
;; TODO: only need to do this if 'eval' was also compiled
(let ((pairs '())
(head-pair #f))
;; Expose list of inlinable lambda functions
(when (not program?)
(let ( ;(cvar-sym (mangle (gensym 'cvar)))
(pair-sym (mangle (gensym 'pair)))
(clo-sym (mangle (gensym 'clo)))
(fnc (string-append
"c_" (lib:name->string lib-name) "_inlinable_lambdas")))
(emits*
" mclosure0(" clo-sym ", " fnc "); "
; " make_cvar(" cvar-sym
; ", (object *)&" fnc ");"
)
(emits*
"make_pair(" pair-sym ", find_or_add_symbol(\"" fnc
"\"), &" clo-sym ");\n")
(set! pairs (cons pair-sym pairs))))
;; END
(for-each
(lambda (g)
(let ((cvar-sym (mangle (gensym 'cvar)))
(pair-sym (mangle (gensym 'pair))))
(emits*
" make_cvar(" cvar-sym
", (object *)&" (cgen:mangle-global (car g)) ");")
(emits*
"make_pair(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g))
"\"), &" cvar-sym ");\n")
(set! pairs (cons pair-sym pairs))
))
*globals*)
(for-each
(lambda (g)
(let ((idb-entry (lib:idb:lookup import-db g)))
(if idb-entry
(emits*
(cgen:mangle-global g) " = "
(mangle-exported-ident import-db g #f)
";\n"))))
lib-pass-thru-exports)
(let loop ((code '())
(ps pairs)
(cs (map (lambda (_) (mangle (gensym 'c))) pairs)))
(cond
((null? ps)
(for-each
(lambda (str)
(emits str))
code))
((null? (cdr ps))
(if (not head-pair)
(set! head-pair (car cs)))
(loop (cons (string-append "make_pair(" (car cs) ", &" (car ps) ",Cyc_global_variables);\n") code)
(cdr ps)
(cdr cs)))
(else
(if (not head-pair)
(set! head-pair (car cs)))
(loop (cons (string-append "make_pair(" (car cs) ", &" (car ps) ", &" (cadr cs) ");\n") code)
(cdr ps)
(cdr cs)))))
(if head-pair
(emit*
"Cyc_global_variables = &" head-pair ";")))
(cond
(program?
;; Emit code to initialize each module (compiled Scheme library)
(let ((this-clo "c_done")
(prev-clo "c_done"))
(emit*
"mclosure1(" this-clo
", c_entry_pt_first_lambda, &" prev-clo ");")
(for-each
(lambda (lib-name)
(set! prev-clo this-clo)
(set! this-clo (mangle (gensym "c")))
(emit*
"mclosure1(" this-clo
", c_" (lib:name->string lib-name) "_entry_pt"
", &" prev-clo ");")
)
(reverse required-libs)) ;; Init each lib's dependencies 1st
(emit*
;; Start cont chain, but do not assume closcall1 macro was defined
"(" this-clo ".fn)(data, 0, &" this-clo ", &" this-clo ");")
(emit "}")
(emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value) {")
; DEBUG (emit (string-append "printf(\"init first lambda\\n\");"))
(emit compiled-program)
(emit ";")))
(else
;; Do not use closcall1 macro as it might not have been defined
(emit "cont = ((closure1_type *)cont)->element;")
(emit*
"(((closure)"
(cgen:mangle-global (lib:name->symbol lib-name))
")->fn)(data, 1, cont, cont);")
(emit* "}")
(emit* "void c_" (lib:name->string lib-name) "_entry_pt(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ")
(emit* " register_library(\""
(lib:name->unique-string lib-name)
"\");")
(if (null? lib-pass-thru-exports)
(emit* " c_" (lib:name->string lib-name) "_entry_pt_first_lambda(data, argc, cont,value);")
; GC to ensure objects are moved when exporting exports.
; Otherwise there will be broken hearts :(
(emit*
" mclosure1(clo, c_" (lib:name->string lib-name) "_entry_pt_first_lambda, ((closure1_type *)cont)->element);\n"
" object buf[1]; buf[0] = cont;\n"
" GC(data, (closure)&clo, buf, 1);\n"))
))
(emit "}")
(if program?
(emit *c-main-function*))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Automatically generate blocks of code for the compiler
(define (autogen filename)
(let ((fp (open-output-file filename)))
(autogen:defprimitives fp)
(autogen:primitive-procedures fp)
(close-output-port fp)))
(define (autogen:defprimitives fp)
(display "/* This section is auto-generated via --autogen */\n" fp)
(for-each
(lambda (p)
(display
(string-append
"defprimitive("
(mangle p)
", "
(symbol->string p)
", &_"
(mangle p)
"); /* "
(symbol->string p)
" */\n")
fp))
*primitives*)
(display "/* -------------------------------------------- */\n" fp))
;; List of primitive procedures
(define (autogen:primitive-procedures fp)
(let ((code
(cons
'list
(map
(lambda (p)
`(list (quote ,p) ,p))
*primitives*))))
(cond-expand
(chicken
(pp code fp)) ;; CHICKEN pretty-print
(else
(write code fp)))))
))
Reference in a new issue View git blame Copy permalink