1(*
2 * Copyright (C) 2006-2007 XenSource Ltd.
3 * Copyright (C) 2008      Citrix Ltd.
4 * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU Lesser General Public License as published
8 * by the Free Software Foundation; version 2.1 only. with the special
9 * exception on linking described in file LICENSE.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 * GNU Lesser General Public License for more details.
15 *)
16
17(** *)
18type domid = int
19
20(* ** xenctrl.h ** *)
21
22type vcpuinfo =
23{
24	online: bool;
25	blocked: bool;
26	running: bool;
27	cputime: int64;
28	cpumap: int32;
29}
30
31type xen_arm_arch_domainconfig =
32{
33	gic_version: int;
34	nr_spis: int;
35	clock_frequency: int32;
36}
37
38type x86_arch_emulation_flags =
39	| X86_EMU_LAPIC
40	| X86_EMU_HPET
41	| X86_EMU_PM
42	| X86_EMU_RTC
43	| X86_EMU_IOAPIC
44	| X86_EMU_PIC
45	| X86_EMU_VGA
46	| X86_EMU_IOMMU
47	| X86_EMU_PIT
48	| X86_EMU_USE_PIRQ
49
50type xen_x86_arch_domainconfig =
51{
52	emulation_flags: x86_arch_emulation_flags list;
53}
54
55type arch_domainconfig =
56	| ARM of xen_arm_arch_domainconfig
57	| X86 of xen_x86_arch_domainconfig
58
59type domaininfo =
60{
61	domid             : domid;
62	dying             : bool;
63	shutdown          : bool;
64	paused            : bool;
65	blocked           : bool;
66	running           : bool;
67	hvm_guest         : bool;
68	shutdown_code     : int;
69	total_memory_pages: nativeint;
70	max_memory_pages  : nativeint;
71	shared_info_frame : int64;
72	cpu_time          : int64;
73	nr_online_vcpus   : int;
74	max_vcpu_id       : int;
75	ssidref           : int32;
76	handle            : int array;
77	arch_config       : arch_domainconfig;
78}
79
80type sched_control =
81{
82	weight : int;
83	cap    : int;
84}
85
86type physinfo_cap_flag =
87	| CAP_HVM
88	| CAP_DirectIO
89
90type physinfo =
91{
92	threads_per_core : int;
93	cores_per_socket : int;
94	nr_cpus          : int;
95	max_node_id      : int;
96	cpu_khz          : int;
97	total_pages      : nativeint;
98	free_pages       : nativeint;
99	scrub_pages      : nativeint;
100	(* XXX hw_cap *)
101	capabilities     : physinfo_cap_flag list;
102	max_nr_cpus      : int;
103}
104
105type version =
106{
107	major : int;
108	minor : int;
109	extra : string;
110}
111
112
113type compile_info =
114{
115	compiler : string;
116	compile_by : string;
117	compile_domain : string;
118	compile_date : string;
119}
120
121type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Watchdog | Soft_reset
122
123type domain_create_flag = CDF_HVM | CDF_HAP
124
125exception Error of string
126
127type handle
128
129(* this is only use by coredumping *)
130external sizeof_core_header: unit -> int
131       = "stub_sizeof_core_header"
132external sizeof_vcpu_guest_context: unit -> int
133       = "stub_sizeof_vcpu_guest_context"
134external sizeof_xen_pfn: unit -> int = "stub_sizeof_xen_pfn"
135(* end of use *)
136
137external interface_open: unit -> handle = "stub_xc_interface_open"
138external interface_close: handle -> unit = "stub_xc_interface_close"
139
140let with_intf f =
141	let xc = interface_open () in
142	let r = try f xc with exn -> interface_close xc; raise exn in
143	interface_close xc;
144	r
145
146external _domain_create: handle -> int32 -> domain_create_flag list -> int array -> arch_domainconfig -> domid
147       = "stub_xc_domain_create"
148
149let int_array_of_uuid_string s =
150	try
151		Scanf.sscanf s
152			"%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
153			(fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 ->
154				[| a0; a1; a2; a3; a4; a5; a6; a7;
155				   a8; a9; a10; a11; a12; a13; a14; a15 |])
156	with _ -> invalid_arg ("Xc.int_array_of_uuid_string: " ^ s)
157
158let domain_create handle n flags uuid =
159	_domain_create handle n flags (int_array_of_uuid_string uuid)
160
161external _domain_sethandle: handle -> domid -> int array -> unit
162                          = "stub_xc_domain_sethandle"
163
164let domain_sethandle handle n uuid =
165	_domain_sethandle handle n (int_array_of_uuid_string uuid)
166
167external domain_max_vcpus: handle -> domid -> int -> unit
168       = "stub_xc_domain_max_vcpus"
169
170external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause"
171external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause"
172external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fast"
173external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy"
174
175external domain_shutdown: handle -> domid -> shutdown_reason -> unit
176       = "stub_xc_domain_shutdown"
177
178external _domain_getinfolist: handle -> domid -> int -> domaininfo list
179       = "stub_xc_domain_getinfolist"
180
181let domain_getinfolist handle first_domain =
182	let nb = 2 in
183	let last_domid l = (List.hd l).domid + 1 in
184	let rec __getlist from =
185		let l = _domain_getinfolist handle from nb in
186		(if List.length l = nb then __getlist (last_domid l) else []) @ l
187		in
188	List.rev (__getlist first_domain)
189
190external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo"
191
192external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo
193       = "stub_xc_vcpu_getinfo"
194
195external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit
196       = "stub_xc_domain_ioport_permission"
197external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit
198       = "stub_xc_domain_iomem_permission"
199external domain_irq_permission: handle -> domid -> int -> bool -> unit
200       = "stub_xc_domain_irq_permission"
201
202external vcpu_affinity_set: handle -> domid -> int -> bool array -> unit
203       = "stub_xc_vcpu_setaffinity"
204external vcpu_affinity_get: handle -> domid -> int -> bool array
205       = "stub_xc_vcpu_getaffinity"
206
207external vcpu_context_get: handle -> domid -> int -> string
208       = "stub_xc_vcpu_context_get"
209
210external sched_id: handle -> int = "stub_xc_sched_id"
211
212external sched_credit_domain_set: handle -> domid -> sched_control -> unit
213       = "stub_sched_credit_domain_set"
214external sched_credit_domain_get: handle -> domid -> sched_control
215       = "stub_sched_credit_domain_get"
216
217external shadow_allocation_set: handle -> domid -> int -> unit
218       = "stub_shadow_allocation_set"
219external shadow_allocation_get: handle -> domid -> int
220       = "stub_shadow_allocation_get"
221
222external evtchn_alloc_unbound: handle -> domid -> domid -> int
223       = "stub_xc_evtchn_alloc_unbound"
224external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset"
225
226external readconsolering: handle -> string = "stub_xc_readconsolering"
227
228external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys"
229external physinfo: handle -> physinfo = "stub_xc_physinfo"
230external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info"
231
232external domain_setmaxmem: handle -> domid -> int64 -> unit
233       = "stub_xc_domain_setmaxmem"
234external domain_set_memmap_limit: handle -> domid -> int64 -> unit
235       = "stub_xc_domain_set_memmap_limit"
236external domain_memory_increase_reservation: handle -> domid -> int64 -> unit
237       = "stub_xc_domain_memory_increase_reservation"
238
239external domain_set_machine_address_size: handle -> domid -> int -> unit
240       = "stub_xc_domain_set_machine_address_size"
241external domain_get_machine_address_size: handle -> domid -> int
242       = "stub_xc_domain_get_machine_address_size"
243
244external domain_cpuid_set: handle -> domid -> (int64 * (int64 option))
245                        -> string option array
246                        -> string option array
247       = "stub_xc_domain_cpuid_set"
248external domain_cpuid_apply_policy: handle -> domid -> unit
249       = "stub_xc_domain_cpuid_apply_policy"
250
251external map_foreign_range: handle -> domid -> int
252                         -> nativeint -> Xenmmap.mmap_interface
253       = "stub_map_foreign_range"
254
255external domain_get_pfn_list: handle -> domid -> nativeint -> nativeint array
256       = "stub_xc_domain_get_pfn_list"
257
258external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
259       = "stub_xc_domain_assign_device"
260external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit
261       = "stub_xc_domain_deassign_device"
262external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool
263       = "stub_xc_domain_test_assign_device"
264
265external version: handle -> version = "stub_xc_version_version"
266external version_compile_info: handle -> compile_info
267       = "stub_xc_version_compile_info"
268external version_changeset: handle -> string = "stub_xc_version_changeset"
269external version_capabilities: handle -> string =
270  "stub_xc_version_capabilities"
271
272type featureset_index = Featureset_raw | Featureset_host | Featureset_pv | Featureset_hvm
273external get_cpu_featureset : handle -> featureset_index -> int64 array = "stub_xc_get_cpu_featureset"
274
275external watchdog : handle -> int -> int32 -> int
276  = "stub_xc_watchdog"
277
278(* core dump structure *)
279type core_magic = Magic_hvm | Magic_pv
280
281type core_header = {
282	xch_magic: core_magic;
283	xch_nr_vcpus: int;
284	xch_nr_pages: nativeint;
285	xch_index_offset: int64;
286	xch_ctxt_offset: int64;
287	xch_pages_offset: int64;
288}
289
290external marshall_core_header: core_header -> string = "stub_marshall_core_header"
291
292(* coredump *)
293let coredump xch domid fd =
294	let dump s =
295		let wd = Unix.write fd s 0 (String.length s) in
296		if wd <> String.length s then
297			failwith "error while writing";
298		in
299
300	let info = domain_getinfo xch domid in
301
302	let nrpages = info.total_memory_pages in
303	let ctxt = Array.make info.max_vcpu_id None in
304	let nr_vcpus = ref 0 in
305	for i = 0 to info.max_vcpu_id - 1
306	do
307		ctxt.(i) <- try
308			let v = vcpu_context_get xch domid i in
309			incr nr_vcpus;
310			Some v
311			with _ -> None
312	done;
313
314	(* FIXME page offset if not rounded to sup *)
315	let page_offset =
316		Int64.add
317			(Int64.of_int (sizeof_core_header () +
318			 (sizeof_vcpu_guest_context () * !nr_vcpus)))
319			(Int64.of_nativeint (
320				Nativeint.mul
321					(Nativeint.of_int (sizeof_xen_pfn ()))
322					nrpages)
323				)
324		in
325
326	let header = {
327		xch_magic = if info.hvm_guest then Magic_hvm else Magic_pv;
328		xch_nr_vcpus = !nr_vcpus;
329		xch_nr_pages = nrpages;
330		xch_ctxt_offset = Int64.of_int (sizeof_core_header ());
331		xch_index_offset = Int64.of_int (sizeof_core_header ()
332					+ sizeof_vcpu_guest_context ());
333		xch_pages_offset = page_offset;
334	} in
335
336	dump (marshall_core_header header);
337	for i = 0 to info.max_vcpu_id - 1
338	do
339		match ctxt.(i) with
340		| None -> ()
341		| Some ctxt_i -> dump ctxt_i
342	done;
343	let pfns = domain_get_pfn_list xch domid nrpages in
344	if Array.length pfns <> Nativeint.to_int nrpages then
345		failwith "could not get the page frame list";
346
347	let page_size = Xenmmap.getpagesize () in
348	for i = 0 to Nativeint.to_int nrpages - 1
349	do
350		let page = map_foreign_range xch domid page_size pfns.(i) in
351		let data = Xenmmap.read page 0 page_size in
352		Xenmmap.unmap page;
353		dump data
354	done
355
356(* ** Misc ** *)
357
358(**
359   Convert the given number of pages to an amount in KiB, rounded up.
360 *)
361external pages_to_kib : int64 -> int64 = "stub_pages_to_kib"
362let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L
363
364let _ = Callback.register_exception "xc.error" (Error "register_callback")
365