From d486191b1ad2dbb5b0c16c35f167c6311d167005 Mon Sep 17 00:00:00 2001 From: Michael Young Date: Jan 28 2012 16:15:37 +0000 Subject: Start building xen's ocaml libraries --- diff --git a/upstream-23936:cdb34816a40a-rework b/upstream-23936:cdb34816a40a-rework new file mode 100644 index 0000000..b7bc317 --- /dev/null +++ b/upstream-23936:cdb34816a40a-rework @@ -0,0 +1,7924 @@ +# HG changeset patch +# User Jon Ludlam +# Date 1317293932 -3600 +# Node ID ba4cba41f5550684719bc95a25f8f51b92fb604f +# Parent 7998217630e236639825d4db174c852cfa18e709 +[OCAML] Rename the ocamlfind packages + +This patch has the same effect as xen-unstable.hg +c/s 23936:cdb34816a40a. + +ocamlfind does not support namespaces, so to avoid +name clashes the ocamlfind package names have been +changed. Note that this does not change the names +of the actual modules themselves. + +xb becomes xenbus, xc becomes xenctrl, xl becomes xenlight, +xs becomes xenstore, eventchn becomes xeneventchn. + +Signed-off-by: Jon Ludlam + +--- a/tools/ocaml/libs/eventchn/META.in ++++ b/tools/ocaml/libs/eventchn/META.in +@@ -1,5 +1,5 @@ + version = "@VERSION@" + description = "Eventchn interface extension" + requires = "unix" +-archive(byte) = "eventchn.cma" +-archive(native) = "eventchn.cmxa" ++archive(byte) = "xeneventchn.cma" ++archive(native) = "xeneventchn.cmxa" +--- a/tools/ocaml/libs/eventchn/Makefile ++++ b/tools/ocaml/libs/eventchn/Makefile +@@ -2,9 +2,11 @@ + XEN_ROOT=$(TOPLEVEL)/../.. + include $(TOPLEVEL)/common.make + +-OBJS = eventchn ++OBJS = xeneventchn + INTF = $(foreach obj, $(OBJS),$(obj).cmi) +-LIBS = eventchn.cma eventchn.cmxa ++LIBS = xeneventchn.cma xeneventchn.cmxa ++ ++LIBS_xeneventchn = $(LDLIBS_libxenctrl) + + all: $(INTF) $(LIBS) $(PROGRAMS) + +@@ -12,20 +14,20 @@ + + libs: $(LIBS) + +-eventchn_OBJS = $(OBJS) +-eventchn_C_OBJS = eventchn_stubs ++xeneventchn_OBJS = $(OBJS) ++xeneventchn_C_OBJS = xeneventchn_stubs + +-OCAML_LIBRARY = eventchn ++OCAML_LIBRARY = xeneventchn + + .PHONY: install + install: $(LIBS) META + mkdir -p $(OCAMLDESTDIR) +- ocamlfind remove -destdir $(OCAMLDESTDIR) eventchn +- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xeneventchn ++ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xeneventchn META $(INTF) $(LIBS) *.a *.so *.cmx + + .PHONY: uninstall + uninstall: +- ocamlfind remove -destdir $(OCAMLDESTDIR) eventchn ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xeneventchn + + include $(TOPLEVEL)/Makefile.rules + +--- a/tools/ocaml/libs/eventchn/eventchn.ml ++++ /dev/null +@@ -1,30 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-exception Error of string +- +-type handle +- +-external init: unit -> handle = "stub_eventchn_init" +-external fd: handle -> Unix.file_descr = "stub_eventchn_fd" +-external notify: handle -> int -> unit = "stub_eventchn_notify" +-external bind_interdomain: handle -> int -> int -> int = "stub_eventchn_bind_interdomain" +-external bind_dom_exc_virq: handle -> int = "stub_eventchn_bind_dom_exc_virq" +-external unbind: handle -> int -> unit = "stub_eventchn_unbind" +-external pending: handle -> int = "stub_eventchn_pending" +-external unmask: handle -> int -> unit = "stub_eventchn_unmask" +- +-let _ = Callback.register_exception "eventchn.error" (Error "register_callback") +--- a/tools/ocaml/libs/eventchn/eventchn.mli ++++ /dev/null +@@ -1,31 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-exception Error of string +- +-type handle +- +-external init : unit -> handle = "stub_eventchn_init" +-external fd: handle -> Unix.file_descr = "stub_eventchn_fd" +- +-external notify : handle -> int -> unit = "stub_eventchn_notify" +-external bind_interdomain : handle -> int -> int -> int +- = "stub_eventchn_bind_interdomain" +-external bind_dom_exc_virq : handle -> int = "stub_eventchn_bind_dom_exc_virq" +-external unbind : handle -> int -> unit = "stub_eventchn_unbind" +-external pending : handle -> int = "stub_eventchn_pending" +-external unmask : handle -> int -> unit +- = "stub_eventchn_unmask" +--- a/tools/ocaml/libs/eventchn/eventchn_stubs.c ++++ /dev/null +@@ -1,143 +0,0 @@ +-/* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * 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 +-#include +-#include +-#include +-#include +-#include +-#include +-#include +-#include +-#include +-#include +- +-#define CAML_NAME_SPACE +-#include +-#include +-#include +-#include +-#include +-#include +- +-#define _H(__h) ((xc_interface *)(__h)) +- +-CAMLprim value stub_eventchn_init(void) +-{ +- CAMLparam0(); +- CAMLlocal1(result); +- +- xc_interface *xce = xc_evtchn_open(NULL, XC_OPENFLAG_NON_REENTRANT); +- if (xce == NULL) +- caml_failwith("open failed"); +- +- result = (value)xce; +- CAMLreturn(result); +-} +- +-CAMLprim value stub_eventchn_fd(value xce) +-{ +- CAMLparam1(xce); +- CAMLlocal1(result); +- int fd; +- +- fd = xc_evtchn_fd(_H(xce)); +- if (fd == -1) +- caml_failwith("evtchn fd failed"); +- +- result = Val_int(fd); +- +- CAMLreturn(result); +-} +- +-CAMLprim value stub_eventchn_notify(value xce, value port) +-{ +- CAMLparam2(xce, port); +- int rc; +- +- rc = xc_evtchn_notify(_H(xce), Int_val(port)); +- if (rc == -1) +- caml_failwith("evtchn notify failed"); +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_eventchn_bind_interdomain(value xce, value domid, +- value remote_port) +-{ +- CAMLparam3(xce, domid, remote_port); +- CAMLlocal1(port); +- evtchn_port_or_error_t rc; +- +- rc = xc_evtchn_bind_interdomain(_H(xce), Int_val(domid), Int_val(remote_port)); +- if (rc == -1) +- caml_failwith("evtchn bind_interdomain failed"); +- port = Val_int(rc); +- +- CAMLreturn(port); +-} +- +-CAMLprim value stub_eventchn_bind_dom_exc_virq(value xce) +-{ +- CAMLparam1(xce); +- CAMLlocal1(port); +- evtchn_port_or_error_t rc; +- +- rc = xc_evtchn_bind_virq(_H(xce), VIRQ_DOM_EXC); +- if (rc == -1) +- caml_failwith("evtchn bind_dom_exc_virq failed"); +- port = Val_int(rc); +- +- CAMLreturn(port); +-} +- +-CAMLprim value stub_eventchn_unbind(value xce, value port) +-{ +- CAMLparam2(xce, port); +- int rc; +- +- rc = xc_evtchn_unbind(_H(xce), Int_val(port)); +- if (rc == -1) +- caml_failwith("evtchn unbind failed"); +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_eventchn_pending(value xce) +-{ +- CAMLparam1(xce); +- CAMLlocal1(result); +- evtchn_port_or_error_t port; +- +- port = xc_evtchn_pending(_H(xce)); +- if (port == -1) +- caml_failwith("evtchn pending failed"); +- result = Val_int(port); +- +- CAMLreturn(result); +-} +- +-CAMLprim value stub_eventchn_unmask(value xce, value _port) +-{ +- CAMLparam2(xce, _port); +- evtchn_port_t port; +- +- port = Int_val(_port); +- if (xc_evtchn_unmask(_H(xce), port)) +- caml_failwith("evtchn unmask failed"); +- CAMLreturn(Val_unit); +-} +--- /dev/null ++++ b/tools/ocaml/libs/eventchn/xeneventchn.ml +@@ -0,0 +1,30 @@ ++(* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * This program is free software; you can redistribute it and/or modify ++ * it under the terms of the GNU Lesser General Public License as published ++ * by the Free Software Foundation; version 2.1 only. with the special ++ * exception on linking described in file LICENSE. ++ * ++ * This program is distributed in the hope that it will be useful, ++ * but WITHOUT ANY WARRANTY; without even the implied warranty of ++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ * GNU Lesser General Public License for more details. ++ *) ++ ++exception Error of string ++ ++type handle ++ ++external init: unit -> handle = "stub_eventchn_init" ++external fd: handle -> Unix.file_descr = "stub_eventchn_fd" ++external notify: handle -> int -> unit = "stub_eventchn_notify" ++external bind_interdomain: handle -> int -> int -> int = "stub_eventchn_bind_interdomain" ++external bind_dom_exc_virq: handle -> int = "stub_eventchn_bind_dom_exc_virq" ++external unbind: handle -> int -> unit = "stub_eventchn_unbind" ++external pending: handle -> int = "stub_eventchn_pending" ++external unmask: handle -> int -> unit = "stub_eventchn_unmask" ++ ++let _ = Callback.register_exception "eventchn.error" (Error "register_callback") +--- /dev/null ++++ b/tools/ocaml/libs/eventchn/xeneventchn.mli +@@ -0,0 +1,31 @@ ++(* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * This program is free software; you can redistribute it and/or modify ++ * it under the terms of the GNU Lesser General Public License as published ++ * by the Free Software Foundation; version 2.1 only. with the special ++ * exception on linking described in file LICENSE. ++ * ++ * This program is distributed in the hope that it will be useful, ++ * but WITHOUT ANY WARRANTY; without even the implied warranty of ++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ * GNU Lesser General Public License for more details. ++ *) ++ ++exception Error of string ++ ++type handle ++ ++external init : unit -> handle = "stub_eventchn_init" ++external fd: handle -> Unix.file_descr = "stub_eventchn_fd" ++ ++external notify : handle -> int -> unit = "stub_eventchn_notify" ++external bind_interdomain : handle -> int -> int -> int ++ = "stub_eventchn_bind_interdomain" ++external bind_dom_exc_virq : handle -> int = "stub_eventchn_bind_dom_exc_virq" ++external unbind : handle -> int -> unit = "stub_eventchn_unbind" ++external pending : handle -> int = "stub_eventchn_pending" ++external unmask : handle -> int -> unit ++ = "stub_eventchn_unmask" +--- /dev/null ++++ b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c +@@ -0,0 +1,143 @@ ++/* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * 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 ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++ ++#define CAML_NAME_SPACE ++#include ++#include ++#include ++#include ++#include ++#include ++ ++#define _H(__h) ((xc_interface *)(__h)) ++ ++CAMLprim value stub_eventchn_init(void) ++{ ++ CAMLparam0(); ++ CAMLlocal1(result); ++ ++ xc_interface *xce = xc_evtchn_open(NULL, XC_OPENFLAG_NON_REENTRANT); ++ if (xce == NULL) ++ caml_failwith("open failed"); ++ ++ result = (value)xce; ++ CAMLreturn(result); ++} ++ ++CAMLprim value stub_eventchn_fd(value xce) ++{ ++ CAMLparam1(xce); ++ CAMLlocal1(result); ++ int fd; ++ ++ fd = xc_evtchn_fd(_H(xce)); ++ if (fd == -1) ++ caml_failwith("evtchn fd failed"); ++ ++ result = Val_int(fd); ++ ++ CAMLreturn(result); ++} ++ ++CAMLprim value stub_eventchn_notify(value xce, value port) ++{ ++ CAMLparam2(xce, port); ++ int rc; ++ ++ rc = xc_evtchn_notify(_H(xce), Int_val(port)); ++ if (rc == -1) ++ caml_failwith("evtchn notify failed"); ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_eventchn_bind_interdomain(value xce, value domid, ++ value remote_port) ++{ ++ CAMLparam3(xce, domid, remote_port); ++ CAMLlocal1(port); ++ evtchn_port_or_error_t rc; ++ ++ rc = xc_evtchn_bind_interdomain(_H(xce), Int_val(domid), Int_val(remote_port)); ++ if (rc == -1) ++ caml_failwith("evtchn bind_interdomain failed"); ++ port = Val_int(rc); ++ ++ CAMLreturn(port); ++} ++ ++CAMLprim value stub_eventchn_bind_dom_exc_virq(value xce) ++{ ++ CAMLparam1(xce); ++ CAMLlocal1(port); ++ evtchn_port_or_error_t rc; ++ ++ rc = xc_evtchn_bind_virq(_H(xce), VIRQ_DOM_EXC); ++ if (rc == -1) ++ caml_failwith("evtchn bind_dom_exc_virq failed"); ++ port = Val_int(rc); ++ ++ CAMLreturn(port); ++} ++ ++CAMLprim value stub_eventchn_unbind(value xce, value port) ++{ ++ CAMLparam2(xce, port); ++ int rc; ++ ++ rc = xc_evtchn_unbind(_H(xce), Int_val(port)); ++ if (rc == -1) ++ caml_failwith("evtchn unbind failed"); ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_eventchn_pending(value xce) ++{ ++ CAMLparam1(xce); ++ CAMLlocal1(result); ++ evtchn_port_or_error_t port; ++ ++ port = xc_evtchn_pending(_H(xce)); ++ if (port == -1) ++ caml_failwith("evtchn pending failed"); ++ result = Val_int(port); ++ ++ CAMLreturn(result); ++} ++ ++CAMLprim value stub_eventchn_unmask(value xce, value _port) ++{ ++ CAMLparam2(xce, _port); ++ evtchn_port_t port; ++ ++ port = Int_val(_port); ++ if (xc_evtchn_unmask(_H(xce), port)) ++ caml_failwith("evtchn unmask failed"); ++ CAMLreturn(Val_unit); ++} +--- a/tools/ocaml/libs/mmap/META.in ++++ b/tools/ocaml/libs/mmap/META.in +@@ -1,4 +1,4 @@ + version = "@VERSION@" + description = "Mmap interface extension" +-archive(byte) = "mmap.cma" +-archive(native) = "mmap.cmxa" ++archive(byte) = "xenmmap.cma" ++archive(native) = "xenmmap.cmxa" +--- a/tools/ocaml/libs/mmap/Makefile ++++ b/tools/ocaml/libs/mmap/Makefile +@@ -2,9 +2,9 @@ + XEN_ROOT=$(TOPLEVEL)/../.. + include $(TOPLEVEL)/common.make + +-OBJS = mmap ++OBJS = xenmmap + INTF = $(foreach obj, $(OBJS),$(obj).cmi) +-LIBS = mmap.cma mmap.cmxa ++LIBS = xenmmap.cma xenmmap.cmxa + + all: $(INTF) $(LIBS) $(PROGRAMS) + +@@ -12,19 +12,19 @@ + + libs: $(LIBS) + +-mmap_OBJS = $(OBJS) +-mmap_C_OBJS = mmap_stubs +-OCAML_LIBRARY = mmap ++xenmmap_OBJS = $(OBJS) ++xenmmap_C_OBJS = xenmmap_stubs ++OCAML_LIBRARY = xenmmap + + .PHONY: install + install: $(LIBS) META + mkdir -p $(OCAMLDESTDIR) +- ocamlfind remove -destdir $(OCAMLDESTDIR) mmap +- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore mmap META $(INTF) $(LIBS) *.a *.so *.cmx ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenmmap ++ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenmmap META $(INTF) $(LIBS) *.a *.so *.cmx + + .PHONY: uninstall + uninstall: +- ocamlfind remove -destdir $(OCAMLDESTDIR) mmap ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenmmap + + include $(TOPLEVEL)/Makefile.rules + +--- a/tools/ocaml/libs/mmap/mmap.ml ++++ /dev/null +@@ -1,31 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-type mmap_interface +- +-type mmap_prot_flag = RDONLY | WRONLY | RDWR +-type mmap_map_flag = SHARED | PRIVATE +- +-(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *) +-external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag +- -> int -> int -> mmap_interface = "stub_mmap_init" +-external unmap: mmap_interface -> unit = "stub_mmap_final" +-(* read: interface -> start -> length -> data *) +-external read: mmap_interface -> int -> int -> string = "stub_mmap_read" +-(* write: interface -> data -> start -> length -> unit *) +-external write: mmap_interface -> string -> int -> int -> unit = "stub_mmap_write" +-(* getpagesize: unit -> size of page *) +-external getpagesize: unit -> int = "stub_mmap_getpagesize" +--- a/tools/ocaml/libs/mmap/mmap.mli ++++ /dev/null +@@ -1,28 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-type mmap_interface +-type mmap_prot_flag = RDONLY | WRONLY | RDWR +-type mmap_map_flag = SHARED | PRIVATE +- +-external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int +- -> mmap_interface = "stub_mmap_init" +-external unmap : mmap_interface -> unit = "stub_mmap_final" +-external read : mmap_interface -> int -> int -> string = "stub_mmap_read" +-external write : mmap_interface -> string -> int -> int -> unit +- = "stub_mmap_write" +- +-external getpagesize : unit -> int = "stub_mmap_getpagesize" +--- a/tools/ocaml/libs/mmap/mmap_stubs.c ++++ /dev/null +@@ -1,136 +0,0 @@ +-/* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * 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 +-#include +-#include +-#include +-#include +-#include "mmap_stubs.h" +- +-#include +-#include +-#include +-#include +-#include +-#include +- +-#define GET_C_STRUCT(a) ((struct mmap_interface *) a) +- +-static int mmap_interface_init(struct mmap_interface *intf, +- int fd, int pflag, int mflag, +- int len, int offset) +-{ +- intf->len = len; +- intf->addr = mmap(NULL, len, pflag, mflag, fd, offset); +- return (intf->addr == MAP_FAILED) ? errno : 0; +-} +- +-CAMLprim value stub_mmap_init(value fd, value pflag, value mflag, +- value len, value offset) +-{ +- CAMLparam5(fd, pflag, mflag, len, offset); +- CAMLlocal1(result); +- int c_pflag, c_mflag; +- +- switch (Int_val(pflag)) { +- case 0: c_pflag = PROT_READ; break; +- case 1: c_pflag = PROT_WRITE; break; +- case 2: c_pflag = PROT_READ|PROT_WRITE; break; +- default: caml_invalid_argument("protectiontype"); +- } +- +- switch (Int_val(mflag)) { +- case 0: c_mflag = MAP_SHARED; break; +- case 1: c_mflag = MAP_PRIVATE; break; +- default: caml_invalid_argument("maptype"); +- } +- +- result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); +- +- if (mmap_interface_init(GET_C_STRUCT(result), Int_val(fd), +- c_pflag, c_mflag, +- Int_val(len), Int_val(offset))) +- caml_failwith("mmap"); +- CAMLreturn(result); +-} +- +-CAMLprim value stub_mmap_final(value interface) +-{ +- CAMLparam1(interface); +- struct mmap_interface *intf; +- +- intf = GET_C_STRUCT(interface); +- if (intf->addr != MAP_FAILED) +- munmap(intf->addr, intf->len); +- intf->addr = MAP_FAILED; +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_mmap_read(value interface, value start, value len) +-{ +- CAMLparam3(interface, start, len); +- CAMLlocal1(data); +- struct mmap_interface *intf; +- int c_start; +- int c_len; +- +- c_start = Int_val(start); +- c_len = Int_val(len); +- intf = GET_C_STRUCT(interface); +- +- if (c_start > intf->len) +- caml_invalid_argument("start invalid"); +- if (c_start + c_len > intf->len) +- caml_invalid_argument("len invalid"); +- +- data = caml_alloc_string(c_len); +- memcpy((char *) data, intf->addr + c_start, c_len); +- +- CAMLreturn(data); +-} +- +-CAMLprim value stub_mmap_write(value interface, value data, +- value start, value len) +-{ +- CAMLparam4(interface, data, start, len); +- struct mmap_interface *intf; +- int c_start; +- int c_len; +- +- c_start = Int_val(start); +- c_len = Int_val(len); +- intf = GET_C_STRUCT(interface); +- +- if (c_start > intf->len) +- caml_invalid_argument("start invalid"); +- if (c_start + c_len > intf->len) +- caml_invalid_argument("len invalid"); +- +- memcpy(intf->addr + c_start, (char *) data, c_len); +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_mmap_getpagesize(value unit) +-{ +- CAMLparam1(unit); +- CAMLlocal1(data); +- +- data = Val_int(getpagesize()); +- CAMLreturn(data); +-} +--- /dev/null ++++ b/tools/ocaml/libs/mmap/xenmmap.ml +@@ -0,0 +1,31 @@ ++(* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * This program is free software; you can redistribute it and/or modify ++ * it under the terms of the GNU Lesser General Public License as published ++ * by the Free Software Foundation; version 2.1 only. with the special ++ * exception on linking described in file LICENSE. ++ * ++ * This program is distributed in the hope that it will be useful, ++ * but WITHOUT ANY WARRANTY; without even the implied warranty of ++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ * GNU Lesser General Public License for more details. ++ *) ++ ++type mmap_interface ++ ++type mmap_prot_flag = RDONLY | WRONLY | RDWR ++type mmap_map_flag = SHARED | PRIVATE ++ ++(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *) ++external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag ++ -> int -> int -> mmap_interface = "stub_mmap_init" ++external unmap: mmap_interface -> unit = "stub_mmap_final" ++(* read: interface -> start -> length -> data *) ++external read: mmap_interface -> int -> int -> string = "stub_mmap_read" ++(* write: interface -> data -> start -> length -> unit *) ++external write: mmap_interface -> string -> int -> int -> unit = "stub_mmap_write" ++(* getpagesize: unit -> size of page *) ++external getpagesize: unit -> int = "stub_mmap_getpagesize" +--- /dev/null ++++ b/tools/ocaml/libs/mmap/xenmmap.mli +@@ -0,0 +1,28 @@ ++(* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * This program is free software; you can redistribute it and/or modify ++ * it under the terms of the GNU Lesser General Public License as published ++ * by the Free Software Foundation; version 2.1 only. with the special ++ * exception on linking described in file LICENSE. ++ * ++ * This program is distributed in the hope that it will be useful, ++ * but WITHOUT ANY WARRANTY; without even the implied warranty of ++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ * GNU Lesser General Public License for more details. ++ *) ++ ++type mmap_interface ++type mmap_prot_flag = RDONLY | WRONLY | RDWR ++type mmap_map_flag = SHARED | PRIVATE ++ ++external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int ++ -> mmap_interface = "stub_mmap_init" ++external unmap : mmap_interface -> unit = "stub_mmap_final" ++external read : mmap_interface -> int -> int -> string = "stub_mmap_read" ++external write : mmap_interface -> string -> int -> int -> unit ++ = "stub_mmap_write" ++ ++external getpagesize : unit -> int = "stub_mmap_getpagesize" +--- /dev/null ++++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c +@@ -0,0 +1,136 @@ ++/* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * 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 ++#include ++#include ++#include ++#include ++#include "mmap_stubs.h" ++ ++#include ++#include ++#include ++#include ++#include ++#include ++ ++#define GET_C_STRUCT(a) ((struct mmap_interface *) a) ++ ++static int mmap_interface_init(struct mmap_interface *intf, ++ int fd, int pflag, int mflag, ++ int len, int offset) ++{ ++ intf->len = len; ++ intf->addr = mmap(NULL, len, pflag, mflag, fd, offset); ++ return (intf->addr == MAP_FAILED) ? errno : 0; ++} ++ ++CAMLprim value stub_mmap_init(value fd, value pflag, value mflag, ++ value len, value offset) ++{ ++ CAMLparam5(fd, pflag, mflag, len, offset); ++ CAMLlocal1(result); ++ int c_pflag, c_mflag; ++ ++ switch (Int_val(pflag)) { ++ case 0: c_pflag = PROT_READ; break; ++ case 1: c_pflag = PROT_WRITE; break; ++ case 2: c_pflag = PROT_READ|PROT_WRITE; break; ++ default: caml_invalid_argument("protectiontype"); ++ } ++ ++ switch (Int_val(mflag)) { ++ case 0: c_mflag = MAP_SHARED; break; ++ case 1: c_mflag = MAP_PRIVATE; break; ++ default: caml_invalid_argument("maptype"); ++ } ++ ++ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); ++ ++ if (mmap_interface_init(GET_C_STRUCT(result), Int_val(fd), ++ c_pflag, c_mflag, ++ Int_val(len), Int_val(offset))) ++ caml_failwith("mmap"); ++ CAMLreturn(result); ++} ++ ++CAMLprim value stub_mmap_final(value interface) ++{ ++ CAMLparam1(interface); ++ struct mmap_interface *intf; ++ ++ intf = GET_C_STRUCT(interface); ++ if (intf->addr != MAP_FAILED) ++ munmap(intf->addr, intf->len); ++ intf->addr = MAP_FAILED; ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_mmap_read(value interface, value start, value len) ++{ ++ CAMLparam3(interface, start, len); ++ CAMLlocal1(data); ++ struct mmap_interface *intf; ++ int c_start; ++ int c_len; ++ ++ c_start = Int_val(start); ++ c_len = Int_val(len); ++ intf = GET_C_STRUCT(interface); ++ ++ if (c_start > intf->len) ++ caml_invalid_argument("start invalid"); ++ if (c_start + c_len > intf->len) ++ caml_invalid_argument("len invalid"); ++ ++ data = caml_alloc_string(c_len); ++ memcpy((char *) data, intf->addr + c_start, c_len); ++ ++ CAMLreturn(data); ++} ++ ++CAMLprim value stub_mmap_write(value interface, value data, ++ value start, value len) ++{ ++ CAMLparam4(interface, data, start, len); ++ struct mmap_interface *intf; ++ int c_start; ++ int c_len; ++ ++ c_start = Int_val(start); ++ c_len = Int_val(len); ++ intf = GET_C_STRUCT(interface); ++ ++ if (c_start > intf->len) ++ caml_invalid_argument("start invalid"); ++ if (c_start + c_len > intf->len) ++ caml_invalid_argument("len invalid"); ++ ++ memcpy(intf->addr + c_start, (char *) data, c_len); ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_mmap_getpagesize(value unit) ++{ ++ CAMLparam1(unit); ++ CAMLlocal1(data); ++ ++ data = Val_int(getpagesize()); ++ CAMLreturn(data); ++} +--- a/tools/ocaml/libs/xb/META.in ++++ b/tools/ocaml/libs/xb/META.in +@@ -1,5 +1,5 @@ + version = "@VERSION@" + description = "XenBus Interface" +-requires = "unix,mmap" +-archive(byte) = "xb.cma" +-archive(native) = "xb.cmxa" ++requires = "unix,xenmmap" ++archive(byte) = "xenbus.cma" ++archive(native) = "xenbus.cmxa" +--- a/tools/ocaml/libs/xb/Makefile ++++ b/tools/ocaml/libs/xb/Makefile +@@ -4,6 +4,7 @@ + + CFLAGS += -I../mmap + OCAMLINCLUDE += -I ../mmap ++OCAMLOPTFLAGS += -for-pack Xenbus + + .NOTPARALLEL: + # Ocaml is such a PITA! +@@ -13,7 +14,7 @@ + PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx) + OBJS = op partial packet xs_ring xb + INTF = op.cmi packet.cmi xb.cmi +-LIBS = xb.cma xb.cmxa ++LIBS = xenbus.cma xenbus.cmxa + + ALL_OCAML_OBJS = $(OBJS) $(PREOJBS) + +@@ -23,22 +24,30 @@ + + libs: $(LIBS) + +-xb_OBJS = $(OBJS) +-xb_C_OBJS = xs_ring_stubs xb_stubs +-OCAML_LIBRARY = xb ++xenbus_OBJS = xenbus ++xenbus_C_OBJS = xs_ring_stubs xenbus_stubs ++OCAML_LIBRARY = xenbus ++ ++xenbus.cmx : $(foreach obj, $(OBJS), $(obj).cmx) ++ $(E) " CMX $@" ++ $(OCAMLOPT) -pack -o $@ $^ ++ ++xenbus.cmo : $(foreach obj, $(OBJS), $(obj).cmo) ++ $(E) " CMO $@" ++ $(OCAMLC) -pack -o $@ $^ + + %.mli: %.ml + $(E) " MLI $@" +- $(Q)$(OCAMLC) -i $< $o ++ $(Q)$(OCAMLC) $(OCAMLINCLUDE) -i $< $o + + .PHONY: install + install: $(LIBS) META + mkdir -p $(OCAMLDESTDIR) +- ocamlfind remove -destdir $(OCAMLDESTDIR) xb +- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenbus ++ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenbus META $(LIBS) xenbus.cmi xenbus.cmx *.a *.so + + .PHONY: uninstall + uninstall: +- ocamlfind remove -destdir $(OCAMLDESTDIR) xb ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenbus + + include $(TOPLEVEL)/Makefile.rules +--- a/tools/ocaml/libs/xb/xb.ml ++++ b/tools/ocaml/libs/xb/xb.ml +@@ -24,7 +24,7 @@ + + type backend_mmap = + { +- mmap: Mmap.mmap_interface; (* mmaped interface = xs_ring *) ++ mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *) + eventchn_notify: unit -> unit; (* function to notify through eventchn *) + mutable work_again: bool; + } +@@ -34,7 +34,7 @@ + fd: Unix.file_descr; + } + +-type backend = Fd of backend_fd | Mmap of backend_mmap ++type backend = Fd of backend_fd | Xenmmap of backend_mmap + + type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string + +@@ -68,7 +68,7 @@ + let read con s len = + match con.backend with + | Fd backfd -> read_fd backfd con s len +- | Mmap backmmap -> read_mmap backmmap con s len ++ | Xenmmap backmmap -> read_mmap backmmap con s len + + let write_fd back con s len = + Unix.write back.fd s 0 len +@@ -82,7 +82,7 @@ + let write con s len = + match con.backend with + | Fd backfd -> write_fd backfd con s len +- | Mmap backmmap -> write_mmap backmmap con s len ++ | Xenmmap backmmap -> write_mmap backmmap con s len + + let output con = + (* get the output string from a string_of(packet) or partial_out *) +@@ -145,7 +145,7 @@ + let open_fd fd = newcon (Fd { fd = fd; }) + + let open_mmap mmap notifyfct = +- newcon (Mmap { ++ newcon (Xenmmap { + mmap = mmap; + eventchn_notify = notifyfct; + work_again = false; }) +@@ -153,12 +153,12 @@ + let close con = + match con.backend with + | Fd backend -> Unix.close backend.fd +- | Mmap backend -> Mmap.unmap backend.mmap ++ | Xenmmap backend -> Xenmmap.unmap backend.mmap + + let is_fd con = + match con.backend with + | Fd _ -> true +- | Mmap _ -> false ++ | Xenmmap _ -> false + + let is_mmap con = not (is_fd con) + +@@ -176,14 +176,14 @@ + let has_more_input con = + match con.backend with + | Fd _ -> false +- | Mmap backend -> backend.work_again ++ | Xenmmap backend -> backend.work_again + + let is_selectable con = + match con.backend with + | Fd _ -> true +- | Mmap _ -> false ++ | Xenmmap _ -> false + + let get_fd con = + match con.backend with + | Fd backend -> backend.fd +- | Mmap _ -> raise (Failure "get_fd") ++ | Xenmmap _ -> raise (Failure "get_fd") +--- a/tools/ocaml/libs/xb/xb.mli ++++ b/tools/ocaml/libs/xb/xb.mli +@@ -1,83 +1,103 @@ +-module Op: +-sig +- type operation = Op.operation = +- | Debug +- | Directory +- | Read +- | Getperms +- | Watch +- | Unwatch +- | Transaction_start +- | Transaction_end +- | Introduce +- | Release +- | Getdomainpath +- | Write +- | Mkdir +- | Rm +- | Setperms +- | Watchevent +- | Error +- | Isintroduced +- | Resume +- | Set_target +- | Restrict +- val to_string : operation -> string +-end +- +-module Packet: +-sig +- type t +- +- exception Error of string +- exception DataError of string +- +- val create : int -> int -> Op.operation -> string -> t +- val unpack : t -> int * int * Op.operation * string +- +- val get_tid : t -> int +- val get_ty : t -> Op.operation +- val get_data : t -> string +- val get_rid: t -> int +-end +- ++module Op : ++ sig ++ type operation = ++ Op.operation = ++ Debug ++ | Directory ++ | Read ++ | Getperms ++ | Watch ++ | Unwatch ++ | Transaction_start ++ | Transaction_end ++ | Introduce ++ | Release ++ | Getdomainpath ++ | Write ++ | Mkdir ++ | Rm ++ | Setperms ++ | Watchevent ++ | Error ++ | Isintroduced ++ | Resume ++ | Set_target ++ | Restrict ++ val operation_c_mapping : operation array ++ val size : int ++ val offset_pq : int ++ val operation_c_mapping_pq : 'a array ++ val size_pq : int ++ val array_search : 'a -> 'a array -> int ++ val of_cval : int -> operation ++ val to_cval : operation -> int ++ val to_string : operation -> string ++ end ++module Packet : ++ sig ++ type t = ++ Packet.t = { ++ tid : int; ++ rid : int; ++ ty : Op.operation; ++ data : string; ++ } ++ exception Error of string ++ exception DataError of string ++ external string_of_header : int -> int -> int -> int -> string ++ = "stub_string_of_header" ++ val create : int -> int -> Op.operation -> string -> t ++ val of_partialpkt : Partial.pkt -> t ++ val to_string : t -> string ++ val unpack : t -> int * int * Op.operation * string ++ val get_tid : t -> int ++ val get_ty : t -> Op.operation ++ val get_data : t -> string ++ val get_rid : t -> int ++ end + exception End_of_file + exception Eagain + exception Noent + exception Invalid +- +-type t +- +-(** queue a packet into the output queue for later sending *) ++type backend_mmap = { ++ mmap : Xenmmap.mmap_interface; ++ eventchn_notify : unit -> unit; ++ mutable work_again : bool; ++} ++type backend_fd = { fd : Unix.file_descr; } ++type backend = Fd of backend_fd | Xenmmap of backend_mmap ++type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string ++type t = { ++ backend : backend; ++ pkt_in : Packet.t Queue.t; ++ pkt_out : Packet.t Queue.t; ++ mutable partial_in : partial_buf; ++ mutable partial_out : string; ++} ++val init_partial_in : unit -> partial_buf + val queue : t -> Packet.t -> unit +- +-(** process the output queue, return if a packet has been totally sent *) ++val read_fd : backend_fd -> 'a -> string -> int -> int ++val read_mmap : backend_mmap -> 'a -> string -> int -> int ++val read : t -> string -> int -> int ++val write_fd : backend_fd -> 'a -> string -> int -> int ++val write_mmap : backend_mmap -> 'a -> string -> int -> int ++val write : t -> string -> int -> int + val output : t -> bool +- +-(** process the input queue, return if a packet has been totally received *) + val input : t -> bool +- +-(** create new connection using a fd interface *) ++val newcon : backend -> t + val open_fd : Unix.file_descr -> t +-(** create new connection using a mmap intf and a function to notify eventchn *) +-val open_mmap : Mmap.mmap_interface -> (unit -> unit) -> t +- +-(* close a connection *) ++val open_mmap : Xenmmap.mmap_interface -> (unit -> unit) -> t + val close : t -> unit +- + val is_fd : t -> bool + val is_mmap : t -> bool +- + val output_len : t -> int + val has_new_output : t -> bool + val has_old_output : t -> bool + val has_output : t -> bool + val peek_output : t -> Packet.t +- + val input_len : t -> int + val has_in_packet : t -> bool + val get_in_packet : t -> Packet.t + val has_more_input : t -> bool +- + val is_selectable : t -> bool + val get_fd : t -> Unix.file_descr +--- a/tools/ocaml/libs/xb/xb_stubs.c ++++ /dev/null +@@ -1,71 +0,0 @@ +-/* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * 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 +-#include +-#include +-#include +-#include +- +-#include +-#include +-#include +-#include +-#include +-#include +- +-#include +-#include +- +-CAMLprim value stub_header_size(void) +-{ +- CAMLparam0(); +- CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); +-} +- +-CAMLprim value stub_header_of_string(value s) +-{ +- CAMLparam1(s); +- CAMLlocal1(ret); +- struct xsd_sockmsg *hdr; +- +- if (caml_string_length(s) != sizeof(struct xsd_sockmsg)) +- caml_failwith("xb header incomplete"); +- ret = caml_alloc_tuple(4); +- hdr = (struct xsd_sockmsg *) String_val(s); +- Store_field(ret, 0, Val_int(hdr->tx_id)); +- Store_field(ret, 1, Val_int(hdr->req_id)); +- Store_field(ret, 2, Val_int(hdr->type)); +- Store_field(ret, 3, Val_int(hdr->len)); +- CAMLreturn(ret); +-} +- +-CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len) +-{ +- CAMLparam4(tid, rid, ty, len); +- CAMLlocal1(ret); +- struct xsd_sockmsg xsd = { +- .type = Int_val(ty), +- .tx_id = Int_val(tid), +- .req_id = Int_val(rid), +- .len = Int_val(len), +- }; +- +- ret = caml_alloc_string(sizeof(struct xsd_sockmsg)); +- memcpy(String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); +- +- CAMLreturn(ret); +-} +--- /dev/null ++++ b/tools/ocaml/libs/xb/xenbus_stubs.c +@@ -0,0 +1,71 @@ ++/* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * 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 ++#include ++#include ++#include ++#include ++ ++#include ++#include ++#include ++#include ++#include ++#include ++ ++#include ++#include ++ ++CAMLprim value stub_header_size(void) ++{ ++ CAMLparam0(); ++ CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); ++} ++ ++CAMLprim value stub_header_of_string(value s) ++{ ++ CAMLparam1(s); ++ CAMLlocal1(ret); ++ struct xsd_sockmsg *hdr; ++ ++ if (caml_string_length(s) != sizeof(struct xsd_sockmsg)) ++ caml_failwith("xb header incomplete"); ++ ret = caml_alloc_tuple(4); ++ hdr = (struct xsd_sockmsg *) String_val(s); ++ Store_field(ret, 0, Val_int(hdr->tx_id)); ++ Store_field(ret, 1, Val_int(hdr->req_id)); ++ Store_field(ret, 2, Val_int(hdr->type)); ++ Store_field(ret, 3, Val_int(hdr->len)); ++ CAMLreturn(ret); ++} ++ ++CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len) ++{ ++ CAMLparam4(tid, rid, ty, len); ++ CAMLlocal1(ret); ++ struct xsd_sockmsg xsd = { ++ .type = Int_val(ty), ++ .tx_id = Int_val(tid), ++ .req_id = Int_val(rid), ++ .len = Int_val(len), ++ }; ++ ++ ret = caml_alloc_string(sizeof(struct xsd_sockmsg)); ++ memcpy(String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); ++ ++ CAMLreturn(ret); ++} +--- a/tools/ocaml/libs/xb/xs_ring.ml ++++ b/tools/ocaml/libs/xb/xs_ring.ml +@@ -14,5 +14,5 @@ + * GNU Lesser General Public License for more details. + *) + +-external read: Mmap.mmap_interface -> string -> int -> int = "ml_interface_read" +-external write: Mmap.mmap_interface -> string -> int -> int = "ml_interface_write" ++external read: Xenmmap.mmap_interface -> string -> int -> int = "ml_interface_read" ++external write: Xenmmap.mmap_interface -> string -> int -> int = "ml_interface_write" +--- a/tools/ocaml/libs/xc/META.in ++++ b/tools/ocaml/libs/xc/META.in +@@ -1,5 +1,5 @@ + version = "@VERSION@" + description = "Xen Control Interface" +-requires = "mmap,uuid" +-archive(byte) = "xc.cma" +-archive(native) = "xc.cmxa" ++requires = "xenmmap,uuid" ++archive(byte) = "xenctrl.cma" ++archive(native) = "xenctrl.cmxa" +--- a/tools/ocaml/libs/xc/Makefile ++++ b/tools/ocaml/libs/xc/Makefile +@@ -5,16 +5,16 @@ + CFLAGS += -I../mmap -I./ -I$(XEN_ROOT)/tools/libxc + OCAMLINCLUDE += -I ../mmap -I ../uuid -I $(XEN_ROOT)/tools/libxc + +-OBJS = xc +-INTF = xc.cmi +-LIBS = xc.cma xc.cmxa ++OBJS = xenctrl ++INTF = xenctrl.cmi ++LIBS = xenctrl.cma xenctrl.cmxa + +-LIBS_xc = -L$(XEN_ROOT)/tools/libxc -lxenctrl -lxenguest ++LIBS_xenctrl = -L$(XEN_ROOT)/tools/libxc -lxenctrl -lxenguest + +-xc_OBJS = $(OBJS) +-xc_C_OBJS = xc_stubs ++xenctrl_OBJS = $(OBJS) ++xenctrl_C_OBJS = xenctrl_stubs + +-OCAML_LIBRARY = xc ++OCAML_LIBRARY = xenctrl + + all: $(INTF) $(LIBS) + +@@ -23,11 +23,11 @@ + .PHONY: install + install: $(LIBS) META + mkdir -p $(OCAMLDESTDIR) +- ocamlfind remove -destdir $(OCAMLDESTDIR) xc +- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xc META $(INTF) $(LIBS) *.a *.so *.cmx ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenctrl ++ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenctrl META $(INTF) $(LIBS) *.a *.so *.cmx + + .PHONY: uninstall + uninstall: +- ocamlfind remove -destdir $(OCAMLDESTDIR) xc ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenctrl + + include $(TOPLEVEL)/Makefile.rules +--- a/tools/ocaml/libs/xc/xc.ml ++++ /dev/null +@@ -1,326 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-(** *) +-type domid = int +- +-(* ** xenctrl.h ** *) +- +-type vcpuinfo = +-{ +- online: bool; +- blocked: bool; +- running: bool; +- cputime: int64; +- cpumap: int32; +-} +- +-type domaininfo = +-{ +- domid : domid; +- dying : bool; +- shutdown : bool; +- paused : bool; +- blocked : bool; +- running : bool; +- hvm_guest : bool; +- shutdown_code : int; +- total_memory_pages: nativeint; +- max_memory_pages : nativeint; +- shared_info_frame : int64; +- cpu_time : int64; +- nr_online_vcpus : int; +- max_vcpu_id : int; +- ssidref : int32; +- handle : int array; +-} +- +-type sched_control = +-{ +- weight : int; +- cap : int; +-} +- +-type physinfo_cap_flag = +- | CAP_HVM +- | CAP_DirectIO +- +-type physinfo = +-{ +- threads_per_core : int; +- cores_per_socket : int; +- nr_cpus : int; +- max_node_id : int; +- cpu_khz : int; +- total_pages : nativeint; +- free_pages : nativeint; +- scrub_pages : nativeint; +- (* XXX hw_cap *) +- capabilities : physinfo_cap_flag list; +-} +- +-type version = +-{ +- major : int; +- minor : int; +- extra : string; +-} +- +- +-type compile_info = +-{ +- compiler : string; +- compile_by : string; +- compile_domain : string; +- compile_date : string; +-} +- +-type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt +- +-type domain_create_flag = CDF_HVM | CDF_HAP +- +-exception Error of string +- +-type handle +- +-(* this is only use by coredumping *) +-external sizeof_core_header: unit -> int +- = "stub_sizeof_core_header" +-external sizeof_vcpu_guest_context: unit -> int +- = "stub_sizeof_vcpu_guest_context" +-external sizeof_xen_pfn: unit -> int = "stub_sizeof_xen_pfn" +-(* end of use *) +- +-external interface_open: unit -> handle = "stub_xc_interface_open" +-external interface_close: handle -> unit = "stub_xc_interface_close" +- +-external is_fake: unit -> bool = "stub_xc_interface_is_fake" +- +-let with_intf f = +- let xc = interface_open () in +- let r = try f xc with exn -> interface_close xc; raise exn in +- interface_close xc; +- r +- +-external _domain_create: handle -> int32 -> domain_create_flag list -> int array -> domid +- = "stub_xc_domain_create" +- +-let domain_create handle n flags uuid = +- _domain_create handle n flags (Uuid.int_array_of_uuid uuid) +- +-external _domain_sethandle: handle -> domid -> int array -> unit +- = "stub_xc_domain_sethandle" +- +-let domain_sethandle handle n uuid = +- _domain_sethandle handle n (Uuid.int_array_of_uuid uuid) +- +-external domain_max_vcpus: handle -> domid -> int -> unit +- = "stub_xc_domain_max_vcpus" +- +-external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause" +-external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause" +-external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fast" +-external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy" +- +-external domain_shutdown: handle -> domid -> shutdown_reason -> unit +- = "stub_xc_domain_shutdown" +- +-external _domain_getinfolist: handle -> domid -> int -> domaininfo list +- = "stub_xc_domain_getinfolist" +- +-let domain_getinfolist handle first_domain = +- let nb = 2 in +- let last_domid l = (List.hd l).domid + 1 in +- let rec __getlist from = +- let l = _domain_getinfolist handle from nb in +- (if List.length l = nb then __getlist (last_domid l) else []) @ l +- in +- List.rev (__getlist first_domain) +- +-external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo" +- +-external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo +- = "stub_xc_vcpu_getinfo" +- +-external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit +- = "stub_xc_domain_ioport_permission" +-external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit +- = "stub_xc_domain_iomem_permission" +-external domain_irq_permission: handle -> domid -> int -> bool -> unit +- = "stub_xc_domain_irq_permission" +- +-external vcpu_affinity_set: handle -> domid -> int -> bool array -> unit +- = "stub_xc_vcpu_setaffinity" +-external vcpu_affinity_get: handle -> domid -> int -> bool array +- = "stub_xc_vcpu_getaffinity" +- +-external vcpu_context_get: handle -> domid -> int -> string +- = "stub_xc_vcpu_context_get" +- +-external sched_id: handle -> int = "stub_xc_sched_id" +- +-external sched_credit_domain_set: handle -> domid -> sched_control -> unit +- = "stub_sched_credit_domain_set" +-external sched_credit_domain_get: handle -> domid -> sched_control +- = "stub_sched_credit_domain_get" +- +-external shadow_allocation_set: handle -> domid -> int -> unit +- = "stub_shadow_allocation_set" +-external shadow_allocation_get: handle -> domid -> int +- = "stub_shadow_allocation_get" +- +-external evtchn_alloc_unbound: handle -> domid -> domid -> int +- = "stub_xc_evtchn_alloc_unbound" +-external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset" +- +-external readconsolering: handle -> string = "stub_xc_readconsolering" +- +-external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys" +-external physinfo: handle -> physinfo = "stub_xc_physinfo" +-external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info" +- +-external domain_setmaxmem: handle -> domid -> int64 -> unit +- = "stub_xc_domain_setmaxmem" +-external domain_set_memmap_limit: handle -> domid -> int64 -> unit +- = "stub_xc_domain_set_memmap_limit" +-external domain_memory_increase_reservation: handle -> domid -> int64 -> unit +- = "stub_xc_domain_memory_increase_reservation" +- +-external domain_set_machine_address_size: handle -> domid -> int -> unit +- = "stub_xc_domain_set_machine_address_size" +-external domain_get_machine_address_size: handle -> domid -> int +- = "stub_xc_domain_get_machine_address_size" +- +-external domain_cpuid_set: handle -> domid -> (int64 * (int64 option)) +- -> string option array +- -> string option array +- = "stub_xc_domain_cpuid_set" +-external domain_cpuid_apply_policy: handle -> domid -> unit +- = "stub_xc_domain_cpuid_apply_policy" +-external cpuid_check: handle -> (int64 * (int64 option)) -> string option array -> (bool * string option array) +- = "stub_xc_cpuid_check" +- +-external map_foreign_range: handle -> domid -> int +- -> nativeint -> Mmap.mmap_interface +- = "stub_map_foreign_range" +- +-external domain_get_pfn_list: handle -> domid -> nativeint -> nativeint array +- = "stub_xc_domain_get_pfn_list" +- +-external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit +- = "stub_xc_domain_assign_device" +-external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit +- = "stub_xc_domain_deassign_device" +-external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool +- = "stub_xc_domain_test_assign_device" +- +-external version: handle -> version = "stub_xc_version_version" +-external version_compile_info: handle -> compile_info +- = "stub_xc_version_compile_info" +-external version_changeset: handle -> string = "stub_xc_version_changeset" +-external version_capabilities: handle -> string = +- "stub_xc_version_capabilities" +- +-external watchdog : handle -> int -> int32 -> int +- = "stub_xc_watchdog" +- +-(* core dump structure *) +-type core_magic = Magic_hvm | Magic_pv +- +-type core_header = { +- xch_magic: core_magic; +- xch_nr_vcpus: int; +- xch_nr_pages: nativeint; +- xch_index_offset: int64; +- xch_ctxt_offset: int64; +- xch_pages_offset: int64; +-} +- +-external marshall_core_header: core_header -> string = "stub_marshall_core_header" +- +-(* coredump *) +-let coredump xch domid fd = +- let dump s = +- let wd = Unix.write fd s 0 (String.length s) in +- if wd <> String.length s then +- failwith "error while writing"; +- in +- +- let info = domain_getinfo xch domid in +- +- let nrpages = info.total_memory_pages in +- let ctxt = Array.make info.max_vcpu_id None in +- let nr_vcpus = ref 0 in +- for i = 0 to info.max_vcpu_id - 1 +- do +- ctxt.(i) <- try +- let v = vcpu_context_get xch domid i in +- incr nr_vcpus; +- Some v +- with _ -> None +- done; +- +- (* FIXME page offset if not rounded to sup *) +- let page_offset = +- Int64.add +- (Int64.of_int (sizeof_core_header () + +- (sizeof_vcpu_guest_context () * !nr_vcpus))) +- (Int64.of_nativeint ( +- Nativeint.mul +- (Nativeint.of_int (sizeof_xen_pfn ())) +- nrpages) +- ) +- in +- +- let header = { +- xch_magic = if info.hvm_guest then Magic_hvm else Magic_pv; +- xch_nr_vcpus = !nr_vcpus; +- xch_nr_pages = nrpages; +- xch_ctxt_offset = Int64.of_int (sizeof_core_header ()); +- xch_index_offset = Int64.of_int (sizeof_core_header () +- + sizeof_vcpu_guest_context ()); +- xch_pages_offset = page_offset; +- } in +- +- dump (marshall_core_header header); +- for i = 0 to info.max_vcpu_id - 1 +- do +- match ctxt.(i) with +- | None -> () +- | Some ctxt_i -> dump ctxt_i +- done; +- let pfns = domain_get_pfn_list xch domid nrpages in +- if Array.length pfns <> Nativeint.to_int nrpages then +- failwith "could not get the page frame list"; +- +- let page_size = Mmap.getpagesize () in +- for i = 0 to Nativeint.to_int nrpages - 1 +- do +- let page = map_foreign_range xch domid page_size pfns.(i) in +- let data = Mmap.read page 0 page_size in +- Mmap.unmap page; +- dump data +- done +- +-(* ** Misc ** *) +- +-(** +- Convert the given number of pages to an amount in KiB, rounded up. +- *) +-external pages_to_kib : int64 -> int64 = "stub_pages_to_kib" +-let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L +- +-let _ = Callback.register_exception "xc.error" (Error "register_callback") +--- a/tools/ocaml/libs/xc/xc.mli ++++ /dev/null +@@ -1,184 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-type domid = int +-type vcpuinfo = { +- online : bool; +- blocked : bool; +- running : bool; +- cputime : int64; +- cpumap : int32; +-} +-type domaininfo = { +- domid : domid; +- dying : bool; +- shutdown : bool; +- paused : bool; +- blocked : bool; +- running : bool; +- hvm_guest : bool; +- shutdown_code : int; +- total_memory_pages : nativeint; +- max_memory_pages : nativeint; +- shared_info_frame : int64; +- cpu_time : int64; +- nr_online_vcpus : int; +- max_vcpu_id : int; +- ssidref : int32; +- handle : int array; +-} +-type sched_control = { weight : int; cap : int; } +-type physinfo_cap_flag = CAP_HVM | CAP_DirectIO +-type physinfo = { +- threads_per_core : int; +- cores_per_socket : int; +- nr_cpus : int; +- max_node_id : int; +- cpu_khz : int; +- total_pages : nativeint; +- free_pages : nativeint; +- scrub_pages : nativeint; +- capabilities : physinfo_cap_flag list; +-} +-type version = { major : int; minor : int; extra : string; } +-type compile_info = { +- compiler : string; +- compile_by : string; +- compile_domain : string; +- compile_date : string; +-} +-type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt +- +-type domain_create_flag = CDF_HVM | CDF_HAP +- +-exception Error of string +-type handle +-external sizeof_core_header : unit -> int = "stub_sizeof_core_header" +-external sizeof_vcpu_guest_context : unit -> int +- = "stub_sizeof_vcpu_guest_context" +-external sizeof_xen_pfn : unit -> int = "stub_sizeof_xen_pfn" +-external interface_open : unit -> handle = "stub_xc_interface_open" +-external is_fake : unit -> bool = "stub_xc_interface_is_fake" +-external interface_close : handle -> unit = "stub_xc_interface_close" +-val with_intf : (handle -> 'a) -> 'a +-external _domain_create : handle -> int32 -> domain_create_flag list -> int array -> domid +- = "stub_xc_domain_create" +-val domain_create : handle -> int32 -> domain_create_flag list -> 'a Uuid.t -> domid +-external _domain_sethandle : handle -> domid -> int array -> unit +- = "stub_xc_domain_sethandle" +-val domain_sethandle : handle -> domid -> 'a Uuid.t -> unit +-external domain_max_vcpus : handle -> domid -> int -> unit +- = "stub_xc_domain_max_vcpus" +-external domain_pause : handle -> domid -> unit = "stub_xc_domain_pause" +-external domain_unpause : handle -> domid -> unit = "stub_xc_domain_unpause" +-external domain_resume_fast : handle -> domid -> unit +- = "stub_xc_domain_resume_fast" +-external domain_destroy : handle -> domid -> unit = "stub_xc_domain_destroy" +-external domain_shutdown : handle -> domid -> shutdown_reason -> unit +- = "stub_xc_domain_shutdown" +-external _domain_getinfolist : handle -> domid -> int -> domaininfo list +- = "stub_xc_domain_getinfolist" +-val domain_getinfolist : handle -> domid -> domaininfo list +-external domain_getinfo : handle -> domid -> domaininfo +- = "stub_xc_domain_getinfo" +-external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo +- = "stub_xc_vcpu_getinfo" +-external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit +- = "stub_xc_domain_ioport_permission" +-external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit +- = "stub_xc_domain_iomem_permission" +-external domain_irq_permission: handle -> domid -> int -> bool -> unit +- = "stub_xc_domain_irq_permission" +-external vcpu_affinity_set : handle -> domid -> int -> bool array -> unit +- = "stub_xc_vcpu_setaffinity" +-external vcpu_affinity_get : handle -> domid -> int -> bool array +- = "stub_xc_vcpu_getaffinity" +-external vcpu_context_get : handle -> domid -> int -> string +- = "stub_xc_vcpu_context_get" +-external sched_id : handle -> int = "stub_xc_sched_id" +-external sched_credit_domain_set : handle -> domid -> sched_control -> unit +- = "stub_sched_credit_domain_set" +-external sched_credit_domain_get : handle -> domid -> sched_control +- = "stub_sched_credit_domain_get" +-external shadow_allocation_set : handle -> domid -> int -> unit +- = "stub_shadow_allocation_set" +-external shadow_allocation_get : handle -> domid -> int +- = "stub_shadow_allocation_get" +-external evtchn_alloc_unbound : handle -> domid -> domid -> int +- = "stub_xc_evtchn_alloc_unbound" +-external evtchn_reset : handle -> domid -> unit = "stub_xc_evtchn_reset" +-external readconsolering : handle -> string = "stub_xc_readconsolering" +-external send_debug_keys : handle -> string -> unit = "stub_xc_send_debug_keys" +-external physinfo : handle -> physinfo = "stub_xc_physinfo" +-external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info" +-external domain_setmaxmem : handle -> domid -> int64 -> unit +- = "stub_xc_domain_setmaxmem" +-external domain_set_memmap_limit : handle -> domid -> int64 -> unit +- = "stub_xc_domain_set_memmap_limit" +-external domain_memory_increase_reservation : +- handle -> domid -> int64 -> unit +- = "stub_xc_domain_memory_increase_reservation" +-external map_foreign_range : +- handle -> domid -> int -> nativeint -> Mmap.mmap_interface +- = "stub_map_foreign_range" +-external domain_get_pfn_list : +- handle -> domid -> nativeint -> nativeint array +- = "stub_xc_domain_get_pfn_list" +- +-external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit +- = "stub_xc_domain_assign_device" +-external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit +- = "stub_xc_domain_deassign_device" +-external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool +- = "stub_xc_domain_test_assign_device" +- +-external version : handle -> version = "stub_xc_version_version" +-external version_compile_info : handle -> compile_info +- = "stub_xc_version_compile_info" +-external version_changeset : handle -> string = "stub_xc_version_changeset" +-external version_capabilities : handle -> string +- = "stub_xc_version_capabilities" +-type core_magic = Magic_hvm | Magic_pv +-type core_header = { +- xch_magic : core_magic; +- xch_nr_vcpus : int; +- xch_nr_pages : nativeint; +- xch_index_offset : int64; +- xch_ctxt_offset : int64; +- xch_pages_offset : int64; +-} +-external marshall_core_header : core_header -> string +- = "stub_marshall_core_header" +-val coredump : handle -> domid -> Unix.file_descr -> unit +-external pages_to_kib : int64 -> int64 = "stub_pages_to_kib" +-val pages_to_mib : int64 -> int64 +-external watchdog : handle -> int -> int32 -> int +- = "stub_xc_watchdog" +- +-external domain_set_machine_address_size: handle -> domid -> int -> unit +- = "stub_xc_domain_set_machine_address_size" +-external domain_get_machine_address_size: handle -> domid -> int +- = "stub_xc_domain_get_machine_address_size" +- +-external domain_cpuid_set: handle -> domid -> (int64 * (int64 option)) +- -> string option array +- -> string option array +- = "stub_xc_domain_cpuid_set" +-external domain_cpuid_apply_policy: handle -> domid -> unit +- = "stub_xc_domain_cpuid_apply_policy" +-external cpuid_check: handle -> (int64 * (int64 option)) -> string option array -> (bool * string option array) +- = "stub_xc_cpuid_check" +- +--- a/tools/ocaml/libs/xc/xc_stubs.c ++++ /dev/null +@@ -1,1161 +0,0 @@ +-/* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * 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 +-#include +- +-#define CAML_NAME_SPACE +-#include +-#include +-#include +-#include +-#include +- +-#include +-#include +-#include +- +-#include +- +-#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> r) & 1) { +- tmp = caml_alloc_small(2, Tag_cons); +- Field(tmp, 0) = Val_int(r); +- Field(tmp, 1) = cap_list; +- cap_list = tmp; +- } +- } +- +- physinfo = caml_alloc_tuple(9); +- Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core)); +- Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket)); +- Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus)); +- Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id)); +- Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz)); +- Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages)); +- Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages)); +- Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages)); +- Store_field(physinfo, 8, cap_list); +- +- CAMLreturn(physinfo); +-} +- +-CAMLprim value stub_xc_pcpu_info(value xch, value nr_cpus) +-{ +- CAMLparam2(xch, nr_cpus); +- CAMLlocal2(pcpus, v); +- xc_cpuinfo_t *info; +- int r, size; +- +- if (Int_val(nr_cpus) < 1) +- caml_invalid_argument("nr_cpus"); +- +- info = calloc(Int_val(nr_cpus) + 1, sizeof(*info)); +- if (!info) +- caml_raise_out_of_memory(); +- +- // caml_enter_blocking_section(); +- r = xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size); +- // caml_leave_blocking_section(); +- +- if (r) { +- free(info); +- failwith_xc(_H(xch)); +- } +- +- if (size > 0) { +- int i; +- pcpus = caml_alloc(size, 0); +- for (i = 0; i < size; i++) { +- v = caml_copy_int64(info[i].idletime); +- caml_modify(&Field(pcpus, i), v); +- } +- } else +- pcpus = Atom(0); +- free(info); +- CAMLreturn(pcpus); +-} +- +-CAMLprim value stub_xc_domain_setmaxmem(value xch, value domid, +- value max_memkb) +-{ +- CAMLparam3(xch, domid, max_memkb); +- +- uint32_t c_domid = _D(domid); +- unsigned int c_max_memkb = Int64_val(max_memkb); +- // caml_enter_blocking_section(); +- int retval = xc_domain_setmaxmem(_H(xch), c_domid, +- c_max_memkb); +- // caml_leave_blocking_section(); +- if (retval) +- failwith_xc(_H(xch)); +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_domain_set_memmap_limit(value xch, value domid, +- value map_limitkb) +-{ +- CAMLparam3(xch, domid, map_limitkb); +- unsigned long v; +- int retval; +- +- v = Int64_val(map_limitkb); +- retval = xc_domain_set_memmap_limit(_H(xch), _D(domid), v); +- if (retval) +- failwith_xc(_H(xch)); +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_domain_memory_increase_reservation(value xch, +- value domid, +- value mem_kb) +-{ +- CAMLparam3(xch, domid, mem_kb); +- +- unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (PAGE_SHIFT - 10); +- +- uint32_t c_domid = _D(domid); +- // caml_enter_blocking_section(); +- int retval = xc_domain_increase_reservation_exact(_H(xch), c_domid, +- nr_extents, 0, 0, NULL); +- // caml_leave_blocking_section(); +- +- if (retval) +- failwith_xc(_H(xch)); +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_domain_set_machine_address_size(value xch, +- value domid, +- value width) +-{ +- CAMLparam3(xch, domid, width); +- uint32_t c_domid = _D(domid); +- int c_width = Int_val(width); +- +- int retval = xc_domain_set_machine_address_size(_H(xch), c_domid, c_width); +- if (retval) +- failwith_xc(_H(xch)); +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_domain_get_machine_address_size(value xch, +- value domid) +-{ +- CAMLparam2(xch, domid); +- int retval; +- +- retval = xc_domain_get_machine_address_size(_H(xch), _D(domid)); +- if (retval < 0) +- failwith_xc(_H(xch)); +- CAMLreturn(Val_int(retval)); +-} +- +-CAMLprim value stub_xc_domain_cpuid_set(value xch, value domid, +- value input, +- value config) +-{ +- CAMLparam4(xch, domid, input, config); +- CAMLlocal2(array, tmp); +- int r; +- unsigned int c_input[2]; +- char *c_config[4], *out_config[4]; +- +- c_config[0] = string_of_option_array(config, 0); +- c_config[1] = string_of_option_array(config, 1); +- c_config[2] = string_of_option_array(config, 2); +- c_config[3] = string_of_option_array(config, 3); +- +- cpuid_input_of_val(c_input[0], c_input[1], input); +- +- array = caml_alloc(4, 0); +- for (r = 0; r < 4; r++) { +- tmp = Val_none; +- if (c_config[r]) { +- tmp = caml_alloc_small(1, 0); +- Field(tmp, 0) = caml_alloc_string(32); +- } +- Store_field(array, r, tmp); +- } +- +- for (r = 0; r < 4; r++) +- out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL; +- +- r = xc_cpuid_set(_H(xch), _D(domid), +- c_input, (const char **)c_config, out_config); +- if (r < 0) +- failwith_xc(_H(xch)); +- CAMLreturn(array); +-} +- +-CAMLprim value stub_xc_domain_cpuid_apply_policy(value xch, value domid) +-{ +- CAMLparam2(xch, domid); +- int r; +- +- r = xc_cpuid_apply_policy(_H(xch), _D(domid)); +- if (r < 0) +- failwith_xc(_H(xch)); +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_cpuid_check(value xch, value input, value config) +-{ +- CAMLparam3(xch, input, config); +- CAMLlocal3(ret, array, tmp); +- int r; +- unsigned int c_input[2]; +- char *c_config[4], *out_config[4]; +- +- c_config[0] = string_of_option_array(config, 0); +- c_config[1] = string_of_option_array(config, 1); +- c_config[2] = string_of_option_array(config, 2); +- c_config[3] = string_of_option_array(config, 3); +- +- cpuid_input_of_val(c_input[0], c_input[1], input); +- +- array = caml_alloc(4, 0); +- for (r = 0; r < 4; r++) { +- tmp = Val_none; +- if (c_config[r]) { +- tmp = caml_alloc_small(1, 0); +- Field(tmp, 0) = caml_alloc_string(32); +- } +- Store_field(array, r, tmp); +- } +- +- for (r = 0; r < 4; r++) +- out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL; +- +- r = xc_cpuid_check(_H(xch), c_input, (const char **)c_config, out_config); +- if (r < 0) +- failwith_xc(_H(xch)); +- +- ret = caml_alloc_tuple(2); +- Store_field(ret, 0, Val_bool(r)); +- Store_field(ret, 1, array); +- +- CAMLreturn(ret); +-} +- +-CAMLprim value stub_xc_version_version(value xch) +-{ +- CAMLparam1(xch); +- CAMLlocal1(result); +- xen_extraversion_t extra; +- long packed; +- int retval; +- +- // caml_enter_blocking_section(); +- packed = xc_version(_H(xch), XENVER_version, NULL); +- retval = xc_version(_H(xch), XENVER_extraversion, &extra); +- // caml_leave_blocking_section(); +- +- if (retval) +- failwith_xc(_H(xch)); +- +- result = caml_alloc_tuple(3); +- +- Store_field(result, 0, Val_int(packed >> 16)); +- Store_field(result, 1, Val_int(packed & 0xffff)); +- Store_field(result, 2, caml_copy_string(extra)); +- +- CAMLreturn(result); +-} +- +- +-CAMLprim value stub_xc_version_compile_info(value xch) +-{ +- CAMLparam1(xch); +- CAMLlocal1(result); +- xen_compile_info_t ci; +- int retval; +- +- // caml_enter_blocking_section(); +- retval = xc_version(_H(xch), XENVER_compile_info, &ci); +- // caml_leave_blocking_section(); +- +- if (retval) +- failwith_xc(_H(xch)); +- +- result = caml_alloc_tuple(4); +- +- Store_field(result, 0, caml_copy_string(ci.compiler)); +- Store_field(result, 1, caml_copy_string(ci.compile_by)); +- Store_field(result, 2, caml_copy_string(ci.compile_domain)); +- Store_field(result, 3, caml_copy_string(ci.compile_date)); +- +- CAMLreturn(result); +-} +- +- +-static value xc_version_single_string(value xch, int code, void *info) +-{ +- CAMLparam1(xch); +- int retval; +- +- // caml_enter_blocking_section(); +- retval = xc_version(_H(xch), code, info); +- // caml_leave_blocking_section(); +- +- if (retval) +- failwith_xc(_H(xch)); +- +- CAMLreturn(caml_copy_string((char *)info)); +-} +- +- +-CAMLprim value stub_xc_version_changeset(value xch) +-{ +- xen_changeset_info_t ci; +- +- return xc_version_single_string(xch, XENVER_changeset, &ci); +-} +- +- +-CAMLprim value stub_xc_version_capabilities(value xch) +-{ +- xen_capabilities_info_t ci; +- +- return xc_version_single_string(xch, XENVER_capabilities, &ci); +-} +- +- +-CAMLprim value stub_pages_to_kib(value pages) +-{ +- CAMLparam1(pages); +- +- CAMLreturn(caml_copy_int64(Int64_val(pages) << (PAGE_SHIFT - 10))); +-} +- +- +-CAMLprim value stub_map_foreign_range(value xch, value dom, +- value size, value mfn) +-{ +- CAMLparam4(xch, dom, size, mfn); +- CAMLlocal1(result); +- struct mmap_interface *intf; +- uint32_t c_dom; +- unsigned long c_mfn; +- +- result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); +- intf = (struct mmap_interface *) result; +- +- intf->len = Int_val(size); +- +- c_dom = _D(dom); +- c_mfn = Nativeint_val(mfn); +- // caml_enter_blocking_section(); +- intf->addr = xc_map_foreign_range(_H(xch), c_dom, +- intf->len, PROT_READ|PROT_WRITE, +- c_mfn); +- // caml_leave_blocking_section(); +- if (!intf->addr) +- caml_failwith("xc_map_foreign_range error"); +- CAMLreturn(result); +-} +- +-CAMLprim value stub_sched_credit_domain_get(value xch, value domid) +-{ +- CAMLparam2(xch, domid); +- CAMLlocal1(sdom); +- struct xen_domctl_sched_credit c_sdom; +- int ret; +- +- // caml_enter_blocking_section(); +- ret = xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom); +- // caml_leave_blocking_section(); +- if (ret != 0) +- failwith_xc(_H(xch)); +- +- sdom = caml_alloc_tuple(2); +- Store_field(sdom, 0, Val_int(c_sdom.weight)); +- Store_field(sdom, 1, Val_int(c_sdom.cap)); +- +- CAMLreturn(sdom); +-} +- +-CAMLprim value stub_sched_credit_domain_set(value xch, value domid, +- value sdom) +-{ +- CAMLparam3(xch, domid, sdom); +- struct xen_domctl_sched_credit c_sdom; +- int ret; +- +- c_sdom.weight = Int_val(Field(sdom, 0)); +- c_sdom.cap = Int_val(Field(sdom, 1)); +- // caml_enter_blocking_section(); +- ret = xc_sched_credit_domain_set(_H(xch), _D(domid), &c_sdom); +- // caml_leave_blocking_section(); +- if (ret != 0) +- failwith_xc(_H(xch)); +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_shadow_allocation_get(value xch, value domid) +-{ +- CAMLparam2(xch, domid); +- CAMLlocal1(mb); +- unsigned long c_mb; +- int ret; +- +- // caml_enter_blocking_section(); +- ret = xc_shadow_control(_H(xch), _D(domid), +- XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION, +- NULL, 0, &c_mb, 0, NULL); +- // caml_leave_blocking_section(); +- if (ret != 0) +- failwith_xc(_H(xch)); +- +- mb = Val_int(c_mb); +- CAMLreturn(mb); +-} +- +-CAMLprim value stub_shadow_allocation_set(value xch, value domid, +- value mb) +-{ +- CAMLparam3(xch, domid, mb); +- unsigned long c_mb; +- int ret; +- +- c_mb = Int_val(mb); +- // caml_enter_blocking_section(); +- ret = xc_shadow_control(_H(xch), _D(domid), +- XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION, +- NULL, 0, &c_mb, 0, NULL); +- // caml_leave_blocking_section(); +- if (ret != 0) +- failwith_xc(_H(xch)); +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_domain_get_pfn_list(value xch, value domid, +- value nr_pfns) +-{ +- CAMLparam3(xch, domid, nr_pfns); +- CAMLlocal2(array, v); +- unsigned long c_nr_pfns; +- long ret, i; +- uint64_t *c_array; +- +- c_nr_pfns = Nativeint_val(nr_pfns); +- +- c_array = malloc(sizeof(uint64_t) * c_nr_pfns); +- if (!c_array) +- caml_raise_out_of_memory(); +- +- ret = xc_get_pfn_list(_H(xch), _D(domid), +- c_array, c_nr_pfns); +- if (ret < 0) { +- free(c_array); +- failwith_xc(_H(xch)); +- } +- +- array = caml_alloc(ret, 0); +- for (i = 0; i < ret; i++) { +- v = caml_copy_nativeint(c_array[i]); +- Store_field(array, i, v); +- } +- free(c_array); +- +- CAMLreturn(array); +-} +- +-CAMLprim value stub_xc_domain_ioport_permission(value xch, value domid, +- value start_port, value nr_ports, +- value allow) +-{ +- CAMLparam5(xch, domid, start_port, nr_ports, allow); +- uint32_t c_start_port, c_nr_ports; +- uint8_t c_allow; +- int ret; +- +- c_start_port = Int_val(start_port); +- c_nr_ports = Int_val(nr_ports); +- c_allow = Bool_val(allow); +- +- ret = xc_domain_ioport_permission(_H(xch), _D(domid), +- c_start_port, c_nr_ports, c_allow); +- if (ret < 0) +- failwith_xc(_H(xch)); +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_domain_iomem_permission(value xch, value domid, +- value start_pfn, value nr_pfns, +- value allow) +-{ +- CAMLparam5(xch, domid, start_pfn, nr_pfns, allow); +- unsigned long c_start_pfn, c_nr_pfns; +- uint8_t c_allow; +- int ret; +- +- c_start_pfn = Nativeint_val(start_pfn); +- c_nr_pfns = Nativeint_val(nr_pfns); +- c_allow = Bool_val(allow); +- +- ret = xc_domain_iomem_permission(_H(xch), _D(domid), +- c_start_pfn, c_nr_pfns, c_allow); +- if (ret < 0) +- failwith_xc(_H(xch)); +- +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_domain_irq_permission(value xch, value domid, +- value pirq, value allow) +-{ +- CAMLparam4(xch, domid, pirq, allow); +- uint8_t c_pirq; +- uint8_t c_allow; +- int ret; +- +- c_pirq = Int_val(pirq); +- c_allow = Bool_val(allow); +- +- ret = xc_domain_irq_permission(_H(xch), _D(domid), +- c_pirq, c_allow); +- if (ret < 0) +- failwith_xc(_H(xch)); +- +- CAMLreturn(Val_unit); +-} +- +-static uint32_t pci_dev_to_bdf(int domain, int bus, int slot, int func) +-{ +- uint32_t bdf = 0; +- bdf |= (bus & 0xff) << 16; +- bdf |= (slot & 0x1f) << 11; +- bdf |= (func & 0x7) << 8; +- return bdf; +-} +- +-CAMLprim value stub_xc_domain_test_assign_device(value xch, value domid, value desc) +-{ +- CAMLparam3(xch, domid, desc); +- int ret; +- int domain, bus, slot, func; +- uint32_t bdf; +- +- domain = Int_val(Field(desc, 0)); +- bus = Int_val(Field(desc, 1)); +- slot = Int_val(Field(desc, 2)); +- func = Int_val(Field(desc, 3)); +- bdf = pci_dev_to_bdf(domain, bus, slot, func); +- +- ret = xc_test_assign_device(_H(xch), _D(domid), bdf); +- +- CAMLreturn(Val_bool(ret == 0)); +-} +- +-CAMLprim value stub_xc_domain_assign_device(value xch, value domid, value desc) +-{ +- CAMLparam3(xch, domid, desc); +- int ret; +- int domain, bus, slot, func; +- uint32_t bdf; +- +- domain = Int_val(Field(desc, 0)); +- bus = Int_val(Field(desc, 1)); +- slot = Int_val(Field(desc, 2)); +- func = Int_val(Field(desc, 3)); +- bdf = pci_dev_to_bdf(domain, bus, slot, func); +- +- ret = xc_assign_device(_H(xch), _D(domid), bdf); +- +- if (ret < 0) +- failwith_xc(_H(xch)); +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_domain_deassign_device(value xch, value domid, value desc) +-{ +- CAMLparam3(xch, domid, desc); +- int ret; +- int domain, bus, slot, func; +- uint32_t bdf; +- +- domain = Int_val(Field(desc, 0)); +- bus = Int_val(Field(desc, 1)); +- slot = Int_val(Field(desc, 2)); +- func = Int_val(Field(desc, 3)); +- bdf = pci_dev_to_bdf(domain, bus, slot, func); +- +- ret = xc_deassign_device(_H(xch), _D(domid), bdf); +- +- if (ret < 0) +- failwith_xc(_H(xch)); +- CAMLreturn(Val_unit); +-} +- +-CAMLprim value stub_xc_watchdog(value xch, value domid, value timeout) +-{ +- CAMLparam3(xch, domid, timeout); +- int ret; +- unsigned int c_timeout = Int32_val(timeout); +- +- ret = xc_watchdog(_H(xch), _D(domid), c_timeout); +- if (ret < 0) +- failwith_xc(_H(xch)); +- +- CAMLreturn(Val_int(ret)); +-} +- +-/* +- * Local variables: +- * indent-tabs-mode: t +- * c-basic-offset: 8 +- * tab-width: 8 +- * End: +- */ +--- /dev/null ++++ b/tools/ocaml/libs/xc/xenctrl.ml +@@ -0,0 +1,326 @@ ++(* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * This program is free software; you can redistribute it and/or modify ++ * it under the terms of the GNU Lesser General Public License as published ++ * by the Free Software Foundation; version 2.1 only. with the special ++ * exception on linking described in file LICENSE. ++ * ++ * This program is distributed in the hope that it will be useful, ++ * but WITHOUT ANY WARRANTY; without even the implied warranty of ++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ * GNU Lesser General Public License for more details. ++ *) ++ ++(** *) ++type domid = int ++ ++(* ** xenctrl.h ** *) ++ ++type vcpuinfo = ++{ ++ online: bool; ++ blocked: bool; ++ running: bool; ++ cputime: int64; ++ cpumap: int32; ++} ++ ++type domaininfo = ++{ ++ domid : domid; ++ dying : bool; ++ shutdown : bool; ++ paused : bool; ++ blocked : bool; ++ running : bool; ++ hvm_guest : bool; ++ shutdown_code : int; ++ total_memory_pages: nativeint; ++ max_memory_pages : nativeint; ++ shared_info_frame : int64; ++ cpu_time : int64; ++ nr_online_vcpus : int; ++ max_vcpu_id : int; ++ ssidref : int32; ++ handle : int array; ++} ++ ++type sched_control = ++{ ++ weight : int; ++ cap : int; ++} ++ ++type physinfo_cap_flag = ++ | CAP_HVM ++ | CAP_DirectIO ++ ++type physinfo = ++{ ++ threads_per_core : int; ++ cores_per_socket : int; ++ nr_cpus : int; ++ max_node_id : int; ++ cpu_khz : int; ++ total_pages : nativeint; ++ free_pages : nativeint; ++ scrub_pages : nativeint; ++ (* XXX hw_cap *) ++ capabilities : physinfo_cap_flag list; ++} ++ ++type version = ++{ ++ major : int; ++ minor : int; ++ extra : string; ++} ++ ++ ++type compile_info = ++{ ++ compiler : string; ++ compile_by : string; ++ compile_domain : string; ++ compile_date : string; ++} ++ ++type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt ++ ++type domain_create_flag = CDF_HVM | CDF_HAP ++ ++exception Error of string ++ ++type handle ++ ++(* this is only use by coredumping *) ++external sizeof_core_header: unit -> int ++ = "stub_sizeof_core_header" ++external sizeof_vcpu_guest_context: unit -> int ++ = "stub_sizeof_vcpu_guest_context" ++external sizeof_xen_pfn: unit -> int = "stub_sizeof_xen_pfn" ++(* end of use *) ++ ++external interface_open: unit -> handle = "stub_xc_interface_open" ++external interface_close: handle -> unit = "stub_xc_interface_close" ++ ++external is_fake: unit -> bool = "stub_xc_interface_is_fake" ++ ++let with_intf f = ++ let xc = interface_open () in ++ let r = try f xc with exn -> interface_close xc; raise exn in ++ interface_close xc; ++ r ++ ++external _domain_create: handle -> int32 -> domain_create_flag list -> int array -> domid ++ = "stub_xc_domain_create" ++ ++let domain_create handle n flags uuid = ++ _domain_create handle n flags (Uuid.int_array_of_uuid uuid) ++ ++external _domain_sethandle: handle -> domid -> int array -> unit ++ = "stub_xc_domain_sethandle" ++ ++let domain_sethandle handle n uuid = ++ _domain_sethandle handle n (Uuid.int_array_of_uuid uuid) ++ ++external domain_max_vcpus: handle -> domid -> int -> unit ++ = "stub_xc_domain_max_vcpus" ++ ++external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause" ++external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause" ++external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fast" ++external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy" ++ ++external domain_shutdown: handle -> domid -> shutdown_reason -> unit ++ = "stub_xc_domain_shutdown" ++ ++external _domain_getinfolist: handle -> domid -> int -> domaininfo list ++ = "stub_xc_domain_getinfolist" ++ ++let domain_getinfolist handle first_domain = ++ let nb = 2 in ++ let last_domid l = (List.hd l).domid + 1 in ++ let rec __getlist from = ++ let l = _domain_getinfolist handle from nb in ++ (if List.length l = nb then __getlist (last_domid l) else []) @ l ++ in ++ List.rev (__getlist first_domain) ++ ++external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo" ++ ++external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo ++ = "stub_xc_vcpu_getinfo" ++ ++external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit ++ = "stub_xc_domain_ioport_permission" ++external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit ++ = "stub_xc_domain_iomem_permission" ++external domain_irq_permission: handle -> domid -> int -> bool -> unit ++ = "stub_xc_domain_irq_permission" ++ ++external vcpu_affinity_set: handle -> domid -> int -> bool array -> unit ++ = "stub_xc_vcpu_setaffinity" ++external vcpu_affinity_get: handle -> domid -> int -> bool array ++ = "stub_xc_vcpu_getaffinity" ++ ++external vcpu_context_get: handle -> domid -> int -> string ++ = "stub_xc_vcpu_context_get" ++ ++external sched_id: handle -> int = "stub_xc_sched_id" ++ ++external sched_credit_domain_set: handle -> domid -> sched_control -> unit ++ = "stub_sched_credit_domain_set" ++external sched_credit_domain_get: handle -> domid -> sched_control ++ = "stub_sched_credit_domain_get" ++ ++external shadow_allocation_set: handle -> domid -> int -> unit ++ = "stub_shadow_allocation_set" ++external shadow_allocation_get: handle -> domid -> int ++ = "stub_shadow_allocation_get" ++ ++external evtchn_alloc_unbound: handle -> domid -> domid -> int ++ = "stub_xc_evtchn_alloc_unbound" ++external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset" ++ ++external readconsolering: handle -> string = "stub_xc_readconsolering" ++ ++external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys" ++external physinfo: handle -> physinfo = "stub_xc_physinfo" ++external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info" ++ ++external domain_setmaxmem: handle -> domid -> int64 -> unit ++ = "stub_xc_domain_setmaxmem" ++external domain_set_memmap_limit: handle -> domid -> int64 -> unit ++ = "stub_xc_domain_set_memmap_limit" ++external domain_memory_increase_reservation: handle -> domid -> int64 -> unit ++ = "stub_xc_domain_memory_increase_reservation" ++ ++external domain_set_machine_address_size: handle -> domid -> int -> unit ++ = "stub_xc_domain_set_machine_address_size" ++external domain_get_machine_address_size: handle -> domid -> int ++ = "stub_xc_domain_get_machine_address_size" ++ ++external domain_cpuid_set: handle -> domid -> (int64 * (int64 option)) ++ -> string option array ++ -> string option array ++ = "stub_xc_domain_cpuid_set" ++external domain_cpuid_apply_policy: handle -> domid -> unit ++ = "stub_xc_domain_cpuid_apply_policy" ++external cpuid_check: handle -> (int64 * (int64 option)) -> string option array -> (bool * string option array) ++ = "stub_xc_cpuid_check" ++ ++external map_foreign_range: handle -> domid -> int ++ -> nativeint -> Xenmmap.mmap_interface ++ = "stub_map_foreign_range" ++ ++external domain_get_pfn_list: handle -> domid -> nativeint -> nativeint array ++ = "stub_xc_domain_get_pfn_list" ++ ++external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit ++ = "stub_xc_domain_assign_device" ++external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit ++ = "stub_xc_domain_deassign_device" ++external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool ++ = "stub_xc_domain_test_assign_device" ++ ++external version: handle -> version = "stub_xc_version_version" ++external version_compile_info: handle -> compile_info ++ = "stub_xc_version_compile_info" ++external version_changeset: handle -> string = "stub_xc_version_changeset" ++external version_capabilities: handle -> string = ++ "stub_xc_version_capabilities" ++ ++external watchdog : handle -> int -> int32 -> int ++ = "stub_xc_watchdog" ++ ++(* core dump structure *) ++type core_magic = Magic_hvm | Magic_pv ++ ++type core_header = { ++ xch_magic: core_magic; ++ xch_nr_vcpus: int; ++ xch_nr_pages: nativeint; ++ xch_index_offset: int64; ++ xch_ctxt_offset: int64; ++ xch_pages_offset: int64; ++} ++ ++external marshall_core_header: core_header -> string = "stub_marshall_core_header" ++ ++(* coredump *) ++let coredump xch domid fd = ++ let dump s = ++ let wd = Unix.write fd s 0 (String.length s) in ++ if wd <> String.length s then ++ failwith "error while writing"; ++ in ++ ++ let info = domain_getinfo xch domid in ++ ++ let nrpages = info.total_memory_pages in ++ let ctxt = Array.make info.max_vcpu_id None in ++ let nr_vcpus = ref 0 in ++ for i = 0 to info.max_vcpu_id - 1 ++ do ++ ctxt.(i) <- try ++ let v = vcpu_context_get xch domid i in ++ incr nr_vcpus; ++ Some v ++ with _ -> None ++ done; ++ ++ (* FIXME page offset if not rounded to sup *) ++ let page_offset = ++ Int64.add ++ (Int64.of_int (sizeof_core_header () + ++ (sizeof_vcpu_guest_context () * !nr_vcpus))) ++ (Int64.of_nativeint ( ++ Nativeint.mul ++ (Nativeint.of_int (sizeof_xen_pfn ())) ++ nrpages) ++ ) ++ in ++ ++ let header = { ++ xch_magic = if info.hvm_guest then Magic_hvm else Magic_pv; ++ xch_nr_vcpus = !nr_vcpus; ++ xch_nr_pages = nrpages; ++ xch_ctxt_offset = Int64.of_int (sizeof_core_header ()); ++ xch_index_offset = Int64.of_int (sizeof_core_header () ++ + sizeof_vcpu_guest_context ()); ++ xch_pages_offset = page_offset; ++ } in ++ ++ dump (marshall_core_header header); ++ for i = 0 to info.max_vcpu_id - 1 ++ do ++ match ctxt.(i) with ++ | None -> () ++ | Some ctxt_i -> dump ctxt_i ++ done; ++ let pfns = domain_get_pfn_list xch domid nrpages in ++ if Array.length pfns <> Nativeint.to_int nrpages then ++ failwith "could not get the page frame list"; ++ ++ let page_size = Xenmmap.getpagesize () in ++ for i = 0 to Nativeint.to_int nrpages - 1 ++ do ++ let page = map_foreign_range xch domid page_size pfns.(i) in ++ let data = Xenmmap.read page 0 page_size in ++ Xenmmap.unmap page; ++ dump data ++ done ++ ++(* ** Misc ** *) ++ ++(** ++ Convert the given number of pages to an amount in KiB, rounded up. ++ *) ++external pages_to_kib : int64 -> int64 = "stub_pages_to_kib" ++let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L ++ ++let _ = Callback.register_exception "xc.error" (Error "register_callback") +--- /dev/null ++++ b/tools/ocaml/libs/xc/xenctrl.mli +@@ -0,0 +1,184 @@ ++(* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * This program is free software; you can redistribute it and/or modify ++ * it under the terms of the GNU Lesser General Public License as published ++ * by the Free Software Foundation; version 2.1 only. with the special ++ * exception on linking described in file LICENSE. ++ * ++ * This program is distributed in the hope that it will be useful, ++ * but WITHOUT ANY WARRANTY; without even the implied warranty of ++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ * GNU Lesser General Public License for more details. ++ *) ++ ++type domid = int ++type vcpuinfo = { ++ online : bool; ++ blocked : bool; ++ running : bool; ++ cputime : int64; ++ cpumap : int32; ++} ++type domaininfo = { ++ domid : domid; ++ dying : bool; ++ shutdown : bool; ++ paused : bool; ++ blocked : bool; ++ running : bool; ++ hvm_guest : bool; ++ shutdown_code : int; ++ total_memory_pages : nativeint; ++ max_memory_pages : nativeint; ++ shared_info_frame : int64; ++ cpu_time : int64; ++ nr_online_vcpus : int; ++ max_vcpu_id : int; ++ ssidref : int32; ++ handle : int array; ++} ++type sched_control = { weight : int; cap : int; } ++type physinfo_cap_flag = CAP_HVM | CAP_DirectIO ++type physinfo = { ++ threads_per_core : int; ++ cores_per_socket : int; ++ nr_cpus : int; ++ max_node_id : int; ++ cpu_khz : int; ++ total_pages : nativeint; ++ free_pages : nativeint; ++ scrub_pages : nativeint; ++ capabilities : physinfo_cap_flag list; ++} ++type version = { major : int; minor : int; extra : string; } ++type compile_info = { ++ compiler : string; ++ compile_by : string; ++ compile_domain : string; ++ compile_date : string; ++} ++type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt ++ ++type domain_create_flag = CDF_HVM | CDF_HAP ++ ++exception Error of string ++type handle ++external sizeof_core_header : unit -> int = "stub_sizeof_core_header" ++external sizeof_vcpu_guest_context : unit -> int ++ = "stub_sizeof_vcpu_guest_context" ++external sizeof_xen_pfn : unit -> int = "stub_sizeof_xen_pfn" ++external interface_open : unit -> handle = "stub_xc_interface_open" ++external is_fake : unit -> bool = "stub_xc_interface_is_fake" ++external interface_close : handle -> unit = "stub_xc_interface_close" ++val with_intf : (handle -> 'a) -> 'a ++external _domain_create : handle -> int32 -> domain_create_flag list -> int array -> domid ++ = "stub_xc_domain_create" ++val domain_create : handle -> int32 -> domain_create_flag list -> 'a Uuid.t -> domid ++external _domain_sethandle : handle -> domid -> int array -> unit ++ = "stub_xc_domain_sethandle" ++val domain_sethandle : handle -> domid -> 'a Uuid.t -> unit ++external domain_max_vcpus : handle -> domid -> int -> unit ++ = "stub_xc_domain_max_vcpus" ++external domain_pause : handle -> domid -> unit = "stub_xc_domain_pause" ++external domain_unpause : handle -> domid -> unit = "stub_xc_domain_unpause" ++external domain_resume_fast : handle -> domid -> unit ++ = "stub_xc_domain_resume_fast" ++external domain_destroy : handle -> domid -> unit = "stub_xc_domain_destroy" ++external domain_shutdown : handle -> domid -> shutdown_reason -> unit ++ = "stub_xc_domain_shutdown" ++external _domain_getinfolist : handle -> domid -> int -> domaininfo list ++ = "stub_xc_domain_getinfolist" ++val domain_getinfolist : handle -> domid -> domaininfo list ++external domain_getinfo : handle -> domid -> domaininfo ++ = "stub_xc_domain_getinfo" ++external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo ++ = "stub_xc_vcpu_getinfo" ++external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit ++ = "stub_xc_domain_ioport_permission" ++external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit ++ = "stub_xc_domain_iomem_permission" ++external domain_irq_permission: handle -> domid -> int -> bool -> unit ++ = "stub_xc_domain_irq_permission" ++external vcpu_affinity_set : handle -> domid -> int -> bool array -> unit ++ = "stub_xc_vcpu_setaffinity" ++external vcpu_affinity_get : handle -> domid -> int -> bool array ++ = "stub_xc_vcpu_getaffinity" ++external vcpu_context_get : handle -> domid -> int -> string ++ = "stub_xc_vcpu_context_get" ++external sched_id : handle -> int = "stub_xc_sched_id" ++external sched_credit_domain_set : handle -> domid -> sched_control -> unit ++ = "stub_sched_credit_domain_set" ++external sched_credit_domain_get : handle -> domid -> sched_control ++ = "stub_sched_credit_domain_get" ++external shadow_allocation_set : handle -> domid -> int -> unit ++ = "stub_shadow_allocation_set" ++external shadow_allocation_get : handle -> domid -> int ++ = "stub_shadow_allocation_get" ++external evtchn_alloc_unbound : handle -> domid -> domid -> int ++ = "stub_xc_evtchn_alloc_unbound" ++external evtchn_reset : handle -> domid -> unit = "stub_xc_evtchn_reset" ++external readconsolering : handle -> string = "stub_xc_readconsolering" ++external send_debug_keys : handle -> string -> unit = "stub_xc_send_debug_keys" ++external physinfo : handle -> physinfo = "stub_xc_physinfo" ++external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info" ++external domain_setmaxmem : handle -> domid -> int64 -> unit ++ = "stub_xc_domain_setmaxmem" ++external domain_set_memmap_limit : handle -> domid -> int64 -> unit ++ = "stub_xc_domain_set_memmap_limit" ++external domain_memory_increase_reservation : ++ handle -> domid -> int64 -> unit ++ = "stub_xc_domain_memory_increase_reservation" ++external map_foreign_range : ++ handle -> domid -> int -> nativeint -> Xenmmap.mmap_interface ++ = "stub_map_foreign_range" ++external domain_get_pfn_list : ++ handle -> domid -> nativeint -> nativeint array ++ = "stub_xc_domain_get_pfn_list" ++ ++external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit ++ = "stub_xc_domain_assign_device" ++external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit ++ = "stub_xc_domain_deassign_device" ++external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool ++ = "stub_xc_domain_test_assign_device" ++ ++external version : handle -> version = "stub_xc_version_version" ++external version_compile_info : handle -> compile_info ++ = "stub_xc_version_compile_info" ++external version_changeset : handle -> string = "stub_xc_version_changeset" ++external version_capabilities : handle -> string ++ = "stub_xc_version_capabilities" ++type core_magic = Magic_hvm | Magic_pv ++type core_header = { ++ xch_magic : core_magic; ++ xch_nr_vcpus : int; ++ xch_nr_pages : nativeint; ++ xch_index_offset : int64; ++ xch_ctxt_offset : int64; ++ xch_pages_offset : int64; ++} ++external marshall_core_header : core_header -> string ++ = "stub_marshall_core_header" ++val coredump : handle -> domid -> Unix.file_descr -> unit ++external pages_to_kib : int64 -> int64 = "stub_pages_to_kib" ++val pages_to_mib : int64 -> int64 ++external watchdog : handle -> int -> int32 -> int ++ = "stub_xc_watchdog" ++ ++external domain_set_machine_address_size: handle -> domid -> int -> unit ++ = "stub_xc_domain_set_machine_address_size" ++external domain_get_machine_address_size: handle -> domid -> int ++ = "stub_xc_domain_get_machine_address_size" ++ ++external domain_cpuid_set: handle -> domid -> (int64 * (int64 option)) ++ -> string option array ++ -> string option array ++ = "stub_xc_domain_cpuid_set" ++external domain_cpuid_apply_policy: handle -> domid -> unit ++ = "stub_xc_domain_cpuid_apply_policy" ++external cpuid_check: handle -> (int64 * (int64 option)) -> string option array -> (bool * string option array) ++ = "stub_xc_cpuid_check" ++ +--- /dev/null ++++ b/tools/ocaml/libs/xc/xenctrl_stubs.c +@@ -0,0 +1,1161 @@ ++/* ++ * Copyright (C) 2006-2007 XenSource Ltd. ++ * Copyright (C) 2008 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * 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 ++#include ++ ++#define CAML_NAME_SPACE ++#include ++#include ++#include ++#include ++#include ++ ++#include ++#include ++#include ++ ++#include ++ ++#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> r) & 1) { ++ tmp = caml_alloc_small(2, Tag_cons); ++ Field(tmp, 0) = Val_int(r); ++ Field(tmp, 1) = cap_list; ++ cap_list = tmp; ++ } ++ } ++ ++ physinfo = caml_alloc_tuple(9); ++ Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core)); ++ Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket)); ++ Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus)); ++ Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id)); ++ Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz)); ++ Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages)); ++ Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages)); ++ Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages)); ++ Store_field(physinfo, 8, cap_list); ++ ++ CAMLreturn(physinfo); ++} ++ ++CAMLprim value stub_xc_pcpu_info(value xch, value nr_cpus) ++{ ++ CAMLparam2(xch, nr_cpus); ++ CAMLlocal2(pcpus, v); ++ xc_cpuinfo_t *info; ++ int r, size; ++ ++ if (Int_val(nr_cpus) < 1) ++ caml_invalid_argument("nr_cpus"); ++ ++ info = calloc(Int_val(nr_cpus) + 1, sizeof(*info)); ++ if (!info) ++ caml_raise_out_of_memory(); ++ ++ // caml_enter_blocking_section(); ++ r = xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size); ++ // caml_leave_blocking_section(); ++ ++ if (r) { ++ free(info); ++ failwith_xc(_H(xch)); ++ } ++ ++ if (size > 0) { ++ int i; ++ pcpus = caml_alloc(size, 0); ++ for (i = 0; i < size; i++) { ++ v = caml_copy_int64(info[i].idletime); ++ caml_modify(&Field(pcpus, i), v); ++ } ++ } else ++ pcpus = Atom(0); ++ free(info); ++ CAMLreturn(pcpus); ++} ++ ++CAMLprim value stub_xc_domain_setmaxmem(value xch, value domid, ++ value max_memkb) ++{ ++ CAMLparam3(xch, domid, max_memkb); ++ ++ uint32_t c_domid = _D(domid); ++ unsigned int c_max_memkb = Int64_val(max_memkb); ++ // caml_enter_blocking_section(); ++ int retval = xc_domain_setmaxmem(_H(xch), c_domid, ++ c_max_memkb); ++ // caml_leave_blocking_section(); ++ if (retval) ++ failwith_xc(_H(xch)); ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_domain_set_memmap_limit(value xch, value domid, ++ value map_limitkb) ++{ ++ CAMLparam3(xch, domid, map_limitkb); ++ unsigned long v; ++ int retval; ++ ++ v = Int64_val(map_limitkb); ++ retval = xc_domain_set_memmap_limit(_H(xch), _D(domid), v); ++ if (retval) ++ failwith_xc(_H(xch)); ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_domain_memory_increase_reservation(value xch, ++ value domid, ++ value mem_kb) ++{ ++ CAMLparam3(xch, domid, mem_kb); ++ ++ unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (PAGE_SHIFT - 10); ++ ++ uint32_t c_domid = _D(domid); ++ // caml_enter_blocking_section(); ++ int retval = xc_domain_increase_reservation_exact(_H(xch), c_domid, ++ nr_extents, 0, 0, NULL); ++ // caml_leave_blocking_section(); ++ ++ if (retval) ++ failwith_xc(_H(xch)); ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_domain_set_machine_address_size(value xch, ++ value domid, ++ value width) ++{ ++ CAMLparam3(xch, domid, width); ++ uint32_t c_domid = _D(domid); ++ int c_width = Int_val(width); ++ ++ int retval = xc_domain_set_machine_address_size(_H(xch), c_domid, c_width); ++ if (retval) ++ failwith_xc(_H(xch)); ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_domain_get_machine_address_size(value xch, ++ value domid) ++{ ++ CAMLparam2(xch, domid); ++ int retval; ++ ++ retval = xc_domain_get_machine_address_size(_H(xch), _D(domid)); ++ if (retval < 0) ++ failwith_xc(_H(xch)); ++ CAMLreturn(Val_int(retval)); ++} ++ ++CAMLprim value stub_xc_domain_cpuid_set(value xch, value domid, ++ value input, ++ value config) ++{ ++ CAMLparam4(xch, domid, input, config); ++ CAMLlocal2(array, tmp); ++ int r; ++ unsigned int c_input[2]; ++ char *c_config[4], *out_config[4]; ++ ++ c_config[0] = string_of_option_array(config, 0); ++ c_config[1] = string_of_option_array(config, 1); ++ c_config[2] = string_of_option_array(config, 2); ++ c_config[3] = string_of_option_array(config, 3); ++ ++ cpuid_input_of_val(c_input[0], c_input[1], input); ++ ++ array = caml_alloc(4, 0); ++ for (r = 0; r < 4; r++) { ++ tmp = Val_none; ++ if (c_config[r]) { ++ tmp = caml_alloc_small(1, 0); ++ Field(tmp, 0) = caml_alloc_string(32); ++ } ++ Store_field(array, r, tmp); ++ } ++ ++ for (r = 0; r < 4; r++) ++ out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL; ++ ++ r = xc_cpuid_set(_H(xch), _D(domid), ++ c_input, (const char **)c_config, out_config); ++ if (r < 0) ++ failwith_xc(_H(xch)); ++ CAMLreturn(array); ++} ++ ++CAMLprim value stub_xc_domain_cpuid_apply_policy(value xch, value domid) ++{ ++ CAMLparam2(xch, domid); ++ int r; ++ ++ r = xc_cpuid_apply_policy(_H(xch), _D(domid)); ++ if (r < 0) ++ failwith_xc(_H(xch)); ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_cpuid_check(value xch, value input, value config) ++{ ++ CAMLparam3(xch, input, config); ++ CAMLlocal3(ret, array, tmp); ++ int r; ++ unsigned int c_input[2]; ++ char *c_config[4], *out_config[4]; ++ ++ c_config[0] = string_of_option_array(config, 0); ++ c_config[1] = string_of_option_array(config, 1); ++ c_config[2] = string_of_option_array(config, 2); ++ c_config[3] = string_of_option_array(config, 3); ++ ++ cpuid_input_of_val(c_input[0], c_input[1], input); ++ ++ array = caml_alloc(4, 0); ++ for (r = 0; r < 4; r++) { ++ tmp = Val_none; ++ if (c_config[r]) { ++ tmp = caml_alloc_small(1, 0); ++ Field(tmp, 0) = caml_alloc_string(32); ++ } ++ Store_field(array, r, tmp); ++ } ++ ++ for (r = 0; r < 4; r++) ++ out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL; ++ ++ r = xc_cpuid_check(_H(xch), c_input, (const char **)c_config, out_config); ++ if (r < 0) ++ failwith_xc(_H(xch)); ++ ++ ret = caml_alloc_tuple(2); ++ Store_field(ret, 0, Val_bool(r)); ++ Store_field(ret, 1, array); ++ ++ CAMLreturn(ret); ++} ++ ++CAMLprim value stub_xc_version_version(value xch) ++{ ++ CAMLparam1(xch); ++ CAMLlocal1(result); ++ xen_extraversion_t extra; ++ long packed; ++ int retval; ++ ++ // caml_enter_blocking_section(); ++ packed = xc_version(_H(xch), XENVER_version, NULL); ++ retval = xc_version(_H(xch), XENVER_extraversion, &extra); ++ // caml_leave_blocking_section(); ++ ++ if (retval) ++ failwith_xc(_H(xch)); ++ ++ result = caml_alloc_tuple(3); ++ ++ Store_field(result, 0, Val_int(packed >> 16)); ++ Store_field(result, 1, Val_int(packed & 0xffff)); ++ Store_field(result, 2, caml_copy_string(extra)); ++ ++ CAMLreturn(result); ++} ++ ++ ++CAMLprim value stub_xc_version_compile_info(value xch) ++{ ++ CAMLparam1(xch); ++ CAMLlocal1(result); ++ xen_compile_info_t ci; ++ int retval; ++ ++ // caml_enter_blocking_section(); ++ retval = xc_version(_H(xch), XENVER_compile_info, &ci); ++ // caml_leave_blocking_section(); ++ ++ if (retval) ++ failwith_xc(_H(xch)); ++ ++ result = caml_alloc_tuple(4); ++ ++ Store_field(result, 0, caml_copy_string(ci.compiler)); ++ Store_field(result, 1, caml_copy_string(ci.compile_by)); ++ Store_field(result, 2, caml_copy_string(ci.compile_domain)); ++ Store_field(result, 3, caml_copy_string(ci.compile_date)); ++ ++ CAMLreturn(result); ++} ++ ++ ++static value xc_version_single_string(value xch, int code, void *info) ++{ ++ CAMLparam1(xch); ++ int retval; ++ ++ // caml_enter_blocking_section(); ++ retval = xc_version(_H(xch), code, info); ++ // caml_leave_blocking_section(); ++ ++ if (retval) ++ failwith_xc(_H(xch)); ++ ++ CAMLreturn(caml_copy_string((char *)info)); ++} ++ ++ ++CAMLprim value stub_xc_version_changeset(value xch) ++{ ++ xen_changeset_info_t ci; ++ ++ return xc_version_single_string(xch, XENVER_changeset, &ci); ++} ++ ++ ++CAMLprim value stub_xc_version_capabilities(value xch) ++{ ++ xen_capabilities_info_t ci; ++ ++ return xc_version_single_string(xch, XENVER_capabilities, &ci); ++} ++ ++ ++CAMLprim value stub_pages_to_kib(value pages) ++{ ++ CAMLparam1(pages); ++ ++ CAMLreturn(caml_copy_int64(Int64_val(pages) << (PAGE_SHIFT - 10))); ++} ++ ++ ++CAMLprim value stub_map_foreign_range(value xch, value dom, ++ value size, value mfn) ++{ ++ CAMLparam4(xch, dom, size, mfn); ++ CAMLlocal1(result); ++ struct mmap_interface *intf; ++ uint32_t c_dom; ++ unsigned long c_mfn; ++ ++ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); ++ intf = (struct mmap_interface *) result; ++ ++ intf->len = Int_val(size); ++ ++ c_dom = _D(dom); ++ c_mfn = Nativeint_val(mfn); ++ // caml_enter_blocking_section(); ++ intf->addr = xc_map_foreign_range(_H(xch), c_dom, ++ intf->len, PROT_READ|PROT_WRITE, ++ c_mfn); ++ // caml_leave_blocking_section(); ++ if (!intf->addr) ++ caml_failwith("xc_map_foreign_range error"); ++ CAMLreturn(result); ++} ++ ++CAMLprim value stub_sched_credit_domain_get(value xch, value domid) ++{ ++ CAMLparam2(xch, domid); ++ CAMLlocal1(sdom); ++ struct xen_domctl_sched_credit c_sdom; ++ int ret; ++ ++ // caml_enter_blocking_section(); ++ ret = xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom); ++ // caml_leave_blocking_section(); ++ if (ret != 0) ++ failwith_xc(_H(xch)); ++ ++ sdom = caml_alloc_tuple(2); ++ Store_field(sdom, 0, Val_int(c_sdom.weight)); ++ Store_field(sdom, 1, Val_int(c_sdom.cap)); ++ ++ CAMLreturn(sdom); ++} ++ ++CAMLprim value stub_sched_credit_domain_set(value xch, value domid, ++ value sdom) ++{ ++ CAMLparam3(xch, domid, sdom); ++ struct xen_domctl_sched_credit c_sdom; ++ int ret; ++ ++ c_sdom.weight = Int_val(Field(sdom, 0)); ++ c_sdom.cap = Int_val(Field(sdom, 1)); ++ // caml_enter_blocking_section(); ++ ret = xc_sched_credit_domain_set(_H(xch), _D(domid), &c_sdom); ++ // caml_leave_blocking_section(); ++ if (ret != 0) ++ failwith_xc(_H(xch)); ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_shadow_allocation_get(value xch, value domid) ++{ ++ CAMLparam2(xch, domid); ++ CAMLlocal1(mb); ++ unsigned long c_mb; ++ int ret; ++ ++ // caml_enter_blocking_section(); ++ ret = xc_shadow_control(_H(xch), _D(domid), ++ XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION, ++ NULL, 0, &c_mb, 0, NULL); ++ // caml_leave_blocking_section(); ++ if (ret != 0) ++ failwith_xc(_H(xch)); ++ ++ mb = Val_int(c_mb); ++ CAMLreturn(mb); ++} ++ ++CAMLprim value stub_shadow_allocation_set(value xch, value domid, ++ value mb) ++{ ++ CAMLparam3(xch, domid, mb); ++ unsigned long c_mb; ++ int ret; ++ ++ c_mb = Int_val(mb); ++ // caml_enter_blocking_section(); ++ ret = xc_shadow_control(_H(xch), _D(domid), ++ XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION, ++ NULL, 0, &c_mb, 0, NULL); ++ // caml_leave_blocking_section(); ++ if (ret != 0) ++ failwith_xc(_H(xch)); ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_domain_get_pfn_list(value xch, value domid, ++ value nr_pfns) ++{ ++ CAMLparam3(xch, domid, nr_pfns); ++ CAMLlocal2(array, v); ++ unsigned long c_nr_pfns; ++ long ret, i; ++ uint64_t *c_array; ++ ++ c_nr_pfns = Nativeint_val(nr_pfns); ++ ++ c_array = malloc(sizeof(uint64_t) * c_nr_pfns); ++ if (!c_array) ++ caml_raise_out_of_memory(); ++ ++ ret = xc_get_pfn_list(_H(xch), _D(domid), ++ c_array, c_nr_pfns); ++ if (ret < 0) { ++ free(c_array); ++ failwith_xc(_H(xch)); ++ } ++ ++ array = caml_alloc(ret, 0); ++ for (i = 0; i < ret; i++) { ++ v = caml_copy_nativeint(c_array[i]); ++ Store_field(array, i, v); ++ } ++ free(c_array); ++ ++ CAMLreturn(array); ++} ++ ++CAMLprim value stub_xc_domain_ioport_permission(value xch, value domid, ++ value start_port, value nr_ports, ++ value allow) ++{ ++ CAMLparam5(xch, domid, start_port, nr_ports, allow); ++ uint32_t c_start_port, c_nr_ports; ++ uint8_t c_allow; ++ int ret; ++ ++ c_start_port = Int_val(start_port); ++ c_nr_ports = Int_val(nr_ports); ++ c_allow = Bool_val(allow); ++ ++ ret = xc_domain_ioport_permission(_H(xch), _D(domid), ++ c_start_port, c_nr_ports, c_allow); ++ if (ret < 0) ++ failwith_xc(_H(xch)); ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_domain_iomem_permission(value xch, value domid, ++ value start_pfn, value nr_pfns, ++ value allow) ++{ ++ CAMLparam5(xch, domid, start_pfn, nr_pfns, allow); ++ unsigned long c_start_pfn, c_nr_pfns; ++ uint8_t c_allow; ++ int ret; ++ ++ c_start_pfn = Nativeint_val(start_pfn); ++ c_nr_pfns = Nativeint_val(nr_pfns); ++ c_allow = Bool_val(allow); ++ ++ ret = xc_domain_iomem_permission(_H(xch), _D(domid), ++ c_start_pfn, c_nr_pfns, c_allow); ++ if (ret < 0) ++ failwith_xc(_H(xch)); ++ ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_domain_irq_permission(value xch, value domid, ++ value pirq, value allow) ++{ ++ CAMLparam4(xch, domid, pirq, allow); ++ uint8_t c_pirq; ++ uint8_t c_allow; ++ int ret; ++ ++ c_pirq = Int_val(pirq); ++ c_allow = Bool_val(allow); ++ ++ ret = xc_domain_irq_permission(_H(xch), _D(domid), ++ c_pirq, c_allow); ++ if (ret < 0) ++ failwith_xc(_H(xch)); ++ ++ CAMLreturn(Val_unit); ++} ++ ++static uint32_t pci_dev_to_bdf(int domain, int bus, int slot, int func) ++{ ++ uint32_t bdf = 0; ++ bdf |= (bus & 0xff) << 16; ++ bdf |= (slot & 0x1f) << 11; ++ bdf |= (func & 0x7) << 8; ++ return bdf; ++} ++ ++CAMLprim value stub_xc_domain_test_assign_device(value xch, value domid, value desc) ++{ ++ CAMLparam3(xch, domid, desc); ++ int ret; ++ int domain, bus, slot, func; ++ uint32_t bdf; ++ ++ domain = Int_val(Field(desc, 0)); ++ bus = Int_val(Field(desc, 1)); ++ slot = Int_val(Field(desc, 2)); ++ func = Int_val(Field(desc, 3)); ++ bdf = pci_dev_to_bdf(domain, bus, slot, func); ++ ++ ret = xc_test_assign_device(_H(xch), _D(domid), bdf); ++ ++ CAMLreturn(Val_bool(ret == 0)); ++} ++ ++CAMLprim value stub_xc_domain_assign_device(value xch, value domid, value desc) ++{ ++ CAMLparam3(xch, domid, desc); ++ int ret; ++ int domain, bus, slot, func; ++ uint32_t bdf; ++ ++ domain = Int_val(Field(desc, 0)); ++ bus = Int_val(Field(desc, 1)); ++ slot = Int_val(Field(desc, 2)); ++ func = Int_val(Field(desc, 3)); ++ bdf = pci_dev_to_bdf(domain, bus, slot, func); ++ ++ ret = xc_assign_device(_H(xch), _D(domid), bdf); ++ ++ if (ret < 0) ++ failwith_xc(_H(xch)); ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_domain_deassign_device(value xch, value domid, value desc) ++{ ++ CAMLparam3(xch, domid, desc); ++ int ret; ++ int domain, bus, slot, func; ++ uint32_t bdf; ++ ++ domain = Int_val(Field(desc, 0)); ++ bus = Int_val(Field(desc, 1)); ++ slot = Int_val(Field(desc, 2)); ++ func = Int_val(Field(desc, 3)); ++ bdf = pci_dev_to_bdf(domain, bus, slot, func); ++ ++ ret = xc_deassign_device(_H(xch), _D(domid), bdf); ++ ++ if (ret < 0) ++ failwith_xc(_H(xch)); ++ CAMLreturn(Val_unit); ++} ++ ++CAMLprim value stub_xc_watchdog(value xch, value domid, value timeout) ++{ ++ CAMLparam3(xch, domid, timeout); ++ int ret; ++ unsigned int c_timeout = Int32_val(timeout); ++ ++ ret = xc_watchdog(_H(xch), _D(domid), c_timeout); ++ if (ret < 0) ++ failwith_xc(_H(xch)); ++ ++ CAMLreturn(Val_int(ret)); ++} ++ ++/* ++ * Local variables: ++ * indent-tabs-mode: t ++ * c-basic-offset: 8 ++ * tab-width: 8 ++ * End: ++ */ +--- a/tools/ocaml/libs/xl/Makefile ++++ b/tools/ocaml/libs/xl/Makefile +@@ -2,14 +2,14 @@ + XEN_ROOT=$(TOPLEVEL)/../.. + include $(TOPLEVEL)/common.make + +-OBJS = xl +-INTF = xl.cmi +-LIBS = xl.cma xl.cmxa ++OBJS = xenlight ++INTF = xenlight.cmi ++LIBS = xenlight.cma xenlight.cmxa + +-xl_OBJS = $(OBJS) +-xl_C_OBJS = xl_stubs ++xenlight_OBJS = $(OBJS) ++xenlight_C_OBJS = xenlight_stubs + +-OCAML_LIBRARY = xl ++OCAML_LIBRARY = xenlight + + all: $(INTF) $(LIBS) + +@@ -18,11 +18,11 @@ + .PHONY: install + install: $(LIBS) META + mkdir -p $(OCAMLDESTDIR) +- ocamlfind remove -destdir $(OCAMLDESTDIR) xl +- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xl META $(INTF) $(LIBS) *.a *.so *.cmx ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenlight ++ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenlight META $(INTF) $(LIBS) *.a *.so *.cmx + + .PHONY: uninstall + uninstall: +- ocamlfind remove -destdir $(OCAMLDESTDIR) xl ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenlight + + include $(TOPLEVEL)/Makefile.rules +--- /dev/null ++++ b/tools/ocaml/libs/xl/xenlight_stubs.c +@@ -0,0 +1,729 @@ ++/* ++ * Copyright (C) 2009-2010 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * 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 ++ ++#define CAML_NAME_SPACE ++#include ++#include ++#include ++#include ++#include ++ ++#include ++#include ++#include ++ ++#include "libxl.h" ++ ++struct caml_logger { ++ struct xentoollog_logger logger; ++ int log_offset; ++ char log_buf[2048]; ++}; ++ ++typedef struct caml_gc { ++ int offset; ++ void *ptrs[64]; ++} caml_gc; ++ ++void log_vmessage(struct xentoollog_logger *logger, xentoollog_level level, ++ int errnoval, const char *context, const char *format, va_list al) ++{ ++ struct caml_logger *ologger = (struct caml_logger *) logger; ++ ++ ologger->log_offset += vsnprintf(ologger->log_buf + ologger->log_offset, ++ 2048 - ologger->log_offset, format, al); ++} ++ ++void log_destroy(struct xentoollog_logger *logger) ++{ ++} ++ ++#define INIT_STRUCT() libxl_ctx ctx; struct caml_logger lg; struct caml_gc gc; gc.offset = 0; ++ ++#define INIT_CTX() \ ++ lg.logger.vmessage = log_vmessage; \ ++ lg.logger.destroy = log_destroy; \ ++ lg.logger.progress = NULL; \ ++ caml_enter_blocking_section(); \ ++ ret = libxl_ctx_init(&ctx, LIBXL_VERSION, (struct xentoollog_logger *) &lg); \ ++ if (ret != 0) \ ++ failwith_xl("cannot init context", &lg); ++ ++#define FREE_CTX() \ ++ gc_free(&gc); \ ++ caml_leave_blocking_section(); \ ++ libxl_ctx_free(&ctx) ++ ++static char * dup_String_val(caml_gc *gc, value s) ++{ ++ int len; ++ char *c; ++ len = caml_string_length(s); ++ c = calloc(len + 1, sizeof(char)); ++ if (!c) ++ caml_raise_out_of_memory(); ++ gc->ptrs[gc->offset++] = c; ++ memcpy(c, String_val(s), len); ++ return c; ++} ++ ++static void gc_free(caml_gc *gc) ++{ ++ int i; ++ for (i = 0; i < gc->offset; i++) { ++ free(gc->ptrs[i]); ++ } ++} ++ ++void failwith_xl(char *fname, struct caml_logger *lg) ++{ ++ char *s; ++ s = (lg) ? lg->log_buf : fname; ++ caml_raise_with_string(*caml_named_value("xl.error"), s); ++} ++ ++#if 0 /* TODO: wrap libxl_domain_create(), these functions will be needed then */ ++static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size) ++{ ++ void *ptr; ++ ptr = calloc(nmemb, size); ++ if (!ptr) ++ caml_raise_out_of_memory(); ++ gc->ptrs[gc->offset++] = ptr; ++ return ptr; ++} ++ ++static int string_string_tuple_array_val (caml_gc *gc, char ***c_val, value v) ++{ ++ CAMLparam1(v); ++ CAMLlocal1(a); ++ int i; ++ char **array; ++ ++ for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1)) { i++; } ++ ++ array = gc_calloc(gc, (i + 1) * 2, sizeof(char *)); ++ if (!array) ++ return 1; ++ for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1), i++) { ++ value b = Field(a, 0); ++ array[i * 2] = dup_String_val(gc, Field(b, 0)); ++ array[i * 2 + 1] = dup_String_val(gc, Field(b, 1)); ++ } ++ *c_val = array; ++ CAMLreturn(0); ++} ++ ++static int domain_create_info_val (caml_gc *gc, libxl_domain_create_info *c_val, value v) ++{ ++ CAMLparam1(v); ++ CAMLlocal1(a); ++ uint8_t *uuid = libxl_uuid_bytearray(&c_val->uuid); ++ int i; ++ ++ c_val->hvm = Bool_val(Field(v, 0)); ++ c_val->hap = Bool_val(Field(v, 1)); ++ c_val->oos = Bool_val(Field(v, 2)); ++ c_val->ssidref = Int32_val(Field(v, 3)); ++ c_val->name = dup_String_val(gc, Field(v, 4)); ++ a = Field(v, 5); ++ for (i = 0; i < 16; i++) ++ uuid[i] = Int_val(Field(a, i)); ++ string_string_tuple_array_val(gc, &(c_val->xsdata), Field(v, 6)); ++ string_string_tuple_array_val(gc, &(c_val->platformdata), Field(v, 7)); ++ ++ c_val->poolid = Int32_val(Field(v, 8)); ++ c_val->poolname = dup_String_val(gc, Field(v, 9)); ++ ++ CAMLreturn(0); ++} ++ ++static int domain_build_info_val (caml_gc *gc, libxl_domain_build_info *c_val, value v) ++{ ++ CAMLparam1(v); ++ CAMLlocal1(infopriv); ++ ++ c_val->max_vcpus = Int_val(Field(v, 0)); ++ c_val->cur_vcpus = Int_val(Field(v, 1)); ++ c_val->max_memkb = Int64_val(Field(v, 2)); ++ c_val->target_memkb = Int64_val(Field(v, 3)); ++ c_val->video_memkb = Int64_val(Field(v, 4)); ++ c_val->shadow_memkb = Int64_val(Field(v, 5)); ++ c_val->kernel.path = dup_String_val(gc, Field(v, 6)); ++ c_val->is_hvm = Tag_val(Field(v, 7)) == 0; ++ infopriv = Field(Field(v, 7), 0); ++ if (c_val->hvm) { ++ c_val->u.hvm.pae = Bool_val(Field(infopriv, 0)); ++ c_val->u.hvm.apic = Bool_val(Field(infopriv, 1)); ++ c_val->u.hvm.acpi = Bool_val(Field(infopriv, 2)); ++ c_val->u.hvm.nx = Bool_val(Field(infopriv, 3)); ++ c_val->u.hvm.viridian = Bool_val(Field(infopriv, 4)); ++ c_val->u.hvm.timeoffset = dup_String_val(gc, Field(infopriv, 5)); ++ c_val->u.hvm.timer_mode = Int_val(Field(infopriv, 6)); ++ c_val->u.hvm.hpet = Int_val(Field(infopriv, 7)); ++ c_val->u.hvm.vpt_align = Int_val(Field(infopriv, 8)); ++ } else { ++ c_val->u.pv.slack_memkb = Int64_val(Field(infopriv, 0)); ++ c_val->u.pv.cmdline = dup_String_val(gc, Field(infopriv, 1)); ++ c_val->u.pv.ramdisk.path = dup_String_val(gc, Field(infopriv, 2)); ++ c_val->u.pv.features = dup_String_val(gc, Field(infopriv, 3)); ++ } ++ ++ CAMLreturn(0); ++} ++#endif ++ ++static int device_disk_val(caml_gc *gc, libxl_device_disk *c_val, value v) ++{ ++ CAMLparam1(v); ++ ++ c_val->backend_domid = Int_val(Field(v, 0)); ++ c_val->pdev_path = dup_String_val(gc, Field(v, 1)); ++ c_val->vdev = dup_String_val(gc, Field(v, 2)); ++ c_val->backend = (Int_val(Field(v, 3))); ++ c_val->format = (Int_val(Field(v, 4))); ++ c_val->unpluggable = Bool_val(Field(v, 5)); ++ c_val->readwrite = Bool_val(Field(v, 6)); ++ c_val->is_cdrom = Bool_val(Field(v, 7)); ++ ++ CAMLreturn(0); ++} ++ ++static int device_nic_val(caml_gc *gc, libxl_device_nic *c_val, value v) ++{ ++ CAMLparam1(v); ++ int i; ++ int ret = 0; ++ c_val->backend_domid = Int_val(Field(v, 0)); ++ c_val->devid = Int_val(Field(v, 1)); ++ c_val->mtu = Int_val(Field(v, 2)); ++ c_val->model = dup_String_val(gc, Field(v, 3)); ++ ++ if (Wosize_val(Field(v, 4)) != 6) { ++ ret = 1; ++ goto out; ++ } ++ for (i = 0; i < 6; i++) ++ c_val->mac[i] = Int_val(Field(Field(v, 4), i)); ++ ++ /* not handling c_val->ip */ ++ c_val->bridge = dup_String_val(gc, Field(v, 5)); ++ c_val->ifname = dup_String_val(gc, Field(v, 6)); ++ c_val->script = dup_String_val(gc, Field(v, 7)); ++ c_val->nictype = (Int_val(Field(v, 8))) + NICTYPE_IOEMU; ++ ++out: ++ CAMLreturn(ret); ++} ++ ++static int device_console_val(caml_gc *gc, libxl_device_console *c_val, value v) ++{ ++ CAMLparam1(v); ++ ++ c_val->backend_domid = Int_val(Field(v, 0)); ++ c_val->devid = Int_val(Field(v, 1)); ++ c_val->consback = (Int_val(Field(v, 2))) + LIBXL_CONSBACK_XENCONSOLED; ++ ++ CAMLreturn(0); ++} ++ ++static int device_vkb_val(caml_gc *gc, libxl_device_vkb *c_val, value v) ++{ ++ CAMLparam1(v); ++ ++ c_val->backend_domid = Int_val(Field(v, 0)); ++ c_val->devid = Int_val(Field(v, 1)); ++ ++ CAMLreturn(0); ++} ++ ++static int device_vfb_val(caml_gc *gc, libxl_device_vfb *c_val, value v) ++{ ++ CAMLparam1(v); ++ ++ c_val->backend_domid = Int_val(Field(v, 0)); ++ c_val->devid = Int_val(Field(v, 1)); ++ c_val->vnc = Bool_val(Field(v, 2)); ++ c_val->vnclisten = dup_String_val(gc, Field(v, 3)); ++ c_val->vncpasswd = dup_String_val(gc, Field(v, 4)); ++ c_val->vncdisplay = Int_val(Field(v, 5)); ++ c_val->keymap = dup_String_val(gc, Field(v, 6)); ++ c_val->sdl = Bool_val(Field(v, 7)); ++ c_val->opengl = Bool_val(Field(v, 8)); ++ c_val->display = dup_String_val(gc, Field(v, 9)); ++ c_val->xauthority = dup_String_val(gc, Field(v, 10)); ++ ++ CAMLreturn(0); ++} ++ ++static int device_pci_val(caml_gc *gc, libxl_device_pci *c_val, value v) ++{ ++ union { ++ unsigned int value; ++ struct { ++ unsigned int reserved1:2; ++ unsigned int reg:6; ++ unsigned int func:3; ++ unsigned int dev:5; ++ unsigned int bus:8; ++ unsigned int reserved2:7; ++ unsigned int enable:1; ++ }fields; ++ }u; ++ CAMLparam1(v); ++ ++ /* FIXME: propagate API change to ocaml */ ++ u.value = Int_val(Field(v, 0)); ++ c_val->reg = u.fields.reg; ++ c_val->func = u.fields.func; ++ c_val->dev = u.fields.dev; ++ c_val->bus = u.fields.bus; ++ c_val->enable = u.fields.enable; ++ ++ c_val->domain = Int_val(Field(v, 1)); ++ c_val->vdevfn = Int_val(Field(v, 2)); ++ c_val->msitranslate = Bool_val(Field(v, 3)); ++ c_val->power_mgmt = Bool_val(Field(v, 4)); ++ ++ CAMLreturn(0); ++} ++ ++static int sched_credit_val(caml_gc *gc, libxl_sched_credit *c_val, value v) ++{ ++ CAMLparam1(v); ++ c_val->weight = Int_val(Field(v, 0)); ++ c_val->cap = Int_val(Field(v, 1)); ++ CAMLreturn(0); ++} ++ ++static int domain_build_state_val(caml_gc *gc, libxl_domain_build_state *c_val, value v) ++{ ++ CAMLparam1(v); ++ ++ c_val->store_port = Int_val(Field(v, 0)); ++ c_val->store_mfn = Int64_val(Field(v, 1)); ++ c_val->console_port = Int_val(Field(v, 2)); ++ c_val->console_mfn = Int64_val(Field(v, 3)); ++ ++ CAMLreturn(0); ++} ++ ++static value Val_sched_credit(libxl_sched_credit *c_val) ++{ ++ CAMLparam0(); ++ CAMLlocal1(v); ++ ++ v = caml_alloc_tuple(2); ++ ++ Store_field(v, 0, Val_int(c_val->weight)); ++ Store_field(v, 1, Val_int(c_val->cap)); ++ ++ CAMLreturn(v); ++} ++ ++static value Val_physinfo(libxl_physinfo *c_val) ++{ ++ CAMLparam0(); ++ CAMLlocal2(v, hwcap); ++ int i; ++ ++ hwcap = caml_alloc_tuple(8); ++ for (i = 0; i < 8; i++) ++ Store_field(hwcap, i, caml_copy_int32(c_val->hw_cap[i])); ++ ++ v = caml_alloc_tuple(11); ++ Store_field(v, 0, Val_int(c_val->threads_per_core)); ++ Store_field(v, 1, Val_int(c_val->cores_per_socket)); ++ Store_field(v, 2, Val_int(c_val->max_cpu_id)); ++ Store_field(v, 3, Val_int(c_val->nr_cpus)); ++ Store_field(v, 4, Val_int(c_val->cpu_khz)); ++ Store_field(v, 5, caml_copy_int64(c_val->total_pages)); ++ Store_field(v, 6, caml_copy_int64(c_val->free_pages)); ++ Store_field(v, 7, caml_copy_int64(c_val->scrub_pages)); ++ Store_field(v, 8, Val_int(c_val->nr_nodes)); ++ Store_field(v, 9, hwcap); ++ Store_field(v, 10, caml_copy_int32(c_val->phys_cap)); ++ ++ CAMLreturn(v); ++} ++ ++value stub_xl_disk_add(value info, value domid) ++{ ++ CAMLparam2(info, domid); ++ libxl_device_disk c_info; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_disk_val(&gc, &c_info, info); ++ c_info.domid = Int_val(domid); ++ ++ INIT_CTX(); ++ ret = libxl_device_disk_add(&ctx, Int_val(domid), &c_info); ++ if (ret != 0) ++ failwith_xl("disk_add", &lg); ++ FREE_CTX(); ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_disk_remove(value info, value domid) ++{ ++ CAMLparam2(info, domid); ++ libxl_device_disk c_info; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_disk_val(&gc, &c_info, info); ++ c_info.domid = Int_val(domid); ++ ++ INIT_CTX(); ++ ret = libxl_device_disk_del(&ctx, &c_info, 0); ++ if (ret != 0) ++ failwith_xl("disk_remove", &lg); ++ FREE_CTX(); ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_nic_add(value info, value domid) ++{ ++ CAMLparam2(info, domid); ++ libxl_device_nic c_info; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_nic_val(&gc, &c_info, info); ++ c_info.domid = Int_val(domid); ++ ++ INIT_CTX(); ++ ret = libxl_device_nic_add(&ctx, Int_val(domid), &c_info); ++ if (ret != 0) ++ failwith_xl("nic_add", &lg); ++ FREE_CTX(); ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_nic_remove(value info, value domid) ++{ ++ CAMLparam2(info, domid); ++ libxl_device_nic c_info; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_nic_val(&gc, &c_info, info); ++ c_info.domid = Int_val(domid); ++ ++ INIT_CTX(); ++ ret = libxl_device_nic_del(&ctx, &c_info, 0); ++ if (ret != 0) ++ failwith_xl("nic_remove", &lg); ++ FREE_CTX(); ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_console_add(value info, value state, value domid) ++{ ++ CAMLparam3(info, state, domid); ++ libxl_device_console c_info; ++ libxl_domain_build_state c_state; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_console_val(&gc, &c_info, info); ++ domain_build_state_val(&gc, &c_state, state); ++ c_info.domid = Int_val(domid); ++ c_info.build_state = &c_state; ++ ++ INIT_CTX(); ++ ret = libxl_device_console_add(&ctx, Int_val(domid), &c_info); ++ if (ret != 0) ++ failwith_xl("console_add", &lg); ++ FREE_CTX(); ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_vkb_add(value info, value domid) ++{ ++ CAMLparam2(info, domid); ++ libxl_device_vkb c_info; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_vkb_val(&gc, &c_info, info); ++ c_info.domid = Int_val(domid); ++ ++ INIT_CTX(); ++ ret = libxl_device_vkb_add(&ctx, Int_val(domid), &c_info); ++ if (ret != 0) ++ failwith_xl("vkb_add", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_vkb_clean_shutdown(value domid) ++{ ++ CAMLparam1(domid); ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_device_vkb_clean_shutdown(&ctx, Int_val(domid)); ++ if (ret != 0) ++ failwith_xl("vkb_clean_shutdown", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_vkb_hard_shutdown(value domid) ++{ ++ CAMLparam1(domid); ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_device_vkb_hard_shutdown(&ctx, Int_val(domid)); ++ if (ret != 0) ++ failwith_xl("vkb_hard_shutdown", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_vfb_add(value info, value domid) ++{ ++ CAMLparam2(info, domid); ++ libxl_device_vfb c_info; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_vfb_val(&gc, &c_info, info); ++ c_info.domid = Int_val(domid); ++ ++ INIT_CTX(); ++ ret = libxl_device_vfb_add(&ctx, Int_val(domid), &c_info); ++ if (ret != 0) ++ failwith_xl("vfb_add", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_vfb_clean_shutdown(value domid) ++{ ++ CAMLparam1(domid); ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_device_vfb_clean_shutdown(&ctx, Int_val(domid)); ++ if (ret != 0) ++ failwith_xl("vfb_clean_shutdown", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_vfb_hard_shutdown(value domid) ++{ ++ CAMLparam1(domid); ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_device_vfb_hard_shutdown(&ctx, Int_val(domid)); ++ if (ret != 0) ++ failwith_xl("vfb_hard_shutdown", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_pci_add(value info, value domid) ++{ ++ CAMLparam2(info, domid); ++ libxl_device_pci c_info; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_pci_val(&gc, &c_info, info); ++ ++ INIT_CTX(); ++ ret = libxl_device_pci_add(&ctx, Int_val(domid), &c_info); ++ if (ret != 0) ++ failwith_xl("pci_add", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_pci_remove(value info, value domid) ++{ ++ CAMLparam2(info, domid); ++ libxl_device_pci c_info; ++ int ret; ++ INIT_STRUCT(); ++ ++ device_pci_val(&gc, &c_info, info); ++ ++ INIT_CTX(); ++ ret = libxl_device_pci_remove(&ctx, Int_val(domid), &c_info, 0); ++ if (ret != 0) ++ failwith_xl("pci_remove", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_pci_shutdown(value domid) ++{ ++ CAMLparam1(domid); ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_device_pci_shutdown(&ctx, Int_val(domid)); ++ if (ret != 0) ++ failwith_xl("pci_shutdown", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_button_press(value domid, value button) ++{ ++ CAMLparam2(domid, button); ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_button_press(&ctx, Int_val(domid), Int_val(button) + POWER_BUTTON); ++ if (ret != 0) ++ failwith_xl("button_press", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_physinfo(value unit) ++{ ++ CAMLparam1(unit); ++ CAMLlocal1(physinfo); ++ libxl_physinfo c_physinfo; ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_get_physinfo(&ctx, &c_physinfo); ++ if (ret != 0) ++ failwith_xl("physinfo", &lg); ++ FREE_CTX(); ++ ++ physinfo = Val_physinfo(&c_physinfo); ++ CAMLreturn(physinfo); ++} ++ ++value stub_xl_sched_credit_domain_get(value domid) ++{ ++ CAMLparam1(domid); ++ CAMLlocal1(scinfo); ++ libxl_sched_credit c_scinfo; ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_sched_credit_domain_get(&ctx, Int_val(domid), &c_scinfo); ++ if (ret != 0) ++ failwith_xl("sched_credit_domain_get", &lg); ++ FREE_CTX(); ++ ++ scinfo = Val_sched_credit(&c_scinfo); ++ CAMLreturn(scinfo); ++} ++ ++value stub_xl_sched_credit_domain_set(value domid, value scinfo) ++{ ++ CAMLparam2(domid, scinfo); ++ libxl_sched_credit c_scinfo; ++ int ret; ++ INIT_STRUCT(); ++ ++ sched_credit_val(&gc, &c_scinfo, scinfo); ++ ++ INIT_CTX(); ++ ret = libxl_sched_credit_domain_set(&ctx, Int_val(domid), &c_scinfo); ++ if (ret != 0) ++ failwith_xl("sched_credit_domain_set", &lg); ++ FREE_CTX(); ++ ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_send_trigger(value domid, value trigger, value vcpuid) ++{ ++ CAMLparam3(domid, trigger, vcpuid); ++ int ret; ++ char *c_trigger; ++ INIT_STRUCT(); ++ ++ c_trigger = dup_String_val(&gc, trigger); ++ ++ INIT_CTX(); ++ ret = libxl_send_trigger(&ctx, Int_val(domid), c_trigger, Int_val(vcpuid)); ++ if (ret != 0) ++ failwith_xl("send_trigger", &lg); ++ FREE_CTX(); ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_send_sysrq(value domid, value sysrq) ++{ ++ CAMLparam2(domid, sysrq); ++ int ret; ++ INIT_STRUCT(); ++ ++ INIT_CTX(); ++ ret = libxl_send_sysrq(&ctx, Int_val(domid), Int_val(sysrq)); ++ if (ret != 0) ++ failwith_xl("send_sysrq", &lg); ++ FREE_CTX(); ++ CAMLreturn(Val_unit); ++} ++ ++value stub_xl_send_debug_keys(value keys) ++{ ++ CAMLparam1(keys); ++ int ret; ++ char *c_keys; ++ INIT_STRUCT(); ++ ++ c_keys = dup_String_val(&gc, keys); ++ ++ INIT_CTX(); ++ ret = libxl_send_debug_keys(&ctx, c_keys); ++ if (ret != 0) ++ failwith_xl("send_debug_keys", &lg); ++ FREE_CTX(); ++ CAMLreturn(Val_unit); ++} ++ ++/* ++ * Local variables: ++ * indent-tabs-mode: t ++ * c-basic-offset: 8 ++ * tab-width: 8 ++ * End: ++ */ +--- a/tools/ocaml/libs/xl/xl_stubs.c ++++ /dev/null +@@ -1,729 +0,0 @@ +-/* +- * Copyright (C) 2009-2010 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * 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 +- +-#define CAML_NAME_SPACE +-#include +-#include +-#include +-#include +-#include +- +-#include +-#include +-#include +- +-#include "libxl.h" +- +-struct caml_logger { +- struct xentoollog_logger logger; +- int log_offset; +- char log_buf[2048]; +-}; +- +-typedef struct caml_gc { +- int offset; +- void *ptrs[64]; +-} caml_gc; +- +-void log_vmessage(struct xentoollog_logger *logger, xentoollog_level level, +- int errnoval, const char *context, const char *format, va_list al) +-{ +- struct caml_logger *ologger = (struct caml_logger *) logger; +- +- ologger->log_offset += vsnprintf(ologger->log_buf + ologger->log_offset, +- 2048 - ologger->log_offset, format, al); +-} +- +-void log_destroy(struct xentoollog_logger *logger) +-{ +-} +- +-#define INIT_STRUCT() libxl_ctx ctx; struct caml_logger lg; struct caml_gc gc; gc.offset = 0; +- +-#define INIT_CTX() \ +- lg.logger.vmessage = log_vmessage; \ +- lg.logger.destroy = log_destroy; \ +- lg.logger.progress = NULL; \ +- caml_enter_blocking_section(); \ +- ret = libxl_ctx_init(&ctx, LIBXL_VERSION, (struct xentoollog_logger *) &lg); \ +- if (ret != 0) \ +- failwith_xl("cannot init context", &lg); +- +-#define FREE_CTX() \ +- gc_free(&gc); \ +- caml_leave_blocking_section(); \ +- libxl_ctx_free(&ctx) +- +-static char * dup_String_val(caml_gc *gc, value s) +-{ +- int len; +- char *c; +- len = caml_string_length(s); +- c = calloc(len + 1, sizeof(char)); +- if (!c) +- caml_raise_out_of_memory(); +- gc->ptrs[gc->offset++] = c; +- memcpy(c, String_val(s), len); +- return c; +-} +- +-static void gc_free(caml_gc *gc) +-{ +- int i; +- for (i = 0; i < gc->offset; i++) { +- free(gc->ptrs[i]); +- } +-} +- +-void failwith_xl(char *fname, struct caml_logger *lg) +-{ +- char *s; +- s = (lg) ? lg->log_buf : fname; +- caml_raise_with_string(*caml_named_value("xl.error"), s); +-} +- +-#if 0 /* TODO: wrap libxl_domain_create(), these functions will be needed then */ +-static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size) +-{ +- void *ptr; +- ptr = calloc(nmemb, size); +- if (!ptr) +- caml_raise_out_of_memory(); +- gc->ptrs[gc->offset++] = ptr; +- return ptr; +-} +- +-static int string_string_tuple_array_val (caml_gc *gc, char ***c_val, value v) +-{ +- CAMLparam1(v); +- CAMLlocal1(a); +- int i; +- char **array; +- +- for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1)) { i++; } +- +- array = gc_calloc(gc, (i + 1) * 2, sizeof(char *)); +- if (!array) +- return 1; +- for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1), i++) { +- value b = Field(a, 0); +- array[i * 2] = dup_String_val(gc, Field(b, 0)); +- array[i * 2 + 1] = dup_String_val(gc, Field(b, 1)); +- } +- *c_val = array; +- CAMLreturn(0); +-} +- +-static int domain_create_info_val (caml_gc *gc, libxl_domain_create_info *c_val, value v) +-{ +- CAMLparam1(v); +- CAMLlocal1(a); +- uint8_t *uuid = libxl_uuid_bytearray(&c_val->uuid); +- int i; +- +- c_val->hvm = Bool_val(Field(v, 0)); +- c_val->hap = Bool_val(Field(v, 1)); +- c_val->oos = Bool_val(Field(v, 2)); +- c_val->ssidref = Int32_val(Field(v, 3)); +- c_val->name = dup_String_val(gc, Field(v, 4)); +- a = Field(v, 5); +- for (i = 0; i < 16; i++) +- uuid[i] = Int_val(Field(a, i)); +- string_string_tuple_array_val(gc, &(c_val->xsdata), Field(v, 6)); +- string_string_tuple_array_val(gc, &(c_val->platformdata), Field(v, 7)); +- +- c_val->poolid = Int32_val(Field(v, 8)); +- c_val->poolname = dup_String_val(gc, Field(v, 9)); +- +- CAMLreturn(0); +-} +- +-static int domain_build_info_val (caml_gc *gc, libxl_domain_build_info *c_val, value v) +-{ +- CAMLparam1(v); +- CAMLlocal1(infopriv); +- +- c_val->max_vcpus = Int_val(Field(v, 0)); +- c_val->cur_vcpus = Int_val(Field(v, 1)); +- c_val->max_memkb = Int64_val(Field(v, 2)); +- c_val->target_memkb = Int64_val(Field(v, 3)); +- c_val->video_memkb = Int64_val(Field(v, 4)); +- c_val->shadow_memkb = Int64_val(Field(v, 5)); +- c_val->kernel.path = dup_String_val(gc, Field(v, 6)); +- c_val->is_hvm = Tag_val(Field(v, 7)) == 0; +- infopriv = Field(Field(v, 7), 0); +- if (c_val->hvm) { +- c_val->u.hvm.pae = Bool_val(Field(infopriv, 0)); +- c_val->u.hvm.apic = Bool_val(Field(infopriv, 1)); +- c_val->u.hvm.acpi = Bool_val(Field(infopriv, 2)); +- c_val->u.hvm.nx = Bool_val(Field(infopriv, 3)); +- c_val->u.hvm.viridian = Bool_val(Field(infopriv, 4)); +- c_val->u.hvm.timeoffset = dup_String_val(gc, Field(infopriv, 5)); +- c_val->u.hvm.timer_mode = Int_val(Field(infopriv, 6)); +- c_val->u.hvm.hpet = Int_val(Field(infopriv, 7)); +- c_val->u.hvm.vpt_align = Int_val(Field(infopriv, 8)); +- } else { +- c_val->u.pv.slack_memkb = Int64_val(Field(infopriv, 0)); +- c_val->u.pv.cmdline = dup_String_val(gc, Field(infopriv, 1)); +- c_val->u.pv.ramdisk.path = dup_String_val(gc, Field(infopriv, 2)); +- c_val->u.pv.features = dup_String_val(gc, Field(infopriv, 3)); +- } +- +- CAMLreturn(0); +-} +-#endif +- +-static int device_disk_val(caml_gc *gc, libxl_device_disk *c_val, value v) +-{ +- CAMLparam1(v); +- +- c_val->backend_domid = Int_val(Field(v, 0)); +- c_val->pdev_path = dup_String_val(gc, Field(v, 1)); +- c_val->vdev = dup_String_val(gc, Field(v, 2)); +- c_val->backend = (Int_val(Field(v, 3))); +- c_val->format = (Int_val(Field(v, 4))); +- c_val->unpluggable = Bool_val(Field(v, 5)); +- c_val->readwrite = Bool_val(Field(v, 6)); +- c_val->is_cdrom = Bool_val(Field(v, 7)); +- +- CAMLreturn(0); +-} +- +-static int device_nic_val(caml_gc *gc, libxl_device_nic *c_val, value v) +-{ +- CAMLparam1(v); +- int i; +- int ret = 0; +- c_val->backend_domid = Int_val(Field(v, 0)); +- c_val->devid = Int_val(Field(v, 1)); +- c_val->mtu = Int_val(Field(v, 2)); +- c_val->model = dup_String_val(gc, Field(v, 3)); +- +- if (Wosize_val(Field(v, 4)) != 6) { +- ret = 1; +- goto out; +- } +- for (i = 0; i < 6; i++) +- c_val->mac[i] = Int_val(Field(Field(v, 4), i)); +- +- /* not handling c_val->ip */ +- c_val->bridge = dup_String_val(gc, Field(v, 5)); +- c_val->ifname = dup_String_val(gc, Field(v, 6)); +- c_val->script = dup_String_val(gc, Field(v, 7)); +- c_val->nictype = (Int_val(Field(v, 8))) + NICTYPE_IOEMU; +- +-out: +- CAMLreturn(ret); +-} +- +-static int device_console_val(caml_gc *gc, libxl_device_console *c_val, value v) +-{ +- CAMLparam1(v); +- +- c_val->backend_domid = Int_val(Field(v, 0)); +- c_val->devid = Int_val(Field(v, 1)); +- c_val->consback = (Int_val(Field(v, 2))) + LIBXL_CONSBACK_XENCONSOLED; +- +- CAMLreturn(0); +-} +- +-static int device_vkb_val(caml_gc *gc, libxl_device_vkb *c_val, value v) +-{ +- CAMLparam1(v); +- +- c_val->backend_domid = Int_val(Field(v, 0)); +- c_val->devid = Int_val(Field(v, 1)); +- +- CAMLreturn(0); +-} +- +-static int device_vfb_val(caml_gc *gc, libxl_device_vfb *c_val, value v) +-{ +- CAMLparam1(v); +- +- c_val->backend_domid = Int_val(Field(v, 0)); +- c_val->devid = Int_val(Field(v, 1)); +- c_val->vnc = Bool_val(Field(v, 2)); +- c_val->vnclisten = dup_String_val(gc, Field(v, 3)); +- c_val->vncpasswd = dup_String_val(gc, Field(v, 4)); +- c_val->vncdisplay = Int_val(Field(v, 5)); +- c_val->keymap = dup_String_val(gc, Field(v, 6)); +- c_val->sdl = Bool_val(Field(v, 7)); +- c_val->opengl = Bool_val(Field(v, 8)); +- c_val->display = dup_String_val(gc, Field(v, 9)); +- c_val->xauthority = dup_String_val(gc, Field(v, 10)); +- +- CAMLreturn(0); +-} +- +-static int device_pci_val(caml_gc *gc, libxl_device_pci *c_val, value v) +-{ +- union { +- unsigned int value; +- struct { +- unsigned int reserved1:2; +- unsigned int reg:6; +- unsigned int func:3; +- unsigned int dev:5; +- unsigned int bus:8; +- unsigned int reserved2:7; +- unsigned int enable:1; +- }fields; +- }u; +- CAMLparam1(v); +- +- /* FIXME: propagate API change to ocaml */ +- u.value = Int_val(Field(v, 0)); +- c_val->reg = u.fields.reg; +- c_val->func = u.fields.func; +- c_val->dev = u.fields.dev; +- c_val->bus = u.fields.bus; +- c_val->enable = u.fields.enable; +- +- c_val->domain = Int_val(Field(v, 1)); +- c_val->vdevfn = Int_val(Field(v, 2)); +- c_val->msitranslate = Bool_val(Field(v, 3)); +- c_val->power_mgmt = Bool_val(Field(v, 4)); +- +- CAMLreturn(0); +-} +- +-static int sched_credit_val(caml_gc *gc, libxl_sched_credit *c_val, value v) +-{ +- CAMLparam1(v); +- c_val->weight = Int_val(Field(v, 0)); +- c_val->cap = Int_val(Field(v, 1)); +- CAMLreturn(0); +-} +- +-static int domain_build_state_val(caml_gc *gc, libxl_domain_build_state *c_val, value v) +-{ +- CAMLparam1(v); +- +- c_val->store_port = Int_val(Field(v, 0)); +- c_val->store_mfn = Int64_val(Field(v, 1)); +- c_val->console_port = Int_val(Field(v, 2)); +- c_val->console_mfn = Int64_val(Field(v, 3)); +- +- CAMLreturn(0); +-} +- +-static value Val_sched_credit(libxl_sched_credit *c_val) +-{ +- CAMLparam0(); +- CAMLlocal1(v); +- +- v = caml_alloc_tuple(2); +- +- Store_field(v, 0, Val_int(c_val->weight)); +- Store_field(v, 1, Val_int(c_val->cap)); +- +- CAMLreturn(v); +-} +- +-static value Val_physinfo(libxl_physinfo *c_val) +-{ +- CAMLparam0(); +- CAMLlocal2(v, hwcap); +- int i; +- +- hwcap = caml_alloc_tuple(8); +- for (i = 0; i < 8; i++) +- Store_field(hwcap, i, caml_copy_int32(c_val->hw_cap[i])); +- +- v = caml_alloc_tuple(11); +- Store_field(v, 0, Val_int(c_val->threads_per_core)); +- Store_field(v, 1, Val_int(c_val->cores_per_socket)); +- Store_field(v, 2, Val_int(c_val->max_cpu_id)); +- Store_field(v, 3, Val_int(c_val->nr_cpus)); +- Store_field(v, 4, Val_int(c_val->cpu_khz)); +- Store_field(v, 5, caml_copy_int64(c_val->total_pages)); +- Store_field(v, 6, caml_copy_int64(c_val->free_pages)); +- Store_field(v, 7, caml_copy_int64(c_val->scrub_pages)); +- Store_field(v, 8, Val_int(c_val->nr_nodes)); +- Store_field(v, 9, hwcap); +- Store_field(v, 10, caml_copy_int32(c_val->phys_cap)); +- +- CAMLreturn(v); +-} +- +-value stub_xl_disk_add(value info, value domid) +-{ +- CAMLparam2(info, domid); +- libxl_device_disk c_info; +- int ret; +- INIT_STRUCT(); +- +- device_disk_val(&gc, &c_info, info); +- c_info.domid = Int_val(domid); +- +- INIT_CTX(); +- ret = libxl_device_disk_add(&ctx, Int_val(domid), &c_info); +- if (ret != 0) +- failwith_xl("disk_add", &lg); +- FREE_CTX(); +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_disk_remove(value info, value domid) +-{ +- CAMLparam2(info, domid); +- libxl_device_disk c_info; +- int ret; +- INIT_STRUCT(); +- +- device_disk_val(&gc, &c_info, info); +- c_info.domid = Int_val(domid); +- +- INIT_CTX(); +- ret = libxl_device_disk_del(&ctx, &c_info, 0); +- if (ret != 0) +- failwith_xl("disk_remove", &lg); +- FREE_CTX(); +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_nic_add(value info, value domid) +-{ +- CAMLparam2(info, domid); +- libxl_device_nic c_info; +- int ret; +- INIT_STRUCT(); +- +- device_nic_val(&gc, &c_info, info); +- c_info.domid = Int_val(domid); +- +- INIT_CTX(); +- ret = libxl_device_nic_add(&ctx, Int_val(domid), &c_info); +- if (ret != 0) +- failwith_xl("nic_add", &lg); +- FREE_CTX(); +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_nic_remove(value info, value domid) +-{ +- CAMLparam2(info, domid); +- libxl_device_nic c_info; +- int ret; +- INIT_STRUCT(); +- +- device_nic_val(&gc, &c_info, info); +- c_info.domid = Int_val(domid); +- +- INIT_CTX(); +- ret = libxl_device_nic_del(&ctx, &c_info, 0); +- if (ret != 0) +- failwith_xl("nic_remove", &lg); +- FREE_CTX(); +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_console_add(value info, value state, value domid) +-{ +- CAMLparam3(info, state, domid); +- libxl_device_console c_info; +- libxl_domain_build_state c_state; +- int ret; +- INIT_STRUCT(); +- +- device_console_val(&gc, &c_info, info); +- domain_build_state_val(&gc, &c_state, state); +- c_info.domid = Int_val(domid); +- c_info.build_state = &c_state; +- +- INIT_CTX(); +- ret = libxl_device_console_add(&ctx, Int_val(domid), &c_info); +- if (ret != 0) +- failwith_xl("console_add", &lg); +- FREE_CTX(); +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_vkb_add(value info, value domid) +-{ +- CAMLparam2(info, domid); +- libxl_device_vkb c_info; +- int ret; +- INIT_STRUCT(); +- +- device_vkb_val(&gc, &c_info, info); +- c_info.domid = Int_val(domid); +- +- INIT_CTX(); +- ret = libxl_device_vkb_add(&ctx, Int_val(domid), &c_info); +- if (ret != 0) +- failwith_xl("vkb_add", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_vkb_clean_shutdown(value domid) +-{ +- CAMLparam1(domid); +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_device_vkb_clean_shutdown(&ctx, Int_val(domid)); +- if (ret != 0) +- failwith_xl("vkb_clean_shutdown", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_vkb_hard_shutdown(value domid) +-{ +- CAMLparam1(domid); +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_device_vkb_hard_shutdown(&ctx, Int_val(domid)); +- if (ret != 0) +- failwith_xl("vkb_hard_shutdown", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_vfb_add(value info, value domid) +-{ +- CAMLparam2(info, domid); +- libxl_device_vfb c_info; +- int ret; +- INIT_STRUCT(); +- +- device_vfb_val(&gc, &c_info, info); +- c_info.domid = Int_val(domid); +- +- INIT_CTX(); +- ret = libxl_device_vfb_add(&ctx, Int_val(domid), &c_info); +- if (ret != 0) +- failwith_xl("vfb_add", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_vfb_clean_shutdown(value domid) +-{ +- CAMLparam1(domid); +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_device_vfb_clean_shutdown(&ctx, Int_val(domid)); +- if (ret != 0) +- failwith_xl("vfb_clean_shutdown", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_vfb_hard_shutdown(value domid) +-{ +- CAMLparam1(domid); +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_device_vfb_hard_shutdown(&ctx, Int_val(domid)); +- if (ret != 0) +- failwith_xl("vfb_hard_shutdown", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_pci_add(value info, value domid) +-{ +- CAMLparam2(info, domid); +- libxl_device_pci c_info; +- int ret; +- INIT_STRUCT(); +- +- device_pci_val(&gc, &c_info, info); +- +- INIT_CTX(); +- ret = libxl_device_pci_add(&ctx, Int_val(domid), &c_info); +- if (ret != 0) +- failwith_xl("pci_add", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_pci_remove(value info, value domid) +-{ +- CAMLparam2(info, domid); +- libxl_device_pci c_info; +- int ret; +- INIT_STRUCT(); +- +- device_pci_val(&gc, &c_info, info); +- +- INIT_CTX(); +- ret = libxl_device_pci_remove(&ctx, Int_val(domid), &c_info, 0); +- if (ret != 0) +- failwith_xl("pci_remove", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_pci_shutdown(value domid) +-{ +- CAMLparam1(domid); +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_device_pci_shutdown(&ctx, Int_val(domid)); +- if (ret != 0) +- failwith_xl("pci_shutdown", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_button_press(value domid, value button) +-{ +- CAMLparam2(domid, button); +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_button_press(&ctx, Int_val(domid), Int_val(button) + POWER_BUTTON); +- if (ret != 0) +- failwith_xl("button_press", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_physinfo(value unit) +-{ +- CAMLparam1(unit); +- CAMLlocal1(physinfo); +- libxl_physinfo c_physinfo; +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_get_physinfo(&ctx, &c_physinfo); +- if (ret != 0) +- failwith_xl("physinfo", &lg); +- FREE_CTX(); +- +- physinfo = Val_physinfo(&c_physinfo); +- CAMLreturn(physinfo); +-} +- +-value stub_xl_sched_credit_domain_get(value domid) +-{ +- CAMLparam1(domid); +- CAMLlocal1(scinfo); +- libxl_sched_credit c_scinfo; +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_sched_credit_domain_get(&ctx, Int_val(domid), &c_scinfo); +- if (ret != 0) +- failwith_xl("sched_credit_domain_get", &lg); +- FREE_CTX(); +- +- scinfo = Val_sched_credit(&c_scinfo); +- CAMLreturn(scinfo); +-} +- +-value stub_xl_sched_credit_domain_set(value domid, value scinfo) +-{ +- CAMLparam2(domid, scinfo); +- libxl_sched_credit c_scinfo; +- int ret; +- INIT_STRUCT(); +- +- sched_credit_val(&gc, &c_scinfo, scinfo); +- +- INIT_CTX(); +- ret = libxl_sched_credit_domain_set(&ctx, Int_val(domid), &c_scinfo); +- if (ret != 0) +- failwith_xl("sched_credit_domain_set", &lg); +- FREE_CTX(); +- +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_send_trigger(value domid, value trigger, value vcpuid) +-{ +- CAMLparam3(domid, trigger, vcpuid); +- int ret; +- char *c_trigger; +- INIT_STRUCT(); +- +- c_trigger = dup_String_val(&gc, trigger); +- +- INIT_CTX(); +- ret = libxl_send_trigger(&ctx, Int_val(domid), c_trigger, Int_val(vcpuid)); +- if (ret != 0) +- failwith_xl("send_trigger", &lg); +- FREE_CTX(); +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_send_sysrq(value domid, value sysrq) +-{ +- CAMLparam2(domid, sysrq); +- int ret; +- INIT_STRUCT(); +- +- INIT_CTX(); +- ret = libxl_send_sysrq(&ctx, Int_val(domid), Int_val(sysrq)); +- if (ret != 0) +- failwith_xl("send_sysrq", &lg); +- FREE_CTX(); +- CAMLreturn(Val_unit); +-} +- +-value stub_xl_send_debug_keys(value keys) +-{ +- CAMLparam1(keys); +- int ret; +- char *c_keys; +- INIT_STRUCT(); +- +- c_keys = dup_String_val(&gc, keys); +- +- INIT_CTX(); +- ret = libxl_send_debug_keys(&ctx, c_keys); +- if (ret != 0) +- failwith_xl("send_debug_keys", &lg); +- FREE_CTX(); +- CAMLreturn(Val_unit); +-} +- +-/* +- * Local variables: +- * indent-tabs-mode: t +- * c-basic-offset: 8 +- * tab-width: 8 +- * End: +- */ +--- a/tools/ocaml/libs/xs/META.in ++++ b/tools/ocaml/libs/xs/META.in +@@ -1,5 +1,5 @@ + version = "@VERSION@" + description = "XenStore Interface" +-requires = "unix,xb" +-archive(byte) = "xs.cma" +-archive(native) = "xs.cmxa" ++requires = "unix,xenbus" ++archive(byte) = "xenstore.cma" ++archive(native) = "xenstore.cmxa" +--- a/tools/ocaml/libs/xs/Makefile ++++ b/tools/ocaml/libs/xs/Makefile +@@ -3,6 +3,7 @@ + include $(TOPLEVEL)/common.make + + OCAMLINCLUDE += -I ../xb/ ++OCAMLOPTFLAGS += -for-pack Xenstore + + .NOTPARALLEL: + # Ocaml is such a PITA! +@@ -12,7 +13,7 @@ + PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx) + OBJS = queueop xsraw xst xs + INTF = xsraw.cmi xst.cmi xs.cmi +-LIBS = xs.cma xs.cmxa ++LIBS = xenstore.cma xenstore.cmxa + + all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS) + +@@ -20,26 +21,26 @@ + + libs: $(LIBS) + +-xs_OBJS = $(OBJS) +-OCAML_NOC_LIBRARY = xs ++xenstore_OBJS = xenstore ++OCAML_NOC_LIBRARY = xenstore + +-#xs.cmxa: $(foreach obj,$(OBJS),$(obj).cmx) +-# $(E) " MLLIB $@" +-# $(Q)$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx) +-# +-#xs.cma: $(foreach obj,$(OBJS),$(obj).cmo) +-# $(E) " MLLIB $@" +-# $(Q)$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo) ++xenstore.cmx : $(foreach obj, $(OBJS), $(obj).cmx) ++ $(E) " CMX $@" ++ $(Q)$(OCAMLOPT) -pack -o $@ $^ ++ ++xenstore.cmo : $(foreach obj, $(OBJS), $(obj).cmo) ++ $(E) " CMO $@" ++ $(Q)$(OCAMLC) -pack -o $@ $^ + + .PHONY: install + install: $(LIBS) META + mkdir -p $(OCAMLDESTDIR) +- ocamlfind remove -destdir $(OCAMLDESTDIR) xs +- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenstore ++ ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xenstore META $(LIBS) xenstore.cmx xenstore.cmi *.a + + .PHONY: uninstall + uninstall: +- ocamlfind remove -destdir $(OCAMLDESTDIR) xs ++ ocamlfind remove -destdir $(OCAMLDESTDIR) xenstore + + include $(TOPLEVEL)/Makefile.rules + +--- a/tools/ocaml/libs/xs/queueop.ml ++++ b/tools/ocaml/libs/xs/queueop.ml +@@ -13,6 +13,7 @@ + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) ++open Xenbus + + let data_concat ls = (String.concat "\000" ls) ^ "\000" + let queue_path ty (tid: int) (path: string) con = +--- a/tools/ocaml/libs/xs/xs.ml ++++ b/tools/ocaml/libs/xs/xs.ml +@@ -69,7 +69,7 @@ + let read_watchevent xsh = Xsraw.read_watchevent xsh.con + + let make fd = get_operations (Xsraw.open_fd fd) +-let get_fd xsh = Xb.get_fd xsh.con.Xsraw.xb ++let get_fd xsh = Xenbus.Xb.get_fd xsh.con.Xsraw.xb + + exception Timeout + +--- a/tools/ocaml/libs/xs/xsraw.ml ++++ b/tools/ocaml/libs/xs/xsraw.ml +@@ -14,6 +14,8 @@ + * GNU Lesser General Public License for more details. + *) + ++open Xenbus ++ + exception Partial_not_empty + exception Unexpected_packet of string + +@@ -27,7 +29,7 @@ + raise (Unexpected_packet s) + + type con = { +- xb: Xb.t; ++ xb: Xenbus.Xb.t; + watchevents: (string * string) Queue.t; + } + +--- a/tools/ocaml/libs/xs/xsraw.mli ++++ b/tools/ocaml/libs/xs/xsraw.mli +@@ -16,8 +16,8 @@ + exception Partial_not_empty + exception Unexpected_packet of string + exception Invalid_path of string +-val unexpected_packet : Xb.Op.operation -> Xb.Op.operation -> 'a +-type con = { xb : Xb.t; watchevents : (string * string) Queue.t; } ++val unexpected_packet : Xenbus.Xb.Op.operation -> Xenbus.Xb.Op.operation -> 'a ++type con = { xb : Xenbus.Xb.t; watchevents : (string * string) Queue.t; } + val close : con -> unit + val open_fd : Unix.file_descr -> con + val split_string : ?limit:int -> char -> string -> string list +@@ -26,14 +26,14 @@ + val string_of_perms : int * perm * (int * perm) list -> string + val perms_of_string : string -> int * perm * (int * perm) list + val pkt_send : con -> unit +-val pkt_recv : con -> Xb.Packet.t +-val pkt_recv_timeout : con -> float -> bool * Xb.Packet.t option ++val pkt_recv : con -> Xenbus.Xb.Packet.t ++val pkt_recv_timeout : con -> float -> bool * Xenbus.Xb.Packet.t option + val queue_watchevent : con -> string -> unit + val has_watchevents : con -> bool + val get_watchevent : con -> string * string + val read_watchevent : con -> string * string +-val sync_recv : Xb.Op.operation -> con -> string +-val sync : (Xb.t -> 'a) -> con -> string ++val sync_recv : Xenbus.Xb.Op.operation -> con -> string ++val sync : (Xenbus.Xb.t -> 'a) -> con -> string + val ack : string -> unit + val validate_path : string -> unit + val validate_watch_path : string -> unit +--- a/tools/ocaml/xenstored/Makefile ++++ b/tools/ocaml/xenstored/Makefile +@@ -35,11 +35,11 @@ + XENSTOREDLIBS = \ + unix.cmxa \ + $(OCAML_TOPLEVEL)/libs/uuid/uuid.cmxa \ +- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/mmap.cmxa \ ++ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/log $(OCAML_TOPLEVEL)/libs/log/log.cmxa \ +- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/eventchn.cmxa \ +- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xc.cmxa \ +- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xb.cmxa \ ++ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \ ++ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \ ++ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xenbus.cmxa \ + -ccopt -L -ccopt $(XEN_ROOT)/tools/libxc + + PROGRAMS = oxenstored +--- a/tools/ocaml/xenstored/connection.ml ++++ b/tools/ocaml/xenstored/connection.ml +@@ -27,7 +27,7 @@ + } + + and t = { +- xb: Xb.t; ++ xb: Xenbus.Xb.t; + dom: Domain.t option; + transactions: (int, Transaction.t) Hashtbl.t; + mutable next_tid: int; +@@ -93,10 +93,10 @@ + Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con); + con + +-let get_fd con = Xb.get_fd con.xb ++let get_fd con = Xenbus.Xb.get_fd con.xb + let close con = + Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con); +- Xb.close con.xb ++ Xenbus.Xb.close con.xb + + let get_perm con = + con.perm +@@ -108,9 +108,9 @@ + con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid + + let send_reply con tid rid ty data = +- Xb.queue con.xb (Xb.Packet.create tid rid ty data) ++ Xenbus.Xb.queue con.xb (Xenbus.Xb.Packet.create tid rid ty data) + +-let send_error con tid rid err = send_reply con tid rid Xb.Op.Error (err ^ "\000") ++let send_error con tid rid err = send_reply con tid rid Xenbus.Xb.Op.Error (err ^ "\000") + let send_ack con tid rid ty = send_reply con tid rid ty "OK\000" + + let get_watch_path con path = +@@ -166,7 +166,7 @@ + + let fire_single_watch watch = + let data = Utils.join_by_null [watch.path; watch.token; ""] in +- send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data ++ send_reply watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data + + let fire_watch watch path = + let new_path = +@@ -179,7 +179,7 @@ + path + in + let data = Utils.join_by_null [ new_path; watch.token; "" ] in +- send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data ++ send_reply watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data + + let find_next_tid con = + let ret = con.next_tid in con.next_tid <- con.next_tid + 1; ret +@@ -203,15 +203,15 @@ + let get_transaction con tid = + Hashtbl.find con.transactions tid + +-let do_input con = Xb.input con.xb +-let has_input con = Xb.has_in_packet con.xb +-let pop_in con = Xb.get_in_packet con.xb +-let has_more_input con = Xb.has_more_input con.xb +- +-let has_output con = Xb.has_output con.xb +-let has_new_output con = Xb.has_new_output con.xb +-let peek_output con = Xb.peek_output con.xb +-let do_output con = Xb.output con.xb ++let do_input con = Xenbus.Xb.input con.xb ++let has_input con = Xenbus.Xb.has_in_packet con.xb ++let pop_in con = Xenbus.Xb.get_in_packet con.xb ++let has_more_input con = Xenbus.Xb.has_more_input con.xb ++ ++let has_output con = Xenbus.Xb.has_output con.xb ++let has_new_output con = Xenbus.Xb.has_new_output con.xb ++let peek_output con = Xenbus.Xb.peek_output con.xb ++let do_output con = Xenbus.Xb.output con.xb + + let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1 + +--- a/tools/ocaml/xenstored/connections.ml ++++ b/tools/ocaml/xenstored/connections.ml +@@ -26,12 +26,12 @@ + let create () = { anonymous = []; domains = Hashtbl.create 8; watches = Trie.create () } + + let add_anonymous cons fd can_write = +- let xbcon = Xb.open_fd fd in ++ let xbcon = Xenbus.Xb.open_fd fd in + let con = Connection.create xbcon None in + cons.anonymous <- con :: cons.anonymous + + let add_domain cons dom = +- let xbcon = Xb.open_mmap (Domain.get_interface dom) (fun () -> Domain.notify dom) in ++ let xbcon = Xenbus.Xb.open_mmap (Domain.get_interface dom) (fun () -> Domain.notify dom) in + let con = Connection.create xbcon (Some dom) in + Hashtbl.add cons.domains (Domain.get_id dom) con + +--- a/tools/ocaml/xenstored/domain.ml ++++ b/tools/ocaml/xenstored/domain.ml +@@ -20,10 +20,10 @@ + + type t = + { +- id: Xc.domid; ++ id: Xenctrl.domid; + mfn: nativeint; + remote_port: int; +- interface: Mmap.mmap_interface; ++ interface: Xenmmap.mmap_interface; + eventchn: Event.t; + mutable port: int; + } +@@ -47,7 +47,7 @@ + let close dom = + debug "domain %d unbound port %d" dom.id dom.port; + Event.unbind dom.eventchn dom.port; +- Mmap.unmap dom.interface; ++ Xenmmap.unmap dom.interface; + () + + let make id mfn remote_port interface eventchn = { +--- a/tools/ocaml/xenstored/domains.ml ++++ b/tools/ocaml/xenstored/domains.ml +@@ -16,7 +16,7 @@ + + type domains = { + eventchn: Event.t; +- table: (Xc.domid, Domain.t) Hashtbl.t; ++ table: (Xenctrl.domid, Domain.t) Hashtbl.t; + } + + let init eventchn = +@@ -33,16 +33,16 @@ + + Hashtbl.iter (fun id _ -> if id <> 0 then + try +- let info = Xc.domain_getinfo xc id in +- if info.Xc.shutdown || info.Xc.dying then ( ++ let info = Xenctrl.domain_getinfo xc id in ++ if info.Xenctrl.shutdown || info.Xenctrl.dying then ( + Logs.debug "general" "Domain %u died (dying=%b, shutdown %b -- code %d)" +- id info.Xc.dying info.Xc.shutdown info.Xc.shutdown_code; +- if info.Xc.dying then ++ id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code; ++ if info.Xenctrl.dying then + dead_dom := id :: !dead_dom + else + notify := true; + ) +- with Xc.Error _ -> ++ with Xenctrl.Error _ -> + Logs.debug "general" "Domain %u died -- no domain info" id; + dead_dom := id :: !dead_dom; + ) doms.table; +@@ -57,7 +57,7 @@ + () + + let create xc doms domid mfn port = +- let interface = Xc.map_foreign_range xc domid (Mmap.getpagesize()) mfn in ++ let interface = Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize()) mfn in + let dom = Domain.make domid mfn port interface doms.eventchn in + Hashtbl.add doms.table domid dom; + Domain.bind_interdomain dom; +@@ -66,13 +66,13 @@ + let create0 fake doms = + let port, interface = + if fake then ( +- 0, Xc.with_intf (fun xc -> Xc.map_foreign_range xc 0 (Mmap.getpagesize()) 0n) ++ 0, Xenctrl.with_intf (fun xc -> Xenctrl.map_foreign_range xc 0 (Xenmmap.getpagesize()) 0n) + ) else ( + let port = Utils.read_file_single_integer Define.xenstored_proc_port + and fd = Unix.openfile Define.xenstored_proc_kva + [ Unix.O_RDWR ] 0o600 in +- let interface = Mmap.mmap fd Mmap.RDWR Mmap.SHARED +- (Mmap.getpagesize()) 0 in ++ let interface = Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED ++ (Xenmmap.getpagesize()) 0 in + Unix.close fd; + port, interface + ) +--- a/tools/ocaml/xenstored/event.ml ++++ b/tools/ocaml/xenstored/event.ml +@@ -16,15 +16,15 @@ + + (**************** high level binding ****************) + type t = { +- handle: Eventchn.handle; ++ handle: Xeneventchn.handle; + mutable virq_port: int; + } + +-let init () = { handle = Eventchn.init (); virq_port = -1; } +-let fd eventchn = Eventchn.fd eventchn.handle +-let bind_dom_exc_virq eventchn = eventchn.virq_port <- Eventchn.bind_dom_exc_virq eventchn.handle +-let bind_interdomain eventchn domid port = Eventchn.bind_interdomain eventchn.handle domid port +-let unbind eventchn port = Eventchn.unbind eventchn.handle port +-let notify eventchn port = Eventchn.notify eventchn.handle port +-let pending eventchn = Eventchn.pending eventchn.handle +-let unmask eventchn port = Eventchn.unmask eventchn.handle port ++let init () = { handle = Xeneventchn.init (); virq_port = -1; } ++let fd eventchn = Xeneventchn.fd eventchn.handle ++let bind_dom_exc_virq eventchn = eventchn.virq_port <- Xeneventchn.bind_dom_exc_virq eventchn.handle ++let bind_interdomain eventchn domid port = Xeneventchn.bind_interdomain eventchn.handle domid port ++let unbind eventchn port = Xeneventchn.unbind eventchn.handle port ++let notify eventchn port = Xeneventchn.notify eventchn.handle port ++let pending eventchn = Xeneventchn.pending eventchn.handle ++let unmask eventchn port = Xeneventchn.unmask eventchn.handle port +--- a/tools/ocaml/xenstored/logging.ml ++++ b/tools/ocaml/xenstored/logging.ml +@@ -39,7 +39,7 @@ + | Commit + | Newconn + | Endconn +- | XbOp of Xb.Op.operation ++ | XbOp of Xenbus.Xb.Op.operation + + type access = + { +@@ -82,35 +82,35 @@ + | Endconn -> "endconn " + + | XbOp op -> match op with +- | Xb.Op.Debug -> "debug " ++ | Xenbus.Xb.Op.Debug -> "debug " + +- | Xb.Op.Directory -> "directory" +- | Xb.Op.Read -> "read " +- | Xb.Op.Getperms -> "getperms " +- +- | Xb.Op.Watch -> "watch " +- | Xb.Op.Unwatch -> "unwatch " +- +- | Xb.Op.Transaction_start -> "t start " +- | Xb.Op.Transaction_end -> "t end " +- +- | Xb.Op.Introduce -> "introduce" +- | Xb.Op.Release -> "release " +- | Xb.Op.Getdomainpath -> "getdomain" +- | Xb.Op.Isintroduced -> "is introduced" +- | Xb.Op.Resume -> "resume " ++ | Xenbus.Xb.Op.Directory -> "directory" ++ | Xenbus.Xb.Op.Read -> "read " ++ | Xenbus.Xb.Op.Getperms -> "getperms " ++ ++ | Xenbus.Xb.Op.Watch -> "watch " ++ | Xenbus.Xb.Op.Unwatch -> "unwatch " ++ ++ | Xenbus.Xb.Op.Transaction_start -> "t start " ++ | Xenbus.Xb.Op.Transaction_end -> "t end " ++ ++ | Xenbus.Xb.Op.Introduce -> "introduce" ++ | Xenbus.Xb.Op.Release -> "release " ++ | Xenbus.Xb.Op.Getdomainpath -> "getdomain" ++ | Xenbus.Xb.Op.Isintroduced -> "is introduced" ++ | Xenbus.Xb.Op.Resume -> "resume " + +- | Xb.Op.Write -> "write " +- | Xb.Op.Mkdir -> "mkdir " +- | Xb.Op.Rm -> "rm " +- | Xb.Op.Setperms -> "setperms " +- | Xb.Op.Restrict -> "restrict " +- | Xb.Op.Set_target -> "settarget" ++ | Xenbus.Xb.Op.Write -> "write " ++ | Xenbus.Xb.Op.Mkdir -> "mkdir " ++ | Xenbus.Xb.Op.Rm -> "rm " ++ | Xenbus.Xb.Op.Setperms -> "setperms " ++ | Xenbus.Xb.Op.Restrict -> "restrict " ++ | Xenbus.Xb.Op.Set_target -> "settarget" + +- | Xb.Op.Error -> "error " +- | Xb.Op.Watchevent -> "w event " ++ | Xenbus.Xb.Op.Error -> "error " ++ | Xenbus.Xb.Op.Watchevent -> "w event " + +- | x -> Xb.Op.to_string x ++ | x -> Xenbus.Xb.Op.to_string x + + let file_exists file = + try +@@ -210,10 +210,10 @@ + let xb_op ~tid ~con ~ty data = + let print = + match ty with +- | Xb.Op.Read | Xb.Op.Directory | Xb.Op.Getperms -> !log_read_ops +- | Xb.Op.Transaction_start | Xb.Op.Transaction_end -> ++ | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !log_read_ops ++ | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end -> + false (* transactions are managed below *) +- | Xb.Op.Introduce | Xb.Op.Release | Xb.Op.Getdomainpath | Xb.Op.Isintroduced | Xb.Op.Resume -> ++ | Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume -> + !log_special_ops + | _ -> true + in +@@ -222,17 +222,17 @@ + + let start_transaction ~tid ~con = + if !log_transaction_ops && tid <> 0 +- then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_start) ++ then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) + + let end_transaction ~tid ~con = + if !log_transaction_ops && tid <> 0 +- then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_end) ++ then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) + + let xb_answer ~tid ~con ~ty data = + let print = match ty with +- | Xb.Op.Error when data="ENOENT " -> !log_read_ops +- | Xb.Op.Error -> !log_special_ops +- | Xb.Op.Watchevent -> true ++ | Xenbus.Xb.Op.Error when data="ENOENT " -> !log_read_ops ++ | Xenbus.Xb.Op.Error -> !log_special_ops ++ | Xenbus.Xb.Op.Watchevent -> true + | _ -> false + in + if print +--- a/tools/ocaml/xenstored/perms.ml ++++ b/tools/ocaml/xenstored/perms.ml +@@ -43,9 +43,9 @@ + + type t = + { +- owner: Xc.domid; ++ owner: Xenctrl.domid; + other: permty; +- acl: (Xc.domid * permty) list; ++ acl: (Xenctrl.domid * permty) list; + } + + let create owner other acl = +@@ -88,7 +88,7 @@ + module Connection = + struct + +-type elt = Xc.domid * (permty list) ++type elt = Xenctrl.domid * (permty list) + type t = + { main: elt; + target: elt option; } +--- a/tools/ocaml/xenstored/process.ml ++++ b/tools/ocaml/xenstored/process.ml +@@ -54,10 +54,10 @@ + let process_watch ops cons = + let do_op_watch op cons = + let recurse = match (fst op) with +- | Xb.Op.Write -> false +- | Xb.Op.Mkdir -> false +- | Xb.Op.Rm -> true +- | Xb.Op.Setperms -> false ++ | Xenbus.Xb.Op.Write -> false ++ | Xenbus.Xb.Op.Mkdir -> false ++ | Xenbus.Xb.Op.Rm -> true ++ | Xenbus.Xb.Op.Setperms -> false + | _ -> raise (Failure "huh ?") in + Connections.fire_watches cons (snd op) recurse in + List.iter (fun op -> do_op_watch op cons) ops +@@ -83,7 +83,7 @@ + then None + else try match split None '\000' data with + | "print" :: msg :: _ -> +- Logging.xb_op ~tid:0 ~ty:Xb.Op.Debug ~con:"=======>" msg; ++ Logging.xb_op ~tid:0 ~ty:Xenbus.Xb.Op.Debug ~con:"=======>" msg; + None + | "quota" :: domid :: _ -> + let domid = int_of_string domid in +@@ -120,7 +120,7 @@ + | _ -> raise Invalid_Cmd_Args + in + let watch = Connections.add_watch cons con node token in +- Connection.send_ack con (Transaction.get_id t) rid Xb.Op.Watch; ++ Connection.send_ack con (Transaction.get_id t) rid Xenbus.Xb.Op.Watch; + Connection.fire_single_watch watch + + let do_unwatch con t domains cons data = +@@ -165,7 +165,7 @@ + if Domains.exist domains domid then + Domains.find domains domid + else try +- let ndom = Xc.with_intf (fun xc -> ++ let ndom = Xenctrl.with_intf (fun xc -> + Domains.create xc domains domid mfn port) in + Connections.add_domain cons ndom; + Connections.fire_spec_watches cons "@introduceDomain"; +@@ -299,25 +299,25 @@ + + let function_of_type ty = + match ty with +- | Xb.Op.Debug -> reply_data_or_ack do_debug +- | Xb.Op.Directory -> reply_data do_directory +- | Xb.Op.Read -> reply_data do_read +- | Xb.Op.Getperms -> reply_data do_getperms +- | Xb.Op.Watch -> reply_none do_watch +- | Xb.Op.Unwatch -> reply_ack do_unwatch +- | Xb.Op.Transaction_start -> reply_data do_transaction_start +- | Xb.Op.Transaction_end -> reply_ack do_transaction_end +- | Xb.Op.Introduce -> reply_ack do_introduce +- | Xb.Op.Release -> reply_ack do_release +- | Xb.Op.Getdomainpath -> reply_data do_getdomainpath +- | Xb.Op.Write -> reply_ack do_write +- | Xb.Op.Mkdir -> reply_ack do_mkdir +- | Xb.Op.Rm -> reply_ack do_rm +- | Xb.Op.Setperms -> reply_ack do_setperms +- | Xb.Op.Isintroduced -> reply_data do_isintroduced +- | Xb.Op.Resume -> reply_ack do_resume +- | Xb.Op.Set_target -> reply_ack do_set_target +- | Xb.Op.Restrict -> reply_ack do_restrict ++ | Xenbus.Xb.Op.Debug -> reply_data_or_ack do_debug ++ | Xenbus.Xb.Op.Directory -> reply_data do_directory ++ | Xenbus.Xb.Op.Read -> reply_data do_read ++ | Xenbus.Xb.Op.Getperms -> reply_data do_getperms ++ | Xenbus.Xb.Op.Watch -> reply_none do_watch ++ | Xenbus.Xb.Op.Unwatch -> reply_ack do_unwatch ++ | Xenbus.Xb.Op.Transaction_start -> reply_data do_transaction_start ++ | Xenbus.Xb.Op.Transaction_end -> reply_ack do_transaction_end ++ | Xenbus.Xb.Op.Introduce -> reply_ack do_introduce ++ | Xenbus.Xb.Op.Release -> reply_ack do_release ++ | Xenbus.Xb.Op.Getdomainpath -> reply_data do_getdomainpath ++ | Xenbus.Xb.Op.Write -> reply_ack do_write ++ | Xenbus.Xb.Op.Mkdir -> reply_ack do_mkdir ++ | Xenbus.Xb.Op.Rm -> reply_ack do_rm ++ | Xenbus.Xb.Op.Setperms -> reply_ack do_setperms ++ | Xenbus.Xb.Op.Isintroduced -> reply_data do_isintroduced ++ | Xenbus.Xb.Op.Resume -> reply_ack do_resume ++ | Xenbus.Xb.Op.Set_target -> reply_ack do_set_target ++ | Xenbus.Xb.Op.Restrict -> reply_ack do_restrict + | _ -> reply_ack do_error + + let input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data = +@@ -370,11 +370,11 @@ + let do_input store cons doms con = + if Connection.do_input con then ( + let packet = Connection.pop_in con in +- let tid, rid, ty, data = Xb.Packet.unpack packet in ++ let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in + (* As we don't log IO, do not call an unnecessary sanitize_data + Logs.info "io" "[%s] -> [%d] %s \"%s\"" + (Connection.get_domstr con) tid +- (Xb.Op.to_string ty) (sanitize_data data); *) ++ (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *) + process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data; + write_access_log ~ty ~tid ~con ~data; + Connection.incr_ops con; +@@ -384,11 +384,11 @@ + if Connection.has_output con then ( + if Connection.has_new_output con then ( + let packet = Connection.peek_output con in +- let tid, rid, ty, data = Xb.Packet.unpack packet in ++ let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in + (* As we don't log IO, do not call an unnecessary sanitize_data + Logs.info "io" "[%s] <- %s \"%s\"" + (Connection.get_domstr con) +- (Xb.Op.to_string ty) (sanitize_data data);*) ++ (Xenbus.Xb.Op.to_string ty) (sanitize_data data);*) + write_answer_log ~ty ~tid ~con ~data; + ); + ignore (Connection.do_output con) +--- a/tools/ocaml/xenstored/quota.ml ++++ b/tools/ocaml/xenstored/quota.ml +@@ -26,7 +26,7 @@ + type t = { + maxent: int; (* max entities per domU *) + maxsize: int; (* max size of data store in one node *) +- cur: (Xc.domid, int) Hashtbl.t; (* current domains quota *) ++ cur: (Xenctrl.domid, int) Hashtbl.t; (* current domains quota *) + } + + let to_string quota domid = +--- a/tools/ocaml/xenstored/transaction.ml ++++ b/tools/ocaml/xenstored/transaction.ml +@@ -74,7 +74,7 @@ + type t = { + ty: ty; + store: Store.t; +- mutable ops: (Xb.Op.operation * Store.Path.t) list; ++ mutable ops: (Xenbus.Xb.Op.operation * Store.Path.t) list; + mutable read_lowpath: Store.Path.t option; + mutable write_lowpath: Store.Path.t option; + } +@@ -105,23 +105,23 @@ + if path_exists + then set_write_lowpath t path + else set_write_lowpath t (Store.Path.get_parent path); +- add_wop t Xb.Op.Write path ++ add_wop t Xenbus.Xb.Op.Write path + + let mkdir ?(with_watch=true) t perm path = + Store.mkdir t.store perm path; + set_write_lowpath t path; + if with_watch then +- add_wop t Xb.Op.Mkdir path ++ add_wop t Xenbus.Xb.Op.Mkdir path + + let setperms t perm path perms = + Store.setperms t.store perm path perms; + set_write_lowpath t path; +- add_wop t Xb.Op.Setperms path ++ add_wop t Xenbus.Xb.Op.Setperms path + + let rm t perm path = + Store.rm t.store perm path; + set_write_lowpath t (Store.Path.get_parent path); +- add_wop t Xb.Op.Rm path ++ add_wop t Xenbus.Xb.Op.Rm path + + let ls t perm path = + let r = Store.ls t.store perm path in +--- a/tools/ocaml/xenstored/xenstored.ml ++++ b/tools/ocaml/xenstored/xenstored.ml +@@ -35,7 +35,7 @@ + if err <> Unix.ECONNRESET then + error "closing socket connection: read error: %s" + (Unix.error_message err) +- | Xb.End_of_file -> ++ | Xenbus.Xb.End_of_file -> + Connections.del_anonymous cons c; + debug "closing socket connection" + in +@@ -170,7 +170,7 @@ + let from_channel store cons doms chan = + (* don't let the permission get on our way, full perm ! *) + let op = Store.get_ops store Perms.Connection.full_rights in +- let xc = Xc.interface_open () in ++ let xc = Xenctrl.interface_open () in + + let domain_f domid mfn port = + let ndom = +@@ -190,7 +190,7 @@ + op.Store.setperms path perms + in + finally (fun () -> from_channel_f chan domain_f watch_f store_f) +- (fun () -> Xc.interface_close xc) ++ (fun () -> Xenctrl.interface_close xc) + + let from_file store cons doms file = + let channel = open_in file in +@@ -282,7 +282,7 @@ + Store.mkdir store (Perms.Connection.create 0) localpath; + + if cf.domain_init then ( +- let usingxiu = Xc.is_fake () in ++ let usingxiu = Xenctrl.is_fake () in + Connections.add_domain cons (Domains.create0 usingxiu domains); + Event.bind_dom_exc_virq eventchn + ); +@@ -301,7 +301,7 @@ + (if cf.domain_init then [ Event.fd eventchn ] else []) + in + +- let xc = Xc.interface_open () in ++ let xc = Xenctrl.interface_open () in + + let process_special_fds rset = + let accept_connection can_write fd = +--- a/tools/ocaml/libs/xl/xl.ml ++++ /dev/null +@@ -1,213 +0,0 @@ +-(* +- * Copyright (C) 2009-2010 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-exception Error of string +- +-type create_info = +-{ +- hvm : bool; +- hap : bool; +- oos : bool; +- ssidref : int32; +- name : string; +- uuid : int array; +- xsdata : (string * string) list; +- platformdata : (string * string) list; +- poolid : int32; +- poolname : string; +-} +- +-type build_pv_info = +-{ +- slack_memkb : int64; +- cmdline : string; +- ramdisk : string; +- features : string; +-} +- +-type build_hvm_info = +-{ +- pae : bool; +- apic : bool; +- acpi : bool; +- nx : bool; +- viridian : bool; +- timeoffset : string; +- timer_mode : int; +- hpet : int; +- vpt_align : int; +-} +- +-type build_spec = BuildHVM of build_hvm_info | BuildPV of build_pv_info +- +-type build_info = +-{ +- max_vcpus : int; +- cur_vcpus : int; +- max_memkb : int64; +- target_memkb : int64; +- video_memkb : int64; +- shadow_memkb : int64; +- kernel : string; +- priv: build_spec; +-} +- +-type build_state = +-{ +- store_port : int; +- store_mfn : int64; +- console_port : int; +- console_mfn : int64; +-} +- +-type domid = int +- +-type disk_phystype = +- | PHYSTYPE_QCOW +- | PHYSTYPE_QCOW2 +- | PHYSTYPE_VHD +- | PHYSTYPE_AIO +- | PHYSTYPE_FILE +- | PHYSTYPE_PHY +- +-type disk_info = +-{ +- backend_domid : domid; +- physpath : string; +- phystype : disk_phystype; +- virtpath : string; +- unpluggable : bool; +- readwrite : bool; +- is_cdrom : bool; +-} +- +-type nic_type = +- | NICTYPE_IOEMU +- | NICTYPE_VIF +- +-type nic_info = +-{ +- backend_domid : domid; +- devid : int; +- mtu : int; +- model : string; +- mac : int array; +- bridge : string; +- ifname : string; +- script : string; +- nictype : nic_type; +-} +- +-type console_type = +- | CONSOLETYPE_XENCONSOLED +- | CONSOLETYPE_IOEMU +- +-type console_info = +-{ +- backend_domid : domid; +- devid : int; +- consoletype : console_type; +-} +- +-type vkb_info = +-{ +- backend_domid : domid; +- devid : int; +-} +- +-type vfb_info = +-{ +- backend_domid : domid; +- devid : int; +- vnc : bool; +- vnclisten : string; +- vncpasswd : string; +- vncdisplay : int; +- vncunused : bool; +- keymap : string; +- sdl : bool; +- opengl : bool; +- display : string; +- xauthority : string; +-} +- +-type pci_info = +-{ +- v : int; (* domain * bus * dev * func multiplexed *) +- domain : int; +- vdevfn : int; +- msitranslate : bool; +- power_mgmt : bool; +-} +- +-type physinfo = +-{ +- threads_per_core: int; +- cores_per_socket: int; +- max_cpu_id: int; +- nr_cpus: int; +- cpu_khz: int; +- total_pages: int64; +- free_pages: int64; +- scrub_pages: int64; +- nr_nodes: int; +- hwcap: int32 array; +- physcap: int32; +-} +- +-type sched_credit = +-{ +- weight: int; +- cap: int; +-} +- +-external domain_make : create_info -> domid = "stub_xl_domain_make" +-external domain_build : build_info -> domid -> build_state = "stub_xl_domain_build" +- +-external disk_add : disk_info -> domid -> unit = "stub_xl_disk_add" +-external disk_remove : disk_info -> domid -> unit = "stub_xl_disk_remove" +- +-external nic_add : nic_info -> domid -> unit = "stub_xl_nic_add" +-external nic_remove : disk_info -> domid -> unit = "stub_xl_nic_remove" +- +-external console_add : console_info -> build_state -> domid -> unit = "stub_xl_console_add" +- +-external vkb_add : vkb_info -> domid -> unit = "stub_xl_vkb_add" +-external vkb_clean_shutdown : domid -> unit = "stub_vkb_clean_shutdown" +-external vkb_hard_shutdown : domid -> unit = "stub_vkb_hard_shutdown" +- +-external vfb_add : vfb_info -> domid -> unit = "stub_xl_vfb_add" +-external vfb_clean_shutdown : domid -> unit = "stub_vfb_clean_shutdown" +-external vfb_hard_shutdown : domid -> unit = "stub_vfb_hard_shutdown" +- +-external pci_add : pci_info -> domid -> unit = "stub_xl_pci_add" +-external pci_remove : pci_info -> domid -> unit = "stub_xl_pci_remove" +-external pci_shutdown : domid -> unit = "stub_xl_pci_shutdown" +- +-type button = +- | Button_Power +- | Button_Sleep +- +-external button_press : domid -> button -> unit = "stub_xl_button_press" +-external physinfo : unit -> physinfo = "stub_xl_physinfo" +- +-external domain_sched_credit_get : domid -> sched_credit = "stub_xl_sched_credit_domain_get" +-external domain_sched_credit_set : domid -> sched_credit -> unit = "stub_xl_sched_credit_domain_set" +- +-external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger" +-external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq" +-external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys" +- +-let _ = Callback.register_exception "xl.error" (Error "register_callback") +--- a/tools/ocaml/libs/xl/xl.mli ++++ /dev/null +@@ -1,211 +0,0 @@ +-(* +- * Copyright (C) 2009-2010 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-exception Error of string +- +-type create_info = +-{ +- hvm : bool; +- hap : bool; +- oos : bool; +- ssidref : int32; +- name : string; +- uuid : int array; +- xsdata : (string * string) list; +- platformdata : (string * string) list; +- poolid : int32; +- poolname : string; +-} +- +-type build_pv_info = +-{ +- slack_memkb : int64; +- cmdline : string; +- ramdisk : string; +- features : string; +-} +- +-type build_hvm_info = +-{ +- pae : bool; +- apic : bool; +- acpi : bool; +- nx : bool; +- viridian : bool; +- timeoffset : string; +- timer_mode : int; +- hpet : int; +- vpt_align : int; +-} +- +-type build_spec = BuildHVM of build_hvm_info | BuildPV of build_pv_info +- +-type build_info = +-{ +- max_vcpus : int; +- cur_vcpus : int; +- max_memkb : int64; +- target_memkb : int64; +- video_memkb : int64; +- shadow_memkb : int64; +- kernel : string; +- priv: build_spec; +-} +- +-type build_state = +-{ +- store_port : int; +- store_mfn : int64; +- console_port : int; +- console_mfn : int64; +-} +- +-type domid = int +- +-type disk_phystype = +- | PHYSTYPE_QCOW +- | PHYSTYPE_QCOW2 +- | PHYSTYPE_VHD +- | PHYSTYPE_AIO +- | PHYSTYPE_FILE +- | PHYSTYPE_PHY +- +-type disk_info = +-{ +- backend_domid : domid; +- physpath : string; +- phystype : disk_phystype; +- virtpath : string; +- unpluggable : bool; +- readwrite : bool; +- is_cdrom : bool; +-} +- +-type nic_type = +- | NICTYPE_IOEMU +- | NICTYPE_VIF +- +-type nic_info = +-{ +- backend_domid : domid; +- devid : int; +- mtu : int; +- model : string; +- mac : int array; +- bridge : string; +- ifname : string; +- script : string; +- nictype : nic_type; +-} +- +-type console_type = +- | CONSOLETYPE_XENCONSOLED +- | CONSOLETYPE_IOEMU +- +-type console_info = +-{ +- backend_domid : domid; +- devid : int; +- consoletype : console_type; +-} +- +-type vkb_info = +-{ +- backend_domid : domid; +- devid : int; +-} +- +-type vfb_info = +-{ +- backend_domid : domid; +- devid : int; +- vnc : bool; +- vnclisten : string; +- vncpasswd : string; +- vncdisplay : int; +- vncunused : bool; +- keymap : string; +- sdl : bool; +- opengl : bool; +- display : string; +- xauthority : string; +-} +- +-type pci_info = +-{ +- v : int; (* domain * bus * dev * func multiplexed *) +- domain : int; +- vdevfn : int; +- msitranslate : bool; +- power_mgmt : bool; +-} +- +-type physinfo = +-{ +- threads_per_core: int; +- cores_per_socket: int; +- max_cpu_id: int; +- nr_cpus: int; +- cpu_khz: int; +- total_pages: int64; +- free_pages: int64; +- scrub_pages: int64; +- nr_nodes: int; +- hwcap: int32 array; +- physcap: int32; +-} +- +-type sched_credit = +-{ +- weight: int; +- cap: int; +-} +- +-external domain_make : create_info -> domid = "stub_xl_domain_make" +-external domain_build : build_info -> domid -> build_state = "stub_xl_domain_build" +- +-external disk_add : disk_info -> domid -> unit = "stub_xl_disk_add" +-external disk_remove : disk_info -> domid -> unit = "stub_xl_disk_remove" +- +-external nic_add : nic_info -> domid -> unit = "stub_xl_nic_add" +-external nic_remove : disk_info -> domid -> unit = "stub_xl_nic_remove" +- +-external console_add : console_info -> build_state -> domid -> unit = "stub_xl_console_add" +- +-external vkb_add : vkb_info -> domid -> unit = "stub_xl_vkb_add" +-external vkb_clean_shutdown : domid -> unit = "stub_vkb_clean_shutdown" +-external vkb_hard_shutdown : domid -> unit = "stub_vkb_hard_shutdown" +- +-external vfb_add : vfb_info -> domid -> unit = "stub_xl_vfb_add" +-external vfb_clean_shutdown : domid -> unit = "stub_vfb_clean_shutdown" +-external vfb_hard_shutdown : domid -> unit = "stub_vfb_hard_shutdown" +- +-external pci_add : pci_info -> domid -> unit = "stub_xl_pci_add" +-external pci_remove : pci_info -> domid -> unit = "stub_xl_pci_remove" +-external pci_shutdown : domid -> unit = "stub_xl_pci_shutdown" +- +-type button = +- | Button_Power +- | Button_Sleep +- +-external button_press : domid -> button -> unit = "stub_xl_button_press" +-external physinfo : unit -> physinfo = "stub_xl_physinfo" +- +-external domain_sched_credit_get : domid -> sched_credit = "stub_xl_sched_credit_domain_get" +-external domain_sched_credit_set : domid -> sched_credit -> unit = "stub_xl_sched_credit_domain_set" +- +-external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger" +-external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq" +-external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys" +--- /dev/null ++++ b/tools/ocaml/libs/xl/xenlight.ml +@@ -0,0 +1,213 @@ ++(* ++ * Copyright (C) 2009-2010 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * This program is free software; you can redistribute it and/or modify ++ * it under the terms of the GNU Lesser General Public License as published ++ * by the Free Software Foundation; version 2.1 only. with the special ++ * exception on linking described in file LICENSE. ++ * ++ * This program is distributed in the hope that it will be useful, ++ * but WITHOUT ANY WARRANTY; without even the implied warranty of ++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ * GNU Lesser General Public License for more details. ++ *) ++ ++exception Error of string ++ ++type create_info = ++{ ++ hvm : bool; ++ hap : bool; ++ oos : bool; ++ ssidref : int32; ++ name : string; ++ uuid : int array; ++ xsdata : (string * string) list; ++ platformdata : (string * string) list; ++ poolid : int32; ++ poolname : string; ++} ++ ++type build_pv_info = ++{ ++ slack_memkb : int64; ++ cmdline : string; ++ ramdisk : string; ++ features : string; ++} ++ ++type build_hvm_info = ++{ ++ pae : bool; ++ apic : bool; ++ acpi : bool; ++ nx : bool; ++ viridian : bool; ++ timeoffset : string; ++ timer_mode : int; ++ hpet : int; ++ vpt_align : int; ++} ++ ++type build_spec = BuildHVM of build_hvm_info | BuildPV of build_pv_info ++ ++type build_info = ++{ ++ max_vcpus : int; ++ cur_vcpus : int; ++ max_memkb : int64; ++ target_memkb : int64; ++ video_memkb : int64; ++ shadow_memkb : int64; ++ kernel : string; ++ priv: build_spec; ++} ++ ++type build_state = ++{ ++ store_port : int; ++ store_mfn : int64; ++ console_port : int; ++ console_mfn : int64; ++} ++ ++type domid = int ++ ++type disk_phystype = ++ | PHYSTYPE_QCOW ++ | PHYSTYPE_QCOW2 ++ | PHYSTYPE_VHD ++ | PHYSTYPE_AIO ++ | PHYSTYPE_FILE ++ | PHYSTYPE_PHY ++ ++type disk_info = ++{ ++ backend_domid : domid; ++ physpath : string; ++ phystype : disk_phystype; ++ virtpath : string; ++ unpluggable : bool; ++ readwrite : bool; ++ is_cdrom : bool; ++} ++ ++type nic_type = ++ | NICTYPE_IOEMU ++ | NICTYPE_VIF ++ ++type nic_info = ++{ ++ backend_domid : domid; ++ devid : int; ++ mtu : int; ++ model : string; ++ mac : int array; ++ bridge : string; ++ ifname : string; ++ script : string; ++ nictype : nic_type; ++} ++ ++type console_type = ++ | CONSOLETYPE_XENCONSOLED ++ | CONSOLETYPE_IOEMU ++ ++type console_info = ++{ ++ backend_domid : domid; ++ devid : int; ++ consoletype : console_type; ++} ++ ++type vkb_info = ++{ ++ backend_domid : domid; ++ devid : int; ++} ++ ++type vfb_info = ++{ ++ backend_domid : domid; ++ devid : int; ++ vnc : bool; ++ vnclisten : string; ++ vncpasswd : string; ++ vncdisplay : int; ++ vncunused : bool; ++ keymap : string; ++ sdl : bool; ++ opengl : bool; ++ display : string; ++ xauthority : string; ++} ++ ++type pci_info = ++{ ++ v : int; (* domain * bus * dev * func multiplexed *) ++ domain : int; ++ vdevfn : int; ++ msitranslate : bool; ++ power_mgmt : bool; ++} ++ ++type physinfo = ++{ ++ threads_per_core: int; ++ cores_per_socket: int; ++ max_cpu_id: int; ++ nr_cpus: int; ++ cpu_khz: int; ++ total_pages: int64; ++ free_pages: int64; ++ scrub_pages: int64; ++ nr_nodes: int; ++ hwcap: int32 array; ++ physcap: int32; ++} ++ ++type sched_credit = ++{ ++ weight: int; ++ cap: int; ++} ++ ++external domain_make : create_info -> domid = "stub_xl_domain_make" ++external domain_build : build_info -> domid -> build_state = "stub_xl_domain_build" ++ ++external disk_add : disk_info -> domid -> unit = "stub_xl_disk_add" ++external disk_remove : disk_info -> domid -> unit = "stub_xl_disk_remove" ++ ++external nic_add : nic_info -> domid -> unit = "stub_xl_nic_add" ++external nic_remove : disk_info -> domid -> unit = "stub_xl_nic_remove" ++ ++external console_add : console_info -> build_state -> domid -> unit = "stub_xl_console_add" ++ ++external vkb_add : vkb_info -> domid -> unit = "stub_xl_vkb_add" ++external vkb_clean_shutdown : domid -> unit = "stub_vkb_clean_shutdown" ++external vkb_hard_shutdown : domid -> unit = "stub_vkb_hard_shutdown" ++ ++external vfb_add : vfb_info -> domid -> unit = "stub_xl_vfb_add" ++external vfb_clean_shutdown : domid -> unit = "stub_vfb_clean_shutdown" ++external vfb_hard_shutdown : domid -> unit = "stub_vfb_hard_shutdown" ++ ++external pci_add : pci_info -> domid -> unit = "stub_xl_pci_add" ++external pci_remove : pci_info -> domid -> unit = "stub_xl_pci_remove" ++external pci_shutdown : domid -> unit = "stub_xl_pci_shutdown" ++ ++type button = ++ | Button_Power ++ | Button_Sleep ++ ++external button_press : domid -> button -> unit = "stub_xl_button_press" ++external physinfo : unit -> physinfo = "stub_xl_physinfo" ++ ++external domain_sched_credit_get : domid -> sched_credit = "stub_xl_sched_credit_domain_get" ++external domain_sched_credit_set : domid -> sched_credit -> unit = "stub_xl_sched_credit_domain_set" ++ ++external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger" ++external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq" ++external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys" ++ ++let _ = Callback.register_exception "xl.error" (Error "register_callback") +--- /dev/null ++++ b/tools/ocaml/libs/xl/xenlight.mli +@@ -0,0 +1,211 @@ ++(* ++ * Copyright (C) 2009-2010 Citrix Ltd. ++ * Author Vincent Hanquez ++ * ++ * This program is free software; you can redistribute it and/or modify ++ * it under the terms of the GNU Lesser General Public License as published ++ * by the Free Software Foundation; version 2.1 only. with the special ++ * exception on linking described in file LICENSE. ++ * ++ * This program is distributed in the hope that it will be useful, ++ * but WITHOUT ANY WARRANTY; without even the implied warranty of ++ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ * GNU Lesser General Public License for more details. ++ *) ++ ++exception Error of string ++ ++type create_info = ++{ ++ hvm : bool; ++ hap : bool; ++ oos : bool; ++ ssidref : int32; ++ name : string; ++ uuid : int array; ++ xsdata : (string * string) list; ++ platformdata : (string * string) list; ++ poolid : int32; ++ poolname : string; ++} ++ ++type build_pv_info = ++{ ++ slack_memkb : int64; ++ cmdline : string; ++ ramdisk : string; ++ features : string; ++} ++ ++type build_hvm_info = ++{ ++ pae : bool; ++ apic : bool; ++ acpi : bool; ++ nx : bool; ++ viridian : bool; ++ timeoffset : string; ++ timer_mode : int; ++ hpet : int; ++ vpt_align : int; ++} ++ ++type build_spec = BuildHVM of build_hvm_info | BuildPV of build_pv_info ++ ++type build_info = ++{ ++ max_vcpus : int; ++ cur_vcpus : int; ++ max_memkb : int64; ++ target_memkb : int64; ++ video_memkb : int64; ++ shadow_memkb : int64; ++ kernel : string; ++ priv: build_spec; ++} ++ ++type build_state = ++{ ++ store_port : int; ++ store_mfn : int64; ++ console_port : int; ++ console_mfn : int64; ++} ++ ++type domid = int ++ ++type disk_phystype = ++ | PHYSTYPE_QCOW ++ | PHYSTYPE_QCOW2 ++ | PHYSTYPE_VHD ++ | PHYSTYPE_AIO ++ | PHYSTYPE_FILE ++ | PHYSTYPE_PHY ++ ++type disk_info = ++{ ++ backend_domid : domid; ++ physpath : string; ++ phystype : disk_phystype; ++ virtpath : string; ++ unpluggable : bool; ++ readwrite : bool; ++ is_cdrom : bool; ++} ++ ++type nic_type = ++ | NICTYPE_IOEMU ++ | NICTYPE_VIF ++ ++type nic_info = ++{ ++ backend_domid : domid; ++ devid : int; ++ mtu : int; ++ model : string; ++ mac : int array; ++ bridge : string; ++ ifname : string; ++ script : string; ++ nictype : nic_type; ++} ++ ++type console_type = ++ | CONSOLETYPE_XENCONSOLED ++ | CONSOLETYPE_IOEMU ++ ++type console_info = ++{ ++ backend_domid : domid; ++ devid : int; ++ consoletype : console_type; ++} ++ ++type vkb_info = ++{ ++ backend_domid : domid; ++ devid : int; ++} ++ ++type vfb_info = ++{ ++ backend_domid : domid; ++ devid : int; ++ vnc : bool; ++ vnclisten : string; ++ vncpasswd : string; ++ vncdisplay : int; ++ vncunused : bool; ++ keymap : string; ++ sdl : bool; ++ opengl : bool; ++ display : string; ++ xauthority : string; ++} ++ ++type pci_info = ++{ ++ v : int; (* domain * bus * dev * func multiplexed *) ++ domain : int; ++ vdevfn : int; ++ msitranslate : bool; ++ power_mgmt : bool; ++} ++ ++type physinfo = ++{ ++ threads_per_core: int; ++ cores_per_socket: int; ++ max_cpu_id: int; ++ nr_cpus: int; ++ cpu_khz: int; ++ total_pages: int64; ++ free_pages: int64; ++ scrub_pages: int64; ++ nr_nodes: int; ++ hwcap: int32 array; ++ physcap: int32; ++} ++ ++type sched_credit = ++{ ++ weight: int; ++ cap: int; ++} ++ ++external domain_make : create_info -> domid = "stub_xl_domain_make" ++external domain_build : build_info -> domid -> build_state = "stub_xl_domain_build" ++ ++external disk_add : disk_info -> domid -> unit = "stub_xl_disk_add" ++external disk_remove : disk_info -> domid -> unit = "stub_xl_disk_remove" ++ ++external nic_add : nic_info -> domid -> unit = "stub_xl_nic_add" ++external nic_remove : disk_info -> domid -> unit = "stub_xl_nic_remove" ++ ++external console_add : console_info -> build_state -> domid -> unit = "stub_xl_console_add" ++ ++external vkb_add : vkb_info -> domid -> unit = "stub_xl_vkb_add" ++external vkb_clean_shutdown : domid -> unit = "stub_vkb_clean_shutdown" ++external vkb_hard_shutdown : domid -> unit = "stub_vkb_hard_shutdown" ++ ++external vfb_add : vfb_info -> domid -> unit = "stub_xl_vfb_add" ++external vfb_clean_shutdown : domid -> unit = "stub_vfb_clean_shutdown" ++external vfb_hard_shutdown : domid -> unit = "stub_vfb_hard_shutdown" ++ ++external pci_add : pci_info -> domid -> unit = "stub_xl_pci_add" ++external pci_remove : pci_info -> domid -> unit = "stub_xl_pci_remove" ++external pci_shutdown : domid -> unit = "stub_xl_pci_shutdown" ++ ++type button = ++ | Button_Power ++ | Button_Sleep ++ ++external button_press : domid -> button -> unit = "stub_xl_button_press" ++external physinfo : unit -> physinfo = "stub_xl_physinfo" ++ ++external domain_sched_credit_get : domid -> sched_credit = "stub_xl_sched_credit_domain_get" ++external domain_sched_credit_set : domid -> sched_credit -> unit = "stub_xl_sched_credit_domain_set" ++ ++external send_trigger : domid -> string -> int -> unit = "stub_xl_send_trigger" ++external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq" ++external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys" +--- a/tools/ocaml/libs/xl/META.in ++++ b/tools/ocaml/libs/xl/META.in +@@ -1,4 +1,4 @@ + version = "@VERSION@" + description = "Xen Toolstack Library" +-archive(byte) = "xl.cma" +-archive(native) = "xl.cmxa" ++archive(byte) = "xenlight.cma" ++archive(native) = "xenlight.cmxa" diff --git a/upstream-23937:5173834e8476 b/upstream-23937:5173834e8476 new file mode 100644 index 0000000..f91dbaf --- /dev/null +++ b/upstream-23937:5173834e8476 @@ -0,0 +1,20 @@ +# HG changeset patch +# User Jon Ludlam +# Date 1318261088 -3600 +# Node ID 5173834e8476074afceb5c0124126e74a3954e97 +# Parent cdb34816a40a2dd3aaf324f7dcba83a122cf9146 +tools/ocaml: Add a missing dependency to the xenctrl ocaml package + +Signed-off-by: Jon Ludlam +Acked-by: Ian Campbell +Committed-by: Ian Jackson + +--- a/tools/ocaml/libs/xc/META.in ++++ b/tools/ocaml/libs/xc/META.in +@@ -1,5 +1,5 @@ + version = "@VERSION@" + description = "Xen Control Interface" +-requires = "xenmmap,uuid" ++requires = "unix,xenmmap,uuid" + archive(byte) = "xenctrl.cma" + archive(native) = "xenctrl.cmxa" diff --git a/upstream-23938:fa04fbd56521-rework b/upstream-23938:fa04fbd56521-rework new file mode 100644 index 0000000..72f0e64 --- /dev/null +++ b/upstream-23938:fa04fbd56521-rework @@ -0,0 +1,321 @@ +# HG changeset patch +# User Jon Ludlam +# Date 1317295879 -3600 +# Node ID 6c87e9dc5331096e8bfbad60a4f560cae05c4034 +# Parent c5df5f625ee2a0339b2a6785f99a5a0f9727f836 +[OCAML] Remove the uuid library + +This patch has the same effect as xen-unstable.hg c/s +23938:fa04fbd56521 + +The library was only minimally used, and was really rather redundant. + +Signed-off-by: Zheng Li +Acked-by: Jon Ludlam + +--- a/tools/ocaml/libs/Makefile ++++ b/tools/ocaml/libs/Makefile +@@ -2,7 +2,7 @@ + include $(XEN_ROOT)/tools/Rules.mk + + SUBDIRS= \ +- uuid mmap \ ++ mmap \ + log xc eventchn \ + xb xs xl + +--- a/tools/ocaml/libs/uuid/META.in ++++ /dev/null +@@ -1,4 +0,0 @@ +-version = "@VERSION@" +-description = "Uuid - universal identifer" +-archive(byte) = "uuid.cma" +-archive(native) = "uuid.cmxa" +--- a/tools/ocaml/libs/uuid/uuid.ml ++++ /dev/null +@@ -1,100 +0,0 @@ +-(* +- * Copyright (C) 2006-2010 Citrix Systems Inc. +- * Author Vincent Hanquez +- * +- * 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. +- *) +- +-(* Internally, a UUID is simply a string. *) +-type 'a t = string +- +-type cookie = string +- +-let of_string s = s +-let to_string s = s +- +-let null = "" +- +-(* deprecated: we don't need to duplicate the uuid prefix/suffix *) +-let uuid_of_string = of_string +-let string_of_uuid = to_string +- +-let string_of_cookie s = s +- +-let cookie_of_string s = s +- +-let dev_random = "/dev/random" +-let dev_urandom = "/dev/urandom" +- +-let rnd_array n = +- let fstbyte i = 0xff land i in +- let sndbyte i = fstbyte (i lsr 8) in +- let thdbyte i = sndbyte (i lsr 8) in +- let rec rnd_list n acc = match n with +- | 0 -> acc +- | 1 -> +- let b = fstbyte (Random.bits ()) in +- b :: acc +- | 2 -> +- let r = Random.bits () in +- let b1 = fstbyte r in +- let b2 = sndbyte r in +- b1 :: b2 :: acc +- | n -> +- let r = Random.bits () in +- let b1 = fstbyte r in +- let b2 = sndbyte r in +- let b3 = thdbyte r in +- rnd_list (n - 3) (b1 :: b2 :: b3 :: acc) +- in +- Array.of_list (rnd_list n []) +- +-let read_array dev n = +- let ic = open_in_bin dev in +- try +- let result = Array.init n (fun _ -> input_byte ic) in +- close_in ic; +- result +- with e -> +- close_in ic; +- raise e +- +-let uuid_of_int_array uuid = +- Printf.sprintf "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x" +- uuid.(0) uuid.(1) uuid.(2) uuid.(3) uuid.(4) uuid.(5) +- uuid.(6) uuid.(7) uuid.(8) uuid.(9) uuid.(10) uuid.(11) +- uuid.(12) uuid.(13) uuid.(14) uuid.(15) +- +-let make_uuid_prng () = uuid_of_int_array (rnd_array 16) +-let make_uuid_urnd () = uuid_of_int_array (read_array dev_urandom 16) +-let make_uuid_rnd () = uuid_of_int_array (read_array dev_random 16) +-let make_uuid = make_uuid_urnd +- +-let make_cookie() = +- let bytes = Array.to_list (read_array dev_urandom 64) in +- String.concat "" (List.map (Printf.sprintf "%1x") bytes) +- +-let int_array_of_uuid s = +- try +- let l = ref [] in +- Scanf.sscanf s "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x" +- (fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 -> +- l := [ a0; a1; a2; a3; a4; a5; a6; a7; a8; a9; +- a10; a11; a12; a13; a14; a15; ]); +- Array.of_list !l +- with _ -> invalid_arg "Uuid.int_array_of_uuid" +- +-let is_uuid str = +- try +- Scanf.sscanf str +- "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x" +- (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> true) +- with _ -> false +--- a/tools/ocaml/libs/uuid/uuid.mli ++++ /dev/null +@@ -1,67 +0,0 @@ +-(* +- * Copyright (C) 2006-2010 Citrix Systems Inc. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +-(** Type-safe UUIDs. +- Probably need to refactor this; UUIDs are used in two places: +- + to uniquely name things across the cluster +- + as secure session IDs +- +- There is the additional constraint that current Xen tools use +- a particular format of UUID (the 16 byte variety generated by fresh ()) +- +- Also, cookies aren't UUIDs and should be put somewhere else. +-*) +- +-(** A 128-bit UUID. Using phantom types ('a) to achieve the requires type-safety. *) +-type 'a t +- +-(** Create a fresh UUID *) +-val make_uuid : unit -> 'a t +-val make_uuid_prng : unit -> 'a t +-val make_uuid_urnd : unit -> 'a t +-val make_uuid_rnd : unit -> 'a t +- +-(** Create a UUID from a string. *) +-val of_string : string -> 'a t +- +-(** Marshal a UUID to a string. *) +-val to_string : 'a t -> string +- +-(** A null UUID, as if such a thing actually existed. It turns out to be +- * useful though. *) +-val null : 'a t +- +-(** Deprecated alias for {! Uuid.of_string} *) +-val uuid_of_string : string -> 'a t +- +-(** Deprecated alias for {! Uuid.to_string} *) +-val string_of_uuid : 'a t -> string +- +-(** Convert an array to a UUID. *) +-val uuid_of_int_array : int array -> 'a t +- +-(** Convert a UUID to an array. *) +-val int_array_of_uuid : 'a t -> int array +- +-(** Check whether a string is a UUID. *) +-val is_uuid : string -> bool +- +-(** A 512-bit cookie. *) +-type cookie +- +-val make_cookie : unit -> cookie +- +-val cookie_of_string : string -> cookie +- +-val string_of_cookie : cookie -> string +--- a/tools/ocaml/libs/xc/META.in ++++ b/tools/ocaml/libs/xc/META.in +@@ -1,5 +1,5 @@ + version = "@VERSION@" + description = "Xen Control Interface" +-requires = "unix,xenmmap,uuid" ++requires = "unix,xenmmap" + archive(byte) = "xenctrl.cma" + archive(native) = "xenctrl.cmxa" +--- a/tools/ocaml/libs/xc/Makefile ++++ b/tools/ocaml/libs/xc/Makefile +@@ -3,7 +3,7 @@ + include $(TOPLEVEL)/common.make + + CFLAGS += -I../mmap -I./ -I$(XEN_ROOT)/tools/libxc +-OCAMLINCLUDE += -I ../mmap -I ../uuid -I $(XEN_ROOT)/tools/libxc ++OCAMLINCLUDE += -I ../mmap -I $(XEN_ROOT)/tools/libxc + + OBJS = xenctrl + INTF = xenctrl.cmi +--- a/tools/ocaml/libs/xc/xenctrl.ml ++++ b/tools/ocaml/libs/xc/xenctrl.ml +@@ -118,14 +118,23 @@ + external _domain_create: handle -> int32 -> domain_create_flag list -> int array -> domid + = "stub_xc_domain_create" + ++let int_array_of_uuid_string s = ++ try ++ Scanf.sscanf s ++ "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x" ++ (fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 -> ++ [| a0; a1; a2; a3; a4; a5; a6; a7; ++ a8; a9; a10; a11; a12; a13; a14; a15 |]) ++ with _ -> invalid_arg ("Xc.int_array_of_uuid_string: " ^ s) ++ + let domain_create handle n flags uuid = +- _domain_create handle n flags (Uuid.int_array_of_uuid uuid) ++ _domain_create handle n flags (int_array_of_uuid_string 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) ++ _domain_sethandle handle n (int_array_of_uuid_string uuid) + + external domain_max_vcpus: handle -> domid -> int -> unit + = "stub_xc_domain_max_vcpus" +--- a/tools/ocaml/libs/xc/xenctrl.mli ++++ b/tools/ocaml/libs/xc/xenctrl.mli +@@ -74,12 +74,8 @@ + 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 ++val domain_create : handle -> int32 -> domain_create_flag list -> string -> domid ++val domain_sethandle : handle -> domid -> string -> unit + external domain_max_vcpus : handle -> domid -> int -> unit + = "stub_xc_domain_max_vcpus" + external domain_pause : handle -> domid -> unit = "stub_xc_domain_pause" +--- a/tools/ocaml/xenstored/Makefile ++++ b/tools/ocaml/xenstored/Makefile +@@ -5,7 +5,6 @@ + OCAMLINCLUDE += \ + -I $(OCAML_TOPLEVEL)/libs/log \ + -I $(OCAML_TOPLEVEL)/libs/xb \ +- -I $(OCAML_TOPLEVEL)/libs/uuid \ + -I $(OCAML_TOPLEVEL)/libs/mmap \ + -I $(OCAML_TOPLEVEL)/libs/xc \ + -I $(OCAML_TOPLEVEL)/libs/eventchn +@@ -34,7 +33,6 @@ + INTF = symbol.cmi trie.cmi + XENSTOREDLIBS = \ + unix.cmxa \ +- $(OCAML_TOPLEVEL)/libs/uuid/uuid.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/log $(OCAML_TOPLEVEL)/libs/log/log.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \ +--- a/tools/ocaml/libs/uuid/Makefile ++++ /dev/null +@@ -1,29 +0,0 @@ +-TOPLEVEL=$(CURDIR)/../.. +-XEN_ROOT=$(TOPLEVEL)/../.. +-include $(TOPLEVEL)/common.make +- +-OBJS = uuid +-INTF = $(foreach obj, $(OBJS),$(obj).cmi) +-LIBS = uuid.cma uuid.cmxa +- +-all: $(INTF) $(LIBS) $(PROGRAMS) +- +-bins: $(PROGRAMS) +- +-libs: $(LIBS) +- +-uuid_OBJS = $(OBJS) +-OCAML_NOC_LIBRARY = uuid +- +-.PHONY: install +-install: $(LIBS) META +- mkdir -p $(OCAMLDESTDIR) +- ocamlfind remove -destdir $(OCAMLDESTDIR) uuid +- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore uuid META $(INTF) $(LIBS) *.a *.cmx +- +-.PHONY: uninstall +-uninstall: +- ocamlfind remove -destdir $(OCAMLDESTDIR) uuid +- +-include $(TOPLEVEL)/Makefile.rules +- diff --git a/upstream-23939:51288f69523f-rework b/upstream-23939:51288f69523f-rework new file mode 100644 index 0000000..30fcb1c --- /dev/null +++ b/upstream-23939:51288f69523f-rework @@ -0,0 +1,1509 @@ +# HG changeset patch +# User Jon Ludlam +# Date 1317300078 -3600 +# Node ID f628a2174cd0289400e2fe476cc3177fbcba3c8d +# Parent 42cdb34ec175602fa2d8f0f65e44c4eb3a086496 +[OCAML] Remove log library from tools/ocaml/libs + +This patch has the same effect as xen-unstable.hg c/s 23939:51288f69523f + +The only user was oxenstored, which has had the relevant bits +merged in. + +Signed-off-by: Zheng Li +Acked-by: Jon Ludlam + +--- a/tools/ocaml/libs/Makefile ++++ b/tools/ocaml/libs/Makefile +@@ -3,7 +3,7 @@ + + SUBDIRS= \ + mmap \ +- log xc eventchn \ ++ xc eventchn \ + xb xs xl + + .PHONY: all +--- a/tools/ocaml/libs/log/META.in ++++ /dev/null +@@ -1,5 +0,0 @@ +-version = "@VERSION@" +-description = "Log - logging library" +-requires = "unix" +-archive(byte) = "log.cma" +-archive(native) = "log.cmxa" +--- a/tools/ocaml/libs/log/log.ml ++++ /dev/null +@@ -1,258 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-open Printf +- +-exception Unknown_level of string +- +-type stream_type = Stderr | Stdout | File of string +- +-type stream_log = { +- ty : stream_type; +- channel : out_channel option ref; +-} +- +-type level = Debug | Info | Warn | Error +- +-type output = +- | Stream of stream_log +- | String of string list ref +- | Syslog of string +- | Nil +- +-let int_of_level l = +- match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3 +- +-let string_of_level l = +- match l with Debug -> "debug" | Info -> "info" +- | Warn -> "warn" | Error -> "error" +- +-let level_of_string s = +- match s with +- | "debug" -> Debug +- | "info" -> Info +- | "warn" -> Warn +- | "error" -> Error +- | _ -> raise (Unknown_level s) +- +-let mkdir_safe dir perm = +- try Unix.mkdir dir perm with _ -> () +- +-let mkdir_rec dir perm = +- let rec p_mkdir dir = +- let p_name = Filename.dirname dir in +- if p_name = "/" || p_name = "." then +- () +- else ( +- p_mkdir p_name; +- mkdir_safe dir perm +- ) in +- p_mkdir dir +- +-type t = { output: output; mutable level: level; } +- +-let make output level = { output = output; level = level; } +- +-let make_stream ty channel = +- Stream {ty=ty; channel=ref channel; } +- +-(** open a syslog logger *) +-let opensyslog k level = +- make (Syslog k) level +- +-(** open a stderr logger *) +-let openerr level = +- if (Unix.stat "/dev/stderr").Unix.st_kind <> Unix.S_CHR then +- failwith "/dev/stderr is not a valid character device"; +- make (make_stream Stderr (Some (open_out "/dev/stderr"))) level +- +-let openout level = +- if (Unix.stat "/dev/stdout").Unix.st_kind <> Unix.S_CHR then +- failwith "/dev/stdout is not a valid character device"; +- make (make_stream Stdout (Some (open_out "/dev/stdout"))) level +- +- +-(** open a stream logger - returning the channel. *) +-(* This needs to be separated from 'openfile' so we can reopen later *) +-let doopenfile filename = +- if Filename.is_relative filename then +- None +- else ( +- try +- mkdir_rec (Filename.dirname filename) 0o700; +- Some (open_out_gen [ Open_append; Open_creat ] 0o600 filename) +- with _ -> None +- ) +- +-(** open a stream logger - returning the output type *) +-let openfile filename level = +- make (make_stream (File filename) (doopenfile filename)) level +- +-(** open a nil logger *) +-let opennil () = +- make Nil Error +- +-(** open a string logger *) +-let openstring level = +- make (String (ref [""])) level +- +-(** try to reopen a logger *) +-let reopen t = +- match t.output with +- | Nil -> t +- | Syslog k -> Syslog.close (); opensyslog k t.level +- | Stream s -> ( +- match (s.ty,!(s.channel)) with +- | (File filename, Some c) -> close_out c; s.channel := (try doopenfile filename with _ -> None); t +- | _ -> t) +- | String _ -> t +- +-(** close a logger *) +-let close t = +- match t.output with +- | Nil -> () +- | Syslog k -> Syslog.close (); +- | Stream s -> ( +- match !(s.channel) with +- | Some c -> close_out c; s.channel := None +- | None -> ()) +- | String _ -> () +- +-(** create a string representating the parameters of the logger *) +-let string_of_logger t = +- match t.output with +- | Nil -> "nil" +- | Syslog k -> sprintf "syslog:%s" k +- | String _ -> "string" +- | Stream s -> +- begin +- match s.ty with +- | File f -> sprintf "file:%s" f +- | Stderr -> "stderr" +- | Stdout -> "stdout" +- end +- +-(** parse a string to a logger *) +-let logger_of_string s : t = +- match s with +- | "nil" -> opennil () +- | "stderr" -> openerr Debug +- | "stdout" -> openout Debug +- | "string" -> openstring Debug +- | _ -> +- let split_in_2 s = +- try +- let i = String.index s ':' in +- String.sub s 0 (i), +- String.sub s (i + 1) (String.length s - i - 1) +- with _ -> +- failwith "logger format error: expecting string:string" +- in +- let k, s = split_in_2 s in +- match k with +- | "syslog" -> opensyslog s Debug +- | "file" -> openfile s Debug +- | _ -> failwith "unknown logger type" +- +-let validate s = +- match s with +- | "nil" -> () +- | "stderr" -> () +- | "stdout" -> () +- | "string" -> () +- | _ -> +- let split_in_2 s = +- try +- let i = String.index s ':' in +- String.sub s 0 (i), +- String.sub s (i + 1) (String.length s - i - 1) +- with _ -> +- failwith "logger format error: expecting string:string" +- in +- let k, s = split_in_2 s in +- match k with +- | "syslog" -> () +- | "file" -> ( +- try +- let st = Unix.stat s in +- if st.Unix.st_kind <> Unix.S_REG then +- failwith "logger file is a directory"; +- () +- with Unix.Unix_error (Unix.ENOENT, _, _) -> () +- ) +- | _ -> failwith "unknown logger" +- +-(** change a logger level to level *) +-let set t level = t.level <- level +- +-let gettimestring () = +- let time = Unix.gettimeofday () in +- let tm = Unix.localtime time in +- let msec = time -. (floor time) in +- sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d|" (1900 + tm.Unix.tm_year) +- (tm.Unix.tm_mon + 1) tm.Unix.tm_mday +- tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec +- (int_of_float (1000.0 *. msec)) +- +-(*let extra_hook = ref (fun x -> x)*) +- +-let output t ?(key="") ?(extra="") priority (message: string) = +- let construct_string withtime = +- (*let key = if key = "" then [] else [ key ] in +- let extra = if extra = "" then [] else [ extra ] in +- let items = +- (if withtime then [ gettimestring () ] else []) +- @ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in +-(* let items = !extra_hook items in*) +- String.concat " " items*) +- Printf.sprintf "[%s%s|%s] %s" +- (if withtime then gettimestring () else "") (string_of_level priority) extra message +- in +- (* Keep track of how much we write out to streams, so that we can *) +- (* log-rotate at appropriate times *) +- let write_to_stream stream = +- let string = (construct_string true) in +- try +- fprintf stream "%s\n%!" string +- with _ -> () (* Trap exception when we fail to write log *) +- in +- +- if String.length message > 0 then +- match t.output with +- | Syslog k -> +- let sys_prio = match priority with +- | Debug -> Syslog.Debug +- | Info -> Syslog.Info +- | Warn -> Syslog.Warning +- | Error -> Syslog.Err in +- Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n") +- | Stream s -> ( +- match !(s.channel) with +- | Some c -> write_to_stream c +- | None -> ()) +- | Nil -> () +- | String s -> (s := (construct_string true)::!s) +- +-let log t level (fmt: ('a, unit, string, unit) format4): 'a = +- let b = (int_of_level t.level) <= (int_of_level level) in +- (* ksprintf is the preferred name for kprintf, but the former +- * is not available in OCaml 3.08.3 *) +- Printf.kprintf (if b then output t level else (fun _ -> ())) fmt +- +-let debug t (fmt: ('a , unit, string, unit) format4) = log t Debug fmt +-let info t (fmt: ('a , unit, string, unit) format4) = log t Info fmt +-let warn t (fmt: ('a , unit, string, unit) format4) = log t Warn fmt +-let error t (fmt: ('a , unit, string, unit) format4) = log t Error fmt +--- a/tools/ocaml/libs/log/log.mli ++++ /dev/null +@@ -1,55 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-exception Unknown_level of string +-type level = Debug | Info | Warn | Error +- +-type stream_type = Stderr | Stdout | File of string +-type stream_log = { +- ty : stream_type; +- channel : out_channel option ref; +-} +-type output = +- Stream of stream_log +- | String of string list ref +- | Syslog of string +- | Nil +-val int_of_level : level -> int +-val string_of_level : level -> string +-val level_of_string : string -> level +-val mkdir_safe : string -> Unix.file_perm -> unit +-val mkdir_rec : string -> Unix.file_perm -> unit +-type t = { output : output; mutable level : level; } +-val make : output -> level -> t +-val opensyslog : string -> level -> t +-val openerr : level -> t +-val openout : level -> t +-val openfile : string -> level -> t +-val opennil : unit -> t +-val openstring : level -> t +-val reopen : t -> t +-val close : t -> unit +-val string_of_logger : t -> string +-val logger_of_string : string -> t +-val validate : string -> unit +-val set : t -> level -> unit +-val gettimestring : unit -> string +-val output : t -> ?key:string -> ?extra:string -> level -> string -> unit +-val log : t -> level -> ('a, unit, string, unit) format4 -> 'a +-val debug : t -> ('a, unit, string, unit) format4 -> 'a +-val info : t -> ('a, unit, string, unit) format4 -> 'a +-val warn : t -> ('a, unit, string, unit) format4 -> 'a +-val error : t -> ('a, unit, string, unit) format4 -> 'a +--- a/tools/ocaml/libs/log/logs.ml ++++ /dev/null +@@ -1,197 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-type keylogger = +-{ +- mutable debug: string list; +- mutable info: string list; +- mutable warn: string list; +- mutable error: string list; +- no_default: bool; +-} +- +-(* map all logger strings into a logger *) +-let __all_loggers = Hashtbl.create 10 +- +-(* default logger that everything that doesn't have a key in __lop_mapping get send *) +-let __default_logger = { debug = []; info = []; warn = []; error = []; no_default = false } +- +-(* +- * This describe the mapping between a name to a keylogger. +- * a keylogger contains a list of logger string per level of debugging. +- * Example: "xenops", debug -> [ "stderr"; "/var/log/xensource.log" ] +- * "xapi", error -> [] +- * "xapi", debug -> [ "/var/log/xensource.log" ] +- * "xenops", info -> [ "syslog" ] +- *) +-let __log_mapping = Hashtbl.create 32 +- +-let get_or_open logstring = +- if Hashtbl.mem __all_loggers logstring then +- Hashtbl.find __all_loggers logstring +- else +- let t = Log.logger_of_string logstring in +- Hashtbl.add __all_loggers logstring t; +- t +- +-(** create a mapping entry for the key "name". +- * all log level of key "name" default to "logger" logger. +- * a sensible default is put "nil" as a logger and reopen a specific level to +- * the logger you want to. +- *) +-let add key logger = +- let kl = { +- debug = logger; +- info = logger; +- warn = logger; +- error = logger; +- no_default = false; +- } in +- Hashtbl.add __log_mapping key kl +- +-let get_by_level keylog level = +- match level with +- | Log.Debug -> keylog.debug +- | Log.Info -> keylog.info +- | Log.Warn -> keylog.warn +- | Log.Error -> keylog.error +- +-let set_by_level keylog level logger = +- match level with +- | Log.Debug -> keylog.debug <- logger +- | Log.Info -> keylog.info <- logger +- | Log.Warn -> keylog.warn <- logger +- | Log.Error -> keylog.error <- logger +- +-(** set a specific key|level to the logger "logger" *) +-let set key level logger = +- if not (Hashtbl.mem __log_mapping key) then +- add key []; +- +- let keylog = Hashtbl.find __log_mapping key in +- set_by_level keylog level logger +- +-(** set default logger *) +-let set_default level logger = +- set_by_level __default_logger level logger +- +-(** append a logger to the list *) +-let append key level logger = +- if not (Hashtbl.mem __log_mapping key) then +- add key []; +- let keylog = Hashtbl.find __log_mapping key in +- let loggers = get_by_level keylog level in +- set_by_level keylog level (loggers @ [ logger ]) +- +-(** append a logger to the default list *) +-let append_default level logger = +- let loggers = get_by_level __default_logger level in +- set_by_level __default_logger level (loggers @ [ logger ]) +- +-(** reopen all logger open *) +-let reopen () = +- Hashtbl.iter (fun k v -> +- Hashtbl.replace __all_loggers k (Log.reopen v)) __all_loggers +- +-(** reclaim close all logger open that are not use by any other keys *) +-let reclaim () = +- let list_sort_uniq l = +- let oldprev = ref "" and prev = ref "" in +- List.fold_left (fun a k -> +- oldprev := !prev; +- prev := k; +- if k = !oldprev then a else k :: a) [] +- (List.sort compare l) +- in +- let flatten_keylogger v = +- list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in +- let oldkeys = Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in +- let usedkeys = Hashtbl.fold (fun k v a -> +- (flatten_keylogger v) @ a) +- __log_mapping (flatten_keylogger __default_logger) in +- let usedkeys = list_sort_uniq usedkeys in +- +- List.iter (fun k -> +- if not (List.mem k usedkeys) then ( +- begin try +- Log.close (Hashtbl.find __all_loggers k) +- with +- Not_found -> () +- end; +- Hashtbl.remove __all_loggers k +- )) oldkeys +- +-(** clear a specific key|level *) +-let clear key level = +- try +- let keylog = Hashtbl.find __log_mapping key in +- set_by_level keylog level []; +- reclaim () +- with Not_found -> +- () +- +-(** clear a specific default level *) +-let clear_default level = +- set_default level []; +- reclaim () +- +-(** reset all the loggers to the specified logger *) +-let reset_all logger = +- Hashtbl.clear __log_mapping; +- set_default Log.Debug logger; +- set_default Log.Warn logger; +- set_default Log.Error logger; +- set_default Log.Info logger; +- reclaim () +- +-(** log a fmt message to the key|level logger specified in the log mapping. +- * if the logger doesn't exist, assume nil logger. +- *) +-let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a = +- let keylog = +- if Hashtbl.mem __log_mapping key then +- let keylog = Hashtbl.find __log_mapping key in +- if keylog.no_default = false && +- get_by_level keylog level = [] then +- __default_logger +- else +- keylog +- else +- __default_logger in +- let loggers = get_by_level keylog level in +- match loggers with +- | [] -> Printf.kprintf ignore fmt +- | _ -> +- let l = List.fold_left (fun acc logger -> +- try get_or_open logger :: acc +- with _ -> acc +- ) [] loggers in +- let l = List.rev l in +- +- (* ksprintf is the preferred name for kprintf, but the former +- * is not available in OCaml 3.08.3 *) +- Printf.kprintf (fun s -> +- List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt +- +-(* define some convenience functions *) +-let debug t ?extra (fmt: ('a , unit, string, unit) format4) = +- log t Log.Debug ?extra fmt +-let info t ?extra (fmt: ('a , unit, string, unit) format4) = +- log t Log.Info ?extra fmt +-let warn t ?extra (fmt: ('a , unit, string, unit) format4) = +- log t Log.Warn ?extra fmt +-let error t ?extra (fmt: ('a , unit, string, unit) format4) = +- log t Log.Error ?extra fmt +--- a/tools/ocaml/libs/log/logs.mli ++++ /dev/null +@@ -1,46 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-type keylogger = { +- mutable debug : string list; +- mutable info : string list; +- mutable warn : string list; +- mutable error : string list; +- no_default : bool; +-} +-val __all_loggers : (string, Log.t) Hashtbl.t +-val __default_logger : keylogger +-val __log_mapping : (string, keylogger) Hashtbl.t +-val get_or_open : string -> Log.t +-val add : string -> string list -> unit +-val get_by_level : keylogger -> Log.level -> string list +-val set_by_level : keylogger -> Log.level -> string list -> unit +-val set : string -> Log.level -> string list -> unit +-val set_default : Log.level -> string list -> unit +-val append : string -> Log.level -> string -> unit +-val append_default : Log.level -> string -> unit +-val reopen : unit -> unit +-val reclaim : unit -> unit +-val clear : string -> Log.level -> unit +-val clear_default : Log.level -> unit +-val reset_all : string list -> unit +-val log : +- string -> +- Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +-val debug : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +-val info : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +-val warn : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +-val error : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +--- a/tools/ocaml/libs/log/syslog.ml ++++ /dev/null +@@ -1,26 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug +-type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid +-type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern +- | Local0 | Local1 | Local2 | Local3 +- | Local4 | Local5 | Local6 | Local7 +- | Lpr | Mail | News | Syslog | User | Uucp +- +-(* external init : string -> options list -> facility -> unit = "stub_openlog" *) +-external log : facility -> level -> string -> unit = "stub_syslog" +-external close : unit -> unit = "stub_closelog" +--- a/tools/ocaml/libs/log/syslog_stubs.c ++++ /dev/null +@@ -1,75 +0,0 @@ +-/* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * 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 +-#include +-#include +-#include +-#include +- +-static int __syslog_level_table[] = { +- LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, +- LOG_NOTICE, LOG_INFO, LOG_DEBUG +-}; +- +-/* +-static int __syslog_options_table[] = { +- LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID +-}; +-*/ +- +-static int __syslog_facility_table[] = { +- LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN, +- LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, +- LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7, +- LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP +-}; +- +-/* According to the openlog manpage the 'openlog' call may take a reference +- to the 'ident' string and keep it long-term. This means we cannot just pass in +- an ocaml string which is under the control of the GC. Since we aren't actually +- calling this function we can just comment it out for the time-being. */ +-/* +-value stub_openlog(value ident, value option, value facility) +-{ +- CAMLparam3(ident, option, facility); +- int c_option; +- int c_facility; +- +- c_option = caml_convert_flag_list(option, __syslog_options_table); +- c_facility = __syslog_facility_table[Int_val(facility)]; +- openlog(String_val(ident), c_option, c_facility); +- CAMLreturn(Val_unit); +-} +-*/ +- +-value stub_syslog(value facility, value level, value msg) +-{ +- CAMLparam3(facility, level, msg); +- int c_facility; +- +- c_facility = __syslog_facility_table[Int_val(facility)] +- | __syslog_level_table[Int_val(level)]; +- syslog(c_facility, "%s", String_val(msg)); +- CAMLreturn(Val_unit); +-} +- +-value stub_closelog(value unit) +-{ +- CAMLparam1(unit); +- closelog(); +- CAMLreturn(Val_unit); +-} +--- a/tools/ocaml/xenstored/Makefile ++++ b/tools/ocaml/xenstored/Makefile +@@ -3,7 +3,6 @@ + include $(OCAML_TOPLEVEL)/common.make + + OCAMLINCLUDE += \ +- -I $(OCAML_TOPLEVEL)/libs/log \ + -I $(OCAML_TOPLEVEL)/libs/xb \ + -I $(OCAML_TOPLEVEL)/libs/mmap \ + -I $(OCAML_TOPLEVEL)/libs/xc \ +@@ -34,7 +33,6 @@ + XENSTOREDLIBS = \ + unix.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \ +- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/log $(OCAML_TOPLEVEL)/libs/log/log.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \ + -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xenbus.cmxa \ +--- a/tools/ocaml/xenstored/connection.ml ++++ b/tools/ocaml/xenstored/connection.ml +@@ -232,3 +232,8 @@ + Printf.fprintf chan "watch,%d,%s,%s\n" domid (Utils.hexify path) (Utils.hexify token) + ) (list_watches con); + | None -> () ++ ++let debug con = ++ let domid = get_domstr con in ++ let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in ++ String.concat "" watches +--- a/tools/ocaml/xenstored/connections.ml ++++ b/tools/ocaml/xenstored/connections.ml +@@ -15,7 +15,7 @@ + * GNU Lesser General Public License for more details. + *) + +-let debug fmt = Logs.debug "general" fmt ++let debug fmt = Logging.debug "connections" fmt + + type t = { + mutable anonymous: Connection.t list; +@@ -165,3 +165,8 @@ + ); + (List.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon, + Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom) ++ ++let debug cons = ++ let anonymous = List.map Connection.debug cons.anonymous in ++ let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in ++ String.concat "" (domains @ anonymous) +--- a/tools/ocaml/xenstored/disk.ml ++++ b/tools/ocaml/xenstored/disk.ml +@@ -17,7 +17,7 @@ + let enable = ref false + let xs_daemon_database = "/var/run/xenstored/db" + +-let error = Logs.error "general" ++let error fmt = Logging.error "disk" fmt + + (* unescape utils *) + exception Bad_escape +--- a/tools/ocaml/xenstored/domain.ml ++++ b/tools/ocaml/xenstored/domain.ml +@@ -16,7 +16,7 @@ + + open Printf + +-let debug fmt = Logs.debug "general" fmt ++let debug fmt = Logging.debug "domain" fmt + + type t = + { +--- a/tools/ocaml/xenstored/domains.ml ++++ b/tools/ocaml/xenstored/domains.ml +@@ -14,6 +14,8 @@ + * GNU Lesser General Public License for more details. + *) + ++let debug fmt = Logging.debug "domains" fmt ++ + type domains = { + eventchn: Event.t; + table: (Xenctrl.domid, Domain.t) Hashtbl.t; +@@ -35,7 +37,7 @@ + try + let info = Xenctrl.domain_getinfo xc id in + if info.Xenctrl.shutdown || info.Xenctrl.dying then ( +- Logs.debug "general" "Domain %u died (dying=%b, shutdown %b -- code %d)" ++ debug "Domain %u died (dying=%b, shutdown %b -- code %d)" + id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code; + if info.Xenctrl.dying then + dead_dom := id :: !dead_dom +@@ -43,7 +45,7 @@ + notify := true; + ) + with Xenctrl.Error _ -> +- Logs.debug "general" "Domain %u died -- no domain info" id; ++ debug "Domain %u died -- no domain info" id; + dead_dom := id :: !dead_dom; + ) doms.table; + List.iter (fun id -> +--- a/tools/ocaml/xenstored/logging.ml ++++ b/tools/ocaml/xenstored/logging.ml +@@ -17,21 +17,122 @@ + open Stdext + open Printf + +-let error fmt = Logs.error "general" fmt +-let info fmt = Logs.info "general" fmt +-let debug fmt = Logs.debug "general" fmt + +-let access_log_file = ref "/var/log/xenstored-access.log" +-let access_log_nb_files = ref 20 +-let access_log_nb_lines = ref 13215 +-let activate_access_log = ref true ++(* Logger common *) ++ ++type logger = ++ { stop: unit -> unit; ++ restart: unit -> unit; ++ rotate: unit -> unit; ++ write: 'a. ('a, unit, string, unit) format4 -> 'a } ++ ++let truncate_line nb_chars line = ++ if String.length line > nb_chars - 1 then ++ let len = max (nb_chars - 1) 2 in ++ let dst_line = String.create len in ++ String.blit line 0 dst_line 0 (len - 2); ++ dst_line.[len-2] <- '.'; ++ dst_line.[len-1] <- '.'; ++ dst_line ++ else line ++ ++let log_rotate ref_ch log_file log_nb_files = ++ let file n = sprintf "%s.%i" log_file n in ++ let log_files = ++ let rec aux accu n = ++ if n >= log_nb_files then accu ++ else ++ if n = 1 && Sys.file_exists log_file ++ then aux [log_file,1] 2 ++ else ++ let file = file (n-1) in ++ if Sys.file_exists file then ++ aux ((file, n) :: accu) (n+1) ++ else accu in ++ aux [] 1 in ++ List.iter (fun (f, n) -> Unix.rename f (file n)) log_files; ++ close_out !ref_ch; ++ ref_ch := open_out log_file ++ ++let make_logger log_file log_nb_files log_nb_lines log_nb_chars post_rotate = ++ let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in ++ let counter = ref 0 in ++ let stop() = ++ try flush !channel; close_out !channel ++ with _ -> () in ++ let restart() = ++ stop(); ++ channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in ++ let rotate() = ++ log_rotate channel log_file log_nb_files; ++ (post_rotate (): unit); ++ counter := 0 in ++ let output s = ++ let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in ++ let s = s ^ "\n" in ++ output_string !channel s; ++ flush !channel; ++ incr counter; ++ if !counter > log_nb_lines then rotate() in ++ { stop=stop; restart=restart; rotate=rotate; write = fun fmt -> Printf.ksprintf output fmt } ++ ++ ++(* Xenstored logger *) ++ ++exception Unknown_level of string ++ ++type level = Debug | Info | Warn | Error | Null ++ ++let int_of_level = function ++ | Debug -> 0 | Info -> 1 | Warn -> 2 ++ | Error -> 3 | Null -> max_int ++ ++let string_of_level = function ++ | Debug -> "debug" | Info -> "info" | Warn -> "warn" ++ | Error -> "error" | Null -> "null" ++ ++let level_of_string = function ++ | "debug" -> Debug | "info" -> Info | "warn" -> Warn ++ | "error" -> Error | "null" -> Null | s -> raise (Unknown_level s) ++ ++let string_of_date () = ++ let time = Unix.gettimeofday () in ++ let tm = Unix.gmtime time in ++ let msec = time -. (floor time) in ++ sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ" ++ (1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday ++ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec ++ (int_of_float (1000.0 *. msec)) + +-(* maximal size of the lines in xenstore-acces.log file *) +-let line_size = 180 ++let xenstored_log_file = ref "/var/log/xenstored.log" ++let xenstored_log_level = ref Null ++let xenstored_log_nb_files = ref 10 ++let xenstored_log_nb_lines = ref 13215 ++let xenstored_log_nb_chars = ref (-1) ++let xenstored_logger = ref (None: logger option) ++ ++let init_xenstored_log () = ++ if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then ++ let logger = ++ make_logger ++ !xenstored_log_file !xenstored_log_nb_files !xenstored_log_nb_lines ++ !xenstored_log_nb_chars ignore in ++ xenstored_logger := Some logger ++ ++let xenstored_logging level key (fmt: (_,_,_,_) format4) = ++ match !xenstored_logger with ++ | Some logger when int_of_level level >= int_of_level !xenstored_log_level -> ++ let date = string_of_date() in ++ let level = string_of_level level in ++ logger.write ("[%s|%5s|%s] " ^^ fmt) date level key ++ | _ -> Printf.ksprintf ignore fmt ++ ++let debug key = xenstored_logging Debug key ++let info key = xenstored_logging Info key ++let warn key = xenstored_logging Warn key ++let error key = xenstored_logging Error key + +-let log_read_ops = ref false +-let log_transaction_ops = ref false +-let log_special_ops = ref false ++(* Access logger *) + + type access_type = + | Coalesce +@@ -41,38 +142,10 @@ + | Endconn + | XbOp of Xenbus.Xb.Op.operation + +-type access = +- { +- fd: out_channel ref; +- counter: int ref; +- write: tid:int -> con:string -> ?data:string -> access_type -> unit; +- } +- +-let string_of_date () = +- let time = Unix.gettimeofday () in +- let tm = Unix.localtime time in +- let msec = time -. (floor time) in +- sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d" (1900 + tm.Unix.tm_year) +- (tm.Unix.tm_mon + 1) +- tm.Unix.tm_mday +- tm.Unix.tm_hour +- tm.Unix.tm_min +- tm.Unix.tm_sec +- (int_of_float (1000.0 *. msec)) +- +-let fill_with_space n s = +- if String.length s < n +- then +- let r = String.make n ' ' in +- String.blit s 0 r 0 (String.length s); +- r +- else +- s +- + let string_of_tid ~con tid = + if tid = 0 +- then fill_with_space 12 (sprintf "%s" con) +- else fill_with_space 12 (sprintf "%s.%i" con tid) ++ then sprintf "%-12s" con ++ else sprintf "%-12s" (sprintf "%s.%i" con tid) + + let string_of_access_type = function + | Coalesce -> "coalesce " +@@ -109,41 +182,9 @@ + + | Xenbus.Xb.Op.Error -> "error " + | Xenbus.Xb.Op.Watchevent -> "w event " +- ++ (* + | x -> Xenbus.Xb.Op.to_string x +- +-let file_exists file = +- try +- Unix.close (Unix.openfile file [Unix.O_RDONLY] 0o644); +- true +- with _ -> +- false +- +-let log_rotate fd = +- let file n = sprintf "%s.%i" !access_log_file n in +- let log_files = +- let rec aux accu n = +- if n >= !access_log_nb_files +- then accu +- else if n = 1 && file_exists !access_log_file +- then aux [!access_log_file,1] 2 +- else +- let file = file (n-1) in +- if file_exists file +- then aux ((file,n) :: accu) (n+1) +- else accu +- in +- aux [] 1 +- in +- let rec rename = function +- | (f,n) :: t when n < !access_log_nb_files -> +- Unix.rename f (file n); +- rename t +- | _ -> () +- in +- rename log_files; +- close_out !fd; +- fd := open_out !access_log_file ++ *) + + let sanitize_data data = + let data = String.copy data in +@@ -154,86 +195,68 @@ + done; + String.escaped data + +-let make save_to_disk = +- let fd = ref (open_out_gen [Open_append; Open_creat] 0o644 !access_log_file) in +- let counter = ref 0 in +- { +- fd = fd; +- counter = counter; +- write = +- if not !activate_access_log || !access_log_nb_files = 0 +- then begin fun ~tid ~con ?data _ -> () end +- else fun ~tid ~con ?(data="") access_type -> +- let s = Printf.sprintf "[%s] %s %s %s\n" (string_of_date()) (string_of_tid ~con tid) +- (string_of_access_type access_type) (sanitize_data data) in +- let s = +- if String.length s > line_size +- then begin +- let s = String.sub s 0 line_size in +- s.[line_size-3] <- '.'; +- s.[line_size-2] <- '.'; +- s.[line_size-1] <- '\n'; +- s +- end else +- s +- in +- incr counter; +- output_string !fd s; +- flush !fd; +- if !counter > !access_log_nb_lines +- then begin +- log_rotate fd; +- save_to_disk (); +- counter := 0; +- end +- } +- +-let access : (access option) ref = ref None +-let init aal save_to_disk = +- activate_access_log := aal; +- access := Some (make save_to_disk) +- +-let write_access_log ~con ~tid ?data access_type = ++let activate_access_log = ref true ++let access_log_file = ref "/var/log/xenstored-access.log" ++let access_log_nb_files = ref 20 ++let access_log_nb_lines = ref 13215 ++let access_log_nb_chars = ref 180 ++let access_log_read_ops = ref false ++let access_log_transaction_ops = ref false ++let access_log_special_ops = ref false ++let access_logger = ref None ++ ++let init_access_log post_rotate = ++ if !access_log_nb_files > 0 then ++ let logger = ++ make_logger ++ !access_log_file !access_log_nb_files !access_log_nb_lines ++ !access_log_nb_chars post_rotate in ++ access_logger := Some logger ++ ++let access_logging ~con ~tid ?(data="") access_type = + try +- maybe (fun a -> a.write access_type ~con ~tid ?data) !access ++ maybe ++ (fun logger -> ++ let date = string_of_date() in ++ let tid = string_of_tid ~con tid in ++ let access_type = string_of_access_type access_type in ++ let data = sanitize_data data in ++ logger.write "[%s] %s %s %s" date tid access_type data) ++ !access_logger + with _ -> () + +-let new_connection = write_access_log Newconn +-let end_connection = write_access_log Endconn ++let new_connection = access_logging Newconn ++let end_connection = access_logging Endconn + let read_coalesce ~tid ~con data = +- if !log_read_ops +- then write_access_log Coalesce ~tid ~con ~data:("read "^data) +-let write_coalesce data = write_access_log Coalesce ~data:("write "^data) +-let conflict = write_access_log Conflict +-let commit = write_access_log Commit ++ if !access_log_read_ops ++ then access_logging Coalesce ~tid ~con ~data:("read "^data) ++let write_coalesce data = access_logging Coalesce ~data:("write "^data) ++let conflict = access_logging Conflict ++let commit = access_logging Commit + + let xb_op ~tid ~con ~ty data = +- let print = +- match ty with +- | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !log_read_ops ++ let print = match ty with ++ | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops + | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end -> + false (* transactions are managed below *) + | Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume -> +- !log_special_ops +- | _ -> true +- in +- if print +- then write_access_log ~tid ~con ~data (XbOp ty) ++ !access_log_special_ops ++ | _ -> true in ++ if print then access_logging ~tid ~con ~data (XbOp ty) + + let start_transaction ~tid ~con = +- if !log_transaction_ops && tid <> 0 +- then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ++ if !access_log_transaction_ops && tid <> 0 ++ then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) + + let end_transaction ~tid ~con = +- if !log_transaction_ops && tid <> 0 +- then write_access_log ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) ++ if !access_log_transaction_ops && tid <> 0 ++ then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) + + let xb_answer ~tid ~con ~ty data = + let print = match ty with +- | Xenbus.Xb.Op.Error when data="ENOENT " -> !log_read_ops +- | Xenbus.Xb.Op.Error -> !log_special_ops ++ | Xenbus.Xb.Op.Error when String.startswith "ENOENT " data -> !access_log_read_ops ++ | Xenbus.Xb.Op.Error -> true + | Xenbus.Xb.Op.Watchevent -> true + | _ -> false + in +- if print +- then write_access_log ~tid ~con ~data (XbOp ty) ++ if print then access_logging ~tid ~con ~data (XbOp ty) +--- a/tools/ocaml/xenstored/perms.ml ++++ b/tools/ocaml/xenstored/perms.ml +@@ -15,6 +15,8 @@ + * GNU Lesser General Public License for more details. + *) + ++let info fmt = Logging.info "perms" fmt ++ + open Stdext + + let activate = ref true +@@ -145,16 +147,16 @@ + in + match perm, request with + | NONE, _ -> +- Logs.info "io" "Permission denied: Domain %d has no permission" domainid; ++ info "Permission denied: Domain %d has no permission" domainid; + false + | RDWR, _ -> true + | READ, READ -> true + | WRITE, WRITE -> true + | READ, _ -> +- Logs.info "io" "Permission denied: Domain %d has read only access" domainid; ++ info "Permission denied: Domain %d has read only access" domainid; + false + | WRITE, _ -> +- Logs.info "io" "Permission denied: Domain %d has write only access" domainid; ++ info "Permission denied: Domain %d has write only access" domainid; + false + in + if !activate +--- a/tools/ocaml/xenstored/process.ml ++++ b/tools/ocaml/xenstored/process.ml +@@ -14,6 +14,9 @@ + * GNU Lesser General Public License for more details. + *) + ++let error fmt = Logging.error "process" fmt ++let info fmt = Logging.info "process" fmt ++ + open Printf + open Stdext + +@@ -79,7 +82,7 @@ + + (* packets *) + let do_debug con t domains cons data = +- if not !allow_debug ++ if not (Connection.is_dom0 con) && not !allow_debug + then None + else try match split None '\000' data with + | "print" :: msg :: _ -> +@@ -89,6 +92,9 @@ + let domid = int_of_string domid in + let quota = (Store.get_quota t.Transaction.store) in + Some (Quota.to_string quota domid ^ "\000") ++ | "watches" :: _ -> ++ let watches = Connections.debug cons in ++ Some (watches ^ "\000") + | "mfn" :: domid :: _ -> + let domid = int_of_string domid in + let con = Connections.find_domain cons domid in +@@ -357,8 +363,7 @@ + in + input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data; + with exn -> +- Logs.error "general" "process packet: %s" +- (Printexc.to_string exn); ++ error "process packet: %s" (Printexc.to_string exn); + Connection.send_error con tid rid "EIO" + + let write_access_log ~ty ~tid ~con ~data = +@@ -372,7 +377,7 @@ + let packet = Connection.pop_in con in + let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in + (* As we don't log IO, do not call an unnecessary sanitize_data +- Logs.info "io" "[%s] -> [%d] %s \"%s\"" ++ info "[%s] -> [%d] %s \"%s\"" + (Connection.get_domstr con) tid + (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *) + process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data; +@@ -386,7 +391,7 @@ + let packet = Connection.peek_output con in + let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in + (* As we don't log IO, do not call an unnecessary sanitize_data +- Logs.info "io" "[%s] <- %s \"%s\"" ++ info "[%s] <- %s \"%s\"" + (Connection.get_domstr con) + (Xenbus.Xb.Op.to_string ty) (sanitize_data data);*) + write_answer_log ~ty ~tid ~con ~data; +--- a/tools/ocaml/xenstored/quota.ml ++++ b/tools/ocaml/xenstored/quota.ml +@@ -18,7 +18,7 @@ + exception Data_too_big + exception Transaction_opened + +-let warn fmt = Logs.warn "general" fmt ++let warn fmt = Logging.warn "quota" fmt + let activate = ref true + let maxent = ref (10000) + let maxsize = ref (4096) +--- a/tools/ocaml/xenstored/store.ml ++++ b/tools/ocaml/xenstored/store.ml +@@ -83,7 +83,7 @@ + let check_owner node connection = + if not (Perms.check_owner connection node.perms) + then begin +- Logs.info "io" "Permission denied: Domain %d not owner" (get_owner node); ++ Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node); + raise Define.Permission_denied; + end + +--- a/tools/ocaml/xenstored/xenstored.conf ++++ b/tools/ocaml/xenstored/xenstored.conf +@@ -22,9 +22,14 @@ + # Activate filed base backend + persistant = false + +-# Logs +-log = error;general;file:/var/log/xenstored.log +-log = warn;general;file:/var/log/xenstored.log +-log = info;general;file:/var/log/xenstored.log ++# Xenstored logs ++# xenstored-log-file = /var/log/xenstored.log ++# xenstored-log-level = null ++# xenstored-log-nb-files = 10 ++ ++# Xenstored access logs ++# access-log-file = /var/log/xenstored-access.log ++# access-log-nb-lines = 13215 ++# acesss-log-nb-chars = 180 ++# access-log-special-ops = false + +-# log = debug;io;file:/var/log/xenstored-io.log +--- a/tools/ocaml/xenstored/xenstored.ml ++++ b/tools/ocaml/xenstored/xenstored.ml +@@ -18,7 +18,10 @@ + open Printf + open Parse_arg + open Stdext +-open Logging ++ ++let error fmt = Logging.error "xenstored" fmt ++let debug fmt = Logging.debug "xenstored" fmt ++let info fmt = Logging.info "xenstored" fmt + + (*------------ event klass processors --------------*) + let process_connection_fds store cons domains rset wset = +@@ -64,7 +67,8 @@ + () + + let sighup_handler _ = +- try Logs.reopen (); info "Log re-opened" with _ -> () ++ maybe (fun logger -> logger.Logging.restart()) !Logging.xenstored_logger; ++ maybe (fun logger -> logger.Logging.restart()) !Logging.access_logger + + let config_filename cf = + match cf.config_file with +@@ -75,26 +79,6 @@ + + let parse_config filename = + let pidfile = ref default_pidfile in +- let set_log s = +- let ls = String.split ~limit:3 ';' s in +- let level, key, logger = match ls with +- | [ level; key; logger ] -> level, key, logger +- | _ -> failwith "format mismatch: expecting 3 arguments" in +- +- let loglevel = match level with +- | "debug" -> Log.Debug +- | "info" -> Log.Info +- | "warn" -> Log.Warn +- | "error" -> Log.Error +- | s -> failwith (sprintf "Unknown log level: %s" s) in +- +- (* if key is empty, append to the default logger *) +- let append = +- if key = "" then +- Logs.append_default +- else +- Logs.append key in +- append loglevel logger in + let options = [ + ("merge-activate", Config.Set_bool Transaction.do_coalesce); + ("perms-activate", Config.Set_bool Perms.activate); +@@ -104,14 +88,20 @@ + ("quota-maxentity", Config.Set_int Quota.maxent); + ("quota-maxsize", Config.Set_int Quota.maxsize); + ("test-eagain", Config.Set_bool Transaction.test_eagain); +- ("log", Config.String set_log); + ("persistant", Config.Set_bool Disk.enable); ++ ("xenstored-log-file", Config.Set_string Logging.xenstored_log_file); ++ ("xenstored-log-level", Config.String ++ (fun s -> Logging.xenstored_log_level := Logging.level_of_string s)); ++ ("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_files); ++ ("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lines); ++ ("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_chars); + ("access-log-file", Config.Set_string Logging.access_log_file); + ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files); + ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines); +- ("access-log-read-ops", Config.Set_bool Logging.log_read_ops); +- ("access-log-transactions-ops", Config.Set_bool Logging.log_transaction_ops); +- ("access-log-special-ops", Config.Set_bool Logging.log_special_ops); ++ ("access-log-nb-chars", Config.Set_int Logging.access_log_nb_chars); ++ ("access-log-read-ops", Config.Set_bool Logging.access_log_read_ops); ++ ("access-log-transactions-ops", Config.Set_bool Logging.access_log_transaction_ops); ++ ("access-log-special-ops", Config.Set_bool Logging.access_log_special_ops); + ("allow-debug", Config.Set_bool Process.allow_debug); + ("pid-file", Config.Set_string pidfile); ] in + begin try Config.read filename options (fun _ _ -> raise Not_found) +@@ -223,9 +213,6 @@ + end + + let _ = +- printf "Xen Storage Daemon, version %d.%d\n%!" +- Define.xenstored_major Define.xenstored_minor; +- + let cf = do_argv in + let pidfile = + if Sys.file_exists (config_filename cf) then +@@ -249,13 +236,13 @@ + in + + if cf.daemonize then +- Unixext.daemonize (); ++ Unixext.daemonize () ++ else ++ printf "Xen Storage Daemon, version %d.%d\n%!" ++ Define.xenstored_major Define.xenstored_minor; + + (try Unixext.pidfile_write pidfile with _ -> ()); + +- info "Xen Storage Daemon, version %d.%d" +- Define.xenstored_major Define.xenstored_minor; +- + (* for compatilibity with old xenstored *) + begin match cf.pidfile with + | Some pidfile -> Unixext.pidfile_write pidfile +@@ -293,7 +280,14 @@ + Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun i -> sigusr1_handler store)); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + +- Logging.init cf.activate_access_log (fun () -> DB.to_file store cons "/var/run/xenstored/db"); ++ Logging.init_xenstored_log(); ++ if cf.activate_access_log then begin ++ let post_rotate () = DB.to_file store cons "/var/run/xenstored/db" in ++ Logging.init_access_log post_rotate ++ end; ++ ++ info "Xen Storage Daemon, version %d.%d" ++ Define.xenstored_major Define.xenstored_minor; + + let spec_fds = + (match rw_sock with None -> [] | Some x -> [ x ]) @ +--- a/tools/ocaml/libs/log/syslog.mli ++++ /dev/null +@@ -1,41 +0,0 @@ +-(* +- * Copyright (C) 2006-2007 XenSource Ltd. +- * Copyright (C) 2008 Citrix Ltd. +- * Author Vincent Hanquez +- * +- * This program is free software; you can redistribute it and/or modify +- * it under the terms of the GNU Lesser General Public License as published +- * by the Free Software Foundation; version 2.1 only. with the special +- * exception on linking described in file LICENSE. +- * +- * This program is distributed in the hope that it will be useful, +- * but WITHOUT ANY WARRANTY; without even the implied warranty of +- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +- * GNU Lesser General Public License for more details. +- *) +- +-type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug +-type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid +-type facility = +- Auth +- | Authpriv +- | Cron +- | Daemon +- | Ftp +- | Kern +- | Local0 +- | Local1 +- | Local2 +- | Local3 +- | Local4 +- | Local5 +- | Local6 +- | Local7 +- | Lpr +- | Mail +- | News +- | Syslog +- | User +- | Uucp +-external log : facility -> level -> string -> unit = "stub_syslog" +-external close : unit -> unit = "stub_closelog" +--- a/tools/ocaml/libs/log/Makefile ++++ /dev/null +@@ -1,44 +0,0 @@ +-TOPLEVEL=$(CURDIR)/../.. +-XEN_ROOT=$(TOPLEVEL)/../.. +-include $(TOPLEVEL)/common.make +- +-OBJS = syslog log logs +-INTF = log.cmi logs.cmi syslog.cmi +-LIBS = log.cma log.cmxa +- +-all: $(INTF) $(LIBS) $(PROGRAMS) +- +-bins: $(PROGRAMS) +- +-libs: $(LIBS) +- +-log.cmxa: libsyslog_stubs.a $(foreach obj,$(OBJS),$(obj).cmx) +- $(call mk-caml-lib-native, $@, -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmx)) +- +-log.cma: $(foreach obj,$(OBJS),$(obj).cmo) +- $(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmo)) +- +-syslog_stubs.a: syslog_stubs.o +- $(call mk-caml-stubs, $@, $+) +- +-libsyslog_stubs.a: syslog_stubs.o +- $(call mk-caml-lib-stubs, $@, $+) +- +-logs.mli : logs.ml +- $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@ +- +-syslog.mli : syslog.ml +- $(OCAMLC) -i $< > $@ +- +-.PHONY: install +-install: $(LIBS) META +- mkdir -p $(OCAMLDESTDIR) +- ocamlfind remove -destdir $(OCAMLDESTDIR) log +- ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx +- +-.PHONY: uninstall +-uninstall: +- ocamlfind remove -destdir $(OCAMLDESTDIR) log +- +-include $(TOPLEVEL)/Makefile.rules +- diff --git a/upstream-23940:187d59e32a58 b/upstream-23940:187d59e32a58 new file mode 100644 index 0000000..2c7521a --- /dev/null +++ b/upstream-23940:187d59e32a58 @@ -0,0 +1,45 @@ +# HG changeset patch +# User Jon Ludlam +# Date 1318261276 -3600 +# Node ID 187d59e32a586d65697ed46bef106b52e3fb5ab9 +# Parent 51288f69523fcbbefa12cea5a761a6e957410151 +tools/ocaml: Fix 2 bit-twiddling bugs and an off-by-one + +The bit bugs are in ocaml vcpu affinity calls, and the off-by-one +error is in the ocaml console ring code + +Signed-off-by: Zheng Li +Acked-by: Ian Campbell +Committed-by: Ian Jackson +Acked-by: Jon Ludlam + +diff -r 51288f69523f -r 187d59e32a58 tools/ocaml/libs/xc/xenctrl_stubs.c +--- a/tools/ocaml/libs/xc/xenctrl_stubs.c Mon Oct 10 16:41:16 2011 +0100 ++++ b/tools/ocaml/libs/xc/xenctrl_stubs.c Mon Oct 10 16:41:16 2011 +0100 +@@ -430,7 +430,7 @@ + + for (i=0; i - 4.1.2-5 +- Start building xen's ocaml libraries if appropriate unless --without ocaml + was specified +- add some backported patches from xen unstable (via Debian) for some + ocaml tidying and fixes + * Sun Jan 15 2012 Michael Young - 4.1.2-4 - actually apply the xend-pci-loop.patch - compile fixes for gcc-4.7