summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2015-10-25 20:48:39 -0700
committerKaz Kylheku <kaz@kylheku.com>2015-10-25 20:48:39 -0700
commit596f3633c74f5dbd90768355e389ffadfbf2e89f (patch)
treeff52b9d41fb9988eb5e4301a312a777ce76e690b
parentbde25e195a88a78c12d3cdac820bcfdc8a01bbca (diff)
downloadtxr-596f3633c74f5dbd90768355e389ffadfbf2e89f.tar.gz
txr-596f3633c74f5dbd90768355e389ffadfbf2e89f.tar.bz2
txr-596f3633c74f5dbd90768355e389ffadfbf2e89f.zip
TXR gets delimited continuations.
* unwind.c (sys_cont_s): New symbol variable. (uw_pop_block): New function, supporting uw_block_end macro. Special logic is needed for popping blocks now, because a block can be a captured stub at the top of a continuation, which must not be popped in the regular manner. (struct cont): New struct type. (cont_destroy, cont_mark): New static functions. (cont_ops): New static structure. (revive_cont, capture_cont): New static functions. (uw_capture_cont): New functions. (uw_init): Initialize sys_cont_s. Register sys:capture-cont intrinsic. * unwind.h (enum uw_frtype): New enum member UW_CAPTURED_BLOCK. When a block is captured as a stub copy of the prompt block of a delimited continuation, its type is changed from UW_BLOCK to this new type. This does two things: it makes the block invisible to block-related code that does nothing with continuations (code that looks for UW_BLOCK and ignores anything else). Secondly, there is some special handling related to UW_CAPTURED_BLOCK frames. (uw_pop_block, uw_capture_cont): Declared. (uw_block_begin): New local pointer uw_rslt introduced which helps communicate the result variable over to the uw_block_end macro (so we don't have to add a variable argument to the latter). (uw_block_end): Use uw_pop_block instead of uw_pop_frame. * txr.1: Documented delimited continuations.
-rw-r--r--txr.1183
-rw-r--r--unwind.c156
-rw-r--r--unwind.h11
3 files changed, 345 insertions, 5 deletions
diff --git a/txr.1 b/txr.1
index 899b3c69..9b33de81 100644
--- a/txr.1
+++ b/txr.1
@@ -12506,6 +12506,23 @@ and
A block named by the symbol nil is slightly special: it is
understood to be an anonymous block.
+A named or anonymous block establishes an exit point for the
+.code return-from
+or
+.code return
+operator, respectively. These operators can be invoked within a block
+to cause its immediate termination with a specified return value.
+
+A block also establishes a prompt for a
+.IR "delimited continuation" .
+Anywhere in a block, a continuation can be captured using the
+.code sys:capture-cont
+function. Delimited continuations are described in the section
+Delimited Continuations. A delimited continuation allows an apparently
+abandoned block to be restarted at the capture point, with the
+entire call chain and dynamic environment between the prompt and the capture
+point intact.
+
Blocks in \*(TL have dynamic scope. This means that the following
situation is allowed:
@@ -12547,6 +12564,8 @@ the construct.
.code throw
itself is a function and not an operator.
+Common Lisp blocks also do not support delimited continuations.
+
.coNP Operators @ return and @ return-from
.synb
.mets (return <> [ value ])
@@ -27301,6 +27320,170 @@ The frame receives control even if it it is not otherwise eligible for
catching the exception type denoted by
.metn symbol .
+.SS* Delimited Continuations
+
+\*(TL supports delimited continuations, which are integrated with the
+.code block
+feature. Any named or anonymous block, including the implicit blocks
+created around function bodies, can be used as the delimiting
+.I prompt
+for the capture of a continuation.
+
+A delimited continuation consists of a copy
+of entire activation chain ("call stack") segment between the delimiting
+prompt and the capture point,
+.I reified
+as a first-class function. The function takes one argument. When the
+continuation function is called, the copy of the evaluation context is
+reinstated and its execution is restarted. Within the reinstated context,
+control resumes at the point where the continuation was originally captured.
+
+The argument passed to the continuation function appears as a return value from
+the capture form. Thus the capture form appears to return multiple times: the
+first time it returns, it returns the continuation. Then each time the
+continuation is called, and thereby resumed, the capture form appears to return
+again, this time returning the value which was passed in.
+
+A restarted continuation can terminate normally: that is, by simply continuing
+to execute and then finally terminating the block which served as its
+delimiting prompt. When this happens, the continuation function terminates
+and returns the block's value.
+
+Thus, a delimited continuation is an ordinary function. It can be invoked
+multiple times, composed with other functions and so forth.
+
+.TP* Notes:
+
+Delimited continuations resemble lexical closures in some ways. Both
+constructs provide a way to return to some context whose evaluation
+has already been abandoned, and to access some aspects of that context.
+However, lexical closures are statically scoped. Closures capture the lexically
+apparent scope at a given point, and produce a function whose body has access
+to that scope, as well as to some arbitrary arguments. Thus, a lexical scope
+is reified as a first-class function. By contrast, a delimited continuation
+is dynamic. It captures an an entire segment of a program activation chain,
+up to the delimiting prompt. This segment includes scopes which are not
+lexically visible at the capture point: the scopes of parent functions.
+Moreover, the segment includes not only scopes, but also other aspects of
+the evaluation context, such as the possibility of returning to callers,
+and the (captured portion of) the original dynamic environment, such as
+exception handlers. That is to say, a lexical closure's body cannot return to
+the surrounding code or see any of its original dynamic environment; it can
+only inspect the environment, and then return to its own caller. Whereas a
+restarted delimited continuation can continue evaluation of the surrounding
+code, return to surrounding forms and parent functions, and access the dynamic
+environment. The continuation function returns to its caller when that entire
+restarted context terminates, whereas a closure returns to its caller as soon
+as the closure body terminates.
+
+.coNP Function @ sys:capture-cont
+.synb
+.mets (sys:capture-cont < name << error-report-sym )
+.syne
+.desc
+The
+.code sys:capture-cont
+function captures a continuation, and also serves as the resume point
+for the resulting continuation. Which of these two situations is the
+case (capture or resumption) is distinguished by the return value.
+
+A block named
+.meta name
+must be visible; the continuation is delimited by the closest
+enclosing block of this name.
+
+The
+.meta error-report-sym
+argument should be a symbol. It is used in the error message if
+.code sys:capture-cont
+is incorrectly used. The intent is that higher level constructs built
+on this function can pass their own name, so the resulting diagnostic
+pertains to these constructs, rather than the lower level interface.
+
+The
+.code sys:capture-cont
+function returns a cons cell. The
+.code car
+field of the cell distinguishes the capture and resume situations.
+If the
+.code car
+is the object
+.codn t ,
+then it indicates capture, and in this case, the
+.code cdr
+field contains the continuation function. When the continuation
+function is called, the
+.code sys:capture-cont
+function appears to return again. This time the
+.code car
+of the returned cell is
+.code nil
+indicating that the
+.code cdr
+field holds the argument value which was passed to the continuation
+function.
+
+The invoked continuation function will terminate when the resumed context
+terminates. If that context terminates normally (by returning from the
+delimiting block named by
+.metn name ),
+then the result value of that block will appear as the return value
+of the continuation function.
+
+.TP* Note:
+
+The continuation function may be used any time after it is produced, and may be
+called more than once, regardless of whether the originally captured dynamic
+context is still executing. The underlying continuation stores a copy of the
+captured dynamic context. Whenever the continuation function is invoked, a
+copy of the captured context is made again and reinstated as if it were a new
+context. Thus the apparent additional returns from
+.code sys:capture-cont
+are not actually made in the original context, but a copy. The copy of the
+context is not complete; it only extends up to the enclosing block which was
+named in the capturing call.
+
+.TP* "Example:"
+
+The following example shows an implementation of the
+.meta shift
+and
+.meta reset
+operators which often appear in literature about delimited continuations.
+To avoid a clash with the
+.code shift
+macro, the
+.meta shift
+operator is named
+.codn shft .
+Note that the example shows the extended
+.meta shift
+and
+.meta reset
+with named prompts.
+
+.cblk
+ ;; Definition:
+
+ (defmacro reset (name . body)
+ ^(block ,name ,*body))
+
+ (defun shft-helper (name fun)
+ (let ((val (sys:capture-cont name 'shft)))
+ (if (car val)
+ (call fun (lambda (arg)
+ (call (cdr val) arg)))
+ (cdr val))))
+
+ (defmacro shft (name var . body)
+ ^(shft-helper ',name
+ (lambda (,var) (return-from ,name ,*body))))
+
+ ;; Usage:
+ (reset foo (* 2 (shft foo k [k 3]) (shft foo l [l 4])))
+ --> 24
+.cble
+
.SS* Regular Expression Library
.coNP Functions @ search-regex and @ range-regex
.synb
diff --git a/unwind.c b/unwind.c
index 0e075306..6064ccfd 100644
--- a/unwind.c
+++ b/unwind.c
@@ -50,7 +50,7 @@ static uw_frame_t *uw_env_stack;
static uw_frame_t *uw_exit_point;
static uw_frame_t toplevel_env;
-static val unhandled_hook_s, types_s, jump_s;
+static val unhandled_hook_s, types_s, jump_s, sys_cont_s;
static val frame_type, catch_frame_type, handle_frame_type;
@@ -203,6 +203,20 @@ void uw_pop_frame(uw_frame_t *fr)
}
}
+void uw_pop_block(uw_frame_t *fr, val *pret)
+{
+ if (uw_stack->uw.type == UW_CAPTURED_BLOCK) {
+ assert (fr->uw.type == UW_BLOCK || fr->uw.type == UW_CAPTURED_BLOCK);
+ assert (uw_stack->bl.tag == fr->bl.tag);
+
+ uw_stack = fr->uw.up;
+ uw_block_return(uw_stack->bl.tag, *pret);
+ abort();
+ }
+
+ uw_pop_frame(fr);
+}
+
void uw_pop_until(uw_frame_t *fr)
{
while (uw_stack != fr)
@@ -614,6 +628,144 @@ void uw_continue(uw_frame_t *current, uw_frame_t *cont)
uw_unwind_to_exit_point();
}
+struct cont {
+ uw_frame_t *orig;
+ cnum size;
+ val tag;
+ mem_t *stack;
+};
+
+static void cont_destroy(val obj)
+{
+ struct cont *cont = coerce(struct cont *, obj->co.handle);
+ free(cont->stack);
+ free(cont);
+}
+
+static void cont_mark(val obj)
+{
+ struct cont *cont = coerce(struct cont *, obj->co.handle);
+ val *mem = coerce(val *, cont->stack);
+ gc_mark_mem(mem, mem + cont->size / sizeof *mem);
+ gc_mark(cont->tag);
+}
+
+static struct cobj_ops cont_ops = cobj_ops_init(eq,
+ cobj_print_op,
+ cont_destroy,
+ cont_mark,
+ cobj_hash_op);
+
+static val revive_cont(val dc, val arg)
+{
+ const int frame_slack = 32 * sizeof (val);
+ struct cont *cont = coerce(struct cont *, cobj_handle(dc, sys_cont_s));
+ mem_t *space = coerce(mem_t *, alloca(cont->size + frame_slack)) + frame_slack;
+ uint_ptr_t orig_start = coerce(uint_ptr_t, cont->orig);
+ uint_ptr_t orig_end = orig_start + cont->size;
+ cnum delta = space - coerce(mem_t *, cont->orig);
+ mem_t *ptr;
+ uw_frame_t *new_uw_stack = coerce(uw_frame_t *, space), *fr;
+ int env_set = 0;
+
+ memcpy(space, cont->stack, cont->size);
+
+ for (ptr = space; ptr < space + cont->size; ptr += sizeof (cnum))
+ {
+ uint_ptr_t *wordptr = coerce(uint_ptr_t *, ptr);
+ uint_ptr_t word = *wordptr;
+
+ if (word >= orig_start - frame_slack &&
+ word < orig_end && is_ptr(coerce(val, word)))
+ *wordptr = word + delta;
+ }
+
+ uw_block_begin (cont->tag, result);
+
+ for (fr = new_uw_stack; ; fr = fr->uw.up) {
+ if (!env_set && fr->uw.type == UW_ENV) {
+ uw_env_stack = fr;
+ env_set = 1;
+ }
+ if (fr->uw.up == 0) {
+ bug_unless (fr->uw.type == UW_CAPTURED_BLOCK);
+ bug_unless (fr->bl.tag == cont->tag);
+ fr->uw.up = uw_stack;
+ break;
+ }
+ }
+
+ uw_stack = new_uw_stack;
+
+ bug_unless (uw_stack->uw.type == UW_BLOCK);
+
+ uw_stack->bl.result = cons(nil, arg);
+ uw_exit_point = uw_stack;
+ uw_unwind_to_exit_point();
+ abort();
+
+ uw_block_end;
+
+ return result;
+}
+
+static val capture_cont(val tag, uw_frame_t *block)
+{
+ uw_block_begin (nil, result);
+
+ bug_unless (uw_stack < block);
+
+ {
+ cnum bloff = coerce(mem_t *, block) - coerce(mem_t *, uw_stack);
+ cnum size = bloff + sizeof *block;
+ mem_t *stack = chk_malloc(size);
+ uw_frame_t *blcopy = coerce(uw_frame_t *, stack + bloff);
+ struct cont *cont = coerce(struct cont *, chk_malloc(sizeof *cont));
+
+ cont->orig = uw_stack;
+ cont->size = size;
+ cont->stack = stack;
+ cont->tag = nil;
+
+ memcpy(stack, uw_stack, size);
+
+ blcopy->uw.up = 0;
+ blcopy->uw.type = UW_CAPTURED_BLOCK;
+
+ result = cobj(coerce(mem_t *, cont), sys_cont_s, &cont_ops);
+
+ cont->tag = tag;
+
+ result = cons(t, func_f1(result, revive_cont));
+ }
+
+ uw_block_end;
+
+ return result;
+}
+
+val uw_capture_cont(val tag, val ctx)
+{
+ uw_frame_t *fr;
+
+ for (fr = uw_stack; fr != 0; fr = fr->uw.up) {
+ if (fr->uw.type == UW_BLOCK && fr->bl.tag == tag)
+ break;
+ }
+
+ if (!fr) {
+ if (tag)
+ uw_throwf(error_s, lit("~s: no block ~s is visible"),
+ ctx, tag, nao);
+ else
+ uw_throwf(error_s, lit("~s: no anonymous block is visible"),
+ ctx, nao);
+ abort();
+ }
+
+ return capture_cont(tag, fr);
+}
+
void uw_init(void)
{
protect(&toplevel_env.ev.func_bindings,
@@ -638,6 +790,7 @@ void uw_late_init(void)
convert(val *, 0));
types_s = intern(lit("types"), user_package);
jump_s = intern(lit("jump"), user_package);
+ sys_cont_s = intern(lit("cont"), system_package);
frame_type = make_struct_type(intern(lit("frame"), user_package),
nil, nil, nil, nil, nil, nil);
catch_frame_type = make_struct_type(intern(lit("catch-frame"),
@@ -656,4 +809,5 @@ void uw_late_init(void)
reg_fun(intern(lit("find-frame"), user_package), func_n2o(uw_find_frame, 0));
reg_fun(intern(lit("invoke-catch"), user_package),
func_n2v(uw_invoke_catch));
+ reg_fun(intern(lit("capture-cont"), system_package), func_n2(uw_capture_cont));
}
diff --git a/unwind.h b/unwind.h
index 97d1026a..d6753da4 100644
--- a/unwind.h
+++ b/unwind.h
@@ -32,7 +32,7 @@
typedef union uw_frame uw_frame_t;
typedef enum uw_frtype {
- UW_BLOCK, UW_ENV, UW_CATCH, UW_HANDLE, UW_DBG
+ UW_BLOCK, UW_CAPTURED_BLOCK, UW_ENV, UW_CATCH, UW_HANDLE, UW_DBG
} uw_frtype_t;
struct uw_common {
@@ -123,12 +123,14 @@ void uw_push_debug(uw_frame_t *, val func, struct args *,
val ub_p_a_pairs, val env, val data,
val line, val chr);
void uw_pop_frame(uw_frame_t *);
+void uw_pop_block(uw_frame_t *, val *pret);
void uw_pop_until(uw_frame_t *);
uw_frame_t *uw_current_frame(void);
uw_frame_t *uw_current_exit_point(void);
val uw_get_frames(void);
val uw_find_frame(val extype, val frtype);
val uw_invoke_catch(val catch_frame, val sym, struct args *);
+val uw_capture_cont(val tag, val ctx);
void uw_init(void);
void uw_late_init(void);
@@ -147,15 +149,16 @@ noreturn val type_mismatch(val, ...);
obj_t *RESULTVAR = nil; \
do { \
uw_frame_t uw_blk; \
+ obj_t **uw_rslt = &RESULTVAR; \
uw_push_block(&uw_blk, TAG); \
if (extended_setjmp(uw_blk.bl.jb)) { \
RESULTVAR = uw_blk.bl.result; \
} else { \
do { } while (0)
-#define uw_block_end \
- } \
- uw_pop_frame(&uw_blk); \
+#define uw_block_end \
+ } \
+ uw_pop_block(&uw_blk, uw_rslt); \
} while (0)
#define uw_env_begin \