mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-18 21:29:18 +02:00
1079 lines
37 KiB
Scheme
1079 lines
37 KiB
Scheme
;;
|
|
;; Cyclone Scheme
|
|
;; Copyright (c) 2014, Justin Ethier
|
|
;; All rights reserved.
|
|
;;
|
|
;; This module compiles scheme code to a Cheney-on-the-MTA C runtime.
|
|
;;
|
|
|
|
(define (emit line)
|
|
(display line)
|
|
(newline))
|
|
|
|
(define (emits str)
|
|
(display str))
|
|
|
|
(define (emit-newline)
|
|
(newline))
|
|
|
|
(define (string-join lst delim)
|
|
(cond
|
|
((null? lst)
|
|
"")
|
|
((= (length lst) 1)
|
|
(car lst))
|
|
(else
|
|
(string-append
|
|
(car lst)
|
|
delim
|
|
(string-join (cdr lst) delim)))))
|
|
|
|
;; 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))))
|
|
(else
|
|
(next (cdr head) (cons (car head) tail)))))))
|
|
(next (string->list str) '())))
|
|
|
|
;; Name-mangling.
|
|
|
|
;; We have to "mangle" Scheme identifiers into
|
|
;; C-compatible identifiers, because names like
|
|
;; foo-bar/baz are not identifiers in C.
|
|
|
|
; mangle : symbol -> string
|
|
(define (mangle symbol)
|
|
(letrec
|
|
((m (lambda (chars)
|
|
(if (null? chars)
|
|
'()
|
|
(if (or (and (char-alphabetic? (car chars)) (not (char=? (car chars) #\_)))
|
|
(char-numeric? (car chars)))
|
|
(cons (car chars) (m (cdr chars)))
|
|
(cons #\_ (append (integer->char-list (char->natural (car chars)))
|
|
(m (cdr chars))))))))
|
|
(ident (list->string (m (string->list (symbol->string symbol))))))
|
|
(if (member (string->symbol ident) *c-keywords*)
|
|
(string-append "_" ident)
|
|
ident)))
|
|
|
|
(define (mangle-global symbol)
|
|
(string-append "__glo_" (mangle symbol)))
|
|
|
|
(define *c-keywords*
|
|
'(auto _Bool break case char _Complex const continue default do double else
|
|
enum extern float for goto if _Imaginary inline int long register restrict
|
|
return short signed sizeof static struct switch typedef union unsigned
|
|
void volatile while
|
|
list ;; Not a keyword but reserved type
|
|
))
|
|
|
|
(define *c-main-function*
|
|
"main(int argc,char **argv)
|
|
{long stack_size = long_arg(argc,argv,\"-s\",STACK_SIZE);
|
|
long heap_size = long_arg(argc,argv,\"-h\",HEAP_SIZE);
|
|
global_stack_size = stack_size;
|
|
global_heap_size = heap_size;
|
|
main_main(stack_size,heap_size,(char *) &stack_size);
|
|
return 0;}")
|
|
|
|
;;; Auto-generation of C macros
|
|
(define *c-call-arity* 0)
|
|
|
|
(define (set-c-call-arity! arity)
|
|
(cond
|
|
((not (number? arity))
|
|
(error `(Non-numeric number of arguments received ,arity)))
|
|
(else
|
|
(if (> arity *c-call-arity*)
|
|
(set! *c-call-arity* arity)))))
|
|
|
|
(define (emit-c-macros)
|
|
(c-macro-declare-globals)
|
|
(c-macro-GC-globals)
|
|
(emit (c-macro-after-longjmp))
|
|
(emit-c-arity-macros 0))
|
|
|
|
(define (emit-c-arity-macros arity)
|
|
(when (<= arity *c-call-arity*)
|
|
(emit (c-macro-funcall arity))
|
|
(emit (c-macro-return-funcall arity))
|
|
(emit (c-macro-return-check arity))
|
|
(emit-c-arity-macros (+ arity 1))))
|
|
|
|
(define (c-macro-after-longjmp)
|
|
(letrec (
|
|
(append-args
|
|
(lambda (n)
|
|
(if (> n 0)
|
|
(string-append
|
|
(append-args (- n 1))
|
|
",gc_ans[" (number->string (- n 1)) "]")
|
|
"")))
|
|
(append-next-clause
|
|
(lambda (i)
|
|
(cond
|
|
((= i 0)
|
|
(string-append
|
|
" if (gc_num_ans == 0) { \\\n"
|
|
" funcall0((closure) gc_cont); \\\n"
|
|
(append-next-clause (+ i 1))))
|
|
((<= i *c-call-arity*)
|
|
(let ((this-clause
|
|
(string-append
|
|
" } else if (gc_num_ans == " (number->string i)") { \\\n"
|
|
" funcall" (number->string i) "((closure) gc_cont" (append-args i) "); \\\n")))
|
|
(string-append
|
|
this-clause
|
|
(append-next-clause (+ i 1)))))
|
|
(else
|
|
" } else { \\\n"
|
|
" printf(\"Unsupported number of args from GC %d\\n\", gc_num_ans); \\\n"
|
|
" } \n")))))
|
|
(string-append
|
|
"#define AFTER_LONGJMP \\\n"
|
|
(append-next-clause 0))))
|
|
|
|
(define (c-macro-return-funcall 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
|
|
"/* Return to continuation after checking for stack overflow. */\n"
|
|
"#define return_funcall" n "(cfn" args ") \\\n"
|
|
"{char stack; \\\n"
|
|
" if (DEBUG_ALWAYS_GC || check_overflow(&stack,stack_limit1)) { \\\n"
|
|
" object buf[" n "]; " arry-assign "\\\n"
|
|
" GC(cfn,buf," n "); return; \\\n"
|
|
" } else {funcall" n "((closure) (cfn)" args "); return;}}\n")))
|
|
|
|
(define (c-macro-return-check 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
|
|
"/* Evaluate an expression after checking for stack overflow. */\n"
|
|
"#define return_check" n "(_fn" args ") { \\\n"
|
|
" char stack; \\\n"
|
|
" if (DEBUG_ALWAYS_GC || check_overflow(&stack,stack_limit1)) { \\\n"
|
|
" object buf[" n "]; " arry-assign " \\\n"
|
|
" mclosure0(c1, _fn); \\\n"
|
|
" GC(&c1, buf, " n "); return; \\\n"
|
|
" } else { (_fn)(" n ",(closure)_fn" args "); }}\n")))
|
|
|
|
(define (c-macro-funcall 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 funcall" n "(cfn" args ") "
|
|
(wrap (string-append "if (prim(cfn)) { Cyc_apply(" n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }"))
|
|
(wrap " else { ")
|
|
"((cfn)->fn)(" n ",cfn" args ")"
|
|
(wrap ";}")
|
|
)))
|
|
|
|
(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) ";")
|
|
""))
|
|
|
|
(define (c-macro-GC-globals)
|
|
; emit directly to be more efficient
|
|
; TODO: convert all c-macro functions to direct emit???
|
|
(emit "#define GC_GLOBALS \\")
|
|
(emits "{")
|
|
(for-each
|
|
(lambda (global)
|
|
(emits " \\\n transp(")
|
|
(emits (mangle-global (car global)))
|
|
(emits ");"))
|
|
*globals*)
|
|
(emit "}")
|
|
(emit ""))
|
|
|
|
(define (c-macro-declare-globals)
|
|
(emits "#define DECLARE_GLOBALS ")
|
|
(for-each
|
|
(lambda (global)
|
|
(emit " \\")
|
|
(emits " static volatile object ")
|
|
(emits (mangle-global (car global)))
|
|
(emits " = nil;"))
|
|
*globals*)
|
|
(emit "")
|
|
(emit ""))
|
|
|
|
;;; 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)
|
|
(apply
|
|
string-append
|
|
(map
|
|
(lambda (c)
|
|
(string-append
|
|
(if (null? prefix)
|
|
""
|
|
(car prefix))
|
|
c
|
|
"\n"))
|
|
c-allocs)))
|
|
|
|
(define (c:allocs->str2 c-allocs prefix suffix)
|
|
(apply
|
|
string-append
|
|
(map
|
|
(lambda (c)
|
|
(string-append prefix c 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)
|
|
(let* ((preamble "")
|
|
(append-preamble (lambda (s)
|
|
(set! preamble (string-append preamble " " s "\n"))))
|
|
(body (c-compile-exp exp append-preamble "cont")))
|
|
;(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
|
|
(define (c-compile-exp exp append-preamble cont)
|
|
(cond
|
|
; Core forms:
|
|
((const? exp) (c-compile-const exp))
|
|
((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))
|
|
((if? exp) (c-compile-if exp append-preamble cont))
|
|
|
|
; IR (2):
|
|
((tagged-list? '%closure exp)
|
|
(c-compile-closure exp append-preamble cont))
|
|
; Global definition
|
|
((define? exp)
|
|
(c-compile-global exp append-preamble cont))
|
|
; Special case - global function w/out a closure. Create an empty closure
|
|
((tagged-list? 'lambda exp)
|
|
(c-compile-exp
|
|
`(%closure ,exp)
|
|
append-preamble cont))
|
|
|
|
; Application:
|
|
((app? exp) (c-compile-app exp append-preamble cont))
|
|
(else (error "unknown exp in c-compile-exp: " exp))))
|
|
|
|
(define (c-compile-quote qexp)
|
|
(let ((exp (cadr qexp)))
|
|
(c-compile-scalars exp)))
|
|
|
|
(define (c-compile-scalars args)
|
|
(letrec (
|
|
(num-args 0)
|
|
(create-cons
|
|
(lambda (cvar a b)
|
|
(c-code/vars
|
|
(string-append "make_cons(" cvar "," (c:body a) "," (c:body b) ");")
|
|
(append (c:allocs a) (c:allocs b))))
|
|
)
|
|
(_c-compile-scalars
|
|
(lambda (args)
|
|
(cond
|
|
((null? args)
|
|
(c-code "nil"))
|
|
((not (pair? args))
|
|
(c-compile-const args))
|
|
(else
|
|
(let* ((cvar-name (mangle (gensym 'c)))
|
|
(cell (create-cons
|
|
cvar-name
|
|
(c-compile-const (car args))
|
|
(_c-compile-scalars (cdr args)))))
|
|
(set! num-args (+ 1 num-args))
|
|
(c-code/vars
|
|
(string-append "&" cvar-name)
|
|
(append
|
|
(c:allocs cell)
|
|
(list (c:body cell))))))))))
|
|
(c:tuple/args
|
|
(_c-compile-scalars args)
|
|
num-args)))
|
|
|
|
;; 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)
|
|
(cond
|
|
((null? exp)
|
|
(c-code "nil"))
|
|
((pair? exp)
|
|
(c-compile-scalars exp))
|
|
((integer? exp)
|
|
(let ((cvar-name (mangle (gensym 'c))))
|
|
(c-code/vars
|
|
(string-append "&" cvar-name) ; Code is just the variable name
|
|
(list ; Allocate integer on the C stack
|
|
(string-append
|
|
"make_int(" cvar-name ", " (number->string exp) ");")))))
|
|
((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)
|
|
(let ((cvar-name (mangle (gensym 'c))))
|
|
(c-code/vars
|
|
(string-append "&" cvar-name) ; Code is just the variable name
|
|
(list ; Allocate integer on the C stack
|
|
(string-append
|
|
"make_string(" cvar-name ", " (->cstr exp) ");")))))
|
|
;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 (prim->c-func p)
|
|
(cond
|
|
((eq? p 'Cyc-global-vars) "Cyc_get_global_variables")
|
|
((eq? p 'Cyc-get-cvar) "Cyc_get_cvar")
|
|
((eq? p 'Cyc-set-cvar!) "Cyc_set_cvar")
|
|
((eq? p 'Cyc-cvar?) "Cyc_is_cvar")
|
|
((eq? p 'has-cycle?) "Cyc_has_cycle")
|
|
((eq? p '+) "__sum")
|
|
((eq? p '-) "__sub")
|
|
((eq? p '*) "__mul")
|
|
((eq? p '/) "__div")
|
|
((eq? p '=) "__num_eq")
|
|
((eq? p '>) "__num_gt")
|
|
((eq? p '<) "__num_lt")
|
|
((eq? p '>=) "__num_gte")
|
|
((eq? p '<=) "__num_lte")
|
|
((eq? p 'apply) "apply")
|
|
((eq? p '%halt) "__halt")
|
|
((eq? p 'error) "Cyc_error")
|
|
((eq? p 'current-input-port) "Cyc_io_current_input_port")
|
|
((eq? p 'open-input-file) "Cyc_io_open_input_file")
|
|
((eq? p 'close-input-port) "Cyc_io_close_input_port")
|
|
((eq? p 'read-char) "Cyc_io_read_char")
|
|
((eq? p 'peek-char) "Cyc_io_peek_char")
|
|
((eq? p 'display) "Cyc_display")
|
|
((eq? p 'write) "Cyc_write")
|
|
((eq? p 'car) "car")
|
|
((eq? p 'cdr) "cdr")
|
|
((eq? p 'caar) "caar")
|
|
((eq? p 'cadr) "cadr")
|
|
((eq? p 'cdar) "cdar")
|
|
((eq? p 'cddr) "cddr")
|
|
((eq? p 'caaar) "caaar")
|
|
((eq? p 'caadr) "caadr")
|
|
((eq? p 'cadar) "cadar")
|
|
((eq? p 'caddr) "caddr")
|
|
((eq? p 'cdaar) "cdaar")
|
|
((eq? p 'cdadr) "cdadr")
|
|
((eq? p 'cddar) "cddar")
|
|
((eq? p 'cdddr) "cdddr")
|
|
((eq? p 'caaaar) "caaaar")
|
|
((eq? p 'caaadr) "caaadr")
|
|
((eq? p 'caadar) "caadar")
|
|
((eq? p 'caaddr) "caaddr")
|
|
((eq? p 'cadaar) "cadaar")
|
|
((eq? p 'cadadr) "cadadr")
|
|
((eq? p 'caddar) "caddar")
|
|
((eq? p 'cadddr) "cadddr")
|
|
((eq? p 'cdaaar) "cdaaar")
|
|
((eq? p 'cdaadr) "cdaadr")
|
|
((eq? p 'cdadar) "cdadar")
|
|
((eq? p 'cdaddr) "cdaddr")
|
|
((eq? p 'cddaar) "cddaar")
|
|
((eq? p 'cddadr) "cddadr")
|
|
((eq? p 'cdddar) "cdddar")
|
|
((eq? p 'cddddr) "cddddr")
|
|
((eq? p 'char->integer) "Cyc_char2integer")
|
|
((eq? p 'integer->char) "Cyc_integer2char")
|
|
((eq? p 'string->number)"Cyc_string2number")
|
|
((eq? p 'list->string) "Cyc_list2string")
|
|
((eq? p 'string->list) "string2list")
|
|
((eq? p 'string-append) "Cyc_string_append")
|
|
((eq? p 'string->symbol) "Cyc_string2symbol")
|
|
((eq? p 'symbol->string) "Cyc_symbol2string")
|
|
((eq? p 'number->string) "Cyc_number2string")
|
|
((eq? p 'assq) "assq")
|
|
((eq? p 'assoc) "assoc")
|
|
((eq? p 'member) "memberp")
|
|
((eq? p 'length) "Cyc_length")
|
|
((eq? p 'set-car!) "Cyc_set_car")
|
|
((eq? p 'set-cdr!) "Cyc_set_cdr")
|
|
((eq? p 'eq?) "Cyc_eq")
|
|
((eq? p 'eqv?) "Cyc_eq")
|
|
((eq? p 'equal?) "equalp")
|
|
((eq? p 'boolean?) "Cyc_is_boolean")
|
|
((eq? p 'char?) "Cyc_is_char")
|
|
((eq? p 'null?) "Cyc_is_null")
|
|
((eq? p 'number?) "Cyc_is_number")
|
|
((eq? p 'pair?) "Cyc_is_cons")
|
|
((eq? p 'string?) "Cyc_is_string")
|
|
((eq? p 'eof-object?) "Cyc_is_eof_object")
|
|
((eq? p 'symbol?) "Cyc_is_symbol")
|
|
((eq? p 'cons) "make_cons")
|
|
((eq? p 'cell) "make_cell")
|
|
((eq? p 'cell-get) "cell_get")
|
|
((eq? p 'set-cell!) "cell_set")
|
|
((eq? p 'set-global!) "global_set")
|
|
(else
|
|
(error "unhandled primitive: " p))))
|
|
|
|
;; c-compile-prim : prim-exp -> string -> string
|
|
(define (c-compile-prim p cont)
|
|
(let* ((c-func (prim->c-func p))
|
|
;; Following closure defs are only used for apply, to
|
|
;; create a new closure for the continuation, if needed.
|
|
;;
|
|
;; Apply 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 (eq? p 'apply)
|
|
(> (string-length cont) (string-length "__lambda_"))
|
|
(equal? (substring cont 0 9) "__lambda_"))
|
|
(string-append
|
|
"mclosure0(" closure-sym
|
|
"," cont "); "))
|
|
(else #f)))
|
|
;; END apply defs
|
|
(c-var-assign
|
|
(lambda (type)
|
|
(let ((cv-name (mangle (gensym 'c))))
|
|
(c-code/vars
|
|
(string-append (if (eq? p 'apply) "" "&") cv-name)
|
|
(list
|
|
(string-append
|
|
;; Define closure if necessary (apply only)
|
|
(cond
|
|
(closure-def closure-def)
|
|
(else ""))
|
|
|
|
;; Emit C variable
|
|
type " " cv-name " = " c-func "("
|
|
|
|
;; Emit closure as first arg, if necessary (apply only)
|
|
(cond
|
|
(closure-def
|
|
(string-append "&" closure-sym ", "))
|
|
((eq? p 'apply)
|
|
(string-append cont ", "))
|
|
(else "")))))))))
|
|
(cond
|
|
((prim/c-var-assign p)
|
|
(c-var-assign (prim/c-var-assign p)))
|
|
((prim/cvar? p)
|
|
(let ((cv-name (mangle (gensym 'c))))
|
|
(c-code/vars
|
|
(if (prim:allocates-object? p)
|
|
cv-name ;; Already a pointer
|
|
(string-append "&" cv-name)) ;; Point to data
|
|
(list
|
|
(string-append c-func "(" cv-name)))))
|
|
(else
|
|
(c-code (string-append c-func "("))))))
|
|
|
|
;; Determine if primitive assigns (allocates) a C variable
|
|
;; EG: int v = prim();
|
|
(define (prim/c-var-assign p)
|
|
(cond
|
|
((eq? p 'current-input-port) "port_type")
|
|
((eq? p 'open-input-file) "port_type")
|
|
((eq? p 'length) "integer_type")
|
|
((eq? p 'char->integer) "integer_type")
|
|
((eq? p 'string->number) "integer_type")
|
|
((eq? p 'list->string) "string_type")
|
|
; ((eq? p 'string->list) "object")
|
|
((eq? p 'string-append) "string_type")
|
|
((eq? p 'symbol->string) "string_type")
|
|
((eq? p 'number->string) "string_type")
|
|
((eq? p 'apply) "object")
|
|
(else #f)))
|
|
|
|
;; Primitive creates a C variable
|
|
(define (prim/cvar? exp)
|
|
(and (prim? exp)
|
|
(member exp '(
|
|
current-input-port open-input-file
|
|
char->integer string->number string-append list->string string->list
|
|
symbol->string number->string
|
|
+ - * / apply cons length cell))))
|
|
|
|
;; Need to pass an integer arg count as the function's first parameter
|
|
(define (prim:arg-count? exp)
|
|
(and (prim? exp)
|
|
(member exp '(error string-append))))
|
|
|
|
;; Primitive allocates an object
|
|
(define (prim:allocates-object? exp)
|
|
(and (prim? exp)
|
|
(member exp '(string->list))))
|
|
|
|
;; END primitives
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
; c-compile-ref : ref-exp -> string
|
|
(define (c-compile-ref exp)
|
|
(c-code
|
|
(if (member exp *global-syms*)
|
|
(mangle-global exp)
|
|
(mangle exp))))
|
|
|
|
; c-compile-args : list[exp] (string -> void) -> string
|
|
(define (c-compile-args args append-preamble prefix cont)
|
|
(letrec ((num-args 0)
|
|
(_c-compile-args
|
|
(lambda (args append-preamble prefix cont)
|
|
(if (not (pair? args))
|
|
(c-code "")
|
|
(begin
|
|
;(trace:debug `(c-compile-args ,(car args)))
|
|
(set! num-args (+ 1 num-args))
|
|
(c:append/prefix
|
|
prefix
|
|
(c-compile-exp (car args)
|
|
append-preamble cont)
|
|
(_c-compile-args (cdr args)
|
|
append-preamble ", " cont)))))))
|
|
(c:tuple/args
|
|
(_c-compile-args args
|
|
append-preamble prefix cont)
|
|
num-args)))
|
|
|
|
;; c-compile-app : app-exp (string -> void) -> string
|
|
(define (c-compile-app exp append-preamble cont)
|
|
;(trace:debug `(c-compile-app: ,exp))
|
|
(let (($tmp (mangle (gensym 'tmp))))
|
|
(let* ((args (app->args exp))
|
|
(fun (app->fun exp)))
|
|
(cond
|
|
((lambda? fun)
|
|
(let* ((lid (allocate-lambda (c-compile-lambda fun))) ;; 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))
|
|
(num-cargs (c:num-args cgen)))
|
|
(set-c-call-arity! num-cargs)
|
|
(c-code
|
|
(string-append
|
|
(c:allocs->str (c:allocs cgen))
|
|
"return_check" (number->string num-cargs)
|
|
"(" this-cont
|
|
(if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
|
|
(c:body cgen) ");"))))
|
|
|
|
((prim? fun)
|
|
(let* ((c-fun
|
|
(c-compile-prim fun cont))
|
|
(c-args
|
|
(c-compile-args args append-preamble "" ""))
|
|
(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) "" ",") ; Allocating C var
|
|
(c:body c-args*) ");"))))
|
|
;; Args stay with body
|
|
(c:append
|
|
(c:append c-fun c-args*)
|
|
(c-code ")")))))
|
|
|
|
((equal? '%closure-ref fun)
|
|
(c-code (apply string-append (list
|
|
"("
|
|
;; TODO: probably not the ideal solution, but works for now
|
|
"(closureN)"
|
|
(mangle (car args))
|
|
")->elts["
|
|
(number->string (- (cadr args) 1))"]"))))
|
|
|
|
;; TODO: may not be good enough, closure app could be from an elt
|
|
((tagged-list? '%closure-ref fun)
|
|
(let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont))
|
|
(this-cont (c:body cfun))
|
|
(cargs (c-compile-args (cdr args) append-preamble " " this-cont)))
|
|
(set-c-call-arity! (c:num-args cargs))
|
|
(c-code
|
|
(string-append
|
|
(c:allocs->str (c:allocs cfun) "\n")
|
|
(c:allocs->str (c:allocs cargs) "\n")
|
|
"return_funcall" (number->string (c:num-args cargs))
|
|
"("
|
|
this-cont
|
|
(if (> (c:num-args cargs) 0) "," "")
|
|
(c:body cargs)
|
|
");"))))
|
|
|
|
((tagged-list? '%closure fun)
|
|
(let* ((cfun (c-compile-closure
|
|
fun append-preamble cont))
|
|
(this-cont (string-append "(closure)" (c:body cfun)))
|
|
(cargs (c-compile-args
|
|
args append-preamble " " this-cont))
|
|
(num-cargs (c:num-args cargs)))
|
|
(set-c-call-arity! num-cargs)
|
|
(c-code
|
|
(string-append
|
|
(c:allocs->str (c:allocs cfun) "\n")
|
|
(c:allocs->str (c:allocs cargs) "\n")
|
|
"return_funcall" (number->string num-cargs)
|
|
"("
|
|
this-cont
|
|
(if (> num-cargs 0) "," "")
|
|
(c:body cargs)
|
|
");"))))
|
|
|
|
(else
|
|
(error `(Unsupported function application ,exp)))))))
|
|
|
|
; c-compile-if : if-exp -> string
|
|
(define (c-compile-if exp append-preamble cont)
|
|
(let* ((compile (lambda (exp)
|
|
(c-compile-exp exp append-preamble cont)))
|
|
(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( !eq(boolean_f, "
|
|
(c:body test)
|
|
") ){ \n"
|
|
(c:serialize then " ")
|
|
"\n} else { \n"
|
|
(c:serialize els " ")
|
|
"}\n"))))
|
|
|
|
;; 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)
|
|
(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
|
|
(lambda? body)
|
|
(c-compile-exp body append-preamble cont))
|
|
(c-code/vars "" (list ""))))
|
|
|
|
;; Symbol compilation
|
|
|
|
(define *symbols* '())
|
|
|
|
; These are (at least for now) preallocated by the runtime
|
|
(define *reserved-symbols* '(Cyc_procedure))
|
|
|
|
(define (allocate-symbol sym)
|
|
(if (and (not (member sym *symbols*))
|
|
(not (member sym *reserved-symbols*)))
|
|
(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 an eventually
|
|
;; emitted.
|
|
|
|
; type lambda-id = natural
|
|
|
|
; num-lambdas : natural
|
|
(define num-lambdas 0)
|
|
|
|
; lambdas : alist[lambda-id,string -> string]
|
|
(define lambdas '())
|
|
|
|
; allocate-lambda : (string -> string) -> lambda-id
|
|
(define (allocate-lambda lam)
|
|
(let ((id num-lambdas))
|
|
(set! num-lambdas (+ 1 num-lambdas))
|
|
(set! lambdas (cons (list id lam) lambdas))
|
|
id))
|
|
|
|
; get-lambda : lambda-id -> (symbol -> string)
|
|
(define (get-lambda id)
|
|
(cdr (assv id lambdas)))
|
|
|
|
(define (lambda->env exp)
|
|
(let ((formals (lambda-formals->list exp)))
|
|
(if (pair? formals)
|
|
(car formals)
|
|
'unused)))
|
|
|
|
;; 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)
|
|
(let* ((lam (closure->lam exp))
|
|
(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))))
|
|
(string-append
|
|
"((closureN)" (mangle var) ")->elts[" 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 (c-compile-lambda lam)))
|
|
(create-nclosure (lambda ()
|
|
(string-append
|
|
"closureN_type " cv-name ";\n"
|
|
cv-name ".tag = closureN_tag;\n "
|
|
cv-name ".fn = __lambda_" (number->string lid) ";\n"
|
|
cv-name ".num_elt = " (number->string (length free-vars)) ";\n"
|
|
cv-name ".elts = (object *)alloca(sizeof(object) * "
|
|
(number->string (length free-vars)) ");\n"
|
|
(let loop ((i 0)
|
|
(vars free-vars))
|
|
(if (null? vars)
|
|
""
|
|
(string-append
|
|
cv-name ".elts[" (number->string i) "] = "
|
|
(car vars) ";\n"
|
|
(loop (+ i 1) (cdr vars))))))))
|
|
(create-mclosure (lambda ()
|
|
(string-append
|
|
"mclosure" (number->string (length free-vars)) "(" 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 ", ")
|
|
");"))))
|
|
(c-code/vars
|
|
(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)
|
|
(if (not (pair? formals))
|
|
""
|
|
(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)) ", ..."))
|
|
(else
|
|
"")))))
|
|
|
|
; c-compile-lambda : lamda-exp (string -> void) -> (string -> string)
|
|
(define (c-compile-lambda exp)
|
|
(let* ((preamble "")
|
|
(append-preamble (lambda (s)
|
|
(set! preamble (string-append preamble " " s "\n")))))
|
|
(let* ((formals (c-compile-formals
|
|
(lambda->formals exp)
|
|
(lambda-formals-type exp)))
|
|
(tmp-ident (if (> (length (lambda-formals->list exp)) 0)
|
|
(mangle (car (lambda->formals exp)))
|
|
""))
|
|
(has-closure?
|
|
(and
|
|
(> (string-length tmp-ident) 3)
|
|
(equal? "self" (substring tmp-ident 0 4))))
|
|
(formals*
|
|
(string-append
|
|
(if has-closure?
|
|
""
|
|
(if (equal? "" formals)
|
|
"closure _" ;; TODO: seems wrong, will GC be too aggressive
|
|
"closure _,")) ;; due to missing refs, with ignored closure?
|
|
formals))
|
|
(env-closure (lambda->env exp))
|
|
(body (c-compile-exp
|
|
(car (lambda->exp exp)) ;; car ==> assume single expr in lambda body after CPS
|
|
append-preamble
|
|
(mangle env-closure))))
|
|
(cons
|
|
(lambda (name)
|
|
(string-append "static void " name
|
|
"(int argc, "
|
|
formals*
|
|
") {\n"
|
|
preamble
|
|
(if (lambda-varargs? exp)
|
|
;; Load varargs from C stack into Scheme list
|
|
(string-append
|
|
; DEBUGGING:
|
|
;"printf(\"%d %d\\n\", argc, "
|
|
; (number->string (length (lambda-formals->list exp))) ");"
|
|
"load_varargs("
|
|
(mangle (lambda-varargs-var exp))
|
|
", argc - " (number->string
|
|
(- (length (lambda-formals->list exp))
|
|
1
|
|
(if has-closure? 1 0)))
|
|
");\n");
|
|
"") ; No varargs, skip
|
|
(c:serialize body " ") "; \n"
|
|
"}\n"))
|
|
formals*))))
|
|
|
|
(define (mta:code-gen input-program globals)
|
|
(set! *global-syms* globals)
|
|
(let ((compiled-program
|
|
(apply string-append
|
|
(map c-compile-program input-program))))
|
|
(emit-c-macros)
|
|
(emit "#include \"runtime.h\"")
|
|
|
|
;; Emit symbols
|
|
(for-each
|
|
(lambda (sym)
|
|
(emit
|
|
(string-append
|
|
"defsymbol(" (mangle sym) ", " (symbol->string sym) ");")))
|
|
*symbols*)
|
|
|
|
;; Emit lambdas:
|
|
; Print the prototypes:
|
|
(for-each
|
|
(lambda (l)
|
|
(emit (string-append
|
|
"static void __lambda_"
|
|
(number->string (car l)) "(int argc, "
|
|
(cdadr l)
|
|
") ;")))
|
|
lambdas)
|
|
|
|
(emit "")
|
|
|
|
; Print the definitions:
|
|
(for-each
|
|
(lambda (l)
|
|
(emit ((caadr l) (string-append "__lambda_" (number->string (car l))))))
|
|
lambdas)
|
|
|
|
(emit "
|
|
static void c_entry_pt(argc, env,cont) int argc; closure env,cont; { ")
|
|
|
|
;; Initialize symbol table
|
|
(for-each
|
|
(lambda (sym)
|
|
(emit (string-append " 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 (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))
|
|
(for-each
|
|
(lambda (g)
|
|
(let ((cvar-sym (mangle (gensym 'cvar)))
|
|
(pair-sym (mangle (gensym 'pair))))
|
|
(emits
|
|
(string-append
|
|
" make_cvar(" cvar-sym
|
|
", (object *)&" (mangle-global (car g)) ");"))
|
|
(emits
|
|
(string-append
|
|
"make_cons(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g))
|
|
"\"), &" cvar-sym ");\n"))
|
|
(set! pairs (cons pair-sym pairs))
|
|
))
|
|
*globals*)
|
|
(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))
|
|
(loop (cons (string-append "make_cons(" (car cs) ", &" (car ps) ",nil);\n") code)
|
|
(cdr ps)
|
|
(cdr cs)))
|
|
(else
|
|
(if (not head-pair)
|
|
(set! head-pair (car cs)))
|
|
(loop (cons (string-append "make_cons(" (car cs) ", &" (car ps) ", &" (cadr cs) ");\n") code)
|
|
(cdr ps)
|
|
(cdr cs)))))
|
|
(if head-pair
|
|
(emits
|
|
(string-append "Cyc_global_variables = &" head-pair ";"))))
|
|
|
|
(emit compiled-program)
|
|
(emit "}")
|
|
(emit *c-main-function*)))
|
|
|
|
; Unused -
|
|
;;; Echo file to stdout
|
|
;(define (emit-fp fp)
|
|
; (let ((l (read-line fp)))
|
|
; (if (eof-object? l)
|
|
; (close-port fp)
|
|
; (begin
|
|
; (display l)
|
|
; (newline)
|
|
; (emit-fp fp)))))
|
|
;
|
|
;(define (read-runtime fp)
|
|
; (letrec*
|
|
; ((break "/** SCHEME CODE ENTRY POINT **/")
|
|
; (read-fp (lambda (header footer on-header?)
|
|
; (let ((l (read-line fp)))
|
|
; (cond
|
|
; ((eof-object? l)
|
|
; (close-port fp)
|
|
; (cons (reverse header) (reverse footer)))
|
|
; (else
|
|
; (cond
|
|
; ((equal? l break)
|
|
; (read-fp header footer #f))
|
|
; (else
|
|
; (if on-header?
|
|
; (read-fp (cons l header) footer on-header?)
|
|
; (read-fp header (cons l footer) on-header?))))))))))
|
|
;
|
|
; (read-fp (list) (list) #t)))
|