CP-52880: Avoid O(N^2) behaviour in Xapi_vdi.update_allowed_operations

ocaml/tests/bench/bench_vdi_allowed_operations.ml

@@ -0,0 +1,59 @@
+open Bechamel
+
+module D = Debug.Make (struct let name = __MODULE__ end)
+
+(* tested configuration limits *)
+let max_hosts = 64
+
+let max_vms = (*2400*) 240
+
+let max_vbds = (* 255 *) 25
+
+let () =
+  (* a minimal harness init *)
+  Suite_init.harness_init () ;
+  (* don't spam the logs in [allocate] *)
+  Debug.set_level Syslog.Info
+
+let allocate () =
+  let open Test_common in
+  let __context = make_test_database () in
+  let (_sm_ref : API.ref_SM) = make_sm ~__context () in
+  let sr_ref = make_sr ~__context () in
+  let (_ : API.ref_PBD array) =
+    Array.init max_hosts (fun _ -> make_pbd ~__context ~sR:sr_ref ())
+  in
+  let vms =
+    Array.init max_vms @@ fun _ ->
+    let vm_ref = make_vm ~__context () in
+    Array.init (max_vbds / 2) @@ fun _ ->
+    let vdi_ref = make_vdi ~__context ~sR:sr_ref () in
+    let vbd_ref =
+      make_vbd ~__context ~vDI:vdi_ref ~vM:vm_ref ~currently_attached:true
+        ~mode:`RO ()
+    in
+    let vdi_ref' = make_vdi ~__context ~sR:sr_ref () in
+    let vbd_ref' =
+      make_vbd ~__context ~vDI:vdi_ref' ~vM:vm_ref ~currently_attached:true
+        ~mode:`RW ()
+    in
+    (vdi_ref, vbd_ref, vdi_ref', vbd_ref')
+  in
+  D.info "Created test database" ;
+  (__context, vms)
+
+let test_vdi_update_allowed_operations (__context, vm_disks) =
+  let _, _, vdi_ref, vbd_ref = vm_disks.(0).(0) in
+  Db.VBD.set_currently_attached ~__context ~self:vbd_ref ~value:true ;
+  Xapi_vdi.update_allowed_operations ~__context ~self:vdi_ref ;
+  Db.VBD.set_currently_attached ~__context ~self:vbd_ref ~value:false ;
+  Xapi_vdi.update_allowed_operations ~__context ~self:vdi_ref
+
+let benchmarks =
+  Test.make_grouped ~name:"update_allowed_operations"
+    [
+      Test.make_with_resource ~name:"VDI" ~allocate ~free:ignore Test.uniq
+        (Staged.stage test_vdi_update_allowed_operations)
+    ]
+
+let () = Bechamel_simple_cli.cli benchmarks

ocaml/tests/bench/dune

@@ -1,4 +1,21 @@
 (executables
-	(names bench_tracing bench_uuid bench_throttle2 bench_cached_reads)
-	(libraries tracing bechamel bechamel-notty notty.unix tracing_export threads.posix fmt notty uuid xapi_aux tests_common log xapi_internal)
-)
+ (names
+  bench_tracing
+  bench_uuid
+  bench_throttle2
+  bench_cached_reads
+  bench_vdi_allowed_operations)
+ (libraries
+  tracing
+  bechamel
+  bechamel-notty
+  notty.unix
+  tracing_export
+  threads.posix
+  fmt
+  notty
+  uuid
+  xapi_aux
+  tests_common
+  log
+  xapi_internal))

ocaml/xapi/cancel_tasks.ml

@@ -83,14 +83,14 @@ let update_all_allowed_operations ~__context =
       in
       let vbd_records =
         List.map
-          (fun vbd -> (vbd, Db.VBD.get_record_internal ~__context ~self:vbd))
+          (fun vbd -> Db.VBD.get_record_internal ~__context ~self:vbd)
           all_vbds
       in
       List.iter
         (safe_wrapper "allowed_ops - VDIs" (fun self ->
              let relevant_vbds =
                List.filter
-                 (fun (_, vbd_record) -> vbd_record.Db_actions.vBD_VDI = self)
+                 (fun vbd_record -> vbd_record.Db_actions.vBD_VDI = self)
                  vbd_records
              in
              Xapi_vdi.update_allowed_operations_internal ~__context ~self

ocaml/xapi/xapi_globs.ml

@@ -500,6 +500,16 @@ let rpu_allowed_vm_operations =
   ; `update_allowed_operations
   ]
 
+module Vdi_operations = struct
+  type t = API.vdi_operations
+
+  (* this is more efficient than just 'let compare = Stdlib.compare',
+     because the compiler can specialize it to [t] without calling any runtime functions *)
+  let compare (a : t) (b : t) = Stdlib.compare a b
+end
+
+module Vdi_operations_set = Set.Make (Vdi_operations)
+
 (* Until the Ely release, the vdi_operations enum had stayed unchanged
  * since 2009 or earlier, but then Ely and some subsequent releases
  * added new members to the enum. *)
@@ -517,6 +527,7 @@ let pre_ely_vdi_operations =
   ; `generate_config
   ; `blocked
   ]
+  |> Vdi_operations_set.of_list
 
 (* We might consider restricting this further. *)
 let rpu_allowed_vdi_operations = pre_ely_vdi_operations

ocaml/xapi/xapi_vdi.ml

@@ -86,7 +86,10 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = [])
   let* () =
     if
       Helpers.rolling_upgrade_in_progress ~__context
-      && not (List.mem op Xapi_globs.rpu_allowed_vdi_operations)
+      && not
+           (Xapi_globs.Vdi_operations_set.mem op
+              Xapi_globs.rpu_allowed_vdi_operations
+           )
     then
       Error (Api_errors.not_supported_during_upgrade, [])
     else
@@ -96,7 +99,7 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = [])
     (* Don't fail with other_operation_in_progress if VDI mirroring is in
        progress and destroy is called as part of VDI mirroring *)
     let is_vdi_mirroring_in_progress =
-      List.exists (fun (_, op) -> op = `mirror) current_ops && op = `destroy
+      op = `destroy && List.exists (fun (_, op) -> op = `mirror) current_ops
     in
     if
       List.exists (fun (_, op) -> op <> `copy) current_ops
@@ -130,7 +133,7 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = [])
           pbd_records
   in
   let* () =
