CP-53470 Additional spans in & around the pause section in VM.migrate

Signed-off-by: Aidan Allen <[email protected]>

Author: xs-aidan

ocaml/xenopsd/lib/xenops_server.ml

@@ -1835,28 +1835,6 @@ let rec atomics_of_operation = function
   | _ ->
       []
 
-let with_tracing ~name ~task f =
-  let open Tracing in
-  let parent = Xenops_task.tracing task in
-  let tracer = Tracer.get_tracer ~name in
-  match Tracer.start ~tracer ~name ~parent () with
-  | Ok span -> (
-      Xenops_task.set_tracing task span ;
-      try
-        let result = f () in
-        ignore @@ Tracer.finish span ;
-        Xenops_task.set_tracing task parent ;
-        result
-      with exn ->
-        let backtrace = Printexc.get_raw_backtrace () in
-        let error = (exn, backtrace) in
-        ignore @@ Tracer.finish span ~error ;
-        raise exn
-    )
-  | Error e ->
-      warn "Failed to start tracing: %s" (Printexc.to_string e) ;
-      f ()
-
 let rec perform_atomic ~progress_callback ?result (op : atomic)
     (t : Xenops_task.task_handle) : unit =
   let module B = (val get_backend () : S) in

ocaml/xenopsd/lib/xenops_task.ml

@@ -1,5 +1,7 @@
 open Xenops_utils
 
+module D = Debug.Make (struct let name = __MODULE__ end)
+
 module XI = struct
   include Xenops_interface
 
@@ -89,3 +91,25 @@ let traceparent_header_of_task t =
     )
     (Xenops_task.tracing t)
   |> Option.to_list
+
+let with_tracing ~name ~task f =
+  let open Tracing in
+  let parent = Xenops_task.tracing task in
+  let tracer = Tracer.get_tracer ~name in
+  match Tracer.start ~tracer ~name ~parent () with
+  | Ok span -> (
+      Xenops_task.set_tracing task span ;
+      try
+        let result = f () in
+        let _ : (Span.t option, exn) result = Tracer.finish span in
+        Xenops_task.set_tracing task parent ;
+        result
+      with exn ->
+        let backtrace = Printexc.get_raw_backtrace () in
+        let error = (exn, backtrace) in
+        let _ : (Span.t option, exn) result = Tracer.finish span ~error in
+        raise exn
+    )
+  | Error e ->
+      D.warn "Failed to start tracing: %s" (Printexc.to_string e) ;
+      f ()

ocaml/xenopsd/xc/device.ml

@@ -2501,6 +2501,7 @@ module Backend = struct
       let assert_can_suspend ~xs:_ _ = ()
 
       let suspend (task : Xenops_task.task_handle) ~xs ~qemu_domid domid =
+        with_tracing ~task ~name:"Qemu_none.Dm.suspend" @@ fun () ->
         Dm_Common.signal task ~xs ~qemu_domid ~domid "save" ~wait_for:"paused"
 
       let stop ~xs:_ ~qemu_domid:_ ~vtpm:_ _ = ()
@@ -3180,7 +3181,8 @@ module Backend = struct
 
       (* key not present *)
 
-      let suspend (_ : Xenops_task.task_handle) ~xs:_ ~qemu_domid:_ domid =
+      let suspend (task : Xenops_task.task_handle) ~xs:_ ~qemu_domid:_ domid =
+        with_tracing ~task ~name:"Qemu_upstream_compat.Dm.suspend" @@ fun () ->
         let as_msg cmd = Qmp.(Success (Some __LOC__, cmd)) in
         let perms = [Unix.O_WRONLY; Unix.O_CREAT] in
         let save_file = sprintf qemu_save_path domid in
@@ -3860,7 +3862,8 @@ module Dm = struct
     debug "Called Dm.restore_vgpu" ;
     start_vgpu ~xc ~xs task ~restore:true domid vgpus vcpus profile
 
-  let suspend_varstored (_ : Xenops_task.task_handle) ~xs domid ~vm_uuid =
+  let suspend_varstored (task : Xenops_task.task_handle) ~xs domid ~vm_uuid =
+    with_tracing ~task ~name:"Dm.suspend_varstored" @@ fun () ->
     debug "Called Dm.suspend_varstored (domid=%d)" domid ;
     Service.Varstored.stop ~xs domid ;
     Xenops_sandbox.Varstore_guard.read ~domid efivars_save_path ~vm_uuid
@@ -3877,6 +3880,7 @@ module Dm = struct
     debug "Wrote EFI variables to %s (domid=%d)" path domid
 
   let suspend_vtpm (task : Xenops_task.task_handle) ~xs domid ~vtpm =
