improve a syntax-object resolution cache

src/racket/include/schthread.h

@@ -151,6 +151,8 @@ typedef struct Thread_Local_Variables {
   struct Scheme_Object *cached_ds_stx_;
   struct Scheme_Object *cached_dvs_stx_;
   int cached_stx_phase_;
+  struct Scheme_Object *cwv_stx_;
+  int cwv_stx_phase_;
   struct Scheme_Cont *offstack_cont_;
   struct Scheme_Overflow *offstack_overflow_;
   struct Scheme_Overflow_Jmp *scheme_overflow_jmp_;
@@ -484,6 +486,8 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define cached_ds_stx XOA (scheme_get_thread_local_variables()->cached_ds_stx_)
 #define cached_dvs_stx XOA (scheme_get_thread_local_variables()->cached_dvs_stx_)
 #define cached_stx_phase XOA (scheme_get_thread_local_variables()->cached_stx_phase_)
+#define cwv_stx XOA (scheme_get_thread_local_variables()->cwv_stx_)
+#define cwv_stx_phase XOA (scheme_get_thread_local_variables()->cwv_stx_phase_)
 #define offstack_cont XOA (scheme_get_thread_local_variables()->offstack_cont_)
 #define offstack_overflow XOA (scheme_get_thread_local_variables()->offstack_overflow_)
 #define scheme_overflow_jmp XOA (scheme_get_thread_local_variables()->scheme_overflow_jmp_)

src/racket/src/compile.c

@@ -61,9 +61,13 @@ ROSYM static Scheme_Object *protected_symbol;
 ROSYM static Scheme_Object *quote_symbol;
 ROSYM static Scheme_Object *letrec_syntaxes_symbol;
 ROSYM static Scheme_Object *values_symbol;
+ROSYM static Scheme_Object *call_with_values_symbol;
 
 THREAD_LOCAL_DECL(static Scheme_Object *quick_stx);
 
+THREAD_LOCAL_DECL(struct Scheme_Object *cwv_stx);
+THREAD_LOCAL_DECL(int cwv_stx_phase);
+
 /* locals */
 static Scheme_Object *lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
 static Scheme_Object *lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
@@ -285,6 +289,7 @@ void scheme_init_compile (Scheme_Env *env)
   REGISTER_SO(quote_symbol);
   REGISTER_SO(letrec_syntaxes_symbol);
   REGISTER_SO(values_symbol);
+  REGISTER_SO(call_with_values_symbol);
 
   app_symbol    = scheme_intern_symbol("#%app");
   datum_symbol  = scheme_intern_symbol("#%datum");
@@ -293,6 +298,7 @@ void scheme_init_compile (Scheme_Env *env)
   quote_symbol  = scheme_intern_symbol("quote");
   letrec_syntaxes_symbol = scheme_intern_symbol("letrec-syntaxes+values");
   values_symbol = scheme_intern_symbol("values");
+  call_with_values_symbol = scheme_intern_symbol("call-with-values");
 
   REGISTER_SO(app_expander);
   REGISTER_SO(datum_expander);
@@ -313,6 +319,7 @@ void scheme_init_compile (Scheme_Env *env)
 void scheme_init_compile_places()
 {
   REGISTER_SO(quick_stx);
+  REGISTER_SO(cwv_stx);
 }
 
 Scheme_Object *
@@ -4377,7 +4384,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env,
 
     /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */ 
     if (SCHEME_STX_SYMBOLP(name)) {
-      Scheme_Object *at_first, *at_second, *the_end, *cwv_stx;
+      Scheme_Object *at_first, *at_second, *the_end;
       at_first = SCHEME_STX_CDR(form);
       if (SCHEME_STX_PAIRP(at_first)) {
         at_second = SCHEME_STX_CDR(at_first);
@@ -4386,8 +4393,12 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env,
           if (SCHEME_STX_NULLP(the_end)) {
             Scheme_Object *orig_at_second = at_second;
 
-            cwv_stx = scheme_datum_to_syntax(scheme_intern_symbol("call-with-values"), 
+            if (!cwv_stx || (env->genv->phase != cwv_stx_phase)) {
-                                             scheme_false, scheme_sys_wraps(env), 0, 0);
+              cwv_stx_phase = env->genv->phase;
+              cwv_stx = scheme_datum_to_syntax(call_with_values_symbol, 
+                                               scheme_false, scheme_sys_wraps(env), 0, 0);
+            }
+
             if (scheme_stx_module_eq(name, cwv_stx, 0)) {
               Scheme_Object *first, *orig_first;
               orig_first = SCHEME_STX_CAR(at_first);

src/racket/src/syntax.c

@@ -1758,7 +1758,9 @@ Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn,
 
   if (((Module_Renames *)mrn)->needs_unmarshal) {
     ((Module_Renames *)nmrn)->needs_unmarshal = 1;
-  }  
+  }
+
+  ((Module_Renames *)nmrn)->sealed = ((Module_Renames *)mrn)->sealed;
 
   return nmrn;
 }
@@ -1772,6 +1774,7 @@ Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *_mrns,
   int i;
 
   mrns2 = scheme_make_module_rename_set(mrns->kind, NULL, new_insp);
+  ((Module_Renames_Set *)mrns2)->sealed = mrns->sealed;
   if (mrns->rt) {
     mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->rt, old_midx, new_midx, new_insp);
     scheme_add_module_rename_to_set(mrns2, mrn);
@@ -4218,14 +4221,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
   WRAP_POS wraps;
   Scheme_Object *result, *result_from;
   int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0;
-  int no_lexical = !free_id_recur;
+  int no_lexical = !free_id_recur, unsealed_reason = 0;
   Scheme_Object *phase = orig_phase;
   Scheme_Object *bdg = NULL, *floating = NULL;
 
-  if (!free_id_recur
+  result = ((Scheme_Stx *)a)->u.modinfo_cache;
-      && SAME_OBJ(phase, scheme_make_integer(0))
+  if (result && SAME_OBJ(phase, scheme_make_integer(0)))
-      && ((Scheme_Stx *)a)->u.modinfo_cache)
+    return result;
-    return ((Scheme_Stx *)a)->u.modinfo_cache;
 
   WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps);
 
@@ -4238,10 +4240,19 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
       if (result)
         can_cache = (sealed >= STX_SEAL_BOUND); /* If it becomes bound, it can't become unbound. */
 
+      if (free_id_recur && free_id_recur->count)
+        can_cache = 0;
+
       if (!result)
 	result = SCHEME_STX_VAL(a);
-      
+
-      if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur)
+#if 0
+      printf("%p %p %s (%d) %d %p %d\n", 
+             a, orig_phase, SCHEME_SYMBOLP(result) ? SCHEME_SYM_VAL(result) : "!?", 
+             can_cache, sealed, free_id_recur, unsealed_reason);
+#endif 
+
+      if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)))
         ((Scheme_Stx *)a)->u.modinfo_cache = result;
  
       return result;
