fix an interaction of `dynamic-wind' pre thunks and composable continuations
Merge to 5.0.2
This commit is contained in:
Matthew Flatt
parent
23d1721ad3
commit
caa747e5c6
|
|
@ -1739,6 +1739,167 @@
|
|||
(continuation-mark-set->list (current-continuation-marks) 'x)))))
|
||||
a)))))
|
||||
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Tests related to cotinuations that capture pre-thunk frames
|
||||
|
||||
;; Simple case:
|
||||
(let ([t
|
||||
(lambda (wrapper)
|
||||
(test
|
||||
'(pre1 mid1 post1 pre2 mid1 post1 post2)
|
||||
'cc1
|
||||
(let ([k #f]
|
||||
[recs null])
|
||||
(define (queue v) (set! recs (cons v recs)))
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(queue 'pre1)
|
||||
(call-with-composable-continuation
|
||||
(lambda (k0)
|
||||
(set! k k0))))
|
||||
(lambda () (queue 'mid1))
|
||||
(lambda () (queue 'post1)))))
|
||||
(wrapper
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () (queue 'pre2))
|
||||
(lambda () (k))
|
||||
(lambda () (queue 'post2)))))
|
||||
(reverse recs))))])
|
||||
(t (lambda (f) (f)))
|
||||
(t call-with-continuation-prompt))
|
||||
|
||||
;; Mix in some extra dynamic winds:
|
||||
(test
|
||||
'(pre1 mid1 post1 pre2 mid1 post1 post2 pre2 mid1 post1 post2)
|
||||
'cc2
|
||||
(let ([k #f]
|
||||
[k2 #f]
|
||||
[recs null])
|
||||
(define (queue v) (set! recs (cons v recs)))
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(queue 'pre1)
|
||||
((call-with-composable-continuation
|
||||
(lambda (k0)
|
||||
(set! k k0)
|
||||
void))))
|
||||
(lambda () (queue 'mid1))
|
||||
(lambda () (queue 'post1)))))
|
||||
(let/ec esc
|
||||
(dynamic-wind
|
||||
(lambda () (queue 'pre2))
|
||||
(lambda ()
|
||||
(k (lambda ()
|
||||
(let/cc k0
|
||||
(set! k2 k0))))
|
||||
(esc))
|
||||
(lambda () (queue 'post2))))))
|
||||
(call-with-continuation-prompt
|
||||
(lambda () (k2)))
|
||||
(reverse recs)))
|
||||
|
||||
;; Even more dynamic-winds:
|
||||
(test
|
||||
'(pre0 pre1 mid1 post1 post0
|
||||
pre1.5 pre2 pre0 mid1 post1 post0 post2 post1.5
|
||||
pre3 pre1.5 pre2 pre0 mid1 post1 post0 post2 post1.5 post3)
|
||||
'cc3
|
||||
(let ([k #f]
|
||||
[k2 #f]
|
||||
[recs null])
|
||||
(define (queue v) (set! recs (cons v recs)))
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(queue 'pre0))
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(queue 'pre1)
|
||||
((call-with-composable-continuation
|
||||
(lambda (k0)
|
||||
(set! k k0)
|
||||
void))))
|
||||
(lambda () (queue 'mid1))
|
||||
(lambda () (queue 'post1))))
|
||||
(lambda ()
|
||||
(queue 'post0)))))
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () (queue 'pre1.5))
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () (queue 'pre2))
|
||||
(lambda () (k (lambda ()
|
||||
(call-with-composable-continuation
|
||||
(lambda (k0)
|
||||
(set! k2 k0))))))
|
||||
(lambda () (queue 'post2))))
|
||||
(lambda () (queue 'post1.5)))))
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () (queue 'pre3))
|
||||
(lambda () (k2))
|
||||
(lambda () (queue 'post3)))))
|
||||
(reverse recs)))
|
||||
|
||||
;; Arrange for the captured pre-thunk to trigger extra cloning
|
||||
;; of dynmaic wind records in continuation application:
|
||||
(test
|
||||
'(pre1 pre2 post2 post1 pre1 pre2 post2 post1 last pre2 post2 post1)
|
||||
'cc4
|
||||
(let ([k #f]
|
||||
[k2 #f]
|
||||
[recs null]
|
||||
[tag (make-continuation-prompt-tag)])
|
||||
(define (queue v) (set! recs (cons v recs)))
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(queue 'pre1)
|
||||
((call-with-composable-continuation
|
||||
(lambda (k0)
|
||||
(set! k k0)
|
||||
void))))
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () (queue 'pre2))
|
||||
(lambda ()
|
||||
((call-with-composable-continuation
|
||||
(lambda (k0)
|
||||
(set! k2 k0)
|
||||
void))))
|
||||
(lambda () (queue 'post2))))
|
||||
(lambda () (queue 'post1)))))
|
||||
(let ([k3
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(k2 (lambda ()
|
||||
(call-with-composable-continuation
|
||||
(lambda (k0)
|
||||
(abort-current-continuation tag (lambda () k0)))))))))
|
||||
tag)])
|
||||
(queue 'last)
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(k void))
|
||||
tag))
|
||||
(reverse recs)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Try long chain of composable continuations
|
||||
|
||||
|
|
@ -1804,4 +1965,3 @@
|
|||
(k (lambda () (abort-current-continuation
|
||||
(default-continuation-prompt-tag)
|
||||
(lambda () 45))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -5141,7 +5141,7 @@ static Scheme_Overflow *clone_overflows(Scheme_Overflow *overflow, void *limit,
|
|||
}
|
||||
|
||||
static Scheme_Dynamic_Wind *clone_dyn_wind(Scheme_Dynamic_Wind *dw,
|
||||
Scheme_Object *limit_prompt_tag, int limit_depth,
|
||||
Scheme_Object *limit_prompt_tag, int limit_depth, int limit_count,
|
||||
Scheme_Dynamic_Wind *tail,
|
||||
int keep_tail, int composable)
|
||||
{
|
||||
|
|
@ -5153,6 +5153,8 @@ static Scheme_Dynamic_Wind *clone_dyn_wind(Scheme_Dynamic_Wind *dw,
|
|||
break;
|
||||
if (composable && limit_prompt_tag && (dw->prompt_tag == limit_prompt_tag))
|
||||
break;
|
||||
if (cnt == limit_count)
|
||||
break;
|
||||
scheme_ensure_dw_id(dw);
|
||||
naya = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
|
||||
memcpy(naya, dw, sizeof(Scheme_Dynamic_Wind));
|
||||
|
|
@ -5525,12 +5527,14 @@ static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
|
|||
{
|
||||
Scheme_Thread *p = scheme_current_thread;
|
||||
int old_cac = scheme_continuation_application_count;
|
||||
int need_clone = 0;
|
||||
Scheme_Dynamic_Wind *dw;
|
||||
|
||||
for (; dwl; dwl = dwl->next) {
|
||||
if (dwl->dw->pre) {
|
||||
p->dw = dwl->dw->prev;
|
||||
p->next_meta = dwl->meta_depth + dwl->dw->next_meta;
|
||||
if (dwl->meta_depth > 0) {
|
||||
if (!skip_dws)
|
||||
scheme_apply_dw_in_meta(dwl->dw, 0, dwl->meta_depth, cont);
|
||||
} else {
|
||||
/* Restore the needed part of the mark stack for this
|
||||
|
|
@ -5555,6 +5559,19 @@ static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
|
|||
}
|
||||
p = scheme_current_thread;
|
||||
}
|
||||
|
||||
if (p->dw != dwl->dw->prev) {
|
||||
/* something happened in the pre-thunk to change the
|
||||
continuation that we're building */
|
||||
need_clone = 1;
|
||||
}
|
||||
|
||||
if (need_clone) {
|
||||
dw = clone_dyn_wind(dwl->dw, NULL, -1, 1, p->dw, 0, 0);
|
||||
dw->next_meta = p->next_meta;
|
||||
} else
|
||||
dw = dwl->dw;
|
||||
p->dw = dw;
|
||||
}
|
||||
return copied_cms;
|
||||
}
|
||||
|
|
@ -5603,7 +5620,7 @@ static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int comp
|
|||
else if (prompt) {
|
||||
Scheme_Dynamic_Wind *dw;
|
||||
if (p->dw) {
|
||||
dw = clone_dyn_wind(p->dw, prompt_tag, -1, NULL, 0, composable);
|
||||
dw = clone_dyn_wind(p->dw, prompt_tag, -1, -1, NULL, 0, composable);
|
||||
cont->dw = dw;
|
||||
cont->next_meta = p->next_meta;
|
||||
} else
|
||||
|
|
@ -6031,7 +6048,7 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
|
|||
p->next_meta = common_next_meta;
|
||||
if (p->dw) { /* can be empty if there's only the implicit prompt */
|
||||
/* also, there may be no dw with prompt_tag if there's only the implicit prompt */
|
||||
all_dw = clone_dyn_wind(p->dw, cont->prompt_tag, -1, NULL, 1, 0);
|
||||
all_dw = clone_dyn_wind(p->dw, cont->prompt_tag, -1, -1, NULL, 1, 0);
|
||||
for (dw = all_dw; dw && !SAME_OBJ(dw->prompt_tag, cont->prompt_tag); dw = dw->prev) {
|
||||
p->dw = p->dw->prev;
|
||||
}
|
||||
|
|
@ -6048,8 +6065,12 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
|
|||
if (cont->dw) {
|
||||
int meta_depth;
|
||||
|
||||
/* The allow_dw chain that we build up here is actually
|
||||
premature, in that the tail to splice onto may change
|
||||
in pre-thunks. It doesn't usually happen, and we can
|
||||
detect that case in exec_dyn_wind_pres() in re-clone. */
|
||||
common_depth = (p->dw ? p->dw->depth : -1);
|
||||
all_dw = clone_dyn_wind(cont->dw, NULL, cont->common_dw_depth, p->dw, 0, 0);
|
||||
all_dw = clone_dyn_wind(cont->dw, NULL, cont->common_dw_depth, -1, p->dw, 0, 0);
|
||||
|
||||
if ((common_depth != -1) && (common_depth != all_dw->depth)) {
|
||||
/* Move p->next_meta to the last added dw's next_meta. */
|
||||
|
|
@ -6077,7 +6098,6 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
|
|||
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;
|
||||
}
|
||||
}
|
||||
|
|
@ -8734,6 +8754,17 @@ Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
|
|||
|
||||
p = scheme_current_thread;
|
||||
|
||||
if (pre) {
|
||||
ASSERT_SUSPEND_BREAK_ZERO();
|
||||
p->suspend_break++;
|
||||
pre(data);
|
||||
p = scheme_current_thread;
|
||||
--p->suspend_break;
|
||||
}
|
||||
|
||||
/* set up `dw' after pre(), in case a continuation
|
||||
is captured in pre() and composed later */
|
||||
|
||||
dw = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
|
||||
#ifdef MZTAG_REQUIRED
|
||||
dw->type = scheme_rt_dyn_wind;
|
||||
|
|
@ -8749,14 +8780,6 @@ Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
|
|||
dw->depth = 0;
|
||||
dw->next_meta = p->next_meta;
|
||||
|
||||
if (pre) {
|
||||
ASSERT_SUSPEND_BREAK_ZERO();
|
||||
p->suspend_break++;
|
||||
pre(data);
|
||||
p = scheme_current_thread;
|
||||
--p->suspend_break;
|
||||
}
|
||||
|
||||
p->next_meta = 0;
|
||||
p->dw = dw;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user