CA-403422: lengthen the timeout for xenopsd's serialized tasks (#6192)

Historically parallel operations were run in tasks as part of serial
operations, and serial tasks were not run as part of parallel ones. This
changed recently, causing some timeouts that did not happen before. To
mitigate this issue, now the timeouts for tasks are 20 minutes per
single
serialized operation, instead of 20 minutes per task.

Passed one of the VDI / VM scalibility tests that previously failed
reliably: Job 4182581

Author: psafont

ocaml/xenopsd/lib/xenops_server.ml

@@ -278,6 +278,15 @@ let rec name_of_atomic = function
   | Best_effort atomic ->
       Printf.sprintf "Best_effort (%s)" (name_of_atomic atomic)
 
+let rec atomic_expires_after = function
+  | Serial (_, _, ops) ->
+      List.map atomic_expires_after ops |> List.fold_left ( +. ) 0.
+  | Parallel (_, _, ops) ->
+      List.map atomic_expires_after ops |> List.fold_left Float.max 0.
+  | _ ->
+      (* 20 minutes, in seconds *)
+      1200.
+
 type vm_migrate_op = {
     vmm_id: Vm.id
   ; vmm_vdi_map: (string * string) list
@@ -1848,7 +1857,7 @@ let with_tracing ~name ~task f =
       warn "Failed to start tracing: %s" (Printexc.to_string e) ;
       f ()
 
-let rec perform_atomic ~progress_callback ?subtask:_ ?result (op : atomic)
+let rec perform_atomic ~progress_callback ?result (op : atomic)
     (t : Xenops_task.task_handle) : unit =
   let module B = (val get_backend () : S) in
   with_tracing ~name:(name_of_atomic op) ~task:t @@ fun () ->
@@ -2341,16 +2350,17 @@ and queue_atomics_and_wait ~progress_callback ~max_parallel_atoms dbg id ops =
                let atom_id =
                  Printf.sprintf "%s.chunk=%d.atom=%d" id chunk_idx atom_idx
                in
-               queue_atomic_int ~progress_callback dbg atom_id op
+               (queue_atomic_int ~progress_callback dbg atom_id op, op)
              )
              ops
          in
          let timeout_start = Unix.gettimeofday () in
          List.map
-           (fun task ->
+           (fun (task, op) ->
              let task_id = Xenops_task.id_of_handle task in
+             let expiration = atomic_expires_after op in
              let completion =
-               event_wait updates task ~from ~timeout_start 1200.0
+               event_wait updates task ~from ~timeout_start expiration
                  (is_task task_id) task_ended
              in
              (task_id, task, completion)
@@ -2386,7 +2396,7 @@ let perform_atomics atomics t =
           progress_callback progress (weight /. total_weight) t
         in
         debug "Performing: %s" (string_of_atomic x) ;
-        perform_atomic ~subtask:(string_of_atomic x) ~progress_callback x t ;
+        perform_atomic ~progress_callback x t ;
         progress_callback 1. ;
         progress +. (weight /. total_weight)
       )
@@ -2520,8 +2530,7 @@ and trigger_cleanup_after_failure_atom op t =
   | VM_import_metadata _ ->
       ()
 
-and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle)
-    : unit =
+and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit =
   let module B = (val get_backend () : S) in
   with_tracing ~name:(name_of_operation op) ~task:t @@ fun () ->
   match op with
@@ -2648,9 +2657,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle)
           (id, vm.Vm.memory_dynamic_min, vm.Vm.memory_dynamic_min)
       in
       let (_ : unit) =
-        perform_atomic ~subtask:(string_of_atomic atomic)
-          ~progress_callback:(fun _ -> ())
-          atomic t
+        perform_atomic ~progress_callback:(fun _ -> ()) atomic t
       in
       (* Waiting here is not essential but adds a degree of safety and
          reducess unnecessary memory copying. *)
@@ -3162,7 +3169,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle)
       VUSB_DB.signal id
   | Atomic op ->
       let progress_callback = progress_callback 0. 1. t in
-      perform_atomic ~progress_callback ?subtask ?result op t
+      perform_atomic ~progress_callback ?result op t
 
 and verify_power_state op =
   let module B = (val get_backend () : S) in
@@ -3191,7 +3198,7 @@ and perform ?subtask ?result (op : operation) (t : Xenops_task.task_handle) :
     unit =
   let one op =
     verify_power_state op ;
-    try perform_exn ?subtask ?result op t
+    try perform_exn ?result op t
     with e ->
       Backtrace.is_important e ;
       info "Caught %s executing %s: triggering cleanup actions"