Skip to content

Commit 76e0806

Browse files
ktakashiktakashi
committed
Supporting continuation barrier
1 parent 8895c0f commit 76e0806

File tree

6 files changed

+261
-9
lines changed

6 files changed

+261
-9
lines changed

‎lib/sagittarius/continuations.scm‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,8 @@
3939

4040
&continuation make-continuation-violation
4141
continuation-violation? continuation-violation-prompt-tag
42+
43+
call-with-continuation-barrier
4244

4345
continuation? composable-continuation?
4446
continuation-prompt-available?

‎src/lib_sagittarius.stub‎

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1855,14 +1855,20 @@
18551855
(define-c-proc %call/comp (proc::<procedure> tag) :no-export Sg_VMCallComp)
18561856
(define-c-proc %call/delim-cc (proc::<procedure> tag) :no-export
18571857
Sg_VMCallDelimitedCC)
1858+
(define-c-proc call-with-continuation-barrier (thunk::<procedure>)
1859+
Sg_VMCallCB)
1860+
18581861
(define-c-proc continuation? (o) ::<boolean> :no-side-effect Sg_ContinuationP)
18591862
(define-c-proc composable-continuation? (o) ::<boolean> :no-side-effect
18601863
Sg_ComposableContinuationP)
18611864
(define-c-proc continuation-prompt-available? (tag :optional (cont #f))
18621865
::<boolean> :no-side-effect
18631866
Sg_ContinuationPromptAvailableP)
18641867

1865-
(define (make-continuation-prompt-tag :optional (name (gensym))) (list name))
1868+
(define-c-proc make-continuation-prompt-tag
1869+
(:optional (name::<symbol> (Sg_Gensym NULL)))
1870+
Sg_MakeContinuationPromptTag)
1871+
18661872
(define default-continuation-prompt-tag
18671873
(let ((tag (make-continuation-prompt-tag (gensym "default"))))
18681874
(lambda () tag)))

‎src/sagittarius/private/vm.h‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -215,6 +215,7 @@ typedef struct SgPromptRec
215215
SgObject handler;
216216
SgCStack *cstack;
217217
SgObject winders;
218+
int barrierP;
218219
} SgPrompt;
219220
/* deque of prompt
220221
installation -> prepend
@@ -426,9 +427,12 @@ SG_EXTERN SgObject Sg_VMCallCC(SgObject proc);
426427
/* call-with-continuation-prompt */
427428
SG_EXTERN SgObject Sg_VMCallCP(SgObject proc, SgObject tag,
428429
SgObject handler, SgObject args);
430+
/* call-with-continuation-barrier */
431+
SG_EXTERN SgObject Sg_VMCallCB(SgObject thunk);
429432
SG_EXTERN SgObject Sg_VMCallComp(SgObject proc, SgObject tag);
430433
SG_EXTERN SgObject Sg_VMCallDelimitedCC(SgObject proc, SgObject tag);
431434
SG_EXTERN SgObject Sg_VMAbortCC(SgObject tag, SgObject args);
435+
SG_EXTERN SgObject Sg_MakeContinuationPromptTag(SgObject name);
432436
SG_EXTERN int Sg_ContinuationP(SgObject o);
433437
SG_EXTERN int Sg_ComposableContinuationP(SgObject o);
434438
SG_EXTERN int Sg_ContinuationPromptAvailableP(SgObject tag, SgObject cont);

‎src/vm.c‎

Lines changed: 100 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1561,6 +1561,57 @@ static SgPromptNode *search_prompt_node(SgVM *vm, SgObject tag)
15611561
return NULL;
15621562
}
15631563

1564+
static int has_barrier_node(SgVM *vm, SgObject tag)
1565+
{
1566+
SgPromptNode *node = vm->prompts;
1567+
1568+
/* search tag */
1569+
while (node) {
1570+
if (node->prompt->tag == tag) return FALSE;
1571+
if (node->prompt->barrierP) return TRUE;
1572+
node = node->next;
1573+
}
1574+
return FALSE;
1575+
}
1576+
1577+
/*
1578+
Check if invoking a continuation would enter a barrier from outside.
1579+
This happens when:
1580+
- The continuation was captured inside a barrier
1581+
- We're currently outside that barrier
1582+
- Invoking would restore to inside the barrier = "entering" = error
1583+
1584+
Returns the barrier prompt if entering would occur, NULL otherwise.
1585+
*/
1586+
static SgPrompt *check_barrier_entry(SgVM *vm, SgContinuation *c)
1587+
{
1588+
SgContFrame *cont = c->cont;
1589+
1590+
/* Scan saved continuation frames for barrier prompts */
1591+
while (!bottom_cont_frame_p(vm, cont)) {
1592+
if (PROMPT_FRAME_MARK_P(cont)) {
1593+
SgPrompt *p = (SgPrompt *)cont->pc;
1594+
if (p->barrierP) {
1595+
/* Check if this barrier is in current prompt chain */
1596+
SgPromptNode *node = vm->prompts;
1597+
int found = FALSE;
1598+
while (node) {
1599+
if (node->prompt == p) {
1600+
found = TRUE;
1601+
break;
1602+
}
1603+
node = node->next;
1604+
}
1605+
if (!found) {
1606+
/* Barrier in saved state but not current -> entering barrier */
1607+
return p;
1608+
}
1609+
}
1610+
}
1611+
cont = cont->prev;
1612+
}
1613+
return NULL; /* ok, no barrier entry */
1614+
}
15641615

