Skip to content

Commit 83d3bcc

Browse files
ktakashiktakashi
committed
Adding continuation type
1 parent 0195778 commit 83d3bcc

File tree

3 files changed

+61
-95
lines changed

3 files changed

+61
-95
lines changed

‎src/sagittarius/private/vm.h‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -89,6 +89,12 @@ typedef struct SgCStackRec
8989
jmp_buf jbuf;
9090
} SgCStack;
9191

92+
typedef enum {
93+
SG_FULL_CONTINUATION,
94+
SG_COMPOSABLE_CONTINUATION,
95+
SG_DELIMIETED_CONTINUATION
96+
} SgContType;
97+
9298
typedef struct SgContinucationRec
9399
{
94100
struct SgContinucationRec * prev;
@@ -100,6 +106,7 @@ typedef struct SgContinucationRec
100106
SgObject xhandler;
101107
int errorReporting;
102108
int rewindBefore;
109+
SgContType type;
103110
} SgContinuation;
104111

105112
#define SG_CONTINUATION(obj) ((SgContinuation*)obj)

‎src/vm.c‎

Lines changed: 52 additions & 93 deletions
Original file line numberDiff line numberDiff line change
@@ -1027,7 +1027,10 @@ enum {
10271027
#define PUSH_CONT(vm, next_pc) PUSH_CONT_REC(vm, next_pc, NORMAL_FRAME)
10281028
#define PUSH_BOUNDARY_CONT(vm) \
10291029
PUSH_CONT_REC(vm, BOUNDARY_FRAME_MARK, BOUNDARY_FRAME)
1030-
#define PUSH_PROMPT_CONT(vm, tag) PUSH_CONT_REC(vm, tag, PROMPT_FRAME)
1030+
#define PUSH_PROMPT_CONT(vm, tag) do { \
1031+
PUSH_CONT_REC(vm, tag, PROMPT_FRAME); \
1032+
FP(vm) = SP(vm); \
1033+
} while (0)
10311034

