suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge experiment with futures

Browse Source 
svn: r16435
This commit is contained in:
Matthew Flatt 2009-10-26 19:45:13 +00:00
parent 2ab4f88188
commit a4d3b956f7
8 changed files with 1409 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/configure vendored
View File

@ -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

11
src/mzscheme/configure.ac
View File

@ -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

6
src/mzscheme/gc2/Makefile.in
View File

@ -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

6
src/mzscheme/src/Makefile.in
View File

@ -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 \

6
src/mzscheme/src/env.c
View File

@ -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);

808
src/mzscheme/src/future.c Normal file
View File

@ -0,0 +1,808 @@
#ifndef UNIT_TEST
# include "schpriv.h"
#endif
#ifdef FUTURES_ENABLED
#include "future.h"
#include <stdlib.h>
#include <string.h>
#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

487
src/mzscheme/src/future.h Normal file
View File

@ -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 <stdio.h>
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

85
src/mzscheme/src/jit.c
View File

@ -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;