From de8215b17276a4369a8c3d1e089d6f9c0176f788 Mon Sep 17 00:00:00 2001
From: Rafal Gwozdzinski <rafal@gwozdzinski.com>
Date: Tue, 12 Dec 2023 10:50:27 +0100
Subject: [PATCH] Enhance typing of typer cache

---
 src/kernel/mpipeline.ml | 18 +++++++++++-------
 src/kernel/mtyper.ml    | 15 +++++++++------
 src/kernel/mtyper.mli   |  4 +++-
 3 files changed, 23 insertions(+), 14 deletions(-)

diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml
index a5840b28ec..f325b44bc7 100644
--- a/src/kernel/mpipeline.ml
+++ b/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
@@ -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
@@ -348,7 +348,11 @@ let cache_information t =
   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)
+  let typer_stats_msg =
+    match !(t.typer_cache_stats) with
+    | Miss -> "miss"
+    | Hit { reused; typed } -> Printf.sprintf "reused %d items, typed %d new items" reused typed in
+  let typer = ("buffer", [
+      "stats", typer_stats_msg
   ]) in
-  [phase; cmt; cmi; buffer]
+  [phase; cmt; cmi; typer]
diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml
index f24c1f1287..034cb10c7d 100644
--- a/src/kernel/mtyper.ml
+++ b/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 ())
diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli
index 4acb235ca9..fd6a7a6b77 100644
--- a/src/kernel/mtyper.mli
+++ b/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.