flambda-backend: Support getting paths from -libloc flags (#2482)

* Make [Load_path.Dir] store full paths

* Add arguments

* Reading libloc

* Change format to '-libloc path:libs:hidden_libs' and allow multiple flags

* Fix splitting library names

* Fix typo

* Fix closing of libloc file

* .depend and makefile fixes

* Review changes

.depend

@@ -180,11 +180,13 @@ utils/load_path.cmo : \
     utils/misc.cmi \
     utils/local_store.cmi \
     utils/config.cmi \
+    utils/clflags.cmi \
     utils/load_path.cmi
 utils/load_path.cmx : \
     utils/misc.cmx \
     utils/local_store.cmx \
     utils/config.cmx \
+    utils/clflags.cmx \
     utils/load_path.cmi
 utils/load_path.cmi :
 utils/local_store.cmo : \

Makefile

@@ -1466,13 +1466,13 @@ tools/ocamldep$(EXE): OC_BYTECODE_LINKFLAGS += -compat-32
 ocamlprof_LIBRARIES =
 ocamlprof_MODULES = \
   config build_path_prefix_map misc identifiable numbers arg_helper \
-  local_store load_path zero_alloc_annotations clflags terminfo warnings \
+  local_store  zero_alloc_annotations clflags load_path terminfo warnings \
   location longident docstrings syntaxerr ast_helper camlinternalMenhirLib \
   parser pprintast lexer parse ocamlprof
 
 ocamlcp_ocamloptp_MODULES = \
   config build_path_prefix_map misc profile warnings identifiable numbers \
-  arg_helper local_store load_path zero_alloc_annotations clflags terminfo \
+  arg_helper local_store zero_alloc_annotations clflags load_path terminfo \
   location ccomp compenv main_args ocamlcp_common zero_alloc_annotations
 
 ocamlcp_LIBRARIES =
@@ -1490,7 +1490,7 @@ ocamlmklib_MODULES = config build_path_prefix_map misc ocamlmklib
 ocamlmktop_LIBRARIES =
 ocamlmktop_MODULES = \
   config build_path_prefix_map misc identifiable numbers arg_helper \
-  local_store load_path zero_alloc_annotations clflags profile ccomp ocamlmktop
+  local_store zero_alloc_annotations clflags load_path profile ccomp ocamlmktop
 
 # Reading cmt files
 

compilerlibs/Makefile.compilerlibs

@@ -33,9 +33,9 @@ UTILS = \
   utils/numbers.cmo \
   utils/arg_helper.cmo \
   utils/local_store.cmo \
-  utils/load_path.cmo \
   utils/zero_alloc_annotations.cmo \
   utils/clflags.cmo \
+  utils/load_path.cmo \
   utils/debug.cmo \
   utils/language_extension_kernel.cmo \
   utils/language_extension.cmo \

driver/main_args.ml

@@ -165,6 +165,20 @@ let mk_H f =
   "<dir>  Add <dir> to the list of \"hidden\" include directories\n\
  \     (Like -I, but the program can not directly reference these dependencies)"
 
+let mk_libloc f =
+  "-libloc", Arg.String f, "<dir>:<libs>:<hidden_libs>  Add .libloc directory configuration.\n\
+  \    .libloc directory is alternative (to -I and -H flags) way of telling\n\
+  \    compiler where to find files. Each `.libloc` directory should have a\n\
+  \    structure of `.libloc/<lib>/cmi-cmx`, where `<lib>` is a library name\n\
+  \    and `cmi-cmx` is a file where each line is of format `<filename> <path>`\n\
+  \    telling compiler that <filename> for library <lib> is accessible\n\
+  \    at <path>. If <path> is relative, then it is relative to a parent directory\n\
+  \    of a `.libloc` directory.\n\
+  \    <libs> and <hidden_libs> are comma-separated lists of libraries, to let\n\
+  \    compiler know which libraries should be accessible via this `.libloc`\n\
+  \    directory. Difference between <libs> and <hidden_libs> is the same as\n\
+  \    the difference between -I and -H flags"
+
 let mk_impl f =
   "-impl", Arg.String f, "<file>  Compile <file> as a .ml file"
 
@@ -880,6 +894,7 @@ module type Common_options = sig
   val _alert : string -> unit
   val _I : string -> unit
   val _H : string -> unit
+  val _libloc : string -> unit
   val _labels : unit -> unit
   val _alias_deps : unit -> unit
   val _no_alias_deps : unit -> unit
@@ -1175,6 +1190,7 @@ struct
     mk_i F._i;
     mk_I F._I;
     mk_H F._H;
+    mk_libloc F._libloc;
     mk_impl F._impl;
     mk_intf F._intf;
     mk_intf_suffix F._intf_suffix;
@@ -1279,6 +1295,7 @@ struct
     mk_alert F._alert;
     mk_I F._I;
     mk_H F._H;
+    mk_libloc F._libloc;
     mk_init F._init;
     mk_labels F._labels;
     mk_alias_deps F._alias_deps;
@@ -1393,6 +1410,7 @@ struct
     mk_i F._i;
     mk_I F._I;
     mk_H F._H;
+    mk_libloc F._libloc;
     mk_impl F._impl;
     mk_inline F._inline;
     mk_inline_toplevel F._inline_toplevel;
@@ -1538,6 +1556,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_compact F._compact;
     mk_I F._I;
     mk_H F._H;
+    mk_libloc F._libloc;
     mk_init F._init;
     mk_inline F._inline;
     mk_inline_toplevel F._inline_toplevel;
@@ -1654,6 +1673,7 @@ struct
     mk_alert F._alert;
     mk_I F._I;
     mk_H F._H;
+    mk_libloc F._libloc;
     mk_impl F._impl;
     mk_intf F._intf;
     mk_intf_suffix F._intf_suffix;
@@ -1763,7 +1783,7 @@ module Default = struct
     let _no_absname = clear Clflags.absname
     let _no_alias_deps = set transparent_modules
     let _no_app_funct = clear applicative_functors
-    let _directory d = Clflags.directory := Some d 
+    let _directory d = Clflags.directory := Some d
     let _no_principal = clear principal
     let _no_rectypes = clear recursive_types
     let _no_strict_formats = clear strict_formats
@@ -1806,6 +1826,18 @@ module Default = struct
     include Common
     let _I dir = include_dirs := dir :: (!include_dirs)
     let _H dir = hidden_include_dirs := dir :: (!hidden_include_dirs)
+    let _libloc s =
+      match String.split_on_char ':' s with
+      | [ path; libs; hidden_libs ] ->
+        let split libs =
+          match libs |> String.split_on_char ',' with
+          | [ "" ] -> []
+          | libs -> libs
+        in
+        let libs = split libs in
+        let hidden_libs = split hidden_libs in
+        libloc := { Libloc.path; libs; hidden_libs } :: !libloc
+      | _ -> Compenv.fatal "Incorrect -libloc format, expected: <path>:<lib1>,<lib2>,...:<hidden_lib1>,<hidden_lib2>,..."
     let _color = Misc.set_or_ignore color_reader.parse color
     let _dlambda = set dump_lambda
     let _dparsetree = set dump_parsetree
@@ -2061,6 +2093,7 @@ module Default = struct
          Odoc_global.hidden_include_dirs :=
            (s :: (!Odoc_global.hidden_include_dirs))
       *) ()
