Add experimental feature to use hard affinities when using best-effort (CP-54234)

ocaml/xapi-idl/xen/xenops_interface.ml

@@ -496,9 +496,12 @@ module Host = struct
   [@@deriving rpcty]
 
   type numa_affinity_policy =
-    | Any  (** VMs may run on any NUMA nodes. This is the default in 8.2CU1 *)
+    | Any  (** VMs may run on any NUMA nodes. *)
     | Best_effort
-        (** best effort placement on the smallest number of NUMA nodes where possible *)
+        (** Best-effort placement. Assigns the memory of the VM to a single
+            node, and soft-pins its VCPUs to the node, if possible. Otherwise
+            behaves like Any. *)
+    | Best_effort_hard  (** Like Best_effort, but hard-pins the VCPUs *)
   [@@deriving rpcty]
 
   type numa_affinity_policy_opt = numa_affinity_policy option [@@deriving rpcty]

ocaml/xapi-types/dune

@@ -23,6 +23,8 @@
     xapi-stdext-unix
   )
   (wrapped false)
-  (preprocess (per_module ((pps ppx_deriving_rpc) API Event_types Features SecretString)))
+  (preprocess
+    (per_module
+      ((pps ppx_deriving_rpc) API Event_types SecretString)
+      ((pps ppx_deriving_rpc ppx_deriving.enum) Features)))
 )
-

ocaml/xapi-types/features.ml

@@ -68,79 +68,119 @@ type feature =
   | VM_groups
   | VM_start
   | VM_appliance_start
-[@@deriving rpc]
+[@@deriving rpc, enum]
 
 type orientation = Positive | Negative
 
