* [PATCH 02/10] add ocaml XC bindings.
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
2010-03-09 14:41 ` [PATCH 01/10] add ocaml mmap bindings implementation Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 03/10] add XS ocaml bindings Vincent Hanquez
` (7 subsequent siblings)
9 siblings, 0 replies; 12+ messages in thread
From: Vincent Hanquez @ 2010-03-09 14:41 UTC (permalink / raw)
To: xen-devel; +Cc: Vincent Hanquez
[-- Attachment #1: Type: text/plain, Size: 1246 bytes --]
this include a small and simpler reimplementation of libxc.
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/libs/xc/META.in | 4 +
tools/ocaml/libs/xc/Makefile | 28 +
tools/ocaml/libs/xc/xc.h | 191 +++++
tools/ocaml/libs/xc/xc.ml | 340 ++++++++
tools/ocaml/libs/xc/xc.mli | 196 +++++
tools/ocaml/libs/xc/xc_cpufeature.h | 116 +++
tools/ocaml/libs/xc/xc_cpuid.h | 285 +++++++
tools/ocaml/libs/xc/xc_e820.h | 20 +
tools/ocaml/libs/xc/xc_lib.c | 1502 +++++++++++++++++++++++++++++++++++
tools/ocaml/libs/xc/xc_stubs.c | 1170 +++++++++++++++++++++++++++
10 files changed, 3852 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/libs/xc/META.in
create mode 100644 tools/ocaml/libs/xc/Makefile
create mode 100644 tools/ocaml/libs/xc/xc.h
create mode 100644 tools/ocaml/libs/xc/xc.ml
create mode 100644 tools/ocaml/libs/xc/xc.mli
create mode 100644 tools/ocaml/libs/xc/xc_cpufeature.h
create mode 100644 tools/ocaml/libs/xc/xc_cpuid.h
create mode 100644 tools/ocaml/libs/xc/xc_e820.h
create mode 100644 tools/ocaml/libs/xc/xc_lib.c
create mode 100644 tools/ocaml/libs/xc/xc_stubs.c
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0002-add-ocaml-XC-bindings.patch --]
[-- Type: text/x-patch; name="0002-add-ocaml-XC-bindings.patch", Size: 121587 bytes --]
diff --git a/tools/ocaml/libs/xc/META.in b/tools/ocaml/libs/xc/META.in
new file mode 100644
index 0000000..e46d7dd
--- /dev/null
+++ b/tools/ocaml/libs/xc/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Xen Control Interface"
+archive(byte) = "xc.cma"
+archive(native) = "xc.cmxa"
diff --git a/tools/ocaml/libs/xc/Makefile b/tools/ocaml/libs/xc/Makefile
new file mode 100644
index 0000000..9e361b5
--- /dev/null
+++ b/tools/ocaml/libs/xc/Makefile
@@ -0,0 +1,28 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+CFLAGS += -I../mmap -I./
+OCAMLINCLUDE += -I ../mmap -I ../uuid
+
+OBJS = xc
+INTF = xc.cmi
+LIBS = xc.cma xc.cmxa
+
+xc_OBJS = $(OBJS)
+xc_C_OBJS = xc_lib xc_stubs
+
+OCAML_LIBRARY = xc
+
+all: $(INTF) $(LIBS)
+
+libs: $(LIBS)
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xc META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove xc
+
+include $(TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/libs/xc/xc.h b/tools/ocaml/libs/xc/xc.h
new file mode 100644
index 0000000..8ef7009
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc.h
@@ -0,0 +1,191 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ */
+
+#define __XEN_TOOLS__
+
+#include <xen/xen.h>
+#include <xen/memory.h>
+#include <xen/sysctl.h>
+#include <xen/domctl.h>
+#include <xen/sched.h>
+#include <xen/sysctl.h>
+#if XEN_SYSCTL_INTERFACE_VERSION < 4
+#include <xen/linux/privcmd.h>
+#else
+#include <xen/sys/privcmd.h>
+#endif
+#include <xen/version.h>
+#include <xen/foreign/x86_32.h>
+#include <xen/foreign/x86_64.h>
+#include <xen/hvm/params.h>
+#include "xc_e820.h"
+
+typedef xen_domctl_getdomaininfo_t xc_domaininfo_t;
+typedef xen_domctl_getvcpuinfo_t xc_vcpuinfo_t;
+typedef xen_sysctl_physinfo_t xc_physinfo_t;
+
+struct xc_core_header {
+ unsigned int xch_magic;
+ unsigned int xch_nr_vcpus;
+ unsigned int xch_nr_pages;
+ unsigned int xch_ctxt_offset;
+ unsigned int xch_index_offset;
+ unsigned int xch_pages_offset;
+};
+
+typedef union {
+#if defined(__i386__) || defined(__x86_64__)
+ vcpu_guest_context_x86_64_t x64;
+ vcpu_guest_context_x86_32_t x32;
+#endif
+ vcpu_guest_context_t c;
+} vcpu_guest_context_any_t;
+
+char * xc_error_get(void);
+void xc_error_clear(void);
+
+int xc_using_injection(void);
+
+int xc_interface_open(void);
+int xc_interface_close(int handle);
+
+int xc_domain_create(int handle, unsigned int ssidref,
+ xen_domain_handle_t dhandle,
+ unsigned int flags, unsigned int *pdomid);
+int xc_domain_pause(int handle, unsigned int domid);
+int xc_domain_unpause(int handle, unsigned int domid);
+int xc_domain_resume_fast(int handle, unsigned int domid);
+int xc_domain_destroy(int handle, unsigned int domid);
+int xc_domain_shutdown(int handle, int domid, int reason);
+
+int xc_vcpu_setaffinity(int handle, unsigned int domid, int vcpu,
+ uint64_t cpumap);
+int xc_vcpu_getaffinity(int handle, unsigned int domid, int vcpu,
+ uint64_t *cpumap);
+
+int xc_domain_getinfolist(int handle, unsigned int first_domain,
+ unsigned int max_domains, xc_domaininfo_t *info);
+int xc_domain_getinfo(int handle, unsigned int first_domain,
+ xc_domaininfo_t *info);
+
+int xc_domain_setmaxmem(int handle, unsigned int domid, unsigned int max_memkb);
+int xc_domain_set_memmap_limit(int handle, unsigned int domid,
+ unsigned long map_limitkb);
+
+int xc_domain_set_time_offset(int handle, unsigned int domid, int time_offset);
+
+int xc_domain_memory_increase_reservation(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start);
+int xc_domain_memory_decrease_reservation(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start);
+int xc_domain_memory_populate_physmap(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start);
+int xc_domain_setvmxassist(int handle, unsigned int domid, int use_vmxassist);
+int xc_domain_max_vcpus(int handle, unsigned int domid, unsigned int max);
+int xc_domain_sethandle(int handle, unsigned int domid,
+ xen_domain_handle_t dhandle);
+int xc_vcpu_getinfo(int handle, unsigned int domid, unsigned int vcpu,
+ xc_vcpuinfo_t *info);
+int xc_domain_ioport_permission(int handle, unsigned int domid,
+ unsigned int first_port, unsigned int nr_ports,
+ unsigned int allow_access);
+int xc_vcpu_setcontext(int handle, unsigned int domid,
+ unsigned int vcpu, vcpu_guest_context_any_t *ctxt);
+int xc_vcpu_getcontext(int handle, unsigned int domid,
+ unsigned int vcpu, vcpu_guest_context_any_t *ctxt);
+int xc_domain_irq_permission(int handle, unsigned int domid,
+ unsigned char pirq, unsigned char allow_access);
+int xc_domain_iomem_permission(int handle, unsigned int domid,
+ unsigned long first_mfn, unsigned long nr_mfns,
+ unsigned char allow_access);
+long long xc_domain_get_cpu_usage(int handle, unsigned int domid,
+ unsigned int vcpu);
+void *xc_map_foreign_range(int handle, unsigned int domid,
+ int size, int prot, unsigned long mfn);
+int xc_map_foreign_ranges(int handle, unsigned int domid,
+ privcmd_mmap_entry_t *entries, int nr);
+int xc_readconsolering(int handle, char **pbuffer,
+ unsigned int *pnr_chars, int clear);
+int xc_send_debug_keys(int handle, char *keys);
+int xc_physinfo(int handle, xc_physinfo_t *put_info);
+int xc_pcpu_info(int handle, int max_cpus, uint64_t *info, int *nr_cpus);
+int xc_sched_id(int handle, int *sched_id);
+int xc_version(int handle, int cmd, void *arg);
+int xc_evtchn_alloc_unbound(int handle, unsigned int domid,
+ unsigned int remote_domid);
+int xc_evtchn_reset(int handle, unsigned int domid);
+
+int xc_sched_credit_domain_set(int handle, unsigned int domid,
+ struct xen_domctl_sched_credit *sdom);
+int xc_sched_credit_domain_get(int handle, unsigned int domid,
+ struct xen_domctl_sched_credit *sdom);
+int xc_shadow_allocation_get(int handle, unsigned int domid,
+ uint32_t *mb);
+int xc_shadow_allocation_set(int handle, unsigned int domid,
+ uint32_t mb);
+int xc_domain_get_pfn_list(int handle, unsigned int domid,
+ xen_pfn_t *pfn_array, unsigned long max_pfns);
+int xc_hvm_check_pvdriver(int handle, unsigned int domid);
+
+int xc_domain_assign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func);
+int xc_domain_deassign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func);
+int xc_domain_test_assign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func);
+int xc_domain_watchdog(int handle, int id, uint32_t timeout);
+int xc_domain_set_machine_address_size(int xc, uint32_t domid, unsigned int width);
+int xc_domain_get_machine_address_size(int xc, uint32_t domid);
+
+int xc_domain_cpuid_set(int xc, unsigned int domid, int hvm,
+ uint32_t input, uint32_t oinput,
+ char *config[4], char *config_out[4]);
+int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm);
+int xc_cpuid_check(uint32_t input, uint32_t optsubinput,
+ char *config[4], char *config_out[4]);
+
+int xc_domain_send_s3resume(int handle, unsigned int domid);
+int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_align);
+int xc_domain_set_hpet(int handle, unsigned int domid, int hpet);
+int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode);
+int xc_domain_get_acpi_s_state(int handle, unsigned int domid);
+
+#if XEN_SYSCTL_INTERFACE_VERSION >= 6
+#define SAFEDIV(a, b) (((b) > 0) ? (a) / (b) : (a))
+#define COMPAT_FIELD_physinfo_get_nr_cpus(p) (p).nr_cpus
+#define COMPAT_FIELD_physinfo_get_sockets_per_node(p) \
+ SAFEDIV((p).nr_cpus, ((p).threads_per_core * (p).cores_per_socket * (p).nr_nodes))
+#else
+#define COMPAT_FIELD_physinfo_get_nr_cpus(p) \
+ ((p).threads_per_core * (p).sockets_per_node * \
+ (p).cores_per_socket * (p).threads_per_core)
+#define COMPAT_FIELD_physinfo_get_sockets_per_node(p) (p).sockets_per_node
+#endif
+
+#if __XEN_LATEST_INTERFACE_VERSION__ >= 0x00030209
+#define COMPAT_FIELD_ADDRESS_BITS mem_flags
+#else
+#define COMPAT_FIELD_ADDRESS_BITS address_bits
+#endif
diff --git a/tools/ocaml/libs/xc/xc.ml b/tools/ocaml/libs/xc/xc.ml
new file mode 100644
index 0000000..b9dd284
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc.ml
@@ -0,0 +1,340 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** *)
+type domid = int
+
+(* ** xenctrl.h ** *)
+
+type vcpuinfo =
+{
+ online: bool;
+ blocked: bool;
+ running: bool;
+ cputime: int64;
+ cpumap: int32;
+}
+
+type domaininfo =
+{
+ domid : domid;
+ dying : bool;
+ shutdown : bool;
+ paused : bool;
+ blocked : bool;
+ running : bool;
+ hvm_guest : bool;
+ shutdown_code : int;
+ total_memory_pages: nativeint;
+ max_memory_pages : nativeint;
+ shared_info_frame : int64;
+ cpu_time : int64;
+ nr_online_vcpus : int;
+ max_vcpu_id : int;
+ ssidref : int32;
+ handle : int array;
+}
+
+type sched_control =
+{
+ weight : int;
+ cap : int;
+}
+
+type physinfo_cap_flag =
+ | CAP_HVM
+ | CAP_DirectIO
+
+type physinfo =
+{
+ threads_per_core : int;
+ cores_per_socket : int;
+ nr_cpus : int;
+ max_node_id : int;
+ cpu_khz : int;
+ total_pages : nativeint;
+ free_pages : nativeint;
+ scrub_pages : nativeint;
+ (* XXX hw_cap *)
+ capabilities : physinfo_cap_flag list;
+}
+
+type version =
+{
+ major : int;
+ minor : int;
+ extra : string;
+}
+
+
+type compile_info =
+{
+ compiler : string;
+ compile_by : string;
+ compile_domain : string;
+ compile_date : string;
+}
+
+type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt
+
+type domain_create_flag = CDF_HVM | CDF_HAP
+
+exception Error of string
+
+type handle
+
+(* this is only use by coredumping *)
+external sizeof_core_header: unit -> int
+ = "stub_sizeof_core_header"
+external sizeof_vcpu_guest_context: unit -> int
+ = "stub_sizeof_vcpu_guest_context"
+external sizeof_xen_pfn: unit -> int = "stub_sizeof_xen_pfn"
+(* end of use *)
+
+external interface_open: unit -> handle = "stub_xc_interface_open"
+external interface_close: handle -> unit = "stub_xc_interface_close"
+
+external using_injection: unit -> bool = "stub_xc_using_injection"
+
+let with_intf f =
+ let xc = interface_open () in
+ let r = try f xc with exn -> interface_close xc; raise exn in
+ interface_close xc;
+ r
+
+external _domain_create: handle -> int32 -> domain_create_flag list -> int array -> domid
+ = "stub_xc_domain_create"
+
+let domain_create handle n flags uuid =
+ _domain_create handle n flags (Uuid.int_array_of_uuid uuid)
+
+external _domain_sethandle: handle -> domid -> int array -> unit
+ = "stub_xc_domain_sethandle"
+
+let domain_sethandle handle n uuid =
+ _domain_sethandle handle n (Uuid.int_array_of_uuid uuid)
+
+external domain_setvmxassist: handle -> domid -> bool -> unit
+ = "stub_xc_domain_setvmxassist"
+
+external domain_max_vcpus: handle -> domid -> int -> unit
+ = "stub_xc_domain_max_vcpus"
+
+external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause"
+external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause"
+external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fast"
+external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy"
+
+external domain_shutdown: handle -> domid -> shutdown_reason -> unit
+ = "stub_xc_domain_shutdown"
+
+external _domain_getinfolist: handle -> domid -> int -> domaininfo list
+ = "stub_xc_domain_getinfolist"
+
+let domain_getinfolist handle first_domain =
+ let nb = 2 in
+ let last_domid l = (List.hd l).domid + 1 in
+ let rec __getlist from =
+ let l = _domain_getinfolist handle from nb in
+ (if List.length l = nb then __getlist (last_domid l) else []) @ l
+ in
+ List.rev (__getlist first_domain)
+
+external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo"
+
+external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo
+ = "stub_xc_vcpu_getinfo"
+
+external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit
+ = "stub_xc_domain_ioport_permission"
+external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit
+ = "stub_xc_domain_iomem_permission"
+external domain_irq_permission: handle -> domid -> int -> bool -> unit
+ = "stub_xc_domain_irq_permission"
+
+external vcpu_affinity_set: handle -> domid -> int -> int64 -> unit
+ = "stub_xc_vcpu_setaffinity"
+external vcpu_affinity_get: handle -> domid -> int -> int64
+ = "stub_xc_vcpu_getaffinity"
+
+external vcpu_context_get: handle -> domid -> int -> string
+ = "stub_xc_vcpu_context_get"
+
+external sched_id: handle -> int = "stub_xc_sched_id"
+
+external sched_credit_domain_set: handle -> domid -> sched_control -> unit
+ = "stub_sched_credit_domain_set"
+external sched_credit_domain_get: handle -> domid -> sched_control
+ = "stub_sched_credit_domain_get"
+
+external shadow_allocation_set: handle -> domid -> int -> unit
+ = "stub_shadow_allocation_set"
+external shadow_allocation_get: handle -> domid -> int
+ = "stub_shadow_allocation_get"
+
+external evtchn_alloc_unbound: handle -> domid -> domid -> int
+ = "stub_xc_evtchn_alloc_unbound"
+external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset"
+
+external readconsolering: handle -> string = "stub_xc_readconsolering"
+
+external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys"
+external physinfo: handle -> physinfo = "stub_xc_physinfo"
+external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info"
+
+external domain_setmaxmem: handle -> domid -> int64 -> unit
+ = "stub_xc_domain_setmaxmem"
+external domain_set_memmap_limit: handle -> domid -> int64 -> unit
+ = "stub_xc_domain_set_memmap_limit"
+external domain_memory_increase_reservation: handle -> domid -> int64 -> unit
+ = "stub_xc_domain_memory_increase_reservation"
+
+external domain_set_machine_address_size: handle -> domid -> int -> unit
+ = "stub_xc_domain_set_machine_address_size"
+external domain_get_machine_address_size: handle -> domid -> int
+ = "stub_xc_domain_get_machine_address_size"
+
+external domain_cpuid_set: handle -> domid -> bool -> (int64 * (int64 option))
+ -> string option array
+ -> string option array
+ = "stub_xc_domain_cpuid_set"
+external domain_cpuid_apply: handle -> domid -> bool -> unit
+ = "stub_xc_domain_cpuid_apply"
+external cpuid_check: (int64 * (int64 option)) -> string option array -> (bool * string option array)
+ = "stub_xc_cpuid_check"
+
+external map_foreign_range: handle -> domid -> int
+ -> nativeint -> Mmap.mmap_interface
+ = "stub_map_foreign_range"
+
+external domain_get_pfn_list: handle -> domid -> nativeint -> nativeint array
+ = "stub_xc_domain_get_pfn_list"
+
+external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
+ = "stub_xc_domain_assign_device"
+external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit
+ = "stub_xc_domain_deassign_device"
+external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool
+ = "stub_xc_domain_test_assign_device"
+
+external domain_set_timer_mode: handle -> domid -> int -> unit = "stub_xc_domain_set_timer_mode"
+external domain_set_hpet: handle -> domid -> int -> unit = "stub_xc_domain_set_hpet"
+external domain_set_vpt_align: handle -> domid -> int -> unit = "stub_xc_domain_set_vpt_align"
+
+external domain_send_s3resume: handle -> domid -> unit = "stub_xc_domain_send_s3resume"
+external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
+
+(** check if some hvm domain got pv driver or not *)
+external hvm_check_pvdriver: handle -> domid -> bool
+ = "stub_xc_hvm_check_pvdriver"
+
+external version: handle -> version = "stub_xc_version_version"
+external version_compile_info: handle -> compile_info
+ = "stub_xc_version_compile_info"
+external version_changeset: handle -> string = "stub_xc_version_changeset"
+external version_capabilities: handle -> string =
+ "stub_xc_version_capabilities"
+
+external watchdog : handle -> int -> int32 -> int
+ = "stub_xc_watchdog"
+
+(* core dump structure *)
+type core_magic = Magic_hvm | Magic_pv
+
+type core_header = {
+ xch_magic: core_magic;
+ xch_nr_vcpus: int;
+ xch_nr_pages: nativeint;
+ xch_index_offset: int64;
+ xch_ctxt_offset: int64;
+ xch_pages_offset: int64;
+}
+
+external marshall_core_header: core_header -> string = "stub_marshall_core_header"
+
+(* coredump *)
+let coredump xch domid fd =
+ let dump s =
+ let wd = Unix.write fd s 0 (String.length s) in
+ if wd <> String.length s then
+ failwith "error while writing";
+ in
+
+ let info = domain_getinfo xch domid in
+
+ let nrpages = info.total_memory_pages in
+ let ctxt = Array.make info.max_vcpu_id None in
+ let nr_vcpus = ref 0 in
+ for i = 0 to info.max_vcpu_id - 1
+ do
+ ctxt.(i) <- try
+ let v = vcpu_context_get xch domid i in
+ incr nr_vcpus;
+ Some v
+ with _ -> None
+ done;
+
+ (* FIXME page offset if not rounded to sup *)
+ let page_offset =
+ Int64.add
+ (Int64.of_int (sizeof_core_header () +
+ (sizeof_vcpu_guest_context () * !nr_vcpus)))
+ (Int64.of_nativeint (
+ Nativeint.mul
+ (Nativeint.of_int (sizeof_xen_pfn ()))
+ nrpages)
+ )
+ in
+
+ let header = {
+ xch_magic = if info.hvm_guest then Magic_hvm else Magic_pv;
+ xch_nr_vcpus = !nr_vcpus;
+ xch_nr_pages = nrpages;
+ xch_ctxt_offset = Int64.of_int (sizeof_core_header ());
+ xch_index_offset = Int64.of_int (sizeof_core_header ()
+ + sizeof_vcpu_guest_context ());
+ xch_pages_offset = page_offset;
+ } in
+
+ dump (marshall_core_header header);
+ for i = 0 to info.max_vcpu_id - 1
+ do
+ match ctxt.(i) with
+ | None -> ()
+ | Some ctxt_i -> dump ctxt_i
+ done;
+ let pfns = domain_get_pfn_list xch domid nrpages in
+ if Array.length pfns <> Nativeint.to_int nrpages then
+ failwith "could not get the page frame list";
+
+ let page_size = Mmap.getpagesize () in
+ for i = 0 to Nativeint.to_int nrpages - 1
+ do
+ let page = map_foreign_range xch domid page_size pfns.(i) in
+ let data = Mmap.read page 0 page_size in
+ Mmap.unmap page;
+ dump data
+ done
+
+(* ** Misc ** *)
+
+(**
+ Convert the given number of pages to an amount in KiB, rounded up.
+ *)
+external pages_to_kib : int64 -> int64 = "stub_pages_to_kib"
+let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L
+
+let _ = Callback.register_exception "xc.error" (Error "register_callback")
diff --git a/tools/ocaml/libs/xc/xc.mli b/tools/ocaml/libs/xc/xc.mli
new file mode 100644
index 0000000..dc55b67
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc.mli
@@ -0,0 +1,196 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type domid = int
+type vcpuinfo = {
+ online : bool;
+ blocked : bool;
+ running : bool;
+ cputime : int64;
+ cpumap : int32;
+}
+type domaininfo = {
+ domid : domid;
+ dying : bool;
+ shutdown : bool;
+ paused : bool;
+ blocked : bool;
+ running : bool;
+ hvm_guest : bool;
+ shutdown_code : int;
+ total_memory_pages : nativeint;
+ max_memory_pages : nativeint;
+ shared_info_frame : int64;
+ cpu_time : int64;
+ nr_online_vcpus : int;
+ max_vcpu_id : int;
+ ssidref : int32;
+ handle : int array;
+}
+type sched_control = { weight : int; cap : int; }
+type physinfo_cap_flag = CAP_HVM | CAP_DirectIO
+type physinfo = {
+ threads_per_core : int;
+ cores_per_socket : int;
+ nr_cpus : int;
+ max_node_id : int;
+ cpu_khz : int;
+ total_pages : nativeint;
+ free_pages : nativeint;
+ scrub_pages : nativeint;
+ capabilities : physinfo_cap_flag list;
+}
+type version = { major : int; minor : int; extra : string; }
+type compile_info = {
+ compiler : string;
+ compile_by : string;
+ compile_domain : string;
+ compile_date : string;
+}
+type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt
+
+type domain_create_flag = CDF_HVM | CDF_HAP
+
+exception Error of string
+type handle
+external sizeof_core_header : unit -> int = "stub_sizeof_core_header"
+external sizeof_vcpu_guest_context : unit -> int
+ = "stub_sizeof_vcpu_guest_context"
+external sizeof_xen_pfn : unit -> int = "stub_sizeof_xen_pfn"
+external interface_open : unit -> handle = "stub_xc_interface_open"
+external using_injection : unit -> bool = "stub_xc_using_injection"
+external interface_close : handle -> unit = "stub_xc_interface_close"
+val with_intf : (handle -> 'a) -> 'a
+external _domain_create : handle -> int32 -> domain_create_flag list -> int array -> domid
+ = "stub_xc_domain_create"
+val domain_create : handle -> int32 -> domain_create_flag list -> 'a Uuid.t -> domid
+external _domain_sethandle : handle -> domid -> int array -> unit
+ = "stub_xc_domain_sethandle"
+val domain_sethandle : handle -> domid -> 'a Uuid.t -> unit
+external domain_setvmxassist: handle -> domid -> bool -> unit
+ = "stub_xc_domain_setvmxassist"
+external domain_max_vcpus : handle -> domid -> int -> unit
+ = "stub_xc_domain_max_vcpus"
+external domain_pause : handle -> domid -> unit = "stub_xc_domain_pause"
+external domain_unpause : handle -> domid -> unit = "stub_xc_domain_unpause"
+external domain_resume_fast : handle -> domid -> unit
+ = "stub_xc_domain_resume_fast"
+external domain_destroy : handle -> domid -> unit = "stub_xc_domain_destroy"
+external domain_shutdown : handle -> domid -> shutdown_reason -> unit
+ = "stub_xc_domain_shutdown"
+external _domain_getinfolist : handle -> domid -> int -> domaininfo list
+ = "stub_xc_domain_getinfolist"
+val domain_getinfolist : handle -> domid -> domaininfo list
+external domain_getinfo : handle -> domid -> domaininfo
+ = "stub_xc_domain_getinfo"
+external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo
+ = "stub_xc_vcpu_getinfo"
+external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit
+ = "stub_xc_domain_ioport_permission"
+external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit
+ = "stub_xc_domain_iomem_permission"
+external domain_irq_permission: handle -> domid -> int -> bool -> unit
+ = "stub_xc_domain_irq_permission"
+external vcpu_affinity_set : handle -> domid -> int -> int64 -> unit
+ = "stub_xc_vcpu_setaffinity"
+external vcpu_affinity_get : handle -> domid -> int -> int64
+ = "stub_xc_vcpu_getaffinity"
+external vcpu_context_get : handle -> domid -> int -> string
+ = "stub_xc_vcpu_context_get"
+external sched_id : handle -> int = "stub_xc_sched_id"
+external sched_credit_domain_set : handle -> domid -> sched_control -> unit
+ = "stub_sched_credit_domain_set"
+external sched_credit_domain_get : handle -> domid -> sched_control
+ = "stub_sched_credit_domain_get"
+external shadow_allocation_set : handle -> domid -> int -> unit
+ = "stub_shadow_allocation_set"
+external shadow_allocation_get : handle -> domid -> int
+ = "stub_shadow_allocation_get"
+external evtchn_alloc_unbound : handle -> domid -> domid -> int
+ = "stub_xc_evtchn_alloc_unbound"
+external evtchn_reset : handle -> domid -> unit = "stub_xc_evtchn_reset"
+external readconsolering : handle -> string = "stub_xc_readconsolering"
+external send_debug_keys : handle -> string -> unit = "stub_xc_send_debug_keys"
+external physinfo : handle -> physinfo = "stub_xc_physinfo"
+external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info"
+external domain_setmaxmem : handle -> domid -> int64 -> unit
+ = "stub_xc_domain_setmaxmem"
+external domain_set_memmap_limit : handle -> domid -> int64 -> unit
+ = "stub_xc_domain_set_memmap_limit"
+external domain_memory_increase_reservation :
+ handle -> domid -> int64 -> unit
+ = "stub_xc_domain_memory_increase_reservation"
+external map_foreign_range :
+ handle -> domid -> int -> nativeint -> Mmap.mmap_interface
+ = "stub_map_foreign_range"
+external domain_get_pfn_list :
+ handle -> domid -> nativeint -> nativeint array
+ = "stub_xc_domain_get_pfn_list"
+
+external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
+ = "stub_xc_domain_assign_device"
+external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit
+ = "stub_xc_domain_deassign_device"
+external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool
+ = "stub_xc_domain_test_assign_device"
+
+external domain_set_timer_mode: handle -> domid -> int -> unit = "stub_xc_domain_set_timer_mode"
+external domain_set_hpet: handle -> domid -> int -> unit = "stub_xc_domain_set_hpet"
+external domain_set_vpt_align: handle -> domid -> int -> unit = "stub_xc_domain_set_vpt_align"
+
+external domain_send_s3resume: handle -> domid -> unit
+ = "stub_xc_domain_send_s3resume"
+external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
+
+external hvm_check_pvdriver : handle -> domid -> bool
+ = "stub_xc_hvm_check_pvdriver"
+external version : handle -> version = "stub_xc_version_version"
+external version_compile_info : handle -> compile_info
+ = "stub_xc_version_compile_info"
+external version_changeset : handle -> string = "stub_xc_version_changeset"
+external version_capabilities : handle -> string
+ = "stub_xc_version_capabilities"
+type core_magic = Magic_hvm | Magic_pv
+type core_header = {
+ xch_magic : core_magic;
+ xch_nr_vcpus : int;
+ xch_nr_pages : nativeint;
+ xch_index_offset : int64;
+ xch_ctxt_offset : int64;
+ xch_pages_offset : int64;
+}
+external marshall_core_header : core_header -> string
+ = "stub_marshall_core_header"
+val coredump : handle -> domid -> Unix.file_descr -> unit
+external pages_to_kib : int64 -> int64 = "stub_pages_to_kib"
+val pages_to_mib : int64 -> int64
+external watchdog : handle -> int -> int32 -> int
+ = "stub_xc_watchdog"
+
+external domain_set_machine_address_size: handle -> domid -> int -> unit
+ = "stub_xc_domain_set_machine_address_size"
+external domain_get_machine_address_size: handle -> domid -> int
+ = "stub_xc_domain_get_machine_address_size"
+
+external domain_cpuid_set: handle -> domid -> bool -> (int64 * (int64 option))
+ -> string option array
+ -> string option array
+ = "stub_xc_domain_cpuid_set"
+external domain_cpuid_apply: handle -> domid -> bool -> unit
+ = "stub_xc_domain_cpuid_apply"
+external cpuid_check: (int64 * (int64 option)) -> string option array -> (bool * string option array)
+ = "stub_xc_cpuid_check"
+
diff --git a/tools/ocaml/libs/xc/xc_cpufeature.h b/tools/ocaml/libs/xc/xc_cpufeature.h
new file mode 100644
index 0000000..047a6c9
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_cpufeature.h
@@ -0,0 +1,116 @@
+#ifndef __LIBXC_CPUFEATURE_H
+#define __LIBXC_CPUFEATURE_H
+
+/* Intel-defined CPU features, CPUID level 0x00000001 (edx), word 0 */
+#define X86_FEATURE_FPU (0*32+ 0) /* Onboard FPU */
+#define X86_FEATURE_VME (0*32+ 1) /* Virtual Mode Extensions */
+#define X86_FEATURE_DE (0*32+ 2) /* Debugging Extensions */
+#define X86_FEATURE_PSE (0*32+ 3) /* Page Size Extensions */
+#define X86_FEATURE_TSC (0*32+ 4) /* Time Stamp Counter */
+#define X86_FEATURE_MSR (0*32+ 5) /* Model-Specific Registers, RDMSR, WRMSR */
+#define X86_FEATURE_PAE (0*32+ 6) /* Physical Address Extensions */
+#define X86_FEATURE_MCE (0*32+ 7) /* Machine Check Architecture */
+#define X86_FEATURE_CX8 (0*32+ 8) /* CMPXCHG8 instruction */
+#define X86_FEATURE_APIC (0*32+ 9) /* Onboard APIC */
+#define X86_FEATURE_SEP (0*32+11) /* SYSENTER/SYSEXIT */
+#define X86_FEATURE_MTRR (0*32+12) /* Memory Type Range Registers */
+#define X86_FEATURE_PGE (0*32+13) /* Page Global Enable */
+#define X86_FEATURE_MCA (0*32+14) /* Machine Check Architecture */
+#define X86_FEATURE_CMOV (0*32+15) /* CMOV instruction (FCMOVCC and FCOMI too if FPU present) */
+#define X86_FEATURE_PAT (0*32+16) /* Page Attribute Table */
+#define X86_FEATURE_PSE36 (0*32+17) /* 36-bit PSEs */
+#define X86_FEATURE_PN (0*32+18) /* Processor serial number */
+#define X86_FEATURE_CLFLSH (0*32+19) /* Supports the CLFLUSH instruction */
+#define X86_FEATURE_DS (0*32+21) /* Debug Store */
+#define X86_FEATURE_ACPI (0*32+22) /* ACPI via MSR */
+#define X86_FEATURE_MMX (0*32+23) /* Multimedia Extensions */
+#define X86_FEATURE_FXSR (0*32+24) /* FXSAVE and FXRSTOR instructions (fast save and restore */
+ /* of FPU context), and CR4.OSFXSR available */
+#define X86_FEATURE_XMM (0*32+25) /* Streaming SIMD Extensions */
+#define X86_FEATURE_XMM2 (0*32+26) /* Streaming SIMD Extensions-2 */
+#define X86_FEATURE_SELFSNOOP (0*32+27) /* CPU self snoop */
+#define X86_FEATURE_HT (0*32+28) /* Hyper-Threading */
+#define X86_FEATURE_ACC (0*32+29) /* Automatic clock control */
+#define X86_FEATURE_IA64 (0*32+30) /* IA-64 processor */
+#define X86_FEATURE_PBE (0*32+31) /* Pending Break Enable */
+
+/* AMD-defined CPU features, CPUID level 0x80000001, word 1 */
+/* Don't duplicate feature flags which are redundant with Intel! */
+#define X86_FEATURE_SYSCALL (1*32+11) /* SYSCALL/SYSRET */
+#define X86_FEATURE_MP (1*32+19) /* MP Capable. */
+#define X86_FEATURE_NX (1*32+20) /* Execute Disable */
+#define X86_FEATURE_MMXEXT (1*32+22) /* AMD MMX extensions */
+#define X86_FEATURE_FFXSR (1*32+25) /* FFXSR instruction optimizations */
+#define X86_FEATURE_PAGE1GB (1*32+26) /* 1Gb large page support */
+#define X86_FEATURE_RDTSCP (1*32+27) /* RDTSCP */
+#define X86_FEATURE_LM (1*32+29) /* Long Mode (x86-64) */
+#define X86_FEATURE_3DNOWEXT (1*32+30) /* AMD 3DNow! extensions */
+#define X86_FEATURE_3DNOW (1*32+31) /* 3DNow! */
+
+/* Transmeta-defined CPU features, CPUID level 0x80860001, word 2 */
+#define X86_FEATURE_RECOVERY (2*32+ 0) /* CPU in recovery mode */
+#define X86_FEATURE_LONGRUN (2*32+ 1) /* Longrun power control */
+#define X86_FEATURE_LRTI (2*32+ 3) /* LongRun table interface */
+
+/* Other features, Linux-defined mapping, word 3 */
+/* This range is used for feature bits which conflict or are synthesized */
+#define X86_FEATURE_CXMMX (3*32+ 0) /* Cyrix MMX extensions */
+#define X86_FEATURE_K6_MTRR (3*32+ 1) /* AMD K6 nonstandard MTRRs */
+#define X86_FEATURE_CYRIX_ARR (3*32+ 2) /* Cyrix ARRs (= MTRRs) */
+#define X86_FEATURE_CENTAUR_MCR (3*32+ 3) /* Centaur MCRs (= MTRRs) */
+/* cpu types for specific tunings: */
+#define X86_FEATURE_K8 (3*32+ 4) /* Opteron, Athlon64 */
+#define X86_FEATURE_K7 (3*32+ 5) /* Athlon */
+#define X86_FEATURE_P3 (3*32+ 6) /* P3 */
+#define X86_FEATURE_P4 (3*32+ 7) /* P4 */
+#define X86_FEATURE_CONSTANT_TSC (3*32+ 8) /* TSC ticks at a constant rate */
+
+/* Intel-defined CPU features, CPUID level 0x00000001 (ecx), word 4 */
+#define X86_FEATURE_XMM3 (4*32+ 0) /* Streaming SIMD Extensions-3 */
+#define X86_FEATURE_DTES64 (4*32+ 2) /* 64-bit Debug Store */
+#define X86_FEATURE_MWAIT (4*32+ 3) /* Monitor/Mwait support */
+#define X86_FEATURE_DSCPL (4*32+ 4) /* CPL Qualified Debug Store */
+#define X86_FEATURE_VMXE (4*32+ 5) /* Virtual Machine Extensions */
+#define X86_FEATURE_SMXE (4*32+ 6) /* Safer Mode Extensions */
+#define X86_FEATURE_EST (4*32+ 7) /* Enhanced SpeedStep */
+#define X86_FEATURE_TM2 (4*32+ 8) /* Thermal Monitor 2 */
+#define X86_FEATURE_SSSE3 (4*32+ 9) /* Supplemental Streaming SIMD Extensions-3 */
+#define X86_FEATURE_CID (4*32+10) /* Context ID */
+#define X86_FEATURE_CX16 (4*32+13) /* CMPXCHG16B */
+#define X86_FEATURE_XTPR (4*32+14) /* Send Task Priority Messages */
+#define X86_FEATURE_PDCM (4*32+15) /* Perf/Debug Capability MSR */
+#define X86_FEATURE_DCA (4*32+18) /* Direct Cache Access */
+#define X86_FEATURE_SSE4_1 (4*32+19) /* Streaming SIMD Extensions 4.1 */
+#define X86_FEATURE_SSE4_2 (4*32+20) /* Streaming SIMD Extensions 4.2 */
+#define X86_FEATURE_POPCNT (4*32+23) /* POPCNT instruction */
+#define X86_FEATURE_HYPERVISOR (4*32+31) /* Running under some hypervisor */
+
+/* VIA/Cyrix/Centaur-defined CPU features, CPUID level 0xC0000001, word 5 */
+#define X86_FEATURE_XSTORE (5*32+ 2) /* on-CPU RNG present (xstore insn) */
+#define X86_FEATURE_XSTORE_EN (5*32+ 3) /* on-CPU RNG enabled */
+#define X86_FEATURE_XCRYPT (5*32+ 6) /* on-CPU crypto (xcrypt insn) */
+#define X86_FEATURE_XCRYPT_EN (5*32+ 7) /* on-CPU crypto enabled */
+#define X86_FEATURE_ACE2 (5*32+ 8) /* Advanced Cryptography Engine v2 */
+#define X86_FEATURE_ACE2_EN (5*32+ 9) /* ACE v2 enabled */
+#define X86_FEATURE_PHE (5*32+ 10) /* PadLock Hash Engine */
+#define X86_FEATURE_PHE_EN (5*32+ 11) /* PHE enabled */
+#define X86_FEATURE_PMM (5*32+ 12) /* PadLock Montgomery Multiplier */
+#define X86_FEATURE_PMM_EN (5*32+ 13) /* PMM enabled */
+
+/* More extended AMD flags: CPUID level 0x80000001, ecx, word 6 */
+#define X86_FEATURE_LAHF_LM (6*32+ 0) /* LAHF/SAHF in long mode */
+#define X86_FEATURE_CMP_LEGACY (6*32+ 1) /* If yes HyperThreading not valid */
+#define X86_FEATURE_SVME (6*32+ 2) /* Secure Virtual Machine */
+#define X86_FEATURE_EXTAPICSPACE (6*32+ 3) /* Extended APIC space */
+#define X86_FEATURE_ALTMOVCR (6*32+ 4) /* LOCK MOV CR accesses CR+8 */
+#define X86_FEATURE_ABM (6*32+ 5) /* Advanced Bit Manipulation */
+#define X86_FEATURE_SSE4A (6*32+ 6) /* AMD Streaming SIMD Extensions-4a */
+#define X86_FEATURE_MISALIGNSSE (6*32+ 7) /* Misaligned SSE Access */
+#define X86_FEATURE_3DNOWPF (6*32+ 8) /* 3DNow! Prefetch */
+#define X86_FEATURE_OSVW (6*32+ 9) /* OS Visible Workaround */
+#define X86_FEATURE_IBS (6*32+ 10) /* Instruction Based Sampling */
+#define X86_FEATURE_SSE5 (6*32+ 11) /* AMD Streaming SIMD Extensions-5 */
+#define X86_FEATURE_SKINIT (6*32+ 12) /* SKINIT, STGI/CLGI, DEV */
+#define X86_FEATURE_WDT (6*32+ 13) /* Watchdog Timer */
+
+#endif /* __LIBXC_CPUFEATURE_H */
diff --git a/tools/ocaml/libs/xc/xc_cpuid.h b/tools/ocaml/libs/xc/xc_cpuid.h
new file mode 100644
index 0000000..43743ef
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_cpuid.h
@@ -0,0 +1,285 @@
+#ifndef XC_CPUID_H
+#define XC_CPUID_H
+
+#ifdef XEN_DOMCTL_set_cpuid
+
+#include "xc_cpufeature.h"
+
+#define bitmaskof(idx) (1u << ((idx) & 31))
+#define clear_bit(idx, dst) ((dst) &= ~(1u << ((idx) & 31)))
+#define set_bit(idx, dst) ((dst) |= (1u << ((idx) & 31)))
+
+#define DEF_MAX_BASE 0x00000004u
+#define DEF_MAX_EXT 0x80000008u
+
+static void xc_cpuid(uint32_t eax, uint32_t ecx, uint32_t regs[4])
+{
+ unsigned int realecx = (ecx == XEN_CPUID_INPUT_UNUSED) ? 0 : ecx;
+ asm (
+#ifdef __i386__
+ "push %%ebx; cpuid; mov %%ebx,%1; pop %%ebx"
+#else
+ "push %%rbx; cpuid; mov %%ebx,%1; pop %%rbx"
+#endif
+ : "=a" (regs[0]), "=r" (regs[1]), "=c" (regs[2]), "=d" (regs[3])
+ : "0" (eax), "2" (realecx));
+}
+
+enum { CPU_BRAND_INTEL, CPU_BRAND_AMD, CPU_BRAND_UNKNOWN };
+
+static int xc_cpuid_brand_get(void)
+{
+ uint32_t regs[4];
+ char str[13];
+ uint32_t *istr = (uint32_t *) str;
+
+ xc_cpuid(0, 0, regs);
+ istr[0] = regs[1];
+ istr[1] = regs[3];
+ istr[2] = regs[2];
+ str[12] = '\0';
+ if (strcmp(str, "AuthenticAMD") == 0) {
+ return CPU_BRAND_AMD;
+ } else if (strcmp(str, "GenuineIntel") == 0) {
+ return CPU_BRAND_INTEL;
+ } else
+ return CPU_BRAND_UNKNOWN;
+}
+
+static int hypervisor_is_64bit(int xc)
+{
+ xen_capabilities_info_t xen_caps;
+ return ((xc_version(xc, XENVER_capabilities, &xen_caps) == 0) &&
+ (strstr(xen_caps, "x86_64") != NULL));
+}
+
+static void do_hvm_cpuid_policy(int xc, int domid, uint32_t input, uint32_t regs[4])
+{
+ unsigned long is_pae;
+ int brand;
+
+ /* pae ? */
+ xc_get_hvm_param(xc, domid, HVM_PARAM_PAE_ENABLED, &is_pae);
+ is_pae = !!is_pae;
+
+ switch (input) {
+ case 0x00000000:
+ if (regs[0] > DEF_MAX_BASE)
+ regs[0] = DEF_MAX_BASE;
+ break;
+ case 0x00000001:
+ regs[2] &= (bitmaskof(X86_FEATURE_XMM3) |
+ bitmaskof(X86_FEATURE_SSSE3) |
+ bitmaskof(X86_FEATURE_CX16) |
+ bitmaskof(X86_FEATURE_SSE4_1) |
+ bitmaskof(X86_FEATURE_SSE4_2) |
+ bitmaskof(X86_FEATURE_POPCNT));
+
+ regs[2] |= bitmaskof(X86_FEATURE_HYPERVISOR);
+
+ regs[3] &= (bitmaskof(X86_FEATURE_FPU) |
+ bitmaskof(X86_FEATURE_VME) |
+ bitmaskof(X86_FEATURE_DE) |
+ bitmaskof(X86_FEATURE_PSE) |
+ bitmaskof(X86_FEATURE_TSC) |
+ bitmaskof(X86_FEATURE_MSR) |
+ bitmaskof(X86_FEATURE_PAE) |
+ bitmaskof(X86_FEATURE_MCE) |
+ bitmaskof(X86_FEATURE_CX8) |
+ bitmaskof(X86_FEATURE_APIC) |
+ bitmaskof(X86_FEATURE_SEP) |
+ bitmaskof(X86_FEATURE_MTRR) |
+ bitmaskof(X86_FEATURE_PGE) |
+ bitmaskof(X86_FEATURE_MCA) |
+ bitmaskof(X86_FEATURE_CMOV) |
+ bitmaskof(X86_FEATURE_PAT) |
+ bitmaskof(X86_FEATURE_CLFLSH) |
+ bitmaskof(X86_FEATURE_MMX) |
+ bitmaskof(X86_FEATURE_FXSR) |
+ bitmaskof(X86_FEATURE_XMM) |
+ bitmaskof(X86_FEATURE_XMM2));
+ /* We always support MTRR MSRs. */
+ regs[3] |= bitmaskof(X86_FEATURE_MTRR);
+
+ if (!is_pae)
+ clear_bit(X86_FEATURE_PAE, regs[3]);
+ break;
+ case 0x80000000:
+ if (regs[0] > DEF_MAX_EXT)
+ regs[0] = DEF_MAX_EXT;
+ break;
+ case 0x80000001:
+ if (!is_pae)
+ clear_bit(X86_FEATURE_NX, regs[3]);
+ break;
+ case 0x80000008:
+ regs[0] &= 0x0000ffffu;
+ regs[1] = regs[2] = regs[3] = 0;
+ break;
+ case 0x00000002: /* Intel cache info (dumped by AMD policy) */
+ case 0x00000004: /* Intel cache info (dumped by AMD policy) */
+ case 0x80000002: /* Processor name string */
+ case 0x80000003: /* ... continued */
+ case 0x80000004: /* ... continued */
+ case 0x80000005: /* AMD L1 cache/TLB info (dumped by Intel policy) */
+ case 0x80000006: /* AMD L2/3 cache/TLB info ; Intel L2 cache features */
+ break;
+ default:
+ regs[0] = regs[1] = regs[2] = regs[3] = 0;
+ break;
+ }
+
+ brand = xc_cpuid_brand_get();
+ if (brand == CPU_BRAND_AMD) {
+ switch (input) {
+ case 0x00000001:
+ /* Mask Intel-only features. */
+ regs[2] &= ~(bitmaskof(X86_FEATURE_SSSE3) |
+ bitmaskof(X86_FEATURE_SSE4_1) |
+ bitmaskof(X86_FEATURE_SSE4_2));
+ break;
+
+ case 0x00000002:
+ case 0x00000004:
+ regs[0] = regs[1] = regs[2] = 0;
+ break;
+
+ case 0x80000001: {
+ int is_64bit = hypervisor_is_64bit(xc) && is_pae;
+
+ if (!is_pae)
+ clear_bit(X86_FEATURE_PAE, regs[3]);
+ clear_bit(X86_FEATURE_PSE36, regs[3]);
+
+ /* Filter all other features according to a whitelist. */
+ regs[2] &= ((is_64bit ? bitmaskof(X86_FEATURE_LAHF_LM) : 0) |
+ bitmaskof(X86_FEATURE_ALTMOVCR) |
+ bitmaskof(X86_FEATURE_ABM) |
+ bitmaskof(X86_FEATURE_SSE4A) |
+ bitmaskof(X86_FEATURE_MISALIGNSSE) |
+ bitmaskof(X86_FEATURE_3DNOWPF));
+ regs[3] &= (0x0183f3ff | /* features shared with 0x00000001:EDX */
+ (is_pae ? bitmaskof(X86_FEATURE_NX) : 0) |
+ (is_64bit ? bitmaskof(X86_FEATURE_LM) : 0) |
+ bitmaskof(X86_FEATURE_SYSCALL) |
+ bitmaskof(X86_FEATURE_MP) |
+ bitmaskof(X86_FEATURE_MMXEXT) |
+ bitmaskof(X86_FEATURE_FFXSR) |
+ bitmaskof(X86_FEATURE_3DNOW) |
+ bitmaskof(X86_FEATURE_3DNOWEXT));
+ break;
+ }
+ }
+ } else if (brand == CPU_BRAND_INTEL) {
+ switch (input) {
+ case 0x00000001:
+ /* Mask AMD-only features. */
+ regs[2] &= ~(bitmaskof(X86_FEATURE_POPCNT));
+ break;
+
+ case 0x00000004:
+ regs[0] &= 0x3FF;
+ regs[3] &= 0x3FF;
+ break;
+
+ case 0x80000001:
+ {
+ int is_64bit = hypervisor_is_64bit(xc) && is_pae;
+
+ /* Only a few features are advertised in Intel's 0x80000001. */
+ regs[2] &= (is_64bit ? bitmaskof(X86_FEATURE_LAHF_LM) : 0);
+ regs[3] &= ((is_pae ? bitmaskof(X86_FEATURE_NX) : 0) |
+ (is_64bit ? bitmaskof(X86_FEATURE_LM) : 0) |
+ (is_64bit ? bitmaskof(X86_FEATURE_SYSCALL) : 0));
+ break;
+ }
+ case 0x80000005:
+ {
+ regs[0] = regs[1] = regs[2] = 0;
+ break;
+ }
+ }
+ }
+}
+
+static void do_pv_cpuid_policy(int xc, int domid, uint32_t input, uint32_t regs[4])
+{
+ int brand;
+ int guest_64_bits, xen_64_bits;
+ int ret;
+
+ ret = xc_domain_get_machine_address_size(xc, domid);
+ if (ret < 0)
+ return;
+ guest_64_bits = (ret == 64);
+ xen_64_bits = hypervisor_is_64bit(xc);
+ brand = xc_cpuid_brand_get();
+
+ if ((input & 0x7fffffff) == 1) {
+ clear_bit(X86_FEATURE_VME, regs[3]);
+ clear_bit(X86_FEATURE_PSE, regs[3]);
+ clear_bit(X86_FEATURE_PGE, regs[3]);
+ clear_bit(X86_FEATURE_MCE, regs[3]);
+ clear_bit(X86_FEATURE_MCA, regs[3]);
+ clear_bit(X86_FEATURE_MTRR, regs[3]);
+ clear_bit(X86_FEATURE_PSE36, regs[3]);
+ }
+
+ switch (input) {
+ case 1:
+ if (!xen_64_bits || brand == CPU_BRAND_AMD)
+ clear_bit(X86_FEATURE_SEP, regs[3]);
+ clear_bit(X86_FEATURE_DS, regs[3]);
+ clear_bit(X86_FEATURE_ACC, regs[3]);
+ clear_bit(X86_FEATURE_PBE, regs[3]);
+
+ clear_bit(X86_FEATURE_DTES64, regs[2]);
+ clear_bit(X86_FEATURE_MWAIT, regs[2]);
+ clear_bit(X86_FEATURE_DSCPL, regs[2]);
+ clear_bit(X86_FEATURE_VMXE, regs[2]);
+ clear_bit(X86_FEATURE_SMXE, regs[2]);
+ clear_bit(X86_FEATURE_EST, regs[2]);
+ clear_bit(X86_FEATURE_TM2, regs[2]);
+ if (!guest_64_bits)
+ clear_bit(X86_FEATURE_CX16, regs[2]);
+ clear_bit(X86_FEATURE_XTPR, regs[2]);
+ clear_bit(X86_FEATURE_PDCM, regs[2]);
+ clear_bit(X86_FEATURE_DCA, regs[2]);
+ break;
+ case 0x80000001:
+ if (!guest_64_bits) {
+ clear_bit(X86_FEATURE_LM, regs[3]);
+ clear_bit(X86_FEATURE_LAHF_LM, regs[2]);
+ if (brand != CPU_BRAND_AMD)
+ clear_bit(X86_FEATURE_SYSCALL, regs[3]);
+ } else
+ set_bit(X86_FEATURE_SYSCALL, regs[3]);
+ clear_bit(X86_FEATURE_PAGE1GB, regs[3]);
+ clear_bit(X86_FEATURE_RDTSCP, regs[3]);
+
+ clear_bit(X86_FEATURE_SVME, regs[2]);
+ clear_bit(X86_FEATURE_OSVW, regs[2]);
+ clear_bit(X86_FEATURE_IBS, regs[2]);
+ clear_bit(X86_FEATURE_SKINIT, regs[2]);
+ clear_bit(X86_FEATURE_WDT, regs[2]);
+ break;
+ case 5: /* MONITOR/MWAIT */
+ case 0xa: /* Architectural Performance Monitor Features */
+ case 0x8000000a: /* SVM revision and features */
+ case 0x8000001b: /* Instruction Based Sampling */
+ regs[0] = regs[1] = regs[2] = regs[3] = 0;
+ break;
+ }
+}
+
+static void do_cpuid_policy(int xc, int domid, int hvm, uint32_t input, uint32_t regs[4])
+{
+ if (hvm)
+ do_hvm_cpuid_policy(xc, domid, input, regs);
+ else
+ do_pv_cpuid_policy(xc, domid, input, regs);
+}
+
+#endif
+
+#endif
diff --git a/tools/ocaml/libs/xc/xc_e820.h b/tools/ocaml/libs/xc/xc_e820.h
new file mode 100644
index 0000000..52bbb0f
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_e820.h
@@ -0,0 +1,20 @@
+#ifndef __XC_E820_H__
+#define __XC_E820_H__
+
+#include <xen/hvm/e820.h>
+
+/*
+ * PC BIOS standard E820 types and structure.
+ */
+#define E820_RAM 1
+#define E820_RESERVED 2
+#define E820_ACPI 3
+#define E820_NVS 4
+
+struct e820entry {
+ uint64_t addr;
+ uint64_t size;
+ uint32_t type;
+} __attribute__((packed));
+
+#endif /* __XC_E820_H__ */
diff --git a/tools/ocaml/libs/xc/xc_lib.c b/tools/ocaml/libs/xc/xc_lib.c
new file mode 100644
index 0000000..7fffc43
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_lib.c
@@ -0,0 +1,1502 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ */
+
+#include <stdint.h>
+#include <unistd.h>
+#include <string.h>
+#include <fcntl.h>
+#include <stdio.h>
+#include <errno.h>
+#include <sys/ioctl.h>
+#include <sys/mman.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <stdlib.h>
+#include <stdarg.h>
+
+#include "xc.h"
+
+#define PAGE_SHIFT 12
+#define PAGE_SIZE (1UL << PAGE_SHIFT)
+#define PAGE_MASK (~(PAGE_SIZE-1))
+
+#define MIN(a, b) (((a) < (b)) ? (a) : (b))
+
+#define DECLARE_DOMCTL(_cmd, _domain) \
+ struct xen_domctl domctl = { \
+ .cmd = _cmd, \
+ .domain = _domain, \
+ .interface_version = XEN_DOMCTL_INTERFACE_VERSION, \
+ }
+
+#define DECLARE_SYSCTL(_cmd) \
+ struct xen_sysctl sysctl = { \
+ .cmd = _cmd, \
+ .interface_version = XEN_SYSCTL_INTERFACE_VERSION, \
+ }
+
+#define DECLARE_HYPERCALL2(_cmd, _arg0, _arg1) \
+ privcmd_hypercall_t hypercall = { \
+ .op = _cmd, \
+ .arg[0] = (unsigned long) _arg0,\
+ .arg[1] = (unsigned long) _arg1,\
+ }
+#define DECLARE_HYPERCALL0(_cmd) DECLARE_HYPERCALL2(_cmd, 0, 0);
+#define DECLARE_HYPERCALL1(_cmd, _arg0) DECLARE_HYPERCALL2(_cmd, _arg0, 0);
+
+/*---- Errors handlings ----*/
+#ifndef WITHOUT_GOOD_ERROR
+#define ERROR_STRLEN 256
+
+static char __error_str[ERROR_STRLEN];
+
+char * xc_error_get(void)
+{
+ return __error_str;
+}
+
+static void xc_error_set(const char *fmt, ...)
+{
+ va_list ap;
+ char __errordup[ERROR_STRLEN];
+
+ va_start(ap, fmt);
+ vsnprintf(__errordup, ERROR_STRLEN, fmt, ap);
+ va_end(ap);
+ memcpy(__error_str, __errordup, ERROR_STRLEN);
+}
+
+static void xc_error_dom_set(unsigned int domid, const char *fmt, ...)
+{
+ va_list ap;
+ char __errordup[ERROR_STRLEN];
+ int i;
+
+ i = snprintf(__errordup, ERROR_STRLEN, "domain %u - ", domid);
+ va_start(ap, fmt);
+ i += vsnprintf(__errordup + i, ERROR_STRLEN - i, fmt, ap);
+ va_end(ap);
+ snprintf(__errordup + i, ERROR_STRLEN - i,
+ " failed: %s", xc_error_get());
+ memcpy(__error_str, __errordup, ERROR_STRLEN);
+}
+
+void xc_error_clear(void)
+{
+ memset(__error_str, '\0', ERROR_STRLEN);
+}
+#else
+char * xc_error_get(void)
+{
+ return "";
+}
+#define xc_error_set(fmt, ...) do {} while (0)
+#define xc_error_dom_set(id, fmt, ...) do {} while (0)
+#define xc_error_clear() do {} while (0)
+#endif
+
+#define xc_error_hypercall(_h, _r) \
+ xc_error_set("hypercall %lld fail: %d: %s (ret %d)", _h.op, errno, errno ? strerror(errno) : strerror(-_r), _r)
+
+int xc_using_injection(void)
+{
+ return 0;
+}
+
+/*---- Trivia ----*/
+int xc_interface_open(void)
+{
+ int fd, ret;
+
+ fd = open("/proc/xen/privcmd", O_RDWR);
+ if (fd == -1) {
+ xc_error_set("open /proc/xen/privcmd failed: %s",
+ strerror(errno));
+ return -1;
+ }
+
+ ret = fcntl(fd, F_GETFD);
+ if (ret < 0) {
+ xc_error_set("cannot get handle flags: %s",
+ strerror(errno));
+ goto out;
+ }
+
+ ret = fcntl(fd, F_SETFD, ret | FD_CLOEXEC);
+ if (ret < 0) {
+ xc_error_set("cannot set handle flags: %s",
+ strerror(errno));
+ goto out;
+ }
+
+ return fd;
+out:
+ close(fd);
+ return -1;
+}
+
+int xc_interface_close(int handle)
+{
+ int ret;
+
+ ret = close(handle);
+ if (ret != 0)
+ xc_error_set("close xc failed: %s", strerror(errno));
+ return ret;
+}
+
+/*---- Low private operations ----*/
+static int do_xen_hypercall(int handle, privcmd_hypercall_t *hypercall)
+{
+ return ioctl(handle, IOCTL_PRIVCMD_HYPERCALL, (unsigned long) hypercall);
+}
+
+static int do_domctl(int handle, struct xen_domctl *domctl)
+{
+ int ret;
+ DECLARE_HYPERCALL1(__HYPERVISOR_domctl, domctl);
+
+ if (mlock(domctl, sizeof(*domctl)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0)
+ xc_error_hypercall(hypercall, ret);
+
+ munlock(domctl, sizeof(*domctl));
+ return ret;
+}
+
+static int do_sysctl(int handle, struct xen_sysctl *sysctl)
+{
+ int ret;
+ DECLARE_HYPERCALL1(__HYPERVISOR_sysctl, sysctl);
+
+ if (mlock(sysctl, sizeof(*sysctl)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0)
+ xc_error_hypercall(hypercall, ret);
+
+ munlock(sysctl, sizeof(*sysctl));
+ return ret;
+}
+
+static int do_evtchnctl(int handle, int cmd, void *arg, size_t arg_size)
+{
+ DECLARE_HYPERCALL2(__HYPERVISOR_event_channel_op, cmd, arg);
+ int ret;
+
+ if (mlock(arg, arg_size) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0)
+ xc_error_hypercall(hypercall, ret);
+ munlock(arg, arg_size);
+ return ret;
+}
+
+static int do_memctl_reservation(int handle, int cmd,
+ struct xen_memory_reservation *reservation)
+{
+ int ret;
+ DECLARE_HYPERCALL2(__HYPERVISOR_memory_op, cmd, reservation);
+ xen_pfn_t *extent_start;
+
+ if (cmd != XENMEM_increase_reservation &&
+ cmd != XENMEM_decrease_reservation &&
+ cmd != XENMEM_populate_physmap) {
+ xc_error_set("do_memctl_reservation: unknown cmd %d", cmd);
+ return -EINVAL;
+ }
+
+ if (mlock(reservation, sizeof(*reservation)) == -1) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -ENOMEM;
+ }
+ get_xen_guest_handle(extent_start, reservation->extent_start);
+ if (extent_start && mlock(extent_start, reservation->nr_extents
+ * sizeof(xen_pfn_t)) == -1) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ munlock(reservation, sizeof(*reservation));
+ return -3;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+ munlock(extent_start, reservation->nr_extents * sizeof(xen_pfn_t));
+ get_xen_guest_handle(extent_start, reservation->extent_start);
+ munlock(reservation, sizeof(*reservation));
+ return ret;
+}
+
+static int do_ioctl(int handle, int cmd, void *arg)
+{
+ return ioctl(handle, cmd, arg);
+}
+
+static void * do_mmap(void *start, size_t length, int prot, int flags,
+ int fd, off_t offset)
+{
+ return mmap(start, length, prot, flags, fd, offset);
+}
+
+int xc_get_hvm_param(int handle, unsigned int domid,
+ int param, unsigned long *value)
+{
+ struct xen_hvm_param arg = {
+ .domid = domid,
+ .index = param,
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_get_param,
+ (unsigned long) &arg);
+ int ret;
+
+ if (mlock(&arg, sizeof(arg)) == -1) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+ *value = arg.value;
+ munlock(&arg, sizeof(arg));
+ return ret;
+}
+
+static int xc_set_hvm_param(int handle, unsigned int domid,
+ int param, unsigned long value)
+{
+ struct xen_hvm_param arg = {
+ .domid = domid,
+ .index = param,
+ .value = value,
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_set_param, (unsigned long) &arg);
+ int ret;
+
+ if (mlock(&arg, sizeof(arg)) == -1) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+ munlock(&arg, sizeof(arg));
+ return ret;
+}
+
+
+/*---- XC API ----*/
+int xc_domain_create(int handle, unsigned int ssidref,
+ xen_domain_handle_t dhandle,
+ unsigned int flags, unsigned int *pdomid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_createdomain, *pdomid);
+ domctl.u.createdomain.ssidref = ssidref;
+ domctl.u.createdomain.flags = flags;
+ memcpy(domctl.u.createdomain.handle, dhandle, sizeof(xen_domain_handle_t));
+
+ ret = do_domctl(handle, &domctl);
+ if (ret != 0) {
+ xc_error_set("creating domain failed: %s", xc_error_get());
+ return ret;
+ }
+ *pdomid = domctl.domain;
+ return 0;
+}
+
+int xc_domain_pause(int handle, unsigned int domid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_pausedomain, domid);
+
+ ret = do_domctl(handle, &domctl);
+ if (ret != 0)
+ xc_error_dom_set(domid, "pause");
+ return ret;
+}
+
+int xc_domain_unpause(int handle, unsigned int domid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_unpausedomain, domid);
+
+ ret = do_domctl(handle, &domctl);
+ if (ret != 0)
+ xc_error_dom_set(domid, "unpause");
+ return ret;
+}
+
+/* return 1 if hvm domain got pv driver, 0 if not. -1 is error occurs */
+int xc_hvm_check_pvdriver(int handle, unsigned int domid)
+{
+ int ret;
+ unsigned long irq = 0;
+ xc_domaininfo_t info;
+
+ ret = xc_domain_getinfolist(handle, domid, 1, &info);
+ if (ret != 1) {
+ xc_error_set("domain getinfo failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "hvm_check_pvdriver");
+ return -1;
+ }
+
+ if (!(info.flags & XEN_DOMINF_hvm_guest)) {
+ xc_error_set("domain is not hvm");
+ xc_error_dom_set(domid, "hvm_check_pvdriver");
+ return -1;
+ }
+ xc_get_hvm_param(handle, domid, HVM_PARAM_CALLBACK_IRQ, &irq);
+ return irq;
+}
+
+static int modify_returncode_register(int handle, unsigned int domid)
+{
+ int ret;
+ xc_domaininfo_t info;
+ xen_capabilities_info_t caps;
+ vcpu_guest_context_any_t context;
+
+ ret = xc_domain_getinfolist(handle, domid, 1, &info);
+ if (ret != 1) {
+ xc_error_set("domain getinfo failed: %s", strerror(errno));
+ return -1;
+ }
+
+ /* HVM guests without PV drivers do not have a return code to modify */
+ if (info.flags & XEN_DOMINF_hvm_guest) {
+ unsigned long irq = 0;
+ xc_get_hvm_param(handle, domid, HVM_PARAM_CALLBACK_IRQ, &irq);
+ if (!irq)
+ return 0;
+ }
+
+ ret = xc_version(handle, XENVER_capabilities, &caps);
+ if (ret) {
+ xc_error_set("could not get Xen capabilities");
+ return ret;
+ }
+
+ ret = xc_vcpu_getcontext(handle, domid, 0, &context);
+ if (ret) {
+ xc_error_set("could not get vcpu 0 context");
+ return ret;
+ }
+
+ if (!(info.flags & XEN_DOMINF_hvm_guest))
+ context.c.user_regs.eax = 1;
+ else if (strstr(caps, "x86_64"))
+ context.x64.user_regs.eax = 1;
+ else
+ context.x32.user_regs.eax = 1;
+
+ ret = xc_vcpu_setcontext(handle, domid, 0, &context);
+ if (ret) {
+ xc_error_set("could not set vcpu 0 context");
+ return ret;
+ }
+ return 0;
+}
+
+int xc_domain_resume_fast(int handle, unsigned int domid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_resumedomain, domid);
+
+ ret = modify_returncode_register(handle, domid);
+ if (ret != 0) {
+ xc_error_dom_set(domid, "resume_fast");
+ return ret;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret != 0)
+ xc_error_dom_set(domid, "resume_fast");
+ return ret;
+}
+
+int xc_domain_destroy(int handle, unsigned int domid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_destroydomain, domid);
+
+ do {
+ ret = do_domctl(handle, &domctl);
+ } while (ret && (errno == EAGAIN));
+ if (ret != 0)
+ xc_error_dom_set(domid, "destroy");
+ return ret;
+}
+
+int xc_domain_shutdown(int handle, int domid, int reason)
+{
+ sched_remote_shutdown_t arg = {
+ .domain_id = domid,
+ .reason = reason,
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_sched_op, SCHEDOP_remote_shutdown, &arg);
+ int ret;
+
+ if (mlock(&arg, sizeof(arg)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "shutdown %d", reason);
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0) {
+ xc_error_hypercall(hypercall, ret);
+ xc_error_dom_set(domid, "shutdown %d", reason);
+ }
+ munlock(&arg, sizeof(arg));
+ return ret;
+}
+
+int xc_vcpu_setaffinity(int handle, unsigned int domid, int vcpu,
+ uint64_t cpumap)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_setvcpuaffinity, domid);
+ domctl.u.vcpuaffinity.vcpu = vcpu;
+ domctl.u.vcpuaffinity.cpumap.nr_cpus = sizeof(cpumap) * 8;
+
+ set_xen_guest_handle(domctl.u.vcpuaffinity.cpumap.bitmap, (uint8_t *) &cpumap);
+
+ if (mlock(&cpumap, sizeof(cpumap)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "vcpu %d set affinity", vcpu);
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "vcpu %d set affinity", vcpu);
+ munlock(&cpumap, sizeof(cpumap));
+ return ret;
+}
+
+int xc_vcpu_getaffinity(int handle, unsigned int domid, int vcpu,
+ uint64_t *cpumap)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpuaffinity, domid);
+ domctl.u.vcpuaffinity.vcpu = vcpu;
+ domctl.u.vcpuaffinity.cpumap.nr_cpus = sizeof(*cpumap) * 8;
+
+ set_xen_guest_handle(domctl.u.vcpuaffinity.cpumap.bitmap, cpumap);
+
+ if (mlock(cpumap, sizeof(*cpumap)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "vcpu %d get affinity", vcpu);
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "vcpu %d get affinity", vcpu);
+ munlock(cpumap, sizeof(*cpumap));
+ return ret;
+}
+
+int xc_vcpu_context_get(int handle, unsigned int domid, unsigned short vcpu,
+ struct vcpu_guest_context *ctxt)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpucontext, domid);
+ domctl.u.vcpucontext.vcpu = vcpu;
+
+ set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt);
+
+ if (mlock(ctxt, sizeof(struct vcpu_guest_context)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "vcpu %d get context", vcpu);
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "vcpu %d get context", vcpu);
+ munlock(ctxt, sizeof(struct vcpu_guest_context));
+
+ return ret;
+}
+
+int xc_domain_getinfolist(int handle, unsigned int first_domain,
+ unsigned int max_domains, xc_domaininfo_t *info)
+{
+ int ret;
+ DECLARE_SYSCTL(XEN_SYSCTL_getdomaininfolist);
+ sysctl.u.getdomaininfolist.first_domain = first_domain;
+ sysctl.u.getdomaininfolist.max_domains = max_domains;
+ set_xen_guest_handle(sysctl.u.getdomaininfolist.buffer, info);
+
+ if (mlock(info, max_domains * sizeof(xc_domaininfo_t)) != 0) {
+ xc_error_set("getinfolist(%d, %u, %u, %x (%d)) failed: mlock failed: %s",
+ handle, first_domain, max_domains, info, sizeof(xc_domaininfo_t),
+ strerror(errno));
+ return -1;
+ }
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret < 0)
+ xc_error_set("getinfolist(%d, %u, %u, %x (%d)) failed: %s",
+ handle, first_domain, max_domains, info, sizeof(xc_domaininfo_t),
+ xc_error_get());
+ else
+ ret = sysctl.u.getdomaininfolist.num_domains;
+
+ munlock(info, max_domains * sizeof(xc_domaininfo_t));
+ return ret;
+}
+
+int xc_domain_getinfo(int handle, unsigned int domid, xc_domaininfo_t *info)
+{
+ int ret;
+ ret = xc_domain_getinfolist(handle, domid, 1, info);
+ if (ret != 1) {
+ xc_error_set("getinfo failed: domain %d: %s", domid, xc_error_get());
+ return -1;
+ }
+
+ /* If the requested domain didn't exist but there exists one with a
+ higher domain ID, this will be returned. We consider this an error since
+ we only wanted info about a specific domain. */
+ if (info->domain != domid) {
+ xc_error_set("getinfo failed: domain %d nolonger exists", domid);
+ return -1;
+ }
+
+ return 0;
+}
+
+int xc_domain_setmaxmem(int handle, unsigned int domid, unsigned int max_memkb)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_max_mem, domid);
+ domctl.u.max_mem.max_memkb = max_memkb;
+ int ret;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "set max memory to %u", max_memkb);
+ return ret;
+}
+
+int xc_domain_set_memmap_limit(int handle, unsigned int domid,
+ unsigned long map_limitkb)
+{
+ int ret;
+ struct xen_foreign_memory_map fmap = {
+ .domid = domid,
+ .map = { .nr_entries = 1 }
+ };
+ struct e820entry e820 = {
+ .addr = 0,
+ .size = (uint64_t)map_limitkb << 10,
+ .type = E820_RAM
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_memory_op, XENMEM_set_memory_map, &fmap);
+
+ set_xen_guest_handle(fmap.map.buffer, &e820);
+
+ if (mlock(&fmap, sizeof(fmap)) != 0) {
+ xc_error_set("set_memmap_limit failed: mlock failed: %s",
+ strerror(errno));
+ return -1;
+ }
+
+ if (mlock(&e820, sizeof(e820)) != 0) {
+ xc_error_set("set_memmap_limit failed: mlock failed: %s",
+ strerror(errno));
+ munlock(&fmap, sizeof(fmap));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+
+ munlock(&e820, sizeof(e820));
+ munlock(&fmap, sizeof(fmap));
+ return ret;
+}
+
+int xc_domain_set_time_offset(int handle, unsigned int domid, int time_offset)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_settimeoffset, domid);
+ domctl.u.settimeoffset.time_offset_seconds = time_offset;
+ int ret;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "set time offset %d", time_offset);
+ return ret;
+}
+
+int xc_domain_memory_increase_reservation(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start)
+{
+ int ret;
+ struct xen_memory_reservation reservation = {
+ .nr_extents = nr_extents,
+ .extent_order = extent_order,
+ .COMPAT_FIELD_ADDRESS_BITS = address_bits,
+ .domid = domid
+ };
+
+ set_xen_guest_handle(reservation.extent_start, extent_start);
+
+ ret = do_memctl_reservation(handle, XENMEM_increase_reservation,
+ &reservation);
+ if (ret != nr_extents) {
+ xc_error_dom_set(domid, "increase reservation to %lu",
+ nr_extents);
+ return (ret >= 0) ? -1 : ret;
+ }
+ return 0;
+}
+
+int xc_domain_memory_decrease_reservation(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start)
+{
+ int ret;
+ struct xen_memory_reservation reservation = {
+ .nr_extents = nr_extents,
+ .extent_order = extent_order,
+ .COMPAT_FIELD_ADDRESS_BITS = 0,
+ .domid = domid
+ };
+
+ set_xen_guest_handle(reservation.extent_start, extent_start);
+ if (!extent_start) {
+ xc_error_set("decrease reservation: extent start is NULL");
+ return -EINVAL;
+ }
+
+ ret = do_memctl_reservation(handle, XENMEM_decrease_reservation,
+ &reservation);
+ if (ret < nr_extents) {
+ xc_error_dom_set(domid, "decrease reservation to %lu",
+ nr_extents);
+ return (ret >= 0) ? -1 : ret;
+ }
+ return 0;
+}
+
+int xc_domain_memory_populate_physmap(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start)
+{
+ int ret;
+ struct xen_memory_reservation reservation = {
+ .nr_extents = nr_extents,
+ .extent_order = extent_order,
+ .COMPAT_FIELD_ADDRESS_BITS = address_bits,
+ .domid = domid
+ };
+
+ set_xen_guest_handle(reservation.extent_start, extent_start);
+ ret = do_memctl_reservation(handle, XENMEM_populate_physmap,
+ &reservation);
+ if (ret < nr_extents) {
+ xc_error_dom_set(domid, "populate physmap");
+ return (ret >= 0) ? -1 : ret;
+ }
+ return 0;
+}
+
+int xc_domain_setvmxassist(int handle, unsigned int domid, int use_vmxassist)
+{
+ int ret = 0;
+#ifdef XEN_DOMCTL_setvmxassist
+ DECLARE_DOMCTL(XEN_DOMCTL_setvmxassist, domid);
+ domctl.u.setvmxassist.use_vmxassist = use_vmxassist;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "setting vmxassist to %d",
+ use_vmxassist);
+#endif
+ return ret;
+}
+
+int xc_domain_max_vcpus(int handle, unsigned int domid, unsigned int max)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_max_vcpus, domid);
+ domctl.u.max_vcpus.max = max;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "setting max vcpus to %d", max);
+ return ret;
+}
+
+int xc_domain_sethandle(int handle, unsigned int domid,
+ xen_domain_handle_t dhandle)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_setdomainhandle, domid);
+ memcpy(domctl.u.setdomainhandle.handle, dhandle, sizeof(xen_domain_handle_t));
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "set handle");
+ return ret;
+}
+
+int xc_vcpu_getinfo(int handle, unsigned int domid, unsigned int vcpu,
+ xc_vcpuinfo_t *info)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpuinfo, domid);
+ domctl.u.getvcpuinfo.vcpu = vcpu;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0) {
+ xc_error_dom_set(domid, "vcpu %u getinfo", vcpu);
+ return ret;
+ }
+ memcpy(info, &domctl.u.getvcpuinfo, sizeof(*info));
+ return ret;
+}
+
+int xc_domain_ioport_permission(int handle, unsigned int domid,
+ unsigned int first_port, unsigned int nr_ports,
+ unsigned int allow_access)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_ioport_permission, domid);
+ domctl.u.ioport_permission.first_port = first_port;
+ domctl.u.ioport_permission.nr_ports = nr_ports;
+ domctl.u.ioport_permission.allow_access = allow_access;
+
+ return do_domctl(handle, &domctl);
+}
+
+int xc_vcpu_getcontext(int handle, unsigned int domid,
+ unsigned int vcpu, vcpu_guest_context_any_t *ctxt)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpucontext, domid);
+ domctl.u.vcpucontext.vcpu = vcpu;
+ set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt);
+
+ if (mlock(ctxt, sizeof(*ctxt)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "vcpu %u getcontext", vcpu);
+ munlock(ctxt, sizeof(*ctxt));
+ return ret;
+}
+
+int xc_vcpu_setcontext(int handle, unsigned int domid,
+ unsigned int vcpu, vcpu_guest_context_any_t *ctxt)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_setvcpucontext, domid);
+ domctl.u.vcpucontext.vcpu = vcpu;
+ set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt);
+
+ if (mlock(ctxt, sizeof(*ctxt)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "vcpu %u setcontext", vcpu);
+
+ munlock(ctxt, sizeof(*ctxt));
+ return ret;
+}
+
+int xc_domain_irq_permission(int handle, unsigned int domid,
+ unsigned char pirq, unsigned char allow_access)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_irq_permission, domid);
+ domctl.u.irq_permission.pirq = pirq;
+ domctl.u.irq_permission.allow_access = allow_access;
+ int ret;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "irq permission %u to %u",
+ pirq, allow_access);
+ return ret;
+}
+
+int xc_domain_iomem_permission(int handle, unsigned int domid,
+ unsigned long first_mfn, unsigned long nr_mfns,
+ unsigned char allow_access)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_iomem_permission, domid);
+ domctl.u.iomem_permission.first_mfn = first_mfn;
+ domctl.u.iomem_permission.nr_mfns = nr_mfns;
+ domctl.u.iomem_permission.allow_access = allow_access;
+ int ret;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "iomem permission [%lu, %lu] to %u",
+ first_mfn, first_mfn + nr_mfns, allow_access);
+ return ret;
+}
+
+long long xc_domain_get_cpu_usage(int handle, unsigned int domid,
+ unsigned int vcpu)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpuinfo, domid);
+ domctl.u.getvcpuinfo.vcpu = vcpu;
+
+ if (do_domctl(handle, &domctl) < 0) {
+ xc_error_dom_set(domid, "get cpu %d usage", vcpu);
+ return -1;
+ }
+ return domctl.u.getvcpuinfo.cpu_time;
+}
+
+void *xc_map_foreign_range(int handle, unsigned int domid,
+ int size, int prot, unsigned long mfn)
+{
+ privcmd_mmap_entry_t entry = {
+ .mfn = mfn,
+ .npages = (size + PAGE_SIZE - 1) >> PAGE_SHIFT,
+ };
+ privcmd_mmap_t ioctlx = {
+ .num = 1,
+ .dom = domid,
+ .entry = &entry,
+ };
+ void *addr;
+
+ addr = do_mmap(NULL, size, prot, MAP_SHARED, handle, 0);
+ if (addr == MAP_FAILED) {
+ xc_error_set("mmap failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "map foreign range [%lx,%lx] prot %u",
+ mfn, mfn + size, prot);
+ return NULL;
+ }
+ entry.va = (unsigned long) addr;
+ if (do_ioctl(handle, IOCTL_PRIVCMD_MMAP, &ioctlx) < 0) {
+ xc_error_set("ioctl failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "map foreign range [%lx,%lx] prot %u",
+ mfn, mfn + size, prot);
+ munmap(addr, size);
+ return NULL;
+ }
+ return addr;
+}
+
+int xc_map_foreign_ranges(int handle, unsigned int domid,
+ privcmd_mmap_entry_t *entries, int nr)
+{
+ privcmd_mmap_t ioctlx = {
+ .num = nr,
+ .dom = domid,
+ .entry = entries,
+ };
+ int ret;
+
+ ret = do_ioctl(handle, IOCTL_PRIVCMD_MMAP, &ioctlx);
+ if (ret < 0) {
+ xc_error_set("ioctl failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "map foreign ranges");
+ return -1;
+ }
+ return ret;
+}
+
+int xc_readconsolering(int handle, char **pbuffer,
+ unsigned int *pnr_chars, int clear)
+{
+ int ret;
+ DECLARE_SYSCTL(XEN_SYSCTL_readconsole);
+ char *buffer = *pbuffer;
+ unsigned int nr_chars = *pnr_chars;
+
+ set_xen_guest_handle(sysctl.u.readconsole.buffer, buffer);
+ sysctl.u.readconsole.count = nr_chars;
+ sysctl.u.readconsole.clear = clear;
+
+ if (mlock(buffer, nr_chars) != 0) {
+ xc_error_set("read console ring: mlock failed: %s",
+ strerror(errno));
+ return -1;
+ }
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret != 0)
+ xc_error_set("read console ring failed: %s", xc_error_get());
+ else
+ *pnr_chars = sysctl.u.readconsole.count;
+
+ munlock(buffer, nr_chars);
+ return ret;
+}
+
+int xc_send_debug_keys(int handle, char *keys)
+{
+ int ret;
+ DECLARE_SYSCTL(XEN_SYSCTL_debug_keys);
+
+ set_xen_guest_handle(sysctl.u.debug_keys.keys, keys);
+ sysctl.u.debug_keys.nr_keys = strlen(keys);
+
+ if (mlock(keys, sysctl.u.debug_keys.nr_keys) != 0) {
+ xc_error_set("send debug keys: mlock failed: %s",
+ strerror(errno));
+ return -1;
+ }
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret != 0)
+ xc_error_set("send debug keys: %s", xc_error_get());
+
+ munlock(keys, sysctl.u.debug_keys.nr_keys);
+ return ret;
+}
+
+int xc_physinfo(int handle, xc_physinfo_t *put_info)
+{
+ DECLARE_SYSCTL(XEN_SYSCTL_physinfo);
+ int ret;
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret) {
+ xc_error_set("physinfo failed: %s", xc_error_get());
+ return ret;
+ }
+ memcpy(put_info, &sysctl.u.physinfo, sizeof(*put_info));
+ return 0;
+}
+
+int xc_pcpu_info(int handle, int max_cpus, uint64_t *info, int *nr_cpus)
+{
+ DECLARE_SYSCTL(XEN_SYSCTL_getcpuinfo);
+ int ret;
+
+ sysctl.u.getcpuinfo.max_cpus = max_cpus;
+ set_xen_guest_handle(sysctl.u.getcpuinfo.info, info);
+
+ if (mlock(info, sizeof(*info) * max_cpus) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret)
+ xc_error_set("pcpu info failed: %s", xc_error_get());
+ else if (ret == 0 && nr_cpus)
+ *nr_cpus = sysctl.u.getcpuinfo.nr_cpus;
+ munlock(info, sizeof(*info) * max_cpus);
+ return ret;
+}
+
+int xc_sched_id(int handle, int *sched_id)
+{
+ DECLARE_SYSCTL(XEN_SYSCTL_sched_id);
+ int ret;
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret) {
+ xc_error_set("sched id failed: %s", xc_error_get());
+ return ret;
+ }
+ *sched_id = sysctl.u.sched_id.sched_id;
+ return 0;
+}
+
+int xc_version(int handle, int cmd, void *arg)
+{
+ int argsize;
+ int ret;
+ DECLARE_HYPERCALL2(__HYPERVISOR_xen_version, cmd, arg);
+
+ switch (cmd) {
+ case XENVER_extraversion:
+ argsize = sizeof(xen_extraversion_t); break;
+ case XENVER_compile_info:
+ argsize = sizeof(xen_compile_info_t); break;
+ case XENVER_capabilities:
+ argsize = sizeof(xen_capabilities_info_t); break;
+ case XENVER_changeset:
+ argsize = sizeof(xen_changeset_info_t); break;
+ case XENVER_platform_parameters:
+ argsize = sizeof(xen_platform_parameters_t); break;
+ case XENVER_version:
+ argsize = 0; break;
+ default:
+ xc_error_set("version: unknown command");
+ return -1;
+ }
+ if (argsize && mlock(arg, argsize) == -1) {
+ xc_error_set("version: mlock failed: %s", strerror(errno));
+ return -ENOMEM;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+
+ if (argsize)
+ munlock(arg, argsize);
+ return ret;
+}
+
+int xc_evtchn_alloc_unbound(int handle, unsigned int domid,
+ unsigned int remote_domid)
+{
+ struct evtchn_alloc_unbound arg = {
+ .dom = domid,
+ .remote_dom = remote_domid,
+ };
+ int ret;
+
+ ret = do_evtchnctl(handle, EVTCHNOP_alloc_unbound, &arg, sizeof(arg));
+ if (ret) {
+ xc_error_dom_set(domid, "alloc unbound evtchn to %d",
+ remote_domid);
+ return ret;
+ }
+ return arg.port;
+}
+
+int xc_evtchn_reset(int handle, unsigned int domid)
+{
+ struct evtchn_reset arg = {
+ .dom = domid,
+ };
+ int ret;
+
+ ret = do_evtchnctl(handle, EVTCHNOP_reset, &arg, sizeof(arg));
+ if (ret)
+ xc_error_dom_set(domid, "reset evtchn of %d", domid);
+ return ret;
+}
+
+int xc_sched_credit_domain_set(int handle, unsigned int domid,
+ struct xen_domctl_sched_credit *sdom)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_scheduler_op, domid);
+ domctl.u.scheduler_op.sched_id = XEN_SCHEDULER_CREDIT;
+ domctl.u.scheduler_op.cmd = XEN_DOMCTL_SCHEDOP_putinfo;
+ domctl.u.scheduler_op.u.credit = *sdom;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "credit scheduler domain set");
+ return ret;
+}
+
+int xc_sched_credit_domain_get(int handle, unsigned int domid,
+ struct xen_domctl_sched_credit *sdom)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_scheduler_op, domid);
+
+ domctl.u.scheduler_op.sched_id = XEN_SCHEDULER_CREDIT;
+ domctl.u.scheduler_op.cmd = XEN_DOMCTL_SCHEDOP_getinfo;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "credit scheduler domain get");
+ else
+ *sdom = domctl.u.scheduler_op.u.credit;
+ return ret;
+}
+
+int xc_shadow_allocation_get(int handle, unsigned int domid, uint32_t *mb)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_shadow_op, domid);
+
+ domctl.u.shadow_op.op = XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "shadow allocation get");
+ else
+ *mb = domctl.u.shadow_op.mb;
+ return ret;
+}
+
+int xc_shadow_allocation_set(int handle, unsigned int domid, uint32_t mb)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_shadow_op, domid);
+
+ domctl.u.shadow_op.op = XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION;
+ domctl.u.shadow_op.mb = mb;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "shadow allocation set");
+ return ret;
+}
+
+int xc_domain_get_pfn_list(int handle, unsigned int domid,
+ xen_pfn_t *pfn_array, unsigned long max_pfns)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getmemlist, domid);
+
+ domctl.u.getmemlist.max_pfns = max_pfns;
+ set_xen_guest_handle(domctl.u.getmemlist.buffer, pfn_array);
+
+ if (mlock(pfn_array, max_pfns * sizeof(xen_pfn_t)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "get pfn list");
+
+ munlock(pfn_array, max_pfns * sizeof(xen_pfn_t));
+ return (ret < 0) ? ret : domctl.u.getmemlist.num_pfns;
+}
+
+#define MARSHALL_BDF(d,b,s,f) \
+ (((b) & 0xff) << 16 | ((s) & 0x1f) << 11 | ((f) & 0x7) << 8)
+
+int xc_domain_assign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_assign_device
+ DECLARE_DOMCTL(XEN_DOMCTL_assign_device, domid);
+
+ domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func);
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "assign device");
+#endif
+ return ret;
+}
+
+int xc_domain_deassign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_deassign_device
+ DECLARE_DOMCTL(XEN_DOMCTL_deassign_device, domid);
+
+ domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func);
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "deassign device");
+#endif
+ return ret;
+}
+
+int xc_domain_test_assign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_test_assign_device
+ DECLARE_DOMCTL(XEN_DOMCTL_test_assign_device, domid);
+ domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func);
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "test assign device");
+#endif
+ return ret;
+}
+
+int xc_domain_watchdog(int handle, int id, uint32_t timeout)
+{
+ int ret = -EBADF;
+#ifdef SCHEDOP_watchdog
+ sched_watchdog_t arg = {
+ .id = (uint32_t) id,
+ .timeout = timeout,
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_sched_op, SCHEDOP_watchdog, &arg);
+
+ if (mlock(&arg, sizeof(arg)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0) {
+ xc_error_hypercall(hypercall, ret);
+ }
+ munlock(&arg, sizeof(arg));
+#endif
+ return ret;
+}
+
+int xc_domain_set_machine_address_size(int xc, uint32_t domid, unsigned int width)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_set_machine_address_size, domid);
+ int rc;
+
+ domctl.u.address_size.size = width;
+ rc = do_domctl(xc, &domctl);
+ if (rc != 0)
+ xc_error_dom_set(domid, "set machine address size");
+
+ return rc;
+}
+
+int xc_domain_get_machine_address_size(int xc, uint32_t domid)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_get_machine_address_size, domid);
+ int rc;
+
+ rc = do_domctl(xc, &domctl);
+ if (rc != 0)
+ xc_error_dom_set(domid, "get machine address size");
+ return rc == 0 ? domctl.u.address_size.size : rc;
+}
+
+#include "xc_cpuid.h"
+int xc_domain_cpuid_set(int xc, unsigned int domid, int hvm,
+ uint32_t input, uint32_t oinput,
+ char *config[4], char *config_out[4])
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_set_cpuid
+ DECLARE_DOMCTL(XEN_DOMCTL_set_cpuid, domid);
+ uint32_t regs[4], polregs[4];
+ int i, j;
+
+ xc_cpuid(input, oinput, regs);
+ memcpy(polregs, regs, sizeof(regs));
+ do_cpuid_policy(xc, domid, hvm, input, polregs);
+
+ for (i = 0; i < 4; i++) {
+ if (!config[i]) {
+ regs[i] = polregs[i];
+ continue;
+ }
+
+ for (j = 0; j < 32; j++) {
+ unsigned char val, polval;
+
+ val = !!((regs[i] & (1U << (31 - j))));
+ polval = !!((regs[i] & (1U << (31 - j))));
+
+ switch (config[i][j]) {
+ case '1': val = 1; break; /* force to true */
+ case '0': val = 0; break; /* force to false */
+ case 'x': val = polval; break;
+ case 'k': case 's': break;
+ default:
+ xc_error_dom_set(domid, "domain cpuid set: invalid config");
+ ret = -EINVAL;
+ goto out;
+ }
+
+ if (val)
+ set_bit(31 - j, regs[i]);
+ else
+ clear_bit(31 - j, regs[i]);
+
+ if (config_out && config_out[i]) {
+ config_out[i][j] = (config[i][j] == 's')
+ ? '0' + val
+ : config[i][j];
+ }
+ }
+ }
+
+ domctl.u.cpuid.input[0] = input;
+ domctl.u.cpuid.input[1] = oinput;
+ domctl.u.cpuid.eax = regs[0];
+ domctl.u.cpuid.ebx = regs[1];
+ domctl.u.cpuid.ecx = regs[2];
+ domctl.u.cpuid.edx = regs[3];
+ ret = do_domctl(xc, &domctl);
+ if (ret) {
+ xc_error_dom_set(domid, "cpuid set");
+ goto out;
+ }
+out:
+#endif
+ return ret;
+}
+
+int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_set_cpuid
+ uint32_t regs[4], base_max, ext_max, eax, ecx;
+
+ /* determinate cpuid range */
+ xc_cpuid(0, 0, regs);
+ base_max = MIN(regs[0], DEF_MAX_BASE);
+ xc_cpuid(0x80000000, 0, regs);
+ ext_max = MIN(regs[0], DEF_MAX_EXT);
+
+ eax = ecx = 0;
+ while (!(eax & 0x80000000) || (eax <= ext_max)) {
+ xc_cpuid(eax, ecx, regs);
+
+ do_cpuid_policy(xc, domid, hvm, eax, regs);
+
+ if (regs[0] || regs[1] || regs[2] || regs[3]) {
+ DECLARE_DOMCTL(XEN_DOMCTL_set_cpuid, domid);
+
+ domctl.u.cpuid.input[0] = eax;
+ domctl.u.cpuid.input[1] = (eax == 4) ? ecx : XEN_CPUID_INPUT_UNUSED;
+ domctl.u.cpuid.eax = regs[0];
+ domctl.u.cpuid.ebx = regs[1];
+ domctl.u.cpuid.ecx = regs[2];
+ domctl.u.cpuid.edx = regs[3];
+
+ ret = do_domctl(xc, &domctl);
+ if (ret) {
+ xc_error_dom_set(domid, "cpuid apply");
+ goto out;
+ }
+
+ /* we repeat when doing node 4 (cache descriptor leaves) increasing ecx
+ * until the cpuid eax value masked is 0 */
+ if (eax == 4) {
+ ecx++;
+ if ((regs[0] & 0x1f) != 0)
+ continue;
+ ecx = 0;
+ }
+ }
+
+ eax++;
+ if (!(eax & 0x80000000) && (eax > base_max))
+ eax = 0x80000000;
+ }
+ ret = 0;
+out:
+#endif
+ return ret;
+}
+
+/*
+ * return 1 on checking success
+ * 0 on checking failure
+ * -EINVAL if the config contains unknown character
+ */
+int xc_cpuid_check(uint32_t input, uint32_t optsubinput,
+ char *config[4], char *config_out[4])
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_set_cpuid
+ uint32_t regs[4];
+ int i, j;
+
+ xc_cpuid(input, optsubinput, regs);
+
+ ret = 1;
+ for (i = 0; i < 4; i++) {
+ if (!config[i])
+ continue;
+ for (j = 0; j < 32; j++) {
+ unsigned char val;
+
+ val = !!((regs[i] & (1U << (31 - j))));
+
+ switch (config[i][j]) {
+ case '1': if (!val) { ret = 0; goto out; }; break;
+ case '0': if (val) { ret = 0; goto out; }; break;
+ case 'x': case 's': break;
+ default:
+ xc_error_set("cpuid check: invalid config");
+ ret = -EINVAL;
+ goto out;
+ }
+
+ if (config_out && config_out[i]) {
+ config_out[i][j] = (config[i][j] == 's')
+ ? '0' + val
+ : config[i][j];
+ }
+ }
+ }
+out:
+#endif
+ return ret;
+}
+
+#ifndef HVM_PARAM_HPET_ENABLED
+#define HVM_PARAM_HPET_ENABLED 11
+#endif
+
+#ifndef HVM_PARAM_ACPI_S_STATE
+#define HVM_PARAM_ACPI_S_STATE 14
+#endif
+
+#ifndef HVM_PARAM_VPT_ALIGN
+#define HVM_PARAM_VPT_ALIGN 16
+#endif
+
+int xc_domain_send_s3resume(int handle, unsigned int domid)
+{
+ return xc_set_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, 0);
+}
+
+int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode)
+{
+ return xc_set_hvm_param(handle, domid,
+ HVM_PARAM_TIMER_MODE, (unsigned long) mode);
+}
+
+int xc_domain_set_hpet(int handle, unsigned int domid, int hpet)
+{
+ return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigned long) hpet);
+}
+
+int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_align)
+{
+ return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigned long) vpt_align);
+}
+
+int xc_domain_get_acpi_s_state(int handle, unsigned int domid)
+{
+ int ret;
+ unsigned long value;
+
+ ret = xc_get_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, &value);
+ if (ret != 0)
+ xc_error_dom_set(domid, "get acpi s-state");
+ return value;
+}
diff --git a/tools/ocaml/libs/xc/xc_stubs.c b/tools/ocaml/libs/xc/xc_stubs.c
new file mode 100644
index 0000000..b43a750
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_stubs.c
@@ -0,0 +1,1170 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ */
+
+#define _XOPEN_SOURCE 600
+#include <stdlib.h>
+
+#define CAML_NAME_SPACE
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#include <sys/mman.h>
+#include <stdint.h>
+#include <string.h>
+
+#include "xc.h"
+
+#include "mmap_stubs.h"
+
+#define PAGE_SHIFT 12
+#define PAGE_SIZE (1UL << PAGE_SHIFT)
+#define PAGE_MASK (~(PAGE_SIZE-1))
+
+#define _H(__h) (Int_val(__h))
+#define _D(__d) ((uint32_t)Int_val(__d))
+
+#define Val_none (Val_int(0))
+
+#define string_of_option_array(array, index) \
+ ((Field(array, index) == Val_none) ? NULL : String_val(Field(Field(array, index), 0)))
+
+/* maybe here we should check the range of the input instead of blindly
+ * casting it to uint32 */
+#define cpuid_input_of_val(i1, i2, input) \
+ i1 = (uint32_t) Int64_val(Field(input, 0)); \
+ i2 = ((Field(input, 1) == Val_none) ? 0xffffffff : (uint32_t) Int64_val(Field(Field(input, 1), 0)));
+
+/**
+ * Convert the given number of pages to an amount in MiB, rounded up.
+ */
+void failwith_xc(void)
+{
+ caml_raise_with_string(*caml_named_value("xc.error"), xc_error_get());
+}
+
+CAMLprim value stub_sizeof_core_header(value unit)
+{
+ CAMLparam1(unit);
+ CAMLreturn(Val_int(sizeof(struct xc_core_header)));
+}
+
+CAMLprim value stub_sizeof_vcpu_guest_context(value unit)
+{
+ CAMLparam1(unit);
+ CAMLreturn(Val_int(sizeof(struct vcpu_guest_context)));
+}
+
+CAMLprim value stub_sizeof_xen_pfn(value unit)
+{
+ CAMLparam1(unit);
+ CAMLreturn(Val_int(sizeof(xen_pfn_t)));
+}
+
+#define XC_CORE_MAGIC 0xF00FEBED
+#define XC_CORE_MAGIC_HVM 0xF00FEBEE
+
+CAMLprim value stub_marshall_core_header(value header)
+{
+ CAMLparam1(header);
+ CAMLlocal1(s);
+ struct xc_core_header c_header;
+
+ c_header.xch_magic = (Field(header, 0))
+ ? XC_CORE_MAGIC
+ : XC_CORE_MAGIC_HVM;
+ c_header.xch_nr_vcpus = Int_val(Field(header, 1));
+ c_header.xch_nr_pages = Nativeint_val(Field(header, 2));
+ c_header.xch_ctxt_offset = Int64_val(Field(header, 3));
+ c_header.xch_index_offset = Int64_val(Field(header, 4));
+ c_header.xch_pages_offset = Int64_val(Field(header, 5));
+
+ s = caml_alloc_string(sizeof(c_header));
+ memcpy(String_val(s), (char *) &c_header, sizeof(c_header));
+ CAMLreturn(s);
+}
+
+CAMLprim value stub_xc_interface_open()
+{
+ int handle;
+ handle = xc_interface_open();
+ if (handle == -1)
+ failwith_xc();
+ return Val_int(handle);
+}
+
+
+CAMLprim value stub_xc_interface_open_fake()
+{
+ return Val_int(-1);
+}
+
+CAMLprim value stub_xc_using_injection()
+{
+ if (xc_using_injection ()){
+ return Val_int(1);
+ } else {
+ return Val_int(0);
+ }
+}
+
+CAMLprim value stub_xc_interface_close(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+
+ int handle = _H(xc_handle);
+ // caml_enter_blocking_section();
+ xc_interface_close(handle);
+ // caml_leave_blocking_section();
+
+ CAMLreturn(Val_unit);
+}
+
+static int domain_create_flag_table[] = {
+ XEN_DOMCTL_CDF_hvm_guest,
+ XEN_DOMCTL_CDF_hap,
+};
+
+CAMLprim value stub_xc_domain_create(value xc_handle, value ssidref,
+ value flags, value handle)
+{
+ CAMLparam4(xc_handle, ssidref, flags, handle);
+
+ uint32_t domid = 0;
+ xen_domain_handle_t h = { 0 };
+ int result;
+ int i;
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_ssidref = Int32_val(ssidref);
+ unsigned int c_flags = 0;
+ value l;
+
+ if (Wosize_val(handle) != 16)
+ caml_invalid_argument("Handle not a 16-integer array");
+
+ for (i = 0; i < sizeof(h); i++) {
+ h[i] = Int_val(Field(handle, i)) & 0xff;
+ }
+
+ for (l = flags; l != Val_none; l = Field(l, 1)) {
+ int v = Int_val(Field(l, 0));
+ c_flags |= domain_create_flag_table[v];
+ }
+
+ // caml_enter_blocking_section();
+ result = xc_domain_create(c_xc_handle, c_ssidref, h, c_flags, &domid);
+ // caml_leave_blocking_section();
+
+ if (result < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_int(domid));
+}
+
+CAMLprim value stub_xc_domain_setvmxassist(value xc_handle, value domid,
+ value use_vmxassist)
+{
+ CAMLparam3(xc_handle, domid, use_vmxassist);
+ int r;
+
+ r = xc_domain_setvmxassist(_H(xc_handle), _D(domid),
+ Bool_val(use_vmxassist));
+ if (r)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_max_vcpus(value xc_handle, value domid,
+ value max_vcpus)
+{
+ CAMLparam3(xc_handle, domid, max_vcpus);
+ int r;
+
+ r = xc_domain_max_vcpus(_H(xc_handle), _D(domid), Int_val(max_vcpus));
+ if (r)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+
+value stub_xc_domain_sethandle(value xc_handle, value domid, value handle)
+{
+ CAMLparam3(xc_handle, domid, handle);
+ xen_domain_handle_t h = { 0 };
+ int i;
+
+ if (Wosize_val(handle) != 16)
+ caml_invalid_argument("Handle not a 16-integer array");
+
+ for (i = 0; i < sizeof(h); i++) {
+ h[i] = Int_val(Field(handle, i)) & 0xff;
+ }
+
+ i = xc_domain_sethandle(_H(xc_handle), _D(domid), h);
+ if (i)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+static value dom_op(value xc_handle, value domid, int (*fn)(int, uint32_t))
+{
+ CAMLparam2(xc_handle, domid);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+
+ // caml_enter_blocking_section();
+ int result = fn(c_xc_handle, c_domid);
+ // caml_leave_blocking_section();
+ if (result)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_pause(value xc_handle, value domid)
+{
+ return dom_op(xc_handle, domid, xc_domain_pause);
+}
+
+
+CAMLprim value stub_xc_domain_unpause(value xc_handle, value domid)
+{
+ return dom_op(xc_handle, domid, xc_domain_unpause);
+}
+
+CAMLprim value stub_xc_domain_destroy(value xc_handle, value domid)
+{
+ return dom_op(xc_handle, domid, xc_domain_destroy);
+}
+
+CAMLprim value stub_xc_domain_resume_fast(value xc_handle, value domid)
+{
+ return dom_op(xc_handle, domid, xc_domain_resume_fast);
+}
+
+CAMLprim value stub_xc_domain_shutdown(value handle, value domid, value reason)
+{
+ CAMLparam3(handle, domid, reason);
+ int ret;
+
+ ret = xc_domain_shutdown(_H(handle), _D(domid), Int_val(reason));
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+static value alloc_domaininfo(xc_domaininfo_t * info)
+{
+ CAMLparam0();
+ CAMLlocal2(result, tmp);
+ int i;
+
+ result = caml_alloc_tuple(16);
+
+ Store_field(result, 0, Val_int(info->domain));
+ Store_field(result, 1, Val_bool(info->flags & XEN_DOMINF_dying));
+ Store_field(result, 2, Val_bool(info->flags & XEN_DOMINF_shutdown));
+ Store_field(result, 3, Val_bool(info->flags & XEN_DOMINF_paused));
+ Store_field(result, 4, Val_bool(info->flags & XEN_DOMINF_blocked));
+ Store_field(result, 5, Val_bool(info->flags & XEN_DOMINF_running));
+ Store_field(result, 6, Val_bool(info->flags & XEN_DOMINF_hvm_guest));
+ Store_field(result, 7, Val_int((info->flags >> XEN_DOMINF_shutdownshift)
+ & XEN_DOMINF_shutdownmask));
+ Store_field(result, 8, caml_copy_nativeint(info->tot_pages));
+ Store_field(result, 9, caml_copy_nativeint(info->max_pages));
+ Store_field(result, 10, caml_copy_int64(info->shared_info_frame));
+ Store_field(result, 11, caml_copy_int64(info->cpu_time));
+ Store_field(result, 12, Val_int(info->nr_online_vcpus));
+ Store_field(result, 13, Val_int(info->max_vcpu_id));
+ Store_field(result, 14, caml_copy_int32(info->ssidref));
+
+ tmp = caml_alloc_small(16, 0);
+ for (i = 0; i < 16; i++) {
+ Field(tmp, i) = Val_int(info->handle[i]);
+ }
+
+ Store_field(result, 15, tmp);
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_domain_getinfolist(value xc_handle, value first_domain, value nb)
+{
+ CAMLparam3(xc_handle, first_domain, nb);
+ CAMLlocal2(result, temp);
+ xc_domaininfo_t * info;
+ int i, ret, toalloc;
+
+ /* get the minimum number of allocate byte we need and bump it up to page boundary */
+ toalloc = (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff;
+ ret = posix_memalign((void **) ((void *) &info), 4096, toalloc);
+ if (ret)
+ caml_raise_out_of_memory();
+
+ result = temp = Val_emptylist;
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_first_domain = _D(first_domain);
+ unsigned int c_max_domains = Int_val(nb);
+ // caml_enter_blocking_section();
+ int retval = xc_domain_getinfolist(c_xc_handle, c_first_domain,
+ c_max_domains, info);
+ // caml_leave_blocking_section();
+
+ if (retval < 0) {
+ free(info);
+ failwith_xc();
+ }
+ for (i = 0; i < retval; i++) {
+ result = caml_alloc_small(2, Tag_cons);
+ Field(result, 0) = Val_int(0);
+ Field(result, 1) = temp;
+ temp = result;
+
+ Store_field(result, 0, alloc_domaininfo(info + i));
+ }
+
+ free(info);
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_domain_getinfo(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ CAMLlocal1(result);
+ xc_domaininfo_t info;
+ int ret;
+
+ ret = xc_domain_getinfo(_H(xc_handle), _D(domid), &info);
+ if (ret != 0)
+ failwith_xc();
+
+ result = alloc_domaininfo(&info);
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_vcpu_getinfo(value xc_handle, value domid, value vcpu)
+{
+ CAMLparam3(xc_handle, domid, vcpu);
+ CAMLlocal1(result);
+ xc_vcpuinfo_t info;
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ uint32_t c_vcpu = Int_val(vcpu);
+ // caml_enter_blocking_section();
+ retval = xc_vcpu_getinfo(c_xc_handle, c_domid,
+ c_vcpu, &info);
+ // caml_leave_blocking_section();
+ if (retval < 0)
+ failwith_xc();
+
+ result = caml_alloc_tuple(5);
+ Store_field(result, 0, Val_bool(info.online));
+ Store_field(result, 1, Val_bool(info.blocked));
+ Store_field(result, 2, Val_bool(info.running));
+ Store_field(result, 3, caml_copy_int64(info.cpu_time));
+ Store_field(result, 4, caml_copy_int32(info.cpu));
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_vcpu_context_get(value xc_handle, value domid,
+ value cpu)
+{
+ CAMLparam3(xc_handle, domid, cpu);
+ CAMLlocal1(context);
+ int ret;
+ struct vcpu_guest_context ctxt;
+
+ ret = xc_vcpu_getcontext(_H(xc_handle), _D(domid), Int_val(cpu), &ctxt);
+
+ context = caml_alloc_string(sizeof(ctxt));
+ memcpy(String_val(context), (char *) &ctxt, sizeof(ctxt));
+
+ CAMLreturn(context);
+}
+
+CAMLprim value stub_xc_vcpu_setaffinity(value xc_handle, value domid,
+ value vcpu, value cpumap)
+{
+ CAMLparam4(xc_handle, domid, vcpu, cpumap);
+ uint64_t c_cpumap;
+ int retval;
+
+ c_cpumap = Int64_val(cpumap);
+ retval = xc_vcpu_setaffinity(_H(xc_handle), _D(domid),
+ Int_val(vcpu), c_cpumap);
+ if (retval < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_vcpu_getaffinity(value xc_handle, value domid,
+ value vcpu)
+{
+ CAMLparam3(xc_handle, domid, vcpu);
+ CAMLlocal1(ret);
+ uint64_t cpumap;
+ int retval;
+
+ retval = xc_vcpu_getaffinity(_H(xc_handle), _D(domid),
+ Int_val(vcpu), &cpumap);
+ if (retval < 0)
+ failwith_xc();
+ ret = caml_copy_int64(cpumap);
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_xc_sched_id(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+ int sched_id;
+
+ if (xc_sched_id(_H(xc_handle), &sched_id))
+ failwith_xc();
+ CAMLreturn(Val_int(sched_id));
+}
+
+CAMLprim value stub_xc_evtchn_alloc_unbound(value xc_handle,
+ value local_domid,
+ value remote_domid)
+{
+ CAMLparam3(xc_handle, local_domid, remote_domid);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_local_domid = _D(local_domid);
+ uint32_t c_remote_domid = _D(remote_domid);
+
+ // caml_enter_blocking_section();
+ int result = xc_evtchn_alloc_unbound(c_xc_handle, c_local_domid,
+ c_remote_domid);
+ // caml_leave_blocking_section();
+
+ if (result < 0)
+ failwith_xc();
+ CAMLreturn(Val_int(result));
+}
+
+CAMLprim value stub_xc_evtchn_reset(value handle, value domid)
+{
+ CAMLparam2(handle, domid);
+ int r;
+
+ r = xc_evtchn_reset(_H(handle), _D(domid));
+ if (r < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+
+#define RING_SIZE 32768
+static char ring[RING_SIZE];
+
+CAMLprim value stub_xc_readconsolering(value xc_handle)
+{
+ unsigned int size = RING_SIZE;
+ char *ring_ptr = ring;
+
+ CAMLparam1(xc_handle);
+ int c_xc_handle = _H(xc_handle);
+
+ // caml_enter_blocking_section();
+ int retval = xc_readconsolering(c_xc_handle, &ring_ptr, &size, 0);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+ ring[size] = '\0';
+ CAMLreturn(caml_copy_string(ring));
+}
+
+CAMLprim value stub_xc_send_debug_keys(value xc_handle, value keys)
+{
+ CAMLparam2(xc_handle, keys);
+ int r;
+
+ r = xc_send_debug_keys(_H(xc_handle), String_val(keys));
+ if (r)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_physinfo(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+ CAMLlocal3(physinfo, cap_list, tmp);
+ xc_physinfo_t c_physinfo;
+ int r;
+
+ // caml_enter_blocking_section();
+ r = xc_physinfo(_H(xc_handle), &c_physinfo);
+ // caml_leave_blocking_section();
+
+ if (r)
+ failwith_xc();
+
+ tmp = cap_list = Val_emptylist;
+ for (r = 0; r < 2; r++) {
+ if ((c_physinfo.capabilities >> r) & 1) {
+ tmp = caml_alloc_small(2, Tag_cons);
+ Field(tmp, 0) = Val_int(r);
+ Field(tmp, 1) = cap_list;
+ cap_list = tmp;
+ }
+ }
+
+ physinfo = caml_alloc_tuple(9);
+ Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core));
+ Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket));
+ Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus));
+ Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id));
+ Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz));
+ Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages));
+ Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages));
+ Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages));
+ Store_field(physinfo, 8, cap_list);
+
+ CAMLreturn(physinfo);
+}
+
+CAMLprim value stub_xc_pcpu_info(value xc_handle, value nr_cpus)
+{
+ CAMLparam2(xc_handle, nr_cpus);
+ CAMLlocal2(pcpus, v);
+ uint64_t *info;
+ int r, size;
+
+ if (Int_val(nr_cpus) < 1)
+ caml_invalid_argument("nr_cpus");
+
+ info = calloc(Int_val(nr_cpus) + 1, sizeof(uint64_t));
+ if (!info)
+ caml_raise_out_of_memory();
+
+ // caml_enter_blocking_section();
+ r = xc_pcpu_info(_H(xc_handle), Int_val(nr_cpus), info, &size);
+ // caml_leave_blocking_section();
+
+ if (r) {
+ free(info);
+ failwith_xc();
+ }
+
+ if (size > 0) {
+ int i;
+ pcpus = caml_alloc(size, 0);
+ for (i = 0; i < size; i++) {
+ v = caml_copy_int64(info[i]);
+ caml_modify(&Field(pcpus, i), v);
+ }
+ } else
+ pcpus = Atom(0);
+ free(info);
+ CAMLreturn(pcpus);
+}
+
+CAMLprim value stub_xc_domain_setmaxmem(value xc_handle, value domid,
+ value max_memkb)
+{
+ CAMLparam3(xc_handle, domid, max_memkb);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ unsigned int c_max_memkb = Int64_val(max_memkb);
+ // caml_enter_blocking_section();
+ int retval = xc_domain_setmaxmem(c_xc_handle, c_domid,
+ c_max_memkb);
+ // caml_leave_blocking_section();
+ if (retval)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_memmap_limit(value xc_handle, value domid,
+ value map_limitkb)
+{
+ CAMLparam3(xc_handle, domid, map_limitkb);
+ unsigned long v;
+ int retval;
+
+ v = Int64_val(map_limitkb);
+ retval = xc_domain_set_memmap_limit(_H(xc_handle), _D(domid), v);
+ if (retval)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_memory_increase_reservation(value xc_handle,
+ value domid,
+ value mem_kb)
+{
+ CAMLparam3(xc_handle, domid, mem_kb);
+
+ unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (PAGE_SHIFT - 10);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ // caml_enter_blocking_section();
+ int retval = xc_domain_memory_increase_reservation(c_xc_handle, c_domid,
+ nr_extents, 0, 0, NULL);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_machine_address_size(value xc_handle,
+ value domid,
+ value width)
+{
+ CAMLparam3(xc_handle, domid, width);
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ int c_width = Int_val(width);
+
+ int retval = xc_domain_set_machine_address_size(c_xc_handle, c_domid, c_width);
+ if (retval)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_get_machine_address_size(value xc_handle,
+ value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ int retval;
+
+ retval = xc_domain_get_machine_address_size(_H(xc_handle), _D(domid));
+ if (retval < 0)
+ failwith_xc();
+ CAMLreturn(Val_int(retval));
+}
+
+CAMLprim value stub_xc_domain_cpuid_set(value xc_handle, value domid,
+ value is_hvm, value input,
+ value config)
+{
+ CAMLparam5(xc_handle, domid, is_hvm, input, config);
+ CAMLlocal2(array, tmp);
+ int r;
+ char *c_config[4], *out_config[4];
+ uint32_t c_input, c_oinput;
+
+ c_config[0] = string_of_option_array(config, 0);
+ c_config[1] = string_of_option_array(config, 1);
+ c_config[2] = string_of_option_array(config, 2);
+ c_config[3] = string_of_option_array(config, 3);
+
+ cpuid_input_of_val(c_input, c_oinput, input);
+
+ array = caml_alloc(4, 0);
+ for (r = 0; r < 4; r++) {
+ tmp = Val_none;
+ if (c_config[r]) {
+ tmp = caml_alloc_small(1, 0);
+ Field(tmp, 0) = caml_alloc_string(32);
+ }
+ Store_field(array, r, tmp);
+ }
+
+ for (r = 0; r < 4; r++)
+ out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL;
+
+ r = xc_domain_cpuid_set(_H(xc_handle), _D(domid), Bool_val(is_hvm),
+ c_input, c_oinput, c_config, out_config);
+ if (r < 0)
+ failwith_xc();
+ CAMLreturn(array);
+}
+
+CAMLprim value stub_xc_domain_cpuid_apply(value xc_handle, value domid, value is_hvm)
+{
+ CAMLparam3(xc_handle, domid, is_hvm);
+ int r;
+ r = xc_domain_cpuid_apply(_H(xc_handle), _D(domid), Bool_val(is_hvm));
+ if (r < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_cpuid_check(value input, value config)
+{
+ CAMLparam2(input, config);
+ CAMLlocal3(ret, array, tmp);
+ int r;
+ uint32_t c_input, c_oinput;
+ char *c_config[4], *out_config[4];
+
+ c_config[0] = string_of_option_array(config, 0);
+ c_config[1] = string_of_option_array(config, 1);
+ c_config[2] = string_of_option_array(config, 2);
+ c_config[3] = string_of_option_array(config, 3);
+
+ cpuid_input_of_val(c_input, c_oinput, input);
+
+ array = caml_alloc(4, 0);
+ for (r = 0; r < 4; r++) {
+ tmp = Val_none;
+ if (c_config[r]) {
+ tmp = caml_alloc_small(1, 0);
+ Field(tmp, 0) = caml_alloc_string(32);
+ }
+ Store_field(array, r, tmp);
+ }
+
+ for (r = 0; r < 4; r++)
+ out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL;
+
+ r = xc_cpuid_check(c_input, c_oinput, c_config, out_config);
+ if (r < 0)
+ failwith_xc();
+
+ ret = caml_alloc_tuple(2);
+ Store_field(ret, 0, Val_bool(r));
+ Store_field(ret, 1, array);
+
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_xc_version_version(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+ CAMLlocal1(result);
+ xen_extraversion_t extra;
+ long packed;
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ // caml_enter_blocking_section();
+ packed = xc_version(c_xc_handle, XENVER_version, NULL);
+ retval = xc_version(c_xc_handle, XENVER_extraversion, &extra);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+
+ result = caml_alloc_tuple(3);
+
+ Store_field(result, 0, Val_int(packed >> 16));
+ Store_field(result, 1, Val_int(packed & 0xffff));
+ Store_field(result, 2, caml_copy_string(extra));
+
+ CAMLreturn(result);
+}
+
+
+CAMLprim value stub_xc_version_compile_info(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+ CAMLlocal1(result);
+ xen_compile_info_t ci;
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ // caml_enter_blocking_section();
+ retval = xc_version(c_xc_handle, XENVER_compile_info, &ci);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+
+ result = caml_alloc_tuple(4);
+
+ Store_field(result, 0, caml_copy_string(ci.compiler));
+ Store_field(result, 1, caml_copy_string(ci.compile_by));
+ Store_field(result, 2, caml_copy_string(ci.compile_domain));
+ Store_field(result, 3, caml_copy_string(ci.compile_date));
+
+ CAMLreturn(result);
+}
+
+
+static value xc_version_single_string(value xc_handle, int code, void *info)
+{
+ CAMLparam1(xc_handle);
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ // caml_enter_blocking_section();
+ retval = xc_version(c_xc_handle, code, info);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+
+ CAMLreturn(caml_copy_string((char *)info));
+}
+
+
+CAMLprim value stub_xc_version_changeset(value xc_handle)
+{
+ xen_changeset_info_t ci;
+
+ return xc_version_single_string(xc_handle, XENVER_changeset, &ci);
+}
+
+
+CAMLprim value stub_xc_version_capabilities(value xc_handle)
+{
+ xen_capabilities_info_t ci;
+
+ return xc_version_single_string(xc_handle, XENVER_capabilities, &ci);
+}
+
+
+CAMLprim value stub_pages_to_kib(value pages)
+{
+ CAMLparam1(pages);
+
+ CAMLreturn(caml_copy_int64(Int64_val(pages) << (PAGE_SHIFT - 10)));
+}
+
+
+CAMLprim value stub_map_foreign_range(value xc_handle, value dom,
+ value size, value mfn)
+{
+ CAMLparam4(xc_handle, dom, size, mfn);
+ CAMLlocal1(result);
+ struct mmap_interface *intf;
+
+ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
+ intf = (struct mmap_interface *) result;
+
+ intf->len = Int_val(size);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_dom = _D(dom);
+ unsigned long c_mfn = Nativeint_val(mfn);
+ // caml_enter_blocking_section();
+ intf->addr = xc_map_foreign_range(c_xc_handle, c_dom,
+ intf->len, PROT_READ|PROT_WRITE,
+ c_mfn);
+ // caml_leave_blocking_section();
+ if (!intf->addr)
+ caml_failwith("xc_map_foreign_range error");
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_sched_credit_domain_get(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ CAMLlocal1(sdom);
+ struct xen_domctl_sched_credit c_sdom;
+ int ret;
+
+ // caml_enter_blocking_section();
+ ret = xc_sched_credit_domain_get(_H(xc_handle), _D(domid), &c_sdom);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc();
+
+ sdom = caml_alloc_tuple(2);
+ Store_field(sdom, 0, Val_int(c_sdom.weight));
+ Store_field(sdom, 1, Val_int(c_sdom.cap));
+
+ CAMLreturn(sdom);
+}
+
+CAMLprim value stub_sched_credit_domain_set(value xc_handle, value domid,
+ value sdom)
+{
+ CAMLparam3(xc_handle, domid, sdom);
+ struct xen_domctl_sched_credit c_sdom;
+ int ret;
+
+ c_sdom.weight = Int_val(Field(sdom, 0));
+ c_sdom.cap = Int_val(Field(sdom, 1));
+ // caml_enter_blocking_section();
+ ret = xc_sched_credit_domain_set(_H(xc_handle), _D(domid), &c_sdom);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_shadow_allocation_get(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ CAMLlocal1(mb);
+ uint32_t c_mb;
+ int ret;
+
+ // caml_enter_blocking_section();
+ ret = xc_shadow_allocation_get(_H(xc_handle), _D(domid), &c_mb);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc();
+
+ mb = Val_int(c_mb);
+ CAMLreturn(mb);
+}
+
+CAMLprim value stub_shadow_allocation_set(value xc_handle, value domid,
+ value mb)
+{
+ CAMLparam3(xc_handle, domid, mb);
+ uint32_t c_mb;
+ int ret;
+
+ c_mb = Int_val(mb);
+ // caml_enter_blocking_section();
+ ret = xc_shadow_allocation_set(_H(xc_handle), _D(domid), c_mb);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_get_pfn_list(value xc_handle, value domid,
+ value nr_pfns)
+{
+ CAMLparam3(xc_handle, domid, nr_pfns);
+ CAMLlocal2(array, v);
+ unsigned long c_nr_pfns;
+ long ret, i;
+ xen_pfn_t *c_array;
+
+ c_nr_pfns = Nativeint_val(nr_pfns);
+
+ c_array = malloc(sizeof(xen_pfn_t) * c_nr_pfns);
+ if (!c_array)
+ caml_raise_out_of_memory();
+
+ ret = xc_domain_get_pfn_list(_H(xc_handle), _D(domid),
+ c_array, c_nr_pfns);
+ if (ret < 0) {
+ free(c_array);
+ failwith_xc();
+ }
+
+ array = caml_alloc(ret, 0);
+ for (i = 0; i < ret; i++) {
+ v = caml_copy_nativeint(c_array[i]);
+ Store_field(array, i, v);
+ }
+ free(c_array);
+
+ CAMLreturn(array);
+}
+
+CAMLprim value stub_xc_domain_ioport_permission(value xc_handle, value domid,
+ value start_port, value nr_ports,
+ value allow)
+{
+ CAMLparam5(xc_handle, domid, start_port, nr_ports, allow);
+ uint32_t c_start_port, c_nr_ports;
+ uint8_t c_allow;
+ int ret;
+
+ c_start_port = Int_val(start_port);
+ c_nr_ports = Int_val(nr_ports);
+ c_allow = Bool_val(allow);
+
+ ret = xc_domain_ioport_permission(_H(xc_handle), _D(domid),
+ c_start_port, c_nr_ports, c_allow);
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_iomem_permission(value xc_handle, value domid,
+ value start_pfn, value nr_pfns,
+ value allow)
+{
+ CAMLparam5(xc_handle, domid, start_pfn, nr_pfns, allow);
+ unsigned long c_start_pfn, c_nr_pfns;
+ uint8_t c_allow;
+ int ret;
+
+ c_start_pfn = Nativeint_val(start_pfn);
+ c_nr_pfns = Nativeint_val(nr_pfns);
+ c_allow = Bool_val(allow);
+
+ ret = xc_domain_iomem_permission(_H(xc_handle), _D(domid),
+ c_start_pfn, c_nr_pfns, c_allow);
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_irq_permission(value xc_handle, value domid,
+ value pirq, value allow)
+{
+ CAMLparam4(xc_handle, domid, pirq, allow);
+ uint8_t c_pirq;
+ uint8_t c_allow;
+ int ret;
+
+ c_pirq = Int_val(pirq);
+ c_allow = Bool_val(allow);
+
+ ret = xc_domain_irq_permission(_H(xc_handle), _D(domid),
+ c_pirq, c_allow);
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_hvm_check_pvdriver(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ int ret;
+
+ ret = xc_hvm_check_pvdriver(_H(xc_handle), _D(domid));
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_bool(ret));
+}
+
+CAMLprim value stub_xc_domain_test_assign_device(value xc_handle, value domid, value desc)
+{
+ CAMLparam3(xc_handle, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+
+ ret = xc_domain_test_assign_device(_H(xc_handle), _D(domid),
+ domain, bus, slot, func);
+ CAMLreturn(Val_bool(ret == 0));
+}
+
+CAMLprim value stub_xc_domain_assign_device(value xc_handle, value domid, value desc)
+{
+ CAMLparam3(xc_handle, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+
+ ret = xc_domain_assign_device(_H(xc_handle), _D(domid),
+ domain, bus, slot, func);
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_deassign_device(value xc_handle, value domid, value desc)
+{
+ CAMLparam3(xc_handle, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+
+ ret = xc_domain_deassign_device(_H(xc_handle), _D(domid),
+ domain, bus, slot, func);
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_timer_mode(value handle, value id, value mode)
+{
+ CAMLparam3(handle, id, mode);
+ int ret;
+
+ ret = xc_domain_set_timer_mode(_H(handle), _D(id), Int_val(mode));
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_hpet(value handle, value id, value mode)
+{
+ CAMLparam3(handle, id, mode);
+ int ret;
+
+ ret = xc_domain_set_hpet(_H(handle), _D(id), Int_val(mode));
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_vpt_align(value handle, value id, value mode)
+{
+ CAMLparam3(handle, id, mode);
+ int ret;
+
+ ret = xc_domain_set_vpt_align(_H(handle), _D(id), Int_val(mode));
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_watchdog(value handle, value domid, value timeout)
+{
+ CAMLparam3(handle, domid, timeout);
+ int ret;
+ unsigned int c_timeout = Int32_val(timeout);
+
+ ret = xc_domain_watchdog(_H(handle), _D(domid), c_timeout);
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_int(ret));
+}
+
+CAMLprim value stub_xc_domain_send_s3resume(value handle, value domid)
+{
+ CAMLparam2(handle, domid);
+ xc_domain_send_s3resume(_H(handle), _D(domid));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_get_acpi_s_state(value handle, value domid)
+{
+ CAMLparam2(handle, domid);
+ int ret;
+
+ ret = xc_domain_get_acpi_s_state(_H(handle), _D(domid));
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_int(ret));
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
[-- Attachment #3: Type: text/plain, Size: 138 bytes --]
_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xensource.com
http://lists.xensource.com/xen-devel
^ permalink raw reply related [flat|nested] 12+ messages in thread* [PATCH 06/10] add ocaml xenstored
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
` (4 preceding siblings ...)
2010-03-09 14:41 ` [PATCH 05/10] add logs " Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 07/10] add compilation makefile to ocaml directory Vincent Hanquez
` (3 subsequent siblings)
9 siblings, 0 replies; 12+ messages in thread
From: Vincent Hanquez @ 2010-03-09 14:41 UTC (permalink / raw)
To: xen-devel; +Cc: Vincent Hanquez
[-- Attachment #1: Type: text/plain, Size: 2488 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/xenstored/Makefile | 54 ++++
tools/ocaml/xenstored/config.ml | 112 ++++++++
tools/ocaml/xenstored/connection.ml | 234 +++++++++++++++++
tools/ocaml/xenstored/connections.ml | 167 ++++++++++++
tools/ocaml/xenstored/define.ml | 40 +++
tools/ocaml/xenstored/disk.ml | 157 ++++++++++++
tools/ocaml/xenstored/domain.ml | 62 +++++
tools/ocaml/xenstored/domains.ml | 84 ++++++
tools/ocaml/xenstored/event.ml | 29 +++
tools/ocaml/xenstored/logging.ml | 239 ++++++++++++++++++
tools/ocaml/xenstored/parse_arg.ml | 68 +++++
tools/ocaml/xenstored/perms.ml | 167 ++++++++++++
tools/ocaml/xenstored/process.ml | 396 +++++++++++++++++++++++++++++
tools/ocaml/xenstored/quota.ml | 83 ++++++
tools/ocaml/xenstored/store.ml | 461 ++++++++++++++++++++++++++++++++++
tools/ocaml/xenstored/symbol.ml | 76 ++++++
tools/ocaml/xenstored/symbol.mli | 52 ++++
tools/ocaml/xenstored/transaction.ml | 198 +++++++++++++++
tools/ocaml/xenstored/utils.ml | 107 ++++++++
tools/ocaml/xenstored/xenstored.conf | 30 +++
tools/ocaml/xenstored/xenstored.ml | 404 +++++++++++++++++++++++++++++
21 files changed, 3220 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/xenstored/Makefile
create mode 100644 tools/ocaml/xenstored/config.ml
create mode 100644 tools/ocaml/xenstored/connection.ml
create mode 100644 tools/ocaml/xenstored/connections.ml
create mode 100644 tools/ocaml/xenstored/define.ml
create mode 100644 tools/ocaml/xenstored/disk.ml
create mode 100644 tools/ocaml/xenstored/domain.ml
create mode 100644 tools/ocaml/xenstored/domains.ml
create mode 100644 tools/ocaml/xenstored/event.ml
create mode 100644 tools/ocaml/xenstored/logging.ml
create mode 100644 tools/ocaml/xenstored/parse_arg.ml
create mode 100644 tools/ocaml/xenstored/perms.ml
create mode 100644 tools/ocaml/xenstored/process.ml
create mode 100644 tools/ocaml/xenstored/quota.ml
create mode 100644 tools/ocaml/xenstored/store.ml
create mode 100644 tools/ocaml/xenstored/symbol.ml
create mode 100644 tools/ocaml/xenstored/symbol.mli
create mode 100644 tools/ocaml/xenstored/transaction.ml
create mode 100644 tools/ocaml/xenstored/utils.ml
create mode 100644 tools/ocaml/xenstored/xenstored.conf
create mode 100644 tools/ocaml/xenstored/xenstored.ml
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0006-add-ocaml-xenstored.patch --]
[-- Type: text/x-patch; name="0006-add-ocaml-xenstored.patch", Size: 107992 bytes --]
diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile
new file mode 100644
index 0000000..1af6368
--- /dev/null
+++ b/tools/ocaml/xenstored/Makefile
@@ -0,0 +1,54 @@
+OCAML_TOPLEVEL = ..
+include $(OCAML_TOPLEVEL)/common.make
+
+OCAMLINCLUDE += \
+ -I $(OCAML_TOPLEVEL)/libs/log \
+ -I $(OCAML_TOPLEVEL)/libs/xb \
+ -I $(OCAML_TOPLEVEL)/libs/uuid \
+ -I $(OCAML_TOPLEVEL)/libs/mmap \
+ -I $(OCAML_TOPLEVEL)/libs/xc \
+ -I $(OCAML_TOPLEVEL)/libs/eventchn
+
+OBJS = define \
+ stdext \
+ trie \
+ config \
+ logging \
+ quota \
+ perms \
+ symbol \
+ utils \
+ store \
+ disk \
+ transaction \
+ event \
+ domain \
+ domains \
+ connection \
+ connections \
+ parse_arg \
+ process \
+ xenstored
+
+INTF = symbol.cmi trie.cmi
+XENSTOREDLIBS = \
+ unix.cmxa \
+ $(OCAML_TOPLEVEL)/libs/uuid/uuid.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/mmap.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/log $(OCAML_TOPLEVEL)/libs/log/log.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/eventchn.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xc.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xb.cmxa
+
+PROGRAMS = oxenstored
+
+oxenstored_LIBS = $(XENSTOREDLIBS)
+oxenstored_OBJS = $(OBJS)
+
+OCAML_PROGRAM = oxenstored
+
+all: $(INTF) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+include $(OCAML_TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/xenstored/config.ml b/tools/ocaml/xenstored/config.ml
new file mode 100644
index 0000000..0ee7bc3
--- /dev/null
+++ b/tools/ocaml/xenstored/config.ml
@@ -0,0 +1,112 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type ty =
+ | Set_bool of bool ref
+ | Set_int of int ref
+ | Set_string of string ref
+ | Set_float of float ref
+ | Unit of (unit -> unit)
+ | Bool of (bool -> unit)
+ | Int of (int -> unit)
+ | String of (string -> unit)
+ | Float of (float -> unit)
+
+exception Error of (string * string) list
+
+let trim_start lc s =
+ let len = String.length s and i = ref 0 in
+ while !i < len && (List.mem s.[!i] lc)
+ do
+ incr i
+ done;
+ if !i < len then String.sub s !i (len - !i) else ""
+
+let trim_end lc s =
+ let i = ref (String.length s - 1) in
+ while !i > 0 && (List.mem s.[!i] lc)
+ do
+ decr i
+ done;
+ if !i >= 0 then String.sub s 0 (!i + 1) else ""
+
+let rec split ?limit:(limit=(-1)) c s =
+ let i = try String.index s c with Not_found -> -1 in
+ let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in
+ if i = -1 || nlimit = 0 then
+ [ s ]
+ else
+ let a = String.sub s 0 i
+ and b = String.sub s (i + 1) (String.length s - i - 1) in
+ a :: (split ~limit: nlimit c b)
+
+let parse_line stream =
+ let lc = [ ' '; '\t' ] in
+ let trim_spaces s = trim_end lc (trim_start lc s) in
+ let to_config s =
+ match split ~limit:2 '=' s with
+ | k :: v :: [] -> Some (trim_end lc k, trim_start lc v)
+ | _ -> None in
+ let rec read_filter_line () =
+ try
+ let line = trim_spaces (input_line stream) in
+ if String.length line > 0 && line.[0] <> '#' then
+ match to_config line with
+ | None -> read_filter_line ()
+ | Some x -> x :: read_filter_line ()
+ else
+ read_filter_line ()
+ with
+ End_of_file -> [] in
+ read_filter_line ()
+
+let parse filename =
+ let stream = open_in filename in
+ let cf = parse_line stream in
+ close_in stream;
+ cf
+
+let validate cf expected other =
+ let err = ref [] in
+ let append x = err := x :: !err in
+ List.iter (fun (k, v) ->
+ try
+ if not (List.mem_assoc k expected) then
+ other k v
+ else let ty = List.assoc k expected in
+ match ty with
+ | Unit f -> f ()
+ | Bool f -> f (bool_of_string v)
+ | String f -> f v
+ | Int f -> f (int_of_string v)
+ | Float f -> f (float_of_string v)
+ | Set_bool r -> r := (bool_of_string v)
+ | Set_string r -> r := v
+ | Set_int r -> r := int_of_string v
+ | Set_float r -> r := (float_of_string v)
+ with
+ | Not_found -> append (k, "unknown key")
+ | Failure "int_of_string" -> append (k, "expect int arg")
+ | Failure "bool_of_string" -> append (k, "expect bool arg")
+ | Failure "float_of_string" -> append (k, "expect float arg")
+ | exn -> append (k, Printexc.to_string exn)
+ ) cf;
+ if !err != [] then raise (Error !err)
+
+(** read a filename, parse and validate, and return the errors if any *)
+let read filename expected other =
+ let cf = parse filename in
+ validate cf expected other
diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml
new file mode 100644
index 0000000..70cdbbf
--- /dev/null
+++ b/tools/ocaml/xenstored/connection.ml
@@ -0,0 +1,234 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+exception End_of_file
+
+open Stdext
+
+type watch = {
+ con: t;
+ token: string;
+ path: string;
+ base: string;
+ is_relative: bool;
+}
+
+and t = {
+ xb: Xb.t;
+ dom: Domain.t option;
+ transactions: (int, Transaction.t) Hashtbl.t;
+ mutable next_tid: int;
+ watches: (string, watch list) Hashtbl.t;
+ mutable nb_watches: int;
+ anonid: int;
+ mutable stat_nb_ops: int;
+ mutable perm: Perms.Connection.t;
+}
+
+let get_path con =
+Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d)
+
+let watch_create ~con ~path ~token = {
+ con = con;
+ token = token;
+ path = path;
+ base = get_path con;
+ is_relative = path.[0] <> '/' && path.[0] <> '@'
+}
+
+let get_con w = w.con
+
+let number_of_transactions con =
+ Hashtbl.length con.transactions
+
+let get_domain con = con.dom
+
+let anon_id_next = ref 1
+
+let get_domstr con =
+ match con.dom with
+ | None -> "A" ^ (string_of_int con.anonid)
+ | Some dom -> "D" ^ (string_of_int (Domain.get_id dom))
+
+let make_perm dom =
+ let domid =
+ match dom with
+ | None -> 0
+ | Some d -> Domain.get_id d
+ in
+ Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid
+
+let create xbcon dom =
+ let id =
+ match dom with
+ | None -> let old = !anon_id_next in incr anon_id_next; old
+ | Some _ -> 0
+ in
+ let con =
+ {
+ xb = xbcon;
+ dom = dom;
+ transactions = Hashtbl.create 5;
+ next_tid = 1;
+ watches = Hashtbl.create 8;
+ nb_watches = 0;
+ anonid = id;
+ stat_nb_ops = 0;
+ perm = make_perm dom;
+ }
+ in
+ Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con);
+ con
+
+let get_fd con = Xb.get_fd con.xb
+let close con =
+ Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con);
+ Xb.close con.xb
+
+let get_perm con =
+ con.perm
+
+let restrict con domid =
+ con.perm <- Perms.Connection.restrict con.perm domid
+
+let set_target con target_domid =
+ con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid
+
+let send_reply con tid rid ty data =
+ Xb.queue con.xb (Xb.Packet.create tid rid ty data)
+
+let send_error con tid rid err = send_reply con tid rid Xb.Op.Error (err ^ "\000")
+let send_ack con tid rid ty = send_reply con tid rid ty "OK\000"
+
+let get_watch_path con path =
+ if path.[0] = '@' || path.[0] = '/' then
+ path
+ else
+ let rpath = get_path con in
+ rpath ^ path
+
+let get_watches (con: t) path =
+ if Hashtbl.mem con.watches path
+ then Hashtbl.find con.watches path
+ else []
+
+let get_children_watches con path =
+ let path = path ^ "/" in
+ List.concat (Hashtbl.fold (fun p w l ->
+ if String.startswith path p then w :: l else l) con.watches [])
+
+let is_dom0 con =
+ Perms.Connection.is_dom0 (get_perm con)
+
+let add_watch con path token =
+ if !Quota.activate && !Define.maxwatch > 0 &&
+ not (is_dom0 con) && con.nb_watches > !Define.maxwatch then
+ raise Quota.Limit_reached;
+ let apath = get_watch_path con path in
+ let l = get_watches con apath in
+ if List.exists (fun w -> w.token = token) l then
+ raise Define.Already_exist;
+ let watch = watch_create ~con ~token ~path in
+ Hashtbl.replace con.watches apath (watch :: l);
+ con.nb_watches <- con.nb_watches + 1;
+ apath, watch
+
+let del_watch con path token =
+ let apath = get_watch_path con path in
+ let ws = Hashtbl.find con.watches apath in
+ let w = List.find (fun w -> w.token = token) ws in
+ let filtered = Utils.list_remove w ws in
+ if List.length filtered > 0 then
+ Hashtbl.replace con.watches apath filtered
+ else
+ Hashtbl.remove con.watches apath;
+ con.nb_watches <- con.nb_watches - 1;
+ apath, w
+
+let list_watches con =
+ let ll = Hashtbl.fold
+ (fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc)
+ con.watches [] in
+ List.concat ll
+
+let fire_single_watch watch =
+ let data = Utils.join_by_null [watch.path; watch.token; ""] in
+ send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
+
+let fire_watch watch path =
+ let new_path =
+ if watch.is_relative && path.[0] = '/'
+ then begin
+ let n = String.length watch.base
+ and m = String.length path in
+ String.sub path n (m - n)
+ end else
+ path
+ in
+ let data = Utils.join_by_null [ new_path; watch.token; "" ] in
+ send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
+
+let find_next_tid con =
+ let ret = con.next_tid in con.next_tid <- con.next_tid + 1; ret
+
+let start_transaction con store =
+ if !Define.maxtransaction > 0 && not (is_dom0 con)
+ && Hashtbl.length con.transactions > !Define.maxtransaction then
+ raise Quota.Transaction_opened;
+ let id = find_next_tid con in
+ let ntrans = Transaction.make id store in
+ Hashtbl.add con.transactions id ntrans;
+ Logging.start_transaction ~tid:id ~con:(get_domstr con);
+ id
+
+let end_transaction con tid commit =
+ let trans = Hashtbl.find con.transactions tid in
+ Hashtbl.remove con.transactions tid;
+ Logging.end_transaction ~tid ~con:(get_domstr con);
+ if commit then Transaction.commit ~con:(get_domstr con) trans else true
+
+let get_transaction con tid =
+ Hashtbl.find con.transactions tid
+
+let do_input con = Xb.input con.xb
+let has_input con = Xb.has_in_packet con.xb
+let pop_in con = Xb.get_in_packet con.xb
+let has_more_input con = Xb.has_more_input con.xb
+
+let has_output con = Xb.has_output con.xb
+let has_new_output con = Xb.has_new_output con.xb
+let peek_output con = Xb.peek_output con.xb
+let do_output con = Xb.output con.xb
+
+let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
+
+let mark_symbols con =
+ Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t)) con.transactions
+
+let stats con =
+ Hashtbl.length con.watches, con.stat_nb_ops
+
+let dump con chan =
+ match con.dom with
+ | Some dom ->
+ let domid = Domain.get_id dom in
+ (* dump domain *)
+ Domain.dump dom chan;
+ (* dump watches *)
+ List.iter (fun (path, token) ->
+ Printf.fprintf chan "watch,%d,%s,%s\n" domid (Utils.hexify path) (Utils.hexify token)
+ ) (list_watches con);
+ | None -> ()
diff --git a/tools/ocaml/xenstored/connections.ml b/tools/ocaml/xenstored/connections.ml
new file mode 100644
index 0000000..c331bab
--- /dev/null
+++ b/tools/ocaml/xenstored/connections.ml
@@ -0,0 +1,167 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+let debug fmt = Logs.debug "general" fmt
+
+type t = {
+ mutable anonymous: Connection.t list;
+ domains: (int, Connection.t) Hashtbl.t;
+ mutable watches: (string, Connection.watch list) Trie.t;
+}
+
+let create () = { anonymous = []; domains = Hashtbl.create 8; watches = Trie.create () }
+
+let add_anonymous cons fd can_write =
+ let xbcon = Xb.open_fd fd in
+ let con = Connection.create xbcon None in
+ cons.anonymous <- con :: cons.anonymous
+
+let add_domain cons dom =
+ let xbcon = Xb.open_mmap (Domain.get_interface dom) (fun () -> Domain.notify dom) in
+ let con = Connection.create xbcon (Some dom) in
+ Hashtbl.add cons.domains (Domain.get_id dom) con
+
+let select cons =
+ let inset = List.map (fun c -> Connection.get_fd c) cons.anonymous
+ and outset = List.fold_left (fun l c -> if Connection.has_output c
+ then Connection.get_fd c :: l
+ else l) [] cons.anonymous in
+ inset, outset
+
+let find cons fd =
+ List.find (fun c -> Connection.get_fd c = fd) cons.anonymous
+
+let find_domain cons id =
+ Hashtbl.find cons.domains id
+
+let del_watches_of_con con watches =
+ match List.filter (fun w -> Connection.get_con w != con) watches with
+ | [] -> None
+ | ws -> Some ws
+
+let del_anonymous cons con =
+ try
+ cons.anonymous <- Utils.list_remove con cons.anonymous;
+ cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
+ Connection.close con
+ with exn ->
+ debug "del anonymous %s" (Printexc.to_string exn)
+
+let del_domain cons id =
+ try
+ let con = find_domain cons id in
+ Hashtbl.remove cons.domains id;
+ cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
+ Connection.close con
+ with exn ->
+ debug "del domain %u: %s" id (Printexc.to_string exn)
+
+let iter_domains cons fct =
+ Hashtbl.iter (fun k c -> fct c) cons.domains
+
+let iter_anonymous cons fct =
+ List.iter (fun c -> fct c) (List.rev cons.anonymous)
+
+let iter cons fct =
+ iter_domains cons fct; iter_anonymous cons fct
+
+let has_more_work cons =
+ Hashtbl.fold (fun id con acc ->
+ if Connection.has_more_input con then
+ con :: acc
+ else
+ acc) cons.domains []
+
+let key_of_str path =
+ if path.[0] = '@'
+ then [path]
+ else "" :: Store.Path.to_string_list (Store.Path.of_string path)
+
+let key_of_path path =
+ "" :: Store.Path.to_string_list path
+
+let add_watch cons con path token =
+ let apath, watch = Connection.add_watch con path token in
+ let key = key_of_str apath in
+ let watches =
+ if Trie.mem cons.watches key
+ then Trie.find cons.watches key
+ else []
+ in
+ cons.watches <- Trie.set cons.watches key (watch :: watches);
+ watch
+
+let del_watch cons con path token =
+ let apath, watch = Connection.del_watch con path token in
+ let key = key_of_str apath in
+ let watches = Utils.list_remove watch (Trie.find cons.watches key) in
+ if watches = [] then
+ cons.watches <- Trie.unset cons.watches key
+ else
+ cons.watches <- Trie.set cons.watches key watches;
+ watch
+
+(* path is absolute *)
+let fire_watches cons path recurse =
+ let key = key_of_path path in
+ let path = Store.Path.to_string path in
+ let fire_watch _ = function
+ | None -> ()
+ | Some watches -> List.iter (fun w -> Connection.fire_watch w path) watches
+ in
+ let fire_rec x = function
+ | None -> ()
+ | Some watches ->
+ List.iter (fun w -> Connection.fire_single_watch w) watches
+ in
+ Trie.iter_path fire_watch cons.watches key;
+ if recurse then
+ Trie.iter fire_rec (Trie.sub cons.watches key)
+
+let fire_spec_watches cons specpath =
+ iter cons (fun con ->
+ List.iter (fun w -> Connection.fire_single_watch w) (Connection.get_watches con specpath))
+
+let set_target cons domain target_domain =
+ let con = find_domain cons domain in
+ Connection.set_target con target_domain
+
+let number_of_transactions cons =
+ let res = ref 0 in
+ let aux con =
+ res := Connection.number_of_transactions con + !res
+ in
+ iter cons aux;
+ !res
+
+let stats cons =
+ let nb_ops_anon = ref 0
+ and nb_watchs_anon = ref 0
+ and nb_ops_dom = ref 0
+ and nb_watchs_dom = ref 0 in
+ iter_anonymous cons (fun con ->
+ let con_watchs, con_ops = Connection.stats con in
+ nb_ops_anon := !nb_ops_anon + con_ops;
+ nb_watchs_anon := !nb_watchs_anon + con_watchs;
+ );
+ iter_domains cons (fun con ->
+ let con_watchs, con_ops = Connection.stats con in
+ nb_ops_dom := !nb_ops_dom + con_ops;
+ nb_watchs_dom := !nb_watchs_dom + con_watchs;
+ );
+ (List.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
+ Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)
diff --git a/tools/ocaml/xenstored/define.ml b/tools/ocaml/xenstored/define.ml
new file mode 100644
index 0000000..19a699f
--- /dev/null
+++ b/tools/ocaml/xenstored/define.ml
@@ -0,0 +1,40 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+let xenstored_major = 1
+let xenstored_minor = 0
+
+let xenstored_proc_kva = "/proc/xen/xsd_kva"
+let xenstored_proc_port = "/proc/xen/xsd_port"
+
+let xs_daemon_socket = "/var/run/xenstored/socket"
+let xs_daemon_socket_ro = "/var/run/xenstored/socket_ro"
+
+let default_config_dir = "/etc/xensource"
+
+let maxwatch = ref (50)
+let maxtransaction = ref (20)
+
+let domid_self = 0x7FF0
+
+exception Not_a_directory of string
+exception Not_a_value of string
+exception Already_exist
+exception Doesnt_exist
+exception Lookup_Doesnt_exist of string
+exception Invalid_path
+exception Permission_denied
+exception Unknown_operation
diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml
new file mode 100644
index 0000000..65dd42a
--- /dev/null
+++ b/tools/ocaml/xenstored/disk.ml
@@ -0,0 +1,157 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+let enable = ref false
+let xs_daemon_database = "/var/run/xenstored/db"
+
+let error = Logs.error "general"
+
+(* unescape utils *)
+exception Bad_escape
+
+let is_digit c = match c with '0' .. '9' -> true | _ -> false
+
+let undec c =
+ match c with
+ | '0' .. '9' -> (Char.code c) - (Char.code '0')
+ | _ -> raise (Failure "undecify")
+
+let unhex c =
+ let c = Char.lowercase c in
+ match c with
+ | '0' .. '9' -> (Char.code c) - (Char.code '0')
+ | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10
+ | _ -> raise (Failure "unhexify")
+
+let string_unescaped s =
+ let len = String.length s
+ and i = ref 0 in
+ let d = Buffer.create len in
+
+ let read_escape () =
+ incr i;
+ match s.[!i] with
+ | 'n' -> '\n'
+ | 'r' -> '\r'
+ | '\\' -> '\\'
+ | '\'' -> '\''
+ | '"' -> '"'
+ | 't' -> '\t'
+ | 'b' -> '\b'
+ | 'x' ->
+ let v = (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in
+ i := !i + 2;
+ Char.chr v
+ | c ->
+ if is_digit c then (
+ let v = (undec s.[!i]) * 100 +
+ (undec s.[!i + 1]) * 10 +
+ (undec s.[!i + 2]) in
+ i := !i + 2;
+ Char.chr v
+ ) else
+ raise Bad_escape
+ in
+
+ while !i < len
+ do
+ let c = match s.[!i] with
+ | '\\' -> read_escape ()
+ | c -> c in
+ Buffer.add_char d c;
+ incr i
+ done;
+ Buffer.contents d
+
+(* file -> lines_of_file *)
+let file_readlines file =
+ let channel = open_in file in
+ let rec input_line_list channel =
+ let line = try input_line channel with End_of_file -> "" in
+ if String.length line > 0 then
+ line :: input_line_list channel
+ else (
+ close_in channel;
+ []
+ ) in
+ input_line_list channel
+
+let rec map_string_list_range l s =
+ match l with
+ | [] -> []
+ | (a,b) :: l -> String.sub s a (b - a) :: map_string_list_range l s
+
+let is_digit c =
+ try ignore (int_of_char c); true with _ -> false
+
+let rec parse_perm s =
+ let len = String.length s in
+ if len = 0 then
+ []
+ else
+ let i = ref 1 in
+ while !i < len && is_digit s.[!i] do incr i done;
+ let x = String.sub s 0 !i
+ and lx = String.sub s !i len in
+ x :: parse_perm lx
+
+let read store =
+ (* don't let the permission get on our way, full perm ! *)
+ let v = Store.get_ops store Perms.Connection.full_rights in
+
+ (* a line is : path{perm} or path{perm} = value *)
+ let parse_line s =
+ let path, perm, value =
+ let len = String.length s in
+ let si = if String.contains s '=' then
+ String.index s '='
+ else
+ len - 1 in
+ let pi = String.rindex_from s si '{' in
+ let epi = String.index_from s pi '}' in
+
+ if String.contains s '=' then
+ let ss = map_string_list_range [ (0, pi);
+ (pi + 1, epi);
+ (si + 2, len); ] s in
+ (List.nth ss 0, List.nth ss 1, List.nth ss 2)
+ else
+ let ss = map_string_list_range [ (0, pi);
+ (pi + 1, epi);
+ ] s in
+ (List.nth ss 0, List.nth ss 1, "")
+ in
+ let path = Store.Path.of_string path in
+ v.Store.write path (string_unescaped value);
+ v.Store.setperms path (Perms.Node.of_strings (parse_perm perm)) in
+ try
+ let lines = file_readlines xs_daemon_database in
+ List.iter (fun s -> parse_line s) lines
+ with exc ->
+ error "caught exn %s" (Printexc.to_string exc)
+
+let write store =
+ if !enable then
+ try
+ let tfile = Printf.sprintf "%s#" xs_daemon_database in
+ let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ]
+ 0o600 tfile in
+ Store.dump store channel;
+ flush channel;
+ close_out channel;
+ Unix.rename tfile xs_daemon_database
+ with exc ->
+ error "caught exn %s" (Printexc.to_string exc)
diff --git a/tools/ocaml/xenstored/domain.ml b/tools/ocaml/xenstored/domain.ml
new file mode 100644
index 0000000..258d172
--- /dev/null
+++ b/tools/ocaml/xenstored/domain.ml
@@ -0,0 +1,62 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+open Printf
+
+let debug fmt = Logs.debug "general" fmt
+
+type t =
+{
+ id: Xc.domid;
+ mfn: nativeint;
+ remote_port: int;
+ interface: Mmap.mmap_interface;
+ eventchn: Event.t;
+ mutable port: int;
+}
+
+let get_path dom = "/local/domain/" ^ (sprintf "%u" dom.id)
+let get_id domain = domain.id
+let get_interface d = d.interface
+let get_mfn d = d.mfn
+let get_remote_port d = d.remote_port
+
+let dump d chan =
+ fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.port
+
+let notify dom = Event.notify dom.eventchn dom.port; ()
+
+let bind_interdomain dom =
+ dom.port <- Event.bind_interdomain dom.eventchn dom.id dom.remote_port;
+ debug "domain %d bound port %d" dom.id dom.port
+
+
+let close dom =
+ debug "domain %d unbound port %d" dom.id dom.port;
+ Event.unbind dom.eventchn dom.port;
+ Mmap.unmap dom.interface;
+ ()
+
+let make id mfn remote_port interface eventchn = {
+ id = id;
+ mfn = mfn;
+ remote_port = remote_port;
+ interface = interface;
+ eventchn = eventchn;
+ port = -1
+}
+
+let is_dom0 d = d.id = 0
diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domains.ml
new file mode 100644
index 0000000..54d50d8
--- /dev/null
+++ b/tools/ocaml/xenstored/domains.ml
@@ -0,0 +1,84 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type domains = {
+ eventchn: Event.t;
+ table: (Xc.domid, Domain.t) Hashtbl.t;
+}
+
+let init eventchn =
+ { eventchn = eventchn; table = Hashtbl.create 10 }
+let del doms id = Hashtbl.remove doms.table id
+let exist doms id = Hashtbl.mem doms.table id
+let find doms id = Hashtbl.find doms.table id
+let number doms = Hashtbl.length doms.table
+let iter doms fct = Hashtbl.iter (fun _ b -> fct b) doms.table
+
+let cleanup xc doms =
+ let notify = ref false in
+ let dead_dom = ref [] in
+
+ Hashtbl.iter (fun id _ -> if id <> 0 then
+ try
+ let info = Xc.domain_getinfo xc id in
+ if info.Xc.shutdown || info.Xc.dying then (
+ Logs.debug "general" "Domain %u died (dying=%b, shutdown %b -- code %d)"
+ id info.Xc.dying info.Xc.shutdown info.Xc.shutdown_code;
+ if info.Xc.dying then
+ dead_dom := id :: !dead_dom
+ else
+ notify := true;
+ )
+ with Xc.Error _ ->
+ Logs.debug "general" "Domain %u died -- no domain info" id;
+ dead_dom := id :: !dead_dom;
+ ) doms.table;
+ List.iter (fun id ->
+ let dom = Hashtbl.find doms.table id in
+ Domain.close dom;
+ Hashtbl.remove doms.table id;
+ ) !dead_dom;
+ !notify, !dead_dom
+
+let resume doms domid =
+ ()
+
+let create xc doms domid mfn port =
+ let interface = Xc.map_foreign_range xc domid (Mmap.getpagesize()) mfn in
+ let dom = Domain.make domid mfn port interface doms.eventchn in
+ Hashtbl.add doms.table domid dom;
+ Domain.bind_interdomain dom;
+ dom
+
+let create0 fake doms =
+ let port, interface =
+ if fake then (
+ 0, Xc.with_intf (fun xc -> Xc.map_foreign_range xc 0 (Mmap.getpagesize()) 0n)
+ ) else (
+ let port = Utils.read_file_single_integer Define.xenstored_proc_port
+ and fd = Unix.openfile Define.xenstored_proc_kva
+ [ Unix.O_RDWR ] 0o600 in
+ let interface = Mmap.mmap fd Mmap.RDWR Mmap.SHARED
+ (Mmap.getpagesize()) 0 in
+ Unix.close fd;
+ port, interface
+ )
+ in
+ let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in
+ Hashtbl.add doms.table 0 dom;
+ Domain.bind_interdomain dom;
+ Domain.notify dom;
+ dom
diff --git a/tools/ocaml/xenstored/event.ml b/tools/ocaml/xenstored/event.ml
new file mode 100644
index 0000000..5cbdccf
--- /dev/null
+++ b/tools/ocaml/xenstored/event.ml
@@ -0,0 +1,29 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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 binding ****************)
+type t = {
+ fd: Unix.file_descr;
+ mutable virq_port: int;
+}
+
+let init () = { fd = Eventchn.init (); virq_port = -1; }
+let bind_virq eventchn = eventchn.virq_port <- Eventchn.bind_virq eventchn.fd
+let bind_interdomain eventchn domid port = Eventchn.bind_interdomain eventchn.fd domid port
+let unbind eventchn port = Eventchn.unbind eventchn.fd port
+let notify eventchn port = Eventchn.notify eventchn.fd port
+let read_port eventchn = Eventchn.read_port eventchn.fd
+let write_port eventchn port = Eventchn.write_port eventchn.fd port
diff --git a/tools/ocaml/xenstored/logging.ml b/tools/ocaml/xenstored/logging.ml
new file mode 100644
index 0000000..6198309
--- /dev/null
+++ b/tools/ocaml/xenstored/logging.ml
@@ -0,0 +1,239 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
+ *
+ * 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.
+ *)
+
+open Stdext
+open Printf
+
+let error fmt = Logs.error "general" fmt
+let info fmt = Logs.info "general" fmt
+let debug fmt = Logs.debug "general" fmt
+
+let access_log_file = ref "/var/log/xenstored-access.log"
+let access_log_nb_files = ref 20
+let access_log_nb_lines = ref 13215
+let activate_access_log = ref true
+
+(* maximal size of the lines in xenstore-acces.log file *)
+let line_size = 180
+
+let log_read_ops = ref false
+let log_transaction_ops = ref false
+let log_special_ops = ref false
+
+type access_type =
+ | Coalesce
+ | Conflict
+ | Commit
+ | Newconn
+ | Endconn
+ | XbOp of Xb.Op.operation
+
+type access =
+ {
+ fd: out_channel ref;
+ counter: int ref;
+ write: tid:int -> con:string -> ?data:string -> access_type -> unit;
+ }
+
+let string_of_date () =
+ let time = Unix.gettimeofday () in
+ let tm = Unix.localtime time in
+ let msec = time -. (floor time) in
+ sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d" (1900 + tm.Unix.tm_year)
+ (tm.Unix.tm_mon + 1)
+ tm.Unix.tm_mday
+ tm.Unix.tm_hour
+ tm.Unix.tm_min
+ tm.Unix.tm_sec
+ (int_of_float (1000.0 *. msec))
+
+let fill_with_space n s =
+ if String.length s < n
+ then
+ let r = String.make n ' ' in
+ String.blit s 0 r 0 (String.length s);
+ r
+ else
+ s
+
+let string_of_tid ~con tid =
+ if tid = 0
+ then fill_with_space 12 (sprintf "%s" con)
+ else fill_with_space 12 (sprintf "%s.%i" con tid)
+
+let string_of_access_type = function
+ | Coalesce -> "coalesce "
+ | Conflict -> "conflict "
+ | Commit -> "commit "
+ | Newconn -> "newconn "
+ | Endconn -> "endconn "
+
+ | XbOp op -> match op with
+ | Xb.Op.Debug -> "debug "
+
+ | Xb.Op.Directory -> "directory"
+ | Xb.Op.Read -> "read "
+ | Xb.Op.Getperms -> "getperms "
+
+ | Xb.Op.Watch -> "watch "
+ | Xb.Op.Unwatch -> "unwatch "
+
+ | Xb.Op.Transaction_start -> "t start "
+ | Xb.Op.Transaction_end -> "t end "
+
+ | Xb.Op.Introduce -> "introduce"
+ | Xb.Op.Release -> "release "
+ | Xb.Op.Getdomainpath -> "getdomain"
+ | Xb.Op.Isintroduced -> "is introduced"
+ | Xb.Op.Resume -> "resume "
+
+ | Xb.Op.Write -> "write "
+ | Xb.Op.Mkdir -> "mkdir "
+ | Xb.Op.Rm -> "rm "
+ | Xb.Op.Setperms -> "setperms "
+ | Xb.Op.Restrict -> "restrict "
+ | Xb.Op.Set_target -> "settarget"
+
+ | Xb.Op.Error -> "error "
+ | Xb.Op.Watchevent -> "w event "
+
+ | x -> Xb.Op.to_string x
+
+let file_exists file =
+ try
+ Unix.close (Unix.openfile file [Unix.O_RDONLY] 0o644);
+ true
+ with _ ->
+ false
+
+let log_rotate fd =
+ let file n = sprintf "%s.%i" !access_log_file n in
+ let log_files =
+ let rec aux accu n =
+ if n >= !access_log_nb_files
+ then accu
+ else if n = 1 && file_exists !access_log_file
+ then aux [!access_log_file,1] 2
+ else
+ let file = file (n-1) in
+ if file_exists file
+ then aux ((file,n) :: accu) (n+1)
+ else accu
+ in
+ aux [] 1
+ in
+ let rec rename = function
+ | (f,n) :: t when n < !access_log_nb_files ->
+ Unix.rename f (file n);
+ rename t
+ | _ -> ()
+ in
+ rename log_files;
+ close_out !fd;
+ fd := open_out !access_log_file
+
+let sanitize_data data =
+ let data = String.copy data in
+ for i = 0 to String.length data - 1
+ do
+ if data.[i] = '\000' then
+ data.[i] <- ' '
+ done;
+ String.escaped data
+
+let make save_to_disk =
+ let fd = ref (open_out_gen [Open_append; Open_creat] 0o644 !access_log_file) in
+ let counter = ref 0 in
+ {
+ fd = fd;
+ counter = counter;
+ write =
+ if not !activate_access_log || !access_log_nb_files = 0
+ then begin fun ~tid ~con ?data _ -> () end
+ else fun ~tid ~con ?(data="") access_type ->
+ let s = Printf.sprintf "[%s] %s %s %s\n" (string_of_date()) (string_of_tid ~con tid)
+ (string_of_access_type access_type) (sanitize_data data) in
+ let s =
+ if String.length s > line_size
+ then begin
+ let s = String.sub s 0 line_size in
+ s.[line_size-3] <- '.';
+ s.[line_size-2] <- '.';
+ s.[line_size-1] <- '\n';
+ s
+ end else
+ s
+ in
+ incr counter;
+ output_string !fd s;
+ flush !fd;
+ if !counter > !access_log_nb_lines
+ then begin
+ log_rotate fd;
+ save_to_disk ();
+ counter := 0;
+ end
+ }
+
+let access : (access option) ref = ref None
+let init aal save_to_disk =
+ activate_access_log := aal;
+ access := Some (make save_to_disk)
+
+let write_access_log ~con ~tid ?data access_type =
+ try
+ maybe (fun a -> a.write access_type ~con ~tid ?data) !access
+ with _ -> ()
+
+let new_connection = write_access_log Newconn
+let end_connection = write_access_log Endconn
+let read_coalesce ~tid ~con data =
+ if !log_read_ops
+ then write_access_log Coalesce ~tid ~con ~data:("read "^data)
+let write_coalesce data = write_access_log Coalesce ~data:("write "^data)
+let conflict = write_access_log Conflict
+let commit = write_access_log Commit
+
+let xb_op ~tid ~con ~ty data =
+ let print =
+ match ty with
+ | Xb.Op.Read | Xb.Op.Directory | Xb.Op.Getperms -> !log_read_ops
+ | Xb.Op.Transaction_start | Xb.Op.Transaction_end ->
+ false (* transactions are managed below *)
+ | Xb.Op.Introduce | Xb.Op.Release | Xb.Op.Getdomainpath | Xb.Op.Isintroduced | Xb.Op.Resume ->
+ !log_special_ops
+ | _ -> true
+ in
+ if print
+ then write_access_log ~tid ~con ~data (XbOp ty)
+
+let start_transaction ~tid ~con =
+ if !log_transaction_ops && tid <> 0
+ then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_start)
+
+let end_transaction ~tid ~con =
+ if !log_transaction_ops && tid <> 0
+ then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_end)
+
+let xb_answer ~tid ~con ~ty data =
+ let print = match ty with
+ | Xb.Op.Error when data="ENOENT " -> !log_read_ops
+ | Xb.Op.Error -> !log_special_ops
+ | Xb.Op.Watchevent -> true
+ | _ -> false
+ in
+ if print
+ then write_access_log ~tid ~con ~data (XbOp ty)
diff --git a/tools/ocaml/xenstored/parse_arg.ml b/tools/ocaml/xenstored/parse_arg.ml
new file mode 100644
index 0000000..5d21601
--- /dev/null
+++ b/tools/ocaml/xenstored/parse_arg.ml
@@ -0,0 +1,68 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type config =
+{
+ domain_init: bool;
+ activate_access_log: bool;
+ daemonize: bool;
+ reraise_top_level: bool;
+ config_file: string option;
+ pidfile: string option; (* old xenstored compatibility *)
+ tracefile: string option; (* old xenstored compatibility *)
+ restart: bool;
+ disable_socket: bool;
+}
+
+let do_argv =
+ let pidfile = ref "" and tracefile = ref "" (* old xenstored compatibility *)
+ and domain_init = ref true
+ and activate_access_log = ref true
+ and daemonize = ref true
+ and reraise_top_level = ref false
+ and config_file = ref ""
+ and restart = ref false
+ and disable_socket = ref false in
+
+ let speclist =
+ [ ("--no-domain-init", Arg.Unit (fun () -> domain_init := false),
+ "to state that xenstored should not initialise dom0");
+ ("--config-file", Arg.Set_string config_file,
+ "set an alternative location for the configuration file");
+ ("--no-fork", Arg.Unit (fun () -> daemonize := false),
+ "to request that the daemon does not fork");
+ ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level := true),
+ "reraise exceptions caught at the top level");
+ ("--no-access-log", Arg.Unit (fun () -> activate_access_log := false),
+ "do not create a xenstore-access.log file");
+ ("--pid-file", Arg.Set_string pidfile, ""); (* for compatibility *)
+ ("-T", Arg.Set_string tracefile, ""); (* for compatibility *)
+ ("--restart", Arg.Set restart, "Read database on starting");
+ ("--disable-socket", Arg.Unit (fun () -> disable_socket := true), "Disable socket");
+ ] in
+ let usage_msg = "usage : xenstored [--config-file <filename>] [--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable-socket]" in
+ Arg.parse speclist (fun s -> ()) usage_msg;
+ {
+ domain_init = !domain_init;
+ activate_access_log = !activate_access_log;
+ daemonize = !daemonize;
+ reraise_top_level = !reraise_top_level;
+ config_file = if !config_file <> "" then Some !config_file else None;
+ pidfile = if !pidfile <> "" then Some !pidfile else None;
+ tracefile = if !tracefile <> "" then Some !tracefile else None;
+ restart = !restart;
+ disable_socket = !disable_socket;
+ }
diff --git a/tools/ocaml/xenstored/perms.ml b/tools/ocaml/xenstored/perms.ml
new file mode 100644
index 0000000..0462d53
--- /dev/null
+++ b/tools/ocaml/xenstored/perms.ml
@@ -0,0 +1,167 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+open Stdext
+
+let activate = ref true
+
+type permty = READ | WRITE | RDWR | NONE
+
+let char_of_permty perm =
+ match perm with
+ | READ -> 'r'
+ | WRITE -> 'w'
+ | RDWR -> 'b'
+ | NONE -> 'n'
+
+let permty_of_char c =
+ match c with
+ | 'r' -> READ
+ | 'w' -> WRITE
+ | 'b' -> RDWR
+ | 'n' -> NONE
+ | _ -> invalid_arg "unknown permission type"
+
+
+(* node permissions *)
+module Node =
+struct
+
+type t =
+{
+ owner: Xc.domid;
+ other: permty;
+ acl: (Xc.domid * permty) list;
+}
+
+let create owner other acl =
+ { owner = owner; other = other; acl = acl }
+
+let get_other perms = perms.other
+let get_acl perms = perms.acl
+let get_owner perm = perm.owner
+
+let default0 = create 0 NONE []
+
+let perm_of_string s =
+ let ty = permty_of_char s.[0]
+ and id = int_of_string (String.sub s 1 (String.length s - 1)) in
+ (id, ty)
+
+let of_strings ls =
+ let vect = List.map (perm_of_string) ls in
+ match vect with
+ | [] -> invalid_arg "permvec empty"
+ | h :: l -> create (fst h) (snd h) l
+
+(* [s] must end with '\000' *)
+let of_string s =
+ let ls = String.split '\000' s in
+ let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in
+ of_strings ls
+
+let string_of_perm perm =
+ Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm)
+
+let to_string permvec =
+ let l = ((permvec.owner, permvec.other) :: permvec.acl) in
+ String.concat "\000" (List.map string_of_perm l)
+
+end
+
+
+(* permission of connections *)
+module Connection =
+struct
+
+type elt = Xc.domid * (permty list)
+type t =
+ { main: elt;
+ target: elt option; }
+
+let full_rights : t =
+ { main = 0, [READ; WRITE];
+ target = None }
+
+let create ?(perms=[NONE]) domid : t =
+ { main = (domid, perms);
+ target = None }
+
+let set_target (connection:t) ?(perms=[NONE]) domid =
+ { connection with target = Some (domid, perms) }
+
+let get_owners (connection:t) =
+ match connection.main, connection.target with
+ | c1, Some c2 -> [ fst c1; fst c2 ]
+ | c1, None -> [ fst c1 ]
+
+let is_owner (connection:t) id =
+ match connection.target with
+ | Some target -> fst connection.main = id || fst target = id
+ | None -> fst connection.main = id
+
+let is_dom0 (connection:t) =
+ is_owner connection 0
+
+let restrict (connection:t) domid =
+ match connection.target, connection.main with
+ | None, (0, perms) -> { connection with main = (domid, perms) }
+ | _ -> raise Define.Permission_denied
+
+let elt_to_string (i,p) =
+ Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p)))
+
+let to_string connection =
+ Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target))
+end
+
+(* check if owner of the current connection and of the current node are the same *)
+let check_owner (connection:Connection.t) (node:Node.t) =
+ if !activate && not (Connection.is_dom0 connection)
+ then Connection.is_owner connection (Node.get_owner node)
+ else true
+
+(* check if the current connection has the requested perm on the current node *)
+let check (connection:Connection.t) request (node:Node.t) =
+ let check_acl domainid =
+ let perm =
+ if List.mem_assoc domainid (Node.get_acl node)
+ then List.assoc domainid (Node.get_acl node)
+ else Node.get_other node
+ in
+ match perm, request with
+ | NONE, _ ->
+ Logs.info "io" "Permission denied: Domain %d has no permission" domainid;
+ false
+ | RDWR, _ -> true
+ | READ, READ -> true
+ | WRITE, WRITE -> true
+ | READ, _ ->
+ Logs.info "io" "Permission denied: Domain %d has read only access" domainid;
+ false
+ | WRITE, _ ->
+ Logs.info "io" "Permission denied: Domain %d has write only access" domainid;
+ false
+ in
+ if !activate
+ && not (Connection.is_dom0 connection)
+ && not (check_owner connection node)
+ && not (List.exists check_acl (Connection.get_owners connection))
+ then raise Define.Permission_denied
+
+let equiv perm1 perm2 =
+ (Node.to_string perm1) = (Node.to_string perm2)
diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml
new file mode 100644
index 0000000..1549774
--- /dev/null
+++ b/tools/ocaml/xenstored/process.ml
@@ -0,0 +1,396 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+open Printf
+open Stdext
+
+exception Transaction_again
+exception Transaction_nested
+exception Domain_not_match
+exception Invalid_Cmd_Args
+
+let allow_debug = ref false
+
+let c_int_of_string s =
+ let v = ref 0 in
+ let is_digit c = c >= '0' && c <= '9' in
+ let len = String.length s in
+ let i = ref 0 in
+ while !i < len && not (is_digit s.[!i]) do incr i done;
+ while !i < len && is_digit s.[!i]
+ do
+ let x = (Char.code s.[!i]) - (Char.code '0') in
+ v := !v * 10 + x;
+ incr i
+ done;
+ !v
+
+(* when we don't want a limit, apply a max limit of 8 arguments.
+ no arguments take more than 3 currently, which is pointless to split
+ more than needed. *)
+let split limit c s =
+ let limit = match limit with None -> 8 | Some x -> x in
+ String.split ~limit c s
+
+let split_one_path data con =
+ let args = split (Some 2) '\000' data in
+ match args with
+ | path :: "" :: [] -> Store.Path.create path (Connection.get_path con)
+ | _ -> raise Invalid_Cmd_Args
+
+let process_watch ops cons =
+ let do_op_watch op cons =
+ let recurse = match (fst op) with
+ | Xb.Op.Write -> false
+ | Xb.Op.Mkdir -> false
+ | Xb.Op.Rm -> true
+ | Xb.Op.Setperms -> false
+ | _ -> raise (Failure "huh ?") in
+ Connections.fire_watches cons (snd op) recurse in
+ List.iter (fun op -> do_op_watch op cons) ops
+
+let create_implicit_path t perm path =
+ let dirname = Store.Path.get_parent path in
+ if not (Transaction.path_exists t dirname) then (
+ let rec check_path p =
+ match p with
+ | [] -> []
+ | h :: l ->
+ if Transaction.path_exists t h then
+ check_path l
+ else
+ p in
+ let ret = check_path (List.tl (Store.Path.get_hierarchy dirname)) in
+ List.iter (fun s -> Transaction.mkdir ~with_watch:false t perm s) ret
+ )
+
+(* packets *)
+let do_debug con t domains cons data =
+ if not !allow_debug
+ then None
+ else try match split None '\000' data with
+ | "print" :: msg :: _ ->
+ Logging.xb_op ~tid:0 ~ty:Xb.Op.Debug ~con:"=======>" msg;
+ None
+ | "quota" :: domid :: _ ->
+ let domid = int_of_string domid in
+ let quota = (Store.get_quota t.Transaction.store) in
+ Some (Quota.to_string quota domid ^ "\000")
+ | "mfn" :: domid :: _ ->
+ let domid = int_of_string domid in
+ let con = Connections.find_domain cons domid in
+ may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connection.get_domain con)
+ | _ -> None
+ with _ -> None
+
+let do_directory con t domains cons data =
+ let path = split_one_path data con in
+ let entries = Transaction.ls t (Connection.get_perm con) path in
+ if List.length entries > 0 then
+ (Utils.join_by_null entries) ^ "\000"
+ else
+ ""
+
+let do_read con t domains cons data =
+ let path = split_one_path data con in
+ Transaction.read t (Connection.get_perm con) path
+
+let do_getperms con t domains cons data =
+ let path = split_one_path data con in
+ let perms = Transaction.getperms t (Connection.get_perm con) path in
+ Perms.Node.to_string perms ^ "\000"
+
+let do_watch con t rid domains cons data =
+ let (node, token) =
+ match (split None '\000' data) with
+ | [node; token; ""] -> node, token
+ | _ -> raise Invalid_Cmd_Args
+ in
+ let watch = Connections.add_watch cons con node token in
+ Connection.send_ack con (Transaction.get_id t) rid Xb.Op.Watch;
+ Connection.fire_single_watch watch
+
+let do_unwatch con t domains cons data =
+ let (node, token) =
+ match (split None '\000' data) with
+ | [node; token; ""] -> node, token
+ | _ -> raise Invalid_Cmd_Args
+ in
+ Connections.del_watch cons con node token
+
+let do_transaction_start con t domains cons data =
+ if Transaction.get_id t <> Transaction.none then
+ raise Transaction_nested;
+ let store = Transaction.get_store t in
+ string_of_int (Connection.start_transaction con store) ^ "\000"
+
+let do_transaction_end con t domains cons data =
+ let commit =
+ match (split None '\000' data) with
+ | "T" :: _ -> true
+ | "F" :: _ -> false
+ | x :: _ -> raise (Invalid_argument x)
+ | _ -> raise Invalid_Cmd_Args
+ in
+ let success =
+ Connection.end_transaction con (Transaction.get_id t) commit in
+ if not success then
+ raise Transaction_again;
+ if commit then
+ process_watch (List.rev (Transaction.get_ops t)) cons
+
+let do_introduce con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ let (domid, mfn, port) =
+ match (split None '\000' data) with
+ | domid :: mfn :: port :: _ ->
+ int_of_string domid, Nativeint.of_string mfn, int_of_string port
+ | _ -> raise Invalid_Cmd_Args;
+ in
+ let dom =
+ if Domains.exist domains domid then
+ Domains.find domains domid
+ else try
+ let ndom = Xc.with_intf (fun xc ->
+ Domains.create xc domains domid mfn port) in
+ Connections.add_domain cons ndom;
+ Connections.fire_spec_watches cons "@introduceDomain";
+ ndom
+ with _ -> raise Invalid_Cmd_Args
+ in
+ if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn then
+ raise Domain_not_match
+
+let do_release con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ let domid =
+ match (split None '\000' data) with
+ | [domid;""] -> int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ let fire_spec_watches = Domains.exist domains domid in
+ Domains.del domains domid;
+ Connections.del_domain cons domid;
+ if fire_spec_watches
+ then Connections.fire_spec_watches cons "@releaseDomain"
+ else raise Invalid_Cmd_Args
+
+let do_resume con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ let domid =
+ match (split None '\000' data) with
+ | domid :: _ -> int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ if Domains.exist domains domid
+ then Domains.resume domains domid
+ else raise Invalid_Cmd_Args
+
+let do_getdomainpath con t domains cons data =
+ let domid =
+ match (split None '\000' data) with
+ | domid :: "" :: [] -> c_int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ sprintf "/local/domain/%u\000" domid
+
+let do_write con t domains cons data =
+ let path, value =
+ match (split (Some 2) '\000' data) with
+ | path :: value :: [] -> Store.Path.create path (Connection.get_path con), value
+ | _ -> raise Invalid_Cmd_Args
+ in
+ create_implicit_path t (Connection.get_perm con) path;
+ Transaction.write t (Connection.get_perm con) path value
+
+let do_mkdir con t domains cons data =
+ let path = split_one_path data con in
+ create_implicit_path t (Connection.get_perm con) path;
+ try
+ Transaction.mkdir t (Connection.get_perm con) path
+ with
+ Define.Already_exist -> ()
+
+let do_rm con t domains cons data =
+ let path = split_one_path data con in
+ try
+ Transaction.rm t (Connection.get_perm con) path
+ with
+ Define.Doesnt_exist -> ()
+
+let do_setperms con t domains cons data =
+ let path, perms =
+ match (split (Some 2) '\000' data) with
+ | path :: perms :: _ ->
+ Store.Path.create path (Connection.get_path con),
+ (Perms.Node.of_string perms)
+ | _ -> raise Invalid_Cmd_Args
+ in
+ Transaction.setperms t (Connection.get_perm con) path perms
+
+let do_error con t domains cons data =
+ raise Define.Unknown_operation
+
+let do_isintroduced con t domains cons data =
+ let domid =
+ match (split None '\000' data) with
+ | domid :: _ -> int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ if domid = Define.domid_self || Domains.exist domains domid then "T\000" else "F\000"
+
+(* [restrict] is in the patch queue since xen3.2 *)
+let do_restrict con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ let domid =
+ match (split None '\000' data) with
+ | [ domid; "" ] -> c_int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ Connection.restrict con domid
+
+(* only in >= xen3.3 *)
+(* we ensure backward compatibility with restrict by counting the number of argument of set_target ... *)
+(* This is not very elegant, but it is safe as 'restrict' only restricts permission of dom0 connections *)
+let do_set_target con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ match split None '\000' data with
+ | [ domid; "" ] -> do_restrict con t domains con data (* backward compatibility with xen3.2-pq *)
+ | [ domid; target_domid; "" ] -> Connections.set_target cons (c_int_of_string domid) (c_int_of_string target_domid)
+ | _ -> raise Invalid_Cmd_Args
+
+(*------------- Generic handling of ty ------------------*)
+let reply_ack fct ty con t rid doms cons data =
+ fct con t doms cons data;
+ Connection.send_ack con (Transaction.get_id t) rid ty;
+ if Transaction.get_id t = Transaction.none then
+ process_watch (Transaction.get_ops t) cons
+
+let reply_data fct ty con t rid doms cons data =
+ let ret = fct con t doms cons data in
+ Connection.send_reply con (Transaction.get_id t) rid ty ret
+
+let reply_data_or_ack fct ty con t rid doms cons data =
+ match fct con t doms cons data with
+ | Some ret -> Connection.send_reply con (Transaction.get_id t) rid ty ret
+ | None -> Connection.send_ack con (Transaction.get_id t) rid ty
+
+let reply_none fct ty con t rid doms cons data =
+ (* let the function reply *)
+ fct con t rid doms cons data
+
+let function_of_type ty =
+ match ty with
+ | Xb.Op.Debug -> reply_data_or_ack do_debug
+ | Xb.Op.Directory -> reply_data do_directory
+ | Xb.Op.Read -> reply_data do_read
+ | Xb.Op.Getperms -> reply_data do_getperms
+ | Xb.Op.Watch -> reply_none do_watch
+ | Xb.Op.Unwatch -> reply_ack do_unwatch
+ | Xb.Op.Transaction_start -> reply_data do_transaction_start
+ | Xb.Op.Transaction_end -> reply_ack do_transaction_end
+ | Xb.Op.Introduce -> reply_ack do_introduce
+ | Xb.Op.Release -> reply_ack do_release
+ | Xb.Op.Getdomainpath -> reply_data do_getdomainpath
+ | Xb.Op.Write -> reply_ack do_write
+ | Xb.Op.Mkdir -> reply_ack do_mkdir
+ | Xb.Op.Rm -> reply_ack do_rm
+ | Xb.Op.Setperms -> reply_ack do_setperms
+ | Xb.Op.Isintroduced -> reply_data do_isintroduced
+ | Xb.Op.Resume -> reply_ack do_resume
+ | Xb.Op.Set_target -> reply_ack do_set_target
+ | Xb.Op.Restrict -> reply_ack do_restrict
+ | _ -> reply_ack do_error
+
+let input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data =
+ let reply_error e =
+ Connection.send_error con (Transaction.get_id t) rid e in
+ try
+ fct ty con t rid doms cons data
+ with
+ | Define.Invalid_path -> reply_error "EINVAL"
+ | Define.Already_exist -> reply_error "EEXIST"
+ | Define.Doesnt_exist -> reply_error "ENOENT"
+ | Define.Lookup_Doesnt_exist s -> reply_error "ENOENT"
+ | Define.Permission_denied -> reply_error "EACCES"
+ | Not_found -> reply_error "ENOENT"
+ | Invalid_Cmd_Args -> reply_error "EINVAL"
+ | Invalid_argument i -> reply_error "EINVAL"
+ | Transaction_again -> reply_error "EAGAIN"
+ | Transaction_nested -> reply_error "EBUSY"
+ | Domain_not_match -> reply_error "EINVAL"
+ | Quota.Limit_reached -> reply_error "EQUOTA"
+ | Quota.Data_too_big -> reply_error "E2BIG"
+ | Quota.Transaction_opened -> reply_error "EQUOTA"
+ | (Failure "int_of_string") -> reply_error "EINVAL"
+ | Define.Unknown_operation -> reply_error "ENOSYS"
+
+(**
+ * Nothrow guarantee.
+ *)
+let process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data =
+ try
+ let fct = function_of_type ty in
+ let t =
+ if tid = Transaction.none then
+ Transaction.make tid store
+ else
+ Connection.get_transaction con tid
+ in
+ input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data;
+ with exn ->
+ Logs.error "general" "process packet: %s"
+ (Printexc.to_string exn);
+ Connection.send_error con tid rid "EIO"
+
+let write_access_log ~ty ~tid ~con ~data =
+ Logging.xb_op ~ty ~tid ~con:(Connection.get_domstr con) data
+
+let write_answer_log ~ty ~tid ~con ~data =
+ Logging.xb_answer ~ty ~tid ~con:(Connection.get_domstr con) data
+
+let do_input store cons doms con =
+ if Connection.do_input con then (
+ let packet = Connection.pop_in con in
+ let tid, rid, ty, data = Xb.Packet.unpack packet in
+ (* As we don't log IO, do not call an unnecessary sanitize_data
+ Logs.info "io" "[%s] -> [%d] %s \"%s\""
+ (Connection.get_domstr con) tid
+ (Xb.Op.to_string ty) (sanitize_data data); *)
+ process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data;
+ write_access_log ~ty ~tid ~con ~data;
+ Connection.incr_ops con;
+ )
+
+let do_output store cons doms con =
+ if Connection.has_output con then (
+ if Connection.has_new_output con then (
+ let packet = Connection.peek_output con in
+ let tid, rid, ty, data = Xb.Packet.unpack packet in
+ (* As we don't log IO, do not call an unnecessary sanitize_data
+ Logs.info "io" "[%s] <- %s \"%s\""
+ (Connection.get_domstr con)
+ (Xb.Op.to_string ty) (sanitize_data data);*)
+ write_answer_log ~ty ~tid ~con ~data;
+ );
+ ignore (Connection.do_output con)
+ )
+
diff --git a/tools/ocaml/xenstored/quota.ml b/tools/ocaml/xenstored/quota.ml
new file mode 100644
index 0000000..4091e40
--- /dev/null
+++ b/tools/ocaml/xenstored/quota.ml
@@ -0,0 +1,83 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+exception Limit_reached
+exception Data_too_big
+exception Transaction_opened
+
+let warn fmt = Logs.warn "general" fmt
+let activate = ref true
+let maxent = ref (10000)
+let maxsize = ref (4096)
+
+type t = {
+ maxent: int; (* max entities per domU *)
+ maxsize: int; (* max size of data store in one node *)
+ cur: (Xc.domid, int) Hashtbl.t; (* current domains quota *)
+}
+
+let to_string quota domid =
+ if Hashtbl.mem quota.cur domid
+ then Printf.sprintf "dom%i quota: %i/%i" domid (Hashtbl.find quota.cur domid) quota.maxent
+ else Printf.sprintf "dom%i quota: not set" domid
+
+let create () =
+ { maxent = !maxent; maxsize = !maxsize; cur = Hashtbl.create 100; }
+
+let copy quota = { quota with cur = (Hashtbl.copy quota.cur) }
+
+let del quota id = Hashtbl.remove quota.cur id
+
+let _check quota id size =
+ if size > quota.maxsize then (
+ warn "domain %u err create entry: data too big %d" id size;
+ raise Data_too_big
+ );
+ if id > 0 && Hashtbl.mem quota.cur id then
+ let entry = Hashtbl.find quota.cur id in
+ if entry >= quota.maxent then (
+ warn "domain %u cannot create entry: quota reached" id;
+ raise Limit_reached
+ )
+
+let check quota id size =
+ if !activate then
+ _check quota id size
+
+let get_entry quota id = Hashtbl.find quota.cur id
+
+let set_entry quota id nb =
+ if nb = 0
+ then Hashtbl.remove quota.cur id
+ else begin
+ if Hashtbl.mem quota.cur id then
+ Hashtbl.replace quota.cur id nb
+ else
+ Hashtbl.add quota.cur id nb
+ end
+
+let del_entry quota id =
+ try
+ let nb = get_entry quota id in
+ set_entry quota id (nb - 1)
+ with Not_found -> ()
+
+let add_entry quota id =
+ let nb = try get_entry quota id with Not_found -> 0 in
+ set_entry quota id (nb + 1)
+
+let add quota diff =
+ Hashtbl.iter (fun id nb -> set_entry quota id (get_entry quota id + nb)) diff.cur
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
new file mode 100644
index 0000000..34552bb
--- /dev/null
+++ b/tools/ocaml/xenstored/store.ml
@@ -0,0 +1,461 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * 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.
+ *)
+open Stdext
+
+module Node = struct
+
+type t = {
+ name: Symbol.t;
+ perms: Perms.Node.t;
+ value: string;
+ children: t list;
+}
+
+let create _name _perms _value =
+ { name = Symbol.of_string _name; perms = _perms; value = _value; children = []; }
+
+let get_owner node = Perms.Node.get_owner node.perms
+let get_children node = node.children
+let get_value node = node.value
+let get_perms node = node.perms
+let get_name node = Symbol.to_string node.name
+
+let set_value node nvalue =
+ if node.value = nvalue
+ then node
+ else { node with value = nvalue }
+
+let set_perms node nperms = { node with perms = nperms }
+
+let add_child node child =
+ { node with children = child :: node.children }
+
+let exists node childname =
+ let childname = Symbol.of_string childname in
+ List.exists (fun n -> n.name = childname) node.children
+
+let find node childname =
+ let childname = Symbol.of_string childname in
+ List.find (fun n -> n.name = childname) node.children
+
+let replace_child node child nchild =
+ (* this is the on-steroid version of the filter one-replace one *)
+ let rec replace_one_in_list l =
+ match l with
+ | [] -> []
+ | h :: tl when h.name = child.name -> nchild :: tl
+ | h :: tl -> h :: replace_one_in_list tl
+ in
+ { node with children = (replace_one_in_list node.children) }
+
+let del_childname node childname =
+ let sym = Symbol.of_string childname in
+ let rec delete_one_in_list l =
+ match l with
+ | [] -> raise Not_found
+ | h :: tl when h.name = sym -> tl
+ | h :: tl -> h :: delete_one_in_list tl
+ in
+ { node with children = (delete_one_in_list node.children) }
+
+let del_all_children node =
+ { node with children = [] }
+
+(* check if the current node can be accessed by the current connection with rperm permissions *)
+let check_perm node connection request =
+ Perms.check connection request node.perms
+
+(* check if the current node is owned by the current connection *)
+let check_owner node connection =
+ if not (Perms.check_owner connection node.perms)
+ then begin
+ Logs.info "io" "Permission denied: Domain %d not owner" (get_owner node);
+ raise Define.Permission_denied;
+ end
+
+let rec recurse fct node = fct node; List.iter (recurse fct) node.children
+
+let unpack node = (Symbol.to_string node.name, node.perms, node.value)
+
+end
+
+module Path = struct
+
+(* represent a path in a store.
+ * [] -> "/"
+ * [ "local"; "domain"; "1" ] -> "/local/domain/1"
+ *)
+type t = string list
+
+let char_is_valid c =
+ (c >= 'a' && c <= 'z') ||
+ (c >= 'A' && c <= 'Z') ||
+ (c >= '0' && c <= '9') ||
+ c = '_' || c = '-' || c = '@'
+
+let name_is_valid name =
+ name <> "" && String.fold_left (fun accu c -> accu && char_is_valid c) true name
+
+let is_valid path =
+ List.for_all name_is_valid path
+
+let of_string s =
+ if s.[0] = '@'
+ then [s]
+ else if s = "/"
+ then []
+ else match String.split '/' s with
+ | "" :: path when is_valid path -> path
+ | _ -> raise Define.Invalid_path
+
+let create path connection_path =
+ of_string (Utils.path_validate path connection_path)
+
+let to_string t =
+ "/" ^ (String.concat "/" t)
+
+let to_string_list x = x
+
+let get_parent t =
+ if t = [] then [] else List.rev (List.tl (List.rev t))
+
+let get_hierarchy path =
+ Utils.get_hierarchy path
+
+let get_common_prefix p1 p2 =
+ let rec compare l1 l2 =
+ match l1, l2 with
+ | h1 :: tl1, h2 :: tl2 ->
+ if h1 = h2 then h1 :: (compare tl1 tl2) else []
+ | _, [] | [], _ ->
+ (* if l1 or l2 is empty, we found the equal part already *)
+ []
+ in
+ compare p1 p2
+
+let rec lookup_modify node path fct =
+ match path with
+ | [] -> raise (Define.Invalid_path)
+ | h :: [] -> fct node h
+ | h :: l ->
+ let (n, c) =
+ if not (Node.exists node h) then
+ raise (Define.Lookup_Doesnt_exist h)
+ else
+ (node, Node.find node h) in
+ let nc = lookup_modify c l fct in
+ Node.replace_child n c nc
+
+let apply_modify rnode path fct =
+ lookup_modify rnode path fct
+
+let rec lookup_get node path =
+ match path with
+ | [] -> raise (Define.Invalid_path)
+ | h :: [] ->
+ (try
+ Node.find node h
+ with Not_found ->
+ raise Define.Doesnt_exist)
+ | h :: l -> let cnode = Node.find node h in lookup_get cnode l
+
+let get_node rnode path =
+ if path = [] then
+ Some rnode
+ else (
+ try Some (lookup_get rnode path) with Define.Doesnt_exist -> None
+ )
+
+(* get the deepest existing node for this path *)
+let rec get_deepest_existing_node node = function
+ | [] -> node
+ | h :: t ->
+ try get_deepest_existing_node (Node.find node h) t
+ with Not_found -> node
+
+let set_node rnode path nnode =
+ let quota = Quota.create () in
+ if !Quota.activate then Node.recurse (fun node -> Quota.add_entry quota (Node.get_owner node)) nnode;
+ if path = [] then
+ nnode, quota
+ else
+ let set_node node name =
+ try
+ let ent = Node.find node name in
+ if !Quota.activate then Node.recurse (fun node -> Quota.del_entry quota (Node.get_owner node)) ent;
+ Node.replace_child node ent nnode
+ with Not_found ->
+ Node.add_child node nnode
+ in
+ apply_modify rnode path set_node, quota
+
+(* read | ls | getperms use this *)
+let rec lookup node path fct =
+ match path with
+ | [] -> raise (Define.Invalid_path)
+ | h :: [] -> fct node h
+ | h :: l -> let cnode = Node.find node h in lookup cnode l fct
+
+let apply rnode path fct =
+ lookup rnode path fct
+end
+
+type t =
+{
+ mutable stat_transaction_coalesce: int;
+ mutable stat_transaction_abort: int;
+ mutable root: Node.t;
+ mutable quota: Quota.t;
+}
+
+let get_root store = store.root
+let set_root store root = store.root <- root
+
+let get_quota store = store.quota
+let set_quota store quota = store.quota <- quota
+
+(* modifying functions *)
+let path_mkdir store perm path =
+ let do_mkdir node name =
+ try
+ let ent = Node.find node name in
+ Node.check_perm ent perm Perms.WRITE;
+ raise Define.Already_exist
+ with Not_found ->
+ Node.check_perm node perm Perms.WRITE;
+ Node.add_child node (Node.create name node.Node.perms "") in
+ if path = [] then
+ store.root
+ else
+ Path.apply_modify store.root path do_mkdir
+
+let path_write store perm path value =
+ let node_created = ref false in
+ let do_write node name =
+ try
+ let ent = Node.find node name in
+ Node.check_perm ent perm Perms.WRITE;
+ let nent = Node.set_value ent value in
+ Node.replace_child node ent nent
+ with Not_found ->
+ node_created := true;
+ Node.check_perm node perm Perms.WRITE;
+ Node.add_child node (Node.create name node.Node.perms value) in
+ if path = [] then (
+ Node.check_perm store.root perm Perms.WRITE;
+ Node.set_value store.root value, false
+ ) else
+ Path.apply_modify store.root path do_write, !node_created
+
+let path_rm store perm path =
+ let do_rm node name =
+ try
+ let ent = Node.find node name in
+ Node.check_perm ent perm Perms.WRITE;
+ Node.del_childname node name
+ with Not_found ->
+ raise Define.Doesnt_exist in
+ if path = [] then
+ Node.del_all_children store.root
+ else
+ Path.apply_modify store.root path do_rm
+
+let path_setperms store perm path perms =
+ if path = [] then
+ Node.set_perms store.root perms
+ else
+ let do_setperms node name =
+ let c = Node.find node name in
+ Node.check_owner c perm;
+ Node.check_perm c perm Perms.WRITE;
+ let nc = Node.set_perms c perms in
+ Node.replace_child node c nc
+ in
+ Path.apply_modify store.root path do_setperms
+
+(* accessing functions *)
+let get_node store path =
+ Path.get_node store.root path
+
+let get_deepest_existing_node store path =
+ Path.get_deepest_existing_node store.root path
+
+let read store perm path =
+ let do_read node name =
+ let ent = Node.find node name in
+ Node.check_perm ent perm Perms.READ;
+ ent.Node.value
+ in
+ Path.apply store.root path do_read
+
+let ls store perm path =
+ let children =
+ if path = [] then
+ (Node.get_children store.root)
+ else
+ let do_ls node name =
+ let cnode = Node.find node name in
+ Node.check_perm cnode perm Perms.READ;
+ cnode.Node.children in
+ Path.apply store.root path do_ls in
+ List.rev (List.map (fun n -> Symbol.to_string n.Node.name) children)
+
+let getperms store perm path =
+ if path = [] then
+ (Node.get_perms store.root)
+ else
+ let fct n name =
+ let c = Node.find n name in
+ Node.check_perm c perm Perms.READ;
+ c.Node.perms in
+ Path.apply store.root path fct
+
+let path_exists store path =
+ if path = [] then
+ true
+ else
+ try
+ let check_exist node name =
+ ignore(Node.find node name);
+ true in
+ Path.apply store.root path check_exist
+ with Not_found -> false
+
+
+(* others utils *)
+let traversal root_node f =
+ let rec _traversal path node =
+ f path node;
+ List.iter (_traversal (path @ [ Symbol.to_string node.Node.name ])) node.Node.children
+ in
+ _traversal [] root_node
+
+let dump_store_buf root_node =
+ let buf = Buffer.create 8192 in
+ let dump_node path node =
+ let pathstr = String.concat "/" path in
+ Printf.bprintf buf "%s/%s{%s}" pathstr (Symbol.to_string node.Node.name)
+ (String.escaped (Perms.Node.to_string (Node.get_perms node)));
+ if String.length node.Node.value > 0 then
+ Printf.bprintf buf " = %s\n" (String.escaped node.Node.value)
+ else
+ Printf.bprintf buf "\n";
+ in
+ traversal root_node dump_node;
+ buf
+
+let dump_store chan root_node =
+ let buf = dump_store_buf root_node in
+ output_string chan (Buffer.contents buf);
+ Buffer.reset buf
+
+let dump_fct store f = traversal store.root f
+let dump store out_chan = dump_store out_chan store.root
+let dump_stdout store = dump_store stdout store.root
+let dump_buffer store = dump_store_buf store.root
+
+
+(* modifying functions with quota udpate *)
+let set_node store path node =
+ let root, quota_diff = Path.set_node store.root path node in
+ store.root <- root;
+ Quota.add store.quota quota_diff
+
+let write store perm path value =
+ let owner = Node.get_owner (get_deepest_existing_node store path) in
+ Quota.check store.quota owner (String.length value);
+ let root, node_created = path_write store perm path value in
+ store.root <- root;
+ if node_created
+ then Quota.add_entry store.quota owner
+
+let mkdir store perm path =
+ let owner = Node.get_owner (get_deepest_existing_node store path) in
+ Quota.check store.quota owner 0;
+ store.root <- path_mkdir store perm path;
+ Quota.add_entry store.quota owner
+
+let rm store perm path =
+ let rmed_node = Path.get_node store.root path in
+ match rmed_node with
+ | None -> raise Define.Doesnt_exist
+ | Some rmed_node ->
+ store.root <- path_rm store perm path;
+ Node.recurse (fun node -> Quota.del_entry store.quota (Node.get_owner node)) rmed_node
+
+let setperms store perm path nperms =
+ match Path.get_node store.root path with
+ | None -> raise Define.Doesnt_exist
+ | Some node ->
+ let old_owner = Node.get_owner node in
+ let new_owner = Perms.Node.get_owner nperms in
+ Quota.check store.quota new_owner 0;
+ store.root <- path_setperms store perm path nperms;
+ Quota.del_entry store.quota old_owner;
+ Quota.add_entry store.quota new_owner
+
+type ops = {
+ store: t;
+ write: Path.t -> string -> unit;
+ mkdir: Path.t -> unit;
+ rm: Path.t -> unit;
+ setperms: Path.t -> Perms.Node.t -> unit;
+ ls: Path.t -> string list;
+ read: Path.t -> string;
+ getperms: Path.t -> Perms.Node.t;
+ path_exists: Path.t -> bool;
+}
+
+let get_ops store perms = {
+ store = store;
+ write = write store perms;
+ mkdir = mkdir store perms;
+ rm = rm store perms;
+ setperms = setperms store perms;
+ ls = ls store perms;
+ read = read store perms;
+ getperms = getperms store perms;
+ path_exists = path_exists store;
+}
+
+let create () = {
+ stat_transaction_coalesce = 0;
+ stat_transaction_abort = 0;
+ root = Node.create "" Perms.Node.default0 "";
+ quota = Quota.create ();
+}
+let copy store = {
+ stat_transaction_coalesce = store.stat_transaction_coalesce;
+ stat_transaction_abort = store.stat_transaction_abort;
+ root = store.root;
+ quota = Quota.copy store.quota;
+}
+
+let mark_symbols store =
+ Node.recurse (fun node -> Symbol.mark_as_used node.Node.name) store.root
+
+let incr_transaction_coalesce store =
+ store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1
+let incr_transaction_abort store =
+ store.stat_transaction_abort <- store.stat_transaction_abort + 1
+
+let stats store =
+ let nb_nodes = ref 0 in
+ traversal store.root (fun path node ->
+ incr nb_nodes
+ );
+ !nb_nodes, store.stat_transaction_abort, store.stat_transaction_coalesce
diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml
new file mode 100644
index 0000000..4420c6a
--- /dev/null
+++ b/tools/ocaml/xenstored/symbol.ml
@@ -0,0 +1,76 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type t = int
+
+type 'a record = { data: 'a; mutable garbage: bool }
+let int_string_tbl : (int,string record) Hashtbl.t = Hashtbl.create 1024
+let string_int_tbl : (string,int) Hashtbl.t = Hashtbl.create 1024
+
+let created_counter = ref 0
+let used_counter = ref 0
+
+let count = ref 0
+let rec fresh () =
+ if Hashtbl.mem int_string_tbl !count
+ then begin
+ incr count;
+ fresh ()
+ end else
+ !count
+
+let new_record v = { data=v; garbage=false }
+
+let of_string name =
+ if Hashtbl.mem string_int_tbl name
+ then begin
+ incr used_counter;
+ Hashtbl.find string_int_tbl name
+ end else begin
+ let i = fresh () in
+ incr created_counter;
+ Hashtbl.add string_int_tbl name i;
+ Hashtbl.add int_string_tbl i (new_record name);
+ i
+ end
+
+let to_string i =
+ (Hashtbl.find int_string_tbl i).data
+
+let mark_all_as_unused () =
+ Hashtbl.iter (fun _ v -> v.garbage <- true) int_string_tbl
+
+let mark_as_used symb =
+ let record1 = Hashtbl.find int_string_tbl symb in
+ record1.garbage <- false
+
+let garbage () =
+ let records = Hashtbl.fold (fun symb record accu ->
+ if record.garbage then (symb, record.data) :: accu else accu
+ ) int_string_tbl [] in
+ let remove (int,string) =
+ Hashtbl.remove int_string_tbl int;
+ Hashtbl.remove string_int_tbl string
+ in
+ created_counter := 0;
+ used_counter := 0;
+ List.iter remove records
+
+let stats () =
+ Hashtbl.length string_int_tbl
+
+let created () = !created_counter
+let used () = !used_counter
diff --git a/tools/ocaml/xenstored/symbol.mli b/tools/ocaml/xenstored/symbol.mli
new file mode 100644
index 0000000..8ed709f
--- /dev/null
+++ b/tools/ocaml/xenstored/symbol.mli
@@ -0,0 +1,52 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+(** Node names *)
+
+(** Xenstore nodes names are often the same, ie. "local", "domain", "device", ... so it is worth to
+ manipulate them through the use of small identifiers that we call symbols. These symbols can be
+ compared in constant time (as opposite to strings) and should help the ocaml GC. *)
+
+type t
+(** The type of symbols. *)
+
+val of_string : string -> t
+(** Convert a string into a symbol. *)
+
+val to_string : t -> string
+(** Convert a symbol into a string. *)
+
+(** {6 Garbage Collection} *)
+
+(** Symbols need to be regulary garbage collected. The following steps should be followed:
+- mark all the knowns symbols as unused (with [mark_all_as_unused]);
+- mark all the symbols really usefull as used (with [mark_as_used]); and
+- finally, call [garbage] *)
+
+val mark_all_as_unused : unit -> unit
+val mark_as_used : t -> unit
+val garbage : unit -> unit
+
+(** {6 Statistics } *)
+
+val stats : unit -> int
+(** Get the number of used symbols. *)
+
+val created : unit -> int
+(** Returns the number of symbols created since the last GC. *)
+
+val used : unit -> int
+(** Returns the number of existing symbols used since the last GC *)
diff --git a/tools/ocaml/xenstored/transaction.ml b/tools/ocaml/xenstored/transaction.ml
new file mode 100644
index 0000000..6942b25
--- /dev/null
+++ b/tools/ocaml/xenstored/transaction.ml
@@ -0,0 +1,198 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
+ *
+ * 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.
+ *)
+open Stdext
+
+let none = 0
+let test_eagain = ref false
+let do_coalesce = ref true
+
+let check_parents_perms_identical root1 root2 path =
+ let hierarch = Store.Path.get_hierarchy path in
+ let permdiff = List.fold_left (fun acc path ->
+ let n1 = Store.Path.get_node root1 path
+ and n2 = Store.Path.get_node root2 path in
+ match n1, n2 with
+ | Some n1, Some n2 ->
+ not (Perms.equiv (Store.Node.get_perms n1) (Store.Node.get_perms n2)) || acc
+ | _ ->
+ true || acc
+ ) false hierarch in
+ (not permdiff)
+
+let get_lowest path1 path2 =
+ match path2 with
+ | None -> Some path1
+ | Some path2 -> Some (Store.Path.get_common_prefix path1 path2)
+
+let test_coalesce oldroot currentroot optpath =
+ match optpath with
+ | None -> true
+ | Some path ->
+ let oldnode = Store.Path.get_node oldroot path
+ and currentnode = Store.Path.get_node currentroot path in
+
+ match oldnode, currentnode with
+ | (Some oldnode), (Some currentnode) ->
+ if oldnode == currentnode then (
+ check_parents_perms_identical oldroot currentroot path
+ ) else (
+ false
+ )
+ | None, None -> (
+ (* ok then it doesn't exists in the old version and the current version,
+ just sneak it in as a child of the parent node if it exists, or else fail *)
+ let pnode = Store.Path.get_node currentroot (Store.Path.get_parent path) in
+ match pnode with
+ | None -> false (* ok it doesn't exists, just bail out. *)
+ | Some pnode -> true
+ )
+ | _ ->
+ false
+
+let can_coalesce oldroot currentroot path =
+ if !do_coalesce then
+ try test_coalesce oldroot currentroot path with _ -> false
+ else
+ false
+
+type ty = No | Full of (int * Store.Node.t * Store.t)
+
+type t = {
+ ty: ty;
+ store: Store.t;
+ mutable ops: (Xb.Op.operation * Store.Path.t) list;
+ mutable read_lowpath: Store.Path.t option;
+ mutable write_lowpath: Store.Path.t option;
+}
+
+let make id store =
+ let ty = if id = none then No else Full(id, Store.get_root store, store) in
+ {
+ ty = ty;
+ store = if id = none then store else Store.copy store;
+ ops = [];
+ read_lowpath = None;
+ write_lowpath = None;
+ }
+
+let get_id t = match t.ty with No -> none | Full (id, _, _) -> id
+let get_store t = t.store
+let get_ops t = t.ops
+
+let add_wop t ty path = t.ops <- (ty, path) :: t.ops
+let set_read_lowpath t path = t.read_lowpath <- get_lowest path t.read_lowpath
+let set_write_lowpath t path = t.write_lowpath <- get_lowest path t.write_lowpath
+
+let path_exists t path = Store.path_exists t.store path
+
+let write t perm path value =
+ let path_exists = path_exists t path in
+ Store.write t.store perm path value;
+ if path_exists
+ then set_write_lowpath t path
+ else set_write_lowpath t (Store.Path.get_parent path);
+ add_wop t Xb.Op.Write path
+
+let mkdir ?(with_watch=true) t perm path =
+ Store.mkdir t.store perm path;
+ set_write_lowpath t path;
+ if with_watch then
+ add_wop t Xb.Op.Mkdir path
+
+let setperms t perm path perms =
+ Store.setperms t.store perm path perms;
+ set_write_lowpath t path;
+ add_wop t Xb.Op.Setperms path
+
+let rm t perm path =
+ Store.rm t.store perm path;
+ set_write_lowpath t (Store.Path.get_parent path);
+ add_wop t Xb.Op.Rm path
+
+let ls t perm path =
+ let r = Store.ls t.store perm path in
+ set_read_lowpath t path;
+ r
+
+let read t perm path =
+ let r = Store.read t.store perm path in
+ set_read_lowpath t path;
+ r
+
+let getperms t perm path =
+ let r = Store.getperms t.store perm path in
+ set_read_lowpath t path;
+ r
+
+let commit ~con t =
+ let has_write_ops = List.length t.ops > 0 in
+ let has_coalesced = ref false in
+ let has_commited =
+ match t.ty with
+ | No -> true
+ | Full (id, oldroot, cstore) ->
+ let commit_partial oldroot cstore store =
+ (* get the lowest path of the query and verify that it hasn't
+ been modified by others transactions. *)
+ if can_coalesce oldroot (Store.get_root cstore) t.read_lowpath
+ && can_coalesce oldroot (Store.get_root cstore) t.write_lowpath then (
+ maybe (fun p ->
+ let n = Store.get_node store p in
+
+ (* it has to be in the store, otherwise it means bugs
+ in the lowpath registration. we don't need to handle none. *)
+ maybe (fun n -> Store.set_node cstore p n) n;
+ Logging.write_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p);
+ ) t.write_lowpath;
+ maybe (fun p ->
+ Logging.read_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p)
+ ) t.read_lowpath;
+ has_coalesced := true;
+ Store.incr_transaction_coalesce cstore;
+ true
+ ) else (
+ (* cannot do anything simple, just discard the queries,
+ and the client need to redo it later *)
+ Store.incr_transaction_abort cstore;
+ false
+ )
+ in
+ let try_commit oldroot cstore store =
+ if oldroot == Store.get_root cstore then (
+ (* move the new root to the current store, if the oldroot
+ has not been modified *)
+ if has_write_ops then (
+ Store.set_root cstore (Store.get_root store);
+ Store.set_quota cstore (Store.get_quota store)
+ );
+ true
+ ) else
+ (* we try a partial commit if possible *)
+ commit_partial oldroot cstore store
+ in
+ if !test_eagain && Random.int 3 = 0 then
+ false
+ else
+ try_commit oldroot cstore t.store
+ in
+ if has_commited && has_write_ops then
+ Disk.write t.store;
+ if not has_commited
+ then Logging.conflict ~tid:(get_id t) ~con
+ else if not !has_coalesced
+ then Logging.commit ~tid:(get_id t) ~con;
+ has_commited
diff --git a/tools/ocaml/xenstored/utils.ml b/tools/ocaml/xenstored/utils.ml
new file mode 100644
index 0000000..68b70c5
--- /dev/null
+++ b/tools/ocaml/xenstored/utils.ml
@@ -0,0 +1,107 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+open Printf
+open Stdext
+
+(* lists utils *)
+let filter_out filter l =
+ List.filter (fun x -> not (List.mem x filter)) l
+
+let filter_in filter l =
+ List.filter (fun x -> List.mem x filter) l
+
+let list_remove element l =
+ List.filter (fun e -> e != element) l
+
+let list_tl_multi n l =
+ let rec do_tl i x =
+ if i = 0 then x else do_tl (i - 1) (List.tl x)
+ in
+ do_tl n l
+
+(* string utils *)
+let get_hierarchy path =
+ let l = List.length path in
+ let revpath = List.rev path in
+ let rec sub i =
+ let x = List.rev (list_tl_multi (l - i) revpath) in
+ if i = l then [ x ] else x :: sub (i + 1)
+ in
+ sub 0
+
+let hexify s =
+ let hexseq_of_char c = sprintf "%02x" (Char.code c) in
+ let hs = String.create (String.length s * 2) in
+ for i = 0 to String.length s - 1
+ do
+ let seq = hexseq_of_char s.[i] in
+ hs.[i * 2] <- seq.[0];
+ hs.[i * 2 + 1] <- seq.[1];
+ done;
+ hs
+
+let unhexify hs =
+ let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in
+ let s = String.create (String.length hs / 2) in
+ for i = 0 to String.length s - 1
+ do
+ s.[i] <- char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]
+ done;
+ s
+
+let trim_path path =
+ try
+ let rindex = String.rindex path '/' in
+ String.sub path 0 rindex
+ with
+ Not_found -> ""
+
+let join_by_null ls = String.concat "\000" ls
+
+(* unix utils *)
+let create_unix_socket name =
+ Unixext.unlink_safe name;
+ Unixext.mkdir_rec (Filename.dirname name) 0o700;
+ let sockaddr = Unix.ADDR_UNIX(name) in
+ let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+ Unix.bind sock sockaddr;
+ Unix.listen sock 1;
+ sock
+
+let read_file_single_integer filename =
+ let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in
+ let buf = String.make 20 (char_of_int 0) in
+ let sz = Unix.read fd buf 0 20 in
+ Unix.close fd;
+ int_of_string (String.sub buf 0 sz)
+
+let path_complete path connection_path =
+ if String.get path 0 <> '/' then
+ connection_path ^ path
+ else
+ path
+
+let path_validate path connection_path =
+ if String.length path = 0 || String.length path > 1024 then
+ raise Define.Invalid_path
+ else
+ let cpath = path_complete path connection_path in
+ if String.get cpath 0 <> '/' then
+ raise Define.Invalid_path
+ else
+ cpath
+
diff --git a/tools/ocaml/xenstored/xenstored.conf b/tools/ocaml/xenstored/xenstored.conf
new file mode 100644
index 0000000..0e0e5fb
--- /dev/null
+++ b/tools/ocaml/xenstored/xenstored.conf
@@ -0,0 +1,30 @@
+# default xenstored config
+
+# Where the pid file is stored
+pid-file = /var/run/xensource/xenstored.pid
+
+# Randomly failed a transaction with EAGAIN. Used for testing Xs user
+test-eagain = true
+
+# Activate transaction merge support
+merge-activate = true
+
+# Activate node permission system
+perms-activate = true
+
+# Activate quota
+quota-activate = true
+quota-maxentity = 1000
+quota-maxsize = 2048
+quota-maxwatch = 100
+quota-transaction = 10
+
+# Activate filed base backend
+persistant = false
+
+# Logs
+log = error;general;file:/var/log/xenstored.log
+log = warn;general;file:/var/log/xenstored.log
+log = info;general;file:/var/log/xenstored.log
+
+# log = debug;io;file:/var/log/xenstored-io.log
diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml
new file mode 100644
index 0000000..44223eb
--- /dev/null
+++ b/tools/ocaml/xenstored/xenstored.ml
@@ -0,0 +1,404 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+open Printf
+open Parse_arg
+open Stdext
+open Logging
+
+(*------------ event klass processors --------------*)
+let process_connection_fds store cons domains rset wset =
+ let try_fct fct c =
+ try
+ fct store cons domains c
+ with
+ | Unix.Unix_error(err, "write", _) ->
+ Connections.del_anonymous cons c;
+ error "closing socket connection: write error: %s"
+ (Unix.error_message err)
+ | Unix.Unix_error(err, "read", _) ->
+ Connections.del_anonymous cons c;
+ if err <> Unix.ECONNRESET then
+ error "closing socket connection: read error: %s"
+ (Unix.error_message err)
+ | Xb.End_of_file ->
+ Connections.del_anonymous cons c;
+ debug "closing socket connection"
+ in
+ let process_fdset_with fds fct =
+ List.iter (fun fd ->
+ try try_fct fct (Connections.find cons fd)
+ with Not_found -> ()) fds
+ in
+ process_fdset_with rset Process.do_input;
+ process_fdset_with wset Process.do_output
+
+let process_domains store cons domains =
+ let do_io_domain domain =
+ let con = Connections.find_domain cons (Domain.get_id domain) in
+ Process.do_input store cons domains con;
+ Process.do_output store cons domains con in
+ Domains.iter domains do_io_domain
+
+let sigusr1_handler store =
+ try
+ let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ]
+ 0o600 "/var/run/xenstored/db.debug" in
+ finally (fun () -> Store.dump store channel)
+ (fun () -> close_out channel)
+ with _ ->
+ ()
+
+let sighup_handler _ =
+ try Logs.reopen (); info "Log re-opened" with _ -> ()
+
+let config_filename cf =
+ match cf.config_file with
+ | Some name -> name
+ | None -> Define.default_config_dir ^ "/xenstored.conf"
+
+let default_pidfile = "/var/run/xenstored.pid"
+
+let parse_config filename =
+ let pidfile = ref default_pidfile in
+ let set_log s =
+ let ls = String.split ~limit:3 ';' s in
+ let level, key, logger = match ls with
+ | [ level; key; logger ] -> level, key, logger
+ | _ -> failwith "format mismatch: expecting 3 arguments" in
+
+ let loglevel = match level with
+ | "debug" -> Log.Debug
+ | "info" -> Log.Info
+ | "warn" -> Log.Warn
+ | "error" -> Log.Error
+ | s -> failwith (sprintf "Unknown log level: %s" s) in
+
+ (* if key is empty, append to the default logger *)
+ let append =
+ if key = "" then
+ Logs.append_default
+ else
+ Logs.append key in
+ append loglevel logger in
+ let options = [
+ ("merge-activate", Config.Set_bool Transaction.do_coalesce);
+ ("perms-activate", Config.Set_bool Perms.activate);
+ ("quota-activate", Config.Set_bool Quota.activate);
+ ("quota-maxwatch", Config.Set_int Define.maxwatch);
+ ("quota-transaction", Config.Set_int Define.maxtransaction);
+ ("quota-maxentity", Config.Set_int Quota.maxent);
+ ("quota-maxsize", Config.Set_int Quota.maxsize);
+ ("test-eagain", Config.Set_bool Transaction.test_eagain);
+ ("log", Config.String set_log);
+ ("persistant", Config.Set_bool Disk.enable);
+ ("access-log-file", Config.Set_string Logging.access_log_file);
+ ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files);
+ ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines);
+ ("access-log-read-ops", Config.Set_bool Logging.log_read_ops);
+ ("access-log-transactions-ops", Config.Set_bool Logging.log_transaction_ops);
+ ("access-log-special-ops", Config.Set_bool Logging.log_special_ops);
+ ("allow-debug", Config.Set_bool Process.allow_debug);
+ ("pid-file", Config.Set_string pidfile); ] in
+ begin try Config.read filename options (fun _ _ -> raise Not_found)
+ with
+ | Config.Error err -> List.iter (fun (k, e) ->
+ match e with
+ | "unknown key" -> eprintf "config: unknown key %s\n" k
+ | _ -> eprintf "config: %s: %s\n" k e
+ ) err;
+ | Sys_error m -> eprintf "error: config: %s\n" m;
+ end;
+ !pidfile
+
+module DB = struct
+
+exception Bad_format of string
+
+let dump_format_header = "$xenstored-dump-format"
+
+let from_channel_f chan domain_f watch_f store_f =
+ let unhexify s = Utils.unhexify s in
+ let getpath s = Store.Path.of_string (Utils.unhexify s) in
+ let header = input_line chan in
+ if header <> dump_format_header then
+ raise (Bad_format "header");
+ let quit = ref false in
+ while not !quit
+ do
+ try
+ let line = input_line chan in
+ let l = String.split ',' line in
+ try
+ match l with
+ | "dom" :: domid :: mfn :: port :: []->
+ domain_f (int_of_string domid)
+ (Nativeint.of_string mfn)
+ (int_of_string port)
+ | "watch" :: domid :: path :: token :: [] ->
+ watch_f (int_of_string domid)
+ (unhexify path) (unhexify token)
+ | "store" :: path :: perms :: value :: [] ->
+ store_f (getpath path)
+ (Perms.Node.of_string (unhexify perms ^ "\000"))
+ (unhexify value)
+ | _ ->
+ info "restoring: ignoring unknown line: %s" line
+ with exn ->
+ info "restoring: ignoring unknown line: %s (exception: %s)"
+ line (Printexc.to_string exn);
+ ()
+ with End_of_file ->
+ quit := true
+ done;
+ ()
+
+let from_channel store cons doms chan =
+ (* don't let the permission get on our way, full perm ! *)
+ let op = Store.get_ops store Perms.Connection.full_rights in
+ let xc = Xc.interface_open () in
+
+ let domain_f domid mfn port =
+ let ndom =
+ if domid > 0 then
+ Domains.create xc doms domid mfn port
+ else
+ Domains.create0 false doms
+ in
+ Connections.add_domain cons ndom;
+ in
+ let watch_f domid path token =
+ let con = Connections.find_domain cons domid in
+ ignore (Connections.add_watch cons con path token)
+ in
+ let store_f path perms value =
+ op.Store.write path value;
+ op.Store.setperms path perms
+ in
+ finally (fun () -> from_channel_f chan domain_f watch_f store_f)
+ (fun () -> Xc.interface_close xc)
+
+let from_file store cons doms file =
+ let channel = open_in file in
+ finally (fun () -> from_channel store doms cons channel)
+ (fun () -> close_in channel)
+
+let to_channel store cons chan =
+ let hexify s = Utils.hexify s in
+
+ fprintf chan "%s\n" dump_format_header;
+
+ (* dump connections related to domains; domid, mfn, eventchn port, watches *)
+ Connections.iter_domains cons (fun con -> Connection.dump con chan);
+
+ (* dump the store *)
+ Store.dump_fct store (fun path node ->
+ let name, perms, value = Store.Node.unpack node in
+ let fullpath = (Store.Path.to_string path) ^ "/" ^ name in
+ let permstr = Perms.Node.to_string perms in
+ fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexify value)
+ );
+ flush chan;
+ ()
+
+
+let to_file store cons file =
+ let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o600 file in
+ finally (fun () -> to_channel store cons channel)
+ (fun () -> close_out channel)
+end
+
+let _ =
+ printf "Xen Storage Daemon, version %d.%d\n%!"
+ Define.xenstored_major Define.xenstored_minor;
+
+ let cf = do_argv in
+ let pidfile =
+ if Sys.file_exists (config_filename cf) then
+ parse_config (config_filename cf)
+ else
+ default_pidfile
+ in
+
+ (try
+ Unixext.mkdir_rec (Filename.dirname pidfile) 0o755
+ with _ ->
+ ()
+ );
+
+ let rw_sock, ro_sock =
+ if cf.disable_socket then
+ None, None
+ else
+ Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket),
+ Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket_ro)
+ in
+
+ if cf.daemonize then
+ Unixext.daemonize ();
+
+ (try Unixext.pidfile_write pidfile with _ -> ());
+
+ info "Xen Storage Daemon, version %d.%d"
+ Define.xenstored_major Define.xenstored_minor;
+
+ (* for compatilibity with old xenstored *)
+ begin match cf.pidfile with
+ | Some pidfile -> Unixext.pidfile_write pidfile
+ | None -> () end;
+
+ let store = Store.create () in
+ let eventchn = Event.init () in
+ let domains = Domains.init eventchn in
+ let cons = Connections.create () in
+
+ let quit = ref false in
+
+ if cf.restart then (
+ DB.from_file store domains cons "/var/run/xenstored/db";
+ Event.bind_virq eventchn
+ ) else (
+ if !Disk.enable then (
+ info "reading store from disk";
+ Disk.read store
+ );
+
+ let localpath = Store.Path.of_string "/local" in
+ if not (Store.path_exists store localpath) then
+ Store.mkdir store (Perms.Connection.create 0) localpath;
+
+ if cf.domain_init then (
+ let usingxiu = Xc.using_injection () in
+ Connections.add_domain cons (Domains.create0 usingxiu domains);
+ Event.bind_virq eventchn
+ );
+ );
+
+ Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler);
+ Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun i -> quit := true));
+ Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun i -> sigusr1_handler store));
+ Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
+
+ Logging.init cf.activate_access_log (fun () -> DB.to_file store cons "/var/run/xenstored/db");
+
+ let spec_fds =
+ (match rw_sock with None -> [] | Some x -> [ x ]) @
+ (match ro_sock with None -> [] | Some x -> [ x ]) @
+ (if cf.domain_init then [ eventchn.Event.fd ] else [])
+ in
+
+ let xc = Xc.interface_open () in
+
+ let process_special_fds rset =
+ let accept_connection can_write fd =
+ let (cfd, addr) = Unix.accept fd in
+ debug "new connection through socket";
+ Connections.add_anonymous cons cfd can_write
+ and handle_eventchn fd =
+ let port = Event.read_port eventchn in
+ finally (fun () ->
+ if port = eventchn.Event.virq_port then (
+ let (notify, deaddom) = Domains.cleanup xc domains in
+ List.iter (Connections.del_domain cons) deaddom;
+ if deaddom <> [] || notify then
+ Connections.fire_spec_watches cons "@releaseDomain"
+ )
+ ) (fun () -> Event.write_port eventchn port);
+ and do_if_set fd set fct =
+ if List.mem fd set then
+ fct fd in
+
+ maybe (fun fd -> do_if_set fd rset (accept_connection true)) rw_sock;
+ maybe (fun fd -> do_if_set fd rset (accept_connection false)) ro_sock;
+ do_if_set eventchn.Event.fd rset (handle_eventchn)
+ in
+
+ let last_stat_time = ref 0. in
+ let periodic_ops_counter = ref 0 in
+ let periodic_ops () =
+ (* we garbage collect the string->int dictionary after a sizeable amount of operations,
+ * there's no need to be really fast even if we got loose
+ * objects since names are often reuse.
+ *)
+ if Symbol.created () > 1000 || Symbol.used () > 20000
+ then begin
+ Symbol.mark_all_as_unused ();
+ Store.mark_symbols store;
+ Connections.iter cons Connection.mark_symbols;
+ Symbol.garbage ()
+ end;
+
+ (* make sure we don't print general stats faster than 2 min *)
+ let ntime = Unix.gettimeofday () in
+ if ntime > (!last_stat_time +. 120.) then (
+ last_stat_time := ntime;
+
+ let gc = Gc.stat () in
+ let (lanon, lanon_ops, lanon_watchs,
+ ldom, ldom_ops, ldom_watchs) = Connections.stats cons in
+ let store_nodes, store_abort, store_coalesce = Store.stats store in
+ let symtbl_len = Symbol.stats () in
+
+ info "store stat: nodes(%d) t-abort(%d) t-coalesce(%d)"
+ store_nodes store_abort store_coalesce;
+ info "sytbl stat: %d" symtbl_len;
+ info " con stat: anonymous(%d, %d o, %d w) domains(%d, %d o, %d w)"
+ lanon lanon_ops lanon_watchs ldom ldom_ops ldom_watchs;
+ info " mem stat: minor(%.0f) promoted(%.0f) major(%.0f) heap(%d w, %d c) live(%d w, %d b) free(%d w, %d b)"
+ gc.Gc.minor_words gc.Gc.promoted_words gc.Gc.major_words
+ gc.Gc.heap_words gc.Gc.heap_chunks
+ gc.Gc.live_words gc.Gc.live_blocks
+ gc.Gc.free_words gc.Gc.free_blocks
+ )
+ in
+
+ let main_loop () =
+ incr periodic_ops_counter;
+ if !periodic_ops_counter > 20 then (
+ periodic_ops_counter := 0;
+ periodic_ops ();
+ );
+
+ let mw = Connections.has_more_work cons in
+ let inset, outset = Connections.select cons in
+ let timeout = if List.length mw > 0 then 0. else -1. in
+ let rset, wset, _ =
+ try
+ Unix.select (spec_fds @ inset) outset [] timeout
+ with Unix.Unix_error(Unix.EINTR, _, _) ->
+ [], [], [] in
+ let sfds, cfds =
+ List.partition (fun fd -> List.mem fd spec_fds) rset in
+ if List.length sfds > 0 then
+ process_special_fds sfds;
+ if List.length cfds > 0 || List.length wset > 0 then
+ process_connection_fds store cons domains cfds wset;
+ process_domains store cons domains
+ in
+
+ while not !quit
+ do
+ try
+ main_loop ()
+ with exc ->
+ error "caught exception %s" (Printexc.to_string exc);
+ if cf.reraise_top_level then
+ raise exc
+ done;
+ info "stopping xenstored";
+ DB.to_file store cons "/var/run/xenstored/db";
+ ()
[-- Attachment #3: Type: text/plain, Size: 138 bytes --]
_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xensource.com
http://lists.xensource.com/xen-devel
^ permalink raw reply related [flat|nested] 12+ messages in thread