@@ -4260,8 +4271,10 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
         
         if ((!is_in_module || (mrns->kind != mzMOD_RENAME_TOPLEVEL))
             && !skip_other_mods) {
-          if (mrns->sealed < sealed)
+          if (mrns->sealed < sealed) {
             sealed = mrns->sealed;
+            unsealed_reason = 2;
+          }
         }
 
         mrn = extract_renames(mrns, phase);
@@ -4276,8 +4289,10 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
 	  /* Module rename: */
 	  Scheme_Object *rename, *glob_id;
 
-          if (mrn->sealed < sealed)
+          if (mrn->sealed < sealed) {
             sealed = mrn->sealed;
+            unsealed_reason = 3;
+          }
           
 	  if (mrn->needs_unmarshal) {
 	    /* Use resolve_env to trigger unmarshal, so that we
@@ -4310,14 +4325,16 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
           if (free_id_recur && mrn->free_id_renames) {
             rename = scheme_hash_get(mrn->free_id_renames, glob_id);
             if (rename && SCHEME_STXP(rename)) {
-              int sealed;
+              int sd;
               rename = extract_module_free_id_binding((Scheme_Object *)mrn,
                                                       glob_id, 
                                                       rename,
-                                                      &sealed,
+                                                      &sd,
                                                       free_id_recur);
-              if (!sealed)
+              if (!sd) {
                 sealed = 0;
+                unsealed_reason = 4;
+              }
             }
           } else
             rename = NULL;
@@ -4386,7 +4403,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
 
       do {
         if (rib) {
-          if (!*rib->sealed) sealed = 0;
+          if (!*rib->sealed) { sealed = 0; unsealed_reason = 1; }
           rename = rib->rename;
           rib = rib->next;
         }
@@ -4434,8 +4451,10 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
                 names[6] = NULL;
 
                 modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur);
-                if (rib_dep)
+                if (rib_dep) {
                   sealed = 0;
+                  unsealed_reason = 5;
+                }
 
                 if (!SCHEME_FALSEP(modname)
                     && !SAME_OBJ(names[0], scheme_undefined)) {
@@ -7306,6 +7325,20 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
   return result;
 }
 
+static int quick_check_graph(Scheme_Object *o, int fuel)
+{
+  if (!fuel) return 0;
+
+  if (SCHEME_PAIRP(o))
+    return quick_check_graph(SCHEME_CDR(o),
+                             quick_check_graph(SCHEME_CAR(o), fuel - 1));
+
+  if (HAS_CHAPERONE_SUBSTX(o))
+    return 0;
+  else
+    return fuel;
+}
+
 static Scheme_Object *general_datum_to_syntax(Scheme_Object *o, 
                                               Scheme_Unmarshal_Tables *ut,
                                               Scheme_Object *stx_src,
@@ -7325,7 +7358,7 @@ static Scheme_Object *general_datum_to_syntax(Scheme_Object *o,
   if (SCHEME_STXP(o))
     return o;
 
-  if (can_graph && HAS_CHAPERONE_SUBSTX(o))
+  if (can_graph && !quick_check_graph(o, 10))
     ht = scheme_make_hash_table(SCHEME_hash_ptr);
   else
     ht = NULL;