diff --git a/collects/racket/future.rkt b/collects/racket/future.rkt index ac13738a55..eece3e1f25 100644 --- a/collects/racket/future.rkt +++ b/collects/racket/future.rkt @@ -4,4 +4,5 @@ (provide future? future touch - processor-count) + processor-count + current-future) diff --git a/src/racket/src/future.c b/src/racket/src/future.c index 490947e828..75450ff496 100644 --- a/src/racket/src/future.c +++ b/src/racket/src/future.c @@ -60,6 +60,11 @@ 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; @@ -137,6 +142,7 @@ void scheme_init_futures(Scheme_Env *env) 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, 0, 0, newenv); + FUTURE_PRIM_W_ARITY("current-future", current_future, 0, 0, newenv); scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); @@ -296,7 +302,7 @@ typedef struct future_thread_params_t { /* Invoked by the runtime on startup to make primitives known */ void scheme_init_futures(Scheme_Env *env) { - Scheme_Object *v; + Scheme_Object *v, *p; Scheme_Env *newenv; futures_init(); @@ -340,6 +346,24 @@ void scheme_init_futures(Scheme_Env *env) 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, + "current-future", + 0, + 0); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; + scheme_add_global_constant("current-future", p, newenv); scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); @@ -625,6 +649,15 @@ 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 */ diff --git a/src/racket/src/future.h b/src/racket/src/future.h index 57a366f8cf..82f75a20c4 100644 --- a/src/racket/src/future.h +++ b/src/racket/src/future.h @@ -141,6 +141,8 @@ void scheme_future_continue_after_gc(); void scheme_check_future_work(); void scheme_future_gc_pause(); +Scheme_Object *current_future(int argc, Scheme_Object *argv[]); + #ifdef UNIT_TEST //These forwarding decls only need to be here to make //primitives visible to test cases written in C diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 494ca0e9cb..f6c13de38e 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -8231,7 +8231,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int /* de-sync's; for branch, sync'd before */ { Scheme_Object *rator = app->args[0]; - + if (!SCHEME_PRIMP(rator)) return 0; @@ -8260,6 +8260,14 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } else if (IS_NAMED_PRIM(rator, ">=")) { 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); + mz_finish(current_future); + jit_retval(JIT_R0); + return 1; } else if (!for_branch) { if (IS_NAMED_PRIM(rator, "vector-set!") || IS_NAMED_PRIM(rator, "unsafe-vector-set!")