CP-314178: xapi_host: report each host's GPU partitioning status

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 911
+let schema_minor_vsn = 912
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_host.ml

@@ -922,6 +922,26 @@ let latest_synced_updates_applied_state =
       ]
     )
 
+(* Complete from the first release: a host fails on a stored enum value it does
+   not know, so new causes go in gpu_partitioning_reason instead. *)
+let host_gpu_partitioning_status =
+  Enum
+    ( "host_gpu_partitioning_status"
+    , [
+        ("not_reported", "The host has not reported its status yet")
+      ; ("inactive", "GPU partitioning is not in use on the host")
+      ; ("entering", "The host is preparing its GPUs for partitioning")
+      ; ("active", "GPU partitioning is in use on the host")
+      ; ("leaving", "The host is returning its GPUs from partitioning")
+      ]
+    )
+
+let gpu_partitioning_reason_doc =
+  "Why GPU partitioning is not active on the host, empty until the host \
+   reports: no_partitionable_gpu (no GPU from a vendor whose GPUs this version \
+   can partition) or pool_disabled (it is not enabled for the pool). Later \
+   versions may add values: treat an unknown one as a reason to show as is."
+
 let create_params =
   [
     {
@@ -1191,6 +1211,20 @@ let create_params =
     ; param_release= numbered_release "26.0.0"
     ; param_default= Some (VSet [])
     }
+  ; {
+      param_type= host_gpu_partitioning_status
+    ; param_name= "gpu_partitioning_status"
+    ; param_doc= "The state of GPU partitioning on the host"
+    ; param_release= numbered_release "26.18.0-next"
+    ; param_default= Some (VEnum "not_reported")
+    }
+  ; {
+      param_type= String
+    ; param_name= "gpu_partitioning_reason"
+    ; param_doc= gpu_partitioning_reason_doc
+    ; param_release= numbered_release "26.18.0-next"
+    ; param_default= Some (VString "")
+    }
   ]
 
 let create =
@@ -2776,6 +2810,14 @@ let t =
         ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:String
             ~default_value:(Some (VString "UTC")) "timezone"
             "The time zone identifier as defined in the IANA Time Zone Database"
+        ; field ~qualifier:DynamicRO ~lifecycle:[]
+            ~ty:host_gpu_partitioning_status
+            ~default_value:(Some (VEnum "not_reported"))
+            "gpu_partitioning_status"
+            "The state of GPU partitioning on the host"
+        ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:String
+            ~default_value:(Some (VString "")) "gpu_partitioning_reason"
+            gpu_partitioning_reason_doc
         ]
       )
     ()

ocaml/idl/datamodel_lifecycle.ml

@@ -173,6 +173,10 @@ let prototyped_of_field = function
       Some "26.21.1"
   | "VIF", "trunks" ->
       Some "26.17.0"
+  | "host", "gpu_partitioning_reason" ->
+      Some "26.18.0-next"
+  | "host", "gpu_partitioning_status" ->
+      Some "26.18.0-next"
   | "host", "timezone" ->
       Some "26.0.0"
   | "host", "ntp_custom_servers" ->

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "4983c4c3b72e42406d2940f985380801"
+let last_known_schema_hash = "745041364ba89ddd6137373ea60a5e1e"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/libs/gpu/dune

@@ -3,4 +3,4 @@
  (public_name xapi-gpu)
  (preprocess (pps ppx_deriving.std))
  (flags (:standard -w -39@8))
- (modules partition_mode gpu_partition_lifecycle))
+ (modules partition_mode gpu_partition_lifecycle host_partitioning))

ocaml/libs/gpu/host_partitioning.ml

