From 198f471467e57c2876f86a7d24c32ce01ba591bc Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 3 May 2024 16:05:02 +0200 Subject: [PATCH] [fleche] Handle performance data correctly for cached sentences We extend `Memo` as to store the original performance execution data, this way, we can display it correctly, and we distinguish the case where a sentence was memoized better. This is a fix, because before we would display the wrong data for incremental checking. This is complementary to #686 and #689. We cherry pick the protocol fixes from #689 as to have this PR in mergeable / testeable shape. We also send by default the full document perf data, instead of the atop 10 hotspots. --- CHANGES.md | 4 ++ editor/code/lib/types.ts | 4 +- editor/code/views/perf/App.tsx | 4 +- etc/doc/PROTOCOL.md | 11 ++- fleche/doc.ml | 124 ++++++++++++++++++--------------- fleche/doc.mli | 11 ++- fleche/memo.ml | 82 +++++++++++----------- fleche/memo.mli | 16 +++-- fleche/perf.ml | 4 +- fleche/perf.mli | 4 +- fleche/perf_analysis.ml | 35 ++++++---- fleche/stats.ml | 67 +++++++++++------- fleche/stats.mli | 37 +++++++--- 13 files changed, 234 insertions(+), 169 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index dac06c04..a018faf2 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -98,6 +98,10 @@ - Update `package-lock.json` for latest bugfixes (@ejgallego, #687) - Update Nix flake enviroment (@Alizter, #684 #688) - Update `prettier` (@Alizter @ejgallego, #684 #688) + - Store original performance data in the cache, so we now display the + original timing and memory data even for cached commands (@ejgallego, #) + - Fix type errors in the Performance Data Notifications (@ejgallego, + @Alizter, #) # coq-lsp 0.1.8.1: Spring fix ----------------------------- diff --git a/editor/code/lib/types.ts b/editor/code/lib/types.ts index 2de1f115..1a0a495a 100644 --- a/editor/code/lib/types.ts +++ b/editor/code/lib/types.ts @@ -114,9 +114,9 @@ export interface FlecheSaveParams { } export interface SentencePerfParams { - loc: Loc; + Range: Range; time: number; - mem: number; + memory: number; } export interface DocumentPerfParams { diff --git a/editor/code/views/perf/App.tsx b/editor/code/views/perf/App.tsx index 17f59a44..3dc29b09 100644 --- a/editor/code/views/perf/App.tsx +++ b/editor/code/views/perf/App.tsx @@ -33,14 +33,14 @@ function printWords(w: number) { function SentencePerfCell({ field, value }) { switch (field) { - case "loc": + case "range": let r = value as Range; return ( {`l: ${r.start.line} c: ${r.start.character} -- l: ${r.end.line} c: ${r.end.character}`} ); case "time": return {`${value.toFixed(4).toString()} secs`}; - case "mem": + case "memory": return {printWords(value)}; default: return null; diff --git a/etc/doc/PROTOCOL.md b/etc/doc/PROTOCOL.md index cc512143..5de66ee1 100644 --- a/etc/doc/PROTOCOL.md +++ b/etc/doc/PROTOCOL.md @@ -303,9 +303,9 @@ hotspots and memory use by sentences. ```typescript export interface SentencePerfParams { - loc: Loc, + range: Range, time: number, - mem, number + memory, number } export interface DocumentPerfParams { @@ -317,6 +317,13 @@ export interface DocumentPerfParams { #### Changelog +- v0.1.9: + + Fields renamed: `loc -> range`, `mem -> memory` + + Fixed type for `range`, it was always `Range` + + We now send the real time, even if the command was cached + + `memory` now means difference in memory from `GC.quick_stat` + + we send all the sentences in the document, not only the top 10 + hotspots, and we send them in document order - v0.1.7: Initial version ### Trim cache notification diff --git a/fleche/doc.ml b/fleche/doc.ml index 3e718d8b..94fe2822 100644 --- a/fleche/doc.ml +++ b/fleche/doc.ml @@ -30,13 +30,13 @@ module Util = struct (if !Config.v.mem_stats then let size = Memo.all_size () in Io.Log.trace "stats" (string_of_int size)); - let stats = Stats.dump () in - Io.Log.trace "cache" (Stats.to_string stats); - Io.Log.trace "cache" (Memo.CacheStats.stats ()); + let stats = Stats.Global.dump () in + Io.Log.trace "cache" (Stats.Global.to_string stats); + Io.Log.trace "cache" (Memo.GlobalCacheStats.stats ()); (* this requires patches to Coq *) (* Io.Log.error "coq parsing" (CoqParsingStats.dump ()); *) (* CoqParsingStats.reset (); *) - Memo.CacheStats.reset (); + Memo.GlobalCacheStats.reset (); Stats.reset () let safe_sub s pos len = @@ -76,29 +76,44 @@ module Node = struct module Info = struct type t = - { cache_hit : bool - ; parsing_time : float - ; time : float option - ; mw_prev : float - ; mw_after : float - ; stats : Stats.t (** Info about cumulative stats *) + { parsing_time : float + ; stats : Memo.Stats.t option + ; global_stats : Stats.Global.t (** Info about cumulative stats *) } - let make ?(cache_hit = false) ~parsing_time ?time ~mw_prev ~mw_after ~stats - () = - { cache_hit; parsing_time; time; mw_prev; mw_after; stats } + let make ~parsing_time ?stats ~global_stats () = + { parsing_time; stats; global_stats } + + let pp_cache_hit fmt = function + | None -> Format.fprintf fmt "N/A" + | Some hit -> Format.fprintf fmt "%b" hit let pp_time fmt = function | None -> Format.fprintf fmt "N/A" | Some time -> Format.fprintf fmt "%.3f" time - let print { cache_hit; parsing_time; time; mw_prev; mw_after; stats } = - let cptime = Stats.get_f stats ~kind:Stats.Kind.Parsing in - let cetime = Stats.get_f stats ~kind:Stats.Kind.Exec in + let pp_words fmt = function + | None -> Format.fprintf fmt "N/A" + | Some memory -> Stats.pp_words fmt memory + + let osplit = function + | None -> (None, None, None) + | Some (x, y, z) -> (Some x, Some y, Some z) + + let print { parsing_time; stats; global_stats } = + let cptime = Stats.Global.get_f global_stats ~kind:Stats.Kind.Parsing in + let cetime = Stats.Global.get_f global_stats ~kind:Stats.Kind.Exec in + let cache_hit, time, memory = + Option.map + (fun (s : Memo.Stats.t) -> + (s.cache_hit, s.stats.time, s.stats.memory)) + stats + |> osplit + in Format.asprintf - "Cached: %b | P: %.3f / %.2f | E: %a / %.2f | M: %a | Diff: %a" - cache_hit parsing_time cptime pp_time time cetime Stats.pp_words - mw_after Stats.pp_words (mw_after -. mw_prev) + "Cached: %a | P: %.3f / %.2f | E: %a / %.2f | Mem-Diff: %a" pp_cache_hit + cache_hit parsing_time cptime.time pp_time time cetime.time pp_words + memory end module Message = struct @@ -311,22 +326,19 @@ let drange = let end_ = Point.{ line = 0; character = 1; offset = 1 } in Range.{ start; end_ } -let process_init_feedback ~lines ~stats state feedback = +let process_init_feedback ~lines ~stats ~global_stats state feedback = let messages = List.map (Node.Message.feedback_to_message ~lines) feedback in if not (CList.is_empty messages) then let diags, messages = Diags.of_messages ~drange messages in let parsing_time = 0.0 in - let { Gc.major_words = mw_prev; _ } = Gc.quick_stat () in - let info = - Node.Info.make ~parsing_time ~mw_prev ~mw_after:mw_prev ~stats () - in + let info = Node.Info.make ~parsing_time ?stats ~global_stats () in let range = drange in [ { Node.range; ast = None; state; diags; messages; info } ] else [] (* Memoized call to [Coq.Init.doc_init] *) let mk_doc ~token ~env ~uri = - Memo.Init.eval ~token (env.Env.init, env.workspace, uri) + Memo.Init.evalS ~token (env.Env.init, env.workspace, uri) (* Create empty doc, in state [~completed] *) let empty_doc ~uri ~contents ~version ~env ~root ~nodes ~completed = @@ -350,17 +362,20 @@ let conv_error_doc ~raw ~uri ~version ~env ~root ~completed err = let err = (None, Diags.err, Pp.(str "Error in document conversion: " ++ str err)) in - let stats = Stats.dump () in - let nodes = process_init_feedback ~lines ~stats root [ err ] in + (* No execution to add *) + let stats = None in + let global_stats = Stats.Global.dump () in + let nodes = process_init_feedback ~lines ~stats ~global_stats root [ err ] in empty_doc ~uri ~version ~env ~root ~nodes ~completed ~contents let create ~token ~env ~uri ~version ~contents = let () = Stats.reset () in - let root = mk_doc ~token ~env ~uri in - Coq.Protect.E.map root ~f:(fun root -> - let nodes = [] in - let completed range = Completion.Stopped range in - empty_doc ~uri ~contents ~version ~env ~root ~nodes ~completed) + let root, stats = mk_doc ~token ~env ~uri in + ( Coq.Protect.E.map root ~f:(fun root -> + let nodes = [] in + let completed range = Completion.Stopped range in + empty_doc ~uri ~contents ~version ~env ~root ~nodes ~completed) + , stats ) (** Create a permanently failed doc, to be removed when we drop 8.16 support *) let handle_failed_permanent ~env ~uri ~version ~contents = @@ -369,10 +384,12 @@ let handle_failed_permanent ~env ~uri ~version ~contents = let doc, feedback = error_doc ~loc ~message ~uri ~contents ~version ~env ~completed in - let stats = Stats.dump () in + let stats = None in + let global_stats = Stats.Global.dump () in let nodes = let lines = contents.Contents.lines in - process_init_feedback ~lines ~stats env.Env.init feedback @ doc.nodes + process_init_feedback ~lines ~stats ~global_stats env.Env.init feedback + @ doc.nodes in let diags_dirty = not (CList.is_empty nodes) in { doc with nodes; diags_dirty } @@ -382,7 +399,7 @@ let handle_failed_permanent ~env ~uri ~version ~contents = the initial document. *) let handle_doc_creation_exec ~token ~env ~uri ~version ~contents = let completed range = Completion.Failed range in - let { Coq.Protect.E.r; feedback } = + let { Coq.Protect.E.r; feedback }, stats = create ~token ~env ~uri ~version ~contents in let doc, extra_feedback = @@ -400,10 +417,12 @@ let handle_doc_creation_exec ~token ~env ~uri ~version ~contents = | Completed (Ok doc) -> (doc, []) in let state = doc.root in - let stats = Stats.dump () in + let stats = Some stats in + let global_stats = Stats.Global.dump () in let nodes = let lines = contents.Contents.lines in - process_init_feedback ~lines ~stats state (feedback @ extra_feedback) + process_init_feedback ~lines ~stats ~global_stats state + (feedback @ extra_feedback) @ doc.nodes in let diags_dirty = not (CList.is_empty nodes) in @@ -659,16 +678,9 @@ let interp_and_info ~st ~files ast = | Some ast -> Memo.Require.evalS (st, files, ast) let interp_and_info ~token ~parsing_time ~st ~files ast = - let { Gc.major_words = mw_prev; _ } = Gc.quick_stat () in - (* memo memory stats are disabled: slow and misleading *) - let { Memo.Stats.res; cache_hit; memory = _; time } = - interp_and_info ~token ~st ~files ast - in - let { Gc.major_words = mw_after; _ } = Gc.quick_stat () in - let stats = Stats.dump () in - let info = - Node.Info.make ~cache_hit ~parsing_time ~time ~mw_prev ~mw_after ~stats () - in + let res, stats = interp_and_info ~token ~st ~files ast in + let global_stats = Stats.Global.dump () in + let info = Node.Info.make ~parsing_time ~stats ~global_stats () in (res, info) type parse_action = @@ -681,9 +693,10 @@ type parse_action = (* Returns parse_action, diags, parsing_time *) let parse_action ~token ~lines ~st last_tok doc_handle = let start_loc = Coq.Parsing.Parsable.loc doc_handle |> CLexer.after in - let parse_res, time = parse_stm ~token ~st doc_handle in + let parse_res, stats = parse_stm ~token ~st doc_handle in let f = Coq.Utils.to_range ~lines in let { Coq.Protect.E.r; feedback } = Coq.Protect.E.map_loc ~f parse_res in + let { Stats.time; memory = _ } = stats in match r with | Coq.Protect.R.Interrupted -> (EOF (Stopped last_tok), [], feedback, time) | Coq.Protect.R.Completed res -> ( @@ -727,11 +740,9 @@ let unparseable_node ~range ~parsing_diags ~parsing_feedback ~state ~parsing_time = let fb_diags, messages = Diags.of_messages ~drange:range parsing_feedback in let diags = fb_diags @ parsing_diags in - let stats = Stats.dump () in - let { Gc.major_words = mw_prev; _ } = Gc.quick_stat () in - let info = - Node.Info.make ~parsing_time ~mw_prev ~mw_after:mw_prev ~stats () - in + let stats = None in + let global_stats = Stats.Global.dump () in + let info = Node.Info.make ~parsing_time ?stats ~global_stats () in { Node.range; ast = None; diags; messages; state; info } let assemble_diags ~range ~parsing_diags ~parsing_feedback ~diags ~feedback = @@ -933,11 +944,12 @@ let process_and_parse ~io ~token ~target ~uri ~version doc last_tok doc_handle = let last_node = Util.hd_opt doc.nodes in let st, stats = Option.cata - (fun { Node.state; info = { stats; _ }; _ } -> (state, stats)) - (doc.root, Stats.zero ()) + (fun { Node.state; info = { global_stats; _ }; _ } -> + (state, global_stats)) + (doc.root, Stats.Global.zero ()) last_node in - Stats.restore stats; + Stats.Global.restore stats; let doc = stm doc st last_tok 0 in (* Set the document to "finished" mode: reverse the node list *) let doc = { doc with nodes = List.rev doc.nodes } in diff --git a/fleche/doc.mli b/fleche/doc.mli index 9eeb7c50..408736f1 100644 --- a/fleche/doc.mli +++ b/fleche/doc.mli @@ -14,13 +14,10 @@ module Node : sig end module Info : sig - type t = private - { cache_hit : bool - ; parsing_time : float - ; time : float option - ; mw_prev : float - ; mw_after : float - ; stats : Stats.t (** Info about cumulative stats *) + type t = + { parsing_time : float + ; stats : Memo.Stats.t option + ; global_stats : Stats.Global.t (** Info about cumulative stats *) } val print : t -> string diff --git a/fleche/memo.ml b/fleche/memo.ml index 11c84c76..281a36ab 100644 --- a/fleche/memo.ml +++ b/fleche/memo.ml @@ -1,21 +1,21 @@ module CS = Stats module Stats = struct - type 'a t = - { res : 'a - ; cache_hit : bool - ; memory : int - ; time : float + type t = + { stats : Stats.t + ; time_hash : float + (** Time in hashing consumed in the original execution *) + ; cache_hit : bool (** Whether we had a cache hit *) } - let make ?(cache_hit = false) ~time res = - (* This is quite slow! *) + let make ~stats ?(cache_hit = false) ~time_hash () = + (* This is quite slow, to the point it is not really usable, but a more + precise option *) (* let memory = Obj.magic res |> Obj.reachable_words in *) - let memory = 0 in - { res; cache_hit; memory; time } + { stats; time_hash; cache_hit } end -module CacheStats = struct +module GlobalCacheStats = struct let nhit, ntotal = (ref 0, ref 0) let reset () = @@ -50,12 +50,15 @@ module MemoTable = struct val clear : 'a t -> unit val add_execution : - ('a, 'l) Coq.Protect.E.t t -> key -> ('a, 'l) Coq.Protect.E.t -> unit + (('a, 'l) Coq.Protect.E.t * 'b) t + -> key + -> ('a, 'l) Coq.Protect.E.t * 'b + -> unit val add_execution_loc : - ('v * ('a, 'l) Coq.Protect.E.t) t + ('v * ('a, 'l) Coq.Protect.E.t * 'b) t -> key - -> 'v * ('a, 'l) Coq.Protect.E.t + -> 'v * ('a, 'l) Coq.Protect.E.t * 'b -> unit (** sorted *) @@ -87,12 +90,12 @@ module MemoTable = struct to_seq_values count |> List.of_seq |> List.sort (fun x y -> -Int.compare x y) - let add_execution t k ({ Coq.Protect.E.r; _ } as v) = + let add_execution t k (({ Coq.Protect.E.r; _ }, _) as v) = match r with | Coq.Protect.R.Interrupted -> () | _ -> add t k v - let add_execution_loc t k ((_, { Coq.Protect.E.r; _ }) as v) = + let add_execution_loc t k ((_, { Coq.Protect.E.r; _ }, _) as v) = match r with | Coq.Protect.R.Interrupted -> () | _ -> add t k v @@ -163,7 +166,9 @@ module type S = sig (** [eval i] Eval an input [i] and produce stats *) val evalS : - token:Coq.Limits.Token.t -> input -> (output, Loc.t) Coq.Protect.E.t Stats.t + token:Coq.Limits.Token.t + -> input + -> (output, Loc.t) Coq.Protect.E.t * Stats.t (** [size ()] Return the cache size in words, expensive *) val size : unit -> int @@ -191,28 +196,22 @@ module SEval (E : EvalType) : let all_freqs = HC.all_freqs let clear () = HC.clear cache - let eval ~token v = - match HC.find_opt cache v with - | None -> - let res = E.eval ~token v in - HC.add_execution cache v res; - res - | Some cached_res -> cached_res - let in_cache i = let kind = CS.Kind.Hashing in CS.record ~kind ~f:(HC.find_opt cache) i let evalS ~token i = match in_cache i with - | Some cached_res, time -> Stats.make ~cache_hit:true ~time cached_res - | None, time_hash -> + | Some (cached_res, stats), { time = time_hash; memory = _ } -> + (cached_res, Stats.make ~stats ~cache_hit:true ~time_hash ()) + | None, { time = time_hash; memory = _ } -> let kind = CS.Kind.Exec in let f i = E.eval ~token i in - let res, time_interp = CS.record ~kind ~f i in - let () = HC.add_execution cache i res in - let time = time_hash +. time_interp in - Stats.make ~cache_hit:false ~time res + let res, stats = CS.record ~kind ~f i in + let () = HC.add_execution cache i (res, stats) in + (res, Stats.make ~stats ~cache_hit:false ~time_hash ()) + + let eval ~token i = evalS ~token i |> fst end module type LocEvalType = sig @@ -229,7 +228,7 @@ module CEval (E : LocEvalType) = struct module Result = struct (* We store the location as to compute an offset for cached results *) - type t = Loc.t * (E.output, Loc.t) Coq.Protect.E.t + type t = Loc.t * (E.output, Loc.t) Coq.Protect.E.t * CS.t end type cache = Result.t HC.t @@ -246,24 +245,23 @@ module CEval (E : LocEvalType) = struct let kind = CS.Kind.Hashing in CS.record ~kind ~f:(HC.find_opt cache) i - let evalS ~token i : _ Stats.t = + let evalS ~token i = let stm_loc = E.loc_of_input i in match in_cache i with - | Some (cached_loc, res), time -> + | Some (cached_loc, res, stats), { time = time_hash; memory = _ } -> if Debug.cache then Io.Log.trace "memo" "cache hit"; - CacheStats.hit (); + GlobalCacheStats.hit (); let res = Loc_utils.adjust_offset ~stm_loc ~cached_loc res in - Stats.make ~cache_hit:true ~time res - | None, time_hash -> + (res, Stats.make ~stats ~cache_hit:true ~time_hash ()) + | None, { time = time_hash; memory = _ } -> if Debug.cache then Io.Log.trace "memo" "cache miss"; - CacheStats.miss (); + GlobalCacheStats.miss (); let kind = CS.Kind.Exec in - let res, time_interp = CS.record ~kind ~f:(E.eval ~token) i in - let () = HC.add_execution_loc cache i (stm_loc, res) in - let time = time_hash +. time_interp in - Stats.make ~time res + let res, stats = CS.record ~kind ~f:(E.eval ~token) i in + let () = HC.add_execution_loc cache i (stm_loc, res, stats) in + (res, Stats.make ~stats ~cache_hit:false ~time_hash ()) - let eval ~token i = (evalS ~token i).res + let eval ~token i = evalS ~token i |> fst end module VernacEval = struct diff --git a/fleche/memo.mli b/fleche/memo.mli index 22b167cc..bd5a21b7 100644 --- a/fleche/memo.mli +++ b/fleche/memo.mli @@ -1,9 +1,9 @@ module Stats : sig - type 'a t = - { res : 'a - ; cache_hit : bool - ; memory : int - ; time : float + type t = + { stats : Stats.t + ; time_hash : float + (** Time in hashing consumed in the original execution *) + ; cache_hit : bool (** Whether we had a cache hit *) } end @@ -20,7 +20,9 @@ module type S = sig (** [eval i] Eval an input [i] and produce stats *) val evalS : - token:Coq.Limits.Token.t -> input -> (output, Loc.t) Coq.Protect.E.t Stats.t + token:Coq.Limits.Token.t + -> input + -> (output, Loc.t) Coq.Protect.E.t * Stats.t (** [size ()] Return the cache size in words, expensive *) val size : unit -> int @@ -56,7 +58,7 @@ module Require : (** Admit evaluation cache *) module Admit : S with type input = Coq.State.t and type output = Coq.State.t -module CacheStats : sig +module GlobalCacheStats : sig val reset : unit -> unit (** Returns the hit ratio of the cache, etc... *) diff --git a/fleche/perf.ml b/fleche/perf.ml index 346829ac..2246c97b 100644 --- a/fleche/perf.ml +++ b/fleche/perf.ml @@ -7,9 +7,9 @@ module Sentence = struct type t = - { loc : Lang.Range.t + { range : Lang.Range.t ; time : float - ; mem : float + ; memory : float } end diff --git a/fleche/perf.mli b/fleche/perf.mli index 5e8bb57a..9d711ec2 100644 --- a/fleche/perf.mli +++ b/fleche/perf.mli @@ -7,9 +7,9 @@ module Sentence : sig type t = - { loc : Lang.Range.t + { range : Lang.Range.t ; time : float - ; mem : float + ; memory : float } end diff --git a/fleche/perf_analysis.ml b/fleche/perf_analysis.ml index 158c97b0..08a71215 100644 --- a/fleche/perf_analysis.ml +++ b/fleche/perf_analysis.ml @@ -5,19 +5,32 @@ let rec list_take n = function | x :: xs -> if n = 0 then [] else x :: list_take (n - 1) xs let mk_loc_time (n : Doc.Node.t) = - let time = Option.default 0.0 n.info.time in - let mem = n.info.mw_after -. n.info.mw_prev in - let loc = n.Doc.Node.range in - Sentence.{ loc; time; mem } + let time, memory = + Option.cata + (fun (stats : Memo.Stats.t) -> (stats.stats.time, stats.stats.memory)) + (0.0, 0.0) n.info.stats + in + let range = n.Doc.Node.range in + Sentence.{ range; time; memory } let get_stats ~(doc : Doc.t) = match List.rev doc.nodes with - | [] -> "no stats" - | n :: _ -> Stats.to_string n.info.stats + | [] -> "no global stats" + | n :: _ -> Stats.Global.to_string n.info.global_stats (** Turn into a config option at some point? This is very expensive *) let display_cache_size = false +let node_time_compare (n1 : Doc.Node.t) (n2 : Doc.Node.t) = + match (n1.info.stats, n2.info.stats) with + | Some s1, Some s2 -> -compare s1.stats.time s2.stats.time + | None, Some _ -> 1 + | Some _, None -> -1 + | None, None -> 0 + +(* Old mode of sending only the 10 hotspots *) +let hotspot = false + let make (doc : Doc.t) = let n_stm = List.length doc.nodes in let stats = get_stats ~doc in @@ -28,11 +41,9 @@ let make (doc : Doc.t) = Format.asprintf "{ num sentences: %d@\n; stats: %s; cache: %a@\n}" n_stm stats Stats.pp_words cache_size in - let top = - List.stable_sort - (fun (n1 : Doc.Node.t) n2 -> compare n2.info.time n1.info.time) - doc.nodes + let timings = + if hotspot then List.stable_sort node_time_compare doc.nodes |> list_take 10 + else doc.nodes in - let top = list_take 10 top in - let timings = List.map mk_loc_time top in + let timings = List.map mk_loc_time timings in { summary; timings } diff --git a/fleche/stats.ml b/fleche/stats.ml index 2ef7e5c8..ce37eeb9 100644 --- a/fleche/stats.ml +++ b/fleche/stats.ml @@ -14,44 +14,59 @@ module Kind = struct | Exec end -let stats = Hashtbl.create 1000 -let find kind = Hashtbl.find_opt stats kind |> Option.default 0.0 +type t = + { time : float + ; memory : float + } -type t = float * float * float +let stats : (Kind.t, t) Hashtbl.t = Hashtbl.create 1000 +let z = { time = 0.0; memory = 0.0 } +let find kind = Hashtbl.find_opt stats kind |> Option.default z -let zero () = (0.0, 0.0, 0.0) -let dump () = (find Kind.Hashing, find Kind.Parsing, find Kind.Exec) +module Global = struct + type nonrec 'a stats = t + type nonrec t = t * t * t -let restore (h, p, e) = - Hashtbl.replace stats Kind.Hashing h; - Hashtbl.replace stats Kind.Parsing p; - Hashtbl.replace stats Kind.Exec e + let zero () = (z, z, z) + let dump () = (find Kind.Hashing, find Kind.Parsing, find Kind.Exec) -let get_f (h, p, e) ~kind = - match kind with - | Kind.Hashing -> h - | Parsing -> p - | Exec -> e + let restore (h, p, e) = + Hashtbl.replace stats Kind.Hashing h; + Hashtbl.replace stats Kind.Parsing p; + Hashtbl.replace stats Kind.Exec e -let bump kind time = + let get_f (h, p, e) ~kind = + match kind with + | Kind.Hashing -> h + | Parsing -> p + | Exec -> e + + let to_string (h, p, e) = + Format.asprintf "hashing: %f | parsing: %f | exec: %f" h.time p.time e.time +end + +let bump kind { time; memory } = let acc = find kind in - Hashtbl.replace stats kind (acc +. time) + let time = acc.time +. time in + let memory = acc.memory +. memory in + Hashtbl.replace stats kind { time; memory } -let time f x = +let time_and_mem f x = + let { Gc.major_words = mw_prev; _ } = Gc.quick_stat () in let before = Unix.gettimeofday () in - let res = f x in + let v = f x in let after = Unix.gettimeofday () in - (res, after -. before) + let { Gc.major_words = mw_after; _ } = Gc.quick_stat () in + let time = after -. before in + let memory = mw_after -. mw_prev in + (v, { time; memory }) let record ~kind ~f x = - let res, time = time f x in - bump kind time; - (res, time) - -let get ~kind = find kind + let res, stats = time_and_mem f x in + bump kind stats; + (res, stats) -let to_string (h, p, e) = - Format.asprintf "hashing: %f | parsing: %f | exec: %f" h p e +let get_accumulated ~kind = find kind let reset () = Hashtbl.remove stats Kind.Hashing; diff --git a/fleche/stats.mli b/fleche/stats.mli index 4a0bf9c9..e7fa3216 100644 --- a/fleche/stats.mli +++ b/fleche/stats.mli @@ -1,4 +1,4 @@ -(** time-based stats *) +(** time and memory-based stats *) module Kind : sig type t = | Hashing @@ -6,17 +6,36 @@ module Kind : sig | Exec end -val get : kind:Kind.t -> float -val record : kind:Kind.t -> f:('a -> 'b) -> 'a -> 'b * float +type t = + { time : float + ; memory : float + } + +(** [record ~kind ~f x] returns [f x] with timing and memory use data attached + to it; it will also update the global table for [kind] *) +val record : kind:Kind.t -> f:('a -> 'b) -> 'a -> 'b * t + +(** [get_accumulated ~kind] returns global accumulated stats for [kind] *) +val get_accumulated : kind:Kind.t -> t + +(** [reset ()] Reset global accumulated stats *) val reset : unit -> unit -type t +module Global : sig + (** Operations to save/restore global accumulated state *) + type nonrec 'a stats = t + + type t -val zero : unit -> t -val to_string : t -> string -val dump : unit -> t -val restore : t -> unit -val get_f : t -> kind:Kind.t -> float + val zero : unit -> t + val dump : unit -> t + val restore : t -> unit + + (** Get a particular field *) + val get_f : t -> kind:Kind.t -> unit stats + + val to_string : t -> string +end (** Pretty-print memory info as words *) val pp_words : Format.formatter -> float -> unit