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

This needed:
- Changes in the C bindings to be able to set the hard affinity for each
vcpu. This needed change in the basic call to be able to set hard and
soft affinities, at the same time.
- Stop feeding xenguest the hard affinities when user did not set any in
particular. Prior to the all->all priorities were set instead, with the
misfortune of setting them after the NUMA code had decided the
affinities and set them, overriding the desired values. Fortunately
xenguest is able to cope with the missing values. (edwin found this
strange behaviour)

I took time to fix the exhaustivity issue when defining features, and
now xenopsd sets the hard affinities when the user has hardcoded them
for a VM, instead of sending them for xenguest to read them.

Tests:
- manually tested that soft-pinning works by default
- manually tested that enabling the feature and restart xapi enables
hard-pinning
- manually tested that setting the vcpu mask works (`xe vm-param-set
uuid=A_UUID VCPUs-params:mask=20`)
- manually checked that the all_features contains the same features as
before using the REPL, in case some got forgotten (there are also
unit-tests for the module)

The vcpu affinities were checked using `xl vcpu-list` and restarting a
VM repeatedly while changing the feature and the vm arguments.

Author: psafont

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 ->