15651616
static int cont_prompt_match_p(SgContFrame *c, SgPrompt *prompt)
15661617
{
@@ -1603,6 +1654,8 @@ static void install_prompt(SgVM *, SgPrompt *);
16031654
static void remove_prompt(SgVM *, SgPrompt *);
16041655
static SgPromptNode * remove_prompts(SgVM *, SgObject);
16051656
static SgObject abort_body(SgPromptNode *node, SgObject winders, SgObject args);
1657+
static void continuation_violation(SgObject who, SgObject message,
1658+
SgObject promptTag);
16061659

16071660
static SgObject throw_delimited_continuation_body(SgObject,
16081661
SgContinuation *,
@@ -1858,6 +1911,15 @@ static SgObject throw_continuation(SgObject *argv, int argc, void *data)
18581911
SgObject handlers;
18591912
SgVM *vm = Sg_VM();
18601913
SgPrompt *prompt = (SgPrompt *)SG_CDR(data);
1914+
SgPrompt *barrier;
1915+
1916+
/* Check if we're trying to enter a barrier from outside */
1917+
barrier = check_barrier_entry(vm, c);
1918+
if (barrier) {
1919+
continuation_violation(SG_INTERN("continuation"),
1920+
SG_MAKE_STRING("Cannot apply continuation across barrier"),
1921+
barrier->tag);
1922+
}
18611923

18621924
if (c->cstack && vm->cstack != c->cstack) {
18631925
SgCStack *cs;
@@ -1984,8 +2046,14 @@ SgObject Sg_VMCallComp(SgObject proc, SgObject tag)
19842046
SgContinuation *cont;
19852047
SgObject contproc;
19862048
SgVM *vm = Sg_VM();
1987-
SgPromptNode *node = search_prompt_node(vm, tag);
2049+
SgPromptNode *node;
19882050

2051+
if (has_barrier_node(vm, tag)) {
2052+
CONT_ERR("call-with-composable-continuation",
2053+
"Cannot capture past continuation barrier", tag);
2054+
}
2055+
2056+
node = search_prompt_node(vm, tag);
19892057
if (!node) goto err;
19902058
/*
19912059
NOT DOING IT FOR NOW.
@@ -2181,6 +2249,7 @@ static SgPrompt *make_prompt(SgObject tag, SgObject handler, SgVM *vm)
21812249
prompt->handler = handler;
21822250
prompt->cstack = vm->cstack;
21832251
prompt->winders = vm->dynamicWinders;
2252+
prompt->barrierP = FALSE;
21842253
return prompt;
21852254
}
21862255

@@ -2226,6 +2295,11 @@ static SgPromptNode * remove_prompts(SgVM *vm, SgObject tag)
22262295
return cur_node;
22272296
}
22282297

2298+
static SgObject make_prompt_tag(SgObject name)
2299+
{
2300+
return SG_LIST1(name);
2301+
}
2302+
22292303
SgObject Sg_VMCallCP(SgObject proc, SgObject tag,
22302304
SgObject handler, SgObject args)
22312305
{
@@ -2244,6 +2318,28 @@ SgObject Sg_VMCallCP(SgObject proc, SgObject tag,
22442318
return Sg_VMApply(proc, args);
22452319
}
22462320

2321+
static SgPrompt * make_barrier_prompt(SgVM *vm)
2322+
{
2323+
SgObject tag = make_prompt_tag(Sg_Gensym(SG_MAKE_STRING("barrier")));
2324+
SgPrompt *p = make_prompt(tag, SG_FALSE, vm);
2325+
p->barrierP = TRUE;
2326+
return p;
2327+
}
2328+
2329+
SgObject Sg_VMCallCB(SgObject thunk)
2330+
{
2331+
SgVM *vm = theVM;
2332+
SgPrompt *prompt = make_barrier_prompt(vm);
2333+
CHECK_STACK(CONT_FRAME_SIZE, vm);
2334+
PUSH_PROMPT_CONT(vm, prompt);
2335+
install_prompt(vm, prompt);
2336+
return Sg_VMApply0(thunk);
2337+
}
2338+
2339+
SgObject Sg_MakeContinuationPromptTag(SgObject name)
2340+
{
2341+
return make_prompt_tag(name);
2342+
}
22472343

22482344
/* given load path must be unshifted.
22492345
NB: we don't check the validity of given path.
@@ -2746,7 +2842,8 @@ static SgObject abort_body(SgPromptNode *node, SgObject winders, SgObject args)
27462842
the captured node is not loger valid.
27472843
*/
27482844
SgPromptNode *cur_node = remove_prompts(vm, node->prompt->tag);
2749-
if (!cur_node) Sg_Error(UC("Stale prompt: %S"), node->prompt->tag);
2845+
if (!cur_node)
2846+
CONT_ERR("abort-current-continuation", "Stale prompt", node->prompt->tag);
27502847
SgPrompt *prompt = cur_node->prompt;
27512848

27522849
if (prompt->cstack != vm->cstack) {
@@ -2774,7 +2871,7 @@ SgObject Sg_VMAbortCC(SgObject tag, SgObject args)
27742871
SgPromptNode *node = search_prompt_node(vm, tag);
27752872
SgContinuation c;
27762873

2777-
if (!node) Sg_Error(UC("No continuation tag: %S"), tag);
2874+
if (!node) CONT_ERR("abort-current-continuation", "No continuation tag", tag);
27782875

27792876
/* compose fake continuation to compute winders */
27802877
c.winders = node->prompt->winders;

‎test/tests/sagittarius/continuations.scm‎

Lines changed: 85 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -67,6 +67,20 @@
6767
(test-assert "call/cc p1 (#t)" (continuation-prompt-available? p1 k))
6868
(test-assert "call/cc p2 (#t)" (continuation-prompt-available? p2 k))))
6969

70+
(define-syntax with-cc-variants
71+
(lambda (x)
72+
(syntax-case x ()
73+
((k expr ...)
74+
(with-syntax ((call/cc (datum->syntax #'k 'call/cc))
75+
(call-with-current-continuation
76+
(datum->syntax #'k 'call-with-current-continuation)))
77+
#'(begin
78+
(define (a-test call/cc call-with-current-continuation)
79+
(call/prompt (lambda () expr)) ...)
80+
(a-test call/cc call-with-current-continuation)
81+
(a-test call/delim-cc
82+
call-with-delimited-current-continuation)))))))
83+
7084
(define-syntax test
7185
(lambda (x)
7286
(syntax-case x ()
@@ -76,8 +90,7 @@
7690
(datum->syntax #'k 'call-with-current-continuation)))
7791
#'(begin
7892
(define (a-test call/cc call-with-current-continuation)
79-
(call-with-continuation-prompt
80-
(lambda () (test-equal expected expr))))
93+
(test-equal expected (call/prompt (lambda () expr))))
8194
;; should work the same
8295
(a-test call/cc call-with-current-continuation)
8396
(a-test call/delim-cc
@@ -264,4 +277,74 @@
264277
27)))))
265278
tag
266279
#f)))
280+
281+
;; continuation barrier
282+
(with-cc-variants
283+
(test-equal 103 (call-with-continuation-barrier
284+
(lambda ()
285+
(call/cc
286+
(lambda (k)
287+
(+ 100 (k 103)))))))
288+
289+
(test-equal 104 (call/cc
290+
(lambda (k)
291+
(call-with-continuation-barrier
292+
(lambda ()
293+
(+ 100 (k 104)))))))
294+
295+
(test-equal 112 (let/prompt ()
296+
(call-with-current-continuation
297+
(lambda (k)
298+
(call-with-continuation-barrier
299+
(lambda ()
300+
(call-with-continuation-prompt
301+
(lambda ()
302+
(k 112)))))))))
303+
304+
(test-equal 'ok
305+
(call/cc
306+
(lambda (k)
307+
(call-with-continuation-barrier
308+
(lambda ()
309+
(k 'ok))))))
310+
)
311+
312+
(test-equal '((1 3 5) . 11)
313+
(let/prompt ([res '()])
314+
(define put!
315+
(lambda (obj)
316+
(set! res (cons obj res))))
317+
(define result
318+
(lambda ()
319+
(reverse res)))
320+
(define val
321+
(call-with-continuation-prompt
322+
(lambda ()
323+
(+ 1
324+
(call-with-composable-continuation
325+
(lambda (k)
326+
(call-with-continuation-barrier
327+
(lambda ()
328+
(dynamic-wind
329+
(lambda () (put! 1))
330+
(lambda ()
331+
(put! (k 2))
332+
10)
333+
(lambda () (put! 5)))))))))))
334+
(cons (result) val)))
335+
336+
(test-error continuation-violation?
337+
(call-with-continuation-barrier
338+
(lambda ()
339+
(call/comp values))))
340+
341+
(with-cc-variants
342+
(test-assert (continuation?
343+
(call-with-continuation-barrier
344+
(lambda ()
345+
(call/cc values)))))
346+
(test-error continuation-violation?
347+
((call-with-continuation-barrier
348+
(lambda ()
349+
(call/cc values))))))
267350
(test-end)

0 commit comments

Comments
 (0)