ocaml-trace/test/domains/t_domains.real.ml

(* Test concurrent span recording across multiple domains (OCaml 5+).
   Each domain runs [iters] spans.  We embed the recording thread's id into
   the span value so that exit events can be attributed to the right domain,
   then verify that every domain has exactly [iters] enters and exits. *)

let ( let@ ) = ( @@ )
let iters = 10_000

(* Custom span type that carries the thread id of the recording domain. *)
type Trace_core.span += Thread_span of int

let make_recorder () =
  let log = Queue.create () in
  let mu = Mutex.create () in
  let add x =
    Mutex.lock mu;
    Queue.add x log;
    Mutex.unlock mu
  in
  let enter_span () ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~level:_ ~params:_
      ~data:_ ~parent:_ _name =
    let tid = Thread.id (Thread.self ()) in
    add (`Enter tid);
    Thread_span tid
  in
  let exit_span () sp =
    match sp with
    | Thread_span tid -> add (`Exit tid)
    | _ -> ()
  in
  let message () ~level:_ ~params:_ ~data:_ ~span:_ _msg =
    add (`Msg (Thread.id (Thread.self ())))
  in
  let metric () ~level:_ ~params:_ ~data:_ _name _m = () in
  let add_data_to_span () _sp _data = () in
  let coll =
    Trace_core.Collector.(
      C_some
        ( (),
          Callbacks.make ~enter_span ~exit_span ~add_data_to_span ~message
            ~metric () ))
  in
  coll, fun () -> Queue.fold (fun acc x -> x :: acc) [] log |> List.rev

let () =
  print_endline "=== domain concurrency ===";
  let coll, get = make_recorder () in
  let@ () = Trace_core.with_setup_collector coll in
  let n = 4 in
  (* Each domain returns its own thread id so we can check per-domain counts. *)
  let domains =
    Array.init n (fun _i ->
        Domain.spawn (fun () ->
            let tid = Thread.id (Thread.self ()) in
            for j = 1 to iters do
              Trace_core.with_span ~__FILE__ ~__LINE__ "" @@ fun _ ->
              Trace_core.message "";
              if j mod 1000 = 0 then Thread.yield ()
            done;
            tid))
  in
  let tids = Array.map Domain.join domains in
  let events = get () in
  let count pred = List.length (List.filter pred events) in
  (* For each domain, verify exactly [iters] enters and [iters] exits. *)
  Array.iteri
    (fun i tid ->
      let n_enter =
        count (function
          | `Enter t -> t = tid
          | _ -> false)
      in
      let n_exit =
        count (function
          | `Exit t -> t = tid
          | _ -> false)
      in
      let n_msg =
        count (function
          | `Msg t -> t = tid
          | _ -> false)
      in
      Printf.printf "domain-%d: enter=%d exit=%d msg=%d%s\n" i n_enter n_exit
        n_msg
        (if n_enter = iters && n_exit = iters && n_msg = iters then
           ""
         else
           " FAIL"))
    tids