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

@@ -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"))
+
+

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

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) {
+  if (i != -1) {
-    scope_set_index(props, i, &key, &val);
+    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);
+      o = stx_adjust_scope(o, key, phase, SCHEME_INT_VAL(val) | flag, mutate);
-    
+
-    i = scope_set_next(props, i);
+      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;
 }