On 2012-09-04 00:45:05 -0400, Asumu Takikawa wrote: > I've attached a patch that implements something like what I described
Stevie's Law: Emails you send that say "file attached" will never have the file attached. --Asumu
>From a5eecb89c484f5dc643a085348dfef7885ddff26 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa <as...@ccs.neu.edu> Date: Fri, 31 Aug 2012 16:26:50 -0400 Subject: [PATCH] Modify call/cc to invoke the prompt handler in some cases --- src/racket/src/eval.c | 141 ++++++++++++++++++++++++++----------------------- 1 file changed, 76 insertions(+), 65 deletions(-) diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 65d138e..4fe1fef 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1490,6 +1490,23 @@ static int exec_dyn_wind_posts(Scheme_Dynamic_Wind *common, Scheme_Cont *c, int return common_depth; } +static Scheme_Object *callcc_thunk(int argc, Scheme_Object **argv, Scheme_Object *prim) +{ + Scheme_Object *cont = SCHEME_PRIM_CLOSURE_ELS(prim)[0]; + int num_rands = (int)SCHEME_PRIM_CLOSURE_ELS(prim)[1]; + Scheme_Object *val = SCHEME_PRIM_CLOSURE_ELS(prim)[2]; + + if (num_rands == 1) { + Scheme_Object *a[1]; + a[0] = val; + return _scheme_apply_multi(cont, 1, a); + } + else { + Scheme_Object** vals = (Scheme_Object**)val; + return _scheme_apply_multi(cont, num_rands, vals); + } +} + Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object **old_runstack, int can_ec) { @@ -1550,6 +1567,63 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc prompt = lookup_cont_prompt(c, &prompt_mc, &prompt_pos, LOOKUP_NO_PROMPT); barrier_prompt = check_barrier(prompt, prompt_mc, prompt_pos, c); + if (prompt && + !(prompt->id && (prompt->id == c->prompt_id) + && !prompt_mc)) { + Scheme_Object* a[3]; + Scheme_Object* thunk; + Scheme_Dynamic_Wind* dw; + Scheme_Meta_Continuation* mc; + c->composable = 1; + + /* Remove extra dynamic wind records in call/cc continuation + to pretend it was composable to begin with */ + dw = c->dw; + if (dw && dw->prompt_tag == c->prompt_tag) + c->dw = NULL; + + for (; dw; dw = dw->prev) { + if (dw->prev && c->prompt_tag && + (dw->prev->prompt_tag == c->prompt_tag)) { + dw->prev = NULL; + break; + } + } + + /* Remove extra meta-continuation for composable */ + mc = c->meta_continuation; + if (mc && mc->pseudo && mc->prompt_tag == c->prompt_tag) + c->meta_continuation = NULL; + + for (; mc; mc = mc->next) { + if (mc->pseudo && mc->empty_to_next && mc->next + && SAME_OBJ(mc->next->prompt_tag, c->prompt_tag)) { + mc->next = NULL; + break; + } + } + + a[0] = (Scheme_Object *)c; + a[1] = (Scheme_Object *)num_rands; + a[2] = (Scheme_Object *)value; + thunk = scheme_make_prim_closure_w_arity(callcc_thunk, + 3, a, + "callcc-thunk", + 0, 0); + + p->cjs.jumping_to_continuation = (Scheme_Object *)prompt; + p->cjs.alt_full_continuation = NULL; + p->cjs.num_vals = 1; + p->cjs.val = thunk; + p->cjs.is_escape = 0; + p->cjs.skip_dws = 0; + + MZ_RUNSTACK = old_runstack; + scheme_longjmp(*p->error_buf, 1); + + return NULL; + } + p->suspend_break++; /* restored at call/cc destination */ /* Find `common', the intersection of dynamic-wind chain for @@ -1637,73 +1711,10 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc p->cjs.skip_dws = 0; scheme_longjmpup(&overflow->jmp->cont); } - } else { - /* The prompt is different than when we captured the continuation, - so we need to compose the continuation with the current prompt. */ - p->cjs.jumping_to_continuation = (Scheme_Object *)prompt; - p->cjs.alt_full_continuation = NULL; - 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 - from the current one. Jump to the meta-continuation - and continue from there. Immediate destination is - in compose_continuation() in fun.c; the ultimate - destination is in scheme_finish_apply_for_prompt() - in fun.c. - We need to adjust the meta-continuation offsets in - common, based on the number that we're discarding - here. */ - { - Scheme_Meta_Continuation *xmc; - int offset = 1; - for (xmc = p->meta_continuation; - xmc->prompt_tag != prompt_mc->prompt_tag; - xmc = xmc->next) { - if (xmc->overflow) - offset++; - } - c->common_next_meta -= offset; - } - p->meta_continuation = prompt_mc->next; - p->stack_start = prompt_mc->overflow->stack_start; - p->decompose_mc = prompt_mc; - scheme_longjmpup(&prompt_mc->overflow->jmp->cont); - } else if ((!prompt->boundary_overflow_id && !p->overflow) - || (prompt->boundary_overflow_id - && (prompt->boundary_overflow_id == p->overflow->id))) { - /* Jump directly to the prompt: destination is in - scheme_finish_apply_for_prompt() in fun.c. */ - if (!p->meta_continuation) - scheme_signal_error("internal error: no meta-cont for escape"); - if (p->meta_continuation->pseudo) - scheme_signal_error("internal error: trying to jump to a prompt in a meta-cont" - " that starts with a pseudo prompt"); - scheme_drop_prompt_meta_continuations(c->prompt_tag); - scheme_longjmp(*prompt->prompt_buf, 1); - } else { - /* Need to unwind overflows to get to the prompt. */ - Scheme_Overflow *overflow; - scheme_drop_prompt_meta_continuations(c->prompt_tag); - overflow = p->overflow; - while (overflow->prev - && (!overflow->prev->id - || (overflow->prev->id != prompt->boundary_overflow_id))) { - overflow = overflow->prev; - } - /* Immediate destination is in scheme_handle_stack_overflow(). - Ultimate destination is in scheme_finish_apply_for_prompt() - in fun.c. */ - p->overflow = overflow; - p->stack_start = overflow->stack_start; - scheme_longjmpup(&overflow->jmp->cont); - } } - return NULL; } + + return NULL; } void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full) -- 1.7.10.4
_________________________ Racket Developers list: http://lists.racket-lang.org/dev