diff --git a/pkgs/racket-test/tests/racket/stress/prompt-mem-use.rkt b/pkgs/racket-test/tests/racket/stress/prompt-mem-use.rkt new file mode 100644 index 0000000000..3d1050289b --- /dev/null +++ b/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))))) diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index a3326c8b3b..f1be9c19fb 100644 --- a/racket/src/racket/src/fun.c +++ b/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)); - - if (!new_thread) { - prompt->is_barrier = 1; - } + initialize_prompt(p, prompt, PROMPT_STACK(prompt), !new_thread); } #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) { - id = scheme_make_pair(scheme_false, scheme_false); - prompt->id = id; - } + init_prompt_id(prompt); 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); diff --git a/racket/src/racket/src/mzmark_type.inc b/racket/src/racket/src/mzmark_type.inc index e619de8b2e..8c9c5c9e62 100644 --- a/racket/src/racket/src/mzmark_type.inc +++ b/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]; - b = (void **)s + 5 + s[3]; + a = (void **)s + RUNSTACK_HEADER_FIELDS + s[2]; + 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; - b = (void **)s + 5 + s[2]; + a = (void **)s + RUNSTACK_HEADER_FIELDS; + b = (void **)s + RUNSTACK_HEADER_FIELDS + s[2]; while (a < b) { *a = RUNSTACK_ZERO_VAL; a++; } - a = (void **)s + 5 + s[3]; - b = (void **)s + 5 + (s[1] - 5); + a = (void **)s + RUNSTACK_HEADER_FIELDS + s[3]; + 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]; - b = (void **)s + 5 + s[3]; + a = (void **)s + RUNSTACK_HEADER_FIELDS + s[2]; + 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()) - gcMARK2(pr->runstack_boundary_start, gc); + if (!GC_merely_accounting()) { + 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()) - gcFIXUP2(pr->runstack_boundary_start, gc); + if (!GC_merely_accounting()) { + 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 diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 49ee37d241..4897d22f3a 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/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]; - b = (void **)s + 5 + s[3]; + a = (void **)s + RUNSTACK_HEADER_FIELDS + s[2]; + 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; - b = (void **)s + 5 + s[2]; + a = (void **)s + RUNSTACK_HEADER_FIELDS; + b = (void **)s + RUNSTACK_HEADER_FIELDS + s[2]; while (a < b) { *a = RUNSTACK_ZERO_VAL; a++; } - a = (void **)s + 5 + s[3]; - b = (void **)s + 5 + (s[1] - 5); + a = (void **)s + RUNSTACK_HEADER_FIELDS + s[3]; + 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()) - gcMARK2(pr->runstack_boundary_start, gc); + if (!GC_merely_accounting()) { + 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: diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index f392b386f3..6295d09717 100644 --- a/racket/src/racket/src/schpriv.h +++ b/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 diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 54b2534b53..efc45fd8a7 100644 --- a/racket/src/racket/src/thread.c +++ b/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;