-let keys_of_features =
-  [
-    (VLAN, ("restrict_vlan", Negative, "VLAN"))
-  ; (QoS, ("restrict_qos", Negative, "QoS"))
-  ; (Shared_storage, ("restrict_pool_attached_storage", Negative, "SStorage"))
-  ; (Netapp, ("restrict_netapp", Negative, "NTAP"))
-  ; (Equalogic, ("restrict_equalogic", Negative, "EQL"))
-  ; (Pooling, ("restrict_pooling", Negative, "Pool"))
-  ; (HA, ("enable_xha", Positive, "XHA"))
-  ; (Marathon, ("restrict_marathon", Negative, "MTC"))
-  ; (Email, ("restrict_email_alerting", Negative, "email"))
-  ; (Performance, ("restrict_historical_performance", Negative, "perf"))
-  ; (WLB, ("restrict_wlb", Negative, "WLB"))
-  ; (RBAC, ("restrict_rbac", Negative, "RBAC"))
-  ; (DMC, ("restrict_dmc", Negative, "DMC"))
-  ; (Checkpoint, ("restrict_checkpoint", Negative, "chpt"))
-  ; (CPU_masking, ("restrict_cpu_masking", Negative, "Mask"))
-  ; (Connection, ("restrict_connection", Negative, "Cnx"))
-  ; (No_platform_filter, ("platform_filter", Negative, "Plat"))
-  ; (No_nag_dialog, ("regular_nag_dialog", Negative, "nonag"))
-  ; (VMPR, ("restrict_vmpr", Negative, "VMPR"))
-  ; (VMSS, ("restrict_vmss", Negative, "VMSS"))
-  ; (IntelliCache, ("restrict_intellicache", Negative, "IntelliCache"))
-  ; (GPU, ("restrict_gpu", Negative, "GPU"))
-  ; (DR, ("restrict_dr", Negative, "DR"))
-  ; (VIF_locking, ("restrict_vif_locking", Negative, "VIFLock"))
-  ; (Storage_motion, ("restrict_storage_xen_motion", Negative, "SXM"))
-  ; (VGPU, ("restrict_vgpu", Negative, "vGPU"))
-  ; (Integrated_GPU, ("restrict_integrated_gpu_passthrough", Negative, "iGPU"))
-  ; (VSS, ("restrict_vss", Negative, "VSS"))
-  ; ( Guest_agent_auto_update
-    , ("restrict_guest_agent_auto_update", Negative, "GAAU")
-    )
-  ; ( PCI_device_for_auto_update
-    , ("restrict_pci_device_for_auto_update", Negative, "PciAU")
-    )
-  ; (Xen_motion, ("restrict_xen_motion", Negative, "Live_migration"))
-  ; (Guest_ip_setting, ("restrict_guest_ip_setting", Negative, "GuestIP"))
-  ; (AD, ("restrict_ad", Negative, "AD"))
-  ; (Nested_virt, ("restrict_nested_virt", Negative, "Nested_virt"))
-  ; (Live_patching, ("restrict_live_patching", Negative, "Live_patching"))
-  ; ( Live_set_vcpus
-    , ("restrict_set_vcpus_number_live", Negative, "Live_set_vcpus")
-    )
-  ; (PVS_proxy, ("restrict_pvs_proxy", Negative, "PVS_proxy"))
-  ; (IGMP_snooping, ("restrict_igmp_snooping", Negative, "IGMP_snooping"))
-  ; (RPU, ("restrict_rpu", Negative, "RPU"))
-  ; (Pool_size, ("restrict_pool_size", Negative, "Pool_size"))
-  ; (CBT, ("restrict_cbt", Negative, "CBT"))
-  ; (USB_passthrough, ("restrict_usb_passthrough", Negative, "USB_passthrough"))
-  ; (Network_sriov, ("restrict_network_sriov", Negative, "Network_sriov"))
-  ; (Corosync, ("restrict_corosync", Negative, "Corosync"))
-  ; (Cluster_address, ("restrict_cluster_address", Negative, "Cluster_address"))
-  ; (Zstd_export, ("restrict_zstd_export", Negative, "Zstd_export"))
-  ; ( Pool_secret_rotation
-    , ("restrict_pool_secret_rotation", Negative, "Pool_secret_rotation")
-    )
-  ; ( Certificate_verification
-    , ("restrict_certificate_verification", Negative, "Certificate_verification")
-    )
-  ; (Updates, ("restrict_updates", Negative, "Upd"))
-  ; ( Internal_repo_access
-    , ("restrict_internal_repo_access", Negative, "Internal_repo_access")
-    )
-  ; (VTPM, ("restrict_vtpm", Negative, "VTPM"))
-  ; (VM_groups, ("restrict_vm_groups", Negative, "VM_groups"))
-  ; (VM_start, ("restrict_vm_start", Negative, "Start"))
-  ; (VM_appliance_start, ("restrict_vm_appliance_start", Negative, "Start"))
-  ]
+let props_of_feature = function
+  | VLAN ->
+      ("restrict_vlan", Negative, "VLAN")
+  | QoS ->
+      ("restrict_qos", Negative, "QoS")
+  | Shared_storage ->
+      ("restrict_pool_attached_storage", Negative, "SStorage")
+  | Netapp ->
+      ("restrict_netapp", Negative, "NTAP")
+  | Equalogic ->
+      ("restrict_equalogic", Negative, "EQL")
+  | Pooling ->
+      ("restrict_pooling", Negative, "Pool")
+  | HA ->
+      ("enable_xha", Positive, "XHA")
+  | Marathon ->
+      ("restrict_marathon", Negative, "MTC")
+  | Email ->
+      ("restrict_email_alerting", Negative, "email")
+  | Performance ->
+      ("restrict_historical_performance", Negative, "perf")
+  | WLB ->
+      ("restrict_wlb", Negative, "WLB")
+  | RBAC ->
+      ("restrict_rbac", Negative, "RBAC")
+  | DMC ->
+      ("restrict_dmc", Negative, "DMC")
+  | Checkpoint ->
+      ("restrict_checkpoint", Negative, "chpt")
+  | CPU_masking ->
+      ("restrict_cpu_masking", Negative, "Mask")
+  | Connection ->
+      ("restrict_connection", Negative, "Cnx")
+  | No_platform_filter ->
+      ("platform_filter", Negative, "Plat")
+  | No_nag_dialog ->
+      ("regular_nag_dialog", Negative, "nonag")
+  | VMPR ->
+      ("restrict_vmpr", Negative, "VMPR")
+  | VMSS ->
+      ("restrict_vmss", Negative, "VMSS")
+  | IntelliCache ->
+      ("restrict_intellicache", Negative, "IntelliCache")
+  | GPU ->
+      ("restrict_gpu", Negative, "GPU")
+  | DR ->
+      ("restrict_dr", Negative, "DR")
+  | VIF_locking ->
+      ("restrict_vif_locking", Negative, "VIFLock")
+  | Storage_motion ->
+      ("restrict_storage_xen_motion", Negative, "SXM")
+  | VGPU ->
+      ("restrict_vgpu", Negative, "vGPU")
+  | Integrated_GPU ->
+      ("restrict_integrated_gpu_passthrough", Negative, "iGPU")
+  | VSS ->
+      ("restrict_vss", Negative, "VSS")
+  | Guest_agent_auto_update ->
+      ("restrict_guest_agent_auto_update", Negative, "GAAU")
+  | PCI_device_for_auto_update ->
+      ("restrict_pci_device_for_auto_update", Negative, "PciAU")
+  | Xen_motion ->
+      ("restrict_xen_motion", Negative, "Live_migration")
+  | Guest_ip_setting ->
+      ("restrict_guest_ip_setting", Negative, "GuestIP")
+  | AD ->
+      ("restrict_ad", Negative, "AD")
+  | Nested_virt ->
+      ("restrict_nested_virt", Negative, "Nested_virt")
+  | Live_patching ->
+      ("restrict_live_patching", Negative, "Live_patching")
+  | Live_set_vcpus ->
+      ("restrict_set_vcpus_number_live", Negative, "Live_set_vcpus")
+  | PVS_proxy ->
+      ("restrict_pvs_proxy", Negative, "PVS_proxy")
+  | IGMP_snooping ->
+      ("restrict_igmp_snooping", Negative, "IGMP_snooping")
+  | RPU ->
+      ("restrict_rpu", Negative, "RPU")
+  | Pool_size ->
+      ("restrict_pool_size", Negative, "Pool_size")
+  | CBT ->
+      ("restrict_cbt", Negative, "CBT")
+  | USB_passthrough ->
+      ("restrict_usb_passthrough", Negative, "USB_passthrough")
+  | Network_sriov ->
+      ("restrict_network_sriov", Negative, "Network_sriov")
+  | Corosync ->
+      ("restrict_corosync", Negative, "Corosync")
+  | Cluster_address ->
+      ("restrict_cluster_address", Negative, "Cluster_address")
+  | Zstd_export ->
+      ("restrict_zstd_export", Negative, "Zstd_export")
+  | Pool_secret_rotation ->
+      ("restrict_pool_secret_rotation", Negative, "Pool_secret_rotation")
+  | Certificate_verification ->
+      ("restrict_certificate_verification", Negative, "Certificate_verification")
+  | Updates ->
+      ("restrict_updates", Negative, "Upd")
+  | Internal_repo_access ->
+      ("restrict_internal_repo_access", Negative, "Internal_repo_access")
+  | VTPM ->
+      ("restrict_vtpm", Negative, "VTPM")
+  | VM_groups ->
+      ("restrict_vm_groups", Negative, "VM_groups")
+  | VM_start ->
+      ("restrict_vm_start", Negative, "Start")
+  | VM_appliance_start ->
+      ("restrict_vm_appliance_start", Negative, "Start")
 
 (* A list of features that must be considered "enabled" by `of_assoc_list`
    if the feature string is missing from the list. These are existing features
@@ -149,52 +189,40 @@ let keys_of_features =
 let enabled_when_unknown =
   [Xen_motion; AD; Updates; VM_start; VM_appliance_start]
 
-let name_of_feature f = rpc_of_feature f |> Rpc.string_of_rpc
-
-let string_of_feature f =
-  let str, o, _ = List.assoc f keys_of_features in
-  (str, o)
+let all_features =
+  let length = max_feature - min_feature + 1 in
+  let start = min_feature in
+  List.init length (fun i -> feature_of_enum (i + start) |> Option.get)
 
-let tag_of_feature f =
-  let _, _, tag = List.assoc f keys_of_features in
-  tag
+let name_of_feature f = rpc_of_feature f |> Rpc.string_of_rpc
 
-let all_features = List.map (fun (f, _) -> f) keys_of_features
+let is_enabled v = function Positive -> v | Negative -> not v
 
 let to_compact_string (s : feature list) =
   let get_tag f =
-    let tag = tag_of_feature f in
+    let _, _, tag = props_of_feature f in
     if List.mem f s then
       tag
     else
       String.make (String.length tag) ' '
   in
-  let tags = List.map get_tag all_features in
-  String.concat " " tags
+  List.map get_tag all_features |> String.concat " "
 
 let to_assoc_list (s : feature list) =
   let get_map f =
-    let str, o = string_of_feature f in
+    let str, o, _ = props_of_feature f in
     let switch = List.mem f s in
-    let switch = string_of_bool (if o = Positive then switch else not switch) in
+    let switch = string_of_bool (is_enabled switch o) in
     (str, switch)
   in
   List.map get_map all_features
 
 let of_assoc_list l =
-  let get_feature f =
+  let enabled f =
     try
-      let str, o = string_of_feature f in
-      let v = bool_of_string (List.assoc str l) in
-      let v = if o = Positive then v else not v in
-      if v then Some f else None
-    with _ -> if List.mem f enabled_when_unknown then Some f else None
+      let str, o, _ = props_of_feature f in
+      let v = List.assoc str l in
+      is_enabled (bool_of_string v) o
+    with _ -> List.mem f enabled_when_unknown
   in
-  (* Filter_map to avoid having to carry the whole xapi-stdext-std
-   * Note that the following is not tail recursive, in this case I
-   * have chosen such implementation because the feature list is small
-   * and the implementation looks readable and fairly self-contained.
-   * Do not use this pattern for lists that can be long. *)
-  List.fold_right
-    (fun f acc -> match get_feature f with Some v -> v :: acc | None -> acc)
-    all_features []
+  List.filter enabled all_features

ocaml/xapi/xapi_xenops.ml

@@ -3110,6 +3110,12 @@ let resync_all_vms ~__context =
   in
   List.iter (fun vm -> refresh_vm ~__context ~self:vm) resident_vms_in_db
 
+(* experimental feature for hard-pinning vcpus *)
+let hard_numa_enabled ~__context =
+  let pool = Helpers.get_pool ~__context in
+  let restrictions = Db.Pool.get_restrictions ~__context ~self:pool in
+  List.assoc_opt "restrict_hard_numa" restrictions = Some "false"
+
 let set_numa_affinity_policy ~__context ~value =
   let dbg = Context.string_of_task __context in
   let open Xapi_xenops_queue in
@@ -3119,6 +3125,8 @@ let set_numa_affinity_policy ~__context ~value =
     match value with
     | `any ->
         Some Any
+    | `best_effort when hard_numa_enabled ~__context ->
+        Some Best_effort_hard
     | `best_effort ->
         Some Best_effort
     | `default_policy ->