Merge branch 'private/edvint/instrument-locks0'

ocaml/libs/http-lib/xmlrpc_client.ml

@@ -27,11 +27,9 @@ module E = Debug.Make (struct let name = "mscgen" end)
 let () = Debug.disable ~level:Syslog.Debug "mscgen"
 
 module Internal = struct
-  let set_stunnelpid_callback : (string option -> int -> unit) option ref =
-    ref None
+  let set_unset_stunnelpid_callback = ref None
 
-  let unset_stunnelpid_callback : (string option -> int -> unit) option ref =
-    ref None
+  let set_stunnelpid_callback set = set_unset_stunnelpid_callback := Some set
 
   let destination_is_ok : (string -> bool) option ref = ref None
 end
@@ -345,19 +343,12 @@ let with_transport ?(stunnel_wait_disconnect = true) transport f =
         host port ;
       (* Call the {,un}set_stunnelpid_callback hooks around the remote call *)
       let with_recorded_stunnelpid f =
-        ( match !Internal.set_stunnelpid_callback with
-        | Some f ->
-            f task_id s_pid
-        | _ ->
-            ()
-        ) ;
-        finally f (fun () ->
-            match !Internal.unset_stunnelpid_callback with
-            | Some f ->
-                f task_id s_pid
-            | _ ->
-                ()
-        )
+        match !Internal.set_unset_stunnelpid_callback with
+        | Some set ->
+            let unset = set task_id s_pid in
+            finally f unset
+        | None ->
+            f ()
       in
       with_recorded_stunnelpid (fun () ->
           finally

ocaml/libs/http-lib/xmlrpc_client.mli

@@ -138,14 +138,9 @@ end
 module Internal : sig
   (** Internal functions should not be used by clients directly *)
 
-  val set_stunnelpid_callback : (string option -> int -> unit) option ref
-  (** When invoking an XMLRPC call over HTTPS via stunnel, this callback
-      		is called to allow us to store the association between a task and an
-      		stunnel pid *)
-
-  val unset_stunnelpid_callback : (string option -> int -> unit) option ref
-  (** After invoking an XMLRPC call over HTTPS via stunnel, this callback
-      		is called to allow us to forget the association between a task and an
+  val set_stunnelpid_callback : (string option -> int -> unit -> unit) -> unit
+  (** When invoking an XMLRPC call over HTTPS via stunnel, these callback
+      		are called to allow us to store and forget the association between a task and an
       		stunnel pid *)
 
   val destination_is_ok : (string -> bool) option ref

ocaml/libs/tracing/tracing.ml

@@ -416,21 +416,19 @@ module Tracer = struct
       Spans.add_to_spans ~span ; Ok (Some span)
 
   let finish ?error span =
-    Ok
-      (Option.map
-         (fun span ->
-           let span =
-             match error with
-             | Some exn_t ->
-                 Span.set_error span exn_t
-             | None ->
-                 Span.set_ok span
-           in
-           let span = Span.finish ~span () in
-           Spans.mark_finished span ; span
-         )
-         span
-      )
+    match span with
+    | None ->
+        None
+    | Some span ->
+        let span =
+          match error with
+          | Some exn_t ->
+              Span.set_error span exn_t
+          | None ->
+              Span.set_ok span
+        in
+        let span = Span.finish ~span () in
+        Spans.mark_finished span ; Some span
 
   let span_is_finished x = Spans.span_is_finished x
 

ocaml/libs/tracing/tracing.mli

@@ -73,8 +73,7 @@ module Tracer : sig
     -> unit
     -> (Span.t option, exn) result
 
-  val finish :
-    ?error:exn * string -> Span.t option -> (Span.t option, exn) result
+  val finish : ?error:exn * string -> Span.t option -> Span.t option
 
   val span_is_finished : Span.t option -> bool
 

ocaml/tests/bench/bechamel_simple_cli.ml

@@ -0,0 +1,49 @@
+(* based on bechamel example code *)
+open Bechamel
+open Toolkit
+
+let instances = Instance.[monotonic_clock; minor_allocated; major_allocated]
+
+let benchmark tests =
+  (* stabilize:true would be the default but it measures GC stabilization time as part of the function
+     runtime, leading to about 10x as much time measured than without.
+     It is also confusing for flamegraphs because the GC will show up much more frequently than in reality
+     due to the thousands of repeated calls.
+  *)
+  let cfg =
+    Benchmark.cfg
+      ~quota:Time.(second 5.0)
+      ~start:10 ~stabilize:false ~compaction:false ()
+  in
+  Benchmark.all cfg instances tests
+
+let analyze raw_results =
+  let ols =
+    Analyze.ols ~r_square:true ~bootstrap:0 ~predictors:[|Measure.run|]
+  in
+  let results =
+    List.map (fun instance -> Analyze.all ols instance raw_results) instances
+  in
+  (Analyze.merge ols instances results, raw_results)
+
+let () =
+  List.iter (fun i -> Bechamel_notty.Unit.add i (Measure.unit i)) instances
+
+let img (window, results) =
+  Bechamel_notty.Multiple.image_of_ols_results ~rect:window
+    ~predictor:Measure.run results
+
+open Notty_unix
+
+let cli tests =
+  Format.printf "@,Running benchmarks@." ;
+  let results, _ = tests |> benchmark |> analyze 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

ocaml/tests/bench/bench_named_mutex.ml

@@ -0,0 +1,50 @@
+open Bechamel
+
+let bench_tracing = true
+
+let test name allocate execute =
+  let test_mutex m = execute m ignore in
+  Test.make_with_resource ~name
+    Test.multiple (* TODO: Test.uniq segfaults here, bechamel bug *)
+    ~allocate ~free:ignore (Staged.stage test_mutex)
+
+let mutex_lock_unlock m f = Mutex.lock m ; f () ; Mutex.unlock m
+
+let tracing_benchmarks () =
+  let () = Suite_init.harness_init () in
+  let __context = Test_common.make_test_database () in
+  let observer =
+    Xapi_observer.create ~__context ~name_label:"test" ~name_description:""
+      ~hosts:[] ~attributes:[] ~endpoints:["bugtool"] ~components:["xapi"]
+      ~enabled:true
+  in
+  let host = !Xapi_globs.localhost_ref in
+  let () = Xapi_observer.register ~__context ~self:observer ~host in
+  let open Locking_helpers in
+  let named_trace_execute m f =
+    Context.with_tracing __context "bench" @@ fun __context ->
+    Named_mutex.execute m f
+  in
+  test "NamedMutex.execute (tracing)"
+    (fun () -> Named_mutex.create "test")
+    named_trace_execute
+
+let benchmarks =
+  let open Locking_helpers in
+  let named_execute m f = Named_mutex.execute m f in
+  Test.make_grouped ~name:"Mutex"
+    ([
+       test "Mutex.lock/unlock" Mutex.create mutex_lock_unlock
+     ; test "Mutex.execute" Mutex.create
+         Xapi_stdext_threads.Threadext.Mutex.execute
+     ; test "NamedMutex.execute"
+         (fun () -> Named_mutex.create "test")
+         named_execute
+     ]
+    @ if bench_tracing then [tracing_benchmarks ()] else []
+    )
+
+let () =
+  Gc.compact () ;
+  Memtrace.trace_if_requested () ;
+  Bechamel_simple_cli.cli benchmarks

ocaml/tests/bench/dune

@@ -0,0 +1,6 @@
+(executable
+ (name bench_named_mutex)
+ (modes exe)
+ (optional)
+ (libraries bechamel xapi_internal bechamel-notty notty.unix xapi-stdext-threads tests_common memtrace)
+)

ocaml/tests/dune

@@ -8,6 +8,7 @@
       test_vm_placement test_vm_helpers test_repository test_repository_helpers
       test_ref
       test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer
+      test_locking_helpers
       test_pool_periodic_update_sync))
   (libraries
     alcotest
@@ -123,6 +124,13 @@
 (modules test_observer)
 (libraries alcotest tracing xapi_internal tests_common yojson))
 
+(test
+(name test_locking_helpers)
+(package xapi)
+(modules test_locking_helpers)
+(libraries alcotest tracing xapi_internal tests_common)
+)
+
 (rule
   (alias runtest)
   (package xapi)