diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index 13da53dbbf..01813acefc 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -2269,6 +2269,31 @@ (namespace-syntax-introduce (datum->syntax #f 'car))))) (open-output-bytes))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that reading a compiled module doesn't mutate the +;; shared "self" modix for a submodule: + +(parameterize ([current-namespace (make-base-namespace)]) + (define o (open-output-bytes)) + (write (compile `(module name-1 racket/base (module+ inside))) o) + (define m + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes (get-output-bytes o))))) + (define s (expand `(module name-2 racket/base (module+ inside (define check-me 1))))) + (test "(|expanded module| inside)" + format + "~s" + (resolved-module-path-name + (let loop ([s s]) + (cond + [(identifier? s) + (and (equal? 'check-me (syntax-e s)) + (module-path-index-resolve (car (identifier-binding s))))] + [(syntax? s) (loop (syntax-e s))] + [(pair? s) + (or (loop (car s)) (loop (cdr s)))] + [else #f]))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 238f0d266d..33ebc783a0 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -3716,7 +3716,7 @@ static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]) "second argument", 1, argv[1], "third argument", 1, argv[2], NULL); - return scheme_get_submodule_empty_self_modidx(argv[2]); + return scheme_get_submodule_empty_self_modidx(argv[2], 0); } } @@ -4024,31 +4024,49 @@ static Scheme_Object *resolved_module_path_to_modidx(Scheme_Object *rmp) return scheme_make_modidx(path, scheme_false, rmp); } -Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path) +Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path, int can_cache) { Scheme_Bucket *b; + Scheme_Object *modidx; - if (SCHEME_NULLP(submodule_path)) - return empty_self_modidx; + if (SCHEME_NULLP(submodule_path)) { + if (can_cache) + return empty_self_modidx; + return scheme_make_modidx(scheme_false, scheme_false, empty_self_modname); + } if (!submodule_empty_modidx_table) { REGISTER_SO(submodule_empty_modidx_table); submodule_empty_modidx_table = scheme_make_weak_equal_table(); } - scheme_start_atomic(); - b = scheme_bucket_from_table(submodule_empty_modidx_table, (const char *)submodule_path); - if (!b->val) { - submodule_path = make_resolved_module_path_obj(scheme_make_pair(scheme_resolved_module_path_value(empty_self_modname), - submodule_path)); - submodule_path = scheme_make_modidx(scheme_false, - scheme_false, - submodule_path); - b->val = submodule_path; + if (can_cache) { + scheme_start_atomic(); + b = scheme_bucket_from_table(submodule_empty_modidx_table, (const char *)submodule_path); + if (b->val) + modidx = scheme_ephemeron_value(b->val); + else + modidx = NULL; + } else { + b = NULL; + modidx = NULL; } - scheme_end_atomic_no_swap(); - return b->val; + if (!modidx) { + modidx = make_resolved_module_path_obj(scheme_make_pair(scheme_resolved_module_path_value(empty_self_modname), + submodule_path)); + modidx = scheme_make_modidx(scheme_false, scheme_false, modidx); + if (b) { + modidx = scheme_make_ephemeron(submodule_path, modidx); + b->val = modidx; + modidx = scheme_ephemeron_value(modidx); + } + } + + if (can_cache) + scheme_end_atomic_no_swap(); + + return modidx; } static Scheme_Object *_module_resolve_k(void); @@ -7325,7 +7343,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp)); - this_empty_self_modidx = scheme_get_submodule_empty_self_modidx(submodule_path); + this_empty_self_modidx = scheme_get_submodule_empty_self_modidx(submodule_path, 1); /* phase shift to replace self_modidx of previous expansion: */ fm = scheme_stx_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, diff --git a/racket/src/racket/src/read.c b/racket/src/racket/src/read.c index fb354cd3f2..26b55dd703 100644 --- a/racket/src/racket/src/read.c +++ b/racket/src/racket/src/read.c @@ -5168,7 +5168,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) if (SCHEME_FALSEP(path)) return scheme_make_modidx(scheme_false, scheme_false, scheme_false); else - return scheme_get_submodule_empty_self_modidx(path); + return scheme_get_submodule_empty_self_modidx(path, 0); } else return scheme_make_modidx(path, base, scheme_false); } diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index a06b2eca72..1f26f0b3f5 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -3719,7 +3719,7 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, Scheme_Object *shift_to_modidx); Scheme_Object *scheme_modidx_submodule(Scheme_Object *modidx); -Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path); +Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path, int can_cache); #define SCHEME_RMPP(o) (SAME_TYPE(SCHEME_TYPE((o)), scheme_resolved_module_path_type)) #define SCHEME_MODNAMEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type))