-    if pbds_attached = [] && List.mem op [`resize] then
+    if pbds_attached = [] && op = `resize then
       Error (Api_errors.sr_no_pbds, [Ref.string_of sr])
     else
       Ok ()
@@ -155,16 +158,14 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = [])
                )
           )
     | Some records ->
-        List.map snd
-          (List.filter
-             (fun (_, vbd_record) ->
-               vbd_record.Db_actions.vBD_VDI = _ref'
-               && (vbd_record.Db_actions.vBD_currently_attached
-                  || vbd_record.Db_actions.vBD_reserved
-                  )
-             )
-             records
+        List.filter
+          (fun vbd_record ->
+            vbd_record.Db_actions.vBD_VDI = _ref'
+            && (vbd_record.Db_actions.vBD_currently_attached
+               || vbd_record.Db_actions.vBD_reserved
+               )
           )
+          records
   in
   let my_active_rw_vbd_records =
     List.filter (fun vbd -> vbd.Db_actions.vBD_mode = `RW) my_active_vbd_records
@@ -183,14 +184,12 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = [])
                )
           )
     | Some records ->
-        List.map snd
-          (List.filter
-             (fun (_, vbd_record) ->
-               vbd_record.Db_actions.vBD_VDI = _ref'
-               && vbd_record.Db_actions.vBD_current_operations <> []
-             )
-             records
+        List.filter
+          (fun vbd_record ->
+            vbd_record.Db_actions.vBD_VDI = _ref'
+            && vbd_record.Db_actions.vBD_current_operations <> []
           )
+          records
   in
   (* If the VBD is currently_attached then some operations can still be
      performed ie: VDI.clone (if the VM is suspended we have to have the
@@ -467,7 +466,7 @@ let update_allowed_operations_internal ~__context ~self ~sr_records ~pbd_records
    *)
   let all_ops =
     Xapi_globs.pre_ely_vdi_operations
-    |> List.filter (function
+    |> Xapi_globs.Vdi_operations_set.filter (function
          | `blocked ->
              false (* CA-260245 *)
          | `force_unlock ->
@@ -477,25 +476,36 @@ let update_allowed_operations_internal ~__context ~self ~sr_records ~pbd_records
          )
   in
   let all = Db.VDI.get_record_internal ~__context ~self in
+  let vbd_records =
+    match vbd_records with
+    | None when Pool_role.is_master () ->
+        all.Db_actions.vDI_VBDs
+        |> List.rev_map (fun self -> Db.VBD.get_record_internal ~__context ~self)
+        |> Option.some
+    | v ->
+        v
+  in
   let allowed =
     let check x =
       match
         check_operation_error ~__context ~sr_records ~pbd_records ?vbd_records
           ha_enabled all self x
       with
       | Ok () ->
-          [x]
+          true
       | _ ->
-          []
+          false
     in
-    List.fold_left (fun accu op -> check op @ accu) [] all_ops
+    all_ops |> Xapi_globs.Vdi_operations_set.filter check
   in
   let allowed =
-    if Helpers.rolling_upgrade_in_progress ~__context then
-      Xapi_stdext_std.Listext.List.intersect allowed
-        Xapi_globs.rpu_allowed_vdi_operations
-    else
-      allowed
+    ( if Helpers.rolling_upgrade_in_progress ~__context then
+        Xapi_globs.Vdi_operations_set.inter allowed
+          Xapi_globs.rpu_allowed_vdi_operations
+      else
+        allowed
+    )
+    |> Xapi_globs.Vdi_operations_set.elements
   in
   Db.VDI.set_allowed_operations ~__context ~self ~value:allowed
 

ocaml/xapi/xapi_vdi.mli

@@ -23,7 +23,7 @@ val check_operation_error :
      __context:Context.t
   -> ?sr_records:'a list
   -> ?pbd_records:(API.ref_PBD * API.pBD_t) list
-  -> ?vbd_records:(API.ref_VBD * Db_actions.vBD_t) list
+  -> ?vbd_records:Db_actions.vBD_t list
   -> bool
   -> Db_actions.vDI_t
   -> API.ref_VDI
@@ -40,7 +40,7 @@ val update_allowed_operations_internal :
   -> self:[`VDI] API.Ref.t
   -> sr_records:'a list
   -> pbd_records:(API.ref_PBD * API.pBD_t) list
-  -> ?vbd_records:(API.ref_VBD * Db_actions.vBD_t) list
+  -> ?vbd_records:Db_actions.vBD_t list
   -> unit
   -> unit