Report cache hit/miss stats (ocaml#1711)

from 3Rafal/cache-stats

CHANGES.md

@@ -3,6 +3,8 @@ merlin NEXT_VERSION
 
   + merlin binary
     - Add a "heap_mbytes" field to Merlin server responses to report heap usage (#1717)
+    - Add cache stats to telemetry (#1711)
+
 
 merlin 4.13
 ===========

src/frontend/ocamlmerlin/new/new_merlin.ml

@@ -137,7 +137,8 @@ let run = function
             "class", `String class_; "value", message;
             "notifications", `List (List.rev_map notify !notifications);
             "timing", `Assoc (List.map format_timing timing);
-            "heap_mbytes", `Int heap_mbytes
+            "heap_mbytes", `Int heap_mbytes;
+            "cache", Mpipeline.cache_information pipeline
           ]
         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;
+  typer_cache_stats : Mtyper.typer_cache_stats 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)
+    ?(typer_cache_stats = ref Mtyper.Miss)
     ?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
@@ -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
+      typer_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; typer_cache_stats }
 
 let make config source =
   process (Mconfig.normalize config) source
@@ -325,3 +336,30 @@ let timing_information t = [
   "typer"  , !(t.typer_time);
   "error"  , !(t.error_time);
 ]
+
+let cache_information t =
+  let typer =
+    match !(t.typer_cache_stats) with
+    | Miss -> `String "miss"
+    | Hit { reused; typed } ->
+      `Assoc
+        [ "reused" , `Int reused;
+          "typed", `Int typed
+        ]
+  in
+  let fmt_hit_miss h m =
+    `Assoc [ "hit", `Int h; "miss", `Int m ] in
+  let cmt_stat = Cmt_cache.get_cache_stats () in
+  let cmt = fmt_hit_miss cmt_stat.hit cmt_stat.miss in
+  let cmi_stat = Cmi_cache.get_cache_stats () in
+  let cmi = fmt_hit_miss cmi_stat.hit cmi_stat.miss in
+  Cmt_cache.clear_cache_stats ();
+  Cmi_cache.clear_cache_stats ();
+  let fmt_bool hit = `String (if hit then "hit" else "miss") in
+  `Assoc [
+    "reader_phase" , fmt_bool !(t.reader_cache_hit);
+    "ppx_phase"    , fmt_bool !(t.ppx_cache_hit);
+    "typer"        , typer;
+    "cmt"          , cmt;
+    "cmi"          , cmi
+  ]

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 -> Std.json

src/kernel/mtyper.ml

@@ -19,6 +19,8 @@ type typedtree = [
   | `Implementation of Typedtree.structure
 ]
 
+type typer_cache_stats = Miss | Hit of { reused : int; typed : int }
+
 let cache = s_ref None
 
 let fresh_env config =
@@ -30,7 +32,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 +53,26 @@ type result = {
     | `Implementation of
         (Parsetree.structure_item, Typedtree.structure_item) item list
   ];
+  cache_stat : typer_cache_stats
 }
 
 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 reused = List.length acc in
+      let typed = List.length pitems in
+      let cache_stat = Hit { reused; typed } in
       log ~title:"compatible_prefix" "reusing %d items, %d new items to type"
-        (List.length acc) (List.length pitems);
-      acc, pitems
+        reused typed;
+      acc, pitems, cache_stat
   in
   aux [] (result_items, tree_items)
 
@@ -103,10 +111,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 +128,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 +149,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 +164,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

@@ -14,6 +14,8 @@ type typedtree = [
   | `Implementation of Typedtree.structure
 ]
 
+type typer_cache_stats = Miss | Hit of { reused : int; typed : int }
+
 val run : Mconfig.t -> Mreader.parsetree -> result
 
 val get_env : ?pos:Msource.position -> result -> Env.t
@@ -24,6 +26,8 @@ val get_errors : result -> exn list
 
 val initial_env : result -> Env.t
 
+val get_cache_stat : result -> typer_cache_stats
+
 (** 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,19 @@ end) = struct
   let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t
             = Hashtbl.create 17
 
+  type cache_stats = { hit: int; miss: int }
+  let cache_hit = ref 0
+  let cache_miss = ref 0
+
+  let get_cache_stats () = { hit = !cache_hit; miss = !cache_miss }
+  let clear_cache_stats () =
+    cache_hit := 0; cache_miss := 0
+
   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_hit := !cache_hit + 1)
     else (
       log ~title "%S was updated on disk" filename;
       raise Not_found;
@@ -53,6 +62,7 @@ end) = struct
     try get_cached_entry ~title fid filename
     with Not_found ->
     try
+      cache_miss := !cache_miss + 1;
       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,8 @@ end) : sig
 
   val get_cached_entry : string -> Input.t
   (** @raises Not_found if the file is not in cache. *)
+
+  type cache_stats = { hit: int; miss: int }
+  val get_cache_stats : unit -> cache_stats
+  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'