avoid retaining unneeded runstacks in continuations

While a continuation is set up to avoid retaining runstacks, partly by
storing a prompt ID instead of a prompt record, prompt records can
remain on the C stack and get captured anyway. Mitigate that problem
by making the runstack link weak in some prompt record.

Racket CS doesn't have this problem, of course.

Relevant to jeapostrophe/lux#10

pkgs/racket-test/tests/racket/stress/prompt-mem-use.rkt

@@ -0,0 +1,75 @@
+#lang racket/base
+
+;; Version 1, using DOS
+#;(require dos)
+
+;; Version 2, going direct
+(begin
+  (define 0x80 (make-continuation-prompt-tag 'dos))
+
+  (define (run-process-until-syscall p st)
+    (call-with-continuation-barrier
+     (λ ()
+       (call-with-continuation-prompt
+        (λ () (p st))
+        0x80
+        (λ (x) x)))))
+
+  (define (dos-syscall k->syscall)
+    ;; First we capture our context back to the OS
+    (call-with-current-continuation
+     (λ (k)
+       ;; Then we abort, give it to the OS, along with a syscall
+       ;; specification
+       (abort-current-continuation 0x80 (k->syscall k)))
+     0x80))
+
+  (define USE-OBSCENE-MEMORY? #t)
+  (define (map-reduce f + a l)
+    (if USE-OBSCENE-MEMORY?
+      (cond
+        [(null? l) a]
+        [else
+         (+ (f (car l)) (map-reduce f + a (cdr l)))])
+      (cond
+        [(null? l)
+         a]
+        [(pair? l)
+         (+ (map-reduce f + a (car l))
+            (map-reduce f + a (cdr l)))]
+        [else
+         (f l)])))
+
+  (define USE-LOTS-OF-MEMORY? #t)
+  (define (dos-boot merge-effects last-state ps empty-effects)
+    (if USE-LOTS-OF-MEMORY?
+      (map-reduce (λ (p) (run-process-until-syscall p last-state))
+                  merge-effects
+                  empty-effects
+                  ps)
+      (map (λ (p) (run-process-until-syscall p last-state)) ps))))
+
+(define nothing-threads
+  (for/list ([i (in-range 1900)])
+    (λ (init-st)
+      (let lp ()
+        (dos-syscall (λ (k) k))
+        (lp)))))
+
+;; prevent inlining
+(set! dos-boot dos-boot)
+
+(begin
+  (let lp ([ps nothing-threads] [max-use 0] [n 0] [grow-n 0])
+    (printf "~s ~s ~s\n" max-use n grow-n)
+    (unless (= n 200)
+      (when (= grow-n 25)
+        (error "memory use grew too many times"))
+      (collect-garbage)
+      (define use (current-memory-use))
+      (lp (dos-boot cons #f ps null)
+          (max use max-use)
+          (add1 n)
+          (if (use . > . max-use)
+              (add1 grow-n)
+              grow-n)))))

racket/src/racket/src/fun.c

@@ -996,16 +996,61 @@ int scheme_intern_prim_opt_flags(int flags)
 /*                            prompt helpers                              */
 /*========================================================================*/
 
-static void initialize_prompt(Scheme_Thread *p, Scheme_Prompt *prompt, void *stack_boundary)
+static void initialize_prompt(Scheme_Thread *p, Scheme_Prompt *prompt, void *stack_boundary, int is_barrier)
 {
-  prompt->is_barrier = 0;
+  prompt->is_barrier = is_barrier;
   prompt->stack_boundary = stack_boundary;
-  prompt->runstack_boundary_start = MZ_RUNSTACK_START;
+  if (is_barrier) {
+    /* Avoid leak in case barrier is retained longer than the rest of the stack */
+    Scheme_Object *ref;
+    ref = scheme_make_weak_box((Scheme_Object *)MZ_RUNSTACK_START);
+    prompt->u.runstack_boundary_start_ref = ref;
+    prompt->weak_boundary = 1;
+  } else
+    prompt->u.runstack_boundary_start = MZ_RUNSTACK_START;
   prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START);
   prompt->mark_boundary = MZ_CONT_MARK_STACK;
   prompt->boundary_mark_pos = MZ_CONT_MARK_POS;
 }
 
+Scheme_Object **scheme_prompt_runstack_boundary_start(Scheme_Prompt *p)
+{
+  if (p->weak_boundary)
+    return (Scheme_Object **)(SCHEME_BOX_VAL(p->u.runstack_boundary_start_ref));
+  else
+    return p->u.runstack_boundary_start;
+}
+
+static void init_prompt_id(Scheme_Prompt *prompt)
+{
+  Scheme_Object *id;
+
+  if (!prompt->id) {
+    id = scheme_make_pair(scheme_false, scheme_false);
+    prompt->id = id;
+  }
+}
+
+Scheme_Prompt *make_weak_prompt(Scheme_Prompt *p)
+{
+  Scheme_Prompt *p2;
+  Scheme_Object *ref;
+
+  if (p->weak_boundary)
+    return p;
+
+  init_prompt_id(p);
+
+  p2 = MALLOC_ONE_TAGGED(Scheme_Prompt);
+  memcpy(p2, p, sizeof(Scheme_Prompt));
+
+  ref = scheme_make_weak_box((Scheme_Object *)p2->u.runstack_boundary_start);
+  p2->u.runstack_boundary_start_ref = ref;
+  p2->weak_boundary = 1;
+
+  return p2;
+}
+
 /*========================================================================*/
 /*                         stack-overflow wrapper                         */
 /*========================================================================*/
@@ -1193,11 +1238,7 @@ void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread)
   
   if (eb) {
     prompt = allocate_prompt(&available_prompt);
-    initialize_prompt(p, prompt, PROMPT_STACK(prompt));
+    initialize_prompt(p, prompt, PROMPT_STACK(prompt), !new_thread);
-      
-    if (!new_thread) {
-      prompt->is_barrier = 1;
-    }
   }
 
 #ifdef MZ_PRECISE_GC
@@ -4589,7 +4630,7 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
       size += MAX_CALL_CC_ARG_COUNT;
     else
       size += shared_amt;
-  } else if (effective_prompt && (effective_prompt->runstack_boundary_start == runstack_start)) {
+  } else if (effective_prompt && (scheme_prompt_runstack_boundary_start(effective_prompt) == runstack_start)) {
     /* Copy only up to the prompt */
     size = effective_prompt->runstack_boundary_offset - (runstack XFORM_OK_MINUS runstack_start);
   } else {
@@ -4604,7 +4645,7 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
   memcpy(saved->runstack_start, runstack, size * sizeof(Scheme_Object *));
   saved->runstack_offset = (runstack XFORM_OK_MINUS runstack_start);
 
-  if (!effective_prompt || (effective_prompt->runstack_boundary_start != runstack_start)) {
+  if (!effective_prompt || (scheme_prompt_runstack_boundary_start(effective_prompt) != runstack_start)) {
 
     /* Copy saved runstacks: */
     if (share_from) {
@@ -4630,7 +4671,7 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
       isaved->prev = ss;
       isaved = ss;
 
-      if (effective_prompt && (effective_prompt->runstack_boundary_start == csaved->runstack_start)) {
+      if (effective_prompt && (scheme_prompt_runstack_boundary_start(effective_prompt) == csaved->runstack_start)) {
 	size = effective_prompt->runstack_boundary_offset - csaved->runstack_offset;
 	done = 1;
       } else {
@@ -5071,16 +5112,16 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
         saved = clone_runstack_copied(cnaya->runstack_copied, 
                                       cnaya->runstack_start,
                                       cnaya->runstack_saved, 
-                                      prompt->runstack_boundary_start,
+                                      scheme_prompt_runstack_boundary_start(prompt),
                                       prompt->runstack_boundary_offset);
         cnaya->runstack_copied = saved;
 
         /* Prune unneeded buffers */
-        if (prompt->runstack_boundary_start == cnaya->runstack_start)
+        if (scheme_prompt_runstack_boundary_start(prompt) == cnaya->runstack_start)
           saved = NULL;
         else
           saved = clone_runstack_saved(cnaya->runstack_saved, 
-                                       prompt->runstack_boundary_start,
+                                       scheme_prompt_runstack_boundary_start(prompt),
                                        NULL);
         cnaya->runstack_saved = saved;
 
@@ -5383,16 +5424,12 @@ static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int comp
     cont->meta_continuation = NULL;
   } else if (prompt) {
     Scheme_Meta_Continuation *mc;
-    Scheme_Object *id;
     mc = clone_meta_cont(p->meta_continuation, pt, -1, prompt_cont, prompt, NULL, composable);
     cont->meta_continuation = mc;
     if (!prompt_cont) {
       /* Remember the prompt id, so we can maybe take a shortcut on 
          invocation. (The shortcut only works within a meta-continuation.) */
-      if (!prompt->id) {
+      init_prompt_id(prompt);
-        id = scheme_make_pair(scheme_false, scheme_false);
-        prompt->id = id;
-      }
       cont->prompt_id = prompt->id;
     }
     cont->has_prompt_dw = 1;
@@ -5475,11 +5512,11 @@ static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int comp
          (Note that this is different than runstack_copied; 
           runstack_saved keeps the shared runstack buffers, 
           not the content.) */
-      if (SAME_OBJ(prompt->runstack_boundary_start, MZ_RUNSTACK_START))
+      if (scheme_prompt_runstack_boundary_start(prompt) == MZ_RUNSTACK_START)
         saved = NULL;
       else
         saved = clone_runstack_saved(cont->runstack_saved, 
-                                     prompt->runstack_boundary_start,
+                                     scheme_prompt_runstack_boundary_start(prompt),
                                      NULL);
       cont->runstack_saved = saved;
     }
@@ -5629,11 +5666,11 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
     /* In shortcut mode, we need to preserve saved runstacks
        that were pruned when capturing the continuation. */
     Scheme_Saved_Stack *rs;
-    if (shortcut_prompt->runstack_boundary_start == MZ_RUNSTACK_START)
+    if (scheme_prompt_runstack_boundary_start(shortcut_prompt) == MZ_RUNSTACK_START)
       rs = p->runstack_saved;
     else {
       rs = p->runstack_saved;
-      while (rs && (rs->runstack_start != shortcut_prompt->runstack_boundary_start)) {
+      while (rs && (rs->runstack_start != scheme_prompt_runstack_boundary_start(shortcut_prompt))) {
         rs = rs->prev;
       }
       if (rs)
@@ -5762,10 +5799,10 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
           actual = actual->prev;
       }
       if (actual) {
-        meta_prompt->runstack_boundary_start = actual->runstack_start;
+        meta_prompt->u.runstack_boundary_start = actual->runstack_start;
         meta_prompt->runstack_boundary_offset = actual->runstack_offset + saved->runstack_size;
       } else {
-        meta_prompt->runstack_boundary_start = MZ_RUNSTACK_START;
+        meta_prompt->u.runstack_boundary_start = MZ_RUNSTACK_START;
         meta_prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START) + saved->runstack_size + delta;
         MZ_ASSERT(meta_prompt->runstack_boundary_offset <= scheme_current_thread->runstack_size);
       }
@@ -5935,6 +5972,13 @@ internal_call_cc (int argc, Scheme_Object *argv[])
     return NULL;
   }
 
+  /* This prompt is likely to be on the C stack when we capture it for
+     the continuation, but we only want to retain the prompt's
+     runstack. Convert it to one that has the same ID but holds the
+     runstack weakly. */
+  if (prompt)
+    prompt = make_weak_prompt(prompt);
+
   barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
 
   if (composable && SCHEME_FALSEP(argv[2])) {
@@ -6736,7 +6780,7 @@ static void restore_from_prompt(Scheme_Prompt *prompt)
 {
   Scheme_Thread *p = scheme_current_thread;
 
-  while (MZ_RUNSTACK_START != prompt->runstack_boundary_start) {
+  while (MZ_RUNSTACK_START != scheme_prompt_runstack_boundary_start(prompt)) {
     MZ_RUNSTACK_START = p->runstack_saved->runstack_start;
     p->runstack_saved = p->runstack_saved->prev;
   }
@@ -7029,7 +7073,7 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
 
     ASSERT_SUSPEND_BREAK_ZERO();
 
-    initialize_prompt(p, prompt, NULL);
+    initialize_prompt(p, prompt, NULL, 0);
 
     if (p->overflow) {
       ensure_overflow_id(p->overflow);

racket/src/racket/src/mzmark_type.inc

@@ -2857,8 +2857,8 @@ static int runstack_val_MARK(void *p, struct NewGC *gc) {
 #ifndef GC_NO_MARK_PROCEDURE_NEEDED
   intptr_t *s = (intptr_t *)p;
   void **a, **b;
-  a = (void **)s + 5 + s[2];
+  a = (void **)s + RUNSTACK_HEADER_FIELDS + s[2];
-  b = (void **)s + 5 + s[3];
+  b = (void **)s + RUNSTACK_HEADER_FIELDS + s[3];
   while (a < b) {
     gcMARK2(*a, gc);
     a++;
@@ -2866,14 +2866,14 @@ static int runstack_val_MARK(void *p, struct NewGC *gc) {
 
   /* Zero out the part that we didn't mark, in case it becomes
      live later. */
-  a = (void **)s + 5;
+  a = (void **)s + RUNSTACK_HEADER_FIELDS;
-  b = (void **)s + 5 + s[2];
+  b = (void **)s + RUNSTACK_HEADER_FIELDS + s[2];
   while (a < b) {
     *a = RUNSTACK_ZERO_VAL;
     a++;
   }
-  a = (void **)s + 5 + s[3];
+  a = (void **)s + RUNSTACK_HEADER_FIELDS + s[3];
-  b = (void **)s + 5 + (s[1] - 5);
+  b = (void **)s + RUNSTACK_HEADER_FIELDS + (s[1] - RUNSTACK_HEADER_FIELDS);
   while (a < b) {
     *a = RUNSTACK_ZERO_VAL;
     a++;
@@ -2892,8 +2892,8 @@ static int runstack_val_FIXUP(void *p, struct NewGC *gc) {
 #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
   intptr_t *s = (intptr_t *)p;
   void **a, **b;
-  a = (void **)s + 5 + s[2];
+  a = (void **)s + RUNSTACK_HEADER_FIELDS + s[2];
-  b = (void **)s + 5 + s[3];
+  b = (void **)s + RUNSTACK_HEADER_FIELDS + s[3];
   while (a < b) {
     gcFIXUP2(*a, gc);
     a++;
@@ -2925,8 +2925,12 @@ static int prompt_val_MARK(void *p, struct NewGC *gc) {
 #ifndef GC_NO_MARK_PROCEDURE_NEEDED
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcMARK2(pr->boundary_overflow_id, gc);
-  if (!GC_merely_accounting())
+  if (!GC_merely_accounting()) {
-    gcMARK2(pr->runstack_boundary_start, gc);
+    if (pr->is_barrier)
+      gcMARK2(pr->u.runstack_boundary_start_ref, gc);
+    else
+      gcMARK2(pr->u.runstack_boundary_start, gc);
+  }
   gcMARK2(pr->tag, gc);
   gcMARK2(pr->id, gc);
 # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
@@ -2942,8 +2946,12 @@ static int prompt_val_FIXUP(void *p, struct NewGC *gc) {
 #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcFIXUP2(pr->boundary_overflow_id, gc);
-  if (!GC_merely_accounting())
+  if (!GC_merely_accounting()) {
-    gcFIXUP2(pr->runstack_boundary_start, gc);
+    if (pr->is_barrier)
+      gcFIXUP2(pr->u.runstack_boundary_start_ref, gc);
+    else
+      gcFIXUP2(pr->u.runstack_boundary_start, gc);
+  }
   gcFIXUP2(pr->tag, gc);
   gcFIXUP2(pr->id, gc);
 # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS

racket/src/racket/src/mzmarksrc.c

@@ -810,8 +810,8 @@ runstack_val {
   intptr_t *s = (intptr_t *)p;
  mark:
   void **a, **b;
-  a = (void **)s + 5 + s[2];
+  a = (void **)s + RUNSTACK_HEADER_FIELDS + s[2];
-  b = (void **)s + 5 + s[3];
+  b = (void **)s + RUNSTACK_HEADER_FIELDS + s[3];
   while (a < b) {
     gcMARK2(*a, gc);
     a++;
@@ -820,14 +820,14 @@ runstack_val {
   START_MARK_ONLY;
   /* Zero out the part that we didn't mark, in case it becomes
      live later. */
-  a = (void **)s + 5;
+  a = (void **)s + RUNSTACK_HEADER_FIELDS;
-  b = (void **)s + 5 + s[2];
+  b = (void **)s + RUNSTACK_HEADER_FIELDS + s[2];
   while (a < b) {
     *a = RUNSTACK_ZERO_VAL;
     a++;
   }
-  a = (void **)s + 5 + s[3];
+  a = (void **)s + RUNSTACK_HEADER_FIELDS + s[3];
-  b = (void **)s + 5 + (s[1] - 5);
+  b = (void **)s + RUNSTACK_HEADER_FIELDS + (s[1] - RUNSTACK_HEADER_FIELDS);
   while (a < b) {
     *a = RUNSTACK_ZERO_VAL;
     a++;
@@ -842,8 +842,12 @@ prompt_val {
  mark: 
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcMARK2(pr->boundary_overflow_id, gc);
-  if (!GC_merely_accounting())
+  if (!GC_merely_accounting()) {
-    gcMARK2(pr->runstack_boundary_start, gc);
+    if (pr->is_barrier)
+      gcMARK2(pr->u.runstack_boundary_start_ref, gc);
+    else
+      gcMARK2(pr->u.runstack_boundary_start, gc);
+  }
   gcMARK2(pr->tag, gc);
   gcMARK2(pr->id, gc);
  size:

racket/src/racket/src/schpriv.h

@@ -736,6 +736,10 @@ THREAD_LOCAL_DECL(extern MZ_MARK_POS_TYPE scheme_current_cont_mark_pos);
 # define MZ_CONT_MARK_POS (scheme_current_thread->cont_mark_pos)
 #endif
 
+#ifdef MZ_PRECISE_GC
+# define RUNSTACK_HEADER_FIELDS 5
+#endif
+
 THREAD_LOCAL_DECL(extern volatile int scheme_fuel_counter);
 
 THREAD_LOCAL_DECL(extern Scheme_Thread *scheme_main_thread);
@@ -1977,19 +1981,24 @@ typedef struct Scheme_Meta_Continuation {
 
 typedef struct Scheme_Prompt {
   Scheme_Object so;
-  char is_barrier, has_chaperone;
+  char is_barrier, has_chaperone, weak_boundary;
   Scheme_Object *tag;
   Scheme_Object *id;                  /* created as needed; allows direct-jump optimization for cont app */
   void *stack_boundary;               /* where to stop copying the C stack */
   void *boundary_overflow_id;         /* indicates the C stack segment */
   MZ_MARK_STACK_TYPE mark_boundary;   /* where to stop copying cont marks */
   MZ_MARK_POS_TYPE boundary_mark_pos; /* mark position of prompt */
-  Scheme_Object **runstack_boundary_start; /* which stack has runstack_boundary */
+  union {
+    Scheme_Object **runstack_boundary_start;    /* which stack has runstack_boundary */
+    Scheme_Object *runstack_boundary_start_ref; /* weak-ref variant, used when `weak_boundary` */
+  } u;
   intptr_t runstack_boundary_offset;      /* where to stop copying the Scheme stack */
   mz_jmp_buf *prompt_buf;             /* to jump directly to the prompt */
   intptr_t runstack_size;                 /* needed for restore */
 } Scheme_Prompt;
 
+XFORM_NONGCING Scheme_Object **scheme_prompt_runstack_boundary_start(Scheme_Prompt *p);
+
 /* Compiler helper: */
 #define ESCAPED_BEFORE_HERE  return NULL
 

racket/src/racket/src/thread.c

@@ -2740,7 +2740,7 @@ Scheme_Object **scheme_alloc_runstack(intptr_t len)
 #ifdef MZ_PRECISE_GC
   intptr_t sz;
   void **p;
-  sz = sizeof(Scheme_Object*) * (len + 5);
+  sz = sizeof(Scheme_Object*) * (len + RUNSTACK_HEADER_FIELDS);
   p = (void **)GC_malloc_tagged_allow_interior(sz);
   *(Scheme_Type *)(void *)p = scheme_rt_runstack;
   ((intptr_t *)(void *)p)[1] = gcBYTES_TO_WORDS(sz);
@@ -2748,7 +2748,7 @@ Scheme_Object **scheme_alloc_runstack(intptr_t len)
   ((intptr_t *)(void *)p)[3] = len;
 # define MZ_RUNSTACK_OVERFLOW_CANARY 0xFF77FF77
   ((intptr_t *)(void *)p)[4] = MZ_RUNSTACK_OVERFLOW_CANARY;
-  return (Scheme_Object **)(p + 5);
+  return (Scheme_Object **)(p + RUNSTACK_HEADER_FIELDS);
 #else
   return (Scheme_Object **)scheme_malloc_allow_interior(sizeof(Scheme_Object*) * len);
 #endif
@@ -9093,7 +9093,7 @@ static void prepare_thread_for_GC(Scheme_Object *t)
       Scheme_Object **rs_start;
 
       /* If there's a meta-prompt, we can also zero out past the unused part */
-      if (p->meta_prompt && (p->meta_prompt->runstack_boundary_start == p->runstack_start)) {
+      if (p->meta_prompt && (scheme_prompt_runstack_boundary_start(p->meta_prompt) == p->runstack_start)) {
         rs_end = p->meta_prompt->runstack_boundary_offset;
       } else {
         rs_end = p->runstack_size;
@@ -9115,7 +9115,7 @@ static void prepare_thread_for_GC(Scheme_Object *t)
       for (saved = p->runstack_saved; saved; saved = saved->prev) {
 	RUNSTACK_TUNE( size += saved->runstack_size; );
 
-        if (p->meta_prompt && (p->meta_prompt->runstack_boundary_start == saved->runstack_start)) {
+        if (p->meta_prompt && (scheme_prompt_runstack_boundary_start(p->meta_prompt) == saved->runstack_start)) {
           rs_end = p->meta_prompt->runstack_boundary_offset;
         } else {
           rs_end = saved->runstack_size;