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

WIP

Browse source
This commit is contained in:
Justin Ethier 2015-11-03 23:04:13 -05:00
parent 0cd4d2e796
commit a84c8b9339
3 changed files with 43 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
Makefile
View file

@ -150,8 +150,9 @@ sld:
.PHONY: debug .PHONY: debug
debug: debug:
cyclone scheme/cyclone/macros.sld && sudo cp scheme/cyclone/macros.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.o /usr/local/share/cyclone/scheme/cyclone/ && \ cyclone scheme/cyclone/cgen.sld && sudo cp scheme/cyclone/cgen.* /usr/local/share/cyclone/scheme/cyclone/ && cyclone cyclone.scm && sudo make install-includes && sudo make install-libs && ./cyclone generate-c.scm
cyclone scheme/cyclone/util.sld && sudo cp scheme/cyclone/util.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.o /usr/local/share/cyclone/scheme/cyclone/ && \ ### cyclone scheme/cyclone/macros.sld && sudo cp scheme/cyclone/macros.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.o /usr/local/share/cyclone/scheme/cyclone/ && \
cyclone scheme/cyclone/transforms.sld && sudo cp scheme/cyclone/transforms.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.o /usr/local/share/cyclone/scheme/cyclone/ && \ ### cyclone scheme/cyclone/util.sld && sudo cp scheme/cyclone/util.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.o /usr/local/share/cyclone/scheme/cyclone/ && \
cyclone -t cyclone.scm && cyclone -t icyc.scm && sudo make install-bin ### cyclone scheme/cyclone/transforms.sld && sudo cp scheme/cyclone/transforms.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.o /usr/local/share/cyclone/scheme/cyclone/ && \
### cyclone -t cyclone.scm && cyclone -t icyc.scm && sudo make install-bin

6
include/cyclone/runtime-main.h
View file

@ -14,7 +14,7 @@
long global_stack_size = 0; long global_stack_size = 0;
long global_heap_size = 0; long global_heap_size = 0;
static void c_entry_pt(int,closure,closure); static void c_entry_pt(void *,int,closure,closure);
static void Cyc_main(long stack_size,long heap_size,char *stack_base); static void Cyc_main(long stack_size,long heap_size,char *stack_base);
static void Cyc_main (stack_size,heap_size,stack_base) static void Cyc_main (stack_size,heap_size,stack_base)
@ -87,9 +87,9 @@ static void Cyc_main (stack_size,heap_size,stack_base)
// JAE - note for the general case, setjmp will return the data pointer's addy // JAE - note for the general case, setjmp will return the data pointer's addy
if (type_of(gc_cont) == cons_tag || prim(gc_cont)) { if (type_of(gc_cont) == cons_tag || prim(gc_cont)) {
Cyc_apply_from_buf(gc_num_ans, gc_cont, gc_ans); Cyc_apply_from_buf(Cyc_thread, gc_num_ans, gc_cont, gc_ans);
} else { } else {
do_dispatch(gc_num_ans, ((closure)gc_cont)->fn, gc_cont, gc_ans); do_dispatch(Cyc_thread, gc_num_ans, ((closure)gc_cont)->fn, gc_cont, gc_ans);
} }
printf("Internal error: should never have reached this line\n"); exit(0);}} printf("Internal error: should never have reached this line\n"); exit(0);}}

62
scheme/cyclone/cgen.sld
View file

