xapi-project
diff --git a/‎ocaml/libs/tracing/tracing.ml‎
Lines changed: 221 additions & 189 deletions b/‎ocaml/libs/tracing/tracing.ml‎
Lines changed: 221 additions & 189 deletions
diff --git a/‎ocaml/libs/tracing/tracing.mli‎
Lines changed: 32 additions & 9 deletions b/‎ocaml/libs/tracing/tracing.mli‎
Lines changed: 32 additions & 9 deletions
diff --git a/‎ocaml/libs/tracing/tracing_export.ml‎
Lines changed: 19 additions & 14 deletions b/‎ocaml/libs/tracing/tracing_export.ml‎
Lines changed: 19 additions & 14 deletions
diff --git a/‎ocaml/tests/bench/bechamel_simple_cli.ml‎
Lines changed: 153 additions & 0 deletions b/‎ocaml/tests/bench/bechamel_simple_cli.ml‎
Lines changed: 153 additions & 0 deletions
diff --git a/‎ocaml/tests/bench/bench_tracing.ml‎
Lines changed: 87 additions & 0 deletions b/‎ocaml/tests/bench/bench_tracing.ml‎
Lines changed: 87 additions & 0 deletions
diff --git a/‎ocaml/tests/bench/dune‎
Lines changed: 4 additions & 0 deletions b/‎ocaml/tests/bench/dune‎
Lines changed: 4 additions & 0 deletions
@@ -54,18 +54,40 @@ module SpanEvent : sig
   type t = {name: string; time: float; attributes: string Attributes.t}
 end
 
-module SpanContext : sig
+module Span_id : sig
   type t
 
-  val context : string -> string -> t
+  val make : unit -> t
+
+  val compare : t -> t -> int
+
+  val of_string : string -> t
+
+  val to_string : t -> string
+end
+
+module Trace_id : sig
+  type t
+
+  val make : unit -> t
+
+  val compare : t -> t -> int
+
+  val of_string : string -> t
+
+  val to_string : t -> string
+end
+
+module SpanContext : sig
+  type t
 
   val to_traceparent : t -> string
 
   val of_traceparent : string -> t option
 
-  val trace_id_of_span_context : t -> string
+  val trace_id_of_span_context : t -> Trace_id.t
 
-  val span_id_of_span_context : t -> string
+  val span_id_of_span_context : t -> Span_id.t
 end
 
 module Span : sig
@@ -98,17 +120,20 @@ module Span : sig
   val get_attributes : t -> (string * string) list
 end
 
+module TraceMap : module type of Map.Make (Trace_id)
+
+module SpanMap : module type of Map.Make (Span_id)
+
 module Spans : sig
   val set_max_spans : int -> unit
 
   val set_max_traces : int -> unit
 
   val span_count : unit -> int
 
-  val since : unit -> (string, Span.t list) Hashtbl.t
+  val since : unit -> Span.t list * int
 
-  val dump :
-    unit -> (string, Span.t list) Hashtbl.t * (string, Span.t list) Hashtbl.t
+  val dump : unit -> Span.t SpanMap.t TraceMap.t * (Span.t list * int)
 end
 
 module Tracer : sig
@@ -140,8 +165,6 @@ module Tracer : sig
   val finish :
     ?error:exn * string -> Span.t option -> (Span.t option, exn) result
 
-  val span_is_finished : Span.t option -> bool
-
   val span_hashtbl_is_empty : unit -> bool
 
   val finished_span_hashtbl_is_empty : unit -> bool
 
