From 174c416f9e7a690d4618a0263a2ace5ec41accf0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Sep 2019 11:23:47 -0600 Subject: [PATCH] repair for opportunistic 1-shot If normal 1-shot continuations are mixed with opportunistic 1-shot continuations created by `call-setting-continuation-attachment`, then promoting an opportunistic 1-shot at a GC is wrong unless the whole chain is promoted. original commit: 2dfac475666763b60935e382386af4438f3029e0 --- c/externs.h | 1 + c/gc.c | 18 +++++++++++++++--- c/schsig.c | 3 +-- mats/4.ms | 20 ++++++++++++++++++++ s/cpnanopass.ss | 3 ++- 5 files changed, 39 insertions(+), 6 deletions(-) diff --git a/c/externs.h b/c/externs.h index bb97ba84eb..4e50cc7aff 100644 --- a/c/externs.h +++ b/c/externs.h @@ -325,6 +325,7 @@ extern ptr S_get_scheme_arg PROTO((ptr tc, iptr n)); extern void S_put_scheme_arg PROTO((ptr tc, iptr n, ptr x)); extern iptr S_continuation_depth PROTO((ptr k)); extern ptr S_single_continuation PROTO((ptr k, iptr n)); +extern void S_promote_to_multishot PROTO((ptr k)); extern void S_split_and_resize PROTO((void)); extern void S_handle_overflow PROTO((void)); extern void S_handle_overflood PROTO((void)); diff --git a/c/gc.c b/c/gc.c index 11a355e09c..7a63972f96 100644 --- a/c/gc.c +++ b/c/gc.c @@ -83,6 +83,7 @@ static ptr sweep_loc[max_real_space+1]; static ptr orig_next_loc[max_real_space+1]; static ptr sorted_locked_objects; static ptr tlcs_to_rehash; +static ptr conts_to_promote; static ptr recheck_guardians_ls; #ifdef ENABLE_BACKREFERENCE @@ -613,10 +614,12 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { find_room(space_continuation, tg, type_closure, size_continuation, p); SETCLOSCODE(p,code); - /* don't promote general one-shots, but do promote opportunistic one-shots */ - if (CONTLENGTH(pp) == opportunistic_1_shot_flag) + /* don't promote general one-shots, but promote opportunistic one-shots */ + if (CONTLENGTH(pp) == opportunistic_1_shot_flag) { CONTLENGTH(p) = CONTCLENGTH(pp); - else + /* may need to recur at end to promote link: */ + conts_to_promote = S_cons_in(space_new, 0, p, conts_to_promote); + } else CONTLENGTH(p) = CONTLENGTH(pp); CONTCLENGTH(p) = CONTCLENGTH(pp); CONTWINDERS(p) = CONTWINDERS(pp); @@ -963,6 +966,7 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { } tlcs_to_rehash = Snil; + conts_to_promote = Snil; for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { ptr tc = (ptr)THREADTC(Scar(ls)); @@ -1573,6 +1577,14 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { tlcs_to_rehash = Scdr(tlcs_to_rehash); } + /* Promote opportunistic 1-shot continuations, because we can no + longer cached one and we can no longer reliably fuse the stack + back. */ + while (conts_to_promote != Snil) { + S_promote_to_multishot(CONTLINK(Scar(conts_to_promote))); + conts_to_promote = Scdr(conts_to_promote); + } + S_resize_oblist(); } diff --git a/c/schsig.c b/c/schsig.c index 01e9dc237d..82d37438f9 100644 --- a/c/schsig.c +++ b/c/schsig.c @@ -18,7 +18,6 @@ #include /* locally defined functions */ -static void S_promote_to_multishot PROTO((ptr k)); static void split PROTO((ptr k, ptr *s)); static void reset_scheme PROTO((void)); static NORETURN void do_error PROTO((iptr type, const char *who, const char *s, ptr args)); @@ -38,7 +37,7 @@ void S_put_scheme_arg(tc, n, x) ptr tc; iptr n; ptr x; { else FRAME(tc, n - asm_arg_reg_cnt) = x; } -static void S_promote_to_multishot(k) ptr k; { +void S_promote_to_multishot(k) ptr k; { while (CONTLENGTH(k) != CONTCLENGTH(k)) { CONTLENGTH(k) = CONTCLENGTH(k); k = CONTLINK(k); diff --git a/mats/4.ms b/mats/4.ms index a4dd35df3e..7cf1224bad 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -3596,6 +3596,26 @@ 'yes (lambda () (get-or-nope)))))))) + (begin + (define (gc-and-capture-continuation) + (collect 0) + (call/cc + (lambda (k) + (lambda () + (k (lambda () 8)))))) + (equal? 8 + (let ([v (call/1cc + (lambda (ek) + (let ([v (call-setting-continuation-attachment + 'v + (lambda () + (gc-and-capture-continuation)))]) + (if (number? v) + (add1 v) + v))))]) + (if (procedure? v) + (v) + 'no)))) ) ;;; section 4-7: diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 90c3b28129..58b12d3ebb 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -11613,12 +11613,13 @@ ,(%seq (set! ,%ts ,(%inline + ,%td ,(%mref ,xp/cp ,(constant continuation-stack-disp)))) (if ,(%inline eq? ,%sfp ,%ts) - ; merge, and we assume that the stack link includes attachments + ; merge, and we assume that the continuation includes attachments ,(%seq (set! ,(%tc-ref scheme-stack-size) ,(%inline + ,%td ,(%tc-ref scheme-stack-size))) (set! ,(%tc-ref scheme-stack) ,(%mref ,xp/cp ,(constant continuation-stack-disp))) (set! ,(%tc-ref stack-link) ,(%mref ,xp/cp ,(constant continuation-link-disp))) (set! ,%ts ,(%mref ,xp/cp ,(constant continuation-attachments-disp))) + (set! ,(%mref ,xp/cp ,(constant continuation-stack-clength-disp)) (immediate 0)) ; in case GC sees it (set! ,(%tc-ref cached-frame) ,xp/cp) ; save for fast immediate realloc (set! ,(%tc-ref attachments) ,%ts) (goto ,Lreturn))