@@ -0,0 +1,30 @@
+(*
+ * Copyright (C) 2026 Cloud Software Group
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type reason = No_partitionable_gpu | Pool_disabled
+[@@deriving show {with_path= false}]
+
+let token r = String.lowercase_ascii (show_reason r)
+
+let ( let* ) = Result.bind
+
+let check ok reason =
+  if ok () then
+    Ok ()
+  else
+    Error reason
+
+let desired ~partitionable_gpu ~pool_enabled =
+  let* () = check partitionable_gpu No_partitionable_gpu in
+  check pool_enabled Pool_disabled

ocaml/libs/gpu/host_partitioning.mli

@@ -0,0 +1,27 @@
+(*
+ * Copyright (C) 2026 Cloud Software Group
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** Why GPU partitioning is not wanted on a host. *)
+type reason = No_partitionable_gpu | Pool_disabled
+
+val token : reason -> string
+(** The reason as the host's status shows it to clients *)
+
+val desired :
+     partitionable_gpu:(unit -> bool)
+  -> pool_enabled:(unit -> bool)
+  -> (unit, reason) result
+(** [Ok ()] if the host should partition its GPUs, or else the reason of the
+    first check that fails. The checks run in this order, most specific to the
+    host first, and none runs after one fails. *)

ocaml/tests/common/test_common.ml

@@ -187,7 +187,8 @@ let make_host ~__context ?(uuid = make_uuid ()) ?(name_label = "host")
       ~https_only ~max_cstate:"" ~ntp_mode:`Factory ~ntp_custom_servers:[]
       ~timezone:"UTC" ~numa_affinity_policy:`default_policy
       ~latest_synced_updates_applied:`unknown ~pending_guidances_full:[]
-      ~pending_guidances_recommended:[]
+      ~pending_guidances_recommended:[] ~gpu_partitioning_status:`not_reported
+      ~gpu_partitioning_reason:""
   in
   Db.Host.set_cpu_info ~__context ~self:host ~value:default_cpu_info ;
   host
@@ -228,7 +229,8 @@ let make_host2 ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ())
     ~last_update_hash:"" ~ssh_enabled:true ~ssh_enabled_timeout:0L
     ~ssh_expiry:Date.epoch ~console_idle_timeout:0L ~ssh_auto_mode:false
     ~secure_boot:false ~https_only ~max_cstate:"" ~ntp_mode:`Factory
-    ~ntp_custom_servers:[] ~timezone:"UTC" ;
+    ~ntp_custom_servers:[] ~timezone:"UTC"
+    ~gpu_partitioning_status:`not_reported ~gpu_partitioning_reason:"" ;
   ref
 
 let make_pif ~__context ~network ~host ?(device = "eth0")

ocaml/tests/test_host.ml

@@ -31,7 +31,8 @@ let add_host __context name =
        ~ntp_custom_servers:[] ~timezone:"UTC"
        ~numa_affinity_policy:`default_policy
        ~latest_synced_updates_applied:`unknown ~pending_guidances_full:[]
-       ~pending_guidances_recommended:[]
+       ~pending_guidances_recommended:[] ~gpu_partitioning_status:`not_reported
+       ~gpu_partitioning_reason:""
     )
 
 (* Creates an unlicensed pool with the maximum number of hosts *)
@@ -73,4 +74,69 @@ let test_host_join_restriction () =
     (Xapi_globs.restricted_pool_size + 1)
     (Db.Host.get_all ~__context |> List.length)
 
-let test = [("test_host_join_restriction", `Quick, test_host_join_restriction)]
+(* Each row: the checks of the desired state, most specific first; a check
+   after a failed one must not run. *)
+let gpu_partitioning_desired (name, partitionable_gpu, pool_enabled, expected) =
+  let test () =
+    Alcotest.(check (result unit string))
+      name expected
+      Gpu.Host_partitioning.(
+        desired ~partitionable_gpu ~pool_enabled |> Result.map_error token
+      )
+  in
+  (name, `Quick, test)
+
+let not_run () = Alcotest.fail "a check ran after an earlier one failed"
+
+(* Each row: GPUs added in steps, the host's state written after each step. *)
+let sync_gpu_partitioning (name, steps, reason) =
+  let test () =
+    let __context = make_test_database () in
+    let host = Helpers.get_localhost ~__context in
+    let add_gpu vendor_id =
+      let pCI = make_pci ~__context ~host ~vendor_id () in
+      ignore (make_pgpu ~__context ~pCI ~host () : API.ref_PGPU)
+    in
+    steps
+    |> List.iter (fun gpus ->
+        List.iter add_gpu gpus ;
+        Xapi_host.sync_gpu_partitioning ~__context
+    ) ;
+    Alcotest.(check (pair string string))
+      name ("inactive", reason)
+      ( API.host_gpu_partitioning_status_to_string
+          (Db.Host.get_gpu_partitioning_status ~__context ~self:host)
+      , Db.Host.get_gpu_partitioning_reason ~__context ~self:host
+      )
+  in
+  (name, `Quick, test)
+
+let test =
+  ("test_host_join_restriction", `Quick, test_host_join_restriction)
+  :: List.map gpu_partitioning_desired
+       [
+         ( "desired: no partitionable GPU"
+         , Fun.const false
+         , not_run
+         , Error "no_partitionable_gpu"
+         )
+       ; ( "desired: a partitionable GPU, the pool switch off"
+         , Fun.const true
+         , Fun.const false
+         , Error "pool_disabled"
+         )
+       ; ( "desired: a partitionable GPU, the pool switch on"
+         , Fun.const true
+         , Fun.const true
+         , Ok ()
+         )
+       ]
+  @ List.map sync_gpu_partitioning
+      [
+        ("sync: another vendor's GPU", [["8086"]], "no_partitionable_gpu")
+      ; ("sync: an NVIDIA GPU", [["10de"]], "pool_disabled")
+      ; ( "sync: an NVIDIA GPU added after a first sync"
+        , [["8086"]; ["10de"]]
+        , "pool_disabled"
+        )
+      ]

ocaml/xapi-cli-server/records.ml

@@ -3551,6 +3551,15 @@ let host_record rpc session_id host =
             Client.Host.set_timezone ~rpc ~session_id ~self:host ~value
           )
           ()
+      ; make_field ~name:"gpu-partitioning-status"
+          ~get:(fun () ->
+            Record_util.host_gpu_partitioning_status_to_string
+              (x ()).API.host_gpu_partitioning_status
+          )
+          ()
+      ; make_field ~name:"gpu-partitioning-reason"
+          ~get:(fun () -> (x ()).API.host_gpu_partitioning_reason)
+          ()
       ]
   }
 

ocaml/xapi/dbsync_slave.ml

@@ -76,7 +76,8 @@ let create_localhost ~__context info =
         ~ntp_custom_servers:[] ~timezone:"UTC"
         ~numa_affinity_policy:`default_policy
         ~latest_synced_updates_applied:`unknown ~pending_guidances_full:[]
-        ~pending_guidances_recommended:[]
+        ~pending_guidances_recommended:[] ~gpu_partitioning_status:`not_reported
+        ~gpu_partitioning_reason:""
     in
     ()
 

ocaml/xapi/xapi.ml

@@ -1528,6 +1528,10 @@ let server_init () =
             , [Startup.NoExnRaising]
             , fun () -> Xapi_host.update_firewalld_service_status ~__context
             )
