Source file backend.ml

open Catapult_utils
module P = Catapult
module Tracing = P.Tracing

type event = P.Ser.Event.t

module type ARG = sig
  val conn : Connections.t
end

module Make (A : ARG) : P.BACKEND = struct
  let conn = A.conn
  let teardown () = Connections.close conn

  let[@inline] opt_map_ f = function
    | None -> None
    | Some x -> Some (f x)

  let conv_arg (key, a) =
    let open P.Ser in
    let value =
      match a with
      | `Int x -> Arg_value.Int64 (Int64.of_int x)
      | `String s -> Arg_value.String s
      | `Float f -> Arg_value.Float64 f
      | `Bool b -> Arg_value.Bool b
      | `Null -> Arg_value.Void
    in
    { Arg.key; value }

  let emit ~id ~name ~ph ~tid ~pid ~cat ~ts_us ~args ~stack ~dur ?extra () :
      unit =
    let ev =
      let open P.Ser in
      let tid = Int64.of_int tid in
      let pid = Int64.of_int pid in
      let stack = opt_map_ Array.of_list stack in
      let ph = P.Event_type.to_char ph |> Char.code in
      let cat = opt_map_ Array.of_list cat in
      let extra =
        match extra with
        | None -> None
        | Some l ->
          Some
            (Array.of_list l
            |> Array.map (fun (key, value) -> { Extra.key; value }))
      in
      let args =
        opt_map_ (fun l -> l |> Array.of_list |> Array.map conv_arg) args
      in
      { Event.id; name; ph; tid; pid; cat; ts_us; args; stack; dur; extra }
    in
    Connections.send_msg conn ~pid ~now:ts_us ev

  let tick () =
    let now = P.Clock.now_us () in
    let pid = Unix.getpid () in
    Gc_stats.maybe_emit ~now ~pid ()
end