Don't load transitive deps eagerly

Instead, check in [canonize_t] before writing a module if a foreign
module is used in polymorphic functions. If it is, load it

lib/module.ml

@@ -20,23 +20,28 @@ and item =
 
 and sg_kind = Stypedef | Svalue
 and sig_item = string * loc * typ * sg_kind [@@deriving sexp]
-and t = { s : sig_item list; i : item list; objects : string list }
 
-type cache_kind = Cfile of string | Clocal of Path.t
+and t = {
+  s : sig_item list;
+  i : item list;
+  objects : (string * bool (* transitive dep needs load *)) list;
+}
+
+type cache_kind = Cfile of string * bool | Clocal of Path.t
 
 let t_of_sexp s =
   triple_of_sexp
     (list_of_sexp sig_item_of_sexp)
     (list_of_sexp item_of_sexp)
-    (list_of_sexp string_of_sexp)
+    (list_of_sexp (pair_of_sexp string_of_sexp bool_of_sexp))
     s
   |> fun (s, i, objects) -> { s; i; objects }
 
 let sexp_of_t m =
   sexp_of_triple
     (sexp_of_list sexp_of_sig_item)
     (sexp_of_list sexp_of_item)
-    (sexp_of_list sexp_of_string)
+    (sexp_of_list (sexp_of_pair sexp_of_string sexp_of_bool))
     (m.s, m.i, m.objects)
 
 type cached =
@@ -80,7 +85,7 @@ let add_module_alias loc key mname ~into =
   let filename =
     match Hashtbl.find_opt module_cache mname with
     | None | Some (Cached (Clocal _, _, _)) -> None
-    | Some (Cached (Cfile f, _, _) | Located (f, _, _)) -> Some f
+    | Some (Cached (Cfile (f, _), _, _) | Located (f, _, _)) -> Some f
   in
   { into with i = Mmodule_alias (loc, key, mname, filename) :: into.i }
 
@@ -241,9 +246,20 @@ and change_name id nsub =
   match Smap.find_opt id nsub with None -> id | Some name -> name
 
 and canonexpr mname nsub sub = function
-  | Typed_tree.Var id ->
+  | Typed_tree.Var (id, m) ->
       let id = change_name id nsub in
-      (sub, Var id)
+      (match m with
+      | Some m when not (Path.share_base mname m) -> (
+          (* Make sure this is eagerly loaded on use *)
+          match Hashtbl.find_opt module_cache m with
+          | None | Some (Located _ | Cached (Clocal _, _, _)) ->
+              failwith "unreachable what is this module's path?"
+          | Some (Cached (Cfile (_, true), _, _)) -> ()
+          | Some (Cached (Cfile (name, false), scope, md)) ->
+              Hashtbl.replace module_cache m
+                (Cached (Cfile (name, true), scope, md)))
+      | None | Some _ -> ());
+      (sub, Var (id, m))
   | Const (Array a) ->
       let sub, a = List.fold_left_map (canonbody mname nsub) sub a in
       (sub, Const (Array a))
@@ -421,7 +437,6 @@ let rec map_item ~mname ~f = function
       (* Change name of poly func to module-unique name to prevent name clashes from
          different modules *)
       let item = (mname, Typed_tree.Tl_function (l, n, u, abs)) in
-      if String.contains (Path.show mname) '.' then failwith "hhh";
       poly_funcs := item :: !poly_funcs;
       (* This will be ignored in [add_to_env] *)
       Mpoly_fun (l, abs, n, u)
@@ -494,7 +509,9 @@ and canonize_t mname m =
   in
   { m with s; i }
 
-let modpath_of_kind = function Clocal p -> p | Cfile name -> Path.Pid name
+let modpath_of_kind = function
+  | Clocal p -> p
+  | Cfile (name, _) -> Path.Pid name
 
 let envmodule_of_cached path = function
   | Located _ -> Env.Cm_located path
@@ -620,12 +637,14 @@ and module_name_of_path p =
 
 and load_dep_modules env fname loc objects ~regeneralize =
   List.iter
