diff --git a/collects/tests/mzscheme/prompt-sfs.ss b/collects/tests/mzscheme/prompt-sfs.ss new file mode 100644 index 0000000000..a967382bf5 --- /dev/null +++ b/collects/tests/mzscheme/prompt-sfs.ss @@ -0,0 +1,63 @@ +#lang scheme + +#| + +This test is designed to to check whether meta-continuations are +correctly split when a continuation is delimited in the middle of +a meta-continuation other than the current one. In aprticular, +the `x' binding is part of the deeper meta-continuation when `ak' +is captured, but it is delimited inside the binding, so `x' +should not be reated in `ak'. + +|# + +(define (make-big-thing) (cons (make-string 100000) (make-will-executor))) +(define (show-big-thing say x) (say (string-length (car x)))) + +(collect-garbage) +(collect-garbage) +(define orig (current-memory-use)) + +(define single (make-will-executor)) + +(let loop ([n 10][accums null]) + (if (zero? n) + (begin + (collect-garbage) + (collect-garbage) + (dump-memory-stats) ; look for just one + (printf "~s\n" (- (current-memory-use) orig)) + accums) + (let* ([says null] + [say (lambda (s) + (set! says (cons s says)))] + [a (make-continuation-prompt-tag 'a)] + [b (make-continuation-prompt-tag 'b)]) + (let ([ak + (let ([x (make-big-thing)]) + (begin0 + (call-with-continuation-prompt + (lambda () + (with-continuation-mark 'y "y0" + (let ([bk (call-with-continuation-prompt + (lambda () + (let ([f (call-with-composable-continuation + (lambda (k) + (lambda () k)) + b)]) + (say "bcall") + (begin0 + (f) + (say "breturn")))) + b)]) + (call-with-continuation-prompt + (lambda () + ((bk (lambda () + (let ([f (call/cc (lambda (k) (lambda () (lambda () k))) a)]) + (begin0 + (f) + (say "areturn"))))))) + b)))) + a) + (show-big-thing say x)))]) + (loop (sub1 n) (cons ak accums)))))) diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index a073f5b95a..d6a1e59983 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -924,7 +924,7 @@ typedef struct Scheme_Thread { mz_jmp_buf *error_buf; Scheme_Continuation_Jump_State cjs; - struct Scheme_Cont *decompose; + struct Scheme_Meta_Continuation *decompose_mc; /* set during a jump */ Scheme_Thread_Cell_Table *cell_values; Scheme_Config *init_config; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 918da6fab9..14bb8da5fb 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -7123,7 +7123,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc } p->meta_continuation = prompt_mc->next; p->stack_start = prompt_mc->overflow->stack_start; - p->decompose = prompt_mc->cont; + p->decompose_mc = prompt_mc; scheme_longjmpup(&prompt_mc->overflow->jmp->cont); } else if ((!prompt->boundary_overflow_id && !p->overflow) || (prompt->boundary_overflow_id diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index dda4bfc71a..cfe43a9724 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -194,7 +194,10 @@ typedef struct Scheme_Dynamic_Wind_List { } Scheme_Dynamic_Wind_List; static Scheme_Object *cached_beg_stx, *cached_dv_stx, *cached_ds_stx; -int cached_stx_phase; +static int cached_stx_phase; + +static Scheme_Cont *offstack_cont; +static Scheme_Overflow *offstack_overflow; /*========================================================================*/ /* initialization */ @@ -222,6 +225,9 @@ scheme_init_fun (Scheme_Env *env) REGISTER_SO(cached_ds_stx); REGISTER_SO(scheme_procedure_p_proc); + REGISTER_SO(offstack_cont); + REGISTER_SO(offstack_overflow); + o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(o) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("procedure?", o, env); @@ -4050,6 +4056,7 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p, start = MALLOC_N(Scheme_Object*, size); saved->runstack_start = start; memcpy(saved->runstack_start, runstack, size * sizeof(Scheme_Object *)); + saved->runstack_offset = (runstack XFORM_OK_MINUS runstack_start); if (!effective_prompt || (effective_prompt->runstack_boundary_start != runstack_start)) { @@ -4349,6 +4356,87 @@ static void clear_cm_copy_caches(Scheme_Cont_Mark *cp, int cnt) } } +static Scheme_Saved_Stack *clone_runstack_saved(Scheme_Saved_Stack *saved, Scheme_Object **boundary_start, + Scheme_Saved_Stack *last) +{ + Scheme_Saved_Stack *naya, *first = last, *prev = NULL; + + while (saved) { + naya = MALLOC_ONE_RT(Scheme_Saved_Stack); + memcpy(naya, saved, sizeof(Scheme_Saved_Stack)); + if (prev) + prev->prev = naya; + else + first = naya; + prev = naya; + if (saved->runstack_start == boundary_start) + break; + saved = saved->prev; + } + if (prev) + prev->prev = last; + + return first; +} + +static Scheme_Saved_Stack *clone_runstack_copied(Scheme_Saved_Stack *copied, + Scheme_Object **copied_start, + Scheme_Saved_Stack *saved, + Scheme_Object **boundary_start, + long boundary_offset) +{ + Scheme_Saved_Stack *naya, *first = NULL, *prev = NULL, *s; + + if (copied_start == boundary_start) { + naya = copied; + } else { + for (naya = copied->prev, s = saved; + s->runstack_start != boundary_start; + naya = naya->prev, s = s->prev) { + } + } + if ((naya->runstack_offset + naya->runstack_size == boundary_offset) + && !naya->prev) { + /* no need to prune anything */ + return copied; + } + + s = NULL; + while (copied) { + naya = MALLOC_ONE_RT(Scheme_Saved_Stack); + memcpy(naya, copied, sizeof(Scheme_Saved_Stack)); + naya->prev = NULL; + if (prev) + prev->prev = naya; + else + first = naya; + prev = naya; + if ((!s && copied_start == boundary_start) + || (s && (s->runstack_start == boundary_start))) { + long size; + Scheme_Object **a; + size = boundary_offset - naya->runstack_offset; + if (size < 0) + scheme_signal_error("negative stack-copy size while pruning"); + if (size > naya->runstack_size) + scheme_signal_error("bigger stack-copy size while pruning: %d vs. %d", size, naya->runstack_size); + a = MALLOC_N(Scheme_Object *, size); + memcpy(a, naya->runstack_start, size * sizeof(Scheme_Object *)); + naya->runstack_start = a; + naya->runstack_size = size; + break; + } + + copied = copied->prev; + if (!s) + s = saved; + else + s = s->prev; + } + + return first; +} + static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc, Scheme_Object *limit_tag, int limit_depth, Scheme_Meta_Continuation *prompt_cont, @@ -4378,6 +4466,8 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc, if (SAME_OBJ(mc, prompt_cont)) { /* Need only part of this meta-continuation's marks. */ long delta; + void *stack_boundary; + delta = prompt->mark_boundary - naya->cont_mark_offset; if (delta) { naya->cont_mark_total -= delta; @@ -4396,8 +4486,18 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc, naya->cont_mark_stack_copied = NULL; } naya->cont_mark_pos_bottom = prompt->boundary_mark_pos; - { + + if ((prompt->boundary_overflow_id && (prompt->boundary_overflow_id == naya->overflow->id)) + || (!prompt->boundary_overflow_id && !naya->overflow->prev)) { + stack_boundary = prompt->stack_boundary; + } else { + stack_boundary = naya->overflow->stack_start; + } + + if (naya->cont) { Scheme_Cont *cnaya; + Scheme_Saved_Stack *saved; + cnaya = MALLOC_ONE_TAGGED(Scheme_Cont); memcpy(cnaya, naya->cont, sizeof(Scheme_Cont)); @@ -4408,10 +4508,40 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc, cnaya->cont_mark_pos_bottom = naya->cont_mark_pos_bottom; cnaya->cont_mark_stack_copied = naya->cont_mark_stack_copied; - cnaya->prompt_stack_start = prompt->stack_boundary; + cnaya->prompt_stack_start = stack_boundary; + + /* Prune unneeded runstack data */ + saved = clone_runstack_copied(cnaya->runstack_copied, + cnaya->runstack_start, + cnaya->runstack_saved, + prompt->runstack_boundary_start, + prompt->runstack_boundary_offset); + cnaya->runstack_copied = saved; + + /* Prune unneeded buffers */ + if (prompt->runstack_boundary_start == cnaya->runstack_start) + saved = NULL; + else + saved = clone_runstack_saved(cnaya->runstack_saved, + prompt->runstack_boundary_start, + NULL); + cnaya->runstack_saved = saved; cnaya->need_meta_prompt = 1; } + if (naya->overflow && !naya->overflow->eot) { + /* Prune unneeded C-stack data */ + Scheme_Overflow *onaya; + Scheme_Overflow_Jmp *jmp; + jmp = scheme_prune_jmpup(naya->overflow->jmp, stack_boundary); + if (jmp) { + onaya = MALLOC_ONE_RT(Scheme_Overflow); + memcpy(onaya, naya->overflow, sizeof(Scheme_Overflow)); + naya->overflow = onaya; + onaya->jmp = jmp; + onaya->stack_start = stack_boundary; + } + } } else { if (!mc->cm_caches) { mc->cm_shared = 1; @@ -4549,29 +4679,6 @@ void prune_cont_marks(Scheme_Meta_Continuation *resume_mc, Scheme_Cont *cont, Sc sync_meta_cont(resume_mc); } -Scheme_Saved_Stack *clone_runstack_saved(Scheme_Saved_Stack *saved, Scheme_Object **boundary_start, - Scheme_Saved_Stack *last) -{ - Scheme_Saved_Stack *naya, *first = last, *prev = NULL; - - while (saved) { - naya = MALLOC_ONE_RT(Scheme_Saved_Stack); - memcpy(naya, saved, sizeof(Scheme_Saved_Stack)); - if (prev) - prev->prev = naya; - else - first = naya; - prev = naya; - if (saved->runstack_start == boundary_start) - break; - saved = saved->prev; - } - if (prev) - prev->prev = last; - - return first; -} - static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl, int dwl_len, Scheme_Cont *cont, @@ -4751,7 +4858,10 @@ static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int comp (for_prompt ? p->meta_prompt : prompt)); cont->runstack_copied = saved; if (!for_prompt && prompt) { - /* Prune cont->runstack_saved to drop unneeded saves. */ + /* Prune cont->runstack_saved to drop unneeded saves. + (Note that this is different than runstack_copied; + runstack_saved keeps the shared runstack buffers, + not the content.) */ if (SAME_OBJ(prompt->runstack_boundary_start, MZ_RUNSTACK_START)) saved = NULL; else @@ -5626,7 +5736,7 @@ Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Obje p->cjs.val = val; } p->stack_start = resume->stack_start; - p->decompose = resume_mc->cont; + p->decompose_mc = resume_mc; scheme_longjmpup(&resume->jmp->cont); return NULL; } @@ -5689,11 +5799,17 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain, overflow->jmp = jmp; saved->resume_to = overflow; /* used by eval to jump to current meta-continuation */ - cont->use_next_cont = saved; + offstack_cont = saved; saved = NULL; - + scheme_init_jmpup_buf(&overflow->jmp->cont); - if (scheme_setjmpup(&overflow->jmp->cont, overflow->jmp, ADJUST_STACK_START(p->stack_start))) { + + offstack_overflow = overflow; + overflow = NULL; /* so it's not saved in the continuation */ + + if (scheme_setjmpup(&offstack_overflow->jmp->cont, + offstack_overflow->jmp, + ADJUST_STACK_START(p->stack_start))) { /* Returning. (Jumped here from finish_apply_for_prompt, scheme_compose_continuation, scheme_eval, or start_child.) @@ -5709,12 +5825,14 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain, scheme_finish_apply_for_prompt() for those possibilities. */ Scheme_Object *v; - Scheme_Meta_Continuation *mc; + Scheme_Meta_Continuation *mc, *dmc; p = scheme_current_thread; - saved = p->decompose; - p->decompose = NULL; + dmc = p->decompose_mc; + p->decompose_mc = NULL; + saved = dmc->cont; + overflow = dmc->overflow; if (!p->cjs.jumping_to_continuation) { /* Got a result: */ @@ -5765,16 +5883,21 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain, reset_cjs(&p->cjs); /* The current meta-continuation may have changed since capture: */ saved->meta_continuation = p->meta_continuation; - cont->use_next_cont = saved; /* Fall though to continuation application below. */ } else { return v; } + } else { + saved = offstack_cont; + overflow = offstack_overflow; + offstack_cont = NULL; + offstack_overflow = NULL; } scheme_current_thread->suspend_break++; /* Here's where we jump to the target: */ + cont->use_next_cont = saved; cont->resume_to = overflow; cont->empty_to_next_mc = (char)empty_to_next_mc; scheme_current_thread->stack_start = cont->prompt_stack_start; @@ -6228,7 +6351,7 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch p->cjs.is_escape = 1; p->stack_start = mc->overflow->stack_start; - p->decompose = mc->cont; + p->decompose_mc = mc; scheme_longjmpup(&mc->overflow->jmp->cont); return NULL; diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 000259b5da..7e409c2e5b 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -929,8 +929,6 @@ static int cont_proc_MARK(void *p) { gcMARK(c->prompt_id); gcMARK(c->prompt_buf); - /* These shouldn't actually persist across a GC, but - just in case... */ gcMARK(c->value); gcMARK(c->resume_to); gcMARK(c->use_next_cont); @@ -969,8 +967,6 @@ static int cont_proc_FIXUP(void *p) { gcFIXUP(c->prompt_id); gcFIXUP(c->prompt_buf); - /* These shouldn't actually persist across a GC, but - just in case... */ gcFIXUP(c->value); gcFIXUP(c->resume_to); gcFIXUP(c->use_next_cont); @@ -1598,7 +1594,7 @@ static int thread_val_MARK(void *p) { gcMARK(pr->t_set_prev); MARK_cjs(&pr->cjs); - gcMARK(pr->decompose); + gcMARK(pr->decompose_mc); gcMARK(pr->cell_values); gcMARK(pr->init_config); @@ -1699,7 +1695,7 @@ static int thread_val_FIXUP(void *p) { gcFIXUP(pr->t_set_prev); FIXUP_cjs(&pr->cjs); - gcFIXUP(pr->decompose); + gcFIXUP(pr->decompose_mc); gcFIXUP(pr->cell_values); gcFIXUP(pr->init_config); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index eb032856cd..5695db58c7 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -361,8 +361,6 @@ cont_proc { gcMARK(c->prompt_id); gcMARK(c->prompt_buf); - /* These shouldn't actually persist across a GC, but - just in case... */ gcMARK(c->value); gcMARK(c->resume_to); gcMARK(c->use_next_cont); @@ -611,7 +609,7 @@ thread_val { gcMARK(pr->t_set_prev); MARK_cjs(&pr->cjs); - gcMARK(pr->decompose); + gcMARK(pr->decompose_mc); gcMARK(pr->cell_values); gcMARK(pr->init_config); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index d5b6594d2b..898b3de384 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -978,6 +978,8 @@ extern void *scheme_deepest_stack_start; # define ADJUST_STACK_START(start) (start ? start : scheme_deepest_stack_start) #endif +struct Scheme_Overflow_Jmp *scheme_prune_jmpup(struct Scheme_Overflow_Jmp *jmp, void *stack_boundary); + void scheme_jmpup_free(Scheme_Jumpup_Buf *); void *scheme_enlarge_runstack(long size, void *(*k)()); int scheme_check_runstack(long size); diff --git a/src/mzscheme/src/setjmpup.c b/src/mzscheme/src/setjmpup.c index be9ca8801a..99059f625d 100644 --- a/src/mzscheme/src/setjmpup.c +++ b/src/mzscheme/src/setjmpup.c @@ -466,24 +466,26 @@ static void *align_var_stack(void **vs, void *s) } #define ALIGN_VAR_STACK(vs, s) s = align_var_stack(vs, s) -static void *shift_var_stack(void *s) +static void *shift_var_stack(void *s, long delta) { #ifdef STACK_GROWS_UP return s; #else - void **vs = (void **)s; + void **vs = (void **)(s + delta); long cnt; /* Set s past end of vs: */ cnt = ((long *)vs)[1]; - return (void *)(vs + cnt + 2); + return (void *)((void **)s + cnt + 2); #endif } -#define PAST_VAR_STACK(s) s = shift_var_stack(s); +#define PAST_VAR_STACK(s) s = shift_var_stack(s, 0); +#define PAST_VAR_STACK_DELTA(s, d) s = shift_var_stack(s, d); END_XFORM_SKIP; #else # define ALIGN_VAR_STACK(vs, s) /* empty */ # define PAST_VAR_STACK(s) /* empty */ +# define PAST_VAR_STACK_DELTA(s, d) /* empty */ #endif int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base, @@ -550,6 +552,62 @@ int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base, return local; } +struct Scheme_Overflow_Jmp *scheme_prune_jmpup(struct Scheme_Overflow_Jmp *jmp, void *stack_boundary) +{ + void *cur_end; + + PAST_VAR_STACK_DELTA(stack_boundary, (void *)get_copy(jmp->cont.stack_copy) - (void *)jmp->cont.stack_from); + +#ifdef STACK_GROWS_UP + cur_end = (void *)jmp->cont.stack_from; +#else + cur_end = (void *)((char *)jmp->cont.stack_from + jmp->cont.stack_size); +#endif + + if (stack_boundary != cur_end) { + long new_size, delta; + Scheme_Overflow_Jmp *naya; + void *copy, *base; + +# ifdef STACK_GROWS_UP + delta = (char *)stack_boundary - (char *)jmp->cont.stack_from; + new_size = jmp->cont.stack_size - delta; + base = (char *)stack_boundary; +# else + delta = 0; + new_size = (long)stack_boundary - (long)jmp->cont.stack_from; + base = jmp->cont.stack_from; +# endif + + if ((new_size < 0) || (new_size > jmp->cont.stack_size)) + scheme_signal_error("bad C-stack pruigin size: %ld vs. %ld", new_size, jmp->cont.stack_size); + + naya = MALLOC_ONE_RT(Scheme_Overflow_Jmp); + memcpy(naya, jmp, sizeof(Scheme_Overflow_Jmp)); + scheme_init_jmpup_buf(&naya->cont); + +#ifndef MZ_PRECISE_GC + copy = make_stack_copy_rec(new_size); + naya->cont.stack_copy = copy; + set_copy(naya->cont.stack_copy, MALLOC_STACK(new_size)); +#else + copy = MALLOC_STACK(new_size); + set_copy(naya->cont.stack_copy, copy); +#endif + + memcpy(get_copy(copy), + get_copy(jmp->cont.stack_copy) XFORM_OK_PLUS delta, + new_size); + + naya->cont.stack_size = naya->cont.stack_max_size = new_size; + naya->cont.stack_from = base; + + return naya; + } + + return NULL; +} + void scheme_longjmpup(Scheme_Jumpup_Buf *b) { long z; diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 8860d64b1b..b5ddeb4049 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -2790,7 +2790,7 @@ static void start_child(Scheme_Thread * volatile child, p->meta_continuation = mc->next; if (!oflow->eot) { p->stack_start = oflow->stack_start; - p->decompose = mc->cont; + p->decompose_mc = mc; scheme_longjmpup(&oflow->jmp->cont); } }