408: reconcile initial environment

This pulls in the new Load_path module from the compiler distribution,
but adds a layer of caching on directories content.

src/kernel/mocaml.ml

@@ -7,7 +7,7 @@ let setup_config config = (
   let open Mconfig in
   let open Clflags in
   let ocaml = config.ocaml in
-  Config.load_path := Mconfig.build_path config;
+  Load_path.init (Mconfig.build_path config);
   Location.input_name  := config.query.filename;
   fast                 := ocaml.unsafe ;
   classic              := ocaml.classic ;
@@ -105,7 +105,8 @@ let with_printer printer f =
 (* Cleanup caches *)
 let clear_caches () = (
   Cmi_cache.clear ();
-  Cmt_cache.clear ()
+  Cmt_cache.clear ();
+  Directory_content_cache.clear ();
 )
 
 (* Flush cache *)

src/ocaml/merlin_specific/408/typer_raw.ml

@@ -30,30 +30,19 @@ open Std
 open Location
 open Parsetree
 
-let open_implicit_module m env =
-  let open Asttypes in
-  let lid = {loc = Location.in_file "command line";
-             txt = Longident.parse m } in
-  match snd (Typemod.type_open_ Override env lid.loc lid) with
-  | env -> env
-  | exception exn ->
-    Msupport.raise_error exn;
-    env
-
 let fresh_env () =
   (*Ident.reinit();*)
-  let initial =
-    if !Clflags.unsafe_string then
-      Env.initial_unsafe_string
-    else
-      Env.initial_safe_string in
-  let env =
+  let initially_opened_module =
     if !Clflags.nopervasives then
-      initial
+      None
     else
-      open_implicit_module "Stdlib" initial in
-  List.fold_right ~f:open_implicit_module
-    !Clflags.open_modules ~init:env
+      Some "Stdlib"
+  in
+  Typemod.initial_env
+    ~loc:(Location.in_file "command line")
+    ~safe_string:(not !Clflags.unsafe_string)
+    ~initially_opened_module
+    ~open_implicit_modules:(List.rev !Clflags.open_modules)
 
 module Rewrite_loc = struct
   let queue = ref []

src/ocaml/typing/408/cmt_format.ml

@@ -183,7 +183,7 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi =
            cmt_args = Sys.argv;
            cmt_sourcefile = sourcefile;
            cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
-           cmt_loadpath = !Config.load_path;
+           cmt_loadpath = Load_path.get_paths ();
            cmt_source_digest = source_digest;
            cmt_initial_env = if need_to_clear_env then
                keep_only_summary initial_env else initial_env;

src/ocaml/typing/408/env.ml

@@ -834,7 +834,7 @@ module Persistent_signature = struct
       cmi_cache : exn ref }
 
   let load = ref (fun ~unit_name ->
-      match find_in_path_uncap !Config.load_path (unit_name ^ ".cmi") with
+      match Load_path.find_uncap (unit_name ^ ".cmi") with
       | filename ->
         let {Cmi_cache. cmi; cmi_cache} = Cmi_cache.read filename in
         Some { filename; cmi; cmi_cache }
@@ -2594,7 +2594,6 @@ let read_signature modname filename =
   let ps = read_pers_struct modname filename in
   Lazy.force ps.ps_sig
 
-(*
 let is_identchar_latin1 = function
   | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
   | '\248'..'\255' | '\'' | '0'..'9' -> true
@@ -2618,7 +2617,6 @@ let persistent_structures_of_dir dir =
   |> List.to_seq
   |> Seq.filter_map unit_name_of_filename
   |> StringSet.of_seq
-*)
 
 (* Return the CRC of the interface of the given compilation unit *)
 
@@ -3209,7 +3207,7 @@ let check_state_consistency () =
   Std.Hashtbl.forall !persistent_structures @@ fun name ps ->
   match ps with
   | None ->
-    begin match find_in_path_uncap !Config.load_path (name ^ ".cmi") with
+    begin match Load_path.find_uncap (name ^ ".cmi") with
       | _ -> false
       | exception Not_found -> true
     end

src/ocaml/typing/408/env.mli

@@ -183,7 +183,7 @@ val add_persistent_structure : Ident.t -> t -> t
 
 (* Returns the set of persistent structures found in the given
    directory. *)
-(* val persistent_structures_of_dir : Load_path.Dir.t -> Misc.StringSet.t *)
+val persistent_structures_of_dir : Load_path.Dir.t -> Misc.StringSet.t
 
 (* [filter_non_loaded_persistent f env] removes all the persistent
    structures that are not yet loaded and for which [f] returns

src/ocaml/typing/408/typemod.ml

@@ -154,7 +154,6 @@ let type_open_ ?used_slot ?toplevel ovf env loc lid =
       ignore (extract_sig_open env lid.loc md.md_type);
       assert false
 
-(*
 let initial_env ~loc ~safe_string ~initially_opened_module
     ~open_implicit_modules =
   let env =
@@ -169,7 +168,7 @@ let initial_env ~loc ~safe_string ~initially_opened_module
     snd (type_open_ Override env lid.loc lid)
   in
   let add_units env units =
-    String.Set.fold
+    StringSet.fold
       (fun name env ->
          Env.add_persistent_structure (Ident.create_persistent name) env)
       units
@@ -189,7 +188,7 @@ let initial_env ~loc ~safe_string ~initially_opened_module
           match after with
           | [] -> None
           | units :: after ->
-              if String.Set.mem m units then
+              if StringSet.mem m units then
                 Some (units, List.rev_append before after)
               else
                 loop (units :: before) after
@@ -205,7 +204,6 @@ let initial_env ~loc ~safe_string ~initially_opened_module
   in
   let env = List.fold_left add_units env units in
   List.fold_left open_module env open_implicit_modules
-*)
 
 let type_open_descr ?used_slot ?toplevel env sod =
   let (path, newenv) =
@@ -2602,7 +2600,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
         if Sys.file_exists sourceintf then begin
           let intf_file =
             try
-              find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
+              Load_path.find_uncap (modulename ^ ".cmi")
             with Not_found ->
               raise(Error(Location.in_file sourcefile, Env.empty,
                           Interface_not_compiled sourceintf)) in

src/ocaml/typing/408/typemod.mli

@@ -63,13 +63,11 @@ val save_signature:
 val package_units:
   Env.t -> string list -> string -> string -> Typedtree.module_coercion
 
-(*
 (* Should be in Envaux, but it breaks the build of the debugger *)
 val initial_env:
   loc:Location.t -> safe_string:bool ->
   initially_opened_module:string option ->
   open_implicit_modules:string list -> Env.t
-*)
 
 module Sig_component_kind : sig
   type t =

src/ocaml/utils/408/load_path.ml

@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module SMap = Misc.StringMap
+
+(* Mapping from basenames to full filenames *)
+type registry = string SMap.t ref
+
+let state = Local_store.new_bindings ()
+let srefk k = Local_store.ref state (fun () -> k)
+
+let files : registry = srefk SMap.empty
+let files_uncap : registry = srefk SMap.empty
+
+module Dir = struct
+  type t = {
+    path : string;
+    files : string list;
+  }
+
+  let path t = t.path
+  let files t = t.files
+
+  let create path =
+    { path; files = Array.to_list (Directory_content_cache.read path) }
+end
+
+let dirs = srefk []
+
+let reset () =
+  files := SMap.empty;
+  files_uncap := SMap.empty;
+  dirs := []
+
+let get () = !dirs
+let get_paths () = List.map Dir.path !dirs
+
+let add dir =
+  let add_file base =
+    let fn = Filename.concat dir.Dir.path base in
+    files := SMap.add base fn !files;
+    files_uncap := SMap.add (String.uncapitalize_ascii base) fn !files_uncap;
+  in
+  List.iter add_file dir.Dir.files;
+  dirs := dir :: !dirs
+
+let remove_dir dir =
+  let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in
+  if new_dirs <> !dirs then begin
+    reset ();
+    List.iter add (List.rev new_dirs)
+  end
+
+let add_dir dir = add (Dir.create dir)
+
+let init l =
+  reset ();
+  List.iter add_dir (List.rev l)
+
+let is_basename fn = Filename.basename fn = fn
+
+let find fn =
+  if is_basename fn then
+    SMap.find fn !files
+  else
+    Misc.find_in_path (get_paths ()) fn
+
+let find_uncap fn =
+  if is_basename fn then
+    SMap.find (String.uncapitalize_ascii fn) !files_uncap
+  else
+    Misc.find_in_path_uncap (get_paths ()) fn

src/ocaml/utils/408/load_path.mli

@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Management of include directories.
+
+    This module offers a high level interface to locating files in the
+    load path, which is constructed from [-I] command line flags and a few
+    other parameters.
+
+    It makes the assumption that the contents of include directories
+    doesn't change during the execution of the compiler.
+*)
+
+val add_dir : string -> unit
+(** Add a directory to the load path *)
+
+val remove_dir : string -> unit
+(** Remove a directory from the load path *)
+
+val reset : unit -> unit
+(** Remove all directories *)
+
+val init : string list -> unit
+(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *)
+
+val get_paths : unit -> string list
+(** Return the list of directories passed to [add_dir] so far, in
+    reverse order. *)
+
+val find : string -> string
+(** Locate a file in the load path. Raise [Not_found] if the file
+    cannot be found. This function is optimized for the case where the
+    filename is a basename, i.e. doesn't contain a directory
+    separator. *)
+
+val find_uncap : string -> string
+(** Same as [find], but search also for uncapitalized name, i.e.  if
+    name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *)
+
+module Dir : sig
+  type t
+  (** Represent one directory in the load path. *)
+
+  val create : string -> t
+
+  val path : t -> string
+
+  val files : t -> string list
+  (** All the files in that directory. This doesn't include files in
+      sub-directories of this directory. *)
+end
+
+val add : Dir.t -> unit
+
+val get : unit -> Dir.t list
+(** Same as [get_paths ()], except that it returns a [Dir.t list]. *)

src/ocaml/utils/directory_content_cache.ml

@@ -0,0 +1,14 @@
+include File_cache.Make (struct
+    let cache_name = "Directory_content_cache"
+    type t = string array
+
+    (* For backward compatibility reason, simulate the behavior of
+       [Misc.find_in_path]: silently ignore directories that don't exist
+       + treat [""] as the current directory. *)
+    let read dir =
+      try
+        Sys.readdir (if dir = "" then Filename.current_dir_name else dir)
+      with Sys_error _ ->
+        [||]
+  end)
+

src/ocaml/utils/dune

@@ -10,13 +10,23 @@ let ver =
     | _ -> raise Not_found
   with Not_found ->
     Scanf.sscanf J.ocaml_version "%s@.%s@." (fun maj min -> maj ^ min)
+
+let load_path =
+  let version = Scanf.sscanf J.ocaml_version "%d.%d." (fun ma mi -> ma, mi) in
+  if version >= (4,8)
+  then ""
+  else {|
+(rule
+  (targets load_path.ml)
+  (action (copy# load_path.ml.pre408 %{targets})))|}
 ;;
 
 Printf.ksprintf J.send {|
 (copy_files# %s/*.ml{,i})
+%s
 
 (library
   (name utils)
   (wrapped false)
   (libraries config findlib merlin_utils))
-|} ver
+|} ver load_path

src/ocaml/utils/load_path.ml.pre408

@@ -0,0 +1,2 @@
+let init build_path =
+  Config.load_path := build_path

tests/misc/dune

@@ -10,18 +10,6 @@
 (alias
  (name runtest)
  (deps load_path.t)
- (enabled_if (< %{ocaml_version} 4.08.0))
- (action
-   (progn
-     (setenv OCAMLC %{ocamlc}
-     (setenv MERLIN %{dep:../merlin-wrapper}
-       (run %{bin:mdx} test --syntax=cram %{deps})))
-     (diff? %{deps} %{deps}.corrected))))
-
-(alias
- (name runtest)
- (deps load_path_post_407.t)
- (enabled_if (>= %{ocaml_version} 4.08.0))
  (action
    (progn
      (setenv OCAMLC %{ocamlc}