diff --git a/src/configure b/src/configure index e30929faa9..d04652e4a2 100755 --- a/src/configure +++ b/src/configure @@ -1349,6 +1349,7 @@ Optional Features: --enable-jit compile JIT support (enabled by default) --enable-foreign compile foreign support (enabled by default) --enable-places compile places support + --enable-futures compile futures support --enable-cgcdefault use CGC (Boehm or Senora) as default build --enable-sgc use Senora GC instead of the Boehm GC --enable-sgcdebug use Senora GC for debugging @@ -1903,6 +1904,11 @@ if test "${enable_places+set}" = set; then enableval=$enable_places; fi +# Check whether --enable-futures was given. +if test "${enable_futures+set}" = set; then + enableval=$enable_futures; +fi + # Check whether --enable-cgcdefault was given. if test "${enable_cgcdefault+set}" = set; then @@ -2250,6 +2256,9 @@ show_explicitly_disabled "${enable_jit}" JIT show_explicitly_disabled "${enable_foreign}" Foreign +show_explicitly_enabled "${enable_places}" Places +show_explicitly_enabled "${enable_futures}" Futures + show_explicitly_enabled "${enable_sgc}" SGC show_explicitly_enabled "${enable_sgcdebug}" "SGC debug mode" show_explicitly_enabled "${enable_compact}" "Compact 3m GC" @@ -10713,6 +10722,13 @@ if test "${enable_places}" = "yes" ; then LIBATOM="LIBATOM_USE" fi +############### futures ################### + +if test "${enable_futures}" = "yes" ; then + PREFLAGS="$PREFLAGS -DFUTURES_ENABLED" + LDFLAGS="$LDFLAGS -pthread" +fi + ################ Xrender ################## if test "${enable_xrender}" = "" ; then diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index a5b6ca46d0..96378b6c91 100644 --- a/src/mzscheme/configure.ac +++ b/src/mzscheme/configure.ac @@ -44,6 +44,7 @@ AC_ARG_ENABLE(jit, [ --enable-jit compile JIT support (enabled b AC_ARG_ENABLE(foreign, [ --enable-foreign compile foreign support (enabled by default)], , enable_foreign=yes) AC_ARG_ENABLE(places, [ --enable-places compile places support]) +AC_ARG_ENABLE(futures, [ --enable-futures compile futures support]) AC_ARG_ENABLE(cgcdefault, [ --enable-cgcdefault use CGC (Boehm or Senora) as default build]) AC_ARG_ENABLE(sgc, [ --enable-sgc use Senora GC instead of the Boehm GC]) @@ -293,6 +294,9 @@ show_explicitly_disabled "${enable_jit}" JIT show_explicitly_disabled "${enable_foreign}" Foreign +show_explicitly_enabled "${enable_places}" Places +show_explicitly_enabled "${enable_futures}" Futures + show_explicitly_enabled "${enable_sgc}" SGC show_explicitly_enabled "${enable_sgcdebug}" "SGC debug mode" show_explicitly_enabled "${enable_compact}" "Compact 3m GC" @@ -1148,6 +1152,13 @@ if test "${enable_places}" = "yes" ; then LIBATOM="LIBATOM_USE" fi +############### futures ################### + +if test "${enable_futures}" = "yes" ; then + PREFLAGS="$PREFLAGS -DFUTURES_ENABLED" + LDFLAGS="$LDFLAGS -pthread" +fi + ################ Xrender ################## if test "${enable_xrender}" = "" ; then diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index 1cf5ac8f65..0a1a9a1211 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -48,6 +48,7 @@ OBJS = salloc.@LTO@ \ eval.@LTO@ \ file.@LTO@ \ fun.@LTO@ \ + future.@LTO@ \ hash.@LTO@ \ jit.@LTO@ \ list.@LTO@ \ @@ -92,6 +93,7 @@ XSRCS = $(XSRCDIR)/salloc.c \ $(XSRCDIR)/eval.c \ $(XSRCDIR)/file.c \ $(XSRCDIR)/fun.c \ + $(XSRCDIR)/future.c \ $(XSRCDIR)/hash.c \ $(XSRCDIR)/jit.c \ $(XSRCDIR)/list.c \ @@ -174,6 +176,8 @@ $(XSRCDIR)/file.c: ../src/file.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/file.c $(SRCDIR)/file.c $(XSRCDIR)/fun.c: ../src/fun.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/fun.c $(SRCDIR)/fun.c +$(XSRCDIR)/future.c: ../src/future.@LTO@ $(XFORMDEP) + $(XFORM) $(XSRCDIR)/future.c $(SRCDIR)/future.c $(XSRCDIR)/hash.c: ../src/hash.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/hash.c $(SRCDIR)/hash.c $(XSRCDIR)/jit.c: ../src/jit.@LTO@ $(XFORMDEP) $(LIGHTNINGDEP) @@ -255,6 +259,8 @@ file.@LTO@: $(XSRCDIR)/file.c $(CC) $(CFLAGS) -c $(XSRCDIR)/file.c -o file.@LTO@ fun.@LTO@: $(XSRCDIR)/fun.c $(CC) $(CFLAGS) -c $(XSRCDIR)/fun.c -o fun.@LTO@ +future.@LTO@: $(XSRCDIR)/future.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/future.c -o future.@LTO@ hash.@LTO@: $(XSRCDIR)/hash.c $(CC) $(CFLAGS) -c $(XSRCDIR)/hash.c -o hash.@LTO@ jit.@LTO@: $(XSRCDIR)/jit.c diff --git a/src/mzscheme/src/Makefile.in b/src/mzscheme/src/Makefile.in index cced9bb7fb..1d45649196 100644 --- a/src/mzscheme/src/Makefile.in +++ b/src/mzscheme/src/Makefile.in @@ -24,6 +24,7 @@ OBJS = salloc.@LTO@ \ eval.@LTO@ \ file.@LTO@ \ fun.@LTO@ \ + future.@LTO@ \ gmp.@LTO@ \ hash.@LTO@ \ jit.@LTO@ \ @@ -66,6 +67,7 @@ SRCS = $(srcdir)/salloc.c \ $(srcdir)/eval.c \ $(srcdir)/file.c \ $(srcdir)/fun.c \ + $(srcdir)/future.c \ $(srcdir)/gmp/gmp.c \ $(srcdir)/hash.c \ $(srcdir)/jit.c \ @@ -170,6 +172,8 @@ file.@LTO@: $(srcdir)/file.c $(CC) $(CFLAGS) -c $(srcdir)/file.c -o file.@LTO@ fun.@LTO@: $(srcdir)/fun.c $(CC) $(CFLAGS) -c $(srcdir)/fun.c -o fun.@LTO@ +future.@LTO@: $(srcdir)/future.c + $(CC) $(CFLAGS) -c $(srcdir)/future.c -o future.@LTO@ gmp.@LTO@: $(srcdir)/gmp/gmp.c $(srcdir)/gmp/gmplonglong.h $(CC) $(CFLAGS) -c $(srcdir)/gmp/gmp.c -o gmp.@LTO@ hash.@LTO@: $(srcdir)/hash.c @@ -262,6 +266,8 @@ file.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../inclu $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c fun.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schmap.inc +future.@LTO@: $(srcdir)/schpriv.h $(srcdir)/future.h $(SCONFIG) $(srcdir)/../include/scheme.h \ + $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c hash.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c jit.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 79b393f791..a25a491421 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -32,6 +32,9 @@ #include "schminc.h" #include "schmach.h" #include "schexpobs.h" +#ifdef FUTURES_ENABLED +# include "future.h" +#endif #define GLOBAL_TABLE_SIZE 500 #define TABLE_CACHE_MAX_SIZE 2048 @@ -465,6 +468,9 @@ static Scheme_Env *place_instance_init_post_kernel() { #if defined(MZ_USE_PLACES) scheme_jit_fill_threadlocal_table(); #endif +#ifdef FUTURES_ENABLED + scheme_init_futures(env); +#endif #ifndef DONT_USE_FOREIGN scheme_init_foreign(env); diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c new file mode 100644 index 0000000000..6be35207d5 --- /dev/null +++ b/src/mzscheme/src/future.c @@ -0,0 +1,808 @@ + +#ifndef UNIT_TEST +# include "schpriv.h" +#endif + +#ifdef FUTURES_ENABLED + +#include "future.h" +#include +#include +#ifdef UNIT_TEST +# include "./tests/unit_test.h" +#endif + +#define THREAD_POOL_SIZE 1 +static pthread_t g_pool_threads[THREAD_POOL_SIZE]; + +future_t *g_future_queue = NULL; +int g_next_futureid = 0; +pthread_t g_rt_threadid = 0; + +static pthread_mutex_t g_future_queue_mutex = PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t g_future_pending_mutex = PTHREAD_MUTEX_INITIALIZER; +static pthread_cond_t g_future_pending_cv = PTHREAD_COND_INITIALIZER; + +//Stuff for scheme runstack +//Some of these may mimic defines in thread.c, but are redefined here +//to avoid making any changes to that file for now (moving anything out into common +//headers, etc.) +#ifndef DEFAULT_INIT_STACK_SIZE +#define DEFAULT_INIT_STACK_SIZE 1000 +#endif + +//Functions +#ifndef UNIT_TEST +static Scheme_Object *future(int argc, Scheme_Object *argv[]); +static Scheme_Object *touch(int argc, Scheme_Object **argv); +static void *worker_thread_future_loop(void *arg); +static void *invoke_rtcall(future_t *future); +static future_t *enqueue_future(void); +static future_t *get_pending_future(void); +static future_t *get_my_future(void); +static future_t *get_future_by_threadid(pthread_t threadid); +static future_t *get_future(int futureid); +static future_t *get_last_future(void); +#else +//Garbage stubs for unit testing +#define START_XFORM_SKIP +#define END_XFORM_SKIP +void scheme_add_global(char *name, int arity, Scheme_Env *env) { } +int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2) { return 1; } +Scheme_Object *future_touch(int futureid) +{ + Scheme_Object *args[1] = { &futureid }; + return touch(1, args); +} +#endif + +void *g_funcargs[5]; +void *func_retval = NULL; + + +/**********************************************************************/ +/* Helpers for debugging */ +/**********************************************************************/ +#ifdef DEBUG_FUTURES +int g_rtcall_count = 0; + +void debug_save_context(void) +{ + future_t *future; + rtcall_context_t *context; + future = get_my_future(); + context = (rtcall_context_t*)malloc(sizeof(rtcall_context_t)); + + future->context = context; + future->context->mz_runstack_start = MZ_RUNSTACK_START; + future->context->mz_runstack = MZ_RUNSTACK; +} + +void debug_assert_context(future_t *future) +{ + rtcall_context_t *context = future->context; + if (MZ_RUNSTACK_START != future->context->mz_runstack_start) + { + printf("MZ_RUNSTACK_START was %p, but future runstack start should be %p.\n", + MZ_RUNSTACK_START, + context->mz_runstack_start); + } + + if (MZ_RUNSTACK != context->mz_runstack) + { + printf("MZ_RUNSTACK was %p, but future runstack should be %p.\n", + MZ_RUNSTACK, + context->mz_runstack); + } +} + +void debug_kill_context(void) +{ + future_t *future; + future = get_my_future(); + free(future->context); + future->context = NULL; +} +#endif + +static Scheme_Object **get_thread_runstack(void) +{ + return MZ_RUNSTACK; +} + + +static Scheme_Object **get_thread_runstack_start(void) +{ + return MZ_RUNSTACK_START; +} + + +/**********************************************************************/ +/* Plumbing for MzScheme initialization */ +/**********************************************************************/ + +//Invoked by the runtime on startup to make +//primitives known +void scheme_init_futures(Scheme_Env *env) +{ + START_XFORM_SKIP; + Scheme_Object *v; + Scheme_Env *newenv; + + futures_init(); + + v = scheme_intern_symbol("#%futures"); + newenv = scheme_primitive_module(v, env); + + scheme_add_global_constant( + "future", + scheme_make_prim_w_arity( + future, + "future", + 1, + 1), + newenv); + + scheme_add_global_constant( + "touch", + scheme_make_prim_w_arity( + touch, + "touch", + 1, + 1), + newenv); + + scheme_finish_primitive_module(newenv); + scheme_protect_primitive_provide(newenv, NULL); + END_XFORM_SKIP; +} + + +//Setup code here that should be invoked on +//the runtime thread. +void futures_init(void) +{ + int i; + pthread_t threadid; + g_rt_threadid = pthread_self(); + + //Create the worker thread pool. These threads will + //'queue up' and wait for futures to become available + for (i = 0; i < THREAD_POOL_SIZE; i++) + { + pthread_create(&threadid, NULL, worker_thread_future_loop, NULL); + g_pool_threads[i] = threadid; + } +} + + +/**********************************************************************/ +/* Primitive implementations */ +/**********************************************************************/ + +Scheme_Object *future(int argc, Scheme_Object *argv[]) +{ + START_XFORM_SKIP; + int init_runstack_size, main_runstack_size; + int futureid = ++g_next_futureid; + future_t *ft; + Scheme_Object **old_rs, **old_rs_start; + Scheme_Native_Closure *nc; + Scheme_Native_Closure_Data *ncd; + Scheme_Object *lambda = argv[0]; + Scheme_Type type = SCHEME_TYPE(lambda); + nc = (Scheme_Native_Closure*)lambda; + ncd = nc->code; + + //Create the future descriptor and add to the queue as 'pending' + pthread_mutex_lock(&g_future_queue_mutex); + ft = enqueue_future(); + pthread_cond_init(&ft->can_continue_cv, NULL); + ft->id = futureid; + ft->orig_lambda = lambda; + ft->pending = 1; + + //Allocate the runstack and copy the runtime thread's + //runstack + init_runstack_size = MZ_RUNSTACK - MZ_RUNSTACK_START; + + ft->runstack_start = scheme_alloc_runstack(init_runstack_size); + ft->runstack = ft->runstack_start + init_runstack_size; + //memcpy(ft->runstack_start, MZ_RUNSTACK_START, main_runstack_size); + + pthread_mutex_unlock(&g_future_queue_mutex); + + //JIT compile the code + //Temporarily repoint MZ_RUNSTACK + //to the worker thread's runstack - + //in case the JIT compiler uses the stack address + //when generating code + //old_rs = MZ_RUNSTACK; + //old_rs_start = MZ_RUNSTACK_START; + //MZ_RUNSTACK = ft->runstack; + //MZ_RUNSTACK_START = ft->runstack_start; + scheme_on_demand_generate_lambda(nc, 0, NULL); + //MZ_RUNSTACK = old_rs; + //MZ_RUNSTACK_START = old_rs_start; + + pthread_mutex_lock(&g_future_queue_mutex); + ft->code = (void*)ncd->code; + pthread_mutex_unlock(&g_future_queue_mutex); + + //Signal that a future is pending + pthread_mutex_lock(&g_future_pending_mutex); + pthread_cond_signal(&g_future_pending_cv); + pthread_mutex_unlock(&g_future_pending_mutex); + + return scheme_make_integer(futureid); + END_XFORM_SKIP; +} + + +Scheme_Object *touch(int argc, Scheme_Object *argv[]) +{ + START_XFORM_SKIP; + Scheme_Object *retval = NULL; + void *rtcall_retval = NULL; + future_t *ft; + int futureid; + + futureid = SCHEME_INT_VAL(argv[0]); + + pthread_mutex_lock(&g_future_queue_mutex); + ft = get_future(futureid); + pthread_mutex_unlock(&g_future_queue_mutex); + + //Spin waiting for primitive calls or a return value from + //the worker thread + wait_for_rtcall_or_completion: + pthread_mutex_lock(&g_future_queue_mutex); + if (ft->work_completed) + { + retval = ft->retval; + + //Destroy the future descriptor + if (ft->prev == NULL) + { + //Set next to be the head of the queue + g_future_queue = ft->next; + if (g_future_queue != NULL) + g_future_queue->prev = NULL; + + free(ft); + } + else + { + ft->prev->next = ft->next; + if (NULL != ft->next) + ft->next->prev = ft->prev; + + free(ft); + } + + pthread_mutex_unlock(&g_future_queue_mutex); + } + else if (ft->rt_prim != NULL) + { + //Invoke the primitive and stash the result + //Release the lock so other threads can manipulate the queue + //while the runtime call executes + pthread_mutex_unlock(&g_future_queue_mutex); + rtcall_retval = invoke_rtcall(ft); + pthread_mutex_lock(&g_future_queue_mutex); + + ft->rt_prim_retval = rtcall_retval; + ft->rt_prim = NULL; + ft->rt_prim_sigtype = 0; + ft->rt_prim_args = NULL; + + //Signal the waiting worker thread that it + //can continue running machine code + pthread_cond_signal(&ft->can_continue_cv); + pthread_mutex_unlock(&g_future_queue_mutex); + + goto wait_for_rtcall_or_completion; + } + else + { + pthread_mutex_unlock(&g_future_queue_mutex); + goto wait_for_rtcall_or_completion; + } + + return retval; + END_XFORM_SKIP; +} + + +//Entry point for a worker thread allocated for +//executing futures. This function will never terminate +//(until the process dies). +void *worker_thread_future_loop(void *arg) +{ + START_XFORM_SKIP; + Scheme_Object *v; + Scheme_Object* (*jitcode)(Scheme_Object*, int, Scheme_Object**); + + wait_for_work: + LOG("Waiting for new future work..."); + pthread_mutex_lock(&g_future_pending_mutex); + pthread_cond_wait(&g_future_pending_cv, &g_future_pending_mutex); + + LOG("Got a signal that a future is pending..."); + + //Work is available for this thread + pthread_mutex_lock(&g_future_queue_mutex); + future_t *ft = get_pending_future(); + ft->pending = 0; + ft->threadid = pthread_self(); + + //Initialize the runstack for this thread + //MZ_RUNSTACK AND MZ_RUNSTACK_START should be thread-local + MZ_RUNSTACK = ft->runstack; + MZ_RUNSTACK_START = ft->runstack_start; + + //Set up the JIT compiler for this thread + scheme_jit_fill_threadlocal_table(); + + jitcode = (Scheme_Object* (*)(Scheme_Object*, int, Scheme_Object**))(ft->code); + pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&g_future_pending_mutex); + + //Run the code + //Passing no arguments for now. + //The lambda passed to a future will always be a parameterless + //function. + //From this thread's perspective, this call will never return + //until all the work to be done in the future has been completed, + //including runtime calls. + v = jitcode(ft->orig_lambda, 0, NULL); + + //Set the return val in the descriptor + pthread_mutex_lock(&g_future_queue_mutex); + ft->work_completed = 1; + ft->retval = v; + pthread_mutex_unlock(&g_future_queue_mutex); + + goto wait_for_work; + + return NULL; + END_XFORM_SKIP; +} + + +//Returns 0 if the call isn't actually executed by this function, +//i.e. if we are already running on the runtime thread. Otherwise returns +//1, and 'retval' is set to point to the return value of the runtime +//call invocation. +int future_do_runtimecall( + void *func, + int sigtype, + void *args, + void *retval) +{ + START_XFORM_SKIP; + future_t *future; + //If already running on the main thread + //or no future is involved, do nothing + //and return FALSE + if (pthread_self() == g_rt_threadid) + { + //Should never get here! This check should be done + //by the caller using the macros defined in scheme-futures.h! + return 0; + } + + //Fetch the future descriptor for this thread + future = get_my_future(); + + //set up the arguments for the runtime call + //to be picked up by the main rt thread + //pthread_mutex_lock(&future->mutex); + pthread_mutex_lock(&g_future_queue_mutex); + + //Update the stack pointer for this future + //to be in sync with MZ_RUNSTACK - the runtime thread + //will use this value to temporarily swap its stack + //for the worker thread's + future->runstack = MZ_RUNSTACK; + future->rt_prim = func; + future->rt_prim_sigtype = sigtype; + future->rt_prim_args = args; + + //Wait for the signal that the RT call is finished + pthread_cond_wait(&future->can_continue_cv, &g_future_queue_mutex); + + //Clear rt call fields before releasing the lock on the descriptor + future->rt_prim = NULL; + future->rt_prim_sigtype = 0; + future->rt_prim_args = NULL; + + retval = future->rt_prim_retval; + pthread_mutex_unlock(&g_future_queue_mutex); + return 1; + END_XFORM_SKIP; +} + + +/**********************************************************************/ +/* Functions for primitive invocation */ +/**********************************************************************/ +int rtcall_void_void(void (*f)()) +{ + START_XFORM_SKIP; + future_t *future; + sig_void_void_t data; + memset(&data, 0, sizeof(sig_void_void_t)); + if (!IS_WORKER_THREAD) + { + return 0; + } + + LOG_RTCALL_VOID_VOID(f); + + #ifdef DEBUG_FUTURES + debug_save_context(); + #endif + + data.prim = f; + + future = get_my_future(); + future->rt_prim_sigtype = SIG_VOID_VOID; + future->calldata.void_void = data; + + future_do_runtimecall((void*)f, SIG_VOID_VOID, NULL, NULL); + + #ifdef DEBUG_FUTURES + debug_kill_context(); + #endif + + return 1; + END_XFORM_SKIP; +} + + +int rtcall_obj_int_pobj_obj( + Scheme_Object* (*f)(Scheme_Object*, int, Scheme_Object**), + Scheme_Object *a, + int b, + Scheme_Object **c, + Scheme_Object *retval) +{ + START_XFORM_SKIP; + future_t *future; + sig_obj_int_pobj_obj_t data; + memset(&data, 0, sizeof(sig_obj_int_pobj_obj_t)); + if (!IS_WORKER_THREAD) + { + return 0; + } + + LOG_RTCALL_OBJ_INT_POBJ_OBJ(f, a, b, c); + + #ifdef DEBUG_FUTURES + debug_save_context(); + #endif + + data.prim = f; + data.a = a; + data.b = b; + data.c = c; + + future = get_my_future(); + future->rt_prim_sigtype = SIG_OBJ_INT_POBJ_OBJ; + future->calldata.obj_int_pobj_obj = data; + + future_do_runtimecall((void*)f, SIG_OBJ_INT_POBJ_OBJ, NULL, NULL); + *retval = *(future->calldata.obj_int_pobj_obj.retval); + + #ifdef DEBUG_FUTURES + debug_kill_context(); + #endif + + return 1; + END_XFORM_SKIP; +} + + +//Does the work of actually invoking a primitive on behalf of a +//future. This function is always invoked on the main (runtime) +//thread. +void *invoke_rtcall(future_t *future) +{ + START_XFORM_SKIP; + void *ret = NULL, *dummy_ret, *args = future->rt_prim_args; + void **arr = NULL; + MZ_MARK_STACK_TYPE lret = 0; + + //Temporarily use the worker thread's runstack + Scheme_Object **old_rs = MZ_RUNSTACK, **old_rs_start = MZ_RUNSTACK_START; + MZ_RUNSTACK = future->runstack; + MZ_RUNSTACK_START = future->runstack_start; + #ifdef DEBUG_FUTURES + debug_assert_context(future); + g_rtcall_count++; + #endif + + switch (future->rt_prim_sigtype) + { + case SIG_VOID_VOID: + { + sig_void_void_t *data = &future->calldata.void_void; + data->prim(); + + //((void (*)(void))future->rt_prim)(); + ret = &dummy_ret; + break; + } + case SIG_OBJ_INT_POBJ_OBJ: + { + sig_obj_int_pobj_obj_t *data = &future->calldata.obj_int_pobj_obj; + data->retval = data->prim( + data->a, + data->b, + data->c); + + //arr = (void**)args; + //ret = (void*)((Scheme_Object* (*)(Scheme_Object*, int, Scheme_Object**))future->rt_prim)( + // (Scheme_Object*)arr[0], + // GET_INT(arr[1]), + // (Scheme_Object**)arr[2]); + + break; + } + case SIG_OBJ_INT_POBJ_VOID: + arr = (void**)args; + ((Scheme_Object* (*)(Scheme_Object*, int, Scheme_Object**))future->rt_prim)( + (Scheme_Object*)arr[0], + GET_INT(arr[1]), + (Scheme_Object**)arr[2]); + + ret = (void*)0x1; + case SIG_INT_OBJARR_OBJ: + arr = (void**)args; + ret = (void*)((Scheme_Object* (*)(int, Scheme_Object*[]))future->rt_prim)( + GET_INT(arr[0]), + (Scheme_Object**)arr[1]); + break; + case SIG_LONG_OBJ_OBJ: + arr = (void**)args; + ret = (void*)((Scheme_Object* (*)(long, Scheme_Object*))future->rt_prim)( + GET_LONG(arr[0]), + (Scheme_Object*)arr[1]); + break; + case SIG_OBJ_OBJ: + ret = (void*)((Scheme_Object* (*)(Scheme_Object*))future->rt_prim)((Scheme_Object*)args); + break; + case SIG_OBJ_OBJ_OBJ: + arr = (void**)args; + ret = (void*)((Scheme_Object * (*)(Scheme_Object*, Scheme_Object*))future->rt_prim)( + (Scheme_Object*)arr[0], + (Scheme_Object*)arr[1]); + break; + case SIG_VOID_PVOID: + ret = ((void* (*)(void))future->rt_prim)(); + break; + case SIG_SNCD_OBJ: + ret = (void*)((Scheme_Object* (*)(Scheme_Native_Closure_Data*))future->rt_prim)( + (Scheme_Native_Closure_Data*)args); + break; + case SIG_OBJ_VOID: + ((void (*)(Scheme_Object*))future->rt_prim)((Scheme_Object*)args); + ret = &dummy_ret; + break; + case SIG_LONG_OBJ: + ret = ((Scheme_Object* (*)(long))future->rt_prim)(GET_LONG(args)); + break; + case SIG_BUCKET_OBJ_INT_VOID: + arr = (void**)args; + ((void (*)(Scheme_Bucket*, Scheme_Object*, int))future->rt_prim)( + (Scheme_Bucket*)arr[0], + (Scheme_Object*)arr[1], + GET_INT(arr[2])); + + ret = &dummy_ret; + break; + case SIG_INT_INT_POBJ_VOID: + arr = (void**)args; + ((void (*)(int, int, Scheme_Object**))future->rt_prim)( + GET_INT(arr[0]), + GET_INT(arr[1]), + (Scheme_Object**)arr[2]); + break; + case SIG_OBJ_OBJ_MZST: + arr = (void**)args; + lret = ((MZ_MARK_STACK_TYPE (*)(Scheme_Object*, Scheme_Object*))future->rt_prim)( + (Scheme_Object*)arr[0], + (Scheme_Object*)arr[1]); + + ret = malloc(sizeof(MZ_MARK_STACK_TYPE)); + *((MZ_MARK_STACK_TYPE*)ret) = lret; + break; + case SIG_BUCKET_VOID: + ((void (*)(Scheme_Bucket*))future->rt_prim)((Scheme_Bucket*)args); + ret = &dummy_ret; + break; + case SIG_POBJ_LONG_OBJ: + arr = (void**)args; + ret = ((Scheme_Object* (*)(Scheme_Object**, long))future->rt_prim)( + (Scheme_Object**)arr[0], + GET_LONG(arr[1])); + break; + case SIG_INT_POBJ_INT_OBJ: + arr = (void**)args; + ret = ((Scheme_Object* (*)(int, Scheme_Object**, int))future->rt_prim)( + GET_INT(arr[0]), + (Scheme_Object**)arr[1], + GET_INT(arr[2])); + break; + case SIG_INT_POBJ_OBJ_OBJ: + arr = (void**)args; + ret = ((Scheme_Object* (*)(int, Scheme_Object**, Scheme_Object*))future->rt_prim)( + GET_INT(arr[0]), + (Scheme_Object**)arr[1], + (Scheme_Object*)arr[2]); + break; + case SIG_ENV_ENV_VOID: + arr = (void**)args; + ((void (*)(Scheme_Env*, Scheme_Env*))future->rt_prim)( + GET_SCHEMEENV(arr[0]), + GET_SCHEMEENV(arr[1])); + break; + } + + //Restore main thread's runstack + MZ_RUNSTACK = old_rs; + MZ_RUNSTACK_START = old_rs_start; + + return ret; + END_XFORM_SKIP; +} + + +/**********************************************************************/ +/* Helpers for manipulating the futures queue */ +/**********************************************************************/ + +future_t *enqueue_future(void) +{ + START_XFORM_SKIP; + future_t *last = get_last_future(); + future_t *ft = (future_t*)malloc(sizeof(future_t)); + memset(ft, 0, sizeof(future_t)); + if (NULL == last) + { + g_future_queue = ft; + return ft; + } + + ft->prev = last; + last->next = ft; + ft->next = NULL; + + return ft; + END_XFORM_SKIP; +} + + +future_t *get_pending_future(void) +{ + START_XFORM_SKIP; + future_t *f; + for (f = g_future_queue; f != NULL; f = f->next) + { + if (f->pending) + return f; + } + + return NULL; + END_XFORM_SKIP; +} + + +future_t *get_my_future(void) +{ + return get_future_by_threadid(pthread_self()); +} + + +future_t *get_future_by_threadid(pthread_t threadid) +{ + START_XFORM_SKIP; + future_t *ft = g_future_queue; + if (NULL == ft) + { + return ft; + } + + while (ft->threadid != threadid) + { + ft = ft->next; + } + + //Sanity check + if (ft->threadid != threadid) + { + return NULL; + } + + return ft; + END_XFORM_SKIP; +} + + +future_t *get_future(int futureid) +{ + START_XFORM_SKIP; + future_t *ft = g_future_queue; + if (NULL == ft) + { + return ft; + } + + while (ft->id != futureid) + { + ft = ft->next; + } + + //Sanity check + if (ft->id != futureid) + { + return NULL; + } + + return ft; + END_XFORM_SKIP; +} + + +future_t *get_last_future(void) +{ + START_XFORM_SKIP; + future_t *ft = g_future_queue; + if (NULL == ft) + { + return ft; + } + + while (ft->next != NULL) + { + ft = ft->next; + } + + return ft; + END_XFORM_SKIP; +} + + +void clear_futures(void) +{ + int i; + future_t *f, *tmp; + pthread_mutex_lock(&g_future_queue_mutex); + for (i = 0; i < THREAD_POOL_SIZE; i++) + { + pthread_cancel(g_pool_threads[i]); + } + + pthread_mutex_unlock(&g_future_queue_mutex); + f = get_last_future(); + if (NULL == f) + return; + + while (1) + { + tmp = f->prev; + free(f); + if (tmp == NULL) + { + break; + } + + tmp->next = NULL; + f = tmp; + } + + g_future_queue = NULL; +} + +#endif diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h new file mode 100644 index 0000000000..36ca694edf --- /dev/null +++ b/src/mzscheme/src/future.h @@ -0,0 +1,487 @@ +#ifndef SCHEME_FUTURES_H +#define SCHEME_FUTURES_H + +#ifndef UNIT_TEST +typedef Scheme_Object*(*prim_t)(int, Scheme_Object**); +#else +#define Scheme_Object void +#define Scheme_Bucket void +#define Scheme_Env void +#define Scheme_Type int +#define scheme_void NULL +#define scheme_false 0x0 +#define START_XFORM_SKIP +#define END_XFORM_SKIP +#define MZ_MARK_STACK_TYPE long +#define Scheme_Native_Closure_Data void +typedef Scheme_Object*(*prim_t)(int, Scheme_Object**); +void scheme_add_global(char *name, int arity, Scheme_Env *env); +int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2); +#endif + +#include "pthread.h" +#include + +extern pthread_t g_rt_threadid; +extern void scheme_init_futures(Scheme_Env *env); +extern int future_do_runtimecall(void *func, int sigtype, void *args, void *retval); +extern void futures_init(void); + +#ifdef DEBUG_FUTURES +//Debugging structure that contains +//all relevant data at the time of a +//runtime call. +typedef struct rtcall_context { + Scheme_Object **mz_runstack_start; + Scheme_Object **mz_runstack; +} rtcall_context_t; +#endif + +typedef struct { + void (*prim)(); +} sig_void_void_t; + +typedef struct { + Scheme_Object* (*prim)(Scheme_Object*, int, Scheme_Object**); + Scheme_Object *a; + int b; + Scheme_Object **c; + Scheme_Object *retval; +} sig_obj_int_pobj_obj_t; + +typedef struct { + int sig_type; + union { + sig_void_void_t void_void; + sig_obj_int_pobj_obj_t obj_int_pobj_obj; + } calldata; +} rtcall_args_t; + +typedef struct future { + int id; + pthread_t threadid; + int pending; + int work_completed; + pthread_cond_t can_continue_cv; + + Scheme_Object **runstack; + Scheme_Object **runstack_start; + Scheme_Object *orig_lambda; + void *code; + + //Runtime call stuff + void *rt_prim; + int rt_prim_sigtype; + void *rt_prim_args; + void *rt_prim_retval; + + union { + sig_void_void_t void_void; + sig_obj_int_pobj_obj_t obj_int_pobj_obj; + } calldata; + + Scheme_Object *retval; + struct future *prev; + struct future *next; + + #ifdef DEBUG_FUTURES + rtcall_context_t *context; + #endif +} future_t; + +#ifdef DEBUG_FUTURES +extern void debug_save_context(void); +extern void debug_kill_context(void); +#else +#define debug_save_context(...) +#define debug_kill_context(...) +#endif + +#ifdef UNIT_TEST +//If unit testing, expose internal functions and vars to +//the test suite +extern future_t *g_future_queue; +extern int g_next_futureid; +extern pthread_t g_rt_threadid; + +extern void *worker_thread_future_loop(void *arg); +extern void *invoke_rtcall(future_t *future); +extern future_t *enqueue_future(void); +extern future_t *get_pending_future(void); +extern future_t *get_my_future(void); +extern future_t *get_future_by_threadid(pthread_t threadid); +extern future_t *get_future(int futureid); +extern future_t *get_last_future(void); +extern void clear_futures(void); +#endif + +//Signature flags for primitive invocations +//Here the convention is SIG_[arg1type]_[arg2type]..._[return type] +#define SIG_VOID_VOID 1 //void -> void +#define SIG_OBJ_INT_POBJ_OBJ 2 //Scheme_Object* -> int -> Scheme_Object** -> Scheme_Object* +#define SIG_INT_OBJARR_OBJ 3 //int -> Scheme_Object*[] -> Scheme_Object* +#define SIG_LONG_OBJ_OBJ 4 //long -> Scheme_Object* -> Scheme_Object* +#define SIG_OBJ_OBJ 5 //Scheme_Object* -> Scheme_Object* +#define SIG_OBJ_OBJ_OBJ 6 //Scheme_Object* -> Scheme_Object* -> Scheme_Object* +#define SIG_VOID_PVOID 7 //void -> void* +#define SIG_SNCD_OBJ 8 //Scheme_Native_Closure_Data* -> Scheme_Object* +#define SIG_OBJ_VOID 9 //Scheme_Object* -> void +#define SIG_LONG_OBJ 10 //long -> Scheme_Object* +#define SIG_BUCKET_OBJ_INT_VOID 11 //Scheme_Bucket* -> Scheme_Object* -> int -> void +#define SIG_INT_INT_POBJ_VOID 12 //int -> int -> Scheme_Object** -> void +#define SIG_OBJ_OBJ_MZST 13 //Scheme_Object* -> Scheme_Object* -> MZ_MARK_STACK_TYPE +#define SIG_BUCKET_VOID 14 //Scheme_Bucket* -> void +#define SIG_POBJ_LONG_OBJ 15 //Scheme_Object** -> long -> Scheme_Object* +#define SIG_INT_POBJ_INT_OBJ 16 //int -> Scheme_Object** -> int -> Scheme_Object* +#define SIG_INT_POBJ_OBJ_OBJ 17 //int -> Scheme_Object** -> Scheme_Object* -> Scheme_Object* +#define SIG_OBJ_INT_POBJ_VOID 18 //Scheme_Object* -> int -> Scheme_Object** -> void +#define SIG_ENV_ENV_VOID 19 //Scheme_Env* -> Scheme_Env* -> void + +//Helper macros for argument marshaling +#ifdef FUTURES_ENABLED +extern void *g_funcargs[]; +extern void *func_retval; + +#define GET_INT(x) *((int*)(x)) +#define GET_LONG(x) *((long*)(x)) +#define GET_SCHEMEOBJ(x) (Scheme_Object*)(x) +#define GET_PSCHEMEOBJ(x) (Scheme_Object**)(x) +#define GET_SCHEMEENV(x) (Scheme_Env*)(x) + +#define IS_WORKER_THREAD (g_rt_threadid != 0 && pthread_self() != g_rt_threadid) +#define ASSERT_CORRECT_THREAD if (g_rt_threadid != 0 && pthread_self() != g_rt_threadid) \ + { \ + printf("%s invoked on wrong thread!\n", __FUNCTION__); \ + /*GDB_BREAK;*/ \ + } + +extern int rtcall_void_void(void (*f)()); +extern int rtcall_obj_int_pobj_obj( + Scheme_Object* (*f)(Scheme_Object*, int, Scheme_Object**), + Scheme_Object *a, + int b, + Scheme_Object **c, + Scheme_Object *retval); + + +/* +#define RTCALL_VOID_VOID(f) \ + if (IS_WORKER_THREAD) \ + { \ + debug_save_context(); \ + future_do_runtimecall((void*)f, SIG_VOID_VOID, NULL, NULL); \ + debug_kill_context(); \ + return; \ + } +*/ + +/* +#define RTCALL_OBJ_INT_POBJ_OBJ(f,a,b,c) \ + g_funcargs[0] = a; \ + g_funcargs[1] = &b; \ + g_funcargs[2] = c; \ + LOG_RTCALL_OBJ_INT_POBJ_OBJ(a, b, c); \ + if (IS_WORKER_THREAD) \ + { \ + debug_save_context(); \ + future_do_runtimecall((void*)f, SIG_OBJ_INT_POBJ_OBJ, &g_funcargs, func_retval); \ + debug_kill_context(); \ + return (Scheme_Object*)func_retval; \ + } +*/ + +#define RTCALL_OBJ_INT_POBJ_VOID(f,a,b,c) \ + g_funcargs[0] = a; \ + g_funcargs[1] = &b; \ + g_funcargs[2] = c; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall((void*)f, SIG_OBJ_INT_POBJ_VOID, &g_funcargs, NULL); \ + } + +#define RTCALL_INT_OBJARR_OBJ(f,a,b) \ + g_funcargs[0] = &a; \ + g_funcargs[1] = b; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_INT_OBJARR_OBJ, \ + &g_funcargs, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_LONG_OBJ_OBJ(f,a,b) \ + g_funcargs[0] = &a; \ + g_funcargs[1] = b; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_LONG_OBJ_OBJ, \ + &g_funcargs, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_OBJ_OBJ(f,a) \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_OBJ_OBJ, \ + a, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_OBJ_OBJ_OBJ(f,a,b) \ + g_funcargs[0] = a; \ + g_funcargs[1] = b; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_OBJ_OBJ_OBJ, \ + &g_funcargs, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_SNCD_OBJ(f,a) \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_SNCD_OBJ, \ + (void*)a, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_OBJ_VOID(f,a) \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_OBJ_VOID, \ + (void*)a, \ + NULL); \ +\ + return; \ + } + +#define RTCALL_LONG_OBJ(f,a) \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_LONG_OBJ, \ + &a, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_BUCKET_OBJ_INT_VOID(f,a,b,c) \ + g_funcargs[0] = a; \ + g_funcargs[1] = b; \ + g_funcargs[2] = &c; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_BUCKET_OBJ_INT_VOID, \ + &g_funcargs, \ + NULL); \ + return; \ + } + +#define RTCALL_INT_INT_POBJ_VOID(f,a,b,c) \ + g_funcargs[0] = &a; \ + g_funcargs[1] = &b; \ + g_funcargs[2] = c; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_INT_INT_POBJ_VOID, \ + &g_funcargs, \ + NULL); \ + return; \ + } + +#define RTCALL_OBJ_OBJ_MZST(f,a,b) \ + MZ_MARK_STACK_TYPE v; \ + MZ_MARK_STACK_TYPE *r; \ + g_funcargs[0] = a; \ + g_funcargs[1] = b; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_OBJ_OBJ_MZST, \ + &g_funcargs, \ + func_retval); \ +\ + r = (MZ_MARK_STACK_TYPE*)func_retval; \ + v = *r; \ + free(r); \ + return v; \ + } + +#define RTCALL_BUCKET_VOID(f,a) \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_BUCKET_VOID, \ + (void*)a, \ + NULL); \ + return; \ + } + +#define RTCALL_POBJ_LONG_OBJ(f,a,b) \ + g_funcargs[0] = a; \ + g_funcargs[1] = &b; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_POBJ_LONG_OBJ, \ + &g_funcargs, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_INT_POBJ_INT_OBJ(f,a,b,c) \ + g_funcargs[0] = &a; \ + g_funcargs[1] = b; \ + g_funcargs[2] = &c; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_INT_POBJ_INT_OBJ, \ + &g_funcargs, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_INT_POBJ_OBJ_OBJ(f,a,b,c) \ + g_funcargs[0] = &a; \ + g_funcargs[1] = b; \ + g_funcargs[2] = c; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_INT_POBJ_OBJ_OBJ, \ + &g_funcargs, \ + func_retval); \ +\ + return (Scheme_Object*)func_retval; \ + } + +#define RTCALL_ENV_ENV_VOID(f,a,b) \ + g_funcargs[0] = a; \ + g_funcargs[1] = b; \ + if (IS_WORKER_THREAD) \ + { \ + future_do_runtimecall( \ + (void*)f, \ + SIG_ENV_ENV_VOID, \ + &g_funcargs, \ + func_retval); \ + } + +#else + +#define RTCALL_VOID_VOID(f) +#define RTCALL_OBJ_INT_POBJ_OBJ(f,a,b,c) LOG_RTCALL_OBJ_INT_POBJ_OBJ(a,b,c) +#define RTCALL_OBJ_INT_POBJ_VOID(f,a,b,c) LOG_RTCALL_OBJ_INT_POBJ_VOID(a,b,c) +#define RTCALL_INT_OBJARR_OBJ(f,a,b) LOG_RTCALL_INT_OBJARR_OBJ(a,b) +#define RTCALL_LONG_OBJ_OBJ(f,a,b) LOG_RTCALL_LONG_OBJ_OBJ(a,b) +#define RTCALL_OBJ_OBJ(f,a) LOG_RTCALL_OBJ_OBJ(a) +#define RTCALL_OBJ_OBJ_OBJ(f,a,b) LOG_RTCALL_OBJ_OBJ_OBJ(a,b) +#define RTCALL_SNCD_OBJ(f,a) LOG_RTCALL_SNCD_OBJ(a) +#define RTCALL_OBJ_VOID(f,a) LOG_RTCALL_OBJ_VOID(a) +#define RTCALL_LONG_OBJ(f,a) LOG_RTCALL_LONG_OBJ(a) +#define RTCALL_BUCKET_OBJ_INT_VOID(f,a,b,c) LOG_RTCALL_BUCKET_OBJ_INT_VOID(a,b,c) +#define RTCALL_INT_INT_POBJ_VOID(f,a,b,c) LOG_RTCALL_INT_INT_POBJ_VOID(a,b,c) +#define RTCALL_OBJ_OBJ_MZST(f,a,b) LOG_RTCALL_OBJ_OBJ_MZST(a,b) +#define RTCALL_BUCKET_VOID(f,a) LOG_RTCALL_BUCKET_VOID(a) +#define RTCALL_POBJ_LONG_OBJ(f,a,b) LOG_RTCALL_POBJ_LONG_OBJ(a,b) +#define RTCALL_INT_POBJ_INT_OBJ(f,a,b,c) LOG_RTCALL_INT_POBJ_INT_OBJ(a,b,c) +#define RTCALL_INT_POBJ_OBJ_OBJ(f,a,b,c) LOG_RTCALL_INT_POBJ_OBJ_OBJ(a,b,c) +#define RTCALL_ENV_ENV_VOID(f,a,b) LOG_RTCALL_ENV_ENV_VOID(a,b) + +#define IS_WORKER_THREAD 0 +#define ASSERT_CORRECT_THREAD + +#endif + +#ifdef LOG_ARGS +#define LOG(a...) do { fprintf(stderr, "%x:%s:%s:%d ", (unsigned) pthread_self(), __FILE__, __FUNCTION__, __LINE__); fprintf(stderr, a); fprintf(stderr, "\n"); fflush(stdout); } while(0) +#define LOG_THISCALL LOG(__FUNCTION__) + +#define LOG_RTCALL_VOID_VOID(f) LOG("(function=%p)", f) +#define LOG_RTCALL_OBJ_INT_POBJ_OBJ(f,a,b,c) LOG("(function = %p, a=%p, b=%d, c=%p)", f, a, b, c) +#define LOG_RTCALL_OBJ_INT_POBJ_VOID(a,b,c) LOG("(%p, %d, %p)", a, b,c) +#define LOG_RTCALL_INT_OBJARR_OBJ(a,b) LOG("(%d, %p)", a, b) +#define LOG_RTCALL_LONG_OBJ_OBJ(a,b) LOG("(%ld, %p)", a, b) +#define LOG_RTCALL_OBJ_OBJ(a) LOG("(%p)", a) +#define LOG_RTCALL_OBJ_OBJ_OBJ(a,b) LOG("(%p, %p)", a, b) +#define LOG_RTCALL_SNCD_OBJ(a) LOG("(%p)", a) +#define LOG_RTCALL_OBJ_VOID(a) LOG("(%p)", a) +#define LOG_RTCALL_LONG_OBJ(a) LOG("(%ld)", a) +#define LOG_RTCALL_BUCKET_OBJ_INT_VOID(a,b,c) LOG("(%p, %p, %d)", a, b, c) +#define LOG_RTCALL_INT_INT_POBJ_VOID(a,b,c) LOG("(%d, %d, %p)", a, b, c) +#define LOG_RTCALL_OBJ_OBJ_MZST(a,b) LOG("(%p, %p)", a, b) +#define LOG_RTCALL_BUCKET_VOID(a) LOG("(%p)", a) +#define LOG_RTCALL_POBJ_LONG_OBJ(a,b) LOG("(%p, %ld)", a, b) +#define LOG_RTCALL_INT_POBJ_INT_OBJ(a,b,c) LOG("(%d, %p, %d)", a, b, c) +#define LOG_RTCALL_INT_POBJ_OBJ_OBJ(a,b,c) LOG("(%d, %p, %p)", a, b, c) +#define LOG_RTCALL_ENV_ENV_VOID(a,b) LOG("(%p, %p)", a, b) +#else +#define LOG(a...) +#define LOG_THISCALL + +#define LOG_RTCALL_VOID_VOID(f) +#define LOG_RTCALL_OBJ_INT_POBJ_OBJ(f,a,b,c) +#define LOG_RTCALL_OBJ_INT_POBJ_VOID(a,b,c) +#define LOG_RTCALL_INT_OBJARR_OBJ(a,b) +#define LOG_RTCALL_LONG_OBJ_OBJ(a,b) +#define LOG_RTCALL_OBJ_OBJ(a) +#define LOG_RTCALL_OBJ_OBJ_OBJ(a,b) +#define LOG_RTCALL_SNCD_OBJ(a) +#define LOG_RTCALL_OBJ_VOID(a) +#define LOG_RTCALL_LONG_OBJ(a) +#define LOG_RTCALL_BUCKET_OBJ_INT_VOID(a,b,c) +#define LOG_RTCALL_INT_INT_POBJ_VOID(a,b,c) +#define LOG_RTCALL_OBJ_OBJ_MZST(a,b) +#define LOG_RTCALL_BUCKET_VOID(a) +#define LOG_RTCALL_POBJ_LONG_OBJ(a,b) +#define LOG_RTCALL_INT_POBJ_INT_OBJ(a,b,c) +#define LOG_RTCALL_INT_POBJ_OBJ_OBJ(a,b,c) +#define LOG_RTCALL_ENV_ENV_VOID(a,b) +#endif + + +#ifdef UNIT_TEST +//These forwarding decls only need to be here to make +//primitives visible to test cases written in C +extern int future_begin_invoke(void *code); +extern Scheme_Object *touch(int argc, Scheme_Object **argv); +extern Scheme_Object *future_touch(int futureid); +#endif + +#endif diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 5c49ac84cc..aa1efc5b06 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -41,6 +41,9 @@ #include "schpriv.h" #include "schmach.h" +#ifdef FUTURES_ENABLED +# include "future.h" +#endif #ifdef MZ_USE_DWARF_LIBUNWIND # include "unwind/libunwind.h" #endif @@ -268,8 +271,8 @@ void scheme_jit_fill_threadlocal_table(); On x86, the thread-local table pointer is loaded on entry to the JIT world into a C stack slot. On x86_64, it is loaded into the callee-saved R14 (and the old value is saved on the C stack). */ -#ifdef MZ_USE_PLACES -#define JIT_THREAD_LOCAL +#if defined(MZ_USE_PLACES) || defined(FUTURES_ENABLED) +# define JIT_THREAD_LOCAL #endif #ifdef JIT_THREAD_LOCAL @@ -2127,22 +2130,72 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, } /* Support for intercepting direct calls to primitives: */ -#if 1 -# define mz_prepare_direct_prim(n) mz_prepare(n) -# define mz_finishr_direct_prim(reg, proc) mz_finishr(reg) -# define mz_direct_only(p) p -#else +#ifdef FUTURES_ENABLED # define mz_prepare_direct_prim(n) mz_prepare(n) # define mz_finishr_direct_prim(reg, proc) (jit_pusharg_p(reg), (void)mz_finish(proc)) # define mz_direct_only(p) /* skip this arg, so that total count <= 3 args */ static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) { + RTCALL_INT_OBJARR_OBJ(proc, argc, MZ_RUNSTACK); return proc(argc, MZ_RUNSTACK); } static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self) { + RTCALL_INT_POBJ_OBJ_OBJ(proc, argc, MZ_RUNSTACK, self); return proc(argc, MZ_RUNSTACK, self); } + +/* Various specific 'futurized' versions of primitives that may + be invoked directly from JIT code and are not considered thread-safe + (are not invoked via apply_multi_from_native, etc.) */ + +static Scheme_Object *ts_scheme_apply_multi_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv) +{ + /* RTCALL_OBJ_INT_POBJ_OBJ(_scheme_apply_multi_from_native, rator, argc, argv); */ + Scheme_Object *ret; + if (rtcall_obj_int_pobj_obj(_scheme_apply_multi_from_native, + rator, + argc, + argv, + ret)) { + return ret; + } + + return _scheme_apply_multi_from_native(rator, argc, argv); +} + +static Scheme_Object *ts_scheme_apply_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv) +{ + /* RTCALL_OBJ_INT_POBJ_OBJ(_scheme_apply_from_native, rator, argc, argv); */ + Scheme_Object *ret; + if (rtcall_obj_int_pobj_obj(_scheme_apply_from_native, + rator, + argc, + argv, + ret)) { + return ret; + } + + return _scheme_apply_from_native(rator, argc, argv); +} + +static void ts_on_demand(void) +{ + /* RTCALL_VOID_VOID(on_demand); */ + if (rtcall_void_void(on_demand)) { + return; + } + + on_demand(); +} +#else +/* futures not enabled */ +# define mz_prepare_direct_prim(n) mz_prepare(n) +# define mz_finishr_direct_prim(reg, proc) mz_finishr(reg) +# define mz_direct_only(p) p +# define ts_scheme_apply_multi_from_native _scheme_apply_multi_from_native +# define ts_scheme_apply_from_native _scheme_apply_from_native +# define ts_on_demand on_demand #endif static int generate_direct_prim_tail_call(mz_jit_state *jitter, int num_rands) @@ -2719,9 +2772,9 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc jit_pusharg_p(JIT_V1); if (num_rands < 0) { jit_movr_p(JIT_V1, JIT_R0); } /* save argc to manually pop runstack */ if (multi_ok) { - (void)mz_finish(_scheme_apply_multi_from_native); + (void)mz_finish(ts_scheme_apply_multi_from_native); } else { - (void)mz_finish(_scheme_apply_from_native); + (void)mz_finish(ts_scheme_apply_from_native); } CHECK_LIMIT(); mz_patch_ucbranch(ref5); @@ -7965,7 +8018,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1); jit_stxi_p(WORDS_TO_BYTES(2), JIT_RUNSTACK, JIT_R2); JIT_UPDATE_THREAD_RSPTR(); - (void)jit_calli(on_demand); /* DARWIN: stack needs to be 16-byte aligned */ + (void)jit_calli(ts_on_demand); /* DARWIN: stack needs to be 16-byte aligned */ CHECK_LIMIT(); /* Restore registers and runstack, and jump to arity checking of newly-created code when argv == runstack (i.e., a tail call): */ @@ -8003,7 +8056,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R2); jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(_scheme_apply_multi_from_native); + (void)mz_finish(ts_scheme_apply_multi_from_native); CHECK_LIMIT(); mz_pop_threadlocal(); mz_pop_locals(); @@ -8452,9 +8505,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_V1); jit_pusharg_p(JIT_R0); if (ii == 1) { - (void)mz_finish(_scheme_apply_multi_from_native); + (void)mz_finish(ts_scheme_apply_multi_from_native); } else { - (void)mz_finish(_scheme_apply_from_native); + (void)mz_finish(ts_scheme_apply_from_native); } jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -9152,7 +9205,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) return 1; } -static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv) +void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv) { Scheme_Native_Closure_Data *ndata = nc->code; Scheme_Closure_Data *data; @@ -9233,7 +9286,7 @@ static void on_demand() argc = MZ_RUNSTACK[1]; argv = (Scheme_Object **)MZ_RUNSTACK[2]; - on_demand_generate_lambda((Scheme_Native_Closure *)c, SCHEME_INT_VAL(argc), argv); + scheme_on_demand_generate_lambda((Scheme_Native_Closure *)c, SCHEME_INT_VAL(argc), argv); } Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, int clear_code_after_jit, @@ -9271,7 +9324,7 @@ Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, in #if 0 /* Compile immediately: */ - on_demand_generate_lambda(ndata); + scheme_on_demand_generate_lambda(ndata); #endif return ndata;