From 193178028daaa5cc8eaf9262cfff1aefaaa37996 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 2 Apr 2016 17:48:25 -0600 Subject: [PATCH] fix 'origin info in submodule expansion While expanding a module, the root of module-relative references is a fresh notion of "this module". After expansion, "this module" is shifted to "an expanded module", which is a global constant (for top-level modules). When an expanded module is re-expanded, "an expanded module" is shifted to a fresh "this module" during re-expansion, and so on. One problem with this approach is that the shift from "this module" to "an expanded module" isn't applied to syntax properties --- but there's some extra trickery to make it work out by mutating "this module" to make it look like "an expanded module". Submodule expansion introduces an intermediate "parent of this module" that wasn't currently covered by the extra trickery, so fix that. --- pkgs/racket-test-core/tests/racket/macro.rktl | 31 +++++++++++++++++++ racket/src/racket/src/module.c | 24 ++++++++++++-- racket/src/racket/src/mzmark_type.inc | 2 ++ racket/src/racket/src/mzmarksrc.c | 1 + racket/src/racket/src/schpriv.h | 1 + 5 files changed, 57 insertions(+), 2 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index 16eb9e4eea..410169e3f8 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/pkgs/racket-test-core/tests/racket/macro.rktl @@ -1577,6 +1577,37 @@ (module->namespace ''macro-that-introduces-a-lifted-one)]) (eval '(values m)))) +;; ---------------------------------------- +;; Check that expanded references in submodule +;; have the right binding info for 'origin + +(let () + (define m + '(module m racket/base + (define-syntax-rule (m) 1) + (module+ main + (m)))) + + (define m-expanded + (parameterize ([current-namespace (make-base-namespace)]) + (expand m))) + + (define-values (bind-m ref-m) + (syntax-case m-expanded () + [(module _ racket/base + (#%module-begin + _ + (define-syntaxes + (m) + _) + (module* main #f + (#%module-begin-2 + _ + (#%app1 call-with-values (lambda () ONE) print-values))))) + (values #'m (car (syntax-property #'ONE 'origin)))])) + + (test #t free-identifier=? bind-m ref-m)) + ;; ---------------------------------------- (report-errs) diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index f9b0c17379..ffe71fbb0c 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -127,6 +127,7 @@ typedef struct Module_Begin_Expand_State { Scheme_Object *redef_modname; Scheme_Object *end_statementss; /* list of lists */ Scheme_Object *modsrc; /* source for top-level module */ + Scheme_Object **sub_iidx_ptrs; /* contains `iidx`es for `(module* name #f ...)` submodules */ } Module_Begin_Expand_State; static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, @@ -7122,7 +7123,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Comp_Env *benv; Scheme_Module *m; Scheme_Object *mbval, *orig_ii; - Scheme_Object *this_empty_self_modidx; + Scheme_Object *this_empty_self_modidx, **sub_iidx_ptrs; int saw_mb, check_mb = 0, shift_back = 0; Scheme_Object *restore_confusing_name = NULL; LOG_EXPAND_DECLS; @@ -7278,6 +7279,9 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, self_modidx, scheme_false); + shift = scheme_make_pair(iidx, *super_bxs->sub_iidx_ptrs); + *super_bxs->sub_iidx_ptrs = shift; + super_phase_shift = scheme_bin_minus(scheme_make_integer(0), super_phase_shift); shift = scheme_make_shift(super_phase_shift, @@ -7295,6 +7299,10 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, m->super_bxs_info = super_bxs_info; } + sub_iidx_ptrs = MALLOC_N(Scheme_Object*, 1); + *sub_iidx_ptrs = scheme_null; + m->sub_iidx_ptrs = sub_iidx_ptrs; + if (!rec[drec].comp) { SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer); } @@ -7463,6 +7471,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, m->ii_src = NULL; m->super_bxs_info = NULL; + m->sub_iidx_ptrs = NULL; pv = scheme_stx_property(form, scheme_intern_symbol("module-language"), NULL); if (pv && SCHEME_TRUEP(pv)) { @@ -7487,6 +7496,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, m->ii_src = NULL; m->super_bxs_info = NULL; + m->sub_iidx_ptrs = NULL; hints = m->hints; m->hints = NULL; @@ -7572,11 +7582,20 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, scheme_stx_add_shift(stx, ps)); } - /* make self_modidx like the empty modidx */ + /* make self_modidx like the empty modidx; this update plays the + role of applying a shift to identifiers that are in syntax + properties, such as the 'origin property */ if (SAME_OBJ(this_empty_self_modidx, empty_self_modidx)) ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname; else ((Scheme_Modidx *)self_modidx)->resolved = ((Scheme_Modidx *)this_empty_self_modidx)->resolved; + + while (SCHEME_PAIRP(*sub_iidx_ptrs)) { + /* Each in `*sub_iidx_ptrs` corresponds to the implicit `..` import for + a `(module* name #f ...)` submodule: */ + ((Scheme_Modidx *)SCHEME_CAR(*sub_iidx_ptrs))->resolved = ((Scheme_Modidx *)self_modidx)->resolved; + *sub_iidx_ptrs = SCHEME_CDR(*sub_iidx_ptrs); + } } if (rec[drec].comp || (rec[drec].depth != -2)) { @@ -8352,6 +8371,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env bxs->redef_modname = redef_modname; bxs->end_statementss = scheme_null; bxs->modsrc = env->genv->module->modsrc; + bxs->sub_iidx_ptrs = env->genv->module->sub_iidx_ptrs; if (env->genv->module->super_bxs_info) { /* initialize imports that are available for export from the enclosing module's diff --git a/racket/src/racket/src/mzmark_type.inc b/racket/src/racket/src/mzmark_type.inc index d892e34d80..0d08dc8e3f 100644 --- a/racket/src/racket/src/mzmark_type.inc +++ b/racket/src/racket/src/mzmark_type.inc @@ -3838,6 +3838,7 @@ static int module_val_MARK(void *p, struct NewGC *gc) { gcMARK2(m->hints, gc); gcMARK2(m->ii_src, gc); gcMARK2(m->super_bxs_info, gc); + gcMARK2(m->sub_iidx_ptrs, gc); gcMARK2(m->comp_prefix, gc); gcMARK2(m->prefix, gc); @@ -3898,6 +3899,7 @@ static int module_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(m->hints, gc); gcFIXUP2(m->ii_src, gc); gcFIXUP2(m->super_bxs_info, gc); + gcFIXUP2(m->sub_iidx_ptrs, gc); gcFIXUP2(m->comp_prefix, gc); gcFIXUP2(m->prefix, gc); diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 8654616a99..6d5ef536b0 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -1115,6 +1115,7 @@ module_val { gcMARK2(m->hints, gc); gcMARK2(m->ii_src, gc); gcMARK2(m->super_bxs_info, gc); + gcMARK2(m->sub_iidx_ptrs, gc); gcMARK2(m->comp_prefix, gc); gcMARK2(m->prefix, gc); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index fb1fcf2102..a6be09e7ee 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -3778,6 +3778,7 @@ typedef struct Scheme_Module Scheme_Object *ii_src; /* set by compile, temporary */ Comp_Prefix *comp_prefix; /* set by body compile, temporary */ void **super_bxs_info; /* set by expansion; temporary */ + Scheme_Object **sub_iidx_ptrs; /* set by expansion; temporary */ int max_let_depth; Resolve_Prefix *prefix;