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