diff --git a/src/tef/Sidekick_tef.real.ml b/src/tef/Sidekick_tef.real.ml index 163c4bce..e025ca10 100644 --- a/src/tef/Sidekick_tef.real.ml +++ b/src/tef/Sidekick_tef.real.ml @@ -61,17 +61,6 @@ module Make () : P.BACKEND = struct String.iter encode_char s; char oc '"' - let emit_duration_event ~name ~start ~end_ () : unit = - let dur = end_ -. start in - let ts = start in - let pid = Unix.getpid () in - let tid = Thread.id (Thread.self ()) in - emit_sep_ (); - Printf.fprintf oc - {json|{"pid": %d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"}|json} - pid tid dur ts str_val name; - () - (* emit args, if not empty. [ppv] is used to print values. *) let emit_args_o_ ppv oc args : unit = if args <> [] then ( @@ -84,6 +73,17 @@ module Make () : P.BACKEND = struct char oc '}' ) + let emit_duration_event ~name ~start ~end_ ~args () : unit = + let dur = end_ -. start in + let ts = start in + let pid = Unix.getpid () in + let tid = Thread.id (Thread.self ()) in + emit_sep_ (); + Printf.fprintf oc + {json|{"pid": %d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"%a}|json} + pid tid dur ts str_val name (emit_args_o_ str_val) args; + () + let emit_instant_event ~name ~ts ~args () : unit = let pid = Unix.getpid () in let tid = Thread.id (Thread.self ()) in diff --git a/src/util/Profile.ml b/src/util/Profile.ml index 5da6abf9..cc43cc8c 100644 --- a/src/util/Profile.ml +++ b/src/util/Profile.ml @@ -2,7 +2,12 @@ module type BACKEND = sig val get_ts : unit -> float val emit_duration_event : - name:string -> start:float -> end_:float -> unit -> unit + name:string -> + start:float -> + end_:float -> + args:(string * string) list -> + unit -> + unit val emit_instant_event : name:string -> ts:float -> args:(string * string) list -> unit -> unit @@ -49,47 +54,47 @@ let[@inline] count name cs = ) (* slow path *) -let[@inline never] exit_full_ (module B : BACKEND) name start = +let[@inline never] exit_full_ (module B : BACKEND) ~args name start = let now = B.get_ts () in - B.emit_duration_event ~name ~start ~end_:now () + B.emit_duration_event ~name ~start ~end_:now ~args () -let[@inline] exit_with_ b pb = +let[@inline] exit_with_ ~args b pb = match pb with | No_probe -> () - | Probe { name; start } -> exit_full_ b name start + | Probe { name; start } -> exit_full_ ~args b name start -let[@inline] exit pb = +let[@inline] exit ?(args = []) pb = match pb, !out_ with - | Probe { name; start }, Some b -> exit_full_ b name start + | Probe { name; start }, Some b -> exit_full_ ~args b name start | _ -> () -let[@inline] with_ name f = +let[@inline] with_ ?(args = []) name f = match !out_ with | None -> f () | Some b -> let pb = begin_with_ b name in (try let x = f () in - exit_with_ b pb; + exit_with_ ~args b pb; x with e -> - exit_with_ b pb; + exit_with_ ~args b pb; raise e) -let[@inline] with1 name f x = +let[@inline] with1 ?(args = []) name f x = match !out_ with | None -> f x | Some b -> let pb = begin_with_ b name in (try let res = f x in - exit_with_ b pb; + exit_with_ ~args b pb; res with e -> - exit_with_ b pb; + exit_with_ ~args b pb; raise e) -let[@inline] with2 name f x y = with_ name (fun () -> f x y) +let[@inline] with2 ?args name f x y = with_ ?args name (fun () -> f x y) module Control = struct let setup b = diff --git a/src/util/Profile.mli b/src/util/Profile.mli index b563ea6f..b44a9cc8 100644 --- a/src/util/Profile.mli +++ b/src/util/Profile.mli @@ -10,17 +10,25 @@ val null_probe : probe val enabled : unit -> bool val instant : ?args:(string * string) list -> string -> unit val begin_ : string -> probe -val exit : probe -> unit -val with_ : string -> (unit -> 'a) -> 'a -val with1 : string -> ('a -> 'b) -> 'a -> 'b -val with2 : string -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c +val exit : ?args:(string * string) list -> probe -> unit +val with_ : ?args:(string * string) list -> string -> (unit -> 'a) -> 'a +val with1 : ?args:(string * string) list -> string -> ('a -> 'b) -> 'a -> 'b + +val with2 : + ?args:(string * string) list -> string -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c + val count : string -> (string * int) list -> unit module type BACKEND = sig val get_ts : unit -> float val emit_duration_event : - name:string -> start:float -> end_:float -> unit -> unit + name:string -> + start:float -> + end_:float -> + args:(string * string) list -> + unit -> + unit val emit_instant_event : name:string -> ts:float -> args:(string * string) list -> unit -> unit