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

Added (current-future) to the futures module (as an inlined, nonblocking primitive).

Browse Source
This commit is contained in:
James Swaine 2010-08-18 23:33:22 -05:00
parent dac2bcaa20
commit a41c9b882a
3 changed files with 79 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
collects/tests/future/future.rkt
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/future
(require scheme/future
scheme/list
rackunit)
#|Need to add expressions which raise exceptions inside a
@ -147,3 +148,58 @@ We should also test deep continuations.
(continuation-mark-set->list (touch f2) 'x)
(continuation-mark-set->list (current-continuation-marks) 'x))))
;Tests for current-future
(check-equal? '() (current-future))
(check-equal? #t (null? (current-future)))
(check-equal? #t (equal? (current-future) (current-future)))
(let ([f (future (λ () (current-future)))])
(check-equal? #t (equal? f (touch f))))
;Where futures might be touched before ever making it
;to a worker kernel thread
(let ([f1 (future (λ () (current-future)))]
[f2 (future (λ () (current-future)))])
(check-equal? #t (equal? f1 (touch f1)))
(check-equal? #f (equal? f2 (touch f1)))
(check-equal? #t (equal? f2 (touch f2)))
(check-equal? #f (equal? (touch f2) (touch f1)))
(check-equal? #f (equal? (current-future) (touch f1)))
(check-equal? #f (equal? (current-future) (touch f2))))
;Where futures are pretty much guaranteed to be running
;on a worker thread
(let ([f1 (future (λ () (current-future)))]
[f2 (future (λ () (current-future)))])
(sleep 3)
(check-equal? #t (equal? f1 (touch f1)))
(check-equal? #f (equal? f2 (touch f1)))
(check-equal? #t (equal? f2 (touch f2)))
(check-equal? #f (equal? (touch f2) (touch f1)))
(check-equal? #f (equal? (current-future) (touch f1)))
(check-equal? #f (equal? (current-future) (touch f2))))
;Preceding current-future with an obvious blocking call
(let ([f1 (future (λ () (sleep 1) (current-future)))]
[f2 (future (λ () (sleep 1) (current-future)))])
(check-equal? #t (equal? f1 (touch f1)))
(check-equal? #f (equal? f2 (touch f1)))
(check-equal? #t (equal? f2 (touch f2)))
(check-equal? #f (equal? (touch f2) (touch f1)))
(check-equal? #f (equal? (current-future) (touch f1)))
(check-equal? #f (equal? (current-future) (touch f2))))
(let* ([fs (build-list 20 (λ (n) (future (λ () (current-future)))))]
[retvalfs (map touch fs)])
(check-equal? 20 (length (remove-duplicates retvalfs))))

66
src/racket/src/future.c
View File

@ -60,11 +60,6 @@ static Scheme_Object *future(int argc, Scheme_Object *argv[])
return (Scheme_Object *)ft;
}
static Scheme_Object *current_future(int argc, Scheme_Object *argv[])
{
return scheme_make_null();
}
static Scheme_Object *touch(int argc, Scheme_Object *argv[])
{
future_t * volatile ft;
@ -129,6 +124,11 @@ static Scheme_Object *processor_count(int argc, Scheme_Object *argv[])
return scheme_make_integer(1);
}
Scheme_Object *current_future(int argc, Scheme_Object *argv[])
{
return scheme_make_null();
}
# define FUTURE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env)
void scheme_init_futures(Scheme_Env *newenv)
@ -197,7 +197,6 @@ void scheme_init_futures_once()
static Scheme_Object *future(int argc, Scheme_Object *argv[]);
static Scheme_Object *touch(int argc, Scheme_Object *argv[]);
static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_future(int argc, Scheme_Object *argv[]);
static void futures_init(void);
static void init_future_thread(struct Scheme_Future_State *fs, int i);
@ -298,13 +297,7 @@ typedef struct future_thread_params_t {
/* Invoked by the runtime on startup to make primitives known */
void scheme_init_futures(Scheme_Env *newenv)
{
Scheme_Object *v, *p;
Scheme_Env *newenv;
futures_init();
v = scheme_intern_symbol("#%futures");
newenv = scheme_primitive_module(v, env);
Scheme_Object *p;
scheme_add_global_constant(
"future?",
@ -342,16 +335,6 @@ void scheme_init_futures(Scheme_Env *newenv)
1,
1),
newenv);
/*
scheme_add_global_constant(
"current-future",
scheme_make_prim_w_arity(
current_future,
"current-future",
0,
0),
newenv);
*/
p = scheme_make_immed_prim(
current_future,
@ -361,15 +344,6 @@ void scheme_init_futures(Scheme_Env *newenv)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("current-future", p, newenv);
scheme_add_global_constant(
"current-future",
scheme_make_prim_w_arity(
current_future,
"current-future",
0,
0),
newenv);
scheme_finish_primitive_module(newenv);
scheme_protect_primitive_provide(newenv, NULL);
}
@ -397,6 +371,13 @@ void futures_init(void)
REGISTER_SO(fs->future_queue_end);
REGISTER_SO(fs->future_waiting_atomic);
REGISTER_SO(jit_future_storage);
/* Create a 'dummy' future thread state object for the runtime
thread, so that current-future will work even for
thunks that are touched before fetched by a worker thread
and are executed on the runtime thread */
scheme_future_thread_state = (Scheme_Future_Thread_State*)malloc(sizeof(Scheme_Future_Thread_State));
memset(scheme_future_thread_state, 0, sizeof(Scheme_Future_Thread_State));
mzrt_mutex_create(&fs->future_mutex);
mzrt_sema_create(&fs->future_pending_sema, 0);
@ -659,16 +640,6 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
return (Scheme_Object*)ft;
}
Scheme_Object *current_future(int argc, Scheme_Object *argv[])
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
if (NULL == fts || NULL == fts->current_ft)
return scheme_make_null();
return (Scheme_Object*)(fts->current_ft);
}
int future_ready(Scheme_Object *obj)
/* Called in runtime thread by Scheme scheduler */
{
@ -709,6 +680,7 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
/* Called in runtime thread */
{
Scheme_Future_State *fs = scheme_future_state;
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
Scheme_Object *retval = NULL;
future_t *ft;
@ -731,9 +703,11 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
ft->status = RUNNING;
mzrt_mutex_unlock(fs->future_mutex);
fts->current_ft = ft;
retval = scheme_apply_multi(ft->orig_lambda, 0, NULL);
send_special_result(ft, retval);
fts->current_ft = NULL;
mzrt_mutex_lock(fs->future_mutex);
ft->work_completed = 1;
ft->retval = retval;
@ -823,9 +797,13 @@ Scheme_Object *processor_count(int argc, Scheme_Object *argv[])
}
Scheme_Object *current_future(int argc, Scheme_Object *argv[])
/* Called in runtime thread */
/* Called from any thread (either runtime or future) */
{
return scheme_false;
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
if (NULL == fts || NULL == fts->current_ft)
return scheme_make_null();
return (Scheme_Object*)(fts->current_ft);
}
/* Entry point for a worker thread allocated for

1
src/racket/src/jit.c
View File

@ -8264,7 +8264,6 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
generate_nary_arith(jitter, app, 0, 1, for_branch, branch_short);
return 1;
} else if (IS_NAMED_PRIM(rator, "current-future")) {
printf("current-future\n");
mz_rs_sync();
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
mz_prepare(0);