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

Merge branch 'cargs-dev' into cargs2-dev

Browse source
This commit is contained in:
Justin Ethier 2021-02-15 21:21:15 -05:00
commit 496387293f
5 changed files with 200 additions and 76 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
docs/C-Calling-Conventions.md
View file

@ -58,7 +58,7 @@ Where:
* `data` is state data for the current thread
* `argc` indicates how many arguments were sent by the caller. Generally only applicable for variadic functions.
* `closure` is the caller's closure. Note this is ignored for global functions as closures are never applicable to them.
* `k` is the continuation to call into next.
* `k` is the continuation to call into next. Note this is not necessarily present; it is often placed here as a result of the compiler's CPS conversion phase.
In addition zero or more objects may be listed after that as well as an ellipsis `...` for variadic functions. For example:
@ -79,7 +79,7 @@ Note our `define-c` FFI requires the user to specify the same calling convention
We want a signature similar to this:
static void __lambda(void *data, object closure, object k, int argc, object *args) ;
static void __lambda(void *data, object closure, int argc, object *args) ;
That way we can pack all the extra arguments into `args` and call all functions using a single standard interface.
@ -151,15 +151,16 @@ TODO: Are there any complications in referencing vars from `args` rather than di
## Changes to the FFI
`define-c` needs to use the new signature.
`define-c` needs to use the new signature. **TBD if there is an efficient way to do this without also requiring a migration of existing `define-c` forms. It would be great if existing code would continue to work, thus not making this a breaking change. Perhaps the compiler can detect the old signature and generate scaffolding accordingly.**
`(cyclone foreign)` will need to be modified to generate `define-c` forms that are compatible with the new signatures.
# Development Plan
- Modify compiler to generate code using the new calling conventions
- Modify compiler (scheme/cyclone/cgen.sld) to generate code using the new calling conventions. Test as best we can that C code is generated properly.
- Branch off of master at this point?? At some point we will want to do this to prevent a nasty merge of cargs development back into master.
- Add necessary header definitions
- Modify runtime / primitives to use calling convention
- Modify FFI and define-c definitions
- Modify runtime / primitives to use calling convention. Ensure runtime compiles with these changes in place.
- Modify FFI and define-c definitions in scheme files
- Bring up the compiler in stages. Will need to use the current version of Cyclone to generate a version with the new function signatures.

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

@ -12,7 +12,7 @@
long global_stack_size = 0;
long global_heap_size = 0;
static void c_entry_pt(void *, int, closure, closure);
static void c_entry_pt(void *data, object clo, int argc, object *args);
static void Cyc_heap_init(long heap_size);
static void Cyc_heap_init(long heap_size)

30
include/cyclone/runtime.h
View file

