CP-5845: Use policy when choosing VM host and pGPU

At the pool-level, hosts are split into groups of equally-optimal hosts (based
on GPU_group.allocation_algorithm). The VM placement code is then run
sequentially on each of these groups (cf. was run before on all hosts in pool).
Only when exhausing this list of lists of hosts does it fail to start the VM.

At the host-level, a pGPU is selected according to the same
allocation_algorithm. If no capacity can be found then the VM_REQUIRES_VGPU
error is raised.

Signed-off-by: Si Beaumont <[email protected]>

Author: simonjbeaumont

ocaml/xapi/helpers.ml

@@ -489,6 +489,40 @@ let compare_int_lists : int list -> int list -> int =
 		let first_non_zero is = List.fold_left (fun a b -> if (a<>0) then a else b) 0 is in
 		first_non_zero (List.map2 compare a b)
 
+let group_by f list =
+	let evaluated_list = List.map (fun x -> (x, f x)) list in
+	let snd_equality (_, x) (_, y) = x = y in
+	let snd_compare (_, x) (_, y) = compare x y in
+	let sorted = List.sort snd_compare evaluated_list in
+	let rec take_while p ac = function
+		| [] -> (ac, [])
+		| x :: xs ->
+			if (p x) then take_while p (x :: ac) xs
+			else (ac, x :: xs)
+	in
+	let rec group ac = function
+		| [] -> ac
+		| x :: xs ->
+			let peers, rest = take_while (snd_equality x) [] (x :: xs) in
+			group (peers :: ac) rest
+	in
+	group [] sorted
+
+(** Groups list elements by equality of result of function application sorted
+ *  in order of that result *)
+let group_by ?(descending=false) f list =
+	match descending with
+	| true -> group_by f list
+	| false -> List.rev (group_by f list)
+
+(** Schwarzian transform sort *)
+let sort_by_schwarzian ?(descending=false) f list =
+	let comp x y = if descending then compare y x else compare x y in
+	let (|>) a f = f a in
+	List.map (fun x -> (x, f x)) list |>
+	List.sort (fun (_, x') (_, y') -> comp x' y') |>
+	List.map (fun (x, _) -> x)
+
 let version_string_of : __context:Context.t -> [`host] api_object -> string =
 	fun ~__context host ->
 		try

ocaml/xapi/vgpuops.ml

@@ -92,6 +92,18 @@ let create_virtual_vgpu ~__context vm vgpu =
 	let available_pgpus = Db.Host.get_PGPUs ~__context ~self:host in
 	let compatible_pgpus = Db.GPU_group.get_PGPUs ~__context ~self:vgpu.gpu_group_ref in
 	let pgpus = List.intersect compatible_pgpus available_pgpus in
+	(* Sort the pgpus in lists of equal optimality for vGPU placement based on
+	 * the GPU groups allocation algorithm *)
+	let sort_desc =
+		match Db.GPU_group.get_allocation_algorithm ~__context ~self:vgpu.gpu_group_ref with
+		| `depth_first -> false
+		| `breadth_first -> true
+	in
+	let sorted_pgpus = Helpers.sort_by_schwarzian ~descending:sort_desc
+		(fun pgpu -> Xapi_pgpu_helpers.get_remaining_capacity ~__context
+			~self:pgpu ~vgpu_type:vgpu.type_ref)
+		pgpus
+	in
 	let rec allocate_vgpu vgpu_type = function
 		| [] -> None
 		| pgpu :: remaining_pgpus ->
@@ -103,7 +115,7 @@ let create_virtual_vgpu ~__context vm vgpu =
 			with _ -> allocate_vgpu vgpu_type remaining_pgpus
 	in
 	Threadext.Mutex.execute m (fun () ->
-		match allocate_vgpu vgpu.type_ref pgpus with
+		match allocate_vgpu vgpu.type_ref sorted_pgpus with
 		| None ->
 			raise (Api_errors.Server_error (Api_errors.vm_requires_vgpu, [
 				Ref.string_of vm;

ocaml/xapi/xapi_vm_helpers.ml

@@ -602,7 +602,55 @@ let choose_host_for_vm_no_wlb ~__context ~vm ~snapshot =
 	let validate_host = vm_can_run_on_host __context vm snapshot true in
 	let all_hosts = Db.Host.get_all ~__context in
 	try
-		Xapi_vm_placement.select_host __context vm validate_host all_hosts
+		match Db.VM.get_VGPUs ~__context ~self:vm with
+		| [] -> Xapi_vm_placement.select_host __context vm validate_host all_hosts
+		| vgpu :: _ -> (* just considering first vgpu *)
+			let vgpu_type = Db.VGPU.get_type ~__context ~self:vgpu in
+			let gpu_group = Db.VGPU.get_GPU_group ~__context ~self:vgpu in
+			if not (Xapi_gpu_group.get_remaining_capacity ~__context ~self:gpu_group ~vgpu_type > 0L)
+			then raise (Api_errors.Server_error (Api_errors.vm_requires_vgpu,
+				[Ref.string_of vm; Ref.string_of gpu_group; Ref.string_of vgpu_type]));
+			let pgpus = Db.GPU_group.get_PGPUs ~__context ~self:gpu_group in
+			let can_accomodate_vgpu pgpu =
+				Xapi_pgpu_helpers.get_remaining_capacity ~__context ~self:pgpu
+					~vgpu_type > 0L
+			in
+			let viable_pgpus = List.filter can_accomodate_vgpu pgpus in
+			let viable_hosts = List.setify
+				(List.map (fun pgpu -> Db.PGPU.get_host ~__context ~self:pgpu)
+					viable_pgpus)
+			in
+			(* Group the hosts by pgpu-capacity and try to select a host based
+			 * on GPU group allocation algorithm *)
+			let host_lists = Helpers.group_by
+				(fun host ->
+					let group_by_capacity pgpus =
+						(match Db.GPU_group.get_allocation_algorithm ~__context ~self:gpu_group with
+						| `depth_first -> Helpers.group_by ~descending:false
+						| `breadth_first -> Helpers.group_by ~descending:true)
+						(fun pgpu -> Xapi_pgpu_helpers.get_remaining_capacity ~__context ~self:pgpu ~vgpu_type)
+						pgpus
+					in
+					let viable_resident_pgpus = List.filter
+						(fun self -> Db.PGPU.get_host ~__context ~self = host)
+						viable_pgpus
+					in
+					snd (List.hd (List.hd (group_by_capacity viable_resident_pgpus)))
+				) viable_hosts
+			in
+			let rec select_host_from = function
+				| [] -> raise (Api_errors.Server_error (Api_errors.no_hosts_available, []))
+				| (hosts :: less_optimal_groups_of_hosts) ->
+					let hosts = List.map (fun (h, c) -> h) hosts in
+					debug "Attempting to start VM (%s) on one of equally optimal hosts [ %s ]"
+						(Ref.string_of vm) (String.concat ";" (List.map Ref.string_of hosts));
+					try Xapi_vm_placement.select_host __context vm validate_host hosts
+					with _ ->
+						info "Failed to start VM (%s) on any of [ %s ]"
+							(Ref.string_of vm) (String.concat ";" (List.map Ref.string_of hosts));
+						select_host_from less_optimal_groups_of_hosts
+			in
+			select_host_from host_lists
 	with Api_errors.Server_error(x,[]) when x=Api_errors.no_hosts_available ->
 		debug "No hosts guaranteed to satisfy VM constraints. Trying again ignoring memory checks";
 		let validate_host = vm_can_run_on_host __context vm snapshot false in