diff --git a/src/tef/dune b/src/tef/dune index acacd95..00d68bd 100644 --- a/src/tef/dune +++ b/src/tef/dune @@ -4,6 +4,9 @@ (public_name trace-tef) (synopsis "Simple and lightweight tracing using TEF/Catapult format, in-process") (libraries trace.core mtime mtime.clock.os atomic unix threads + (select on_gc_.ml from + (runtime_events -> on_gc_.real.ml) + (-> on_gc_.dummy.ml)) (select relax_.ml from (base-domain -> relax_.real.ml) ( -> relax_.dummy.ml)))) diff --git a/src/tef/on_gc_.dummy.ml b/src/tef/on_gc_.dummy.ml new file mode 100644 index 0000000..3073aa8 --- /dev/null +++ b/src/tef/on_gc_.dummy.ml @@ -0,0 +1,3 @@ +let run_poll ~on_gc_major:_ () = () +let shutdown () = () +let is_real = false diff --git a/src/tef/on_gc_.mli b/src/tef/on_gc_.mli new file mode 100644 index 0000000..885c5fc --- /dev/null +++ b/src/tef/on_gc_.mli @@ -0,0 +1,3 @@ +val run_poll : on_gc_major:(int64 -> int64 -> unit) -> unit -> unit +val shutdown : unit -> unit +val is_real : bool diff --git a/src/tef/on_gc_.real.ml b/src/tef/on_gc_.real.ml new file mode 100644 index 0000000..f6bf1a5 --- /dev/null +++ b/src/tef/on_gc_.real.ml @@ -0,0 +1,51 @@ +module Trace = Trace_core +module A = Trace.Internal_.Atomic_ +module RE = Runtime_events + +module I_tbl = Hashtbl.Make (struct + type t = int + + let equal : t -> t -> bool = ( = ) + let hash = Hashtbl.hash +end) + +type on_gc_major_handler = int64 -> int64 -> unit + +let active = A.make true +let shutdown () = A.set active false + +let run_poll ~(on_gc_major : on_gc_major_handler) () = + let begin_ = I_tbl.create 16 in + + let runtime_begin ring_id ts ev = + match ev with + | RE.EV_MAJOR -> I_tbl.add begin_ ring_id (RE.Timestamp.to_int64 ts) + | _ -> () + in + + let runtime_end ring_id ts_end ev = + match ev with + | RE.EV_MAJOR -> + (match I_tbl.find_opt begin_ ring_id with + | None -> () (* TODO: warn *) + | Some ts_start -> + I_tbl.remove begin_ ring_id; + let ts = RE.Timestamp.to_int64 ts_end in + on_gc_major ts_start ts) + | _ -> () + in + + RE.start (); + let cbs = RE.Callbacks.create ~runtime_begin ~runtime_end () in + let cursor = RE.create_cursor None in + + while A.get active do + let n = RE.read_poll cursor cbs None in + + (* sleep a bit if nothing happened *) + if n = 0 then Thread.delay 0.000_100 + done; + RE.pause (); + () + +let is_real = true diff --git a/src/tef/trace_tef.ml b/src/tef/trace_tef.ml index c644ac7..42d3740 100644 --- a/src/tef/trace_tef.ml +++ b/src/tef/trace_tef.ml @@ -11,15 +11,13 @@ module Mock_ = struct float_of_int x end -let counter = Mtime_clock.counter () - (** Now, in microseconds *) let now_us () : float = if !Mock_.enabled then Mock_.now_us () else ( - let t = Mtime_clock.count counter in - Mtime.Span.to_float_ns t /. 1e3 + let t = Mtime_clock.elapsed_ns () in + Int64.to_float t /. 1e3 ) let protect ~finally f = @@ -388,7 +386,7 @@ type output = | `File of string ] -let collector ~out () : collector = +let collector ~capture_gc ~out () : collector = let module M = struct let active = A.make true @@ -419,6 +417,37 @@ let collector ~out () : collector = else Thread.id (Thread.self ()) + let _t_gc : Thread.t option = + if capture_gc && On_gc_.is_real then ( + (* use initial tid for all events *) + let tid = get_tid_ () in + + let on_gc_major ts_start ts_stop : unit = + let name = "gc_major" in + try + B_queue.push events + (E_enter_context + { + tid; + name; + time_us = Int64.to_float ts_start /. 1e3; + data = []; + }); + B_queue.push events + (E_exit_context + { + tid; + name; + time_us = Int64.to_float ts_stop /. 1e3; + data = []; + }) + with B_queue.Closed -> On_gc_.shutdown () + in + let th = Thread.create (On_gc_.run_poll ~on_gc_major) () in + Some th + ) else + None + let with_span ~__FUNCTION__:fun_name ~__FILE__:_ ~__LINE__:_ ~data name f = let span = Int64.of_int (A.fetch_and_add span_id_gen_ 1) in let tid = get_tid_ () in @@ -507,26 +536,31 @@ let collector ~out () : collector = end in (module M) -let setup ?(out = `Env) () = +let setup ?(capture_gc = true) ?(out = `Env) () = match out with - | `Stderr -> Trace_core.setup_collector @@ collector ~out:`Stderr () - | `Stdout -> Trace_core.setup_collector @@ collector ~out:`Stdout () - | `File path -> Trace_core.setup_collector @@ collector ~out:(`File path) () + | `Stderr -> + Trace_core.setup_collector @@ collector ~capture_gc ~out:`Stderr () + | `Stdout -> + Trace_core.setup_collector @@ collector ~capture_gc ~out:`Stdout () + | `File path -> + Trace_core.setup_collector @@ collector ~capture_gc ~out:(`File path) () | `Env -> (match Sys.getenv_opt "TRACE" with | Some ("1" | "true") -> let path = "trace.json" in - let c = collector ~out:(`File path) () in + let c = collector ~capture_gc ~out:(`File path) () in Trace_core.setup_collector c - | Some "stdout" -> Trace_core.setup_collector @@ collector ~out:`Stdout () - | Some "stderr" -> Trace_core.setup_collector @@ collector ~out:`Stderr () + | Some "stdout" -> + Trace_core.setup_collector @@ collector ~capture_gc ~out:`Stdout () + | Some "stderr" -> + Trace_core.setup_collector @@ collector ~capture_gc ~out:`Stderr () | Some path -> - let c = collector ~out:(`File path) () in + let c = collector ~capture_gc ~out:(`File path) () in Trace_core.setup_collector c | None -> ()) -let with_setup ?out () f = - setup ?out (); +let with_setup ?capture_gc ?out () f = + setup ?capture_gc ?out (); protect ~finally:Trace_core.shutdown f module Internal_ = struct diff --git a/src/tef/trace_tef.mli b/src/tef/trace_tef.mli index 3aaf060..3d41daa 100644 --- a/src/tef/trace_tef.mli +++ b/src/tef/trace_tef.mli @@ -1,5 +1,8 @@ val collector : - out:[ `File of string | `Stderr | `Stdout ] -> unit -> Trace_core.collector + capture_gc:bool -> + out:[ `File of string | `Stderr | `Stdout ] -> + unit -> + Trace_core.collector (** Make a collector that writes into the given output. See {!setup} for more details. *) @@ -16,7 +19,7 @@ type output = named "foo" *) -val setup : ?out:[ output | `Env ] -> unit -> unit +val setup : ?capture_gc:bool -> ?out:[ output | `Env ] -> unit -> unit (** [setup ()] installs the collector depending on [out]. @param out can take different values: @@ -29,12 +32,17 @@ val setup : ?out:[ output | `Env ] -> unit -> unit - If it's set to "stderr", then logging happens on stdout (since 0.2) - Otherwise, if it's set to a non empty string, the value is taken to be the file path into which to write. + + @param capture_gc capture some GC events (since NEXT_RELEASE) *) -val with_setup : ?out:[ output | `Env ] -> unit -> (unit -> 'a) -> 'a +val with_setup : + ?capture_gc:bool -> ?out:[ output | `Env ] -> unit -> (unit -> 'a) -> 'a (** [with_setup () f] (optionally) sets a collector up, calls [f()], and makes sure to shutdown before exiting. since 0.2 a () argument was added. + + See {!setup} for more details *) (**/**)