flambda-backend: Use Global_module.Name.t to stand for a global mod…

…ule identifier (ocaml-flambda#1872)

driver/compile_common.ml

@@ -90,7 +90,7 @@ let emit_signature info alerts tsg =
       else begin
         let cmi_arg_for =
           match !Clflags.as_argument_for with
-          | Some arg_type -> Some (Compilation_unit.Name.of_string arg_type)
+          | Some arg_type -> Some (Global_module.Name.create arg_type [])
           | None -> None
         in
         Normal { cmi_impl = info.module_name; cmi_arg_for }

file_formats/cmi_format.ml

@@ -23,7 +23,7 @@ type pers_flags =
 type kind =
   | Normal of {
       cmi_impl : Compilation_unit.t;
-      cmi_arg_for : Compilation_unit.Name.t option;
+      cmi_arg_for : Global_module.Name.t option;
     }
   | Parameter
 
@@ -64,14 +64,14 @@ type header = {
     header_name : Compilation_unit.Name.t;
     header_kind : kind;
     header_sign : Serialized.signature;
-    header_params : Compilation_unit.Name.t list;
+    header_params : Global_module.Name.t list;
 }
 
 type 'sg cmi_infos_generic = {
     cmi_name : Compilation_unit.Name.t;
     cmi_kind : kind;
     cmi_sign : 'sg;
-    cmi_params : Compilation_unit.Name.t list;
+    cmi_params : Global_module.Name.t list;
     cmi_crcs : crcs;
     cmi_flags : flags;
 }

file_formats/cmi_format.mli

@@ -25,15 +25,15 @@ type kind =
       cmi_impl : Compilation_unit.t;
         (* If this module takes parameters, [cmi_impl] will be the functor that
            generates instances *)
-      cmi_arg_for : Compilation_unit.Name.t option;
+      cmi_arg_for : Global_module.Name.t option;
     }
   | Parameter
 
 type 'sg cmi_infos_generic = {
     cmi_name : Compilation_unit.Name.t;
     cmi_kind : kind;
     cmi_sign : 'sg;
-    cmi_params : Compilation_unit.Name.t list;
+    cmi_params : Global_module.Name.t list;
     cmi_crcs : Import_info.t array;
     cmi_flags : pers_flags list;
 }

middle_end/compilenv.ml

@@ -35,10 +35,12 @@ type error =
 
 exception Error of error
 
+module Infos_table = Global.Name.Tbl
+
 let global_infos_table =
-  (CU.Name.Tbl.create 17 : unit_infos option CU.Name.Tbl.t)
+  (Infos_table.create 17 : unit_infos option Infos_table.t)
 let export_infos_table =