+    let _libloc(_:string) = ()
     let _impl (_:string) =
       (* placeholder:
          Odoc_global.files := ((!Odoc_global.files) @ [Odoc_global.Impl_file s])

driver/main_args.mli

@@ -22,6 +22,7 @@ module type Common_options = sig
   val _alert : string -> unit
   val _I : string -> unit
   val _H : string -> unit
+  val _libloc : string -> unit
   val _labels : unit -> unit
   val _alias_deps : unit -> unit
   val _no_alias_deps : unit -> unit

otherlibs/dynlink/Makefile

@@ -83,9 +83,9 @@ COMPILERLIBS_SOURCES=\
   utils/numbers.ml \
   utils/arg_helper.ml \
   utils/local_store.ml \
+  utils/clflags.ml \
   utils/load_path.ml \
   utils/zero_alloc_annotations.ml \
-  utils/clflags.ml \
   utils/debug.ml \
   utils/language_extension_kernel.ml \
   utils/language_extension.ml \

tools/Makefile

@@ -102,8 +102,8 @@ opt.opt: profiling.cmx
 OCAMLCP = config.cmo build_path_prefix_map.cmo misc.cmo profile.cmo \
           warnings.cmo identifiable.cmo numbers.cmo arg_helper.cmo \
           language_extension_kernel.cmo language_extension.cmo \
-	  	  zero_alloc_annotations.cmo clflags.cmo local_store.cmo \
-          terminfo.cmo location.cmo load_path.cmo ccomp.cmo compenv.cmo \
+	  	  zero_alloc_annotations.cmo local_store.cmo \
+          terminfo.cmo location.cmo clflags.cmo load_path.cmo ccomp.cmo compenv.cmo \
           main_args.cmo
 
 ocamlcp$(EXE): $(OCAMLCP) ocamlcp.cmo

typing/env.ml

@@ -2669,7 +2669,7 @@ let unit_name_of_filename fn =
   | _ -> None
 
 let persistent_structures_of_dir dir =
-  Load_path.Dir.files dir
+  Load_path.Dir.basenames dir
   |> List.to_seq
   |> Seq.filter_map unit_name_of_filename
   |> String.Set.of_seq

utils/clflags.ml

@@ -44,10 +44,19 @@ and dllibs = ref ([] : string list)     (* .so and -dllib -lxxx *)
 
 let cmi_file = ref None
 
+module Libloc = struct
+  type t = {
+    path: string;
+    libs: string list;
+    hidden_libs: string list
+  }
+end
+
 let compile_only = ref false            (* -c *)
 and output_name = ref (None : string option) (* -o *)
 and include_dirs = ref ([] : string list) (* -I *)
 and hidden_include_dirs = ref ([] : string list) (* -H *)
+and libloc = ref ([] : Libloc.t list) (* -libloc *)
 and no_std_include = ref false          (* -nostdlib *)
 and no_cwd = ref false                  (* -nocwd *)
 and print_types = ref false             (* -i *)

utils/clflags.mli

@@ -51,6 +51,14 @@ val set_int_arg :
 val set_float_arg :
     int option -> Float_arg_helper.parsed ref -> float -> float option -> unit
 
+module Libloc : sig
+  type t = {
+    path: string;
+    libs: string list;
+    hidden_libs: string list
+  }
+end
+
 val objfiles : string list ref
 val ccobjs : string list ref
 val dllibs : string list ref
@@ -59,6 +67,7 @@ val compile_only : bool ref
 val output_name : string option ref
 val include_dirs : string list ref
 val hidden_include_dirs : string list ref
+val libloc : Libloc.t list ref
 val no_std_include : bool ref
 val no_cwd : bool ref
 val print_types : bool ref

utils/load_path.ml

@@ -15,38 +15,52 @@
 open Local_store
 
 module Dir : sig
+  type entry = {
+    basename : string;
+    path : string
+  }
+
   type t
 
   val path : t -> string
-  val files : t -> string list
+  val files : t -> entry list
+  val basenames : t -> string list
   val hidden : t -> bool
 
   val create : hidden:bool -> string -> t
+  val create_libloc : hidden:bool -> libloc:string -> string -> t
 
   val find : t -> string -> string option
   val find_uncap : t -> string -> string option
 end = struct
+  type entry = {
+    basename : string;
+    path : string
+  }
+
   type t = {
     path : string;
-    files : string list;
-    hidden : bool;
+    files : entry list;
+    hidden : bool
   }
 
   let path t = t.path
   let files t = t.files
+  let basenames t = List.map (fun { basename; _ } -> basename) t.files
   let hidden t = t.hidden
 
   let find t fn =
-    if List.mem fn t.files then
-      Some (Filename.concat t.path fn)
-    else
-      None
+    List.find_map (fun { basename; path } ->
+      if String.equal basename fn then
+        Some path
+      else
+        None) t.files
 
   let find_uncap t fn =
     let fn = String.uncapitalize_ascii fn in
-    let search base =
-      if String.uncapitalize_ascii base = fn then
-        Some (Filename.concat t.path base)
+    let search { basename; path } =
+      if String.uncapitalize_ascii basename = fn then
+        Some path
       else
         None
     in
@@ -62,7 +76,36 @@ end = struct
       [||]
 
   let create ~hidden path =
-    { path; files = Array.to_list (readdir_compat path); hidden }
+    let files = Array.to_list (readdir_compat path)
+      |> List.map (fun basename -> { basename; path = Filename.concat path basename }) in
+    { path; files; hidden }
+
+  let read_libloc_file path =
+    let ic = open_in path in
+    Misc.try_finally
+      (fun () ->
+        let rec loop acc =
+          try
+            let line = input_line ic in
+            let (basename, path) = Misc.Stdlib.String.split_first_exn ~split_on:' ' line in
+            loop ({ basename; path } :: acc)
+          with End_of_file -> acc
+        in
+        loop [])
+      ~always:(fun () -> close_in ic)
+
+  let create_libloc ~hidden ~libloc libname =
+    let libloc_lib_path = Filename.concat libloc libname in
+    let files = read_libloc_file (Filename.concat libloc_lib_path "cmi-cmx") in
+    let files = List.map (fun { basename; path } ->
+      let path = if Filename.is_relative path then
+        (* Paths are relative to parent directory of libloc directory *)
+        Filename.concat (Filename.dirname libloc) path
+      else
+        path
+      in
+      { basename; path }) files in
+    { path = libloc_lib_path; files; hidden }
 end
 
 type visibility = Visible | Hidden
@@ -103,8 +146,7 @@ end = struct
     STbl.clear !visible_files_uncap
 
   let prepend_add dir =
-    List.iter (fun base ->
-        let fn = Filename.concat (Dir.path dir) base in
+    List.iter (fun ({ basename = base; path = fn } : Dir.entry) ->
         if Dir.hidden dir then begin
           STbl.replace !hidden_files base fn;
           STbl.replace !hidden_files_uncap (String.uncapitalize_ascii base) fn
@@ -122,8 +164,7 @@ end = struct
         STbl.replace !visible_files base fn
     in
     List.iter
-      (fun base ->
-         let fn = Filename.concat (Dir.path dir) base in
+      (fun ({ basename = base; path = fn }: Dir.entry) ->
          update base fn visible_files hidden_files;
          let ubase = String.uncapitalize_ascii base in
          update ubase fn visible_files_uncap hidden_files_uncap)
@@ -175,6 +216,10 @@ let init ~auto_include ~visible ~hidden =
   reset ();
   visible_dirs := List.rev_map (Dir.create ~hidden:false) visible;
   hidden_dirs := List.rev_map (Dir.create ~hidden:true) hidden;
+  List.iter (fun (libloc : Clflags.Libloc.t) ->
+    visible_dirs := Misc.rev_map_end (fun lib -> Dir.create_libloc ~hidden:false ~libloc:libloc.path lib) libloc.libs !visible_dirs;
+    hidden_dirs := Misc.rev_map_end (fun lib -> Dir.create_libloc ~hidden:true ~libloc:libloc.path lib) libloc.hidden_libs !hidden_dirs
+  ) !Clflags.libloc;
   List.iter Path_cache.prepend_add !hidden_dirs;
   List.iter Path_cache.prepend_add !visible_dirs;
   auto_include_callback := auto_include

utils/load_path.mli

@@ -37,7 +37,7 @@ module Dir : sig
 
   val create : hidden:bool -> string -> t
 
-  val files : t -> string list
+  val basenames : t -> string list
   (** All the files in that directory. This doesn't include files in
       sub-directories of this directory. *)
 end

utils/misc.ml

@@ -360,10 +360,17 @@ module Stdlib = struct
       in
       helper chars str []
 
-    let split_last_exn str ~split_on =
+    let split_once str ~idx =
       let n = String.length str in
+      String.sub str 0 idx, String.sub str (idx + 1) (n - idx - 1)
+
+    let split_last_exn str ~split_on =
       let ridx = String.rindex str split_on in
-      String.sub str 0 ridx, String.sub str (ridx + 1) (n - ridx - 1)
+      split_once str ~idx:ridx
+
+    let split_first_exn str ~split_on =
+      let idx = String.index str split_on in
+      split_once str ~idx
 
     let starts_with ~prefix s =
       let len_s = length s