From 981a491c45454e3e7bb9a80f1a29819eb5351dae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Oct 2008 12:14:06 +0000 Subject: [PATCH] change representation of marked imports in syntax context (which finally fixes the 13MB-of-redundant-bytecode problem with the framework and tools docs) svn: r12156 --- src/mzscheme/src/env.c | 54 +++++--- src/mzscheme/src/module.c | 37 ++++-- src/mzscheme/src/mzmark.c | 2 + src/mzscheme/src/mzmarksrc.c | 1 + src/mzscheme/src/schpriv.h | 4 +- src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/stxobj.c | 238 +++++++++++++++++++++++++---------- 7 files changed, 243 insertions(+), 97 deletions(-) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 0bb16801d1..1ae51c5c92 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -1743,31 +1743,36 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid return val; } -Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, +Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, + int mode, /* -1, 0 => lookup; 2, 3 => define + -1 and 3 => use temp table + 1 would mean define if no match; not currently used */ Scheme_Object *phase, int *_skipped) /* The `env' argument can actually be a hash table. */ { Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg; int best_match_skipped, ms, one_mark; - Scheme_Hash_Table *marked_names; + Scheme_Hash_Table *marked_names, *temp_marked_names, *dest_marked_names; sym = SCHEME_STX_SYM(id); if (_skipped) *_skipped = 0; - if (SCHEME_HASHTP((Scheme_Object *)env)) + if (SCHEME_HASHTP((Scheme_Object *)env)) { marked_names = (Scheme_Hash_Table *)env; - else { + temp_marked_names = NULL; + } else { /* If there's no table and we're not defining, bail out fast */ - if (!is_def && !env->rename_set) + if ((mode <= 0) && !env->rename_set) return sym; marked_names = scheme_get_module_rename_marked_names(env->rename_set, phase ? phase : scheme_make_integer(env->phase), 0); + temp_marked_names = env->temp_marked_names; } - if (is_def) { + if (mode > 0) { /* If we're defining, see if we need to create a table. Getting marks is relatively expensive, but we only do this once per definition. */ @@ -1784,12 +1789,23 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec phase ? phase : scheme_make_integer(env->phase), 1); } + if (!temp_marked_names && (mode > 2)) { + /* The "temp" marked name table is used to correlate marked module + requires with similarly marked provides. We don't go through + the normal rename table because (for efficiency) the marks in + this case are handled more directly in the shared_pes module + renamings. */ + temp_marked_names = scheme_make_hash_table(SCHEME_hash_ptr); + env->temp_marked_names = temp_marked_names; + } map = scheme_hash_get(marked_names, sym); + if (!map && ((mode < 0) || (mode > 2)) && temp_marked_names) + map = scheme_hash_get(temp_marked_names, sym); if (!map) { /* If we're not defining, we can bail out before extracting marks. */ - if (!is_def) + if (mode <= 0) return sym; else map = scheme_null; @@ -1833,7 +1849,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec abdg = NULL; if (SAME_OBJ(abdg, bdg)) { - if (is_def) { + if (mode > 0) { if (scheme_equal(amarks, marks)) { best_match = SCHEME_CDR(a); break; @@ -1873,7 +1889,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec } if (!best_match) { - if (!is_def) { + if (mode <= 0) { return sym; } @@ -1883,7 +1899,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec "redundant" module renamings wouldn't be redundant. (See simpify in stxobj.c.) So check for a context-determined existing rename. */ - if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (is_def != 2)) { + if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) { Scheme_Object *mod, *nm = id; mod = scheme_stx_module_name(&nm, scheme_make_integer(env->phase), NULL, NULL, NULL, NULL, NULL); if (mod /* must refer to env->module, otherwise there would @@ -1925,11 +1941,14 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec best_match = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); if (!scheme_stx_parallel_is_used(best_match, id)) { - /* Also check environment's rename tables. This - last check turns out to matter for compiling in - `module->namespace' contexts, because no renaming - is added after expansion to record the rename table. */ - if (!scheme_tl_id_is_sym_used(marked_names, best_match)) { + /* Also check environment's rename tables. This last check + includes the temp table. It also turns out to matter for + compiling in `module->namespace' contexts, because no + renaming is added after expansion to record the rename + table. */ + if (!scheme_tl_id_is_sym_used(marked_names, best_match) + && (!temp_marked_names + || !scheme_tl_id_is_sym_used(temp_marked_names, best_match))) { /* Ok, no matches, so this name is fine. */ break; } @@ -1947,10 +1966,11 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec a = scheme_make_pair(marks, best_match); map = scheme_make_pair(a, map); - scheme_hash_set(marked_names, sym, map); + dest_marked_names = ((mode < 0) || (mode > 2)) ? temp_marked_names : marked_names; + scheme_hash_set(dest_marked_names, sym, map); { Scheme_Hash_Table *rev_ht; - rev_ht = (Scheme_Hash_Table *)scheme_hash_get(marked_names, scheme_false); + rev_ht = (Scheme_Hash_Table *)scheme_hash_get(dest_marked_names, scheme_false); if (rev_ht) { scheme_hash_set(rev_ht, best_match, scheme_true); } diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 01f6033eb2..905cb6b53c 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -2156,7 +2156,9 @@ static int do_add_simple_require_renames(Scheme_Object *rn, pt->src_modidx = im->me->src_modidx; scheme_extend_module_rename_with_shared(rn, idx, pt, marshal_phase_index, - scheme_make_integer(0), 1); + scheme_make_integer(0), + scheme_null, + 1); } mark_src = scheme_rename_to_stx(rn); @@ -6278,7 +6280,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, /* may be a single shadowed exclusion, now bound to exclude_hint... */ n = SCHEME_CAR(n); if (SCHEME_STXP(n)) - n = scheme_tl_id_sym(env->genv, n, NULL, 0, NULL, NULL); + n = scheme_tl_id_sym(env->genv, n, NULL, -1, NULL, NULL); n = scheme_hash_get(required, n); if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) { /* there is a single shadowed exclusion. */ @@ -7033,7 +7035,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table prnt_name = name; if (SCHEME_STXP(name)) { if (genv) - name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL); + name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); else name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ } @@ -7106,7 +7108,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (genv && (SAME_OBJ(phase, scheme_make_integer(0)) || SAME_OBJ(phase, scheme_make_integer(1)))) - name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL); + name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); else { name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ } @@ -7869,7 +7871,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ { int j, var_count; Scheme_Object *orig_idx = idx, *to_phase; - Scheme_Object **exs, **exsns, **exss; + Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null; char *exets; int is_kern, has_context, save_marshal_info = 0; Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename; @@ -7879,9 +7881,8 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ if (mark_src) { /* Check whether there's context for this import (which leads to generated local names). */ - Scheme_Object *l; - l = scheme_stx_extract_marks(mark_src); - has_context = !SCHEME_NULLP(l); + context_marks = scheme_stx_extract_marks(mark_src); + has_context = !SCHEME_NULLP(context_marks); if (has_context) { if (all_simple) *all_simple = 0; @@ -7889,7 +7890,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ } else has_context = 0; /* computed later */ - if (iname || ename || onlys || for_unmarshal || unpack_kern || has_context) + if (iname || ename || onlys || for_unmarshal || unpack_kern) can_save_marshal = 0; if (onlys) @@ -7964,7 +7965,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ /* Simple "import everything" whose mappings can be shared via the exporting module: */ if (!pt->src_modidx) pt->src_modidx = me->src_modidx; - scheme_extend_module_rename_with_shared(rn, idx, pt, pt->phase_index, src_phase_index, 1); + scheme_extend_module_rename_with_shared(rn, idx, pt, pt->phase_index, src_phase_index, context_marks, 1); skip_rename = 1; } else skip_rename = 0; @@ -8040,7 +8041,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ /* The `require' expression has a set of marks in its context, which means that we need to generate a name. */ iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); - iname = scheme_tl_id_sym(orig_env, iname, scheme_false, 2, to_phase, NULL); + iname = scheme_tl_id_sym(orig_env, iname, scheme_false, skip_rename ? 3 : 2, to_phase, NULL); if (all_simple) *all_simple = 0; } @@ -8154,7 +8155,7 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info, Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, Scheme_Hash_Table *export_registry) { - Scheme_Object *orig_idx, *exns, *prefix, *idx, *name, *pt_phase, *src_phase_index; + Scheme_Object *orig_idx, *exns, *prefix, *idx, *name, *pt_phase, *src_phase_index, *marks; Scheme_Module_Exports *me; Scheme_Env *env; int share_all; @@ -8164,6 +8165,13 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info, info = SCHEME_CDR(info); pt_phase = SCHEME_CAR(info); info = SCHEME_CDR(info); + + if (SCHEME_PAIRP(info) && SCHEME_PAIRP(SCHEME_CAR(info))) { + marks = SCHEME_CAR(info); + info = SCHEME_CDR(info); + } else + marks = scheme_null; + if (SCHEME_INTP(info) || SCHEME_FALSEP(info)) { share_all = 1; @@ -8224,9 +8232,12 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info, if (pt) { if (!pt->src_modidx) pt->src_modidx = me->src_modidx; - scheme_extend_module_rename_with_shared(rn, orig_idx, pt, pt->phase_index, src_phase_index, 0); + scheme_extend_module_rename_with_shared(rn, orig_idx, pt, pt->phase_index, src_phase_index, marks, 0); } } else { + if (!SCHEME_NULLP(marks)) + scheme_signal_error("internal error: unexpected marks"); + add_single_require(me, pt_phase, src_phase_index, orig_idx, NULL, NULL, NULL, rn, exns, NULL, prefix, NULL, NULL, diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index db9cd15931..df3bae8b96 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -2071,6 +2071,7 @@ static int namespace_val_MARK(void *p) { gcMARK(e->insp); gcMARK(e->rename_set); + gcMARK(e->temp_marked_names); gcMARK(e->syntax); gcMARK(e->exp_env); @@ -2105,6 +2106,7 @@ static int namespace_val_FIXUP(void *p) { gcFIXUP(e->insp); gcFIXUP(e->rename_set); + gcFIXUP(e->temp_marked_names); gcFIXUP(e->syntax); gcFIXUP(e->exp_env); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 08b79a41aa..fcf503e2c0 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -823,6 +823,7 @@ namespace_val { gcMARK(e->insp); gcMARK(e->rename_set); + gcMARK(e->temp_marked_names); gcMARK(e->syntax); gcMARK(e->exp_env); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 0447a44fe6..1dfe3cad91 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -749,6 +749,7 @@ void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *m struct Scheme_Module_Phase_Exports *pt, Scheme_Object *unmarshal_phase_index, Scheme_Object *src_phase_index, + Scheme_Object *marks, int save_unmarshal); void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src); void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info); @@ -2475,6 +2476,7 @@ struct Scheme_Env { protected access and certificates */ Scheme_Object *rename_set; + Scheme_Hash_Table *temp_marked_names; /* used to correlate imports with re-exports */ Scheme_Bucket_Table *syntax; struct Scheme_Env *exp_env; @@ -2633,7 +2635,7 @@ void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Sc -Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, +Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int mode, Scheme_Object *phase, int *_skipped); int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym); diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 79c4fa7b27..a8ae48de01 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.2.1" +#define MZSCHEME_VERSION "4.1.2.2" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 2 -#define MZSCHEME_VERSION_W 1 +#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index b619c3de83..7fe7a9dc67 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -141,7 +141,10 @@ typedef struct Module_Renames { nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase) import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */ Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */ - Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase-index-int)) like nomarshal ht, but shared from provider */ + Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase_and_marks)) + phase_and_marks -> phase-index-int OR + (cons (nonempty-listof mark) phase-index-int) + like nomarshal ht, but shared from provider */ Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module; this table maps a top-level-bound identifier with a non-empty mark set to a gensym created for the binding */ @@ -1320,23 +1323,29 @@ void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *m Scheme_Module_Phase_Exports *pt, Scheme_Object *unmarshal_phase_index, Scheme_Object *src_phase_index, + Scheme_Object *marks, int save_unmarshal) { Module_Renames *mrn = (Module_Renames *)rn; - Scheme_Object *pr; + Scheme_Object *pr, *index_plus_marks; check_not_sealed(mrn); + if (SCHEME_PAIRP(marks)) + index_plus_marks = scheme_make_pair(marks, src_phase_index); + else + index_plus_marks = src_phase_index; + pr = scheme_make_pair(scheme_make_pair(modidx, scheme_make_pair((Scheme_Object *)pt, - src_phase_index)), + index_plus_marks)), mrn->shared_pes); mrn->shared_pes = pr; if (save_unmarshal) { pr = scheme_make_pair(scheme_make_pair(modidx, scheme_make_pair(unmarshal_phase_index, - src_phase_index)), + index_plus_marks)), mrn->unmarshal_info); mrn->unmarshal_info = pr; } @@ -3155,13 +3164,51 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks) } } -static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, Scheme_Object *glob_id, +static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache) +{ + int l1, l2; + Scheme_Object *m1, *m2; + + p = SCHEME_CDR(p); /* skip modidx */ + p = SCHEME_CDR(p); /* skip phase_export */ + if (SCHEME_PAIRP(p)) { + /* has marks */ + + m1 = SCHEME_CAR(p); + if (*marks_cache) + m2 = *marks_cache; + else { + m2 = scheme_stx_extract_marks(orig_id); + *marks_cache = m2; + } + + l1 = scheme_list_length(m1); + l2 = scheme_list_length(m2); + + if (l2 < l1) return -1; /* no match */ + + while (l2 > l1) { + m2 = SCHEME_CDR(m2); + l2--; + } + + if (scheme_equal(m1, m2)) + return l1; /* matches */ + else + return -1; /* no match */ + } else + return 0; /* match empty mark set */ +} + +static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, + Scheme_Object *glob_id, Scheme_Object *orig_id, Scheme_Object **get_names, int get_orig_name) { - Scheme_Object *pr, *idx, *pos, *src; + Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL; Scheme_Module_Phase_Exports *pt; Scheme_Hash_Table *ht; - int i, phase; + int i, phase, best_match_len = -1; + Scheme_Object *marks_cache = NULL; for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr)); @@ -3177,69 +3224,87 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, Scheme pos = scheme_hash_get(pt->ht, glob_id); if (pos) { - /* found it; return suitable rename: */ - idx = SCHEME_CAR(SCHEME_CAR(pr)); + /* Found it, maybe. Check marks. */ + int mark_len; + mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache); + if (mark_len > best_match_len) { + /* Marks match and improve on previously found match. Build suitable rename: */ + best_match_len = mark_len; + + idx = SCHEME_CAR(SCHEME_CAR(pr)); - i = SCHEME_INT_VAL(pos); + i = SCHEME_INT_VAL(pos); - if (get_orig_name) - return pt->provide_src_names[i]; + if (get_orig_name) + best_match = pt->provide_src_names[i]; + else { + if (pt->provide_srcs) + src = pt->provide_srcs[i]; + else + src = scheme_false; - if (pt->provide_srcs) - src = pt->provide_srcs[i]; - else - src = scheme_false; + if (get_names) { + /* If module bound, result is module idx, and get_names[0] is set to source name, + get_names[1] is set to the nominal source module, get_names[2] is set to + the nominal source module's export, get_names[3] is set to the phase of + the source definition, get_names[4] is set to the module import phase index, + and get_names[5] is set to the nominal export phase */ - if (get_names) { - /* If module bound, result is module idx, and get_names[0] is set to source name, - get_names[1] is set to the nominal source module, get_names[2] is set to - the nominal source module's export, get_names[3] is set to the phase of - the source definition, get_names[4] is set to the module import phase index, - and get_names[5] is set to the nominal export phase */ + if (pt->provide_src_phases) + phase = pt->provide_src_phases[i]; + else + phase = 0; - if (pt->provide_src_phases) - phase = pt->provide_src_phases[i]; - else - phase = 0; + get_names[0] = pt->provide_src_names[i]; + get_names[1] = idx; + get_names[2] = glob_id; + get_names[3] = scheme_make_integer(phase); + get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr))); + if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */ + get_names[4] = SCHEME_CDR(get_names[4]); + get_names[5] = pt->phase_index; + } - get_names[0] = pt->provide_src_names[i]; - get_names[1] = idx; - get_names[2] = glob_id; - get_names[3] = scheme_make_integer(phase); - get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr))); - get_names[5] = pt->phase_index; + if (SCHEME_FALSEP(src)) { + src = idx; + } else { + src = scheme_modidx_shift(src, pt->src_modidx, idx); + } + + best_match = src; + } } - - if (SCHEME_FALSEP(src)) { - src = idx; - } else { - src = scheme_modidx_shift(src, pt->src_modidx, idx); - } - - return src; - } - - if (pt->reprovide_kernel) { + } else if (pt->reprovide_kernel) { Scheme_Object *kpr; kpr = scheme_hash_get(krn->ht, glob_id); if (kpr) { - if (get_orig_name) - return glob_id; - if (get_names) { - idx = SCHEME_CAR(SCHEME_CAR(kpr)); - get_names[0] = glob_id; - get_names[1] = idx; - get_names[2] = glob_id; - get_names[3] = scheme_make_integer(0); - get_names[4] = pt->phase_index; - get_names[5] = scheme_make_integer(0); + /* Found it, maybe. Check marks. */ + int mark_len; + mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache); + if (mark_len > best_match_len) { + /* Marks match and improve on previously found match. Build suitable rename: */ + best_match_len = mark_len; + + if (get_orig_name) + best_match = glob_id; + else { + if (get_names) { + idx = SCHEME_CAR(SCHEME_CAR(kpr)); + get_names[0] = glob_id; + get_names[1] = idx; + get_names[2] = glob_id; + get_names[3] = scheme_make_integer(0); + get_names[4] = pt->phase_index; + get_names[5] = scheme_make_integer(0); + } + best_match = scheme_get_kernel_modidx(); + } } - return scheme_get_kernel_modidx(); } } } - return NULL; + return best_match; } static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object *phase) @@ -3457,7 +3522,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } get_names_done = 0; if (!rename) { - rename = scheme_search_shared_pes(mrn->shared_pes, glob_id, get_names, 0); + rename = scheme_search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0); if (rename) get_names_done = 1; } @@ -3841,7 +3906,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ rename = scheme_hash_get(krn->ht, glob_id); if (!rename) - result = scheme_search_shared_pes(mrn->shared_pes, glob_id, NULL, 1); + result = scheme_search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1); else if (rename) { /* match; set result: */ if (mrn->kind == mzMOD_RENAME_MARKED) @@ -5405,6 +5470,8 @@ static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Unmarshal_Tables if (SCHEME_INTP(a) && IS_POSMARK(a)) a = scheme_make_integer(-SCHEME_INT_VAL(a)); + else if (!SCHEME_NUMBERP(a)) + return NULL; else a = scheme_intern_symbol(scheme_number_to_string(10, a)); @@ -5554,6 +5621,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, if (!SCHEME_PAIRP(a)) return_NULL; set_identity = unmarshal_mark(SCHEME_CAR(a), ut); + if (!set_identity) return_NULL; a = SCHEME_CDR(a); mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL); @@ -5566,9 +5634,10 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, if (!SCHEME_VECTORP(a)) { /* Unmarshall info: */ - Scheme_Object *ml = a, *mli; + Scheme_Object *ml = a, *mli, *first = scheme_null, *last = NULL, *ai; while (SCHEME_PAIRP(ml)) { - mli = SCHEME_CAR(ml); + ai = SCHEME_CAR(ml); + mli = ai; if (!SCHEME_PAIRP(mli)) return_NULL; /* A module path index: */ @@ -5580,24 +5649,57 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, if (!SCHEME_PAIRP(mli)) return_NULL; - /* A phase/dimension index */ + /* A phase/dimension index k */ p = SCHEME_CAR(mli); if (!ok_phase_index(p)) return_NULL; p = SCHEME_CDR(mli); + if (SCHEME_PAIRP(p) && SCHEME_PAIRP(SCHEME_CAR(p))) { + /* list of marks: */ + Scheme_Object *m_first = scheme_null, *m_last = NULL, *mp, *after_marks; + + after_marks = SCHEME_CDR(p); + mli = SCHEME_CAR(p); + + while (SCHEME_PAIRP(mli)) { + p = SCHEME_CAR(mli); + p = unmarshal_mark(p, ut); + if (!p) return_NULL; + + mp = scheme_make_pair(p, scheme_null); + if (m_last) + SCHEME_CDR(m_last) = mp; + else + m_first = mp; + m_last = mp; + + mli = SCHEME_CDR(mli); + } + + /* Rebuild for unmarshaled marks: */ + ai = scheme_make_pair(SCHEME_CAR(ai), + scheme_make_pair(SCHEME_CADR(ai), + scheme_make_pair(m_first, after_marks))); + + if (!SCHEME_NULLP(mli)) return_NULL; + p = after_marks; + } + if (ok_phase_index(p)) { - /* For a shared table: (cons k src-phase-index) */ + /* For a shared table: src-phase-index */ } else { + /* For a non-shared table: (list* src-phase-index exceptions prefix), after k */ mli = p; if (!SCHEME_PAIRP(mli)) return_NULL; - /* For a shared table: (cons k src-phase-index) */ p = SCHEME_CAR(mli); if (!ok_phase_index(p)) return_NULL; mli = SCHEME_CDR(mli); + if (!SCHEME_PAIRP(mli)) return_NULL; + /* A list of symbols: */ p = SCHEME_CAR(mli); while (SCHEME_PAIRP(p)) { @@ -5612,11 +5714,19 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, } ml = SCHEME_CDR(ml); + + /* rebuild, in case we converted marks */ + p = scheme_make_pair(ai, scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; } if (!SCHEME_NULLP(ml)) return_NULL; - mrn->unmarshal_info = a; - if (SCHEME_PAIRP(a)) + mrn->unmarshal_info = first; + if (SCHEME_PAIRP(first)) mrn->needs_unmarshal = 1; if (!SCHEME_PAIRP(mns)) return_NULL;