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

@@ -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));

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();
 }
 

c/schsig.c

@@ -18,7 +18,6 @@
 #include <setjmp.h>
 
 /* 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);

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:

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))