Cache stats

src/frontend/ocamlmerlin/new/new_merlin.ml

@@ -132,12 +132,17 @@ let run = function
           let notify { Logger.section; msg } =
             `String (Printf.sprintf "%s: %s" section msg)
           in
+          let cache = Mpipeline.cache_information pipeline in
+          let format_cache (k,v) =
+            let fmt_str (k, v) = (k, `String v) in
+            (k, `Assoc (List.map fmt_str v)) in
           let format_timing (k,v) = (k, `Int (int_of_float (0.5 +. v))) in
           `Assoc [
             "class", `String class_; "value", message;
             "notifications", `List (List.rev_map notify !notifications);
             "timing", `Assoc (List.map format_timing timing);
             "heap_mbytes", `Int heap_mbytes
+            "cache", `Assoc (List.map format_cache cache)
           ]
         in
         log ~title:"run(result)" "%a" Logger.json (fun () -> json);

src/kernel/mpipeline.ml

@@ -99,6 +99,10 @@ type t = {
   ppx_time    : float ref;
   typer_time  : float ref;
   error_time  : float ref;
+
+  ppx_cache_hit : bool ref;
+  reader_cache_hit : bool ref;
+  buffer_cache_stats : string ref;
 }
 
 let raw_source t = t.raw_source
@@ -231,6 +235,9 @@ let process
     ?(ppx_time=ref 0.0)
     ?(typer_time=ref 0.0)
     ?(error_time=ref 0.0)
+    ?(ppx_cache_hit = ref false)
+    ?(reader_cache_hit = ref false)
+    ?(buffer_cache_stats = ref "")
     ?for_completion
     config raw_source =
   let state = match state with
@@ -267,10 +274,11 @@ let process
               Some "source preprocessor usage"
             | true, None -> None
           in
-          let { Reader_with_cache.output = { result; cache_version }; _ } =
+          let { Reader_with_cache.output = { result; cache_version }; cache_was_hit } =
             Reader_with_cache.apply ~cache_disabling
               { source; for_completion; config }
           in
+          reader_cache_hit := cache_was_hit;
           let cache_version =
             if Option.is_some cache_disabling then None else Some cache_version
           in
@@ -280,7 +288,7 @@ let process
       let (lazy {
             Reader.result = { Mreader.parsetree; _ };
             config;
-            cache_version;
+            cache_version
           }) = reader
       in
       let caught = ref [] in
@@ -293,21 +301,24 @@ let process
         | Some v -> None, Ppx_phase.Version v
         | None -> Some "reader cache is disabled", Off
       in
-      let { Ppx_with_cache.output = parsetree; _ } =
+      let { Ppx_with_cache.output = parsetree; cache_was_hit } =
         Ppx_with_cache.apply ~cache_disabling
           {parsetree; config; reader_cache}
       in
+      ppx_cache_hit := cache_was_hit;
       { Ppx.config; parsetree; errors = !caught }
     )) in
   let typer = timed_lazy typer_time (lazy (
       let lazy { Ppx. config; parsetree; _ } = ppx in
       Mocaml.setup_typer_config config;
       let result = Mtyper.run config parsetree in
       let errors = timed_lazy error_time (lazy (Mtyper.get_errors result)) in
+      buffer_cache_stats := Mtyper.get_cache_stat result;
       { Typer. errors; result }
     )) in
   { config; state; raw_source; source; reader; ppx; typer;
-    pp_time; reader_time; ppx_time; typer_time; error_time }
+    pp_time; reader_time; ppx_time; typer_time; error_time;
+    ppx_cache_hit; reader_cache_hit; buffer_cache_stats }
 
 let make config source =
   process (Mconfig.normalize config) source
@@ -325,3 +336,19 @@ let timing_information t = [
   "typer"  , !(t.typer_time);
   "error"  , !(t.error_time);
 ]
+
+let cache_information t =
+  let fmt_bool hit = if hit then "hit" else "miss" in
+  let phase = ("phase", [
+  "reader" , fmt_bool !(t.reader_cache_hit);
+  "ppx"    , fmt_bool !(t.ppx_cache_hit);
+  ]) in
+  let fmt_file (filename, hit) = (filename, fmt_bool hit) in
+  let cmt = ("cmt", List.map ~f:fmt_file (Cmt_cache.get_cache_stats ())) in
+  let cmi = ("cmi", List.map ~f:fmt_file (Cmi_cache.get_cache_stats ())) in
+  Cmt_cache.clear_cache_stats ();
+  Cmi_cache.clear_cache_stats ();
+  let buffer = ("buffer", [
+      "stats", !(t.buffer_cache_stats)
+  ]) in
+  [phase; cmt; cmi; buffer]

src/kernel/mpipeline.mli

@@ -26,3 +26,4 @@ val typer_result : t -> Mtyper.result
 val typer_errors : t -> exn list
 
 val timing_information : t -> (string * float) list
+val cache_information : t -> (string * (string * string) list) list

src/kernel/mtyper.ml

@@ -30,7 +30,7 @@ let fresh_env config =
 
 let get_cache config =
   match !cache with
-  | Some (env0, snap0, stamp0, items) when Types.is_valid snap0 ->
+  | Some (env0, snap0, stamp0, items, _) when Types.is_valid snap0 ->
     env0, snap0, stamp0, Some items
   | Some _ | None ->
     let env0, snap0, stamp0 = fresh_env config in