10321035
static SgWord apply_callN[2] = {
10331036
MERGE_INSN_VALUE2(APPLY, 2, 1),
@@ -1581,6 +1584,11 @@ static void install_prompt(SgVM *vm, SgPrompt *prompt);
15811584
static void remove_prompt(SgVM *vm, SgPrompt *prompt);
15821585
static SgObject abort_body(SgPromptNode *node, SgObject winders, SgObject args);
15831586

1587+
static SgObject throw_delimited_continuation_body(SgObject,
1588+
SgContinuation *,
1589+
SgObject,
1590+
SgPrompt *);
1591+
15841592
static SgObject throw_continuation_body(SgObject handlers,
15851593
SgContinuation *c,
15861594
SgObject args,
@@ -1820,7 +1828,7 @@ static SgObject throw_cont_compute_handlers(SgContinuation *c,
18201828
static SgObject throw_continuation(SgObject *argv, int argc, void *data)
18211829
{
18221830
SgContinuation *c = (SgContinuation*)SG_CAR(data);
1823-
SgObject handlers_to_call;
1831+
SgObject handlers;
18241832
SgVM *vm = Sg_VM();
18251833
SgPrompt *prompt = (SgPrompt *)SG_CDR(data);
18261834

@@ -1837,9 +1845,20 @@ static SgObject throw_continuation(SgObject *argv, int argc, void *data)
18371845
}
18381846
save_cont(vm);
18391847
}
1840-
handlers_to_call = throw_cont_compute_handlers(c, prompt, vm);
1841-
1842-
return throw_continuation_body(handlers_to_call, c, argv[0], prompt);
1848+
if (c->type == SG_DELIMIETED_CONTINUATION) {
1849+
SgContinuation abort_c;
1850+
SgPromptNode *node = search_prompt_node_by_tag(vm, prompt->tag);
1851+
abort_c.winders = node->prompt->winders;
1852+
abort_c.cstack = node->prompt->cstack; /* Non-null to enable post-thunks */
1853+
abort_c.cont = NULL;
1854+
abort_c.prev = NULL;
1855+
abort_c.ehandler = SG_FALSE;
1856+
handlers = throw_cont_compute_handlers(&abort_c, node->prompt, vm);
1857+
return throw_delimited_continuation_body(handlers, c, argv[0], prompt);
1858+
} else {
1859+
handlers = throw_cont_compute_handlers(c, prompt, vm);
1860+
return throw_continuation_body(handlers, c, argv[0], prompt);
1861+
}
18431862
}
18441863

18451864
static SgObject sym_continuation = SG_FALSE;
@@ -1867,6 +1886,7 @@ SgObject Sg_VMCallCC(SgObject proc)
18671886
cont->cstack = vm->cstack;
18681887
cont->prev = NULL;
18691888
cont->ehandler = SG_FALSE;
1889+
cont->type = SG_FULL_CONTINUATION;
18701890

18711891

18721892
contproc = make_cont_subr(cont, NULL);
@@ -1913,6 +1933,7 @@ SgObject Sg_VMCallComp(SgObject proc, SgObject tag)
19131933
cont->ehandler = SG_FALSE;
19141934
cont->cstack = NULL; /* so that this continuation can be
19151935
run on any cstack state. */
1936+
cont->type = SG_COMPOSABLE_CONTINUATION;
19161937
contproc = make_cont_subr(cont, node->prompt);
19171938

19181939
return Sg_VMApply1(proc, contproc);
@@ -1934,41 +1955,39 @@ SgObject Sg_VMCallComp(SgObject proc, SgObject tag)
19341955
static SgObject throw_delimited_continuation_cc(SgObject, void **);
19351956

19361957
static SgObject throw_delimited_continuation_body(SgObject handlers,
1937-
SgContinuation *c,
1938-
SgPrompt *capture_prompt,
1939-
SgObject args,
1940-
SgObject tag)
1958+
SgContinuation *c,
1959+
SgObject args,
1960+
SgPrompt *prompt)
19411961
{
19421962
SgVM *vm = Sg_VM();
19431963

19441964
/* Process abort handlers (post-thunks for unwinding) */
19451965
if (SG_PAIRP(handlers)) {
19461966
SgObject handler, chain;
1947-
void *data[5];
1967+
void *data[4];
19481968
handler = SG_CAAR(handlers);
19491969
chain = SG_CDAR(handlers);
19501970
data[0] = (void*)SG_CDR(handlers);
19511971
data[1] = (void*)c;
1952-
data[2] = (void*)capture_prompt;
1953-
data[3] = (void*)args;
1954-
data[4] = (void*)tag;
1955-
Sg_VMPushCC(throw_delimited_continuation_cc, data, 5);
1956-
1972+
data[2] = (void*)args;
1973+
data[3] = (void*)prompt;
1974+
Sg_VMPushCC(throw_delimited_continuation_cc, data, 4);
19571975
/* For abort/post-thunks, directly SET winders to the chain (not merge)
19581976
This is like abort_body which also sets vm->dynamicWinders = chain */
19591977
vm->dynamicWinders = chain;
19601978
return Sg_VMApply0(handler);
19611979
} else {
19621980
/* All abort handlers processed. Now we need to:
19631981
1. Set up the new prompt
1964-
2. Compute wind-in handlers (pre-thunks) to restore the continuation's dynamic extent
1982+
2. Compute wind-in handlers (pre-thunks) to restore the continuation's
1983+
dynamic extent
19651984
3. Run those handlers, then apply the continuation */
19661985

19671986
SgPrompt *new_prompt;
1968-
SgPromptNode *node = search_prompt_node_by_tag(vm, tag);
1987+
SgPromptNode *node = search_prompt_node_by_tag(vm, prompt->tag);
19691988

19701989
if (!node) {
1971-
Sg_Error(UC("Stale prompt in delimited continuation: %S"), tag);
1990+
Sg_Error(UC("Stale prompt in delimited continuation: %S"), prompt->tag);
19721991
}
19731992

19741993
/* Pop continuation frames up to and including the prompt frame */
@@ -1980,95 +1999,35 @@ static SgObject throw_delimited_continuation_body(SgObject handlers,
19801999
cont_frame = cont_frame->prev;
19812000
}
19822001

1983-
/* Remove the original prompt and set continuation to just before the prompt */
2002+
/* Remove the original prompt and set continuation to just before
2003+
the prompt */
19842004
remove_prompt(vm, node->prompt);
19852005
vm->cont = node->frame->prev;
19862006

19872007
/* Create a new prompt for the continuation */
1988-
new_prompt = make_prompt(tag, SG_FALSE, vm);
2008+
new_prompt = make_prompt(prompt->tag, SG_FALSE, vm);
19892009

19902010
CHECK_STACK(CONT_FRAME_SIZE, vm);
19912011
PUSH_PROMPT_CONT(vm, new_prompt);
1992-
FP(vm) = SP(vm);
19932012
install_prompt(vm, new_prompt);
19942013

1995-
/* Now compute and run wind-in handlers using the composable continuation path.
1996-
We've already aborted to the prompt, so current vm->dynamicWinders is at
1997-
the prompt's level. We need to wind into c's winders. */
1998-
{
1999-
SgObject wind_handlers = throw_cont_compute_handlers(c, capture_prompt, vm);
2000-
/* Use the regular composable continuation body to process these handlers */
2001-
return throw_continuation_body(wind_handlers, c, args, capture_prompt);
2002-
}
2014+
/* Now compute and run wind-in handlers using the composable
2015+
continuation path. We've already aborted to the prompt, so
2016+
current vm->dynamicWinders is at the prompt's level. We need to
2017+
wind into c's winders. */
2018+
SgObject wind_handlers = throw_cont_compute_handlers(c, prompt, vm);
2019+
/* Use the regular composable continuation body to process these handlers */
2020+
return throw_continuation_body(wind_handlers, c, args, prompt);
20032021
}
20042022
}
20052023

