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

scheme/future, sequential futures implementation when --enable-futures not specified; doc updates

Browse Source 
svn: r16999
This commit is contained in:
Matthew Flatt 2009-11-23 18:12:23 +00:00
parent 7662ef4bc1
commit f719aac2be
5 changed files with 164 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/scheme/future.ss Normal file
View File

@ -0,0 +1,7 @@
#lang scheme/base
(require '#%futures)
(provide future?
future
touch
processor-count)

18
collects/scribblings/futures/futures.scrbl
View File

@ -9,16 +9,18 @@
scribble/struct
(for-label scheme/base
scheme/contract
'#%futures))
scheme/future))
@; ----------------------------------------------------------------------
PLT's future support is only enabled if you pass
@DFlag{enable-futures} to @exec{configure} when you build PLT (and that
build currently only works with @exec{mzscheme}, not with
@exec{mred}).
PLT's parallel-future support is only enabled if you pass
@DFlag{enable-futures} to @exec{configure} when you build PLT (and
that build currently only works with @exec{mzscheme}, not with
@exec{mred}). When parallel-future support is not enabled,
@scheme[future] just remembers the given thunk to call sequentially
on a later @scheme[touch].
@defmodule['#%futures]{}
@defmodule[scheme/future]{}
@defproc[(future [thunk (-> any)]) future?]{
Starts running @scheme[thunk] in parallel.
@ -33,3 +35,7 @@ build currently only works with @exec{mzscheme}, not with
Returns @scheme[#t] if @scheme[x] is a future.
}
@defproc[(processor-count) exact-positive-integer?]{
Returns the number of processors available on the current system.
}

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

@ -6,26 +6,94 @@
//This will be TRUE if primitive tracking has been enabled
//by the program
static Scheme_Object *future_p(int argc, Scheme_Object *argv[])
{
if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type))
return scheme_true;
else
return scheme_false;
}
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
#ifndef FUTURES_ENABLED
/* Futures not enabled, but make a stub module */
/* Futures not enabled, but make a stub module and implementation */
typedef struct future_t {
Scheme_Object so;
Scheme_Object *running_sema;
Scheme_Object *orig_lambda;
Scheme_Object *retval;
int no_retval;
} future_t;
static Scheme_Object *future(int argc, Scheme_Object *argv[])
{
scheme_signal_error("future: not enabled");
return NULL;
future_t *ft;
scheme_check_proc_arity("future", 0, 0, argc, argv);
ft = MALLOC_ONE_TAGGED(future_t);
ft->so.type = scheme_future_type;
ft->orig_lambda = argv[0];
return (Scheme_Object *)ft;
}
static Scheme_Object *touch(int argc, Scheme_Object *argv[])
{
scheme_signal_error("touch: not enabled");
future_t * volatile ft;
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type))
scheme_wrong_type("touch", "future", 0, argc, argv);
ft = (future_t *)argv[0];
while (1) {
if (ft->retval) return ft->retval;
if (ft->no_retval)
scheme_signal_error("touch: future previously aborted");
if (ft->running_sema) {
scheme_wait_sema(ft->running_sema, 0);
scheme_post_sema(ft->running_sema);
} else {
Scheme_Object *sema;
mz_jmp_buf newbuf, * volatile savebuf;
Scheme_Thread *p = scheme_current_thread;
/* In case another Scheme thread touchs the future. */
sema = scheme_make_sema(0);
ft->running_sema = sema;
savebuf = p->error_buf;
p->error_buf = &newbuf;
if (scheme_setjmp(newbuf)) {
ft->no_retval = 1;
scheme_post_sema(ft->running_sema);
scheme_longjmp(*savebuf, 1);
} else {
GC_CAN_IGNORE Scheme_Object *retval, *proc;
proc = ft->orig_lambda;
ft->orig_lambda = NULL; /* don't hold on to proc */
retval = _scheme_apply(proc, 0, NULL);
ft->retval = retval;
scheme_post_sema(ft->running_sema);
p->error_buf = savebuf;
}
}
}
return NULL;
}
static Scheme_Object *processor_count(int argc, Scheme_Object *argv[])
{
scheme_signal_error("processor-count: not enabled");
return NULL;
return scheme_make_integer(1);
}
# define FUTURE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env)
@ -37,12 +105,17 @@ void scheme_init_futures(Scheme_Env *env)
newenv = scheme_primitive_module(scheme_intern_symbol("#%futures"),
env);
FUTURE_PRIM_W_ARITY("future?", future_p, 1, 1, newenv);
FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv);
FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv);
FUTURE_PRIM_W_ARITY("processor-count", processor_count, 1, 1, newenv);
scheme_finish_primitive_module(newenv);
scheme_protect_primitive_provide(newenv, NULL);
#ifdef MZ_PRECISE_GC
register_traversers();
#endif
}
#else
@ -106,10 +179,6 @@ THREAD_LOCAL_DECL(void *jit_future_storage[2]);
THREAD_LOCAL_DECL(extern unsigned long GC_gen0_alloc_page_ptr);
#endif
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
static void start_gc_not_ok(Scheme_Future_State *fs);
static void end_gc_not_ok(Scheme_Future_Thread_State *fts,
Scheme_Future_State *fs,
@ -203,6 +272,16 @@ void scheme_init_futures(Scheme_Env *env)
v = scheme_intern_symbol("#%futures");
newenv = scheme_primitive_module(v, env);
scheme_add_global_constant(
"future?",
scheme_make_folding_prim(
future_p,
"future?",
1,
1,
1),
newenv);
scheme_add_global_constant(
"future",
scheme_make_prim_w_arity(
@ -1000,6 +1079,7 @@ static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile
if (scheme_setjmp(newbuf)) {
pthread_mutex_lock(&fs->future_mutex);
future->no_retval = 1;
future->work_completed = 1;
//Signal the waiting worker thread that it
//can continue running machine code
pthread_cond_signal(future->can_continue_cv);
@ -1046,6 +1126,8 @@ future_t *get_pending_future(Scheme_Future_State *fs)
return NULL;
}
#endif
/**********************************************************************/
/* Precise GC */
/**********************************************************************/
@ -1059,11 +1141,13 @@ START_XFORM_SKIP;
static void register_traversers(void)
{
#ifdef FUTURES_ENABLED
GC_REG_TRAV(scheme_future_type, future);
#else
GC_REG_TRAV(scheme_future_type, sequential_future);
#endif
}
END_XFORM_SKIP;
#endif
#endif

33
src/mzscheme/src/mzmark.c
View File

@ -5413,6 +5413,8 @@ static int native_unclosed_proc_plus_case_FIXUP(void *p) {
#ifdef MARKS_FOR_FUTURE_C
#ifdef FUTURES_ENABLED
static int future_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(future_t));
@ -5468,6 +5470,37 @@ static int future_FIXUP(void *p) {
#define future_IS_CONST_SIZE 1
#else
static int sequential_future_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(future_t));
}
static int sequential_future_MARK(void *p) {
future_t *f = (future_t *)p;
gcMARK(f->orig_lambda);
gcMARK(f->running_sema);
gcMARK(f->retval);
return
gcBYTES_TO_WORDS(sizeof(future_t));
}
static int sequential_future_FIXUP(void *p) {
future_t *f = (future_t *)p;
gcFIXUP(f->orig_lambda);
gcFIXUP(f->running_sema);
gcFIXUP(f->retval);
return
gcBYTES_TO_WORDS(sizeof(future_t));
}
#define sequential_future_IS_ATOMIC 0
#define sequential_future_IS_CONST_SIZE 1
#endif
#endif /* FUTURE */
/**********************************************************************/

16
src/mzscheme/src/mzmarksrc.c
View File

@ -2220,6 +2220,8 @@ END jit;
START future;
#ifdef FUTURES_ENABLED
future {
mark:
future_t *f = (future_t *)p;
@ -2244,6 +2246,20 @@ future {
gcBYTES_TO_WORDS(sizeof(future_t));
}
#else
sequential_future {
mark:
future_t *f = (future_t *)p;
gcMARK(f->orig_lambda);
gcMARK(f->running_sema);
gcMARK(f->retval);
size:
gcBYTES_TO_WORDS(sizeof(future_t));
}
#endif
END future;
/**********************************************************************/