diff --git a/CHANGES.md b/CHANGES.md index c64e869f21..d7e1121fe5 100644 --- a/CHANGES.md +++ b/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 =========== diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index 446ce1aaa5..d971dacead 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/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); diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 6b63af6be5..cbfedbe790 100644 --- a/src/kernel/mpipeline.ml +++ b/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,10 +301,11 @@ 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 ( @@ -304,10 +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 + 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 + ] diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index 24355f19fa..58355efdce 100644 --- a/src/kernel/mpipeline.mli +++ b/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 diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 8920e76b41..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 = @@ -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,10 +53,13 @@ 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) @@ -62,9 +67,12 @@ let compatible_prefix result_items tree_items = && 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 ( diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli index 77820e2b17..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,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 : diff --git a/src/utils/file_cache.ml b/src/utils/file_cache.ml index 1010867ced..0ce83ef54b 100644 --- a/src/utils/file_cache.ml +++ b/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); diff --git a/src/utils/file_cache.mli b/src/utils/file_cache.mli index 33fb2b8ed6..5ea735405b 100644 --- a/src/utils/file_cache.mli +++ b/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 diff --git a/tests/merlin-wrapper b/tests/merlin-wrapper index b343c6cb26..f38e307034 100755 --- a/tests/merlin-wrapper +++ b/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'