# HG changeset patch
# User Jon Ludlam <jonathan.ludlam@xxxxxxxxxxxxx>
# Date 1318261027 -3600
# Node ID cdb34816a40a2dd3aaf324f7dcba83a122cf9146
# Parent 72f339bc600d7a9629d3f9eb8a279fbf8be25b12
tools/ocaml: Rename the ocaml libraries
ocamlfind does not support namespaces, so to avoid
name clashes the module names have become longer.
Additionally, the xenstore and xenbus subdirs, which
contain several modules each, have been packed into
toplevel Xenstore and Xenbus modules.
xb becomes xenbus, xc becomes xenctrl, xl becomes xenlight,
xs becomes xenstore, eventchn becomes xeneventchn and
mmap becomes xenmmap.
[ Patch modified from that submitted, to update the .hgignore, and to
cope with intervening changes to mmap_stubs.c -iwj ]
Signed-off-by: Jon Ludlam <jonathan.ludlam@xxxxxxxxxxxxx>
Acked-by: Ian Campbell <ian.campbell@xxxxxxxxxx>
Signed-off-by: Ian Jackson <ian.jackson@xxxxxxxxxxxxx>
Committed-by: Ian Jackson <ian.jackson@xxxxxxxxxxxxx>
---
diff -r 72f339bc600d -r cdb34816a40a .hgignore
--- a/.hgignore Mon Oct 10 11:21:51 2011 +0100
+++ b/.hgignore Mon Oct 10 16:37:07 2011 +0100
@@ -301,8 +301,8 @@
^tools/ocaml/libs/xl/_libxl_types\.ml\.in$
^tools/ocaml/libs/xl/_libxl_types\.mli\.in$
^tools/ocaml/libs/xl/_libxl_types\.inc$
-^tools/ocaml/libs/xl/xl\.ml$
-^tools/ocaml/libs/xl/xl\.mli$
+^tools/ocaml/libs/xl/xenlight\.ml$
+^tools/ocaml/libs/xl/xenlight\.mli$
^tools/ocaml/xenstored/oxenstored$
^xen/\.banner.*$
^xen/BLOG$
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/eventchn/META.in
--- a/tools/ocaml/libs/eventchn/META.in Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/eventchn/META.in Mon Oct 10 16:37:07 2011 +0100
@@ -1,5 +1,5 @@
version = "@VERSION@"
description = "Eventchn interface extension"
requires = "unix"
-archive(byte) = "eventchn.cma"
-archive(native) = "eventchn.cmxa"
+archive(byte) = "xeneventchn.cma"
+archive(native) = "xeneventchn.cmxa"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/eventchn/Makefile
--- a/tools/ocaml/libs/eventchn/Makefile Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/eventchn/Makefile Mon Oct 10 16:37:07 2011 +0100
@@ -4,11 +4,11 @@
CFLAGS += $(CFLAGS_libxenctrl) $(CFLAGS_xeninclude)
-OBJS = eventchn
+OBJS = xeneventchn
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
-LIBS = eventchn.cma eventchn.cmxa
+LIBS = xeneventchn.cma xeneventchn.cmxa
-LIBS_evtchn = $(LDLIBS_libxenctrl)
+LIBS_xeneventchn = $(LDLIBS_libxenctrl)
all: $(INTF) $(LIBS) $(PROGRAMS)
@@ -16,20 +16,20 @@
libs: $(LIBS)
-eventchn_OBJS = $(OBJS)
-eventchn_C_OBJS = eventchn_stubs
+xeneventchn_OBJS = $(OBJS)
+xeneventchn_C_OBJS = xeneventchn_stubs
-OCAML_LIBRARY = eventchn
+OCAML_LIBRARY = xeneventchn
.PHONY: install
install: $(LIBS) META
mkdir -p $(OCAMLDESTDIR)
- ocamlfind remove -destdir $(OCAMLDESTDIR) eventchn
- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore eventchn META
$(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xeneventchn
+ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xeneventchn
META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
- ocamlfind remove -destdir $(OCAMLDESTDIR) eventchn
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xeneventchn
include $(TOPLEVEL)/Makefile.rules
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/eventchn/eventchn.ml
--- a/tools/ocaml/libs/eventchn/eventchn.ml Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,30 +0,0 @@
-(*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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
-
-type handle
-
-external init: unit -> handle = "stub_eventchn_init"
-external fd: handle -> Unix.file_descr = "stub_eventchn_fd"
-external notify: handle -> int -> unit = "stub_eventchn_notify"
-external bind_interdomain: handle -> int -> int -> int =
"stub_eventchn_bind_interdomain"
-external bind_dom_exc_virq: handle -> int = "stub_eventchn_bind_dom_exc_virq"
-external unbind: handle -> int -> unit = "stub_eventchn_unbind"
-external pending: handle -> int = "stub_eventchn_pending"
-external unmask: handle -> int -> unit = "stub_eventchn_unmask"
-
-let _ = Callback.register_exception "eventchn.error" (Error
"register_callback")
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/eventchn/eventchn.mli
--- a/tools/ocaml/libs/eventchn/eventchn.mli Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,31 +0,0 @@
-(*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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
-
-type handle
-
-external init : unit -> handle = "stub_eventchn_init"
-external fd: handle -> Unix.file_descr = "stub_eventchn_fd"
-
-external notify : handle -> int -> unit = "stub_eventchn_notify"
-external bind_interdomain : handle -> int -> int -> int
- = "stub_eventchn_bind_interdomain"
-external bind_dom_exc_virq : handle -> int = "stub_eventchn_bind_dom_exc_virq"
-external unbind : handle -> int -> unit = "stub_eventchn_unbind"
-external pending : handle -> int = "stub_eventchn_pending"
-external unmask : handle -> int -> unit
- = "stub_eventchn_unmask"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/eventchn/eventchn_stubs.c
--- a/tools/ocaml/libs/eventchn/eventchn_stubs.c Mon Oct 10 11:21:51
2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,143 +0,0 @@
-/*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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>
-#include <xen/sysctl.h>
-#include <xen/xen.h>
-#include <xen/sys/evtchn.h>
-#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 _H(__h) ((xc_interface *)(__h))
-
-CAMLprim value stub_eventchn_init(void)
-{
- CAMLparam0();
- CAMLlocal1(result);
-
- xc_interface *xce = xc_evtchn_open(NULL, XC_OPENFLAG_NON_REENTRANT);
- if (xce == NULL)
- caml_failwith("open failed");
-
- result = (value)xce;
- CAMLreturn(result);
-}
-
-CAMLprim value stub_eventchn_fd(value xce)
-{
- CAMLparam1(xce);
- CAMLlocal1(result);
- int fd;
-
- fd = xc_evtchn_fd(_H(xce));
- if (fd == -1)
- caml_failwith("evtchn fd failed");
-
- result = Val_int(fd);
-
- CAMLreturn(result);
-}
-
-CAMLprim value stub_eventchn_notify(value xce, value port)
-{
- CAMLparam2(xce, port);
- int rc;
-
- rc = xc_evtchn_notify(_H(xce), Int_val(port));
- if (rc == -1)
- caml_failwith("evtchn notify failed");
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_eventchn_bind_interdomain(value xce, value domid,
- value remote_port)
-{
- CAMLparam3(xce, domid, remote_port);
- CAMLlocal1(port);
- evtchn_port_or_error_t rc;
-
- rc = xc_evtchn_bind_interdomain(_H(xce), Int_val(domid),
Int_val(remote_port));
- if (rc == -1)
- caml_failwith("evtchn bind_interdomain failed");
- port = Val_int(rc);
-
- CAMLreturn(port);
-}
-
-CAMLprim value stub_eventchn_bind_dom_exc_virq(value xce)
-{
- CAMLparam1(xce);
- CAMLlocal1(port);
- evtchn_port_or_error_t rc;
-
- rc = xc_evtchn_bind_virq(_H(xce), VIRQ_DOM_EXC);
- if (rc == -1)
- caml_failwith("evtchn bind_dom_exc_virq failed");
- port = Val_int(rc);
-
- CAMLreturn(port);
-}
-
-CAMLprim value stub_eventchn_unbind(value xce, value port)
-{
- CAMLparam2(xce, port);
- int rc;
-
- rc = xc_evtchn_unbind(_H(xce), Int_val(port));
- if (rc == -1)
- caml_failwith("evtchn unbind failed");
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_eventchn_pending(value xce)
-{
- CAMLparam1(xce);
- CAMLlocal1(result);
- evtchn_port_or_error_t port;
-
- port = xc_evtchn_pending(_H(xce));
- if (port == -1)
- caml_failwith("evtchn pending failed");
- result = Val_int(port);
-
- CAMLreturn(result);
-}
-
-CAMLprim value stub_eventchn_unmask(value xce, value _port)
-{
- CAMLparam2(xce, _port);
- evtchn_port_t port;
-
- port = Int_val(_port);
- if (xc_evtchn_unmask(_H(xce), port))
- caml_failwith("evtchn unmask failed");
- CAMLreturn(Val_unit);
-}
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/eventchn/xeneventchn.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/eventchn/xeneventchn.ml Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,30 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
+
+type handle
+
+external init: unit -> handle = "stub_eventchn_init"
+external fd: handle -> Unix.file_descr = "stub_eventchn_fd"
+external notify: handle -> int -> unit = "stub_eventchn_notify"
+external bind_interdomain: handle -> int -> int -> int =
"stub_eventchn_bind_interdomain"
+external bind_dom_exc_virq: handle -> int = "stub_eventchn_bind_dom_exc_virq"
+external unbind: handle -> int -> unit = "stub_eventchn_unbind"
+external pending: handle -> int = "stub_eventchn_pending"
+external unmask: handle -> int -> unit = "stub_eventchn_unmask"
+
+let _ = Callback.register_exception "eventchn.error" (Error
"register_callback")
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/eventchn/xeneventchn.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/eventchn/xeneventchn.mli Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,31 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
+
+type handle
+
+external init : unit -> handle = "stub_eventchn_init"
+external fd: handle -> Unix.file_descr = "stub_eventchn_fd"
+
+external notify : handle -> int -> unit = "stub_eventchn_notify"
+external bind_interdomain : handle -> int -> int -> int
+ = "stub_eventchn_bind_interdomain"
+external bind_dom_exc_virq : handle -> int = "stub_eventchn_bind_dom_exc_virq"
+external unbind : handle -> int -> unit = "stub_eventchn_unbind"
+external pending : handle -> int = "stub_eventchn_pending"
+external unmask : handle -> int -> unit
+ = "stub_eventchn_unmask"
diff -r 72f339bc600d -r cdb34816a40a
tools/ocaml/libs/eventchn/xeneventchn_stubs.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c Mon Oct 10 16:37:07
2011 +0100
@@ -0,0 +1,143 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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>
+#include <xen/sysctl.h>
+#include <xen/xen.h>
+#include <xen/sys/evtchn.h>
+#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 _H(__h) ((xc_interface *)(__h))
+
+CAMLprim value stub_eventchn_init(void)
+{
+ CAMLparam0();
+ CAMLlocal1(result);
+
+ xc_interface *xce = xc_evtchn_open(NULL, XC_OPENFLAG_NON_REENTRANT);
+ if (xce == NULL)
+ caml_failwith("open failed");
+
+ result = (value)xce;
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_eventchn_fd(value xce)
+{
+ CAMLparam1(xce);
+ CAMLlocal1(result);
+ int fd;
+
+ fd = xc_evtchn_fd(_H(xce));
+ if (fd == -1)
+ caml_failwith("evtchn fd failed");
+
+ result = Val_int(fd);
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_eventchn_notify(value xce, value port)
+{
+ CAMLparam2(xce, port);
+ int rc;
+
+ rc = xc_evtchn_notify(_H(xce), Int_val(port));
+ if (rc == -1)
+ caml_failwith("evtchn notify failed");
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_eventchn_bind_interdomain(value xce, value domid,
+ value remote_port)
+{
+ CAMLparam3(xce, domid, remote_port);
+ CAMLlocal1(port);
+ evtchn_port_or_error_t rc;
+
+ rc = xc_evtchn_bind_interdomain(_H(xce), Int_val(domid),
Int_val(remote_port));
+ if (rc == -1)
+ caml_failwith("evtchn bind_interdomain failed");
+ port = Val_int(rc);
+
+ CAMLreturn(port);
+}
+
+CAMLprim value stub_eventchn_bind_dom_exc_virq(value xce)
+{
+ CAMLparam1(xce);
+ CAMLlocal1(port);
+ evtchn_port_or_error_t rc;
+
+ rc = xc_evtchn_bind_virq(_H(xce), VIRQ_DOM_EXC);
+ if (rc == -1)
+ caml_failwith("evtchn bind_dom_exc_virq failed");
+ port = Val_int(rc);
+
+ CAMLreturn(port);
+}
+
+CAMLprim value stub_eventchn_unbind(value xce, value port)
+{
+ CAMLparam2(xce, port);
+ int rc;
+
+ rc = xc_evtchn_unbind(_H(xce), Int_val(port));
+ if (rc == -1)
+ caml_failwith("evtchn unbind failed");
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_eventchn_pending(value xce)
+{
+ CAMLparam1(xce);
+ CAMLlocal1(result);
+ evtchn_port_or_error_t port;
+
+ port = xc_evtchn_pending(_H(xce));
+ if (port == -1)
+ caml_failwith("evtchn pending failed");
+ result = Val_int(port);
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_eventchn_unmask(value xce, value _port)
+{
+ CAMLparam2(xce, _port);
+ evtchn_port_t port;
+
+ port = Int_val(_port);
+ if (xc_evtchn_unmask(_H(xce), port))
+ caml_failwith("evtchn unmask failed");
+ CAMLreturn(Val_unit);
+}
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/mmap/META.in
--- a/tools/ocaml/libs/mmap/META.in Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/mmap/META.in Mon Oct 10 16:37:07 2011 +0100
@@ -1,4 +1,4 @@
version = "@VERSION@"
description = "Mmap interface extension"
-archive(byte) = "mmap.cma"
-archive(native) = "mmap.cmxa"
+archive(byte) = "xenmmap.cma"
+archive(native) = "xenmmap.cmxa"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/mmap/Makefile
--- a/tools/ocaml/libs/mmap/Makefile Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/mmap/Makefile Mon Oct 10 16:37:07 2011 +0100
@@ -2,9 +2,9 @@
XEN_ROOT=$(TOPLEVEL)/../..
include $(TOPLEVEL)/common.make
-OBJS = mmap
+OBJS = xenmmap
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
-LIBS = mmap.cma mmap.cmxa
+LIBS = xenmmap.cma xenmmap.cmxa
all: $(INTF) $(LIBS) $(PROGRAMS)
@@ -12,19 +12,19 @@
libs: $(LIBS)
-mmap_OBJS = $(OBJS)
-mmap_C_OBJS = mmap_stubs
-OCAML_LIBRARY = mmap
+xenmmap_OBJS = $(OBJS)
+xenmmap_C_OBJS = xenmmap_stubs
+OCAML_LIBRARY = xenmmap
.PHONY: install
install: $(LIBS) META
mkdir -p $(OCAMLDESTDIR)
- ocamlfind remove -destdir $(OCAMLDESTDIR) mmap
- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore mmap META
$(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenmmap
+ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenmmap META
$(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
- ocamlfind remove -destdir $(OCAMLDESTDIR) mmap
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenmmap
include $(TOPLEVEL)/Makefile.rules
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/mmap/mmap.ml
--- a/tools/ocaml/libs/mmap/mmap.ml Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,31 +0,0 @@
-(*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/mmap/mmap.mli
--- a/tools/ocaml/libs/mmap/mmap.mli Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-(*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/mmap/mmap_stubs.c
--- a/tools/ocaml/libs/mmap/mmap_stubs.c Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,130 +0,0 @@
-/*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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 Intf_val(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(Intf_val(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 intf)
-{
- CAMLparam1(intf);
-
- if (Intf_val(intf)->addr != MAP_FAILED)
- munmap(Intf_val(intf)->addr, Intf_val(intf)->len);
- Intf_val(intf)->addr = MAP_FAILED;
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_mmap_read(value intf, value start, value len)
-{
- CAMLparam3(intf, start, len);
- CAMLlocal1(data);
- int c_start;
- int c_len;
-
- c_start = Int_val(start);
- c_len = Int_val(len);
-
- if (c_start > Intf_val(intf)->len)
- caml_invalid_argument("start invalid");
- if (c_start + c_len > Intf_val(intf)->len)
- caml_invalid_argument("len invalid");
-
- data = caml_alloc_string(c_len);
- memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len);
-
- CAMLreturn(data);
-}
-
-CAMLprim value stub_mmap_write(value intf, value data,
- value start, value len)
-{
- CAMLparam4(intf, data, start, len);
- int c_start;
- int c_len;
-
- c_start = Int_val(start);
- c_len = Int_val(len);
-
- if (c_start > Intf_val(intf)->len)
- caml_invalid_argument("start invalid");
- if (c_start + c_len > Intf_val(intf)->len)
- caml_invalid_argument("len invalid");
-
- memcpy(Intf_val(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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/mmap/xenmmap.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/mmap/xenmmap.ml Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,31 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/mmap/xenmmap.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/mmap/xenmmap.mli Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,28 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/mmap/xenmmap_stubs.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,130 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 Intf_val(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(Intf_val(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 intf)
+{
+ CAMLparam1(intf);
+
+ if (Intf_val(intf)->addr != MAP_FAILED)
+ munmap(Intf_val(intf)->addr, Intf_val(intf)->len);
+ Intf_val(intf)->addr = MAP_FAILED;
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_mmap_read(value intf, value start, value len)
+{
+ CAMLparam3(intf, start, len);
+ CAMLlocal1(data);
+ int c_start;
+ int c_len;
+
+ c_start = Int_val(start);
+ c_len = Int_val(len);
+
+ if (c_start > Intf_val(intf)->len)
+ caml_invalid_argument("start invalid");
+ if (c_start + c_len > Intf_val(intf)->len)
+ caml_invalid_argument("len invalid");
+
+ data = caml_alloc_string(c_len);
+ memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len);
+
+ CAMLreturn(data);
+}
+
+CAMLprim value stub_mmap_write(value intf, value data,
+ value start, value len)
+{
+ CAMLparam4(intf, data, start, len);
+ int c_start;
+ int c_len;
+
+ c_start = Int_val(start);
+ c_len = Int_val(len);
+
+ if (c_start > Intf_val(intf)->len)
+ caml_invalid_argument("start invalid");
+ if (c_start + c_len > Intf_val(intf)->len)
+ caml_invalid_argument("len invalid");
+
+ memcpy(Intf_val(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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xb/META.in
--- a/tools/ocaml/libs/xb/META.in Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xb/META.in Mon Oct 10 16:37:07 2011 +0100
@@ -1,5 +1,5 @@
version = "@VERSION@"
description = "XenBus Interface"
-requires = "unix,mmap"
-archive(byte) = "xb.cma"
-archive(native) = "xb.cmxa"
+requires = "unix,xenmmap"
+archive(byte) = "xenbus.cma"
+archive(native) = "xenbus.cmxa"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xb/Makefile
--- a/tools/ocaml/libs/xb/Makefile Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xb/Makefile Mon Oct 10 16:37:07 2011 +0100
@@ -6,6 +6,7 @@
CFLAGS += $(CFLAGS_libxenctrl) # For xen_mb()
CFLAGS += $(CFLAGS_xeninclude)
OCAMLINCLUDE += -I ../mmap
+OCAMLOPTFLAGS += -for-pack Xenbus
.NOTPARALLEL:
# Ocaml is such a PITA!
@@ -15,7 +16,7 @@
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
+LIBS = xenbus.cma xenbus.cmxa
ALL_OCAML_OBJS = $(OBJS) $(PREOJBS)
@@ -25,22 +26,30 @@
libs: $(LIBS)
-xb_OBJS = $(OBJS)
-xb_C_OBJS = xs_ring_stubs xb_stubs
-OCAML_LIBRARY = xb
+xenbus_OBJS = xenbus
+xenbus_C_OBJS = xs_ring_stubs xenbus_stubs
+OCAML_LIBRARY = xenbus
+
+xenbus.cmx : $(foreach obj, $(OBJS), $(obj).cmx)
+ $(E) " CMX $@"
+ $(OCAMLOPT) -pack -o $@ $^
+
+xenbus.cmo : $(foreach obj, $(OBJS), $(obj).cmo)
+ $(E) " CMO $@"
+ $(OCAMLC) -pack -o $@ $^
%.mli: %.ml
$(E) " MLI $@"
- $(Q)$(OCAMLC) -i $< $o
+ $(Q)$(OCAMLC) $(OCAMLINCLUDE) -i $< $o
.PHONY: install
install: $(LIBS) META
mkdir -p $(OCAMLDESTDIR)
- ocamlfind remove -destdir $(OCAMLDESTDIR) xb
- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xb META
$(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenbus
+ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenbus META
$(LIBS) xenbus.cmo xenbus.cmi xenbus.cmx *.a *.so
.PHONY: uninstall
uninstall:
- ocamlfind remove -destdir $(OCAMLDESTDIR) xb
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenbus
include $(TOPLEVEL)/Makefile.rules
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xb/xb.ml
--- a/tools/ocaml/libs/xb/xb.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xb/xb.ml Mon Oct 10 16:37:07 2011 +0100
@@ -24,7 +24,7 @@
type backend_mmap =
{
- mmap: Mmap.mmap_interface; (* mmaped interface = xs_ring *)
+ mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *)
eventchn_notify: unit -> unit; (* function to notify through eventchn *)
mutable work_again: bool;
}
@@ -34,7 +34,7 @@
fd: Unix.file_descr;
}
-type backend = Fd of backend_fd | Mmap of backend_mmap
+type backend = Fd of backend_fd | Xenmmap of backend_mmap
type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string
@@ -68,7 +68,7 @@
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
+ | Xenmmap backmmap -> read_mmap backmmap con s len
let write_fd back con s len =
Unix.write back.fd s 0 len
@@ -82,7 +82,7 @@
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
+ | Xenmmap backmmap -> write_mmap backmmap con s len
let output con =
(* get the output string from a string_of(packet) or partial_out *)
@@ -145,7 +145,7 @@
let open_fd fd = newcon (Fd { fd = fd; })
let open_mmap mmap notifyfct =
- newcon (Mmap {
+ newcon (Xenmmap {
mmap = mmap;
eventchn_notify = notifyfct;
work_again = false; })
@@ -153,12 +153,12 @@
let close con =
match con.backend with
| Fd backend -> Unix.close backend.fd
- | Mmap backend -> Mmap.unmap backend.mmap
+ | Xenmmap backend -> Xenmmap.unmap backend.mmap
let is_fd con =
match con.backend with
| Fd _ -> true
- | Mmap _ -> false
+ | Xenmmap _ -> false
let is_mmap con = not (is_fd con)
@@ -176,14 +176,14 @@
let has_more_input con =
match con.backend with
| Fd _ -> false
- | Mmap backend -> backend.work_again
+ | Xenmmap backend -> backend.work_again
let is_selectable con =
match con.backend with
| Fd _ -> true
- | Mmap _ -> false
+ | Xenmmap _ -> false
let get_fd con =
match con.backend with
| Fd backend -> backend.fd
- | Mmap _ -> raise (Failure "get_fd")
+ | Xenmmap _ -> raise (Failure "get_fd")
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xb/xb.mli
--- a/tools/ocaml/libs/xb/xb.mli Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xb/xb.mli Mon Oct 10 16:37:07 2011 +0100
@@ -1,83 +1,103 @@
-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
-
+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 operation_c_mapping : operation array
+ val size : int
+ val offset_pq : int
+ val operation_c_mapping_pq : 'a array
+ val size_pq : int
+ val array_search : 'a -> 'a array -> int
+ val of_cval : int -> operation
+ val to_cval : operation -> int
+ val to_string : operation -> string
+ end
+module Packet :
+ sig
+ type t =
+ Packet.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"
+ val create : int -> int -> Op.operation -> string -> t
+ val of_partialpkt : Partial.pkt -> t
+ val to_string : t -> string
+ 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 *)
+type backend_mmap = {
+ mmap : Xenmmap.mmap_interface;
+ eventchn_notify : unit -> unit;
+ mutable work_again : bool;
+}
+type backend_fd = { fd : Unix.file_descr; }
+type backend = Fd of backend_fd | Xenmmap 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;
+}
+val init_partial_in : unit -> partial_buf
val queue : t -> Packet.t -> unit
-
-(** process the output queue, return if a packet has been totally sent *)
+val read_fd : backend_fd -> 'a -> string -> int -> int
+val read_mmap : backend_mmap -> 'a -> string -> int -> int
+val read : t -> string -> int -> int
+val write_fd : backend_fd -> 'a -> string -> int -> int
+val write_mmap : backend_mmap -> 'a -> string -> int -> int
+val write : t -> string -> int -> int
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 newcon : backend -> t
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 open_mmap : Xenmmap.mmap_interface -> (unit -> unit) -> t
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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xb/xb_stubs.c
--- a/tools/ocaml/libs/xb/xb_stubs.c Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,71 +0,0 @@
-/*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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>
-
-#include <xenctrl.h>
-#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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xb/xenbus_stubs.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xb/xenbus_stubs.c Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,71 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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>
+
+#include <xenctrl.h>
+#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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xb/xs_ring.ml
--- a/tools/ocaml/libs/xb/xs_ring.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xb/xs_ring.ml Mon Oct 10 16:37:07 2011 +0100
@@ -14,5 +14,5 @@
* 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"
+external read: Xenmmap.mmap_interface -> string -> int -> int =
"ml_interface_read"
+external write: Xenmmap.mmap_interface -> string -> int -> int =
"ml_interface_write"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xc/META.in
--- a/tools/ocaml/libs/xc/META.in Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xc/META.in Mon Oct 10 16:37:07 2011 +0100
@@ -1,5 +1,5 @@
version = "@VERSION@"
description = "Xen Control Interface"
-requires = "mmap,uuid"
-archive(byte) = "xc.cma"
-archive(native) = "xc.cmxa"
+requires = "xenmmap,uuid"
+archive(byte) = "xenctrl.cma"
+archive(native) = "xenctrl.cmxa"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xc/Makefile
--- a/tools/ocaml/libs/xc/Makefile Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xc/Makefile Mon Oct 10 16:37:07 2011 +0100
@@ -5,16 +5,16 @@
CFLAGS += -I../mmap $(CFLAGS_libxenctrl) $(CFLAGS_libxenguest)
OCAMLINCLUDE += -I ../mmap -I ../uuid
-OBJS = xc
-INTF = xc.cmi
-LIBS = xc.cma xc.cmxa
+OBJS = xenctrl
+INTF = xenctrl.cmi
+LIBS = xenctrl.cma xenctrl.cmxa
-LIBS_xc = $(LDLIBS_libxenctrl) $(LDLIBS_libxenguest)
+LIBS_xenctrl = $(LDLIBS_libxenctrl) $(LDLIBS_libxenguest)
-xc_OBJS = $(OBJS)
-xc_C_OBJS = xc_stubs
+xenctrl_OBJS = $(OBJS)
+xenctrl_C_OBJS = xenctrl_stubs
-OCAML_LIBRARY = xc
+OCAML_LIBRARY = xenctrl
all: $(INTF) $(LIBS)
@@ -23,11 +23,11 @@
.PHONY: install
install: $(LIBS) META
mkdir -p $(OCAMLDESTDIR)
- ocamlfind remove -destdir $(OCAMLDESTDIR) xc
- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xc META
$(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenctrl
+ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenctrl META
$(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
- ocamlfind remove -destdir $(OCAMLDESTDIR) xc
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenctrl
include $(TOPLEVEL)/Makefile.rules
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xc/xc.ml
--- a/tools/ocaml/libs/xc/xc.ml Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,326 +0,0 @@
-(*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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 is_fake: unit -> bool = "stub_xc_interface_is_fake"
-
-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_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 -> bool array -> unit
- = "stub_xc_vcpu_setaffinity"
-external vcpu_affinity_get: handle -> domid -> int -> bool array
- = "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 -> (int64 * (int64 option))
- -> string option array
- -> string option array
- = "stub_xc_domain_cpuid_set"
-external domain_cpuid_apply_policy: handle -> domid -> unit
- = "stub_xc_domain_cpuid_apply_policy"
-external cpuid_check: handle -> (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 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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xc/xc.mli
--- a/tools/ocaml/libs/xc/xc.mli Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,184 +0,0 @@
-(*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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 is_fake : unit -> bool = "stub_xc_interface_is_fake"
-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_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 -> bool array -> unit
- = "stub_xc_vcpu_setaffinity"
-external vcpu_affinity_get : handle -> domid -> int -> bool array
- = "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 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 -> (int64 * (int64 option))
- -> string option array
- -> string option array
- = "stub_xc_domain_cpuid_set"
-external domain_cpuid_apply_policy: handle -> domid -> unit
- = "stub_xc_domain_cpuid_apply_policy"
-external cpuid_check: handle -> (int64 * (int64 option)) -> string option
array -> (bool * string option array)
- = "stub_xc_cpuid_check"
-
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xc/xc_stubs.c
--- a/tools/ocaml/libs/xc/xc_stubs.c Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1161 +0,0 @@
-/*
- * Copyright (C) 2006-2007 XenSource Ltd.
- * Copyright (C) 2008 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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>
-#include <errno.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 <xenctrl.h>
-
-#include "mmap_stubs.h"
-
-#define PAGE_SHIFT 12
-#define PAGE_SIZE (1UL << PAGE_SHIFT)
-#define PAGE_MASK (~(PAGE_SIZE-1))
-
-#define _H(__h) ((xc_interface *)(__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)));
-
-#define ERROR_STRLEN 1024
-void failwith_xc(xc_interface *xch)
-{
- static char error_str[ERROR_STRLEN];
- if (xch) {
- const xc_error *error = xc_get_last_error(xch);
- if (error->code == XC_ERROR_NONE)
- snprintf(error_str, ERROR_STRLEN, "%d: %s", errno,
strerror(errno));
- else
- snprintf(error_str, ERROR_STRLEN, "%d: %s: %s",
- error->code,
- xc_error_code_to_desc(error->code),
- error->message);
- } else {
- snprintf(error_str, ERROR_STRLEN, "Unable to open XC
interface");
- }
- caml_raise_with_string(*caml_named_value("xc.error"), error_str);
-}
-
-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(void)
-{
- CAMLparam0();
- xc_interface *xch;
- xch = xc_interface_open(NULL, NULL, XC_OPENFLAG_NON_REENTRANT);
- if (xch == NULL)
- failwith_xc(NULL);
- CAMLreturn((value)xch);
-}
-
-
-CAMLprim value stub_xc_interface_is_fake(void)
-{
- CAMLparam0();
- int is_fake = xc_interface_is_fake();
- CAMLreturn(Val_int(is_fake));
-}
-
-CAMLprim value stub_xc_interface_close(value xch)
-{
- CAMLparam1(xch);
-
- // caml_enter_blocking_section();
- xc_interface_close(_H(xch));
- // 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 xch, value ssidref,
- value flags, value handle)
-{
- CAMLparam4(xch, ssidref, flags, handle);
-
- uint32_t domid = 0;
- xen_domain_handle_t h = { 0 };
- int result;
- int i;
- 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(_H(xch), c_ssidref, h, c_flags, &domid);
- // caml_leave_blocking_section();
-
- if (result < 0)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_int(domid));
-}
-
-CAMLprim value stub_xc_domain_max_vcpus(value xch, value domid,
- value max_vcpus)
-{
- CAMLparam3(xch, domid, max_vcpus);
- int r;
-
- r = xc_domain_max_vcpus(_H(xch), _D(domid), Int_val(max_vcpus));
- if (r)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_unit);
-}
-
-
-value stub_xc_domain_sethandle(value xch, value domid, value handle)
-{
- CAMLparam3(xch, 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(xch), _D(domid), h);
- if (i)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_unit);
-}
-
-static value dom_op(value xch, value domid, int (*fn)(xc_interface *,
uint32_t))
-{
- CAMLparam2(xch, domid);
-
- uint32_t c_domid = _D(domid);
-
- // caml_enter_blocking_section();
- int result = fn(_H(xch), c_domid);
- // caml_leave_blocking_section();
- if (result)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_pause(value xch, value domid)
-{
- return dom_op(xch, domid, xc_domain_pause);
-}
-
-
-CAMLprim value stub_xc_domain_unpause(value xch, value domid)
-{
- return dom_op(xch, domid, xc_domain_unpause);
-}
-
-CAMLprim value stub_xc_domain_destroy(value xch, value domid)
-{
- return dom_op(xch, domid, xc_domain_destroy);
-}
-
-CAMLprim value stub_xc_domain_resume_fast(value xch, value domid)
-{
- CAMLparam2(xch, domid);
-
- uint32_t c_domid = _D(domid);
-
- // caml_enter_blocking_section();
- int result = xc_domain_resume(_H(xch), c_domid, 1);
- // caml_leave_blocking_section();
- if (result)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_shutdown(value xch, value domid, value reason)
-{
- CAMLparam3(xch, domid, reason);
- int ret;
-
- ret = xc_domain_shutdown(_H(xch), _D(domid), Int_val(reason));
- if (ret < 0)
- failwith_xc(_H(xch));
-
- 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 xch, value first_domain, value
nb)
-{
- CAMLparam3(xch, first_domain, nb);
- CAMLlocal2(result, temp);
- xc_domaininfo_t * info;
- int i, ret, toalloc, retval;
- unsigned int c_max_domains;
- uint32_t c_first_domain;
-
- /* 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;
-
- c_first_domain = _D(first_domain);
- c_max_domains = Int_val(nb);
- // caml_enter_blocking_section();
- retval = xc_domain_getinfolist(_H(xch), c_first_domain,
- c_max_domains, info);
- // caml_leave_blocking_section();
-
- if (retval < 0) {
- free(info);
- failwith_xc(_H(xch));
- }
- 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 xch, value domid)
-{
- CAMLparam2(xch, domid);
- CAMLlocal1(result);
- xc_domaininfo_t info;
- int ret;
-
- ret = xc_domain_getinfolist(_H(xch), _D(domid), 1, &info);
- if (ret != 1)
- failwith_xc(_H(xch));
- if (info.domain != _D(domid))
- failwith_xc(_H(xch));
-
- result = alloc_domaininfo(&info);
- CAMLreturn(result);
-}
-
-CAMLprim value stub_xc_vcpu_getinfo(value xch, value domid, value vcpu)
-{
- CAMLparam3(xch, domid, vcpu);
- CAMLlocal1(result);
- xc_vcpuinfo_t info;
- int retval;
-
- uint32_t c_domid = _D(domid);
- uint32_t c_vcpu = Int_val(vcpu);
- // caml_enter_blocking_section();
- retval = xc_vcpu_getinfo(_H(xch), c_domid,
- c_vcpu, &info);
- // caml_leave_blocking_section();
- if (retval < 0)
- failwith_xc(_H(xch));
-
- 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 xch, value domid,
- value cpu)
-{
- CAMLparam3(xch, domid, cpu);
- CAMLlocal1(context);
- int ret;
- vcpu_guest_context_any_t ctxt;
-
- ret = xc_vcpu_getcontext(_H(xch), _D(domid), Int_val(cpu), &ctxt);
-
- context = caml_alloc_string(sizeof(ctxt));
- memcpy(String_val(context), (char *) &ctxt.c, sizeof(ctxt.c));
-
- CAMLreturn(context);
-}
-
-static int get_cpumap_len(value xch, value cpumap)
-{
- int ml_len = Wosize_val(cpumap);
- int xc_len = xc_get_max_cpus(_H(xch));
-
- if (ml_len < xc_len)
- return ml_len;
- else
- return xc_len;
-}
-
-CAMLprim value stub_xc_vcpu_setaffinity(value xch, value domid,
- value vcpu, value cpumap)
-{
- CAMLparam4(xch, domid, vcpu, cpumap);
- int i, len = get_cpumap_len(xch, cpumap);
- xc_cpumap_t c_cpumap;
- int retval;
-
- c_cpumap = xc_cpumap_alloc(_H(xch));
- if (c_cpumap == NULL)
- failwith_xc(_H(xch));
-
- for (i=0; i<len; i++) {
- if (Bool_val(Field(cpumap, i)))
- c_cpumap[i/8] |= i << (i&7);
- }
- retval = xc_vcpu_setaffinity(_H(xch), _D(domid),
- Int_val(vcpu), c_cpumap);
- free(c_cpumap);
-
- if (retval < 0)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_vcpu_getaffinity(value xch, value domid,
- value vcpu)
-{
- CAMLparam3(xch, domid, vcpu);
- CAMLlocal1(ret);
- xc_cpumap_t c_cpumap;
- int i, len = xc_get_max_cpus(_H(xch));
- int retval;
-
- c_cpumap = xc_cpumap_alloc(_H(xch));
- if (c_cpumap == NULL)
- failwith_xc(_H(xch));
-
- retval = xc_vcpu_getaffinity(_H(xch), _D(domid),
- Int_val(vcpu), c_cpumap);
- free(c_cpumap);
-
- if (retval < 0) {
- free(c_cpumap);
- failwith_xc(_H(xch));
- }
-
- ret = caml_alloc(len, 0);
-
- for (i=0; i<len; i++) {
- if (c_cpumap[i%8] & 1 << (i&7))
- Store_field(ret, i, Val_true);
- else
- Store_field(ret, i, Val_false);
- }
-
- free(c_cpumap);
-
- CAMLreturn(ret);
-}
-
-CAMLprim value stub_xc_sched_id(value xch)
-{
- CAMLparam1(xch);
- int sched_id;
-
- if (xc_sched_id(_H(xch), &sched_id))
- failwith_xc(_H(xch));
- CAMLreturn(Val_int(sched_id));
-}
-
-CAMLprim value stub_xc_evtchn_alloc_unbound(value xch,
- value local_domid,
- value remote_domid)
-{
- CAMLparam3(xch, local_domid, remote_domid);
-
- 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(_H(xch), c_local_domid,
- c_remote_domid);
- // caml_leave_blocking_section();
-
- if (result < 0)
- failwith_xc(_H(xch));
- CAMLreturn(Val_int(result));
-}
-
-CAMLprim value stub_xc_evtchn_reset(value xch, value domid)
-{
- CAMLparam2(xch, domid);
- int r;
-
- r = xc_evtchn_reset(_H(xch), _D(domid));
- if (r < 0)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-
-#define RING_SIZE 32768
-static char ring[RING_SIZE];
-
-CAMLprim value stub_xc_readconsolering(value xch)
-{
- unsigned int size = RING_SIZE;
- char *ring_ptr = ring;
-
- CAMLparam1(xch);
-
- // caml_enter_blocking_section();
- int retval = xc_readconsolering(_H(xch), ring_ptr, &size, 0, 0, NULL);
- // caml_leave_blocking_section();
-
- if (retval)
- failwith_xc(_H(xch));
- ring[size] = '\0';
- CAMLreturn(caml_copy_string(ring));
-}
-
-CAMLprim value stub_xc_send_debug_keys(value xch, value keys)
-{
- CAMLparam2(xch, keys);
- int r;
-
- r = xc_send_debug_keys(_H(xch), String_val(keys));
- if (r)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_physinfo(value xch)
-{
- CAMLparam1(xch);
- CAMLlocal3(physinfo, cap_list, tmp);
- xc_physinfo_t c_physinfo;
- int r;
-
- // caml_enter_blocking_section();
- r = xc_physinfo(_H(xch), &c_physinfo);
- // caml_leave_blocking_section();
-
- if (r)
- failwith_xc(_H(xch));
-
- 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 xch, value nr_cpus)
-{
- CAMLparam2(xch, nr_cpus);
- CAMLlocal2(pcpus, v);
- xc_cpuinfo_t *info;
- int r, size;
-
- if (Int_val(nr_cpus) < 1)
- caml_invalid_argument("nr_cpus");
-
- info = calloc(Int_val(nr_cpus) + 1, sizeof(*info));
- if (!info)
- caml_raise_out_of_memory();
-
- // caml_enter_blocking_section();
- r = xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size);
- // caml_leave_blocking_section();
-
- if (r) {
- free(info);
- failwith_xc(_H(xch));
- }
-
- if (size > 0) {
- int i;
- pcpus = caml_alloc(size, 0);
- for (i = 0; i < size; i++) {
- v = caml_copy_int64(info[i].idletime);
- caml_modify(&Field(pcpus, i), v);
- }
- } else
- pcpus = Atom(0);
- free(info);
- CAMLreturn(pcpus);
-}
-
-CAMLprim value stub_xc_domain_setmaxmem(value xch, value domid,
- value max_memkb)
-{
- CAMLparam3(xch, domid, max_memkb);
-
- uint32_t c_domid = _D(domid);
- unsigned int c_max_memkb = Int64_val(max_memkb);
- // caml_enter_blocking_section();
- int retval = xc_domain_setmaxmem(_H(xch), c_domid,
- c_max_memkb);
- // caml_leave_blocking_section();
- if (retval)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_set_memmap_limit(value xch, value domid,
- value map_limitkb)
-{
- CAMLparam3(xch, domid, map_limitkb);
- unsigned long v;
- int retval;
-
- v = Int64_val(map_limitkb);
- retval = xc_domain_set_memmap_limit(_H(xch), _D(domid), v);
- if (retval)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_memory_increase_reservation(value xch,
- value domid,
- value mem_kb)
-{
- CAMLparam3(xch, domid, mem_kb);
-
- unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >>
(PAGE_SHIFT - 10);
-
- uint32_t c_domid = _D(domid);
- // caml_enter_blocking_section();
- int retval = xc_domain_increase_reservation_exact(_H(xch), c_domid,
- nr_extents, 0, 0,
NULL);
- // caml_leave_blocking_section();
-
- if (retval)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_set_machine_address_size(value xch,
- value domid,
- value width)
-{
- CAMLparam3(xch, domid, width);
- uint32_t c_domid = _D(domid);
- int c_width = Int_val(width);
-
- int retval = xc_domain_set_machine_address_size(_H(xch), c_domid,
c_width);
- if (retval)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_get_machine_address_size(value xch,
- value domid)
-{
- CAMLparam2(xch, domid);
- int retval;
-
- retval = xc_domain_get_machine_address_size(_H(xch), _D(domid));
- if (retval < 0)
- failwith_xc(_H(xch));
- CAMLreturn(Val_int(retval));
-}
-
-CAMLprim value stub_xc_domain_cpuid_set(value xch, value domid,
- value input,
- value config)
-{
- CAMLparam4(xch, domid, input, config);
- CAMLlocal2(array, tmp);
- int r;
- unsigned int c_input[2];
- 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[0], c_input[1], 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_set(_H(xch), _D(domid),
- c_input, (const char **)c_config, out_config);
- if (r < 0)
- failwith_xc(_H(xch));
- CAMLreturn(array);
-}
-
-CAMLprim value stub_xc_domain_cpuid_apply_policy(value xch, value domid)
-{
- CAMLparam2(xch, domid);
- int r;
-
- r = xc_cpuid_apply_policy(_H(xch), _D(domid));
- if (r < 0)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_cpuid_check(value xch, value input, value config)
-{
- CAMLparam3(xch, input, config);
- CAMLlocal3(ret, array, tmp);
- int r;
- unsigned int c_input[2];
- 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[0], c_input[1], 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(_H(xch), c_input, (const char **)c_config,
out_config);
- if (r < 0)
- failwith_xc(_H(xch));
-
- 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 xch)
-{
- CAMLparam1(xch);
- CAMLlocal1(result);
- xen_extraversion_t extra;
- long packed;
- int retval;
-
- // caml_enter_blocking_section();
- packed = xc_version(_H(xch), XENVER_version, NULL);
- retval = xc_version(_H(xch), XENVER_extraversion, &extra);
- // caml_leave_blocking_section();
-
- if (retval)
- failwith_xc(_H(xch));
-
- 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 xch)
-{
- CAMLparam1(xch);
- CAMLlocal1(result);
- xen_compile_info_t ci;
- int retval;
-
- // caml_enter_blocking_section();
- retval = xc_version(_H(xch), XENVER_compile_info, &ci);
- // caml_leave_blocking_section();
-
- if (retval)
- failwith_xc(_H(xch));
-
- 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 xch, int code, void *info)
-{
- CAMLparam1(xch);
- int retval;
-
- // caml_enter_blocking_section();
- retval = xc_version(_H(xch), code, info);
- // caml_leave_blocking_section();
-
- if (retval)
- failwith_xc(_H(xch));
-
- CAMLreturn(caml_copy_string((char *)info));
-}
-
-
-CAMLprim value stub_xc_version_changeset(value xch)
-{
- xen_changeset_info_t ci;
-
- return xc_version_single_string(xch, XENVER_changeset, &ci);
-}
-
-
-CAMLprim value stub_xc_version_capabilities(value xch)
-{
- xen_capabilities_info_t ci;
-
- return xc_version_single_string(xch, 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 xch, value dom,
- value size, value mfn)
-{
- CAMLparam4(xch, dom, size, mfn);
- CAMLlocal1(result);
- struct mmap_interface *intf;
- uint32_t c_dom;
- unsigned long c_mfn;
-
- result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
- intf = (struct mmap_interface *) result;
-
- intf->len = Int_val(size);
-
- c_dom = _D(dom);
- c_mfn = Nativeint_val(mfn);
- // caml_enter_blocking_section();
- intf->addr = xc_map_foreign_range(_H(xch), 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 xch, value domid)
-{
- CAMLparam2(xch, domid);
- CAMLlocal1(sdom);
- struct xen_domctl_sched_credit c_sdom;
- int ret;
-
- // caml_enter_blocking_section();
- ret = xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom);
- // caml_leave_blocking_section();
- if (ret != 0)
- failwith_xc(_H(xch));
-
- 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 xch, value domid,
- value sdom)
-{
- CAMLparam3(xch, 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(xch), _D(domid), &c_sdom);
- // caml_leave_blocking_section();
- if (ret != 0)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_shadow_allocation_get(value xch, value domid)
-{
- CAMLparam2(xch, domid);
- CAMLlocal1(mb);
- unsigned long c_mb;
- int ret;
-
- // caml_enter_blocking_section();
- ret = xc_shadow_control(_H(xch), _D(domid),
- XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION,
- NULL, 0, &c_mb, 0, NULL);
- // caml_leave_blocking_section();
- if (ret != 0)
- failwith_xc(_H(xch));
-
- mb = Val_int(c_mb);
- CAMLreturn(mb);
-}
-
-CAMLprim value stub_shadow_allocation_set(value xch, value domid,
- value mb)
-{
- CAMLparam3(xch, domid, mb);
- unsigned long c_mb;
- int ret;
-
- c_mb = Int_val(mb);
- // caml_enter_blocking_section();
- ret = xc_shadow_control(_H(xch), _D(domid),
- XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION,
- NULL, 0, &c_mb, 0, NULL);
- // caml_leave_blocking_section();
- if (ret != 0)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_get_pfn_list(value xch, value domid,
- value nr_pfns)
-{
- CAMLparam3(xch, domid, nr_pfns);
- CAMLlocal2(array, v);
- unsigned long c_nr_pfns;
- long ret, i;
- uint64_t *c_array;
-
- c_nr_pfns = Nativeint_val(nr_pfns);
-
- c_array = malloc(sizeof(uint64_t) * c_nr_pfns);
- if (!c_array)
- caml_raise_out_of_memory();
-
- ret = xc_get_pfn_list(_H(xch), _D(domid),
- c_array, c_nr_pfns);
- if (ret < 0) {
- free(c_array);
- failwith_xc(_H(xch));
- }
-
- 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 xch, value domid,
- value start_port, value nr_ports,
- value allow)
-{
- CAMLparam5(xch, 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(xch), _D(domid),
- c_start_port, c_nr_ports, c_allow);
- if (ret < 0)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_iomem_permission(value xch, value domid,
- value start_pfn, value nr_pfns,
- value allow)
-{
- CAMLparam5(xch, 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(xch), _D(domid),
- c_start_pfn, c_nr_pfns, c_allow);
- if (ret < 0)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_irq_permission(value xch, value domid,
- value pirq, value allow)
-{
- CAMLparam4(xch, 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(xch), _D(domid),
- c_pirq, c_allow);
- if (ret < 0)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_unit);
-}
-
-static uint32_t pci_dev_to_bdf(int domain, int bus, int slot, int func)
-{
- uint32_t bdf = 0;
- bdf |= (bus & 0xff) << 16;
- bdf |= (slot & 0x1f) << 11;
- bdf |= (func & 0x7) << 8;
- return bdf;
-}
-
-CAMLprim value stub_xc_domain_test_assign_device(value xch, value domid, value
desc)
-{
- CAMLparam3(xch, domid, desc);
- int ret;
- int domain, bus, slot, func;
- uint32_t bdf;
-
- domain = Int_val(Field(desc, 0));
- bus = Int_val(Field(desc, 1));
- slot = Int_val(Field(desc, 2));
- func = Int_val(Field(desc, 3));
- bdf = pci_dev_to_bdf(domain, bus, slot, func);
-
- ret = xc_test_assign_device(_H(xch), _D(domid), bdf);
-
- CAMLreturn(Val_bool(ret == 0));
-}
-
-CAMLprim value stub_xc_domain_assign_device(value xch, value domid, value desc)
-{
- CAMLparam3(xch, domid, desc);
- int ret;
- int domain, bus, slot, func;
- uint32_t bdf;
-
- domain = Int_val(Field(desc, 0));
- bus = Int_val(Field(desc, 1));
- slot = Int_val(Field(desc, 2));
- func = Int_val(Field(desc, 3));
- bdf = pci_dev_to_bdf(domain, bus, slot, func);
-
- ret = xc_assign_device(_H(xch), _D(domid), bdf);
-
- if (ret < 0)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_deassign_device(value xch, value domid, value
desc)
-{
- CAMLparam3(xch, domid, desc);
- int ret;
- int domain, bus, slot, func;
- uint32_t bdf;
-
- domain = Int_val(Field(desc, 0));
- bus = Int_val(Field(desc, 1));
- slot = Int_val(Field(desc, 2));
- func = Int_val(Field(desc, 3));
- bdf = pci_dev_to_bdf(domain, bus, slot, func);
-
- ret = xc_deassign_device(_H(xch), _D(domid), bdf);
-
- if (ret < 0)
- failwith_xc(_H(xch));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_watchdog(value xch, value domid, value timeout)
-{
- CAMLparam3(xch, domid, timeout);
- int ret;
- unsigned int c_timeout = Int32_val(timeout);
-
- ret = xc_watchdog(_H(xch), _D(domid), c_timeout);
- if (ret < 0)
- failwith_xc(_H(xch));
-
- CAMLreturn(Val_int(ret));
-}
-
-/*
- * Local variables:
- * indent-tabs-mode: t
- * c-basic-offset: 8
- * tab-width: 8
- * End:
- */
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xc/xenctrl.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xc/xenctrl.ml Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,326 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 is_fake: unit -> bool = "stub_xc_interface_is_fake"
+
+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_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 -> bool array -> unit
+ = "stub_xc_vcpu_setaffinity"
+external vcpu_affinity_get: handle -> domid -> int -> bool array
+ = "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 -> (int64 * (int64 option))
+ -> string option array
+ -> string option array
+ = "stub_xc_domain_cpuid_set"
+external domain_cpuid_apply_policy: handle -> domid -> unit
+ = "stub_xc_domain_cpuid_apply_policy"
+external cpuid_check: handle -> (int64 * (int64 option)) -> string option
array -> (bool * string option array)
+ = "stub_xc_cpuid_check"
+
+external map_foreign_range: handle -> domid -> int
+ -> nativeint -> Xenmmap.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 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 = Xenmmap.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 = Xenmmap.read page 0 page_size in
+ Xenmmap.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 -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xc/xenctrl.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xc/xenctrl.mli Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,184 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 is_fake : unit -> bool = "stub_xc_interface_is_fake"
+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_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 -> bool array -> unit
+ = "stub_xc_vcpu_setaffinity"
+external vcpu_affinity_get : handle -> domid -> int -> bool array
+ = "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 -> Xenmmap.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 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 -> (int64 * (int64 option))
+ -> string option array
+ -> string option array
+ = "stub_xc_domain_cpuid_set"
+external domain_cpuid_apply_policy: handle -> domid -> unit
+ = "stub_xc_domain_cpuid_apply_policy"
+external cpuid_check: handle -> (int64 * (int64 option)) -> string option
array -> (bool * string option array)
+ = "stub_xc_cpuid_check"
+
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xc/xenctrl_stubs.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xc/xenctrl_stubs.c Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,1161 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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>
+#include <errno.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 <xenctrl.h>
+
+#include "mmap_stubs.h"
+
+#define PAGE_SHIFT 12
+#define PAGE_SIZE (1UL << PAGE_SHIFT)
+#define PAGE_MASK (~(PAGE_SIZE-1))
+
+#define _H(__h) ((xc_interface *)(__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)));
+
+#define ERROR_STRLEN 1024
+void failwith_xc(xc_interface *xch)
+{
+ static char error_str[ERROR_STRLEN];
+ if (xch) {
+ const xc_error *error = xc_get_last_error(xch);
+ if (error->code == XC_ERROR_NONE)
+ snprintf(error_str, ERROR_STRLEN, "%d: %s", errno,
strerror(errno));
+ else
+ snprintf(error_str, ERROR_STRLEN, "%d: %s: %s",
+ error->code,
+ xc_error_code_to_desc(error->code),
+ error->message);
+ } else {
+ snprintf(error_str, ERROR_STRLEN, "Unable to open XC
interface");
+ }
+ caml_raise_with_string(*caml_named_value("xc.error"), error_str);
+}
+
+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(void)
+{
+ CAMLparam0();
+ xc_interface *xch;
+ xch = xc_interface_open(NULL, NULL, XC_OPENFLAG_NON_REENTRANT);
+ if (xch == NULL)
+ failwith_xc(NULL);
+ CAMLreturn((value)xch);
+}
+
+
+CAMLprim value stub_xc_interface_is_fake(void)
+{
+ CAMLparam0();
+ int is_fake = xc_interface_is_fake();
+ CAMLreturn(Val_int(is_fake));
+}
+
+CAMLprim value stub_xc_interface_close(value xch)
+{
+ CAMLparam1(xch);
+
+ // caml_enter_blocking_section();
+ xc_interface_close(_H(xch));
+ // 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 xch, value ssidref,
+ value flags, value handle)
+{
+ CAMLparam4(xch, ssidref, flags, handle);
+
+ uint32_t domid = 0;
+ xen_domain_handle_t h = { 0 };
+ int result;
+ int i;
+ 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(_H(xch), c_ssidref, h, c_flags, &domid);
+ // caml_leave_blocking_section();
+
+ if (result < 0)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_int(domid));
+}
+
+CAMLprim value stub_xc_domain_max_vcpus(value xch, value domid,
+ value max_vcpus)
+{
+ CAMLparam3(xch, domid, max_vcpus);
+ int r;
+
+ r = xc_domain_max_vcpus(_H(xch), _D(domid), Int_val(max_vcpus));
+ if (r)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_unit);
+}
+
+
+value stub_xc_domain_sethandle(value xch, value domid, value handle)
+{
+ CAMLparam3(xch, 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(xch), _D(domid), h);
+ if (i)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_unit);
+}
+
+static value dom_op(value xch, value domid, int (*fn)(xc_interface *,
uint32_t))
+{
+ CAMLparam2(xch, domid);
+
+ uint32_t c_domid = _D(domid);
+
+ // caml_enter_blocking_section();
+ int result = fn(_H(xch), c_domid);
+ // caml_leave_blocking_section();
+ if (result)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_pause(value xch, value domid)
+{
+ return dom_op(xch, domid, xc_domain_pause);
+}
+
+
+CAMLprim value stub_xc_domain_unpause(value xch, value domid)
+{
+ return dom_op(xch, domid, xc_domain_unpause);
+}
+
+CAMLprim value stub_xc_domain_destroy(value xch, value domid)
+{
+ return dom_op(xch, domid, xc_domain_destroy);
+}
+
+CAMLprim value stub_xc_domain_resume_fast(value xch, value domid)
+{
+ CAMLparam2(xch, domid);
+
+ uint32_t c_domid = _D(domid);
+
+ // caml_enter_blocking_section();
+ int result = xc_domain_resume(_H(xch), c_domid, 1);
+ // caml_leave_blocking_section();
+ if (result)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_shutdown(value xch, value domid, value reason)
+{
+ CAMLparam3(xch, domid, reason);
+ int ret;
+
+ ret = xc_domain_shutdown(_H(xch), _D(domid), Int_val(reason));
+ if (ret < 0)
+ failwith_xc(_H(xch));
+
+ 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 xch, value first_domain, value
nb)
+{
+ CAMLparam3(xch, first_domain, nb);
+ CAMLlocal2(result, temp);
+ xc_domaininfo_t * info;
+ int i, ret, toalloc, retval;
+ unsigned int c_max_domains;
+ uint32_t c_first_domain;
+
+ /* 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;
+
+ c_first_domain = _D(first_domain);
+ c_max_domains = Int_val(nb);
+ // caml_enter_blocking_section();
+ retval = xc_domain_getinfolist(_H(xch), c_first_domain,
+ c_max_domains, info);
+ // caml_leave_blocking_section();
+
+ if (retval < 0) {
+ free(info);
+ failwith_xc(_H(xch));
+ }
+ 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 xch, value domid)
+{
+ CAMLparam2(xch, domid);
+ CAMLlocal1(result);
+ xc_domaininfo_t info;
+ int ret;
+
+ ret = xc_domain_getinfolist(_H(xch), _D(domid), 1, &info);
+ if (ret != 1)
+ failwith_xc(_H(xch));
+ if (info.domain != _D(domid))
+ failwith_xc(_H(xch));
+
+ result = alloc_domaininfo(&info);
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_vcpu_getinfo(value xch, value domid, value vcpu)
+{
+ CAMLparam3(xch, domid, vcpu);
+ CAMLlocal1(result);
+ xc_vcpuinfo_t info;
+ int retval;
+
+ uint32_t c_domid = _D(domid);
+ uint32_t c_vcpu = Int_val(vcpu);
+ // caml_enter_blocking_section();
+ retval = xc_vcpu_getinfo(_H(xch), c_domid,
+ c_vcpu, &info);
+ // caml_leave_blocking_section();
+ if (retval < 0)
+ failwith_xc(_H(xch));
+
+ 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 xch, value domid,
+ value cpu)
+{
+ CAMLparam3(xch, domid, cpu);
+ CAMLlocal1(context);
+ int ret;
+ vcpu_guest_context_any_t ctxt;
+
+ ret = xc_vcpu_getcontext(_H(xch), _D(domid), Int_val(cpu), &ctxt);
+
+ context = caml_alloc_string(sizeof(ctxt));
+ memcpy(String_val(context), (char *) &ctxt.c, sizeof(ctxt.c));
+
+ CAMLreturn(context);
+}
+
+static int get_cpumap_len(value xch, value cpumap)
+{
+ int ml_len = Wosize_val(cpumap);
+ int xc_len = xc_get_max_cpus(_H(xch));
+
+ if (ml_len < xc_len)
+ return ml_len;
+ else
+ return xc_len;
+}
+
+CAMLprim value stub_xc_vcpu_setaffinity(value xch, value domid,
+ value vcpu, value cpumap)
+{
+ CAMLparam4(xch, domid, vcpu, cpumap);
+ int i, len = get_cpumap_len(xch, cpumap);
+ xc_cpumap_t c_cpumap;
+ int retval;
+
+ c_cpumap = xc_cpumap_alloc(_H(xch));
+ if (c_cpumap == NULL)
+ failwith_xc(_H(xch));
+
+ for (i=0; i<len; i++) {
+ if (Bool_val(Field(cpumap, i)))
+ c_cpumap[i/8] |= i << (i&7);
+ }
+ retval = xc_vcpu_setaffinity(_H(xch), _D(domid),
+ Int_val(vcpu), c_cpumap);
+ free(c_cpumap);
+
+ if (retval < 0)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_vcpu_getaffinity(value xch, value domid,
+ value vcpu)
+{
+ CAMLparam3(xch, domid, vcpu);
+ CAMLlocal1(ret);
+ xc_cpumap_t c_cpumap;
+ int i, len = xc_get_max_cpus(_H(xch));
+ int retval;
+
+ c_cpumap = xc_cpumap_alloc(_H(xch));
+ if (c_cpumap == NULL)
+ failwith_xc(_H(xch));
+
+ retval = xc_vcpu_getaffinity(_H(xch), _D(domid),
+ Int_val(vcpu), c_cpumap);
+ free(c_cpumap);
+
+ if (retval < 0) {
+ free(c_cpumap);
+ failwith_xc(_H(xch));
+ }
+
+ ret = caml_alloc(len, 0);
+
+ for (i=0; i<len; i++) {
+ if (c_cpumap[i%8] & 1 << (i&7))
+ Store_field(ret, i, Val_true);
+ else
+ Store_field(ret, i, Val_false);
+ }
+
+ free(c_cpumap);
+
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_xc_sched_id(value xch)
+{
+ CAMLparam1(xch);
+ int sched_id;
+
+ if (xc_sched_id(_H(xch), &sched_id))
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_int(sched_id));
+}
+
+CAMLprim value stub_xc_evtchn_alloc_unbound(value xch,
+ value local_domid,
+ value remote_domid)
+{
+ CAMLparam3(xch, local_domid, remote_domid);
+
+ 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(_H(xch), c_local_domid,
+ c_remote_domid);
+ // caml_leave_blocking_section();
+
+ if (result < 0)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_int(result));
+}
+
+CAMLprim value stub_xc_evtchn_reset(value xch, value domid)
+{
+ CAMLparam2(xch, domid);
+ int r;
+
+ r = xc_evtchn_reset(_H(xch), _D(domid));
+ if (r < 0)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+
+#define RING_SIZE 32768
+static char ring[RING_SIZE];
+
+CAMLprim value stub_xc_readconsolering(value xch)
+{
+ unsigned int size = RING_SIZE;
+ char *ring_ptr = ring;
+
+ CAMLparam1(xch);
+
+ // caml_enter_blocking_section();
+ int retval = xc_readconsolering(_H(xch), ring_ptr, &size, 0, 0, NULL);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc(_H(xch));
+ ring[size] = '\0';
+ CAMLreturn(caml_copy_string(ring));
+}
+
+CAMLprim value stub_xc_send_debug_keys(value xch, value keys)
+{
+ CAMLparam2(xch, keys);
+ int r;
+
+ r = xc_send_debug_keys(_H(xch), String_val(keys));
+ if (r)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_physinfo(value xch)
+{
+ CAMLparam1(xch);
+ CAMLlocal3(physinfo, cap_list, tmp);
+ xc_physinfo_t c_physinfo;
+ int r;
+
+ // caml_enter_blocking_section();
+ r = xc_physinfo(_H(xch), &c_physinfo);
+ // caml_leave_blocking_section();
+
+ if (r)
+ failwith_xc(_H(xch));
+
+ 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 xch, value nr_cpus)
+{
+ CAMLparam2(xch, nr_cpus);
+ CAMLlocal2(pcpus, v);
+ xc_cpuinfo_t *info;
+ int r, size;
+
+ if (Int_val(nr_cpus) < 1)
+ caml_invalid_argument("nr_cpus");
+
+ info = calloc(Int_val(nr_cpus) + 1, sizeof(*info));
+ if (!info)
+ caml_raise_out_of_memory();
+
+ // caml_enter_blocking_section();
+ r = xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size);
+ // caml_leave_blocking_section();
+
+ if (r) {
+ free(info);
+ failwith_xc(_H(xch));
+ }
+
+ if (size > 0) {
+ int i;
+ pcpus = caml_alloc(size, 0);
+ for (i = 0; i < size; i++) {
+ v = caml_copy_int64(info[i].idletime);
+ caml_modify(&Field(pcpus, i), v);
+ }
+ } else
+ pcpus = Atom(0);
+ free(info);
+ CAMLreturn(pcpus);
+}
+
+CAMLprim value stub_xc_domain_setmaxmem(value xch, value domid,
+ value max_memkb)
+{
+ CAMLparam3(xch, domid, max_memkb);
+
+ uint32_t c_domid = _D(domid);
+ unsigned int c_max_memkb = Int64_val(max_memkb);
+ // caml_enter_blocking_section();
+ int retval = xc_domain_setmaxmem(_H(xch), c_domid,
+ c_max_memkb);
+ // caml_leave_blocking_section();
+ if (retval)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_memmap_limit(value xch, value domid,
+ value map_limitkb)
+{
+ CAMLparam3(xch, domid, map_limitkb);
+ unsigned long v;
+ int retval;
+
+ v = Int64_val(map_limitkb);
+ retval = xc_domain_set_memmap_limit(_H(xch), _D(domid), v);
+ if (retval)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_memory_increase_reservation(value xch,
+ value domid,
+ value mem_kb)
+{
+ CAMLparam3(xch, domid, mem_kb);
+
+ unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >>
(PAGE_SHIFT - 10);
+
+ uint32_t c_domid = _D(domid);
+ // caml_enter_blocking_section();
+ int retval = xc_domain_increase_reservation_exact(_H(xch), c_domid,
+ nr_extents, 0, 0,
NULL);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_machine_address_size(value xch,
+ value domid,
+ value width)
+{
+ CAMLparam3(xch, domid, width);
+ uint32_t c_domid = _D(domid);
+ int c_width = Int_val(width);
+
+ int retval = xc_domain_set_machine_address_size(_H(xch), c_domid,
c_width);
+ if (retval)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_get_machine_address_size(value xch,
+ value domid)
+{
+ CAMLparam2(xch, domid);
+ int retval;
+
+ retval = xc_domain_get_machine_address_size(_H(xch), _D(domid));
+ if (retval < 0)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_int(retval));
+}
+
+CAMLprim value stub_xc_domain_cpuid_set(value xch, value domid,
+ value input,
+ value config)
+{
+ CAMLparam4(xch, domid, input, config);
+ CAMLlocal2(array, tmp);
+ int r;
+ unsigned int c_input[2];
+ 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[0], c_input[1], 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_set(_H(xch), _D(domid),
+ c_input, (const char **)c_config, out_config);
+ if (r < 0)
+ failwith_xc(_H(xch));
+ CAMLreturn(array);
+}
+
+CAMLprim value stub_xc_domain_cpuid_apply_policy(value xch, value domid)
+{
+ CAMLparam2(xch, domid);
+ int r;
+
+ r = xc_cpuid_apply_policy(_H(xch), _D(domid));
+ if (r < 0)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_cpuid_check(value xch, value input, value config)
+{
+ CAMLparam3(xch, input, config);
+ CAMLlocal3(ret, array, tmp);
+ int r;
+ unsigned int c_input[2];
+ 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[0], c_input[1], 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(_H(xch), c_input, (const char **)c_config,
out_config);
+ if (r < 0)
+ failwith_xc(_H(xch));
+
+ 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 xch)
+{
+ CAMLparam1(xch);
+ CAMLlocal1(result);
+ xen_extraversion_t extra;
+ long packed;
+ int retval;
+
+ // caml_enter_blocking_section();
+ packed = xc_version(_H(xch), XENVER_version, NULL);
+ retval = xc_version(_H(xch), XENVER_extraversion, &extra);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc(_H(xch));
+
+ 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 xch)
+{
+ CAMLparam1(xch);
+ CAMLlocal1(result);
+ xen_compile_info_t ci;
+ int retval;
+
+ // caml_enter_blocking_section();
+ retval = xc_version(_H(xch), XENVER_compile_info, &ci);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc(_H(xch));
+
+ 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 xch, int code, void *info)
+{
+ CAMLparam1(xch);
+ int retval;
+
+ // caml_enter_blocking_section();
+ retval = xc_version(_H(xch), code, info);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(caml_copy_string((char *)info));
+}
+
+
+CAMLprim value stub_xc_version_changeset(value xch)
+{
+ xen_changeset_info_t ci;
+
+ return xc_version_single_string(xch, XENVER_changeset, &ci);
+}
+
+
+CAMLprim value stub_xc_version_capabilities(value xch)
+{
+ xen_capabilities_info_t ci;
+
+ return xc_version_single_string(xch, 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 xch, value dom,
+ value size, value mfn)
+{
+ CAMLparam4(xch, dom, size, mfn);
+ CAMLlocal1(result);
+ struct mmap_interface *intf;
+ uint32_t c_dom;
+ unsigned long c_mfn;
+
+ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
+ intf = (struct mmap_interface *) result;
+
+ intf->len = Int_val(size);
+
+ c_dom = _D(dom);
+ c_mfn = Nativeint_val(mfn);
+ // caml_enter_blocking_section();
+ intf->addr = xc_map_foreign_range(_H(xch), 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 xch, value domid)
+{
+ CAMLparam2(xch, domid);
+ CAMLlocal1(sdom);
+ struct xen_domctl_sched_credit c_sdom;
+ int ret;
+
+ // caml_enter_blocking_section();
+ ret = xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc(_H(xch));
+
+ 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 xch, value domid,
+ value sdom)
+{
+ CAMLparam3(xch, 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(xch), _D(domid), &c_sdom);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_shadow_allocation_get(value xch, value domid)
+{
+ CAMLparam2(xch, domid);
+ CAMLlocal1(mb);
+ unsigned long c_mb;
+ int ret;
+
+ // caml_enter_blocking_section();
+ ret = xc_shadow_control(_H(xch), _D(domid),
+ XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION,
+ NULL, 0, &c_mb, 0, NULL);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc(_H(xch));
+
+ mb = Val_int(c_mb);
+ CAMLreturn(mb);
+}
+
+CAMLprim value stub_shadow_allocation_set(value xch, value domid,
+ value mb)
+{
+ CAMLparam3(xch, domid, mb);
+ unsigned long c_mb;
+ int ret;
+
+ c_mb = Int_val(mb);
+ // caml_enter_blocking_section();
+ ret = xc_shadow_control(_H(xch), _D(domid),
+ XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION,
+ NULL, 0, &c_mb, 0, NULL);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_get_pfn_list(value xch, value domid,
+ value nr_pfns)
+{
+ CAMLparam3(xch, domid, nr_pfns);
+ CAMLlocal2(array, v);
+ unsigned long c_nr_pfns;
+ long ret, i;
+ uint64_t *c_array;
+
+ c_nr_pfns = Nativeint_val(nr_pfns);
+
+ c_array = malloc(sizeof(uint64_t) * c_nr_pfns);
+ if (!c_array)
+ caml_raise_out_of_memory();
+
+ ret = xc_get_pfn_list(_H(xch), _D(domid),
+ c_array, c_nr_pfns);
+ if (ret < 0) {
+ free(c_array);
+ failwith_xc(_H(xch));
+ }
+
+ 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 xch, value domid,
+ value start_port, value nr_ports,
+ value allow)
+{
+ CAMLparam5(xch, 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(xch), _D(domid),
+ c_start_port, c_nr_ports, c_allow);
+ if (ret < 0)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_iomem_permission(value xch, value domid,
+ value start_pfn, value nr_pfns,
+ value allow)
+{
+ CAMLparam5(xch, 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(xch), _D(domid),
+ c_start_pfn, c_nr_pfns, c_allow);
+ if (ret < 0)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_irq_permission(value xch, value domid,
+ value pirq, value allow)
+{
+ CAMLparam4(xch, 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(xch), _D(domid),
+ c_pirq, c_allow);
+ if (ret < 0)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_unit);
+}
+
+static uint32_t pci_dev_to_bdf(int domain, int bus, int slot, int func)
+{
+ uint32_t bdf = 0;
+ bdf |= (bus & 0xff) << 16;
+ bdf |= (slot & 0x1f) << 11;
+ bdf |= (func & 0x7) << 8;
+ return bdf;
+}
+
+CAMLprim value stub_xc_domain_test_assign_device(value xch, value domid, value
desc)
+{
+ CAMLparam3(xch, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+ uint32_t bdf;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+ bdf = pci_dev_to_bdf(domain, bus, slot, func);
+
+ ret = xc_test_assign_device(_H(xch), _D(domid), bdf);
+
+ CAMLreturn(Val_bool(ret == 0));
+}
+
+CAMLprim value stub_xc_domain_assign_device(value xch, value domid, value desc)
+{
+ CAMLparam3(xch, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+ uint32_t bdf;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+ bdf = pci_dev_to_bdf(domain, bus, slot, func);
+
+ ret = xc_assign_device(_H(xch), _D(domid), bdf);
+
+ if (ret < 0)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_deassign_device(value xch, value domid, value
desc)
+{
+ CAMLparam3(xch, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+ uint32_t bdf;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+ bdf = pci_dev_to_bdf(domain, bus, slot, func);
+
+ ret = xc_deassign_device(_H(xch), _D(domid), bdf);
+
+ if (ret < 0)
+ failwith_xc(_H(xch));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_watchdog(value xch, value domid, value timeout)
+{
+ CAMLparam3(xch, domid, timeout);
+ int ret;
+ unsigned int c_timeout = Int32_val(timeout);
+
+ ret = xc_watchdog(_H(xch), _D(domid), c_timeout);
+ if (ret < 0)
+ failwith_xc(_H(xch));
+
+ CAMLreturn(Val_int(ret));
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xl/Makefile
--- a/tools/ocaml/libs/xl/Makefile Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xl/Makefile Mon Oct 10 16:37:07 2011 +0100
@@ -6,44 +6,44 @@
CFLAGS += -Wno-unused
CFLAGS += $(CFLAGS_libxenlight)
-OBJS = xl
-INTF = xl.cmi
-LIBS = xl.cma xl.cmxa
+OBJS = xenlight
+INTF = xenlight.cmi
+LIBS = xenlight.cma xenlight.cmxa
-LIBS_xl = $(LDLIBS_libxenlight)
+LIBS_xenlight = $(LDLIBS_libxenlight)
-xl_OBJS = $(OBJS)
-xl_C_OBJS = xl_stubs
+xenlight_OBJS = $(OBJS)
+xenlight_C_OBJS = xenlight_stubs
-OCAML_LIBRARY = xl
+OCAML_LIBRARY = xenlight
-GENERATED_FILES += xl.ml xl.ml.tmp xl.mli xl.mli.tmp
+GENERATED_FILES += xenlight.ml xenlight.ml.tmp xenlight.mli xenlight.mli.tmp
GENERATED_FILES += _libxl_types.ml.in _libxl_types.mli.in
GENERATED_FILES += _libxl_types.inc
all: $(INTF) $(LIBS)
-xl.ml: xl.ml.in _libxl_types.ml.in
+xenlight.ml: xenlight.ml.in _libxl_types.ml.in
$(Q)sed -e '1i\
(*\
* AUTO-GENERATED FILE DO NOT EDIT\
- * Generated from xl.ml.in and _libxl_types.ml.in\
+ * Generated from xenlight.ml.in and _libxl_types.ml.in\
*)\
' \
-e '/^(\* @@LIBXL_TYPES@@ \*)$$/r_libxl_types.ml.in' \
- < xl.ml.in > xl.ml.tmp
- $(Q)mv xl.ml.tmp xl.ml
+ < xenlight.ml.in > xenlight.ml.tmp
+ $(Q)mv xenlight.ml.tmp xenlight.ml
-xl.mli: xl.mli.in _libxl_types.mli.in
+xenlight.mli: xenlight.mli.in _libxl_types.mli.in
$(Q)sed -e '1i\
(*\
* AUTO-GENERATED FILE DO NOT EDIT\
- * Generated from xl.mli.in and _libxl_types.mli.in\
+ * Generated from xenlight.mli.in and _libxl_types.mli.in\
*)\
' \
-e '/^(\* @@LIBXL_TYPES@@ \*)$$/r_libxl_types.mli.in' \
- < xl.mli.in > xl.mli.tmp
- $(Q)mv xl.mli.tmp xl.mli
+ < xenlight.mli.in > xenlight.mli.tmp
+ $(Q)mv xenlight.mli.tmp xenlight.mli
_libxl_types.ml.in _libxl_types.mli.in _libxl_types.inc: genwrap.py
$(XEN_ROOT)/tools/libxl/libxl_types.idl \
$(XEN_ROOT)/tools/libxl/libxltypes.py
@@ -56,11 +56,11 @@
.PHONY: install
install: $(LIBS) META
mkdir -p $(OCAMLDESTDIR)
- ocamlfind remove -destdir $(OCAMLDESTDIR) xl
- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xl META
$(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenlight
+ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenlight META
$(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
- ocamlfind remove -destdir $(OCAMLDESTDIR) xl
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenlight
include $(TOPLEVEL)/Makefile.rules
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xl/xenlight.ml.in
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xl/xenlight.ml.in Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,39 @@
+(*
+ * Copyright (C) 2009-2011 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
+
+type domid = int
+
+(* @@LIBXL_TYPES@@ *)
+
+module Topologyinfo = struct
+ type t =
+ {
+ core : int;
+ socket : int;
+ node : int;
+ }
+ external get : unit -> t = "stub_xl_topologyinfo"
+end
+
+external button_press : domid -> button -> unit = "stub_xl_button_press"
+
+
+external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger"
+external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
+external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
+
+let _ = Callback.register_exception "xl.error" (Error "register_callback")
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xl/xenlight.mli.in
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xl/xenlight.mli.in Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,36 @@
+(*
+ * Copyright (C) 2009-2011 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
+
+type domid = int
+
+(* @@LIBXL_TYPES@@ *)
+
+module Topologyinfo : sig
+ type t =
+ {
+ core : int;
+ socket : int;
+ node : int;
+ }
+ external get : unit -> t = "stub_xl_topologyinfo"
+end
+
+external button_press : domid -> button -> unit = "stub_xl_button_press"
+
+external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger"
+external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
+external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xl/xenlight_stubs.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c Mon Oct 10 16:37:07 2011 +0100
@@ -0,0 +1,596 @@
+/*
+ * Copyright (C) 2009-2011 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 <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 <libxl.h>
+
+struct caml_logger {
+ struct xentoollog_logger logger;
+ int log_offset;
+ char log_buf[2048];
+};
+
+typedef struct caml_gc {
+ int offset;
+ void *ptrs[64];
+} caml_gc;
+
+static void log_vmessage(struct xentoollog_logger *logger, xentoollog_level
level,
+ int errnoval, const char *context, const char *format,
va_list al)
+{
+ struct caml_logger *ologger = (struct caml_logger *) logger;
+
+ ologger->log_offset += vsnprintf(ologger->log_buf + ologger->log_offset,
+ 2048 - ologger->log_offset, format,
al);
+}
+
+static void log_destroy(struct xentoollog_logger *logger)
+{
+}
+
+#define INIT_STRUCT() libxl_ctx *ctx; struct caml_logger lg; struct caml_gc
gc; gc.offset = 0;
+
+#define INIT_CTX() \
+ lg.logger.vmessage = log_vmessage; \
+ lg.logger.destroy = log_destroy; \
+ lg.logger.progress = NULL; \
+ caml_enter_blocking_section(); \
+ ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, (struct xentoollog_logger *)
&lg); \
+ if (ret != 0) \
+ failwith_xl("cannot init context", &lg);
+
+#define FREE_CTX() \
+ gc_free(&gc); \
+ caml_leave_blocking_section(); \
+ libxl_ctx_free(ctx)
+
+static char * dup_String_val(caml_gc *gc, value s)
+{
+ int len;
+ char *c;
+ len = caml_string_length(s);
+ c = calloc(len + 1, sizeof(char));
+ if (!c)
+ caml_raise_out_of_memory();
+ gc->ptrs[gc->offset++] = c;
+ memcpy(c, String_val(s), len);
+ return c;
+}
+
+static void gc_free(caml_gc *gc)
+{
+ int i;
+ for (i = 0; i < gc->offset; i++) {
+ free(gc->ptrs[i]);
+ }
+}
+
+static void failwith_xl(char *fname, struct caml_logger *lg)
+{
+ char *s;
+ s = (lg) ? lg->log_buf : fname;
+ caml_raise_with_string(*caml_named_value("xl.error"), s);
+}
+
+#if 0 /* TODO: wrap libxl_domain_create(), these functions will be needed then
*/
+static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size)
+{
+ void *ptr;
+ ptr = calloc(nmemb, size);
+ if (!ptr)
+ caml_raise_out_of_memory();
+ gc->ptrs[gc->offset++] = ptr;
+ return ptr;
+}
+
+static int string_string_tuple_array_val (caml_gc *gc, char ***c_val, value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(a);
+ int i;
+ char **array;
+
+ for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1)) {
i++; }
+
+ array = gc_calloc(gc, (i + 1) * 2, sizeof(char *));
+ if (!array)
+ return 1;
+ for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1), i++) {
+ value b = Field(a, 0);
+ array[i * 2] = dup_String_val(gc, Field(b, 0));
+ array[i * 2 + 1] = dup_String_val(gc, Field(b, 1));
+ }
+ *c_val = array;
+ CAMLreturn(0);
+}
+
+#endif
+
+static value Val_mac (libxl_mac *c_val)
+{
+ CAMLparam0();
+ CAMLlocal1(v);
+ int i;
+
+ v = caml_alloc_tuple(6);
+
+ for(i=0; i<6; i++)
+ Store_field(v, i, Val_int((*c_val)[i]));
+
+ CAMLreturn(v);
+}
+
+static int Mac_val(caml_gc *gc, struct caml_logger *lg, libxl_mac *c_val,
value v)
+{
+ CAMLparam1(v);
+ int i;
+
+ for(i=0; i<6; i++)
+ (*c_val)[i] = Int_val(Field(v, i));
+
+ CAMLreturn(0);
+}
+
+static value Val_uuid (libxl_uuid *c_val)
+{
+ CAMLparam0();
+ CAMLlocal1(v);
+ uint8_t *uuid = libxl_uuid_bytearray(c_val);
+ int i;
+
+ v = caml_alloc_tuple(16);
+
+ for(i=0; i<16; i++)
+ Store_field(v, i, Val_int(uuid[i]));
+
+ CAMLreturn(v);
+}
+
+static int Uuid_val(caml_gc *gc, struct caml_logger *lg, libxl_uuid *c_val,
value v)
+{
+ CAMLparam1(v);
+ int i;
+ uint8_t *uuid = libxl_uuid_bytearray(c_val);
+
+ for(i=0; i<16; i++)
+ uuid[i] = Int_val(Field(v, i));
+
+ CAMLreturn(0);
+}
+
+static value Val_hwcap(libxl_hwcap *c_val)
+{
+ CAMLparam0();
+ CAMLlocal1(hwcap);
+ int i;
+
+ hwcap = caml_alloc_tuple(8);
+ for (i = 0; i < 8; i++)
+ Store_field(hwcap, i, caml_copy_int32((*c_val)[i]));
+
+ CAMLreturn(hwcap);
+}
+
+#include "_libxl_types.inc"
+
+static value Val_topologyinfo(libxl_topologyinfo *c_val)
+{
+ CAMLparam0();
+ CAMLlocal3(v, topology, topologyinfo);
+ int i;
+
+ topologyinfo = caml_alloc_tuple(c_val->coremap.entries);
+ for (i = 0; i < c_val->coremap.entries; i++) {
+ v = Val_int(0); /* None */
+ if (c_val->coremap.array[i] != LIBXL_CPUARRAY_INVALID_ENTRY) {
+ topology = caml_alloc_tuple(3);
+ Store_field(topology, 0,
Val_int(c_val->coremap.array[i]));
+ Store_field(topology, 1,
Val_int(c_val->socketmap.array[i]));
+ Store_field(topology, 2,
Val_int(c_val->nodemap.array[i]));
+ v = caml_alloc(1, 0); /* Some */
+ Store_field(v, 0, topology);
+ }
+ Store_field(topologyinfo, i, v);
+ }
+
+ CAMLreturn(topologyinfo);
+}
+
+value stub_xl_device_disk_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_disk c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_disk_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_disk_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("disk_add", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_disk_del(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_disk c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_disk_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_disk_del(ctx, Int_val(domid), &c_info, 0);
+ if (ret != 0)
+ failwith_xl("disk_del", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_nic_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_nic c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_nic_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_nic_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("nic_add", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_nic_del(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_nic c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_nic_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_nic_del(ctx, Int_val(domid), &c_info, 0);
+ if (ret != 0)
+ failwith_xl("nic_del", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_console_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_console c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_console_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_console_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("console_add", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vkb_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_vkb c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_vkb_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_vkb_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("vkb_add", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vkb_clean_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_vkb_clean_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("vkb_clean_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vkb_hard_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_vkb_hard_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("vkb_hard_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vfb_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_vfb c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_vfb_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_vfb_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("vfb_add", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vfb_clean_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_vfb_clean_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("vfb_clean_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vfb_hard_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_vfb_hard_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("vfb_hard_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_pci_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_pci c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_pci_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_pci_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("pci_add", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_pci_remove(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_pci c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_pci_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_pci_remove(ctx, Int_val(domid), &c_info, 0);
+ if (ret != 0)
+ failwith_xl("pci_remove", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_pci_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_pci_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("pci_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_button_press(value domid, value button)
+{
+ CAMLparam2(domid, button);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_button_press(ctx, Int_val(domid), Int_val(button) +
LIBXL_BUTTON_POWER);
+ if (ret != 0)
+ failwith_xl("button_press", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_physinfo_get(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(physinfo);
+ libxl_physinfo c_physinfo;
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_get_physinfo(ctx, &c_physinfo);
+ if (ret != 0)
+ failwith_xl("physinfo", &lg);
+ FREE_CTX();
+
+ physinfo = Val_physinfo(&gc, &lg, &c_physinfo);
+ CAMLreturn(physinfo);
+}
+
+value stub_xl_topologyinfo(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(topologyinfo);
+ libxl_topologyinfo c_topologyinfo;
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_get_topologyinfo(ctx, &c_topologyinfo);
+ if (ret != 0)
+ failwith_xl("topologyinfo", &lg);
+ FREE_CTX();
+
+ topologyinfo = Val_topologyinfo(&c_topologyinfo);
+ CAMLreturn(topologyinfo);
+}
+
+value stub_xl_sched_credit_domain_get(value domid)
+{
+ CAMLparam1(domid);
+ CAMLlocal1(scinfo);
+ libxl_sched_credit c_scinfo;
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_sched_credit_domain_get(ctx, Int_val(domid), &c_scinfo);
+ if (ret != 0)
+ failwith_xl("sched_credit_domain_get", &lg);
+ FREE_CTX();
+
+ scinfo = Val_sched_credit(&gc, &lg, &c_scinfo);
+ CAMLreturn(scinfo);
+}
+
+value stub_xl_sched_credit_domain_set(value domid, value scinfo)
+{
+ CAMLparam2(domid, scinfo);
+ libxl_sched_credit c_scinfo;
+ int ret;
+ INIT_STRUCT();
+
+ sched_credit_val(&gc, &lg, &c_scinfo, scinfo);
+
+ INIT_CTX();
+ ret = libxl_sched_credit_domain_set(ctx, Int_val(domid), &c_scinfo);
+ if (ret != 0)
+ failwith_xl("sched_credit_domain_set", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_send_trigger(value domid, value trigger, value vcpuid)
+{
+ CAMLparam3(domid, trigger, vcpuid);
+ int ret;
+ char *c_trigger;
+ INIT_STRUCT();
+
+ c_trigger = dup_String_val(&gc, trigger);
+
+ INIT_CTX();
+ ret = libxl_send_trigger(ctx, Int_val(domid), c_trigger,
Int_val(vcpuid));
+ if (ret != 0)
+ failwith_xl("send_trigger", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_send_sysrq(value domid, value sysrq)
+{
+ CAMLparam2(domid, sysrq);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_send_sysrq(ctx, Int_val(domid), Int_val(sysrq));
+ if (ret != 0)
+ failwith_xl("send_sysrq", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_send_debug_keys(value keys)
+{
+ CAMLparam1(keys);
+ int ret;
+ char *c_keys;
+ INIT_STRUCT();
+
+ c_keys = dup_String_val(&gc, keys);
+
+ INIT_CTX();
+ ret = libxl_send_debug_keys(ctx, c_keys);
+ if (ret != 0)
+ failwith_xl("send_debug_keys", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xl/xl.ml.in
--- a/tools/ocaml/libs/xl/xl.ml.in Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,39 +0,0 @@
-(*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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
-
-type domid = int
-
-(* @@LIBXL_TYPES@@ *)
-
-module Topologyinfo = struct
- type t =
- {
- core : int;
- socket : int;
- node : int;
- }
- external get : unit -> t = "stub_xl_topologyinfo"
-end
-
-external button_press : domid -> button -> unit = "stub_xl_button_press"
-
-
-external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
-
-let _ = Callback.register_exception "xl.error" (Error "register_callback")
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xl/xl.mli.in
--- a/tools/ocaml/libs/xl/xl.mli.in Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,36 +0,0 @@
-(*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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
-
-type domid = int
-
-(* @@LIBXL_TYPES@@ *)
-
-module Topologyinfo : sig
- type t =
- {
- core : int;
- socket : int;
- node : int;
- }
- external get : unit -> t = "stub_xl_topologyinfo"
-end
-
-external button_press : domid -> button -> unit = "stub_xl_button_press"
-
-external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xl/xl_stubs.c
--- a/tools/ocaml/libs/xl/xl_stubs.c Mon Oct 10 11:21:51 2011 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,596 +0,0 @@
-/*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
- *
- * 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 <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 <libxl.h>
-
-struct caml_logger {
- struct xentoollog_logger logger;
- int log_offset;
- char log_buf[2048];
-};
-
-typedef struct caml_gc {
- int offset;
- void *ptrs[64];
-} caml_gc;
-
-static void log_vmessage(struct xentoollog_logger *logger, xentoollog_level
level,
- int errnoval, const char *context, const char *format,
va_list al)
-{
- struct caml_logger *ologger = (struct caml_logger *) logger;
-
- ologger->log_offset += vsnprintf(ologger->log_buf + ologger->log_offset,
- 2048 - ologger->log_offset, format,
al);
-}
-
-static void log_destroy(struct xentoollog_logger *logger)
-{
-}
-
-#define INIT_STRUCT() libxl_ctx *ctx; struct caml_logger lg; struct caml_gc
gc; gc.offset = 0;
-
-#define INIT_CTX() \
- lg.logger.vmessage = log_vmessage; \
- lg.logger.destroy = log_destroy; \
- lg.logger.progress = NULL; \
- caml_enter_blocking_section(); \
- ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, (struct xentoollog_logger *)
&lg); \
- if (ret != 0) \
- failwith_xl("cannot init context", &lg);
-
-#define FREE_CTX() \
- gc_free(&gc); \
- caml_leave_blocking_section(); \
- libxl_ctx_free(ctx)
-
-static char * dup_String_val(caml_gc *gc, value s)
-{
- int len;
- char *c;
- len = caml_string_length(s);
- c = calloc(len + 1, sizeof(char));
- if (!c)
- caml_raise_out_of_memory();
- gc->ptrs[gc->offset++] = c;
- memcpy(c, String_val(s), len);
- return c;
-}
-
-static void gc_free(caml_gc *gc)
-{
- int i;
- for (i = 0; i < gc->offset; i++) {
- free(gc->ptrs[i]);
- }
-}
-
-static void failwith_xl(char *fname, struct caml_logger *lg)
-{
- char *s;
- s = (lg) ? lg->log_buf : fname;
- caml_raise_with_string(*caml_named_value("xl.error"), s);
-}
-
-#if 0 /* TODO: wrap libxl_domain_create(), these functions will be needed then
*/
-static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size)
-{
- void *ptr;
- ptr = calloc(nmemb, size);
- if (!ptr)
- caml_raise_out_of_memory();
- gc->ptrs[gc->offset++] = ptr;
- return ptr;
-}
-
-static int string_string_tuple_array_val (caml_gc *gc, char ***c_val, value v)
-{
- CAMLparam1(v);
- CAMLlocal1(a);
- int i;
- char **array;
-
- for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1)) {
i++; }
-
- array = gc_calloc(gc, (i + 1) * 2, sizeof(char *));
- if (!array)
- return 1;
- for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1), i++) {
- value b = Field(a, 0);
- array[i * 2] = dup_String_val(gc, Field(b, 0));
- array[i * 2 + 1] = dup_String_val(gc, Field(b, 1));
- }
- *c_val = array;
- CAMLreturn(0);
-}
-
-#endif
-
-static value Val_mac (libxl_mac *c_val)
-{
- CAMLparam0();
- CAMLlocal1(v);
- int i;
-
- v = caml_alloc_tuple(6);
-
- for(i=0; i<6; i++)
- Store_field(v, i, Val_int((*c_val)[i]));
-
- CAMLreturn(v);
-}
-
-static int Mac_val(caml_gc *gc, struct caml_logger *lg, libxl_mac *c_val,
value v)
-{
- CAMLparam1(v);
- int i;
-
- for(i=0; i<6; i++)
- (*c_val)[i] = Int_val(Field(v, i));
-
- CAMLreturn(0);
-}
-
-static value Val_uuid (libxl_uuid *c_val)
-{
- CAMLparam0();
- CAMLlocal1(v);
- uint8_t *uuid = libxl_uuid_bytearray(c_val);
- int i;
-
- v = caml_alloc_tuple(16);
-
- for(i=0; i<16; i++)
- Store_field(v, i, Val_int(uuid[i]));
-
- CAMLreturn(v);
-}
-
-static int Uuid_val(caml_gc *gc, struct caml_logger *lg, libxl_uuid *c_val,
value v)
-{
- CAMLparam1(v);
- int i;
- uint8_t *uuid = libxl_uuid_bytearray(c_val);
-
- for(i=0; i<16; i++)
- uuid[i] = Int_val(Field(v, i));
-
- CAMLreturn(0);
-}
-
-static value Val_hwcap(libxl_hwcap *c_val)
-{
- CAMLparam0();
- CAMLlocal1(hwcap);
- int i;
-
- hwcap = caml_alloc_tuple(8);
- for (i = 0; i < 8; i++)
- Store_field(hwcap, i, caml_copy_int32((*c_val)[i]));
-
- CAMLreturn(hwcap);
-}
-
-#include "_libxl_types.inc"
-
-static value Val_topologyinfo(libxl_topologyinfo *c_val)
-{
- CAMLparam0();
- CAMLlocal3(v, topology, topologyinfo);
- int i;
-
- topologyinfo = caml_alloc_tuple(c_val->coremap.entries);
- for (i = 0; i < c_val->coremap.entries; i++) {
- v = Val_int(0); /* None */
- if (c_val->coremap.array[i] != LIBXL_CPUARRAY_INVALID_ENTRY) {
- topology = caml_alloc_tuple(3);
- Store_field(topology, 0,
Val_int(c_val->coremap.array[i]));
- Store_field(topology, 1,
Val_int(c_val->socketmap.array[i]));
- Store_field(topology, 2,
Val_int(c_val->nodemap.array[i]));
- v = caml_alloc(1, 0); /* Some */
- Store_field(v, 0, topology);
- }
- Store_field(topologyinfo, i, v);
- }
-
- CAMLreturn(topologyinfo);
-}
-
-value stub_xl_device_disk_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_disk c_info;
- int ret;
- INIT_STRUCT();
-
- device_disk_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_disk_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("disk_add", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_disk_del(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_disk c_info;
- int ret;
- INIT_STRUCT();
-
- device_disk_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_disk_del(ctx, Int_val(domid), &c_info, 0);
- if (ret != 0)
- failwith_xl("disk_del", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_nic_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_nic c_info;
- int ret;
- INIT_STRUCT();
-
- device_nic_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_nic_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("nic_add", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_nic_del(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_nic c_info;
- int ret;
- INIT_STRUCT();
-
- device_nic_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_nic_del(ctx, Int_val(domid), &c_info, 0);
- if (ret != 0)
- failwith_xl("nic_del", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_console_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_console c_info;
- int ret;
- INIT_STRUCT();
-
- device_console_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_console_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("console_add", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_vkb c_info;
- int ret;
- INIT_STRUCT();
-
- device_vkb_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_vkb_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("vkb_add", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_clean_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_vkb_clean_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("vkb_clean_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_hard_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_vkb_hard_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("vkb_hard_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_vfb c_info;
- int ret;
- INIT_STRUCT();
-
- device_vfb_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_vfb_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("vfb_add", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_clean_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_vfb_clean_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("vfb_clean_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_hard_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_vfb_hard_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("vfb_hard_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_pci c_info;
- int ret;
- INIT_STRUCT();
-
- device_pci_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_pci_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("pci_add", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_remove(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_pci c_info;
- int ret;
- INIT_STRUCT();
-
- device_pci_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_pci_remove(ctx, Int_val(domid), &c_info, 0);
- if (ret != 0)
- failwith_xl("pci_remove", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_pci_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("pci_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_button_press(value domid, value button)
-{
- CAMLparam2(domid, button);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_button_press(ctx, Int_val(domid), Int_val(button) +
LIBXL_BUTTON_POWER);
- if (ret != 0)
- failwith_xl("button_press", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_physinfo_get(value unit)
-{
- CAMLparam1(unit);
- CAMLlocal1(physinfo);
- libxl_physinfo c_physinfo;
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_get_physinfo(ctx, &c_physinfo);
- if (ret != 0)
- failwith_xl("physinfo", &lg);
- FREE_CTX();
-
- physinfo = Val_physinfo(&gc, &lg, &c_physinfo);
- CAMLreturn(physinfo);
-}
-
-value stub_xl_topologyinfo(value unit)
-{
- CAMLparam1(unit);
- CAMLlocal1(topologyinfo);
- libxl_topologyinfo c_topologyinfo;
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_get_topologyinfo(ctx, &c_topologyinfo);
- if (ret != 0)
- failwith_xl("topologyinfo", &lg);
- FREE_CTX();
-
- topologyinfo = Val_topologyinfo(&c_topologyinfo);
- CAMLreturn(topologyinfo);
-}
-
-value stub_xl_sched_credit_domain_get(value domid)
-{
- CAMLparam1(domid);
- CAMLlocal1(scinfo);
- libxl_sched_credit c_scinfo;
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_sched_credit_domain_get(ctx, Int_val(domid), &c_scinfo);
- if (ret != 0)
- failwith_xl("sched_credit_domain_get", &lg);
- FREE_CTX();
-
- scinfo = Val_sched_credit(&gc, &lg, &c_scinfo);
- CAMLreturn(scinfo);
-}
-
-value stub_xl_sched_credit_domain_set(value domid, value scinfo)
-{
- CAMLparam2(domid, scinfo);
- libxl_sched_credit c_scinfo;
- int ret;
- INIT_STRUCT();
-
- sched_credit_val(&gc, &lg, &c_scinfo, scinfo);
-
- INIT_CTX();
- ret = libxl_sched_credit_domain_set(ctx, Int_val(domid), &c_scinfo);
- if (ret != 0)
- failwith_xl("sched_credit_domain_set", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_trigger(value domid, value trigger, value vcpuid)
-{
- CAMLparam3(domid, trigger, vcpuid);
- int ret;
- char *c_trigger;
- INIT_STRUCT();
-
- c_trigger = dup_String_val(&gc, trigger);
-
- INIT_CTX();
- ret = libxl_send_trigger(ctx, Int_val(domid), c_trigger,
Int_val(vcpuid));
- if (ret != 0)
- failwith_xl("send_trigger", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_sysrq(value domid, value sysrq)
-{
- CAMLparam2(domid, sysrq);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_send_sysrq(ctx, Int_val(domid), Int_val(sysrq));
- if (ret != 0)
- failwith_xl("send_sysrq", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_debug_keys(value keys)
-{
- CAMLparam1(keys);
- int ret;
- char *c_keys;
- INIT_STRUCT();
-
- c_keys = dup_String_val(&gc, keys);
-
- INIT_CTX();
- ret = libxl_send_debug_keys(ctx, c_keys);
- if (ret != 0)
- failwith_xl("send_debug_keys", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-/*
- * Local variables:
- * indent-tabs-mode: t
- * c-basic-offset: 8
- * tab-width: 8
- * End:
- */
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xs/META.in
--- a/tools/ocaml/libs/xs/META.in Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xs/META.in Mon Oct 10 16:37:07 2011 +0100
@@ -1,5 +1,5 @@
version = "@VERSION@"
description = "XenStore Interface"
-requires = "unix,xb"
-archive(byte) = "xs.cma"
-archive(native) = "xs.cmxa"
+requires = "unix,xenbus"
+archive(byte) = "xenstore.cma"
+archive(native) = "xenstore.cmxa"
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xs/Makefile
--- a/tools/ocaml/libs/xs/Makefile Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xs/Makefile Mon Oct 10 16:37:07 2011 +0100
@@ -3,6 +3,7 @@
include $(TOPLEVEL)/common.make
OCAMLINCLUDE += -I ../xb/
+OCAMLOPTFLAGS += -for-pack Xenstore
.NOTPARALLEL:
# Ocaml is such a PITA!
@@ -12,7 +13,7 @@
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
+LIBS = xenstore.cma xenstore.cmxa
all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
@@ -20,18 +21,27 @@
libs: $(LIBS)
-xs_OBJS = $(OBJS)
-OCAML_NOC_LIBRARY = xs
+xenstore_OBJS = xenstore
+OCAML_NOC_LIBRARY = xenstore
+
+xenstore.cmx : $(foreach obj, $(OBJS), $(obj).cmx)
+ $(E) " CMX $@"
+ $(Q)$(OCAMLOPT) -pack -o $@ $^
+
+xenstore.cmo : $(foreach obj, $(OBJS), $(obj).cmo)
+ $(E) " CMO $@"
+ $(Q)$(OCAMLC) -pack -o $@ $^
+
.PHONY: install
install: $(LIBS) META
mkdir -p $(OCAMLDESTDIR)
- ocamlfind remove -destdir $(OCAMLDESTDIR) xs
- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xs META
$(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenstore
+ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenstore META
$(LIBS) xenstore.cmo xenstore.cmi xenstore.cmx *.a
.PHONY: uninstall
uninstall:
- ocamlfind remove -destdir $(OCAMLDESTDIR) xs
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenstore
include $(TOPLEVEL)/Makefile.rules
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xs/queueop.ml
--- a/tools/ocaml/libs/xs/queueop.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xs/queueop.ml Mon Oct 10 16:37:07 2011 +0100
@@ -13,6 +13,7 @@
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
+open Xenbus
let data_concat ls = (String.concat "\000" ls) ^ "\000"
let queue_path ty (tid: int) (path: string) con =
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xs/xs.ml
--- a/tools/ocaml/libs/xs/xs.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xs/xs.ml Mon Oct 10 16:37:07 2011 +0100
@@ -69,7 +69,7 @@
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
+let get_fd xsh = Xenbus.Xb.get_fd xsh.con.Xsraw.xb
exception Timeout
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xs/xsraw.ml
--- a/tools/ocaml/libs/xs/xsraw.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xs/xsraw.ml Mon Oct 10 16:37:07 2011 +0100
@@ -14,6 +14,8 @@
* GNU Lesser General Public License for more details.
*)
+open Xenbus
+
exception Partial_not_empty
exception Unexpected_packet of string
@@ -27,7 +29,7 @@
raise (Unexpected_packet s)
type con = {
- xb: Xb.t;
+ xb: Xenbus.Xb.t;
watchevents: (string * string) Queue.t;
}
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/libs/xs/xsraw.mli
--- a/tools/ocaml/libs/xs/xsraw.mli Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/libs/xs/xsraw.mli Mon Oct 10 16:37:07 2011 +0100
@@ -16,8 +16,8 @@
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 unexpected_packet : Xenbus.Xb.Op.operation -> Xenbus.Xb.Op.operation -> 'a
+type con = { xb : Xenbus.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
@@ -26,14 +26,14 @@
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 pkt_recv : con -> Xenbus.Xb.Packet.t
+val pkt_recv_timeout : con -> float -> bool * Xenbus.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 sync_recv : Xenbus.Xb.Op.operation -> con -> string
+val sync : (Xenbus.Xb.t -> 'a) -> con -> string
val ack : string -> unit
val validate_path : string -> unit
val validate_watch_path : string -> unit
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/Makefile
--- a/tools/ocaml/xenstored/Makefile Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/Makefile Mon Oct 10 16:37:07 2011 +0100
@@ -35,11 +35,11 @@
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/mmap
$(OCAML_TOPLEVEL)/libs/mmap/xenmmap.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 \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn
$(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc
$(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb
$(OCAML_TOPLEVEL)/libs/xb/xenbus.cmxa \
-ccopt -L -ccopt $(XEN_ROOT)/tools/libxc
PROGRAMS = oxenstored
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/connection.ml
--- a/tools/ocaml/xenstored/connection.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/connection.ml Mon Oct 10 16:37:07 2011 +0100
@@ -27,7 +27,7 @@
}
and t = {
- xb: Xb.t;
+ xb: Xenbus.Xb.t;
dom: Domain.t option;
transactions: (int, Transaction.t) Hashtbl.t;
mutable next_tid: int;
@@ -93,10 +93,10 @@
Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con);
con
-let get_fd con = Xb.get_fd con.xb
+let get_fd con = Xenbus.Xb.get_fd con.xb
let close con =
Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con);
- Xb.close con.xb
+ Xenbus.Xb.close con.xb
let get_perm con =
con.perm
@@ -108,9 +108,9 @@
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)
+ Xenbus.Xb.queue con.xb (Xenbus.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_error con tid rid err = send_reply con tid rid Xenbus.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 =
@@ -166,7 +166,7 @@
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
+ send_reply watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data
let fire_watch watch path =
let new_path =
@@ -179,7 +179,7 @@
path
in
let data = Utils.join_by_null [ new_path; watch.token; "" ] in
- send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
+ send_reply watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data
let find_next_tid con =
let ret = con.next_tid in con.next_tid <- con.next_tid + 1; ret
@@ -203,15 +203,15 @@
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 do_input con = Xenbus.Xb.input con.xb
+let has_input con = Xenbus.Xb.has_in_packet con.xb
+let pop_in con = Xenbus.Xb.get_in_packet con.xb
+let has_more_input con = Xenbus.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 has_output con = Xenbus.Xb.has_output con.xb
+let has_new_output con = Xenbus.Xb.has_new_output con.xb
+let peek_output con = Xenbus.Xb.peek_output con.xb
+let do_output con = Xenbus.Xb.output con.xb
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/connections.ml
--- a/tools/ocaml/xenstored/connections.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/connections.ml Mon Oct 10 16:37:07 2011 +0100
@@ -26,12 +26,12 @@
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 xbcon = Xenbus.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 xbcon = Xenbus.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
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/domain.ml
--- a/tools/ocaml/xenstored/domain.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/domain.ml Mon Oct 10 16:37:07 2011 +0100
@@ -20,10 +20,10 @@
type t =
{
- id: Xc.domid;
+ id: Xenctrl.domid;
mfn: nativeint;
remote_port: int;
- interface: Mmap.mmap_interface;
+ interface: Xenmmap.mmap_interface;
eventchn: Event.t;
mutable port: int;
}
@@ -47,7 +47,7 @@
let close dom =
debug "domain %d unbound port %d" dom.id dom.port;
Event.unbind dom.eventchn dom.port;
- Mmap.unmap dom.interface;
+ Xenmmap.unmap dom.interface;
()
let make id mfn remote_port interface eventchn = {
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/domains.ml
--- a/tools/ocaml/xenstored/domains.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/domains.ml Mon Oct 10 16:37:07 2011 +0100
@@ -16,7 +16,7 @@
type domains = {
eventchn: Event.t;
- table: (Xc.domid, Domain.t) Hashtbl.t;
+ table: (Xenctrl.domid, Domain.t) Hashtbl.t;
}
let init eventchn =
@@ -33,16 +33,16 @@
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 (
+ let info = Xenctrl.domain_getinfo xc id in
+ if info.Xenctrl.shutdown || info.Xenctrl.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
+ id info.Xenctrl.dying
info.Xenctrl.shutdown info.Xenctrl.shutdown_code;
+ if info.Xenctrl.dying then
dead_dom := id :: !dead_dom
else
notify := true;
)
- with Xc.Error _ ->
+ with Xenctrl.Error _ ->
Logs.debug "general" "Domain %u died -- no domain info"
id;
dead_dom := id :: !dead_dom;
) doms.table;
@@ -57,7 +57,7 @@
()
let create xc doms domid mfn port =
- let interface = Xc.map_foreign_range xc domid (Mmap.getpagesize()) mfn
in
+ let interface = Xenctrl.map_foreign_range xc domid
(Xenmmap.getpagesize()) mfn in
let dom = Domain.make domid mfn port interface doms.eventchn in
Hashtbl.add doms.table domid dom;
Domain.bind_interdomain dom;
@@ -66,13 +66,13 @@
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)
+ 0, Xenctrl.with_intf (fun xc ->
Xenctrl.map_foreign_range xc 0 (Xenmmap.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
+ let interface = Xenmmap.mmap fd Xenmmap.RDWR
Xenmmap.SHARED
+ (Xenmmap.getpagesize()) 0 in
Unix.close fd;
port, interface
)
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/event.ml
--- a/tools/ocaml/xenstored/event.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/event.ml Mon Oct 10 16:37:07 2011 +0100
@@ -16,15 +16,15 @@
(**************** high level binding ****************)
type t = {
- handle: Eventchn.handle;
+ handle: Xeneventchn.handle;
mutable virq_port: int;
}
-let init () = { handle = Eventchn.init (); virq_port = -1; }
-let fd eventchn = Eventchn.fd eventchn.handle
-let bind_dom_exc_virq eventchn = eventchn.virq_port <-
Eventchn.bind_dom_exc_virq eventchn.handle
-let bind_interdomain eventchn domid port = Eventchn.bind_interdomain
eventchn.handle domid port
-let unbind eventchn port = Eventchn.unbind eventchn.handle port
-let notify eventchn port = Eventchn.notify eventchn.handle port
-let pending eventchn = Eventchn.pending eventchn.handle
-let unmask eventchn port = Eventchn.unmask eventchn.handle port
+let init () = { handle = Xeneventchn.init (); virq_port = -1; }
+let fd eventchn = Xeneventchn.fd eventchn.handle
+let bind_dom_exc_virq eventchn = eventchn.virq_port <-
Xeneventchn.bind_dom_exc_virq eventchn.handle
+let bind_interdomain eventchn domid port = Xeneventchn.bind_interdomain
eventchn.handle domid port
+let unbind eventchn port = Xeneventchn.unbind eventchn.handle port
+let notify eventchn port = Xeneventchn.notify eventchn.handle port
+let pending eventchn = Xeneventchn.pending eventchn.handle
+let unmask eventchn port = Xeneventchn.unmask eventchn.handle port
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/logging.ml
--- a/tools/ocaml/xenstored/logging.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/logging.ml Mon Oct 10 16:37:07 2011 +0100
@@ -39,7 +39,7 @@
| Commit
| Newconn
| Endconn
- | XbOp of Xb.Op.operation
+ | XbOp of Xenbus.Xb.Op.operation
type access =
{
@@ -82,35 +82,35 @@
| Endconn -> "endconn "
| XbOp op -> match op with
- | Xb.Op.Debug -> "debug "
+ | Xenbus.Xb.Op.Debug -> "debug "
- | Xb.Op.Directory -> "directory"
- | Xb.Op.Read -> "read "
- | Xb.Op.Getperms -> "getperms "
+ | Xenbus.Xb.Op.Directory -> "directory"
+ | Xenbus.Xb.Op.Read -> "read "
+ | Xenbus.Xb.Op.Getperms -> "getperms "
- | Xb.Op.Watch -> "watch "
- | Xb.Op.Unwatch -> "unwatch "
+ | Xenbus.Xb.Op.Watch -> "watch "
+ | Xenbus.Xb.Op.Unwatch -> "unwatch "
- | Xb.Op.Transaction_start -> "t start "
- | Xb.Op.Transaction_end -> "t end "
+ | Xenbus.Xb.Op.Transaction_start -> "t start "
+ | Xenbus.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 "
+ | Xenbus.Xb.Op.Introduce -> "introduce"
+ | Xenbus.Xb.Op.Release -> "release "
+ | Xenbus.Xb.Op.Getdomainpath -> "getdomain"
+ | Xenbus.Xb.Op.Isintroduced -> "is introduced"
+ | Xenbus.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"
+ | Xenbus.Xb.Op.Write -> "write "
+ | Xenbus.Xb.Op.Mkdir -> "mkdir "
+ | Xenbus.Xb.Op.Rm -> "rm "
+ | Xenbus.Xb.Op.Setperms -> "setperms "
+ | Xenbus.Xb.Op.Restrict -> "restrict "
+ | Xenbus.Xb.Op.Set_target -> "settarget"
- | Xb.Op.Error -> "error "
- | Xb.Op.Watchevent -> "w event "
+ | Xenbus.Xb.Op.Error -> "error "
+ | Xenbus.Xb.Op.Watchevent -> "w event "
- | x -> Xb.Op.to_string x
+ | x -> Xenbus.Xb.Op.to_string x
let file_exists file =
try
@@ -210,10 +210,10 @@
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 ->
+ | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory |
Xenbus.Xb.Op.Getperms -> !log_read_ops
+ | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end
->
false (* transactions are managed below *)
- | Xb.Op.Introduce | Xb.Op.Release | Xb.Op.Getdomainpath |
Xb.Op.Isintroduced | Xb.Op.Resume ->
+ | Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release |
Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume ->
!log_special_ops
| _ -> true
in
@@ -222,17 +222,17 @@
let start_transaction ~tid ~con =
if !log_transaction_ops && tid <> 0
- then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_start)
+ then write_access_log ~tid ~con (XbOp Xenbus.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)
+ then write_access_log ~tid ~con (XbOp Xenbus.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
+ | Xenbus.Xb.Op.Error when data="ENOENT " -> !log_read_ops
+ | Xenbus.Xb.Op.Error -> !log_special_ops
+ | Xenbus.Xb.Op.Watchevent -> true
| _ -> false
in
if print
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/perms.ml
--- a/tools/ocaml/xenstored/perms.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/perms.ml Mon Oct 10 16:37:07 2011 +0100
@@ -43,9 +43,9 @@
type t =
{
- owner: Xc.domid;
+ owner: Xenctrl.domid;
other: permty;
- acl: (Xc.domid * permty) list;
+ acl: (Xenctrl.domid * permty) list;
}
let create owner other acl =
@@ -88,7 +88,7 @@
module Connection =
struct
-type elt = Xc.domid * (permty list)
+type elt = Xenctrl.domid * (permty list)
type t =
{ main: elt;
target: elt option; }
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/process.ml
--- a/tools/ocaml/xenstored/process.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/process.ml Mon Oct 10 16:37:07 2011 +0100
@@ -54,10 +54,10 @@
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
+ | Xenbus.Xb.Op.Write -> false
+ | Xenbus.Xb.Op.Mkdir -> false
+ | Xenbus.Xb.Op.Rm -> true
+ | Xenbus.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
@@ -83,7 +83,7 @@
then None
else try match split None '\000' data with
| "print" :: msg :: _ ->
- Logging.xb_op ~tid:0 ~ty:Xb.Op.Debug ~con:"=======>" msg;
+ Logging.xb_op ~tid:0 ~ty:Xenbus.Xb.Op.Debug ~con:"=======>" msg;
None
| "quota" :: domid :: _ ->
let domid = int_of_string domid in
@@ -120,7 +120,7 @@
| _ -> 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.send_ack con (Transaction.get_id t) rid Xenbus.Xb.Op.Watch;
Connection.fire_single_watch watch
let do_unwatch con t domains cons data =
@@ -165,7 +165,7 @@
if Domains.exist domains domid then
Domains.find domains domid
else try
- let ndom = Xc.with_intf (fun xc ->
+ let ndom = Xenctrl.with_intf (fun xc ->
Domains.create xc domains domid mfn port) in
Connections.add_domain cons ndom;
Connections.fire_spec_watches cons "@introduceDomain";
@@ -299,25 +299,25 @@
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
+ | Xenbus.Xb.Op.Debug -> reply_data_or_ack do_debug
+ | Xenbus.Xb.Op.Directory -> reply_data do_directory
+ | Xenbus.Xb.Op.Read -> reply_data do_read
+ | Xenbus.Xb.Op.Getperms -> reply_data do_getperms
+ | Xenbus.Xb.Op.Watch -> reply_none do_watch
+ | Xenbus.Xb.Op.Unwatch -> reply_ack do_unwatch
+ | Xenbus.Xb.Op.Transaction_start -> reply_data do_transaction_start
+ | Xenbus.Xb.Op.Transaction_end -> reply_ack do_transaction_end
+ | Xenbus.Xb.Op.Introduce -> reply_ack do_introduce
+ | Xenbus.Xb.Op.Release -> reply_ack do_release
+ | Xenbus.Xb.Op.Getdomainpath -> reply_data do_getdomainpath
+ | Xenbus.Xb.Op.Write -> reply_ack do_write
+ | Xenbus.Xb.Op.Mkdir -> reply_ack do_mkdir
+ | Xenbus.Xb.Op.Rm -> reply_ack do_rm
+ | Xenbus.Xb.Op.Setperms -> reply_ack do_setperms
+ | Xenbus.Xb.Op.Isintroduced -> reply_data do_isintroduced
+ | Xenbus.Xb.Op.Resume -> reply_ack do_resume
+ | Xenbus.Xb.Op.Set_target -> reply_ack do_set_target
+ | Xenbus.Xb.Op.Restrict -> reply_ack do_restrict
| _ -> reply_ack do_error
let input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data =
@@ -370,11 +370,11 @@
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
+ let tid, rid, ty, data = Xenbus.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); *)
+ (Xenbus.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;
@@ -384,11 +384,11 @@
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
+ let tid, rid, ty, data = Xenbus.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);*)
+ (Xenbus.Xb.Op.to_string ty) (sanitize_data
data);*)
write_answer_log ~ty ~tid ~con ~data;
);
ignore (Connection.do_output con)
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/quota.ml
--- a/tools/ocaml/xenstored/quota.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/quota.ml Mon Oct 10 16:37:07 2011 +0100
@@ -26,7 +26,7 @@
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 *)
+ cur: (Xenctrl.domid, int) Hashtbl.t; (* current domains quota *)
}
let to_string quota domid =
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/transaction.ml
--- a/tools/ocaml/xenstored/transaction.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/transaction.ml Mon Oct 10 16:37:07 2011 +0100
@@ -74,7 +74,7 @@
type t = {
ty: ty;
store: Store.t;
- mutable ops: (Xb.Op.operation * Store.Path.t) list;
+ mutable ops: (Xenbus.Xb.Op.operation * Store.Path.t) list;
mutable read_lowpath: Store.Path.t option;
mutable write_lowpath: Store.Path.t option;
}
@@ -105,23 +105,23 @@
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
+ add_wop t Xenbus.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
+ add_wop t Xenbus.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
+ add_wop t Xenbus.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
+ add_wop t Xenbus.Xb.Op.Rm path
let ls t perm path =
let r = Store.ls t.store perm path in
diff -r 72f339bc600d -r cdb34816a40a tools/ocaml/xenstored/xenstored.ml
--- a/tools/ocaml/xenstored/xenstored.ml Mon Oct 10 11:21:51 2011 +0100
+++ b/tools/ocaml/xenstored/xenstored.ml Mon Oct 10 16:37:07 2011 +0100
@@ -35,7 +35,7 @@
if err <> Unix.ECONNRESET then
error "closing socket connection: read error: %s"
(Unix.error_message err)
- | Xb.End_of_file ->
+ | Xenbus.Xb.End_of_file ->
Connections.del_anonymous cons c;
debug "closing socket connection"
in
@@ -170,7 +170,7 @@
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 xc = Xenctrl.interface_open () in
let domain_f domid mfn port =
let ndom =
@@ -190,7 +190,7 @@
op.Store.setperms path perms
in
finally (fun () -> from_channel_f chan domain_f watch_f store_f)
- (fun () -> Xc.interface_close xc)
+ (fun () -> Xenctrl.interface_close xc)
let from_file store cons doms file =
let channel = open_in file in
@@ -282,7 +282,7 @@
Store.mkdir store (Perms.Connection.create 0) localpath;
if cf.domain_init then (
- let usingxiu = Xc.is_fake () in
+ let usingxiu = Xenctrl.is_fake () in
Connections.add_domain cons (Domains.create0 usingxiu
domains);
Event.bind_dom_exc_virq eventchn
);
@@ -301,7 +301,7 @@
(if cf.domain_init then [ Event.fd eventchn ] else [])
in
- let xc = Xc.interface_open () in
+ let xc = Xenctrl.interface_open () in
let process_special_fds rset =
let accept_connection can_write fd =
_______________________________________________
Xen-changelog mailing list
Xen-changelog@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/xen-changelog
|
Home