@ -76,6 +76,15 @@ void gc_init_heap(long heap_size);
} \
}
#define Cyc_check_argc(data, fnc_name, argc, expected) { \
if (expected > argc) { \
char buf[128]; \
snprintf(buf, 127, "Expected %d arguments to %s but received %ld", \
expected, fnc_name, argc); \
Cyc_rt_raise_msg(data, buf); \
} \
}
#define Cyc_verify_mutable(data, obj) { \
if (immutable(obj)) Cyc_immutable_obj_error(data, obj); }
#define Cyc_verify_immutable(data, obj) { \
@ -140,28 +149,21 @@ object Cyc_global_set_cps(void *thd, object cont, object sym, object * glo, obje
our compiler will compute the difference between the number of required
args and the number of provided ones, and pass the difference as 'count'
*/
#define load_varargs(var, arg_var, count) \
list var = (count > 0) ? alloca(sizeof(pair_type)*count) : NULL; \
#define load_varargs(var, args_var, start, count) \
list var = ((count) > 0) ? alloca(sizeof(pair_type)*(count)) : NULL; \
{ \
int i; \
object tmp; \
va_list va; \
if (count > 0) { \
va_start(va, arg_var); \
for (i = 0; i < count; i++) { \
if (i) { \
tmp = va_arg(va, object); \
} else { \
tmp = arg_var; \
} \
if ((count) > 0) { \
for (i = 0; i < (count); i++) { \
tmp = args_var[start + i]; \
var[i].hdr.mark = gc_color_red; \
var[i].hdr.grayed = 0; \
var[i].hdr.immutable = 0; \
var[i].tag = pair_tag; \
var[i].pair_car = tmp; \
var[i].pair_cdr = (i == (count-1)) ? NULL : &var[i + 1]; \
var[i].pair_cdr = (i == ((count)-1)) ? NULL : &var[i + 1]; \
} \
va_end(va); \
} \
}
/* Prototypes for primitive functions. */
@ -173,7 +175,7 @@ object Cyc_global_set_cps(void *thd, object cont, object sym, object * glo, obje
/**@{*/
object apply(void *data, object cont, object func, object args);
void Cyc_apply(void *data, int argc, closure cont, object prim, ...);
void Cyc_apply(void *data, object cont, int argc, object *args);
void dispatch_apply_va(void *data, int argc, object clo, object cont, object func, ...);
object apply_va(void *data, object cont, int argc, object func, ...);
void dispatch(void *data, int argc, function_type func, object clo, object cont,

3
runtime.c
View file

@ -5696,6 +5696,9 @@ object apply(void *data, object cont, object func, object args)
}
// Version of apply meant to be called from within compiled code
// TODO: in cargs branch we are swapping cont and prim below
// old call convention, EG: Cyc_apply(td, 0, (closure)(a1), clo);
//
void Cyc_apply(void *data, int argc, closure cont, object prim, ...)
{
va_list ap;

228
scheme/cyclone/cgen.sld
View file

@ -145,12 +145,12 @@
;;"/* Check for GC, then call given continuation closure */\n"
"#define return_closcall" n "(td, clo" args ") { \\\n"
" char top; \\\n"
" object buf[" n "]; " arry-assign "\\\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"
" closcall" n "(td, (closure) (clo), buf); \\\n"
" return;\\\n"
" } \\\n"
"}\n")))
@ -183,13 +183,13 @@
;;"/* Check for GC, then call C function directly */\n"
"#define return_direct" n "(td, _fn" args ") { \\\n"
" char top; \\\n"
" object buf[" n "]; " arry-assign " \\\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"
" (_fn)(td, (closure)_fn, " n ", buf); \\\n"
" }}\n")))
(define (c-macro-return-direct-with-closure num-args)
@ -200,12 +200,12 @@
;;"/* Check for GC, then call C function directly */\n"
"#define return_direct_with_clo" n "(td, clo, _fn" args ") { \\\n"
" char top; \\\n"
" object buf[" n "]; " arry-assign "\\\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"
" (_fn)(td, (closure)(clo), " n ", buf); \\\n"
" }}\n")))
;; Generate hybrid macros that can call a function directly but also receives
@ -218,13 +218,13 @@
;;"/* 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"
" object buf[" n "]; " arry-assign "\\\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"
" (_fn)(td, (closure)(clo), " n ", buf); \\\n"
" }}\n")))
(define (c-macro-closcall num-args)
@ -233,12 +233,12 @@
(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"
"#define closcall" n "(td, clo, buf) \\\n"
(wrap (string-append "if (obj_is_not_closure(clo)) { \\\n"
" Cyc_apply(td, " n-1 ", (closure)(a1), clo" (if (> num-args 1) (substring args 3 (string-length args)) "") "); \\\n"
" Cyc_apply(td, clo, " n ", buf ); \\\n"
"}"))
(wrap " else { \\\n")
" ((clo)->fn)(td, " n ", clo" args ")"
" ((clo)->fn)(td, clo, " n ", buf); \\\n"
(wrap ";\\\n}"))))
(define (c-macro-n-prefix n prefix)
@ -709,6 +709,12 @@
(define-c string-byte-length
"(void *data, int argc, closure _, object k, object s)"
" return_closcall1(data, k, Cyc_string_byte_length(data, s)); ")
; cargs TODO:
;(define-c string-byte-length
; "(void *data, object clo, int argc, object *args)"
; " Cyc_check_argc(data, \"string-byte-length\", argc, 2);
; object s = args[1];
; return_closcall1(data, args[0], Cyc_string_byte_length(data, s)); ")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Primitives
@ -1774,6 +1780,17 @@
(and
(> (string-length tmp-ident) 3)
(equal? "self" (substring tmp-ident 0 4))))
(formals-as-list
(let ((lis (string-split formals #\,)))
(if (null? lis)
(list formals)
lis)))
(closure-name
(if has-closure?
(let* ((lis formals-as-list)
(var (cadr (string-split (car lis) #\space))))
var)
"_"))
(has-loop?
(or
(adbf:calls-self? (adb:get/default (ast:lambda-id exp) (adb:make-fnc)))
@ -1790,6 +1807,46 @@
arg-closure
(string-append arg-closure ",")))
formals))
(c-formals
(cond
(cps?
(string-append
"(void *data, object " closure-name ", int argc, object *args)"
" /* " formals* " */\n"))
(else
(string-append
"(void *data, " arg-argc
formals*
")"))))
(c-arg-unpacking ;; Unpack args array into locals
(cond
;; TODO: how to unpack varargs
(cps?
(let ((i 0)
(cstr "")
(args formals-as-list))
;; Strip off extra varargs since we will load them
;; up using a different technique
(when (ast:lambda-varargs? exp)
(set! args
(reverse
(cddr (reverse args)))))
;; Generate code to unpack args into locals w/expected names
(for-each
(lambda (arg)
(set! cstr (string-append
cstr
arg
" = args["
(number->string i)
"];"
))
(set! i (+ i 1)))
(if has-closure?
(cdr args)
args))
cstr))
(else "")))
(env-closure (lambda->env exp))
(body (c-compile-exp
(car (ast:lambda-body exp)) ; car ==> assume single expr in lambda body after CPS
@ -1801,25 +1858,26 @@
(cons
(lambda (name)
(string-append "static " return-type " " name
"(void *data, " arg-argc
formals*
") {\n"
c-formals
" {\n"
c-arg-unpacking
"\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");
(let ((num-fixargs (- (length (ast:lambda-formals->list exp))
1
(if has-closure? 1 0))))
(string-append
;; DEBUGGING:
;; "printf(\"%d %d\\n\", argc, "
;; (number->string (length (ast:lambda-formals->list exp))) ");"
"load_varargs("
(mangle (ast:lambda-varargs-var exp))
", args"
", " (number->string num-fixargs)
", argc - " (number->string num-fixargs)
");\n"))
"") ; No varargs, skip
(c:serialize
(c:append
@ -2009,9 +2067,13 @@
(else
(emit*
"static void __lambda_"
(number->string (car l)) "(void *data, int argc, "
(number->string (car l))
"(void *data, object clo, int argc, object *args"
") ;"
"/*"
(cdadr l)
") ;"))))
"*/"
))))
lambdas)
(emit "")
@ -2030,7 +2092,6 @@
(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
@ -2038,14 +2099,24 @@
(string-split
(string-replace-all params-str "object" "")
#\,))
#\,)))
#\,))
(unpack-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,"
"(void *data, int argc," ; cargs TODO: update this and call below
params-str
")"
"{"
;; cargs TODO: this is broken, will fix later
unpack-args-str
"\nobject obj = "
"((closure1)" (mangle (car (adbf:all-params fnc))) ")->element;\n"
"__lambda_"
@ -2060,15 +2131,33 @@
;; Print the definitions:
(for-each
(lambda (l)
;(trace:error `(JAE def ,l))
(cond
((equal? 'precompiled-lambda (caadr l))
(emit*
"static void __lambda_"
(number->string (car l))
(cadadr l)
" {"
(car (cddadr l))
" }"))
(cond
((equal? (substring (cadadr l) 0 42)
"(void *data, int argc, closure _, object k")
;; Backwards compatibility for define-c expressions using
;; the old style of all C parameters contained directly
;; in the function definition. The above code finds them
;; and below we emit code that unpacks the args array into
;; a series of local variables
(emit*
"static void __lambda_"
(number->string (car l))
"(void *data, object _, int args, object *args)"
" {"
(c:old-c-args->new-decls-from-args (cadadr l))
(car (cddadr l))
" }"))
(else
(emit*
"static void __lambda_"
(number->string (car l))
(cadadr l)
" {"
(car (cddadr l))
" }"))))
((equal? 'precompiled-inline-lambda (caadr l))
(emit*
"static object __lambda_"
@ -2086,7 +2175,7 @@
;; Emit inlinable function list
(cond
((not program?)
(emit* "void c_" (lib:name->string lib-name) "_inlinable_lambdas(void *data, int argc, closure _, object cont){ ")
(emit* "void c_" (lib:name->string lib-name) "_inlinable_lambdas(void *data, object clo, int argc, object *args){ ")
(let ((pairs '())
(head-pair #f))
(for-each
@ -2098,7 +2187,7 @@
(set! pairs (cons pair-sym pairs))))
*global-inlines*)
;; Link the pairs
(let loop ((code '())
(let loop ((code '())
(ps pairs)
(cs (map (lambda (_) (mangle (gensym 'c))) pairs)))
(cond
@ -2119,23 +2208,23 @@
(loop (cons (string-append "make_pair(" (car cs) ", &" (car ps) ", &" (cadr cs) ");\n") code)
(cdr ps)
(cdr cs)))))
(emit* "object buf[1]; object cont = args[0];");
(if head-pair
(emit* "(((closure)cont)->fn)(data, 1, cont, &" head-pair ");")
(emit* "(((closure)cont)->fn)(data, 1, cont, NULL);"))
(emit* "buf[0] = &" head-pair "; (((closure)cont)->fn)(data, cont, 1, buf);")
(emit* "buf[0] = NULL; (((closure)cont)->fn)(data, cont, 1, buf);"))
(emit* " } "))))
;; Emit entry point
(cond
(program?
(emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value);")
(emit "static void c_entry_pt_first_lambda(void *data, object clo, int argc, object *args);")
(for-each
(lambda (lib-name)
(emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(void *data, int argc, closure cont, object value);"))
(emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(void *data, object clo, int argc, object* args);"))
required-libs)
(emit "static void c_entry_pt(data, argc, env,cont) void *data; int argc; closure env,cont; { "))
(emit "static void c_entry_pt(void *data, object clo, int argc, object *args) { "))
(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\");"))
(emit* "void c_" (lib:name->string lib-name) "_entry_pt_first_lambda(void *data, object clo, int argc, object *args){ ")
))
;; Set global-changed indicator
@ -2270,27 +2359,27 @@
(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 ");")
" object buf[1]; buf[0] = &" this-clo "; "
"(" this-clo ".fn)(data, &" this-clo ", 1, buf);")
(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 "static void c_entry_pt_first_lambda(void *data, object clo, int argc, object *args) {")
(emit compiled-program)
(emit ";")))
(else
;; Do not use closcall1 macro as it might not have been defined
(emit "cont = ((closure1_type *)cont)->element;")
(emit "object buf[1]; buf[0] = ((closure1_type *)clo)->element;")
(emit*
"(((closure)"
(cgen:mangle-global (lib:name->symbol lib-name))
")->fn)(data, 1, cont, cont);")
")->fn)(data, buf[0], 1, buf);")
(emit* "}")
(emit* "void c_" (lib:name->string lib-name) "_entry_pt(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ")
(emit* "void c_" (lib:name->string lib-name) "_entry_pt(void *data, object cont, int argc, 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);")
(emit* " c_" (lib:name->string lib-name) "_entry_pt_first_lambda(data, cont, argc, value);")
;; GC to ensure objects are moved when exporting exports.
;; Otherwise there will be broken hearts :(
(emit*
@ -2302,6 +2391,35 @@
(if program?
(emit *c-main-function*))))
;; Take an old define-c CPS function definition string such as:
;;
;; "(void *data, int argc, closure _, object k, object a, object b, object c)")
;;
;; And convert it to a series of local variable declarations, assigning a value
;; from our new `args` parameter.
;;
;; These declarations are returned as a string.
(define (c:old-c-args->new-decls-from-args cstr)
(let* ((args (cdddr
(string-split
(filter-invalid-chars cstr)
#\,))) ;; Get scheme list of any extra arguments
(vars (map (lambda (a) (cadr (string-split a #\space))) args)) ;; Get identifiers of variables
(i 0)
(str ""))
(for-each ;; Create a set of assignments from args array to new C local variables
(lambda (v)
(set! str (string-append str "object " v " = args[" (number->string i) "];"))
(set! i (+ i 1)))
vars)
str))
(define (filter-invalid-chars str)
(list->string
(filter
(lambda (c)
(not (member c '(#\( #\)))))
(string->list str))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Automatically generate blocks of code for the compiler