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

futures fixes

Browse Source 
svn: r16829
This commit is contained in:
James Swaine 2009-11-17 15:32:01 +00:00
parent e068d2ef86
commit f50fe8f455
10 changed files with 414 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
src/mzscheme/gc2/newgc.c
View File

@ -32,10 +32,24 @@
#include <stdio.h>
#include <string.h>
#include <assert.h>
#include "pthread.h"
#include "platforms.h"
#include "gc2.h"
#include "gc2_dump.h"
#include "gc2_dump.h"
/*
#ifdef FUTURES_ENABLED
extern pthread_t g_rt_threadid;
#ifdef DEBUG_FUTURES
extern void dump_state(void);
#endif
#endif
*/
#if defined(FUTURES_ENABLED) || defined(INSTRUMENT_PRIMITIVES)
#include "../src/future.h"
#endif
/* the number of tags to use for tagged objects */
#define NUMBER_OF_TAGS 512
@ -771,7 +785,15 @@ inline static void *allocate(const size_t request_size, const int type)
GC_gen0_alloc_page_end = NUM(new_mpage->addr) + GEN0_PAGE_SIZE;
}
else {
#ifdef INSTRUMENT_PRIMITIVES
LOG_PRIM_START(((void*)garbage_collect));
#endif
garbage_collect(gc, 0);
#ifdef INSTRUMENT_PRIMITIVES
LOG_PRIM_END(((void*)garbage_collect));
#endif
}
newptr = GC_gen0_alloc_page_ptr + allocate_size;
ASSERT_VALID_OBJPTR(newptr);
@ -3055,6 +3077,14 @@ extern double scheme_get_inexact_milliseconds(void);
static void garbage_collect(NewGC *gc, int force_full)
{
#ifdef FUTURES_ENABLED
//Sanity check for FUTURES
if (g_rt_threadid != 0 && pthread_self() != g_rt_threadid)
{
printf("garbage_collect invoked on wrong thread!!!\n");
}
#endif
unsigned long old_mem_use = gc->memory_in_use;
unsigned long old_gen0 = gc->gen0.current_size;
int next_gc_full;

4
src/mzscheme/main.c
View File

@ -78,6 +78,10 @@ START_XFORM_SUSPEND;
# endif
#endif
#ifdef INSTRUMENT_PRIMITIVES
extern int g_print_prims;
#endif
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif

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

@ -261,11 +261,13 @@ error.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../incl
$(srcdir)/../src/stypes.h
eval.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/mzmark.c \
$(srcdir)/schmach.h $(srcdir)/mzstkchk.h $(srcdir)/schrunst.h
$(srcdir)/schmach.h $(srcdir)/mzstkchk.h $(srcdir)/schrunst.h \
$(srcdir)/future.h
file.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(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
$(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schmap.inc \
$(srcdir)/future.h
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 \
@ -279,7 +281,8 @@ jit.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../includ
$(srcdir)/lightning/ppc/core.h $(srcdir)/lightning/ppc/core-common.h \
$(srcdir)/lightning/ppc/asm.h $(srcdir)/lightning/ppc/asm-common.h \
$(srcdir)/lightning/ppc/funcs.h $(srcdir)/lightning/ppc/funcs-common.h \
$(srcdir)/lightning/ppc/fp.h $(srcdir)/lightning/ppc/fp-common.h
$(srcdir)/lightning/ppc/fp.h $(srcdir)/lightning/ppc/fp-common.h \
$(srcdir)/future.h
list.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h
module.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \

12
src/mzscheme/src/eval.c
View File

@ -142,7 +142,9 @@
#include "schmach.h"
#ifdef MACOS_STACK_LIMIT
#include <Memory.h>
#endif
#endif
#include "future.h"
#define EMBEDDED_DEFINES_START_ANYWHERE 0
@ -7694,6 +7696,10 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj
*/
#ifdef INSTRUMENT_PRIMITIVES
extern int g_print_prims;
#endif
#ifdef REGISTER_POOR_MACHINE
# define USE_LOCAL_RUNSTACK 0
# define DELAY_THREAD_RUNSTACK_UPDATE 0
@ -7852,8 +7858,10 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
}
f = prim->prim_val;
v = f(num_rands, rands, (Scheme_Object *)prim);
LOG_PRIM_START(f);
v = f(num_rands, rands, (Scheme_Object *)prim);
LOG_PRIM_END(f);
DEBUG_CHECK_TYPE(v);
} else if (type == scheme_closure_type) {
Scheme_Closure_Data *data;

11
src/mzscheme/src/fun.c
View File

@ -2388,10 +2388,14 @@ Scheme_Object *_scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_ran
return do_apply_with_prompt(rator, num_rands, rands, 1, 0);
}
#ifdef INSTRUMENT_PRIMITIVES
extern int g_print_prims;
#endif
Scheme_Object *
scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
/* NOTE: apply_values_execute (in syntax.c) and
tail_call_with_values_from_multiple_result (in jit.c)
assume that this function won't allocate when
@ -2399,6 +2403,13 @@ scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
int i;
Scheme_Thread *p = scheme_current_thread;
#ifdef INSTRUMENT_PRIMITIVES
if (g_print_prims)
{
printf("scheme_tail_apply\n");
}
#endif
p->ku.apply.tail_rator = rator;
p->ku.apply.tail_num_rands = num_rands;

339
src/mzscheme/src/future.c
View File

@ -3,6 +3,10 @@
# include "schpriv.h"
#endif
#ifdef INSTRUMENT_PRIMITIVES
int g_print_prims = 0;
#endif
#ifdef FUTURES_ENABLED
#include "future.h"
@ -12,8 +16,12 @@
# include "./tests/unit_test.h"
#endif
#define THREAD_POOL_SIZE 1
extern void *on_demand_jit_code;
#define THREAD_POOL_SIZE 2
static pthread_t g_pool_threads[THREAD_POOL_SIZE];
static int g_num_avail_threads = 0;
static unsigned long g_cur_cpu_mask = 1;
future_t *g_future_queue = NULL;
int g_next_futureid = 0;
@ -33,8 +41,6 @@ static pthread_cond_t g_future_pending_cv = PTHREAD_COND_INITIALIZER;
//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);
@ -54,7 +60,7 @@ Scheme_Object *future_touch(int futureid)
Scheme_Object *args[1] = { &futureid };
return touch(1, args);
}
#endif
#endif
void *g_funcargs[5];
void *func_retval = NULL;
@ -83,16 +89,20 @@ 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",
printf("Future %d (thread %p) reports MZ_RUNSTACK_START was %p, but future runstack start should be %p.\n",
future->id,
future->threadid,
MZ_RUNSTACK_START,
context->mz_runstack_start);
future->runstack_start);
}
if (MZ_RUNSTACK != context->mz_runstack)
{
printf("MZ_RUNSTACK was %p, but future runstack should be %p.\n",
printf("Future %d (thread %p) reports MZ_RUNSTACK was %p, but future runstack should be %p.\n",
future->id,
future->threadid,
MZ_RUNSTACK,
context->mz_runstack);
future->runstack);
}
}
@ -103,7 +113,6 @@ void debug_kill_context(void)
free(future->context);
future->context = NULL;
}
#endif
static Scheme_Object **get_thread_runstack(void)
{
@ -116,6 +125,50 @@ static Scheme_Object **get_thread_runstack_start(void)
return MZ_RUNSTACK_START;
}
void dump_state(void)
{
future_t *f;
pthread_mutex_lock(&g_future_queue_mutex);
printf("\n");
printf("FUTURES STATE:\n");
printf("-------------------------------------------------------------\n");
if (NULL == g_future_queue)
{
printf("No futures currently running. %d thread(s) available in the thread pool.\n\n", g_num_avail_threads);
pthread_mutex_unlock(&g_future_queue_mutex);
return;
}
for (f = g_future_queue; f != NULL; f = f->next)
{
printf("Future %d [Thread: %p, Runstack start = %p, Runstack = %p]: ", f->id, f->threadid, f->runstack_start, f->runstack);
fflush(stdout);
switch (f->status)
{
case PENDING:
printf("Waiting to be assigned to thread\n");
break;
case RUNNING:
printf("Executing JIT code\n");
break;
case WAITING_FOR_PRIM:
printf("Waiting for runtime primitive invocation (prim=%p)\n", (void*)f->rt_prim);
break;
case FINISHED:
printf("Finished work, waiting for cleanup\n");
break;
}
fflush(stdout);
printf("%d thread(s) available in the thread pool.\n", g_num_avail_threads);
printf("\n");
fflush(stdout);
}
pthread_mutex_unlock(&g_future_queue_mutex);
}
#endif
/**********************************************************************/
/* Plumbing for MzScheme initialization */
@ -143,6 +196,15 @@ void scheme_init_futures(Scheme_Env *env)
1),
newenv);
scheme_add_global_constant(
"num-processors",
scheme_make_prim_w_arity(
num_processors,
"num-processors",
0,
0),
newenv);
scheme_add_global_constant(
"touch",
scheme_make_prim_w_arity(
@ -152,6 +214,26 @@ void scheme_init_futures(Scheme_Env *env)
1),
newenv);
#ifdef INSTRUMENT_PRIMITIVES
scheme_add_global_constant(
"start-primitive-tracking",
scheme_make_prim_w_arity(
start_primitive_tracking,
"start-primitive-tracking",
0,
0),
newenv);
scheme_add_global_constant(
"end-primitive-tracking",
scheme_make_prim_w_arity(
end_primitive_tracking,
"end-primitive-tracking",
0,
0),
newenv);
#endif
scheme_finish_primitive_module(newenv);
scheme_protect_primitive_provide(newenv, NULL);
END_XFORM_SKIP;
@ -164,15 +246,17 @@ void futures_init(void)
{
int i;
pthread_t threadid;
g_rt_threadid = pthread_self();
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;
}
//Create the worker thread pool. These threads will
//'queue up' and wait for futures to become available
for (i = 0; i < THREAD_POOL_SIZE - 1; i++)
{
pthread_create(&threadid, NULL, worker_thread_future_loop, NULL);
g_pool_threads[i] = threadid;
}
g_num_avail_threads = THREAD_POOL_SIZE;
}
@ -180,13 +264,59 @@ void futures_init(void)
/* Primitive implementations */
/**********************************************************************/
#ifdef INSTRUMENT_PRIMITIVES
long start_ms = 0;
Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[])
{
//Get the start time
struct timeval now;
long ms;
gettimeofday(&now, NULL);
start_ms = now.tv_usec / 1000.0;
g_print_prims = 1;
printf("Primitive tracking started at ");
print_ms_and_us();
printf("\n");
return scheme_void;
}
Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[])
{
g_print_prims = 0;
printf("Primitive tracking ended at ");
print_ms_and_us();
printf("\n");
return scheme_void;
}
void print_ms_and_us()
{
struct timeval now;
long ms, us;
gettimeofday(&now, NULL);
//ms = (now.tv_sec * 1000.0) - start_ms;
ms = (now.tv_usec / 1000) - start_ms;
us = now.tv_usec - (ms * 1000) - (start_ms * 1000);
printf("%ld.%ld", ms, us);
}
#endif
Scheme_Object *future(int argc, Scheme_Object *argv[])
{
START_XFORM_SKIP;
#ifdef DEBUG_FUTURES
LOG_THISCALL;
dump_state();
#endif
int init_runstack_size, main_runstack_size;
int futureid = ++g_next_futureid;
int 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];
@ -198,34 +328,41 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
pthread_mutex_lock(&g_future_queue_mutex);
ft = enqueue_future();
pthread_cond_init(&ft->can_continue_cv, NULL);
futureid = ++g_next_futureid;
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;
//Allocate a new scheme stack for the future
//init_runstack_size = MZ_RUNSTACK - MZ_RUNSTACK_START;
init_runstack_size = 1000;
#ifdef DEBUG_FUTURES
printf("Allocating Scheme stack of %d bytes for future %d.\n", init_runstack_size, futureid);
#endif
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);
//pthread_mutex_unlock(&g_future_queue_mutex);
//JIT compile the code
//JIT compile the code if not already jitted
//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;
if (ncd->code == on_demand_jit_code)
{
printf("JIT compiling code.\n");
scheme_on_demand_generate_lambda(nc, 0, NULL);
printf("Code pointer is now %p, and on_demand_jit_code is %p.\n", ncd->code, on_demand_jit_code);
}
else
{
printf("Code pointer was %p, and on_demand_jit_code was %p. Code is already JIT compiled.\n", ncd->code, on_demand_jit_code);
}
pthread_mutex_lock(&g_future_queue_mutex);
//pthread_mutex_lock(&g_future_queue_mutex);
ft->code = (void*)ncd->code;
pthread_mutex_unlock(&g_future_queue_mutex);
@ -239,15 +376,26 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
}
Scheme_Object *num_processors(int argc, Scheme_Object *argv[])
{
return scheme_make_integer(THREAD_POOL_SIZE);
}
Scheme_Object *touch(int argc, Scheme_Object *argv[])
{
START_XFORM_SKIP;
Scheme_Object *retval = NULL;
void *rtcall_retval = NULL;
future_t *ft;
int futureid;
future_t *ft;
int futureid;
futureid = SCHEME_INT_VAL(argv[0]);
futureid = SCHEME_INT_VAL(argv[0]);
#ifdef DEBUG_FUTURES
LOG("touch (future %d)", futureid);
dump_state();
#endif
pthread_mutex_lock(&g_future_queue_mutex);
ft = get_future(futureid);
@ -280,6 +428,8 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
free(ft);
}
//Increment the number of available pool threads
g_num_avail_threads++;
pthread_mutex_unlock(&g_future_queue_mutex);
}
else if (ft->rt_prim != NULL)
@ -288,7 +438,9 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
//Release the lock so other threads can manipulate the queue
//while the runtime call executes
pthread_mutex_unlock(&g_future_queue_mutex);
LOG("Invoking primitive %p on behalf of future %d...", ft->rt_prim, ft->id);
rtcall_retval = invoke_rtcall(ft);
LOG("done.\n");
pthread_mutex_lock(&g_future_queue_mutex);
ft->rt_prim_retval = rtcall_retval;
@ -301,6 +453,10 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
pthread_cond_signal(&ft->can_continue_cv);
pthread_mutex_unlock(&g_future_queue_mutex);
#ifdef DEBUG_FUTURES
dump_state();
#endif
goto wait_for_rtcall_or_completion;
}
else
@ -323,26 +479,42 @@ void *worker_thread_future_loop(void *arg)
Scheme_Object *v;
Scheme_Object* (*jitcode)(Scheme_Object*, int, Scheme_Object**);
//Set processor affinity
pthread_mutex_lock(&g_future_queue_mutex);
if (pthread_setaffinity_np(pthread_self(), sizeof(g_cur_cpu_mask), &g_cur_cpu_mask))
{
printf(
"Could not set CPU affinity (%lu) for thread %p!\n",
++g_cur_cpu_mask,
pthread_self());
}
pthread_mutex_unlock(&g_future_queue_mutex);
wait_for_work:
LOG("Waiting for new future 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...");
//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->status = RUNNING;
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;
//Decrement the number of available pool threads
g_num_avail_threads--;
//Set up the JIT compiler for this thread
scheme_jit_fill_threadlocal_table();
//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);
@ -355,12 +527,17 @@ void *worker_thread_future_loop(void *arg)
//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.
LOG("Running JIT code at %p...\n", ft->code);
v = jitcode(ft->orig_lambda, 0, NULL);
LOG("Finished running JIT code at %p.\n", ft->code);
//Set the return val in the descriptor
pthread_mutex_lock(&g_future_queue_mutex);
ft->work_completed = 1;
ft->retval = v;
//Update the status
ft->status = FINISHED;
pthread_mutex_unlock(&g_future_queue_mutex);
goto wait_for_work;
@ -400,15 +577,18 @@ int future_do_runtimecall(
//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;
//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;
//Update the future's status to waiting
future->status = WAITING_FOR_PRIM;
//Wait for the signal that the RT call is finished
pthread_cond_wait(&future->can_continue_cv, &g_future_queue_mutex);
@ -441,19 +621,20 @@ int rtcall_void_void(void (*f)())
LOG_RTCALL_VOID_VOID(f);
#ifdef DEBUG_FUTURES
debug_save_context();
//debug_save_context();
#endif
data.prim = f;
future = get_my_future();
future->rt_prim_sigtype = SIG_VOID_VOID;
future->rt_prim = (void*)f;
future->calldata.void_void = data;
future_do_runtimecall((void*)f, SIG_VOID_VOID, NULL, NULL);
#ifdef DEBUG_FUTURES
debug_kill_context();
//debug_kill_context();
#endif
return 1;
@ -466,7 +647,7 @@ int rtcall_obj_int_pobj_obj(
Scheme_Object *a,
int b,
Scheme_Object **c,
Scheme_Object *retval)
Scheme_Object **retval)
{
START_XFORM_SKIP;
future_t *future;
@ -480,7 +661,7 @@ int rtcall_obj_int_pobj_obj(
LOG_RTCALL_OBJ_INT_POBJ_OBJ(f, a, b, c);
#ifdef DEBUG_FUTURES
debug_save_context();
//debug_save_context();
#endif
data.prim = f;
@ -490,13 +671,14 @@ int rtcall_obj_int_pobj_obj(
future = get_my_future();
future->rt_prim_sigtype = SIG_OBJ_INT_POBJ_OBJ;
future->rt_prim = (void*)f;
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);
*retval = future->calldata.obj_int_pobj_obj.retval;
#ifdef DEBUG_FUTURES
debug_kill_context();
//debug_kill_context();
#endif
return 1;
@ -519,7 +701,7 @@ void *invoke_rtcall(future_t *future)
MZ_RUNSTACK = future->runstack;
MZ_RUNSTACK_START = future->runstack_start;
#ifdef DEBUG_FUTURES
debug_assert_context(future);
//debug_assert_context(future);
g_rtcall_count++;
#endif
@ -708,46 +890,47 @@ future_t *get_my_future(void)
future_t *get_future_by_threadid(pthread_t threadid)
{
START_XFORM_SKIP;
future_t *ft = g_future_queue;
if (NULL == ft)
future_t *ft = g_future_queue;
if (NULL == ft)
{
printf("Couldn't find a future with thread ID %p!\n", threadid);
return NULL;
}
while (1)
{
if (ft->threadid == threadid)
{
return ft;
}
while (ft->threadid != threadid)
{
ft = ft->next;
return ft;
}
//Sanity check
if (ft->threadid != threadid)
{
return NULL;
}
ft = ft->next;
}
return ft;
END_XFORM_SKIP;
printf("Couldn't find a future with thread ID %p!\n", threadid);
return NULL;
END_XFORM_SKIP;
}
future_t *get_future(int futureid)
{
START_XFORM_SKIP;
future_t *ft = g_future_queue;
if (NULL == ft)
future_t *ft = g_future_queue;
if (NULL == ft)
{
return ft;
return ft;
}
while (ft->id != futureid)
while (ft->id != futureid)
{
ft = ft->next;
ft = ft->next;
}
//Sanity check
if (ft->id != futureid)
if (ft->id != futureid)
{
return NULL;
return NULL;
}
return ft;

51
src/mzscheme/src/future.h
View File

@ -2,6 +2,7 @@
#define SCHEME_FUTURES_H
#ifndef UNIT_TEST
#include "schpriv.h"
typedef Scheme_Object*(*prim_t)(int, Scheme_Object**);
#else
#define Scheme_Object void
@ -23,6 +24,11 @@ int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2);
#include <stdio.h>
extern pthread_t g_rt_threadid;
extern Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]);
extern Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]);
extern Scheme_Object *future(int argc, Scheme_Object *argv[]);
extern Scheme_Object *touch(int argc, Scheme_Object *argv[]);
extern Scheme_Object *num_processors(int argc, Scheme_Object *argv[]);
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);
@ -57,10 +63,16 @@ typedef struct {
} calldata;
} rtcall_args_t;
#define PENDING 0
#define RUNNING 1
#define WAITING_FOR_PRIM 2
#define FINISHED 3
typedef struct future {
int id;
pthread_t threadid;
int pending;
int status;
int pending;
int work_completed;
pthread_cond_t can_continue_cv;
@ -115,6 +127,41 @@ extern future_t *get_last_future(void);
extern void clear_futures(void);
#endif
//Primitive instrumentation stuff
#ifdef INSTRUMENT_PRIMITIVES
extern int g_print_prims;
extern void print_ms_and_us(void);
#define LOG_PRIM_START(p) \
if (g_print_prims) \
{ \
printf("%p ", p); \
print_ms_and_us(); \
printf("\n"); \
}
#define LOG_PRIM_END(p)
/*
#define LOG_PRIM_END(p) \
if (g_print_prims) \
{ \
print_ms_and_us(); \
printf("\n"); \
}
*/
#define LOG_PRIM_W_NAME(name) \
if (g_print_prims) \
{ \
printf("%s ", name); \
print_ms_and_us(); \
printf("\n"); \
}
#else
#define LOG_PRIM_START(p)
#define LOG_PRIM_END(p)
#define LOG_PRIM_W_NAME(name)
#endif
//Signature flags for primitive invocations
//Here the convention is SIG_[arg1type]_[arg2type]..._[return type]
#define SIG_VOID_VOID 1 //void -> void
@ -161,7 +208,7 @@ extern int rtcall_obj_int_pobj_obj(
Scheme_Object *a,
int b,
Scheme_Object **c,
Scheme_Object *retval);
Scheme_Object **retval);
/*

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

@ -41,9 +41,7 @@
#include "schpriv.h"
#include "schmach.h"
#ifdef FUTURES_ENABLED
# include "future.h"
#endif
#ifdef MZ_USE_DWARF_LIBUNWIND
# include "unwind/libunwind.h"
#endif
@ -143,7 +141,7 @@ static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *v
static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code;
static void *syntax_e_code;
static void *on_demand_jit_code;
void *on_demand_jit_code;
static void *on_demand_jit_arity_code;
static void *get_stack_pointer_code;
static void *stack_cache_pop_code;
@ -2129,6 +2127,10 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
return ref2;
}
#ifdef INSTRUMENT_PRIMITIVES
extern int g_print_prims;
#endif
/* Support for intercepting direct calls to primitives: */
#ifdef FUTURES_ENABLED
# define mz_prepare_direct_prim(n) mz_prepare(n)
@ -2136,13 +2138,25 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
# 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)
{
Scheme_Object *ret;
LOG_PRIM_START(proc);
RTCALL_INT_OBJARR_OBJ(proc, argc, MZ_RUNSTACK);
return proc(argc, MZ_RUNSTACK);
ret = proc(argc, MZ_RUNSTACK);
LOG_PRIM_END(proc);
return ret;
}
static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self)
{
Scheme_Object *ret;
LOG_PRIM_START(proc);
RTCALL_INT_POBJ_OBJ_OBJ(proc, argc, MZ_RUNSTACK, self);
return proc(argc, MZ_RUNSTACK, self);
ret = proc(argc, MZ_RUNSTACK, self);
LOG_PRIM_END(proc);
return ret;
}
/* Various specific 'futurized' versions of primitives that may
@ -2152,13 +2166,13 @@ static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc
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;
Scheme_Object *retptr;
if (rtcall_obj_int_pobj_obj(_scheme_apply_multi_from_native,
rator,
argc,
argv,
ret)) {
return ret;
&retptr)) {
return retptr;
}
return _scheme_apply_multi_from_native(rator, argc, argv);
@ -2167,13 +2181,13 @@ static Scheme_Object *ts_scheme_apply_multi_from_native(Scheme_Object *rator, in
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;
Scheme_Object *retptr;
if (rtcall_obj_int_pobj_obj(_scheme_apply_from_native,
rator,
argc,
argv,
ret)) {
return ret;
&retptr)) {
return retptr;
}
return _scheme_apply_from_native(rator, argc, argv);

15
src/mzscheme/src/schnapp.inc
View File

@ -1,3 +1,5 @@
#include "future.h"
/* For non-tail calls, the native context has already
incremented MZ_CONT_MARK_POS. Counter
scheme_do_eval()'s increment, because this
@ -30,8 +32,10 @@ static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator,
}
f = (Scheme_Primitive_Closure_Proc *)prim->prim_val;
LOG_PRIM_START(f);
v = f(argc, argv, (Scheme_Object *)prim);
LOG_PRIM_END(f);
#if PRIM_CHECK_VALUE
if (v == SCHEME_TAIL_CALL_WAITING) {
int i;
@ -68,6 +72,9 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
{
GC_CAN_IGNORE Scheme_Object *v;
MZ_CONT_MARK_POS -= 2;
LOG_PRIM_W_NAME("_scheme_apply");
v = _scheme_apply(rator, argc, argv);
MZ_CONT_MARK_POS += 2;
return v;
@ -75,13 +82,17 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
#else
# if PRIM_CHECK_VALUE
{
LOG_PRIM_W_NAME("_scheme_apply_multi");
GC_CAN_IGNORE Scheme_Object *v;
MZ_CONT_MARK_POS -= 2;
v = _scheme_apply_multi(rator, argc, argv);
MZ_CONT_MARK_POS += 2;
return v;
}
# else
# else
LOG_PRIM_W_NAME("_scheme_tail_apply");
return _scheme_tail_apply(rator, argc, argv);
# endif
#endif

4
src/mzscheme/src/string.c
View File

@ -1872,6 +1872,10 @@ format(int argc, Scheme_Object *argv[])
return scheme_make_sized_utf8_string(s, len);
}
#ifdef INSTRUMENT_PRIMITIVES
extern int g_print_prims;
#endif
static Scheme_Object *
sch_printf(int argc, Scheme_Object *argv[])
{