From 3eb2c20ad026706fa3f16eea0c11ac2874ce44fc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 23 Oct 2015 15:36:57 -0600 Subject: [PATCH] avoid excessive memory use in `or` expansion When `or` has many subexpressions, the expansion generates a sequence of deeply nested `let`s, where original and macro-introduced forms are interleaved in a way that defeats a minimal child-is-same-as-parent sharing of scope sets. Add a small cache that's good enough to capture extra sharing and dramatically lower memory use for an `or` that has 1000 subexpressions. --- pkgs/racket-test/tests/racket/stress/or.rkt | 34 ++++++++++++ racket/src/racket/include/schthread.h | 7 +++ racket/src/racket/src/syntax.c | 59 ++++++++++++++++++--- 3 files changed, 93 insertions(+), 7 deletions(-) create mode 100644 pkgs/racket-test/tests/racket/stress/or.rkt diff --git a/pkgs/racket-test/tests/racket/stress/or.rkt b/pkgs/racket-test/tests/racket/stress/or.rkt new file mode 100644 index 0000000000..bb851d156f --- /dev/null +++ b/pkgs/racket-test/tests/racket/stress/or.rkt @@ -0,0 +1,34 @@ +#lang racket/base + +;; Ensure that `or` with lots of arguments doesn't +;; use excessive memory to expand --- which can happen +;; if there's not enough sharing of scope sets, for +;; example. + +(define ns (make-base-namespace)) + +(define c (make-custodian)) +(custodian-limit-memory c (* 500 1024 1024)) + +(define done? #f) + +(thread-wait + (parameterize ([current-namespace ns] + [current-custodian c]) + (thread + (lambda () + (namespace-require '(for-syntax racket/base)) + (eval + '(define-syntax (m stx) + (syntax-case stx () + [(_ id) + #`(define (id x) + (or #,@(for/list ([i 1000]) + #`(= x #,i))))]))) + (eval '(m f)) + (set! done? #t))))) + +(unless done? + (error "failed")) + + diff --git a/racket/src/racket/include/schthread.h b/racket/src/racket/include/schthread.h index 2ff040cc54..e614cf1842 100644 --- a/racket/src/racket/include/schthread.h +++ b/racket/src/racket/include/schthread.h @@ -96,6 +96,9 @@ MZ_EXTERN void scheme_init_os_thread(void); #define STACK_CACHE_SIZE 32 #define NUM_MORE_CONSTANT_STXES 24 + /* The number of cached scope sets should be a power of 2: */ +#define NUM_RECENT_SCOPE_SETS 8 + /* This structure must be 4 words: */ typedef struct { void *orig_return_address; @@ -243,6 +246,8 @@ typedef struct Thread_Local_Variables { struct Binding_Cache_Entry *binding_cache_table_; intptr_t binding_cache_pos_; intptr_t binding_cache_len_; + struct Scheme_Scope_Set *recent_scope_sets_[2][NUM_RECENT_SCOPE_SETS]; + int recent_scope_sets_pos_[2]; struct Scheme_Thread *scheme_current_thread_; struct Scheme_Thread *scheme_main_thread_; struct Scheme_Thread *scheme_first_thread_; @@ -636,6 +641,8 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define binding_cache_table XOA (scheme_get_thread_local_variables()->binding_cache_table_) #define binding_cache_pos XOA (scheme_get_thread_local_variables()->binding_cache_pos_) #define binding_cache_len XOA (scheme_get_thread_local_variables()->binding_cache_len_) +#define recent_scope_sets XOA (scheme_get_thread_local_variables()->recent_scope_sets_) +#define recent_scope_sets_pos XOA (scheme_get_thread_local_variables()->recent_scope_sets_pos_) #define scheme_current_thread XOA (scheme_get_thread_local_variables()->scheme_current_thread_) #define scheme_main_thread XOA (scheme_get_thread_local_variables()->scheme_main_thread_) #define scheme_first_thread XOA (scheme_get_thread_local_variables()->scheme_first_thread_) diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index bcc5f263f4..62c5a8b0cb 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -101,6 +101,8 @@ THREAD_LOCAL_DECL(static Scheme_Bucket_Table *taint_intern_table); THREAD_LOCAL_DECL(static struct Binding_Cache_Entry *binding_cache_table); THREAD_LOCAL_DECL(static intptr_t binding_cache_pos); THREAD_LOCAL_DECL(static intptr_t binding_cache_len); +THREAD_LOCAL_DECL(static Scheme_Scope_Set *recent_scope_sets[2][NUM_RECENT_SCOPE_SETS]); +THREAD_LOCAL_DECL(static int recent_scope_sets_pos[2]); static Scheme_Object *syntax_p(int argc, Scheme_Object **argv); @@ -1677,6 +1679,13 @@ Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, void scheme_clear_shift_cache(void) { + int i; + + for (i = 0; i < NUM_RECENT_SCOPE_SETS; i++) { + recent_scope_sets[0][i] = NULL; + recent_scope_sets[1][i] = NULL; + } + last_phase_shift = NULL; nominal_ipair_cache = NULL; clear_binding_cache(); @@ -1782,6 +1791,35 @@ int stx_shorts, stx_meds, stx_longs, stx_couldas; # define COUNT_PROPAGATES(x) /* empty */ #endif +static void intern_scope_set(Scheme_Scope_Table *t, int prop_table) +/* We don't realy intern, but approximate interning by checking + against a small set of recently allocated scope sets. That's good + enough to find sharing for a deeply nested sequence of `let`s from + a many-argument `or`, for example, where the interleaving of + original an macro-introduced syntax prevents the usual + child-is-same-as-parent sharing detecting from working well + enough. */ +{ + int i; + + if (!t->simple_scopes || !scope_set_count(t->simple_scopes)) + return; + + for (i = 0; i < NUM_RECENT_SCOPE_SETS; i++) { + if (recent_scope_sets[prop_table][i]) { + if (recent_scope_sets[prop_table][i] == t->simple_scopes) + return; + if (scopes_equal(recent_scope_sets[prop_table][i], t->simple_scopes)) { + t->simple_scopes = recent_scope_sets[prop_table][i]; + } + } + } + + recent_scope_sets[prop_table][recent_scope_sets_pos[prop_table]] = t->simple_scopes; + + recent_scope_sets_pos[prop_table] = ((recent_scope_sets_pos[prop_table] + 1) & (NUM_RECENT_SCOPE_SETS - 1)); +} + static Scheme_Object *propagate_scope_set(Scheme_Scope_Set *props, Scheme_Object *o, Scheme_Object *phase, int flag, GC_CAN_IGNORE int *mutate) @@ -1790,15 +1828,22 @@ static Scheme_Object *propagate_scope_set(Scheme_Scope_Set *props, Scheme_Object Scheme_Object *key, *val; i = scope_set_next(props, -1); - while (i != -1) { - scope_set_index(props, i, &key, &val); + if (i != -1) { + do { + scope_set_index(props, i, &key, &val); - STX_ASSERT(!SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)key)); + STX_ASSERT(!SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)key)); - o = stx_adjust_scope(o, key, phase, SCHEME_INT_VAL(val) | flag, mutate); - - i = scope_set_next(props, i); - } + o = stx_adjust_scope(o, key, phase, SCHEME_INT_VAL(val) | flag, mutate); + + i = scope_set_next(props, i); + } while (i != -1); + + intern_scope_set(((Scheme_Stx *)o)->scopes, 0); + if (STX_KEY(((Scheme_Stx *)o)) & STX_SUBSTX_FLAG + && ((Scheme_Stx *)o)->u.to_propagate) + intern_scope_set(((Scheme_Stx *)o)->u.to_propagate, 1); + } return o; }