+++ /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 / amarx / ipfire-3.x.git / commitdiff
