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

extend C API to abort/capture cont skipping dynamic-winds

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-19 09:23:21 -06:00
parent 5517909a5c
commit b85934d2d4
13 changed files with 119 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/racket/include/mzwin.def
View File

@ -84,6 +84,9 @@ EXPORTS
scheme_with_stack_freeze
scheme_frozen_run_some
scheme_is_in_frozen_stack
scheme_abort_continuation_no_dws
scheme_call_with_composable_no_dws
scheme_set_on_atomic_timeout
scheme_signal_error
scheme_raise_exn
scheme_warning

3
src/racket/include/mzwin3m.def
View File

@ -84,6 +84,9 @@ EXPORTS
scheme_with_stack_freeze
scheme_frozen_run_some
scheme_is_in_frozen_stack
scheme_abort_continuation_no_dws
scheme_call_with_composable_no_dws
scheme_set_on_atomic_timeout
scheme_signal_error
scheme_raise_exn
scheme_warning

3
src/racket/include/racket.exp
View File

@ -82,6 +82,9 @@ scheme_pop_break_enable
scheme_with_stack_freeze
scheme_frozen_run_some
scheme_is_in_frozen_stack
scheme_abort_continuation_no_dws
scheme_call_with_composable_no_dws
scheme_set_on_atomic_timeout
scheme_signal_error
scheme_raise_exn
scheme_warning

3
src/racket/include/racket3m.exp
View File

@ -82,6 +82,9 @@ scheme_pop_break_enable
scheme_with_stack_freeze
scheme_frozen_run_some
scheme_is_in_frozen_stack
scheme_abort_continuation_no_dws
scheme_call_with_composable_no_dws
scheme_set_on_atomic_timeout
scheme_signal_error
scheme_raise_exn
scheme_warning

6
src/racket/include/scheme.h
View File

@ -882,7 +882,7 @@ typedef struct Scheme_Continuation_Jump_State {
struct Scheme_Object *alt_full_continuation;
Scheme_Object *val; /* or **vals */
mzshort num_vals;
short is_kill, is_escape;
char is_kill, is_escape, skip_dws;
} Scheme_Continuation_Jump_State;
/* A mark position is in odd number, so that it can be
@ -1684,6 +1684,8 @@ extern void *scheme_malloc_envunbox(size_t);
/* embedding configuration and hooks */
/*========================================================================*/
typedef void (*Scheme_On_Atomic_Timeout_Proc)(void);
#if SCHEME_DIRECT_EMBEDDED
#if defined(_IBMR2)
@ -1810,7 +1812,7 @@ MZ_EXTERN void scheme_register_static(void *ptr, long size);
# define MZ_REGISTER_STATIC(x) /* empty */
#endif
MZ_EXTERN void (*scheme_on_atomic_timeout)(void);
MZ_EXTERN Scheme_On_Atomic_Timeout_Proc scheme_on_atomic_timeout;
MZ_EXTERN void scheme_immediate_exit(int status);

3
src/racket/src/eval.c
View File

