Apply review comments to ocaml#1711

src/frontend/ocamlmerlin/new/new_merlin.ml

@@ -132,17 +132,13 @@ 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)
+            "heap_mbytes", `Int heap_mbytes;
+            "cache", Mpipeline.cache_information pipeline
           ]
         in
         log ~title:"run(result)" "%a" Logger.json (fun () -> json);

src/kernel/mpipeline.ml

@@ -102,7 +102,7 @@ type t = {
 
   ppx_cache_hit : bool ref;
   reader_cache_hit : bool ref;
-  buffer_cache_stats : string ref;
+  typer_cache_stats : Mtyper.typer_cache_stats ref;
 }
 
 let raw_source t = t.raw_source
@@ -237,7 +237,7 @@ let process
     ?(error_time=ref 0.0)
     ?(ppx_cache_hit = ref false)
     ?(reader_cache_hit = ref false)
-    ?(buffer_cache_stats = ref "")
+    ?(typer_cache_stats = ref Mtyper.Miss)
     ?for_completion
     config raw_source =
   let state = match state with
@@ -288,7 +288,7 @@ let process
       let (lazy {
             Reader.result = { Mreader.parsetree; _ };
             config;
-            cache_version
+            cache_version;
           }) = reader
       in
       let caught = ref [] in
@@ -313,12 +313,12 @@ let process
       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_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;
-    ppx_cache_hit; reader_cache_hit; buffer_cache_stats }
+    ppx_cache_hit; reader_cache_hit; typer_cache_stats }
 
 let make config source =
   process (Mconfig.normalize config) source
@@ -338,17 +338,28 @@ let timing_information t = [
 ]
 
 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
+  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 buffer = ("buffer", [
-      "stats", !(t.buffer_cache_stats)
-  ]) in
-  [phase; cmt; cmi; buffer]
+  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,4 +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
+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 =
@@ -51,7 +53,7 @@ type result = {
     | `Implementation of
         (Parsetree.structure_item, Typedtree.structure_item) item list
   ];
-  cache_stat : string
+  cache_stat : typer_cache_stats
 }
 
 let initial_env res = res.initial_env
@@ -65,10 +67,11 @@ let compatible_prefix result_items tree_items =
         && 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
+      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);
+        reused typed;
       acc, pitems, cache_stat
   in
   aux [] (result_items, tree_items)
@@ -111,7 +114,7 @@ let type_implementation config caught parsetree =
   let prefix, parsetree, cache_stat =
     match prefix with
     | Some (`Implementation items) -> compatible_prefix items parsetree
-    | Some (`Interface _) | None -> ([], parsetree, "miss")
+    | Some (`Interface _) | None -> ([], parsetree, Miss)
   in
   let env', snap', stamp', warn' = match prefix with
     | [] -> (env0, snap0, stamp0, Warnings.backup ())
@@ -132,7 +135,7 @@ let type_interface config caught parsetree =
   let prefix, parsetree, cache_stat =
     match prefix with
     | Some (`Interface items) -> compatible_prefix items parsetree
-    | Some (`Implementation _) | None -> ([], parsetree, "miss")
+    | Some (`Implementation _) | None -> ([], parsetree, Miss)
   in
   let env', snap', stamp', warn' = match prefix with
     | [] -> (env0, snap0, stamp0, Warnings.backup ())

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,7 +26,7 @@ val get_errors : result -> exn list
 
 val initial_env : result -> Env.t
 
-val get_cache_stat : result -> string
+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.

src/utils/file_cache.ml

@@ -36,16 +36,19 @@ end) = struct
   let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t
             = Hashtbl.create 17
 
-  let cache_stats = ref []
+  type cache_stats = { hit: int; miss: int }
+  let cache_hit = ref 0
+  let cache_miss = ref 0
 
-  let get_cache_stats () = !cache_stats
-  let clear_cache_stats () = cache_stats := []
+  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;
-      cache_stats := (filename, true) :: !cache_stats)
+      cache_hit := !cache_hit + 1)
     else (
       log ~title "%S was updated on disk" filename;
       raise Not_found;
@@ -59,7 +62,7 @@ end) = struct
     try get_cached_entry ~title fid filename
     with Not_found ->
     try
-      cache_stats := (filename, false) :: !cache_stats;
+      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

@@ -39,6 +39,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
+  type cache_stats = { hit: int; miss: int }
+  val get_cache_stats : unit -> cache_stats
   val clear_cache_stats : unit -> unit
 end