futures: make tail-call allocation local or synchronizable

By itself, this change won't help anything, because tail-call
allocation is triggered for something that can't be called directly.
This change sets up part of an improvement for future-local recovery
from stack overflow, though.

(I had trouble constructing a test that would trigger the new code.
Fortunately, the existing tests trigger it.)

src/racket/src/future.c

@@ -2797,7 +2797,7 @@ void scheme_rtcall_allocate_values(const char *who, int src_type, int count, Sch
   future->source_of_request = who;
   future->source_type = src_type;
 
-  future_do_runtimecall(fts, (void*)f, 1, 1);
+  future_do_runtimecall(fts, (void*)f, 1, 0);
 
   /* Fetch the future again, in case moved by a GC */ 
   future = fts->thread->current_ft;
@@ -2805,6 +2805,41 @@ void scheme_rtcall_allocate_values(const char *who, int src_type, int count, Sch
   future->arg_s0 = NULL;
 }
 
+Scheme_Object *scheme_rtcall_tail_apply(const char *who, int src_type, 
+                                        Scheme_Object *rator, int argc, Scheme_Object **argv)
+  XFORM_SKIP_PROC
+/* Called in future thread */
+{
+  Scheme_Future_Thread_State *fts = scheme_future_thread_state;
+  future_t *future = fts->thread->current_ft;
+  Scheme_Object *retval;
+
+  future->prim_protocol = SIG_TAIL_APPLY;
+
+  future->arg_s0 = rator;
+  future->arg_i0 = argc;
+  future->arg_S0 = argv;
+
+  future->time_of_request = get_future_timestamp();
+  future->source_of_request = who;
+  future->source_type = src_type;
+
+  future_do_runtimecall(fts, (void*)scheme_void, 1, 0);
+
+  /* Fetch the future again, in case moved by a GC */ 
+  future = fts->thread->current_ft;
+
+  future->arg_s0 = NULL;
+  future->arg_S0 = NULL;
+
+  retval = future->retval_s;
+  future->retval_s = NULL;
+
+  receive_special_result(future, retval, 1);
+
+  return retval;
+}
+
 #ifdef MZ_PRECISE_GC 
 uintptr_t scheme_rtcall_alloc(const char *who, int src_type)
   XFORM_SKIP_PROC
@@ -3075,6 +3110,22 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future, int is_a
 
         func(future->arg_i0, (Scheme_Thread *)arg_s0);
 
+        break;
+      }
+    case SIG_TAIL_APPLY:
+      {
+        GC_CAN_IGNORE Scheme_Object *arg_s0 = future->arg_s0;
+        GC_CAN_IGNORE Scheme_Object **arg_S0 = future->arg_S0;
+        GC_CAN_IGNORE Scheme_Object *retval;
+
+        future->arg_s0 = NULL;
+        future->arg_S0 = NULL;
+
+        retval = _scheme_tail_apply(arg_s0, future->arg_i0, arg_S0);
+
+        future->retval_s = retval;
+        send_special_result(future, retval);
+
         break;
       }
     case SIG_WRONG_TYPE_EXN:

src/racket/src/future.h

@@ -229,6 +229,7 @@ typedef struct fsemaphore_t {
 #define SIG_MAKE_FSEMAPHORE    5
 #define SIG_FUTURE             6
 #define SIG_WRONG_TYPE_EXN     7
+#define SIG_TAIL_APPLY         8
 
 # include "jit_ts_protos.h"
 
@@ -241,6 +242,7 @@ extern void scheme_rtcall_allocate_values(const char *who, int src_type, int cou
                                           prim_allocate_values_t f);
 extern Scheme_Object *scheme_rtcall_make_fsemaphore(const char *who, int src_type, Scheme_Object *ready);
 extern Scheme_Object *scheme_rtcall_make_future(const char *who, int src_type, Scheme_Object *proc);
+extern Scheme_Object *scheme_rtcall_tail_apply(const char *who, int src_type, Scheme_Object *rator, int argc, Scheme_Object **argv);
 
 void scheme_future_block_until_gc();
 void scheme_future_continue_after_gc();

src/racket/src/jit_ts.c

@@ -94,7 +94,6 @@ define_ts_iS_s(scheme_box_cas, FSRC_MARKS)
 #endif
 
 #ifdef JITCALL_TS_PROCS
-define_ts_siS_s(_scheme_tail_apply_from_native, FSRC_RATOR)
 define_ts_s_s(scheme_force_value_same_mark, FSRC_MARKS)
 define_ts_s_s(scheme_force_one_value_same_mark, FSRC_MARKS)
 #endif
@@ -129,7 +128,6 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
 #else
 # define ts__scheme_apply_multi_from_native _scheme_apply_multi_from_native
 # define ts__scheme_apply_from_native _scheme_apply_from_native
-# define ts__scheme_tail_apply_from_native _scheme_tail_apply_from_native
 # define ts_scheme_force_value_same_mark scheme_force_value_same_mark
 # define ts_scheme_force_one_value_same_mark scheme_force_one_value_same_mark
 # define ts_scheme_force_value_same_mark scheme_force_value_same_mark

src/racket/src/jitcall.c

@@ -149,6 +149,30 @@ Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v)
 
 #endif
 
+#ifdef MZ_USE_FUTURES
+static Scheme_Object *ts__scheme_tail_apply_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv)
+  XFORM_SKIP_PROC
+{
+  if (scheme_use_rtcall) {
+    /* try thread-local allocation: */
+    Scheme_Object **a;    
+    a = MALLOC_N(Scheme_Object *, argc);
+    if (a) {
+      Scheme_Thread *p = scheme_current_thread;
+      memcpy(a, argv, argc * sizeof(Scheme_Object*));
+      p->ku.apply.tail_rator = rator;
+      p->ku.apply.tail_num_rands = argc;
+      p->ku.apply.tail_rands = a;
+      return SCHEME_TAIL_CALL_WAITING;
+    } else
+      return scheme_rtcall_tail_apply("[tail-call]", FSRC_OTHER, rator, argc, argv);
+  } else
+    return _scheme_tail_apply_from_native(rator, argc, argv);
+}
+#else
+# define ts__scheme_tail_apply_from_native _scheme_tail_apply_from_native
+#endif
+
 static Scheme_Object *_scheme_tail_apply_from_native_fixup_args(Scheme_Object *rator,
                                                                 int argc,
                                                                 Scheme_Object **argv)