wip: use runtime_events to capture major GC collection spans

problem: timestamps are not at all related to our use
of Mtime.elapsed.

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))))

src/tef/on_gc_.dummy.ml

@@ -0,0 +1,3 @@
+let run_poll ~on_gc_major:_ () = ()
+let shutdown () = ()
+let is_real = false

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

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

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

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
 *)
 
 (**/**)