diff --git a/.gitignore b/.gitignore index dd6086e4a..b881839e2 100644 --- a/.gitignore +++ b/.gitignore @@ -35,3 +35,5 @@ *.cmt *.cmti *.so +dist +config.mk diff --git a/xl/domain.ml b/xl/domain.ml deleted file mode 100644 index 520dc92c3..000000000 --- a/xl/domain.ml +++ /dev/null @@ -1,1185 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * 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. - *) -(** Functions relating to Xen domains *) - -open Printf -open Xenops_utils -open Xenstore -open Cancel_utils - -open Xenops_helpers -open Device_common -open Xenops_task - -module D = Debug.Make(struct let name = "xenops" end) -open D - -type create_info = { - ssidref: int32; - hvm: bool; - hap: bool; - name: string; - xsdata: (string * string) list; - platformdata: (string * string) list; - bios_strings: (string * string) list; -} with rpc - -type build_hvm_info = { - shadow_multiplier: float; - video_mib: int; -} with rpc - -type build_pv_info = { - cmdline: string; - ramdisk: string option; -} with rpc - -type builder_spec_info = BuildHVM of build_hvm_info | BuildPV of build_pv_info -with rpc - -type build_info = { - memory_max: int64; (* memory max in kilobytes *) - memory_target: int64; (* memory target in kilobytes *) - kernel: string; (* in hvm case, point to hvmloader *) - vcpus: int; (* vcpus max *) - priv: builder_spec_info; -} with rpc - -type domid = int - -let allowed_xsdata_prefixes = [ "vm-data"; "FIST" ] - -let filtered_xsdata = - (* disallowed by default; allowed only if it has one of a set of prefixes *) - let allowed (x, _) = List.fold_left (||) false (List.map (fun p -> String.startswith (p ^ "/") x) allowed_xsdata_prefixes) in - List.filter allowed - -exception Restore_signature_mismatch -exception Domain_build_failed -exception Domain_restore_failed -exception Domain_restore_truncated_hvmstate -exception Xenguest_protocol_failure of string (* internal protocol failure *) -exception Xenguest_failure of string (* an actual error is reported to us *) -exception Timeout_backend -exception Could_not_read_file of string (* eg linux kernel/ initrd *) -exception Domain_stuck_in_dying_state of Xenctrl.domid - -let save_signature = "XenSavedDomain\n" -let qemu_save_signature = "QemuDeviceModelRecord\n" -let releaseDomain = "@releaseDomain" -let introduceDomain = "@introduceDomain" - -module Uuid = Uuidm - -let log_exn_continue msg f x = try f x with e -> debug "Safely ignoring exception: %s while %s" (Printexc.to_string e) msg - -let log_exn_rm ~xs x = log_exn_continue ("xenstore-rm " ^ x) xs.Xs.rm x - -let set_difference a b = List.filter (fun x -> not(List.mem x b)) a - -let assert_file_is_readable filename = - try Unix.access filename [ Unix.F_OK; Unix.R_OK ] - with _ -> - error "Cannot read file %s" filename; - raise (Could_not_read_file filename) -let maybe f = function None -> () | Some x -> f x - -type domarch = Arch_HVM | Arch_native | Arch_X64 | Arch_X32 - -let string_of_domarch = function - | Arch_HVM -> "hvm" - | Arch_native -> "" - | Arch_X64 -> "x64" - | Arch_X32 -> "x32" - -let domarch_of_string = function - | "hvm" -> Arch_HVM - | "x64" -> Arch_X64 - | "x32" -> Arch_X32 - | _ -> Arch_native - -let get_uuid ~xc domid = - Xenctrl_uuid.uuid_of_handle (Xenctrl.domain_getinfo xc domid).Xenctrl.handle - -let wait_xen_free_mem ~xc ?(maximum_wait_time_seconds=64) required_memory_kib : bool = - let open Memory in - let rec wait accumulated_wait_time_seconds = - let host_info = Xenctrl.physinfo xc in - let free_memory_kib = - kib_of_pages (Int64.of_nativeint host_info.Xenctrl.free_pages) in - let scrub_memory_kib = - kib_of_pages (Int64.of_nativeint host_info.Xenctrl.scrub_pages) in - (* At exponentially increasing intervals, write *) - (* a debug message saying how long we've waited: *) - if is_power_of_2 accumulated_wait_time_seconds then debug - "Waited %i second(s) for memory to become available: \ - %Ld KiB free, %Ld KiB scrub, %Ld KiB required" - accumulated_wait_time_seconds - free_memory_kib scrub_memory_kib required_memory_kib; - if free_memory_kib >= required_memory_kib - (* We already have enough memory. *) - then true else - if scrub_memory_kib = 0L - (* We'll never have enough memory. *) - then false else - if accumulated_wait_time_seconds >= maximum_wait_time_seconds - (* We've waited long enough. *) - then false else - begin - Thread.delay 1.0; - wait (accumulated_wait_time_seconds + 1) - end in - wait 0 - - -let make ~xc ~xs vm_info uuid = - let flags = if vm_info.hvm then begin - let default_flags = - (if vm_info.hvm then [ Xenctrl.CDF_HVM ] else []) @ - (if (vm_info.hvm && vm_info.hap) then [ Xenctrl.CDF_HAP ] else []) in - if (List.mem_assoc "hap" vm_info.platformdata) then begin - let hap = List.assoc "hap" vm_info.platformdata in - if hap = "false" then begin - info "VM = %s; Hardware Assisted Paging (HAP) disabled" (Uuid.to_string uuid); - [ Xenctrl.CDF_HVM ] - end else if hap = "true" then begin - info "VM = %s; Hardware Assisted Paging (HAP) will be enabled." (Uuid.to_string uuid); - [ Xenctrl.CDF_HVM; Xenctrl.CDF_HAP ] - end else begin - warn "VM = %s; Unrecognized value platform/hap=\"%s\". Hardware Assisted Paging will be %s." (Uuid.to_string uuid) hap (if List.mem Xenctrl.CDF_HAP default_flags then "enabled" else "disabled"); - default_flags - end - end else begin - info "VM = %s; Hardware Assisted Paging will be %s. Use platform/hap=(true|false) to override" (Uuid.to_string uuid) (if List.mem Xenctrl.CDF_HAP default_flags then "enabled" else "disabled"); - default_flags - end - end else [] in - let domid = Xenctrl.domain_create xc vm_info.ssidref flags (Uuidm.to_string uuid) in - let name = if vm_info.name <> "" then vm_info.name else sprintf "Domain-%d" domid in - try - let dom_path = xs.Xs.getdomainpath domid in - let vm_path = "/vm/" ^ (Uuid.to_string uuid) in - let vss_path = "/vss/" ^ (Uuid.to_string uuid) in - let roperm = Xenbus_utils.roperm_for_guest domid in - let rwperm = Xenbus_utils.rwperm_for_guest domid in - debug "VM = %s; creating xenstored tree: %s" (Uuid.to_string uuid) dom_path; - - Xs.transaction xs (fun t -> - (* Clear any existing rubbish in xenstored *) - t.Xst.rm dom_path; - t.Xst.mkdir dom_path; - t.Xst.setperms dom_path roperm; - - (* The /vm path needs to be shared over a localhost migrate *) - let vm_exists = try ignore(t.Xst.read vm_path); true with _ -> false in - if not vm_exists then begin - t.Xst.mkdir vm_path; - t.Xst.setperms vm_path roperm; - t.Xst.writev vm_path [ - "uuid", (Uuid.to_string uuid); - "name", name; - ]; - end; - t.Xst.write (Printf.sprintf "%s/domains/%d" vm_path domid) dom_path; - - t.Xst.rm vss_path; - t.Xst.mkdir vss_path; - t.Xst.setperms vss_path rwperm; - - t.Xst.write (dom_path ^ "/vm") vm_path; - t.Xst.write (dom_path ^ "/vss") vss_path; - t.Xst.write (dom_path ^ "/name") name; - - (* create cpu and memory directory with read only perms *) - List.iter (fun dir -> - let ent = sprintf "%s/%s" dom_path dir in - t.Xst.mkdir ent; - t.Xst.setperms ent roperm - ) [ "cpu"; "memory" ]; - (* create read/write nodes for the guest to use *) - List.iter (fun dir -> - let ent = sprintf "%s/%s" dom_path dir in - t.Xst.mkdir ent; - t.Xst.setperms ent rwperm - ) [ "device"; "error"; "drivers"; "control"; "attr"; "data"; "messages"; "vm-data" ]; - ); - - xs.Xs.writev dom_path (filtered_xsdata vm_info.xsdata); - xs.Xs.writev (dom_path ^ "/platform") vm_info.platformdata; - - xs.Xs.writev (dom_path ^ "/bios-strings") vm_info.bios_strings; - - (* If a toolstack sees a domain which it should own in this state then the - domain is not completely setup and should be shutdown. *) - xs.Xs.write (dom_path ^ "/action-request") "poweroff"; - - xs.Xs.write (dom_path ^ "/control/platform-feature-multiprocessor-suspend") "1"; - - (* CA-30811: let the linux guest agent easily determine if this is a fresh domain even if - the domid hasn't changed (consider cross-host migrate) *) - xs.Xs.write (dom_path ^ "/unique-domain-id") (Uuid.to_string (Uuid.create `V4)); - - info "VM = %s; domid = %d" (Uuid.to_string uuid) domid; - domid - with e -> - debug "VM = %s; domid = %d; Caught exception while creating xenstore tree: %s" (Uuid.to_string uuid) domid (Printexc.to_string e); - raise e - -type shutdown_reason = PowerOff | Reboot | Suspend | Crash | Halt | S3Suspend | Unknown of int - -(** Strings suitable for putting in the control/shutdown xenstore entry *) -let string_of_shutdown_reason = function - | PowerOff -> "poweroff" - | Reboot -> "reboot" - | Suspend -> "suspend" - | Crash -> "crash" (* this one makes no sense to send to a guest *) - | Halt -> "halt" - | S3Suspend -> "s3" - | Unknown x -> sprintf "(unknown %d)" x (* or this one *) - -(** Decode the shutdown_reason contained within the dominfo struct *) -let shutdown_reason_of_int = function - | 0 -> PowerOff - | 1 -> Reboot - | 2 -> Suspend - | 3 -> Crash - | 4 -> Halt - | x -> Unknown x - -let shutdown_to_xc_shutdown = function - | PowerOff -> Xenctrl.Poweroff - | Reboot -> Xenctrl.Reboot - | Suspend -> Xenctrl.Suspend - | Crash -> Xenctrl.Crash - | Halt -> Xenctrl.Halt - | S3Suspend -> raise (Invalid_argument "unknown") - | Unknown _-> raise (Invalid_argument "unknown") - -(** Immediately change the domain state to shutdown *) -let hard_shutdown ~xc domid req = - Xenctrl.domain_shutdown xc domid (shutdown_to_xc_shutdown req) - -(** Return the path in xenstore watched by the PV shutdown driver *) -let control_shutdown ~xs domid = xs.Xs.getdomainpath domid ^ "/control/shutdown" - -(** Raised if a domain has vanished *) -exception Domain_does_not_exist - -(** Request a shutdown, return without waiting for acknowledgement *) -let shutdown ~xc ~xs domid req = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; Requesting domain %s" (Uuid.to_string uuid) domid (string_of_shutdown_reason req); - - let reason = string_of_shutdown_reason req in - let path = control_shutdown ~xs domid in - let domainpath = xs.Xs.getdomainpath domid in - Xs.transaction xs - (fun t -> - (* Fail if the directory has been deleted *) - let domain_exists = try ignore (t.Xst.read domainpath); true with Xs_protocol.Enoent _ -> false in - if not domain_exists then raise Domain_does_not_exist; - (* Delete the node if it already exists. NB: the guest may well still shutdown for the - previous reason... we only want to give it a kick again just in case. *) - (try t.Xst.rm path with _ -> ()); - t.Xst.write path reason - ) - -(** If domain is PV, signal it to shutdown. If the PV domain fails to respond then throw a Watch.Timeout exception. - All other exceptions imply the domain has disappeared. *) -let shutdown_wait_for_ack (t: Xenops_task.t) ?(timeout=60.) ~xc ~xs domid req = - let di = Xenctrl.domain_getinfo xc domid in - let uuid = get_uuid ~xc domid in - if di.Xenctrl.hvm_guest then begin - debug "VM = %s; domid = %d; HVM guest with PV drivers: not expecting any acknowledgement" (Uuid.to_string uuid) domid; - end else begin - debug "VM = %s; domid = %d; Waiting for PV domain to acknowledge shutdown request" (Uuid.to_string uuid) domid; - let path = control_shutdown ~xs domid in - let cancel = Domain domid in - if cancellable_watch cancel [ Watch.value_to_become path ""] [ Watch.key_to_disappear path ] t ~xs ~timeout () - then info "VM = %s; domid = %d; Domain acknowledged shutdown request" (Uuid.to_string uuid) domid - else debug "VM = %s; domid = %d; Domain disappeared" (Uuid.to_string uuid) domid - end - -let sysrq ~xs domid key = - let path = xs.Xs.getdomainpath domid ^ "/control/sysrq" in - xs.Xs.write path (String.make 1 key) - -let destroy (task: Xenops_task.t) ~xc ~xs ~qemu_domid domid = - let dom_path = xs.Xs.getdomainpath domid in - let uuid = get_uuid ~xc domid in - (* These are the devices with a frontend in [domid] and a well-formed backend - in some other domain *) - let all_devices = list_frontends ~xs domid in - - debug "VM = %s; domid = %d; Domain.destroy: all known devices = [ %a ]" - (Uuid.to_string uuid) domid - (fun () -> String.concat "; ") - (List.map string_of_device all_devices); - -(* - (* reset PCI devices before xc.domain_destroy otherwise we lot all IOMMU mapping *) - let _, all_pci_devices = List.split (Device.PCI.list xc xs domid) in - List.iter - (fun pcidev -> - log_exn_continue - ("Deassign PCI device " ^ Device.PCI.to_string pcidev) - (fun () -> Xenctrl.domain_deassign_device xc domid pcidev) ()) - all_pci_devices; - List.iter - (fun pcidev -> - log_exn_continue - ("Reset PCI device " ^ Device.PCI.to_string pcidev) - (fun () -> Device.PCI.reset ~xs pcidev) ()) - all_pci_devices; -*) - (* Now we should kill the domain itself *) - debug "VM = %s; domid = %d; Domain.destroy calling Xenctrl.domain_destroy" (Uuid.to_string uuid) domid; - log_exn_continue "Xenctrl.domain_destroy" (Xenctrl.domain_destroy xc) domid; - - log_exn_continue "Error stoping device-model, already dead ?" - (fun () -> Device.Dm.stop ~xs ~qemu_domid domid) (); - log_exn_continue "Error stoping vncterm, already dead ?" - (fun () -> Device.PV_Vnc.stop ~xs domid) (); - - (* Forcibly shutdown every backend *) - List.iter - (fun device -> - try - Device.hard_shutdown task ~xs device - with e -> - (* If this fails we may have a resource leak. We should prevent - this from happening! *) - error "VM = %s; domid = %d; Caught exception %s while destroying device %s" - (Uuid.to_string uuid) domid - (Printexc.to_string e) (string_of_device device); - (* Keep going on a best-effort basis *) - ) all_devices; - - (* For each device which has a hotplug entry, perform the cleanup. Even if one - fails, try to cleanup the rest anyway.*) - let released = ref [] in - List.iter (fun x -> - log_exn_continue ("waiting for hotplug for " ^ (string_of_device x)) - (fun () -> - Hotplug.release task ~xs x; released := x :: !released - ) () - ) all_devices; - - (* If we fail to release a device we leak resources. If we are to tolerate this - then we need an async cleanup thread. *) - let failed_devices = List.filter (fun x -> not(List.mem x !released)) all_devices in - List.iter (fun dev -> - error "VM = %s; domid = %d; Domain.destroy failed to release device: %s" - (Uuid.to_string uuid) domid - (string_of_device dev)) failed_devices; - - (* Remove our reference to the /vm/ directory *) - let vm_path = try Some (xs.Xs.read (dom_path ^ "/vm")) with _ -> None in - Opt.iter (fun vm_path -> xs.Xs.rm (vm_path ^ "/domains/" ^ (string_of_int domid))) vm_path; - - let vss_path = try Some (xs.Xs.read (dom_path ^ "/vss")) with _ -> None in - (* If there are no more references then remove /vm/ and /vss/ *) - Opt.iter (fun vm_path -> - let domains = List.filter (fun x -> x <> "") (xs.Xs.directory (vm_path ^ "/domains")) in - if domains = [] then begin - debug "xenstore-rm %s" vm_path; - xs.Xs.rm vm_path; - Opt.iter (fun vss_path -> - debug "xenstore-rm %s" vss_path; - xs.Xs.rm vss_path - ) vss_path - end - ) vm_path; - - (* Delete the /local/domain/ and all the backend device paths *) - debug "VM = %s; domid = %d; xenstore-rm %s" (Uuid.to_string uuid) domid dom_path; - xs.Xs.rm dom_path; - debug "VM = %s; domid = %d; deleting backends" (Uuid.to_string uuid) domid; - let backend_path = xs.Xs.getdomainpath 0 ^ "/backend" in - let all_backend_types = try xs.Xs.directory backend_path with _ -> [] in - List.iter (fun ty -> log_exn_rm ~xs (Printf.sprintf "%s/%s/%d" backend_path ty domid)) all_backend_types; - - (* If all devices were properly un-hotplugged, then zap the tree in xenstore. - If there was some error leave the tree for debugging / async cleanup. *) - if failed_devices = [] - then log_exn_rm ~xs (Hotplug.get_private_path domid); - - (* Block waiting for the dying domain to disappear: aim is to catch shutdown errors early*) - let still_exists () = - try - let _ = Xenctrl.domain_getinfo xc domid in - debug "VM = %s; domid = %d; Domain still exist, waiting for it to disappear." (Uuid.to_string uuid) domid; - true - with - | Xenctrl.Error err -> - debug "VM = %s; domid = %d; Domain nolonger exists (%s)" (Uuid.to_string uuid) domid err; - false - | e -> - error "VM = %s; domid = %d; Xenctrl.domain_getinfo threw: %s" (Uuid.to_string uuid) domid (Printexc.to_string e); - raise e in - let start = Unix.gettimeofday () in - let timeout = 60. in - while still_exists () && (Unix.gettimeofday () -. start < timeout) do - Thread.delay 5. - done; - if still_exists () then begin - (* CA-13801: to avoid confusing people, we shall change this domain's uuid *) - let s = Printf.sprintf "deadbeef-dead-beef-dead-beef0000%04x" domid in - error "VM = %s; domid = %d; Domain stuck in dying state after 30s; resetting UUID to %s. This probably indicates a backend driver bug." (Uuid.to_string uuid) domid s; - Xenctrl.domain_sethandle xc domid s; - raise (Domain_stuck_in_dying_state domid) - end - - -let pause ~xc domid = - Xenctrl.domain_pause xc domid - -let unpause ~xc domid = - Xenctrl.domain_unpause xc domid - -let set_action_request ~xs domid x = - let path = xs.Xs.getdomainpath domid ^ "/action-request" in - match x with - | None -> xs.Xs.rm path - | Some v -> xs.Xs.write path v - -let get_action_request ~xs domid = - let path = xs.Xs.getdomainpath domid ^ "/action-request" in - try - Some (xs.Xs.read path) - with Xs_protocol.Enoent _ -> None - -(** create store and console channels *) -let create_channels ~xc uuid domid = - let store = Xenctrl.evtchn_alloc_unbound xc domid 0 in - let console = Xenctrl.evtchn_alloc_unbound xc domid 0 in - debug "VM = %s; domid = %d; store evtchn = %d; console evtchn = %d" (Uuid.to_string uuid) domid store console; - store, console - -let build_pre ~xc ~xs ~vcpus ~xen_max_mib ~shadow_mib ~required_host_free_mib domid = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; waiting for %Ld MiB of free host memory" (Uuid.to_string uuid) domid required_host_free_mib; - (* CA-39743: Wait, if necessary, for the Xen scrubber to catch up. *) - let (_: bool) = wait_xen_free_mem ~xc (Memory.kib_of_mib required_host_free_mib) in - - let shadow_mib = Int64.to_int shadow_mib in - - let dom_path = xs.Xs.getdomainpath domid in - let read_platform flag = xs.Xs.read (dom_path ^ "/platform/" ^ flag) in - let int_platform_flag flag = try Some (int_of_string (read_platform flag)) with _ -> None in - let timer_mode = int_platform_flag "timer_mode" in - let hpet = int_platform_flag "hpet" in - let vpt_align = int_platform_flag "vpt_align" in - - let maybe_exn_ign name f opt = - maybe (fun opt -> try f opt with exn -> warn "exception setting %s: %s" name (Printexc.to_string exn)) opt - in - - maybe_exn_ign "timer mode" (fun mode -> - debug "VM = %s; domid = %d; domain_set_timer_mode %d" (Uuid.to_string uuid) domid mode; - Xenctrlext.domain_set_timer_mode xc domid mode - ) timer_mode; - maybe_exn_ign "hpet" (fun hpet -> - debug "VM = %s; domid = %d; domain_set_hpet %d" (Uuid.to_string uuid) domid hpet; - Xenctrlext.domain_set_hpet xc domid hpet - ) hpet; - maybe_exn_ign "vpt align" (fun vpt_align -> - debug "VM = %s; domid = %d; domain_set_vpt_align %d" (Uuid.to_string uuid) domid vpt_align; - Xenctrlext.domain_set_vpt_align xc domid vpt_align - ) vpt_align; - debug "VM = %s; domid = %d; domain_max_vcpus %d" (Uuid.to_string uuid) domid vcpus; - Xenctrl.domain_max_vcpus xc domid vcpus; - debug "VM = %s; domid = %d; domain_set_memmap_limit %Ld MiB" (Uuid.to_string uuid) domid xen_max_mib; - begin - let kib = Memory.kib_of_mib xen_max_mib in - try - Xenctrl.domain_set_memmap_limit xc domid kib - with e -> - error "VM = %s; domid = %d; domain_set_mmap_limit %Ld KiB failed: %s" - (Uuid.to_string uuid) domid kib (Printexc.to_string e) - end; - debug "VM = %s; domid = %d; shadow_allocation_set %d MiB" (Uuid.to_string uuid) domid shadow_mib; - Xenctrl.shadow_allocation_set xc domid shadow_mib; - - create_channels ~xc uuid domid - -let resume_post ~xc ~xs domid = - let uuid = get_uuid ~xc domid in - let dom_path = xs.Xs.getdomainpath domid in - let store_mfn_s = xs.Xs.read (dom_path ^ "/store/ring-ref") in - let store_mfn = Nativeint.of_string store_mfn_s in - let store_port = int_of_string (xs.Xs.read (dom_path ^ "/store/port")) in - debug "VM = %s; domid = %d; @introduceDomain" (Uuid.to_string uuid) domid; - xs.Xs.introduce domid store_mfn store_port - -(* puts value in store after the domain build succeed *) -let build_post ~xc ~xs ~vcpus ~static_max_mib ~target_mib domid - store_mfn store_port ents vments = - let uuid = get_uuid ~xc domid in - let dom_path = xs.Xs.getdomainpath domid in - (* Unit conversion. *) - let static_max_kib = Memory.kib_of_mib static_max_mib in - let target_kib = Memory.kib_of_mib target_mib in - (* expand local stuff with common values *) - let ents = - [ ("memory/static-max", Int64.to_string static_max_kib); - ("memory/target", Int64.to_string target_kib); - ("domid", string_of_int domid); - ("store/port", string_of_int store_port); - ("store/ring-ref", sprintf "%nu" store_mfn); - ] @ ents in - Xs.transaction xs (fun t -> t.Xst.writev dom_path ents); - if vments <> [] then ( - let vm_path = xs.Xs.read (dom_path ^ "/vm") in - Xs.transaction xs (fun t -> t.Xst.writev vm_path vments) - ); - debug "VM = %s; domid = %d; @introduceDomain" (Uuid.to_string uuid) domid; - xs.Xs.introduce domid store_mfn store_port - -(** build a linux type of domain *) -let build_linux (task: Xenops_task.t) ~xc ~xs ~store_domid ~console_domid ~static_max_kib ~target_kib ~kernel ~cmdline ~ramdisk - ~vcpus domid = - let uuid = get_uuid ~xc domid in - assert_file_is_readable kernel; - maybe assert_file_is_readable ramdisk; - - (* Convert memory configuration values into the correct units. *) - let static_max_mib = Memory.mib_of_kib_used static_max_kib in - let target_mib = Memory.mib_of_kib_used target_kib in - - (* Sanity check. *) - assert (target_mib <= static_max_mib); - - (* Adapt memory configuration values for Xen and the domain builder. *) - let video_mib = 0 in - let build_max_mib = - Memory.Linux.build_max_mib static_max_mib video_mib in - let build_start_mib = - Memory.Linux.build_start_mib target_mib video_mib in - let xen_max_mib = - Memory.Linux.xen_max_mib static_max_mib in - let shadow_multiplier = - Memory.Linux.shadow_multiplier_default in - let shadow_mib = - Memory.Linux.shadow_mib static_max_mib vcpus shadow_multiplier in - let required_host_free_mib = - Memory.Linux.footprint_mib target_mib static_max_mib vcpus shadow_multiplier in - - let store_port, console_port = build_pre ~xc ~xs - ~xen_max_mib ~shadow_mib ~required_host_free_mib ~vcpus domid in - - let line = XenguestHelper.with_connection task domid - [ - "-mode"; "linux_build"; - "-domid"; string_of_int domid; - "-mem_max_mib"; Int64.to_string build_max_mib; - "-mem_start_mib"; Int64.to_string build_start_mib; - "-image"; kernel; - "-ramdisk"; (match ramdisk with Some x -> x | None -> ""); - "-cmdline"; cmdline; - "-features"; ""; - "-flags"; "0"; - "-store_port"; string_of_int store_port; - "-store_domid"; string_of_int store_domid; - "-console_port"; string_of_int console_port; - "-console_domid"; string_of_int console_domid; - "-fork"; "true"; - ] [] - XenguestHelper.receive_success in - - let store_mfn, console_mfn, protocol = - (* the "protocol" (ie the domU architecture) was only needed for very - old kernels which had bugs preventing them succesfully autonegotiating - the 64-bit version of the protocol. If we don't know the architecture, - it should be safe to assume "native" i.e. let the domU do its thing. *) - match Re_str.split (Re_str.regexp "[ ]") line with - | [ store_mfn; console_mfn; protocol ] -> - debug "VM = %s; domid = %d; store_mfn = %s; console_mfn = %s; protocol = %s" (Uuid.to_string uuid) domid store_mfn console_mfn protocol; - Nativeint.of_string store_mfn, Nativeint.of_string console_mfn, protocol - | [ store_mfn; console_mfn ] -> - debug "VM = %s; domid = %d; store_mfn = %s; console_mfn = %s; protocol unavailable, assuming 'native'" (Uuid.to_string uuid) domid store_mfn console_mfn; - Nativeint.of_string store_mfn, Nativeint.of_string console_mfn, "" - | _ -> - error "VM = %s; domid = %d; domain builder returned invalid result: \"%s\"" (Uuid.to_string uuid) domid line; - raise Domain_build_failed in - - let local_stuff = [ - "serial/0/limit", string_of_int 65536; - "console/port", string_of_int console_port; - "console/ring-ref", sprintf "%nu" console_mfn; - ] in - let vm_stuff = [] in - build_post ~xc ~xs ~vcpus ~target_mib ~static_max_mib - domid store_mfn store_port local_stuff vm_stuff; - match protocol with - | "x86_32-abi" -> Arch_X32 - | "x86_64-abi" -> Arch_X64 - | _ -> Arch_native - -(** build hvm type of domain *) -let build_hvm (task: Xenops_task.t) ~xc ~xs ~store_domid ~console_domid ~static_max_kib ~target_kib ~shadow_multiplier ~vcpus - ~kernel ~timeoffset ~video_mib domid = - let uuid = get_uuid ~xc domid in - assert_file_is_readable kernel; - - (* Convert memory configuration values into the correct units. *) - let static_max_mib = Memory.mib_of_kib_used static_max_kib in - let target_mib = Memory.mib_of_kib_used target_kib in - - (* Sanity check. *) - assert (target_mib <= static_max_mib); - - (* Adapt memory configuration values for Xen and the domain builder. *) - let build_max_mib = - Memory.HVM.build_max_mib static_max_mib video_mib in - let build_start_mib = - Memory.HVM.build_start_mib target_mib video_mib in - let xen_max_mib = - Memory.HVM.xen_max_mib static_max_mib in - let shadow_mib = - Memory.HVM.shadow_mib static_max_mib vcpus shadow_multiplier in - let required_host_free_mib = - Memory.HVM.footprint_mib target_mib static_max_mib vcpus shadow_multiplier in - - let store_port, console_port = build_pre ~xc ~xs - ~xen_max_mib ~shadow_mib ~required_host_free_mib ~vcpus domid in - - let line = XenguestHelper.with_connection task domid - [ - "-mode"; "hvm_build"; - "-domid"; string_of_int domid; - "-store_port"; string_of_int store_port; - "-store_domid"; string_of_int store_domid; - "-console_port"; string_of_int console_port; - "-console_domid"; string_of_int console_domid; - "-image"; kernel; - "-mem_max_mib"; Int64.to_string build_max_mib; - "-mem_start_mib"; Int64.to_string build_start_mib; - "-fork"; "true"; - ] [] XenguestHelper.receive_success in - - (* XXX: domain builder will reduce our shadow allocation under our feet. - Detect this and override. *) - let requested_shadow_mib = Int64.to_int shadow_mib in - let actual_shadow_mib = Xenctrl.shadow_allocation_get xc domid in - if actual_shadow_mib < requested_shadow_mib then begin - warn - "VM = %s; domid = %d; HVM domain builder reduced our \ - shadow memory from %d to %d MiB; reverting" - (Uuid.to_string uuid) domid - requested_shadow_mib actual_shadow_mib; - Xenctrl.shadow_allocation_set xc domid requested_shadow_mib; - let shadow = Xenctrl.shadow_allocation_get xc domid in - debug "VM = %s; domid = %d; Domain now has %d MiB of shadow" - (Uuid.to_string uuid) domid shadow; - end; - - let store_mfn, console_mfn = - match Re_str.split (Re_str.regexp "[ ]") line with - | [ store_mfn; console_mfn] -> - debug "VM = %s; domid = %d; store_mfn = %s; console_mfn = %s" (Uuid.to_string uuid) domid store_mfn console_mfn; - Nativeint.of_string store_mfn, Nativeint.of_string console_mfn - | _ -> - error "VM = %s; domid = %d; domain builder returned invalid result: \"%s\"" (Uuid.to_string uuid) domid line; - raise Domain_build_failed in - - let local_stuff = [ - "serial/0/limit", string_of_int 65536; -(* - "console/port", string_of_int console_port; - "console/ring-ref", sprintf "%nu" console_mfn; -*) - ] in -(* - let store_mfn = - try Nativeint.of_string line - with _ -> raise Domain_build_failed in -*) - let vm_stuff = [ - "rtc/timeoffset", timeoffset; - ] in - - build_post ~xc ~xs ~vcpus ~target_mib ~static_max_mib - domid store_mfn store_port local_stuff vm_stuff; - - Arch_HVM - -let build (task: Xenops_task.t) ~xc ~xs ~store_domid ~console_domid info timeoffset domid = - match info.priv with - | BuildHVM hvminfo -> - build_hvm task ~xc ~xs ~store_domid ~console_domid ~static_max_kib:info.memory_max ~target_kib:info.memory_target - ~shadow_multiplier:hvminfo.shadow_multiplier ~vcpus:info.vcpus - ~kernel:info.kernel ~timeoffset ~video_mib:hvminfo.video_mib domid - | BuildPV pvinfo -> - build_linux task ~xc ~xs ~store_domid ~console_domid ~static_max_kib:info.memory_max ~target_kib:info.memory_target - ~kernel:info.kernel ~cmdline:pvinfo.cmdline ~ramdisk:pvinfo.ramdisk - ~vcpus:info.vcpus domid - -(* restore a domain from a file descriptor. it read first the signature - * to be we are not trying to restore from random data. - * the linux_restore process is in charge to allocate memory as it's needed - *) -let restore_common (task: Xenops_task.t) ~xc ~xs ~hvm ~store_port ~store_domid ~console_port ~console_domid ~vcpus ~extras domid fd = - let uuid = get_uuid ~xc domid in - let read_signature = Io.read fd (String.length save_signature) in - if read_signature <> save_signature then begin - error "VM = %s; domid = %d; read invalid save file signature: \"%s\"" (Uuid.to_string uuid) domid read_signature; - raise Restore_signature_mismatch; - end; - Unix.clear_close_on_exec fd; - let fd_uuid = Uuid.to_string (Uuid.create `V4) in - - let line = XenguestHelper.with_connection task domid - ([ - "-mode"; if hvm then "hvm_restore" else "restore"; - "-domid"; string_of_int domid; - "-fd"; fd_uuid; - "-store_port"; string_of_int store_port; - "-store_domid"; string_of_int store_domid; - "-console_port"; string_of_int console_port; - "-console_domid"; string_of_int console_domid; - "-fork"; "true"; - ] @ extras) [ fd_uuid, fd ] XenguestHelper.receive_success in - - let store_mfn, console_mfn = - match Re_str.split (Re_str.regexp "[ ]") line with - | [ store; console ] -> - debug "VM = %s; domid = %d; store_mfn = %s; console_mfn = %s" (Uuid.to_string uuid) domid store console; - Nativeint.of_string store, Nativeint.of_string console - | _ -> - error "VM = %s; domid = %d; domain builder returned invalid result: \"%s\"" (Uuid.to_string uuid) domid line; - raise Domain_restore_failed - in - - if hvm then ( - (* restore qemu-dm tmp file *) - let read_signature = Io.read fd (String.length qemu_save_signature) in - if read_signature <> qemu_save_signature then begin - error "VM = %s; domid = %d; read invalid qemu save file signature: \"%s\"" (Uuid.to_string uuid) domid read_signature; - raise Restore_signature_mismatch; - end; - let limit = Int64.of_int (Io.read_int fd) in - - let file = sprintf qemu_restore_path domid in - let fd2 = Unix.openfile file [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] 0o640 in - finally (fun () -> - debug "VM = %s; domid = %d; reading %Ld bytes from %s" (Uuid.to_string uuid) domid limit file; - if Unixext.copy_file ~limit fd fd2 <> limit then begin - error "VM = %s; domid = %d; qemu save file was truncated" (Uuid.to_string uuid) domid; - raise Domain_restore_truncated_hvmstate - end - ) (fun () -> Unix.close fd2); - ); - store_mfn, console_mfn - -let resume (task: Xenops_task.t) ~xc ~xs ~hvm ~cooperative ~qemu_domid domid = - if not cooperative - then failwith "Domain.resume works only for collaborative domains"; - Xenctrl.domain_resume_fast xc domid; - resume_post ~xc ~xs domid; - if hvm then Device.Dm.resume task ~xs ~qemu_domid domid - -let pv_restore (task: Xenops_task.t) ~xc ~xs ~store_domid ~console_domid ~static_max_kib ~target_kib ~vcpus domid fd = - - (* Convert memory configuration values into the correct units. *) - let static_max_mib = Memory.mib_of_kib_used static_max_kib in - let target_mib = Memory.mib_of_kib_used target_kib in - - (* Sanity check. *) - assert (target_mib <= static_max_mib); - - (* Adapt memory configuration values for Xen and the domain builder. *) - let xen_max_mib = - Memory.Linux.xen_max_mib static_max_mib in - let shadow_multiplier = - Memory.Linux.shadow_multiplier_default in - let shadow_mib = - Memory.Linux.shadow_mib static_max_mib vcpus shadow_multiplier in - let required_host_free_mib = - Memory.Linux.footprint_mib target_mib static_max_mib vcpus shadow_multiplier in - - let store_port, console_port = build_pre ~xc ~xs - ~xen_max_mib ~shadow_mib ~required_host_free_mib ~vcpus domid in - - let store_mfn, console_mfn = restore_common task ~xc ~xs ~store_domid ~console_domid ~hvm:false - ~store_port ~console_port - ~vcpus ~extras:[] domid fd in - let local_stuff = [ - "serial/0/limit", string_of_int 65536; - "console/port", string_of_int console_port; - "console/ring-ref", sprintf "%nu" console_mfn; - ] in - let vm_stuff = [] in - build_post ~xc ~xs ~vcpus ~target_mib ~static_max_mib - domid store_mfn store_port local_stuff vm_stuff - -let hvm_restore (task: Xenops_task.t) ~xc ~xs ~store_domid ~console_domid ~static_max_kib ~target_kib ~shadow_multiplier ~vcpus ~timeoffset domid fd = - - (* Convert memory configuration values into the correct units. *) - let static_max_mib = Memory.mib_of_kib_used static_max_kib in - let target_mib = Memory.mib_of_kib_used target_kib in - - (* Sanity check. *) - assert (target_mib <= static_max_mib); - - (* Adapt memory configuration values for Xen and the domain builder. *) - let xen_max_mib = - Memory.HVM.xen_max_mib static_max_mib in - let shadow_mib = - Memory.HVM.shadow_mib static_max_mib vcpus shadow_multiplier in - let required_host_free_mib = - Memory.HVM.footprint_mib target_mib static_max_mib vcpus shadow_multiplier in - - let store_port, console_port = build_pre ~xc ~xs - ~xen_max_mib ~shadow_mib ~required_host_free_mib ~vcpus domid in - - let store_mfn, console_mfn = restore_common task ~xc ~xs ~store_domid ~console_domid ~hvm:true - ~store_port ~console_port - ~vcpus ~extras:[] domid fd in - let local_stuff = [ - "serial/0/limit", string_of_int 65536; -(* - "console/port", string_of_int console_port; - "console/ring-ref", sprintf "%nu" console_mfn; -*) - ] in - let vm_stuff = [ - "rtc/timeoffset", timeoffset; - ] in - (* and finish domain's building *) - build_post ~xc ~xs ~vcpus ~target_mib ~static_max_mib - domid store_mfn store_port local_stuff vm_stuff - -let restore (task: Xenops_task.t) ~xc ~xs ~store_domid ~console_domid info timeoffset domid fd = - let restore_fct = match info.priv with - | BuildHVM hvminfo -> - hvm_restore task ~shadow_multiplier:hvminfo.shadow_multiplier - ~timeoffset - | BuildPV pvinfo -> - pv_restore task - in - restore_fct ~xc ~xs ~store_domid ~console_domid - ~static_max_kib:info.memory_max ~target_kib:info.memory_target ~vcpus:info.vcpus - domid fd - -type suspend_flag = Live | Debug - -(* suspend register the callback function that will be call by linux_save - * and is in charge to suspend the domain when called. the whole domain - * context is saved to fd - *) -let suspend (task: Xenops_task.t) ~xc ~xs ~hvm domid fd flags ?(progress_callback = fun _ -> ()) ~qemu_domid do_suspend_callback = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; suspend live = %b" (Uuid.to_string uuid) domid (List.mem Live flags); - Io.write fd save_signature; - let fd_uuid = Uuid.to_string (Uuid.create `V4) in - - let cmdline_to_flag flag = - match flag with - | Live -> [ "-live"; "true" ] - | Debug -> [ "-debug"; "true" ] - in - let flags' = List.map cmdline_to_flag flags in - - let xenguestargs = [ - "-fd"; fd_uuid; - "-mode"; if hvm then "hvm_save" else "save"; - "-domid"; string_of_int domid; - "-fork"; "true"; - ] @ (List.concat flags') in - - XenguestHelper.with_connection task domid xenguestargs [ fd_uuid, fd ] - (fun cnx -> - debug "VM = %s; domid = %d; waiting for xenguest to call suspend callback" (Uuid.to_string uuid) domid; - - (* Monitor the debug (stderr) output of the xenguest helper and - spot the progress indicator *) - let callback txt = - let prefix = "\\b\\b\\b\\b" in - if String.startswith prefix txt then - let rest = String.sub txt (String.length prefix) - (String.length txt - (String.length prefix)) in - match Re_str.split (Re_str.regexp "[ %]") rest with - | [ percent ] -> ( - try - let percent = int_of_string percent in - debug "VM = %s; domid = %d; progress = %d / 100" (Uuid.to_string uuid) domid percent; - progress_callback (float_of_int percent /. 100.) - with e -> - error "VM = %s; domid = %d; failed to parse progress update: \"%s\"" (Uuid.to_string uuid) domid percent; - (* MTC: catch exception by progress_callback, for example, - an abort request, and re-raise them *) - raise e - ) - | _ -> () - else - debug "VM = %s; domid = %d; %s" (Uuid.to_string uuid) domid txt - in - - (match XenguestHelper.non_debug_receive ~debug_callback:callback cnx with - | XenguestHelper.Suspend -> - debug "VM = %s; domid = %d; suspend callback called" (Uuid.to_string uuid) domid; - | XenguestHelper.Error x -> - error "VM = %s; domid = %d; xenguesthelper failed: \"%s\"" (Uuid.to_string uuid) domid x; - raise (Xenguest_failure (Printf.sprintf "Error while waiting for suspend notification: %s" x)) - | msg -> - let err = Printf.sprintf "expected %s got %s" - (XenguestHelper.string_of_message XenguestHelper.Suspend) - (XenguestHelper.string_of_message msg) in - error "VM = %s; domid = %d; xenguesthelper protocol failure %s" (Uuid.to_string uuid) domid err; - raise (Xenguest_protocol_failure err)); - do_suspend_callback (); - if hvm then ( - debug "VM = %s; domid = %d; suspending qemu-dm" (Uuid.to_string uuid) domid; - Device.Dm.suspend task ~xs ~qemu_domid domid; - ); - XenguestHelper.send cnx "done\n"; - - let msg = XenguestHelper.non_debug_receive cnx in - progress_callback 1.; - match msg with - | XenguestHelper.Result x -> - debug "VM = %s; domid = %d; xenguesthelper returned \"%s\"" (Uuid.to_string uuid) domid x - | XenguestHelper.Error x -> - error "VM = %s; domid = %d; xenguesthelper failed: \"%s\"" (Uuid.to_string uuid) domid x; - raise (Xenguest_failure (Printf.sprintf "Received error from xenguesthelper: %s" x)) - | _ -> - error "VM = %s; domid = %d; xenguesthelper protocol failure" (Uuid.to_string uuid) domid; - ); - - (* hvm domain need to also save qemu-dm data *) - if hvm then ( - Io.write fd qemu_save_signature; - let file = sprintf qemu_save_path domid in - let fd2 = Unix.openfile file [ Unix.O_RDONLY ] 0o640 in - let size = (Unix.stat file).Unix.st_size in - - finally (fun () -> - Io.write_int fd size; - let limit = Int64.of_int size in - debug "VM = %s; domid = %d; writing %Ld bytes from %s" (Uuid.to_string uuid) domid limit file; - if Unixext.copy_file ~limit fd2 fd <> limit - then failwith "Failed to write whole qemu-dm state file" - ) (fun () -> - Unix.unlink file; - Unix.close fd2) - ); - debug "VM = %s; domid = %d; suspend complete" (Uuid.to_string uuid) domid - -let send_s3resume ~xc domid = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; send_s3resume" (Uuid.to_string uuid) domid; - Xenctrlext.domain_send_s3resume xc domid - -let trigger_power ~xc domid = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; domain_trigger_power" (Uuid.to_string uuid) domid; - Xenctrlext.domain_trigger_power xc domid -let trigger_sleep ~xc domid = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; domain_trigger_sleep" (Uuid.to_string uuid) domid; - Xenctrlext.domain_trigger_sleep xc domid - -let vcpu_affinity_set ~xc domid vcpu cpumap = - (* - let bitmap = ref Int64.zero in - if Array.length cpumap > 64 then - invalid_arg "affinity_set"; - let bit_set bitmap n = - Int64.logor bitmap (Int64.shift_left 1L n) in - (* set bits in the bitmap that are true *) - Array.iteri (fun i has_affinity -> - if has_affinity then bitmap := bit_set !bitmap i - ) cpumap; - (*Xenctrl.vcpu_affinity_set xc domid vcpu !bitmap*) - *) - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; vcpu_affinity_set %d <- %s" (Uuid.to_string uuid) domid vcpu - (String.concat "" (List.map (fun b -> if b then "1" else "0") (Array.to_list cpumap))); - Xenctrl.vcpu_affinity_set xc domid vcpu cpumap - - -let vcpu_affinity_get ~xc domid vcpu = - (* - let pcpus = (Xenctrl.physinfo xc).Xenctrl.max_nr_cpus in - (* NB we ignore bits corresponding to pCPUs which we don't have *) - let bitmap = Xenctrl.vcpu_affinity_get xc domid vcpu in - let bit_isset bitmap n = - (Int64.logand bitmap (Int64.shift_left 1L n)) > 0L in - let cpumap = Array.of_list (List.map (bit_isset bitmap) (List.range 0 pcpus)) in - cpumap - *) - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; vcpu_affinity_get %d" (Uuid.to_string uuid) domid vcpu; - Xenctrl.vcpu_affinity_get xc domid vcpu - -let set_memory_dynamic_range ~xc ~xs ~min ~max domid = - let kvs = [ - "dynamic-min", string_of_int min; - "dynamic-max", string_of_int max; - ] in - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; set_memory_dynamic_range min = %d; max = %d" (Uuid.to_string uuid) domid min max; - xs.Xs.writev (Printf.sprintf "%s/memory" (xs.Xs.getdomainpath domid)) kvs - -let add_ioport ~xc domid start_port end_port = - let uuid = get_uuid ~xc domid in - let nr_ports = end_port - start_port in - debug "VM = %s; domid = %d; ioport add %#x-%#x" (Uuid.to_string uuid) domid start_port (start_port + nr_ports); - Xenctrl.domain_ioport_permission xc domid start_port nr_ports true - -let del_ioport ~xc domid start_port end_port = - let uuid = get_uuid ~xc domid in - let nr_ports = end_port - start_port in - debug "VM = %s; domid = %d; ioport del %#x-%#x" (Uuid.to_string uuid) domid start_port (start_port + nr_ports); - Xenctrl.domain_ioport_permission xc domid start_port nr_ports false - -(* start_address and end_address are potentially 64 bit? *) -let add_iomem ~xc domid start_address end_address = - let uuid = get_uuid ~xc domid in - let mem_to_pfn m = Int64.to_nativeint (Int64.div m 4096L) in - let start_pfn = mem_to_pfn start_address and end_pfn = mem_to_pfn end_address in - let nr_pfns = Nativeint.sub end_pfn start_pfn in - debug "VM = %s; domid = %d; iomem add %#nx-%#nx" (Uuid.to_string uuid) domid start_pfn end_pfn; - Xenctrl.domain_iomem_permission xc domid start_pfn nr_pfns true - -let del_iomem ~xc domid start_address end_address = - let uuid = get_uuid ~xc domid in - let mem_to_pfn m = Int64.to_nativeint (Int64.div m 4096L) in - let start_pfn = mem_to_pfn start_address and end_pfn = mem_to_pfn end_address in - let nr_pfns = Nativeint.sub end_pfn start_pfn in - debug "VM = %s; domid = %d; iomem del %#nx-%#nx" (Uuid.to_string uuid) domid start_pfn end_pfn; - Xenctrl.domain_iomem_permission xc domid start_pfn nr_pfns false - -let add_irq ~xc domid irq = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; irq add %#x" (Uuid.to_string uuid) domid irq; - Xenctrl.domain_irq_permission xc domid irq true - -let del_irq ~xc domid irq = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; irq del %#x" (Uuid.to_string uuid) domid irq; - Xenctrl.domain_irq_permission xc domid irq false - -let set_machine_address_size ~xc domid width = - match width with - | Some width -> begin - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; domain_set_machine_address_size %d bits" (Uuid.to_string uuid) domid width; - Xenctrl.domain_set_machine_address_size xc domid width - end - | None -> () - -let suppress_spurious_page_faults ~xc domid = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; domain_suppress_spurious_page_faults" (Uuid.to_string uuid) domid; - Xenctrlext.domain_suppress_spurious_page_faults xc domid - -type cpuid_reg = Eax | Ebx | Ecx | Edx -type cpuid_rtype = Clear | Set | Default | Same | Keep - -type cpuid_config = ((int64 * int64 option) * ((cpuid_reg * (cpuid_rtype array)) list)) list - -exception Cpuid_unknown_type of char -exception Cpuid_unknown_reg of string -exception Cpuid_misconfiguration - -let cpuid_reg_of_string = function - | "eax" -> Eax | "ebx" -> Ebx | "ecx" -> Ecx | "edx" -> Edx - | s -> raise (Cpuid_unknown_reg s) - -let cpuid_rtype_of_char = function - | '0' -> Clear | '1' -> Set | 'x' -> Default | 's' -> Same | 'k' -> Keep - | c -> raise (Cpuid_unknown_type c) - -let char_of_cpuid_rtype = function - | Clear -> '0' | Set -> '1' | Default -> 'x' | Same -> 's' | Keep -> 'k' - -let cpuid_cfg_to_xc_cpuid_cfg a constr = - let get_config_for reg lconstr = - if List.mem_assoc reg lconstr then ( - let rtype = List.assoc reg lconstr in - if Array.length rtype <> 32 then - raise Cpuid_misconfiguration; - let s = String.create 32 in - Array.iteri (fun i x -> s.[i] <- char_of_cpuid_rtype x) rtype; - Some s - ) else - None - in - a.(0) <- get_config_for Eax constr; - a.(1) <- get_config_for Ebx constr; - a.(2) <- get_config_for Ecx constr; - a.(3) <- get_config_for Edx constr; - () - -let cpuid_cfg_of_xc_cpuid_cfg cfg = - let back_to reg arr = - match arr with - | None -> None - | Some s -> - let a = Array.create 32 Default in - for i = 0 to String.length s - do - a.(i) <- cpuid_rtype_of_char s.[i] - done; - Some (reg, a) - in - List.fold_left (fun acc x -> match x with None -> acc | Some x -> x :: acc) - [] [ back_to Eax cfg.(0); back_to Ebx cfg.(1); - back_to Ecx cfg.(2); back_to Edx cfg.(3) ] - -let cpuid_set ~xc ~hvm domid cfg = - let uuid = get_uuid ~xc domid in - let tmp = Array.create 4 None in - let cfgout = List.map (fun (node, constr) -> - cpuid_cfg_to_xc_cpuid_cfg tmp constr; - debug "VM = %s; domid = %d; cpuid_set" (Uuid.to_string uuid) domid; - let ret = Xenctrl.domain_cpuid_set xc domid (*hvm*) node tmp in - let ret = cpuid_cfg_of_xc_cpuid_cfg ret in - (node, ret) - ) cfg in - cfgout - -let cpuid_apply ~xc ~hvm domid = - let uuid = get_uuid ~xc domid in - debug "VM = %s; domid = %d; cpuid_apply" (Uuid.to_string uuid) domid; - Xenctrl.domain_cpuid_apply_policy xc domid - -let cpuid_check ~xc cfg = - let tmp = Array.create 4 None in - List.map (fun (node, constr) -> - cpuid_cfg_to_xc_cpuid_cfg tmp constr; - let (success, cfgout) = Xenctrl.cpuid_check xc node tmp in - (success, (node, (cpuid_cfg_of_xc_cpuid_cfg cfgout))) - ) cfg - -(** Sets the current memory target for a running VM, to the given value (in KiB), *) -(** by writing the target to XenStore. The value is automatically rounded down to *) -(** the nearest page boundary. *) -let set_memory_target ~xs domid mem_kib = - let mem_kib = Memory.round_kib_down_to_nearest_page_boundary mem_kib in - let dompath = xs.Xs.getdomainpath domid in - xs.Xs.write (dompath ^ "/memory/target") (Int64.to_string mem_kib); - (* Debugging information: *) - let mem_mib = Memory.mib_of_kib_used mem_kib in - debug "domain %d set memory target to %Ld MiB" domid mem_mib - - -let set_xsdata ~xs domid xsdata = - let dom_path = Printf.sprintf "/local/domain/%d" domid in - Xs.transaction xs (fun t -> - List.iter (fun x -> t.Xst.rm (dom_path ^ "/" ^ x)) allowed_xsdata_prefixes; - t.Xst.writev dom_path (filtered_xsdata xsdata); - ) diff --git a/xl/domain.mli b/xl/domain.mli deleted file mode 100644 index 60413ac71..000000000 --- a/xl/domain.mli +++ /dev/null @@ -1,227 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * 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. - *) -(** High-level domain management functions *) - -open Device_common - -type domid = Xenctrl.domid - -exception Restore_signature_mismatch -exception Domain_build_failed -exception Domain_restore_failed -exception Xenguest_protocol_failure of string (* internal protocol failure *) -exception Xenguest_failure of string (* an actual error is reported to us *) -exception Timeout_backend -exception Could_not_read_file of string (* eg linux kernel/ initrd *) - -type create_info = { - ssidref: int32; - hvm: bool; - hap: bool; - name: string; - xsdata: (string * string) list; - platformdata: (string * string) list; - bios_strings: (string * string) list; -} -val create_info_of_rpc: Rpc.t -> create_info -val rpc_of_create_info: create_info -> Rpc.t - -type build_hvm_info = { - shadow_multiplier: float; - video_mib: int; -} -val build_hvm_info_of_rpc: Rpc.t -> build_hvm_info -val rpc_of_build_hvm_info: build_hvm_info -> Rpc.t - -type build_pv_info = { - cmdline: string; - ramdisk: string option; -} -val build_pv_info_of_rpc: Rpc.t -> build_pv_info -val rpc_of_build_pv_info: build_pv_info -> Rpc.t - -type builder_spec_info = BuildHVM of build_hvm_info | BuildPV of build_pv_info -val builder_spec_info_of_rpc: Rpc.t -> builder_spec_info -val rpc_of_builder_spec_info: builder_spec_info -> Rpc.t - -type build_info = { - memory_max: int64; (* memory max in kilobytes *) - memory_target: int64; (* memory target in kilobytes *) - kernel: string; (* in hvm case, point to hvmloader *) - vcpus: int; (* vcpus max *) - priv: builder_spec_info; -} -val build_info_of_rpc: Rpc.t -> build_info -val rpc_of_build_info: build_info -> Rpc.t - -type domarch = Arch_HVM | Arch_native | Arch_X64 | Arch_X32 - -val string_of_domarch : domarch -> string -val domarch_of_string : string -> domarch - -(** Create a fresh (empty) domain with a specific UUID, returning the domain ID *) -val make: xc:Xenctrl.handle -> xs:Xenstore.Xs.xsh -> create_info -> Uuidm.t -> domid - -(** 'types' of shutdown request *) -type shutdown_reason = PowerOff | Reboot | Suspend | Crash | Halt | S3Suspend | Unknown of int - -(** string versions of the shutdown_reasons, suitable for writing into control/shutdown *) -val string_of_shutdown_reason : shutdown_reason -> string - -(** decodes the shutdown_reason contained within the xc dominfo struct *) -val shutdown_reason_of_int : int -> shutdown_reason - -(** Immediately force shutdown the domain with reason 'shutdown_reason' *) -val hard_shutdown: xc:Xenctrl.handle -> domid -> shutdown_reason -> unit - -(** Thrown if the domain has disappeared *) -exception Domain_does_not_exist - -(** Tell the domain to shutdown with reason 'shutdown_reason'. Don't wait for an ack *) -val shutdown: xc:Xenctrl.handle -> xs:Xenstore.Xs.xsh -> domid -> shutdown_reason -> unit - -(** Tell the domain to shutdown with reason ''shutdown_reason', waiting for an ack *) -val shutdown_wait_for_ack: Xenops_task.Xenops_task.t -> ?timeout:float -> xc:Xenctrl.handle -> xs:Xenstore.Xs.xsh -> domid -> shutdown_reason -> unit - -(** send a domain a sysrq *) -val sysrq: xs:Xenstore.Xs.xsh -> domid -> char -> unit - -(** destroy a domain *) -val destroy: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs:Xenstore.Xs.xsh -> qemu_domid:int -> domid -> unit - -(** Pause a domain *) -val pause: xc: Xenctrl.handle -> domid -> unit - -(** Unpause a domain *) -val unpause: xc: Xenctrl.handle -> domid -> unit - -(** [set_action_request xs domid None] declares this domain is fully intact. - Any other string is a hint to the toolstack that the domain is still broken. *) -val set_action_request: xs:Xenstore.Xs.xsh -> domid -> string option -> unit - -val get_action_request: xs:Xenstore.Xs.xsh -> domid -> string option - -(* val create_channels : xc:Xenctrl.handle -> domid -> int * int *) - -(** Builds a linux guest in a fresh domain created with 'make' *) -val build_linux: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs: Xenstore.Xs.xsh -> store_domid:int -> console_domid:int -> static_max_kib:Int64.t - -> target_kib:Int64.t -> kernel:string -> cmdline:string - -> ramdisk:string option -> vcpus:int -> domid - -> domarch - -(** build an hvm domain in a fresh domain created with 'make' *) -val build_hvm: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs: Xenstore.Xs.xsh -> store_domid:int -> console_domid:int -> static_max_kib:Int64.t - -> target_kib:Int64.t -> shadow_multiplier:float - -> vcpus:int -> kernel:string - -> timeoffset:string -> video_mib:int -> domid - -> domarch - -(** Restore a domain using the info provided *) -val build: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs: Xenstore.Xs.xsh -> store_domid:int -> console_domid:int -> build_info -> string -> domid -> domarch - -(** resume a domain either cooperative or not *) -val resume: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs: Xenstore.Xs.xsh -> hvm: bool -> cooperative: bool -> qemu_domid:int -> domid -> unit - -(** restore a PV domain into a fresh domain created with 'make' *) -val pv_restore: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs: Xenstore.Xs.xsh -> store_domid:int -> console_domid:int -> static_max_kib:Int64.t - -> target_kib:Int64.t -> vcpus:int -> domid -> Unix.file_descr - -> unit - -(** restore an HVM domain from the file descriptor into a fresh domain created - * with 'make' *) -val hvm_restore: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs: Xenstore.Xs.xsh -> store_domid:int -> console_domid:int -> static_max_kib:Int64.t - -> target_kib:Int64.t -> shadow_multiplier:float - -> vcpus:int -> timeoffset:string - -> domid -> Unix.file_descr - -> unit - -(** Restore a domain using the info provided *) -val restore: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs: Xenstore.Xs.xsh -> store_domid:int -> console_domid:int -> build_info -> string -> domid -> Unix.file_descr -> unit - -type suspend_flag = Live | Debug - -(** suspend a domain into the file descriptor *) -val suspend: Xenops_task.Xenops_task.t -> xc: Xenctrl.handle -> xs: Xenstore.Xs.xsh -> hvm: bool -> domid - -> Unix.file_descr -> suspend_flag list - -> ?progress_callback: (float -> unit) - -> qemu_domid: int - -> (unit -> unit) -> unit - -(** send a s3resume event to a domain *) -val send_s3resume: xc: Xenctrl.handle -> domid -> unit - -(** send a power button push to a domain *) -val trigger_power: xc: Xenctrl.handle -> domid -> unit - -(** send a sleep button push to a domain *) -val trigger_sleep: xc: Xenctrl.handle -> domid -> unit - -(** Set cpu affinity of some vcpus of a domain using an boolean array *) -val vcpu_affinity_set: xc: Xenctrl.handle -> domid -> int -> bool array -> unit - -(** Get Cpu affinity of some vcpus of a domain *) -val vcpu_affinity_get: xc: Xenctrl.handle -> domid -> int -> bool array - -(** Get the uuid from a specific domain *) -val get_uuid: xc: Xenctrl.handle -> Xenctrl.domid -> Uuidm.t - -(** Write the min,max values of memory/target to xenstore for use by a memory policy agent *) -val set_memory_dynamic_range: xc:Xenctrl.handle -> xs: Xenstore.Xs.xsh -> min:int -> max:int -> domid -> unit - -(** Grant a domain access to a range of IO ports *) -val add_ioport: xc: Xenctrl.handle -> domid -> int -> int -> unit - -(** Revoke a domain's access to a range of IO ports *) -val del_ioport: xc: Xenctrl.handle -> domid -> int -> int -> unit - -(** Grant a domain access to a range of IO memory *) -val add_iomem: xc: Xenctrl.handle -> domid -> int64 -> int64 -> unit - -(** Revoke a domain's access to a range of IO memory *) -val del_iomem: xc: Xenctrl.handle -> domid -> int64 -> int64 -> unit - -(** Grant a domain access to a physical IRQ *) -val add_irq: xc: Xenctrl.handle -> domid -> int -> unit - -(** Revoke a domain's access to a physical IRQ *) -val del_irq: xc: Xenctrl.handle -> domid -> int -> unit - -(** Restrict a domain to a maximum machine address width *) -val set_machine_address_size: xc: Xenctrl.handle -> domid -> int option -> unit - -(** Suppress spurious page faults for this domain *) -val suppress_spurious_page_faults: xc: Xenctrl.handle -> domid -> unit - -(** CPUID related functions *) -type cpuid_reg = Eax | Ebx | Ecx | Edx -type cpuid_rtype = Clear | Set | Default | Same | Keep - -type cpuid_config = ((int64 * int64 option) * ((cpuid_reg * (cpuid_rtype array)) list)) list - -exception Cpuid_unknown_type of char - -val cpuid_reg_of_string : string -> cpuid_reg -val cpuid_rtype_of_char : char -> cpuid_rtype - -val cpuid_set : xc: Xenctrl.handle -> hvm: bool -> domid -> cpuid_config -> cpuid_config -val cpuid_apply : xc: Xenctrl.handle -> hvm: bool -> domid -> unit -val cpuid_check : xc: Xenctrl.handle -> cpuid_config -> (bool * ((int64 * int64 option) * (cpuid_reg * cpuid_rtype array) list)) list - -val set_memory_target : xs:Xenstore.Xs.xsh -> Xenstore.Xs.domid -> int64 -> unit - -val wait_xen_free_mem : xc:Xenctrl.handle -> ?maximum_wait_time_seconds:int -> int64 -> bool - -val allowed_xsdata_prefixes: string list - -val set_xsdata : xs:Xenstore.Xs.xsh -> domid -> (string * string) list -> unit diff --git a/xl/xenlight_events.ml b/xl/xenlight_events.ml index fb91efd98..44c93bbe3 100644 --- a/xl/xenlight_events.ml +++ b/xl/xenlight_events.ml @@ -17,6 +17,8 @@ let xl_m = Mutex.create () (* event callbacks *) +let (fire_event_on_vm : (int -> unit) option ref) = ref None + let event_occurs_callback user event = let open Event in let ty = match event.ty with @@ -26,7 +28,15 @@ let event_occurs_callback user event = | Operation_complete _ -> "operation complete" | Domain_create_console_available -> "domain create console available" in - debug "EVENT occurred: %s, callback user %s, event user %Ld" ty user event.for_user + debug "EVENT occurred: %s, callback user %s, event user %Ld" + ty user event.for_user ; + match event.ty with + | Domain_death -> begin + match !fire_event_on_vm with + | None -> warn "EVENT fire_event_on_vm callback not set, \ + ignoring event for domain %d" event.domid + | Some f -> f event.domid + end let event_disaster_callback user event_type msg errnoval = debug "EVENT disaster: %s, user %s" msg user diff --git a/xl/xenops_server_xenlight.ml b/xl/xenops_server_xenlight.ml index d1cb381a7..de9a37092 100644 --- a/xl/xenops_server_xenlight.ml +++ b/xl/xenops_server_xenlight.ml @@ -92,6 +92,10 @@ let with_ctx f = error "Xenlight error: %s: %s" (Xenlight.string_of_error a) s; raise e +let get_uuid domid = + let open Xenlight.Dominfo in + with_ctx (fun ctx -> (get ctx domid).uuid) + (* *) let run cmd args = @@ -108,12 +112,305 @@ type attached_vdi = { attach_info: Storage_interface.attach_info; } +(* This module is a temporary holdover while we remove the traditional + libxc-based Domain module. *) +module Domain = struct + + type create_info = { + ssidref: int32; + hvm: bool; + hap: bool; + name: string; + xsdata: (string * string) list; + platformdata: (string * string) list; + bios_strings: (string * string) list; + } with rpc + + type build_hvm_info = { + shadow_multiplier: float; + video_mib: int; + } with rpc + + type build_pv_info = { + cmdline: string; + ramdisk: string option; + } with rpc + + type builder_spec_info = BuildHVM of build_hvm_info | BuildPV of build_pv_info + with rpc + + type build_info = { + memory_max: int64; (* memory max in kilobytes *) + memory_target: int64; (* memory target in kilobytes *) + kernel: string; (* in hvm case, point to hvmloader *) + vcpus: int; (* vcpus max *) + priv: builder_spec_info; + } with rpc + + type domid = int + + exception Domain_stuck_in_dying_state of Xenctrl.domid + + let allowed_xsdata_prefixes = [ "vm-data"; "FIST" ] + + let log_exn_continue msg f x = + try f x with e -> + debug "Safely ignoring exception: %s while %s" (Printexc.to_string e) msg + + let log_exn_rm ~xs x = log_exn_continue ("xenstore-rm " ^ x) xs.Xs.rm x + + let destroy (task: Xenops_task.t) ~xc ~xs ~qemu_domid domid = + let dom_path = xs.Xs.getdomainpath domid in + let uuid = get_uuid domid in + (* These are the devices with a frontend in [domid] and a + well-formed backend in some other domain *) + let all_devices = Device_common.list_frontends ~xs domid in + + debug "VM = %s; domid = %d; Domain.destroy: all known devices = [ %a ]" + uuid domid + (fun () -> String.concat "; ") + (List.map Device_common.string_of_device all_devices); + (* Now we should kill the domain itself *) + debug "VM = %s; domid = %d; Domain.destroy calling Xenctrl.domain_destroy" + uuid domid; + log_exn_continue "Xenctrl.domain_destroy" (Xenctrl.domain_destroy xc) domid; + + log_exn_continue "Error stoping device-model, already dead ?" + (fun () -> Device.Dm.stop ~xs ~qemu_domid domid) (); + log_exn_continue "Error stoping vncterm, already dead ?" + (fun () -> Device.PV_Vnc.stop ~xs domid) (); + + (* Forcibly shutdown every backend *) + List.iter + (fun device -> + try + Device.hard_shutdown task ~xs device + with e -> + (* If this fails we may have a resource leak. We should + prevent this from happening! *) + error "VM = %s; domid = %d; Caught exception %s while destroying device %s" + uuid domid + (Printexc.to_string e) (Device_common.string_of_device device); + (* Keep going on a best-effort basis *) + ) all_devices; + + (* For each device which has a hotplug entry, perform the + cleanup. Even if one fails, try to cleanup the rest anyway.*) + let released = ref [] in + List.iter (fun x -> + log_exn_continue ("waiting for hotplug for " ^ (Device_common.string_of_device x)) + (fun () -> + Hotplug.release task ~xs x; released := x :: !released + ) () + ) all_devices; + + (* If we fail to release a device we leak resources. If we are to + tolerate this then we need an async cleanup thread. *) + let failed_devices = List.filter (fun x -> not(List.mem x !released)) all_devices in + List.iter (fun dev -> + error "VM = %s; domid = %d; Domain.destroy failed to release device: %s" + uuid domid + (Device_common.string_of_device dev)) failed_devices; + + (* Remove our reference to the /vm/ directory *) + let vm_path = try Some (xs.Xs.read (dom_path ^ "/vm")) with _ -> None in + Opt.iter (fun vm_path -> + xs.Xs.rm (vm_path ^ "/domains/" ^ (string_of_int domid))) vm_path; + + let vss_path = try Some (xs.Xs.read (dom_path ^ "/vss")) with _ -> None in + (* If there are no more references then remove /vm/ and + /vss/ *) + Opt.iter (fun vm_path -> + let domains = List.filter (fun x -> x <> "") (xs.Xs.directory (vm_path ^ "/domains")) in + if domains = [] then begin + debug "xenstore-rm %s" vm_path; + xs.Xs.rm vm_path; + Opt.iter (fun vss_path -> + debug "xenstore-rm %s" vss_path; + xs.Xs.rm vss_path + ) vss_path + end + ) vm_path; + + (* Delete the /local/domain/ and all the backend device + paths *) + debug "VM = %s; domid = %d; xenstore-rm %s" uuid domid dom_path; + xs.Xs.rm dom_path; + debug "VM = %s; domid = %d; deleting backends" uuid domid; + let backend_path = xs.Xs.getdomainpath 0 ^ "/backend" in + let all_backend_types = try xs.Xs.directory backend_path with _ -> [] in + List.iter (fun ty -> + log_exn_rm ~xs (Printf.sprintf "%s/%s/%d" backend_path ty domid)) all_backend_types; + + (* If all devices were properly un-hotplugged, then zap the tree in + xenstore. If there was some error leave the tree for debugging / + async cleanup. *) + if failed_devices = [] + then log_exn_rm ~xs (Hotplug.get_private_path domid); + + (* Block waiting for the dying domain to disappear: aim is to catch + shutdown errors early*) + let still_exists () = + try + let _ = Xenctrl.domain_getinfo xc domid in + debug "VM = %s; domid = %d; Domain still exist, waiting for it to disappear." + uuid domid; + true + with + | Xenctrl.Error err -> + debug "VM = %s; domid = %d; Domain nolonger exists (%s)" + uuid domid err; + false + | e -> + error "VM = %s; domid = %d; Xenctrl.domain_getinfo threw: %s" + uuid domid (Printexc.to_string e); + raise e in + let start = Unix.gettimeofday () in + let timeout = 60. in + while still_exists () && (Unix.gettimeofday () -. start < timeout) do + Thread.delay 5. + done; + if still_exists () then begin + (* CA-13801: to avoid confusing people, we shall change this + domain's uuid *) + let s = Printf.sprintf "deadbeef-dead-beef-dead-beef0000%04x" domid in + error "VM = %s; domid = %d; Domain stuck in dying state after 30s; resetting \ + UUID to %s. This probably indicates a backend driver bug." + uuid domid s; + Xenctrl.domain_sethandle xc domid s; + raise (Domain_stuck_in_dying_state domid) + end + + let pause ~xc domid = + Xenctrl.domain_pause xc domid + + let unpause ~xc domid = + Xenctrl.domain_unpause xc domid + + let set_xsdata ~xs domid xsdata = + (* disallowed by default; allowed only if it has one of a set of prefixes *) + let filtered_xsdata = + let allowed (x, _) = + List.fold_left (||) false + (List.map + (fun p -> String.startswith (p ^ "/") x) + allowed_xsdata_prefixes) in + List.filter allowed in + + let dom_path = Printf.sprintf "/local/domain/%d" domid in + Xs.transaction xs (fun t -> + List.iter (fun x -> t.Xst.rm (dom_path ^ "/" ^ x)) allowed_xsdata_prefixes; + t.Xst.writev dom_path (filtered_xsdata xsdata)) + + (* TODO: libxl *) + let wait_xen_free_mem ~xc ?(maximum_wait_time_seconds=64) required_memory_kib : bool = + let open Memory in + let rec wait accumulated_wait_time_seconds = + let host_info = Xenctrl.physinfo xc in + let free_memory_kib = + kib_of_pages (Int64.of_nativeint host_info.Xenctrl.free_pages) in + let scrub_memory_kib = + kib_of_pages (Int64.of_nativeint host_info.Xenctrl.scrub_pages) in + (* At exponentially increasing intervals, write *) + (* a debug message saying how long we've waited: *) + if is_power_of_2 accumulated_wait_time_seconds then debug + "Waited %i second(s) for memory to become available: \ + %Ld KiB free, %Ld KiB scrub, %Ld KiB required" + accumulated_wait_time_seconds + free_memory_kib scrub_memory_kib required_memory_kib; + if free_memory_kib >= required_memory_kib + (* We already have enough memory. *) + then true else + if scrub_memory_kib = 0L + (* We'll never have enough memory. *) + then false else + if accumulated_wait_time_seconds >= maximum_wait_time_seconds + (* We've waited long enough. *) + then false else + begin + Thread.delay 1.0; + wait (accumulated_wait_time_seconds + 1) + end in + wait 0 + + let set_memory_dynamic_range ~xc ~xs ~min ~max domid = + let kvs = [ + "dynamic-min", string_of_int min; + "dynamic-max", string_of_int max; + ] in + let uuid = get_uuid domid in + debug "VM = %s; domid = %d; set_memory_dynamic_range min = %d; max = %d" + uuid domid min max; + xs.Xs.writev (Printf.sprintf "%s/memory" (xs.Xs.getdomainpath domid)) kvs + + + (** Raised if a domain has vanished *) + exception Domain_does_not_exist + + type shutdown_reason = + PowerOff | Reboot | Suspend | Crash | Halt | S3Suspend | Unknown of int + + (** Request a shutdown, return without waiting for acknowledgement *) + let shutdown ~xc ~xs domid req = + (** Strings suitable for putting in the control/shutdown xenstore entry *) + let string_of_shutdown_reason = function + | PowerOff -> "poweroff" + | Reboot -> "reboot" + | Suspend -> "suspend" + | Crash -> "crash" (* this one makes no sense to send to a guest *) + | Halt -> "halt" + | S3Suspend -> "s3" + | Unknown x -> Printf.sprintf "(unknown %d)" x (* nor this one *) + in + + (** Return the path in xenstore watched by the PV shutdown driver *) + let control_shutdown ~xs domid = + xs.Xs.getdomainpath domid ^ "/control/shutdown" in + + let uuid = get_uuid domid in + debug "VM = %s; domid = %d; Requesting domain %s" + uuid domid (string_of_shutdown_reason req); + + let reason = string_of_shutdown_reason req in + let path = control_shutdown ~xs domid in + let domainpath = xs.Xs.getdomainpath domid in + Xs.transaction xs + (fun t -> + (* Fail if the directory has been deleted *) + let domain_exists = try ignore (t.Xst.read domainpath); true + with Xs_protocol.Enoent _ -> false in + if not domain_exists then raise Domain_does_not_exist; + (* Delete the node if it already exists. NB: the guest may well + still shutdown for the previous reason... we only want to + give it a kick again just in case. *) + (try t.Xst.rm path with _ -> ()); + t.Xst.write path reason) + + let send_s3resume ~xc domid = + let uuid = get_uuid domid in + debug "VM = %s; domid = %d; send_s3resume" uuid domid; + Xenctrlext.domain_send_s3resume xc domid + + let set_action_request ~xs domid x = + let path = xs.Xs.getdomainpath domid ^ "/action-request" in + match x with + | None -> xs.Xs.rm path + | Some v -> xs.Xs.write path v + + let get_action_request ~xs domid = + let path = xs.Xs.getdomainpath domid ^ "/action-request" in + try + Some (xs.Xs.read path) + with Xs_protocol.Enoent _ -> None + +end + module VmExtra = struct (** Extra data we store per VM. The persistent data is preserved when - the domain is suspended so it can be re-used in the following 'create' - which is part of 'resume'. The non-persistent data will be regenerated. - When a VM is shutdown for other reasons (eg reboot) we throw all this - information away and generate fresh data on the following 'create' *) + the domain is suspended so it can be re-used in the following 'create' + which is part of 'resume'. The non-persistent data will be regenerated. + When a VM is shutdown for other reasons (eg reboot) we throw all this + information away and generate fresh data on the following 'create' *) type persistent_t = { build_info: Domain.build_info option; ty: Vm.builder_info option; @@ -235,13 +532,14 @@ let domid_of_uuid ~xs domain_selection uuid = error "Failed to read %s: has this domain already been cleaned up?" dir; None -let get_uuid ~xc domid = - let di = with_ctx (fun ctx -> Xenlight.Dominfo.get ctx domid) in - uuid_of_string di.Xenlight.Dominfo.uuid +(* TODO: remove *) +(* let get_uuid ~xc domid = *) +(* let di = with_ctx (fun ctx -> Xenlight.Dominfo.get ctx domid) in *) +(* uuid_of_string di.Xenlight.Dominfo.uuid *) let create_vbd_frontend ~xc ~xs task frontend_domid vdi = - let frontend_vm_id = get_uuid ~xc frontend_domid |> Uuidm.to_string in - let backend_vm_id = get_uuid ~xc vdi.domid |> Uuidm.to_string in + let frontend_vm_id = get_uuid frontend_domid in + let backend_vm_id = get_uuid vdi.domid in match domid_of_uuid ~xs Expect_only_one (uuid_of_string backend_vm_id) with | None -> error "VM = %s; domid = %d; Failed to determine domid of backend VM id: %s" frontend_vm_id frontend_domid backend_vm_id; @@ -272,7 +570,7 @@ let block_device_of_vbd_frontend = function let open Device_common in device.frontend.devid |> Device_number.of_xenstore_key |> Device_number.to_linux_device |> (fun x -> "/dev/" ^ x) -let destroy_vbd_frontend ~xc ~xs task disk = +let destroy_vbd_frontend ~xs task disk = match disk with | Name _ -> () | Device device -> @@ -284,7 +582,7 @@ let destroy_vbd_frontend ~xc ~xs task disk = Device.Vbd.clean_shutdown_async ~xs device; Device.Vbd.clean_shutdown_wait task ~xs ~ignore_transients:true device ) - + module Storage = struct open Storage open Storage_interface @@ -295,7 +593,7 @@ module Storage = struct let epoch_end = epoch_end (* We need to deal with driver domains here: *) - let attach_and_activate ~xc ~xs task vm dp sr vdi read_write = + let attach_and_activate ~xs task vm dp sr vdi read_write = let result = attach_and_activate task vm dp sr vdi read_write in let backend = Xenops_task.with_subtask task (Printf.sprintf "Policy.get_backend_vm %s %s %s" vm sr vdi) (transform_exception (fun () -> Client.Policy.get_backend_vm "attach_and_activate" vm sr vdi)) in @@ -310,6 +608,7 @@ module Storage = struct let get_disk_by_name = get_disk_by_name end +(* TODO: libxl *) let with_disk ~xc ~xs task disk write f = match disk with | Local path -> f path | VDI path -> @@ -320,15 +619,15 @@ let with_disk ~xc ~xs task disk write f = match disk with finally (fun () -> let frontend_domid = this_domid ~xs in - let frontend_vm = get_uuid ~xc frontend_domid |> Uuidm.to_string in - let vdi = attach_and_activate ~xc ~xs task frontend_vm dp sr vdi write in + let frontend_vm = get_uuid frontend_domid in + let vdi = attach_and_activate ~xs task frontend_vm dp sr vdi write in let device = create_vbd_frontend ~xc ~xs task frontend_domid vdi in finally (fun () -> device |> block_device_of_vbd_frontend |> f ) (fun () -> - destroy_vbd_frontend ~xc ~xs task device + destroy_vbd_frontend ~xs task device ) ) (fun () -> dp_destroy task dp) @@ -343,11 +642,7 @@ module Mem = struct raise (Cannot_free_this_much_memory(needed, free)) | Memory_interface.Domains_refused_to_cooperate domids -> debug "Got error_domains_refused_to_cooperate_code from ballooning daemon"; - Xenctrl.with_intf - (fun xc -> - let vms = List.map (get_uuid ~xc) domids |> List.map Uuidm.to_string in - raise (Vms_failed_to_cooperate(vms)) - ) + raise (Vms_failed_to_cooperate (List.map get_uuid domids)) | Unix.Unix_error(Unix.ECONNREFUSED, "connect", _) -> info "ECONNREFUSED talking to squeezed: assuming it has been switched off"; None @@ -446,6 +741,7 @@ module Mem = struct (* This happens when someone manually runs 'service squeezed stop' *) Mutex.execute cached_session_id_m (fun () -> cached_session_id := None); error "Ballooning daemon has disappeared. Manually setting domain maxmem for domid = %d to %Ld KiB" domid amount; + (* TODO: replace domain_setmaxmem with libxl_domain_setmaxmem (not yet written!) *) Xenctrl.with_intf (fun xc -> Xenctrl.domain_setmaxmem xc domid amount); end | None -> @@ -467,14 +763,14 @@ end let _device_id kind = Device_common.string_of_kind kind ^ "-id" (* Return the xenstore device with [kind] corresponding to [id] *) -let device_by_id xc xs vm kind domain_selection id = +let device_by_id xs vm kind domain_selection id = match vm |> uuid_of_string |> domid_of_uuid ~xs domain_selection with | None -> debug "VM = %s; does not exist in domain list" vm; raise (Does_not_exist("domain", vm)) | Some frontend_domid -> let open Device_common in - let devices = list_frontends ~xs frontend_domid in + let devices = Device_common.list_frontends ~xs frontend_domid in let key = _device_id kind in let id_of_device device = @@ -532,6 +828,7 @@ module HOST = struct end +(* TODO: libxl *) let on_frontend f domain_selection frontend = with_xc_and_xs (fun xc xs -> @@ -646,7 +943,7 @@ module VBD = struct let id_of vbd = snd vbd.id - let attach_and_activate task xc xs vm vbd = function + let attach_and_activate task xs vm vbd = function | None -> (* XXX: do something better with CDROMs *) { domid = this_domid ~xs; attach_info = { Storage_interface.params=""; xenstore_data=[]; } } @@ -656,7 +953,7 @@ module VBD = struct let sr, vdi = Storage.get_disk_by_name task path in let dp = Storage.id_of vm vbd.id in let vm = fst vbd.id in - Storage.attach_and_activate ~xc ~xs task vm dp sr vdi (vbd.mode = ReadWrite) + Storage.attach_and_activate ~xs task vm dp sr vdi (vbd.mode = ReadWrite) let frontend_domid_of_device device = device.Device_common.frontend.Device_common.domid @@ -686,7 +983,7 @@ module VBD = struct | VDI path -> let sr, vdi = Storage.get_disk_by_name task path in Storage.epoch_end task sr vdi - | _ -> () + | _ -> () let vdi_path_of_device ~xs device = Device_common.backend_path_of_device ~xs device ^ "/vdi" @@ -738,7 +1035,7 @@ module VBD = struct let pre_plug task vm hvm vbd = debug "VBD.pre_plug"; - let vdi = with_xc_and_xs (fun xc xs -> attach_and_activate task xc xs vm vbd vbd.backend) in + let vdi = with_xs (fun xs -> attach_and_activate task xs vm vbd vbd.backend) in let extra_backend_keys = List.fold_left (fun acc (k,v) -> let k = "sm-data/" ^ k in @@ -790,7 +1087,7 @@ module VBD = struct if not(get_active vm vbd) then debug "VBD %s.%s is not active: not plugging into VM" (fst vbd.Vbd.id) (snd vbd.Vbd.id) else on_frontend - (fun xc xs frontend_domid hvm -> + (fun _ xs frontend_domid hvm -> if vbd.backend = None && not hvm then info "VM = %s; an empty CDROM drive on a PV guest is simulated by unplugging the whole drive" vm else begin @@ -826,8 +1123,8 @@ module VBD = struct let unplug task vm vbd force = let vm_t = DB.read vm in - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> try (* On destroying the datapath: 1. if the device has already been shutdown and deactivated (as in suspend) we @@ -842,7 +1139,7 @@ module VBD = struct to free any storage resources. *) let device = try - Some (device_by_id xc xs vm Device_common.Vbd Oldest (id_of vbd)) + Some (device_by_id xs vm Device_common.Vbd Oldest (id_of vbd)) with | (Does_not_exist(_,_)) -> debug "VM = %s; VBD = %s; Ignoring missing domain" vm (id_of vbd); @@ -884,12 +1181,12 @@ module VBD = struct ) device; *) (* If we have a qemu frontend, detach this too. *) - Opt.iter (fun vm_t -> + Opt.iter (fun vm_t -> let non_persistent = vm_t.VmExtra.non_persistent in if List.mem_assoc vbd.Vbd.id non_persistent.VmExtra.qemu_vbds then begin let _, qemu_vbd = List.assoc vbd.Vbd.id non_persistent.VmExtra.qemu_vbds in (* destroy_vbd_frontend ignores 'refusing to close' transients' *) - destroy_vbd_frontend ~xc ~xs task qemu_vbd; + destroy_vbd_frontend ~xs task qemu_vbd; let non_persistent = { non_persistent with VmExtra.qemu_vbds = List.remove_assoc vbd.Vbd.id non_persistent.VmExtra.qemu_vbds } in DB.write vm { vm_t with VmExtra.non_persistent = non_persistent } @@ -900,7 +1197,7 @@ module VBD = struct Storage.dp_destroy task (Storage.id_of vm vbd.Vbd.id) ) domid ) - with + with | Device_common.Device_error(_, s) -> debug "Caught Device_error: %s" s; raise (Device_detach_rejected("VBD", id_of vbd, s)) @@ -908,7 +1205,7 @@ module VBD = struct let insert task vm vbd disk = on_frontend - (fun xc xs frontend_domid hvm -> + (fun _ xs frontend_domid hvm -> if not hvm then plug task vm { vbd with backend = Some disk } else begin @@ -918,14 +1215,14 @@ module VBD = struct match vdev, domid with | Some vdev, Some domid -> let open Xenlight.Device_disk in - let vdi = attach_and_activate task xc xs vm vbd (Some disk) in + let vdi = attach_and_activate task xs vm vbd (Some disk) in let disk' = {of_vdev ctx domid vdev with pdev_path = Some vdi.attach_info.Storage_interface.params; format = Xenlight.DISK_FORMAT_RAW; } in (* We store away the disk so we can implement VBD.stat *) - let (device: Device_common.device) = device_by_id xc xs vm Device_common.Vbd Newest (id_of vbd) in + let (device: Device_common.device) = device_by_id xs vm Device_common.Vbd Newest (id_of vbd) in xs.Xs.write (vdi_path_of_device ~xs device) (disk |> rpc_of_disk |> Jsonrpc.to_string); Xenops_task.with_subtask task (Printf.sprintf "Vbd.insert %s" (id_of vbd)) (fun () -> @@ -946,7 +1243,7 @@ module VBD = struct let eject task vm vbd = on_frontend - (fun xc xs frontend_domid hvm -> + (fun _ xs frontend_domid hvm -> with_ctx (fun ctx -> let vdev = Opt.map Device_number.to_linux_device vbd.position in let domid = domid_of_uuid ~xs Newest (uuid_of_string vm) in @@ -963,7 +1260,7 @@ module VBD = struct insert ctx disk' domid () ); - let (device: Device_common.device) = device_by_id xc xs vm Device_common.Vbd Oldest (id_of vbd) in + let (device: Device_common.device) = device_by_id xs vm Device_common.Vbd Oldest (id_of vbd) in safe_rm xs (vdi_path_of_device ~xs device); Storage.dp_destroy task (Storage.id_of vm vbd.Vbd.id) | _ -> () @@ -982,7 +1279,7 @@ module VBD = struct Opt.iter (function | Ionice qos -> try - let (device: Device_common.device) = device_by_id xc xs vm Device_common.Vbd Newest (id_of vbd) in + let (device: Device_common.device) = device_by_id xs vm Device_common.Vbd Newest (id_of vbd) in let path = Device_common.kthread_pid_path_of_device ~xs device in let kthread_pid = xs.Xs.read path |> int_of_string in ionice qos kthread_pid @@ -1016,7 +1313,7 @@ module VBD = struct with_xc_and_xs (fun xc xs -> try - let (device: Device_common.device) = device_by_id xc xs vm Device_common.Vbd Newest (id_of vbd) in + let (device: Device_common.device) = device_by_id xs vm Device_common.Vbd Newest (id_of vbd) in let qos_target = get_qos xc xs vm vbd device in let device_number = device_number_of_device device in @@ -1043,7 +1340,7 @@ module VBD = struct with_xc_and_xs (fun xc xs -> try - let (device: Device_common.device) = device_by_id xc xs vm Device_common.Vbd Newest (id_of vbd) in + let (device: Device_common.device) = device_by_id xs vm Device_common.Vbd Newest (id_of vbd) in if Hotplug.device_is_online ~xs device then begin let qos_target = get_qos xc xs vm vbd device in @@ -1185,7 +1482,7 @@ module VIF = struct if not(get_active vm vif) then debug "VIF %s.%s is not active: not plugging into VM" (fst vif.Vif.id) (snd vif.Vif.id) else - on_frontend (fun xc xs frontend_domid hvm -> + on_frontend (fun _ xs frontend_domid hvm -> Xenops_task.with_subtask task (Printf.sprintf "Vif.add %s" (id_of vif)) (fun () -> let nic = pre_plug vm hvm vif in @@ -1216,7 +1513,7 @@ module VIF = struct let unplug task vm vif force = with_ctx (fun ctx -> - on_frontend (fun xc xs frontend_domid _ -> + on_frontend (fun _ xs frontend_domid _ -> try let nic = Xenlight.Device_nic.of_devid ctx frontend_domid vif.position in Xenops_task.with_subtask task (Printf.sprintf "Vif.hard_shutdown %s" (id_of vif)) (fun () -> @@ -1228,7 +1525,7 @@ module VIF = struct Xenlight.Device_nic.remove ctx nic frontend_domid () end ); - let device = device_by_id xc xs vm Device_common.Vif Oldest (id_of vif) in + let device = device_by_id xs vm Device_common.Vif Oldest (id_of vif) in Xenops_task.with_subtask task (Printf.sprintf "Vif.release %s" (id_of vif)) (fun () -> Hotplug.release' task ~xs device vm "vif" vif.position) with @@ -1248,11 +1545,11 @@ module VIF = struct let move task vm vif network = let vm_t = DB.read_exn vm in - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> try (* If the device is gone then this is ok *) - let device = device_by_id xc xs vm Device_common.Vif Oldest (id_of vif) in + let device = device_by_id xs vm Device_common.Vif Oldest (id_of vif) in let bridge = match network with | Network.Local x -> x | Network.Remote (_, _) -> raise (Unimplemented("network driver domains")) in @@ -1280,11 +1577,11 @@ module VIF = struct () let set_carrier task vm vif carrier = - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> try (* If the device is gone then this is ok *) - let device = device_by_id xc xs vm Device_common.Vif Newest (id_of vif) in + let device = device_by_id xs vm Device_common.Vif Newest (id_of vif) in Device.Vif.set_carrier ~xs device carrier with | (Does_not_exist(_,_)) -> @@ -1295,10 +1592,10 @@ module VIF = struct let set_locking_mode task vm vif mode = let open Device_common in - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> (* If the device is gone then this is ok *) - let device = device_by_id xc xs vm Vif Newest (id_of vif) in + let device = device_by_id xs vm Vif Newest (id_of vif) in let path = Hotplug.get_private_data_path_of_device device in (* Delete the old keys *) List.iter (fun x -> safe_rm xs (path ^ "/" ^ x)) locking_mode_keys; @@ -1316,10 +1613,10 @@ module VIF = struct ) let get_state vm vif = - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> try - let (d: Device_common.device) = device_by_id xc xs vm Device_common.Vif Newest (id_of vif) in + let (d: Device_common.device) = device_by_id xs vm Device_common.Vif Newest (id_of vif) in let path = Device_common.kthread_pid_path_of_device ~xs d in let kthread_pid = try xs.Xs.read path |> int_of_string with _ -> 0 in (* We say the device is present unless it has been deleted @@ -1341,10 +1638,10 @@ module VIF = struct ) let get_device_action_request vm vif = - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> try - let (device: Device_common.device) = device_by_id xc xs vm Device_common.Vif Newest (id_of vif) in + let (device: Device_common.device) = device_by_id xs vm Device_common.Vif Newest (id_of vif) in if Hotplug.device_is_online ~xs device then None else Some Needs_unplug @@ -1466,11 +1763,12 @@ module VM = struct else helper (i-1) (List.hd list :: acc) (List.tl list) in List.rev $ helper n [] list - let generate_non_persistent_state xc xs vm = + let generate_non_persistent_state xs vm = let hvm = match vm.ty with HVM _ -> true | _ -> false in (* XXX add per-vcpu information to the platform data *) (* VCPU configuration *) - let pcpus = Xenctrlext.get_max_nr_cpus xc in + let pcpus = with_ctx (fun ctx -> + Xenlight.Physinfo.((get ctx).nr_cpus)) |> Int32.to_int in let all_pcpus = pcpus |> Range.make 0 |> Range.to_list in let all_vcpus = vm.vcpu_max |> Range.make 0 |> Range.to_list in let masks = match vm.scheduler_params.affinity with @@ -1482,13 +1780,13 @@ module VM = struct let defaults = List.map (fun _ -> m) all_vcpus in take vm.vcpu_max (m :: ms @ defaults) in (* convert a mask into a binary string, one char per pCPU *) - let bitmap cpus: string = + let bitmap cpus: string = let cpus = List.filter (fun x -> x >= 0 && x < pcpus) cpus in let result = String.make pcpus '0' in List.iter (fun cpu -> result.[cpu] <- '1') cpus; result in - let affinity = - List.mapi (fun idx mask -> + let affinity = + List.mapi (fun idx mask -> Printf.sprintf "vcpu/%d/affinity" idx, bitmap mask ) masks in let weight = Opt.default [] (Opt.map @@ -1525,6 +1823,7 @@ module VM = struct } + (* TODO: libxl *) let on_domain f domain_selection (task: Xenops_task.t) vm = let uuid = uuid_of_vm vm in with_xc_and_xs @@ -1573,21 +1872,25 @@ module VM = struct ) let remove vm = - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> safe_rm xs (Printf.sprintf "/vm/%s" vm.Vm.id); safe_rm xs (Printf.sprintf "/vss/%s" vm.Vm.id); ) let log_exn_continue msg f x = try f x with e -> debug "Safely ignoring exception: %s while %s" (Printexc.to_string e) msg - let destroy = on_domain_if_exists (fun xc xs task vm di -> + let rec destroy = on_domain_if_exists (fun xc xs task vm di -> let open Xenlight.Dominfo in let domid = di.domid in let qemu_domid = Opt.default (this_domid ~xs) (get_stubdom ~xs domid) in (* We need to clean up the stubdom before the primary otherwise we deadlock *) Opt.iter + (* TODO: libxl. We should probably recursively call this destroy + function on the VM's stubdomains, instead of calling the + libxc-based Domain.destroy. Need some refactoring first. *) (fun stubdom_domid -> + (* destroy task vm *) Domain.destroy task ~xc ~xs ~qemu_domid stubdom_domid ) (get_stubdom ~xs domid); @@ -1615,21 +1918,21 @@ module VM = struct log_exn_rm ~xs (Hotplug.get_private_path domid); (* Detach any remaining disks *) - List.iter (fun dp -> - try + List.iter (fun dp -> + try Storage.dp_destroy task dp with e -> warn "Ignoring exception in VM.destroy: %s" (Printexc.to_string e)) dps ) Oldest - let pause = on_domain (fun xc xs _ _ di -> + let pause = on_domain (fun _ xs _ _ di -> let open Xenlight.Dominfo in if di.current_memkb = 0L then raise (Domain_not_built); with_ctx (fun ctx -> Xenlight.Domain.pause ctx di.domid) (* Domain.pause ~xc di.domid *) ) Newest - let unpause = on_domain (fun xc xs _ _ di -> + let unpause = on_domain (fun _ xs _ _ di -> let open Xenlight.Dominfo in if di.current_memkb = 0L then raise (Domain_not_built); with_ctx (fun ctx -> Xenlight.Domain.unpause ctx di.domid) @@ -1640,12 +1943,12 @@ module VM = struct ) (get_stubdom ~xs di.domid)*) ) Newest - let set_xsdata task vm xsdata = on_domain (fun xc xs _ _ di -> + let set_xsdata task vm xsdata = on_domain (fun _ xs _ _ di -> let open Xenlight.Dominfo in Domain.set_xsdata ~xs di.domid xsdata ) Newest task vm - let set_vcpus task vm target = on_domain (fun xc xs _ _ di -> + let set_vcpus task vm target = on_domain (fun _ xs _ _ di -> let open Xenlight.Dominfo in if di.domain_type = Xenlight.DOMAIN_TYPE_HVM then raise (Unimplemented("vcpu hotplug for HVM domains")); @@ -1674,6 +1977,7 @@ module VM = struct ) ) Newest task vm + (* TODO: libxl *) let set_shadow_multiplier task vm target = on_domain (fun xc xs _ _ di -> let open Xenlight.Dominfo in if di.domain_type = Xenlight.DOMAIN_TYPE_PV then @@ -1681,17 +1985,19 @@ module VM = struct let domid = di.domid in let static_max_mib = Memory.mib_of_bytes_used vm.Vm.memory_static_max in let newshadow = Int64.to_int (Memory.HVM.shadow_mib static_max_mib vm.Vm.vcpu_max target) in + (* NB: Xenctrl.shadow_allocation_{get,set} do not yet have a libxl replacement *) let curshadow = Xenctrl.shadow_allocation_get xc domid in let needed_mib = newshadow - curshadow in debug "VM = %s; domid = %d; Domain has %d MiB shadow; an increase of %d MiB requested" vm.Vm.id domid curshadow needed_mib; if not(Domain.wait_xen_free_mem xc (Int64.mul (Int64.of_int needed_mib) 1024L)) then begin - error "VM = %s; domid = %d; Failed waiting for Xen to free %d MiB: some memory is not properly accounted" vm.Vm.id domid needed_mib; + error "VM = %s; domid = %d; Failed waiting for Xen to free %d MiB: some memory is not properly accounted" vm.Vm.id domid needed_mib; raise (Not_enough_memory (Memory.bytes_of_mib (Int64.of_int needed_mib))) end; debug "VM = %s; domid = %d; shadow_allocation_setto %d MiB" vm.Vm.id domid newshadow; Xenctrl.shadow_allocation_set xc domid newshadow; ) Newest task vm + (* TODO: libxl *) let set_memory_dynamic_range task vm min max = on_domain (fun xc xs _ _ di -> let open Xenlight.Dominfo in let domid = di.domid in @@ -1709,8 +2015,7 @@ module VM = struct (* We should prevent leaking files in our filesystem *) let kernel_to_cleanup = ref None in - finally (fun () -> - with_xc_and_xs (fun xc xs -> + finally (fun () -> with_xc_and_xs (fun xc xs -> let persistent, non_persistent = match DB.read k with | Some x -> @@ -1719,7 +2024,7 @@ module VM = struct | None -> begin debug "VM = %s; has no stored domain-level configuration, regenerating" vm.Vm.id; let persistent = { VmExtra.build_info = None; ty = None; last_start_time = Unix.gettimeofday () } in - let non_persistent = generate_non_persistent_state xc xs vm in + let non_persistent = generate_non_persistent_state xs vm in persistent, non_persistent end in let open Memory in @@ -1818,14 +2123,15 @@ module VM = struct in (* We can't use libxl's builtin support for a bootloader because it doesn't understand the convention used by eliloader. *) - with_disk ~xc ~xs task d false - (fun dev -> - let b = Bootloader.extract task - ~bootloader:i.Xenops_interface.Vm.bootloader - ~legacy_args:i.legacy_args ~extra_args:i.extra_args - ~pv_bootloader_args:i.Xenops_interface.Vm.bootloader_args - ~disk:dev ~vm:vm.Vm.id () in - kernel_to_cleanup := Some b; + (* TODO: libxl *) + with_disk ~xc ~xs task d false + (fun dev -> + let b = Bootloader.extract task + ~bootloader:i.Xenops_interface.Vm.bootloader + ~legacy_args:i.legacy_args ~extra_args:i.extra_args + ~pv_bootloader_args:i.Xenops_interface.Vm.bootloader_args + ~disk:dev ~vm:vm.Vm.id () in + kernel_to_cleanup := Some b; { b_info_default with ty = Pv { b_info_pv_default with kernel = Some b.Bootloader.kernel_path; @@ -1912,6 +2218,12 @@ module VM = struct in debug "Xenlight has created domain %d" domid; + let event_user = 0 in + debug "Adding domain_death event watch for domain %d with event \ + user %d" domid event_user; + Mutex.execute Xenlight_events.xl_m (fun () -> with_ctx (fun ctx -> + Xenlight_events.E.evenable_domain_death ctx domid event_user)); + (* Write remaining xenstore keys *) let dom_path = xs.Xs.getdomainpath domid in let vm_path = "/vm/" ^ vm.Vm.id in @@ -1964,7 +2276,7 @@ module VM = struct let request_shutdown task vm reason ack_delay = on_domain - (fun xc xs task vm di -> + (fun _ xs task vm di -> let open Xenlight.Dominfo in let domid = di.domid in try @@ -2073,6 +2385,7 @@ module VM = struct let save task progress_callback vm flags data = let open Xenlight.Dominfo in + (* TODO: libxl *) on_domain (fun xc xs (task:Xenops_task.t) vm di -> let domid = di.domid in @@ -2119,6 +2432,7 @@ module VM = struct ) Oldest task vm let restore task progress_callback vm vbds vifs data = + (* TODO: libxl *) with_xc_and_xs (fun xc xs -> with_data ~xc ~xs task data false (fun fd -> build ~restore_fd:fd task vm vbds vifs @@ -2128,6 +2442,7 @@ module VM = struct let s3suspend = let open Xenlight.Dominfo in (* XXX: TODO: monitor the guest's response; track the s3 state *) + (* TODO: libxl *) on_domain (fun xc xs task vm di -> Domain.shutdown ~xc ~xs di.domid Domain.S3Suspend @@ -2136,6 +2451,7 @@ module VM = struct let s3resume = let open Xenlight.Dominfo in (* XXX: TODO: monitor the guest's response; track the s3 state *) + (* TODO: libxl *) on_domain (fun xc xs task vm di -> Domain.send_s3resume ~xc di.domid @@ -2145,6 +2461,7 @@ module VM = struct let open Xenlight.Dominfo in let uuid = uuid_of_vm vm in let vme = vm.Vm.id |> DB.read in (* may not exist *) + (* TODO: libxl *) with_xc_and_xs (fun xc xs -> match di_of_uuid ~xs Newest uuid with @@ -2278,7 +2595,7 @@ module VM = struct let k = vm.Vm.id in let persistent = state |> Jsonrpc.of_string |> VmExtra.persistent_t_of_rpc in let non_persistent = match DB.read k with - | None -> with_xc_and_xs (fun xc xs -> generate_non_persistent_state xc xs vm) + | None -> with_xs (fun xs -> generate_non_persistent_state xs vm) | Some vmextra -> vmextra.VmExtra.non_persistent in DB.write k { VmExtra.persistent = persistent; VmExtra.non_persistent = non_persistent; } @@ -2499,14 +2816,15 @@ let process_one_watch xc xs (path, token) = List.iter (remove_device_watch xs) old_devices; end in - let fire_event_on_vm domid = - let d = int_of_string domid in - if not(IntMap.mem d !domains) - then debug "Ignoring watch on shutdown domain %d" d - else - let di = IntMap.find d !domains in - let id = di.Xenlight.Dominfo.uuid in - Updates.add (Dynamic.Vm id) updates in + (* XXX: Moved to Xenlight_events section below; remove after review *) + (* let fire_event_on_vm domid = *) + (* let d = int_of_string domid in *) + (* if not(IntMap.mem d !domains) *) + (* then debug "Ignoring watch on shutdown domain %d" d *) + (* else *) + (* let di = IntMap.find d !domains in *) + (* let id = di.Xenlight.Dominfo.uuid in *) + (* Updates.add (Dynamic.Vm id) updates in *) let fire_event_on_device domid kind devid = let d = int_of_string domid in @@ -2533,8 +2851,8 @@ let process_one_watch xc xs (path, token) = fire_event_on_device frontend kind devid | "local" :: "domain" :: frontend :: "device" :: _ -> look_for_different_devices (int_of_string frontend) - | "local" :: "domain" :: domid :: _ -> - fire_event_on_vm domid + (* | "local" :: "domain" :: domid :: _ -> *) + (* fire_event_on_vm domid *) | "vm" :: uuid :: "rtc" :: "timeoffset" :: [] -> let timeoffset = try Some (xs.Xs.read path) with _ -> None in Opt.iter @@ -2623,9 +2941,18 @@ let init () = logger := Some logger'; with_ctx (fun ctx -> - ignore (Xenlight_events.event_loop_init ctx); - (* Xenlight_events.E.evenable_domain_death ctx 47 666 *) - ); + ignore (Xenlight_events.event_loop_init ctx)); + + let fire_event_on_vm domid = + if not(IntMap.mem domid !domains) + then debug "Ignoring watch on shutdown domain %d" domid + else + let di = IntMap.find domid !domains in + let id = di.Xenlight.Dominfo.uuid in + Updates.add (Dynamic.Vm id) updates + in + + Xenlight_events.fire_event_on_vm := Some fire_event_on_vm ; debug "xenstore is responding to requests"; let (_: Thread.t) = Thread.create @@ -2634,6 +2961,7 @@ let init () = finally (fun () -> debug "(re)starting xenstore watch thread"; + (* TODO: libxl *) with_xc register_for_watches) (fun () -> Thread.delay 5.) @@ -2647,24 +2975,25 @@ module DEBUG = struct let trigger cmd args = match cmd, args with | "reboot", [ k ] -> let uuid = uuid_of_string k in - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> match di_of_uuid ~xs Newest uuid with | None -> raise (Does_not_exist("domain", k)) | Some di -> - Xenctrl.domain_shutdown xc di.domid Xenctrl.Reboot + with_ctx (fun ctx -> Xenlight.Domain.reboot ctx di.domid) + (* Xenctrl.domain_shutdown xc di.domid Xenctrl.Reboot *) ) | "halt", [ k ] -> let uuid = uuid_of_string k in - with_xc_and_xs - (fun xc xs -> + with_xs + (fun xs -> match di_of_uuid ~xs Newest uuid with | None -> raise (Does_not_exist("domain", k)) | Some di -> - Xenctrl.domain_shutdown xc di.domid Xenctrl.Halt + with_ctx (fun ctx -> Xenlight.Domain.shutdown ctx di.domid) + (* Xenctrl.domain_shutdown xc di.domid Xenctrl.Halt *) ) | _ -> debug "DEBUG.trigger cmd=%s Unimplemented" cmd; raise (Unimplemented(cmd)) end -