suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

macro-expander fix

Browse Source 
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
This commit is contained in:
Matthew Flatt 2012-07-19 10:57:12 -05:00
parent df8e109c6a
commit 73e07f576b
3 changed files with 195 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/racket/src/module.c
View File

@ -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,

3
src/racket/src/schpriv.h
View File

@ -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,

280
src/racket/src/syntax.c
View File

@ -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);