* [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies
@ 2010-03-09 14:41 Vincent Hanquez
2010-03-09 14:41 ` [PATCH 01/10] add ocaml mmap bindings implementation Vincent Hanquez
` (9 more replies)
0 siblings, 10 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: 9608 bytes --]
Add ocaml xenstored into xen as an alternative to C xenstored.
The goal is to choose it as the default xenstored on the target machine when it has
been built.
build hook mechanism is not ideal, but should be safe for platform that
cannot build ocaml and/or would have some portability issues.
This is RFC, although the first 5 patches are completly safe since they just
introduce new files and hook with default =n the new files. only the 6th patch
make the default to build ocaml tools with fallback if not available.
since v1:
* rebased to latest xen-unstable
* remove stdext ocaml library and folded dependencies into xenstored
* split dependencies in smaller patches
Vincent Hanquez (10):
add ocaml mmap bindings implementation.
add ocaml XC bindings.
add XS ocaml bindings.
add uuid ocaml bindings
add logs ocaml bindings
add ocaml xenstored
add compilation makefile to ocaml directory
remove hook from external ocaml repository
add ocaml tools to build if defined. default to n
default ocaml tools config variable to y
Config.mk | 15 +-
tools/Makefile | 23 +-
tools/ocaml/Makefile | 36 +
tools/ocaml/Makefile.rules | 93 ++
tools/ocaml/common.make | 28 +
tools/ocaml/libs/eventchn/META.in | 4 +
tools/ocaml/libs/eventchn/Makefile | 28 +
tools/ocaml/libs/eventchn/eventchn.ml | 27 +
tools/ocaml/libs/eventchn/eventchn.mli | 26 +
tools/ocaml/libs/eventchn/eventchn_stubs.c | 173 ++++
tools/ocaml/libs/log/META.in | 4 +
tools/ocaml/libs/log/Makefile | 41 +
tools/ocaml/libs/log/log.ml | 258 +++++
tools/ocaml/libs/log/log.mli | 55 +
tools/ocaml/libs/log/logs.ml | 197 ++++
tools/ocaml/libs/log/logs.mli | 46 +
tools/ocaml/libs/log/syslog.ml | 26 +
tools/ocaml/libs/log/syslog.mli | 41 +
tools/ocaml/libs/log/syslog_stubs.c | 73 ++
tools/ocaml/libs/mmap/META.in | 4 +
tools/ocaml/libs/mmap/Makefile | 27 +
tools/ocaml/libs/mmap/mmap.ml | 31 +
tools/ocaml/libs/mmap/mmap.mli | 28 +
tools/ocaml/libs/mmap/mmap_stubs.c | 136 +++
tools/ocaml/libs/mmap/mmap_stubs.h | 33 +
tools/ocaml/libs/uuid/META.in | 4 +
tools/ocaml/libs/uuid/Makefile | 26 +
tools/ocaml/libs/uuid/uuid.ml | 88 ++
tools/ocaml/libs/uuid/uuid.mli | 53 +
tools/ocaml/libs/xb/META.in | 4 +
tools/ocaml/libs/xb/Makefile | 41 +
tools/ocaml/libs/xb/op.ml | 84 ++
tools/ocaml/libs/xb/packet.ml | 50 +
tools/ocaml/libs/xb/partial.ml | 44 +
tools/ocaml/libs/xb/xb.ml | 189 ++++
tools/ocaml/libs/xb/xb.mli | 83 ++
tools/ocaml/libs/xb/xb_stubs.c | 74 ++
tools/ocaml/libs/xb/xs_ring.ml | 18 +
tools/ocaml/libs/xb/xs_ring_stubs.c | 117 +++
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 ++++++++++++++++++++++
tools/ocaml/libs/xs/META.in | 4 +
tools/ocaml/libs/xs/Makefile | 42 +
tools/ocaml/libs/xs/queueop.ml | 73 ++
tools/ocaml/libs/xs/xs.ml | 170 ++++
tools/ocaml/libs/xs/xs.mli | 90 ++
tools/ocaml/libs/xs/xsraw.ml | 265 +++++
tools/ocaml/libs/xs/xsraw.mli | 60 ++
tools/ocaml/libs/xs/xst.ml | 61 ++
tools/ocaml/libs/xs/xst.mli | 30 +
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 ++++++++
tools/xenstore/Makefile | 5 -
80 files changed, 10168 insertions(+), 32 deletions(-)
create mode 100644 tools/ocaml/Makefile
create mode 100644 tools/ocaml/Makefile.rules
create mode 100644 tools/ocaml/common.make
create mode 100644 tools/ocaml/libs/eventchn/META.in
create mode 100644 tools/ocaml/libs/eventchn/Makefile
create mode 100644 tools/ocaml/libs/eventchn/eventchn.ml
create mode 100644 tools/ocaml/libs/eventchn/eventchn.mli
create mode 100644 tools/ocaml/libs/eventchn/eventchn_stubs.c
create mode 100644 tools/ocaml/libs/log/META.in
create mode 100644 tools/ocaml/libs/log/Makefile
create mode 100644 tools/ocaml/libs/log/log.ml
create mode 100644 tools/ocaml/libs/log/log.mli
create mode 100644 tools/ocaml/libs/log/logs.ml
create mode 100644 tools/ocaml/libs/log/logs.mli
create mode 100644 tools/ocaml/libs/log/syslog.ml
create mode 100644 tools/ocaml/libs/log/syslog.mli
create mode 100644 tools/ocaml/libs/log/syslog_stubs.c
create mode 100644 tools/ocaml/libs/mmap/META.in
create mode 100644 tools/ocaml/libs/mmap/Makefile
create mode 100644 tools/ocaml/libs/mmap/mmap.ml
create mode 100644 tools/ocaml/libs/mmap/mmap.mli
create mode 100644 tools/ocaml/libs/mmap/mmap_stubs.c
create mode 100644 tools/ocaml/libs/mmap/mmap_stubs.h
create mode 100644 tools/ocaml/libs/uuid/META.in
create mode 100644 tools/ocaml/libs/uuid/Makefile
create mode 100644 tools/ocaml/libs/uuid/uuid.ml
create mode 100644 tools/ocaml/libs/uuid/uuid.mli
create mode 100644 tools/ocaml/libs/xb/META.in
create mode 100644 tools/ocaml/libs/xb/Makefile
create mode 100644 tools/ocaml/libs/xb/op.ml
create mode 100644 tools/ocaml/libs/xb/packet.ml
create mode 100644 tools/ocaml/libs/xb/partial.ml
create mode 100644 tools/ocaml/libs/xb/xb.ml
create mode 100644 tools/ocaml/libs/xb/xb.mli
create mode 100644 tools/ocaml/libs/xb/xb_stubs.c
create mode 100644 tools/ocaml/libs/xb/xs_ring.ml
create mode 100644 tools/ocaml/libs/xb/xs_ring_stubs.c
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
create mode 100644 tools/ocaml/libs/xs/META.in
create mode 100644 tools/ocaml/libs/xs/Makefile
create mode 100644 tools/ocaml/libs/xs/queueop.ml
create mode 100644 tools/ocaml/libs/xs/xs.ml
create mode 100644 tools/ocaml/libs/xs/xs.mli
create mode 100644 tools/ocaml/libs/xs/xsraw.ml
create mode 100644 tools/ocaml/libs/xs/xsraw.mli
create mode 100644 tools/ocaml/libs/xs/xst.ml
create mode 100644 tools/ocaml/libs/xs/xst.mli
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
[-- Attachment #2: Type: text/plain, Size: 138 bytes --]
_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xensource.com
http://lists.xensource.com/xen-devel
^ permalink raw reply [flat|nested] 12+ messages in thread
* [PATCH 01/10] add ocaml mmap bindings implementation.
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 02/10] add ocaml XC bindings Vincent Hanquez
` (8 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: 883 bytes --]
this is quite similar to the mmap functionality available in bigarray but it's less complicated.
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/libs/mmap/META.in | 4 +
tools/ocaml/libs/mmap/Makefile | 27 +++++++
tools/ocaml/libs/mmap/mmap.ml | 31 ++++++++
tools/ocaml/libs/mmap/mmap.mli | 28 ++++++++
tools/ocaml/libs/mmap/mmap_stubs.c | 136 ++++++++++++++++++++++++++++++++++++
tools/ocaml/libs/mmap/mmap_stubs.h | 33 +++++++++
6 files changed, 259 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/libs/mmap/META.in
create mode 100644 tools/ocaml/libs/mmap/Makefile
create mode 100644 tools/ocaml/libs/mmap/mmap.ml
create mode 100644 tools/ocaml/libs/mmap/mmap.mli
create mode 100644 tools/ocaml/libs/mmap/mmap_stubs.c
create mode 100644 tools/ocaml/libs/mmap/mmap_stubs.h
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-add-ocaml-mmap-bindings-implementation.patch --]
[-- Type: text/x-patch; name="0001-add-ocaml-mmap-bindings-implementation.patch", Size: 9470 bytes --]
diff --git a/tools/ocaml/libs/mmap/META.in b/tools/ocaml/libs/mmap/META.in
new file mode 100644
index 0000000..1d71548
--- /dev/null
+++ b/tools/ocaml/libs/mmap/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Mmap interface extension"
+archive(byte) = "mmap.cma"
+archive(native) = "mmap.cmxa"
diff --git a/tools/ocaml/libs/mmap/Makefile b/tools/ocaml/libs/mmap/Makefile
new file mode 100644
index 0000000..bd8ab43
--- /dev/null
+++ b/tools/ocaml/libs/mmap/Makefile
@@ -0,0 +1,27 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = mmap
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = mmap.cma mmap.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+mmap_OBJS = $(OBJS)
+mmap_C_OBJS = mmap_stubs
+OCAML_LIBRARY = mmap
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore mmap META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove mmap
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/mmap/mmap.ml b/tools/ocaml/libs/mmap/mmap.ml
new file mode 100644
index 0000000..44b67c8
--- /dev/null
+++ b/tools/ocaml/libs/mmap/mmap.ml
@@ -0,0 +1,31 @@
+(*
+ * 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 mmap_interface
+
+type mmap_prot_flag = RDONLY | WRONLY | RDWR
+type mmap_map_flag = SHARED | PRIVATE
+
+(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *)
+external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
+ -> int -> int -> mmap_interface = "stub_mmap_init"
+external unmap: mmap_interface -> unit = "stub_mmap_final"
+(* read: interface -> start -> length -> data *)
+external read: mmap_interface -> int -> int -> string = "stub_mmap_read"
+(* write: interface -> data -> start -> length -> unit *)
+external write: mmap_interface -> string -> int -> int -> unit = "stub_mmap_write"
+(* getpagesize: unit -> size of page *)
+external getpagesize: unit -> int = "stub_mmap_getpagesize"
diff --git a/tools/ocaml/libs/mmap/mmap.mli b/tools/ocaml/libs/mmap/mmap.mli
new file mode 100644
index 0000000..8f92ed6
--- /dev/null
+++ b/tools/ocaml/libs/mmap/mmap.mli
@@ -0,0 +1,28 @@
+(*
+ * 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 mmap_interface
+type mmap_prot_flag = RDONLY | WRONLY | RDWR
+type mmap_map_flag = SHARED | PRIVATE
+
+external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int
+ -> mmap_interface = "stub_mmap_init"
+external unmap : mmap_interface -> unit = "stub_mmap_final"
+external read : mmap_interface -> int -> int -> string = "stub_mmap_read"
+external write : mmap_interface -> string -> int -> int -> unit
+ = "stub_mmap_write"
+
+external getpagesize : unit -> int = "stub_mmap_getpagesize"
diff --git a/tools/ocaml/libs/mmap/mmap_stubs.c b/tools/ocaml/libs/mmap/mmap_stubs.c
new file mode 100644
index 0000000..e32cef6
--- /dev/null
+++ b/tools/ocaml/libs/mmap/mmap_stubs.c
@@ -0,0 +1,136 @@
+/*
+ * 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 <unistd.h>
+#include <stdlib.h>
+#include <sys/mman.h>
+#include <string.h>
+#include <errno.h>
+#include "mmap_stubs.h"
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
+
+static int mmap_interface_init(struct mmap_interface *intf,
+ int fd, int pflag, int mflag,
+ int len, int offset)
+{
+ intf->len = len;
+ intf->addr = mmap(NULL, len, pflag, mflag, fd, offset);
+ return (intf->addr == MAP_FAILED) ? errno : 0;
+}
+
+CAMLprim value stub_mmap_init(value fd, value pflag, value mflag,
+ value len, value offset)
+{
+ CAMLparam5(fd, pflag, mflag, len, offset);
+ CAMLlocal1(result);
+ int c_pflag, c_mflag;
+
+ switch (Int_val(pflag)) {
+ case 0: c_pflag = PROT_READ; break;
+ case 1: c_pflag = PROT_WRITE; break;
+ case 2: c_pflag = PROT_READ|PROT_WRITE; break;
+ default: caml_invalid_argument("protectiontype");
+ }
+
+ switch (Int_val(mflag)) {
+ case 0: c_mflag = MAP_SHARED; break;
+ case 1: c_mflag = MAP_PRIVATE; break;
+ default: caml_invalid_argument("maptype");
+ }
+
+ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
+
+ if (mmap_interface_init(GET_C_STRUCT(result), Int_val(fd),
+ c_pflag, c_mflag,
+ Int_val(len), Int_val(offset)))
+ caml_failwith("mmap");
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_mmap_final(value interface)
+{
+ CAMLparam1(interface);
+ struct mmap_interface *intf;
+
+ intf = GET_C_STRUCT(interface);
+ if (intf->addr != MAP_FAILED)
+ munmap(intf->addr, intf->len);
+ intf->addr = MAP_FAILED;
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_mmap_read(value interface, value start, value len)
+{
+ CAMLparam3(interface, start, len);
+ CAMLlocal1(data);
+ struct mmap_interface *intf;
+ int c_start;
+ int c_len;
+
+ c_start = Int_val(start);
+ c_len = Int_val(len);
+ intf = GET_C_STRUCT(interface);
+
+ if (c_start > intf->len)
+ caml_invalid_argument("start invalid");
+ if (c_start + c_len > intf->len)
+ caml_invalid_argument("len invalid");
+
+ data = caml_alloc_string(c_len);
+ memcpy((char *) data, intf->addr + c_start, c_len);
+
+ CAMLreturn(data);
+}
+
+CAMLprim value stub_mmap_write(value interface, value data,
+ value start, value len)
+{
+ CAMLparam4(interface, data, start, len);
+ struct mmap_interface *intf;
+ int c_start;
+ int c_len;
+
+ c_start = Int_val(start);
+ c_len = Int_val(len);
+ intf = GET_C_STRUCT(interface);
+
+ if (c_start > intf->len)
+ caml_invalid_argument("start invalid");
+ if (c_start + c_len > intf->len)
+ caml_invalid_argument("len invalid");
+
+ memcpy(intf->addr + c_start, (char *) data, c_len);
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_mmap_getpagesize(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(data);
+
+ data = Val_int(getpagesize());
+ CAMLreturn(data);
+}
diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/mmap_stubs.h
new file mode 100644
index 0000000..65e4239
--- /dev/null
+++ b/tools/ocaml/libs/mmap/mmap_stubs.h
@@ -0,0 +1,33 @@
+/*
+ * 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.
+ */
+
+#ifndef C_MMAP_H
+#define C_MMAP_H
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+struct mmap_interface
+{
+ void *addr;
+ int len;
+};
+
+#endif
[-- 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 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 03/10] add XS ocaml 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 ` [PATCH 02/10] add ocaml XC bindings Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 04/10] add uuid " Vincent Hanquez
` (6 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: 2835 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/libs/eventchn/META.in | 4 +
tools/ocaml/libs/eventchn/Makefile | 28 +++
tools/ocaml/libs/eventchn/eventchn.ml | 27 +++
tools/ocaml/libs/eventchn/eventchn.mli | 26 +++
tools/ocaml/libs/eventchn/eventchn_stubs.c | 173 ++++++++++++++++++
tools/ocaml/libs/xb/META.in | 4 +
tools/ocaml/libs/xb/Makefile | 41 +++++
tools/ocaml/libs/xb/op.ml | 84 +++++++++
tools/ocaml/libs/xb/packet.ml | 50 ++++++
tools/ocaml/libs/xb/partial.ml | 44 +++++
tools/ocaml/libs/xb/xb.ml | 189 ++++++++++++++++++++
tools/ocaml/libs/xb/xb.mli | 83 +++++++++
tools/ocaml/libs/xb/xb_stubs.c | 74 ++++++++
tools/ocaml/libs/xb/xs_ring.ml | 18 ++
tools/ocaml/libs/xb/xs_ring_stubs.c | 117 ++++++++++++
tools/ocaml/libs/xs/META.in | 4 +
tools/ocaml/libs/xs/Makefile | 42 +++++
tools/ocaml/libs/xs/queueop.ml | 73 ++++++++
tools/ocaml/libs/xs/xs.ml | 170 ++++++++++++++++++
tools/ocaml/libs/xs/xs.mli | 90 ++++++++++
tools/ocaml/libs/xs/xsraw.ml | 265 ++++++++++++++++++++++++++++
tools/ocaml/libs/xs/xsraw.mli | 60 +++++++
tools/ocaml/libs/xs/xst.ml | 61 +++++++
tools/ocaml/libs/xs/xst.mli | 30 +++
24 files changed, 1757 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/libs/eventchn/META.in
create mode 100644 tools/ocaml/libs/eventchn/Makefile
create mode 100644 tools/ocaml/libs/eventchn/eventchn.ml
create mode 100644 tools/ocaml/libs/eventchn/eventchn.mli
create mode 100644 tools/ocaml/libs/eventchn/eventchn_stubs.c
create mode 100644 tools/ocaml/libs/xb/META.in
create mode 100644 tools/ocaml/libs/xb/Makefile
create mode 100644 tools/ocaml/libs/xb/op.ml
create mode 100644 tools/ocaml/libs/xb/packet.ml
create mode 100644 tools/ocaml/libs/xb/partial.ml
create mode 100644 tools/ocaml/libs/xb/xb.ml
create mode 100644 tools/ocaml/libs/xb/xb.mli
create mode 100644 tools/ocaml/libs/xb/xb_stubs.c
create mode 100644 tools/ocaml/libs/xb/xs_ring.ml
create mode 100644 tools/ocaml/libs/xb/xs_ring_stubs.c
create mode 100644 tools/ocaml/libs/xs/META.in
create mode 100644 tools/ocaml/libs/xs/Makefile
create mode 100644 tools/ocaml/libs/xs/queueop.ml
create mode 100644 tools/ocaml/libs/xs/xs.ml
create mode 100644 tools/ocaml/libs/xs/xs.mli
create mode 100644 tools/ocaml/libs/xs/xsraw.ml
create mode 100644 tools/ocaml/libs/xs/xsraw.mli
create mode 100644 tools/ocaml/libs/xs/xst.ml
create mode 100644 tools/ocaml/libs/xs/xst.mli
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0003-add-XS-ocaml-bindings.patch --]
[-- Type: text/x-patch; name="0003-add-XS-ocaml-bindings.patch", Size: 61082 bytes --]
diff --git a/tools/ocaml/libs/eventchn/META.in b/tools/ocaml/libs/eventchn/META.in
new file mode 100644
index 0000000..f3e01aa
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Eventchn interface extension"
+archive(byte) = "eventchn.cma"
+archive(native) = "eventchn.cmxa"
diff --git a/tools/ocaml/libs/eventchn/Makefile b/tools/ocaml/libs/eventchn/Makefile
new file mode 100644
index 0000000..9d6ef31
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/Makefile
@@ -0,0 +1,28 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = eventchn
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = eventchn.cma eventchn.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+eventchn_OBJS = $(OBJS)
+eventchn_C_OBJS = eventchn_stubs
+
+OCAML_LIBRARY = eventchn
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove eventchn
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/eventchn/eventchn.ml b/tools/ocaml/libs/eventchn/eventchn.ml
new file mode 100644
index 0000000..c4a7fa3
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/eventchn.ml
@@ -0,0 +1,27 @@
+(*
+ * 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 Error of string
+
+external init: unit -> Unix.file_descr = "stub_eventchn_init"
+external notify: Unix.file_descr -> int -> unit = "stub_eventchn_notify"
+external bind_interdomain: Unix.file_descr -> int -> int -> int = "stub_eventchn_bind_interdomain"
+external bind_virq: Unix.file_descr -> int = "stub_eventchn_bind_virq"
+external unbind: Unix.file_descr -> int -> unit = "stub_eventchn_unbind"
+external read_port: Unix.file_descr -> int = "stub_eventchn_read_port"
+external write_port: Unix.file_descr -> int -> unit = "stub_eventchn_write_port"
+
+let _ = Callback.register_exception "eventchn.error" (Error "register_callback")
diff --git a/tools/ocaml/libs/eventchn/eventchn.mli b/tools/ocaml/libs/eventchn/eventchn.mli
new file mode 100644
index 0000000..7088700
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/eventchn.mli
@@ -0,0 +1,26 @@
+(*
+ * 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 Error of string
+external init : unit -> Unix.file_descr = "stub_eventchn_init"
+external notify : Unix.file_descr -> int -> unit = "stub_eventchn_notify"
+external bind_interdomain : Unix.file_descr -> int -> int -> int
+ = "stub_eventchn_bind_interdomain"
+external bind_virq : Unix.file_descr -> int = "stub_eventchn_bind_virq"
+external unbind : Unix.file_descr -> int -> unit = "stub_eventchn_unbind"
+external read_port : Unix.file_descr -> int = "stub_eventchn_read_port"
+external write_port : Unix.file_descr -> int -> unit
+ = "stub_eventchn_write_port"
diff --git a/tools/ocaml/libs/eventchn/eventchn_stubs.c b/tools/ocaml/libs/eventchn/eventchn_stubs.c
new file mode 100644
index 0000000..ab61b0a
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/eventchn_stubs.c
@@ -0,0 +1,173 @@
+/*
+ * 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 <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <errno.h>
+#include <stdint.h>
+
+#include <sys/ioctl.h>
+
+#define __XEN_TOOLS__
+
+#include <xen/sysctl.h>
+
+#if XEN_SYSCTL_INTERFACE_VERSION < 4
+#include <xen/linux/evtchn.h>
+#else
+#include <xen/xen.h>
+#include <xen/sys/evtchn.h>
+#endif
+
+#include <xenctrl.h>
+
+#define CAML_NAME_SPACE
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#define EVENTCHN_PATH "/dev/xen/eventchn"
+
+static int eventchn_major = 10;
+static int eventchn_minor = 61;
+
+static int do_ioctl(int handle, int cmd, void *arg)
+{
+ return ioctl(handle, cmd, arg);
+}
+
+static int do_read_port(int handle, evtchn_port_t *port)
+{
+ return (read(handle, port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
+}
+
+static int do_write_port(int handle, evtchn_port_t port)
+{
+ return (write(handle, &port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
+}
+
+int eventchn_do_open(void)
+{
+ int fd;
+
+ fd = open(EVENTCHN_PATH, O_RDWR);
+ if (fd == -1 && errno == ENOENT) {
+ mkdir("/dev/xen", 0640);
+ mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(eventchn_major, eventchn_minor));
+ fd = open(EVENTCHN_PATH, O_RDWR);
+ }
+ return fd;
+}
+
+CAMLprim value stub_eventchn_init(value unit)
+{
+ CAMLparam1(unit);
+ int fd = eventchn_do_open();
+ if (fd == -1)
+ caml_failwith("open failed");
+ CAMLreturn(Val_int(fd));
+}
+
+CAMLprim value stub_eventchn_notify(value fd, value port)
+{
+ CAMLparam2(fd, port);
+ struct ioctl_evtchn_notify notify;
+ int rc;
+
+ notify.port = Int_val(port);
+ rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_NOTIFY, ¬ify);
+ if (rc == -1)
+ caml_failwith("ioctl notify failed");
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_eventchn_bind_interdomain(value fd, value domid,
+ value remote_port)
+{
+ CAMLparam3(fd, domid, remote_port);
+ CAMLlocal1(port);
+ struct ioctl_evtchn_bind_interdomain bind;
+ int rc;
+
+ bind.remote_domain = Int_val(domid);
+ bind.remote_port = Int_val(remote_port);
+ rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_INTERDOMAIN, &bind);
+ if (rc == -1)
+ caml_failwith("ioctl bind_interdomain failed");
+ port = Val_int(rc);
+
+ CAMLreturn(port);
+}
+
+CAMLprim value stub_eventchn_bind_virq(value fd)
+{
+ CAMLparam1(fd);
+ CAMLlocal1(port);
+ struct ioctl_evtchn_bind_virq bind;
+ int rc;
+
+ bind.virq = VIRQ_DOM_EXC;
+ rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_VIRQ, &bind);
+ if (rc == -1)
+ caml_failwith("ioctl bind_virq failed");
+ port = Val_int(rc);
+
+ CAMLreturn(port);
+}
+
+CAMLprim value stub_eventchn_unbind(value fd, value port)
+{
+ CAMLparam2(fd, port);
+ struct ioctl_evtchn_unbind unbind;
+ int rc;
+
+ unbind.port = Int_val(port);
+ rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_UNBIND, &unbind);
+ if (rc == -1)
+ caml_failwith("ioctl unbind failed");
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_eventchn_read_port(value fd)
+{
+ CAMLparam1(fd);
+ CAMLlocal1(result);
+ evtchn_port_t port;
+
+ if (do_read_port(Int_val(fd), &port))
+ caml_failwith("read port failed");
+ result = Val_int(port);
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_eventchn_write_port(value fd, value _port)
+{
+ CAMLparam2(fd, _port);
+ evtchn_port_t port;
+
+ port = Int_val(_port);
+ if (do_write_port(Int_val(fd), port))
+ caml_failwith("write port failed");
+ CAMLreturn(Val_unit);
+}
diff --git a/tools/ocaml/libs/xb/META.in b/tools/ocaml/libs/xb/META.in
new file mode 100644
index 0000000..c041010
--- /dev/null
+++ b/tools/ocaml/libs/xb/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "XenBus Interface"
+archive(byte) = "xb.cma"
+archive(native) = "xb.cmxa"
diff --git a/tools/ocaml/libs/xb/Makefile b/tools/ocaml/libs/xb/Makefile
new file mode 100644
index 0000000..56afb4a
--- /dev/null
+++ b/tools/ocaml/libs/xb/Makefile
@@ -0,0 +1,41 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+CFLAGS += -I../mmap
+OCAMLINCLUDE += -I ../mmap
+
+.NOTPARALLEL:
+# Ocaml is such a PITA!
+
+PREINTF = op.cmi partial.cmi packet.cmi
+PREOBJS = op partial packet xs_ring
+PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx)
+OBJS = op partial packet xs_ring xb
+INTF = op.cmi packet.cmi xb.cmi
+LIBS = xb.cma xb.cmxa
+
+ALL_OCAML_OBJS = $(OBJS) $(PREOJBS)
+
+all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xb_OBJS = $(OBJS)
+xb_C_OBJS = xs_ring_stubs xb_stubs
+OCAML_LIBRARY = xb
+
+%.mli: %.ml
+ $(E) " MLI $@"
+ $(Q)$(OCAMLC) -i $< $o
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove xb
+
+include $(TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml
new file mode 100644
index 0000000..6ea8fe6
--- /dev/null
+++ b/tools/ocaml/libs/xb/op.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 operation = Debug | Directory | Read | Getperms |
+ Watch | Unwatch | Transaction_start |
+ Transaction_end | Introduce | Release |
+ Getdomainpath | Write | Mkdir | Rm |
+ Setperms | Watchevent | Error | Isintroduced |
+ Resume | Set_target
+ | Restrict
+
+(* There are two sets of XB operations: the one coming from open-source and *)
+(* the one coming from our private patch queue. These operations *)
+(* in two differents arrays for make easier the forward compatibility *)
+let operation_c_mapping =
+ [| Debug; Directory; Read; Getperms;
+ Watch; Unwatch; Transaction_start;
+ Transaction_end; Introduce; Release;
+ Getdomainpath; Write; Mkdir; Rm;
+ Setperms; Watchevent; Error; Isintroduced;
+ Resume; Set_target |]
+let size = Array.length operation_c_mapping
+
+(* [offset_pq] has to be the same as in <xen/io/xs_wire.h> *)
+let offset_pq = size
+let operation_c_mapping_pq =
+ [| Restrict |]
+let size_pq = Array.length operation_c_mapping_pq
+
+let array_search el a =
+ let len = Array.length a in
+ let rec search i =
+ if i > len then raise Not_found;
+ if a.(i) = el then i else search (i + 1) in
+ search 0
+
+let of_cval i =
+ if i >= 0 && i < size
+ then operation_c_mapping.(i)
+ else if i >= offset_pq && i < offset_pq + size_pq
+ then operation_c_mapping_pq.(i-offset_pq)
+ else raise Not_found
+
+let to_cval op =
+ try
+ array_search op operation_c_mapping
+ with _ -> offset_pq + array_search op operation_c_mapping_pq
+
+let to_string ty =
+ match ty with
+ | Debug -> "DEBUG"
+ | Directory -> "DIRECTORY"
+ | Read -> "READ"
+ | Getperms -> "GET_PERMS"
+ | Watch -> "WATCH"
+ | Unwatch -> "UNWATCH"
+ | Transaction_start -> "TRANSACTION_START"
+ | Transaction_end -> "TRANSACTION_END"
+ | Introduce -> "INTRODUCE"
+ | Release -> "RELEASE"
+ | Getdomainpath -> "GET_DOMAIN_PATH"
+ | Write -> "WRITE"
+ | Mkdir -> "MKDIR"
+ | Rm -> "RM"
+ | Setperms -> "SET_PERMS"
+ | Watchevent -> "WATCH_EVENT"
+ | Error -> "ERROR"
+ | Isintroduced -> "IS_INTRODUCED"
+ | Resume -> "RESUME"
+ | Set_target -> "SET_TARGET"
+ | Restrict -> "RESTRICT"
diff --git a/tools/ocaml/libs/xb/packet.ml b/tools/ocaml/libs/xb/packet.ml
new file mode 100644
index 0000000..74c04bb
--- /dev/null
+++ b/tools/ocaml/libs/xb/packet.ml
@@ -0,0 +1,50 @@
+(*
+ * 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 t =
+{
+ tid: int;
+ rid: int;
+ ty: Op.operation;
+ data: string;
+}
+
+exception Error of string
+exception DataError of string
+
+external string_of_header: int -> int -> int -> int -> string = "stub_string_of_header"
+
+let create tid rid ty data = { tid = tid; rid = rid; ty = ty; data = data; }
+
+let of_partialpkt ppkt =
+ create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf)
+
+let to_string pkt =
+ let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in
+ header ^ pkt.data
+
+let unpack pkt =
+ pkt.tid, pkt.rid, pkt.ty, pkt.data
+
+let get_tid pkt = pkt.tid
+let get_ty pkt = pkt.ty
+let get_data pkt =
+ let l = String.length pkt.data in
+ if l > 0 && pkt.data.[l - 1] = '\000' then
+ String.sub pkt.data 0 (l - 1)
+ else
+ pkt.data
+let get_rid pkt = pkt.rid
\ No newline at end of file
diff --git a/tools/ocaml/libs/xb/partial.ml b/tools/ocaml/libs/xb/partial.ml
new file mode 100644
index 0000000..3558889
--- /dev/null
+++ b/tools/ocaml/libs/xb/partial.ml
@@ -0,0 +1,44 @@
+(*
+ * 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 pkt =
+{
+ tid: int;
+ rid: int;
+ ty: Op.operation;
+ len: int;
+ buf: Buffer.t;
+}
+
+external header_size: unit -> int = "stub_header_size"
+external header_of_string_internal: string -> int * int * int * int
+ = "stub_header_of_string"
+
+let of_string s =
+ let tid, rid, opint, dlen = header_of_string_internal s in
+ {
+ tid = tid;
+ rid = rid;
+ ty = (Op.of_cval opint);
+ len = dlen;
+ buf = Buffer.create dlen;
+ }
+
+let append pkt s sz =
+ Buffer.add_string pkt.buf (String.sub s 0 sz)
+
+let to_complete pkt =
+ pkt.len - (Buffer.length pkt.buf)
diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml
new file mode 100644
index 0000000..4d02376
--- /dev/null
+++ b/tools/ocaml/libs/xb/xb.ml
@@ -0,0 +1,189 @@
+(*
+ * 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.
+ *)
+
+module Op = struct include Op end
+module Packet = struct include Packet end
+
+exception End_of_file
+exception Eagain
+exception Noent
+exception Invalid
+
+type backend_mmap =
+{
+ mmap: Mmap.mmap_interface; (* mmaped interface = xs_ring *)
+ eventchn_notify: unit -> unit; (* function to notify through eventchn *)
+ mutable work_again: bool;
+}
+
+type backend_fd =
+{
+ fd: Unix.file_descr;
+}
+
+type backend = Fd of backend_fd | Mmap of backend_mmap
+
+type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string
+
+type t =
+{
+ backend: backend;
+ pkt_in: Packet.t Queue.t;
+ pkt_out: Packet.t Queue.t;
+ mutable partial_in: partial_buf;
+ mutable partial_out: string;
+}
+
+let init_partial_in () = NoHdr
+ (Partial.header_size (), String.make (Partial.header_size()) '\000')
+
+let queue con pkt = Queue.push pkt con.pkt_out
+
+let read_fd back con s len =
+ let rd = Unix.read back.fd s 0 len in
+ if rd = 0 then
+ raise End_of_file;
+ rd
+
+let read_mmap back con s len =
+ let rd = Xs_ring.read back.mmap s len in
+ back.work_again <- (rd > 0);
+ if rd > 0 then
+ back.eventchn_notify ();
+ rd
+
+let read con s len =
+ match con.backend with
+ | Fd backfd -> read_fd backfd con s len
+ | Mmap backmmap -> read_mmap backmmap con s len
+
+let write_fd back con s len =
+ Unix.write back.fd s 0 len
+
+let write_mmap back con s len =
+ let ws = Xs_ring.write back.mmap s len in
+ if ws > 0 then
+ back.eventchn_notify ();
+ ws
+
+let write con s len =
+ match con.backend with
+ | Fd backfd -> write_fd backfd con s len
+ | Mmap backmmap -> write_mmap backmmap con s len
+
+let output con =
+ (* get the output string from a string_of(packet) or partial_out *)
+ let s = if String.length con.partial_out > 0 then
+ con.partial_out
+ else if Queue.length con.pkt_out > 0 then
+ Packet.to_string (Queue.pop con.pkt_out)
+ else
+ "" in
+ (* send data from s, and save the unsent data to partial_out *)
+ if s <> "" then (
+ let len = String.length s in
+ let sz = write con s len in
+ let left = String.sub s sz (len - sz) in
+ con.partial_out <- left
+ );
+ (* after sending one packet, partial is empty *)
+ con.partial_out = ""
+
+let input con =
+ let newpacket = ref false in
+ let to_read =
+ match con.partial_in with
+ | HaveHdr partial_pkt -> Partial.to_complete partial_pkt
+ | NoHdr (i, buf) -> i in
+
+ (* try to get more data from input stream *)
+ let s = String.make to_read '\000' in
+ let sz = if to_read > 0 then read con s to_read else 0 in
+
+ (
+ match con.partial_in with
+ | HaveHdr partial_pkt ->
+ (* we complete the data *)
+ if sz > 0 then
+ Partial.append partial_pkt s sz;
+ if Partial.to_complete partial_pkt = 0 then (
+ let pkt = Packet.of_partialpkt partial_pkt in
+ con.partial_in <- init_partial_in ();
+ Queue.push pkt con.pkt_in;
+ newpacket := true
+ )
+ | NoHdr (i, buf) ->
+ (* we complete the partial header *)
+ if sz > 0 then
+ String.blit s 0 buf (Partial.header_size () - i) sz;
+ con.partial_in <- if sz = i then
+ HaveHdr (Partial.of_string buf) else NoHdr (i - sz, buf)
+ );
+ !newpacket
+
+let newcon backend = {
+ backend = backend;
+ pkt_in = Queue.create ();
+ pkt_out = Queue.create ();
+ partial_in = init_partial_in ();
+ partial_out = "";
+ }
+
+let open_fd fd = newcon (Fd { fd = fd; })
+
+let open_mmap mmap notifyfct =
+ newcon (Mmap {
+ mmap = mmap;
+ eventchn_notify = notifyfct;
+ work_again = false; })
+
+let close con =
+ match con.backend with
+ | Fd backend -> Unix.close backend.fd
+ | Mmap backend -> Mmap.unmap backend.mmap
+
+let is_fd con =
+ match con.backend with
+ | Fd _ -> true
+ | Mmap _ -> false
+
+let is_mmap con = not (is_fd con)
+
+let output_len con = Queue.length con.pkt_out
+let has_new_output con = Queue.length con.pkt_out > 0
+let has_old_output con = String.length con.partial_out > 0
+
+let has_output con = has_new_output con || has_old_output con
+
+let peek_output con = Queue.peek con.pkt_out
+
+let input_len con = Queue.length con.pkt_in
+let has_in_packet con = Queue.length con.pkt_in > 0
+let get_in_packet con = Queue.pop con.pkt_in
+let has_more_input con =
+ match con.backend with
+ | Fd _ -> false
+ | Mmap backend -> backend.work_again
+
+let is_selectable con =
+ match con.backend with
+ | Fd _ -> true
+ | Mmap _ -> false
+
+let get_fd con =
+ match con.backend with
+ | Fd backend -> backend.fd
+ | Mmap _ -> raise (Failure "get_fd")
diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli
new file mode 100644
index 0000000..6cbf0a8
--- /dev/null
+++ b/tools/ocaml/libs/xb/xb.mli
@@ -0,0 +1,83 @@
+module Op:
+sig
+ type operation = Op.operation =
+ | Debug
+ | Directory
+ | Read
+ | Getperms
+ | Watch
+ | Unwatch
+ | Transaction_start
+ | Transaction_end
+ | Introduce
+ | Release
+ | Getdomainpath
+ | Write
+ | Mkdir
+ | Rm
+ | Setperms
+ | Watchevent
+ | Error
+ | Isintroduced
+ | Resume
+ | Set_target
+ | Restrict
+ val to_string : operation -> string
+end
+
+module Packet:
+sig
+ type t
+
+ exception Error of string
+ exception DataError of string
+
+ val create : int -> int -> Op.operation -> string -> t
+ val unpack : t -> int * int * Op.operation * string
+
+ val get_tid : t -> int
+ val get_ty : t -> Op.operation
+ val get_data : t -> string
+ val get_rid: t -> int
+end
+
+exception End_of_file
+exception Eagain
+exception Noent
+exception Invalid
+
+type t
+
+(** queue a packet into the output queue for later sending *)
+val queue : t -> Packet.t -> unit
+
+(** process the output queue, return if a packet has been totally sent *)
+val output : t -> bool
+
+(** process the input queue, return if a packet has been totally received *)
+val input : t -> bool
+
+(** create new connection using a fd interface *)
+val open_fd : Unix.file_descr -> t
+(** create new connection using a mmap intf and a function to notify eventchn *)
+val open_mmap : Mmap.mmap_interface -> (unit -> unit) -> t
+
+(* close a connection *)
+val close : t -> unit
+
+val is_fd : t -> bool
+val is_mmap : t -> bool
+
+val output_len : t -> int
+val has_new_output : t -> bool
+val has_old_output : t -> bool
+val has_output : t -> bool
+val peek_output : t -> Packet.t
+
+val input_len : t -> int
+val has_in_packet : t -> bool
+val get_in_packet : t -> Packet.t
+val has_more_input : t -> bool
+
+val is_selectable : t -> bool
+val get_fd : t -> Unix.file_descr
diff --git a/tools/ocaml/libs/xb/xb_stubs.c b/tools/ocaml/libs/xb/xb_stubs.c
new file mode 100644
index 0000000..b4d1ee6
--- /dev/null
+++ b/tools/ocaml/libs/xb/xb_stubs.c
@@ -0,0 +1,74 @@
+/*
+ * 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 <unistd.h>
+#include <stdlib.h>
+#include <sys/mman.h>
+#include <string.h>
+#include <errno.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#define __XEN_TOOLS__
+
+#include <xenctrl.h>
+#define u32 uint32_t
+#include <xen/io/xs_wire.h>
+
+CAMLprim value stub_header_size(void)
+{
+ CAMLparam0();
+ CAMLreturn(Val_int(sizeof(struct xsd_sockmsg)));
+}
+
+CAMLprim value stub_header_of_string(value s)
+{
+ CAMLparam1(s);
+ CAMLlocal1(ret);
+ struct xsd_sockmsg *hdr;
+
+ if (caml_string_length(s) != sizeof(struct xsd_sockmsg))
+ caml_failwith("xb header incomplete");
+ ret = caml_alloc_tuple(4);
+ hdr = (struct xsd_sockmsg *) String_val(s);
+ Store_field(ret, 0, Val_int(hdr->tx_id));
+ Store_field(ret, 1, Val_int(hdr->req_id));
+ Store_field(ret, 2, Val_int(hdr->type));
+ Store_field(ret, 3, Val_int(hdr->len));
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len)
+{
+ CAMLparam4(tid, rid, ty, len);
+ CAMLlocal1(ret);
+ struct xsd_sockmsg xsd = {
+ .type = Int_val(ty),
+ .tx_id = Int_val(tid),
+ .req_id = Int_val(rid),
+ .len = Int_val(len),
+ };
+
+ ret = caml_alloc_string(sizeof(struct xsd_sockmsg));
+ memcpy(String_val(ret), &xsd, sizeof(struct xsd_sockmsg));
+
+ CAMLreturn(ret);
+}
diff --git a/tools/ocaml/libs/xb/xs_ring.ml b/tools/ocaml/libs/xb/xs_ring.ml
new file mode 100644
index 0000000..00c18d5
--- /dev/null
+++ b/tools/ocaml/libs/xb/xs_ring.ml
@@ -0,0 +1,18 @@
+(*
+ * 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.
+ *)
+
+external read: Mmap.mmap_interface -> string -> int -> int = "ml_interface_read"
+external write: Mmap.mmap_interface -> string -> int -> int = "ml_interface_write"
diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_ring_stubs.c
new file mode 100644
index 0000000..9aef23e
--- /dev/null
+++ b/tools/ocaml/libs/xb/xs_ring_stubs.c
@@ -0,0 +1,117 @@
+/*
+ * 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 <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <errno.h>
+#include <string.h>
+
+#define __XEN_TOOLS__
+
+#include <xenctrl.h>
+#define u32 uint32_t
+#include <xen/io/xs_wire.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#include "mmap_stubs.h"
+
+#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
+
+#ifndef xen_mb
+#define xen_mb() mb()
+#endif
+
+static int xs_ring_read(struct mmap_interface *interface,
+ char *buffer, int len)
+{
+ struct xenstore_domain_interface *intf = interface->addr;
+ XENSTORE_RING_IDX cons, prod;
+ int to_read;
+
+ cons = intf->req_cons;
+ prod = intf->req_prod;
+ xen_mb();
+ if (prod == cons)
+ return 0;
+ if (MASK_XENSTORE_IDX(prod) > MASK_XENSTORE_IDX(cons))
+ to_read = prod - cons;
+ else
+ to_read = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons);
+ if (to_read < len)
+ len = to_read;
+ memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len);
+ xen_mb();
+ intf->req_cons += len;
+ return len;
+}
+
+static int xs_ring_write(struct mmap_interface *interface,
+ char *buffer, int len)
+{
+ struct xenstore_domain_interface *intf = interface->addr;
+ XENSTORE_RING_IDX cons, prod;
+ int can_write;
+
+ cons = intf->rsp_cons;
+ prod = intf->rsp_prod;
+ xen_mb();
+ if ( (prod - cons) >= XENSTORE_RING_SIZE )
+ return 0;
+ if (MASK_XENSTORE_IDX(prod) >= MASK_XENSTORE_IDX(cons))
+ can_write = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod);
+ else
+ can_write = MASK_XENSTORE_IDX(cons) - MASK_XENSTORE_IDX(prod);
+ if (can_write < len)
+ len = can_write;
+ memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len);
+ xen_mb();
+ intf->rsp_prod += len;
+ return len;
+}
+
+CAMLprim value ml_interface_read(value interface, value buffer, value len)
+{
+ CAMLparam3(interface, buffer, len);
+ CAMLlocal1(result);
+ int res;
+
+ res = xs_ring_read(GET_C_STRUCT(interface),
+ String_val(buffer), Int_val(len));
+ if (res == -1)
+ caml_failwith("huh");
+ result = Val_int(res);
+ CAMLreturn(result);
+}
+
+CAMLprim value ml_interface_write(value interface, value buffer, value len)
+{
+ CAMLparam3(interface, buffer, len);
+ CAMLlocal1(result);
+ int res;
+
+ res = xs_ring_write(GET_C_STRUCT(interface),
+ String_val(buffer), Int_val(len));
+ result = Val_int(res);
+ CAMLreturn(result);
+}
diff --git a/tools/ocaml/libs/xs/META.in b/tools/ocaml/libs/xs/META.in
new file mode 100644
index 0000000..77d93b5
--- /dev/null
+++ b/tools/ocaml/libs/xs/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "XenStore Interface"
+archive(byte) = "xs.cma"
+archive(native) = "xs.cmxa"
diff --git a/tools/ocaml/libs/xs/Makefile b/tools/ocaml/libs/xs/Makefile
new file mode 100644
index 0000000..87cd375
--- /dev/null
+++ b/tools/ocaml/libs/xs/Makefile
@@ -0,0 +1,42 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OCAMLINCLUDE += -I ../xb/
+
+.NOTPARALLEL:
+# Ocaml is such a PITA!
+
+PREINTF = xsraw.cmi xst.cmi
+PREOBJS = queueop xsraw xst
+PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx)
+OBJS = queueop xsraw xst xs
+INTF = xsraw.cmi xst.cmi xs.cmi
+LIBS = xs.cma xs.cmxa
+
+all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xs_OBJS = $(OBJS)
+OCAML_NOC_LIBRARY = xs
+
+#xs.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+# $(E) " MLLIB $@"
+# $(Q)$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+#
+#xs.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+# $(E) " MLLIB $@"
+# $(Q)$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove xs
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/xs/queueop.ml b/tools/ocaml/libs/xs/queueop.ml
new file mode 100644
index 0000000..cb298f5
--- /dev/null
+++ b/tools/ocaml/libs/xs/queueop.ml
@@ -0,0 +1,73 @@
+(*
+ * 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 data_concat ls = (String.concat "\000" ls) ^ "\000"
+let queue_path ty (tid: int) (path: string) con =
+ let data = data_concat [ path; ] in
+ Xb.queue con (Xb.Packet.create tid 0 ty data)
+
+(* operations *)
+let directory tid path con = queue_path Xb.Op.Directory tid path con
+let read tid path con = queue_path Xb.Op.Read tid path con
+
+let getperms tid path con = queue_path Xb.Op.Getperms tid path con
+
+let debug commands con =
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands))
+
+let watch path data con =
+ let data = data_concat [ path; data; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Watch data)
+
+let unwatch path data con =
+ let data = data_concat [ path; data; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data)
+
+let transaction_start con =
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat []))
+
+let transaction_end tid commit con =
+ let data = data_concat [ (if commit then "T" else "F"); ] in
+ Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data)
+
+let introduce domid mfn port con =
+ let data = data_concat [ Printf.sprintf "%u" domid;
+ Printf.sprintf "%nu" mfn;
+ string_of_int port; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data)
+
+let release domid con =
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Release data)
+
+let resume domid con =
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Resume data)
+
+let getdomainpath domid con =
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data)
+
+let write tid path value con =
+ let data = path ^ "\000" ^ value (* no NULL at the end *) in
+ Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Write data)
+
+let mkdir tid path con = queue_path Xb.Op.Mkdir tid path con
+let rm tid path con = queue_path Xb.Op.Rm tid path con
+
+let setperms tid path perms con =
+ let data = data_concat [ path; perms ] in
+ Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data)
diff --git a/tools/ocaml/libs/xs/xs.ml b/tools/ocaml/libs/xs/xs.ml
new file mode 100644
index 0000000..768778f
--- /dev/null
+++ b/tools/ocaml/libs/xs/xs.ml
@@ -0,0 +1,170 @@
+(*
+ * 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 perms = Xsraw.perms
+type con = Xsraw.con
+type domid = int
+
+type xsh =
+{
+ con: con;
+ debug: string list -> string;
+ directory: string -> string list;
+ read: string -> string;
+ readv: string -> string list -> string list;
+ write: string -> string -> unit;
+ writev: string -> (string * string) list -> unit;
+ mkdir: string -> unit;
+ rm: string -> unit;
+ getperms: string -> perms;
+ setperms: string -> perms -> unit;
+ setpermsv: string -> string list -> perms -> unit;
+ introduce: domid -> nativeint -> int -> unit;
+ release: domid -> unit;
+ resume: domid -> unit;
+ getdomainpath: domid -> string;
+ watch: string -> string -> unit;
+ unwatch: string -> string -> unit;
+}
+
+let get_operations con = {
+ con = con;
+ debug = (fun commands -> Xsraw.debug commands con);
+ directory = (fun path -> Xsraw.directory 0 path con);
+ read = (fun path -> Xsraw.read 0 path con);
+ readv = (fun dir vec -> Xsraw.readv 0 dir vec con);
+ write = (fun path value -> Xsraw.write 0 path value con);
+ writev = (fun dir vec -> Xsraw.writev 0 dir vec con);
+ mkdir = (fun path -> Xsraw.mkdir 0 path con);
+ rm = (fun path -> Xsraw.rm 0 path con);
+ getperms = (fun path -> Xsraw.getperms 0 path con);
+ setperms = (fun path perms -> Xsraw.setperms 0 path perms con);
+ setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con);
+ introduce = (fun id mfn port -> Xsraw.introduce id mfn port con);
+ release = (fun id -> Xsraw.release id con);
+ resume = (fun id -> Xsraw.resume id con);
+ getdomainpath = (fun id -> Xsraw.getdomainpath id con);
+ watch = (fun path data -> Xsraw.watch path data con);
+ unwatch = (fun path data -> Xsraw.unwatch path data con);
+}
+
+let transaction xsh = Xst.transaction xsh.con
+
+let has_watchevents xsh = Xsraw.has_watchevents xsh.con
+let get_watchevent xsh = Xsraw.get_watchevent xsh.con
+
+let read_watchevent xsh = Xsraw.read_watchevent xsh.con
+
+let make fd = get_operations (Xsraw.open_fd fd)
+let get_fd xsh = Xb.get_fd xsh.con.Xsraw.xb
+
+exception Timeout
+
+(* Should never be thrown, indicates a bug in the read_watchevent_timetout function *)
+exception Timeout_with_nonempty_queue
+
+(* Just in case we screw up: poll the callback every couple of seconds rather
+ than wait for the whole timeout period *)
+let max_blocking_time = 5. (* seconds *)
+
+let read_watchevent_timeout xsh timeout callback =
+ let start_time = Unix.gettimeofday () in
+ let end_time = start_time +. timeout in
+
+ let left = ref timeout in
+
+ (* Returns true if a watch event in the queue satisfied us *)
+ let process_queued_events () =
+ let success = ref false in
+ while Xsraw.has_watchevents xsh.con && not(!success)
+ do
+ success := callback (Xsraw.get_watchevent xsh.con)
+ done;
+ !success in
+ (* Returns true if a watch event read from the socket satisfied us *)
+ let process_incoming_event () =
+ let fd = get_fd xsh in
+ let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in
+
+ (* If data is available for reading then read it *)
+ if r = []
+ then false (* timeout, either a max_blocking_time or global *)
+ else callback (Xsraw.read_watchevent xsh.con) in
+
+ let success = ref false in
+ while !left > 0. && not(!success)
+ do
+ (* NB the 'callback' might call back into Xs functions
+ and as a side-effect, watches might be queued. Hence
+ we must process the queue on every loop iteration *)
+
+ (* First process all queued watch events *)
+ if not(!success)
+ then success := process_queued_events ();
+ (* Then block for one more watch event *)
+ if not(!success)
+ then success := process_incoming_event ();
+ (* Just in case our callback caused events to be queued
+ and this is our last time round the loop: this prevents
+ us throwing the Timeout_with_nonempty_queue spuriously *)
+ if not(!success)
+ then success := process_queued_events ();
+
+ (* Update the time left *)
+ let current_time = Unix.gettimeofday () in
+ left := end_time -. current_time
+ done;
+ if not(!success) then begin
+ (* Sanity check: it should be impossible for any
+ events to be queued here *)
+ if Xsraw.has_watchevents xsh.con
+ then raise Timeout_with_nonempty_queue
+ else raise Timeout
+ end
+
+
+let monitor_paths xsh l time callback =
+ let unwatch () =
+ List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in
+ List.iter (fun (w,v) -> xsh.watch w v) l;
+ begin try
+ read_watchevent_timeout xsh time callback;
+ with
+ exn -> unwatch (); raise exn;
+ end;
+ unwatch ()
+
+let daemon_socket = "/var/run/xenstored/socket"
+
+(** Throws this rather than a miscellaneous Unix.connect failed *)
+exception Failed_to_connect
+
+let daemon_open () =
+ try
+ let sockaddr = Unix.ADDR_UNIX(daemon_socket) in
+ let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+ Unix.connect sock sockaddr;
+ Unix.set_close_on_exec sock;
+ make sock
+ with _ -> raise Failed_to_connect
+
+let domain_open () =
+ let path = "/proc/xen/xenbus" in
+ let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in
+ Unix.set_close_on_exec fd;
+ make fd
+
+let close xsh = Xsraw.close xsh.con
diff --git a/tools/ocaml/libs/xs/xs.mli b/tools/ocaml/libs/xs/xs.mli
new file mode 100644
index 0000000..ce505b6
--- /dev/null
+++ b/tools/ocaml/libs/xs/xs.mli
@@ -0,0 +1,90 @@
+(*
+ * 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 Timeout
+
+(** Throws this rather than a miscellaneous Unix.connect failed *)
+exception Failed_to_connect
+
+(** perms contains 3 things:
+ - owner domid.
+ - other perm: applied to domain that is not owner or in ACL.
+ - ACL: list of per-domain permission
+ *)
+type perms = Xsraw.perms
+
+type domid = int
+type con
+
+type xsh = {
+ con : con;
+ debug: string list -> string;
+ directory : string -> string list;
+ read : string -> string;
+ readv : string -> string list -> string list;
+ write : string -> string -> unit;
+ writev : string -> (string * string) list -> unit;
+ mkdir : string -> unit;
+ rm : string -> unit;
+ getperms : string -> perms;
+ setperms : string -> perms -> unit;
+ setpermsv : string -> string list -> perms -> unit;
+ introduce : domid -> nativeint -> int -> unit;
+ release : domid -> unit;
+ resume : domid -> unit;
+ getdomainpath : domid -> string;
+ watch : string -> string -> unit;
+ unwatch : string -> string -> unit;
+}
+
+(** get operations provide a vector of xenstore function that apply to one
+ connection *)
+val get_operations : con -> xsh
+
+(** create a transaction with a vector of function that can be applied
+ into the transaction. *)
+val transaction : xsh -> (Xst.ops -> 'a) -> 'a
+
+(** watch manipulation on a connection *)
+val has_watchevents : xsh -> bool
+val get_watchevent : xsh -> string * string
+val read_watchevent : xsh -> string * string
+
+(** get_fd return the fd of the connection to be able to select on it.
+ NOTE: it works only for socket-based connection *)
+val get_fd : xsh -> Unix.file_descr
+
+(** wait for watchevent with a timeout. Until the callback return true,
+ every watch during the time specified, will be pass to the callback.
+ NOTE: it works only when use with a socket-based connection *)
+val read_watchevent_timeout : xsh -> float -> (string * string -> bool) -> unit
+
+(** register a set of watches, then wait for watchevent.
+ remove all watches previously set before giving back the hand. *)
+val monitor_paths : xsh
+ -> (string * string) list
+ -> float
+ -> (string * string -> bool)
+ -> unit
+
+(** open a socket-based xenstored connection *)
+val daemon_open : unit -> xsh
+
+(** open a mmap-based xenstored connection *)
+val domain_open : unit -> xsh
+
+(** close any xenstored connection *)
+val close : xsh -> unit
diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml
new file mode 100644
index 0000000..370d38e
--- /dev/null
+++ b/tools/ocaml/libs/xs/xsraw.ml
@@ -0,0 +1,265 @@
+(*
+ * 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 Partial_not_empty
+exception Unexpected_packet of string
+
+(** Thrown when a path looks invalid e.g. if it contains "//" *)
+exception Invalid_path of string
+
+let unexpected_packet expected received =
+ let s = Printf.sprintf "expecting %s received %s"
+ (Xb.Op.to_string expected)
+ (Xb.Op.to_string received) in
+ raise (Unexpected_packet s)
+
+type con = {
+ xb: Xb.t;
+ watchevents: (string * string) Queue.t;
+}
+
+let close con =
+ Xb.close con.xb
+
+let open_fd fd = {
+ xb = Xb.open_fd fd;
+ watchevents = Queue.create ();
+}
+
+let rec split_string ?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_string ~limit: nlimit c b)
+
+type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR
+
+type perms = int * perm * (int * perm) list
+
+let string_of_perms perms =
+ let owner, other, acl = perms in
+ let char_of_perm perm =
+ match perm with PERM_NONE -> 'n' | PERM_READ -> 'r'
+ | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in
+ let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in
+ String.concat "\000" (List.map string_of_perm ((owner,other) :: acl))
+
+let perms_of_string s =
+ let perm_of_char c =
+ match c with 'n' -> PERM_NONE | 'r' -> PERM_READ
+ | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR
+ | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in
+ let perm_of_string s =
+ if String.length s < 2
+ then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s)
+ else
+ begin
+ int_of_string (String.sub s 1 (String.length s - 1)),
+ perm_of_char s.[0]
+ end in
+ let rec split s =
+ try let i = String.index s '\000' in
+ String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i))
+ with Not_found -> if s = "" then [] else [ s ] in
+ let l = List.map perm_of_string (split s) in
+ match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, [])
+
+(* send one packet - can sleep *)
+let pkt_send con =
+ if Xb.has_old_output con.xb then
+ raise Partial_not_empty;
+ let workdone = ref false in
+ while not !workdone
+ do
+ workdone := Xb.output con.xb
+ done
+
+(* receive one packet - can sleep *)
+let pkt_recv con =
+ let workdone = ref false in
+ while not !workdone
+ do
+ workdone := Xb.input con.xb
+ done;
+ Xb.get_in_packet con.xb
+
+let pkt_recv_timeout con timeout =
+ let fd = Xb.get_fd con.xb in
+ let r, _, _ = Unix.select [ fd ] [] [] timeout in
+ if r = [] then
+ true, None
+ else (
+ let workdone = Xb.input con.xb in
+ if workdone then
+ false, (Some (Xb.get_in_packet con.xb))
+ else
+ false, None
+ )
+
+let queue_watchevent con data =
+ let ls = split_string ~limit:2 '\000' data in
+ if List.length ls != 2 then
+ raise (Xb.Packet.DataError "arguments number mismatch");
+ let event = List.nth ls 0
+ and event_data = List.nth ls 1 in
+ Queue.push (event, event_data) con.watchevents
+
+let has_watchevents con = Queue.length con.watchevents > 0
+let get_watchevent con = Queue.pop con.watchevents
+
+let read_watchevent con =
+ let pkt = pkt_recv con in
+ match Xb.Packet.get_ty pkt with
+ | Xb.Op.Watchevent ->
+ queue_watchevent con (Xb.Packet.get_data pkt);
+ Queue.pop con.watchevents
+ | ty -> unexpected_packet Xb.Op.Watchevent ty
+
+(* send one packet in the queue, and wait for reply *)
+let rec sync_recv ty con =
+ let pkt = pkt_recv con in
+ match Xb.Packet.get_ty pkt with
+ | Xb.Op.Error -> (
+ match Xb.Packet.get_data pkt with
+ | "ENOENT" -> raise Xb.Noent
+ | "EAGAIN" -> raise Xb.Eagain
+ | "EINVAL" -> raise Xb.Invalid
+ | s -> raise (Xb.Packet.Error s))
+ | Xb.Op.Watchevent ->
+ queue_watchevent con (Xb.Packet.get_data pkt);
+ sync_recv ty con
+ | rty when rty = ty -> Xb.Packet.get_data pkt
+ | rty -> unexpected_packet ty rty
+
+let sync f con =
+ (* queue a query using function f *)
+ f con.xb;
+ if Xb.output_len con.xb = 0 then
+ Printf.printf "output len = 0\n%!";
+ let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in
+ pkt_send con;
+ sync_recv ty con
+
+let ack s =
+ if s = "OK" then () else raise (Xb.Packet.DataError s)
+
+(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches) *)
+let validate_path path =
+ (* Paths shouldn't have a "//" in the middle *)
+ let bad = "//" in
+ for offset = 0 to String.length path - (String.length bad) do
+ if String.sub path offset (String.length bad) = bad then
+ raise (Invalid_path path)
+ done;
+ (* Paths shouldn't have a "/" at the end, except for the root *)
+ if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then
+ raise (Invalid_path path)
+
+(** Check to see if a path is suitable for watches *)
+let validate_watch_path path =
+ (* Check for stuff like @releaseDomain etc first *)
+ if path <> "" && path.[0] = '@' then ()
+ else validate_path path
+
+let debug command con =
+ sync (Queueop.debug command) con
+
+let directory tid path con =
+ validate_path path;
+ let data = sync (Queueop.directory tid path) con in
+ split_string '\000' data
+
+let read tid path con =
+ validate_path path;
+ sync (Queueop.read tid path) con
+
+let readv tid dir vec con =
+ List.map (fun path -> validate_path path; read tid path con)
+ (if dir <> "" then
+ (List.map (fun v -> dir ^ "/" ^ v) vec) else vec)
+
+let getperms tid path con =
+ validate_path path;
+ perms_of_string (sync (Queueop.getperms tid path) con)
+
+let watch path data con =
+ validate_watch_path path;
+ ack (sync (Queueop.watch path data) con)
+
+let unwatch path data con =
+ validate_watch_path path;
+ ack (sync (Queueop.unwatch path data) con)
+
+let transaction_start con =
+ let data = sync (Queueop.transaction_start) con in
+ try
+ int_of_string data
+ with
+ _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data))
+
+let transaction_end tid commit con =
+ try
+ ack (sync (Queueop.transaction_end tid commit) con);
+ true
+ with
+ Xb.Eagain -> false
+
+let introduce domid mfn port con =
+ ack (sync (Queueop.introduce domid mfn port) con)
+
+let release domid con =
+ ack (sync (Queueop.release domid) con)
+
+let resume domid con =
+ ack (sync (Queueop.resume domid) con)
+
+let getdomainpath domid con =
+ sync (Queueop.getdomainpath domid) con
+
+let write tid path value con =
+ validate_path path;
+ ack (sync (Queueop.write tid path value) con)
+
+let writev tid dir vec con =
+ List.iter (fun (entry, value) ->
+ let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
+ validate_path path;
+ write tid path value con) vec
+
+let mkdir tid path con =
+ validate_path path;
+ ack (sync (Queueop.mkdir tid path) con)
+
+let rm tid path con =
+ validate_path path;
+ try
+ ack (sync (Queueop.rm tid path) con)
+ with
+ Xb.Noent -> ()
+
+let setperms tid path perms con =
+ validate_path path;
+ ack (sync (Queueop.setperms tid path (string_of_perms perms)) con)
+
+let setpermsv tid dir vec perms con =
+ List.iter (fun entry ->
+ let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
+ validate_path path;
+ setperms tid path perms con) vec
diff --git a/tools/ocaml/libs/xs/xsraw.mli b/tools/ocaml/libs/xs/xsraw.mli
new file mode 100644
index 0000000..42f87b6
--- /dev/null
+++ b/tools/ocaml/libs/xs/xsraw.mli
@@ -0,0 +1,60 @@
+(*
+ * 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 Partial_not_empty
+exception Unexpected_packet of string
+exception Invalid_path of string
+val unexpected_packet : Xb.Op.operation -> Xb.Op.operation -> 'a
+type con = { xb : Xb.t; watchevents : (string * string) Queue.t; }
+val close : con -> unit
+val open_fd : Unix.file_descr -> con
+val split_string : ?limit:int -> char -> string -> string list
+type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR
+type perms = int * perm * (int * perm) list
+val string_of_perms : int * perm * (int * perm) list -> string
+val perms_of_string : string -> int * perm * (int * perm) list
+val pkt_send : con -> unit
+val pkt_recv : con -> Xb.Packet.t
+val pkt_recv_timeout : con -> float -> bool * Xb.Packet.t option
+val queue_watchevent : con -> string -> unit
+val has_watchevents : con -> bool
+val get_watchevent : con -> string * string
+val read_watchevent : con -> string * string
+val sync_recv : Xb.Op.operation -> con -> string
+val sync : (Xb.t -> 'a) -> con -> string
+val ack : string -> unit
+val validate_path : string -> unit
+val validate_watch_path : string -> unit
+val directory : int -> string -> con -> string list
+val debug : string list -> con -> string
+val read : int -> string -> con -> string
+val readv : int -> string -> string list -> con -> string list
+val getperms : int -> string -> con -> int * perm * (int * perm) list
+val watch : string -> string -> con -> unit
+val unwatch : string -> string -> con -> unit
+val transaction_start : con -> int
+val transaction_end : int -> bool -> con -> bool
+val introduce : int -> nativeint -> int -> con -> unit
+val release : int -> con -> unit
+val resume : int -> con -> unit
+val getdomainpath : int -> con -> string
+val write : int -> string -> string -> con -> unit
+val writev : int -> string -> (string * string) list -> con -> unit
+val mkdir : int -> string -> con -> unit
+val rm : int -> string -> con -> unit
+val setperms : int -> string -> int * perm * (int * perm) list -> con -> unit
+val setpermsv :
+ int ->
+ string -> string list -> int * perm * (int * perm) list -> con -> unit
diff --git a/tools/ocaml/libs/xs/xst.ml b/tools/ocaml/libs/xs/xst.ml
new file mode 100644
index 0000000..16affd2
--- /dev/null
+++ b/tools/ocaml/libs/xs/xst.ml
@@ -0,0 +1,61 @@
+(*
+ * 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 ops =
+{
+ directory: string -> string list;
+ read: string -> string;
+ readv: string -> string list -> string list;
+ write: string -> string -> unit;
+ writev: string -> (string * string) list -> unit;
+ mkdir: string -> unit;
+ rm: string -> unit;
+ getperms: string -> Xsraw.perms;
+ setperms: string -> Xsraw.perms -> unit;
+ setpermsv: string -> string list -> Xsraw.perms -> unit;
+}
+
+let get_operations tid xsh = {
+ directory = (fun path -> Xsraw.directory tid path xsh);
+ read = (fun path -> Xsraw.read tid path xsh);
+ readv = (fun dir vec -> Xsraw.readv tid dir vec xsh);
+ write = (fun path value -> Xsraw.write tid path value xsh);
+ writev = (fun dir vec -> Xsraw.writev tid dir vec xsh);
+ mkdir = (fun path -> Xsraw.mkdir tid path xsh);
+ rm = (fun path -> Xsraw.rm tid path xsh);
+ getperms = (fun path -> Xsraw.getperms tid path xsh);
+ setperms = (fun path perms -> Xsraw.setperms tid path perms xsh);
+ setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh);
+}
+
+let transaction xsh (f: ops -> 'a) : 'a =
+ let commited = ref false and result = ref None in
+ while not !commited
+ do
+ let tid = Xsraw.transaction_start xsh in
+ let t = get_operations tid xsh in
+
+ begin try
+ result := Some (f t)
+ with exn ->
+ ignore (Xsraw.transaction_end tid false xsh);
+ raise exn
+ end;
+ commited := Xsraw.transaction_end tid true xsh
+ done;
+ match !result with
+ | None -> failwith "internal error in transaction"
+ | Some result -> result
diff --git a/tools/ocaml/libs/xs/xst.mli b/tools/ocaml/libs/xs/xst.mli
new file mode 100644
index 0000000..5ae5604
--- /dev/null
+++ b/tools/ocaml/libs/xs/xst.mli
@@ -0,0 +1,30 @@
+(*
+ * 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 ops = {
+ directory : string -> string list;
+ read : string -> string;
+ readv : string -> string list -> string list;
+ write : string -> string -> unit;
+ writev : string -> (string * string) list -> unit;
+ mkdir : string -> unit;
+ rm : string -> unit;
+ getperms : string -> Xsraw.perms;
+ setperms : string -> Xsraw.perms -> unit;
+ setpermsv : string -> string list -> Xsraw.perms -> unit;
+}
+
+val get_operations : int -> Xsraw.con -> ops
+val transaction : Xsraw.con -> (ops -> 'a) -> 'a
[-- 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 04/10] add uuid ocaml bindings
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
` (2 preceding siblings ...)
2010-03-09 14:41 ` [PATCH 03/10] add XS ocaml bindings Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 05/10] add logs " Vincent Hanquez
` (5 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: 574 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/libs/uuid/META.in | 4 ++
tools/ocaml/libs/uuid/Makefile | 26 ++++++++++++
tools/ocaml/libs/uuid/uuid.ml | 88 ++++++++++++++++++++++++++++++++++++++++
tools/ocaml/libs/uuid/uuid.mli | 53 ++++++++++++++++++++++++
4 files changed, 171 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/libs/uuid/META.in
create mode 100644 tools/ocaml/libs/uuid/Makefile
create mode 100644 tools/ocaml/libs/uuid/uuid.ml
create mode 100644 tools/ocaml/libs/uuid/uuid.mli
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0004-add-uuid-ocaml-bindings.patch --]
[-- Type: text/x-patch; name="0004-add-uuid-ocaml-bindings.patch", Size: 6285 bytes --]
diff --git a/tools/ocaml/libs/uuid/META.in b/tools/ocaml/libs/uuid/META.in
new file mode 100644
index 0000000..f33c980
--- /dev/null
+++ b/tools/ocaml/libs/uuid/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Uuid - universal identifer"
+archive(byte) = "uuid.cma"
+archive(native) = "uuid.cmxa"
diff --git a/tools/ocaml/libs/uuid/Makefile b/tools/ocaml/libs/uuid/Makefile
new file mode 100644
index 0000000..8ddb0e2
--- /dev/null
+++ b/tools/ocaml/libs/uuid/Makefile
@@ -0,0 +1,26 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = uuid
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = uuid.cma uuid.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+uuid_OBJS = $(OBJS)
+OCAML_NOC_LIBRARY = uuid
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore uuid META $(INTF) $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove uuid
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/uuid/uuid.ml b/tools/ocaml/libs/uuid/uuid.ml
new file mode 100644
index 0000000..7c25247
--- /dev/null
+++ b/tools/ocaml/libs/uuid/uuid.ml
@@ -0,0 +1,88 @@
+(*
+ * 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-safe UUIDs. *)
+
+(** Internally, a UUID is simply a string. *)
+type 'a t = string
+
+type cookie = string
+
+let of_string s = s
+let to_string s = s
+
+(* deprecated: we don't need to duplicate the uuid prefix/suffix *)
+let uuid_of_string = of_string
+let string_of_uuid = to_string
+
+let string_of_cookie s = s
+
+let cookie_of_string s = s
+
+(** FIXME: using /dev/random is too slow but using /dev/urandom is too
+ deterministic. *)
+let dev_random = "/dev/urandom"
+
+let read_random n =
+ let ic = open_in_bin dev_random in
+ try
+ let result = Array.init n (fun _ -> input_byte ic) in
+ close_in ic;
+ result
+ with e ->
+ close_in ic;
+ raise e
+
+let uuid_of_int_array uuid =
+ Printf.sprintf "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
+ uuid.(0) uuid.(1) uuid.(2) uuid.(3) uuid.(4) uuid.(5)
+ uuid.(6) uuid.(7) uuid.(8) uuid.(9) uuid.(10) uuid.(11)
+ uuid.(12) uuid.(13) uuid.(14) uuid.(15)
+
+(** Return a new random UUID *)
+let make_uuid() = uuid_of_int_array (read_random 16)
+
+(** Return a new random, big UUID (hopefully big and random enough to be
+ unguessable) *)
+let make_cookie() =
+ let bytes = Array.to_list (read_random 64) in
+ String.concat "" (List.map (Printf.sprintf "%1x") bytes)
+(*
+ let hexencode x =
+ let nibble x =
+ char_of_int (if x < 10
+ then int_of_char '0' + x
+ else int_of_char 'a' + (x - 10)) in
+ let result = String.make (String.length x * 2) ' ' in
+ for i = 0 to String.length x - 1 do
+ let byte = int_of_char x.[i] in
+ result.[i * 2 + 0] <- nibble((byte lsr 4) land 15);
+ result.[i * 2 + 1] <- nibble((byte lsr 0) land 15);
+ done;
+ result in
+ let n = 64 in
+ hexencode (String.concat "" (List.map (fun x -> String.make 1 (char_of_int x)) (Array.to_list (read_n_random_bytes n))))
+*)
+
+let int_array_of_uuid s =
+ try
+ let l = ref [] in
+ Scanf.sscanf s "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
+ (fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 ->
+ l := [ a0; a1; a2; a3; a4; a5; a6; a7; a8; a9;
+ a10; a11; a12; a13; a14; a15; ]);
+ Array.of_list !l
+ with _ -> invalid_arg "Uuid.int_array_of_uuid"
diff --git a/tools/ocaml/libs/uuid/uuid.mli b/tools/ocaml/libs/uuid/uuid.mli
new file mode 100644
index 0000000..3b4a937
--- /dev/null
+++ b/tools/ocaml/libs/uuid/uuid.mli
@@ -0,0 +1,53 @@
+(*
+ * 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-safe UUIDs.
+ Probably need to refactor this; UUIDs are used in two places:
+ 1. to uniquely name things across the cluster
+ 2. as secure session IDs
+ There is the additional constraint that current Xen tools use
+ a particular format of UUID (the 16 byte variety generated by fresh ())
+*)
+
+(** A 128-bit UUID referencing a value of type 'a. *)
+type 'a t
+
+(** A 512-bit UUID. *)
+type cookie
+
+(** Create a fresh (unique!) UUID *)
+val make_uuid : unit -> 'a t
+
+(** Create a fresh secure (bigger and hopefully unguessable) UUID *)
+val make_cookie : unit -> cookie
+
+(** Create a type-safe UUID. *)
+val of_string : string -> 'a t
+
+(** Marshal a UUID to a (type-unsafe) string. *)
+val to_string : 'a t -> string
+
+(* deprecated alias for previous one *)
+val uuid_of_string : string -> 'a t
+val string_of_uuid : 'a t -> string
+
+val cookie_of_string : string -> cookie
+
+val string_of_cookie : cookie -> string
+
+val uuid_of_int_array : int array -> 'a t
+
+val int_array_of_uuid : 'a t -> int array
[-- 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 05/10] add logs ocaml bindings
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
` (3 preceding siblings ...)
2010-03-09 14:41 ` [PATCH 04/10] add uuid " Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 06/10] add ocaml xenstored Vincent Hanquez
` (4 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: 1105 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/libs/log/META.in | 4 +
tools/ocaml/libs/log/Makefile | 41 ++++++
tools/ocaml/libs/log/log.ml | 258 +++++++++++++++++++++++++++++++++++
tools/ocaml/libs/log/log.mli | 55 ++++++++
tools/ocaml/libs/log/logs.ml | 197 ++++++++++++++++++++++++++
tools/ocaml/libs/log/logs.mli | 46 ++++++
tools/ocaml/libs/log/syslog.ml | 26 ++++
tools/ocaml/libs/log/syslog.mli | 41 ++++++
tools/ocaml/libs/log/syslog_stubs.c | 73 ++++++++++
9 files changed, 741 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/libs/log/META.in
create mode 100644 tools/ocaml/libs/log/Makefile
create mode 100644 tools/ocaml/libs/log/log.ml
create mode 100644 tools/ocaml/libs/log/log.mli
create mode 100644 tools/ocaml/libs/log/logs.ml
create mode 100644 tools/ocaml/libs/log/logs.mli
create mode 100644 tools/ocaml/libs/log/syslog.ml
create mode 100644 tools/ocaml/libs/log/syslog.mli
create mode 100644 tools/ocaml/libs/log/syslog_stubs.c
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0005-add-logs-ocaml-bindings.patch --]
[-- Type: text/x-patch; name="0005-add-logs-ocaml-bindings.patch", Size: 26619 bytes --]
diff --git a/tools/ocaml/libs/log/META.in b/tools/ocaml/libs/log/META.in
new file mode 100644
index 0000000..5c3646a
--- /dev/null
+++ b/tools/ocaml/libs/log/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Log - logging library"
+archive(byte) = "log.cma"
+archive(native) = "log.cmxa"
diff --git a/tools/ocaml/libs/log/Makefile b/tools/ocaml/libs/log/Makefile
new file mode 100644
index 0000000..47c7918
--- /dev/null
+++ b/tools/ocaml/libs/log/Makefile
@@ -0,0 +1,41 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = syslog log logs
+INTF = log.cmi logs.cmi syslog.cmi
+LIBS = log.cma log.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+log.cmxa: libsyslog_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(call mk-caml-lib-native, $@, -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmx))
+
+log.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmo))
+
+syslog_stubs.a: syslog_stubs.o
+ $(call mk-caml-stubs, $@, $+)
+
+libsyslog_stubs.a: syslog_stubs.o
+ $(call mk-caml-lib-stubs, $@, $+)
+
+logs.mli : logs.ml
+ $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
+
+syslog.mli : syslog.ml
+ $(OCAMLC) -i $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove log
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/log/log.ml b/tools/ocaml/libs/log/log.ml
new file mode 100644
index 0000000..4f42759
--- /dev/null
+++ b/tools/ocaml/libs/log/log.ml
@@ -0,0 +1,258 @@
+(*
+ * 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
+
+exception Unknown_level of string
+
+type stream_type = Stderr | Stdout | File of string
+
+type stream_log = {
+ ty : stream_type;
+ channel : out_channel option ref;
+}
+
+type level = Debug | Info | Warn | Error
+
+type output =
+ | Stream of stream_log
+ | String of string list ref
+ | Syslog of string
+ | Nil
+
+let int_of_level l =
+ match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3
+
+let string_of_level l =
+ match l with Debug -> "debug" | Info -> "info"
+ | Warn -> "warn" | Error -> "error"
+
+let level_of_string s =
+ match s with
+ | "debug" -> Debug
+ | "info" -> Info
+ | "warn" -> Warn
+ | "error" -> Error
+ | _ -> raise (Unknown_level s)
+
+let mkdir_safe dir perm =
+ try Unix.mkdir dir perm with _ -> ()
+
+let mkdir_rec dir perm =
+ let rec p_mkdir dir =
+ let p_name = Filename.dirname dir in
+ if p_name = "/" || p_name = "." then
+ ()
+ else (
+ p_mkdir p_name;
+ mkdir_safe dir perm
+ ) in
+ p_mkdir dir
+
+type t = { output: output; mutable level: level; }
+
+let make output level = { output = output; level = level; }
+
+let make_stream ty channel =
+ Stream {ty=ty; channel=ref channel; }
+
+(** open a syslog logger *)
+let opensyslog k level =
+ make (Syslog k) level
+
+(** open a stderr logger *)
+let openerr level =
+ if (Unix.stat "/dev/stderr").Unix.st_kind <> Unix.S_CHR then
+ failwith "/dev/stderr is not a valid character device";
+ make (make_stream Stderr (Some (open_out "/dev/stderr"))) level
+
+let openout level =
+ if (Unix.stat "/dev/stdout").Unix.st_kind <> Unix.S_CHR then
+ failwith "/dev/stdout is not a valid character device";
+ make (make_stream Stdout (Some (open_out "/dev/stdout"))) level
+
+
+(** open a stream logger - returning the channel. *)
+(* This needs to be separated from 'openfile' so we can reopen later *)
+let doopenfile filename =
+ if Filename.is_relative filename then
+ None
+ else (
+ try
+ mkdir_rec (Filename.dirname filename) 0o700;
+ Some (open_out_gen [ Open_append; Open_creat ] 0o600 filename)
+ with _ -> None
+ )
+
+(** open a stream logger - returning the output type *)
+let openfile filename level =
+ make (make_stream (File filename) (doopenfile filename)) level
+
+(** open a nil logger *)
+let opennil () =
+ make Nil Error
+
+(** open a string logger *)
+let openstring level =
+ make (String (ref [""])) level
+
+(** try to reopen a logger *)
+let reopen t =
+ match t.output with
+ | Nil -> t
+ | Syslog k -> Syslog.close (); opensyslog k t.level
+ | Stream s -> (
+ match (s.ty,!(s.channel)) with
+ | (File filename, Some c) -> close_out c; s.channel := (try doopenfile filename with _ -> None); t
+ | _ -> t)
+ | String _ -> t
+
+(** close a logger *)
+let close t =
+ match t.output with
+ | Nil -> ()
+ | Syslog k -> Syslog.close ();
+ | Stream s -> (
+ match !(s.channel) with
+ | Some c -> close_out c; s.channel := None
+ | None -> ())
+ | String _ -> ()
+
+(** create a string representating the parameters of the logger *)
+let string_of_logger t =
+ match t.output with
+ | Nil -> "nil"
+ | Syslog k -> sprintf "syslog:%s" k
+ | String _ -> "string"
+ | Stream s ->
+ begin
+ match s.ty with
+ | File f -> sprintf "file:%s" f
+ | Stderr -> "stderr"
+ | Stdout -> "stdout"
+ end
+
+(** parse a string to a logger *)
+let logger_of_string s : t =
+ match s with
+ | "nil" -> opennil ()
+ | "stderr" -> openerr Debug
+ | "stdout" -> openout Debug
+ | "string" -> openstring Debug
+ | _ ->
+ let split_in_2 s =
+ try
+ let i = String.index s ':' in
+ String.sub s 0 (i),
+ String.sub s (i + 1) (String.length s - i - 1)
+ with _ ->
+ failwith "logger format error: expecting string:string"
+ in
+ let k, s = split_in_2 s in
+ match k with
+ | "syslog" -> opensyslog s Debug
+ | "file" -> openfile s Debug
+ | _ -> failwith "unknown logger type"
+
+let validate s =
+ match s with
+ | "nil" -> ()
+ | "stderr" -> ()
+ | "stdout" -> ()
+ | "string" -> ()
+ | _ ->
+ let split_in_2 s =
+ try
+ let i = String.index s ':' in
+ String.sub s 0 (i),
+ String.sub s (i + 1) (String.length s - i - 1)
+ with _ ->
+ failwith "logger format error: expecting string:string"
+ in
+ let k, s = split_in_2 s in
+ match k with
+ | "syslog" -> ()
+ | "file" -> (
+ try
+ let st = Unix.stat s in
+ if st.Unix.st_kind <> Unix.S_REG then
+ failwith "logger file is a directory";
+ ()
+ with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
+ )
+ | _ -> failwith "unknown logger"
+
+(** change a logger level to level *)
+let set t level = t.level <- level
+
+let gettimestring () =
+ 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 extra_hook = ref (fun x -> x)*)
+
+let output t ?(key="") ?(extra="") priority (message: string) =
+ let construct_string withtime =
+ (*let key = if key = "" then [] else [ key ] in
+ let extra = if extra = "" then [] else [ extra ] in
+ let items =
+ (if withtime then [ gettimestring () ] else [])
+ @ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in
+(* let items = !extra_hook items in*)
+ String.concat " " items*)
+ Printf.sprintf "[%s%s|%s] %s"
+ (if withtime then gettimestring () else "") (string_of_level priority) extra message
+ in
+ (* Keep track of how much we write out to streams, so that we can *)
+ (* log-rotate at appropriate times *)
+ let write_to_stream stream =
+ let string = (construct_string true) in
+ try
+ fprintf stream "%s\n%!" string
+ with _ -> () (* Trap exception when we fail to write log *)
+ in
+
+ if String.length message > 0 then
+ match t.output with
+ | Syslog k ->
+ let sys_prio = match priority with
+ | Debug -> Syslog.Debug
+ | Info -> Syslog.Info
+ | Warn -> Syslog.Warning
+ | Error -> Syslog.Err in
+ Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n")
+ | Stream s -> (
+ match !(s.channel) with
+ | Some c -> write_to_stream c
+ | None -> ())
+ | Nil -> ()
+ | String s -> (s := (construct_string true)::!s)
+
+let log t level (fmt: ('a, unit, string, unit) format4): 'a =
+ let b = (int_of_level t.level) <= (int_of_level level) in
+ (* ksprintf is the preferred name for kprintf, but the former
+ * is not available in OCaml 3.08.3 *)
+ Printf.kprintf (if b then output t level else (fun _ -> ())) fmt
+
+let debug t (fmt: ('a , unit, string, unit) format4) = log t Debug fmt
+let info t (fmt: ('a , unit, string, unit) format4) = log t Info fmt
+let warn t (fmt: ('a , unit, string, unit) format4) = log t Warn fmt
+let error t (fmt: ('a , unit, string, unit) format4) = log t Error fmt
diff --git a/tools/ocaml/libs/log/log.mli b/tools/ocaml/libs/log/log.mli
new file mode 100644
index 0000000..36c5a6b
--- /dev/null
+++ b/tools/ocaml/libs/log/log.mli
@@ -0,0 +1,55 @@
+(*
+ * 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 Unknown_level of string
+type level = Debug | Info | Warn | Error
+
+type stream_type = Stderr | Stdout | File of string
+type stream_log = {
+ ty : stream_type;
+ channel : out_channel option ref;
+}
+type output =
+ Stream of stream_log
+ | String of string list ref
+ | Syslog of string
+ | Nil
+val int_of_level : level -> int
+val string_of_level : level -> string
+val level_of_string : string -> level
+val mkdir_safe : string -> Unix.file_perm -> unit
+val mkdir_rec : string -> Unix.file_perm -> unit
+type t = { output : output; mutable level : level; }
+val make : output -> level -> t
+val opensyslog : string -> level -> t
+val openerr : level -> t
+val openout : level -> t
+val openfile : string -> level -> t
+val opennil : unit -> t
+val openstring : level -> t
+val reopen : t -> t
+val close : t -> unit
+val string_of_logger : t -> string
+val logger_of_string : string -> t
+val validate : string -> unit
+val set : t -> level -> unit
+val gettimestring : unit -> string
+val output : t -> ?key:string -> ?extra:string -> level -> string -> unit
+val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
+val debug : t -> ('a, unit, string, unit) format4 -> 'a
+val info : t -> ('a, unit, string, unit) format4 -> 'a
+val warn : t -> ('a, unit, string, unit) format4 -> 'a
+val error : t -> ('a, unit, string, unit) format4 -> 'a
diff --git a/tools/ocaml/libs/log/logs.ml b/tools/ocaml/libs/log/logs.ml
new file mode 100644
index 0000000..2a40896
--- /dev/null
+++ b/tools/ocaml/libs/log/logs.ml
@@ -0,0 +1,197 @@
+(*
+ * 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 keylogger =
+{
+ mutable debug: string list;
+ mutable info: string list;
+ mutable warn: string list;
+ mutable error: string list;
+ no_default: bool;
+}
+
+(* map all logger strings into a logger *)
+let __all_loggers = Hashtbl.create 10
+
+(* default logger that everything that doesn't have a key in __lop_mapping get send *)
+let __default_logger = { debug = []; info = []; warn = []; error = []; no_default = false }
+
+(*
+ * This describe the mapping between a name to a keylogger.
+ * a keylogger contains a list of logger string per level of debugging.
+ * Example: "xenops", debug -> [ "stderr"; "/var/log/xensource.log" ]
+ * "xapi", error -> []
+ * "xapi", debug -> [ "/var/log/xensource.log" ]
+ * "xenops", info -> [ "syslog" ]
+ *)
+let __log_mapping = Hashtbl.create 32
+
+let get_or_open logstring =
+ if Hashtbl.mem __all_loggers logstring then
+ Hashtbl.find __all_loggers logstring
+ else
+ let t = Log.logger_of_string logstring in
+ Hashtbl.add __all_loggers logstring t;
+ t
+
+(** create a mapping entry for the key "name".
+ * all log level of key "name" default to "logger" logger.
+ * a sensible default is put "nil" as a logger and reopen a specific level to
+ * the logger you want to.
+ *)
+let add key logger =
+ let kl = {
+ debug = logger;
+ info = logger;
+ warn = logger;
+ error = logger;
+ no_default = false;
+ } in
+ Hashtbl.add __log_mapping key kl
+
+let get_by_level keylog level =
+ match level with
+ | Log.Debug -> keylog.debug
+ | Log.Info -> keylog.info
+ | Log.Warn -> keylog.warn
+ | Log.Error -> keylog.error
+
+let set_by_level keylog level logger =
+ match level with
+ | Log.Debug -> keylog.debug <- logger
+ | Log.Info -> keylog.info <- logger
+ | Log.Warn -> keylog.warn <- logger
+ | Log.Error -> keylog.error <- logger
+
+(** set a specific key|level to the logger "logger" *)
+let set key level logger =
+ if not (Hashtbl.mem __log_mapping key) then
+ add key [];
+
+ let keylog = Hashtbl.find __log_mapping key in
+ set_by_level keylog level logger
+
+(** set default logger *)
+let set_default level logger =
+ set_by_level __default_logger level logger
+
+(** append a logger to the list *)
+let append key level logger =
+ if not (Hashtbl.mem __log_mapping key) then
+ add key [];
+ let keylog = Hashtbl.find __log_mapping key in
+ let loggers = get_by_level keylog level in
+ set_by_level keylog level (loggers @ [ logger ])
+
+(** append a logger to the default list *)
+let append_default level logger =
+ let loggers = get_by_level __default_logger level in
+ set_by_level __default_logger level (loggers @ [ logger ])
+
+(** reopen all logger open *)
+let reopen () =
+ Hashtbl.iter (fun k v ->
+ Hashtbl.replace __all_loggers k (Log.reopen v)) __all_loggers
+
+(** reclaim close all logger open that are not use by any other keys *)
+let reclaim () =
+ let list_sort_uniq l =
+ let oldprev = ref "" and prev = ref "" in
+ List.fold_left (fun a k ->
+ oldprev := !prev;
+ prev := k;
+ if k = !oldprev then a else k :: a) []
+ (List.sort compare l)
+ in
+ let flatten_keylogger v =
+ list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in
+ let oldkeys = Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in
+ let usedkeys = Hashtbl.fold (fun k v a ->
+ (flatten_keylogger v) @ a)
+ __log_mapping (flatten_keylogger __default_logger) in
+ let usedkeys = list_sort_uniq usedkeys in
+
+ List.iter (fun k ->
+ if not (List.mem k usedkeys) then (
+ begin try
+ Log.close (Hashtbl.find __all_loggers k)
+ with
+ Not_found -> ()
+ end;
+ Hashtbl.remove __all_loggers k
+ )) oldkeys
+
+(** clear a specific key|level *)
+let clear key level =
+ try
+ let keylog = Hashtbl.find __log_mapping key in
+ set_by_level keylog level [];
+ reclaim ()
+ with Not_found ->
+ ()
+
+(** clear a specific default level *)
+let clear_default level =
+ set_default level [];
+ reclaim ()
+
+(** reset all the loggers to the specified logger *)
+let reset_all logger =
+ Hashtbl.clear __log_mapping;
+ set_default Log.Debug logger;
+ set_default Log.Warn logger;
+ set_default Log.Error logger;
+ set_default Log.Info logger;
+ reclaim ()
+
+(** log a fmt message to the key|level logger specified in the log mapping.
+ * if the logger doesn't exist, assume nil logger.
+ *)
+let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a =
+ let keylog =
+ if Hashtbl.mem __log_mapping key then
+ let keylog = Hashtbl.find __log_mapping key in
+ if keylog.no_default = false &&
+ get_by_level keylog level = [] then
+ __default_logger
+ else
+ keylog
+ else
+ __default_logger in
+ let loggers = get_by_level keylog level in
+ match loggers with
+ | [] -> Printf.kprintf ignore fmt
+ | _ ->
+ let l = List.fold_left (fun acc logger ->
+ try get_or_open logger :: acc
+ with _ -> acc
+ ) [] loggers in
+ let l = List.rev l in
+
+ (* ksprintf is the preferred name for kprintf, but the former
+ * is not available in OCaml 3.08.3 *)
+ Printf.kprintf (fun s ->
+ List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt
+
+(* define some convenience functions *)
+let debug t ?extra (fmt: ('a , unit, string, unit) format4) =
+ log t Log.Debug ?extra fmt
+let info t ?extra (fmt: ('a , unit, string, unit) format4) =
+ log t Log.Info ?extra fmt
+let warn t ?extra (fmt: ('a , unit, string, unit) format4) =
+ log t Log.Warn ?extra fmt
+let error t ?extra (fmt: ('a , unit, string, unit) format4) =
+ log t Log.Error ?extra fmt
diff --git a/tools/ocaml/libs/log/logs.mli b/tools/ocaml/libs/log/logs.mli
new file mode 100644
index 0000000..76e10db
--- /dev/null
+++ b/tools/ocaml/libs/log/logs.mli
@@ -0,0 +1,46 @@
+(*
+ * 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 keylogger = {
+ mutable debug : string list;
+ mutable info : string list;
+ mutable warn : string list;
+ mutable error : string list;
+ no_default : bool;
+}
+val __all_loggers : (string, Log.t) Hashtbl.t
+val __default_logger : keylogger
+val __log_mapping : (string, keylogger) Hashtbl.t
+val get_or_open : string -> Log.t
+val add : string -> string list -> unit
+val get_by_level : keylogger -> Log.level -> string list
+val set_by_level : keylogger -> Log.level -> string list -> unit
+val set : string -> Log.level -> string list -> unit
+val set_default : Log.level -> string list -> unit
+val append : string -> Log.level -> string -> unit
+val append_default : Log.level -> string -> unit
+val reopen : unit -> unit
+val reclaim : unit -> unit
+val clear : string -> Log.level -> unit
+val clear_default : Log.level -> unit
+val reset_all : string list -> unit
+val log :
+ string ->
+ Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val debug : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val info : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val warn : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val error : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
diff --git a/tools/ocaml/libs/log/syslog.ml b/tools/ocaml/libs/log/syslog.ml
new file mode 100644
index 0000000..2b417da
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog.ml
@@ -0,0 +1,26 @@
+(*
+ * 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 level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
+type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
+type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern
+ | Local0 | Local1 | Local2 | Local3
+ | Local4 | Local5 | Local6 | Local7
+ | Lpr | Mail | News | Syslog | User | Uucp
+
+(* external init : string -> options list -> facility -> unit = "stub_openlog" *)
+external log : facility -> level -> string -> unit = "stub_syslog"
+external close : unit -> unit = "stub_closelog"
diff --git a/tools/ocaml/libs/log/syslog.mli b/tools/ocaml/libs/log/syslog.mli
new file mode 100644
index 0000000..425f42a
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog.mli
@@ -0,0 +1,41 @@
+(*
+ * 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 level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
+type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
+type facility =
+ Auth
+ | Authpriv
+ | Cron
+ | Daemon
+ | Ftp
+ | Kern
+ | Local0
+ | Local1
+ | Local2
+ | Local3
+ | Local4
+ | Local5
+ | Local6
+ | Local7
+ | Lpr
+ | Mail
+ | News
+ | Syslog
+ | User
+ | Uucp
+external log : facility -> level -> string -> unit = "stub_syslog"
+external close : unit -> unit = "stub_closelog"
diff --git a/tools/ocaml/libs/log/syslog_stubs.c b/tools/ocaml/libs/log/syslog_stubs.c
new file mode 100644
index 0000000..965610a
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog_stubs.c
@@ -0,0 +1,73 @@
+/*
+ * 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 <syslog.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+static int __syslog_level_table[] = {
+ LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING,
+ LOG_NOTICE, LOG_INFO, LOG_DEBUG
+};
+
+static int __syslog_options_table[] = {
+ LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID
+};
+
+static int __syslog_facility_table[] = {
+ LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN,
+ LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3,
+ LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7,
+ LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP
+};
+
+/* According to the openlog manpage the 'openlog' call may take a reference
+ to the 'ident' string and keep it long-term. This means we cannot just pass in
+ an ocaml string which is under the control of the GC. Since we aren't actually
+ calling this function we can just comment it out for the time-being. */
+/*
+value stub_openlog(value ident, value option, value facility)
+{
+ CAMLparam3(ident, option, facility);
+ int c_option;
+ int c_facility;
+
+ c_option = caml_convert_flag_list(option, __syslog_options_table);
+ c_facility = __syslog_facility_table[Int_val(facility)];
+ openlog(String_val(ident), c_option, c_facility);
+ CAMLreturn(Val_unit);
+}
+*/
+
+value stub_syslog(value facility, value level, value msg)
+{
+ CAMLparam3(facility, level, msg);
+ int c_facility;
+
+ c_facility = __syslog_facility_table[Int_val(facility)]
+ | __syslog_level_table[Int_val(level)];
+ syslog(c_facility, "%s", String_val(msg));
+ CAMLreturn(Val_unit);
+}
+
+value stub_closelog(value unit)
+{
+ CAMLparam1(unit);
+ closelog();
+ CAMLreturn(Val_unit);
+}
[-- 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
* [PATCH 07/10] add compilation makefile to ocaml directory
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
` (5 preceding siblings ...)
2010-03-09 14:41 ` [PATCH 06/10] add ocaml xenstored Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 08/10] remove hook from external ocaml repository Vincent Hanquez
` (2 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: 446 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/Makefile | 36 +++++++++++++++++
tools/ocaml/Makefile.rules | 93 ++++++++++++++++++++++++++++++++++++++++++++
tools/ocaml/common.make | 28 +++++++++++++
3 files changed, 157 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/Makefile
create mode 100644 tools/ocaml/Makefile.rules
create mode 100644 tools/ocaml/common.make
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0007-add-compilation-makefile-to-ocaml-directory.patch --]
[-- Type: text/x-patch; name="0007-add-compilation-makefile-to-ocaml-directory.patch", Size: 5476 bytes --]
diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile
new file mode 100644
index 0000000..73c2988
--- /dev/null
+++ b/tools/ocaml/Makefile
@@ -0,0 +1,36 @@
+XEN_ROOT = ../..
+include $(XEN_ROOT)/tools/Rules.mk
+
+SUBDIRS_LIBS = \
+ libs/uuid libs/mmap \
+ libs/log libs/xc libs/eventchn \
+ libs/xb libs/xs
+
+SUBDIRS_PROGRAMS = xenstored
+
+SUBDIRS = $(SUBDIRS_LIBS) $(SUBDIRS_PROGRAMS)
+
+.PHONY: all
+all: build
+
+.PHONY: build $(SUBDIRS)
+build: $(SUBDIRS)
+
+$(SUBDIRS):
+ @echo " === building $@"
+ @$(MAKE) --no-print-directory -C $@
+
+.PHONY: install install-libs install-program
+install: install-libs install-program
+
+install-program: $(SUBDIRS_PROGRAMS)
+ $(INSTALL_DIR) $(DESTDIR)$(SBINDIR)
+ $(INSTALL_PROG) xenstored/oxenstored $(DESTDIR)$(SBINDIR)
+
+install-libs: $(SUBDIRS_LIBS)
+
+.PHONY: clean
+clean:
+ @for dir in $(SUBDIRS); do \
+ $(MAKE) --no-print-directory -C $$dir clean; \
+ done
diff --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules
new file mode 100644
index 0000000..ee06b73
--- /dev/null
+++ b/tools/ocaml/Makefile.rules
@@ -0,0 +1,93 @@
+ifdef V
+ ifeq ("$(origin V)", "command line")
+ BUILD_VERBOSE = $(V)
+ endif
+endif
+ifndef BUILD_VERBOSE
+ BUILD_VERBOSE = 0
+endif
+ifeq ($(BUILD_VERBOSE),1)
+ E = @true
+ Q =
+else
+ E = @echo
+ Q = @
+endif
+
+ALL_OCAML_OBJS ?= $(OBJS)
+
+%.cmo: %.ml
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -c -o $@ $<,MLC,$@)
+
+%.cmi: %.mli
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -c -o $@ $<,MLI,$@)
+
+%.cmx: %.ml
+ $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<,MLOPT,$@)
+
+%.ml: %.mll
+ $(call quiet-command, $(OCAMLLEX) -q -o $@ $<,MLLEX,$@)
+
+%.ml: %.mly
+ $(call quiet-command, $(OCAMLYACC) -q $<,MLYACC,$@)
+
+%.o: %.c
+ $(call quiet-command, $(CC) $(CFLAGS) -c -o $@ $<,CC,$@)
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< $o
+
+ALL_OCAML_OBJ_SOURCES=$(addsuffix .ml, $(ALL_OCAML_OBJS))
+
+.ocamldep.make: $(ALL_OCAML_OBJ_SOURCES) Makefile $(TOPLEVEL)/Makefile.rules
+ $(call quiet-command, $(OCAMLDEP) $(ALL_OCAML_OBJ_SOURCES) *.mli $o,MLDEP,)
+
+clean: $(CLEAN_HOOKS)
+ $(Q)rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) $(GENERATED_FILES) .ocamldep.make
+
+quiet-command = $(if $(V),$1,@printf " %-8s %s\n" "$2" "$3" && $1)
+
+mk-caml-lib-native = $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $1 $2 $3,MLA,$1)
+mk-caml-lib-bytecode = $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -a -o $1 $2 $3,MLA,$1)
+
+mk-caml-stubs = $(call quiet-command, $(OCAMLMKLIB) -o `basename $1 .a` $2,MKLIB,$1)
+mk-caml-lib-stubs = \
+ $(call quiet-command, $(AR) rcs $1 $2 && $(OCAMLMKLIB) -o `basename $1 .a | sed -e 's/^lib//'` $2,MKLIB,$1)
+
+# define a library target <name>.cmxa and <name>.cma
+define OCAML_LIBRARY_template
+ $(1).cmxa: lib$(1)_stubs.a $(foreach obj,$($(1)_OBJS),$(obj).cmx)
+ $(call mk-caml-lib-native,$$@, -cclib -l$(1)_stubs, $(foreach obj,$($(1)_OBJS),$(obj).cmx))
+ $(1).cma: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call mk-caml-lib-bytecode,$$@, -dllib dll$(1)_stubs.so -cclib -l$(1)_stubs, $$+)
+ $(1)_stubs.a: $(foreach obj,$$($(1)_C_OBJS),$(obj).o)
+ $(call mk-caml-stubs,$$@, $$+)
+ lib$(1)_stubs.a: $(foreach obj,$($(1)_C_OBJS),$(obj).o)
+ $(call mk-caml-lib-stubs,$$@, $$+)
+endef
+
+define OCAML_NOC_LIBRARY_template
+ $(1).cmxa: $(foreach obj,$($(1)_OBJS),$(obj).cmx)
+ $(call mk-caml-lib-native,$$@, , $(foreach obj,$($(1)_OBJS),$(obj).cmx))
+ $(1).cma: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call mk-caml-lib-bytecode,$$@, , $$+)
+endef
+
+define OCAML_PROGRAM_template
+ $(1): $(foreach obj,$($(1)_OBJS),$(obj).cmx) $($(1)_EXTRA_DEPS)
+ $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -o $$@ $($(1)_LIBS) $$+,MLBIN,$$@)
+ $(1).byte: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -o $$@ $($(1)_BYTE_LIBS) $$+,MLBIN,$$@)
+endef
+
+define C_PROGRAM_template
+ $(1): $(foreach obj,$($(1)_OBJS),$(obj).o)
+ $(call quiet-command, $(CC) $(CFLAGS) -o $$@ $$+,BIN,$$@)
+endef
+
+-include .ocamldep.make
+
+$(foreach lib,$(OCAML_LIBRARY),$(eval $(call OCAML_LIBRARY_template,$(lib))))
+$(foreach lib,$(OCAML_NOC_LIBRARY),$(eval $(call OCAML_NOC_LIBRARY_template,$(lib))))
+$(foreach p,$(OCAML_PROGRAM),$(eval $(call OCAML_PROGRAM_template,$(p))))
+$(foreach p,$(C_PROGRAM),$(eval $(call C_PROGRAM_template,$(p))))
diff --git a/tools/ocaml/common.make b/tools/ocaml/common.make
new file mode 100644
index 0000000..3b14dfb
--- /dev/null
+++ b/tools/ocaml/common.make
@@ -0,0 +1,28 @@
+CC ?= gcc
+OCAMLOPT ?= ocamlopt
+OCAMLC ?= ocamlc
+OCAMLMKLIB ?= ocamlmklib
+OCAMLDEP ?= ocamldep
+OCAMLLEX ?= ocamllex
+OCAMLYACC ?= ocamlyacc
+
+CFLAGS ?= -Wall -fPIC -O2
+
+XEN_ROOT ?= $(TOPLEVEL)/../xen-unstable.hg
+XEN_DIST_ROOT ?= $(XEN_ROOT)/dist/install
+CFLAGS += -I$(XEN_DIST_ROOT)/usr/include
+
+OCAMLOPTFLAG_G := $(shell $(OCAMLOPT) -h 2>&1 | sed -n 's/^ *\(-g\) .*/\1/p')
+OCAMLOPTFLAGS = $(OCAMLOPTFLAG_G) -ccopt "$(LDFLAGS)" -dtypes $(OCAMLINCLUDE) -cc $(CC) -w F -warn-error F
+OCAMLCFLAGS += -g $(OCAMLINCLUDE) -w F -warn-error F
+
+#LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := echo 0.0
+
+OCAMLABI = $(shell $(OCAMLC) -version)
+OCAMLLIBDIR = $(shell $(OCAMLC) -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+o= >$@.new && mv -f $@.new $@
[-- 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 08/10] remove hook from external ocaml repository
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
` (6 preceding siblings ...)
2010-03-09 14:41 ` [PATCH 07/10] add compilation makefile to ocaml directory Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 09/10] add ocaml tools to build if defined. default to n Vincent Hanquez
2010-03-09 14:41 ` [PATCH 10/10] default ocaml tools config variable to y Vincent Hanquez
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: 259 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
Config.mk | 6 ------
tools/Makefile | 21 ---------------------
tools/xenstore/Makefile | 5 -----
3 files changed, 0 insertions(+), 32 deletions(-)
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0008-remove-hook-from-external-ocaml-repository.patch --]
[-- Type: text/x-patch; name="0008-remove-hook-from-external-ocaml-repository.patch", Size: 2230 bytes --]
diff --git a/Config.mk b/Config.mk
index a0dc40e..364a714 100644
--- a/Config.mk
+++ b/Config.mk
@@ -158,12 +158,6 @@ QEMU_TAG := xen-4.0.0-rc5
# Thu Feb 18 15:36:29 2010 +0000
# When xen_platform_pci=0 also disable fixed Xen platform ioports
-OCAML_XENSTORED_REPO=http://xenbits.xensource.com/ext/xen-ocaml-tools.hg
-
-# Build OCAML version of xenstored instead of the in-tree C version?
-# This will cause $(OCAML_XENSTORED_REPO) to be cloned.
-CONFIG_OCAML_XENSTORED ?= n
-
# Optional components
XENSTAT_XENTOP ?= y
VTPM_TOOLS ?= n
diff --git a/tools/Makefile b/tools/Makefile
index 48c9802..c34dc86 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -6,7 +6,6 @@ SUBDIRS-y += check
SUBDIRS-y += include
SUBDIRS-y += libxc
SUBDIRS-y += flask
-SUBDIRS-$(CONFIG_OCAML_XENSTORED) += ocaml-xenstored
SUBDIRS-y += xenstore
SUBDIRS-y += misc
SUBDIRS-y += examples
@@ -114,23 +113,3 @@ subdir-clean-ioemu-dir:
$(buildmakevars2shellvars); \
$(MAKE) -C ioemu-dir clean; \
fi
-
-ocaml-xenstored:
- set -ex; \
- rm -rf ocaml-xenstored.tmp; \
- hg clone $(OCAML_XENSTORED_REPO) ocaml-xenstored.tmp; \
- if [ "$(OCAML_XENSTORED_TAG)" ]; then \
- hg -R ocaml-xenstored.tmp update -r $(OCAML_XENSTORED_TAG) ;\
- hg -R ocaml-xenstored.tmp branch mybranch ;\
- fi; \
- mv ocaml-xenstored.tmp ocaml-xenstored; \
-
-subdir-all-ocaml-xenstored subdir-install-ocaml-xenstored: ocaml-xenstored
- $(absolutify_xen_root); \
- $(MAKE) -C ocaml-xenstored $(patsubst subdir-%-ocaml-xenstored,%,$@);
-
-subdir-clean-ocaml-xenstored:
- set -e; if test -d ocaml-xenstored; then \
- $(MAKE) -C ocaml-xenstored clean; \
- fi
-
diff --git a/tools/xenstore/Makefile b/tools/xenstore/Makefile
index f64ba9f..6ef6ff0 100644
--- a/tools/xenstore/Makefile
+++ b/tools/xenstore/Makefile
@@ -95,11 +95,6 @@ tarball: clean
.PHONY: install
install: all
-ifneq ($(CONFIG_OCAML_XENSTORED),y)
- $(INSTALL_DIR) $(DESTDIR)/var/run/xenstored
- $(INSTALL_DIR) $(DESTDIR)/var/lib/xenstored
- $(INSTALL_PROG) xenstored $(DESTDIR)$(SBINDIR)
-endif
$(INSTALL_DIR) $(DESTDIR)$(BINDIR)
$(INSTALL_DIR) $(DESTDIR)$(SBINDIR)
$(INSTALL_DIR) $(DESTDIR)$(INCLUDEDIR)
[-- 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 09/10] add ocaml tools to build if defined. default to n
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
` (7 preceding siblings ...)
2010-03-09 14:41 ` [PATCH 08/10] remove hook from external ocaml repository Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
2010-03-09 14:41 ` [PATCH 10/10] default ocaml tools config variable to y Vincent Hanquez
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: 177 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
Config.mk | 1 +
tools/Makefile | 2 ++
2 files changed, 3 insertions(+), 0 deletions(-)
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0009-add-ocaml-tools-to-build-if-defined.-default-to-n.patch --]
[-- Type: text/x-patch; name="0009-add-ocaml-tools-to-build-if-defined.-default-to-n.patch", Size: 694 bytes --]
diff --git a/Config.mk b/Config.mk
index 364a714..88ae9ff 100644
--- a/Config.mk
+++ b/Config.mk
@@ -163,6 +163,7 @@ XENSTAT_XENTOP ?= y
VTPM_TOOLS ?= n
LIBXENAPI_BINDINGS ?= n
PYTHON_TOOLS ?= y
+OCAML_TOOLS ?= n
CONFIG_MINITERM ?= n
CONFIG_LOMOUNT ?= n
diff --git a/tools/Makefile b/tools/Makefile
index c34dc86..58058f9 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -40,6 +40,8 @@ SUBDIRS-$(CONFIG_X86) += xenpaging
ifeq ($(XEN_COMPILE_ARCH),$(XEN_TARGET_ARCH))
SUBDIRS-$(PYTHON_TOOLS) += python
SUBDIRS-$(PYTHON_TOOLS) += pygrub
+
+SUBDIRS-$(OCAML_TOOLS) += ocaml
endif
# For the sake of linking, set the sys-root
[-- 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 10/10] default ocaml tools config variable to y
2010-03-09 14:41 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
` (8 preceding siblings ...)
2010-03-09 14:41 ` [PATCH 09/10] add ocaml tools to build if defined. default to n Vincent Hanquez
@ 2010-03-09 14:41 ` Vincent Hanquez
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: 305 bytes --]
fallback mechanism if ocamlopt is not available or if we don't compile
on a linux system (probably need portability fixes for solaris/netbsd/etc).
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
Config.mk | 10 +++++++++-
1 files changed, 9 insertions(+), 1 deletions(-)
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0010-default-ocaml-tools-config-variable-to-y.patch --]
[-- Type: text/x-patch; name="0010-default-ocaml-tools-config-variable-to-y.patch", Size: 540 bytes --]
diff --git a/Config.mk b/Config.mk
index 88ae9ff..a36c920 100644
--- a/Config.mk
+++ b/Config.mk
@@ -163,8 +163,16 @@ XENSTAT_XENTOP ?= y
VTPM_TOOLS ?= n
LIBXENAPI_BINDINGS ?= n
PYTHON_TOOLS ?= y
-OCAML_TOOLS ?= n
+OCAML_TOOLS ?= y
CONFIG_MINITERM ?= n
CONFIG_LOMOUNT ?= n
+ifeq ($(OCAML_TOOLS),y)
+ifeq ($(CONFIG_Linux),y)
+OCAML_TOOLS := $(shell ocamlopt -v > /dev/null 2>&1 && echo "y" || echo "n")
+else
+OCAML_TOOLS := n
+endif
+endif
+
-include $(XEN_ROOT)/.config
[-- 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 07/10] add compilation makefile to ocaml directory
2010-04-23 14:31 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
@ 2010-04-23 14:31 ` Vincent Hanquez
0 siblings, 0 replies; 12+ messages in thread
From: Vincent Hanquez @ 2010-04-23 14:31 UTC (permalink / raw)
To: xen-devel; +Cc: Vincent Hanquez
[-- Attachment #1: Type: text/plain, Size: 446 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/Makefile | 36 +++++++++++++++++
tools/ocaml/Makefile.rules | 93 ++++++++++++++++++++++++++++++++++++++++++++
tools/ocaml/common.make | 28 +++++++++++++
3 files changed, 157 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/Makefile
create mode 100644 tools/ocaml/Makefile.rules
create mode 100644 tools/ocaml/common.make
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0007-add-compilation-makefile-to-ocaml-directory.patch --]
[-- Type: text/x-patch; name="0007-add-compilation-makefile-to-ocaml-directory.patch", Size: 5476 bytes --]
diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile
new file mode 100644
index 0000000..73c2988
--- /dev/null
+++ b/tools/ocaml/Makefile
@@ -0,0 +1,36 @@
+XEN_ROOT = ../..
+include $(XEN_ROOT)/tools/Rules.mk
+
+SUBDIRS_LIBS = \
+ libs/uuid libs/mmap \
+ libs/log libs/xc libs/eventchn \
+ libs/xb libs/xs
+
+SUBDIRS_PROGRAMS = xenstored
+
+SUBDIRS = $(SUBDIRS_LIBS) $(SUBDIRS_PROGRAMS)
+
+.PHONY: all
+all: build
+
+.PHONY: build $(SUBDIRS)
+build: $(SUBDIRS)
+
+$(SUBDIRS):
+ @echo " === building $@"
+ @$(MAKE) --no-print-directory -C $@
+
+.PHONY: install install-libs install-program
+install: install-libs install-program
+
+install-program: $(SUBDIRS_PROGRAMS)
+ $(INSTALL_DIR) $(DESTDIR)$(SBINDIR)
+ $(INSTALL_PROG) xenstored/oxenstored $(DESTDIR)$(SBINDIR)
+
+install-libs: $(SUBDIRS_LIBS)
+
+.PHONY: clean
+clean:
+ @for dir in $(SUBDIRS); do \
+ $(MAKE) --no-print-directory -C $$dir clean; \
+ done
diff --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules
new file mode 100644
index 0000000..ee06b73
--- /dev/null
+++ b/tools/ocaml/Makefile.rules
@@ -0,0 +1,93 @@
+ifdef V
+ ifeq ("$(origin V)", "command line")
+ BUILD_VERBOSE = $(V)
+ endif
+endif
+ifndef BUILD_VERBOSE
+ BUILD_VERBOSE = 0
+endif
+ifeq ($(BUILD_VERBOSE),1)
+ E = @true
+ Q =
+else
+ E = @echo
+ Q = @
+endif
+
+ALL_OCAML_OBJS ?= $(OBJS)
+
+%.cmo: %.ml
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -c -o $@ $<,MLC,$@)
+
+%.cmi: %.mli
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -c -o $@ $<,MLI,$@)
+
+%.cmx: %.ml
+ $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<,MLOPT,$@)
+
+%.ml: %.mll
+ $(call quiet-command, $(OCAMLLEX) -q -o $@ $<,MLLEX,$@)
+
+%.ml: %.mly
+ $(call quiet-command, $(OCAMLYACC) -q $<,MLYACC,$@)
+
+%.o: %.c
+ $(call quiet-command, $(CC) $(CFLAGS) -c -o $@ $<,CC,$@)
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< $o
+
+ALL_OCAML_OBJ_SOURCES=$(addsuffix .ml, $(ALL_OCAML_OBJS))
+
+.ocamldep.make: $(ALL_OCAML_OBJ_SOURCES) Makefile $(TOPLEVEL)/Makefile.rules
+ $(call quiet-command, $(OCAMLDEP) $(ALL_OCAML_OBJ_SOURCES) *.mli $o,MLDEP,)
+
+clean: $(CLEAN_HOOKS)
+ $(Q)rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) $(GENERATED_FILES) .ocamldep.make
+
+quiet-command = $(if $(V),$1,@printf " %-8s %s\n" "$2" "$3" && $1)
+
+mk-caml-lib-native = $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $1 $2 $3,MLA,$1)
+mk-caml-lib-bytecode = $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -a -o $1 $2 $3,MLA,$1)
+
+mk-caml-stubs = $(call quiet-command, $(OCAMLMKLIB) -o `basename $1 .a` $2,MKLIB,$1)
+mk-caml-lib-stubs = \
+ $(call quiet-command, $(AR) rcs $1 $2 && $(OCAMLMKLIB) -o `basename $1 .a | sed -e 's/^lib//'` $2,MKLIB,$1)
+
+# define a library target <name>.cmxa and <name>.cma
+define OCAML_LIBRARY_template
+ $(1).cmxa: lib$(1)_stubs.a $(foreach obj,$($(1)_OBJS),$(obj).cmx)
+ $(call mk-caml-lib-native,$$@, -cclib -l$(1)_stubs, $(foreach obj,$($(1)_OBJS),$(obj).cmx))
+ $(1).cma: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call mk-caml-lib-bytecode,$$@, -dllib dll$(1)_stubs.so -cclib -l$(1)_stubs, $$+)
+ $(1)_stubs.a: $(foreach obj,$$($(1)_C_OBJS),$(obj).o)
+ $(call mk-caml-stubs,$$@, $$+)
+ lib$(1)_stubs.a: $(foreach obj,$($(1)_C_OBJS),$(obj).o)
+ $(call mk-caml-lib-stubs,$$@, $$+)
+endef
+
+define OCAML_NOC_LIBRARY_template
+ $(1).cmxa: $(foreach obj,$($(1)_OBJS),$(obj).cmx)
+ $(call mk-caml-lib-native,$$@, , $(foreach obj,$($(1)_OBJS),$(obj).cmx))
+ $(1).cma: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call mk-caml-lib-bytecode,$$@, , $$+)
+endef
+
+define OCAML_PROGRAM_template
+ $(1): $(foreach obj,$($(1)_OBJS),$(obj).cmx) $($(1)_EXTRA_DEPS)
+ $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -o $$@ $($(1)_LIBS) $$+,MLBIN,$$@)
+ $(1).byte: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -o $$@ $($(1)_BYTE_LIBS) $$+,MLBIN,$$@)
+endef
+
+define C_PROGRAM_template
+ $(1): $(foreach obj,$($(1)_OBJS),$(obj).o)
+ $(call quiet-command, $(CC) $(CFLAGS) -o $$@ $$+,BIN,$$@)
+endef
+
+-include .ocamldep.make
+
+$(foreach lib,$(OCAML_LIBRARY),$(eval $(call OCAML_LIBRARY_template,$(lib))))
+$(foreach lib,$(OCAML_NOC_LIBRARY),$(eval $(call OCAML_NOC_LIBRARY_template,$(lib))))
+$(foreach p,$(OCAML_PROGRAM),$(eval $(call OCAML_PROGRAM_template,$(p))))
+$(foreach p,$(C_PROGRAM),$(eval $(call C_PROGRAM_template,$(p))))
diff --git a/tools/ocaml/common.make b/tools/ocaml/common.make
new file mode 100644
index 0000000..3b14dfb
--- /dev/null
+++ b/tools/ocaml/common.make
@@ -0,0 +1,28 @@
+CC ?= gcc
+OCAMLOPT ?= ocamlopt
+OCAMLC ?= ocamlc
+OCAMLMKLIB ?= ocamlmklib
+OCAMLDEP ?= ocamldep
+OCAMLLEX ?= ocamllex
+OCAMLYACC ?= ocamlyacc
+
+CFLAGS ?= -Wall -fPIC -O2
+
+XEN_ROOT ?= $(TOPLEVEL)/../xen-unstable.hg
+XEN_DIST_ROOT ?= $(XEN_ROOT)/dist/install
+CFLAGS += -I$(XEN_DIST_ROOT)/usr/include
+
+OCAMLOPTFLAG_G := $(shell $(OCAMLOPT) -h 2>&1 | sed -n 's/^ *\(-g\) .*/\1/p')
+OCAMLOPTFLAGS = $(OCAMLOPTFLAG_G) -ccopt "$(LDFLAGS)" -dtypes $(OCAMLINCLUDE) -cc $(CC) -w F -warn-error F
+OCAMLCFLAGS += -g $(OCAMLINCLUDE) -w F -warn-error F
+
+#LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := echo 0.0
+
+OCAMLABI = $(shell $(OCAMLC) -version)
+OCAMLLIBDIR = $(shell $(OCAMLC) -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+o= >$@.new && mv -f $@.new $@
[-- 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
end of thread, other threads:[~2010-04-23 14:31 UTC | newest]
Thread overview: 12+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
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 ` [PATCH 02/10] add ocaml XC bindings Vincent Hanquez
2010-03-09 14:41 ` [PATCH 03/10] add XS ocaml bindings Vincent Hanquez
2010-03-09 14:41 ` [PATCH 04/10] add uuid " Vincent Hanquez
2010-03-09 14:41 ` [PATCH 05/10] add logs " Vincent Hanquez
2010-03-09 14:41 ` [PATCH 06/10] add ocaml xenstored Vincent Hanquez
2010-03-09 14:41 ` [PATCH 07/10] add compilation makefile to ocaml directory Vincent Hanquez
2010-03-09 14:41 ` [PATCH 08/10] remove hook from external ocaml repository Vincent Hanquez
2010-03-09 14:41 ` [PATCH 09/10] add ocaml tools to build if defined. default to n Vincent Hanquez
2010-03-09 14:41 ` [PATCH 10/10] default ocaml tools config variable to y Vincent Hanquez
2010-04-23 14:31 [PATCH 00/10][RFC][v2] merge ocaml xenstored and dependencies Vincent Hanquez
2010-04-23 14:31 ` [PATCH 07/10] add compilation makefile to ocaml directory Vincent Hanquez
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.