[src][state][cmt] add caching

This replaces the previous local cache in location dependencies
computation.

Author: fantazio

src/state/cmt.ml

@@ -0,0 +1,66 @@
+module Cache = struct
+  (** O(1) addition and retrieval *)
+
+  type ('k, 'v) t =
+    { store : ('k, 'v) Hashtbl.t
+        (** filepath -> cmi_cmt_infos *)
+    ; capacity : int (** n <= capacity *)
+    ; mutable hit : int
+    ; mutable miss : int
+    }
+
+  let create capacity =
+    { store = Hashtbl.create capacity
+    ; capacity
+    ; hit = 0
+    ; miss = 0
+    }
+
+  let find_opt (cache : ('k, 'v) t) (key : 'k) : 'v option =
+    let res = Hashtbl.find_opt cache.store key in
+    if Option.is_some res then cache.hit <- cache.hit + 1
+    else (cache.miss <- cache.miss + 1);
+    res
+
+  let add cache key value =
+    if Hashtbl.length cache.store = cache.capacity then
+      Hashtbl.reset cache.store;
+    Hashtbl.replace cache.store key value
+
+end
+
+let read_no_cache filepath =
+  match Cmt_format.read filepath with
+  | exception _ -> Result.error (filepath ^ ": error reading file")
+  | _, None -> Result.error (filepath ^ ": cmt_infos not found")
+  | cmi_infos, Some cmt_infos ->
+    Result.ok (cmi_infos, cmt_infos)
+
+type cmi_cmt_infos = Cmi_format.cmi_infos option * Cmt_format.cmt_infos
+
+let cache_cmt : ((string * string), (string * cmi_cmt_infos)) Cache.t = Cache.create 64
+
+let read filepath =
+  let comp_unit = Utils.Filepath.unit filepath in
+  let ext = Filename.extension filepath in
+  match Cache.find_opt cache_cmt (ext, comp_unit) with
+  | Some (fp, res) when String.equal fp filepath -> Result.ok res
+  | _ ->
+      read_no_cache filepath
+      |> Result.map (fun cmi_cmt_infos ->
+        Cache.add cache_cmt (ext, comp_unit) (filepath, cmi_cmt_infos);
+        cmi_cmt_infos)
+
+let find_cached_from_comp_unit comp_unit ext =
+  Cache.find_opt cache_cmt (ext, comp_unit)
+  |> Option.map snd
+
+let cached_cmti comp_unit =
+  find_cached_from_comp_unit comp_unit ".cmti"
+
+let cached_cmt comp_unit =
+  find_cached_from_comp_unit comp_unit ".cmt"
+
+let print_cache_stats () =
+  print_endline (Printf.sprintf "CMT CACHE : hit = %i ; miss = %i"
+                                cache_cmt.hit cache_cmt.miss)

src/state/cmt.mli

@@ -0,0 +1,9 @@
+type cmi_cmt_infos = Cmi_format.cmi_infos option * Cmt_format.cmt_infos
+
+val read : string -> (cmi_cmt_infos, string) Result.t
+
+val cached_cmti : string -> cmi_cmt_infos option
+
+val cached_cmt : string -> cmi_cmt_infos option
+
+val print_cache_stats : unit -> unit

src/state/file_infos.ml

@@ -47,10 +47,9 @@ let empty = {
 let init_from_cm_file cm_file =
   if not (Sys.file_exists cm_file) then Result.error (cm_file ^ ": file not found")
   else
-    match Cmt_format.read cm_file with
-    | exception _ -> Result.error (cm_file ^ ": error reading file")
-    | _, None -> Result.error (cm_file ^ ": cmt_infos not found")
-    | cmi_infos, Some cmt_infos ->
+    match Cmt.read cm_file with
+    | Error _ as err -> err
+    | Ok (cmi_infos, cmt_infos) ->
         let file_infos =
           init_from_all_cm_infos ~cm_file ~cmi_infos cmt_infos
         in

src/state/location_dependencies.ml

@@ -20,31 +20,32 @@ let fill_from_cmt_tbl uid_to_decl res_uid_to_loc =
   UidTbl.iter add_uid_loc uid_to_decl;
   res_uid_to_loc
 
-let find_opt_external_uid_loc, clear_external_cache =
-  let cache = Hashtbl.create 16 in
-  let clear_external_cache () = Hashtbl.reset cache in
-  let find_opt_external_uid_loc ~cm_paths = function
-    | Shape.Uid.(Compilation_unit _ | Internal | Predef _) -> None
-    | Item {comp_unit; _} as uid ->
+let find_opt_external_uid_loc ~cm_paths = function
+  | Shape.Uid.(Compilation_unit _ | Internal | Predef _) -> None
+  | Item {comp_unit; from; _} as uid ->
       let ( let* ) x f = Option.bind x f in
-      let* cmt_uid_to_decl =
-        match Hashtbl.find_opt cache comp_unit with
-        | Some _ as cmt_uid_to_decl -> cmt_uid_to_decl
-        | None ->
-            let* cm_path =
-                Utils.StringSet.elements cm_paths
-                |> List.rev
-                |> List.find_opt (fun path -> Utils.Filepath.unit path = comp_unit)
-            in
-            let* cmt_infos = Cmt_format.read cm_path |> snd in
-            let cmt_uid_to_decl = cmt_infos.cmt_uid_to_decl in
-            Hashtbl.add cache comp_unit cmt_uid_to_decl;
-            Some cmt_uid_to_decl
+      let cached =
+        match from with
+        | Unit_info.Intf -> Cmt.cached_cmti comp_unit
+        | Unit_info.Impl -> Cmt.cached_cmt comp_unit
       in
+      let read_from_path () =
+        let* cm_path =
+          Utils.StringSet.elements cm_paths
+          |> List.rev
+          |> List.find_opt (fun path -> Utils.Filepath.unit path = comp_unit)
+        in
+        Cmt.read cm_path |> Result.to_option
+      in
+      let* cmi_cmt_infos =
+        match cached with
+        | Some _ as some -> some
+        | None  -> read_from_path ()
+      in
+      let cmt_infos = snd cmi_cmt_infos in
+      let cmt_uid_to_decl = cmt_infos.cmt_uid_to_decl in
       let* item_decl = UidTbl.find_opt cmt_uid_to_decl uid in
       loc_opt_of_item_decl item_decl
-  in
-  find_opt_external_uid_loc, clear_external_cache
 
 let cmt_decl_dep_to_loc_dep ~cm_paths cmt_decl_dep uid_to_loc =
   let convert_pair (_dep_kind, uid_def, uid_decl) =
@@ -59,7 +60,6 @@ let cmt_decl_dep_to_loc_dep ~cm_paths cmt_decl_dep uid_to_loc =
     Some (def_loc, decl_loc)
   in
   let res = List.filter_map convert_pair cmt_decl_dep in
-  clear_external_cache ();
   res
 
 let init ~cm_paths cmt_infos cmti_uid_to_decl =