+    with_tracing ~task ~name:"Dm.suspend_vtpm" @@ fun () ->
     debug "Called Dm.suspend_vtpm (domid=%d)" domid ;
     let dbg = Xenops_task.get_dbg task in
     Option.map

ocaml/xenopsd/xc/domain.ml

@@ -1702,22 +1702,23 @@ let suspend_emu_manager ~(task : Xenops_task.task_handle) ~xc:_ ~xs ~domain_type
           (string_of_message message) ;
         match message with
         | Suspend ->
-            do_suspend_callback () ;
-            if domain_type = `hvm then (
-              let vm_uuid = Uuidx.to_string uuid in
-              debug "VM = %s; domid = %d; suspending qemu-dm" vm_uuid domid ;
-              Device.Dm.suspend task ~xs ~qemu_domid ~dm domid ;
-              if is_uefi then
-                let (_ : string) =
-                  Device.Dm.suspend_varstored task ~xs domid ~vm_uuid
-                in
-                let (_ : string list) =
-                  Device.Dm.suspend_vtpm task ~xs domid ~vtpm
-                in
-                ()
+            ( with_tracing ~task ~name:"suspend_emu_manager Suspend" @@ fun () ->
+              do_suspend_callback () ;
+              if domain_type = `hvm then (
+                let vm_uuid = Uuidx.to_string uuid in
+                debug "VM = %s; domid = %d; suspending qemu-dm" vm_uuid domid ;
+                Device.Dm.suspend task ~xs ~qemu_domid ~dm domid ;
+                if is_uefi then
+                  let (_ : string) =
+                    Device.Dm.suspend_varstored task ~xs domid ~vm_uuid
+                  in
+                  let (_ : string list) =
+                    Device.Dm.suspend_vtpm task ~xs domid ~vtpm
+                  in
+                  ()
+              )
             ) ;
-            send_done cnx ;
-            wait_for_message ()
+            send_done cnx ; wait_for_message ()
         | Prepare x when x = "xenguest" ->
             debug "Writing Libxc header" ;
             write_header main_fd (Libxc, 0L) >>= fun () ->
@@ -1740,6 +1741,7 @@ let suspend_emu_manager ~(task : Xenops_task.task_handle) ~xc:_ ~xs ~domain_type
                 )
         )
         | Result _ ->
+            with_tracing ~task ~name:"suspend_emu_manager Result" @@ fun () ->
             debug "VM = %s; domid = %d; emu-manager completed successfully"
               (Uuidx.to_string uuid) domid ;
             return ()

ocaml/xenopsd/xc/dune

@@ -51,6 +51,8 @@
   xapi-stdext-std
   xapi-stdext-threads
   xapi-stdext-unix
+  xapi-tracing
+  xapi-tracing-export
   xapi_xenopsd
   xapi_xenopsd_c_stubs
   xapi_xenopsd_xc_c_stubs

ocaml/xenopsd/xc/xenops_server_xen.ml

@@ -2499,15 +2499,35 @@ module VM = struct
                   None
             in
             let manager_path = choose_emu_manager vm.Vm.platformdata in
+            with_tracing ~task ~name:"VM_save_domain_suspend" @@ fun () ->
             Domain.suspend task ~xc ~xs ~domain_type ~dm:(dm_of ~vm)
               ~vtpm:(vtpm_of ~vm) ~progress_callback ~qemu_domid ~manager_path
               ~is_uefi vm_str domid fd vgpu_fd flags' (fun () ->
+                with_tracing ~task ~name:"VM_save_domain_suspend_callback"
+                @@ fun () ->
                 (* SCTX-2558: wait more for ballooning if needed *)
-                wait_ballooning task vm ;
-                pre_suspend_callback task ;
-                if not (request_shutdown task vm Suspend 30.) then
+                ( with_tracing ~task ~name:"VM_save_wait_ballooning" @@ fun () ->
+                  wait_ballooning task vm
+                ) ;
+                ( with_tracing ~task ~name:"VM_save_pre_suspend_callback"
+                @@ fun () -> pre_suspend_callback task
+                ) ;
+
+                if
+                  not
+                    ( with_tracing ~task
+                        ~name:"VM_save_domain_suspend_callback_request_shutdown"
+                    @@ fun () -> request_shutdown task vm Suspend 30.
+                    )
+                then
                   raise (Xenopsd_error Failed_to_acknowledge_suspend_request) ;
-                if not (wait_shutdown task vm Suspend 1200.) then
+                if
+                  not
+                    ( with_tracing ~task
+                        ~name:"VM_save_domain_suspend_callback_wait_shutdown"
+                    @@ fun () -> wait_shutdown task vm Suspend 1200.
+                    )
+                then
                   raise (Xenopsd_error (Failed_to_suspend (vm.Vm.id, 1200.)))
             ) ;
             (* Record the final memory usage of the domain so we know how much