20062024
static SgObject throw_delimited_continuation_cc(SgObject result, void **data)
20072025
{
20082026
SgObject handlers = SG_OBJ(data[0]);
20092027
SgContinuation *c = (SgContinuation*)data[1];
2010-
SgPrompt *capture_prompt = (SgPrompt*)data[2];
2011-
SgObject args = SG_OBJ(data[3]);
2012-
SgObject tag = SG_OBJ(data[4]);
2013-
return throw_delimited_continuation_body(handlers, c, capture_prompt, args, tag);
2014-
}
2015-
2016-
static SgObject throw_delimited_continuation(SgObject *argv, int argc, void *data)
2017-
{
2018-
SgContinuation *c = SG_CONTINUATION(SG_CAAR(data));
2019-
SgPrompt *capture_prompt = (SgPrompt *)SG_CDAR(data);
2020-
SgObject tag = SG_CDR(data);
2021-
SgVM *vm = Sg_VM();
2022-
SgPromptNode *node = search_prompt_node_by_tag(vm, tag);
2023-
SgObject h, args;
2024-
2025-
if (!node) {
2026-
Sg_Error(UC("Continuation application: no corresponding prompt for tag ~S"), tag);
2027-
}
2028-
2029-
/* argv[0] is already a list of arguments (folded by optional arg processing) */
2030-
args = argv[0];
2031-
2032-
/* Check for cross-cstack jumps */
2033-
if (node->prompt->cstack != vm->cstack) {
2034-
SgCStack *cs;
2035-
for (cs = vm->cstack; cs; cs = cs->prev) {
2036-
if (node->prompt->cstack == cs) break;
2037-
}
2038-
if (cs != NULL) {
2039-
/* Need to longjmp */
2040-
vm->escapeReason = SG_VM_ESCAPE_CONT;
2041-
vm->escapeData[0] = c;
2042-
vm->escapeData[1] = Sg_Cons(Sg_Cons(args, (SgObject)capture_prompt), tag);
2043-
longjmp(vm->cstack->jbuf, 1);
2044-
}
2045-
}
2046-
2047-
/* call/delimited-cc (call/cc-like): ALWAYS abort to the prompt and reinstall.
2048-
This is the key difference from composable continuations which just
2049-
continue from where they are.
2050-
2051-
Run post-thunks to unwind from current to prompt. */
2052-
{
2053-
SgContinuation abort_c;
2054-
abort_c.winders = node->prompt->winders;
2055-
abort_c.cstack = node->prompt->cstack; /* Non-null to enable post-thunks */
2056-
abort_c.cont = NULL;
2057-
abort_c.prev = NULL;
2058-
abort_c.ehandler = SG_FALSE;
2059-
h = throw_cont_compute_handlers(&abort_c, node->prompt, vm);
2060-
}
2061-
2062-
return throw_delimited_continuation_body(h, c, capture_prompt, args, tag);
2063-
}
2064-
2065-
static SgObject make_delimited_cont_subr(SgContinuation *cont, SgPrompt *prompt, SgObject tag)
2066-
{
2067-
/* data = ((cont . prompt) . tag) */
2068-
return Sg_MakeSubr(throw_delimited_continuation,
2069-
Sg_Cons(Sg_Cons((SgObject)cont, (SgObject)prompt), tag),
2070-
0, 1,
2071-
sym_continuation);
2028+
SgObject args = SG_OBJ(data[2]);
2029+
SgPrompt *prompt = (SgPrompt*)data[3];
2030+
return throw_delimited_continuation_body(handlers, c, args, prompt);
20722031
}
20732032

20742033
/* call-with-current-continuation with prompt delimiting (Racket-like call/cc) */
@@ -2093,9 +2052,10 @@ SgObject Sg_VMCallDelimitedCC(SgObject proc, SgObject tag)
20932052
cont->prev = NULL;
20942053
cont->ehandler = SG_FALSE;
20952054
cont->cstack = NULL;
2055+
cont->type = SG_DELIMIETED_CONTINUATION;
20962056

20972057
/* Pass the capture-time prompt so we know where to stop when splicing */
2098-
contproc = make_delimited_cont_subr(cont, node->prompt, tag);
2058+
contproc = make_cont_subr(cont, node->prompt);
20992059

21002060
return Sg_VMApply1(proc, contproc);
21012061
err:
@@ -2157,7 +2117,6 @@ SgObject Sg_VMCallCP(SgObject proc, SgObject tag,
21572117

21582118
CHECK_STACK(CONT_FRAME_SIZE, vm);
21592119
PUSH_PROMPT_CONT(vm, prompt);
2160-
FP(vm) = SP(vm);
21612120
install_prompt(vm, prompt);
21622121

21632122
return Sg_VMApply(proc, args);

‎test/tests/sagittarius/prompt.scm‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,12 +10,12 @@
1010
((_ expect (quote name) expr)
1111
(call/prompt (lambda () (test-equal 'name expect expr))))
1212
((_ expect expr args ...)
13-
(test expect 'expr (expr args ...)))))
13+
(test expect '(expr expect) (expr args ...)))))
1414
(define-syntax test-values
1515
(syntax-rules ()
1616
((_ expect expr args ...)
1717
(let-values ((r (expr args ...)))
18-
(test-equal 'expr expect r)))))
18+
(test-equal '(expr expect) expect r)))))
1919

2020
(define-syntax err/rt-test
2121
(syntax-rules ()

0 commit comments

Comments
 (0)