@@ -83,13 +83,24 @@ module Content = struct
              )
         in
         {
-          id= s |> Span.get_context |> SpanContext.span_id_of_span_context
-        ; traceId= s |> Span.get_context |> SpanContext.trace_id_of_span_context
+          id=
+            s
+            |> Span.get_context
+            |> SpanContext.span_id_of_span_context
+            |> Span_id.to_string
+        ; traceId=
+            s
+            |> Span.get_context
+            |> SpanContext.trace_id_of_span_context
+            |> Trace_id.to_string
         ; parentId=
             s
             |> Span.get_parent
             |> Option.map (fun x ->
-                   x |> Span.get_context |> SpanContext.span_id_of_span_context
+                   x
+                   |> Span.get_context
+                   |> SpanContext.span_id_of_span_context
+                   |> Span_id.to_string
                )
         ; name= s |> Span.get_name
         ; timestamp= int_of_float (Span.get_begin_time s *. 1000000.)
@@ -248,19 +259,15 @@ module Destination = struct
             | Bugtool ->
                 (file_export, "Tracing.File.export")
           in
-          let all_spans =
-            Hashtbl.fold (fun _ spans acc -> spans @ acc) traces []
-          in
+          let all_spans, count = traces in
           let attributes =
             [
               ("export.span.count", all_spans |> List.length |> string_of_int)
             ; ("export.endpoint", endpoint_to_string endpoint)
             ; ( "xs.tracing.spans_table.count"
               , Spans.span_count () |> string_of_int
               )
-            ; ( "xs.tracing.finished_spans_table.count"
-              , traces |> Hashtbl.length |> string_of_int
-              )
+            ; ("xs.tracing.finished_spans_table.count", string_of_int count)
             ]
           in
           let@ _ = with_tracing ~parent ~attributes ~name in
@@ -273,17 +280,15 @@ module Destination = struct
       debug "Tracing: unable to export span : %s" (Printexc.to_string exn)
 
   let flush_spans () =
-    let span_list = Spans.since () in
-    let attributes =
-      [("export.traces.count", Hashtbl.length span_list |> string_of_int)]
-    in
+    let ((_span_list, span_count) as span_info) = Spans.since () in
+    let attributes = [("export.traces.count", string_of_int span_count)] in
     let@ parent =
       with_tracing ~parent:None ~attributes ~name:"Tracing.flush_spans"
     in
     TracerProvider.get_tracer_providers ()
     |> List.filter TracerProvider.get_enabled
     |> List.concat_map TracerProvider.get_endpoints
-    |> List.iter (export_to_endpoint parent span_list)
+    |> List.iter (export_to_endpoint parent span_info)
 
   let delay = Delay.make ()
 
 
@@ -0,0 +1,153 @@
+open Bechamel
+open Toolkit
+
+(* Bechamel doesn't provide before/after hooks, just allocate/free, but those are done outside the place where
+   Bechamel checks for GC live words stabilization.
+*)
+let before_after ~before ~after ~get ~label ~unit =
+  let shared_state = Atomic.make None and called = Atomic.make 0 in
+  let module BeforeAfter = struct
+    type witness = int Atomic.t
+
+    let make () = Atomic.make 0
+
+    let load t = Atomic.set t 0
+
+    let unload _ = ()
+
+    let label _ = label
+
+    let unit _ = unit
+
+    let get _ =
+      (*
+        We get added to the instances both at the beginning and the end, so we get called 4 times:
+
+        get () - 0: None -> state := before ()
+        time ()
+        get () - 1
+        
+        benchmark_loop ()
+
+        get () - 2
+        time ()
+        get () - 3, after state, state := None
+
+        We want the time measurement to be as close to the benchmark loop as possible,
+        so we perform operations only on call 1 and 4
+      *)
+      let phase = Atomic.fetch_and_add called 1 mod 4 in
+      let old = Atomic.get shared_state in
+      match (old, phase) with
+      | None, 0 ->
+          before () |> Option.some |> Atomic.set shared_state ;
+          0.
+      | Some state, (1 | 2) ->
+          get state
+      | Some state, 3 ->
+          let r = get state in
+          Atomic.set shared_state None ;
+          after state ;
+          r
+      | None, _ ->
+          assert false
+      | Some _, _ ->
+          assert false
+  end in
+  let measure = Measure.register (module BeforeAfter) in
+  Measure.instance (module BeforeAfter) measure
+
+let skip_label = "workload"
+
+let thread_workload ~before ~run ~after =
+  let before () =
+    let state = before ()
+    and stop = Atomic.make false
+    and loops = Atomic.make 0 in
+    let thread_worker () =
+      while not (Atomic.get stop) do
+        Sys.opaque_identity (run state : unit) ;
+        Atomic.incr loops
+      done
+    in
+    let t = Thread.create thread_worker () in
+    (state, stop, loops, t)
+  and after (state, stop, _loops, worker) =
+    Atomic.set stop true ; Thread.join worker ; after state
+  and get (_, _, loops, _) = Atomic.fetch_and_add loops 1 |> float_of_int in
+  before_after ~before ~after ~get ~label:skip_label ~unit:"loops"
+
+(* based on bechamel example code *)
+
+(* For very short benchmarks ensure that they get to run long enough to switch threads
+   a few times.
+    Bechamel has both an iteration count and time limit, so this won't be a problem for slower benchmarks.
+*)
+let limit = 10_000_000
+
+let benchmark ~instances tests =
+  let cfg = Benchmark.cfg ~limit ~quota:(Time.second 10.0) () in
+  Benchmark.all cfg instances tests
+
+let analyze ~instances raw_results =
+  let ols ~bootstrap =
+    Analyze.ols ~bootstrap ~r_square:true ~predictors:[|Measure.run|]
+  in
+  let results =
+    List.map
+      (fun instance ->
+        let f bootstrap = Analyze.all (ols ~bootstrap) instance raw_results in
+        try f 3000 with _ -> f 0
+      )
+      instances
+  in
+  (Analyze.merge (ols ~bootstrap:3000) instances results, raw_results)
+
+open Notty_unix
+
+let img (window, results) =
+  Bechamel_notty.Multiple.image_of_ols_results ~rect:window
+    ~predictor:Measure.run results
+  |> eol
+
+let not_workload measure = not (Measure.label measure = skip_label)
+
+let run_and_print instances tests =
+  let results, _ =
+    tests
+    |> benchmark ~instances
+    |> analyze ~instances:(List.filter not_workload instances)
+  in
+  let window =
+    match winsize Unix.stdout with
+    | Some (w, h) ->
+        {Bechamel_notty.w; h}
+    | None ->
+        {Bechamel_notty.w= 80; h= 1}
+  in
+  img (window, results) |> eol |> output_image ;
+  results
+  |> Hashtbl.iter @@ fun label results ->
+     if label = Measure.label Instance.monotonic_clock then
+       let units = Bechamel_notty.Unit.unit_of_label label in
+       results
+       |> Hashtbl.iter @@ fun name ols ->
+          Format.printf "%s (%s):@, %a@." name units Analyze.OLS.pp ols
+
+let cli ?(always = []) ?(workloads = []) tests =
+  let instances =
+    always
+    @ Instance.[monotonic_clock; minor_allocated; major_allocated]
+    @ always
+  in
+  List.iter (fun i -> Bechamel_notty.Unit.add i (Measure.unit i)) instances ;
+  Format.printf "@,Running benchmarks (no workloads)@." ;
+  run_and_print instances tests ;
+
+  if workloads <> [] then (
+    Format.printf "@,Running benchmarks (workloads)@." ;
+    List.iter (fun i -> Bechamel_notty.Unit.add i (Measure.unit i)) workloads ;
+    (* workloads come first, so that we unpause them in time *)
+    let instances = workloads @ instances @ workloads in
+    run_and_print instances tests
+  )
@@ -0,0 +1,87 @@
+open Bechamel
+
+let ( let@ ) f x = f x
+
+(* TODO: before *)
+
+let trace_test_inner span =
+  let@ span =
+    Tracing.with_child_trace
+      ~attributes:[("foo", "testing")]
+      span ~name:__FUNCTION__
+  in
+  let@ _ =
+    Tracing.with_child_trace ~attributes:[("bar", "val")] span ~name:"test"
+  in
+  Sys.opaque_identity ignore ()
+
+let trace_test_span _ = Tracing.with_tracing ~name:__FUNCTION__ trace_test_inner
+
+let trace_test_off _ = trace_test_inner None
+
+let uuid = "TEST"
+
+let export_thread =
+  (* need to ensure this isn't running outside the benchmarked section,
+     or bechamel might fail with 'Failed to stabilize GC'
+  *)
+  let after _ = Tracing_export.flush_and_exit () in
+  Bechamel_simple_cli.thread_workload ~before:Tracing_export.main ~after
+    ~run:ignore
+
+let workload1 =
+  Bechamel_simple_cli.thread_workload ~before:ignore ~after:ignore
+    ~run:trace_test_span
+
+let create_gc_work =
+  let a = Array.make 1_000 "" in
+  fun () ->
+    (* create work for the GC by continously creating a lot of short lived strings *)
+    Sys.opaque_identity (Array.iteri (fun i _ -> a.(i) <- String.make 2 'x') a)
+
+let workload2 =
+  Bechamel_simple_cli.thread_workload ~before:ignore ~after:ignore
+    ~run:create_gc_work
+
+let workloads = [workload1; workload2]
+
+let allocate () =
+  Tracing.TracerProvider.create ~enabled:true ~attributes:[] ~endpoints:[]
+    ~name_label:__MODULE__ ~uuid ;
+  Tracing_export.main ()
+
+let free t =
+  Tracing.TracerProvider.destroy ~uuid ;
+  Tracing_export.flush_and_exit () ;
+  Thread.join t
+
+let test_tracing_on ?(overflow = false) ~name f =
+  let allocate () =
+    if overflow then (
+      Tracing.Spans.set_max_spans 10 ;
+      Tracing.Spans.set_max_traces 10
+    ) ;
+    allocate ()
+  and free t =
+    if overflow then (
+      Tracing.Spans.set_max_spans Bechamel_simple_cli.limit ;
+      Tracing.Spans.set_max_traces Bechamel_simple_cli.limit
+    ) ;
+    free t
+  in
+  Test.make_with_resource ~name ~allocate ~free Test.uniq f
+
+let benchmarks =
+  Tracing.Spans.set_max_spans Bechamel_simple_cli.limit ;
+  Tracing.Spans.set_max_traces Bechamel_simple_cli.limit ;
+  Test.make_grouped ~name:"tracing"
+    [
+      Test.make ~name:"overhead(off)" (Staged.stage trace_test_off)
+    ; test_tracing_on ~name:"overhead(on, no span)" (Staged.stage trace_test_off)
+    ; test_tracing_on ~name:"overhead(on, create span)"
+        (Staged.stage trace_test_span)
+    ; test_tracing_on ~overflow:true ~name:"max span overflow"
+        (Staged.stage trace_test_span)
+    ]
+
+let () = Bechamel_simple_cli.cli ~always:[export_thread] ~workloads benchmarks
@@ -0,0 +1,4 @@
+(executable
+	(name bench_tracing)
+	(libraries tracing bechamel bechamel-notty notty.unix tracing_export threads.posix fmt notty)
+)