@ -8906,6 +8906,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
p->cjs.alt_full_continuation = NULL;
p->overflow = overflow;
p->stack_start = overflow->stack_start;
p->cjs.skip_dws = 0;
scheme_longjmpup(&overflow->jmp->cont);
}
} else {
@ -8916,6 +8917,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
p->cjs.num_vals = 1;
p->cjs.val = (Scheme_Object *)c;
p->cjs.is_escape = 1;
p->cjs.skip_dws = 0;
if (prompt_mc) {
/* The prompt is from a meta-continuation that's different
@ -9008,6 +9010,7 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj
p->cjs.val = value;
p->cjs.jumping_to_continuation = obj;
p->cjs.alt_full_continuation = alt_full;
p->cjs.skip_dws = 0;
scheme_longjmp(MZTHREADELEM(p, error_buf), 1);
}

76
src/racket/src/fun.c
View File

@ -4481,6 +4481,7 @@ static void reset_cjs(Scheme_Continuation_Jump_State *a)
a->num_vals = 0;
a->is_kill = 0;
a->is_escape = 0;
a->skip_dws = 0;
}
void scheme_clear_escape(void)
@ -4499,6 +4500,7 @@ static void copy_cjs(Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump
a->num_vals = b->num_vals;
a->is_kill = b->is_kill;
a->is_escape = b->is_escape;
a->skip_dws = b->skip_dws;
}
Scheme_Object *
@ -5402,7 +5404,8 @@ static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
Scheme_Cont *cont,
MZ_MARK_STACK_TYPE copied_cms,
int clear_cm_caches,
Scheme_Object **_sub_conts)
Scheme_Object **_sub_conts,
int skip_dws)
{
Scheme_Thread *p = scheme_current_thread;
int old_cac = scheme_continuation_application_count;
@ -5426,7 +5429,8 @@ static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
clear_cm_caches);
copied_cms = MZ_CONT_MARK_STACK;
pre(dwl->dw->data);
if (!skip_dws)
pre(dwl->dw->data);
if (scheme_continuation_application_count != old_cac) {
old_cac = scheme_continuation_application_count;
@ -5954,7 +5958,8 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
meta_depth += dw->next_meta;
}
copied_cms = exec_dyn_wind_pres(dwl, dwl_len, cont, copied_cms, clear_cm_caches, &sub_conts);
copied_cms = exec_dyn_wind_pres(dwl, dwl_len, cont, copied_cms, clear_cm_caches, &sub_conts,
cont->skip_dws);
p = scheme_current_thread;
p->dw = all_dw;
p->next_meta = cont->next_meta;
@ -6012,7 +6017,7 @@ internal_call_cc (int argc, Scheme_Object *argv[])
barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
if (composable) {
if (composable && SCHEME_FALSEP(argv[2])) {
if (!prompt && !barrier_prompt->is_barrier) {
/* Pseduo-prompt ok. */
} else {
@ -6221,6 +6226,9 @@ internal_call_cc (int argc, Scheme_Object *argv[])
} else if (composable || cont->escape_cont) {
Scheme_Object *argv2[1];
if (SCHEME_TRUEP(argv[2]))
cont->skip_dws = 1;
argv2[0] = (Scheme_Object *)cont;
ret = _scheme_tail_apply(argv[0], 1, argv2);
return ret;
@ -7127,6 +7135,7 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch
p->cjs.val = (Scheme_Object *)cont;
p->cjs.num_vals = 1;
p->cjs.is_escape = 1;
p->cjs.skip_dws = 0;
p->stack_start = mc->overflow->stack_start;
p->decompose_mc = mc;
@ -7159,7 +7168,7 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch
return value;
}
static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], int skip_dws)
{
Scheme_Object *prompt_tag;
Scheme_Prompt *prompt;
@ -7197,13 +7206,31 @@ static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
}
p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
p->cjs.alt_full_continuation = NULL;
p->cjs.skip_dws = skip_dws;
scheme_longjmp(*p->error_buf, 1);
return NULL;
}
static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
{
return do_abort_continuation(argc, argv, 0);
}
Scheme_Object *scheme_abort_continuation_no_dws (Scheme_Object *pt, Scheme_Object *v)
{
/* This function is useful for GRacket-like extensions of Racket that need to
implement something like subtreads through composable continuations. */
Scheme_Object *a[2];
a[0] = pt;
a[1] = v;
return do_abort_continuation(2, a, 1);
}
static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int no_dws)
{
Scheme_Object *prompt_tag;
Scheme_Object *a[3];
@ -7220,13 +7247,29 @@ static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
a[0] = argv[0];
a[1] = prompt_tag;
a[2] = scheme_true;
a[2] = (no_dws ? scheme_true : scheme_false);
/* Trampoline to internal_call_cc. This trampoline ensures that
the runstack is flushed before we try to grab the continuation. */
return _scheme_tail_apply(internal_call_cc_prim, 3, a);
}
static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
{
return do_call_with_control(argc, argv, 0);
}
Scheme_Object *scheme_call_with_composable_no_dws (Scheme_Object *proc, Scheme_Object *pt)
{
/* Works with scheme_abort_continuation_no_dws() above. */
Scheme_Object *a[2];
a[0] = proc;
a[1] = pt;
return do_call_with_control(2, a, 1);
}
static Scheme_Object *continuation_marks(Scheme_Thread *p,
Scheme_Object *_cont,
Scheme_Object *econt,
@ -8373,14 +8416,16 @@ Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
} else {
Scheme_Continuation_Jump_State cjs;
p = scheme_current_thread;
ASSERT_SUSPEND_BREAK_ZERO();
p->suspend_break++;
copy_cjs(&cjs, &p->cjs);
reset_cjs(&p->cjs);
post(data);
copy_cjs(&p->cjs, &cjs);
p = scheme_current_thread;
--p->suspend_break;
if (!p->cjs.skip_dws) {
ASSERT_SUSPEND_BREAK_ZERO();
p->suspend_break++;
copy_cjs(&cjs, &p->cjs);
reset_cjs(&p->cjs);
post(data);
copy_cjs(&p->cjs, &cjs);
p = scheme_current_thread;
--p->suspend_break;
}
}
}
@ -8558,6 +8603,7 @@ static Scheme_Object *jump_to_alt_continuation()
p->cjs.jumping_to_continuation = NULL;
p->cjs.alt_full_continuation = NULL;
p->cjs.val = NULL;
p->cjs.skip_dws = 0;
return scheme_jump_to_continuation(fc, p->cjs.num_vals, args, NULL, 0);
}