@@ -51,20 +51,25 @@ type result = {
     | `Implementation of
         (Parsetree.structure_item, Typedtree.structure_item) item list
   ];
+  cache_stat : string
 }
 
 let initial_env res = res.initial_env
 
+let get_cache_stat res = res.cache_stat
+
 let compatible_prefix result_items tree_items =
   let rec aux acc = function
     | (ritem :: ritems, pitem :: pitems)
       when Types.is_valid ritem.part_snapshot
         && compare ritem.parsetree_item pitem = 0 ->
       aux (ritem :: acc) (ritems, pitems)
     | (_, pitems) ->
+      let cache_stat = Printf.sprintf "reusing %d items, %d new items to type"
+        (List.length acc) (List.length pitems) in
       log ~title:"compatible_prefix" "reusing %d items, %d new items to type"
         (List.length acc) (List.length pitems);
-      acc, pitems
+      acc, pitems, cache_stat
   in
   aux [] (result_items, tree_items)
 
@@ -103,10 +108,10 @@ let rec type_signature caught env = function
 
 let type_implementation config caught parsetree =
   let env0, snap0, stamp0, prefix = get_cache config in
-  let prefix, parsetree =
+  let prefix, parsetree, cache_stat =
     match prefix with
     | Some (`Implementation items) -> compatible_prefix items parsetree
-    | Some (`Interface _) | None -> ([], parsetree)
+    | Some (`Interface _) | None -> ([], parsetree, "miss")
   in
   let env', snap', stamp', warn' = match prefix with
     | [] -> (env0, snap0, stamp0, Warnings.backup ())
@@ -120,14 +125,14 @@ let type_implementation config caught parsetree =
   Env.cleanup_functor_caches ~stamp:stamp';
   let suffix = type_structure caught env' parsetree in
   return_and_cache
-    (env0, snap0, stamp0, `Implementation (List.rev_append prefix suffix))
+    (env0, snap0, stamp0, `Implementation (List.rev_append prefix suffix), cache_stat)
 
 let type_interface config caught parsetree =
   let env0, snap0, stamp0, prefix = get_cache config in
-  let prefix, parsetree =
+  let prefix, parsetree, cache_stat =
     match prefix with
     | Some (`Interface items) -> compatible_prefix items parsetree
-    | Some (`Implementation _) | None -> ([], parsetree)
+    | Some (`Implementation _) | None -> ([], parsetree, "miss")
   in
   let env', snap', stamp', warn' = match prefix with
     | [] -> (env0, snap0, stamp0, Warnings.backup ())
@@ -141,7 +146,7 @@ let type_interface config caught parsetree =
   Env.cleanup_functor_caches ~stamp:stamp';
   let suffix = type_signature caught env' parsetree in
   return_and_cache
-    (env0, snap0, stamp0, `Interface (List.rev_append prefix suffix))
+    (env0, snap0, stamp0, `Interface (List.rev_append prefix suffix), cache_stat)
 
 let run config parsetree =
   if not (Env.check_state_consistency ()) then (
@@ -156,12 +161,12 @@ let run config parsetree =
   let caught = ref [] in
   Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () ->
   Typecore.reset_delayed_checks ();
-  let initial_env, initial_snapshot, initial_stamp, typedtree = match parsetree with
+  let initial_env, initial_snapshot, initial_stamp, typedtree, cache_stat = match parsetree with
     | `Implementation parsetree -> type_implementation config caught parsetree
     | `Interface parsetree -> type_interface config caught parsetree
   in
   Typecore.reset_delayed_checks ();
-  { config; initial_env; initial_snapshot; initial_stamp; typedtree }
+  { config; initial_env; initial_snapshot; initial_stamp; typedtree; cache_stat }
 
 let get_env ?pos:_ t =
   Option.value ~default:t.initial_env (

src/kernel/mtyper.mli

@@ -24,6 +24,8 @@ val get_errors : result -> exn list
 
 val initial_env : result -> Env.t
 
+val get_cache_stat : result -> string
+
 (** Heuristic to find suitable environment to complete / type at given position.
  *  1. Try to find environment near given cursor.
  *  2. Check if there is an invalid construct between found env and cursor :

src/utils/file_cache.ml

@@ -36,10 +36,16 @@ end) = struct
   let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t
             = Hashtbl.create 17
 
+  let cache_stats = ref []
+
+  let get_cache_stats () = !cache_stats
+  let clear_cache_stats () = cache_stats := []
+
   let get_cached_entry ~title fid filename =
     let fid', latest_use, file = Hashtbl.find cache filename in
-    if (File_id.check fid fid') then
-      log ~title "reusing %S" filename
+    if (File_id.check fid fid') then (
+      log ~title "reusing %S" filename;
+      cache_stats := (filename, true) :: !cache_stats)
     else (
       log ~title "%S was updated on disk" filename;
       raise Not_found;
@@ -53,6 +59,7 @@ end) = struct
     try get_cached_entry ~title fid filename
     with Not_found ->
     try
+      cache_stats := (filename, false) :: !cache_stats;
       log ~title "reading %S from disk" filename;
       let file = Input.read filename in
       Hashtbl.replace cache filename (fid, ref (Unix.time ()), file);

src/utils/file_cache.mli

@@ -38,4 +38,7 @@ end) : sig
 
   val get_cached_entry : string -> Input.t
   (** @raises Not_found if the file is not in cache. *)
+
+  val get_cache_stats : unit -> (string * bool) list
+  val clear_cache_stats : unit -> unit
 end

tests/merlin-wrapper

@@ -11,6 +11,7 @@ fi
 ocamlmerlin "$@" \
     | jq 'del(.timing)' \
     | jq 'del(.heap_mbytes)' \
+    | jq 'del(.cache)' \
     | sed -e 's:"[^"]*lib/ocaml:"lib/ocaml:g' \
     | sed -e 's:\\n:\
 :g'