-    (fun name ->
-      let mname = Path.Pid (module_name_of_path name) in
-      if Hashtbl.mem module_cache mname then ()
-      else
-        let filename = make_path fname name in
-        read_module env filename loc ~regeneralize mname |> ignore)
+    (fun (name, load) ->
+      if load then
+        let mname = Path.Pid (module_name_of_path name) in
+        if Hashtbl.mem module_cache mname then ()
+        else
+          let filename = make_path fname name in
+          read_module env filename loc ~regeneralize mname |> ignore
+      else ())
     objects
 
 and read_module env filename loc ~regeneralize mname =
@@ -637,7 +656,9 @@ and read_module env filename loc ~regeneralize mname =
         (* Load transitive modules. The interface files are the same as object files *)
         load_dep_modules env filename loc t.objects ~regeneralize;
         add_object_names filename t.objects;
-        let kind, m = (Cfile filename, map_t ~mname ~f:regeneralize t) in
+        let kind, m =
+          (Cfile (filename, false), map_t ~mname ~f:regeneralize t)
+        in
         (* Make module scope *)
         let scope =
           make_scope env loc (Some (filename, regeneralize)) mname m
@@ -653,7 +674,7 @@ and read_module env filename loc ~regeneralize mname =
 and add_object_names fname objects =
   let objs =
     List.fold_left
