--- /dev/null
+# HG changeset patch
+# User Jon Ludlam <jonathan.ludlam@eu.citrix.com>
+# Date 1317293932 -3600
+# Node ID ba4cba41f5550684719bc95a25f8f51b92fb604f
+# Parent 7998217630e236639825d4db174c852cfa18e709
+[OCAML] Rename the ocamlfind packages
+
+This patch has the same effect as xen-unstable.hg
+c/s 23936:cdb34816a40a.
+
+ocamlfind does not support namespaces, so to avoid
+name clashes the ocamlfind package names have been
+changed. Note that this does not change the names
+of the actual modules themselves.
+
+xb becomes xenbus, xc becomes xenctrl, xl becomes xenlight,
+xs becomes xenstore, eventchn becomes xeneventchn.
+
+Signed-off-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
+
+--- a/tools/ocaml/libs/eventchn/META.in
++++ b/tools/ocaml/libs/eventchn/META.in
+@@ -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"
+--- a/tools/ocaml/libs/eventchn/Makefile
++++ b/tools/ocaml/libs/eventchn/Makefile
+@@ -2,9 +2,11 @@
+ XEN_ROOT=$(TOPLEVEL)/../..
+ include $(TOPLEVEL)/common.make
+
+-OBJS = eventchn
++OBJS = xeneventchn
+ INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+-LIBS = eventchn.cma eventchn.cmxa
++LIBS = xeneventchn.cma xeneventchn.cmxa
++
++LIBS_xeneventchn = $(LDLIBS_libxenctrl)
+
+ all: $(INTF) $(LIBS) $(PROGRAMS)
+
+@@ -12,20 +14,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
+
+--- a/tools/ocaml/libs/eventchn/eventchn.ml
++++ /dev/null
+@@ -1,30 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-exception Error of string
+-
+-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")
+--- a/tools/ocaml/libs/eventchn/eventchn.mli
++++ /dev/null
+@@ -1,31 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-exception Error of string
+-
+-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"
+--- a/tools/ocaml/libs/eventchn/eventchn_stubs.c
++++ /dev/null
+@@ -1,143 +0,0 @@
+-/*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- */
+-
+-#include <sys/types.h>
+-#include <sys/stat.h>
+-#include <fcntl.h>
+-#include <unistd.h>
+-#include <errno.h>
+-#include <stdint.h>
+-#include <sys/ioctl.h>
+-#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);
+-}
+--- /dev/null
++++ b/tools/ocaml/libs/eventchn/xeneventchn.ml
+@@ -0,0 +1,30 @@
++(*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ *)
++
++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")
+--- /dev/null
++++ b/tools/ocaml/libs/eventchn/xeneventchn.mli
+@@ -0,0 +1,31 @@
++(*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ *)
++
++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"
+--- /dev/null
++++ b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c
+@@ -0,0 +1,143 @@
++/*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ */
++
++#include <sys/types.h>
++#include <sys/stat.h>
++#include <fcntl.h>
++#include <unistd.h>
++#include <errno.h>
++#include <stdint.h>
++#include <sys/ioctl.h>
++#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);
++}
+--- a/tools/ocaml/libs/mmap/META.in
++++ b/tools/ocaml/libs/mmap/META.in
+@@ -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"
+--- a/tools/ocaml/libs/mmap/Makefile
++++ b/tools/ocaml/libs/mmap/Makefile
+@@ -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
+
+--- a/tools/ocaml/libs/mmap/mmap.ml
++++ /dev/null
+@@ -1,31 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-type mmap_interface
+-
+-type mmap_prot_flag = RDONLY | WRONLY | RDWR
+-type mmap_map_flag = SHARED | PRIVATE
+-
+-(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *)
+-external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
+- -> int -> int -> mmap_interface = "stub_mmap_init"
+-external unmap: mmap_interface -> unit = "stub_mmap_final"
+-(* read: interface -> start -> length -> data *)
+-external read: mmap_interface -> int -> int -> string = "stub_mmap_read"
+-(* write: interface -> data -> start -> length -> unit *)
+-external write: mmap_interface -> string -> int -> int -> unit = "stub_mmap_write"
+-(* getpagesize: unit -> size of page *)
+-external getpagesize: unit -> int = "stub_mmap_getpagesize"
+--- a/tools/ocaml/libs/mmap/mmap.mli
++++ /dev/null
+@@ -1,28 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-type mmap_interface
+-type mmap_prot_flag = RDONLY | WRONLY | RDWR
+-type mmap_map_flag = SHARED | PRIVATE
+-
+-external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int
+- -> mmap_interface = "stub_mmap_init"
+-external unmap : mmap_interface -> unit = "stub_mmap_final"
+-external read : mmap_interface -> int -> int -> string = "stub_mmap_read"
+-external write : mmap_interface -> string -> int -> int -> unit
+- = "stub_mmap_write"
+-
+-external getpagesize : unit -> int = "stub_mmap_getpagesize"
+--- a/tools/ocaml/libs/mmap/mmap_stubs.c
++++ /dev/null
+@@ -1,136 +0,0 @@
+-/*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- */
+-
+-#include <unistd.h>
+-#include <stdlib.h>
+-#include <sys/mman.h>
+-#include <string.h>
+-#include <errno.h>
+-#include "mmap_stubs.h"
+-
+-#include <caml/mlvalues.h>
+-#include <caml/memory.h>
+-#include <caml/alloc.h>
+-#include <caml/custom.h>
+-#include <caml/fail.h>
+-#include <caml/callback.h>
+-
+-#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
+-
+-static int mmap_interface_init(struct mmap_interface *intf,
+- int fd, int pflag, int mflag,
+- int len, int offset)
+-{
+- intf->len = len;
+- intf->addr = mmap(NULL, len, pflag, mflag, fd, offset);
+- return (intf->addr == MAP_FAILED) ? errno : 0;
+-}
+-
+-CAMLprim value stub_mmap_init(value fd, value pflag, value mflag,
+- value len, value offset)
+-{
+- CAMLparam5(fd, pflag, mflag, len, offset);
+- CAMLlocal1(result);
+- int c_pflag, c_mflag;
+-
+- switch (Int_val(pflag)) {
+- case 0: c_pflag = PROT_READ; break;
+- case 1: c_pflag = PROT_WRITE; break;
+- case 2: c_pflag = PROT_READ|PROT_WRITE; break;
+- default: caml_invalid_argument("protectiontype");
+- }
+-
+- switch (Int_val(mflag)) {
+- case 0: c_mflag = MAP_SHARED; break;
+- case 1: c_mflag = MAP_PRIVATE; break;
+- default: caml_invalid_argument("maptype");
+- }
+-
+- result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
+-
+- if (mmap_interface_init(GET_C_STRUCT(result), Int_val(fd),
+- c_pflag, c_mflag,
+- Int_val(len), Int_val(offset)))
+- caml_failwith("mmap");
+- CAMLreturn(result);
+-}
+-
+-CAMLprim value stub_mmap_final(value interface)
+-{
+- CAMLparam1(interface);
+- struct mmap_interface *intf;
+-
+- intf = GET_C_STRUCT(interface);
+- if (intf->addr != MAP_FAILED)
+- munmap(intf->addr, intf->len);
+- intf->addr = MAP_FAILED;
+-
+- CAMLreturn(Val_unit);
+-}
+-
+-CAMLprim value stub_mmap_read(value interface, value start, value len)
+-{
+- CAMLparam3(interface, start, len);
+- CAMLlocal1(data);
+- struct mmap_interface *intf;
+- int c_start;
+- int c_len;
+-
+- c_start = Int_val(start);
+- c_len = Int_val(len);
+- intf = GET_C_STRUCT(interface);
+-
+- if (c_start > intf->len)
+- caml_invalid_argument("start invalid");
+- if (c_start + c_len > intf->len)
+- caml_invalid_argument("len invalid");
+-
+- data = caml_alloc_string(c_len);
+- memcpy((char *) data, intf->addr + c_start, c_len);
+-
+- CAMLreturn(data);
+-}
+-
+-CAMLprim value stub_mmap_write(value interface, value data,
+- value start, value len)
+-{
+- CAMLparam4(interface, data, start, len);
+- struct mmap_interface *intf;
+- int c_start;
+- int c_len;
+-
+- c_start = Int_val(start);
+- c_len = Int_val(len);
+- intf = GET_C_STRUCT(interface);
+-
+- if (c_start > intf->len)
+- caml_invalid_argument("start invalid");
+- if (c_start + c_len > intf->len)
+- caml_invalid_argument("len invalid");
+-
+- memcpy(intf->addr + c_start, (char *) data, c_len);
+-
+- CAMLreturn(Val_unit);
+-}
+-
+-CAMLprim value stub_mmap_getpagesize(value unit)
+-{
+- CAMLparam1(unit);
+- CAMLlocal1(data);
+-
+- data = Val_int(getpagesize());
+- CAMLreturn(data);
+-}
+--- /dev/null
++++ b/tools/ocaml/libs/mmap/xenmmap.ml
+@@ -0,0 +1,31 @@
++(*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ *)
++
++type mmap_interface
++
++type mmap_prot_flag = RDONLY | WRONLY | RDWR
++type mmap_map_flag = SHARED | PRIVATE
++
++(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *)
++external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
++ -> int -> int -> mmap_interface = "stub_mmap_init"
++external unmap: mmap_interface -> unit = "stub_mmap_final"
++(* read: interface -> start -> length -> data *)
++external read: mmap_interface -> int -> int -> string = "stub_mmap_read"
++(* write: interface -> data -> start -> length -> unit *)
++external write: mmap_interface -> string -> int -> int -> unit = "stub_mmap_write"
++(* getpagesize: unit -> size of page *)
++external getpagesize: unit -> int = "stub_mmap_getpagesize"
+--- /dev/null
++++ b/tools/ocaml/libs/mmap/xenmmap.mli
+@@ -0,0 +1,28 @@
++(*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ *)
++
++type mmap_interface
++type mmap_prot_flag = RDONLY | WRONLY | RDWR
++type mmap_map_flag = SHARED | PRIVATE
++
++external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int
++ -> mmap_interface = "stub_mmap_init"
++external unmap : mmap_interface -> unit = "stub_mmap_final"
++external read : mmap_interface -> int -> int -> string = "stub_mmap_read"
++external write : mmap_interface -> string -> int -> int -> unit
++ = "stub_mmap_write"
++
++external getpagesize : unit -> int = "stub_mmap_getpagesize"
+--- /dev/null
++++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c
+@@ -0,0 +1,136 @@
++/*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ */
++
++#include <unistd.h>
++#include <stdlib.h>
++#include <sys/mman.h>
++#include <string.h>
++#include <errno.h>
++#include "mmap_stubs.h"
++
++#include <caml/mlvalues.h>
++#include <caml/memory.h>
++#include <caml/alloc.h>
++#include <caml/custom.h>
++#include <caml/fail.h>
++#include <caml/callback.h>
++
++#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
++
++static int mmap_interface_init(struct mmap_interface *intf,
++ int fd, int pflag, int mflag,
++ int len, int offset)
++{
++ intf->len = len;
++ intf->addr = mmap(NULL, len, pflag, mflag, fd, offset);
++ return (intf->addr == MAP_FAILED) ? errno : 0;
++}
++
++CAMLprim value stub_mmap_init(value fd, value pflag, value mflag,
++ value len, value offset)
++{
++ CAMLparam5(fd, pflag, mflag, len, offset);
++ CAMLlocal1(result);
++ int c_pflag, c_mflag;
++
++ switch (Int_val(pflag)) {
++ case 0: c_pflag = PROT_READ; break;
++ case 1: c_pflag = PROT_WRITE; break;
++ case 2: c_pflag = PROT_READ|PROT_WRITE; break;
++ default: caml_invalid_argument("protectiontype");
++ }
++
++ switch (Int_val(mflag)) {
++ case 0: c_mflag = MAP_SHARED; break;
++ case 1: c_mflag = MAP_PRIVATE; break;
++ default: caml_invalid_argument("maptype");
++ }
++
++ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
++
++ if (mmap_interface_init(GET_C_STRUCT(result), Int_val(fd),
++ c_pflag, c_mflag,
++ Int_val(len), Int_val(offset)))
++ caml_failwith("mmap");
++ CAMLreturn(result);
++}
++
++CAMLprim value stub_mmap_final(value interface)
++{
++ CAMLparam1(interface);
++ struct mmap_interface *intf;
++
++ intf = GET_C_STRUCT(interface);
++ if (intf->addr != MAP_FAILED)
++ munmap(intf->addr, intf->len);
++ intf->addr = MAP_FAILED;
++
++ CAMLreturn(Val_unit);
++}
++
++CAMLprim value stub_mmap_read(value interface, value start, value len)
++{
++ CAMLparam3(interface, start, len);
++ CAMLlocal1(data);
++ struct mmap_interface *intf;
++ int c_start;
++ int c_len;
++
++ c_start = Int_val(start);
++ c_len = Int_val(len);
++ intf = GET_C_STRUCT(interface);
++
++ if (c_start > intf->len)
++ caml_invalid_argument("start invalid");
++ if (c_start + c_len > intf->len)
++ caml_invalid_argument("len invalid");
++
++ data = caml_alloc_string(c_len);
++ memcpy((char *) data, intf->addr + c_start, c_len);
++
++ CAMLreturn(data);
++}
++
++CAMLprim value stub_mmap_write(value interface, value data,
++ value start, value len)
++{
++ CAMLparam4(interface, data, start, len);
++ struct mmap_interface *intf;
++ int c_start;
++ int c_len;
++
++ c_start = Int_val(start);
++ c_len = Int_val(len);
++ intf = GET_C_STRUCT(interface);
++
++ if (c_start > intf->len)
++ caml_invalid_argument("start invalid");
++ if (c_start + c_len > intf->len)
++ caml_invalid_argument("len invalid");
++
++ memcpy(intf->addr + c_start, (char *) data, c_len);
++
++ CAMLreturn(Val_unit);
++}
++
++CAMLprim value stub_mmap_getpagesize(value unit)
++{
++ CAMLparam1(unit);
++ CAMLlocal1(data);
++
++ data = Val_int(getpagesize());
++ CAMLreturn(data);
++}
+--- a/tools/ocaml/libs/xb/META.in
++++ b/tools/ocaml/libs/xb/META.in
+@@ -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"
+--- a/tools/ocaml/libs/xb/Makefile
++++ b/tools/ocaml/libs/xb/Makefile
+@@ -4,6 +4,7 @@
+
+ CFLAGS += -I../mmap
+ OCAMLINCLUDE += -I ../mmap
++OCAMLOPTFLAGS += -for-pack Xenbus
+
+ .NOTPARALLEL:
+ # Ocaml is such a PITA!
+@@ -13,7 +14,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)
+
+@@ -23,22 +24,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.cmi xenbus.cmx *.a *.so
+
+ .PHONY: uninstall
+ uninstall:
+- ocamlfind remove -destdir $(OCAMLDESTDIR) xb
++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenbus
+
+ include $(TOPLEVEL)/Makefile.rules
+--- a/tools/ocaml/libs/xb/xb.ml
++++ b/tools/ocaml/libs/xb/xb.ml
+@@ -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")
+--- a/tools/ocaml/libs/xb/xb.mli
++++ b/tools/ocaml/libs/xb/xb.mli
+@@ -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
+--- a/tools/ocaml/libs/xb/xb_stubs.c
++++ /dev/null
+@@ -1,71 +0,0 @@
+-/*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- */
+-
+-#include <unistd.h>
+-#include <stdlib.h>
+-#include <sys/mman.h>
+-#include <string.h>
+-#include <errno.h>
+-
+-#include <caml/mlvalues.h>
+-#include <caml/memory.h>
+-#include <caml/alloc.h>
+-#include <caml/custom.h>
+-#include <caml/fail.h>
+-#include <caml/callback.h>
+-
+-#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);
+-}
+--- /dev/null
++++ b/tools/ocaml/libs/xb/xenbus_stubs.c
+@@ -0,0 +1,71 @@
++/*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ */
++
++#include <unistd.h>
++#include <stdlib.h>
++#include <sys/mman.h>
++#include <string.h>
++#include <errno.h>
++
++#include <caml/mlvalues.h>
++#include <caml/memory.h>
++#include <caml/alloc.h>
++#include <caml/custom.h>
++#include <caml/fail.h>
++#include <caml/callback.h>
++
++#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);
++}
+--- a/tools/ocaml/libs/xb/xs_ring.ml
++++ b/tools/ocaml/libs/xb/xs_ring.ml
+@@ -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"
+--- a/tools/ocaml/libs/xc/META.in
++++ b/tools/ocaml/libs/xc/META.in
+@@ -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"
+--- a/tools/ocaml/libs/xc/Makefile
++++ b/tools/ocaml/libs/xc/Makefile
+@@ -5,16 +5,16 @@
+ CFLAGS += -I../mmap -I./ -I$(XEN_ROOT)/tools/libxc
+ OCAMLINCLUDE += -I ../mmap -I ../uuid -I $(XEN_ROOT)/tools/libxc
+
+-OBJS = xc
+-INTF = xc.cmi
+-LIBS = xc.cma xc.cmxa
++OBJS = xenctrl
++INTF = xenctrl.cmi
++LIBS = xenctrl.cma xenctrl.cmxa
+
+-LIBS_xc = -L$(XEN_ROOT)/tools/libxc -lxenctrl -lxenguest
++LIBS_xenctrl = -L$(XEN_ROOT)/tools/libxc -lxenctrl -lxenguest
+
+-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
+--- a/tools/ocaml/libs/xc/xc.ml
++++ /dev/null
+@@ -1,326 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-(** *)
+-type domid = int
+-
+-(* ** xenctrl.h ** *)
+-
+-type vcpuinfo =
+-{
+- online: bool;
+- blocked: bool;
+- running: bool;
+- cputime: int64;
+- cpumap: int32;
+-}
+-
+-type domaininfo =
+-{
+- domid : domid;
+- dying : bool;
+- shutdown : bool;
+- paused : bool;
+- blocked : bool;
+- running : bool;
+- hvm_guest : bool;
+- shutdown_code : int;
+- total_memory_pages: nativeint;
+- max_memory_pages : nativeint;
+- shared_info_frame : int64;
+- cpu_time : int64;
+- nr_online_vcpus : int;
+- max_vcpu_id : int;
+- ssidref : int32;
+- handle : int array;
+-}
+-
+-type sched_control =
+-{
+- weight : int;
+- cap : int;
+-}
+-
+-type physinfo_cap_flag =
+- | CAP_HVM
+- | CAP_DirectIO
+-
+-type physinfo =
+-{
+- threads_per_core : int;
+- cores_per_socket : int;
+- nr_cpus : int;
+- max_node_id : int;
+- cpu_khz : int;
+- total_pages : nativeint;
+- free_pages : nativeint;
+- scrub_pages : nativeint;
+- (* XXX hw_cap *)
+- capabilities : physinfo_cap_flag list;
+-}
+-
+-type version =
+-{
+- major : int;
+- minor : int;
+- extra : string;
+-}
+-
+-
+-type compile_info =
+-{
+- compiler : string;
+- compile_by : string;
+- compile_domain : string;
+- compile_date : string;
+-}
+-
+-type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt
+-
+-type domain_create_flag = CDF_HVM | CDF_HAP
+-
+-exception Error of string
+-
+-type handle
+-
+-(* this is only use by coredumping *)
+-external sizeof_core_header: unit -> int
+- = "stub_sizeof_core_header"
+-external sizeof_vcpu_guest_context: unit -> int
+- = "stub_sizeof_vcpu_guest_context"
+-external sizeof_xen_pfn: unit -> int = "stub_sizeof_xen_pfn"
+-(* end of use *)
+-
+-external interface_open: unit -> handle = "stub_xc_interface_open"
+-external interface_close: handle -> unit = "stub_xc_interface_close"
+-
+-external 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")
+--- a/tools/ocaml/libs/xc/xc.mli
++++ /dev/null
+@@ -1,184 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-type domid = int
+-type vcpuinfo = {
+- online : bool;
+- blocked : bool;
+- running : bool;
+- cputime : int64;
+- cpumap : int32;
+-}
+-type domaininfo = {
+- domid : domid;
+- dying : bool;
+- shutdown : bool;
+- paused : bool;
+- blocked : bool;
+- running : bool;
+- hvm_guest : bool;
+- shutdown_code : int;
+- total_memory_pages : nativeint;
+- max_memory_pages : nativeint;
+- shared_info_frame : int64;
+- cpu_time : int64;
+- nr_online_vcpus : int;
+- max_vcpu_id : int;
+- ssidref : int32;
+- handle : int array;
+-}
+-type sched_control = { weight : int; cap : int; }
+-type physinfo_cap_flag = CAP_HVM | CAP_DirectIO
+-type physinfo = {
+- threads_per_core : int;
+- cores_per_socket : int;
+- nr_cpus : int;
+- max_node_id : int;
+- cpu_khz : int;
+- total_pages : nativeint;
+- free_pages : nativeint;
+- scrub_pages : nativeint;
+- capabilities : physinfo_cap_flag list;
+-}
+-type version = { major : int; minor : int; extra : string; }
+-type compile_info = {
+- compiler : string;
+- compile_by : string;
+- compile_domain : string;
+- compile_date : string;
+-}
+-type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt
+-
+-type domain_create_flag = CDF_HVM | CDF_HAP
+-
+-exception Error of string
+-type handle
+-external sizeof_core_header : unit -> int = "stub_sizeof_core_header"
+-external sizeof_vcpu_guest_context : unit -> int
+- = "stub_sizeof_vcpu_guest_context"
+-external sizeof_xen_pfn : unit -> int = "stub_sizeof_xen_pfn"
+-external interface_open : unit -> handle = "stub_xc_interface_open"
+-external 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"
+-
+--- a/tools/ocaml/libs/xc/xc_stubs.c
++++ /dev/null
+@@ -1,1161 +0,0 @@
+-/*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- */
+-
+-#define _XOPEN_SOURCE 600
+-#include <stdlib.h>
+-#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:
+- */
+--- /dev/null
++++ b/tools/ocaml/libs/xc/xenctrl.ml
+@@ -0,0 +1,326 @@
++(*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ *)
++
++(** *)
++type domid = int
++
++(* ** xenctrl.h ** *)
++
++type vcpuinfo =
++{
++ online: bool;
++ blocked: bool;
++ running: bool;
++ cputime: int64;
++ cpumap: int32;
++}
++
++type domaininfo =
++{
++ domid : domid;
++ dying : bool;
++ shutdown : bool;
++ paused : bool;
++ blocked : bool;
++ running : bool;
++ hvm_guest : bool;
++ shutdown_code : int;
++ total_memory_pages: nativeint;
++ max_memory_pages : nativeint;
++ shared_info_frame : int64;
++ cpu_time : int64;
++ nr_online_vcpus : int;
++ max_vcpu_id : int;
++ ssidref : int32;
++ handle : int array;
++}
++
++type sched_control =
++{
++ weight : int;
++ cap : int;
++}
++
++type physinfo_cap_flag =
++ | CAP_HVM
++ | CAP_DirectIO
++
++type physinfo =
++{
++ threads_per_core : int;
++ cores_per_socket : int;
++ nr_cpus : int;
++ max_node_id : int;
++ cpu_khz : int;
++ total_pages : nativeint;
++ free_pages : nativeint;
++ scrub_pages : nativeint;
++ (* XXX hw_cap *)
++ capabilities : physinfo_cap_flag list;
++}
++
++type version =
++{
++ major : int;
++ minor : int;
++ extra : string;
++}
++
++
++type compile_info =
++{
++ compiler : string;
++ compile_by : string;
++ compile_domain : string;
++ compile_date : string;
++}
++
++type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt
++
++type domain_create_flag = CDF_HVM | CDF_HAP
++
++exception Error of string
++
++type handle
++
++(* this is only use by coredumping *)
++external sizeof_core_header: unit -> int
++ = "stub_sizeof_core_header"
++external sizeof_vcpu_guest_context: unit -> int
++ = "stub_sizeof_vcpu_guest_context"
++external sizeof_xen_pfn: unit -> int = "stub_sizeof_xen_pfn"
++(* end of use *)
++
++external interface_open: unit -> handle = "stub_xc_interface_open"
++external interface_close: handle -> unit = "stub_xc_interface_close"
++
++external 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")
+--- /dev/null
++++ b/tools/ocaml/libs/xc/xenctrl.mli
+@@ -0,0 +1,184 @@
++(*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ *)
++
++type domid = int
++type vcpuinfo = {
++ online : bool;
++ blocked : bool;
++ running : bool;
++ cputime : int64;
++ cpumap : int32;
++}
++type domaininfo = {
++ domid : domid;
++ dying : bool;
++ shutdown : bool;
++ paused : bool;
++ blocked : bool;
++ running : bool;
++ hvm_guest : bool;
++ shutdown_code : int;
++ total_memory_pages : nativeint;
++ max_memory_pages : nativeint;
++ shared_info_frame : int64;
++ cpu_time : int64;
++ nr_online_vcpus : int;
++ max_vcpu_id : int;
++ ssidref : int32;
++ handle : int array;
++}
++type sched_control = { weight : int; cap : int; }
++type physinfo_cap_flag = CAP_HVM | CAP_DirectIO
++type physinfo = {
++ threads_per_core : int;
++ cores_per_socket : int;
++ nr_cpus : int;
++ max_node_id : int;
++ cpu_khz : int;
++ total_pages : nativeint;
++ free_pages : nativeint;
++ scrub_pages : nativeint;
++ capabilities : physinfo_cap_flag list;
++}
++type version = { major : int; minor : int; extra : string; }
++type compile_info = {
++ compiler : string;
++ compile_by : string;
++ compile_domain : string;
++ compile_date : string;
++}
++type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt
++
++type domain_create_flag = CDF_HVM | CDF_HAP
++
++exception Error of string
++type handle
++external sizeof_core_header : unit -> int = "stub_sizeof_core_header"
++external sizeof_vcpu_guest_context : unit -> int
++ = "stub_sizeof_vcpu_guest_context"
++external sizeof_xen_pfn : unit -> int = "stub_sizeof_xen_pfn"
++external interface_open : unit -> handle = "stub_xc_interface_open"
++external 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"
++
+--- /dev/null
++++ b/tools/ocaml/libs/xc/xenctrl_stubs.c
+@@ -0,0 +1,1161 @@
++/*
++ * Copyright (C) 2006-2007 XenSource Ltd.
++ * Copyright (C) 2008 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ */
++
++#define _XOPEN_SOURCE 600
++#include <stdlib.h>
++#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:
++ */
+--- a/tools/ocaml/libs/xl/Makefile
++++ b/tools/ocaml/libs/xl/Makefile
+@@ -2,14 +2,14 @@
+ XEN_ROOT=$(TOPLEVEL)/../..
+ include $(TOPLEVEL)/common.make
+
+-OBJS = xl
+-INTF = xl.cmi
+-LIBS = xl.cma xl.cmxa
++OBJS = xenlight
++INTF = xenlight.cmi
++LIBS = xenlight.cma xenlight.cmxa
+
+-xl_OBJS = $(OBJS)
+-xl_C_OBJS = xl_stubs
++xenlight_OBJS = $(OBJS)
++xenlight_C_OBJS = xenlight_stubs
+
+-OCAML_LIBRARY = xl
++OCAML_LIBRARY = xenlight
+
+ all: $(INTF) $(LIBS)
+
+@@ -18,11 +18,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
+--- /dev/null
++++ b/tools/ocaml/libs/xl/xenlight_stubs.c
+@@ -0,0 +1,729 @@
++/*
++ * Copyright (C) 2009-2010 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ */
++
++#include <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;
++
++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);
++}
++
++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_init(&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]);
++ }
++}
++
++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);
++}
++
++static int domain_create_info_val (caml_gc *gc, libxl_domain_create_info *c_val, value v)
++{
++ CAMLparam1(v);
++ CAMLlocal1(a);
++ uint8_t *uuid = libxl_uuid_bytearray(&c_val->uuid);
++ int i;
++
++ c_val->hvm = Bool_val(Field(v, 0));
++ c_val->hap = Bool_val(Field(v, 1));
++ c_val->oos = Bool_val(Field(v, 2));
++ c_val->ssidref = Int32_val(Field(v, 3));
++ c_val->name = dup_String_val(gc, Field(v, 4));
++ a = Field(v, 5);
++ for (i = 0; i < 16; i++)
++ uuid[i] = Int_val(Field(a, i));
++ string_string_tuple_array_val(gc, &(c_val->xsdata), Field(v, 6));
++ string_string_tuple_array_val(gc, &(c_val->platformdata), Field(v, 7));
++
++ c_val->poolid = Int32_val(Field(v, 8));
++ c_val->poolname = dup_String_val(gc, Field(v, 9));
++
++ CAMLreturn(0);
++}
++
++static int domain_build_info_val (caml_gc *gc, libxl_domain_build_info *c_val, value v)
++{
++ CAMLparam1(v);
++ CAMLlocal1(infopriv);
++
++ c_val->max_vcpus = Int_val(Field(v, 0));
++ c_val->cur_vcpus = Int_val(Field(v, 1));
++ c_val->max_memkb = Int64_val(Field(v, 2));
++ c_val->target_memkb = Int64_val(Field(v, 3));
++ c_val->video_memkb = Int64_val(Field(v, 4));
++ c_val->shadow_memkb = Int64_val(Field(v, 5));
++ c_val->kernel.path = dup_String_val(gc, Field(v, 6));
++ c_val->is_hvm = Tag_val(Field(v, 7)) == 0;
++ infopriv = Field(Field(v, 7), 0);
++ if (c_val->hvm) {
++ c_val->u.hvm.pae = Bool_val(Field(infopriv, 0));
++ c_val->u.hvm.apic = Bool_val(Field(infopriv, 1));
++ c_val->u.hvm.acpi = Bool_val(Field(infopriv, 2));
++ c_val->u.hvm.nx = Bool_val(Field(infopriv, 3));
++ c_val->u.hvm.viridian = Bool_val(Field(infopriv, 4));
++ c_val->u.hvm.timeoffset = dup_String_val(gc, Field(infopriv, 5));
++ c_val->u.hvm.timer_mode = Int_val(Field(infopriv, 6));
++ c_val->u.hvm.hpet = Int_val(Field(infopriv, 7));
++ c_val->u.hvm.vpt_align = Int_val(Field(infopriv, 8));
++ } else {
++ c_val->u.pv.slack_memkb = Int64_val(Field(infopriv, 0));
++ c_val->u.pv.cmdline = dup_String_val(gc, Field(infopriv, 1));
++ c_val->u.pv.ramdisk.path = dup_String_val(gc, Field(infopriv, 2));
++ c_val->u.pv.features = dup_String_val(gc, Field(infopriv, 3));
++ }
++
++ CAMLreturn(0);
++}
++#endif
++
++static int device_disk_val(caml_gc *gc, libxl_device_disk *c_val, value v)
++{
++ CAMLparam1(v);
++
++ c_val->backend_domid = Int_val(Field(v, 0));
++ c_val->pdev_path = dup_String_val(gc, Field(v, 1));
++ c_val->vdev = dup_String_val(gc, Field(v, 2));
++ c_val->backend = (Int_val(Field(v, 3)));
++ c_val->format = (Int_val(Field(v, 4)));
++ c_val->unpluggable = Bool_val(Field(v, 5));
++ c_val->readwrite = Bool_val(Field(v, 6));
++ c_val->is_cdrom = Bool_val(Field(v, 7));
++
++ CAMLreturn(0);
++}
++
++static int device_nic_val(caml_gc *gc, libxl_device_nic *c_val, value v)
++{
++ CAMLparam1(v);
++ int i;
++ int ret = 0;
++ c_val->backend_domid = Int_val(Field(v, 0));
++ c_val->devid = Int_val(Field(v, 1));
++ c_val->mtu = Int_val(Field(v, 2));
++ c_val->model = dup_String_val(gc, Field(v, 3));
++
++ if (Wosize_val(Field(v, 4)) != 6) {
++ ret = 1;
++ goto out;
++ }
++ for (i = 0; i < 6; i++)
++ c_val->mac[i] = Int_val(Field(Field(v, 4), i));
++
++ /* not handling c_val->ip */
++ c_val->bridge = dup_String_val(gc, Field(v, 5));
++ c_val->ifname = dup_String_val(gc, Field(v, 6));
++ c_val->script = dup_String_val(gc, Field(v, 7));
++ c_val->nictype = (Int_val(Field(v, 8))) + NICTYPE_IOEMU;
++
++out:
++ CAMLreturn(ret);
++}
++
++static int device_console_val(caml_gc *gc, libxl_device_console *c_val, value v)
++{
++ CAMLparam1(v);
++
++ c_val->backend_domid = Int_val(Field(v, 0));
++ c_val->devid = Int_val(Field(v, 1));
++ c_val->consback = (Int_val(Field(v, 2))) + LIBXL_CONSBACK_XENCONSOLED;
++
++ CAMLreturn(0);
++}
++
++static int device_vkb_val(caml_gc *gc, libxl_device_vkb *c_val, value v)
++{
++ CAMLparam1(v);
++
++ c_val->backend_domid = Int_val(Field(v, 0));
++ c_val->devid = Int_val(Field(v, 1));
++
++ CAMLreturn(0);
++}
++
++static int device_vfb_val(caml_gc *gc, libxl_device_vfb *c_val, value v)
++{
++ CAMLparam1(v);
++
++ c_val->backend_domid = Int_val(Field(v, 0));
++ c_val->devid = Int_val(Field(v, 1));
++ c_val->vnc = Bool_val(Field(v, 2));
++ c_val->vnclisten = dup_String_val(gc, Field(v, 3));
++ c_val->vncpasswd = dup_String_val(gc, Field(v, 4));
++ c_val->vncdisplay = Int_val(Field(v, 5));
++ c_val->keymap = dup_String_val(gc, Field(v, 6));
++ c_val->sdl = Bool_val(Field(v, 7));
++ c_val->opengl = Bool_val(Field(v, 8));
++ c_val->display = dup_String_val(gc, Field(v, 9));
++ c_val->xauthority = dup_String_val(gc, Field(v, 10));
++
++ CAMLreturn(0);
++}
++
++static int device_pci_val(caml_gc *gc, libxl_device_pci *c_val, value v)
++{
++ union {
++ unsigned int value;
++ struct {
++ unsigned int reserved1:2;
++ unsigned int reg:6;
++ unsigned int func:3;
++ unsigned int dev:5;
++ unsigned int bus:8;
++ unsigned int reserved2:7;
++ unsigned int enable:1;
++ }fields;
++ }u;
++ CAMLparam1(v);
++
++ /* FIXME: propagate API change to ocaml */
++ u.value = Int_val(Field(v, 0));
++ c_val->reg = u.fields.reg;
++ c_val->func = u.fields.func;
++ c_val->dev = u.fields.dev;
++ c_val->bus = u.fields.bus;
++ c_val->enable = u.fields.enable;
++
++ c_val->domain = Int_val(Field(v, 1));
++ c_val->vdevfn = Int_val(Field(v, 2));
++ c_val->msitranslate = Bool_val(Field(v, 3));
++ c_val->power_mgmt = Bool_val(Field(v, 4));
++
++ CAMLreturn(0);
++}
++
++static int sched_credit_val(caml_gc *gc, libxl_sched_credit *c_val, value v)
++{
++ CAMLparam1(v);
++ c_val->weight = Int_val(Field(v, 0));
++ c_val->cap = Int_val(Field(v, 1));
++ CAMLreturn(0);
++}
++
++static int domain_build_state_val(caml_gc *gc, libxl_domain_build_state *c_val, value v)
++{
++ CAMLparam1(v);
++
++ c_val->store_port = Int_val(Field(v, 0));
++ c_val->store_mfn = Int64_val(Field(v, 1));
++ c_val->console_port = Int_val(Field(v, 2));
++ c_val->console_mfn = Int64_val(Field(v, 3));
++
++ CAMLreturn(0);
++}
++
++static value Val_sched_credit(libxl_sched_credit *c_val)
++{
++ CAMLparam0();
++ CAMLlocal1(v);
++
++ v = caml_alloc_tuple(2);
++
++ Store_field(v, 0, Val_int(c_val->weight));
++ Store_field(v, 1, Val_int(c_val->cap));
++
++ CAMLreturn(v);
++}
++
++static value Val_physinfo(libxl_physinfo *c_val)
++{
++ CAMLparam0();
++ CAMLlocal2(v, hwcap);
++ int i;
++
++ hwcap = caml_alloc_tuple(8);
++ for (i = 0; i < 8; i++)
++ Store_field(hwcap, i, caml_copy_int32(c_val->hw_cap[i]));
++
++ v = caml_alloc_tuple(11);
++ Store_field(v, 0, Val_int(c_val->threads_per_core));
++ Store_field(v, 1, Val_int(c_val->cores_per_socket));
++ Store_field(v, 2, Val_int(c_val->max_cpu_id));
++ Store_field(v, 3, Val_int(c_val->nr_cpus));
++ Store_field(v, 4, Val_int(c_val->cpu_khz));
++ Store_field(v, 5, caml_copy_int64(c_val->total_pages));
++ Store_field(v, 6, caml_copy_int64(c_val->free_pages));
++ Store_field(v, 7, caml_copy_int64(c_val->scrub_pages));
++ Store_field(v, 8, Val_int(c_val->nr_nodes));
++ Store_field(v, 9, hwcap);
++ Store_field(v, 10, caml_copy_int32(c_val->phys_cap));
++
++ CAMLreturn(v);
++}
++
++value stub_xl_disk_add(value info, value domid)
++{
++ CAMLparam2(info, domid);
++ libxl_device_disk c_info;
++ int ret;
++ INIT_STRUCT();
++
++ device_disk_val(&gc, &c_info, info);
++ c_info.domid = Int_val(domid);
++
++ 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_disk_remove(value info, value domid)
++{
++ CAMLparam2(info, domid);
++ libxl_device_disk c_info;
++ int ret;
++ INIT_STRUCT();
++
++ device_disk_val(&gc, &c_info, info);
++ c_info.domid = Int_val(domid);
++
++ INIT_CTX();
++ ret = libxl_device_disk_del(&ctx, &c_info, 0);
++ if (ret != 0)
++ failwith_xl("disk_remove", &lg);
++ FREE_CTX();
++ CAMLreturn(Val_unit);
++}
++
++value stub_xl_nic_add(value info, value domid)
++{
++ CAMLparam2(info, domid);
++ libxl_device_nic c_info;
++ int ret;
++ INIT_STRUCT();
++
++ device_nic_val(&gc, &c_info, info);
++ c_info.domid = Int_val(domid);
++
++ 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_nic_remove(value info, value domid)
++{
++ CAMLparam2(info, domid);
++ libxl_device_nic c_info;
++ int ret;
++ INIT_STRUCT();
++
++ device_nic_val(&gc, &c_info, info);
++ c_info.domid = Int_val(domid);
++
++ INIT_CTX();
++ ret = libxl_device_nic_del(&ctx, &c_info, 0);
++ if (ret != 0)
++ failwith_xl("nic_remove", &lg);
++ FREE_CTX();
++ CAMLreturn(Val_unit);
++}
++
++value stub_xl_console_add(value info, value state, value domid)
++{
++ CAMLparam3(info, state, domid);
++ libxl_device_console c_info;
++ libxl_domain_build_state c_state;
++ int ret;
++ INIT_STRUCT();
++
++ device_console_val(&gc, &c_info, info);
++ domain_build_state_val(&gc, &c_state, state);
++ c_info.domid = Int_val(domid);
++ c_info.build_state = &c_state;
++
++ 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_vkb_add(value info, value domid)
++{
++ CAMLparam2(info, domid);
++ libxl_device_vkb c_info;
++ int ret;
++ INIT_STRUCT();
++
++ device_vkb_val(&gc, &c_info, info);
++ c_info.domid = Int_val(domid);
++
++ 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_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_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_vfb_add(value info, value domid)
++{
++ CAMLparam2(info, domid);
++ libxl_device_vfb c_info;
++ int ret;
++ INIT_STRUCT();
++
++ device_vfb_val(&gc, &c_info, info);
++ c_info.domid = Int_val(domid);
++
++ 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_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_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_pci_add(value info, value domid)
++{
++ CAMLparam2(info, domid);
++ libxl_device_pci c_info;
++ int ret;
++ INIT_STRUCT();
++
++ device_pci_val(&gc, &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_pci_remove(value info, value domid)
++{
++ CAMLparam2(info, domid);
++ libxl_device_pci c_info;
++ int ret;
++ INIT_STRUCT();
++
++ device_pci_val(&gc, &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_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) + POWER_BUTTON);
++ if (ret != 0)
++ failwith_xl("button_press", &lg);
++ FREE_CTX();
++
++ CAMLreturn(Val_unit);
++}
++
++value stub_xl_physinfo(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(&c_physinfo);
++ CAMLreturn(physinfo);
++}
++
++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(&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, &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:
++ */
+--- a/tools/ocaml/libs/xl/xl_stubs.c
++++ /dev/null
+@@ -1,729 +0,0 @@
+-/*
+- * Copyright (C) 2009-2010 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- */
+-
+-#include <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;
+-
+-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);
+-}
+-
+-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_init(&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]);
+- }
+-}
+-
+-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);
+-}
+-
+-static int domain_create_info_val (caml_gc *gc, libxl_domain_create_info *c_val, value v)
+-{
+- CAMLparam1(v);
+- CAMLlocal1(a);
+- uint8_t *uuid = libxl_uuid_bytearray(&c_val->uuid);
+- int i;
+-
+- c_val->hvm = Bool_val(Field(v, 0));
+- c_val->hap = Bool_val(Field(v, 1));
+- c_val->oos = Bool_val(Field(v, 2));
+- c_val->ssidref = Int32_val(Field(v, 3));
+- c_val->name = dup_String_val(gc, Field(v, 4));
+- a = Field(v, 5);
+- for (i = 0; i < 16; i++)
+- uuid[i] = Int_val(Field(a, i));
+- string_string_tuple_array_val(gc, &(c_val->xsdata), Field(v, 6));
+- string_string_tuple_array_val(gc, &(c_val->platformdata), Field(v, 7));
+-
+- c_val->poolid = Int32_val(Field(v, 8));
+- c_val->poolname = dup_String_val(gc, Field(v, 9));
+-
+- CAMLreturn(0);
+-}
+-
+-static int domain_build_info_val (caml_gc *gc, libxl_domain_build_info *c_val, value v)
+-{
+- CAMLparam1(v);
+- CAMLlocal1(infopriv);
+-
+- c_val->max_vcpus = Int_val(Field(v, 0));
+- c_val->cur_vcpus = Int_val(Field(v, 1));
+- c_val->max_memkb = Int64_val(Field(v, 2));
+- c_val->target_memkb = Int64_val(Field(v, 3));
+- c_val->video_memkb = Int64_val(Field(v, 4));
+- c_val->shadow_memkb = Int64_val(Field(v, 5));
+- c_val->kernel.path = dup_String_val(gc, Field(v, 6));
+- c_val->is_hvm = Tag_val(Field(v, 7)) == 0;
+- infopriv = Field(Field(v, 7), 0);
+- if (c_val->hvm) {
+- c_val->u.hvm.pae = Bool_val(Field(infopriv, 0));
+- c_val->u.hvm.apic = Bool_val(Field(infopriv, 1));
+- c_val->u.hvm.acpi = Bool_val(Field(infopriv, 2));
+- c_val->u.hvm.nx = Bool_val(Field(infopriv, 3));
+- c_val->u.hvm.viridian = Bool_val(Field(infopriv, 4));
+- c_val->u.hvm.timeoffset = dup_String_val(gc, Field(infopriv, 5));
+- c_val->u.hvm.timer_mode = Int_val(Field(infopriv, 6));
+- c_val->u.hvm.hpet = Int_val(Field(infopriv, 7));
+- c_val->u.hvm.vpt_align = Int_val(Field(infopriv, 8));
+- } else {
+- c_val->u.pv.slack_memkb = Int64_val(Field(infopriv, 0));
+- c_val->u.pv.cmdline = dup_String_val(gc, Field(infopriv, 1));
+- c_val->u.pv.ramdisk.path = dup_String_val(gc, Field(infopriv, 2));
+- c_val->u.pv.features = dup_String_val(gc, Field(infopriv, 3));
+- }
+-
+- CAMLreturn(0);
+-}
+-#endif
+-
+-static int device_disk_val(caml_gc *gc, libxl_device_disk *c_val, value v)
+-{
+- CAMLparam1(v);
+-
+- c_val->backend_domid = Int_val(Field(v, 0));
+- c_val->pdev_path = dup_String_val(gc, Field(v, 1));
+- c_val->vdev = dup_String_val(gc, Field(v, 2));
+- c_val->backend = (Int_val(Field(v, 3)));
+- c_val->format = (Int_val(Field(v, 4)));
+- c_val->unpluggable = Bool_val(Field(v, 5));
+- c_val->readwrite = Bool_val(Field(v, 6));
+- c_val->is_cdrom = Bool_val(Field(v, 7));
+-
+- CAMLreturn(0);
+-}
+-
+-static int device_nic_val(caml_gc *gc, libxl_device_nic *c_val, value v)
+-{
+- CAMLparam1(v);
+- int i;
+- int ret = 0;
+- c_val->backend_domid = Int_val(Field(v, 0));
+- c_val->devid = Int_val(Field(v, 1));
+- c_val->mtu = Int_val(Field(v, 2));
+- c_val->model = dup_String_val(gc, Field(v, 3));
+-
+- if (Wosize_val(Field(v, 4)) != 6) {
+- ret = 1;
+- goto out;
+- }
+- for (i = 0; i < 6; i++)
+- c_val->mac[i] = Int_val(Field(Field(v, 4), i));
+-
+- /* not handling c_val->ip */
+- c_val->bridge = dup_String_val(gc, Field(v, 5));
+- c_val->ifname = dup_String_val(gc, Field(v, 6));
+- c_val->script = dup_String_val(gc, Field(v, 7));
+- c_val->nictype = (Int_val(Field(v, 8))) + NICTYPE_IOEMU;
+-
+-out:
+- CAMLreturn(ret);
+-}
+-
+-static int device_console_val(caml_gc *gc, libxl_device_console *c_val, value v)
+-{
+- CAMLparam1(v);
+-
+- c_val->backend_domid = Int_val(Field(v, 0));
+- c_val->devid = Int_val(Field(v, 1));
+- c_val->consback = (Int_val(Field(v, 2))) + LIBXL_CONSBACK_XENCONSOLED;
+-
+- CAMLreturn(0);
+-}
+-
+-static int device_vkb_val(caml_gc *gc, libxl_device_vkb *c_val, value v)
+-{
+- CAMLparam1(v);
+-
+- c_val->backend_domid = Int_val(Field(v, 0));
+- c_val->devid = Int_val(Field(v, 1));
+-
+- CAMLreturn(0);
+-}
+-
+-static int device_vfb_val(caml_gc *gc, libxl_device_vfb *c_val, value v)
+-{
+- CAMLparam1(v);
+-
+- c_val->backend_domid = Int_val(Field(v, 0));
+- c_val->devid = Int_val(Field(v, 1));
+- c_val->vnc = Bool_val(Field(v, 2));
+- c_val->vnclisten = dup_String_val(gc, Field(v, 3));
+- c_val->vncpasswd = dup_String_val(gc, Field(v, 4));
+- c_val->vncdisplay = Int_val(Field(v, 5));
+- c_val->keymap = dup_String_val(gc, Field(v, 6));
+- c_val->sdl = Bool_val(Field(v, 7));
+- c_val->opengl = Bool_val(Field(v, 8));
+- c_val->display = dup_String_val(gc, Field(v, 9));
+- c_val->xauthority = dup_String_val(gc, Field(v, 10));
+-
+- CAMLreturn(0);
+-}
+-
+-static int device_pci_val(caml_gc *gc, libxl_device_pci *c_val, value v)
+-{
+- union {
+- unsigned int value;
+- struct {
+- unsigned int reserved1:2;
+- unsigned int reg:6;
+- unsigned int func:3;
+- unsigned int dev:5;
+- unsigned int bus:8;
+- unsigned int reserved2:7;
+- unsigned int enable:1;
+- }fields;
+- }u;
+- CAMLparam1(v);
+-
+- /* FIXME: propagate API change to ocaml */
+- u.value = Int_val(Field(v, 0));
+- c_val->reg = u.fields.reg;
+- c_val->func = u.fields.func;
+- c_val->dev = u.fields.dev;
+- c_val->bus = u.fields.bus;
+- c_val->enable = u.fields.enable;
+-
+- c_val->domain = Int_val(Field(v, 1));
+- c_val->vdevfn = Int_val(Field(v, 2));
+- c_val->msitranslate = Bool_val(Field(v, 3));
+- c_val->power_mgmt = Bool_val(Field(v, 4));
+-
+- CAMLreturn(0);
+-}
+-
+-static int sched_credit_val(caml_gc *gc, libxl_sched_credit *c_val, value v)
+-{
+- CAMLparam1(v);
+- c_val->weight = Int_val(Field(v, 0));
+- c_val->cap = Int_val(Field(v, 1));
+- CAMLreturn(0);
+-}
+-
+-static int domain_build_state_val(caml_gc *gc, libxl_domain_build_state *c_val, value v)
+-{
+- CAMLparam1(v);
+-
+- c_val->store_port = Int_val(Field(v, 0));
+- c_val->store_mfn = Int64_val(Field(v, 1));
+- c_val->console_port = Int_val(Field(v, 2));
+- c_val->console_mfn = Int64_val(Field(v, 3));
+-
+- CAMLreturn(0);
+-}
+-
+-static value Val_sched_credit(libxl_sched_credit *c_val)
+-{
+- CAMLparam0();
+- CAMLlocal1(v);
+-
+- v = caml_alloc_tuple(2);
+-
+- Store_field(v, 0, Val_int(c_val->weight));
+- Store_field(v, 1, Val_int(c_val->cap));
+-
+- CAMLreturn(v);
+-}
+-
+-static value Val_physinfo(libxl_physinfo *c_val)
+-{
+- CAMLparam0();
+- CAMLlocal2(v, hwcap);
+- int i;
+-
+- hwcap = caml_alloc_tuple(8);
+- for (i = 0; i < 8; i++)
+- Store_field(hwcap, i, caml_copy_int32(c_val->hw_cap[i]));
+-
+- v = caml_alloc_tuple(11);
+- Store_field(v, 0, Val_int(c_val->threads_per_core));
+- Store_field(v, 1, Val_int(c_val->cores_per_socket));
+- Store_field(v, 2, Val_int(c_val->max_cpu_id));
+- Store_field(v, 3, Val_int(c_val->nr_cpus));
+- Store_field(v, 4, Val_int(c_val->cpu_khz));
+- Store_field(v, 5, caml_copy_int64(c_val->total_pages));
+- Store_field(v, 6, caml_copy_int64(c_val->free_pages));
+- Store_field(v, 7, caml_copy_int64(c_val->scrub_pages));
+- Store_field(v, 8, Val_int(c_val->nr_nodes));
+- Store_field(v, 9, hwcap);
+- Store_field(v, 10, caml_copy_int32(c_val->phys_cap));
+-
+- CAMLreturn(v);
+-}
+-
+-value stub_xl_disk_add(value info, value domid)
+-{
+- CAMLparam2(info, domid);
+- libxl_device_disk c_info;
+- int ret;
+- INIT_STRUCT();
+-
+- device_disk_val(&gc, &c_info, info);
+- c_info.domid = Int_val(domid);
+-
+- 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_disk_remove(value info, value domid)
+-{
+- CAMLparam2(info, domid);
+- libxl_device_disk c_info;
+- int ret;
+- INIT_STRUCT();
+-
+- device_disk_val(&gc, &c_info, info);
+- c_info.domid = Int_val(domid);
+-
+- INIT_CTX();
+- ret = libxl_device_disk_del(&ctx, &c_info, 0);
+- if (ret != 0)
+- failwith_xl("disk_remove", &lg);
+- FREE_CTX();
+- CAMLreturn(Val_unit);
+-}
+-
+-value stub_xl_nic_add(value info, value domid)
+-{
+- CAMLparam2(info, domid);
+- libxl_device_nic c_info;
+- int ret;
+- INIT_STRUCT();
+-
+- device_nic_val(&gc, &c_info, info);
+- c_info.domid = Int_val(domid);
+-
+- 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_nic_remove(value info, value domid)
+-{
+- CAMLparam2(info, domid);
+- libxl_device_nic c_info;
+- int ret;
+- INIT_STRUCT();
+-
+- device_nic_val(&gc, &c_info, info);
+- c_info.domid = Int_val(domid);
+-
+- INIT_CTX();
+- ret = libxl_device_nic_del(&ctx, &c_info, 0);
+- if (ret != 0)
+- failwith_xl("nic_remove", &lg);
+- FREE_CTX();
+- CAMLreturn(Val_unit);
+-}
+-
+-value stub_xl_console_add(value info, value state, value domid)
+-{
+- CAMLparam3(info, state, domid);
+- libxl_device_console c_info;
+- libxl_domain_build_state c_state;
+- int ret;
+- INIT_STRUCT();
+-
+- device_console_val(&gc, &c_info, info);
+- domain_build_state_val(&gc, &c_state, state);
+- c_info.domid = Int_val(domid);
+- c_info.build_state = &c_state;
+-
+- 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_vkb_add(value info, value domid)
+-{
+- CAMLparam2(info, domid);
+- libxl_device_vkb c_info;
+- int ret;
+- INIT_STRUCT();
+-
+- device_vkb_val(&gc, &c_info, info);
+- c_info.domid = Int_val(domid);
+-
+- 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_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_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_vfb_add(value info, value domid)
+-{
+- CAMLparam2(info, domid);
+- libxl_device_vfb c_info;
+- int ret;
+- INIT_STRUCT();
+-
+- device_vfb_val(&gc, &c_info, info);
+- c_info.domid = Int_val(domid);
+-
+- 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_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_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_pci_add(value info, value domid)
+-{
+- CAMLparam2(info, domid);
+- libxl_device_pci c_info;
+- int ret;
+- INIT_STRUCT();
+-
+- device_pci_val(&gc, &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_pci_remove(value info, value domid)
+-{
+- CAMLparam2(info, domid);
+- libxl_device_pci c_info;
+- int ret;
+- INIT_STRUCT();
+-
+- device_pci_val(&gc, &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_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) + POWER_BUTTON);
+- if (ret != 0)
+- failwith_xl("button_press", &lg);
+- FREE_CTX();
+-
+- CAMLreturn(Val_unit);
+-}
+-
+-value stub_xl_physinfo(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(&c_physinfo);
+- CAMLreturn(physinfo);
+-}
+-
+-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(&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, &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:
+- */
+--- a/tools/ocaml/libs/xs/META.in
++++ b/tools/ocaml/libs/xs/META.in
+@@ -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"
+--- a/tools/ocaml/libs/xs/Makefile
++++ b/tools/ocaml/libs/xs/Makefile
+@@ -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,26 +21,26 @@
+
+ libs: $(LIBS)
+
+-xs_OBJS = $(OBJS)
+-OCAML_NOC_LIBRARY = xs
++xenstore_OBJS = xenstore
++OCAML_NOC_LIBRARY = xenstore
+
+-#xs.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+-# $(E) " MLLIB $@"
+-# $(Q)$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+-#
+-#xs.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+-# $(E) " MLLIB $@"
+-# $(Q)$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
++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.cmx xenstore.cmi *.a
+
+ .PHONY: uninstall
+ uninstall:
+- ocamlfind remove -destdir $(OCAMLDESTDIR) xs
++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenstore
+
+ include $(TOPLEVEL)/Makefile.rules
+
+--- a/tools/ocaml/libs/xs/queueop.ml
++++ b/tools/ocaml/libs/xs/queueop.ml
+@@ -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 =
+--- a/tools/ocaml/libs/xs/xs.ml
++++ b/tools/ocaml/libs/xs/xs.ml
+@@ -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
+
+--- a/tools/ocaml/libs/xs/xsraw.ml
++++ b/tools/ocaml/libs/xs/xsraw.ml
+@@ -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;
+ }
+
+--- a/tools/ocaml/libs/xs/xsraw.mli
++++ b/tools/ocaml/libs/xs/xsraw.mli
+@@ -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
+--- a/tools/ocaml/xenstored/Makefile
++++ b/tools/ocaml/xenstored/Makefile
+@@ -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
+--- a/tools/ocaml/xenstored/connection.ml
++++ b/tools/ocaml/xenstored/connection.ml
+@@ -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 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 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 = 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
+
+--- a/tools/ocaml/xenstored/connections.ml
++++ b/tools/ocaml/xenstored/connections.ml
+@@ -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
+
+--- a/tools/ocaml/xenstored/domain.ml
++++ b/tools/ocaml/xenstored/domain.ml
+@@ -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 = {
+--- a/tools/ocaml/xenstored/domains.ml
++++ b/tools/ocaml/xenstored/domains.ml
+@@ -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
+ )
+--- a/tools/ocaml/xenstored/event.ml
++++ b/tools/ocaml/xenstored/event.ml
+@@ -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
+--- a/tools/ocaml/xenstored/logging.ml
++++ b/tools/ocaml/xenstored/logging.ml
+@@ -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 "
+-
+- | Xb.Op.Watch -> "watch "
+- | Xb.Op.Unwatch -> "unwatch "
+-
+- | Xb.Op.Transaction_start -> "t start "
+- | Xb.Op.Transaction_end -> "t end "
+-
+- | Xb.Op.Introduce -> "introduce"
+- | Xb.Op.Release -> "release "
+- | Xb.Op.Getdomainpath -> "getdomain"
+- | Xb.Op.Isintroduced -> "is introduced"
+- | Xb.Op.Resume -> "resume "
++ | Xenbus.Xb.Op.Directory -> "directory"
++ | Xenbus.Xb.Op.Read -> "read "
++ | Xenbus.Xb.Op.Getperms -> "getperms "
++
++ | Xenbus.Xb.Op.Watch -> "watch "
++ | Xenbus.Xb.Op.Unwatch -> "unwatch "
++
++ | Xenbus.Xb.Op.Transaction_start -> "t start "
++ | Xenbus.Xb.Op.Transaction_end -> "t end "
++
++ | 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
+--- a/tools/ocaml/xenstored/perms.ml
++++ b/tools/ocaml/xenstored/perms.ml
+@@ -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; }
+--- a/tools/ocaml/xenstored/process.ml
++++ b/tools/ocaml/xenstored/process.ml
+@@ -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)
+--- a/tools/ocaml/xenstored/quota.ml
++++ b/tools/ocaml/xenstored/quota.ml
+@@ -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 =
+--- a/tools/ocaml/xenstored/transaction.ml
++++ b/tools/ocaml/xenstored/transaction.ml
+@@ -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
+--- a/tools/ocaml/xenstored/xenstored.ml
++++ b/tools/ocaml/xenstored/xenstored.ml
+@@ -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 =
+--- a/tools/ocaml/libs/xl/xl.ml
++++ /dev/null
+@@ -1,213 +0,0 @@
+-(*
+- * Copyright (C) 2009-2010 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-exception Error of string
+-
+-type create_info =
+-{
+- hvm : bool;
+- hap : bool;
+- oos : bool;
+- ssidref : int32;
+- name : string;
+- uuid : int array;
+- xsdata : (string * string) list;
+- platformdata : (string * string) list;
+- poolid : int32;
+- poolname : string;
+-}
+-
+-type build_pv_info =
+-{
+- slack_memkb : int64;
+- cmdline : string;
+- ramdisk : string;
+- features : string;
+-}
+-
+-type build_hvm_info =
+-{
+- pae : bool;
+- apic : bool;
+- acpi : bool;
+- nx : bool;
+- viridian : bool;
+- timeoffset : string;
+- timer_mode : int;
+- hpet : int;
+- vpt_align : int;
+-}
+-
+-type build_spec = BuildHVM of build_hvm_info | BuildPV of build_pv_info
+-
+-type build_info =
+-{
+- max_vcpus : int;
+- cur_vcpus : int;
+- max_memkb : int64;
+- target_memkb : int64;
+- video_memkb : int64;
+- shadow_memkb : int64;
+- kernel : string;
+- priv: build_spec;
+-}
+-
+-type build_state =
+-{
+- store_port : int;
+- store_mfn : int64;
+- console_port : int;
+- console_mfn : int64;
+-}
+-
+-type domid = int
+-
+-type disk_phystype =
+- | PHYSTYPE_QCOW
+- | PHYSTYPE_QCOW2
+- | PHYSTYPE_VHD
+- | PHYSTYPE_AIO
+- | PHYSTYPE_FILE
+- | PHYSTYPE_PHY
+-
+-type disk_info =
+-{
+- backend_domid : domid;
+- physpath : string;
+- phystype : disk_phystype;
+- virtpath : string;
+- unpluggable : bool;
+- readwrite : bool;
+- is_cdrom : bool;
+-}
+-
+-type nic_type =
+- | NICTYPE_IOEMU
+- | NICTYPE_VIF
+-
+-type nic_info =
+-{
+- backend_domid : domid;
+- devid : int;
+- mtu : int;
+- model : string;
+- mac : int array;
+- bridge : string;
+- ifname : string;
+- script : string;
+- nictype : nic_type;
+-}
+-
+-type console_type =
+- | CONSOLETYPE_XENCONSOLED
+- | CONSOLETYPE_IOEMU
+-
+-type console_info =
+-{
+- backend_domid : domid;
+- devid : int;
+- consoletype : console_type;
+-}
+-
+-type vkb_info =
+-{
+- backend_domid : domid;
+- devid : int;
+-}
+-
+-type vfb_info =
+-{
+- backend_domid : domid;
+- devid : int;
+- vnc : bool;
+- vnclisten : string;
+- vncpasswd : string;
+- vncdisplay : int;
+- vncunused : bool;
+- keymap : string;
+- sdl : bool;
+- opengl : bool;
+- display : string;
+- xauthority : string;
+-}
+-
+-type pci_info =
+-{
+- v : int; (* domain * bus * dev * func multiplexed *)
+- domain : int;
+- vdevfn : int;
+- msitranslate : bool;
+- power_mgmt : bool;
+-}
+-
+-type physinfo =
+-{
+- threads_per_core: int;
+- cores_per_socket: int;
+- max_cpu_id: int;
+- nr_cpus: int;
+- cpu_khz: int;
+- total_pages: int64;
+- free_pages: int64;
+- scrub_pages: int64;
+- nr_nodes: int;
+- hwcap: int32 array;
+- physcap: int32;
+-}
+-
+-type sched_credit =
+-{
+- weight: int;
+- cap: int;
+-}
+-
+-external domain_make : create_info -> domid = "stub_xl_domain_make"
+-external domain_build : build_info -> domid -> build_state = "stub_xl_domain_build"
+-
+-external disk_add : disk_info -> domid -> unit = "stub_xl_disk_add"
+-external disk_remove : disk_info -> domid -> unit = "stub_xl_disk_remove"
+-
+-external nic_add : nic_info -> domid -> unit = "stub_xl_nic_add"
+-external nic_remove : disk_info -> domid -> unit = "stub_xl_nic_remove"
+-
+-external console_add : console_info -> build_state -> domid -> unit = "stub_xl_console_add"
+-
+-external vkb_add : vkb_info -> domid -> unit = "stub_xl_vkb_add"
+-external vkb_clean_shutdown : domid -> unit = "stub_vkb_clean_shutdown"
+-external vkb_hard_shutdown : domid -> unit = "stub_vkb_hard_shutdown"
+-
+-external vfb_add : vfb_info -> domid -> unit = "stub_xl_vfb_add"
+-external vfb_clean_shutdown : domid -> unit = "stub_vfb_clean_shutdown"
+-external vfb_hard_shutdown : domid -> unit = "stub_vfb_hard_shutdown"
+-
+-external pci_add : pci_info -> domid -> unit = "stub_xl_pci_add"
+-external pci_remove : pci_info -> domid -> unit = "stub_xl_pci_remove"
+-external pci_shutdown : domid -> unit = "stub_xl_pci_shutdown"
+-
+-type button =
+- | Button_Power
+- | Button_Sleep
+-
+-external button_press : domid -> button -> unit = "stub_xl_button_press"
+-external physinfo : unit -> physinfo = "stub_xl_physinfo"
+-
+-external domain_sched_credit_get : domid -> sched_credit = "stub_xl_sched_credit_domain_get"
+-external domain_sched_credit_set : domid -> sched_credit -> unit = "stub_xl_sched_credit_domain_set"
+-
+-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")
+--- a/tools/ocaml/libs/xl/xl.mli
++++ /dev/null
+@@ -1,211 +0,0 @@
+-(*
+- * Copyright (C) 2009-2010 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-exception Error of string
+-
+-type create_info =
+-{
+- hvm : bool;
+- hap : bool;
+- oos : bool;
+- ssidref : int32;
+- name : string;
+- uuid : int array;
+- xsdata : (string * string) list;
+- platformdata : (string * string) list;
+- poolid : int32;
+- poolname : string;
+-}
+-
+-type build_pv_info =
+-{
+- slack_memkb : int64;
+- cmdline : string;
+- ramdisk : string;
+- features : string;
+-}
+-
+-type build_hvm_info =
+-{
+- pae : bool;
+- apic : bool;
+- acpi : bool;
+- nx : bool;
+- viridian : bool;
+- timeoffset : string;
+- timer_mode : int;
+- hpet : int;
+- vpt_align : int;
+-}
+-
+-type build_spec = BuildHVM of build_hvm_info | BuildPV of build_pv_info
+-
+-type build_info =
+-{
+- max_vcpus : int;
+- cur_vcpus : int;
+- max_memkb : int64;
+- target_memkb : int64;
+- video_memkb : int64;
+- shadow_memkb : int64;
+- kernel : string;
+- priv: build_spec;
+-}
+-
+-type build_state =
+-{
+- store_port : int;
+- store_mfn : int64;
+- console_port : int;
+- console_mfn : int64;
+-}
+-
+-type domid = int
+-
+-type disk_phystype =
+- | PHYSTYPE_QCOW
+- | PHYSTYPE_QCOW2
+- | PHYSTYPE_VHD
+- | PHYSTYPE_AIO
+- | PHYSTYPE_FILE
+- | PHYSTYPE_PHY
+-
+-type disk_info =
+-{
+- backend_domid : domid;
+- physpath : string;
+- phystype : disk_phystype;
+- virtpath : string;
+- unpluggable : bool;
+- readwrite : bool;
+- is_cdrom : bool;
+-}
+-
+-type nic_type =
+- | NICTYPE_IOEMU
+- | NICTYPE_VIF
+-
+-type nic_info =
+-{
+- backend_domid : domid;
+- devid : int;
+- mtu : int;
+- model : string;
+- mac : int array;
+- bridge : string;
+- ifname : string;
+- script : string;
+- nictype : nic_type;
+-}
+-
+-type console_type =
+- | CONSOLETYPE_XENCONSOLED
+- | CONSOLETYPE_IOEMU
+-
+-type console_info =
+-{
+- backend_domid : domid;
+- devid : int;
+- consoletype : console_type;
+-}
+-
+-type vkb_info =
+-{
+- backend_domid : domid;
+- devid : int;
+-}
+-
+-type vfb_info =
+-{
+- backend_domid : domid;
+- devid : int;
+- vnc : bool;
+- vnclisten : string;
+- vncpasswd : string;
+- vncdisplay : int;
+- vncunused : bool;
+- keymap : string;
+- sdl : bool;
+- opengl : bool;
+- display : string;
+- xauthority : string;
+-}
+-
+-type pci_info =
+-{
+- v : int; (* domain * bus * dev * func multiplexed *)
+- domain : int;
+- vdevfn : int;
+- msitranslate : bool;
+- power_mgmt : bool;
+-}
+-
+-type physinfo =
+-{
+- threads_per_core: int;
+- cores_per_socket: int;
+- max_cpu_id: int;
+- nr_cpus: int;
+- cpu_khz: int;
+- total_pages: int64;
+- free_pages: int64;
+- scrub_pages: int64;
+- nr_nodes: int;
+- hwcap: int32 array;
+- physcap: int32;
+-}
+-
+-type sched_credit =
+-{
+- weight: int;
+- cap: int;
+-}
+-
+-external domain_make : create_info -> domid = "stub_xl_domain_make"
+-external domain_build : build_info -> domid -> build_state = "stub_xl_domain_build"
+-
+-external disk_add : disk_info -> domid -> unit = "stub_xl_disk_add"
+-external disk_remove : disk_info -> domid -> unit = "stub_xl_disk_remove"
+-
+-external nic_add : nic_info -> domid -> unit = "stub_xl_nic_add"
+-external nic_remove : disk_info -> domid -> unit = "stub_xl_nic_remove"
+-
+-external console_add : console_info -> build_state -> domid -> unit = "stub_xl_console_add"
+-
+-external vkb_add : vkb_info -> domid -> unit = "stub_xl_vkb_add"
+-external vkb_clean_shutdown : domid -> unit = "stub_vkb_clean_shutdown"
+-external vkb_hard_shutdown : domid -> unit = "stub_vkb_hard_shutdown"
+-
+-external vfb_add : vfb_info -> domid -> unit = "stub_xl_vfb_add"
+-external vfb_clean_shutdown : domid -> unit = "stub_vfb_clean_shutdown"
+-external vfb_hard_shutdown : domid -> unit = "stub_vfb_hard_shutdown"
+-
+-external pci_add : pci_info -> domid -> unit = "stub_xl_pci_add"
+-external pci_remove : pci_info -> domid -> unit = "stub_xl_pci_remove"
+-external pci_shutdown : domid -> unit = "stub_xl_pci_shutdown"
+-
+-type button =
+- | Button_Power
+- | Button_Sleep
+-
+-external button_press : domid -> button -> unit = "stub_xl_button_press"
+-external physinfo : unit -> physinfo = "stub_xl_physinfo"
+-
+-external domain_sched_credit_get : domid -> sched_credit = "stub_xl_sched_credit_domain_get"
+-external domain_sched_credit_set : domid -> sched_credit -> unit = "stub_xl_sched_credit_domain_set"
+-
+-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"
+--- /dev/null
++++ b/tools/ocaml/libs/xl/xenlight.ml
+@@ -0,0 +1,213 @@
++(*
++ * Copyright (C) 2009-2010 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ *)
++
++exception Error of string
++
++type create_info =
++{
++ hvm : bool;
++ hap : bool;
++ oos : bool;
++ ssidref : int32;
++ name : string;
++ uuid : int array;
++ xsdata : (string * string) list;
++ platformdata : (string * string) list;
++ poolid : int32;
++ poolname : string;
++}
++
++type build_pv_info =
++{
++ slack_memkb : int64;
++ cmdline : string;
++ ramdisk : string;
++ features : string;
++}
++
++type build_hvm_info =
++{
++ pae : bool;
++ apic : bool;
++ acpi : bool;
++ nx : bool;
++ viridian : bool;
++ timeoffset : string;
++ timer_mode : int;
++ hpet : int;
++ vpt_align : int;
++}
++
++type build_spec = BuildHVM of build_hvm_info | BuildPV of build_pv_info
++
++type build_info =
++{
++ max_vcpus : int;
++ cur_vcpus : int;
++ max_memkb : int64;
++ target_memkb : int64;
++ video_memkb : int64;
++ shadow_memkb : int64;
++ kernel : string;
++ priv: build_spec;
++}
++
++type build_state =
++{
++ store_port : int;
++ store_mfn : int64;
++ console_port : int;
++ console_mfn : int64;
++}
++
++type domid = int
++
++type disk_phystype =
++ | PHYSTYPE_QCOW
++ | PHYSTYPE_QCOW2
++ | PHYSTYPE_VHD
++ | PHYSTYPE_AIO
++ | PHYSTYPE_FILE
++ | PHYSTYPE_PHY
++
++type disk_info =
++{
++ backend_domid : domid;
++ physpath : string;
++ phystype : disk_phystype;
++ virtpath : string;
++ unpluggable : bool;
++ readwrite : bool;
++ is_cdrom : bool;
++}
++
++type nic_type =
++ | NICTYPE_IOEMU
++ | NICTYPE_VIF
++
++type nic_info =
++{
++ backend_domid : domid;
++ devid : int;
++ mtu : int;
++ model : string;
++ mac : int array;
++ bridge : string;
++ ifname : string;
++ script : string;
++ nictype : nic_type;
++}
++
++type console_type =
++ | CONSOLETYPE_XENCONSOLED
++ | CONSOLETYPE_IOEMU
++
++type console_info =
++{
++ backend_domid : domid;
++ devid : int;
++ consoletype : console_type;
++}
++
++type vkb_info =
++{
++ backend_domid : domid;
++ devid : int;
++}
++
++type vfb_info =
++{
++ backend_domid : domid;
++ devid : int;
++ vnc : bool;
++ vnclisten : string;
++ vncpasswd : string;
++ vncdisplay : int;
++ vncunused : bool;
++ keymap : string;
++ sdl : bool;
++ opengl : bool;
++ display : string;
++ xauthority : string;
++}
++
++type pci_info =
++{
++ v : int; (* domain * bus * dev * func multiplexed *)
++ domain : int;
++ vdevfn : int;
++ msitranslate : bool;
++ power_mgmt : bool;
++}
++
++type physinfo =
++{
++ threads_per_core: int;
++ cores_per_socket: int;
++ max_cpu_id: int;
++ nr_cpus: int;
++ cpu_khz: int;
++ total_pages: int64;
++ free_pages: int64;
++ scrub_pages: int64;
++ nr_nodes: int;
++ hwcap: int32 array;
++ physcap: int32;
++}
++
++type sched_credit =
++{
++ weight: int;
++ cap: int;
++}
++
++external domain_make : create_info -> domid = "stub_xl_domain_make"
++external domain_build : build_info -> domid -> build_state = "stub_xl_domain_build"
++
++external disk_add : disk_info -> domid -> unit = "stub_xl_disk_add"
++external disk_remove : disk_info -> domid -> unit = "stub_xl_disk_remove"
++
++external nic_add : nic_info -> domid -> unit = "stub_xl_nic_add"
++external nic_remove : disk_info -> domid -> unit = "stub_xl_nic_remove"
++
++external console_add : console_info -> build_state -> domid -> unit = "stub_xl_console_add"
++
++external vkb_add : vkb_info -> domid -> unit = "stub_xl_vkb_add"
++external vkb_clean_shutdown : domid -> unit = "stub_vkb_clean_shutdown"
++external vkb_hard_shutdown : domid -> unit = "stub_vkb_hard_shutdown"
++
++external vfb_add : vfb_info -> domid -> unit = "stub_xl_vfb_add"
++external vfb_clean_shutdown : domid -> unit = "stub_vfb_clean_shutdown"
++external vfb_hard_shutdown : domid -> unit = "stub_vfb_hard_shutdown"
++
++external pci_add : pci_info -> domid -> unit = "stub_xl_pci_add"
++external pci_remove : pci_info -> domid -> unit = "stub_xl_pci_remove"
++external pci_shutdown : domid -> unit = "stub_xl_pci_shutdown"
++
++type button =
++ | Button_Power
++ | Button_Sleep
++
++external button_press : domid -> button -> unit = "stub_xl_button_press"
++external physinfo : unit -> physinfo = "stub_xl_physinfo"
++
++external domain_sched_credit_get : domid -> sched_credit = "stub_xl_sched_credit_domain_get"
++external domain_sched_credit_set : domid -> sched_credit -> unit = "stub_xl_sched_credit_domain_set"
++
++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")
+--- /dev/null
++++ b/tools/ocaml/libs/xl/xenlight.mli
+@@ -0,0 +1,211 @@
++(*
++ * Copyright (C) 2009-2010 Citrix Ltd.
++ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
++ *
++ * This program is free software; you can redistribute it and/or modify
++ * it under the terms of the GNU Lesser General Public License as published
++ * by the Free Software Foundation; version 2.1 only. with the special
++ * exception on linking described in file LICENSE.
++ *
++ * This program is distributed in the hope that it will be useful,
++ * but WITHOUT ANY WARRANTY; without even the implied warranty of
++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
++ * GNU Lesser General Public License for more details.
++ *)
++
++exception Error of string
++
++type create_info =
++{
++ hvm : bool;
++ hap : bool;
++ oos : bool;
++ ssidref : int32;
++ name : string;
++ uuid : int array;
++ xsdata : (string * string) list;
++ platformdata : (string * string) list;
++ poolid : int32;
++ poolname : string;
++}
++
++type build_pv_info =
++{
++ slack_memkb : int64;
++ cmdline : string;
++ ramdisk : string;
++ features : string;
++}
++
++type build_hvm_info =
++{
++ pae : bool;
++ apic : bool;
++ acpi : bool;
++ nx : bool;
++ viridian : bool;
++ timeoffset : string;
++ timer_mode : int;
++ hpet : int;
++ vpt_align : int;
++}
++
++type build_spec = BuildHVM of build_hvm_info | BuildPV of build_pv_info
++
++type build_info =
++{
++ max_vcpus : int;
++ cur_vcpus : int;
++ max_memkb : int64;
++ target_memkb : int64;
++ video_memkb : int64;
++ shadow_memkb : int64;
++ kernel : string;
++ priv: build_spec;
++}
++
++type build_state =
++{
++ store_port : int;
++ store_mfn : int64;
++ console_port : int;
++ console_mfn : int64;
++}
++
++type domid = int
++
++type disk_phystype =
++ | PHYSTYPE_QCOW
++ | PHYSTYPE_QCOW2
++ | PHYSTYPE_VHD
++ | PHYSTYPE_AIO
++ | PHYSTYPE_FILE
++ | PHYSTYPE_PHY
++
++type disk_info =
++{
++ backend_domid : domid;
++ physpath : string;
++ phystype : disk_phystype;
++ virtpath : string;
++ unpluggable : bool;
++ readwrite : bool;
++ is_cdrom : bool;
++}
++
++type nic_type =
++ | NICTYPE_IOEMU
++ | NICTYPE_VIF
++
++type nic_info =
++{
++ backend_domid : domid;
++ devid : int;
++ mtu : int;
++ model : string;
++ mac : int array;
++ bridge : string;
++ ifname : string;
++ script : string;
++ nictype : nic_type;
++}
++
++type console_type =
++ | CONSOLETYPE_XENCONSOLED
++ | CONSOLETYPE_IOEMU
++
++type console_info =
++{
++ backend_domid : domid;
++ devid : int;
++ consoletype : console_type;
++}
++
++type vkb_info =
++{
++ backend_domid : domid;
++ devid : int;
++}
++
++type vfb_info =
++{
++ backend_domid : domid;
++ devid : int;
++ vnc : bool;
++ vnclisten : string;
++ vncpasswd : string;
++ vncdisplay : int;
++ vncunused : bool;
++ keymap : string;
++ sdl : bool;
++ opengl : bool;
++ display : string;
++ xauthority : string;
++}
++
++type pci_info =
++{
++ v : int; (* domain * bus * dev * func multiplexed *)
++ domain : int;
++ vdevfn : int;
++ msitranslate : bool;
++ power_mgmt : bool;
++}
++
++type physinfo =
++{
++ threads_per_core: int;
++ cores_per_socket: int;
++ max_cpu_id: int;
++ nr_cpus: int;
++ cpu_khz: int;
++ total_pages: int64;
++ free_pages: int64;
++ scrub_pages: int64;
++ nr_nodes: int;
++ hwcap: int32 array;
++ physcap: int32;
++}
++
++type sched_credit =
++{
++ weight: int;
++ cap: int;
++}
++
++external domain_make : create_info -> domid = "stub_xl_domain_make"
++external domain_build : build_info -> domid -> build_state = "stub_xl_domain_build"
++
++external disk_add : disk_info -> domid -> unit = "stub_xl_disk_add"
++external disk_remove : disk_info -> domid -> unit = "stub_xl_disk_remove"
++
++external nic_add : nic_info -> domid -> unit = "stub_xl_nic_add"
++external nic_remove : disk_info -> domid -> unit = "stub_xl_nic_remove"
++
++external console_add : console_info -> build_state -> domid -> unit = "stub_xl_console_add"
++
++external vkb_add : vkb_info -> domid -> unit = "stub_xl_vkb_add"
++external vkb_clean_shutdown : domid -> unit = "stub_vkb_clean_shutdown"
++external vkb_hard_shutdown : domid -> unit = "stub_vkb_hard_shutdown"
++
++external vfb_add : vfb_info -> domid -> unit = "stub_xl_vfb_add"
++external vfb_clean_shutdown : domid -> unit = "stub_vfb_clean_shutdown"
++external vfb_hard_shutdown : domid -> unit = "stub_vfb_hard_shutdown"
++
++external pci_add : pci_info -> domid -> unit = "stub_xl_pci_add"
++external pci_remove : pci_info -> domid -> unit = "stub_xl_pci_remove"
++external pci_shutdown : domid -> unit = "stub_xl_pci_shutdown"
++
++type button =
++ | Button_Power
++ | Button_Sleep
++
++external button_press : domid -> button -> unit = "stub_xl_button_press"
++external physinfo : unit -> physinfo = "stub_xl_physinfo"
++
++external domain_sched_credit_get : domid -> sched_credit = "stub_xl_sched_credit_domain_get"
++external domain_sched_credit_set : domid -> sched_credit -> unit = "stub_xl_sched_credit_domain_set"
++
++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"
+--- a/tools/ocaml/libs/xl/META.in
++++ b/tools/ocaml/libs/xl/META.in
+@@ -1,4 +1,4 @@
+ version = "@VERSION@"
+ description = "Xen Toolstack Library"
+-archive(byte) = "xl.cma"
+-archive(native) = "xl.cmxa"
++archive(byte) = "xenlight.cma"
++archive(native) = "xenlight.cmxa"
--- /dev/null
+# HG changeset patch
+# User Jon Ludlam <jonathan.ludlam@eu.citrix.com>
+# Date 1317300078 -3600
+# Node ID f628a2174cd0289400e2fe476cc3177fbcba3c8d
+# Parent 42cdb34ec175602fa2d8f0f65e44c4eb3a086496
+[OCAML] Remove log library from tools/ocaml/libs
+
+This patch has the same effect as xen-unstable.hg c/s 23939:51288f69523f
+
+The only user was oxenstored, which has had the relevant bits
+merged in.
+
+Signed-off-by: Zheng Li <zheng.li@eu.citrix.com>
+Acked-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
+
+--- a/tools/ocaml/libs/Makefile
++++ b/tools/ocaml/libs/Makefile
+@@ -3,7 +3,7 @@
+
+ SUBDIRS= \
+ mmap \
+- log xc eventchn \
++ xc eventchn \
+ xb xs xl
+
+ .PHONY: all
+--- a/tools/ocaml/libs/log/META.in
++++ /dev/null
+@@ -1,5 +0,0 @@
+-version = "@VERSION@"
+-description = "Log - logging library"
+-requires = "unix"
+-archive(byte) = "log.cma"
+-archive(native) = "log.cmxa"
+--- a/tools/ocaml/libs/log/log.ml
++++ /dev/null
+@@ -1,258 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-open Printf
+-
+-exception Unknown_level of string
+-
+-type stream_type = Stderr | Stdout | File of string
+-
+-type stream_log = {
+- ty : stream_type;
+- channel : out_channel option ref;
+-}
+-
+-type level = Debug | Info | Warn | Error
+-
+-type output =
+- | Stream of stream_log
+- | String of string list ref
+- | Syslog of string
+- | Nil
+-
+-let int_of_level l =
+- match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3
+-
+-let string_of_level l =
+- match l with Debug -> "debug" | Info -> "info"
+- | Warn -> "warn" | Error -> "error"
+-
+-let level_of_string s =
+- match s with
+- | "debug" -> Debug
+- | "info" -> Info
+- | "warn" -> Warn
+- | "error" -> Error
+- | _ -> raise (Unknown_level s)
+-
+-let mkdir_safe dir perm =
+- try Unix.mkdir dir perm with _ -> ()
+-
+-let mkdir_rec dir perm =
+- let rec p_mkdir dir =
+- let p_name = Filename.dirname dir in
+- if p_name = "/" || p_name = "." then
+- ()
+- else (
+- p_mkdir p_name;
+- mkdir_safe dir perm
+- ) in
+- p_mkdir dir
+-
+-type t = { output: output; mutable level: level; }
+-
+-let make output level = { output = output; level = level; }
+-
+-let make_stream ty channel =
+- Stream {ty=ty; channel=ref channel; }
+-
+-(** open a syslog logger *)
+-let opensyslog k level =
+- make (Syslog k) level
+-
+-(** open a stderr logger *)
+-let openerr level =
+- if (Unix.stat "/dev/stderr").Unix.st_kind <> Unix.S_CHR then
+- failwith "/dev/stderr is not a valid character device";
+- make (make_stream Stderr (Some (open_out "/dev/stderr"))) level
+-
+-let openout level =
+- if (Unix.stat "/dev/stdout").Unix.st_kind <> Unix.S_CHR then
+- failwith "/dev/stdout is not a valid character device";
+- make (make_stream Stdout (Some (open_out "/dev/stdout"))) level
+-
+-
+-(** open a stream logger - returning the channel. *)
+-(* This needs to be separated from 'openfile' so we can reopen later *)
+-let doopenfile filename =
+- if Filename.is_relative filename then
+- None
+- else (
+- try
+- mkdir_rec (Filename.dirname filename) 0o700;
+- Some (open_out_gen [ Open_append; Open_creat ] 0o600 filename)
+- with _ -> None
+- )
+-
+-(** open a stream logger - returning the output type *)
+-let openfile filename level =
+- make (make_stream (File filename) (doopenfile filename)) level
+-
+-(** open a nil logger *)
+-let opennil () =
+- make Nil Error
+-
+-(** open a string logger *)
+-let openstring level =
+- make (String (ref [""])) level
+-
+-(** try to reopen a logger *)
+-let reopen t =
+- match t.output with
+- | Nil -> t
+- | Syslog k -> Syslog.close (); opensyslog k t.level
+- | Stream s -> (
+- match (s.ty,!(s.channel)) with
+- | (File filename, Some c) -> close_out c; s.channel := (try doopenfile filename with _ -> None); t
+- | _ -> t)
+- | String _ -> t
+-
+-(** close a logger *)
+-let close t =
+- match t.output with
+- | Nil -> ()
+- | Syslog k -> Syslog.close ();
+- | Stream s -> (
+- match !(s.channel) with
+- | Some c -> close_out c; s.channel := None
+- | None -> ())
+- | String _ -> ()
+-
+-(** create a string representating the parameters of the logger *)
+-let string_of_logger t =
+- match t.output with
+- | Nil -> "nil"
+- | Syslog k -> sprintf "syslog:%s" k
+- | String _ -> "string"
+- | Stream s ->
+- begin
+- match s.ty with
+- | File f -> sprintf "file:%s" f
+- | Stderr -> "stderr"
+- | Stdout -> "stdout"
+- end
+-
+-(** parse a string to a logger *)
+-let logger_of_string s : t =
+- match s with
+- | "nil" -> opennil ()
+- | "stderr" -> openerr Debug
+- | "stdout" -> openout Debug
+- | "string" -> openstring Debug
+- | _ ->
+- let split_in_2 s =
+- try
+- let i = String.index s ':' in
+- String.sub s 0 (i),
+- String.sub s (i + 1) (String.length s - i - 1)
+- with _ ->
+- failwith "logger format error: expecting string:string"
+- in
+- let k, s = split_in_2 s in
+- match k with
+- | "syslog" -> opensyslog s Debug
+- | "file" -> openfile s Debug
+- | _ -> failwith "unknown logger type"
+-
+-let validate s =
+- match s with
+- | "nil" -> ()
+- | "stderr" -> ()
+- | "stdout" -> ()
+- | "string" -> ()
+- | _ ->
+- let split_in_2 s =
+- try
+- let i = String.index s ':' in
+- String.sub s 0 (i),
+- String.sub s (i + 1) (String.length s - i - 1)
+- with _ ->
+- failwith "logger format error: expecting string:string"
+- in
+- let k, s = split_in_2 s in
+- match k with
+- | "syslog" -> ()
+- | "file" -> (
+- try
+- let st = Unix.stat s in
+- if st.Unix.st_kind <> Unix.S_REG then
+- failwith "logger file is a directory";
+- ()
+- with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
+- )
+- | _ -> failwith "unknown logger"
+-
+-(** change a logger level to level *)
+-let set t level = t.level <- level
+-
+-let gettimestring () =
+- let time = Unix.gettimeofday () in
+- let tm = Unix.localtime time in
+- let msec = time -. (floor time) in
+- sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d|" (1900 + tm.Unix.tm_year)
+- (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
+- tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+- (int_of_float (1000.0 *. msec))
+-
+-(*let extra_hook = ref (fun x -> x)*)
+-
+-let output t ?(key="") ?(extra="") priority (message: string) =
+- let construct_string withtime =
+- (*let key = if key = "" then [] else [ key ] in
+- let extra = if extra = "" then [] else [ extra ] in
+- let items =
+- (if withtime then [ gettimestring () ] else [])
+- @ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in
+-(* let items = !extra_hook items in*)
+- String.concat " " items*)
+- Printf.sprintf "[%s%s|%s] %s"
+- (if withtime then gettimestring () else "") (string_of_level priority) extra message
+- in
+- (* Keep track of how much we write out to streams, so that we can *)
+- (* log-rotate at appropriate times *)
+- let write_to_stream stream =
+- let string = (construct_string true) in
+- try
+- fprintf stream "%s\n%!" string
+- with _ -> () (* Trap exception when we fail to write log *)
+- in
+-
+- if String.length message > 0 then
+- match t.output with
+- | Syslog k ->
+- let sys_prio = match priority with
+- | Debug -> Syslog.Debug
+- | Info -> Syslog.Info
+- | Warn -> Syslog.Warning
+- | Error -> Syslog.Err in
+- Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n")
+- | Stream s -> (
+- match !(s.channel) with
+- | Some c -> write_to_stream c
+- | None -> ())
+- | Nil -> ()
+- | String s -> (s := (construct_string true)::!s)
+-
+-let log t level (fmt: ('a, unit, string, unit) format4): 'a =
+- let b = (int_of_level t.level) <= (int_of_level level) in
+- (* ksprintf is the preferred name for kprintf, but the former
+- * is not available in OCaml 3.08.3 *)
+- Printf.kprintf (if b then output t level else (fun _ -> ())) fmt
+-
+-let debug t (fmt: ('a , unit, string, unit) format4) = log t Debug fmt
+-let info t (fmt: ('a , unit, string, unit) format4) = log t Info fmt
+-let warn t (fmt: ('a , unit, string, unit) format4) = log t Warn fmt
+-let error t (fmt: ('a , unit, string, unit) format4) = log t Error fmt
+--- a/tools/ocaml/libs/log/log.mli
++++ /dev/null
+@@ -1,55 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-exception Unknown_level of string
+-type level = Debug | Info | Warn | Error
+-
+-type stream_type = Stderr | Stdout | File of string
+-type stream_log = {
+- ty : stream_type;
+- channel : out_channel option ref;
+-}
+-type output =
+- Stream of stream_log
+- | String of string list ref
+- | Syslog of string
+- | Nil
+-val int_of_level : level -> int
+-val string_of_level : level -> string
+-val level_of_string : string -> level
+-val mkdir_safe : string -> Unix.file_perm -> unit
+-val mkdir_rec : string -> Unix.file_perm -> unit
+-type t = { output : output; mutable level : level; }
+-val make : output -> level -> t
+-val opensyslog : string -> level -> t
+-val openerr : level -> t
+-val openout : level -> t
+-val openfile : string -> level -> t
+-val opennil : unit -> t
+-val openstring : level -> t
+-val reopen : t -> t
+-val close : t -> unit
+-val string_of_logger : t -> string
+-val logger_of_string : string -> t
+-val validate : string -> unit
+-val set : t -> level -> unit
+-val gettimestring : unit -> string
+-val output : t -> ?key:string -> ?extra:string -> level -> string -> unit
+-val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
+-val debug : t -> ('a, unit, string, unit) format4 -> 'a
+-val info : t -> ('a, unit, string, unit) format4 -> 'a
+-val warn : t -> ('a, unit, string, unit) format4 -> 'a
+-val error : t -> ('a, unit, string, unit) format4 -> 'a
+--- a/tools/ocaml/libs/log/logs.ml
++++ /dev/null
+@@ -1,197 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-type keylogger =
+-{
+- mutable debug: string list;
+- mutable info: string list;
+- mutable warn: string list;
+- mutable error: string list;
+- no_default: bool;
+-}
+-
+-(* map all logger strings into a logger *)
+-let __all_loggers = Hashtbl.create 10
+-
+-(* default logger that everything that doesn't have a key in __lop_mapping get send *)
+-let __default_logger = { debug = []; info = []; warn = []; error = []; no_default = false }
+-
+-(*
+- * This describe the mapping between a name to a keylogger.
+- * a keylogger contains a list of logger string per level of debugging.
+- * Example: "xenops", debug -> [ "stderr"; "/var/log/xensource.log" ]
+- * "xapi", error -> []
+- * "xapi", debug -> [ "/var/log/xensource.log" ]
+- * "xenops", info -> [ "syslog" ]
+- *)
+-let __log_mapping = Hashtbl.create 32
+-
+-let get_or_open logstring =
+- if Hashtbl.mem __all_loggers logstring then
+- Hashtbl.find __all_loggers logstring
+- else
+- let t = Log.logger_of_string logstring in
+- Hashtbl.add __all_loggers logstring t;
+- t
+-
+-(** create a mapping entry for the key "name".
+- * all log level of key "name" default to "logger" logger.
+- * a sensible default is put "nil" as a logger and reopen a specific level to
+- * the logger you want to.
+- *)
+-let add key logger =
+- let kl = {
+- debug = logger;
+- info = logger;
+- warn = logger;
+- error = logger;
+- no_default = false;
+- } in
+- Hashtbl.add __log_mapping key kl
+-
+-let get_by_level keylog level =
+- match level with
+- | Log.Debug -> keylog.debug
+- | Log.Info -> keylog.info
+- | Log.Warn -> keylog.warn
+- | Log.Error -> keylog.error
+-
+-let set_by_level keylog level logger =
+- match level with
+- | Log.Debug -> keylog.debug <- logger
+- | Log.Info -> keylog.info <- logger
+- | Log.Warn -> keylog.warn <- logger
+- | Log.Error -> keylog.error <- logger
+-
+-(** set a specific key|level to the logger "logger" *)
+-let set key level logger =
+- if not (Hashtbl.mem __log_mapping key) then
+- add key [];
+-
+- let keylog = Hashtbl.find __log_mapping key in
+- set_by_level keylog level logger
+-
+-(** set default logger *)
+-let set_default level logger =
+- set_by_level __default_logger level logger
+-
+-(** append a logger to the list *)
+-let append key level logger =
+- if not (Hashtbl.mem __log_mapping key) then
+- add key [];
+- let keylog = Hashtbl.find __log_mapping key in
+- let loggers = get_by_level keylog level in
+- set_by_level keylog level (loggers @ [ logger ])
+-
+-(** append a logger to the default list *)
+-let append_default level logger =
+- let loggers = get_by_level __default_logger level in
+- set_by_level __default_logger level (loggers @ [ logger ])
+-
+-(** reopen all logger open *)
+-let reopen () =
+- Hashtbl.iter (fun k v ->
+- Hashtbl.replace __all_loggers k (Log.reopen v)) __all_loggers
+-
+-(** reclaim close all logger open that are not use by any other keys *)
+-let reclaim () =
+- let list_sort_uniq l =
+- let oldprev = ref "" and prev = ref "" in
+- List.fold_left (fun a k ->
+- oldprev := !prev;
+- prev := k;
+- if k = !oldprev then a else k :: a) []
+- (List.sort compare l)
+- in
+- let flatten_keylogger v =
+- list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in
+- let oldkeys = Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in
+- let usedkeys = Hashtbl.fold (fun k v a ->
+- (flatten_keylogger v) @ a)
+- __log_mapping (flatten_keylogger __default_logger) in
+- let usedkeys = list_sort_uniq usedkeys in
+-
+- List.iter (fun k ->
+- if not (List.mem k usedkeys) then (
+- begin try
+- Log.close (Hashtbl.find __all_loggers k)
+- with
+- Not_found -> ()
+- end;
+- Hashtbl.remove __all_loggers k
+- )) oldkeys
+-
+-(** clear a specific key|level *)
+-let clear key level =
+- try
+- let keylog = Hashtbl.find __log_mapping key in
+- set_by_level keylog level [];
+- reclaim ()
+- with Not_found ->
+- ()
+-
+-(** clear a specific default level *)
+-let clear_default level =
+- set_default level [];
+- reclaim ()
+-
+-(** reset all the loggers to the specified logger *)
+-let reset_all logger =
+- Hashtbl.clear __log_mapping;
+- set_default Log.Debug logger;
+- set_default Log.Warn logger;
+- set_default Log.Error logger;
+- set_default Log.Info logger;
+- reclaim ()
+-
+-(** log a fmt message to the key|level logger specified in the log mapping.
+- * if the logger doesn't exist, assume nil logger.
+- *)
+-let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a =
+- let keylog =
+- if Hashtbl.mem __log_mapping key then
+- let keylog = Hashtbl.find __log_mapping key in
+- if keylog.no_default = false &&
+- get_by_level keylog level = [] then
+- __default_logger
+- else
+- keylog
+- else
+- __default_logger in
+- let loggers = get_by_level keylog level in
+- match loggers with
+- | [] -> Printf.kprintf ignore fmt
+- | _ ->
+- let l = List.fold_left (fun acc logger ->
+- try get_or_open logger :: acc
+- with _ -> acc
+- ) [] loggers in
+- let l = List.rev l in
+-
+- (* ksprintf is the preferred name for kprintf, but the former
+- * is not available in OCaml 3.08.3 *)
+- Printf.kprintf (fun s ->
+- List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt
+-
+-(* define some convenience functions *)
+-let debug t ?extra (fmt: ('a , unit, string, unit) format4) =
+- log t Log.Debug ?extra fmt
+-let info t ?extra (fmt: ('a , unit, string, unit) format4) =
+- log t Log.Info ?extra fmt
+-let warn t ?extra (fmt: ('a , unit, string, unit) format4) =
+- log t Log.Warn ?extra fmt
+-let error t ?extra (fmt: ('a , unit, string, unit) format4) =
+- log t Log.Error ?extra fmt
+--- a/tools/ocaml/libs/log/logs.mli
++++ /dev/null
+@@ -1,46 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-type keylogger = {
+- mutable debug : string list;
+- mutable info : string list;
+- mutable warn : string list;
+- mutable error : string list;
+- no_default : bool;
+-}
+-val __all_loggers : (string, Log.t) Hashtbl.t
+-val __default_logger : keylogger
+-val __log_mapping : (string, keylogger) Hashtbl.t
+-val get_or_open : string -> Log.t
+-val add : string -> string list -> unit
+-val get_by_level : keylogger -> Log.level -> string list
+-val set_by_level : keylogger -> Log.level -> string list -> unit
+-val set : string -> Log.level -> string list -> unit
+-val set_default : Log.level -> string list -> unit
+-val append : string -> Log.level -> string -> unit
+-val append_default : Log.level -> string -> unit
+-val reopen : unit -> unit
+-val reclaim : unit -> unit
+-val clear : string -> Log.level -> unit
+-val clear_default : Log.level -> unit
+-val reset_all : string list -> unit
+-val log :
+- string ->
+- Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+-val debug : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+-val info : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+-val warn : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+-val error : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+--- a/tools/ocaml/libs/log/syslog.ml
++++ /dev/null
+@@ -1,26 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
+-type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
+-type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern
+- | Local0 | Local1 | Local2 | Local3
+- | Local4 | Local5 | Local6 | Local7
+- | Lpr | Mail | News | Syslog | User | Uucp
+-
+-(* external init : string -> options list -> facility -> unit = "stub_openlog" *)
+-external log : facility -> level -> string -> unit = "stub_syslog"
+-external close : unit -> unit = "stub_closelog"
+--- a/tools/ocaml/libs/log/syslog_stubs.c
++++ /dev/null
+@@ -1,75 +0,0 @@
+-/*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- */
+-
+-#include <syslog.h>
+-#include <caml/mlvalues.h>
+-#include <caml/memory.h>
+-#include <caml/alloc.h>
+-#include <caml/custom.h>
+-
+-static int __syslog_level_table[] = {
+- LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING,
+- LOG_NOTICE, LOG_INFO, LOG_DEBUG
+-};
+-
+-/*
+-static int __syslog_options_table[] = {
+- LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID
+-};
+-*/
+-
+-static int __syslog_facility_table[] = {
+- LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN,
+- LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3,
+- LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7,
+- LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP
+-};
+-
+-/* According to the openlog manpage the 'openlog' call may take a reference
+- to the 'ident' string and keep it long-term. This means we cannot just pass in
+- an ocaml string which is under the control of the GC. Since we aren't actually
+- calling this function we can just comment it out for the time-being. */
+-/*
+-value stub_openlog(value ident, value option, value facility)
+-{
+- CAMLparam3(ident, option, facility);
+- int c_option;
+- int c_facility;
+-
+- c_option = caml_convert_flag_list(option, __syslog_options_table);
+- c_facility = __syslog_facility_table[Int_val(facility)];
+- openlog(String_val(ident), c_option, c_facility);
+- CAMLreturn(Val_unit);
+-}
+-*/
+-
+-value stub_syslog(value facility, value level, value msg)
+-{
+- CAMLparam3(facility, level, msg);
+- int c_facility;
+-
+- c_facility = __syslog_facility_table[Int_val(facility)]
+- | __syslog_level_table[Int_val(level)];
+- syslog(c_facility, "%s", String_val(msg));
+- CAMLreturn(Val_unit);
+-}
+-
+-value stub_closelog(value unit)
+-{
+- CAMLparam1(unit);
+- closelog();
+- CAMLreturn(Val_unit);
+-}
+--- a/tools/ocaml/xenstored/Makefile
++++ b/tools/ocaml/xenstored/Makefile
+@@ -3,7 +3,6 @@
+ include $(OCAML_TOPLEVEL)/common.make
+
+ OCAMLINCLUDE += \
+- -I $(OCAML_TOPLEVEL)/libs/log \
+ -I $(OCAML_TOPLEVEL)/libs/xb \
+ -I $(OCAML_TOPLEVEL)/libs/mmap \
+ -I $(OCAML_TOPLEVEL)/libs/xc \
+@@ -34,7 +33,6 @@
+ XENSTOREDLIBS = \
+ unix.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/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 \
+--- a/tools/ocaml/xenstored/connection.ml
++++ b/tools/ocaml/xenstored/connection.ml
+@@ -232,3 +232,8 @@
+ Printf.fprintf chan "watch,%d,%s,%s\n" domid (Utils.hexify path) (Utils.hexify token)
+ ) (list_watches con);
+ | None -> ()
++
++let debug con =
++ let domid = get_domstr con in
++ let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in
++ String.concat "" watches
+--- a/tools/ocaml/xenstored/connections.ml
++++ b/tools/ocaml/xenstored/connections.ml
+@@ -15,7 +15,7 @@
+ * GNU Lesser General Public License for more details.
+ *)
+
+-let debug fmt = Logs.debug "general" fmt
++let debug fmt = Logging.debug "connections" fmt
+
+ type t = {
+ mutable anonymous: Connection.t list;
+@@ -165,3 +165,8 @@
+ );
+ (List.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
+ Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)
++
++let debug cons =
++ let anonymous = List.map Connection.debug cons.anonymous in
++ let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in
++ String.concat "" (domains @ anonymous)
+--- a/tools/ocaml/xenstored/disk.ml
++++ b/tools/ocaml/xenstored/disk.ml
+@@ -17,7 +17,7 @@
+ let enable = ref false
+ let xs_daemon_database = "/var/run/xenstored/db"
+
+-let error = Logs.error "general"
++let error fmt = Logging.error "disk" fmt
+
+ (* unescape utils *)
+ exception Bad_escape
+--- a/tools/ocaml/xenstored/domain.ml
++++ b/tools/ocaml/xenstored/domain.ml
+@@ -16,7 +16,7 @@
+
+ open Printf
+
+-let debug fmt = Logs.debug "general" fmt
++let debug fmt = Logging.debug "domain" fmt
+
+ type t =
+ {
+--- a/tools/ocaml/xenstored/domains.ml
++++ b/tools/ocaml/xenstored/domains.ml
+@@ -14,6 +14,8 @@
+ * GNU Lesser General Public License for more details.
+ *)
+
++let debug fmt = Logging.debug "domains" fmt
++
+ type domains = {
+ eventchn: Event.t;
+ table: (Xenctrl.domid, Domain.t) Hashtbl.t;
+@@ -35,7 +37,7 @@
+ try
+ 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)"
++ debug "Domain %u died (dying=%b, shutdown %b -- code %d)"
+ id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code;
+ if info.Xenctrl.dying then
+ dead_dom := id :: !dead_dom
+@@ -43,7 +45,7 @@
+ notify := true;
+ )
+ with Xenctrl.Error _ ->
+- Logs.debug "general" "Domain %u died -- no domain info" id;
++ debug "Domain %u died -- no domain info" id;
+ dead_dom := id :: !dead_dom;
+ ) doms.table;
+ List.iter (fun id ->
+--- a/tools/ocaml/xenstored/logging.ml
++++ b/tools/ocaml/xenstored/logging.ml
+@@ -17,21 +17,122 @@
+ open Stdext
+ open Printf
+
+-let error fmt = Logs.error "general" fmt
+-let info fmt = Logs.info "general" fmt
+-let debug fmt = Logs.debug "general" fmt
+
+-let access_log_file = ref "/var/log/xenstored-access.log"
+-let access_log_nb_files = ref 20
+-let access_log_nb_lines = ref 13215
+-let activate_access_log = ref true
++(* Logger common *)
++
++type logger =
++ { stop: unit -> unit;
++ restart: unit -> unit;
++ rotate: unit -> unit;
++ write: 'a. ('a, unit, string, unit) format4 -> 'a }
++
++let truncate_line nb_chars line =
++ if String.length line > nb_chars - 1 then
++ let len = max (nb_chars - 1) 2 in
++ let dst_line = String.create len in
++ String.blit line 0 dst_line 0 (len - 2);
++ dst_line.[len-2] <- '.';
++ dst_line.[len-1] <- '.';
++ dst_line
++ else line
++
++let log_rotate ref_ch log_file log_nb_files =
++ let file n = sprintf "%s.%i" log_file n in
++ let log_files =
++ let rec aux accu n =
++ if n >= log_nb_files then accu
++ else
++ if n = 1 && Sys.file_exists log_file
++ then aux [log_file,1] 2
++ else
++ let file = file (n-1) in
++ if Sys.file_exists file then
++ aux ((file, n) :: accu) (n+1)
++ else accu in
++ aux [] 1 in
++ List.iter (fun (f, n) -> Unix.rename f (file n)) log_files;
++ close_out !ref_ch;
++ ref_ch := open_out log_file
++
++let make_logger log_file log_nb_files log_nb_lines log_nb_chars post_rotate =
++ let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in
++ let counter = ref 0 in
++ let stop() =
++ try flush !channel; close_out !channel
++ with _ -> () in
++ let restart() =
++ stop();
++ channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in
++ let rotate() =
++ log_rotate channel log_file log_nb_files;
++ (post_rotate (): unit);
++ counter := 0 in
++ let output s =
++ let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in
++ let s = s ^ "\n" in
++ output_string !channel s;
++ flush !channel;
++ incr counter;
++ if !counter > log_nb_lines then rotate() in
++ { stop=stop; restart=restart; rotate=rotate; write = fun fmt -> Printf.ksprintf output fmt }
++
++
++(* Xenstored logger *)
++
++exception Unknown_level of string
++
++type level = Debug | Info | Warn | Error | Null
++
++let int_of_level = function
++ | Debug -> 0 | Info -> 1 | Warn -> 2
++ | Error -> 3 | Null -> max_int
++
++let string_of_level = function
++ | Debug -> "debug" | Info -> "info" | Warn -> "warn"
++ | Error -> "error" | Null -> "null"
++
++let level_of_string = function
++ | "debug" -> Debug | "info" -> Info | "warn" -> Warn
++ | "error" -> Error | "null" -> Null | s -> raise (Unknown_level s)
++
++let string_of_date () =
++ let time = Unix.gettimeofday () in
++ let tm = Unix.gmtime time in
++ let msec = time -. (floor time) in
++ sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ"
++ (1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
++ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
++ (int_of_float (1000.0 *. msec))
+
+-(* maximal size of the lines in xenstore-acces.log file *)
+-let line_size = 180
++let xenstored_log_file = ref "/var/log/xenstored.log"
++let xenstored_log_level = ref Null
++let xenstored_log_nb_files = ref 10
++let xenstored_log_nb_lines = ref 13215
++let xenstored_log_nb_chars = ref (-1)
++let xenstored_logger = ref (None: logger option)
++
++let init_xenstored_log () =
++ if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then
++ let logger =
++ make_logger
++ !xenstored_log_file !xenstored_log_nb_files !xenstored_log_nb_lines
++ !xenstored_log_nb_chars ignore in
++ xenstored_logger := Some logger
++
++let xenstored_logging level key (fmt: (_,_,_,_) format4) =
++ match !xenstored_logger with
++ | Some logger when int_of_level level >= int_of_level !xenstored_log_level ->
++ let date = string_of_date() in
++ let level = string_of_level level in
++ logger.write ("[%s|%5s|%s] " ^^ fmt) date level key
++ | _ -> Printf.ksprintf ignore fmt
++
++let debug key = xenstored_logging Debug key
++let info key = xenstored_logging Info key
++let warn key = xenstored_logging Warn key
++let error key = xenstored_logging Error key
+
+-let log_read_ops = ref false
+-let log_transaction_ops = ref false
+-let log_special_ops = ref false
++(* Access logger *)
+
+ type access_type =
+ | Coalesce
+@@ -41,38 +142,10 @@
+ | Endconn
+ | XbOp of Xenbus.Xb.Op.operation
+
+-type access =
+- {
+- fd: out_channel ref;
+- counter: int ref;
+- write: tid:int -> con:string -> ?data:string -> access_type -> unit;
+- }
+-
+-let string_of_date () =
+- let time = Unix.gettimeofday () in
+- let tm = Unix.localtime time in
+- let msec = time -. (floor time) in
+- sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d" (1900 + tm.Unix.tm_year)
+- (tm.Unix.tm_mon + 1)
+- tm.Unix.tm_mday
+- tm.Unix.tm_hour
+- tm.Unix.tm_min
+- tm.Unix.tm_sec
+- (int_of_float (1000.0 *. msec))
+-
+-let fill_with_space n s =
+- if String.length s < n
+- then
+- let r = String.make n ' ' in
+- String.blit s 0 r 0 (String.length s);
+- r
+- else
+- s
+-
+ let string_of_tid ~con tid =
+ if tid = 0
+- then fill_with_space 12 (sprintf "%s" con)
+- else fill_with_space 12 (sprintf "%s.%i" con tid)
++ then sprintf "%-12s" con
++ else sprintf "%-12s" (sprintf "%s.%i" con tid)
+
+ let string_of_access_type = function
+ | Coalesce -> "coalesce "
+@@ -109,41 +182,9 @@
+
+ | Xenbus.Xb.Op.Error -> "error "
+ | Xenbus.Xb.Op.Watchevent -> "w event "
+-
++ (*
+ | x -> Xenbus.Xb.Op.to_string x
+-
+-let file_exists file =
+- try
+- Unix.close (Unix.openfile file [Unix.O_RDONLY] 0o644);
+- true
+- with _ ->
+- false
+-
+-let log_rotate fd =
+- let file n = sprintf "%s.%i" !access_log_file n in
+- let log_files =
+- let rec aux accu n =
+- if n >= !access_log_nb_files
+- then accu
+- else if n = 1 && file_exists !access_log_file
+- then aux [!access_log_file,1] 2
+- else
+- let file = file (n-1) in
+- if file_exists file
+- then aux ((file,n) :: accu) (n+1)
+- else accu
+- in
+- aux [] 1
+- in
+- let rec rename = function
+- | (f,n) :: t when n < !access_log_nb_files ->
+- Unix.rename f (file n);
+- rename t
+- | _ -> ()
+- in
+- rename log_files;
+- close_out !fd;
+- fd := open_out !access_log_file
++ *)
+
+ let sanitize_data data =
+ let data = String.copy data in
+@@ -154,86 +195,68 @@
+ done;
+ String.escaped data
+
+-let make save_to_disk =
+- let fd = ref (open_out_gen [Open_append; Open_creat] 0o644 !access_log_file) in
+- let counter = ref 0 in
+- {
+- fd = fd;
+- counter = counter;
+- write =
+- if not !activate_access_log || !access_log_nb_files = 0
+- then begin fun ~tid ~con ?data _ -> () end
+- else fun ~tid ~con ?(data="") access_type ->
+- let s = Printf.sprintf "[%s] %s %s %s\n" (string_of_date()) (string_of_tid ~con tid)
+- (string_of_access_type access_type) (sanitize_data data) in
+- let s =
+- if String.length s > line_size
+- then begin
+- let s = String.sub s 0 line_size in
+- s.[line_size-3] <- '.';
+- s.[line_size-2] <- '.';
+- s.[line_size-1] <- '\n';
+- s
+- end else
+- s
+- in
+- incr counter;
+- output_string !fd s;
+- flush !fd;
+- if !counter > !access_log_nb_lines
+- then begin
+- log_rotate fd;
+- save_to_disk ();
+- counter := 0;
+- end
+- }
+-
+-let access : (access option) ref = ref None
+-let init aal save_to_disk =
+- activate_access_log := aal;
+- access := Some (make save_to_disk)
+-
+-let write_access_log ~con ~tid ?data access_type =
++let activate_access_log = ref true
++let access_log_file = ref "/var/log/xenstored-access.log"
++let access_log_nb_files = ref 20
++let access_log_nb_lines = ref 13215
++let access_log_nb_chars = ref 180
++let access_log_read_ops = ref false
++let access_log_transaction_ops = ref false
++let access_log_special_ops = ref false
++let access_logger = ref None
++
++let init_access_log post_rotate =
++ if !access_log_nb_files > 0 then
++ let logger =
++ make_logger
++ !access_log_file !access_log_nb_files !access_log_nb_lines
++ !access_log_nb_chars post_rotate in
++ access_logger := Some logger
++
++let access_logging ~con ~tid ?(data="") access_type =
+ try
+- maybe (fun a -> a.write access_type ~con ~tid ?data) !access
++ maybe
++ (fun logger ->
++ let date = string_of_date() in
++ let tid = string_of_tid ~con tid in
++ let access_type = string_of_access_type access_type in
++ let data = sanitize_data data in
++ logger.write "[%s] %s %s %s" date tid access_type data)
++ !access_logger
+ with _ -> ()
+
+-let new_connection = write_access_log Newconn
+-let end_connection = write_access_log Endconn
++let new_connection = access_logging Newconn
++let end_connection = access_logging Endconn
+ let read_coalesce ~tid ~con data =
+- if !log_read_ops
+- then write_access_log Coalesce ~tid ~con ~data:("read "^data)
+-let write_coalesce data = write_access_log Coalesce ~data:("write "^data)
+-let conflict = write_access_log Conflict
+-let commit = write_access_log Commit
++ if !access_log_read_ops
++ then access_logging Coalesce ~tid ~con ~data:("read "^data)
++let write_coalesce data = access_logging Coalesce ~data:("write "^data)
++let conflict = access_logging Conflict
++let commit = access_logging Commit
+
+ let xb_op ~tid ~con ~ty data =
+- let print =
+- match ty with
+- | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !log_read_ops
++ let print = match ty with
++ | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops
+ | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end ->
+ false (* transactions are managed below *)
+ | 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
+- if print
+- then write_access_log ~tid ~con ~data (XbOp ty)
++ !access_log_special_ops
++ | _ -> true in
++ if print then access_logging ~tid ~con ~data (XbOp ty)
+
+ let start_transaction ~tid ~con =
+- if !log_transaction_ops && tid <> 0
+- then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start)
++ if !access_log_transaction_ops && tid <> 0
++ then access_logging ~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 Xenbus.Xb.Op.Transaction_end)
++ if !access_log_transaction_ops && tid <> 0
++ then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end)
+
+ let xb_answer ~tid ~con ~ty data =
+ let print = match ty with
+- | Xenbus.Xb.Op.Error when data="ENOENT " -> !log_read_ops
+- | Xenbus.Xb.Op.Error -> !log_special_ops
++ | Xenbus.Xb.Op.Error when String.startswith "ENOENT " data -> !access_log_read_ops
++ | Xenbus.Xb.Op.Error -> true
+ | Xenbus.Xb.Op.Watchevent -> true
+ | _ -> false
+ in
+- if print
+- then write_access_log ~tid ~con ~data (XbOp ty)
++ if print then access_logging ~tid ~con ~data (XbOp ty)
+--- a/tools/ocaml/xenstored/perms.ml
++++ b/tools/ocaml/xenstored/perms.ml
+@@ -15,6 +15,8 @@
+ * GNU Lesser General Public License for more details.
+ *)
+
++let info fmt = Logging.info "perms" fmt
++
+ open Stdext
+
+ let activate = ref true
+@@ -145,16 +147,16 @@
+ in
+ match perm, request with
+ | NONE, _ ->
+- Logs.info "io" "Permission denied: Domain %d has no permission" domainid;
++ info "Permission denied: Domain %d has no permission" domainid;
+ false
+ | RDWR, _ -> true
+ | READ, READ -> true
+ | WRITE, WRITE -> true
+ | READ, _ ->
+- Logs.info "io" "Permission denied: Domain %d has read only access" domainid;
++ info "Permission denied: Domain %d has read only access" domainid;
+ false
+ | WRITE, _ ->
+- Logs.info "io" "Permission denied: Domain %d has write only access" domainid;
++ info "Permission denied: Domain %d has write only access" domainid;
+ false
+ in
+ if !activate
+--- a/tools/ocaml/xenstored/process.ml
++++ b/tools/ocaml/xenstored/process.ml
+@@ -14,6 +14,9 @@
+ * GNU Lesser General Public License for more details.
+ *)
+
++let error fmt = Logging.error "process" fmt
++let info fmt = Logging.info "process" fmt
++
+ open Printf
+ open Stdext
+
+@@ -79,7 +82,7 @@
+
+ (* packets *)
+ let do_debug con t domains cons data =
+- if not !allow_debug
++ if not (Connection.is_dom0 con) && not !allow_debug
+ then None
+ else try match split None '\000' data with
+ | "print" :: msg :: _ ->
+@@ -89,6 +92,9 @@
+ let domid = int_of_string domid in
+ let quota = (Store.get_quota t.Transaction.store) in
+ Some (Quota.to_string quota domid ^ "\000")
++ | "watches" :: _ ->
++ let watches = Connections.debug cons in
++ Some (watches ^ "\000")
+ | "mfn" :: domid :: _ ->
+ let domid = int_of_string domid in
+ let con = Connections.find_domain cons domid in
+@@ -357,8 +363,7 @@
+ in
+ input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data;
+ with exn ->
+- Logs.error "general" "process packet: %s"
+- (Printexc.to_string exn);
++ error "process packet: %s" (Printexc.to_string exn);
+ Connection.send_error con tid rid "EIO"
+
+ let write_access_log ~ty ~tid ~con ~data =
+@@ -372,7 +377,7 @@
+ let packet = Connection.pop_in con 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\""
++ info "[%s] -> [%d] %s \"%s\""
+ (Connection.get_domstr con) tid
+ (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *)
+ process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data;
+@@ -386,7 +391,7 @@
+ let packet = Connection.peek_output con 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\""
++ info "[%s] <- %s \"%s\""
+ (Connection.get_domstr con)
+ (Xenbus.Xb.Op.to_string ty) (sanitize_data data);*)
+ write_answer_log ~ty ~tid ~con ~data;
+--- a/tools/ocaml/xenstored/quota.ml
++++ b/tools/ocaml/xenstored/quota.ml
+@@ -18,7 +18,7 @@
+ exception Data_too_big
+ exception Transaction_opened
+
+-let warn fmt = Logs.warn "general" fmt
++let warn fmt = Logging.warn "quota" fmt
+ let activate = ref true
+ let maxent = ref (10000)
+ let maxsize = ref (4096)
+--- a/tools/ocaml/xenstored/store.ml
++++ b/tools/ocaml/xenstored/store.ml
+@@ -83,7 +83,7 @@
+ let check_owner node connection =
+ if not (Perms.check_owner connection node.perms)
+ then begin
+- Logs.info "io" "Permission denied: Domain %d not owner" (get_owner node);
++ Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node);
+ raise Define.Permission_denied;
+ end
+
+--- a/tools/ocaml/xenstored/xenstored.conf
++++ b/tools/ocaml/xenstored/xenstored.conf
+@@ -22,9 +22,14 @@
+ # Activate filed base backend
+ persistant = false
+
+-# Logs
+-log = error;general;file:/var/log/xenstored.log
+-log = warn;general;file:/var/log/xenstored.log
+-log = info;general;file:/var/log/xenstored.log
++# Xenstored logs
++# xenstored-log-file = /var/log/xenstored.log
++# xenstored-log-level = null
++# xenstored-log-nb-files = 10
++
++# Xenstored access logs
++# access-log-file = /var/log/xenstored-access.log
++# access-log-nb-lines = 13215
++# acesss-log-nb-chars = 180
++# access-log-special-ops = false
+
+-# log = debug;io;file:/var/log/xenstored-io.log
+--- a/tools/ocaml/xenstored/xenstored.ml
++++ b/tools/ocaml/xenstored/xenstored.ml
+@@ -18,7 +18,10 @@
+ open Printf
+ open Parse_arg
+ open Stdext
+-open Logging
++
++let error fmt = Logging.error "xenstored" fmt
++let debug fmt = Logging.debug "xenstored" fmt
++let info fmt = Logging.info "xenstored" fmt
+
+ (*------------ event klass processors --------------*)
+ let process_connection_fds store cons domains rset wset =
+@@ -64,7 +67,8 @@
+ ()
+
+ let sighup_handler _ =
+- try Logs.reopen (); info "Log re-opened" with _ -> ()
++ maybe (fun logger -> logger.Logging.restart()) !Logging.xenstored_logger;
++ maybe (fun logger -> logger.Logging.restart()) !Logging.access_logger
+
+ let config_filename cf =
+ match cf.config_file with
+@@ -75,26 +79,6 @@
+
+ let parse_config filename =
+ let pidfile = ref default_pidfile in
+- let set_log s =
+- let ls = String.split ~limit:3 ';' s in
+- let level, key, logger = match ls with
+- | [ level; key; logger ] -> level, key, logger
+- | _ -> failwith "format mismatch: expecting 3 arguments" in
+-
+- let loglevel = match level with
+- | "debug" -> Log.Debug
+- | "info" -> Log.Info
+- | "warn" -> Log.Warn
+- | "error" -> Log.Error
+- | s -> failwith (sprintf "Unknown log level: %s" s) in
+-
+- (* if key is empty, append to the default logger *)
+- let append =
+- if key = "" then
+- Logs.append_default
+- else
+- Logs.append key in
+- append loglevel logger in
+ let options = [
+ ("merge-activate", Config.Set_bool Transaction.do_coalesce);
+ ("perms-activate", Config.Set_bool Perms.activate);
+@@ -104,14 +88,20 @@
+ ("quota-maxentity", Config.Set_int Quota.maxent);
+ ("quota-maxsize", Config.Set_int Quota.maxsize);
+ ("test-eagain", Config.Set_bool Transaction.test_eagain);
+- ("log", Config.String set_log);
+ ("persistant", Config.Set_bool Disk.enable);
++ ("xenstored-log-file", Config.Set_string Logging.xenstored_log_file);
++ ("xenstored-log-level", Config.String
++ (fun s -> Logging.xenstored_log_level := Logging.level_of_string s));
++ ("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_files);
++ ("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lines);
++ ("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_chars);
+ ("access-log-file", Config.Set_string Logging.access_log_file);
+ ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files);
+ ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines);
+- ("access-log-read-ops", Config.Set_bool Logging.log_read_ops);
+- ("access-log-transactions-ops", Config.Set_bool Logging.log_transaction_ops);
+- ("access-log-special-ops", Config.Set_bool Logging.log_special_ops);
++ ("access-log-nb-chars", Config.Set_int Logging.access_log_nb_chars);
++ ("access-log-read-ops", Config.Set_bool Logging.access_log_read_ops);
++ ("access-log-transactions-ops", Config.Set_bool Logging.access_log_transaction_ops);
++ ("access-log-special-ops", Config.Set_bool Logging.access_log_special_ops);
+ ("allow-debug", Config.Set_bool Process.allow_debug);
+ ("pid-file", Config.Set_string pidfile); ] in
+ begin try Config.read filename options (fun _ _ -> raise Not_found)
+@@ -223,9 +213,6 @@
+ end
+
+ let _ =
+- printf "Xen Storage Daemon, version %d.%d\n%!"
+- Define.xenstored_major Define.xenstored_minor;
+-
+ let cf = do_argv in
+ let pidfile =
+ if Sys.file_exists (config_filename cf) then
+@@ -249,13 +236,13 @@
+ in
+
+ if cf.daemonize then
+- Unixext.daemonize ();
++ Unixext.daemonize ()
++ else
++ printf "Xen Storage Daemon, version %d.%d\n%!"
++ Define.xenstored_major Define.xenstored_minor;
+
+ (try Unixext.pidfile_write pidfile with _ -> ());
+
+- info "Xen Storage Daemon, version %d.%d"
+- Define.xenstored_major Define.xenstored_minor;
+-
+ (* for compatilibity with old xenstored *)
+ begin match cf.pidfile with
+ | Some pidfile -> Unixext.pidfile_write pidfile
+@@ -293,7 +280,14 @@
+ Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun i -> sigusr1_handler store));
+ Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
+
+- Logging.init cf.activate_access_log (fun () -> DB.to_file store cons "/var/run/xenstored/db");
++ Logging.init_xenstored_log();
++ if cf.activate_access_log then begin
++ let post_rotate () = DB.to_file store cons "/var/run/xenstored/db" in
++ Logging.init_access_log post_rotate
++ end;
++
++ info "Xen Storage Daemon, version %d.%d"
++ Define.xenstored_major Define.xenstored_minor;
+
+ let spec_fds =
+ (match rw_sock with None -> [] | Some x -> [ x ]) @
+--- a/tools/ocaml/libs/log/syslog.mli
++++ /dev/null
+@@ -1,41 +0,0 @@
+-(*
+- * Copyright (C) 2006-2007 XenSource Ltd.
+- * Copyright (C) 2008 Citrix Ltd.
+- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+- *
+- * This program is free software; you can redistribute it and/or modify
+- * it under the terms of the GNU Lesser General Public License as published
+- * by the Free Software Foundation; version 2.1 only. with the special
+- * exception on linking described in file LICENSE.
+- *
+- * This program is distributed in the hope that it will be useful,
+- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+- * GNU Lesser General Public License for more details.
+- *)
+-
+-type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
+-type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
+-type facility =
+- Auth
+- | Authpriv
+- | Cron
+- | Daemon
+- | Ftp
+- | Kern
+- | Local0
+- | Local1
+- | Local2
+- | Local3
+- | Local4
+- | Local5
+- | Local6
+- | Local7
+- | Lpr
+- | Mail
+- | News
+- | Syslog
+- | User
+- | Uucp
+-external log : facility -> level -> string -> unit = "stub_syslog"
+-external close : unit -> unit = "stub_closelog"
+--- a/tools/ocaml/libs/log/Makefile
++++ /dev/null
+@@ -1,44 +0,0 @@
+-TOPLEVEL=$(CURDIR)/../..
+-XEN_ROOT=$(TOPLEVEL)/../..
+-include $(TOPLEVEL)/common.make
+-
+-OBJS = syslog log logs
+-INTF = log.cmi logs.cmi syslog.cmi
+-LIBS = log.cma log.cmxa
+-
+-all: $(INTF) $(LIBS) $(PROGRAMS)
+-
+-bins: $(PROGRAMS)
+-
+-libs: $(LIBS)
+-
+-log.cmxa: libsyslog_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+- $(call mk-caml-lib-native, $@, -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmx))
+-
+-log.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+- $(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmo))
+-
+-syslog_stubs.a: syslog_stubs.o
+- $(call mk-caml-stubs, $@, $+)
+-
+-libsyslog_stubs.a: syslog_stubs.o
+- $(call mk-caml-lib-stubs, $@, $+)
+-
+-logs.mli : logs.ml
+- $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
+-
+-syslog.mli : syslog.ml
+- $(OCAMLC) -i $< > $@
+-
+-.PHONY: install
+-install: $(LIBS) META
+- mkdir -p $(OCAMLDESTDIR)
+- ocamlfind remove -destdir $(OCAMLDESTDIR) log
+- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx
+-
+-.PHONY: uninstall
+-uninstall:
+- ocamlfind remove -destdir $(OCAMLDESTDIR) log
+-
+-include $(TOPLEVEL)/Makefile.rules
+-
projects / people / ms / ipfire-3.x.git / commitdiff