5
src/racket/src/schemef.h
View File

@ -180,6 +180,11 @@ MZ_EXTERN int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha
MZ_EXTERN int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs);
MZ_EXTERN int scheme_is_in_frozen_stack();
MZ_EXTERN Scheme_Object *scheme_abort_continuation_no_dws (Scheme_Object *pt, Scheme_Object *v);
MZ_EXTERN Scheme_Object *scheme_call_with_composable_no_dws (Scheme_Object *proc, Scheme_Object *pt);
MZ_EXTERN Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p);
/*========================================================================*/
/* error handling */
/*========================================================================*/

3
src/racket/src/schemex.h
View File

@ -142,6 +142,9 @@ void (*scheme_pop_break_enable)(Scheme_Cont_Frame_Data *cframe, int post_check);
int (*scheme_with_stack_freeze)(Scheme_Frozen_Stack_Proc wha_f, void *wha_data);
int (*scheme_frozen_run_some)(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs);
int (*scheme_is_in_frozen_stack)();
Scheme_Object *scheme_abort_continuation_no_dws;
Scheme_Object *scheme_call_with_composable_no_dws;
Scheme_On_Atomic_Timeout_Proc (*scheme_set_on_atomic_timeout)(Scheme_On_Atomic_Timeout_Proc p);
/*========================================================================*/
/* error handling */
/*========================================================================*/

3
src/racket/src/schemex.inc
View File

@ -90,6 +90,9 @@
scheme_extension_table->scheme_with_stack_freeze = scheme_with_stack_freeze;
scheme_extension_table->scheme_frozen_run_some = scheme_frozen_run_some;
scheme_extension_table->scheme_is_in_frozen_stack = scheme_is_in_frozen_stack;
scheme_extension_table->scheme_abort_continuation_no_dws = scheme_abort_continuation_no_dws;
scheme_extension_table->scheme_call_with_composable_no_dws = scheme_call_with_composable_no_dws;
scheme_extension_table->scheme_set_on_atomic_timeout = scheme_set_on_atomic_timeout;
scheme_extension_table->scheme_signal_error = scheme_signal_error;
scheme_extension_table->scheme_raise_exn = scheme_raise_exn;
scheme_extension_table->scheme_warning = scheme_warning;