-  (CU.Name.Tbl.create 10 : Export_info.t CU.Name.Tbl.t)
+  (Infos_table.create 10 : Export_info.t Infos_table.t)
 
 let imported_sets_of_closures_table =
   (Set_of_closures_id.Tbl.create 10
@@ -94,6 +96,11 @@ let current_unit =
 
 <<<<<<< HEAD
 let reset compilation_unit =
+<<<<<<< HEAD
+  Infos_table.clear global_infos_table;
+||||||| a54ec041ff
+  CU.Name.Tbl.clear global_infos_table;
+=======
   CU.Name.Tbl.clear global_infos_table;
 ||||||| 121bedcfd2
 let concat_symbol unitname id =
@@ -145,6 +152,7 @@ let current_unit_linkage_name () =
 let reset ?packname name =
   Hashtbl.clear global_infos_table;
 >>>>>>> 5.2.0
+>>>>>>> upstream/main
   Set_of_closures_id.Tbl.clear imported_sets_of_closures_table;
   CU.set_current (Some compilation_unit);
   current_unit.ui_unit <- compilation_unit;
@@ -159,7 +167,7 @@ let reset ?packname name =
   structured_constants := structured_constants_empty;
   current_unit.ui_export_info <- default_ui_export_info;
   merged_environment := Export_info.empty;
-  CU.Name.Tbl.clear export_infos_table
+  Infos_table.clear export_infos_table
 
 let current_unit_infos () =
   current_unit
@@ -192,14 +200,25 @@ let read_library_info filename =
 (* Read and cache info on global identifiers *)
 
 <<<<<<< HEAD
+let equal_args (name1, value1) (name2, value2) =
+  CU.equal name1 name2 && CU.equal value1 value2
+
+let equal_up_to_pack_prefix cu1 cu2 =
+  CU.Name.equal (CU.name cu1) (CU.name cu2)
+  && List.equal equal_args (CU.instance_arguments cu1) (CU.instance_arguments cu2)
+
+||||||| a54ec041ff
+=======
+<<<<<<< HEAD
+>>>>>>> upstream/main
 let get_unit_info comp_unit =
   (* If this fails, it likely means that someone didn't call
      [CU.which_cmx_file]. *)
   assert (CU.can_access_cmx_file comp_unit ~accessed_by:current_unit.ui_unit);
   (* CR lmaurer: Surely this should just compare [comp_unit] to
      [current_unit.ui_unit], but doing so seems to break Closure. We should fix
      that. *)
-  if CU.Name.equal (CU.name comp_unit) (CU.name current_unit.ui_unit)
+  if equal_up_to_pack_prefix comp_unit current_unit.ui_unit
   then
 ||||||| 121bedcfd2
 let get_global_info global_ident = (
@@ -218,22 +237,28 @@ let get_global_info global_ident = (
 >>>>>>> 5.2.0
     Some current_unit
   else begin
-    let cmx_name = CU.name comp_unit in
+    let name = CU.to_global_name_without_prefix comp_unit in
     try
-      CU.Name.Tbl.find global_infos_table cmx_name
+      Infos_table.find global_infos_table name
     with Not_found ->
       let (infos, crc) =
-        if Env.is_imported_opaque cmx_name then (None, None)
+        if Env.is_imported_opaque (CU.name comp_unit) then (None, None)
         else begin
           try
             let filename =
+<<<<<<< HEAD
+              Load_path.find_uncap (CU.base_filename comp_unit ^ ".cmx") in
+||||||| a54ec041ff
+              Load_path.find_uncap ((cmx_name |> CU.Name.to_string) ^ ".cmx") in
+=======
 <<<<<<< HEAD
               Load_path.find_uncap ((cmx_name |> CU.Name.to_string) ^ ".cmx") in
 ||||||| 121bedcfd2
               Load_path.find_uncap (modname ^ ".cmx") in
 =======
               Load_path.find_normalized (modname ^ ".cmx") in
 >>>>>>> 5.2.0
+>>>>>>> upstream/main
             let (ui, crc) = read_unit_info filename in
             if not (CU.equal ui.ui_unit comp_unit) then
               raise(Error(Illegal_renaming(comp_unit, ui.ui_unit, filename)));
@@ -263,15 +288,15 @@ let get_global_info global_ident = (
                         (filename, p1, CU.name current_unit.ui_unit, p2))));
             (Some ui, Some crc)
           with Not_found ->
-            let warn = Warnings.No_cmx_file (cmx_name |> CU.Name.to_string) in
+            let warn = Warnings.No_cmx_file (Global.Name.to_string name) in
               Location.prerr_warning Location.none warn;
               (None, None)
           end
       in
       let import = Import_info.create_normal comp_unit ~crc in
       current_unit.ui_imports_cmx <-
         Array.append [| import |] current_unit.ui_imports_cmx;
-      CU.Name.Tbl.add global_infos_table cmx_name infos;
+      Infos_table.add global_infos_table name infos;
       infos
   end
 
@@ -282,7 +307,8 @@ let get_global_info global_ident =
   get_unit_info (which_cmx_file global_ident)
 
 let cache_unit_info ui =
-  CU.Name.Tbl.add global_infos_table (CU.name ui.ui_unit) (Some ui)
+  Infos_table.add global_infos_table
+    (ui.ui_unit |> CU.to_global_name_without_prefix) (Some ui)
 
 (* Return the approximation of a global identifier *)
 
@@ -329,15 +355,15 @@ let approx_for_global comp_unit =
   if CU.equal comp_unit CU.predef_exn
   then invalid_arg "approx_for_global with predef_exn compilation unit";
   let accessible_comp_unit = which_cmx_file comp_unit in
-  let cmx_name = CU.name accessible_comp_unit in
-  match CU.Name.Tbl.find export_infos_table cmx_name with
+  let name = accessible_comp_unit |> CU.to_global_name_without_prefix in
+  match Infos_table.find export_infos_table name with
   | otherwise -> Some otherwise
   | exception Not_found ->
     match get_unit_info accessible_comp_unit with
     | None -> None
     | Some ui ->
       let exported = get_flambda_export_info ui in
-      CU.Name.Tbl.add export_infos_table cmx_name exported;
+      Infos_table.add export_infos_table name exported;
       merged_environment := Export_info.merge !merged_environment exported;
       Some exported
 

otherlibs/dynlink/dune

@@ -103,6 +103,7 @@
   ast_mapper
   attr_helper
   builtin_attributes
+  global_module
   ident
   path
   shape
@@ -260,6 +261,8 @@
 
 (copy_files ../../parsing/builtin_attributes.ml)
 
+(copy_files ../../typing/global_module.ml)
+
 (copy_files ../../typing/ident.ml)
 
 (copy_files ../../typing/path.ml)
@@ -412,6 +415,8 @@
 
 (copy_files ../../parsing/builtin_attributes.mli)
 
+(copy_files ../../typing/global_module.mli)
+
 (copy_files ../../typing/ident.mli)
 
 (copy_files ../../typing/path.mli)
@@ -559,6 +564,7 @@
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Language_extension.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Terminfo.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Location.cmo
+  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Global_module.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ident.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Longident.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Compilation_unit.cmo
@@ -654,6 +660,7 @@
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Language_extension.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Terminfo.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Location.cmx
+  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Global_module.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ident.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Longident.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Compilation_unit.cmx

testsuite/tests/tool-toplevel/pr6468.compilers.reference

@@ -8,18 +8,18 @@ Warning 21 [nonreturning-statement]: this statement never returns (or has an uns
 val g : unit -> int = <fun>
 Exception: Not_found.
 Raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25
-Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1274, characters 8-48
-Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 297, characters 6-21
+Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1275, characters 8-48
+Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 309, characters 6-21
 Called from Env.IdTbl.find_same_without_locks in file "ocaml/typing/env.ml", line 428, characters 10-40
 Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25
-Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1274, characters 8-48
-Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 297, characters 6-21
+Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1275, characters 8-48
+Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 309, characters 6-21
 Called from Env.IdTbl.find_same_without_locks in file "ocaml/typing/env.ml", line 428, characters 10-40
 Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25
-Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1274, characters 8-48
-Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 297, characters 6-21
+Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1275, characters 8-48
+Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 309, characters 6-21
 Called from Env.IdTbl.find_same_without_locks in file "ocaml/typing/env.ml", line 428, characters 10-40
-Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 297, characters 6-21
+Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 309, characters 6-21
 Called from Translmod.toplevel_name in file "ocaml/lambda/translmod.ml", line 1599, characters 6-40
 Re-raised at Stdlib__Hashtbl.find in file "hashtbl.ml", line 547, characters 13-28
 Called from Simplif.simplify_lets.simplif in file "ocaml/lambda/simplif.ml", line 571, characters 8-28

tools/Makefile

@@ -87,6 +87,7 @@ OCAMLPROF=config.cmo build_path_prefix_map.cmo misc.cmo identifiable.cmo \
   debug.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
   syntaxerr.cmo ast_helper.cmo \
+  global_module.cmo \
   language_extension_kernel.cmo language_extension.cmo \
   jane_syntax_parsing.cmo jane_syntax.cmo \
    ast_iterator.cmo zero_alloc_utils.cmo builtin_attributes.cmo \

typing/env.ml

@@ -1028,7 +1028,7 @@ let components_of_module ~alerts ~uid env ps path addr mty shape =
   }
 
 let read_sign_of_cmi sign name uid ~shape ~address:addr ~flags =
-  let id = Ident.create_persistent (Compilation_unit.Name.to_string name) in
+  let id = Ident.create_global name in
   let path = Pident id in
   let alerts =
     List.fold_left (fun acc -> function Alerts s -> s | _ -> acc)
@@ -1165,15 +1165,16 @@ let check_functor_appl
       ~arg_path ~arg_mty ~arg_mode ~param_mty
       env
 
-let modname_of_ident id = Ident.name id |> Compilation_unit.Name.of_string
-
 (* Lookup by identifier *)
 
 let find_ident_module id env =
   match find_same_module id env.modules with
   | Mod_local data -> data
   | Mod_unbound _ -> raise Not_found
-  | Mod_persistent -> find_pers_mod ~allow_hidden:true (id |> modname_of_ident)
+  | Mod_persistent ->
+      match Ident.to_global id with
+      | Some global_name -> find_pers_mod ~allow_hidden:true global_name
+      | None -> Misc.fatal_errorf "Not global: %a" Ident.print id
 
 let rec find_module_components path env =
   match path with
@@ -1623,14 +1624,17 @@ let make_copy_of_types env0 =
 type iter_cont = unit -> unit
 let iter_env_cont = ref []
 
+let global_ident_is_looked_up id =
+  Persistent_env.looked_up !persistent_env (Ident.to_global_exn id)
+
 let rec scrape_alias_for_visit env mty =
   let open Subst.Lazy in
   match mty with
   | Mty_alias path -> begin
       match path with
       | Pident id
         when Ident.is_global id
-          && not (Persistent_env.looked_up !persistent_env (id |> modname_of_ident)) ->
+          && not (global_ident_is_looked_up id) ->
           false
       | path -> (* PR#6600: find_module may raise Not_found *)
           try
@@ -1672,7 +1676,7 @@ let iter_env wrap proj1 proj2 f env () =
        | Mod_persistent -> ())
     env.modules;
   Persistent_env.fold !persistent_env (fun name data () ->
-    let id = Ident.create_persistent (Compilation_unit.Name.to_string name) in
+    let id = Ident.create_global name in
     let path = Pident id in
     iter_components path path data.mda_components) ()
 
@@ -1692,7 +1696,10 @@ let same_types env1 env2 =
 
 let used_persistent () =
   Persistent_env.fold !persistent_env
-    (fun s _m r -> Compilation_unit.Name.Set.add s r)
+    (fun s _m r ->
+       Compilation_unit.Name.Set.add
+         (s |> Compilation_unit.Name.of_head_of_global_name)
+         r)
     Compilation_unit.Name.Set.empty
 
 let find_all_comps wrap proj s (p, mda) =
@@ -3013,7 +3020,8 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
   | Mod_unbound reason ->
       report_module_unbound ~errors ~loc env reason
   | Mod_persistent -> begin
-      let name = s |> Compilation_unit.Name.of_string in
+      (* Currently there are never instance arguments *)
+      let name = Global_module.Name.create s [] in
       match load with
       | Don't_load ->
           check_pers_mod ~allow_hidden:false ~loc name;
@@ -3705,7 +3713,7 @@ let bound_module name env =
       else begin
         match
           find_pers_mod ~allow_hidden:false
-            (name |> Compilation_unit.Name.of_string)
+            (Global_module.Name.create name [])
         with
         | _ -> true
         | exception Not_found -> false
@@ -3789,7 +3797,12 @@ let fold_modules f lid env acc =
                in
                f name p md acc
            | Mod_persistent ->
-               let modname = name |> Compilation_unit.Name.of_string in
+               (* CR lmaurer: Setting instance args to [] here isn't right. We
+                  really should have [IdTbl.fold_name] provide the whole ident
+                  rather than just the name. It looks like the only immediate
+                  consequence of this is that spellcheck won't suggest
+                  instance names (which is good!). *)
+               let modname = Global_module.Name.create name [] in
                match Persistent_env.find_in_cache !persistent_env modname with
                | None -> acc
                | Some mda ->
@@ -3856,7 +3869,9 @@ let filter_non_loaded_persistent f env =
          | Mod_local _ -> acc
          | Mod_unbound _ -> acc
          | Mod_persistent ->
-             let modname = name |> Compilation_unit.Name.of_string in
+             (* CR lmaurer: Again, setting args to [] here is weird but fine
+                for the moment *)
+             let modname = Global_module.Name.create name [] in
              match Persistent_env.find_in_cache !persistent_env modname with
              | Some _ -> acc
              | None ->