Locking_helpers: optimise waiting->acquired->release by looking up th…

…e thread local var just once

There is already a value returned from waiting_for that needs to e sent to acquired and the value returned from acquired sent to released.
Initially this was introduced to pass along Span.t, but it is more efficient to stor e the Span.t inside the thread local record,
and instead return the thread-local record.

That way we don't need to take the global mutex and look up the current thread in the global hash table on acquire and release,
it is sufficient to do that in waiting_for.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>

ocaml/xapi/locking_helpers.ml

@@ -137,10 +137,6 @@ let is_process name = function
 let string_of_resource r = r.str
 
 module Thread_state = struct
-  type waiting = Tracing.Span.t option * Tracing.Span.t option
-
-  type acquired = Tracing.Span.t option
-
   type time = float
 
   type t = {
@@ -150,8 +146,13 @@ module Thread_state = struct
     ; mutable task: API.ref_task
     ; mutable name: string
     ; mutable waiting_for: resource
+    ; mutable parent: Tracing.Span.t option
+    ; mutable span: Tracing.Span.t option
   }
 
+  type waiting = t
+  type acquired = t
+
   let acquired_resources t =
     if t.last_acquired_resource.kind = No_resource then
       t.acquired_resources_other
@@ -167,6 +168,8 @@ module Thread_state = struct
     ; task= Ref.null
     ; name= ""
     ; waiting_for= none
+    ; parent = None
+    ; span = None
     }
 
   let thread_states = Thread_local_storage.make make_empty
@@ -201,56 +204,50 @@ module Thread_state = struct
   let now () = Unix.gettimeofday ()
 
   let waiting_for ?parent resource =
-    let span =
-      match (parent : Tracing.Span.t option) with
-      | None ->
-          None
+    let ts = get_states () in
+    let () = match (parent : Tracing.Span.t option) with
+      | None -> ()
       | Some _ -> (
           let name = resource.waiting_str in
           let tracer = Tracing.get_tracer ~name in
           match Tracing.Tracer.start ~tracer ~name ~parent () with
           | Ok span ->
-              Some (parent, span)
+              ts.parent <- parent;
+              ts.span <- span;
           | Error e ->
               D.warn "Failed to start tracing: %s" (Printexc.to_string e) ;
-              None
         )
     in
-    let ts = get_states () in
     ts.waiting_for <- resource ;
-    span
+    ts
 
-  let acquired resource parent =
-    let span =
-      match parent with
-      | None ->
-          None
-      | Some (parent, span) -> (
-          let (_ : Tracing.Span.t option) = Tracing.Tracer.finish span in
+  let acquired resource ts =
+    let () = match ts.parent with
+      | None -> ()
+      | Some _ -> (
+          let (_ : Tracing.Span.t option) = Tracing.Tracer.finish ts.span in
           let name = resource.acquired_str in
           let tracer = Tracing.get_tracer ~name in
-          match Tracing.Tracer.start ~tracer ~name ~parent () with
+          match Tracing.Tracer.start ~tracer ~name ~parent:ts.parent () with
           | Ok span ->
-              span
+              ts.span <- span
           | Error e ->
               D.warn "Failed to start tracing: %s" (Printexc.to_string e) ;
-              None
+              ts.span <- None
         )
     in
-    let ts = get_states () in
     ts.waiting_for <- none ;
     if ts.last_acquired_resource.kind <> No_resource then
       ts.acquired_resources_other <-
         (ts.last_acquired_resource, ts.last_acquired_at)
         :: ts.acquired_resources_other ;
     ts.last_acquired_resource <- resource ;
     ts.last_acquired_at <- now () ;
-    span
+    ts
 
-  let released resource span =
-    let (_ : Tracing.Span.t option) = Tracing.Tracer.finish span in
-    let ts = get_states () in
-    if ts.last_acquired_resource = resource then
+  let released resource ts =
+    let (_ : Tracing.Span.t option) = Tracing.Tracer.finish ts.span in
+    if ts.last_acquired_resource == resource then
       ts.last_acquired_resource <- none
     else
       ts.acquired_resources_other <-

ocaml/xapi/locking_helpers.mli

@@ -36,10 +36,10 @@ module Thread_state : sig
   val with_named_thread : string -> API.ref_task -> (unit -> 'a) -> 'a
   (** Called when a thread becomes associated with a particular task *)
 
-  val waiting_for : ?parent:Tracing.Span.t -> resource -> waiting option
+  val waiting_for : ?parent:Tracing.Span.t -> resource -> waiting
   (** Called when a thread is about to block waiting for a resource to be free *)
 
-  val acquired : resource -> waiting option -> acquired
+  val acquired : resource -> waiting -> acquired
   (** Called when a thread acquires a resource *)
 
   val released : resource -> acquired -> unit

ocaml/xapi/xapi.ml

@@ -166,11 +166,13 @@ let register_callback_fns () =
   Xapi_cli.rpc_fun := Some fake_rpc ;
   let acquired = ref None in
   let set_stunnelpid _task_opt pid =
+    let resource = Locking_helpers.process ("stunnel", pid) in
+    let waiting = Locking_helpers.Thread_state.waiting_for resource in
     acquired :=
       Some
         (Locking_helpers.Thread_state.acquired
            (Locking_helpers.process ("stunnel", pid))
-           None
+            waiting
         )
   in
   let unset_stunnelpid _task_opt pid =