3
src/racket/src/schemexm.h
View File

@ -90,6 +90,9 @@
#define scheme_with_stack_freeze (scheme_extension_table->scheme_with_stack_freeze)
#define scheme_frozen_run_some (scheme_extension_table->scheme_frozen_run_some)
#define scheme_is_in_frozen_stack (scheme_extension_table->scheme_is_in_frozen_stack)
#define scheme_abort_continuation_no_dws (scheme_extension_table->scheme_abort_continuation_no_dws)
#define scheme_call_with_composable_no_dws (scheme_extension_table->scheme_call_with_composable_no_dws)
#define scheme_set_on_atomic_timeout (scheme_extension_table->scheme_set_on_atomic_timeout)
#define scheme_signal_error (scheme_extension_table->scheme_signal_error)
#define scheme_raise_exn (scheme_extension_table->scheme_raise_exn)
#define scheme_warning (scheme_extension_table->scheme_warning)

2
src/racket/src/schpriv.h
View File

@ -1312,7 +1312,7 @@ typedef struct Scheme_Dynamic_Wind {
typedef struct Scheme_Cont {
Scheme_Object so;
char composable, has_prompt_dw, need_meta_prompt;
char composable, has_prompt_dw, need_meta_prompt, skip_dws;
struct Scheme_Meta_Continuation *meta_continuation;
Scheme_Jumpup_Buf buf;
Scheme_Dynamic_Wind *dw;

25
src/racket/src/thread.c
View File

@ -207,6 +207,7 @@ HOOK_SHARED_OK void (*scheme_notify_multithread)(int on);
HOOK_SHARED_OK void (*scheme_wakeup_on_input)(void *fds);
HOOK_SHARED_OK int (*scheme_check_for_break)(void);
HOOK_SHARED_OK void (*scheme_on_atomic_timeout)(void);
HOOK_SHARED_OK static int atomic_timeout_auto_suspend;
ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol;
ROSYM static Scheme_Object *client_symbol, *server_symbol;
@ -3272,6 +3273,7 @@ static Scheme_Object *def_nested_exn_handler(int argc, Scheme_Object *argv[])
p->cjs.alt_full_continuation = NULL;
p->cjs.val = argv[0];
p->cjs.is_kill = 0;
p->cjs.skip_dws = 0;
scheme_longjmp(*p->error_buf, 1);
}
@ -3875,6 +3877,7 @@ static void exit_or_escape(Scheme_Thread *p)
p->cjs.jumping_to_continuation = (Scheme_Object *)p;
p->cjs.alt_full_continuation = NULL;
p->cjs.is_kill = 1;
p->cjs.skip_dws = 0;
scheme_longjmp(*p->error_buf, 1);
}
@ -4216,8 +4219,16 @@ void scheme_thread_block(float sleep_time)
swap_target = next;
next = NULL;
do_swap_thread();
} else if (do_atomic && scheme_on_atomic_timeout) {
} else if (do_atomic && scheme_on_atomic_timeout
&& (atomic_timeout_auto_suspend < 2)) {
if (atomic_timeout_auto_suspend) {
atomic_timeout_auto_suspend++;
scheme_fuel_counter = p->engine_weight;
scheme_jit_stack_boundary = scheme_stack_boundary;
}
scheme_on_atomic_timeout();
if (atomic_timeout_auto_suspend > 1)
--atomic_timeout_auto_suspend;
} else {
/* If all processes are blocked, check for total process sleeping: */
if (p->block_descriptor != NOT_BLOCKED) {
@ -4470,6 +4481,18 @@ static void wait_until_suspend_ok()
}
}
Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p)
{
Scheme_On_Atomic_Timeout_Proc old;
old = scheme_on_atomic_timeout;
scheme_on_atomic_timeout = p;
if (p)
atomic_timeout_auto_suspend = 1;
return old;
}
void scheme_weak_suspend_thread(Scheme_Thread *r)
{
if (r->running & MZTHREAD_SUSPENDED)