+          ; ( "Sync the GPU partitioning status of the host"
+            , [Startup.NoExnRaising; Startup.OnThread]
+            , fun () -> Xapi_host.sync_gpu_partitioning ~__context
+            )
           ; ( "writing init complete"
             , []
             , fun () -> Helpers.touch_file !Xapi_globs.init_complete

ocaml/xapi/xapi_host.ml

@@ -1029,7 +1029,8 @@ let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address
     ~secure_boot ~software_version ~https_only ~max_cstate ~ntp_mode
     ~ntp_custom_servers ~timezone ~numa_affinity_policy
     ~latest_synced_updates_applied ~pending_guidances_full
-    ~pending_guidances_recommended =
+    ~pending_guidances_recommended ~gpu_partitioning_status
+    ~gpu_partitioning_reason =
   (* fail-safe. We already test this on the joining host, but it's racy, so multiple concurrent
      pool-join might succeed. Note: we do it in this order to avoid a problem checking restrictions during
      the initial setup of the database *)
@@ -1093,7 +1094,8 @@ let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address
     ~recommended_guidances:[] ~latest_synced_updates_applied
     ~pending_guidances_recommended ~pending_guidances_full ~ssh_enabled
     ~ssh_enabled_timeout ~ssh_expiry ~console_idle_timeout ~ssh_auto_mode
-    ~max_cstate ~secure_boot ~ntp_mode ~ntp_custom_servers ~timezone ;
+    ~max_cstate ~secure_boot ~ntp_mode ~ntp_custom_servers ~timezone
+    ~gpu_partitioning_status ~gpu_partitioning_reason ;
   (* If the host we're creating is us, make sure its set to live *)
   Db.Host_metrics.set_last_updated ~__context ~self:metrics ~value:(Date.now ()) ;
   Db.Host_metrics.set_live ~__context ~self:metrics ~value:host_is_us ;
@@ -2687,6 +2689,29 @@ let sync_display ~__context ~host =
     Db.Host.set_display ~__context ~self:host ~value:status
   )
 
+(* Every evaluation of the desired state, whatever started it, runs under this
+   lock and writes the reason and then the status. *)
+let gpu_partitioning_m = Mutex.create ()
+
+let sync_gpu_partitioning ~__context =
+  let self = Helpers.get_localhost ~__context and fn = __FUNCTION__ in
+  with_lock gpu_partitioning_m @@ fun () ->
+  match
+    Gpu.Host_partitioning.desired
+      ~partitionable_gpu:(fun () ->
+        Xapi_pgpu.nvidia_cards ~__context ~host:self <> []
+      )
+      ~pool_enabled:(fun () -> false)
+  with
+  | Error reason ->
+      let value = Gpu.Host_partitioning.token reason in
+      debug "%s: inactive (%s)" fn value ;
+      Db.Host.set_gpu_partitioning_reason ~__context ~self ~value ;
+      Db.Host.set_gpu_partitioning_status ~__context ~self ~value:`inactive
+  | Ok () ->
+      (* Unreachable until the pool can enable partitioning *)
+      ()
+
 let apply_guest_agent_config ~__context ~host:_ =
   let pool = Helpers.get_pool ~__context in
   let config = Db.Pool.get_guest_agent_config ~__context ~self:pool in

ocaml/xapi/xapi_host.mli

@@ -147,6 +147,8 @@ val create :
   -> latest_synced_updates_applied:API.latest_synced_updates_applied_state
   -> pending_guidances_full:API.update_guidances_set
   -> pending_guidances_recommended:API.update_guidances_set
+  -> gpu_partitioning_status:API.host_gpu_partitioning_status
+  -> gpu_partitioning_reason:string
   -> [`host] Ref.t
 
 val destroy : __context:Context.t -> self:API.ref_host -> unit
