From f3b720abe14a107f46ec9484614d447023313930 Mon Sep 17 00:00:00 2001 From: Zesen Qian Date: Tue, 21 Jan 2025 10:35:35 +0000 Subject: [PATCH] Module aliases save locks instead of walking them immediately (#3398) --- .../basic/bad_instance_wrong_mode.ml | 2 + .../basic/bad_instance_wrong_mode.reference | 8 +- testsuite/tests/typing-modes/module.ml | 82 ++++++++++- .../tests/typing-modes/val_modalities.ml | 61 +++++++++ typing/env.ml | 127 +++++++++--------- typing/env.mli | 27 +++- typing/typecore.ml | 13 +- typing/typecore.mli | 3 +- typing/typemod.ml | 85 +++++++++--- 9 files changed, 302 insertions(+), 106 deletions(-) diff --git a/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml b/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml index 6776ff31a5d..996bec9d4ff 100644 --- a/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml +++ b/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml @@ -2,4 +2,6 @@ let (f @ portable) () = let module Monoid_utils_of_list_monoid = Monoid_utils(Monoid)(List_monoid) [@jane.non_erasable.instances] in + (* module alias doesn't walk locks; using it does. *) + let _ = Monoid_utils_of_list_monoid.concat in () diff --git a/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference b/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference index cd840ed625b..67214136bf0 100644 --- a/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference +++ b/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference @@ -1,4 +1,4 @@ -File "bad_instance_wrong_mode.ml", line 3, characters 4-68: -3 | Monoid_utils(Monoid)(List_monoid) [@jane.non_erasable.instances] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Modules are nonportable, so cannot be used inside a function that is portable. +File "bad_instance_wrong_mode.ml", line 6, characters 10-44: +6 | let _ = Monoid_utils_of_list_monoid.concat in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The value "Monoid_utils_of_list_monoid.concat" is nonportable, so cannot be used inside a function that is portable. diff --git a/testsuite/tests/typing-modes/module.ml b/testsuite/tests/typing-modes/module.ml index 9dc270a43da..eb9309fd966 100644 --- a/testsuite/tests/typing-modes/module.ml +++ b/testsuite/tests/typing-modes/module.ml @@ -1,4 +1,5 @@ (* TEST + flags+="-extension mode_alpha"; expect; *) @@ -24,7 +25,7 @@ end val portable_use : 'a @ portable -> unit = module type S = sig val x : 'a -> unit end module type SL = sig type 'a t end -module M : sig type 'a t = int val x : 'a -> unit end +module M : sig type 'a t = int val x : 'a -> unit @@ portable end module F : functor (X : S) -> sig type t = int val x : 'a -> unit end |}] @@ -180,3 +181,82 @@ val foo : unit -> unit = |}] (* Pmty_alias is not testable *) + +(* module alias *) +module type S = sig + val foo : 'a -> 'a + val baz : 'a -> 'a @@ portable +end + +module M : S = struct + let foo = fun x -> x + let baz = fun x -> x +end +[%%expect{| +module type S = sig val foo : 'a -> 'a val baz : 'a -> 'a @@ portable end +module M : S +|}] + +let (bar @ portable) () = + let module N = M in + M.baz (); + N.baz () +[%%expect{| +val bar : unit -> unit = +|}] + +let (bar @ portable) () = + let module N = M in + N.foo () +[%%expect{| +Line 3, characters 4-9: +3 | N.foo () + ^^^^^ +Error: The value "N.foo" is nonportable, so cannot be used inside a function that is portable. +|}] + +let (bar @ portable) () = + let module N = M in + M.foo () +[%%expect{| +Line 3, characters 4-9: +3 | M.foo () + ^^^^^ +Error: The value "M.foo" is nonportable, so cannot be used inside a function that is portable. +|}] + +(* chained aliases. Creating alias of alias is fine. *) +let (bar @ portable) () = + let module N = M in + let module N' = N in + M.baz (); + N.baz (); + N'.baz () +[%%expect{| +val bar : unit -> unit = +|}] + +(* locks are accumulated and not lost *) +let (bar @ portable) () = + let module N = M in + let module N' = N in + N'.foo () +[%%expect{| +Line 4, characters 4-10: +4 | N'.foo () + ^^^^^^ +Error: The value "N'.foo" is nonportable, so cannot be used inside a function that is portable. +|}] + +(* module aliases in structures still walk locks. *) +let (bar @ portable) () = + let module N = struct + module L = M + end in + N.L.foo () +[%%expect{| +Line 3, characters 19-20: +3 | module L = M + ^ +Error: Modules are nonportable, so cannot be used inside a function that is portable. +|}] diff --git a/testsuite/tests/typing-modes/val_modalities.ml b/testsuite/tests/typing-modes/val_modalities.ml index bc859feb821..a1cd08d4ffb 100644 --- a/testsuite/tests/typing-modes/val_modalities.ml +++ b/testsuite/tests/typing-modes/val_modalities.ml @@ -900,3 +900,64 @@ let () = () [%%expect{| |}] + +(* CR zqian: finer treatment of packing and unpacking *) +module type Empty = sig end + +module type S = sig + val foo : 'a -> 'a + val baz : 'a -> 'a @@ portable +end + +module M : S = struct + let foo = fun x -> x + let baz = fun x -> x +end +[%%expect{| +module type Empty = sig end +module type S = sig val foo : 'a -> 'a val baz : 'a -> 'a @@ portable end +module M : S +|}] + +let (bar @ portable) () = + let m = (module M : Empty) in + () +[%%expect{| +Line 2, characters 20-21: +2 | let m = (module M : Empty) in + ^ +Error: Modules are nonportable, so cannot be used inside a function that is portable. +|}] + +let m = (module M : S) +[%%expect{| +val m : (module S) = +|}] + +let (bar @ portable) () = + let module M' = (val m : Empty) in + () +[%%expect{| +Line 2, characters 25-26: +2 | let module M' = (val m : Empty) in + ^ +Error: The value "m" is nonportable, so cannot be used inside a function that is portable. +|}] + +(* CR zqian: this mode crossing should work *) +module M : sig + val x : int +end = struct + let x = 42 +end + +let (foo @ portable) () = + let _ = M.x in + () +[%%expect{| +module M : sig val x : int end +Line 8, characters 10-13: +8 | let _ = M.x in + ^^^ +Error: The value "M.x" is nonportable, so cannot be used inside a function that is portable. +|}] diff --git a/typing/env.ml b/typing/env.ml index b89c70c4885..05afafe143b 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -339,6 +339,12 @@ type lock = | Exclave_lock | Unboxed_lock (* to prevent capture of terms with non-value types *) +type locks = lock list + +let locks_empty = [] + +let locks_is_empty l = l = locks_empty + type lock_item = | Value | Module @@ -719,8 +725,14 @@ and module_data = mda_address : address_lazy; mda_shape: Shape.t; } +and module_alias_locks = locks + (** If the module is an alias for another module, this is the list of locks + from the original module to this module. This is accumulative: write + [module B = A;; module C = B;;], then [C] will record all locks from [A] + to [C]. Empty if not an alias. *) + and module_entry = - | Mod_local of module_data + | Mod_local of module_data * module_alias_locks | Mod_persistent | Mod_unbound of module_unbound_reason @@ -936,7 +948,7 @@ let diff env1 env2 = (* Functions for use in "wrap" parameters in IdTbl *) let wrap_identity x = x let wrap_value vda = Val_bound vda -let wrap_module mda = Mod_local mda +let wrap_module mda = Mod_local (mda, locks_empty) (* Forward declarations *) @@ -1239,7 +1251,7 @@ let check_functor_appl let find_ident_module id env = match find_same_module id env.modules with - | Mod_local data -> data + | Mod_local (data, _) -> data | Mod_unbound _ -> raise Not_found | Mod_persistent -> match Ident.to_global id with @@ -1529,7 +1541,7 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = end | Module -> begin match IdTbl.find_same_without_locks id env.modules with - | Mod_local { mda_shape; _ } -> mda_shape + | Mod_local ({ mda_shape; _ }, _) -> mda_shape | Mod_persistent -> Shape.for_persistent_unit (Ident.name id) | Mod_unbound _ -> (* Only present temporarily while approximating the environment for @@ -1765,7 +1777,7 @@ let iter_env wrap proj1 proj2 f env () = (fun id (path, entry) -> match entry with | Mod_unbound _ -> () - | Mod_local data -> + | Mod_local (data, _) -> iter_components (Pident id) path data.mda_components | Mod_persistent -> ()) env.modules; @@ -1811,7 +1823,7 @@ let rec find_shadowed_comps path env = List.filter_map (fun (p, data) -> match data with - | Mod_local x -> Some (p, x) + | Mod_local (x, _) -> Some (p, x) | Mod_unbound _ | Mod_persistent -> None) (IdTbl.find_all wrap_module (Ident.name id) env.modules) | Pdot (p, s) -> @@ -2077,7 +2089,7 @@ let rec components_of_module_maker NameMap.add (Ident.name id) mda c.comp_modules; env := store_module ~update_summary:false ~check:None - id addr pres md shape !env + id addr pres md shape locks_empty !env | Sig_modtype(id, decl, _) -> let final_decl = (* The prefixed items get the same scope as [cm_path], which is @@ -2352,7 +2364,7 @@ and store_extension ~check ~rebind id addr ext shape env = summary = Env_extension(env.summary, id, ext) } and store_module ?(update_summary=true) ~check - id addr presence md shape env = + id addr presence md shape alias_locks env = let open Subst.Lazy in let loc = md.md_loc in Option.iter @@ -2373,7 +2385,7 @@ and store_module ?(update_summary=true) ~check if not update_summary then env.summary else Env_module (env.summary, id, presence, force_module_decl md) in { env with - modules = IdTbl.add id (Mod_local mda) env.modules; + modules = IdTbl.add id (Mod_local (mda, alias_locks)) env.modules; summary } and store_modtype ?(update_summary=true) id info shape env = @@ -2466,7 +2478,7 @@ and add_extension ~check ?shape ~rebind id ext env = store_extension ~check ~rebind id addr ext shape env and add_module_declaration_lazy - ~update_summary ?(arg=false) ?shape ~check id presence md env = + ~update_summary ?(arg=false) ?shape ~check id presence md ?(locks = []) env = let check = if not check then None @@ -2478,13 +2490,13 @@ and add_module_declaration_lazy let addr = module_declaration_address env id presence md in let shape = shape_or_leaf md.Subst.Lazy.md_uid shape in let env = - store_module ~update_summary ~check id addr presence md shape env + store_module ~update_summary ~check id addr presence md shape locks env in if arg then add_functor_arg id env else env -let add_module_declaration ?(arg=false) ?shape ~check id presence md env = +let add_module_declaration ?(arg=false) ?shape ~check id presence md ?locks env = add_module_declaration_lazy ~update_summary:true ~arg ?shape ~check id - presence (Subst.Lazy.of_module_decl md) env + presence (Subst.Lazy.of_module_decl md) ?locks env and add_modtype_lazy ~update_summary ?shape id info env = let shape = shape_or_leaf info.Subst.Lazy.mtd_uid shape in @@ -2543,9 +2555,9 @@ let enter_extension ~scope ~rebind name ext env = let env = store_extension ~check:true ~rebind id addr ext shape env in (id, env) -let enter_module_declaration ~scope ?arg ?shape s presence md env = +let enter_module_declaration ~scope ?arg ?shape s presence md ?locks env = let id = Ident.create_scoped ~scope s in - (id, add_module_declaration ?arg ?shape ~check:true id presence md env) + (id, add_module_declaration ?arg ?shape ~check:true id presence md ?locks env) let enter_modtype ~scope name mtd env = let id = Ident.create_scoped ~scope name in @@ -2608,7 +2620,8 @@ module Add_signature(T : Types.Wrapped)(M : sig val add_value: ?shape:Shape.t -> mode:(Mode.allowed * 'r0) Mode.Value.t -> Ident.t -> T.value_description -> t -> t val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool - -> Ident.t -> module_presence -> T.module_declaration -> t -> t + -> Ident.t -> module_presence -> T.module_declaration -> ?locks:locks -> + t -> t val add_modtype: ?shape:Shape.t -> Ident.t -> T.modtype_declaration -> t -> t end) = struct open T @@ -2688,7 +2701,7 @@ let add_cltype = add_cltype ?shape:None let add_modtype_lazy = add_modtype_lazy ?shape:None let add_modtype = add_modtype ?shape:None let add_module_declaration_lazy ?(arg=false) = - add_module_declaration_lazy ~arg ?shape:None ~check:false + add_module_declaration_lazy ~arg ?shape:None ~check:false ?locks:None let add_signature sg env = let _, env = add_signature Shape.Map.empty None sg env in env @@ -3002,8 +3015,9 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = may_lookup_error errors loc env (Unbound_module (Lident s)) in match data with - | Mod_local mda -> begin + | Mod_local (mda, alias_locks) -> begin use_module ~use ~loc path mda; + let locks = alias_locks @ locks in match load with | Load -> path, locks, (mda : a) | Don't_load -> path, locks, (() : a) @@ -3568,37 +3582,27 @@ let open_signature (* General forms of the lookup functions *) -let walk_locks_for_module_lookup ~errors ~lock ~loc ~env ~lid locks = - if lock then - walk_locks ~errors ~loc ~env ~item:Module ~lid mda_mode None locks - else - mode_default mda_mode - -let lookup_module_path ~errors ~use ~lock ~loc ~load lid env : Path.t * _ = - let path, locks = - match lid with - | Lident s -> - if !Clflags.transparent_modules && not load then - let path, locks, _ = - lookup_ident_module Don't_load ~errors ~use ~loc s env - in - path, locks - else - let path, locks, _ = - lookup_ident_module Load ~errors ~use ~loc s env - in - path, locks - | Ldot(l, s) -> - let path, locks, _ = lookup_dot_module ~errors ~use ~loc l s env in +let lookup_module_path ~errors ~use ~loc ~load lid env = + match lid with + | Lident s -> + if !Clflags.transparent_modules && not load then + let path, locks, () = + lookup_ident_module Don't_load ~errors ~use ~loc s env + in path, locks - | Lapply _ as lid -> - let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in - Papply(path_f, path_arg), [] - in - let vmode = walk_locks_for_module_lookup ~errors ~lock ~loc ~lid ~env locks in - path, vmode + else + let path, locks, _ = + lookup_ident_module Load ~errors ~use ~loc s env + in + path, locks + | Ldot(l, s) -> + let path, locks, _ = lookup_dot_module ~errors ~use ~loc l s env in + path, locks + | Lapply _ as lid -> + let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in + Papply(path_f, path_arg), [] -let lookup_module_instance_path ~errors ~use ~lock ~loc ~load name env = +let lookup_module_instance_path ~errors ~use ~loc ~load name env = (* The locks are whatever locks we would find if we went through [lookup_module_path] on a module not found in the environment *) let locks = IdTbl.get_all_locks env.modules in @@ -3614,15 +3618,7 @@ let lookup_module_instance_path ~errors ~use ~lock ~loc ~load name env = in path in - let vmode = - let lid : Longident.t = - (* This is only used for error reporting. Probably in the long term we - want [Longident.t] to include instance names *) - Lident (name |> Global_module.Name.to_string) - in - walk_locks_for_module_lookup ~errors ~lock ~loc ~lid ~env locks - in - path, vmode + path, locks let lookup_value_lazy ~errors ~use ~loc lid env = match lid with @@ -3817,17 +3813,14 @@ let find_cltype_index id env = find_index_tbl id env.cltypes (* Ordinary lookup functions *) -let lookup_module_path ?(use=true) ?(lock=use) ~loc ~load lid env = - let path, vmode = - lookup_module_path ~errors:true ~use ~lock ~loc ~load lid env - in - path, vmode.mode +let walk_locks ~loc ~env ~item ~lid mode ty locks = + walk_locks ~errors:true ~loc ~env ~item ~lid mode ty locks -let lookup_module_instance_path ?(use=true) ?(lock=use) ~loc ~load lid env = - let path, vmode = - lookup_module_instance_path ~errors:true ~use ~lock ~loc ~load lid env - in - path, vmode.mode +let lookup_module_path ?(use=true) ~loc ~load lid env = + lookup_module_path ~errors:true ~use ~loc ~load lid env + +let lookup_module_instance_path ?(use=true) ~loc ~load lid env = + lookup_module_instance_path ~errors:true ~use ~loc ~load lid env let lookup_module ?(use=true) ?(lock=use) ~loc lid env = let path, desc, vmode = lookup_module ~errors:true ~use ~lock ~loc lid env in @@ -3987,7 +3980,7 @@ let fold_modules f lid env acc = (fun name (p, entry) acc -> match entry with | Mod_unbound _ -> acc - | Mod_local mda -> + | Mod_local (mda, _) -> let md = Subst.Lazy.force_module_decl mda.mda_declaration in diff --git a/typing/env.mli b/typing/env.mli index b1540ee1880..2cb293671aa 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -204,6 +204,12 @@ type shared_context = | Module | Probe +type locks + +val locks_empty : locks + +val locks_is_empty : locks -> bool + (** Items whose accesses are affected by locks *) type lock_item = | Value @@ -262,6 +268,13 @@ type actual_mode = { (** Explains why [mode] is high. *) } +(** Takes the [mode] and [ty] of a value at definition site, walks through the list of + locks and constrains [mode] and [ty]. Return the access mode of the value allowed by + the locks. [ty] is optional as the function works on modules and classes as well, for + which [ty] should be [None]. *) +val walk_locks : loc:Location.t -> env:t -> item:lock_item -> lid:Longident.t -> + Mode.Value.l -> type_expr option -> locks -> actual_mode + val lookup_value: ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t * value_description * actual_mode @@ -281,14 +294,16 @@ val lookup_cltype: ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration +(* When locks are returned instead of walked for modules, the mode remains as + defined (always legacy), and thus not returned. *) val lookup_module_path: - ?use:bool -> ?lock:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> - Path.t * Mode.Value.l + ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> + Path.t * locks val lookup_modtype_path: ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t val lookup_module_instance_path: - ?use:bool -> ?lock:bool -> loc:Location.t -> load:bool -> - Global_module.Name.t -> t -> Path.t * Mode.Value.l + ?use:bool -> loc:Location.t -> load:bool -> Global_module.Name.t -> t -> + Path.t * locks val lookup_constructor: ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> @@ -386,7 +401,7 @@ val add_module: ?arg:bool -> ?shape:Shape.t -> val add_module_lazy: update_summary:bool -> Ident.t -> module_presence -> Subst.Lazy.module_type -> t -> t val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> - Ident.t -> module_presence -> module_declaration -> t -> t + Ident.t -> module_presence -> module_declaration -> ?locks:locks -> t -> t val add_module_declaration_lazy: ?arg:bool -> update_summary:bool -> Ident.t -> module_presence -> Subst.Lazy.module_declaration -> t -> t val add_modtype: Ident.t -> modtype_declaration -> t -> t @@ -450,7 +465,7 @@ val enter_module: module_type -> t -> Ident.t * t val enter_module_declaration: scope:int -> ?arg:bool -> ?shape:Shape.t -> string -> module_presence -> - module_declaration -> t -> Ident.t * t + module_declaration -> ?locks:locks -> t -> Ident.t * t val enter_modtype: scope:int -> string -> modtype_declaration -> t -> Ident.t * t val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t diff --git a/typing/typecore.ml b/typing/typecore.ml index 307a968fd7f..fcc018534d4 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -300,7 +300,8 @@ let error_of_filter_arrow_failure ~explanation ~first ty_fun let type_module = ref ((fun _env _md -> assert false) : - Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) + Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t * + Env.locks) (* Forward declaration, to be filled in by Typemod.type_open *) @@ -1276,7 +1277,7 @@ let add_module_variables env module_variables = Here, on the other hand, we're calling [type_module] outside the raised level, so there's no extra step to take. *) - let modl, md_shape = + let modl, md_shape, locks = !type_module env Ast_helper.( Mod.unpack ~loc:mv_loc @@ -1294,7 +1295,9 @@ let add_module_variables env module_variables = md_loc = mv_name.loc; md_uid = mv_uid; } in - Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env + Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md + (* the [locks] is always empty, but typecore doesn't need to know *) + ~locks env end ) env module_variables_as_list @@ -6406,7 +6409,7 @@ and type_expect_ with_local_level begin fun () -> let modl, pres, id, new_env = Typetexp.TyVarEnv.with_local_scope begin fun () -> - let modl, md_shape = !type_module env smodl in + let modl, md_shape, locks = !type_module env smodl in Mtype.lower_nongen lv modl.mod_type; let pres = match modl.mod_type with @@ -6427,7 +6430,7 @@ and type_expect_ | Some name -> let id, env = Env.enter_module_declaration - ~scope ~shape:md_shape name pres md env + ~scope ~shape:md_shape name pres md ~locks env in Some id, env in diff --git a/typing/typecore.mli b/typing/typecore.mli index 36c34591889..35a4a6befa6 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -332,7 +332,8 @@ val report_error: loc:Location.t -> Env.t -> error -> Location.error (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: - (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) ref + (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t * + Env.locks) ref (* Forward declaration, to be filled in by Typemod.type_open *) val type_open: (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> diff --git a/typing/typemod.ml b/typing/typemod.ml index bd854508c27..53f28c525d7 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1608,7 +1608,7 @@ let transl_modtype_longident loc env lid = Env.lookup_modtype_path ~loc lid env let transl_module_alias loc env lid = - let path, _ = Env.lookup_module_path ~lock:false ~load:false ~loc lid env in + let path, _ = Env.lookup_module_path ~load:false ~loc lid env in path let mkmty desc typ env loc attrs = @@ -2600,18 +2600,41 @@ let maybe_infer_modalities ~loc ~env ~md_mode ~mode = Mode.Modality.Value.id end +type alias = + | No : alias + (** The module is in a context that doesn't treat aliases specially. *) + | Yes_hold_locks : alias + (** The module is in a context that treat alias specially. If it is indeed an + alias, the caller will hold the locks in the alias, and walk them when + later the alias is used for its content. *) + | Yes_walk_locks : alias + (** The module is in a context that treat alias specially. However, the caller + doesn't want to hold the locks, and therefore the locks must be eagerly + walked. *) + +let is_alias = function + | No -> false + | Yes_walk_locks | Yes_hold_locks -> true + let rec type_module ?(alias=false) sttn funct_body anchor env smod = + let alias = if alias then Yes_walk_locks else No in + let md, shape, locks = + type_module_maybe_hold_locks ~alias sttn funct_body anchor env smod + in + assert (Env.locks_is_empty locks); + md, shape + +and type_module_maybe_hold_locks ~alias sttn funct_body anchor env smod = Builtin_attributes.warning_scope smod.pmod_attributes (fun () -> type_module_aux ~alias sttn funct_body anchor env smod) and type_module_aux ~alias sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> - let path, mode = - Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env + let path, locks = + Env.lookup_module_path ~load:(not @@ is_alias alias) ~loc:smod.pmod_loc lid.txt env in - Mode.Value.submode_exn mode Mode.Value.legacy; - type_module_path_aux ~alias sttn env path lid smod + type_module_path_aux ~alias sttn env path locks lid smod | Pmod_structure sstr -> let (str, sg, names, shape, _finalenv) = type_structure funct_body anchor env sstr in @@ -2623,9 +2646,12 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_loc = smod.pmod_loc } in let sg' = Signature_names.simplify _finalenv names sg in - if List.length sg' = List.length sg then md, shape else - wrap_constraint_with_shape env false md - (Mty_signature sg') shape Tmodtype_implicit + let md, shape = + if List.length sg' = List.length sg then md, shape else + wrap_constraint_with_shape env false md + (Mty_signature sg') shape Tmodtype_implicit + in + md, shape, Env.locks_empty | Pmod_functor(arg_opt, sbody) -> let t_arg, ty_arg, newenv, funct_shape_param, funct_body = match arg_opt with @@ -2665,13 +2691,16 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_env = env; mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc }, - Shape.abs funct_shape_param body_shape + Shape.abs funct_shape_param body_shape, Env.locks_empty | Pmod_apply _ | Pmod_apply_unit _ -> - type_application smod.pmod_loc sttn funct_body env smod + let md, shape = type_application smod.pmod_loc sttn funct_body env smod in + md, shape, Env.locks_empty | Pmod_constraint(sarg, smty, smode) -> check_no_modal_modules ~env smode; let smty = Option.get smty in - let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in + let arg, arg_shape, locks = + type_module_maybe_hold_locks ~alias true funct_body anchor env sarg + in let mty = transl_modtype env smty in let md, final_shape = wrap_constraint_with_shape env true arg mty.mty_type arg_shape @@ -2681,7 +2710,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_loc = smod.pmod_loc; mod_attributes = smod.pmod_attributes; }, - final_shape + final_shape, locks | Pmod_unpack sexp -> let exp = Ctype.with_local_level_if_principal @@ -2714,27 +2743,38 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_env = env; mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc }, - Shape.leaf_for_unpack + Shape.leaf_for_unpack, Env.locks_empty | Pmod_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pmod_instance glob -> Language_extension.assert_enabled ~loc:smod.pmod_loc Instances (); let glob = instance_name ~loc:smod.pmod_loc env glob in - let path, mode = - Env.lookup_module_instance_path ~load:(not alias) ~loc:smod.pmod_loc + let path, locks = + Env.lookup_module_instance_path ~load:(not @@ is_alias alias) ~loc:smod.pmod_loc glob env in - Mode.Value.submode_exn mode Mode.Value.legacy; let lid = (* Only used by [untypeast] *) let name = Format.asprintf "*instance %a*" Global_module.Name.print glob in - Lident name |> Location.mknoloc + Location.(mkloc (Lident name) (ghostify smod.pmod_loc)) in - type_module_path_aux ~alias sttn env path lid smod - -and type_module_path_aux ~alias sttn env path lid smod = + type_module_path_aux ~alias sttn env path locks lid smod + +and type_module_path_aux ~alias sttn env path locks (lid : _ loc) smod = + let locks = + match alias with + | Yes_hold_locks -> locks + | No | Yes_walk_locks -> + let vmode = + Env.walk_locks ~loc:lid.loc ~env ~item:Module ~lid:lid.txt + Mode.Value.(legacy |> disallow_right) None locks + in + Mode.Value.submode_exn vmode.mode Mode.Value.legacy; + Env.locks_empty + in + let alias = is_alias alias in let md = { mod_desc = Tmod_ident (path, lid); mod_type = Mty_alias path; mod_env = env; @@ -2766,7 +2806,7 @@ and type_module_path_aux ~alias sttn env path lid smod = { md with mod_type = mty } end in - md, shape + md, shape, locks and type_application loc strengthen funct_body env smod = let rec extract_application funct_body env sargs smod = @@ -3462,7 +3502,8 @@ let type_toplevel_phrase env sig_acc s = Typecore.optimise_allocations (); (str, sg, to_remove_from_sg, shape, env) -let type_module_alias = type_module ~alias:true true false None +let type_module_alias = + type_module_maybe_hold_locks ~alias:Yes_hold_locks true false None let type_module = type_module true false None let type_structure = type_structure false None