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

fix lack of space-safety in delimited continuations (related to recently fixed crashing bug)

Browse Source 
svn: r9544
This commit is contained in:
Matthew Flatt 2008-04-30 17:39:30 +00:00
parent 95aca3e86a
commit abf86a46a8
9 changed files with 292 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/tests/mzscheme/prompt-sfs.ss Normal file
View File

@ -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 <will-executor>
(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))))))

2
src/mzscheme/include/scheme.h
View File

@ -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;

2
src/mzscheme/src/eval.c
View File

@ -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

195
src/mzscheme/src/fun.c
View File

@ -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;

8
src/mzscheme/src/mzmark.c
View File

@ -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);

4
src/mzscheme/src/mzmarksrc.c
View File

@ -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);

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

@ -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);

66
src/mzscheme/src/setjmpup.c
View File

@ -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;

2
src/mzscheme/src/thread.c
View File

@ -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);
}
}