-      (fun set name ->
+      (fun set (name, _) ->
         let o = make_path fname name ^ ".o" in
         Sset.add o set)
       Sset.empty objects
@@ -707,7 +728,7 @@ let object_names () =
     Hashtbl.fold
       (fun _ cached set ->
         match cached with
-        | Cached (Cfile name, _, _) -> Sset.add (name ^ ".o") set
+        | Cached (Cfile (name, _), _, _) -> Sset.add (name ^ ".o") set
         | Cached (Clocal _, _, _) -> set
         | Located _ -> set)
       module_cache Sset.empty
@@ -717,20 +738,21 @@ let object_names () =
 let rev { s; i; objects } = { s = List.rev s; i = List.rev i; objects }
 
 let to_channel c ~outname m =
+  let module Smap = Map.Make (String) in
+  let m = rev m |> canonize_t (Path.Pid outname) in
+  (* Correct objects only exist after [canonize_t] *)
   let objects =
     Hashtbl.fold
       (fun _ cached set ->
         match cached with
-        | Cached (Cfile name, _, _) ->
+        | Cached (Cfile (name, load), _, _) ->
             if String.ends_with ~suffix:"std" name then set
-            else Sset.add (normalize_path name) set
+            else Smap.add (normalize_path name) load set
         | _ -> set)
-      module_cache Sset.empty
-    |> Sset.to_seq |> List.of_seq
+      module_cache Smap.empty
+    |> Smap.to_seq |> List.of_seq
   in
-  rev { m with objects }
-  |> canonize_t (Path.Pid outname)
-  |> sexp_of_t |> Sexp.to_channel c
+  { m with objects } |> sexp_of_t |> Sexp.to_channel c
 
 let extract_name_type env = function
   | Mtype (l, t) -> (

lib/monomorph_tree.ml

@@ -1081,7 +1081,7 @@ let rec morph_expr param (texpr : Typed_tree.typed_expr) =
     { typ = cln param texpr.typ; expr; return; loc = texpr.loc }
   in
   match texpr.expr with
-  | Typed_tree.Var v -> morph_var make param v
+  | Typed_tree.Var (v, _) -> morph_var make param v
   | Const (String s) -> morph_string make param s
   | Const (Array a) -> morph_array make param a (cln param texpr.typ)
   | Const c -> (param, make (Mconst (morph_const c)) false, no_var)
@@ -1126,7 +1126,11 @@ let rec morph_expr param (texpr : Typed_tree.typed_expr) =
       let p = List.fold_left rec_fs_to_env param decls in
       morph_expr p cont
   | Lambda (id, abs) -> morph_lambda make texpr.typ param id abs
-  | App { callee = { expr = Var id; _ }; args = [ ({ expr = Fmt es; _ }, _) ] }
+  | App
+      {
+        callee = { expr = Var (id, _); _ };
+        args = [ ({ expr = Fmt es; _ }, _) ];
+      }
     when String.equal id
            (Module.absolute_module_name ~mname:(Path.Pid "std") "print") ->
       morph_print_str make param es

lib/typing/exclusivity.ml

@@ -260,7 +260,7 @@ let rec check_exclusivity loc borrow hist =
 
 let make_copy_call loc tree =
   let typ = Tfun ([ { pattr = Dnorm; pt = tree.typ } ], tree.typ, Simple) in
-  let callee = { typ; attr = no_attr; loc; expr = Var "__copy" } in
+  let callee = { typ; attr = no_attr; loc; expr = Var ("__copy", None) } in
   let expr = App { callee; args = [ (tree, Dnorm) ] } in
   { tree with attr = { tree.attr with const = false }; expr }
 
@@ -356,7 +356,8 @@ let rec check_excl_chain loc env borrow hist =
 and check_excl_chains loc env borrow hist =
   List.iter (fun b -> check_excl_chain loc env b hist) borrow
 
-let make_var loc name typ = { typ; expr = Var name; attr = no_attr; loc }
+let make_var loc name typ =
+  { typ; expr = Var (name, None); attr = no_attr; loc }
 
 let binding_of_borrow borrow = function
   | Usage.Uread -> Borrow borrow
@@ -389,7 +390,7 @@ let move_b loc special b =
 
 let rec check_tree env mut ((bpart, special) as bdata) tree hist =
   match tree.expr with
-  | Var borrowed ->
+  | Var (borrowed, _) ->
       (* This is no rvalue, we borrow *)
       let bid = get_id borrowed in
       let loc = tree.loc in
@@ -558,8 +559,10 @@ let rec check_tree env mut ((bpart, special) as bdata) tree hist =
       let expr = Sequence (fst, snd) in
       ({ tree with expr }, v, hs)
   | App
-      { callee = { expr = Var "array-get"; _ } as callee; args = [ arr; idx ] }
-    ->
+      {
+        callee = { expr = Var ("array-get", None); _ } as callee;
+        args = [ arr; idx ];
+      } ->
       (* Special case for array-get *)
       (* Partial moves for arrays are not yet supported in monomorph_tree, so we
          do not allow them as a temporary workaround *)
@@ -607,7 +610,7 @@ let rec check_tree env mut ((bpart, special) as bdata) tree hist =
           args
       in
       (* Check again to ensure exclusivity of arguments and closure *)
-      let c = { callee with expr = Var "_env" } in
+      let c = { callee with expr = Var ("_env", None) } in
       check_tree tmp Uread no_bdata c hs |> ignore;
       List.iteri
         (fun i (arg, attr) ->
@@ -616,7 +619,8 @@ let rec check_tree env mut ((bpart, special) as bdata) tree hist =
               (* Moved values can't have been used later *)
               ()
           | u ->
-              let arg = { arg with expr = Var ("_" ^ string_of_int i) } in
+              let expr = Var ("_" ^ string_of_int i, None) in
+              let arg = { arg with expr } in
               check_tree tmp u no_bdata arg hs |> ignore)
         args;
       let expr = App { callee; args } in

lib/typing/path.ml

@@ -71,6 +71,14 @@ let rec append name = function
   | Pid n -> Pmod (n, Pid name)
   | Pmod (n, tl) -> Pmod (n, append name tl)
 
+let share_base l r =
+  match (l, r) with
+  | Pid l, Pid r
+  | Pmod (l, _), Pid r
+  | Pmod (l, _), Pmod (r, _)
+  | Pid l, Pmod (r, _) ->
+      String.equal l r
+
 let rec pop = function
   | Pid _ as p -> p
   | Pmod (n, Pid _) -> Pid n

lib/typing/typed_tree.ml

@@ -14,7 +14,7 @@ end
 type loc = Show.pos * Show.pos [@@deriving show, sexp]
 
 type expr =
-  | Var of string
+  | Var of string * Path.t option
   | Const of const
   | Bop of Ast.bop * typed_expr * typed_expr
   | Unop of Ast.unop * typed_expr

lib/typing/typing.ml

@@ -548,7 +548,7 @@ let rec wrap_in_lambda texpr = function
             let texpr =
               {
                 typ = p.pt;
-                expr = Var (pn i 0);
+                expr = Var (pn i 0, None);
                 attr = { no_attr with mut };
                 loc = texpr.loc;
               }
@@ -645,7 +645,7 @@ end = struct
               assert (Path.is_local id);
               Path.get_hd id
         in
-        { typ; expr = Var id; attr; loc }
+        { typ; expr = Var (id, t.imported); attr; loc }
     | None ->
         let suff =
           match Env.find_module_opt loc id env with