Added (current-future) as a non-blocking primitive to racket/future.

collects/racket/future.rkt

@@ -4,4 +4,5 @@
 (provide future?
          future
          touch
-         processor-count)
+         processor-count
+         current-future)

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 */

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

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!")