module aliases hold locks instead of walking them

Author: riaqn

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
   ()

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.

testsuite/tests/typing-modes/module.ml

@@ -198,36 +198,55 @@ module type S = sig val foo : 'a -> 'a val baz : 'a -> 'a @@ portable end
 module M : S
 |}]
 
-(* CR zqian: fix the following. *)
 let (bar @ portable) () =
     let module N = M in
     M.baz ();
     N.baz ()
 [%%expect{|
-Line 2, characters 19-20:
-2 |     let module N = M in
-                       ^
-Error: Modules are nonportable, so cannot be used inside a function that is portable.
+val bar : unit -> unit = <fun>
 |}]
 
 let (bar @ portable) () =
     let module N = M in
     N.foo ()
 [%%expect{|
-Line 2, characters 19-20:
-2 |     let module N = M in
-                       ^
-Error: Modules are nonportable, so cannot be used inside a function that is portable.
+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 2, characters 19-20:
-2 |     let module N = M in
-                       ^
-Error: Modules are nonportable, so cannot be used inside a function that is portable.
+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 = <fun>
+|}]
+
+(* 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. *)

typing/env.ml

@@ -719,8 +719,14 @@ and module_data =
     mda_address : address_lazy;
     mda_shape: Shape.t; }
 
+and module_alias_locks = lock list
+  (** 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 +942,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, [])
 
 (* Forward declarations *)
 
@@ -1239,7 +1245,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 +1535,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 +1771,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 +1817,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 +2083,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 [] !env
         | Sig_modtype(id, decl, _) ->
             let final_decl =
               (* The prefixed items get the same scope as [cm_path], which is
@@ -2352,7 +2358,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 +2379,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 +2472,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 +2484,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 +2549,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 +2614,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:lock list ->
+    t -> t
   val add_modtype: ?shape:Shape.t -> Ident.t -> T.modtype_declaration -> t -> t
 end) = struct
   open T
@@ -2688,7 +2695,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
@@ -3001,8 +3008,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)
@@ -3572,7 +3580,7 @@ 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, _ =
+          let path, locks, () =
             lookup_ident_module Don't_load ~errors ~use ~loc s env
           in
           path, locks
@@ -3968,7 +3976,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

typing/env.mli

@@ -403,7 +403,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:lock list -> 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
@@ -467,7 +467,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:lock list -> 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

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.lock list)
 
 (* Forward declaration, to be filled in by Typemod.type_open *)
 
@@ -1273,7 +1274,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
@@ -1291,7 +1292,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
 
@@ -6401,7 +6404,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
@@ -6422,7 +6425,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

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.lock list) ref
 (* Forward declaration, to be filled in by Typemod.type_open *)
 val type_open:
   (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->