From db46b2ef92d5c504a98906adb9b57459acd054fe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 18 Jun 2012 21:53:43 +0800 Subject: [PATCH] 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 | 53 +++++++++++++++++++++++++++++++++++++++- src/racket/src/future.h | 2 ++ src/racket/src/jit_ts.c | 2 -- src/racket/src/jitcall.c | 24 ++++++++++++++++++ 4 files changed, 78 insertions(+), 3 deletions(-) diff --git a/src/racket/src/future.c b/src/racket/src/future.c index f2fc59efcd..f1d8700ade 100644 --- a/src/racket/src/future.c +++ b/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: diff --git a/src/racket/src/future.h b/src/racket/src/future.h index 177944b87e..eb61020535 100644 --- a/src/racket/src/future.h +++ b/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(); diff --git a/src/racket/src/jit_ts.c b/src/racket/src/jit_ts.c index fe8f1aeef7..0f5de16334 100644 --- a/src/racket/src/jit_ts.c +++ b/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 diff --git a/src/racket/src/jitcall.c b/src/racket/src/jitcall.c index 46c8fb465c..10948a50cb 100644 --- a/src/racket/src/jitcall.c +++ b/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)