From 937f6b61c2095fbc079a05bfc2ff24f88493d722 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 14 Aug 2020 14:37:19 -0400 Subject: [PATCH] Added ffi module --- Makefile | 9 +- ffi.c | 179 ++++++++++++++++++++++++++++++++++++++++ include/cyclone/types.h | 8 ++ 3 files changed, 194 insertions(+), 2 deletions(-) create mode 100644 ffi.c diff --git a/Makefile b/Makefile index ba27b43c..f9ef7130 100644 --- a/Makefile +++ b/Makefile @@ -119,9 +119,10 @@ uninstall : tags : ctags -R * -indent : gc.c runtime.c mstreams.c $(HEADER_DIR)/*.h +indent : gc.c runtime.c ffi.c mstreams.c $(HEADER_DIR)/*.h $(INDENT_CMD) gc.c $(INDENT_CMD) runtime.c + $(INDENT_CMD) ffi.c $(INDENT_CMD) mstreams.c $(INDENT_CMD) $(HEADER_DIR)/*.h @@ -183,6 +184,9 @@ dispatch.o : dispatch.c $(HEADERS) gc.o : gc.c $(HEADERS) $(CCOMP) -std=gnu99 -c $< -o $@ +ffi.o : ffi.c $(HEADERS) + $(CCOMP) -c $< -o $@ + mstreams.o : mstreams.c $(HEADERS) $(CCOMP) -c \ -DCYC_HAVE_OPEN_MEMSTREAM=$(CYC_PLATFORM_HAS_MEMSTREAM) \ @@ -203,7 +207,7 @@ runtime.o : runtime.c $(HEADERS) -DCYC_PLATFORM=\"$(PLATFORM)\" \ $< -o $@ -libcyclone.a : runtime.o gc.o dispatch.o mstreams.o hashset.o +libcyclone.a : runtime.o gc.o dispatch.o ffi.o mstreams.o hashset.o $(CREATE_LIBRARY_COMMAND) $(CREATE_LIBRARY_FLAGS) $@ $& $(RANLIB_COMMAND) # Instructions from: http://www.adp-gmbh.ch/cpp/gcc/create_lib.html @@ -236,6 +240,7 @@ bootstrap : icyc libs cp srfi/*.sld $(BOOTSTRAP_DIR)/srfi cp srfi/*.scm $(BOOTSTRAP_DIR)/srfi cp runtime.c $(BOOTSTRAP_DIR) + cp ffi.c $(BOOTSTRAP_DIR) cp mstreams.c $(BOOTSTRAP_DIR) cp hashset.c $(BOOTSTRAP_DIR) cp gc.c $(BOOTSTRAP_DIR) diff --git a/ffi.c b/ffi.c new file mode 100644 index 00000000..3fa7a8da --- /dev/null +++ b/ffi.c @@ -0,0 +1,179 @@ +/** + * Cyclone Scheme + * https://github.com/justinethier/cyclone + * + * Copyright (c) 2020, Justin Ethier + * All rights reserved. + * + * FFI module to support calling Scheme code from C. + */ + +#include "cyclone/types.h" +#include "cyclone/runtime.h" +#include +#include + +static void Cyc_return_from_scm_call(gc_thread_data *thd, int argc, object k, object result) +{ + // Cleaup thread object per Cyc_exit_thread + gc_remove_mutator(thd); + ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_RUNNABLE, + CYC_THREAD_STATE_TERMINATED); + + // Return to local C caller + vector vec = thd->scm_thread_obj; + gc_thread_data *local = opaque_ptr(vec->elements[4]); + local->gc_cont = result; + longjmp(*(local->jmp_start), 1); +} + +/** + * Scheme function calls into this function when it is done. + * We store results and longjmp back to where we started, at the + * bottom of the trampoline (we only jump once). + */ +static void Cyc_after_scm_call(gc_thread_data *thd, int argc, object k, object result) +{ + mclosure0(clo, Cyc_return_from_scm_call); + object buf[1]; buf[0] = result; + GC(thd, &clo, buf, 1); +} + +/** + * Setup a quick-and-dirty thread object and use it to + * make a call into Scheme code. + * + * Note this call is made in a limited way, and is only + * designed for a quick call. There is no support for + * performing any memory allocation by the Scheme code + * other than temporary objects in the nursery. The + * returned object will need to either be an immediate + * or re-allocated (EG: malloc) before returning it + * to the C layer. + */ +object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *args) +{ + jmp_buf l; + gc_thread_data local; + local.gc_cont = NULL; + local.jmp_start = &l; + + gc_thread_data *td = malloc(sizeof(gc_thread_data)); + gc_add_new_unrunning_mutator(td); /* Register this thread */ + make_c_opaque(co, td); + make_utf8_string(NULL, name_str, ""); + + make_c_opaque(co_parent_thd, parent_thd); + make_c_opaque(co_this_thd, &local); + mclosure0(after, (function_type)Cyc_after_scm_call); + + make_empty_vector(vec); + vec.num_elements = 7; + vec.elements = alloca(sizeof(object) * 5); + vec.elements[0] = find_or_add_symbol("cyc-thread-obj"); + vec.elements[1] = fnc; + vec.elements[2] = &co; + vec.elements[3] = &name_str; + vec.elements[4] = &co_this_thd; //boolean_f; + vec.elements[5] = &co_parent_thd; + vec.elements[6] = &after; + + make_pair(thread_and_thunk, &vec, fnc); // TODO: OK we are not clearing vec[5]? I think so... + + if (!setjmp(*(local.jmp_start))) { + Cyc_init_thread(&thread_and_thunk, argc, args); + } + + return local.gc_cont; +} + +/////////////////////////////////////////////////////////////////////////////// +// +// Simplified interface with no support for GC +// +/////////////////////////////////////////////////////////////////////////////// + +/** + * Scheme function calls into this function when it is done. + * We store results and longjmp back to where we started, at the + * bottom of the trampoline (we only jump once). + */ +static void no_gc_after_call_scm(gc_thread_data *thd, int argc, object k, object result) +{ + thd->gc_cont = result; + longjmp(*(thd->jmp_start), 1); +} + +/** + * Call into Scheme function + */ +static void no_gc_call_scm(gc_thread_data *thd, object fnc, object obj) +{ + mclosure0(after, (function_type)no_gc_after_call_scm); + ((closure)fnc)->fn(thd, 2, fnc, &after, obj); +} + +/** + * Setup a quick-and-dirty thread object and use it to + * make a call into Scheme code. + * + * Note this call is made in a limited way, and is only + * designed for a quick call. There is no support for + * performing any memory allocation by the Scheme code + * other than temporary objects in the nursery. The + * returned object will need to either be an immediate + * or re-allocated (EG: malloc) before returning it + * to the C layer. + */ +object Cyc_scm_call_no_gc(gc_thread_data *parent_thd, object fnc, object arg) +{ + long stack_size = 100000; + char *stack_base = (char *)&stack_size; + char *stack_traces[MAX_STACK_TRACES]; + gc_thread_data thd = {0}; + jmp_buf jmp; + thd.jmp_start = &jmp; + thd.stack_start = stack_base; +#if STACK_GROWTH_IS_DOWNWARD + thd.stack_limit = stack_base - stack_size; +#else + thd.stack_limit = stack_base + stack_size; +#endif + thd.stack_traces = stack_traces; + + thd.thread_id = pthread_self(); + thd.thread_state = CYC_THREAD_STATE_RUNNABLE; + + // Copy parameter objects from the calling thread + object parent = parent_thd->param_objs; // Unbox parent thread's data + object child = NULL; + while (parent) { + if (thd.param_objs == NULL) { + alloca_pair(p, NULL, NULL); + thd.param_objs = p; + child = thd.param_objs; + } else { + alloca_pair(p, NULL, NULL); + cdr(child) = p; + child = p; + } + alloca_pair(cc, car(car(parent)), cdr(car(parent))); + car(child) = cc; + parent = cdr(parent); + } + + // Setup trampoline and call into Scheme + // + // When the Scheme call is done we return result back to C + // + // It is very important to know that the result, IF ON THE STACK, + // is further up the stack than the caller and will be overwritten + // by subsequent C calls on this thread. Thus the caller will want + // to immediately create a copy of the object... + // + if (!setjmp(*(thd.jmp_start))) { + no_gc_call_scm(&thd, fnc, arg); + } else { + return(thd.gc_cont); + } +} diff --git a/include/cyclone/types.h b/include/cyclone/types.h index 48d4bd74..540387e9 100644 --- a/include/cyclone/types.h +++ b/include/cyclone/types.h @@ -549,6 +549,14 @@ object transport_stack_value(gc_thread_data *data, object var, object value, int // END GC section /**@}*/ +/** + * \defgroup ffi Foreign Function Interface + */ +/**@{*/ +object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *args); +object Cyc_scm_call_no_gc(gc_thread_data *parent_thd, object fnc, object arg); +/**@}*/ + /** * \defgroup datatypes Data types * @brief All of the Scheme data types provided by Cyclone.