From 5c2a9b2aaa2a7948c8ecd128d29e32cf2d7656bc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 5 Jul 2011 16:09:01 -0600 Subject: [PATCH] improve a syntax-object resolution cache --- src/racket/include/schthread.h | 4 +++ src/racket/src/compile.c | 17 +++++++-- src/racket/src/syntax.c | 65 +++++++++++++++++++++++++--------- 3 files changed, 67 insertions(+), 19 deletions(-) diff --git a/src/racket/include/schthread.h b/src/racket/include/schthread.h index dbbb1a1e51..e1f1a23ace 100644 --- a/src/racket/include/schthread.h +++ b/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_) diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index 24fa1364c0..b72124fb4f 100644 --- a/src/racket/src/compile.c +++ b/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"), - scheme_false, scheme_sys_wraps(env), 0, 0); + if (!cwv_stx || (env->genv->phase != cwv_stx_phase)) { + 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); diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index cd701516bf..887af427fe 100644 --- a/src/racket/src/syntax.c +++ b/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 - && SAME_OBJ(phase, scheme_make_integer(0)) - && ((Scheme_Stx *)a)->u.modinfo_cache) - return ((Scheme_Stx *)a)->u.modinfo_cache; + result = ((Scheme_Stx *)a)->u.modinfo_cache; + if (result && SAME_OBJ(phase, scheme_make_integer(0))) + return result; 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;