^tools/ocaml/libs/xl/_libxl_types\.ml\.in$
^tools/ocaml/libs/xl/_libxl_types\.mli\.in$
^tools/ocaml/libs/xl/_libxl_types\.inc$
-^tools/ocaml/libs/xl/xl\.ml$
-^tools/ocaml/libs/xl/xl\.mli$
+^tools/ocaml/libs/xl/xenlight\.ml$
+^tools/ocaml/libs/xl/xenlight\.mli$
^tools/ocaml/xenstored/oxenstored$
^xen/\.banner.*$
^xen/BLOG$
version = "@VERSION@"
description = "Eventchn interface extension"
requires = "unix"
-archive(byte) = "eventchn.cma"
-archive(native) = "eventchn.cmxa"
+archive(byte) = "xeneventchn.cma"
+archive(native) = "xeneventchn.cmxa"
CFLAGS += $(CFLAGS_libxenctrl) $(CFLAGS_xeninclude)
-OBJS = eventchn
+OBJS = xeneventchn
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
-LIBS = eventchn.cma eventchn.cmxa
+LIBS = xeneventchn.cma xeneventchn.cmxa
-LIBS_evtchn = $(LDLIBS_libxenctrl)
+LIBS_xeneventchn = $(LDLIBS_libxenctrl)
all: $(INTF) $(LIBS) $(PROGRAMS)
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
+++ /dev/null
-(*
- * 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
-(*
- * 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
-/*
- * 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
+(*
+ * 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
+(*
+ * 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
+/*
+ * 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);
+}
version = "@VERSION@"
description = "Mmap interface extension"
-archive(byte) = "mmap.cma"
-archive(native) = "mmap.cmxa"
+archive(byte) = "xenmmap.cma"
+archive(native) = "xenmmap.cmxa"
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)
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
+++ /dev/null
-(*
- * 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
-(*
- * 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
-/*
- * 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 Intf_val(a) ((struct mmap_interface *) a)
-
-static int mmap_interface_init(struct mmap_interface *intf,
- int fd, int pflag, int mflag,
- int len, int offset)
-{
- intf->len = len;
- intf->addr = mmap(NULL, len, pflag, mflag, fd, offset);
- return (intf->addr == MAP_FAILED) ? errno : 0;
-}
-
-CAMLprim value stub_mmap_init(value fd, value pflag, value mflag,
- value len, value offset)
-{
- CAMLparam5(fd, pflag, mflag, len, offset);
- CAMLlocal1(result);
- int c_pflag, c_mflag;
-
- switch (Int_val(pflag)) {
- case 0: c_pflag = PROT_READ; break;
- case 1: c_pflag = PROT_WRITE; break;
- case 2: c_pflag = PROT_READ|PROT_WRITE; break;
- default: caml_invalid_argument("protectiontype");
- }
-
- switch (Int_val(mflag)) {
- case 0: c_mflag = MAP_SHARED; break;
- case 1: c_mflag = MAP_PRIVATE; break;
- default: caml_invalid_argument("maptype");
- }
-
- result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
-
- if (mmap_interface_init(Intf_val(result), Int_val(fd),
- c_pflag, c_mflag,
- Int_val(len), Int_val(offset)))
- caml_failwith("mmap");
- CAMLreturn(result);
-}
-
-CAMLprim value stub_mmap_final(value intf)
-{
- CAMLparam1(intf);
-
- if (Intf_val(intf)->addr != MAP_FAILED)
- munmap(Intf_val(intf)->addr, Intf_val(intf)->len);
- Intf_val(intf)->addr = MAP_FAILED;
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_mmap_read(value intf, value start, value len)
-{
- CAMLparam3(intf, start, len);
- CAMLlocal1(data);
- int c_start;
- int c_len;
-
- c_start = Int_val(start);
- c_len = Int_val(len);
-
- if (c_start > Intf_val(intf)->len)
- caml_invalid_argument("start invalid");
- if (c_start + c_len > Intf_val(intf)->len)
- caml_invalid_argument("len invalid");
-
- data = caml_alloc_string(c_len);
- memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len);
-
- CAMLreturn(data);
-}
-
-CAMLprim value stub_mmap_write(value intf, value data,
- value start, value len)
-{
- CAMLparam4(intf, data, start, len);
- int c_start;
- int c_len;
-
- c_start = Int_val(start);
- c_len = Int_val(len);
-
- if (c_start > Intf_val(intf)->len)
- caml_invalid_argument("start invalid");
- if (c_start + c_len > Intf_val(intf)->len)
- caml_invalid_argument("len invalid");
-
- memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len);
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_mmap_getpagesize(value unit)
-{
- CAMLparam1(unit);
- CAMLlocal1(data);
-
- data = Val_int(getpagesize());
- CAMLreturn(data);
-}
--- /dev/null
+(*
+ * 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
+(*
+ * 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
+/*
+ * 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 Intf_val(a) ((struct mmap_interface *) a)
+
+static int mmap_interface_init(struct mmap_interface *intf,
+ int fd, int pflag, int mflag,
+ int len, int offset)
+{
+ intf->len = len;
+ intf->addr = mmap(NULL, len, pflag, mflag, fd, offset);
+ return (intf->addr == MAP_FAILED) ? errno : 0;
+}
+
+CAMLprim value stub_mmap_init(value fd, value pflag, value mflag,
+ value len, value offset)
+{
+ CAMLparam5(fd, pflag, mflag, len, offset);
+ CAMLlocal1(result);
+ int c_pflag, c_mflag;
+
+ switch (Int_val(pflag)) {
+ case 0: c_pflag = PROT_READ; break;
+ case 1: c_pflag = PROT_WRITE; break;
+ case 2: c_pflag = PROT_READ|PROT_WRITE; break;
+ default: caml_invalid_argument("protectiontype");
+ }
+
+ switch (Int_val(mflag)) {
+ case 0: c_mflag = MAP_SHARED; break;
+ case 1: c_mflag = MAP_PRIVATE; break;
+ default: caml_invalid_argument("maptype");
+ }
+
+ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
+
+ if (mmap_interface_init(Intf_val(result), Int_val(fd),
+ c_pflag, c_mflag,
+ Int_val(len), Int_val(offset)))
+ caml_failwith("mmap");
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_mmap_final(value intf)
+{
+ CAMLparam1(intf);
+
+ if (Intf_val(intf)->addr != MAP_FAILED)
+ munmap(Intf_val(intf)->addr, Intf_val(intf)->len);
+ Intf_val(intf)->addr = MAP_FAILED;
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_mmap_read(value intf, value start, value len)
+{
+ CAMLparam3(intf, start, len);
+ CAMLlocal1(data);
+ int c_start;
+ int c_len;
+
+ c_start = Int_val(start);
+ c_len = Int_val(len);
+
+ if (c_start > Intf_val(intf)->len)
+ caml_invalid_argument("start invalid");
+ if (c_start + c_len > Intf_val(intf)->len)
+ caml_invalid_argument("len invalid");
+
+ data = caml_alloc_string(c_len);
+ memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len);
+
+ CAMLreturn(data);
+}
+
+CAMLprim value stub_mmap_write(value intf, value data,
+ value start, value len)
+{
+ CAMLparam4(intf, data, start, len);
+ int c_start;
+ int c_len;
+
+ c_start = Int_val(start);
+ c_len = Int_val(len);
+
+ if (c_start > Intf_val(intf)->len)
+ caml_invalid_argument("start invalid");
+ if (c_start + c_len > Intf_val(intf)->len)
+ caml_invalid_argument("len invalid");
+
+ memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len);
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_mmap_getpagesize(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(data);
+
+ data = Val_int(getpagesize());
+ CAMLreturn(data);
+}
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"
CFLAGS += $(CFLAGS_libxenctrl) # For xen_mb()
CFLAGS += $(CFLAGS_xeninclude)
OCAMLINCLUDE += -I ../mmap
+OCAMLOPTFLAGS += -for-pack Xenbus
.NOTPARALLEL:
# Ocaml is such a PITA!
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)
libs: $(LIBS)
-xb_OBJS = $(OBJS)
-xb_C_OBJS = xs_ring_stubs xb_stubs
-OCAML_LIBRARY = xb
+xenbus_OBJS = xenbus
+xenbus_C_OBJS = xs_ring_stubs xenbus_stubs
+OCAML_LIBRARY = xenbus
+
+xenbus.cmx : $(foreach obj, $(OBJS), $(obj).cmx)
+ $(E) " CMX $@"
+ $(OCAMLOPT) -pack -o $@ $^
+
+xenbus.cmo : $(foreach obj, $(OBJS), $(obj).cmo)
+ $(E) " CMO $@"
+ $(OCAMLC) -pack -o $@ $^
%.mli: %.ml
$(E) " MLI $@"
- $(Q)$(OCAMLC) -i $< $o
+ $(Q)$(OCAMLC) $(OCAMLINCLUDE) -i $< $o
.PHONY: install
install: $(LIBS) META
mkdir -p $(OCAMLDESTDIR)
- ocamlfind remove -destdir $(OCAMLDESTDIR) xb
- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenbus
+ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenbus META $(LIBS) xenbus.cmo xenbus.cmi xenbus.cmx *.a *.so
.PHONY: uninstall
uninstall:
- ocamlfind remove -destdir $(OCAMLDESTDIR) xb
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenbus
include $(TOPLEVEL)/Makefile.rules
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;
}
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
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
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 *)
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; })
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)
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")
-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
+++ /dev/null
-/*
- * 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
+/*
+ * 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);
+}
* 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"
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"
CFLAGS += -I../mmap $(CFLAGS_libxenctrl) $(CFLAGS_libxenguest)
OCAMLINCLUDE += -I ../mmap -I ../uuid
-OBJS = xc
-INTF = xc.cmi
-LIBS = xc.cma xc.cmxa
+OBJS = xenctrl
+INTF = xenctrl.cmi
+LIBS = xenctrl.cma xenctrl.cmxa
-LIBS_xc = $(LDLIBS_libxenctrl) $(LDLIBS_libxenguest)
+LIBS_xenctrl = $(LDLIBS_libxenctrl) $(LDLIBS_libxenguest)
-xc_OBJS = $(OBJS)
-xc_C_OBJS = xc_stubs
+xenctrl_OBJS = $(OBJS)
+xenctrl_C_OBJS = xenctrl_stubs
-OCAML_LIBRARY = xc
+OCAML_LIBRARY = xenctrl
all: $(INTF) $(LIBS)
.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
+++ /dev/null
-(*
- * 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")
+++ /dev/null
-(*
- * 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"
-
+++ /dev/null
-/*
- * 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
+(*
+ * 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
+(*
+ * 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
+/*
+ * 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:
+ */
CFLAGS += -Wno-unused
CFLAGS += $(CFLAGS_libxenlight)
-OBJS = xl
-INTF = xl.cmi
-LIBS = xl.cma xl.cmxa
+OBJS = xenlight
+INTF = xenlight.cmi
+LIBS = xenlight.cma xenlight.cmxa
-LIBS_xl = $(LDLIBS_libxenlight)
+LIBS_xenlight = $(LDLIBS_libxenlight)
-xl_OBJS = $(OBJS)
-xl_C_OBJS = xl_stubs
+xenlight_OBJS = $(OBJS)
+xenlight_C_OBJS = xenlight_stubs
-OCAML_LIBRARY = xl
+OCAML_LIBRARY = xenlight
-GENERATED_FILES += xl.ml xl.ml.tmp xl.mli xl.mli.tmp
+GENERATED_FILES += xenlight.ml xenlight.ml.tmp xenlight.mli xenlight.mli.tmp
GENERATED_FILES += _libxl_types.ml.in _libxl_types.mli.in
GENERATED_FILES += _libxl_types.inc
all: $(INTF) $(LIBS)
-xl.ml: xl.ml.in _libxl_types.ml.in
+xenlight.ml: xenlight.ml.in _libxl_types.ml.in
$(Q)sed -e '1i\
(*\
* AUTO-GENERATED FILE DO NOT EDIT\
- * Generated from xl.ml.in and _libxl_types.ml.in\
+ * Generated from xenlight.ml.in and _libxl_types.ml.in\
*)\
' \
-e '/^(\* @@LIBXL_TYPES@@ \*)$$/r_libxl_types.ml.in' \
- < xl.ml.in > xl.ml.tmp
- $(Q)mv xl.ml.tmp xl.ml
+ < xenlight.ml.in > xenlight.ml.tmp
+ $(Q)mv xenlight.ml.tmp xenlight.ml
-xl.mli: xl.mli.in _libxl_types.mli.in
+xenlight.mli: xenlight.mli.in _libxl_types.mli.in
$(Q)sed -e '1i\
(*\
* AUTO-GENERATED FILE DO NOT EDIT\
- * Generated from xl.mli.in and _libxl_types.mli.in\
+ * Generated from xenlight.mli.in and _libxl_types.mli.in\
*)\
' \
-e '/^(\* @@LIBXL_TYPES@@ \*)$$/r_libxl_types.mli.in' \
- < xl.mli.in > xl.mli.tmp
- $(Q)mv xl.mli.tmp xl.mli
+ < xenlight.mli.in > xenlight.mli.tmp
+ $(Q)mv xenlight.mli.tmp xenlight.mli
_libxl_types.ml.in _libxl_types.mli.in _libxl_types.inc: genwrap.py $(XEN_ROOT)/tools/libxl/libxl_types.idl \
$(XEN_ROOT)/tools/libxl/libxltypes.py
.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
+(*
+ * Copyright (C) 2009-2011 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 domid = int
+
+(* @@LIBXL_TYPES@@ *)
+
+module Topologyinfo = struct
+ type t =
+ {
+ core : int;
+ socket : int;
+ node : int;
+ }
+ external get : unit -> t = "stub_xl_topologyinfo"
+end
+
+external button_press : domid -> button -> unit = "stub_xl_button_press"
+
+
+external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger"
+external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
+external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
+
+let _ = Callback.register_exception "xl.error" (Error "register_callback")
--- /dev/null
+(*
+ * Copyright (C) 2009-2011 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 domid = int
+
+(* @@LIBXL_TYPES@@ *)
+
+module Topologyinfo : sig
+ type t =
+ {
+ core : int;
+ socket : int;
+ node : int;
+ }
+ external get : unit -> t = "stub_xl_topologyinfo"
+end
+
+external button_press : domid -> button -> unit = "stub_xl_button_press"
+
+external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger"
+external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
+external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
--- /dev/null
+/*
+ * Copyright (C) 2009-2011 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;
+
+static void log_vmessage(struct xentoollog_logger *logger, xentoollog_level level,
+ int errnoval, const char *context, const char *format, va_list al)
+{
+ struct caml_logger *ologger = (struct caml_logger *) logger;
+
+ ologger->log_offset += vsnprintf(ologger->log_buf + ologger->log_offset,
+ 2048 - ologger->log_offset, format, al);
+}
+
+static void log_destroy(struct xentoollog_logger *logger)
+{
+}
+
+#define INIT_STRUCT() libxl_ctx *ctx; struct caml_logger lg; struct caml_gc gc; gc.offset = 0;
+
+#define INIT_CTX() \
+ lg.logger.vmessage = log_vmessage; \
+ lg.logger.destroy = log_destroy; \
+ lg.logger.progress = NULL; \
+ caml_enter_blocking_section(); \
+ ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, (struct xentoollog_logger *) &lg); \
+ if (ret != 0) \
+ failwith_xl("cannot init context", &lg);
+
+#define FREE_CTX() \
+ gc_free(&gc); \
+ caml_leave_blocking_section(); \
+ libxl_ctx_free(ctx)
+
+static char * dup_String_val(caml_gc *gc, value s)
+{
+ int len;
+ char *c;
+ len = caml_string_length(s);
+ c = calloc(len + 1, sizeof(char));
+ if (!c)
+ caml_raise_out_of_memory();
+ gc->ptrs[gc->offset++] = c;
+ memcpy(c, String_val(s), len);
+ return c;
+}
+
+static void gc_free(caml_gc *gc)
+{
+ int i;
+ for (i = 0; i < gc->offset; i++) {
+ free(gc->ptrs[i]);
+ }
+}
+
+static void failwith_xl(char *fname, struct caml_logger *lg)
+{
+ char *s;
+ s = (lg) ? lg->log_buf : fname;
+ caml_raise_with_string(*caml_named_value("xl.error"), s);
+}
+
+#if 0 /* TODO: wrap libxl_domain_create(), these functions will be needed then */
+static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size)
+{
+ void *ptr;
+ ptr = calloc(nmemb, size);
+ if (!ptr)
+ caml_raise_out_of_memory();
+ gc->ptrs[gc->offset++] = ptr;
+ return ptr;
+}
+
+static int string_string_tuple_array_val (caml_gc *gc, char ***c_val, value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(a);
+ int i;
+ char **array;
+
+ for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1)) { i++; }
+
+ array = gc_calloc(gc, (i + 1) * 2, sizeof(char *));
+ if (!array)
+ return 1;
+ for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1), i++) {
+ value b = Field(a, 0);
+ array[i * 2] = dup_String_val(gc, Field(b, 0));
+ array[i * 2 + 1] = dup_String_val(gc, Field(b, 1));
+ }
+ *c_val = array;
+ CAMLreturn(0);
+}
+
+#endif
+
+static value Val_mac (libxl_mac *c_val)
+{
+ CAMLparam0();
+ CAMLlocal1(v);
+ int i;
+
+ v = caml_alloc_tuple(6);
+
+ for(i=0; i<6; i++)
+ Store_field(v, i, Val_int((*c_val)[i]));
+
+ CAMLreturn(v);
+}
+
+static int Mac_val(caml_gc *gc, struct caml_logger *lg, libxl_mac *c_val, value v)
+{
+ CAMLparam1(v);
+ int i;
+
+ for(i=0; i<6; i++)
+ (*c_val)[i] = Int_val(Field(v, i));
+
+ CAMLreturn(0);
+}
+
+static value Val_uuid (libxl_uuid *c_val)
+{
+ CAMLparam0();
+ CAMLlocal1(v);
+ uint8_t *uuid = libxl_uuid_bytearray(c_val);
+ int i;
+
+ v = caml_alloc_tuple(16);
+
+ for(i=0; i<16; i++)
+ Store_field(v, i, Val_int(uuid[i]));
+
+ CAMLreturn(v);
+}
+
+static int Uuid_val(caml_gc *gc, struct caml_logger *lg, libxl_uuid *c_val, value v)
+{
+ CAMLparam1(v);
+ int i;
+ uint8_t *uuid = libxl_uuid_bytearray(c_val);
+
+ for(i=0; i<16; i++)
+ uuid[i] = Int_val(Field(v, i));
+
+ CAMLreturn(0);
+}
+
+static value Val_hwcap(libxl_hwcap *c_val)
+{
+ CAMLparam0();
+ CAMLlocal1(hwcap);
+ int i;
+
+ hwcap = caml_alloc_tuple(8);
+ for (i = 0; i < 8; i++)
+ Store_field(hwcap, i, caml_copy_int32((*c_val)[i]));
+
+ CAMLreturn(hwcap);
+}
+
+#include "_libxl_types.inc"
+
+static value Val_topologyinfo(libxl_topologyinfo *c_val)
+{
+ CAMLparam0();
+ CAMLlocal3(v, topology, topologyinfo);
+ int i;
+
+ topologyinfo = caml_alloc_tuple(c_val->coremap.entries);
+ for (i = 0; i < c_val->coremap.entries; i++) {
+ v = Val_int(0); /* None */
+ if (c_val->coremap.array[i] != LIBXL_CPUARRAY_INVALID_ENTRY) {
+ topology = caml_alloc_tuple(3);
+ Store_field(topology, 0, Val_int(c_val->coremap.array[i]));
+ Store_field(topology, 1, Val_int(c_val->socketmap.array[i]));
+ Store_field(topology, 2, Val_int(c_val->nodemap.array[i]));
+ v = caml_alloc(1, 0); /* Some */
+ Store_field(v, 0, topology);
+ }
+ Store_field(topologyinfo, i, v);
+ }
+
+ CAMLreturn(topologyinfo);
+}
+
+value stub_xl_device_disk_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_disk c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_disk_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_disk_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("disk_add", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_disk_del(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_disk c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_disk_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_disk_del(ctx, Int_val(domid), &c_info, 0);
+ if (ret != 0)
+ failwith_xl("disk_del", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_nic_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_nic c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_nic_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_nic_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("nic_add", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_nic_del(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_nic c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_nic_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_nic_del(ctx, Int_val(domid), &c_info, 0);
+ if (ret != 0)
+ failwith_xl("nic_del", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_console_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_console c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_console_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_console_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("console_add", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vkb_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_vkb c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_vkb_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_vkb_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("vkb_add", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vkb_clean_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_vkb_clean_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("vkb_clean_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vkb_hard_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_vkb_hard_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("vkb_hard_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vfb_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_vfb c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_vfb_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_vfb_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("vfb_add", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vfb_clean_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_vfb_clean_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("vfb_clean_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_vfb_hard_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_vfb_hard_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("vfb_hard_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_pci_add(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_pci c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_pci_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_pci_add(ctx, Int_val(domid), &c_info);
+ if (ret != 0)
+ failwith_xl("pci_add", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_pci_remove(value info, value domid)
+{
+ CAMLparam2(info, domid);
+ libxl_device_pci c_info;
+ int ret;
+ INIT_STRUCT();
+
+ device_pci_val(&gc, &lg, &c_info, info);
+
+ INIT_CTX();
+ ret = libxl_device_pci_remove(ctx, Int_val(domid), &c_info, 0);
+ if (ret != 0)
+ failwith_xl("pci_remove", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_device_pci_shutdown(value domid)
+{
+ CAMLparam1(domid);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_device_pci_shutdown(ctx, Int_val(domid));
+ if (ret != 0)
+ failwith_xl("pci_shutdown", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_button_press(value domid, value button)
+{
+ CAMLparam2(domid, button);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_button_press(ctx, Int_val(domid), Int_val(button) + LIBXL_BUTTON_POWER);
+ if (ret != 0)
+ failwith_xl("button_press", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_physinfo_get(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(physinfo);
+ libxl_physinfo c_physinfo;
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_get_physinfo(ctx, &c_physinfo);
+ if (ret != 0)
+ failwith_xl("physinfo", &lg);
+ FREE_CTX();
+
+ physinfo = Val_physinfo(&gc, &lg, &c_physinfo);
+ CAMLreturn(physinfo);
+}
+
+value stub_xl_topologyinfo(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(topologyinfo);
+ libxl_topologyinfo c_topologyinfo;
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_get_topologyinfo(ctx, &c_topologyinfo);
+ if (ret != 0)
+ failwith_xl("topologyinfo", &lg);
+ FREE_CTX();
+
+ topologyinfo = Val_topologyinfo(&c_topologyinfo);
+ CAMLreturn(topologyinfo);
+}
+
+value stub_xl_sched_credit_domain_get(value domid)
+{
+ CAMLparam1(domid);
+ CAMLlocal1(scinfo);
+ libxl_sched_credit c_scinfo;
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_sched_credit_domain_get(ctx, Int_val(domid), &c_scinfo);
+ if (ret != 0)
+ failwith_xl("sched_credit_domain_get", &lg);
+ FREE_CTX();
+
+ scinfo = Val_sched_credit(&gc, &lg, &c_scinfo);
+ CAMLreturn(scinfo);
+}
+
+value stub_xl_sched_credit_domain_set(value domid, value scinfo)
+{
+ CAMLparam2(domid, scinfo);
+ libxl_sched_credit c_scinfo;
+ int ret;
+ INIT_STRUCT();
+
+ sched_credit_val(&gc, &lg, &c_scinfo, scinfo);
+
+ INIT_CTX();
+ ret = libxl_sched_credit_domain_set(ctx, Int_val(domid), &c_scinfo);
+ if (ret != 0)
+ failwith_xl("sched_credit_domain_set", &lg);
+ FREE_CTX();
+
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_send_trigger(value domid, value trigger, value vcpuid)
+{
+ CAMLparam3(domid, trigger, vcpuid);
+ int ret;
+ char *c_trigger;
+ INIT_STRUCT();
+
+ c_trigger = dup_String_val(&gc, trigger);
+
+ INIT_CTX();
+ ret = libxl_send_trigger(ctx, Int_val(domid), c_trigger, Int_val(vcpuid));
+ if (ret != 0)
+ failwith_xl("send_trigger", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_send_sysrq(value domid, value sysrq)
+{
+ CAMLparam2(domid, sysrq);
+ int ret;
+ INIT_STRUCT();
+
+ INIT_CTX();
+ ret = libxl_send_sysrq(ctx, Int_val(domid), Int_val(sysrq));
+ if (ret != 0)
+ failwith_xl("send_sysrq", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+value stub_xl_send_debug_keys(value keys)
+{
+ CAMLparam1(keys);
+ int ret;
+ char *c_keys;
+ INIT_STRUCT();
+
+ c_keys = dup_String_val(&gc, keys);
+
+ INIT_CTX();
+ ret = libxl_send_debug_keys(ctx, c_keys);
+ if (ret != 0)
+ failwith_xl("send_debug_keys", &lg);
+ FREE_CTX();
+ CAMLreturn(Val_unit);
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
+++ /dev/null
-(*
- * Copyright (C) 2009-2011 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 domid = int
-
-(* @@LIBXL_TYPES@@ *)
-
-module Topologyinfo = struct
- type t =
- {
- core : int;
- socket : int;
- node : int;
- }
- external get : unit -> t = "stub_xl_topologyinfo"
-end
-
-external button_press : domid -> button -> unit = "stub_xl_button_press"
-
-
-external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
-
-let _ = Callback.register_exception "xl.error" (Error "register_callback")
+++ /dev/null
-(*
- * Copyright (C) 2009-2011 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 domid = int
-
-(* @@LIBXL_TYPES@@ *)
-
-module Topologyinfo : sig
- type t =
- {
- core : int;
- socket : int;
- node : int;
- }
- external get : unit -> t = "stub_xl_topologyinfo"
-end
-
-external button_press : domid -> button -> unit = "stub_xl_button_press"
-
-external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
+++ /dev/null
-/*
- * Copyright (C) 2009-2011 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;
-
-static void log_vmessage(struct xentoollog_logger *logger, xentoollog_level level,
- int errnoval, const char *context, const char *format, va_list al)
-{
- struct caml_logger *ologger = (struct caml_logger *) logger;
-
- ologger->log_offset += vsnprintf(ologger->log_buf + ologger->log_offset,
- 2048 - ologger->log_offset, format, al);
-}
-
-static void log_destroy(struct xentoollog_logger *logger)
-{
-}
-
-#define INIT_STRUCT() libxl_ctx *ctx; struct caml_logger lg; struct caml_gc gc; gc.offset = 0;
-
-#define INIT_CTX() \
- lg.logger.vmessage = log_vmessage; \
- lg.logger.destroy = log_destroy; \
- lg.logger.progress = NULL; \
- caml_enter_blocking_section(); \
- ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, (struct xentoollog_logger *) &lg); \
- if (ret != 0) \
- failwith_xl("cannot init context", &lg);
-
-#define FREE_CTX() \
- gc_free(&gc); \
- caml_leave_blocking_section(); \
- libxl_ctx_free(ctx)
-
-static char * dup_String_val(caml_gc *gc, value s)
-{
- int len;
- char *c;
- len = caml_string_length(s);
- c = calloc(len + 1, sizeof(char));
- if (!c)
- caml_raise_out_of_memory();
- gc->ptrs[gc->offset++] = c;
- memcpy(c, String_val(s), len);
- return c;
-}
-
-static void gc_free(caml_gc *gc)
-{
- int i;
- for (i = 0; i < gc->offset; i++) {
- free(gc->ptrs[i]);
- }
-}
-
-static void failwith_xl(char *fname, struct caml_logger *lg)
-{
- char *s;
- s = (lg) ? lg->log_buf : fname;
- caml_raise_with_string(*caml_named_value("xl.error"), s);
-}
-
-#if 0 /* TODO: wrap libxl_domain_create(), these functions will be needed then */
-static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size)
-{
- void *ptr;
- ptr = calloc(nmemb, size);
- if (!ptr)
- caml_raise_out_of_memory();
- gc->ptrs[gc->offset++] = ptr;
- return ptr;
-}
-
-static int string_string_tuple_array_val (caml_gc *gc, char ***c_val, value v)
-{
- CAMLparam1(v);
- CAMLlocal1(a);
- int i;
- char **array;
-
- for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1)) { i++; }
-
- array = gc_calloc(gc, (i + 1) * 2, sizeof(char *));
- if (!array)
- return 1;
- for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1), i++) {
- value b = Field(a, 0);
- array[i * 2] = dup_String_val(gc, Field(b, 0));
- array[i * 2 + 1] = dup_String_val(gc, Field(b, 1));
- }
- *c_val = array;
- CAMLreturn(0);
-}
-
-#endif
-
-static value Val_mac (libxl_mac *c_val)
-{
- CAMLparam0();
- CAMLlocal1(v);
- int i;
-
- v = caml_alloc_tuple(6);
-
- for(i=0; i<6; i++)
- Store_field(v, i, Val_int((*c_val)[i]));
-
- CAMLreturn(v);
-}
-
-static int Mac_val(caml_gc *gc, struct caml_logger *lg, libxl_mac *c_val, value v)
-{
- CAMLparam1(v);
- int i;
-
- for(i=0; i<6; i++)
- (*c_val)[i] = Int_val(Field(v, i));
-
- CAMLreturn(0);
-}
-
-static value Val_uuid (libxl_uuid *c_val)
-{
- CAMLparam0();
- CAMLlocal1(v);
- uint8_t *uuid = libxl_uuid_bytearray(c_val);
- int i;
-
- v = caml_alloc_tuple(16);
-
- for(i=0; i<16; i++)
- Store_field(v, i, Val_int(uuid[i]));
-
- CAMLreturn(v);
-}
-
-static int Uuid_val(caml_gc *gc, struct caml_logger *lg, libxl_uuid *c_val, value v)
-{
- CAMLparam1(v);
- int i;
- uint8_t *uuid = libxl_uuid_bytearray(c_val);
-
- for(i=0; i<16; i++)
- uuid[i] = Int_val(Field(v, i));
-
- CAMLreturn(0);
-}
-
-static value Val_hwcap(libxl_hwcap *c_val)
-{
- CAMLparam0();
- CAMLlocal1(hwcap);
- int i;
-
- hwcap = caml_alloc_tuple(8);
- for (i = 0; i < 8; i++)
- Store_field(hwcap, i, caml_copy_int32((*c_val)[i]));
-
- CAMLreturn(hwcap);
-}
-
-#include "_libxl_types.inc"
-
-static value Val_topologyinfo(libxl_topologyinfo *c_val)
-{
- CAMLparam0();
- CAMLlocal3(v, topology, topologyinfo);
- int i;
-
- topologyinfo = caml_alloc_tuple(c_val->coremap.entries);
- for (i = 0; i < c_val->coremap.entries; i++) {
- v = Val_int(0); /* None */
- if (c_val->coremap.array[i] != LIBXL_CPUARRAY_INVALID_ENTRY) {
- topology = caml_alloc_tuple(3);
- Store_field(topology, 0, Val_int(c_val->coremap.array[i]));
- Store_field(topology, 1, Val_int(c_val->socketmap.array[i]));
- Store_field(topology, 2, Val_int(c_val->nodemap.array[i]));
- v = caml_alloc(1, 0); /* Some */
- Store_field(v, 0, topology);
- }
- Store_field(topologyinfo, i, v);
- }
-
- CAMLreturn(topologyinfo);
-}
-
-value stub_xl_device_disk_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_disk c_info;
- int ret;
- INIT_STRUCT();
-
- device_disk_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_disk_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("disk_add", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_disk_del(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_disk c_info;
- int ret;
- INIT_STRUCT();
-
- device_disk_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_disk_del(ctx, Int_val(domid), &c_info, 0);
- if (ret != 0)
- failwith_xl("disk_del", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_nic_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_nic c_info;
- int ret;
- INIT_STRUCT();
-
- device_nic_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_nic_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("nic_add", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_nic_del(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_nic c_info;
- int ret;
- INIT_STRUCT();
-
- device_nic_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_nic_del(ctx, Int_val(domid), &c_info, 0);
- if (ret != 0)
- failwith_xl("nic_del", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_console_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_console c_info;
- int ret;
- INIT_STRUCT();
-
- device_console_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_console_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("console_add", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_vkb c_info;
- int ret;
- INIT_STRUCT();
-
- device_vkb_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_vkb_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("vkb_add", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_clean_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_vkb_clean_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("vkb_clean_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_hard_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_vkb_hard_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("vkb_hard_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_vfb c_info;
- int ret;
- INIT_STRUCT();
-
- device_vfb_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_vfb_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("vfb_add", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_clean_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_vfb_clean_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("vfb_clean_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_hard_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_vfb_hard_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("vfb_hard_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_add(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_pci c_info;
- int ret;
- INIT_STRUCT();
-
- device_pci_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_pci_add(ctx, Int_val(domid), &c_info);
- if (ret != 0)
- failwith_xl("pci_add", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_remove(value info, value domid)
-{
- CAMLparam2(info, domid);
- libxl_device_pci c_info;
- int ret;
- INIT_STRUCT();
-
- device_pci_val(&gc, &lg, &c_info, info);
-
- INIT_CTX();
- ret = libxl_device_pci_remove(ctx, Int_val(domid), &c_info, 0);
- if (ret != 0)
- failwith_xl("pci_remove", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_shutdown(value domid)
-{
- CAMLparam1(domid);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_device_pci_shutdown(ctx, Int_val(domid));
- if (ret != 0)
- failwith_xl("pci_shutdown", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_button_press(value domid, value button)
-{
- CAMLparam2(domid, button);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_button_press(ctx, Int_val(domid), Int_val(button) + LIBXL_BUTTON_POWER);
- if (ret != 0)
- failwith_xl("button_press", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_physinfo_get(value unit)
-{
- CAMLparam1(unit);
- CAMLlocal1(physinfo);
- libxl_physinfo c_physinfo;
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_get_physinfo(ctx, &c_physinfo);
- if (ret != 0)
- failwith_xl("physinfo", &lg);
- FREE_CTX();
-
- physinfo = Val_physinfo(&gc, &lg, &c_physinfo);
- CAMLreturn(physinfo);
-}
-
-value stub_xl_topologyinfo(value unit)
-{
- CAMLparam1(unit);
- CAMLlocal1(topologyinfo);
- libxl_topologyinfo c_topologyinfo;
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_get_topologyinfo(ctx, &c_topologyinfo);
- if (ret != 0)
- failwith_xl("topologyinfo", &lg);
- FREE_CTX();
-
- topologyinfo = Val_topologyinfo(&c_topologyinfo);
- CAMLreturn(topologyinfo);
-}
-
-value stub_xl_sched_credit_domain_get(value domid)
-{
- CAMLparam1(domid);
- CAMLlocal1(scinfo);
- libxl_sched_credit c_scinfo;
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_sched_credit_domain_get(ctx, Int_val(domid), &c_scinfo);
- if (ret != 0)
- failwith_xl("sched_credit_domain_get", &lg);
- FREE_CTX();
-
- scinfo = Val_sched_credit(&gc, &lg, &c_scinfo);
- CAMLreturn(scinfo);
-}
-
-value stub_xl_sched_credit_domain_set(value domid, value scinfo)
-{
- CAMLparam2(domid, scinfo);
- libxl_sched_credit c_scinfo;
- int ret;
- INIT_STRUCT();
-
- sched_credit_val(&gc, &lg, &c_scinfo, scinfo);
-
- INIT_CTX();
- ret = libxl_sched_credit_domain_set(ctx, Int_val(domid), &c_scinfo);
- if (ret != 0)
- failwith_xl("sched_credit_domain_set", &lg);
- FREE_CTX();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_trigger(value domid, value trigger, value vcpuid)
-{
- CAMLparam3(domid, trigger, vcpuid);
- int ret;
- char *c_trigger;
- INIT_STRUCT();
-
- c_trigger = dup_String_val(&gc, trigger);
-
- INIT_CTX();
- ret = libxl_send_trigger(ctx, Int_val(domid), c_trigger, Int_val(vcpuid));
- if (ret != 0)
- failwith_xl("send_trigger", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_sysrq(value domid, value sysrq)
-{
- CAMLparam2(domid, sysrq);
- int ret;
- INIT_STRUCT();
-
- INIT_CTX();
- ret = libxl_send_sysrq(ctx, Int_val(domid), Int_val(sysrq));
- if (ret != 0)
- failwith_xl("send_sysrq", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_debug_keys(value keys)
-{
- CAMLparam1(keys);
- int ret;
- char *c_keys;
- INIT_STRUCT();
-
- c_keys = dup_String_val(&gc, keys);
-
- INIT_CTX();
- ret = libxl_send_debug_keys(ctx, c_keys);
- if (ret != 0)
- failwith_xl("send_debug_keys", &lg);
- FREE_CTX();
- CAMLreturn(Val_unit);
-}
-
-/*
- * Local variables:
- * indent-tabs-mode: t
- * c-basic-offset: 8
- * tab-width: 8
- * End:
- */
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"
include $(TOPLEVEL)/common.make
OCAMLINCLUDE += -I ../xb/
+OCAMLOPTFLAGS += -for-pack Xenstore
.NOTPARALLEL:
# Ocaml is such a PITA!
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)
libs: $(LIBS)
-xs_OBJS = $(OBJS)
-OCAML_NOC_LIBRARY = xs
+xenstore_OBJS = xenstore
+OCAML_NOC_LIBRARY = xenstore
+
+xenstore.cmx : $(foreach obj, $(OBJS), $(obj).cmx)
+ $(E) " CMX $@"
+ $(Q)$(OCAMLOPT) -pack -o $@ $^
+
+xenstore.cmo : $(foreach obj, $(OBJS), $(obj).cmo)
+ $(E) " CMO $@"
+ $(Q)$(OCAMLC) -pack -o $@ $^
+
.PHONY: install
install: $(LIBS) META
mkdir -p $(OCAMLDESTDIR)
- ocamlfind remove -destdir $(OCAMLDESTDIR) xs
- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenstore
+ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenstore META $(LIBS) xenstore.cmo xenstore.cmi xenstore.cmx *.a
.PHONY: uninstall
uninstall:
- ocamlfind remove -destdir $(OCAMLDESTDIR) xs
+ ocamlfind remove -destdir $(OCAMLDESTDIR) xenstore
include $(TOPLEVEL)/Makefile.rules
* 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 =
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
* GNU Lesser General Public License for more details.
*)
+open Xenbus
+
exception Partial_not_empty
exception Unexpected_packet of string
raise (Unexpected_packet s)
type con = {
- xb: Xb.t;
+ xb: Xenbus.Xb.t;
watchevents: (string * string) Queue.t;
}
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
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
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
}
and t = {
- xb: Xb.t;
+ xb: Xenbus.Xb.t;
dom: Domain.t option;
transactions: (int, Transaction.t) Hashtbl.t;
mutable next_tid: int;
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
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 =
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 =
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
let get_transaction con tid =
Hashtbl.find con.transactions tid
-let do_input con = Xb.input con.xb
-let has_input con = Xb.has_in_packet con.xb
-let pop_in con = Xb.get_in_packet con.xb
-let has_more_input con = Xb.has_more_input con.xb
+let do_input con = Xenbus.Xb.input con.xb
+let has_input con = Xenbus.Xb.has_in_packet con.xb
+let pop_in con = Xenbus.Xb.get_in_packet con.xb
+let has_more_input con = Xenbus.Xb.has_more_input con.xb
-let has_output con = Xb.has_output con.xb
-let has_new_output con = Xb.has_new_output con.xb
-let peek_output con = Xb.peek_output con.xb
-let do_output con = Xb.output con.xb
+let has_output con = Xenbus.Xb.has_output con.xb
+let has_new_output con = Xenbus.Xb.has_new_output con.xb
+let peek_output con = Xenbus.Xb.peek_output con.xb
+let do_output con = Xenbus.Xb.output con.xb
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
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
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;
}
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 = {
type domains = {
eventchn: Event.t;
- table: (Xc.domid, Domain.t) Hashtbl.t;
+ table: (Xenctrl.domid, Domain.t) Hashtbl.t;
}
let init eventchn =
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;
()
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;
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
)
(**************** 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
| Commit
| Newconn
| Endconn
- | XbOp of Xb.Op.operation
+ | XbOp of Xenbus.Xb.Op.operation
type access =
{
| Endconn -> "endconn "
| XbOp op -> match op with
- | Xb.Op.Debug -> "debug "
+ | Xenbus.Xb.Op.Debug -> "debug "
- | Xb.Op.Directory -> "directory"
- | Xb.Op.Read -> "read "
- | Xb.Op.Getperms -> "getperms "
+ | Xenbus.Xb.Op.Directory -> "directory"
+ | Xenbus.Xb.Op.Read -> "read "
+ | Xenbus.Xb.Op.Getperms -> "getperms "
- | Xb.Op.Watch -> "watch "
- | Xb.Op.Unwatch -> "unwatch "
+ | Xenbus.Xb.Op.Watch -> "watch "
+ | Xenbus.Xb.Op.Unwatch -> "unwatch "
- | Xb.Op.Transaction_start -> "t start "
- | Xb.Op.Transaction_end -> "t end "
+ | Xenbus.Xb.Op.Transaction_start -> "t start "
+ | Xenbus.Xb.Op.Transaction_end -> "t end "
- | Xb.Op.Introduce -> "introduce"
- | Xb.Op.Release -> "release "
- | Xb.Op.Getdomainpath -> "getdomain"
- | Xb.Op.Isintroduced -> "is introduced"
- | Xb.Op.Resume -> "resume "
+ | Xenbus.Xb.Op.Introduce -> "introduce"
+ | Xenbus.Xb.Op.Release -> "release "
+ | Xenbus.Xb.Op.Getdomainpath -> "getdomain"
+ | Xenbus.Xb.Op.Isintroduced -> "is introduced"
+ | Xenbus.Xb.Op.Resume -> "resume "
- | Xb.Op.Write -> "write "
- | Xb.Op.Mkdir -> "mkdir "
- | Xb.Op.Rm -> "rm "
- | Xb.Op.Setperms -> "setperms "
- | Xb.Op.Restrict -> "restrict "
- | Xb.Op.Set_target -> "settarget"
+ | Xenbus.Xb.Op.Write -> "write "
+ | Xenbus.Xb.Op.Mkdir -> "mkdir "
+ | Xenbus.Xb.Op.Rm -> "rm "
+ | Xenbus.Xb.Op.Setperms -> "setperms "
+ | Xenbus.Xb.Op.Restrict -> "restrict "
+ | Xenbus.Xb.Op.Set_target -> "settarget"
- | Xb.Op.Error -> "error "
- | Xb.Op.Watchevent -> "w event "
+ | Xenbus.Xb.Op.Error -> "error "
+ | Xenbus.Xb.Op.Watchevent -> "w event "
- | x -> Xb.Op.to_string x
+ | x -> Xenbus.Xb.Op.to_string x
let file_exists file =
try
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
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
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 =
module Connection =
struct
-type elt = Xc.domid * (permty list)
+type elt = Xenctrl.domid * (permty list)
type t =
{ main: elt;
target: elt option; }
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
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
| _ -> 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 =
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";
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 =
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;
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)
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 =
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;
}
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
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
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 =
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
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
);
(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 =
projects / xen.git / commitdiff