From 1394f0eb7db188b5726540b0bfb660467d586604 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Jul 2012 10:57:12 -0500 Subject: [PATCH] macro-expander fix The "simpliciation" of a syntax object's lexical context was dropping module contexts that have no bindings, but those contexts now contribute to the identifty of some bindings. Fix simplification to replace the full rename rename with a simplified one, instead of just dropping it. Merge to v5.3 (cherry picked from commit 73e07f576b682c7c418df414f1a7e92f7c2b132d) --- src/racket/src/module.c | 5 +- src/racket/src/schpriv.h | 3 +- src/racket/src/syntax.c | 280 ++++++++++++++++++++++++++------------- 3 files changed, 195 insertions(+), 93 deletions(-) diff --git a/src/racket/src/module.c b/src/racket/src/module.c index ab25f42cee..f4a078519a 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -576,7 +576,7 @@ void scheme_finish_kernel(Scheme_Env *env) /* Since this is the first module rename, it's registered as the kernel module rename: */ - rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL, NULL); + rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL, NULL, NULL); for (i = kernel->me->rt->num_provides; i--; ) { scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], 0, scheme_make_integer(0), NULL, 0); @@ -760,7 +760,7 @@ static Scheme_Object *scheme_sys_wraps_phase_worker(intptr_t p) { Scheme_Object *rn, *w; - rn = scheme_make_module_rename(scheme_make_integer(p), mzMOD_RENAME_NORMAL, NULL, NULL); + rn = scheme_make_module_rename(scheme_make_integer(p), mzMOD_RENAME_NORMAL, NULL, NULL, NULL); /* Add a module mapping for all kernel provides: */ scheme_extend_module_rename_with_shared(rn, kernel_modidx, @@ -835,6 +835,7 @@ void scheme_save_initial_module_set(Scheme_Env *env) initial_renames = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL, + NULL, NULL); scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); scheme_append_module_rename(scheme_get_module_rename_from_set(env->rename_set, diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index a9945f6125..12524ae011 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -1013,7 +1013,8 @@ void scheme_seal_module_rename_set(Scheme_Object *rns, int level); #define STX_SEAL_BOUND 1 #define STX_SEAL_ALL 2 -Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *mns, Scheme_Object *insp); +Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *mns, + Scheme_Object *insp, Scheme_Object *set_identity); Scheme_Object* scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname, Scheme_Object *locname, Scheme_Object *exname, Scheme_Object *nominal_src, Scheme_Object *nominal_ex, diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 30ec85e160..67a1b55d84 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -1253,7 +1253,8 @@ Scheme_Object *scheme_get_module_rename_from_set(Scheme_Object *set, Scheme_Obje else marked_names = NULL; - mrn = (Module_Renames *)scheme_make_module_rename(phase, mrns->kind, marked_names, mrns->insp); + mrn = (Module_Renames *)scheme_make_module_rename(phase, mrns->kind, marked_names, mrns->insp, + mrns->set_identity); scheme_add_module_rename_to_set(set, (Scheme_Object *)mrn); } @@ -1283,13 +1284,13 @@ Scheme_Hash_Table *scheme_get_module_rename_marked_names(Scheme_Object *set, Sch } Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *marked_names, - Scheme_Object *insp) + Scheme_Object *insp, Scheme_Object *set_identity) { Module_Renames *mr; Scheme_Hash_Table *ht; - Scheme_Object *mk; - mk = scheme_new_mark(); + if (!set_identity) + set_identity = scheme_new_mark(); mr = MALLOC_ONE_TAGGED(Module_Renames); mr->so.type = scheme_rename_table_type; @@ -1299,7 +1300,7 @@ Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_ mr->ht = ht; mr->phase = phase; mr->kind = kind; - mr->set_identity = mk; + mr->set_identity = set_identity; mr->marked_names = marked_names; mr->shared_pes = scheme_null; mr->unmarshal_info = scheme_null; @@ -1316,7 +1317,7 @@ void scheme_seal_module_rename(Scheme_Object *rn, int level) void scheme_seal_module_rename_set(Scheme_Object *_rns, int level) { Module_Renames_Set *rns = (Module_Renames_Set *)_rns; - + rns->sealed = level; if (rns->rt) rns->rt->sealed = level; @@ -1711,8 +1712,10 @@ Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx) scheme_signal_error("can't convert syntax to rename (two sets)"); rns = v; } else if (SCHEME_RENAMESP(v)) { - if (!rns) + if (!rns) { rns = scheme_make_module_rename_set(((Module_Renames *)v)->kind, NULL, NULL); + ((Module_Renames_Set *)rns)->set_identity = ((Module_Renames *)v)->set_identity; + } scheme_add_module_rename_to_set(rns, v); } else { scheme_signal_error("can't convert syntax to rename (non-rename in wrap)"); @@ -1734,7 +1737,8 @@ Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, nmrn = scheme_make_module_rename(((Module_Renames *)mrn)->phase, mzMOD_RENAME_NORMAL, - NULL, new_insp); + NULL, new_insp, + ((Module_Renames *)mrn)->set_identity); /* use "append" to copy most info: */ do_append_module_rename(mrn, nmrn, old_midx, new_midx, 0, 0); @@ -3060,11 +3064,11 @@ static Scheme_Object *get_old_module_env(Scheme_Object *stx) Scheme_Object *result_id = scheme_false, *last_pr = NULL, *pr; WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - + while (!WRAP_POS_END_P(awl)) { a = WRAP_POS_FIRST(awl); - + if (SCHEME_RENAMESP(a) || SCHEME_RENAMES_SETP(a)) { int kind; @@ -3119,8 +3123,9 @@ static Scheme_Object *get_old_module_env(Scheme_Object *stx) #define EXPLAIN_RESOLVE 0 #if EXPLAIN_RESOLVE -int scheme_explain_resolves = 1; +int scheme_explain_resolves = 0; # define EXPLAIN(x) if (scheme_explain_resolves) { x; } +# define EXPLAIN_FOR_ID "..." #else # define EXPLAIN(x) /* empty */ #endif @@ -3737,6 +3742,11 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, int mresult_skipped = -1; int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0; +#ifdef EXPLAIN_FOR_ID + if (!strcmp(EXPLAIN_FOR_ID, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))) + scheme_explain_resolves++; +#endif + EXPLAIN(fprintf(stderr, "%d Resolving %s@%d [skips: %s]: -------------\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), SCHEME_INT_VAL(orig_phase), scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); @@ -3877,6 +3887,10 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, EXPLAIN(fprintf(stderr, "%d phase %s\n", depth, scheme_write_to_string(get_names[3], NULL))); } +#ifdef EXPLAIN_FOR_ID + if (!strcmp(EXPLAIN_FOR_ID, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))) + --scheme_explain_resolves; +#endif return result; } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) @@ -4355,6 +4369,10 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, /* Doesn't match pruned-to sym; already produce #f */ if (_depends_on_unsealed_rib) *_depends_on_unsealed_rib = depends_on_unsealed_rib; +#ifdef EXPLAIN_FOR_ID + if (!strcmp(EXPLAIN_FOR_ID, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))) + --scheme_explain_resolves; +#endif return scheme_false; } } @@ -5941,6 +5959,86 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab return v2l; } +static Scheme_Object *add_rename_to_stack(Module_Renames* mrn, Scheme_Object *stack, + Scheme_Marshal_Tables *mt, + Scheme_Object *a) +{ + Scheme_Object *local_key; + + local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn); + if (!local_key) { + /* Convert hash table to vector, etc.: */ + int i, j, count = 0; + Scheme_Hash_Table *ht; + Scheme_Object *l, *fil; + + ht = mrn->ht; + count = ht->count; + l = scheme_make_vector(count * 2, NULL); + for (i = ht->size, j = 0; i--; ) { + if (ht->vals[i]) { + SCHEME_VEC_ELS(l)[j++] = ht->keys[i]; + fil = ht->vals[i]; + SCHEME_VEC_ELS(l)[j++] = fil; + } + } + + ht = mrn->free_id_renames; + if (ht && ht->count) { + count = ht->count; + fil = scheme_make_vector(count * 2, NULL); + for (i = ht->size, j = 0; i--; ) { + if (ht->vals[i]) { + SCHEME_VEC_ELS(fil)[j++] = ht->keys[i]; + SCHEME_VEC_ELS(fil)[j++] = ht->vals[i]; + } + } + } else + fil = NULL; + + if (mrn->marked_names && mrn->marked_names->count) { + Scheme_Object *d = scheme_null, *p; + + for (i = mrn->marked_names->size; i--; ) { + if (mrn->marked_names->vals[i] + /* #f mapping used to store reverse-map cache: */ + && !SCHEME_FALSEP(mrn->marked_names->keys[i])) { + p = CONS(mrn->marked_names->keys[i], + mrn->marked_names->vals[i]); + d = CONS(p, d); + } + } + + if (fil) + fil = CONS(fil, d); + else + fil = d; + } else if (fil) + fil = CONS(fil, scheme_null); + else + fil = scheme_null; + + l = CONS(l, fil); + + if (SCHEME_PAIRP(mrn->unmarshal_info)) + l = CONS(mrn->unmarshal_info, l); + + l = CONS(mrn->set_identity, l); + l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l); + l = CONS(mrn->phase, l); + + local_key = scheme_marshal_lookup(mt, a); + if (local_key) + scheme_marshal_using_key(mt, a); + else { + local_key = scheme_marshal_wrap_set(mt, a, l); + } + } else { + scheme_marshal_using_key(mt, (Scheme_Object *)mrn); + } + return CONS(local_key, stack); +} + static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, Scheme_Object *w_in, Scheme_Marshal_Tables *mt, @@ -6049,13 +6147,13 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, /* simpliciation eliminates the need for rib delimiters */ } else if (SCHEME_RENAMESP(a) || SCHEME_RENAMES_SETP(a)) { - int which = 0; + int which = 0, all_redundant = 1; while (1) { Module_Renames *mrn; int redundant = 0; - if (SCHEME_RENAMESP(a)) { + if (SCHEME_RENAMESP(a)) { if (!which) { mrn = (Module_Renames *)a; which++; @@ -6139,6 +6237,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, } if (!redundant) { + all_redundant = 0; if (just_simplify) { stack = CONS((Scheme_Object *)mrn, stack); } else { @@ -6175,86 +6274,87 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, else stack = CONS(scheme_false, stack); } else { - Scheme_Object *local_key; - - local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn); - if (!local_key) { - /* Convert hash table to vector, etc.: */ - int i, j, count = 0; - Scheme_Hash_Table *ht; - Scheme_Object *l, *fil; - - ht = mrn->ht; - count = ht->count; - l = scheme_make_vector(count * 2, NULL); - for (i = ht->size, j = 0; i--; ) { - if (ht->vals[i]) { - SCHEME_VEC_ELS(l)[j++] = ht->keys[i]; - fil = ht->vals[i]; - SCHEME_VEC_ELS(l)[j++] = fil; - } - } - - ht = mrn->free_id_renames; - if (ht && ht->count) { - count = ht->count; - fil = scheme_make_vector(count * 2, NULL); - for (i = ht->size, j = 0; i--; ) { - if (ht->vals[i]) { - SCHEME_VEC_ELS(fil)[j++] = ht->keys[i]; - SCHEME_VEC_ELS(fil)[j++] = ht->vals[i]; - } - } - } else - fil = NULL; - - if (mrn->marked_names && mrn->marked_names->count) { - Scheme_Object *d = scheme_null, *p; - - for (i = mrn->marked_names->size; i--; ) { - if (mrn->marked_names->vals[i] - /* #f mapping used to store reverse-map cache: */ - && !SCHEME_FALSEP(mrn->marked_names->keys[i])) { - p = CONS(mrn->marked_names->keys[i], - mrn->marked_names->vals[i]); - d = CONS(p, d); - } - } - - if (fil) - fil = CONS(fil, d); - else - fil = d; - } else if (fil) - fil = CONS(fil, scheme_null); - else - fil = scheme_null; - - l = CONS(l, fil); - - if (SCHEME_PAIRP(mrn->unmarshal_info)) - l = CONS(mrn->unmarshal_info, l); - - l = CONS(mrn->set_identity, l); - l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l); - l = CONS(mrn->phase, l); - - local_key = scheme_marshal_lookup(mt, a); - if (local_key) - scheme_marshal_using_key(mt, a); - else { - local_key = scheme_marshal_wrap_set(mt, a, l); - } - } else { - scheme_marshal_using_key(mt, (Scheme_Object *)mrn); - } - stack = CONS(local_key, stack); + stack = add_rename_to_stack(mrn, stack, mt, a); } } stack_size++; } } } + + if (all_redundant) { + /* The rename isn't actually redundant if we need to keep the + rename-set identity --- but we can simplify to just the + identity. */ + WRAP_POS l; + Scheme_Object *la, *this_set_identity, *set_identity; + int kind, sealed; + + if (SCHEME_RENAMESP(a)) { + this_set_identity = ((Module_Renames *)a)->set_identity; + kind = ((Module_Renames *)a)->kind; + sealed = ((Module_Renames *)a)->sealed; + } else { + this_set_identity = ((Module_Renames_Set *)a)->set_identity; + kind = ((Module_Renames_Set *)a)->kind; + sealed = ((Module_Renames_Set *)a)->sealed; + } + + if (kind != mzMOD_RENAME_TOPLEVEL) { + WRAP_POS_COPY(l,w); + + for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { + la = WRAP_POS_FIRST(l); + if (SCHEME_RENAMESP(la)) + set_identity = ((Module_Renames *)la)->set_identity; + else if (SCHEME_RENAMES_SETP(la)) + set_identity = ((Module_Renames_Set *)la)->set_identity; + else if (SCHEME_BOXP(la)) { + set_identity = SCHEME_VEC_ELS(SCHEME_BOX_VAL(la))[5]; + if (SAME_OBJ(set_identity, this_set_identity)) + set_identity = scheme_false; + else + set_identity = NULL; + } else + set_identity = NULL; + + if (set_identity) { + if (SAME_OBJ(set_identity, this_set_identity)) { + all_redundant = 0; + break; + } else + break; + } + } + + if (all_redundant) { + Scheme_Hash_Table *identity_map; + Scheme_Object *key; + + identity_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_eof); + if (!identity_map) { + identity_map = scheme_make_hash_table_equal(); + scheme_hash_set(rns, scheme_eof, (Scheme_Object *)identity_map); + } + + key = scheme_make_pair(scheme_make_integer(kind), + scheme_make_pair(scheme_make_integer(sealed), + this_set_identity)); + + la = scheme_hash_get(identity_map, key); + if (!la) { + la = scheme_make_module_rename(scheme_make_integer(0), kind, NULL, NULL, this_set_identity); + ((Module_Renames *)la)->sealed = sealed; + scheme_hash_set(identity_map, key, la); + } + + if (just_simplify) + stack = CONS(la, stack); + else + stack = add_rename_to_stack((Module_Renames *)la, stack, mt, a); + } + } + } } else if (SCHEME_SYMBOLP(a)) { /* mark barrier */ stack = CONS(a, stack); @@ -6975,9 +7075,9 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, if (!set_identity) return_NULL; a = SCHEME_CDR(a); - mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL, NULL); - - mrn->set_identity = set_identity; + mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, + NULL, NULL, + set_identity); if (!SCHEME_PAIRP(a)) return_NULL; mns = SCHEME_CDR(a);