diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index 446ce1aaa5..203056e388 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/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); diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 6b63af6be5..0840243358 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; + 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,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 + 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] diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index 24355f19fa..da6854de3b 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 -> (string * (string * string) list) list diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 8920e76b41..f24c1f1287 100644 --- a/src/kernel/mtyper.ml +++ b/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,10 +51,13 @@ 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) @@ -62,9 +65,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 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 ( diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli index 77820e2b17..4acb235ca9 100644 --- a/src/kernel/mtyper.mli +++ b/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 : diff --git a/src/utils/file_cache.ml b/src/utils/file_cache.ml index 1010867ced..4e79b7439f 100644 --- a/src/utils/file_cache.ml +++ b/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); diff --git a/src/utils/file_cache.mli b/src/utils/file_cache.mli index 33fb2b8ed6..2fa80b6b1b 100644 --- a/src/utils/file_cache.mli +++ b/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 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'