@ -110,12 +110,12 @@
(arry-assign (c-macro-array-assign num-args "buf" "a"))) (arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append (string-append
"/* Check for GC, then call given continuation closure */\n" "/* Check for GC, then call given continuation closure */\n"
"#define return_closcall" n "(cfn" args ") \\\n" "#define return_closcall" n "(td,cfn" args ") \\\n"
"{char stack; \\\n" "{char stack; \\\n"
" if (check_overflow(&stack,stack_limit1)) { \\\n" " if (check_overflow(&stack,stack_limit1)) { \\\n"
" object buf[" n "]; " arry-assign "\\\n" " object buf[" n "]; " arry-assign "\\\n"
" GC(cfn,buf," n "); return; \\\n" " GC(td,cfn,buf," n "); return; \\\n"
" } else {closcall" n "((closure) (cfn)" args "); return;}}\n"))) " } else {closcall" n "(td,(closure) (cfn)" args "); return;}}\n")))
(define (c-macro-return-direct num-args) (define (c-macro-return-direct num-args)
(let ((args (c-macro-n-prefix num-args ",a")) (let ((args (c-macro-n-prefix num-args ",a"))
@ -123,13 +123,13 @@
(arry-assign (c-macro-array-assign num-args "buf" "a"))) (arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append (string-append
"/* Check for GC, then call C function directly */\n" "/* Check for GC, then call C function directly */\n"
"#define return_direct" n "(_fn" args ") { \\\n" "#define return_direct" n "(td,_fn" args ") { \\\n"
" char stack; \\\n" " char stack; \\\n"
" if (check_overflow(&stack,stack_limit1)) { \\\n" " if (check_overflow(&stack,stack_limit1)) { \\\n"
" object buf[" n "]; " arry-assign " \\\n" " object buf[" n "]; " arry-assign " \\\n"
" mclosure0(c1, _fn); \\\n" " mclosure0(c1, _fn); \\\n"
" GC(&c1, buf, " n "); return; \\\n" " GC(td,&c1, buf, " n "); return; \\\n"
" } else { (_fn)(" n ",(closure)_fn" args "); }}\n"))) " } else { (_fn)(td," n ",(closure)_fn" args "); }}\n")))
(define (c-macro-closcall num-args) (define (c-macro-closcall num-args)
(let ((args (c-macro-n-prefix num-args ",a")) (let ((args (c-macro-n-prefix num-args ",a"))
@ -137,10 +137,10 @@
(n-1 (number->string (if (> num-args 0) (- num-args 1) 0))) (n-1 (number->string (if (> num-args 0) (- num-args 1) 0)))
(wrap (lambda (s) (if (> num-args 0) s "")))) (wrap (lambda (s) (if (> num-args 0) s ""))))
(string-append (string-append
"#define closcall" n "(cfn" args ") " "#define closcall" n "(td,cfn" args ") "
(wrap (string-append "if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(" n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }")) (wrap (string-append "if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(td," n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }"))
(wrap " else { ") (wrap " else { ")
"((cfn)->fn)(" n ",cfn" args ")" "((cfn)->fn)(td," n ",cfn" args ")"
(wrap ";}") (wrap ";}")
))) )))
@ -610,7 +610,7 @@
set-car! set-car!
set-cdr! set-cdr!
procedure? procedure?
set-cell!)) set-cell!)))
;; Determine if primitive assigns (allocates) a C variable ;; Determine if primitive assigns (allocates) a C variable
;; EG: int v = prim(); ;; EG: int v = prim();
@ -713,6 +713,10 @@
"," cont "); ")) "," cont "); "))
(else #f))) (else #f)))
;; END apply defs ;; END apply defs
(tdata (cond
((prim/data-arg? p) "data ")
(else "")))
(tdata-comma (if (> (string-length tdata) 0) "," ""))
(c-var-assign (c-var-assign
(lambda (type) (lambda (type)
(let ((cv-name (mangle (gensym 'c)))) (let ((cv-name (mangle (gensym 'c))))
@ -731,12 +735,16 @@
;; Emit closure as first arg, if necessary (apply only) ;; Emit closure as first arg, if necessary (apply only)
(cond (cond
(closure-def (closure-def
(string-append "&" closure-sym (string-append
tdata ","
"&" closure-sym
(if (prim:cont-has-args? p) ", " ""))) (if (prim:cont-has-args? p) ", " "")))
((prim:cont? p) ((prim:cont? p)
(string-append cont (string-append
tdata ","
cont
(if (prim:cont-has-args? p) ", " ""))) (if (prim:cont-has-args? p) ", " "")))
(else ""))))))))) (else tdata)))))))))
(cond (cond
((prim/c-var-assign p) ((prim/c-var-assign p)
(c-var-assign (prim/c-var-assign p))) (c-var-assign (prim/c-var-assign p)))
@ -753,9 +761,9 @@
cv-name ;; Already a pointer cv-name ;; Already a pointer
(string-append "&" cv-name)) ;; Point to data (string-append "&" cv-name)) ;; Point to data
(list (list
(string-append c-func "(" cv-name))))) (string-append c-func "(" cv-name tdata-comma tdata)))))
(else (else
(c-code (string-append c-func "(")))))) (c-code (string-append c-func "(" tdata tdata-comma))))))
;; END primitives ;; END primitives
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -812,7 +820,7 @@
(string-append (string-append
(c:allocs->str (c:allocs cgen)) (c:allocs->str (c:allocs cgen))
"return_direct" (number->string num-cargs) "return_direct" (number->string num-cargs)
"(" this-cont "(data," this-cont
(if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " " (if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
(c:body cgen) ");")))) (c:body cgen) ");"))))
@ -864,7 +872,7 @@
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string (c:num-args cargs)) "return_closcall" (number->string (c:num-args cargs))
"(" "(data,"
this-cont this-cont
(if (> (c:num-args cargs) 0) "," "") (if (> (c:num-args cargs) 0) "," "")
(c:body cargs) (c:body cargs)
@ -883,7 +891,7 @@
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n") (c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string num-cargs) "return_closcall" (number->string num-cargs)
"(" "(data,"
this-cont this-cont
(if (> num-cargs 0) "," "") (if (> num-cargs 0) "," "")
(c:body cargs) (c:body cargs)
@ -1145,7 +1153,7 @@
(cons (cons
(lambda (name) (lambda (name)
(string-append "static void " name (string-append "static void " name
"(int argc, " "(void *data, int argc, "
formals* formals*
") {\n" ") {\n"
preamble preamble
@ -1231,7 +1239,7 @@
(lambda (l) (lambda (l)
(emit* (emit*
"static void __lambda_" "static void __lambda_"
(number->string (car l)) "(int argc, " (number->string (car l)) "(void *data, int argc, "
(cdadr l) (cdadr l)
") ;")) ") ;"))
lambdas) lambdas)
@ -1247,14 +1255,14 @@
; Emit entry point ; Emit entry point
(cond (cond
(program? (program?
(emit "static void c_entry_pt_first_lambda();") (emit "static void c_entry_pt_first_lambda(void *data);")
(for-each (for-each
(lambda (lib-name) (lambda (lib-name)
(emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(int argc, closure cont, object value);")) (emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(void *data, int argc, closure cont, object value);"))
required-libs) required-libs)
(emit "static void c_entry_pt(argc, env,cont) int argc; closure env,cont; { ")) (emit "static void c_entry_pt(data, argc, env,cont) void *data; int argc; closure env,cont; { "))
(else (else
(emit* "void c_" (lib:name->string lib-name) "_entry_pt(argc, cont,value) int argc; closure cont; object value;{ ") (emit* "void c_" (lib:name->string lib-name) "_entry_pt(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ")
; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");")) ; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");"))
)) ))
@ -1357,9 +1365,9 @@
(reverse required-libs)) ;; Init each lib's dependencies 1st (reverse required-libs)) ;; Init each lib's dependencies 1st
(emit* (emit*
;; Start cont chain, but do not assume closcall1 macro was defined ;; Start cont chain, but do not assume closcall1 macro was defined
"(" this-clo ".fn)(0, &" this-clo ", &" this-clo ");") "(" this-clo ".fn)(data, 0, &" this-clo ", &" this-clo ");")
(emit "}") (emit "}")
(emit "static void c_entry_pt_first_lambda(int argc, closure cont, object value) {") (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\");")) ; DEBUG (emit (string-append "printf(\"init first lambda\\n\");"))
(emit compiled-program))) (emit compiled-program)))
(else (else
@ -1369,7 +1377,7 @@
(emit* (emit*
"(((closure)" "(((closure)"
(mangle-global (lib:name->symbol lib-name)) (mangle-global (lib:name->symbol lib-name))
")->fn)(1, cont, cont);") ")->fn)(data, 1, cont, cont);")
)) ))
(emit "}") (emit "}")