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

allow full continuations to escape past a continuation barrier

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-10 07:29:27 -06:00
parent 84f9eb3f4c
commit 49ad309630
14 changed files with 132 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/rnrs/base-6.rkt
View File

@ -158,8 +158,8 @@
;; 11.15
(rename-out [r5rs:apply apply]
[r6rs:call/cc call-with-current-continuation]
[r6rs:call/cc call/cc])
[call-with-current-continuation call/cc])
call-with-current-continuation
values call-with-values
dynamic-wind
@ -595,43 +595,3 @@
[(_ ([id expr] ...) body ...)
(syntax/loc stx
(splicing-letrec-syntax ([id (wrap-as-needed expr)] ...) body ...))]))
;; ----------------------------------------
(define detect-tail-key (gensym))
(define (mk-k full-k tag)
(lambda args
(if (continuation-prompt-available? tag)
(abort-current-continuation
tag
(lambda () (apply values args)))
(apply full-k args))))
(define (r6rs:call/cc f)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
;; let call/cc report the error:
(call/cc f))
;; To support call/cc-based jumps in exception
;; handlers, we both grab a continuation and set a prompt
(let/cc k
(let ([v (make-continuation-prompt-tag 'r6rs:call/cc)]
[orig-key (continuation-mark-set-first #f detect-tail-key)])
(with-continuation-mark detect-tail-key v
(let ([new-key (continuation-mark-set-first #f detect-tail-key)])
(if (not (eq? new-key orig-key))
;; Old mark surived => not tail wrt old call.
;; Create an escape continuation to use for
;; error escapes. Of course, we rely on the fact
;; that continuation marks are not visible to EoPL
;; programs.
(call-with-continuation-prompt
(lambda ()
(f (mk-k k new-key)))
new-key)
;; Old mark replaced => tail wrt old call.
;; To preserve tail semantics for all but the first call
;; reuse `mark' instead of creating a new escape continuation:
(with-continuation-mark detect-tail-key orig-key
(f (mk-k k orig-key)))))))))

38
collects/scribblings/reference/cont.scrbl
View File

@ -8,9 +8,9 @@ information about continuations. Racket's support for prompts and
composable continuations most closely resembles Dorai Sitaram's
@racket[%] and @racket[fcontrol] operator @cite["Sitaram93"].
Racket installs a @defterm{continuation barrier} around evaluation in
the following contexts, preventing full-continuation jumps across the
barrier:
Racket installs a @tech{continuation barrier} around evaluation in the
following contexts, preventing full-continuation jumps into the
evaluation context protected by the barrier:
@itemize[
@ -123,20 +123,19 @@ prompt tagged by @racket[prompt-tag] (not including the prompt; if no
such prompt exists, the @exnraise[exn:fail:contract:continuation]), or
up to the nearest continuation frame (if any) shared by the current
and captured continuations---whichever is first. While removing
continuation frames, @racket[dynamic-wind] @racket[post-thunk]s are
continuation frames, @racket[dynamic-wind] @racket[_post-thunk]s are
executed. Finally, the (unshared portion of the) captured continuation
is appended to the remaining continuation, applying
@racket[dynamic-wind] @racket[pre-thunk]s.
@racket[dynamic-wind] @racket[_pre-thunk]s.
The arguments supplied to an applied procedure become the result
values for the restored continuation. In particular, if multiple
arguments are supplied, then the continuation receives multiple
results.
If, at application time, a continuation barrier appears between the
current continuation and the prompt tagged with @racket[prompt-tag],
and if the same barrier is not part of the captured continuation, then
the @exnraise[exn:fail:contract:continuation].
If, at application time, a @tech{continuation barrier} would be
introduced by replacing the current continuation with the applied one,
then the @exnraise[exn:fail:contract:continuation].
A continuation can be invoked from the thread (see
@secref["threads"]) other than the one where it was captured.}
@ -159,10 +158,13 @@ the resulting continuation procedure does not remove any portion of
the current continuation. Instead, application always extends the
current continuation with the captured continuation (without
installing any prompts other than those be captured in the
continuation). When @racket[call-with-composable-continuation] is
called, if a continuation barrier appears in the continuation before
the closest prompt tagged by @racket[prompt-tag], the
@exnraise[exn:fail:contract:continuation].}
continuation).
When @racket[call-with-composable-continuation] is called, if a
continuation barrier appears in the continuation before the closest
prompt tagged by @racket[prompt-tag], the
@exnraise[exn:fail:contract:continuation] (because attempting to apply
the continuation would always fail).}
@defproc[(call-with-escape-continuation
[proc (continuation? . -> . any)])
@ -171,8 +173,7 @@ the closest prompt tagged by @racket[prompt-tag], the
Like @racket[call-with-current-continuation], but @racket[proc] is not
called in tail position, and the continuation procedure supplied to
@racket[proc] can only be called during the dynamic extent of the
@racket[call-with-escape-continuation] call. A continuation barrier,
however, never prevents the application of the continuation.
@racket[call-with-escape-continuation] call.
Due to the limited applicability of its continuation,
@racket[call-with-escape-continuation] can be implemented more efficiently
@ -201,9 +202,10 @@ Equivalent to @racket[(call/ec (lambda (k) body ...))].
@defproc[(call-with-continuation-barrier [thunk (-> any)]) any]{
Applies @racket[thunk] with a barrier between the application and the
current continuation. The results of @racket[thunk] are the results of
the @racket[call-with-continuation-barrier] call.}
Applies @racket[thunk] with a @tech{continuation barrier} between the
application and the current continuation. The results of
@racket[thunk] are the results of the
@racket[call-with-continuation-barrier] call.}
@defproc[(continuation-prompt-available?

18
collects/scribblings/reference/eval-model.scrbl
View File

@ -656,19 +656,19 @@ the marks associated with the relevant frames are also captured.
A @deftech{continuation barrier} is another kind of continuation frame
that prohibits certain replacements of the current continuation with
another. Specifically, while an abort is allowed to remove a portion
of the continuation containing a prompt, the continuation can be
replaced by another only when the replacement also includes the
continuation barrier. Certain operations install barriers
automatically; in particular, when an exception handler is called, a
continuation barrier prohibits the continuation of the handler from
capturing the continuation past the exception point.
another. Specifically, a continuation can be replaced by another only
when the replacement does not introduce any continuation barriers (but
it may remove them). A continuation barrier thus prevents ``downward
jumps'' into a continuation that is protected by a barrier. Certain operations
install barriers automatically; in particular, when an exception
handler is called, a continuation barrier prohibits the continuation
of the handler from capturing the continuation past the exception
point.
A @deftech{escape continuation} is essentially a derived concept. It
combines a prompt for escape purposes with a continuation for
mark-gathering purposes. As the name implies, escape continuations are
used only to abort to the point of capture, which means that
escape-continuation aborts can cross continuation barriers.
used only to abort to the point of capture.
@;------------------------------------------------------------------------
@section[#:tag "thread-model"]{Threads}

7
collects/tests/racket/basic.rktl
View File

@ -1693,12 +1693,19 @@
(lambda () (k2 12)))))
(k0 13))))))
;; Interaction with exceptions:
(test 42 test-call/cc (lambda (k)
(call-with-exception-handler k (lambda () (add1 (raise 42))))))
))
(test-cc-values call/cc)
(test-cc-values call/ec)
(test 'ok
'ec-cc-exn-combo
(with-handlers ([void (lambda (x) 'ok)])

4
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,7 @@
Version 5.0.0.9
Continuation barriers now block only downward continuation jumps
and allow escapes through full continuations
Version 5.0.0.8
Changed internal-definition handling to allow expressions mixed
with definitions

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

@ -879,6 +879,7 @@ typedef struct Scheme_Jumpup_Buf_Holder {
typedef struct Scheme_Continuation_Jump_State {
struct Scheme_Object *jumping_to_continuation;
struct Scheme_Object *alt_full_continuation;
Scheme_Object *val; /* or **vals */
mzshort num_vals;
short is_kill, is_escape;

1
src/racket/src/error.c
View File

@ -2465,6 +2465,7 @@ def_error_escape_proc(int argc, Scheme_Object *argv[])
if (prompt) {
p->cjs.jumping_to_continuation = prompt;
p->cjs.alt_full_continuation = NULL;
p->cjs.num_vals = 1;
p->cjs.val = scheme_void_proc;
}

17
src/racket/src/eval.c
View File

@ -259,6 +259,8 @@ static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_
static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags);
static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimize_Info *info, int context, int rator_flags);
void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full);
#define cons(x,y) scheme_make_pair(x,y)
typedef void (*DW_PrePost_Proc)(void *);
@ -8773,6 +8775,12 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
MZ_MARK_POS_TYPE prompt_pos;
Scheme_Prompt *prompt, *barrier_prompt;
int common_depth;
c = (Scheme_Cont *)obj;
if (c->escape_cont
&& scheme_escape_continuation_ok(c->escape_cont))
scheme_escape_to_continuation(c->escape_cont, num_rands, rands, (Scheme_Object *)c);
if (num_rands != 1) {
GC_CAN_IGNORE Scheme_Object **vals;
@ -8790,8 +8798,6 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
} else
value = rands[0];
c = (Scheme_Cont *)obj;
DO_CHECK_FOR_BREAK(p, ;);
if (!c->runstack_copied) {
@ -8892,6 +8898,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
}
/* Immediate destination is in scheme_handle_stack_overflow(). */
p->cjs.jumping_to_continuation = (Scheme_Object *)c;
p->cjs.alt_full_continuation = NULL;
p->overflow = overflow;
p->stack_start = overflow->stack_start;
scheme_longjmpup(&overflow->jmp->cont);
@ -8900,6 +8907,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
/* 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;
@ -8963,7 +8971,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
}
}
void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands)
void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *value;
@ -8994,6 +9002,7 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj
p->cjs.val = value;
p->cjs.jumping_to_continuation = obj;
p->cjs.alt_full_continuation = alt_full;
scheme_longjmp(MZTHREADELEM(p, error_buf), 1);
}
@ -9466,7 +9475,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
v = scheme_jump_to_continuation(obj, num_rands, rands, old_runstack);
} else if (type == scheme_escaping_cont_type) {
UPDATE_THREAD_RSPTR();
scheme_escape_to_continuation(obj, num_rands, rands);
scheme_escape_to_continuation(obj, num_rands, rands, NULL);
return NULL;
} else if (type == scheme_proc_struct_type) {
int is_method;

68
src/racket/src/fun.c
View File

@ -104,6 +104,7 @@ READ_ONLY static Scheme_Prompt *original_default_prompt; /* for escapes, represe
READ_ONLY static Scheme_Object *call_with_prompt_proc;
READ_ONLY static Scheme_Object *abort_continuation_proc;
READ_ONLY static Scheme_Object *internal_call_cc_prim;
READ_ONLY static Scheme_Object *finish_call_cc_prim;
/* Caches need to be thread-local: */
THREAD_LOCAL_DECL(static Scheme_Prompt *available_prompt);
@ -132,6 +133,7 @@ static Scheme_Object *andmap (int argc, Scheme_Object *argv[]);
static Scheme_Object *ormap (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *internal_call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *finish_call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_continuation_barrier (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_prompt (int argc, Scheme_Object *argv[]);
@ -292,6 +294,11 @@ scheme_init_fun (Scheme_Env *env)
"call-with-current-continuation",
1, 3,
0, -1);
REGISTER_SO(finish_call_cc_prim);
finish_call_cc_prim = scheme_make_prim_w_arity2(finish_call_cc,
"finish-call-with-current-continuation",
2, 2,
0, -1);
o = scheme_make_prim_w_arity2(call_cc,
"call-with-current-continuation",
@ -4467,6 +4474,7 @@ void scheme_detach_multple_array(Scheme_Object **values)
static void reset_cjs(Scheme_Continuation_Jump_State *a)
{
a->jumping_to_continuation = NULL;
a->alt_full_continuation = NULL;
a->val = NULL;
a->num_vals = 0;
a->is_kill = 0;
@ -4484,6 +4492,7 @@ void scheme_clear_escape(void)
static void copy_cjs(Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump_State *b)
{
a->jumping_to_continuation = b->jumping_to_continuation;
a->alt_full_continuation = b->alt_full_continuation;
a->val = b->val;
a->num_vals = b->num_vals;
a->is_kill = b->is_kill;
@ -4491,7 +4500,7 @@ static void copy_cjs(Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump
}
Scheme_Object *
scheme_call_ec (int argc, Scheme_Object *argv[])
do_call_ec (int argc, Scheme_Object *argv[], Scheme_Object *_for_cc)
{
mz_jmp_buf newbuf;
Scheme_Escaping_Cont * volatile cont;
@ -4500,9 +4509,7 @@ scheme_call_ec (int argc, Scheme_Object *argv[])
Scheme_Object *a[1];
Scheme_Cont_Frame_Data cframe;
Scheme_Prompt *barrier_prompt;
scheme_check_proc_arity("call-with-escape-continuation", 1,
0, argc, argv);
Scheme_Object * volatile for_cc = _for_cc;
cont = MALLOC_ONE_TAGGED(Scheme_Escaping_Cont);
cont->so.type = scheme_escaping_cont_type;
@ -4518,7 +4525,8 @@ scheme_call_ec (int argc, Scheme_Object *argv[])
scheme_prompt_capture_count++;
scheme_push_continuation_frame(&cframe);
if (!for_cc)
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark((Scheme_Object *)cont, scheme_true);
if (scheme_setjmp(newbuf)) {
@ -4535,6 +4543,12 @@ scheme_call_ec (int argc, Scheme_Object *argv[])
} else {
scheme_longjmp(*cont->saveerr, 1);
}
} else if (for_cc) {
((Scheme_Cont *)for_cc)->escape_cont = (Scheme_Object *)cont;
a[0] = (Scheme_Object *)for_cc;
MZ_CONT_MARK_POS -= 2;
v = _scheme_apply_multi(argv[0], 1, a);
MZ_CONT_MARK_POS += 2;
} else {
a[0] = (Scheme_Object *)cont;
v = _scheme_apply_multi(argv[0], 1, a);
@ -4543,11 +4557,21 @@ scheme_call_ec (int argc, Scheme_Object *argv[])
p1 = scheme_current_thread;
p1->error_buf = cont->saveerr;
scheme_pop_continuation_frame(&cframe);
if (!for_cc)
scheme_pop_continuation_frame(&cframe);
return v;
}
Scheme_Object *
scheme_call_ec (int argc, Scheme_Object *argv[])
{
scheme_check_proc_arity("call-with-escape-continuation", 1,
0, argc, argv);
return do_call_ec(argc, argv, NULL);
}
int scheme_escape_continuation_ok(Scheme_Object *ec)
{
Scheme_Escaping_Cont *cont = (Scheme_Escaping_Cont *)ec;
@ -6038,6 +6062,8 @@ internal_call_cc (int argc, Scheme_Object *argv[])
cont->buf.cont = sub_cont;
sub_cont = sub_cont->buf.cont;
cont->escape_cont = sub_cont->escape_cont;
/* This mark stack won't be restored, but it may be
used by `continuation-marks'. */
cont->ss.cont_mark_stack = MZ_CONT_MARK_STACK;
@ -6161,15 +6187,29 @@ internal_call_cc (int argc, Scheme_Object *argv[])
scheme_check_break_now();
return result;
} else {
} else if (composable) {
Scheme_Object *argv2[1];
argv2[0] = (Scheme_Object *)cont;
ret = _scheme_tail_apply(argv[0], 1, argv2);
return ret;
} else {
Scheme_Object *argv2[2];
argv2[0] = argv[0];
argv2[1] = (Scheme_Object *)cont;
ret = _scheme_tail_apply(finish_call_cc_prim, 2, argv2);
return ret;
}
}
static Scheme_Object *
finish_call_cc (int argc, Scheme_Object *argv[])
{
return do_call_ec(1, argv, argv[1]);
}
static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[])
{
return ((SCHEME_CONTP(argv[0]) || SCHEME_ECONTP(argv[0]))
@ -7052,6 +7092,7 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch
}
p->cjs.jumping_to_continuation = cm_info; /* vector => trampoline */
p->cjs.alt_full_continuation = NULL;
p->cjs.val = (Scheme_Object *)cont;
p->cjs.num_vals = 1;
p->cjs.is_escape = 1;
@ -7124,6 +7165,7 @@ static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
p->cjs.val = (Scheme_Object *)vals;
}
p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
p->cjs.alt_full_continuation = NULL;
scheme_longjmp(*p->error_buf, 1);
@ -8336,6 +8378,18 @@ Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
} else if (SCHEME_ECONTP(p->cjs.jumping_to_continuation)) {
if (!scheme_escape_continuation_ok(p->cjs.jumping_to_continuation)) {
if (p->cjs.alt_full_continuation) {
/* We were trying to execute a full-continuation jump through
an escape-continuation jump. Go back to full-jump mode. */
Scheme_Object *a[1], **args, *fc;
a[0] = p->cjs.val;
fc = p->cjs.alt_full_continuation;
args = ((p->cjs.num_vals == 1) ? a : (Scheme_Object **)p->cjs.val);
p->cjs.jumping_to_continuation = NULL;
p->cjs.alt_full_continuation = NULL;
p->cjs.val = NULL;
return scheme_jump_to_continuation(fc, p->cjs.num_vals, args, NULL);
}
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"jump to escape continuation in progress,"
" but the target is not in the current continuation"

4
src/racket/src/mzmark.c
View File

@ -918,6 +918,8 @@ static int cont_proc_MARK(void *p, struct NewGC *gc) {
gcMARK2(c->prompt_id, gc);
gcMARK2(c->prompt_buf, gc);
gcMARK2(c->escape_cont, gc);
gcMARK2(c->value, gc);
gcMARK2(c->resume_to, gc);
gcMARK2(c->use_next_cont, gc);
@ -958,6 +960,8 @@ static int cont_proc_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(c->prompt_id, gc);
gcFIXUP2(c->prompt_buf, gc);
gcFIXUP2(c->escape_cont, gc);
gcFIXUP2(c->value, gc);
gcFIXUP2(c->resume_to, gc);
gcFIXUP2(c->use_next_cont, gc);

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

@ -360,6 +360,8 @@ cont_proc {
gcMARK2(c->prompt_id, gc);
gcMARK2(c->prompt_buf, gc);
gcMARK2(c->escape_cont, gc);
gcMARK2(c->value, gc);
gcMARK2(c->resume_to, gc);
gcMARK2(c->use_next_cont, gc);

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

@ -1341,6 +1341,8 @@ typedef struct Scheme_Cont {
struct Scheme_Overflow *save_overflow;
mz_jmp_buf *savebuf; /* save old error buffer here */
Scheme_Object *escape_cont;
/* Arguments passed to a continuation invocation to the continuation restorer: */
Scheme_Object *value; /* argument(s) to continuation */
struct Scheme_Overflow *resume_to; /* meta-continuation return */
@ -1471,6 +1473,8 @@ void scheme_about_to_move_C_stack(void);
Scheme_Object *scheme_apply_multi_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state);
Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object **old_runstack);
/*========================================================================*/
/* semaphores and locks */
/*========================================================================*/

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

@ -3269,6 +3269,7 @@ static Scheme_Object *def_nested_exn_handler(int argc, Scheme_Object *argv[])
if (scheme_current_thread->nester) {
Scheme_Thread *p = scheme_current_thread;
p->cjs.jumping_to_continuation = (Scheme_Object *)scheme_current_thread;
p->cjs.alt_full_continuation = NULL;
p->cjs.val = argv[0];
p->cjs.is_kill = 0;
scheme_longjmp(*p->error_buf, 1);
@ -3872,6 +3873,7 @@ static void exit_or_escape(Scheme_Thread *p)
if (p->running & MZTHREAD_KILLED)
p->running -= MZTHREAD_KILLED;
p->cjs.jumping_to_continuation = (Scheme_Object *)p;
p->cjs.alt_full_continuation = NULL;
p->cjs.is_kill = 1;
scheme_longjmp(*p->error_buf, 1);
}

2
src/racket/src/type.c
View File

@ -424,12 +424,14 @@ static int bad_trav_FIXUP(void *p, struct NewGC *gc)
static void MARK_cjs(Scheme_Continuation_Jump_State *cjs, struct NewGC *gc)
{
gcMARK2(cjs->jumping_to_continuation, gc);
gcMARK2(cjs->alt_full_continuation, gc);
gcMARK2(cjs->val, gc);
}
static void FIXUP_cjs(Scheme_Continuation_Jump_State *cjs, struct NewGC *gc)
{
gcFIXUP2(cjs->jumping_to_continuation, gc);
gcFIXUP2(cjs->alt_full_continuation, gc);
gcFIXUP2(cjs->val, gc);
}