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

fix delim-cont bug (in the case that a captured continuation is delimited in the middle of a meta-contiuation that isn't the current one)

Browse Source 
svn: r9540
This commit is contained in:
Matthew Flatt 2008-04-30 03:01:40 +00:00
parent faaa7d1bc1
commit ac31eba987
9 changed files with 155 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/setup/xref.ss
View File

@ -12,22 +12,22 @@
(define (get-dests dir)
(let* ([i (get-info/full dir)]
[scribblings (i 'scribblings)])
(map (lambda (d)
(and (not (and (list? d)
((length d) . > . 2)
(pair? (list-ref d 2))
(eq? (car (list-ref d 2)) 'omit)))
(pair? d)
(let* ([flags (if (pair? (cdr d)) (cadr d) null)]
[name (if (and (pair? (cdr d)) (pair? (cddr d))
(pair? (cdddr d)))
(cadddr d)
(let-values ([(base name dir?) (split-path (car d))])
(path-replace-suffix name #"")))])
(build-path
(doc-path dir name flags)
"out.sxref"))))
scribblings)))
(map (lambda (d)
(and (not (and (list? d)
((length d) . > . 2)
(pair? (list-ref d 2))
(eq? (car (list-ref d 2)) 'omit)))
(pair? d)
(let* ([flags (if (pair? (cdr d)) (cadr d) null)]
[name (if (and (pair? (cdr d)) (pair? (cddr d))
(pair? (cdddr d)))
(cadddr d)
(let-values ([(base name dir?) (split-path (car d))])
(path-replace-suffix name #"")))])
(build-path
(doc-path dir name flags)
"out.sxref"))))
scribblings)))
(define (load-collections-xref [report-loading void])
(or cached-xref

47
collects/tests/mzscheme/prompt-tests.ss
View File

@ -1693,7 +1693,52 @@
(test s sync s)))
(go (lambda (f) (f)))
(go (lambda (f) (dynamic-wind void f void))))
;; ----------------------------------------
;; Second continuation spans two meta-continuations,
;; and cuts the deeper meta-continuation in half:
(test
'("x1")
'nested-half
(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
(with-continuation-mark 'x "x0"
(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))])
(with-continuation-mark 'x "x1"
(call-with-continuation-prompt
(lambda ()
(ak (lambda ()
(lambda ()
(continuation-mark-set->list (current-continuation-marks) 'x)))))
a)))))
;; ----------------------------------------
;; Try long chain of composable continuations

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

@ -924,6 +924,7 @@ typedef struct Scheme_Thread {
mz_jmp_buf *error_buf;
Scheme_Continuation_Jump_State cjs;
struct Scheme_Cont *decompose;
Scheme_Thread_Cell_Table *cell_values;
Scheme_Config *init_config;

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

@ -7093,6 +7093,8 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
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.num_vals = 1;
p->cjs.val = (Scheme_Object *)c;
@ -7121,12 +7123,18 @@ 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;
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 {

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

@ -4364,13 +4364,14 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
break;
if (!mc->pseudo && SAME_OBJ(mc->prompt_tag, limit_tag))
break;
if (for_composable && mc->pseudo && mc->empty_to_next && mc->next
if (for_composable && mc->pseudo && mc->empty_to_next && mc->next
&& SAME_OBJ(mc->next->prompt_tag, limit_tag)) {
/* We don't need to keep the compose-introduced
meta-continuation, because it represents an empty
continuation relative to the prompt. */
break;
}
naya = MALLOC_ONE_RT(Scheme_Meta_Continuation);
cnt++;
memcpy(naya, mc, sizeof(Scheme_Meta_Continuation));
@ -4395,6 +4396,22 @@ 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;
{
Scheme_Cont *cnaya;
cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
memcpy(cnaya, naya->cont, sizeof(Scheme_Cont));
naya->cont = cnaya;
cnaya->cont_mark_total = naya->cont_mark_total;
cnaya->cont_mark_offset = naya->cont_mark_offset;
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->need_meta_prompt = 1;
}
} else {
if (!mc->cm_caches) {
mc->cm_shared = 1;
@ -4433,6 +4450,23 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
return first;
}
static void sync_meta_cont(Scheme_Meta_Continuation *resume_mc)
{
Scheme_Cont *cnaya;
cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
memcpy(cnaya, resume_mc->cont, sizeof(Scheme_Cont));
resume_mc->cont = cnaya;
cnaya->ss.cont_mark_stack += (resume_mc->cont_mark_total - cnaya->cont_mark_total);
cnaya->cont_mark_total = resume_mc->cont_mark_total;
cnaya->cont_mark_offset = resume_mc->cont_mark_offset;
cnaya->cont_mark_pos_bottom = resume_mc->cont_mark_pos_bottom;
cnaya->cont_mark_stack_copied = resume_mc->cont_mark_stack_copied;
}
void prune_cont_marks(Scheme_Meta_Continuation *resume_mc, Scheme_Cont *cont, Scheme_Object *extra_marks)
{
Scheme_Object *val;
@ -4511,6 +4545,8 @@ void prune_cont_marks(Scheme_Meta_Continuation *resume_mc, Scheme_Cont *cont, Sc
base++;
}
}
sync_meta_cont(resume_mc);
}
Scheme_Saved_Stack *clone_runstack_saved(Scheme_Saved_Stack *saved, Scheme_Object **boundary_start,
@ -4808,7 +4844,10 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
} else {
p->overflow = cont->save_overflow;
}
if (!for_prompt) {
if (for_prompt) {
if (p->meta_prompt)
cont->need_meta_prompt = 1;
} else {
Scheme_Meta_Continuation *mc, *resume_mc;
if (resume) {
resume_mc = MALLOC_ONE_RT(Scheme_Meta_Continuation);
@ -4833,6 +4872,8 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
resume_mc->cont_mark_pos_bottom = cm_cont->cont_mark_pos_bottom;
resume_mc->cont_mark_stack_copied = cm_cont->cont_mark_stack_copied;
resume_mc->cont = cm_cont;
resume_mc->cm_caches = 1; /* conservative assumption */
resume_mc->next = p->meta_continuation;
@ -4949,8 +4990,11 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
MZ_CONT_MARK_STACK = 0;
}
/* If there's a resume, then set up a meta prompt: */
if (resume) {
/* If there's a resume, then set up a meta prompt.
We also need a meta-prompt if we're returning from a composed
continuation to a continuation captured under a meta-prompt,
or truncated somewhere along the way. */
if (resume || (for_prompt && cont->need_meta_prompt)) {
Scheme_Prompt *meta_prompt;
meta_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
@ -5003,7 +5047,7 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
sub_conts = scheme_make_raw_pair((Scheme_Object *)sub_cont, sub_conts);
}
if (!shortcut_prompt) {
if (!shortcut_prompt) {
Scheme_Cont *tc;
for (tc = cont; tc->buf.cont; tc = tc->buf.cont) {
}
@ -5582,6 +5626,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;
scheme_longjmpup(&resume->jmp->cont);
return NULL;
}
@ -5626,7 +5671,10 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
/* Grab a continuation so that we capture the current Scheme stack,
etc.: */
saved = grab_continuation(p, 1, 0, NULL, NULL, NULL, NULL, 0, NULL, NULL, NULL, 0);
if (p->meta_prompt)
saved->prompt_stack_start = p->meta_prompt->stack_boundary;
overflow = MALLOC_ONE_RT(Scheme_Overflow);
#ifdef MZTAG_REQUIRED
overflow->type = scheme_rt_overflow;
@ -5639,11 +5687,15 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
jmp->type = scheme_rt_overflow_jmp;
#endif
overflow->jmp = jmp;
saved->resume_to = overflow; /* used by eval to jump to current meta-continuation */
cont->use_next_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))) {
/* Returning. (Jumped here from finish_apply_for_prompt,
scheme_compose_continuation, or scheme_eval.)
scheme_compose_continuation, scheme_eval, or start_child.)
We can return for several reasons:
1. We got a result value.
@ -5661,6 +5713,9 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
p = scheme_current_thread;
saved = p->decompose;
p->decompose = NULL;
if (!p->cjs.jumping_to_continuation) {
/* Got a result: */
v = p->cjs.val;
@ -5681,7 +5736,7 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
restore_continuation(saved, p, 1, v, NULL, 0,
NULL, NULL,
NULL, 0, NULL,
0, !p->cjs.jumping_to_continuation,
1, !p->cjs.jumping_to_continuation,
NULL, NULL);
p->meta_continuation = mc;
@ -5710,6 +5765,7 @@ 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;
@ -5719,8 +5775,6 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
scheme_current_thread->suspend_break++;
/* Here's where we jump to the target: */
saved->resume_to = overflow; /* used by eval to jump to current meta-continuation */
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;
@ -6174,6 +6228,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;
scheme_longjmpup(&mc->overflow->jmp->cont);
return NULL;
@ -7460,6 +7515,7 @@ void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post_part, int meta_de
rest->cont_mark_total = 0;
rest->cont_mark_offset = 0;
rest->cont_mark_stack_copied = NULL;
sync_meta_cont(rest);
rest = rest->next;
}
@ -7475,6 +7531,7 @@ void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post_part, int meta_de
rest->cont_mark_stack_copied = cp;
} else
rest->cont_mark_stack_copied = NULL;
sync_meta_cont(rest);
}
old_cac = scheme_continuation_application_count;

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

@ -997,6 +997,7 @@ static int meta_cont_proc_MARK(void *p) {
gcMARK(c->overflow);
gcMARK(c->next);
gcMARK(c->cont_mark_stack_copied);
gcMARK(c->cont);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Meta_Continuation));
@ -1009,6 +1010,7 @@ static int meta_cont_proc_FIXUP(void *p) {
gcFIXUP(c->overflow);
gcFIXUP(c->next);
gcFIXUP(c->cont_mark_stack_copied);
gcFIXUP(c->cont);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Meta_Continuation));
@ -1596,6 +1598,7 @@ static int thread_val_MARK(void *p) {
gcMARK(pr->t_set_prev);
MARK_cjs(&pr->cjs);
gcMARK(pr->decompose);
gcMARK(pr->cell_values);
gcMARK(pr->init_config);
@ -1696,6 +1699,7 @@ static int thread_val_FIXUP(void *p) {
gcFIXUP(pr->t_set_prev);
FIXUP_cjs(&pr->cjs);
gcFIXUP(pr->decompose);
gcFIXUP(pr->cell_values);
gcFIXUP(pr->init_config);
@ -3116,6 +3120,7 @@ static int mark_rb_node_SIZE(void *p) {
static int mark_rb_node_MARK(void *p) {
RBNode *rb = (RBNode *)p;
/* Short-circuit on NULL pointers, which are especially likely */
if (rb->left) {
gcMARK(rb->left);
}
@ -3132,6 +3137,7 @@ static int mark_rb_node_MARK(void *p) {
static int mark_rb_node_FIXUP(void *p) {
RBNode *rb = (RBNode *)p;
/* Short-circuit on NULL pointers, which are especially likely */
if (rb->left) {
gcFIXUP(rb->left);
}

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

@ -381,6 +381,7 @@ meta_cont_proc {
gcMARK(c->overflow);
gcMARK(c->next);
gcMARK(c->cont_mark_stack_copied);
gcMARK(c->cont);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Meta_Continuation));
@ -610,6 +611,7 @@ thread_val {
gcMARK(pr->t_set_prev);
MARK_cjs(&pr->cjs);
gcMARK(pr->decompose);
gcMARK(pr->cell_values);
gcMARK(pr->init_config);

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

@ -1065,7 +1065,7 @@ typedef struct Scheme_Dynamic_Wind {
typedef struct Scheme_Cont {
Scheme_Object so;
char composable, has_prompt_dw;
char composable, has_prompt_dw, need_meta_prompt;
struct Scheme_Meta_Continuation *meta_continuation;
Scheme_Jumpup_Buf buf;
Scheme_Dynamic_Wind *dw;
@ -1179,6 +1179,8 @@ typedef struct Scheme_Meta_Continuation {
MZ_MARK_POS_TYPE cont_mark_pos;
long cont_mark_total, cont_mark_offset;
Scheme_Cont_Mark *cont_mark_stack_copied;
/* Continuation (whose cont-mark info is the same as above) */
struct Scheme_Cont *cont;
/* Next: */
struct Scheme_Meta_Continuation *next;
} Scheme_Meta_Continuation;

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

@ -2784,10 +2784,13 @@ static void start_child(Scheme_Thread * volatile child,
if (!SAME_OBJ(p->meta_continuation->prompt_tag, scheme_default_prompt_tag)) {
scheme_signal_error("thread ended with meta continuation that isn't for the default prompt");
} else {
oflow = p->meta_continuation->overflow;
p->meta_continuation = p->meta_continuation->next;
Scheme_Meta_Continuation *mc;
mc = p->meta_continuation;
oflow = mc->overflow;
p->meta_continuation = mc->next;
if (!oflow->eot) {
p->stack_start = oflow->stack_start;
p->decompose = mc->cont;
scheme_longjmpup(&oflow->jmp->cont);
}
}