From 3ccafafa968d8fe5928dac8b45e631fb1e505756 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Mon, 21 Sep 2026 18:53:01 +0200 Subject: [PATCH 1/3] Add an internal `Load_path.Path_cache` module Pull the path-to-file cache logic into a `Path_cache` submodule Ported from oxcaml/oxcaml#2420 Co-authored-by: Andrei Odintsov --- utils/load_path.ml | 155 ++++++++++++++++++++++++++------------------- 1 file changed, 91 insertions(+), 64 deletions(-) diff --git a/utils/load_path.ml b/utils/load_path.ml index 1fe309807cea..7bd5f7719dc3 100644 --- a/utils/load_path.ml +++ b/utils/load_path.ml @@ -14,17 +14,6 @@ open Local_store -module STbl = Misc.Stdlib.String.Tbl - -(* Mapping from basenames to full filenames *) -type registry = string STbl.t - -let visible_files : registry ref = s_table STbl.create 42 -let visible_files_uncap : registry ref = s_table STbl.create 42 - -let hidden_files : registry ref = s_table STbl.create 42 -let hidden_files_uncap : registry ref = s_table STbl.create 42 - module Dir = struct type t = { path : string; @@ -65,6 +54,88 @@ module Dir = struct { path; files = Array.to_list (readdir_compat path); hidden } end +type visibility = Visible | Hidden + +(** Store cached paths to files *) +module Path_cache : sig + (* Clear cache *) + val reset : unit -> unit + + (* Same as [add] below, but will replace existing entries. + + [prepend_add] is faster than [add] and intented for use in [init] and + [remove_dir]: since we are starting from an empty cache, we can avoid + checking whether a unit name already exists in the cache simply by adding + entries in reverse order. *) + val prepend_add : Dir.t -> unit + + (* Add path to cache. If path with same basename is already in cache, skip + adding. *) + val add : Dir.t -> unit + + (* Search for a basename in cache. Assume the basename has been normalized if + [normalized] is true. *) + val find : normalized:bool -> string -> string * visibility +end = struct + module STbl = Misc.Stdlib.String.Tbl + + (* Mapping from basenames to full filenames *) + type registry = string STbl.t + + let visible_files : registry ref = s_table STbl.create 42 + let visible_files_uncap : registry ref = s_table STbl.create 42 + + let hidden_files : registry ref = s_table STbl.create 42 + let hidden_files_uncap : registry ref = s_table STbl.create 42 + + let reset () = + STbl.clear !hidden_files; + STbl.clear !hidden_files_uncap; + STbl.clear !visible_files; + STbl.clear !visible_files_uncap + + let prepend_add dir = + List.iter (fun base -> + Result.iter (fun filename -> + let fn = Filename.concat dir.Dir.path base in + if dir.Dir.hidden then begin + STbl.replace !hidden_files base fn; + STbl.replace !hidden_files_uncap filename fn + end else begin + STbl.replace !visible_files base fn; + STbl.replace !visible_files_uncap filename fn + end) + (Misc.normalized_unit_filename base) + ) dir.Dir.files + + let add (dir : Dir.t) = + let update base fn visible_files hidden_files = + if dir.hidden then begin + if not (STbl.mem !hidden_files base) then + STbl.replace !hidden_files base fn + end else if not (STbl.mem !visible_files base) then + STbl.replace !visible_files base fn + in + List.iter + (fun base -> + Result.iter (fun ubase -> + let fn = Filename.concat dir.Dir.path base in + update base fn visible_files hidden_files; + update ubase fn visible_files_uncap hidden_files_uncap + ) + (Misc.normalized_unit_filename base) + ) + dir.files + + let find fn visible_files hidden_files = + try (STbl.find !visible_files fn, Visible) with + | Not_found -> (STbl.find !hidden_files fn, Hidden) + + let find ~normalized fn = + if normalized then find fn visible_files_uncap hidden_files_uncap + else find fn visible_files hidden_files +end + type auto_include_callback = (Dir.t -> string -> string option) -> string -> string @@ -75,10 +146,7 @@ let auto_include_callback = ref no_auto_include let reset () = assert (not Config.merlin || Local_store.is_bound ()); - STbl.clear !hidden_files; - STbl.clear !hidden_files_uncap; - STbl.clear !visible_files; - STbl.clear !visible_files_uncap; + Path_cache.reset (); hidden_dirs := []; visible_dirs := []; auto_include_callback := no_auto_include @@ -99,30 +167,12 @@ let get_paths () = let get_visible_path_list () = List.rev_map Dir.path !visible_dirs let get_hidden_path_list () = List.rev_map Dir.path !hidden_dirs -(* Optimized version of [add] below, for use in [init] and [remove_dir]: since - we are starting from an empty cache, we can avoid checking whether a unit - name already exists in the cache simply by adding entries in reverse - order. *) -let prepend_add dir = - List.iter (fun base -> - Result.iter (fun filename -> - let fn = Filename.concat dir.Dir.path base in - if dir.Dir.hidden then begin - STbl.replace !hidden_files base fn; - STbl.replace !hidden_files_uncap filename fn - end else begin - STbl.replace !visible_files base fn; - STbl.replace !visible_files_uncap filename fn - end) - (Misc.normalized_unit_filename base) - ) dir.Dir.files - 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 prepend_add !hidden_dirs; - List.iter prepend_add !visible_dirs; + List.iter Path_cache.prepend_add !hidden_dirs; + List.iter Path_cache.prepend_add !visible_dirs; auto_include_callback := auto_include let remove_dir dir = @@ -135,8 +185,8 @@ let remove_dir dir = reset (); visible_dirs := visible; hidden_dirs := hidden; - List.iter prepend_add hidden; - List.iter prepend_add visible; + List.iter Path_cache.prepend_add hidden; + List.iter Path_cache.prepend_add visible; auto_include_callback := saved_auto_include end @@ -145,23 +195,7 @@ let remove_dir dir = left-to-right precedence. *) let add (dir : Dir.t) = assert (not Config.merlin || Local_store.is_bound ()); - let update base fn visible_files hidden_files = - if dir.hidden then begin - if not (STbl.mem !hidden_files base) then - STbl.replace !hidden_files base fn - end else if not (STbl.mem !visible_files base) then - STbl.replace !visible_files base fn - in - List.iter - (fun base -> - Result.iter (fun ubase -> - let fn = Filename.concat dir.Dir.path base in - update base fn visible_files hidden_files; - update ubase fn visible_files_uncap hidden_files_uncap - ) - (Misc.normalized_unit_filename base) - ) - dir.files; + Path_cache.add dir; if dir.hidden then hidden_dirs := dir :: !hidden_dirs else @@ -175,7 +209,7 @@ let add_dir ~hidden dir = add (Dir.create ~hidden dir) unconditionally added. *) let prepend_dir (dir : Dir.t) = assert (not Config.merlin || Local_store.is_bound ()); - prepend_add dir; + Path_cache.prepend_add dir; if dir.hidden then hidden_dirs := !hidden_dirs @ [dir] else @@ -205,17 +239,11 @@ let auto_include_otherlibs = List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in auto_include_libs otherlibs -type visibility = Visible | Hidden - -let find_file_in_cache fn visible_files hidden_files = - try (STbl.find !visible_files fn, Visible) with - | Not_found -> (STbl.find !hidden_files fn, Hidden) - let find fn = assert (not Config.merlin || Local_store.is_bound ()); try if is_basename fn && not !Sys.interactive then - fst (find_file_in_cache fn visible_files hidden_files) + fst (Path_cache.find ~normalized:false fn) else Misc.find_in_path (get_path_list ()) fn with Not_found -> @@ -228,8 +256,7 @@ let find_normalized_with_visibility fn = | Ok fn_uncap -> try if is_basename fn && not !Sys.interactive then - find_file_in_cache fn_uncap - visible_files_uncap hidden_files_uncap + Path_cache.find ~normalized:true fn_uncap else try (Misc.find_in_path_normalized (get_visible_path_list ()) fn, Visible) From ecf476c6c241e86ba448a175cbcf42a505b48972 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Mon, 21 Sep 2026 17:48:02 +0200 Subject: [PATCH 2/3] Distinguish the internal and exported interfaces for `Load_path.Dir` Restrict the exported interface to what is actually used Add an internal interface for `Load_path.Dir` Ported from oxcaml/oxcaml#2420 Co-authored-by: Andrei Odintsov --- utils/load_path.ml | 39 ++++++++++++++++++++++++++++++--------- utils/load_path.mli | 16 +++------------- 2 files changed, 33 insertions(+), 22 deletions(-) diff --git a/utils/load_path.ml b/utils/load_path.ml index 7bd5f7719dc3..b614cb2483f6 100644 --- a/utils/load_path.ml +++ b/utils/load_path.ml @@ -14,7 +14,28 @@ open Local_store -module Dir = struct +module Dir : sig + type 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. *) + + val create : hidden:bool -> string -> t + + val hidden : t -> bool + (** If the modules in this directory should not be bound in the initial + scope *) + + val find : t -> string -> string option + (** [find dir fn] returns the full path to [fn] in [dir]. *) + + val find_normalized : t -> string -> string option + (** As {!find}, but search also for uncapitalized name, i.e. if name is + Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) +end = struct type t = { path : string; files : string list; @@ -97,8 +118,8 @@ end = struct let prepend_add dir = List.iter (fun base -> Result.iter (fun filename -> - let fn = Filename.concat dir.Dir.path base in - if dir.Dir.hidden then begin + let fn = Filename.concat (Dir.path dir) base in + if Dir.hidden dir then begin STbl.replace !hidden_files base fn; STbl.replace !hidden_files_uncap filename fn end else begin @@ -106,11 +127,11 @@ end = struct STbl.replace !visible_files_uncap filename fn end) (Misc.normalized_unit_filename base) - ) dir.Dir.files + ) (Dir.files dir) let add (dir : Dir.t) = let update base fn visible_files hidden_files = - if dir.hidden then begin + if Dir.hidden dir then begin if not (STbl.mem !hidden_files base) then STbl.replace !hidden_files base fn end else if not (STbl.mem !visible_files base) then @@ -119,13 +140,13 @@ end = struct List.iter (fun base -> Result.iter (fun ubase -> - let fn = Filename.concat dir.Dir.path base in + let fn = Filename.concat (Dir.path dir) base in update base fn visible_files hidden_files; update ubase fn visible_files_uncap hidden_files_uncap ) (Misc.normalized_unit_filename base) ) - dir.files + (Dir.files dir) let find fn visible_files hidden_files = try (STbl.find !visible_files fn, Visible) with @@ -196,7 +217,7 @@ let remove_dir dir = let add (dir : Dir.t) = assert (not Config.merlin || Local_store.is_bound ()); Path_cache.add dir; - if dir.hidden then + if Dir.hidden dir then hidden_dirs := dir :: !hidden_dirs else visible_dirs := dir :: !visible_dirs @@ -210,7 +231,7 @@ let add_dir ~hidden dir = add (Dir.create ~hidden dir) let prepend_dir (dir : Dir.t) = assert (not Config.merlin || Local_store.is_bound ()); Path_cache.prepend_add dir; - if dir.hidden then + if Dir.hidden dir then hidden_dirs := !hidden_dirs @ [dir] else visible_dirs := !visible_dirs @ [dir] diff --git a/utils/load_path.mli b/utils/load_path.mli index 488b75f760dd..3df3e8365658 100644 --- a/utils/load_path.mli +++ b/utils/load_path.mli @@ -36,23 +36,13 @@ module Dir : sig (** Represent one directory in the load path. *) val create : hidden:bool -> string -> t - - val path : t -> string + (** [create ~hidden path] creates the representation for the directory at + [path]. When [hidden] is true, the modules in this directory should not be + bound in the initial scope. *) val files : t -> string list (** All the files in that directory. This doesn't include files in sub-directories of this directory. *) - - val hidden : t -> bool - (** If the modules in this directory should not be bound in the initial - scope *) - - val find : t -> string -> string option - (** [find dir fn] returns the full path to [fn] in [dir]. *) - - val find_normalized : t -> string -> string option - (** As {!find}, but search also for uncapitalized name, i.e. if name is - Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) end type auto_include_callback = From 781d39ce7eb272055a0e03a71d227cbbd56a03c7 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Wed, 23 Sep 2026 12:27:47 +0200 Subject: [PATCH 3/3] Rename variable suffix `_uncap` into `_normalized` Normalization now does more than just uncapitalization so rename variables to follow that change --- utils/load_path.ml | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/utils/load_path.ml b/utils/load_path.ml index b614cb2483f6..fe0862992b1b 100644 --- a/utils/load_path.ml +++ b/utils/load_path.ml @@ -33,8 +33,9 @@ module Dir : sig (** [find dir fn] returns the full path to [fn] in [dir]. *) val find_normalized : t -> string -> string option - (** As {!find}, but search also for uncapitalized name, i.e. if name is - Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) + (** As {!find}, but search also for normalized name (see + {!Misc.normalized_unit_filename}), i.e. if name is Foo.ml, either + /path/Foo.ml or /path/foo.ml may be returned. *) end = struct type t = { path : string; @@ -104,16 +105,16 @@ end = struct type registry = string STbl.t let visible_files : registry ref = s_table STbl.create 42 - let visible_files_uncap : registry ref = s_table STbl.create 42 + let visible_files_normalized : registry ref = s_table STbl.create 42 let hidden_files : registry ref = s_table STbl.create 42 - let hidden_files_uncap : registry ref = s_table STbl.create 42 + let hidden_files_normalized : registry ref = s_table STbl.create 42 let reset () = STbl.clear !hidden_files; - STbl.clear !hidden_files_uncap; + STbl.clear !hidden_files_normalized; STbl.clear !visible_files; - STbl.clear !visible_files_uncap + STbl.clear !visible_files_normalized let prepend_add dir = List.iter (fun base -> @@ -121,10 +122,10 @@ end = struct let fn = Filename.concat (Dir.path dir) base in if Dir.hidden dir then begin STbl.replace !hidden_files base fn; - STbl.replace !hidden_files_uncap filename fn + STbl.replace !hidden_files_normalized filename fn end else begin STbl.replace !visible_files base fn; - STbl.replace !visible_files_uncap filename fn + STbl.replace !visible_files_normalized filename fn end) (Misc.normalized_unit_filename base) ) (Dir.files dir) @@ -142,7 +143,7 @@ end = struct Result.iter (fun ubase -> let fn = Filename.concat (Dir.path dir) base in update base fn visible_files hidden_files; - update ubase fn visible_files_uncap hidden_files_uncap + update ubase fn visible_files_normalized hidden_files_normalized ) (Misc.normalized_unit_filename base) ) @@ -153,7 +154,7 @@ end = struct | Not_found -> (STbl.find !hidden_files fn, Hidden) let find ~normalized fn = - if normalized then find fn visible_files_uncap hidden_files_uncap + if normalized then find fn visible_files_normalized hidden_files_normalized else find fn visible_files hidden_files end @@ -274,10 +275,10 @@ let find_normalized_with_visibility fn = assert (not Config.merlin || Local_store.is_bound ()); match Misc.normalized_unit_filename fn with | Error _ -> raise Not_found - | Ok fn_uncap -> + | Ok fn_normalized -> try if is_basename fn && not !Sys.interactive then - Path_cache.find ~normalized:true fn_uncap + Path_cache.find ~normalized:true fn_normalized else try (Misc.find_in_path_normalized (get_visible_path_list ()) fn, Visible) @@ -285,6 +286,6 @@ let find_normalized_with_visibility fn = | Not_found -> (Misc.find_in_path_normalized (get_hidden_path_list ()) fn, Hidden) with Not_found -> - (!auto_include_callback Dir.find_normalized fn_uncap, Visible) + (!auto_include_callback Dir.find_normalized fn_normalized, Visible) let find_normalized fn = fst (find_normalized_with_visibility fn)