@@ -499,6 +501,9 @@ val disable_display :
 
 val sync_display : __context:Context.t -> host:API.ref_host -> unit
 
+val sync_gpu_partitioning : __context:Context.t -> unit
+(** Computes this host's GPU partitioning status and reason and writes both *)
+
 val apply_guest_agent_config : __context:Context.t -> host:API.ref_host -> unit
 
 (* See Xapi_pgpu.mxgpu_vf_setup *)

ocaml/xapi/xapi_pgpu.ml

@@ -36,11 +36,22 @@ let calculate_max_capacities ~__context ~pCI:_ ~size ~supported_VGPU_types =
     )
     supported_VGPU_types
 
+let is_nvidia_vendor id =
+  id = Xapi_pci.id_of_int Xapi_vgpu_type.Nvidia.vendor_id
+
+(* By PCI vendor, not by the driver bound now: a pass-through start unbinds a
+   card from its driver. *)
+let nvidia_cards ~__context ~host =
+  Db.Host.get_PGPUs ~__context ~self:host
+  |> List.map (fun self ->
+      ( self
+      , Db.PCI.get_record ~__context ~self:(Db.PGPU.get_PCI ~__context ~self)
+      )
+  )
+  |> List.filter (fun (_, pci) -> is_nvidia_vendor pci.API.pCI_vendor_id)
+
 let fetch_compatibility_metadata ~__context ~pgpu_pci =
-  if
-    Db.PCI.get_vendor_id ~__context ~self:pgpu_pci
-    = Xapi_pci.id_of_int Xapi_vgpu_type.Nvidia.vendor_id
-  then
+  if is_nvidia_vendor (Db.PCI.get_vendor_id ~__context ~self:pgpu_pci) then
     let dbg = Context.string_of_task __context in
     let pgpu_pci_address = Db.PCI.get_pci_id ~__context ~self:pgpu_pci in
     Xapi_gpumon.Nvidia.get_pgpu_compatibility_metadata ~dbg ~pgpu_pci_address