From mboxrd@z Thu Jan 1 00:00:00 1970 From: Vincent Hanquez Subject: [PATCH 1/6] add ocaml libs (xc/xb/xs/eventchn) Date: Mon, 1 Mar 2010 11:59:46 +0000 Message-ID: <1267444791-4810-2-git-send-email-vincent.hanquez@eu.citrix.com> References: <1267444791-4810-1-git-send-email-vincent.hanquez@eu.citrix.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------1.7.0" Return-path: In-Reply-To: <1267444791-4810-1-git-send-email-vincent.hanquez@eu.citrix.com> List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Sender: xen-devel-bounces@lists.xensource.com Errors-To: xen-devel-bounces@lists.xensource.com To: xen-devel@lists.xensource.com Cc: Vincent Hanquez List-Id: xen-devel@lists.xenproject.org This is a multi-part message in MIME format. --------------1.7.0 Content-Type: text/plain; charset=UTF-8; format=fixed Content-Transfer-Encoding: quoted-printable Signed-off-by: Vincent Hanquez --- tools/ocaml/libs/eventchn/META.in | 4 + tools/ocaml/libs/eventchn/Makefile | 28 + tools/ocaml/libs/eventchn/eventchn.ml | 27 + tools/ocaml/libs/eventchn/eventchn.mli | 26 + tools/ocaml/libs/eventchn/eventchn_stubs.c | 173 ++++ tools/ocaml/libs/log/META.in | 4 + tools/ocaml/libs/log/Makefile | 43 + tools/ocaml/libs/log/log.ml | 258 +++++ tools/ocaml/libs/log/log.mli | 55 + tools/ocaml/libs/log/logs.ml | 197 ++++ tools/ocaml/libs/log/logs.mli | 46 + tools/ocaml/libs/log/syslog.ml | 26 + tools/ocaml/libs/log/syslog.mli | 41 + tools/ocaml/libs/log/syslog_stubs.c | 73 ++ tools/ocaml/libs/mmap/META.in | 4 + tools/ocaml/libs/mmap/Makefile | 27 + tools/ocaml/libs/mmap/mmap.ml | 31 + tools/ocaml/libs/mmap/mmap.mli | 28 + tools/ocaml/libs/mmap/mmap_stubs.c | 136 +++ tools/ocaml/libs/mmap/mmap_stubs.h | 33 + tools/ocaml/libs/stdext/META.in | 5 + tools/ocaml/libs/stdext/Makefile | 43 + tools/ocaml/libs/stdext/bigbuffer.ml | 90 ++ tools/ocaml/libs/stdext/bigbuffer.mli | 22 + tools/ocaml/libs/stdext/eventloop.ml | 357 +++++++ tools/ocaml/libs/stdext/eventloop.mli | 100 ++ tools/ocaml/libs/stdext/file.ml | 34 + tools/ocaml/libs/stdext/file.mli | 18 + tools/ocaml/libs/stdext/filenameext.ml | 33 + tools/ocaml/libs/stdext/filenameext.mli | 17 + tools/ocaml/libs/stdext/hashtblext.ml | 38 + tools/ocaml/libs/stdext/hashtblext.mli | 77 ++ tools/ocaml/libs/stdext/listext.ml | 27 + tools/ocaml/libs/stdext/listext.mli | 65 ++ tools/ocaml/libs/stdext/opt.ml | 48 + tools/ocaml/libs/stdext/opt.mli | 24 + tools/ocaml/libs/stdext/pervasiveext.ml | 61 ++ tools/ocaml/libs/stdext/pervasiveext.mli | 30 + tools/ocaml/libs/stdext/qring.ml | 161 +++ tools/ocaml/libs/stdext/qring.mli | 47 + tools/ocaml/libs/stdext/ring.ml | 109 ++ tools/ocaml/libs/stdext/ring.mli | 30 + tools/ocaml/libs/stdext/stringext.ml | 206 ++++ tools/ocaml/libs/stdext/stringext.mli | 108 ++ tools/ocaml/libs/stdext/threadext.ml | 212 ++++ tools/ocaml/libs/stdext/threadext.mli | 67 ++ tools/ocaml/libs/stdext/trie.ml | 182 ++++ tools/ocaml/libs/stdext/trie.mli | 60 ++ tools/ocaml/libs/stdext/unixext.ml | 437 ++++++++ tools/ocaml/libs/stdext/unixext.mli | 84 ++ tools/ocaml/libs/stdext/unixext_stubs.c | 304 ++++++ tools/ocaml/libs/stdext/vIO.ml | 250 +++++ tools/ocaml/libs/stdext/vIO.mli | 51 + tools/ocaml/libs/stdext/varmap.ml | 26 + tools/ocaml/libs/stdext/varmap.mli | 22 + tools/ocaml/libs/uuid/META.in | 4 + tools/ocaml/libs/uuid/Makefile | 26 + tools/ocaml/libs/uuid/uuid.ml | 88 ++ tools/ocaml/libs/uuid/uuid.mli | 53 + tools/ocaml/libs/xb/META.in | 4 + tools/ocaml/libs/xb/Makefile | 41 + tools/ocaml/libs/xb/op.ml | 84 ++ tools/ocaml/libs/xb/packet.ml | 50 + tools/ocaml/libs/xb/partial.ml | 44 + tools/ocaml/libs/xb/xb.ml | 189 ++++ tools/ocaml/libs/xb/xb.mli | 83 ++ tools/ocaml/libs/xb/xb_stubs.c | 74 ++ tools/ocaml/libs/xb/xs_ring.ml | 18 + tools/ocaml/libs/xb/xs_ring_stubs.c | 117 +++ tools/ocaml/libs/xc/META.in | 4 + tools/ocaml/libs/xc/Makefile | 28 + tools/ocaml/libs/xc/xc.h | 191 ++++ tools/ocaml/libs/xc/xc.ml | 340 +++++++ tools/ocaml/libs/xc/xc.mli | 196 ++++ tools/ocaml/libs/xc/xc_cpufeature.h | 116 +++ tools/ocaml/libs/xc/xc_cpuid.h | 285 ++++++ tools/ocaml/libs/xc/xc_e820.h | 20 + tools/ocaml/libs/xc/xc_lib.c | 1502 ++++++++++++++++++++++= ++++++ tools/ocaml/libs/xc/xc_stubs.c | 1170 ++++++++++++++++++++++ tools/ocaml/libs/xs/META.in | 4 + tools/ocaml/libs/xs/Makefile | 42 + tools/ocaml/libs/xs/queueop.ml | 73 ++ tools/ocaml/libs/xs/xs.ml | 170 ++++ tools/ocaml/libs/xs/xs.mli | 90 ++ tools/ocaml/libs/xs/xsraw.ml | 265 +++++ tools/ocaml/libs/xs/xsraw.mli | 60 ++ tools/ocaml/libs/xs/xst.ml | 61 ++ tools/ocaml/libs/xs/xst.mli | 30 + 88 files changed, 10227 insertions(+), 0 deletions(-) create mode 100644 tools/ocaml/libs/eventchn/META.in create mode 100644 tools/ocaml/libs/eventchn/Makefile create mode 100644 tools/ocaml/libs/eventchn/eventchn.ml create mode 100644 tools/ocaml/libs/eventchn/eventchn.mli create mode 100644 tools/ocaml/libs/eventchn/eventchn_stubs.c create mode 100644 tools/ocaml/libs/log/META.in create mode 100644 tools/ocaml/libs/log/Makefile create mode 100644 tools/ocaml/libs/log/log.ml create mode 100644 tools/ocaml/libs/log/log.mli create mode 100644 tools/ocaml/libs/log/logs.ml create mode 100644 tools/ocaml/libs/log/logs.mli create mode 100644 tools/ocaml/libs/log/syslog.ml create mode 100644 tools/ocaml/libs/log/syslog.mli create mode 100644 tools/ocaml/libs/log/syslog_stubs.c create mode 100644 tools/ocaml/libs/mmap/META.in create mode 100644 tools/ocaml/libs/mmap/Makefile create mode 100644 tools/ocaml/libs/mmap/mmap.ml create mode 100644 tools/ocaml/libs/mmap/mmap.mli create mode 100644 tools/ocaml/libs/mmap/mmap_stubs.c create mode 100644 tools/ocaml/libs/mmap/mmap_stubs.h create mode 100644 tools/ocaml/libs/stdext/META.in create mode 100644 tools/ocaml/libs/stdext/Makefile create mode 100644 tools/ocaml/libs/stdext/bigbuffer.ml create mode 100644 tools/ocaml/libs/stdext/bigbuffer.mli create mode 100644 tools/ocaml/libs/stdext/eventloop.ml create mode 100644 tools/ocaml/libs/stdext/eventloop.mli create mode 100644 tools/ocaml/libs/stdext/file.ml create mode 100644 tools/ocaml/libs/stdext/file.mli create mode 100644 tools/ocaml/libs/stdext/filenameext.ml create mode 100644 tools/ocaml/libs/stdext/filenameext.mli create mode 100644 tools/ocaml/libs/stdext/hashtblext.ml create mode 100644 tools/ocaml/libs/stdext/hashtblext.mli create mode 100644 tools/ocaml/libs/stdext/listext.ml create mode 100644 tools/ocaml/libs/stdext/listext.mli create mode 100644 tools/ocaml/libs/stdext/opt.ml create mode 100644 tools/ocaml/libs/stdext/opt.mli create mode 100644 tools/ocaml/libs/stdext/pervasiveext.ml create mode 100644 tools/ocaml/libs/stdext/pervasiveext.mli create mode 100644 tools/ocaml/libs/stdext/qring.ml create mode 100644 tools/ocaml/libs/stdext/qring.mli create mode 100644 tools/ocaml/libs/stdext/ring.ml create mode 100644 tools/ocaml/libs/stdext/ring.mli create mode 100644 tools/ocaml/libs/stdext/stringext.ml create mode 100644 tools/ocaml/libs/stdext/stringext.mli create mode 100644 tools/ocaml/libs/stdext/threadext.ml create mode 100644 tools/ocaml/libs/stdext/threadext.mli create mode 100644 tools/ocaml/libs/stdext/trie.ml create mode 100644 tools/ocaml/libs/stdext/trie.mli create mode 100644 tools/ocaml/libs/stdext/unixext.ml create mode 100644 tools/ocaml/libs/stdext/unixext.mli create mode 100644 tools/ocaml/libs/stdext/unixext_stubs.c create mode 100644 tools/ocaml/libs/stdext/vIO.ml create mode 100644 tools/ocaml/libs/stdext/vIO.mli create mode 100644 tools/ocaml/libs/stdext/varmap.ml create mode 100644 tools/ocaml/libs/stdext/varmap.mli create mode 100644 tools/ocaml/libs/uuid/META.in create mode 100644 tools/ocaml/libs/uuid/Makefile create mode 100644 tools/ocaml/libs/uuid/uuid.ml create mode 100644 tools/ocaml/libs/uuid/uuid.mli create mode 100644 tools/ocaml/libs/xb/META.in create mode 100644 tools/ocaml/libs/xb/Makefile create mode 100644 tools/ocaml/libs/xb/op.ml create mode 100644 tools/ocaml/libs/xb/packet.ml create mode 100644 tools/ocaml/libs/xb/partial.ml create mode 100644 tools/ocaml/libs/xb/xb.ml create mode 100644 tools/ocaml/libs/xb/xb.mli create mode 100644 tools/ocaml/libs/xb/xb_stubs.c create mode 100644 tools/ocaml/libs/xb/xs_ring.ml create mode 100644 tools/ocaml/libs/xb/xs_ring_stubs.c create mode 100644 tools/ocaml/libs/xc/META.in create mode 100644 tools/ocaml/libs/xc/Makefile create mode 100644 tools/ocaml/libs/xc/xc.h create mode 100644 tools/ocaml/libs/xc/xc.ml create mode 100644 tools/ocaml/libs/xc/xc.mli create mode 100644 tools/ocaml/libs/xc/xc_cpufeature.h create mode 100644 tools/ocaml/libs/xc/xc_cpuid.h create mode 100644 tools/ocaml/libs/xc/xc_e820.h create mode 100644 tools/ocaml/libs/xc/xc_lib.c create mode 100644 tools/ocaml/libs/xc/xc_stubs.c create mode 100644 tools/ocaml/libs/xs/META.in create mode 100644 tools/ocaml/libs/xs/Makefile create mode 100644 tools/ocaml/libs/xs/queueop.ml create mode 100644 tools/ocaml/libs/xs/xs.ml create mode 100644 tools/ocaml/libs/xs/xs.mli create mode 100644 tools/ocaml/libs/xs/xsraw.ml create mode 100644 tools/ocaml/libs/xs/xsraw.mli create mode 100644 tools/ocaml/libs/xs/xst.ml create mode 100644 tools/ocaml/libs/xs/xst.mli --------------1.7.0 Content-Type: text/x-patch; name="0001-add-ocaml-libs-xc-xb-xs-eventchn.patch" Content-Disposition: attachment; filename="0001-add-ocaml-libs-xc-xb-xs-eventchn.patch" Content-Transfer-Encoding: quoted-printable diff --git a/tools/ocaml/libs/eventchn/META.in b/tools/ocaml/libs/eventch= n/META.in new file mode 100644 index 0000000..f3e01aa --- /dev/null +++ b/tools/ocaml/libs/eventchn/META.in @@ -0,0 +1,4 @@ +version =3D "@VERSION@" +description =3D "Eventchn interface extension" +archive(byte) =3D "eventchn.cma" +archive(native) =3D "eventchn.cmxa" diff --git a/tools/ocaml/libs/eventchn/Makefile b/tools/ocaml/libs/eventc= hn/Makefile new file mode 100644 index 0000000..9d6ef31 --- /dev/null +++ b/tools/ocaml/libs/eventchn/Makefile @@ -0,0 +1,28 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +OBJS =3D eventchn +INTF =3D $(foreach obj, $(OBJS),$(obj).cmi) +LIBS =3D eventchn.cma eventchn.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +eventchn_OBJS =3D $(OBJS) +eventchn_C_OBJS =3D eventchn_stubs + +OCAML_LIBRARY =3D eventchn + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove eventchn + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/eventchn/eventchn.ml b/tools/ocaml/libs/eve= ntchn/eventchn.ml new file mode 100644 index 0000000..c4a7fa3 --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn.ml @@ -0,0 +1,27 @@ +(* + * 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 publis= hed + * 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 + +external init: unit -> Unix.file_descr =3D "stub_eventchn_init" +external notify: Unix.file_descr -> int -> unit =3D "stub_eventchn_notif= y" +external bind_interdomain: Unix.file_descr -> int -> int -> int =3D "stu= b_eventchn_bind_interdomain" +external bind_virq: Unix.file_descr -> int =3D "stub_eventchn_bind_virq" +external unbind: Unix.file_descr -> int -> unit =3D "stub_eventchn_unbin= d" +external read_port: Unix.file_descr -> int =3D "stub_eventchn_read_port" +external write_port: Unix.file_descr -> int -> unit =3D "stub_eventchn_w= rite_port" + +let _ =3D Callback.register_exception "eventchn.error" (Error "register_= callback") diff --git a/tools/ocaml/libs/eventchn/eventchn.mli b/tools/ocaml/libs/ev= entchn/eventchn.mli new file mode 100644 index 0000000..7088700 --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn.mli @@ -0,0 +1,26 @@ +(* + * 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 publis= hed + * 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 +external init : unit -> Unix.file_descr =3D "stub_eventchn_init" +external notify : Unix.file_descr -> int -> unit =3D "stub_eventchn_noti= fy" +external bind_interdomain : Unix.file_descr -> int -> int -> int + =3D "stub_eventchn_bind_interdomain" +external bind_virq : Unix.file_descr -> int =3D "stub_eventchn_bind_virq= " +external unbind : Unix.file_descr -> int -> unit =3D "stub_eventchn_unbi= nd" +external read_port : Unix.file_descr -> int =3D "stub_eventchn_read_port= " +external write_port : Unix.file_descr -> int -> unit + =3D "stub_eventchn_write_port" diff --git a/tools/ocaml/libs/eventchn/eventchn_stubs.c b/tools/ocaml/lib= s/eventchn/eventchn_stubs.c new file mode 100644 index 0000000..ab61b0a --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn_stubs.c @@ -0,0 +1,173 @@ +/* + * 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 publis= hed + * 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 + +#define __XEN_TOOLS__ + +#include + +#if XEN_SYSCTL_INTERFACE_VERSION < 4 +#include +#else +#include +#include +#endif + +#include + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include +#include + +#define EVENTCHN_PATH "/dev/xen/eventchn" + +static int eventchn_major =3D 10; +static int eventchn_minor =3D 61; + +static int do_ioctl(int handle, int cmd, void *arg) +{ + return ioctl(handle, cmd, arg); +} + +static int do_read_port(int handle, evtchn_port_t *port) +{ + return (read(handle, port, sizeof(evtchn_port_t)) !=3D sizeof(evtchn_po= rt_t)); +} + +static int do_write_port(int handle, evtchn_port_t port) +{ + return (write(handle, &port, sizeof(evtchn_port_t)) !=3D sizeof(evtchn_= port_t)); +} + +int eventchn_do_open(void) +{ + int fd; + + fd =3D open(EVENTCHN_PATH, O_RDWR); + if (fd =3D=3D -1 && errno =3D=3D ENOENT) { + mkdir("/dev/xen", 0640); + mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(eventchn_major, eventchn_= minor)); + fd =3D open(EVENTCHN_PATH, O_RDWR); + } + return fd; +} + +CAMLprim value stub_eventchn_init(value unit) +{ + CAMLparam1(unit); + int fd =3D eventchn_do_open(); + if (fd =3D=3D -1) + caml_failwith("open failed"); + CAMLreturn(Val_int(fd)); +} + +CAMLprim value stub_eventchn_notify(value fd, value port) +{ + CAMLparam2(fd, port); + struct ioctl_evtchn_notify notify; + int rc; + + notify.port =3D Int_val(port); + rc =3D do_ioctl(Int_val(fd), IOCTL_EVTCHN_NOTIFY, ¬ify); + if (rc =3D=3D -1) + caml_failwith("ioctl notify failed"); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_eventchn_bind_interdomain(value fd, value domid, + value remote_port) +{ + CAMLparam3(fd, domid, remote_port); + CAMLlocal1(port); + struct ioctl_evtchn_bind_interdomain bind; + int rc; + + bind.remote_domain =3D Int_val(domid); + bind.remote_port =3D Int_val(remote_port); + rc =3D do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_INTERDOMAIN, &bind); + if (rc =3D=3D -1) + caml_failwith("ioctl bind_interdomain failed"); + port =3D Val_int(rc); + + CAMLreturn(port); +} + +CAMLprim value stub_eventchn_bind_virq(value fd) +{ + CAMLparam1(fd); + CAMLlocal1(port); + struct ioctl_evtchn_bind_virq bind; + int rc; + + bind.virq =3D VIRQ_DOM_EXC; + rc =3D do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_VIRQ, &bind); + if (rc =3D=3D -1) + caml_failwith("ioctl bind_virq failed"); + port =3D Val_int(rc); + + CAMLreturn(port); +} + +CAMLprim value stub_eventchn_unbind(value fd, value port) +{ + CAMLparam2(fd, port); + struct ioctl_evtchn_unbind unbind; + int rc; + + unbind.port =3D Int_val(port); + rc =3D do_ioctl(Int_val(fd), IOCTL_EVTCHN_UNBIND, &unbind); + if (rc =3D=3D -1) + caml_failwith("ioctl unbind failed"); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_eventchn_read_port(value fd) +{ + CAMLparam1(fd); + CAMLlocal1(result); + evtchn_port_t port; + + if (do_read_port(Int_val(fd), &port)) + caml_failwith("read port failed"); + result =3D Val_int(port); + + CAMLreturn(result); +} + +CAMLprim value stub_eventchn_write_port(value fd, value _port) +{ + CAMLparam2(fd, _port); + evtchn_port_t port; + + port =3D Int_val(_port); + if (do_write_port(Int_val(fd), port)) + caml_failwith("write port failed"); + CAMLreturn(Val_unit); +} diff --git a/tools/ocaml/libs/log/META.in b/tools/ocaml/libs/log/META.in new file mode 100644 index 0000000..5c3646a --- /dev/null +++ b/tools/ocaml/libs/log/META.in @@ -0,0 +1,4 @@ +version =3D "@VERSION@" +description =3D "Log - logging library" +archive(byte) =3D "log.cma" +archive(native) =3D "log.cmxa" diff --git a/tools/ocaml/libs/log/Makefile b/tools/ocaml/libs/log/Makefil= e new file mode 100644 index 0000000..d16f72a --- /dev/null +++ b/tools/ocaml/libs/log/Makefile @@ -0,0 +1,43 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +OCAMLINCLUDE +=3D -I ../stdext + +OBJS =3D syslog log logs +INTF =3D log.cmi logs.cmi syslog.cmi +LIBS =3D 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,$(O= BJS),$(obj).cmx)) + +log.cma: $(foreach obj,$(OBJS),$(obj).cmo) + $(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsys= log_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 + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove log + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/log/log.ml b/tools/ocaml/libs/log/log.ml new file mode 100644 index 0000000..4f42759 --- /dev/null +++ b/tools/ocaml/libs/log/log.ml @@ -0,0 +1,258 @@ +(* + * 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 publis= hed + * 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 =3D Stderr | Stdout | File of string + +type stream_log =3D { + ty : stream_type; + channel : out_channel option ref; +} + +type level =3D Debug | Info | Warn | Error + +type output =3D + | Stream of stream_log + | String of string list ref + | Syslog of string + | Nil + +let int_of_level l =3D + match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3 + +let string_of_level l =3D + match l with Debug -> "debug" | Info -> "info" + | Warn -> "warn" | Error -> "error" + +let level_of_string s =3D + match s with + | "debug" -> Debug + | "info" -> Info + | "warn" -> Warn + | "error" -> Error + | _ -> raise (Unknown_level s) + +let mkdir_safe dir perm =3D + try Unix.mkdir dir perm with _ -> () + +let mkdir_rec dir perm =3D + let rec p_mkdir dir =3D + let p_name =3D Filename.dirname dir in + if p_name =3D "/" || p_name =3D "." then + () + else ( + p_mkdir p_name; + mkdir_safe dir perm + ) in + p_mkdir dir + +type t =3D { output: output; mutable level: level; } + +let make output level =3D { output =3D output; level =3D level; } + +let make_stream ty channel =3D=20 + Stream {ty=3Dty; channel=3Dref channel; } + +(** open a syslog logger *) +let opensyslog k level =3D + make (Syslog k) level + +(** open a stderr logger *) +let openerr level =3D + 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 +=09 +let openout level =3D + 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 =3D + 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 =3D + make (make_stream (File filename) (doopenfile filename)) level + +(** open a nil logger *) +let opennil () =3D + make Nil Error + +(** open a string logger *) +let openstring level =3D + make (String (ref [""])) level + +(** try to reopen a logger *) +let reopen t =3D + match t.output with + | Nil -> t + | Syslog k -> Syslog.close (); opensyslog k t.level + | Stream s -> ( + match (s.ty,!(s.channel)) with=20 + | (File filename, Some c) -> close_out c; s.channel :=3D (try doopenfi= le filename with _ -> None); t=20 + | _ -> t) + | String _ -> t + +(** close a logger *) +let close t =3D + match t.output with + | Nil -> () + | Syslog k -> Syslog.close (); + | Stream s -> ( + match !(s.channel) with=20 + | Some c -> close_out c; s.channel :=3D None + | None -> ()) + | String _ -> () + +(** create a string representating the parameters of the logger *) +let string_of_logger t =3D + match t.output with + | Nil -> "nil" + | Syslog k -> sprintf "syslog:%s" k + | String _ -> "string" + | Stream s ->=20 + begin + match s.ty with=20 + | File f -> sprintf "file:%s" f + | Stderr -> "stderr" + | Stdout -> "stdout" + end + +(** parse a string to a logger *) +let logger_of_string s : t =3D + match s with + | "nil" -> opennil () + | "stderr" -> openerr Debug + | "stdout" -> openout Debug + | "string" -> openstring Debug + | _ -> + let split_in_2 s =3D + try + let i =3D 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 =3D split_in_2 s in + match k with + | "syslog" -> opensyslog s Debug + | "file" -> openfile s Debug + | _ -> failwith "unknown logger type" + +let validate s =3D + match s with + | "nil" -> () + | "stderr" -> () + | "stdout" -> () + | "string" -> () + | _ -> + let split_in_2 s =3D + try + let i =3D 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 =3D split_in_2 s in + match k with + | "syslog" -> () + | "file" -> ( + try + let st =3D 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 =3D t.level <- level + +let gettimestring () =3D + let time =3D Unix.gettimeofday () in + let tm =3D Unix.localtime time in + let msec =3D 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 =3D ref (fun x -> x)*) + +let output t ?(key=3D"") ?(extra=3D"") priority (message: string) =3D + let construct_string withtime =3D + (*let key =3D if key =3D "" then [] else [ key ] in + let extra =3D if extra =3D "" then [] else [ extra ] in + let items =3D=20 + (if withtime then [ gettimestring () ] else []) + @ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ mes= sage ] in +(* let items =3D !extra_hook items in*) + String.concat " " items*) + Printf.sprintf "[%s%s|%s] %s"=20 + (if withtime then gettimestring () else "") (string_of_level prior= ity) 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 =3D + let string =3D (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 =3D 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 :=3D (construct_string true)::!s) + +let log t level (fmt: ('a, unit, string, unit) format4): 'a =3D + let b =3D (int_of_level t.level) <=3D (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 + =20 +let debug t (fmt: ('a , unit, string, unit) format4) =3D log t Debug fmt +let info t (fmt: ('a , unit, string, unit) format4) =3D log t Info fmt +let warn t (fmt: ('a , unit, string, unit) format4) =3D log t Warn fmt +let error t (fmt: ('a , unit, string, unit) format4) =3D log t Error fmt diff --git a/tools/ocaml/libs/log/log.mli b/tools/ocaml/libs/log/log.mli new file mode 100644 index 0000000..36c5a6b --- /dev/null +++ b/tools/ocaml/libs/log/log.mli @@ -0,0 +1,55 @@ +(* + * 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 publis= hed + * 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 =3D Debug | Info | Warn | Error + +type stream_type =3D Stderr | Stdout | File of string +type stream_log =3D { + ty : stream_type; + channel : out_channel option ref; +} +type output =3D + 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 =3D { 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 -> uni= t +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 diff --git a/tools/ocaml/libs/log/logs.ml b/tools/ocaml/libs/log/logs.ml new file mode 100644 index 0000000..2a40896 --- /dev/null +++ b/tools/ocaml/libs/log/logs.ml @@ -0,0 +1,197 @@ +(* + * 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 publis= hed + * 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 =3D +{ + 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 =3D Hashtbl.create 10 + +(* default logger that everything that doesn't have a key in __lop_mappi= ng get send *) +let __default_logger =3D { debug =3D []; info =3D []; warn =3D []; error= =3D []; no_default =3D 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 =3D Hashtbl.create 32 + +let get_or_open logstring =3D + if Hashtbl.mem __all_loggers logstring then + Hashtbl.find __all_loggers logstring + else + let t =3D 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 lev= el to + * the logger you want to. + *) +let add key logger =3D + let kl =3D { + debug =3D logger; + info =3D logger; + warn =3D logger; + error =3D logger; + no_default =3D false; + } in + Hashtbl.add __log_mapping key kl + +let get_by_level keylog level =3D + 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 =3D + 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 =3D + if not (Hashtbl.mem __log_mapping key) then + add key []; + + let keylog =3D Hashtbl.find __log_mapping key in + set_by_level keylog level logger + +(** set default logger *) +let set_default level logger =3D + set_by_level __default_logger level logger + +(** append a logger to the list *) +let append key level logger =3D + if not (Hashtbl.mem __log_mapping key) then + add key []; + let keylog =3D Hashtbl.find __log_mapping key in + let loggers =3D 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 =3D + let loggers =3D get_by_level __default_logger level in + set_by_level __default_logger level (loggers @ [ logger ]) + +(** reopen all logger open *) +let reopen () =3D + 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 () =3D + let list_sort_uniq l =3D + let oldprev =3D ref "" and prev =3D ref "" in + List.fold_left (fun a k -> + oldprev :=3D !prev; + prev :=3D k; + if k =3D !oldprev then a else k :: a) [] + (List.sort compare l) + in + let flatten_keylogger v =3D + list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in + let oldkeys =3D Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in + let usedkeys =3D Hashtbl.fold (fun k v a -> + (flatten_keylogger v) @ a) + __log_mapping (flatten_keylogger __default_logger) in + let usedkeys =3D 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 =3D + try + let keylog =3D Hashtbl.find __log_mapping key in + set_by_level keylog level []; + reclaim () + with Not_found -> + () + +(** clear a specific default level *) +let clear_default level =3D + set_default level []; + reclaim () + +(** reset all the loggers to the specified logger *) +let reset_all logger =3D + 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 mappi= ng. + * if the logger doesn't exist, assume nil logger. + *) +let log key level ?(extra=3D"") (fmt: ('a, unit, string, unit) format4):= 'a =3D + let keylog =3D + if Hashtbl.mem __log_mapping key then + let keylog =3D Hashtbl.find __log_mapping key in + if keylog.no_default =3D false && + get_by_level keylog level =3D [] then + __default_logger + else + keylog + else + __default_logger in + let loggers =3D get_by_level keylog level in + match loggers with + | [] -> Printf.kprintf ignore fmt + | _ -> + let l =3D List.fold_left (fun acc logger ->=09 + try get_or_open logger :: acc + with _ -> acc + ) [] loggers in + let l =3D 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) =3D + log t Log.Debug ?extra fmt +let info t ?extra (fmt: ('a , unit, string, unit) format4) =3D + log t Log.Info ?extra fmt +let warn t ?extra (fmt: ('a , unit, string, unit) format4) =3D + log t Log.Warn ?extra fmt +let error t ?extra (fmt: ('a , unit, string, unit) format4) =3D + log t Log.Error ?extra fmt diff --git a/tools/ocaml/libs/log/logs.mli b/tools/ocaml/libs/log/logs.ml= i new file mode 100644 index 0000000..76e10db --- /dev/null +++ b/tools/ocaml/libs/log/logs.mli @@ -0,0 +1,46 @@ +(* + * 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 publis= hed + * 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 =3D { + 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 diff --git a/tools/ocaml/libs/log/syslog.ml b/tools/ocaml/libs/log/syslog= .ml new file mode 100644 index 0000000..2b417da --- /dev/null +++ b/tools/ocaml/libs/log/syslog.ml @@ -0,0 +1,26 @@ +(* + * 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 publis= hed + * 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 =3D Emerg | Alert | Crit | Err | Warning | Notice | Info | De= bug +type options =3D Cons | Ndelay | Nowait | Odelay | Perror | Pid +type facility =3D 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 =3D "stub_= openlog" *) +external log : facility -> level -> string -> unit =3D "stub_syslog" +external close : unit -> unit =3D "stub_closelog" diff --git a/tools/ocaml/libs/log/syslog.mli b/tools/ocaml/libs/log/syslo= g.mli new file mode 100644 index 0000000..425f42a --- /dev/null +++ b/tools/ocaml/libs/log/syslog.mli @@ -0,0 +1,41 @@ +(* + * 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 publis= hed + * 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 =3D Emerg | Alert | Crit | Err | Warning | Notice | Info | De= bug +type options =3D Cons | Ndelay | Nowait | Odelay | Perror | Pid +type facility =3D + 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 =3D "stub_syslog" +external close : unit -> unit =3D "stub_closelog" diff --git a/tools/ocaml/libs/log/syslog_stubs.c b/tools/ocaml/libs/log/s= yslog_stubs.c new file mode 100644 index 0000000..965610a --- /dev/null +++ b/tools/ocaml/libs/log/syslog_stubs.c @@ -0,0 +1,73 @@ +/* + * 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 publis= hed + * 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[] =3D { + LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, + LOG_NOTICE, LOG_INFO, LOG_DEBUG +}; + +static int __syslog_options_table[] =3D { + LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID +}; + +static int __syslog_facility_table[] =3D { + 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 refere= nce + to the 'ident' string and keep it long-term. This means we cannot jus= t 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 =3D caml_convert_flag_list(option, __syslog_options_table); + c_facility =3D __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 =3D __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); +} diff --git a/tools/ocaml/libs/mmap/META.in b/tools/ocaml/libs/mmap/META.i= n new file mode 100644 index 0000000..1d71548 --- /dev/null +++ b/tools/ocaml/libs/mmap/META.in @@ -0,0 +1,4 @@ +version =3D "@VERSION@" +description =3D "Mmap interface extension" +archive(byte) =3D "mmap.cma" +archive(native) =3D "mmap.cmxa" diff --git a/tools/ocaml/libs/mmap/Makefile b/tools/ocaml/libs/mmap/Makef= ile new file mode 100644 index 0000000..bd8ab43 --- /dev/null +++ b/tools/ocaml/libs/mmap/Makefile @@ -0,0 +1,27 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +OBJS =3D mmap +INTF =3D $(foreach obj, $(OBJS),$(obj).cmi) +LIBS =3D mmap.cma mmap.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +mmap_OBJS =3D $(OBJS) +mmap_C_OBJS =3D mmap_stubs +OCAML_LIBRARY =3D mmap + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -ldconf ignore mmap META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove mmap + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/mmap/mmap.ml b/tools/ocaml/libs/mmap/mmap.m= l new file mode 100644 index 0000000..44b67c8 --- /dev/null +++ b/tools/ocaml/libs/mmap/mmap.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 publis= hed + * 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 =3D RDONLY | WRONLY | RDWR +type mmap_map_flag =3D 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 =3D "stub_mmap_init" +external unmap: mmap_interface -> unit =3D "stub_mmap_final" +(* read: interface -> start -> length -> data *) +external read: mmap_interface -> int -> int -> string =3D "stub_mmap_rea= d" +(* write: interface -> data -> start -> length -> unit *) +external write: mmap_interface -> string -> int -> int -> unit =3D "stub= _mmap_write" +(* getpagesize: unit -> size of page *) +external getpagesize: unit -> int =3D "stub_mmap_getpagesize" diff --git a/tools/ocaml/libs/mmap/mmap.mli b/tools/ocaml/libs/mmap/mmap.= mli new file mode 100644 index 0000000..8f92ed6 --- /dev/null +++ b/tools/ocaml/libs/mmap/mmap.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 publis= hed + * 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 =3D RDONLY | WRONLY | RDWR +type mmap_map_flag =3D SHARED | PRIVATE + +external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> in= t -> int + -> mmap_interface =3D "stub_mmap_init" +external unmap : mmap_interface -> unit =3D "stub_mmap_final" +external read : mmap_interface -> int -> int -> string =3D "stub_mmap_re= ad" +external write : mmap_interface -> string -> int -> int -> unit + =3D "stub_mmap_write" + +external getpagesize : unit -> int =3D "stub_mmap_getpagesize" diff --git a/tools/ocaml/libs/mmap/mmap_stubs.c b/tools/ocaml/libs/mmap/m= map_stubs.c new file mode 100644 index 0000000..e32cef6 --- /dev/null +++ b/tools/ocaml/libs/mmap/mmap_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 publis= hed + * 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 =3D len; + intf->addr =3D mmap(NULL, len, pflag, mflag, fd, offset); + return (intf->addr =3D=3D 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 =3D PROT_READ; break; + case 1: c_pflag =3D PROT_WRITE; break; + case 2: c_pflag =3D PROT_READ|PROT_WRITE; break; + default: caml_invalid_argument("protectiontype"); + } + + switch (Int_val(mflag)) { + case 0: c_mflag =3D MAP_SHARED; break; + case 1: c_mflag =3D MAP_PRIVATE; break; + default: caml_invalid_argument("maptype"); + } + + result =3D 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 =3D GET_C_STRUCT(interface); + if (intf->addr !=3D MAP_FAILED) + munmap(intf->addr, intf->len); + intf->addr =3D 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 =3D Int_val(start); + c_len =3D Int_val(len); + intf =3D 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 =3D 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 =3D Int_val(start); + c_len =3D Int_val(len); + intf =3D 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 =3D Val_int(getpagesize()); + CAMLreturn(data); +} diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/m= map_stubs.h new file mode 100644 index 0000000..65e4239 --- /dev/null +++ b/tools/ocaml/libs/mmap/mmap_stubs.h @@ -0,0 +1,33 @@ +/* + * 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 publis= hed + * 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. + */ + +#ifndef C_MMAP_H +#define C_MMAP_H + +#include +#include +#include +#include +#include +#include + +struct mmap_interface +{ + void *addr; + int len; +}; + +#endif diff --git a/tools/ocaml/libs/stdext/META.in b/tools/ocaml/libs/stdext/ME= TA.in new file mode 100644 index 0000000..bc67d1e --- /dev/null +++ b/tools/ocaml/libs/stdext/META.in @@ -0,0 +1,5 @@ +version =3D "@VERSION@" +description =3D "Stdext - Common stdlib extensions" +requires =3D "unix,uuid" +archive(byte) =3D "stdext.cma" +archive(native) =3D "stdext.cmxa" diff --git a/tools/ocaml/libs/stdext/Makefile b/tools/ocaml/libs/stdext/M= akefile new file mode 100644 index 0000000..7c51c71 --- /dev/null +++ b/tools/ocaml/libs/stdext/Makefile @@ -0,0 +1,43 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +OCAMLINCLUDE +=3D -I ../uuid + +OCAML_TEST_INC =3D -I $(shell ocamlfind query oUnit) +OCAML_TEST_LIB =3D $(shell ocamlfind query oUnit)/oUnit.cmxa + +OBJS =3D filenameext stringext hashtblext listext pervasiveext threadext= ring qring trie opt unixext bigbuffer vIO varmap eventloop +INTF =3D $(foreach obj, $(OBJS),$(obj).cmi) +LIBS =3D stdext.cma stdext.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +stdext_OBJS =3D $(OBJS) +stdext_C_OBJS =3D unixext_stubs + +OCAML_LIBRARY =3D stdext + +## OBJS +threadext.cmo: threadext.ml + $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -thread -c -o $@ $<,MLC,= $@) + +threadext.cmi: threadext.mli + $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -thread -c -o $@ $<,MLI,= $@) + +threadext.cmx: threadext.ml + $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<,= MLOPT,$@) + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -ldconf ignore stdext META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove stdext + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/stdext/bigbuffer.ml b/tools/ocaml/libs/stde= xt/bigbuffer.ml new file mode 100644 index 0000000..b2ac54b --- /dev/null +++ b/tools/ocaml/libs/stdext/bigbuffer.ml @@ -0,0 +1,90 @@ +(* + * 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 publis= hed + * 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 t =3D { + mutable cells: string option array; + mutable index: int64; +} + +let cell_size =3D 4096 +let default_array_len =3D 16 + +let make () =3D { cells =3D Array.make default_array_len None; index =3D= 0L } + +let length bigbuf =3D bigbuf.index + +let rec append_substring bigbuf s offset len =3D + let array_offset =3D Int64.to_int (Int64.div bigbuf.index (Int64.of_int= cell_size)) in + let cell_offset =3D Int64.to_int (Int64.rem bigbuf.index (Int64.of_int = cell_size)) in + + if Array.length bigbuf.cells <=3D array_offset then ( + (* we need to reallocate the array *) + bigbuf.cells <- Array.append bigbuf.cells (Array.make default_array_le= n None) + ); + + let buf =3D match bigbuf.cells.(array_offset) with + | None -> + let newbuf =3D String.create cell_size in + bigbuf.cells.(array_offset) <- Some newbuf; + newbuf + | Some buf -> + buf + in + if len + cell_offset <=3D cell_size then ( + String.blit s offset buf cell_offset len; + bigbuf.index <- Int64.add bigbuf.index (Int64.of_int len); + ) else ( + let rlen =3D cell_size - cell_offset in + String.blit s offset buf cell_offset rlen; + bigbuf.index <- Int64.add bigbuf.index (Int64.of_int rlen); + append_substring bigbuf s (offset + rlen) (len - rlen) + ); + () + +let to_fct bigbuf f =3D + let array_offset =3D Int64.to_int (Int64.div bigbuf.index (Int64.of_int= cell_size)) in + let cell_offset =3D Int64.to_int (Int64.rem bigbuf.index (Int64.of_int = cell_size)) in + + (* copy all complete cells *) + for i =3D 0 to array_offset - 1 + do + match bigbuf.cells.(i) with + | None -> (* ?!?!? *) () + | Some cell -> f cell + done; + + (* copy last cell *) + begin match bigbuf.cells.(array_offset) with + | None -> (* ?!?!?! *) () + | Some cell -> f (String.sub cell 0 cell_offset) + end; + () + +let to_string bigbuf =3D + if bigbuf.index > (Int64.of_int Sys.max_string_length) then + failwith "cannot allocate string big enough"; + + let dest =3D String.create (Int64.to_int bigbuf.index) in + let destoff =3D ref 0 in + to_fct bigbuf (fun s -> + let len =3D String.length s in + String.blit s 0 dest !destoff len; + destoff :=3D !destoff + len + ); + dest + +let to_stream bigbuf outchan =3D + to_fct bigbuf (fun s -> output_string outchan s) diff --git a/tools/ocaml/libs/stdext/bigbuffer.mli b/tools/ocaml/libs/std= ext/bigbuffer.mli new file mode 100644 index 0000000..f40fd09 --- /dev/null +++ b/tools/ocaml/libs/stdext/bigbuffer.mli @@ -0,0 +1,22 @@ +(* + * 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 publis= hed + * 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 t +val make : unit -> t +val length : t -> int64 +val append_substring : t -> string -> int -> int -> unit +val to_fct : t -> (string -> unit) -> unit +val to_string : t -> string +val to_stream : t -> out_channel -> unit diff --git a/tools/ocaml/libs/stdext/eventloop.ml b/tools/ocaml/libs/stde= xt/eventloop.ml new file mode 100644 index 0000000..8d69a4c --- /dev/null +++ b/tools/ocaml/libs/stdext/eventloop.ml @@ -0,0 +1,357 @@ +(* + * Copyright (C) 2009 Citrix Ltd. + * Author Prashanth Mundkur + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) + +let verbose =3D ref false + +let dbg fmt =3D + let logger s =3D if !verbose then Printf.printf "%s\n%!" s in + Printf.ksprintf logger fmt + +module ConnMap =3D Map.Make (struct type t =3D Unix.file_descr let compa= re =3D compare end) +=09 +(* A module that supports finding a timer by handle as well as by expiry= time. *) +module Timers =3D struct + + type 'a entry =3D + { + handle : int; + mutable expires_at: float;=20 + value: 'a; + } + + module Timers_by_expiry =3D Map.Make (struct type t =3D float let compa= re =3D compare end) + + type 'a t =3D + { + mutable by_expiry: (('a entry) list) Timers_by_expiry.t; + } + + let create () =3D { by_expiry =3D Timers_by_expiry.empty } + + let is_empty t =3D Timers_by_expiry.is_empty t.by_expiry + + let next_handle =3D ref 0 + + (** inserts an existing (but not inserted) entry in the map *) + let submit_timer t at e =3D=20 + e.expires_at <- at; + let es =3D try Timers_by_expiry.find e.expires_at t.by_expiry with Not= _found -> [] in + t.by_expiry <- Timers_by_expiry.add e.expires_at (e :: es) t.by_expiry + =09 + let add_timer t at v =3D + incr next_handle; + let e =3D { handle =3D !next_handle; expires_at =3D at; value =3D v } = in + submit_timer t at e; + e + + let remove_timer t entry =3D + let handle =3D entry.handle in + let es =3D Timers_by_expiry.find entry.expires_at t.by_expiry in + let es =3D List.filter (fun e' -> e'.handle <> handle) es in + t.by_expiry <- (match es with + | [] -> Timers_by_expiry.remove entry.expires_at t.by_expiry + | _ -> Timers_by_expiry.add entry.expires_at es t.by_expiry + ) + + exception Found of float + + (* Should only be called on a non-empty Timer set; otherwise, + Not_found is raised. *) + let get_first_expiry_time t =3D + try + (* This should give the earliest expiry time, + since iteration is done in increasing order. *) + Timers_by_expiry.iter (fun tim -> raise (Found tim)) t.by_expiry; + raise Not_found + with Found tim -> tim + + (* Extracts the timers for time t, and return a list of values for thos= e timers *) + let extract_timers_at t tim =3D + try + let es =3D Timers_by_expiry.find tim t.by_expiry in + t.by_expiry <- Timers_by_expiry.remove tim t.by_expiry; + List.map (fun e -> e.value) es + with Not_found -> [] + +end + +type error =3D Unix.error * string * string + +type handle =3D Unix.file_descr + +let handle_compare =3D compare +let handle_hash h =3D Unixext.int_of_file_descr h + +type conn_status =3D + | Connecting + | Listening + | Connected + +type conn_callbacks =3D +{ + accept_callback : t -> handle -> Unix.file_descr -> Unix.sockaddr -> un= it; + connect_callback : t -> handle -> unit; + error_callback : t -> handle -> error -> unit; + recv_ready_callback : t -> handle -> Unix.file_descr -> unit; + send_ready_callback : t -> handle -> Unix.file_descr -> unit; +} + +and conn_state =3D +{ + mutable callbacks : conn_callbacks; + mutable status : conn_status; + mutable send_enabled : bool; + mutable recv_enabled : bool; +} + +and t =3D +{ + mutable conns: conn_state ConnMap.t; + mutable timers: (unit -> unit) Timers.t; + (* select state *) + readers: Unixext.Fdset.t; + writers: Unixext.Fdset.t; + excepts: Unixext.Fdset.t; + (* dispatch state *) + mutable d_readers: Unixext.Fdset.t; + mutable d_writers: Unixext.Fdset.t; + (** Unix.gettimeofday() at the time the loop iteration started *) + mutable current_time: float; +} + +let create () =3D +{ conns =3D ConnMap.empty; + timers =3D Timers.create (); + readers =3D Unixext.Fdset.create (); + writers =3D Unixext.Fdset.create (); + excepts =3D Unixext.Fdset.create (); + d_readers =3D Unixext.Fdset.create (); + d_writers =3D Unixext.Fdset.create (); + current_time =3D 0.0; +} + +(* connections *) + +let register_conn t fd ?(enable_send=3Dfalse) ?(enable_recv=3Dtrue) call= backs =3D + let conn_state =3D { callbacks =3D callbacks; + status =3D Connected; + send_enabled =3D enable_send; + recv_enabled =3D enable_recv; + } + in + t.conns <- ConnMap.add fd conn_state t.conns; + Unix.set_nonblock fd; + if conn_state.recv_enabled then + Unixext.Fdset.set t.readers fd; + if conn_state.send_enabled then + Unixext.Fdset.set t.writers fd; + fd + +let remove_conn t handle =3D + Unixext.Fdset.clear t.readers handle; + Unixext.Fdset.clear t.writers handle; + (* Also remove this handle from the set we might be + dispatching over. *) + Unixext.Fdset.clear t.d_readers handle; + Unixext.Fdset.clear t.d_writers handle; + t.conns <- ConnMap.remove handle t.conns + +let get_fd t handle =3D handle + +let connect t handle addr =3D + let conn_state =3D ConnMap.find handle t.conns in + conn_state.status <- Connecting; + try + Unix.connect handle addr; + conn_state.status <- Connected; + conn_state.callbacks.connect_callback t handle + with + | Unix.Unix_error (Unix.EINPROGRESS, _, _) -> + Unixext.Fdset.set t.readers handle; + Unixext.Fdset.set t.writers handle + | Unix.Unix_error (ec, f, s) -> + conn_state.callbacks.error_callback t handle (ec, f, s) + +let listen t handle =3D + let conn_state =3D ConnMap.find handle t.conns in + Unix.listen handle 5; + Unixext.Fdset.set t.readers handle; + conn_state.recv_enabled <- true; + conn_state.status <- Listening + +let enable_send t handle =3D + let conn_state =3D ConnMap.find handle t.conns in + conn_state.send_enabled <- true; + if conn_state.status =3D Connected then + Unixext.Fdset.set t.writers handle + +let disable_send t handle =3D + let conn_state =3D ConnMap.find handle t.conns in + conn_state.send_enabled <- false; + if conn_state.status =3D Connected then + Unixext.Fdset.clear t.writers handle + +let enable_recv t handle =3D + let conn_state =3D ConnMap.find handle t.conns in + conn_state.recv_enabled <- true; + if conn_state.status =3D Connected then + Unixext.Fdset.set t.readers handle + +let disable_recv t handle =3D + let conn_state =3D ConnMap.find handle t.conns in + conn_state.recv_enabled <- false; + if conn_state.status =3D Connected then + Unixext.Fdset.clear t.readers handle + +let set_callbacks t handle callbacks =3D + let conn_state =3D ConnMap.find handle t.conns in + conn_state.callbacks <- callbacks + +let has_connections t =3D not (ConnMap.is_empty t.conns) + +(* timers *) + +type timer =3D (unit -> unit) Timers.entry + +let start_timer t time_offset_sec cb =3D + let at =3D Unix.gettimeofday () +. time_offset_sec in + Timers.add_timer t.timers at cb + +let start_timer_asap t cb =3D + Timers.add_timer t.timers t.current_time cb + +let start_periodic_timer t time_offset_sec period cb =3D + let orig_timer =3D ref (None: timer option) in + let resubmit_timer_closure () =3D=20 + let orig_timer =3D match !orig_timer with None -> raise Not_found | So= me x -> x in + Timers.submit_timer t.timers (t.current_time +. period) orig_timer; + cb (); (* invoke the user's callback *) + in + let new_timer =3D start_timer t time_offset_sec resubmit_timer_closure = in + orig_timer :=3D Some (new_timer); + new_timer +=09 +let cancel_timer t timer =3D + Timers.remove_timer t.timers timer + +let timer_compare tim1 tim2 =3D compare tim1.Timers.handle tim2.Timers.h= andle +let timer_hash tim =3D tim.Timers.handle + +let has_timers t =3D not (Timers.is_empty t.timers) + +(* event dispatch *) + +let dispatch_read t fd cs =3D + match cs.status with + | Connecting -> + (match Unix.getsockopt_error fd with + | None -> + cs.status <- Connected; + if not cs.recv_enabled then + Unixext.Fdset.clear t.readers fd; + if not cs.send_enabled then + Unixext.Fdset.clear t.writers fd; + cs.callbacks.connect_callback t fd + | Some err -> + cs.callbacks.error_callback t fd (err, "connect", "") + ) + | Listening -> + (try + let afd, aaddr =3D Unix.accept fd in + cs.callbacks.accept_callback t fd afd aaddr + with + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + | Unix.Unix_error (Unix.ECONNABORTED, _, _) + | Unix.Unix_error (Unix.EINTR, _, _) + -> () + | Unix.Unix_error (ec, f, s) -> + cs.callbacks.error_callback t fd (ec, f, s) + ) + | Connected -> + if cs.recv_enabled + then cs.callbacks.recv_ready_callback t fd fd + else Unixext.Fdset.clear t.readers fd + +let dispatch_write t fd cs =3D + match cs.status with + | Connecting -> + (match Unix.getsockopt_error fd with + | None -> + cs.status <- Connected; + if not cs.recv_enabled then + Unixext.Fdset.clear t.readers fd; + if not cs.send_enabled then + Unixext.Fdset.clear t.writers fd; + cs.callbacks.connect_callback t fd + | Some err -> + cs.callbacks.error_callback t fd (err, "connect", "") + ) + | Listening -> + (* This should never happen, since listening sockets + are not set for writing. But, to avoid a busy + select loop in case this socket keeps firing for + writes, we disable the write watch. *) + Unixext.Fdset.clear t.writers fd + | Connected -> + if cs.send_enabled + then cs.callbacks.send_ready_callback t fd fd + else Unixext.Fdset.clear t.writers fd + +let dispatch_timers t =3D + let break =3D ref false in + while ((not (Timers.is_empty t.timers)) && (not !break)) do + let first_expired =3D Timers.get_first_expiry_time t.timers in + if first_expired > t.current_time then + break :=3D true + else begin + let cbs =3D Timers.extract_timers_at t.timers first_expired in + List.iter (fun cb -> cb ()) cbs + end + done + +let dispatch t interval =3D + t.current_time <- Unix.gettimeofday (); + let interval =3D + if Timers.is_empty t.timers then interval + else + (* the blocking interval for select is the + smaller of the specified interval, and the + interval before which the earliest timer + expires. + *) + let block_until =3D if interval > 0.0 then t.current_time +. interval= else t.current_time in + let first_expiry =3D Timers.get_first_expiry_time t.timers in + let block_until =3D (if first_expiry < block_until then first_expiry = else block_until) in + let interval =3D block_until -. t.current_time in + if interval < 0.0 then 0.0 else interval + in + let events =3D + try Some (Unixext.Fdset.select t.readers t.writers t.excepts interval) + with Unix.Unix_error (Unix.EINTR, _, _) -> None + in + (match events with + | Some (r, w, _) -> + (* Store dispatch set for remove_conn. *) + t.d_readers <- r; + t.d_writers <- w; + ConnMap.iter (fun fd cs -> + if Unixext.Fdset.is_set t.d_readers fd then + dispatch_read t fd cs; + if Unixext.Fdset.is_set t.d_writers fd then + dispatch_write t fd cs + ) t.conns + | None -> () + ); + dispatch_timers t diff --git a/tools/ocaml/libs/stdext/eventloop.mli b/tools/ocaml/libs/std= ext/eventloop.mli new file mode 100644 index 0000000..6e57991 --- /dev/null +++ b/tools/ocaml/libs/stdext/eventloop.mli @@ -0,0 +1,100 @@ +(* + * Copyright (C) 2009 Citrix Ltd. + * Author Prashanth Mundkur + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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 t + +val create : unit -> t + +(* connections *) + +type handle +type error =3D Unix.error * string * string + +type conn_callbacks =3D +{ + accept_callback : t -> handle -> Unix.file_descr -> Unix.sockaddr -> un= it; + connect_callback : t -> handle -> unit; + error_callback : t -> handle -> error -> unit; + recv_ready_callback : t -> handle -> Unix.file_descr -> unit; + send_ready_callback : t -> handle -> Unix.file_descr -> unit; +} + +(* this is to allow collections indexed by connection handles. *) +val handle_compare : handle -> handle -> int +val handle_hash : handle -> int + +(* Connection Management *) + +(* by default, notifications for incoming data are disabled, and enabled= for all others. *) +val register_conn : t -> Unix.file_descr -> ?enable_send:bool -> ?enable= _recv:bool -> conn_callbacks -> handle +val remove_conn : t -> handle -> unit +val get_fd : t -> handle -> Unix.file_descr + +val connect : t -> handle -> Unix.sockaddr -> unit +val listen : t -> handle -> unit + +val enable_send : t -> handle -> unit +val disable_send : t -> handle -> unit + +val enable_recv : t -> handle -> unit +val disable_recv : t -> handle -> unit + +val set_callbacks : t -> handle -> conn_callbacks -> unit + +(* Timers *) + +type timer + +(** Starts a timer that will fire once only, and return a handle to + this timer, so that it can be cancelled before it fires. The timer + is automatically cancelled once it has fired. +*) +val start_timer : t -> float (* offset, secs *) -> (unit -> unit) -> tim= er + +(** Enqueues an event that will be invoked in the next event loop + iteration. This behaves as if a timer had been set to fire with + "now" as the trigger time. +*) +val start_timer_asap : t -> (unit -> unit) -> timer + +(** Starts a timer that will fire periodically. The timer needs + explicit cancellation. =09 +*) +val start_periodic_timer: t -> float (* offset from current time, secs *= ) -> float (* period, secs *) -> (unit -> unit) -> timer + +(** Allows cancelling a timer before it fires. Non-periodic timers + are implicitly cancelled when their timer fires. Periodic timers + however need explicit cancellation. +*) +val cancel_timer : t -> timer -> unit + +(** Utilities for storing timer handles in data structures. *) +val timer_compare: timer -> timer -> int +val timer_hash: timer -> int + +(* Event Dispatch *) + +(* dispatch t intvl will block at most for intvl seconds, and dispatch + any retrieved events and expired timers. +*) +val dispatch : t -> float -> unit + + +(* Event loop management *) + +val has_timers : t -> bool + +val has_connections : t -> bool diff --git a/tools/ocaml/libs/stdext/file.ml b/tools/ocaml/libs/stdext/fi= le.ml new file mode 100644 index 0000000..1b6b42d --- /dev/null +++ b/tools/ocaml/libs/stdext/file.ml @@ -0,0 +1,34 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) + +let write_string file mode s =3D + let fn_write_string fd =3D Unixext.really_write fd s 0 (String.length s= ) in + Unixext.with_file file (Unix.O_WRONLY :: mode) 0o640 fn_write_string + +let write_fn file mode fn =3D + let fn_write_fn fd =3D + let quit =3D ref false in + while not !quit + do + let s =3D fn () in + if s =3D "" then + quit :=3D true + else + Unixext.really_write fd s 0 (String.length s) + done + in + Unixext.with_file file (Unix.O_WRONLY :: mode) 0o640 fn_write_fn diff --git a/tools/ocaml/libs/stdext/file.mli b/tools/ocaml/libs/stdext/f= ile.mli new file mode 100644 index 0000000..d3f50e7 --- /dev/null +++ b/tools/ocaml/libs/stdext/file.mli @@ -0,0 +1,18 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +val write_string : string -> Unix.open_flag list -> string -> unit +val write_fn : string -> Unix.open_flag list -> (unit -> string) -> unit diff --git a/tools/ocaml/libs/stdext/filenameext.ml b/tools/ocaml/libs/st= dext/filenameext.ml new file mode 100644 index 0000000..8e4379a --- /dev/null +++ b/tools/ocaml/libs/stdext/filenameext.ml @@ -0,0 +1,33 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) + +(** Makes a new file in the same directory as 'otherfile' *) +let temp_file_in_dir otherfile =3D + let base_dir =3D Filename.dirname otherfile in + let rec keep_trying () =3D=20 + try=20 + let uuid =3D Uuid.to_string (Uuid.make_uuid ()) in + let newfile =3D base_dir ^ "/" ^ uuid in + Unix.close (Unix.openfile newfile [Unix.O_CREAT; Unix.O_TRUNC; Uni= x.O_EXCL] 0o600); + newfile + with + Unix.Unix_error (Unix.EEXIST, _, _) -> keep_trying () + in + keep_trying () + + =20 +=09 diff --git a/tools/ocaml/libs/stdext/filenameext.mli b/tools/ocaml/libs/s= tdext/filenameext.mli new file mode 100644 index 0000000..db4d76e --- /dev/null +++ b/tools/ocaml/libs/stdext/filenameext.mli @@ -0,0 +1,17 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +val temp_file_in_dir : string -> string diff --git a/tools/ocaml/libs/stdext/hashtblext.ml b/tools/ocaml/libs/std= ext/hashtblext.ml new file mode 100644 index 0000000..de0f2ce --- /dev/null +++ b/tools/ocaml/libs/stdext/hashtblext.ml @@ -0,0 +1,38 @@ +(* + * 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 publis= hed + * 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. + *) +module Hashtbl =3D struct include Hashtbl + +let to_list tbl =3D + Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl [] + +let fold_keys tbl =3D + Hashtbl.fold (fun k v acc -> k :: acc) tbl [] + +let fold_values tbl =3D + Hashtbl.fold (fun k v acc -> v :: acc) tbl [] + +let add_empty tbl k v =3D + if not (Hashtbl.mem tbl k) then + Hashtbl.add tbl k v + +let add_list tbl l =3D + List.iter (fun (k, v) -> Hashtbl.add tbl k v) l + +let of_list l =3D + let tbl =3D Hashtbl.create (List.length l) in + add_list tbl l; + tbl +end diff --git a/tools/ocaml/libs/stdext/hashtblext.mli b/tools/ocaml/libs/st= dext/hashtblext.mli new file mode 100644 index 0000000..a117146 --- /dev/null +++ b/tools/ocaml/libs/stdext/hashtblext.mli @@ -0,0 +1,77 @@ +(* + * 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 publis= hed + * 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. + *) +module Hashtbl : + sig + type ('a, 'b) t =3D ('a, 'b) Hashtbl.t + val create : int -> ('a, 'b) t + val clear : ('a, 'b) t -> unit + val add : ('a, 'b) t -> 'a -> 'b -> unit + val copy : ('a, 'b) t -> ('a, 'b) t + val find : ('a, 'b) t -> 'a -> 'b + val find_all : ('a, 'b) t -> 'a -> 'b list + val mem : ('a, 'b) t -> 'a -> bool + val remove : ('a, 'b) t -> 'a -> unit + val replace : ('a, 'b) t -> 'a -> 'b -> unit + val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit + val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c + val length : ('a, 'b) t -> int + module type HashedType =3D + sig type t val equal : t -> t -> bool val hash : t -> int end + module type S =3D + sig + type key + type 'a t + val create : int -> 'a t + val clear : 'a t -> unit + val copy : 'a t -> 'a t + val add : 'a t -> key -> 'a -> unit + val remove : 'a t -> key -> unit + val find : 'a t -> key -> 'a + val find_all : 'a t -> key -> 'a list + val replace : 'a t -> key -> 'a -> unit + val mem : 'a t -> key -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val length : 'a t -> int + end + module Make : + functor (H : HashedType) -> + sig + type key =3D H.t + type 'a t =3D 'a Hashtbl.Make(H).t + val create : int -> 'a t + val clear : 'a t -> unit + val copy : 'a t -> 'a t + val add : 'a t -> key -> 'a -> unit + val remove : 'a t -> key -> unit + val find : 'a t -> key -> 'a + val find_all : 'a t -> key -> 'a list + val replace : 'a t -> key -> 'a -> unit + val mem : 'a t -> key -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val length : 'a t -> int + end + val hash : 'a -> int + external hash_param : int -> int -> 'a -> int =3D "caml_hash_univ_pa= ram" + "noalloc" + val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list + val fold_keys : ('a, 'b) Hashtbl.t -> 'a list + val fold_values : ('a, 'b) Hashtbl.t -> 'b list + val add_empty : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit + val add_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit + val of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t + end diff --git a/tools/ocaml/libs/stdext/listext.ml b/tools/ocaml/libs/stdext= /listext.ml new file mode 100644 index 0000000..3825add --- /dev/null +++ b/tools/ocaml/libs/stdext/listext.ml @@ -0,0 +1,27 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +module List =3D struct include List + +let iteri f l =3D + let i =3D ref 0 in + List.iter (fun x -> f !i x; incr i) l + +let mapi f l =3D + let i =3D ref 0 in + List.map (fun x -> let r =3D f !i x in incr i; r) l + +end diff --git a/tools/ocaml/libs/stdext/listext.mli b/tools/ocaml/libs/stdex= t/listext.mli new file mode 100644 index 0000000..c0dfe6d --- /dev/null +++ b/tools/ocaml/libs/stdext/listext.mli @@ -0,0 +1,65 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +module List : + sig + val length : 'a list -> int + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val rev : 'a list -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val map : ('a -> 'b) -> 'a list -> 'b list + val rev_map : ('a -> 'b) -> 'a list -> 'b list + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list = -> 'a + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c + val for_all : ('a -> bool) -> 'a list -> bool + val exists : ('a -> bool) -> 'a list -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> 'a list -> bool + val memq : 'a -> 'a list -> bool + val find : ('a -> bool) -> 'a list -> 'a + val filter : ('a -> bool) -> 'a list -> 'a list + val find_all : ('a -> bool) -> 'a list -> 'a list + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + val assoc : 'a -> ('a * 'b) list -> 'b + val assq : 'a -> ('a * 'b) list -> 'b + val mem_assoc : 'a -> ('a * 'b) list -> bool + val mem_assq : 'a -> ('a * 'b) list -> bool + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + val iteri : (int -> 'a -> unit) -> 'a list -> unit + + end diff --git a/tools/ocaml/libs/stdext/opt.ml b/tools/ocaml/libs/stdext/opt= .ml new file mode 100644 index 0000000..bb41672 --- /dev/null +++ b/tools/ocaml/libs/stdext/opt.ml @@ -0,0 +1,48 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +let iter f =3D function + | Some x -> f x + | None -> () + +let map f =3D function + | Some x -> Some(f x) + | None -> None + +let default d =3D function + | Some x -> x + | None -> d + +let unbox =3D function + | Some x -> x + | None -> raise Not_found + +let is_boxed =3D function + | Some _ -> true + | None -> false + +let to_list =3D function + | Some x -> [x] + | None -> [] + +let fold_left f accu =3D function + | Some x -> f accu x + | None -> accu + +let fold_right f opt accu =3D + match opt with + | Some x -> f x accu + | None -> accu diff --git a/tools/ocaml/libs/stdext/opt.mli b/tools/ocaml/libs/stdext/op= t.mli new file mode 100644 index 0000000..92b476b --- /dev/null +++ b/tools/ocaml/libs/stdext/opt.mli @@ -0,0 +1,24 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +val iter : ('a -> unit) -> 'a option -> unit +val map : ('a -> 'b) -> 'a option -> 'b option +val default : 'a -> 'a option -> 'a +val unbox : 'a option -> 'a +val is_boxed : 'a option -> bool +val to_list : 'a option -> 'a list +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a +val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b diff --git a/tools/ocaml/libs/stdext/pervasiveext.ml b/tools/ocaml/libs/s= tdext/pervasiveext.ml new file mode 100644 index 0000000..8621c82 --- /dev/null +++ b/tools/ocaml/libs/stdext/pervasiveext.ml @@ -0,0 +1,61 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) + +(** apply the clean_f function after fct function has been called. + * Even if fct raises an exception, clean_f is applied + *) + +let exnhook =3D ref None=20 + +let finally fct clean_f =3D + let result =3D try + fct (); + with + exn -> + (match !exnhook with None -> () | Some f -> f exn); + clean_f (); raise exn in + clean_f (); + result + +type ('a, 'b) either =3D Right of 'a | Left of 'b + +(** if v is not none, apply f on it and return some value else return no= ne. *) +let may f v =3D + match v with Some x -> Some (f x) | None -> None + +(** default value to d if v is none. *)=20 +let default d v =3D + match v with Some x -> x | None -> d + +(** apply f on v if not none *) +let maybe f v =3D + match v with None -> () | Some x -> f x + +(** if bool is false then we intercept and quiten any exception *) +let reraise_if bool fct =3D + try fct () with exn -> if bool then raise exn else () + +(** execute fct ignoring exceptions *) +let ignore_exn fct =3D try fct () with _ -> () + +(* non polymorphic ignore function *) +let ignore_int v =3D let (_: int) =3D v in () +let ignore_int64 v =3D let (_: int64) =3D v in () +let ignore_int32 v =3D let (_: int32) =3D v in () +let ignore_string v =3D let (_: string) =3D v in () +let ignore_float v =3D let (_: float) =3D v in () +let ignore_bool v =3D let (_: bool) =3D v in () diff --git a/tools/ocaml/libs/stdext/pervasiveext.mli b/tools/ocaml/libs/= stdext/pervasiveext.mli new file mode 100644 index 0000000..0d53745 --- /dev/null +++ b/tools/ocaml/libs/stdext/pervasiveext.mli @@ -0,0 +1,30 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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 ('a, 'b) either =3D Right of 'a | Left of 'b +val exnhook : (exn -> unit) option ref +val finally : (unit -> 'a) -> (unit -> 'b) -> 'a +val may : ('a -> 'b) -> 'a option -> 'b option +val default : 'a -> 'a option -> 'a +val maybe : ('a -> unit) -> 'a option -> unit +val reraise_if : bool -> (unit -> unit) -> unit +val ignore_exn : (unit -> unit) -> unit +val ignore_int : int -> unit +val ignore_int32 : int32 -> unit +val ignore_int64 : int64 -> unit +val ignore_string : string -> unit +val ignore_float : float -> unit +val ignore_bool : bool -> unit diff --git a/tools/ocaml/libs/stdext/qring.ml b/tools/ocaml/libs/stdext/q= ring.ml new file mode 100644 index 0000000..859b63b --- /dev/null +++ b/tools/ocaml/libs/stdext/qring.ml @@ -0,0 +1,161 @@ +(* + * 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 publis= hed + * 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 t =3D { + sz: int; + data: string; + mutable prod: int; + mutable cons: int; + mutable pwrap: bool; +} + +exception Data_limit +exception Full + +let make sz =3D { sz =3D sz; data =3D String.create sz; prod =3D 0; cons= =3D 0; pwrap =3D false } + +let to_consume ring =3D + if ring.pwrap then + ring.sz - (ring.cons - ring.prod) + else + ring.prod - ring.cons + +let to_fill ring =3D + if ring.pwrap then + ring.cons - ring.prod + else + ring.cons + (ring.sz - ring.prod) + +let is_full ring =3D ring.pwrap && ring.prod =3D ring.cons +let is_empty ring =3D not ring.pwrap && ring.prod =3D ring.cons + +let adv_cons ring i =3D + ring.cons <- ring.cons + i; + if ring.cons >=3D ring.sz then ( + ring.cons <- ring.cons - ring.sz; + ring.pwrap <- false; + ) + +let adv_prod ring i =3D + ring.prod <- ring.prod + i; + if ring.prod >=3D ring.sz then ( + ring.prod <- ring.prod - ring.sz; + ring.pwrap <- true; + ) + +let consume_internal ring out offset sz =3D + if ring.pwrap then ( + let left_end =3D ring.sz - ring.cons in + if sz > left_end then ( + String.blit ring.data ring.cons out offset left_end; + String.blit ring.data 0 out (offset + left_end) (sz - left_end); + ) else + String.blit ring.data ring.cons out offset sz; + ) else + String.blit ring.data ring.cons out offset sz; + adv_cons ring sz; + () + +let consume_length_max ring sz =3D + let max =3D to_consume ring in + if sz > 0 then + if sz > max then max else sz + else + if max + sz > 0 then max + sz else 0 + +let consume_to ring s offset sz =3D + let sz =3D consume_length_max ring sz in + consume_internal ring s offset sz; + sz + +let consume ring sz =3D + let sz =3D consume_length_max ring sz in + let out =3D String.create sz in + consume_internal ring out 0 sz; + out + +let consume_offset ring i =3D + if i >=3D ring.cons then + consume ring (i - ring.cons) + else + consume ring (ring.sz - ring.cons + i) + +let consume_all ring =3D consume ring (max_int) + +let skip ring n =3D + let max =3D to_consume ring in + let n =3D if n > max then max else n in + adv_cons ring n + +let feed ring data offset len =3D + let max =3D to_fill ring in + if len > max then + raise Data_limit; + if ring.prod + len > ring.sz then ( + let firstblitsz =3D ring.sz - ring.prod in + String.blit data offset ring.data ring.prod firstblitsz; + String.blit data (offset + firstblitsz) ring.data 0 (len - firstblitsz= ); + ) else + String.blit data offset ring.data ring.prod len; + adv_prod ring len; + () + +let feed_data ring data =3D + feed ring data 0 (String.length data) + +(* read and search directly to the qring. + * since we have give a continuous buffer, we limit our read length to t= he + * maximum continous length instead of the full length of the qring left= . + * after the read, piggyback into the new data. + *) +let read_search ring fread fsearch len =3D + let prod =3D ring.prod in + let maxlen =3D + if ring.pwrap + then ring.cons - ring.prod + else ring.sz - ring.prod + in + if maxlen =3D 0 then + raise Full; + let len =3D if maxlen < len then maxlen else len in + let n =3D fread ring.data prod len in + if n > 0 then ( + adv_prod ring n; + fsearch ring.data prod n=20 + ); + n + +let search ring c =3D + let search_from_to f t =3D + let found =3D ref false in + let i =3D ref f in + while not !found && !i < t + do + if ring.data.[!i] =3D c then + found :=3D true + else + incr i + done; + if not !found then + raise Not_found; + !i - f + in + if is_empty ring then + raise Not_found; + if ring.pwrap then ( + try search_from_to ring.cons ring.sz + with Not_found -> search_from_to 0 ring.prod + ) else + search_from_to ring.cons ring.prod diff --git a/tools/ocaml/libs/stdext/qring.mli b/tools/ocaml/libs/stdext/= qring.mli new file mode 100644 index 0000000..9b7f184 --- /dev/null +++ b/tools/ocaml/libs/stdext/qring.mli @@ -0,0 +1,47 @@ +(* + * 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 publis= hed + * 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 t =3D { + sz: int; + data: string; + mutable prod: int; + mutable cons: int; + mutable pwrap: bool; +} + +exception Data_limit +exception Full + +val make : int -> t + +val to_consume : t -> int +val to_fill : t -> int + +val is_full : t -> bool +val is_empty : t -> bool + +val consume_to : t -> string -> int -> int -> int +val consume : t -> int -> string +val consume_offset : t -> int -> string +val consume_all : t -> string +val skip : t -> int -> unit + +val feed : t -> string -> int -> int -> unit +val feed_data : t -> string -> unit +val read_search : t -> (string -> int -> int -> int) + -> (string -> int -> int -> unit) -> int + -> int +val search : t -> char -> int diff --git a/tools/ocaml/libs/stdext/ring.ml b/tools/ocaml/libs/stdext/ri= ng.ml new file mode 100644 index 0000000..4372e22 --- /dev/null +++ b/tools/ocaml/libs/stdext/ring.ml @@ -0,0 +1,109 @@ +(* + * 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 publis= hed + * 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 'a t =3D { size: int; mutable current: int; data: 'a array; } + +(** create a ring structure with @size record. records inited to @initva= l *) +let make size initval =3D + { size =3D size; current =3D size - 1; data =3D Array.create size initv= al; } + +(** length of the ring *) +let length ring =3D ring.size + +(** push into the ring one element *) +let push ring e =3D + ring.current <- ring.current + 1; + if ring.current =3D ring.size then + ring.current <- 0; + ring.data.(ring.current) <- e + +(** get the @ith old element from the ring *) +let peek ring i =3D + if i >=3D ring.size then + raise (Invalid_argument "peek: index"); + let index =3D + let offset =3D ring.current - i in + if offset >=3D 0 then offset else ring.size + offset in + ring.data.(index) + +(** get the top element of the ring *) +let top ring =3D ring.data.(ring.current) + +(** iterate over nb element of the ring, starting from the top *) +let iter_nb ring f nb =3D + if nb > ring.size then + raise (Invalid_argument "iter_nb: nb"); + (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) + for i =3D 0 to nb - 1 + do + f (peek ring i) + done + +(** iter directly on all element without using the index *) +let raw_iter ring f =3D + Array.iter f ring.data + +(** iterate over all element of the ring, starting from the top *) +let iter ring f =3D iter_nb ring f (ring.size) + +(** get array of latest #nb value, starting at the top *) +let get_nb ring nb =3D + if nb > ring.size then + raise (Invalid_argument "get_nb: nb"); + let a =3D Array.create nb (top ring) in + for i =3D 1 to nb - 1 + do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(i) <- peek ring i + done; + a + +let get ring =3D get_nb ring (ring.size) + +(** get list of latest #nb value, starting at the top *) +let get_nb_lst ring nb =3D + if nb > ring.size then + raise (Invalid_argument "get_nb_lst: nb"); + let l =3D ref [] in + for i =3D nb - 1 downto 0 + do + l :=3D peek ring i :: !l + done; + !l + +(** get array of latest #nb value, ending at the top *) +let get_nb_rev ring nb =3D + if nb > ring.size then + raise (Invalid_argument "get_nb_rev: nb"); + let a =3D Array.create nb (top ring) in + for i =3D 1 to nb - 1 + do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(nb - 1 - i) <- peek ring i + done; + a + +(** get list of latest #nb value, ending at the top *) +let get_nb_rev_lst ring nb =3D + if nb > ring.size then + raise (Invalid_argument "get_nb_rev_lst: nb"); + let l =3D ref [] in + for i =3D 0 to nb - 1 + do + l :=3D peek ring i :: !l + done; + !l + diff --git a/tools/ocaml/libs/stdext/ring.mli b/tools/ocaml/libs/stdext/r= ing.mli new file mode 100644 index 0000000..183de02 --- /dev/null +++ b/tools/ocaml/libs/stdext/ring.mli @@ -0,0 +1,30 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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 'a t =3D { size : int; mutable current : int; data : 'a array; } +val make : int -> 'a -> 'a t +val length : 'a t -> int +val push : 'a t -> 'a -> unit +val peek : 'a t -> int -> 'a +val top : 'a t -> 'a +val iter_nb : 'a t -> ('a -> 'b) -> int -> unit +val raw_iter : 'a t -> ('a -> unit) -> unit +val iter : 'a t -> ('a -> 'b) -> unit +val get_nb : 'a t -> int -> 'a array +val get_nb_lst : 'a t -> int -> 'a list +val get : 'a t -> 'a array +val get_nb_rev : 'a t -> int -> 'a array +val get_nb_rev_lst : 'a t -> int -> 'a list diff --git a/tools/ocaml/libs/stdext/stringext.ml b/tools/ocaml/libs/stde= xt/stringext.ml new file mode 100644 index 0000000..e705be3 --- /dev/null +++ b/tools/ocaml/libs/stdext/stringext.ml @@ -0,0 +1,206 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +module String =3D struct include String + +let of_char c =3D String.make 1 c + +let iteri f string =3D + for i =3D 0 to length string - 1 do + f i string.[i] + done + +let fold_right f string accu =3D + let accu =3D ref accu in + for i =3D length string - 1 downto 0 do + accu :=3D f string.[i] !accu + done; + !accu + +let fold_left f accu string =3D + let accu =3D ref accu in + for i =3D 0 to length string - 1 do + accu :=3D f !accu string.[i] + done; + !accu + +let explode string =3D + fold_right (fun h t -> h :: t) string [] + +let implode list =3D + concat "" (List.map of_char list) + +(** True if string 'x' ends with suffix 'suffix' *) +let endswith suffix x =3D + let x_l =3D String.length x and suffix_l =3D String.length suffix in + suffix_l <=3D x_l && String.sub x (x_l - suffix_l) suffix_l =3D suffix + +(** True if string 'x' starts with prefix 'prefix' *) +let startswith prefix x =3D + let x_l =3D String.length x and prefix_l =3D String.length prefix in + prefix_l <=3D x_l && String.sub x 0 prefix_l =3D prefix + +(** Returns true for whitespace characters, false otherwise *) +let isspace =3D function + | ' ' | '\n' | '\r' | '\t' -> true + | _ -> false + +(** Removes all the characters from the ends of a string for which the p= redicate is true *) +let strip predicate string =3D + let rec remove =3D function + | [] -> [] + | c :: cs -> if predicate c then remove cs else c :: cs in + implode (List.rev (remove (List.rev (remove (explode string))))) + +let escaped ?rules string =3D match rules with + | None -> String.escaped string + | Some rules -> + let aux h t =3D (try List.assoc h rules + with Not_found -> of_char h) :: t in + concat "" (fold_right aux string []) + +(** Take a predicate and a string, return a list of strings separated by +runs of characters where the predicate was true *) +let split_f p str =3D + let not_p =3D fun x -> not (p x) in + let rec split_one p acc =3D function + | [] -> List.rev acc, [] + | c :: cs -> if p c then split_one p (c :: acc) cs else List.rev acc, c= :: cs in + + let rec alternate acc drop chars =3D + if chars =3D [] then acc else + begin + let a, b =3D split_one (if drop then p else not_p) [] chars in + alternate (if drop then acc else a :: acc) (not drop) b + end in + List.rev (List.map implode (alternate [] true (explode str))) + +let rec split ?limit:(limit=3D(-1)) c s =3D + let i =3D try String.index s c with Not_found -> -1 in + let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - 1= in + if i =3D -1 || nlimit =3D 0 then + [ s ] + else + let a =3D String.sub s 0 i + and b =3D String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) + +let rtrim s =3D + let n =3D String.length s in + if String.get s (n - 1) =3D '\n' then + String.sub s 0 (n - 1) + else + s + +(** has_substr str sub returns true if sub is a substring of str. Simple= , naive, slow. *) +let has_substr str sub =3D + if String.length sub > String.length str then false else + begin + let result=3Dref false in + for start =3D 0 to (String.length str) - (String.length sub) do + if String.sub str start (String.length sub) =3D sub then result :=3D tr= ue + done; + !result + end + +(** find all occurences of needle in haystack and return all their respe= ctive index *) +let find_all needle haystack =3D + let m =3D String.length needle and n =3D String.length haystack in + + if m > n then + [] + else ( + let i =3D ref 0 and found =3D ref [] in + while !i < (n - m + 1) + do + if (String.sub haystack !i m) =3D needle then ( + found :=3D !i :: !found; + i :=3D !i + m + ) else ( + incr i + ) + done; + List.rev !found + ) + +(* replace all @f substring in @s by @t *) +let replace f t s =3D + let indexes =3D find_all f s in + let n =3D List.length indexes in + if n > 0 then ( + let len_f =3D String.length f and len_t =3D String.length t in + let new_len =3D String.length s + (n * len_t) - (n * len_f) in + let new_s =3D String.make new_len '\000' in + let orig_offset =3D ref 0 and dest_offset =3D ref 0 in + List.iter (fun h -> + let len =3D h - !orig_offset in + String.blit s !orig_offset new_s !dest_offset len; + String.blit t 0 new_s (!dest_offset + len) len_t; + orig_offset :=3D !orig_offset + len + len_f; + dest_offset :=3D !dest_offset + len + len_t; + ) indexes; + String.blit s !orig_offset new_s !dest_offset (String.length s - !orig= _offset); + new_s + ) else + s + +let filter_chars s valid =3D + let badchars =3D ref false in + let buf =3D Buffer.create 0 in + for i =3D 0 to String.length s - 1 + do + if !badchars then ( + if valid s.[i] then + Buffer.add_char buf s.[i] + ) else ( + if not (valid s.[i]) then ( + Buffer.add_substring buf s 0 i; + badchars :=3D true + ) + ) + done; + if !badchars then Buffer.contents buf else s + +let map_unlikely s f =3D + let changed =3D ref false in + let m =3D ref 0 in + let buf =3D Buffer.create 0 in + for i =3D 0 to String.length s - 1 + do + match f s.[i] with + | None -> () + | Some n -> + changed :=3D true; + Buffer.add_substring buf s !m (i - !m); + Buffer.add_string buf n; + m :=3D i + 1 + done; + if !changed then ( + Buffer.add_substring buf s !m (String.length s - !m); + Buffer.contents buf + ) else + s + +let left s n =3D + let l =3D String.length s in + let n =3D min n l in + String.sub s 0 n + +let right s n =3D + let l =3D String.length s in + let p =3D max 0 (l - n) in + String.sub s p (l - p) +end diff --git a/tools/ocaml/libs/stdext/stringext.mli b/tools/ocaml/libs/std= ext/stringext.mli new file mode 100644 index 0000000..4383fd5 --- /dev/null +++ b/tools/ocaml/libs/stdext/stringext.mli @@ -0,0 +1,108 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +module String : + sig + external length : string -> int =3D "%string_length" + external get : string -> int -> char =3D "%string_safe_get" + external set : string -> int -> char -> unit =3D "%string_safe_set" + external create : int -> string =3D "caml_create_string" + val make : int -> char -> string + val copy : string -> string + val sub : string -> int -> int -> string + val fill : string -> int -> int -> char -> unit + val blit : string -> int -> string -> int -> int -> unit + val concat : string -> string list -> string + val iter : (char -> unit) -> string -> unit + val index : string -> char -> int + val rindex : string -> char -> int + val index_from : string -> int -> char -> int + val rindex_from : string -> int -> char -> int + val contains : string -> char -> bool + val contains_from : string -> int -> char -> bool + val rcontains_from : string -> int -> char -> bool + val uppercase : string -> string + val lowercase : string -> string + val capitalize : string -> string + val uncapitalize : string -> string + type t =3D string + val compare : t -> t -> int + external unsafe_get : string -> int -> char =3D "%string_unsafe_get" + external unsafe_set : string -> int -> char -> unit + =3D "%string_unsafe_set" + external unsafe_blit : string -> int -> string -> int -> int -> unit + =3D "caml_blit_string" "noalloc" + external unsafe_fill : string -> int -> int -> char -> unit + =3D "caml_fill_string" "noalloc" + val of_char : char -> string + + (** Iterate over the characters with the character index in argument= *) + val iteri : (int -> char -> 'a) -> string -> unit + + val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a + val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a + + (** Split a string into a list of characters. *) + val explode : string -> char list + + (** Concatenate a list of characters into a string. *) + val implode : char list -> string + + (** True if string 'x' ends with suffix 'suffix' *) + val endswith : string -> string -> bool + + (** True if string 'x' starts with prefix 'prefix' *) + val startswith : string -> string -> bool + + (** True if the character is whitespace *) + val isspace : char -> bool + + (** Removes all the characters from the ends of a string for which t= he predicate is true *) + val strip : (char -> bool) -> string -> string + + (** Backward-compatible string escaping, defaulting to the built-in + OCaml string escaping but allowing an arbitrary mapping from characters + to strings. *) + val escaped : ?rules:(char * string) list -> string -> string + + (** Take a predicate and a string, return a list of strings separate= d by + runs of characters where the predicate was true *) + val split_f : (char -> bool) -> string -> string list + + (** split a string on a single char *) + val split : ?limit:int -> char -> string -> string list + + (** FIXME document me|remove me if similar to strip *) + val rtrim : string -> string + + (** True if sub is a substr of str *) + val has_substr : string -> string -> bool + + (** replace all @f substring in @s by @t *) + val replace : string -> string -> string -> string + + (** filter chars from a string *) + val filter_chars : string -> (char -> bool) -> string + + (** map a string trying to fill the buffer by chunk *) + val map_unlikely : string -> (char -> string option) -> string + + (** get beginning portion of string *) + val left : string -> int -> string + + (** get end portion of string *) + val right : string -> int -> string + end diff --git a/tools/ocaml/libs/stdext/threadext.ml b/tools/ocaml/libs/stde= xt/threadext.ml new file mode 100644 index 0000000..5e96600 --- /dev/null +++ b/tools/ocaml/libs/stdext/threadext.ml @@ -0,0 +1,212 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Anil Madhavapeddy + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) + +module Mutex =3D struct + include Mutex + (** execute the function f with the mutex hold *) + let execute lock f =3D + Mutex.lock lock; + let r =3D begin try f () with exn -> Mutex.unlock lock; raise exn e= nd; in + Mutex.unlock lock; + r +end + +module Condition =3D struct + include Condition + external timedwait : Condition.t -> Mutex.t -> float -> bool =3D "ca= ml_condition_timedwait" +end + +module TMutex =3D struct + +exception Timeout + +type t =3D { mutex: Mutex.t; mutable time: float; post_locking: unit -> = float } + +let init ?(post=3D(fun () -> 0.)) () =3D { mutex =3D Mutex.create (); ti= me =3D 0.; post_locking =3D post } + +let lock ?(retry=3D0) ?(delay=3D0.05) t =3D + if retry > 0 then ( + let left =3D ref retry in + let locked =3D ref false in + while not !locked && !left > 0 + do + locked :=3D Mutex.try_lock t.mutex; + if not !locked then ( + decr left; + Thread.delay delay; + ) + done; + if not !locked then + raise Timeout + ) else ( + Mutex.lock t.mutex; + ); + try t.time <- t.post_locking () with _ -> (); + () + +let unlock t =3D + t.time <- 0.; + Mutex.unlock t.mutex + +let execute ?retry ?delay t f =3D + lock ?retry ?delay t; + let r =3D begin try f () with exn -> unlock t; raise exn end; in + unlock t; + r + +end + +(** create thread loops which periodically applies a function *) +module Thread_loop + : functor (Tr : sig type t val delay : unit -> float end) -> + sig + val start : Tr.t -> (unit -> unit) -> unit + val stop : Tr.t -> unit + val update : Tr.t -> (unit -> unit) -> unit + end + =3D functor (Tr: sig type t val delay : unit -> float end) -> struct + + exception Done_loop + let ref_table : ((Tr.t,(Mutex.t * Thread.t * bool ref)) Hashtbl.t) =3D + Hashtbl.create 1 + + (** Create a thread which periodically applies a function to the + reference specified, and exits cleanly when removed *)=20 + let start xref fn =3D + let mut =3D Mutex.create () in + let exit_var =3D ref false in + (* create thread which periodically applies the function *) + let tid =3D Thread.create (fun () -> + try while true do + Thread.delay (Tr.delay ()); + Mutex.execute mut (fun () -> + if !exit_var then + raise Done_loop; + let () =3D fn () in () + ); + done; with Done_loop -> (); + ) () in + (* create thread to manage the reference table and clean it up + safely once the delay thread is removed *) + let _ =3D Thread.create (fun () -> + Hashtbl.add ref_table xref (mut,tid,exit_var); + Thread.join tid; + List.iter (fun (_,t,_) -> + if tid =3D t then Hashtbl.remove ref_table xref + ) (Hashtbl.find_all ref_table xref) + ) () in () + + (** Remove a reference from the thread table *) + let stop xref =3D + try let mut,_,exit_ref =3D Hashtbl.find ref_table xref in + Mutex.execute mut (fun () -> exit_ref :=3D true) + with Not_found -> () + + (** Replace a thread with another one *) + let update xref fn =3D + stop xref; + start xref fn +end + +(** Parallel List.iter. Remembers all exceptions and returns an associat= ion list mapping input x to an exception. + Applications of x which succeed will be missing from the returned li= st. *) +let thread_iter_all_exns f xs =3D=20 + let exns =3D ref [] in + let m =3D Mutex.create () in + List.iter=20 + Thread.join=20 + (List.map=20 + (fun x ->=20 + Thread.create=20 + (fun () -> =20 + try + f x + with e -> Mutex.execute m (fun () -> exns :=3D (x, e) :: !exns) + ) + () + ) xs); + !exns + +(** Parallel List.iter. Remembers one exception (at random) and throws i= t in the=20 + error case. *) +let thread_iter f xs =3D match thread_iter_all_exns f xs with + | [] -> () + | (_, e) :: _ -> raise e + +module Delay =3D struct + (* Concrete type is the ends of a pipe *) + type t =3D {=20 + (* A pipe is used to wake up a thread blocked in wait: *) + mutable pipe_out: Unix.file_descr option; + mutable pipe_in: Unix.file_descr option; + (* Indicates that a signal arrived before a wait: *) + mutable signalled: bool; + m: Mutex.t + } + + let make () =3D=20 + { pipe_out =3D None; + pipe_in =3D None; + signalled =3D false; + m =3D Mutex.create () } + + exception Pre_signalled + + let wait (x: t) (seconds: float) =3D + let to_close =3D ref [ ] in + let close' fd =3D=20 + if List.mem fd !to_close then Unix.close fd; + to_close :=3D List.filter (fun x -> fd <> x) !to_close in + Pervasiveext.finally + (fun () -> + try + let pipe_out =3D Mutex.execute x.m + (fun () -> + if x.signalled then begin + x.signalled <- false; + raise Pre_signalled; + end; + let pipe_out, pipe_in =3D Unix.pipe () in + (* these will be unconditionally closed on exit *) + to_close :=3D [ pipe_out; pipe_in ]; + x.pipe_out <- Some pipe_out; + x.pipe_in <- Some pipe_in; + x.signalled <- false; + pipe_out) in + let r, _, _ =3D Unix.select [ pipe_out ] [] [] seconds in + (* flush the single byte from the pipe *) + if r <> [] then ignore(Unix.read pipe_out (String.create 1) 0 1); + (* return true if we waited the full length of time, false if we wer= e woken *) + r =3D [] + with Pre_signalled -> false + ) + (fun () ->=20 + Mutex.execute x.m + (fun () -> + x.pipe_out <- None; + x.pipe_in <- None; + List.iter close' !to_close) + ) + + let signal (x: t) =3D=20 + Mutex.execute x.m + (fun () -> + match x.pipe_in with + | Some fd -> ignore(Unix.write fd "X" 0 1) + | None -> x.signalled <- true (* If the wait hasn't happened yet the= n store up the signal *) + ) +end diff --git a/tools/ocaml/libs/stdext/threadext.mli b/tools/ocaml/libs/std= ext/threadext.mli new file mode 100644 index 0000000..d25c795 --- /dev/null +++ b/tools/ocaml/libs/stdext/threadext.mli @@ -0,0 +1,67 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Anil Madhavapeddy + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +module Mutex : + sig + type t =3D Mutex.t + val create : unit -> t + val lock : t -> unit + val try_lock : t -> bool + val unlock : t -> unit + val execute : Mutex.t -> (unit -> 'a) -> 'a + end + +module Condition : + sig + type t =3D Condition.t + val create : unit -> t + val signal : t -> unit + val broadcast: t -> unit + val wait : t -> Mutex.t -> unit + val timedwait : t -> Mutex.t -> float -> bool + end + +module TMutex : sig + exception Timeout + type t + val init : ?post:(unit -> float) -> unit -> t + val lock : ?retry:int -> ?delay:float -> t -> unit + val unlock : t -> unit + val execute : ?retry:int -> ?delay:float -> t -> (unit -> 'a) -> 'a +end + +module Thread_loop : + functor (Tr : sig type t val delay : unit -> float end) -> + sig + val start : Tr.t -> (unit -> unit) -> unit + val stop : Tr.t -> unit + val update : Tr.t -> (unit -> unit) -> unit + end +val thread_iter_all_exns: ('a -> unit) -> 'a list -> ('a * exn) list +val thread_iter: ('a -> unit) -> 'a list -> unit + +module Delay : + sig + type t + val make : unit -> t + (** Blocks the calling thread for a given period of time with the op= tion of=20 + returning early if someone calls 'signal'. Returns true if the full tim= e + period elapsed and false if signalled. Note that multple 'signals' are=20 + coalesced; 'signals' sent before 'wait' is called are not lost. *) + val wait : t -> float -> bool + (** Sends a signal to a waiting thread. See 'wait' *) + val signal : t -> unit + end diff --git a/tools/ocaml/libs/stdext/trie.ml b/tools/ocaml/libs/stdext/tr= ie.ml new file mode 100644 index 0000000..bc9a903 --- /dev/null +++ b/tools/ocaml/libs/stdext/trie.ml @@ -0,0 +1,182 @@ +(* + * Copyright (C) 2008-2009 Citrix Ltd. + * Author Thomas Gazagnaire + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) + +module Node =3D +struct + type ('a,'b) t =3D { + key: 'a; + value: 'b option; + children: ('a,'b) t list; + } + + let create key value =3D { + key =3D key; + value =3D Some value; + children =3D []; + } + + let empty key =3D { + key =3D key; + value =3D None; + children =3D [] + } + + let get_key node =3D node.key + let get_value node =3D=20 + match node.value with + | None -> raise Not_found + | Some value -> value + + let get_children node =3D node.children + + let set_value node value =3D + { node with value =3D Some value } + let set_children node children =3D + { node with children =3D children } + + let add_child node child =3D=20 + { node with children =3D child :: node.children } +end + +type ('a,'b) t =3D ('a,'b) Node.t list + +let mem_node nodes key =3D + List.exists (fun n -> n.Node.key =3D key) nodes + +let find_node nodes key =3D + List.find (fun n -> n.Node.key =3D key) nodes + +let replace_node nodes key node =3D + let rec aux =3D function + | [] -> [] + | h :: tl when h.Node.key =3D key -> node :: tl + | h :: tl -> h :: aux tl + in + aux nodes + =09 +let remove_node nodes key =3D + let rec aux =3D function + | [] -> raise Not_found + | h :: tl when h.Node.key =3D key -> tl + | h :: tl -> h :: aux tl + in + aux nodes + +let create () =3D [] + +let rec iter f tree =3D=20 + let rec aux node =3D + f node.Node.key node.Node.value;=20 + iter f node.Node.children + in + List.iter aux tree + +let rec map f tree =3D + let rec aux node =3D + let value =3D=20 + match node.Node.value with + | None -> None + | Some value -> f value + in + { node with Node.value =3D value; Node.children =3D map f node.Node.ch= ildren } + in + List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (L= ist.map aux tree) + +let rec fold f tree acc =3D + let rec aux accu node =3D + fold f node.Node.children (f node.Node.key node.Node.value accu) + in + List.fold_left aux acc tree=20 + +(* return a sub-trie *) +let rec sub_node tree =3D function + | [] -> raise Not_found + | h::t ->=20 + if mem_node tree h + then begin + let node =3D find_node tree h in + if t =3D [] + then node + else sub_node node.Node.children t + end else + raise Not_found + +let sub tree path =3D=20 + try (sub_node tree path).Node.children + with Not_found -> [] + +let find tree path =3D=20 + Node.get_value (sub_node tree path) + +(* return false if the node doesn't exists or if it is not associated to= any value *) +let rec mem tree =3D function + | [] -> false + | h::t ->=20 + mem_node tree h + && (let node =3D find_node tree h in=20 + if t =3D [] + then node.Node.value <> None + else mem node.Node.children t) + +(* Iterate over the longest valid prefix *) +let rec iter_path f tree =3D function + | [] -> () + | h::l ->=20 + if mem_node tree h + then begin + let node =3D find_node tree h in + f node.Node.key node.Node.value; + iter_path f node.Node.children l + end + +let rec set_node node path value =3D + if path =3D []=20 + then Node.set_value node value + else begin + let children =3D set node.Node.children path value in + Node.set_children node children + end + +and set tree path value =3D + match path with + | [] -> raise Not_found + | h::t ->=20 + if mem_node tree h + then begin + let node =3D find_node tree h in + replace_node tree h (set_node node t value) + end else begin + let node =3D Node.empty h in + set_node node t value :: tree + end + +let rec unset tree =3D function + | [] -> tree + | h::t ->=20 + if mem_node tree h + then begin + let node =3D find_node tree h in + let children =3D unset node.Node.children t in + let new_node =3D + if t =3D [] + then Node.set_children (Node.empty h) children + else Node.set_children node children + in + if children =3D [] && new_node.Node.value =3D None + then remove_node tree h + else replace_node tree h new_node + end else + raise Not_found + diff --git a/tools/ocaml/libs/stdext/trie.mli b/tools/ocaml/libs/stdext/t= rie.mli new file mode 100644 index 0000000..25db9d0 --- /dev/null +++ b/tools/ocaml/libs/stdext/trie.mli @@ -0,0 +1,60 @@ +(* + * Copyright (C) 2008-2009 Citrix Ltd. + * Author Thomas Gazagnaire + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) + +(** Basic Implementation of polymorphic tries (ie. prefix trees) *) + +type ('a, 'b) t +(** The type of tries. ['a list] is the type of keys, ['b] the type of v= alues. + Internally, a trie is represented as a labeled tree, where node contain= s values + of type ['a * 'b option]. *) + +val create : unit -> ('a,'b) t +(** Creates an empty trie. *) + +val mem : ('a,'b) t -> 'a list -> bool +(** [mem t k] returns true if a value is associated with the key [k] in = the trie [t].=20 + Otherwise, it returns false. *) + +val find : ('a, 'b) t -> 'a list -> 'b +(** [find t k] returns the value associated with the key [k] in the trie= [t]. + Returns [Not_found] if no values are associated with [k] in [t]. *) + +val set : ('a, 'b) t -> 'a list -> 'b -> ('a, 'b) t +(** [set t k v] associates the value [v] with the key [k] in the trie [t= ]. *) + +val unset : ('a, 'b) t -> 'a list -> ('a, 'b) t +(** [unset k v] removes the association of value [v] with the key [k] in= the trie [t].=20 + Moreover, it automatically clean the trie, ie. it removes recursively=20 + every nodes of [t] containing no values and having no chil. *) + +val iter : ('a -> 'b option -> unit) -> ('a, 'b) t -> unit +(** [iter f t] applies the function [f] to every node of the trie [t].=20 + As nodes of the trie [t] do not necessary contains a value, the second = argument of + [f] is an option type. *) + +val iter_path : ('a -> 'b option -> unit) -> ('a, 'b) t -> 'a list -> un= it +(** [iter_path f t p] iterates [f] over nodes associated with the path [= p] in the trie [t].=20 + If [p] is not a valid path of [t], it iterates on the longest valid pre= fix of [p]. *) + +val fold : ('a -> 'b option -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c=20 +(** [fold f t x] fold [f] over every nodes of [t], with [x] as initial v= alue. *) + +val map : ('b -> 'c option) -> ('a,'b) t -> ('a,'c) t +(** [map f t] maps [f] over every values stored in [t]. The return value= of [f] is of type 'c option + as one may wants to remove value associated to a key. This function is = not tail-recursive. *) + +val sub : ('a, 'b) t -> 'a list -> ('a,'b) t +(** [sub t p] returns the sub-trie associated with the path [p] in the t= rie [t]. + If [p] is not a valid path of [t], it returns an empty trie. *) diff --git a/tools/ocaml/libs/stdext/unixext.ml b/tools/ocaml/libs/stdext= /unixext.ml new file mode 100644 index 0000000..c34b274 --- /dev/null +++ b/tools/ocaml/libs/stdext/unixext.ml @@ -0,0 +1,437 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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 Pervasiveext + +exception Unix_error of int + +external _exit : int -> unit =3D "unix_exit" + +(** remove a file, but doesn't raise an exception if the file is already= removed *) +let unlink_safe file =3D + try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -= > () + +(** create a directory but doesn't raise an exception if the directory a= lready exist *) +let mkdir_safe dir perm =3D + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + +(** create a directory, and create parent if doesn't exist *) +let mkdir_rec dir perm =3D + let rec p_mkdir dir =3D + let p_name =3D Filename.dirname dir in + if p_name <> "/" && p_name <> "."=20 + then p_mkdir p_name; + mkdir_safe dir perm in + p_mkdir dir + +(** write a pidfile file *) +let pidfile_write filename =3D + let fd =3D Unix.openfile filename + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] + 0o640 in + finally + (fun () -> + let pid =3D Unix.getpid () in + let buf =3D string_of_int pid ^ "\n" in + let len =3D String.length buf in + if Unix.write fd buf 0 len <> len=20 + then failwith "pidfile_write failed"; + ) + (fun () -> Unix.close fd) + +(** read a pidfile file, return either Some pid or None *) +let pidfile_read filename =3D + let fd =3D Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in + finally + (fun () -> + try + let buf =3D String.create 80 in + let rd =3D Unix.read fd buf 0 (String.length buf) in + if rd =3D 0 then + failwith "pidfile_read failed"; + Scanf.sscanf (String.sub buf 0 rd) "%d" (fun i -> Some i) + with exn -> None) + (fun () -> Unix.close fd) + +(** daemonize a process *) +(* !! Must call this before spawning any threads !! *) +let daemonize () =3D + match Unix.fork () with + | 0 -> + if Unix.setsid () =3D=3D -1 then + failwith "Unix.setsid failed"; + + begin match Unix.fork () with + | 0 -> + let nullfd =3D Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0 in + begin try + Unix.close Unix.stdin; + Unix.dup2 nullfd Unix.stdout; + Unix.dup2 nullfd Unix.stderr; + with exn -> Unix.close nullfd; raise exn + end; + Unix.close nullfd + | _ -> exit 0 + end + | _ -> exit 0 + +(** Run a function over every line in a file *) +let readfile_line fn fname =3D + let fin =3D open_in fname in + try + while true do + let line =3D input_line fin in + fn line + done; + close_in fin; + with + | End_of_file -> close_in fin + | exn -> close_in fin; raise exn + +(** open a file, and make sure the close is always done *) +let with_file file mode perms f =3D + let fd =3D Unix.openfile file mode perms in + let r =3D + try f fd + with exn -> Unix.close fd; raise exn + in + Unix.close fd; + r + +let with_directory dir f =3D + let dh =3D Unix.opendir dir in + let r =3D + try f dh + with exn -> Unix.closedir dh; raise exn + in + Unix.closedir dh; + r + +(** Read whole file from specified fd *) +let read_whole_file size_hint block_size fd =3D + let filebuf =3D Buffer.create size_hint in + let blockbuf =3D String.create block_size in + let rec do_read() =3D + let nread =3D Unix.read fd blockbuf 0 block_size in + if nread=3D0 then + Buffer.contents filebuf + else + begin + Buffer.add_substring filebuf blockbuf 0 nread; + do_read() + end in + do_read() + +(** Read whole file into string *) +let read_whole_file_to_string fname =3D + with_file fname [ Unix.O_RDONLY ] 0o0 (read_whole_file 1024 1024) + +(** Atomically write a string to a file *) +let write_string_to_file fname s =3D + let tmp =3D Filenameext.temp_file_in_dir fname in + Pervasiveext.finally=20 + (fun () -> + let fd =3D Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] 0o644 = in + Pervasiveext.finally=20 + (fun () ->=20 + let len =3D String.length s in + let written =3D Unix.write fd s 0 len in + if written <> len then (failwith "Short write occured!")) + (fun () -> Unix.close fd); + Unix.rename tmp fname) + (fun () -> unlink_safe tmp) + +let execv_get_output cmd args =3D + let (pipe_exit, pipe_entrance) =3D Unix.pipe () in + let r =3D try Unix.set_close_on_exec pipe_exit; true with _ -> false in + match Unix.fork () with + | 0 -> + Unix.dup2 pipe_entrance Unix.stdout; + Unix.close pipe_entrance; + if not r then + Unix.close pipe_exit; + begin try Unix.execv cmd args with _ -> exit 127 end + | pid -> + Unix.close pipe_entrance; + pid, pipe_exit + +(** Copy all data from an in_channel to an out_channel, + * returning the total number of bytes *) +let copy_file ?limit ifd ofd =3D + let buffer =3D String.make 65536 '\000' in + let buffer_len =3D Int64.of_int (String.length buffer) in + let finished =3D ref false in + let total_bytes =3D ref 0L in + let limit =3D ref limit in + while not(!finished) do + let requested =3D min (Opt.default buffer_len !limit) buffer_len in + let num =3D Unix.read ifd buffer 0 (Int64.to_int requested) in + let num64 =3D Int64.of_int num in + + limit :=3D Opt.map (fun x -> Int64.sub x num64) !limit; + let wnum =3D Unix.write ofd buffer 0 num in + total_bytes :=3D Int64.add !total_bytes num64; + finished :=3D wnum =3D 0 || !limit =3D Some 0L; + done; + !total_bytes + +(** Create a new file descriptor, connect it to host:port and return it = *) +exception Host_not_found of string +let open_connection_fd host port =3D + let s =3D Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + try=20 + let he =3D + try + Unix.gethostbyname host + with + Not_found -> raise (Host_not_found host) in + if Array.length he.Unix.h_addr_list =3D 0 + then failwith (Printf.sprintf "Couldn't resolve hostname: %s" host); + let ip =3D he.Unix.h_addr_list.(0) in + let addr =3D Unix.ADDR_INET(ip, port) in + Unix.connect s addr; + s + with e -> Unix.close s; raise e + + +let open_connection_unix_fd filename =3D + let s =3D Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + try + let addr =3D Unix.ADDR_UNIX(filename) in + Unix.connect s addr; + s + with e -> Unix.close s; raise e + +type endpoint =3D { fd: Unix.file_descr; mutable buffer: string; mutable= buffer_len: int } + +let make_endpoint fd =3D { + fd =3D fd; + buffer =3D String.make 4096 '\000'; + buffer_len =3D 0 +} + +exception Process_still_alive + +let kill_and_wait ?(signal =3D Sys.sigterm) ?(timeout=3D10.) pid =3D + let proc_entry_exists pid =3D + try Unix.access (Printf.sprintf "/proc/%d" pid) [ Unix.F_OK ]; true + with _ -> false + in + if pid > 0 && proc_entry_exists pid then ( + let loop_time_waiting =3D 0.03 in + let left =3D ref timeout in + let readcmdline pid =3D + try read_whole_file_to_string (Printf.sprintf "/proc/%d/cmdline" pid) + with _ -> "" + in + let reference =3D readcmdline pid and quit =3D ref false in + Unix.kill pid signal; + + (* We cannot do a waitpid here, since we might not be parent of + the process, so instead we are waiting for the /proc/%d to go + away. Also we verify that the cmdline stay the same if it's still h= ere + to prevent the very very unlikely event that the pid get reused bef= ore + we notice it's gone *) + while proc_entry_exists pid && not !quit && !left > 0. + do + let cmdline =3D readcmdline pid in + if cmdline =3D reference then ( + (* still up, let's sleep a bit *) + ignore (Unix.select [] [] [] loop_time_waiting); + left :=3D !left -. loop_time_waiting + ) else ( + (* not the same, it's gone ! *) + quit :=3D true + ) + done; + if !left <=3D 0. then + raise Process_still_alive; + ) + +let proxy (a: Unix.file_descr) (b: Unix.file_descr) =3D + let a' =3D make_endpoint a and b' =3D make_endpoint b in + Unix.set_nonblock a; + Unix.set_nonblock b; + + let can_read x =3D + x.buffer_len < (String.length x.buffer - 1) in + let can_write x =3D + x.buffer_len > 0 in + let write_from x fd =3D + let written =3D Unix.single_write fd x.buffer 0 x.buffer_len in + String.blit x.buffer written x.buffer 0 (x.buffer_len - written); + x.buffer_len <- x.buffer_len - written in + let read_into x =3D + let read =3D Unix.read x.fd x.buffer x.buffer_len (String.length x.buf= fer - x.buffer_len) in + if read =3D 0 then raise End_of_file; + x.buffer_len <- x.buffer_len + read in + + try + while true do + let r =3D (if can_read a' then [ a ] else []) @ (if can_read b' then [= b ] else []) in + let w =3D (if can_write a' then [ b ] else []) @ (if can_write b' then= [ a ] else []) in + + let r, w, _ =3D Unix.select r w [] (-1.0) in + (* Do the writing before the reading *) + List.iter (fun fd -> if a =3D fd then write_from b' a else write_from = a' b) w; + List.iter (fun fd -> if a =3D fd then read_into a' else read_into b') = r + done + with _ -> + (try Unix.clear_nonblock a with _ -> ()); + (try Unix.clear_nonblock b with _ -> ()); + (try Unix.close a with _ -> ()); + (try Unix.close b with _ -> ()) + +let rec really_read fd string off n =3D + if n=3D0 then () else + let m =3D Unix.read fd string off n in + if m =3D 0 then raise End_of_file; + really_read fd string (off+m) (n-m) + +let really_write fd string off n =3D + let written =3D ref 0 in + while !written < n + do + let wr =3D Unix.write fd string (off + !written) (n - !written) in + written :=3D wr + !written + done + +let spawnvp ?(pid_callback=3D(fun _ -> ())) cmd args =3D + match Unix.fork () with + | 0 -> + Unix.execvp cmd args + | pid -> + begin try pid_callback pid with _ -> () end; + snd (Unix.waitpid [] pid) + +let double_fork f =3D + match Unix.fork () with + | 0 -> + begin match Unix.fork () with + (* NB: use _exit (calls C lib _exit directly) to avoid + calling at_exit handlers and flushing output channels + which wouild cause intermittent deadlocks if we + forked from a threaded program *) + | 0 -> (try f () with _ -> ()); _exit 0 + | _ -> _exit 0 + end + | pid -> ignore(Unix.waitpid [] pid) + +external set_tcp_nodelay : Unix.file_descr -> bool -> unit =3D "stub_uni= xext_set_tcp_nodelay" + +external fsync : Unix.file_descr -> unit =3D "stub_unixext_fsync" + +external get_max_fd : unit -> int =3D "stub_unixext_get_max_fd" + +let int_of_file_descr (x: Unix.file_descr) : int =3D Obj.magic x +let file_descr_of_int (x: int) : Unix.file_descr =3D Obj.magic x + +(** Forcibly closes all open file descriptors except those explicitly pa= ssed in as arguments. + Useful to avoid accidentally passing a file descriptor opened in ano= ther thread to a + process being concurrently fork()ed (there's a race between open/set= _close_on_exec). + NB this assumes that 'type Unix.file_descr =3D int'=20 +*) +let close_all_fds_except (fds: Unix.file_descr list) =3D + (* get at the file descriptor within *) + let fds' =3D List.map int_of_file_descr fds in + let close' (x: int) =3D=20 + try Unix.close(file_descr_of_int x) with _ -> () in + + let highest_to_keep =3D List.fold_left max (-1) fds' in + (* close all the fds higher than the one we want to keep *) + for i =3D highest_to_keep + 1 to get_max_fd () do close' i done; + (* close all the rest *) + for i =3D 0 to highest_to_keep - 1 do + if not(List.mem i fds') then close' i + done + +exception Process_output_error of string +let get_process_output ?(handler) cmd : string =3D + let inchan =3D Unix.open_process_in cmd in + + let buffer =3D Buffer.create 1024 + and buf =3D String.make 1024 '\000' in +=09 + let rec read_until_eof () =3D + let rd =3D input inchan buf 0 1024 in + if rd =3D 0 then + () + else ( + Buffer.add_substring buffer buf 0 rd; + read_until_eof () + ) in + (* Make sure an exception doesn't prevent us from waiting for the child= process *) + (try read_until_eof () with _ -> ()); + match (Unix.close_process_in inchan), handler with + | Unix.WEXITED 0, _ -> Buffer.contents buffer + | Unix.WEXITED n, Some handler -> handler cmd n + | _ -> raise (Process_output_error cmd) + +(** Remove "." and ".." from paths (NB doesn't attempt to resolve symlin= ks) *) +let resolve_dot_and_dotdot (path: string) : string =3D=20 + let of_string (x: string): string list =3D=20 + let rec rev_split path =3D=20 + let basename =3D Filename.basename path=20 + and dirname =3D Filename.dirname path in + let rest =3D if Filename.dirname dirname =3D dirname then [] else = rev_split dirname in + basename :: rest in + let abs_path path =3D=20 + if Filename.is_relative path=20 + then Filename.concat "/" path (* no notion of a cwd *) + else path in + rev_split (abs_path x) in + =20 + let to_string (x: string list) =3D List.fold_left Filename.concat "/" = (List.rev x) in + =20 + (* Process all "." and ".." references *) + let rec remove_dots (n: int) (x: string list) =3D=20 + match x, n with + | [], _ -> [] + | "." :: rest, _ -> remove_dots n rest (* throw away ".", don't coun= t as parent for ".." *) + | ".." :: rest, _ -> remove_dots (n + 1) rest (* note the number of = ".." *) + | x :: rest, 0 -> x :: (remove_dots 0 rest) + | x :: rest, n -> remove_dots (n - 1) rest (* munch *) in + to_string (remove_dots 0 (of_string path)) + +type statfs_t =3D { + statfs_type: int64; + statfs_bsize: int; + statfs_blocks: int64; + statfs_bfree: int64; + statfs_bavail: int64; + statfs_files: int64; + statfs_ffree: int64; + statfs_namelen: int; +} + +external statfs: string -> statfs_t =3D "stub_unixext_statfs" + +external get_major_minor : string -> int * int =3D "stub_unixext_get_maj= or_minor" + +module Fdset =3D struct + type t + external of_list : Unix.file_descr list -> t =3D "stub_fdset_of_list" + let create () =3D of_list [] + external is_set : t -> Unix.file_descr -> bool =3D "stub_fdset_is_set" + external set : t -> Unix.file_descr -> unit =3D "stub_fdset_set" + external clear : t -> Unix.file_descr -> unit =3D "stub_fdset_clear" + external _select : t -> t -> t -> float -> t * t * t =3D "stub_fdset_se= lect" + external _select_ro : t -> float -> t =3D "stub_fdset_select_ro" + let select r w e t =3D _select r w e t + let select_ro r t =3D _select_ro r t +end + +let _ =3D Callback.register_exception "unixext.unix_error" (Unix_error (= 0)) diff --git a/tools/ocaml/libs/stdext/unixext.mli b/tools/ocaml/libs/stdex= t/unixext.mli new file mode 100644 index 0000000..b6dc96f --- /dev/null +++ b/tools/ocaml/libs/stdext/unixext.mli @@ -0,0 +1,84 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as publis= hed + * 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. + *) +external _exit : int -> unit =3D "unix_exit" +val unlink_safe : string -> unit +val mkdir_safe : string -> Unix.file_perm -> unit +val mkdir_rec : string -> Unix.file_perm -> unit +val pidfile_write : string -> unit +val pidfile_read : string -> int option +val daemonize : unit -> unit +val with_file : string -> Unix.open_flag list -> Unix.file_perm -> (Unix= .file_descr -> 'a) -> 'a +val with_directory : string -> (Unix.dir_handle -> 'a) -> 'a +val readfile_line : (string -> 'a) -> string -> unit +val read_whole_file : int -> int -> Unix.file_descr -> string +val read_whole_file_to_string : string -> string +val write_string_to_file : string -> string -> unit +val execv_get_output : string -> string array -> int * Unix.file_descr +val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> in= t64 +exception Host_not_found of string +val open_connection_fd : string -> int -> Unix.file_descr +val open_connection_unix_fd : string -> Unix.file_descr +type endpoint =3D { + fd : Unix.file_descr; + mutable buffer : string; + mutable buffer_len : int; +} +exception Process_still_alive +val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit +val make_endpoint : Unix.file_descr -> endpoint +val proxy : Unix.file_descr -> Unix.file_descr -> unit +val really_read : Unix.file_descr -> string -> int -> int -> unit +val really_write : Unix.file_descr -> string -> int -> int -> unit +val spawnvp : + ?pid_callback:(int -> unit) -> + string -> string array -> Unix.process_status +val double_fork : (unit -> unit) -> unit +external set_tcp_nodelay : Unix.file_descr -> bool -> unit + =3D "stub_unixext_set_tcp_nodelay" +external fsync : Unix.file_descr -> unit =3D "stub_unixext_fsync" +external get_max_fd : unit -> int =3D "stub_unixext_get_max_fd" +val int_of_file_descr : Unix.file_descr -> int +val file_descr_of_int : int -> Unix.file_descr +val close_all_fds_except : Unix.file_descr list -> unit +val get_process_output : ?handler:(string -> int -> string) -> string ->= string +val resolve_dot_and_dotdot : string -> string + +type statfs_t =3D { + statfs_type: int64; + statfs_bsize: int; + statfs_blocks: int64; + statfs_bfree: int64; + statfs_bavail: int64; + statfs_files: int64; + statfs_ffree: int64; + statfs_namelen: int; +} + +val statfs: string -> statfs_t +val get_major_minor : string -> int * int=20 + +module Fdset : sig + type t + val create : unit -> t + external of_list : Unix.file_descr list -> t =3D "stub_fdset_of_list" + external is_set : t -> Unix.file_descr -> bool =3D "stub_fdset_is_set" + external set : t -> Unix.file_descr -> unit =3D "stub_fdset_set" + external clear : t -> Unix.file_descr -> unit =3D "stub_fdset_clear" + + val select : t -> t -> t -> float -> t * t * t + val select_ro : t -> float -> t +end diff --git a/tools/ocaml/libs/stdext/unixext_stubs.c b/tools/ocaml/libs/s= tdext/unixext_stubs.c new file mode 100644 index 0000000..cbe1519 --- /dev/null +++ b/tools/ocaml/libs/stdext/unixext_stubs.c @@ -0,0 +1,304 @@ +#include +#include +#include +#include +#include +#include +#include +#include /* needed for _SC_OPEN_MAX */ +#include /* snprintf */ +#include /* needed for caml_condition_timedwait */ + +#include +#include +#include +#include +#include +#include +#include + +static void failwith_errno(void) +{ + char buf[256]; + char buf2[280]; + memset(buf, '\0', sizeof(buf)); + //strerror_r(errno, buf, sizeof(buf)); + snprintf(buf2, sizeof(buf2), "errno: %d msg: %s", errno, buf); + caml_failwith(buf2); +} + +/* Set the TCP_NODELAY flag on a Unix.file_descr */ +CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool) +{ + CAMLparam2 (fd, bool); + int c_fd =3D Int_val(fd); + int opt =3D (Bool_val(bool)) ? 1 : 0; + if (setsockopt(c_fd, IPPROTO_TCP, TCP_NODELAY, (void *)&opt, sizeof(opt= )) !=3D 0){ + failwith_errno(); + } + CAMLreturn(Val_unit); +} + +CAMLprim value stub_unixext_fsync (value fd) +{ + CAMLparam1(fd); + int c_fd =3D Int_val(fd); + if (fsync(c_fd) !=3D 0) failwith_errno(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_unixext_get_max_fd (value unit) +{ + CAMLparam1 (unit); + long maxfd; + maxfd =3D sysconf(_SC_OPEN_MAX); + CAMLreturn(Val_int(maxfd)); +} + +#include + +CAMLprim value stub_unixext_statfs(value path) +{ + CAMLparam1(path); + CAMLlocal1(statinfo); + struct statfs info; + + if (statfs(String_val(path), &info)) + failwith_errno(); + + statinfo =3D caml_alloc_tuple(8); + Store_field(statinfo, 0, caml_copy_int64(info.f_type)); + Store_field(statinfo, 1, Val_int(info.f_bsize)); + Store_field(statinfo, 2, caml_copy_int64(info.f_blocks)); + Store_field(statinfo, 3, caml_copy_int64(info.f_bfree)); + Store_field(statinfo, 4, caml_copy_int64(info.f_bavail)); + Store_field(statinfo, 5, caml_copy_int64(info.f_files)); + Store_field(statinfo, 6, caml_copy_int64(info.f_ffree)); + Store_field(statinfo, 7, Val_int(info.f_namelen)); + + CAMLreturn(statinfo); +} + +#define FDSET_OF_VALUE(v) (&(((struct fdset_t *) v)->fds)) +#define MAXFD_OF_VALUE(v) (((struct fdset_t *) v)->max) +struct fdset_t { fd_set fds; int max; }; + +CAMLprim value stub_fdset_of_list(value l) +{ + CAMLparam1(l); + CAMLlocal1(set); + + set =3D caml_alloc(sizeof(struct fdset_t), Abstract_tag); + FD_ZERO(FDSET_OF_VALUE(set)); + MAXFD_OF_VALUE(set) =3D -1; + while (l !=3D Val_int(0)) { + int fd; + fd =3D Int_val(Field(l, 0)); + FD_SET(fd, FDSET_OF_VALUE(set)); + if (fd > MAXFD_OF_VALUE(set)) + MAXFD_OF_VALUE(set) =3D fd; + l =3D Field(l, 1); + } + CAMLreturn(set); +} + +CAMLprim value stub_fdset_is_set(value set, value fd) +{ + CAMLparam2(set, fd); + CAMLreturn(Val_bool(FD_ISSET(Int_val(fd), FDSET_OF_VALUE(set)))); +} + +CAMLprim value stub_fdset_set(value set, value fd) +{ + CAMLparam2(set, fd); + int cfd; + + cfd =3D Int_val(fd); + FD_SET(cfd, FDSET_OF_VALUE(set)); + if (cfd > MAXFD_OF_VALUE(set)) + MAXFD_OF_VALUE(set) =3D cfd; + CAMLreturn(Val_unit); +} + +CAMLprim value stub_fdset_clear(value set, value fd) +{ + CAMLparam2(set, fd); + int cfd, d; + + cfd =3D Int_val(fd); + FD_CLR(cfd, FDSET_OF_VALUE(set)); + if (cfd =3D=3D MAXFD_OF_VALUE(set)) { + for (d =3D cfd - 1; d >=3D 0; d--) { + if (FD_ISSET(d, FDSET_OF_VALUE(set))) { + MAXFD_OF_VALUE(set) =3D d; + break; + } + } + if (d < 0) + MAXFD_OF_VALUE(set) =3D -1; + } + CAMLreturn(Val_unit); +} + +void unixext_error(int code) +{ + static value *exn =3D NULL; + + if (!exn) { + exn =3D caml_named_value("unixext.unix_error"); + if (!exn) + caml_invalid_argument("unixext.unix_error not initialiazed"); + } + caml_raise_with_arg(*exn, Val_int(code)); +} + +CAMLprim value stub_fdset_select(value rset, value wset, value eset, val= ue t) +{ + CAMLparam4(rset, wset, eset, t); + CAMLlocal4(ret, nrset, nwset, neset); + fd_set r, w, e; + int maxfd; + double tm; + struct timeval tv; + struct timeval *tvp; + int v; + + memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set)); + memcpy(&w, FDSET_OF_VALUE(wset), sizeof(fd_set)); + memcpy(&e, FDSET_OF_VALUE(eset), sizeof(fd_set)); + + maxfd =3D (MAXFD_OF_VALUE(rset) > MAXFD_OF_VALUE(wset)) + ? MAXFD_OF_VALUE(rset) + : MAXFD_OF_VALUE(wset); + maxfd =3D (maxfd > MAXFD_OF_VALUE(eset)) ? maxfd : MAXFD_OF_VALUE(eset)= ; + + tm =3D Double_val(t); + if (tm < 0.0) + tvp =3D NULL; + else { + tv.tv_sec =3D (int) tm; + tv.tv_usec =3D (int) (1e6 * (tm - tv.tv_sec)); + tvp =3D &tv; + } + + caml_enter_blocking_section(); + v =3D select(maxfd + 1, &r, &w, &e, tvp); + caml_leave_blocking_section(); + if (v =3D=3D -1) + unixext_error(errno); + + nrset =3D caml_alloc(sizeof(struct fdset_t), Abstract_tag); + nwset =3D caml_alloc(sizeof(struct fdset_t), Abstract_tag); + neset =3D caml_alloc(sizeof(struct fdset_t), Abstract_tag); + + memcpy(FDSET_OF_VALUE(nrset), &r, sizeof(fd_set)); + memcpy(FDSET_OF_VALUE(nwset), &w, sizeof(fd_set)); + memcpy(FDSET_OF_VALUE(neset), &e, sizeof(fd_set)); + MAXFD_OF_VALUE(nrset) =3D MAXFD_OF_VALUE(rset); + MAXFD_OF_VALUE(nwset) =3D MAXFD_OF_VALUE(wset); + MAXFD_OF_VALUE(neset) =3D MAXFD_OF_VALUE(eset); + + ret =3D caml_alloc_small(3, 0); + Field(ret, 0) =3D nrset; + Field(ret, 1) =3D nwset; + Field(ret, 2) =3D neset; + + CAMLreturn(ret); +} + +CAMLprim value stub_fdset_select_ro(value rset, value t) +{ + CAMLparam2(rset, t); + CAMLlocal1(ret); + fd_set r; + int maxfd; + double tm; + struct timeval tv; + struct timeval *tvp; + int v; + + memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set)); + maxfd =3D MAXFD_OF_VALUE(rset); + + tm =3D Double_val(t); + if (tm < 0.0) + tvp =3D NULL; + else { + tv.tv_sec =3D (int) tm; + tv.tv_usec =3D (int) (1e6 * (tm - tv.tv_sec)); + tvp =3D &tv; + } + + caml_enter_blocking_section(); + v =3D select(maxfd + 1, &r, NULL, NULL, tvp); + caml_leave_blocking_section(); + if (v =3D=3D -1) + unixext_error(errno); + + ret =3D caml_alloc(sizeof(struct fdset_t), Abstract_tag); + memcpy(FDSET_OF_VALUE(ret), &r, sizeof(fd_set)); + + CAMLreturn(ret); +} + +value stub_unixext_get_major_minor(value dpath) +{ + CAMLparam1(dpath); + CAMLlocal1(majmin); + struct stat statbuf; + unsigned major, minor; + int ret; + + ret =3D stat(String_val(dpath), &statbuf); + if (ret =3D=3D -1) + caml_failwith("cannot stat path"); + + major =3D (statbuf.st_rdev & 0xfff00) >> 8; + minor =3D (statbuf.st_rdev & 0xff) | ((statbuf.st_rdev >> 12) & 0xfff00= ); + + majmin =3D caml_alloc_tuple(2); + Store_field(majmin, 0, Val_int(major)); + Store_field(majmin, 1, Val_int(minor)); + CAMLreturn(majmin); +} + +// from otherlibs/systhreads/posix.c +#define Condition_val(v) (* ((pthread_cond_t **) Data_custom_val(v))) +#define Mutex_val(v) (* ((pthread_mutex_t **) Data_custom_val(v))) + +static void caml_pthread_check(int retcode, char *msg) +{ + char * err; + int errlen, msglen; + value str; + + if (retcode =3D=3D 0) return; + err =3D strerror(retcode); + msglen =3D strlen(msg); + errlen =3D strlen(err); + str =3D alloc_string(msglen + 2 + errlen); + memmove (&Byte(str, 0), msg, msglen); + memmove (&Byte(str, msglen), ": ", 2); + memmove (&Byte(str, msglen + 2), err, errlen); + raise_sys_error(str); +} + +// from http://caml.inria.fr/mantis/view.php?id=3D4104 +CAMLprim value caml_condition_timedwait(value v_cnd, value v_mtx, value = v_timeo) +{ + CAMLparam2(v_cnd, v_mtx); + int ret; + pthread_cond_t *cnd =3D Condition_val(v_cnd); + pthread_mutex_t *mtx =3D Mutex_val(v_mtx); + double timeo =3D Double_val(v_timeo); + struct timespec ts; + + ts.tv_sec =3D timeo; + ts.tv_nsec =3D (timeo - ts.tv_sec) * 1e9; + enter_blocking_section(); + ret =3D pthread_cond_timedwait(cnd, mtx, &ts); + leave_blocking_section(); + if (ret =3D=3D ETIMEDOUT) CAMLreturn(Val_false); + caml_pthread_check(ret, "Condition.timedwait"); + CAMLreturn(Val_true); +} diff --git a/tools/ocaml/libs/stdext/vIO.ml b/tools/ocaml/libs/stdext/vIO= .ml new file mode 100644 index 0000000..4f6450a --- /dev/null +++ b/tools/ocaml/libs/stdext/vIO.ml @@ -0,0 +1,250 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008-2009 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 publis= hed + * 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 backend =3D { + blksize: int; + read: string -> int -> int -> int; + write: string -> int -> int -> int; + flush: unit -> unit; + close: unit -> unit; + selectable: Unix.file_descr option; +} + +type cache =3D { + read_cache_size: int; + write_cache_size: int; + read_ring: Qring.t; + write_ring: Qring.t; +} + +type t =3D { backend: backend; mutable cache: cache; mutable reached_eof= : bool } + +exception Cache_not_empty +exception Invalid_cache_size + +let check_cache_size sz =3D + if sz < 0 || sz > 1024 * 1024 then + raise Invalid_cache_size + +let make rcache wcache backend =3D + check_cache_size rcache; + check_cache_size wcache; + let cache =3D { + read_cache_size =3D rcache; + write_cache_size =3D wcache; + read_ring =3D Qring.make rcache; + write_ring =3D Qring.make wcache; + } in + { backend =3D backend; cache =3D cache; reached_eof =3D false } + +let set_read_cache con sz =3D + check_cache_size sz; + if Qring.to_consume con.cache.read_ring > 0 then + raise Cache_not_empty; + con.cache <- { + con.cache with read_cache_size =3D sz; read_ring =3D Qring.make sz + } + +let set_write_cache con sz =3D + check_cache_size sz; + if Qring.to_consume con.cache.write_ring > 0 then + raise Cache_not_empty; + con.cache <- { + con.cache with write_cache_size =3D sz; write_ring =3D Qring.make sz + } + +let get_fd con =3D + match con.backend.selectable with + | None -> assert false + | Some fd -> fd + +let read_fill_cache con =3D + if con.reached_eof then + 0 + else + let tofill =3D Qring.to_fill con.cache.read_ring in + let toread =3D min con.backend.blksize tofill in + let s =3D String.create toread in + let readed =3D con.backend.read s 0 toread in + if readed =3D 0 then + con.reached_eof <- true + else + Qring.feed con.cache.read_ring s 0 readed; + readed + +let has_read_cache con =3D + Qring.to_consume con.cache.read_ring > 0 + +exception Internal_cache_error + +let read_once_nocache con buf index hint =3D + con.backend.read buf index hint + +let read_once_cache con buf index hint =3D + let cached =3D Qring.to_consume con.cache.read_ring in + if cached >=3D hint then ( + let rhint =3D Qring.consume_to con.cache.read_ring buf index hint in + if rhint < hint then + raise Internal_cache_error; + hint + ) else ( + if cached > 0 then ( + let rcached =3D Qring.consume_to con.cache.read_ring buf index cached= in + if rcached < cached then + raise Internal_cache_error;=20 + () + ); + let readed =3D read_fill_cache con in + if readed > 0 then ( + let left =3D hint - cached in + let len =3D if readed > left then left else readed in + let rlen =3D Qring.consume_to con.cache.read_ring buf (index + cached= ) len in + if rlen < len then + raise Internal_cache_error; + () + ); + min (readed + cached) hint + ) + +let read_once con =3D + (if con.cache.read_cache_size =3D 0 then read_once_nocache else read_on= ce_cache) con + +let write_flush_cache con =3D + let buf =3D Qring.consume_all con.cache.write_ring in + let len =3D String.length buf in + if len > 0 then ( + let written =3D con.backend.write buf 0 len in + if written =3D 0 then + 0 + else if written =3D len then + Qring.to_fill con.cache.write_ring + else ( (* 0 < written < len *) + let to_put_back =3D len - written in + Qring.feed con.cache.write_ring buf written to_put_back; + Qring.to_fill con.cache.write_ring + ) + ) else + 0 + +let write_once_nocache con buf index hint =3D + con.backend.write buf index hint + +let write_once_cache con buf index hint =3D + let can_cache =3D Qring.to_fill con.cache.write_ring in + (* the cache is full, flush it, and fill the cache with the buf as much= as we can *) + if can_cache =3D 0 then ( + let to_fill =3D write_flush_cache con in + if to_fill > 0 then ( + let len =3D min hint can_cache in + Qring.feed con.cache.write_ring buf index len; + len + ) else + 0 + (* the cache is empty *) + ) else if can_cache =3D con.cache.write_cache_size then ( + (* check if we have enough to send a full buf without copying to the c= ache *) + if can_cache <=3D hint then ( + let written =3D con.backend.write buf index hint in + written + ) else ( + Qring.feed con.cache.write_ring buf index hint; + hint + ) + (* the cache contains something, try filling it *) + ) else ( + (* the cache will be full *) + if can_cache <=3D hint then ( + Qring.feed con.cache.write_ring buf index can_cache; + let to_fill =3D write_flush_cache con in + ignore to_fill; + can_cache + ) else ( + Qring.feed con.cache.write_ring buf index hint; + hint + ) + ) + +let write_once con =3D + (if con.cache.write_cache_size =3D 0 then write_once_nocache else write= _once_cache) con + +let do_rw_io f buf index len =3D + let left =3D ref len in + let index =3D ref index in + let end_of_file =3D ref false in + while !left > 0 && not !end_of_file + do + let ret =3D f buf !index !left in + if ret =3D 0 then + end_of_file :=3D true + else if ret > 0 then ( + left :=3D !left - ret; + index :=3D !index + ret; + ) + done; + len - !left + +let read con buf index size =3D + do_rw_io (read_once con) buf index size + +exception Line_limit_reached +exception Buffer_limit_reached +exception Eof_reached + +let read_line con max =3D + let buffer =3D Buffer.create 80 in + let s =3D String.create 1 in + let found =3D ref false and i =3D ref 0 in + while not !found && (max =3D 0 || !i < max) + do + let n =3D read_once con s 0 1 in + if n =3D 0 then + raise Eof_reached; + + if s.[0] =3D '\n' then + found :=3D true + else ( + i :=3D !i + n; + Buffer.add_string buffer s; + ) + done; + if !i =3D max then + raise Line_limit_reached; + Buffer.contents buffer + +let readf_eof con f max =3D + let end_of_file =3D ref false in + let acc =3D ref 0 in + let s =3D String.create 1024 in + while not !end_of_file + do + let ret =3D read_once con s 0 1024 in + if ret =3D 0 then + end_of_file :=3D true + else ( + acc :=3D !acc + ret; + if max > 0 && !acc > max then + raise Buffer_limit_reached; + f s 0 ret + ) + done + + +let write con buf index size =3D + do_rw_io (write_once con) buf index size + +let flush con =3D while write_flush_cache con > 0 do () done + +let close con =3D con.backend.close () diff --git a/tools/ocaml/libs/stdext/vIO.mli b/tools/ocaml/libs/stdext/vI= O.mli new file mode 100644 index 0000000..6f05c97 --- /dev/null +++ b/tools/ocaml/libs/stdext/vIO.mli @@ -0,0 +1,51 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008-2009 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 publis= hed + * 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 backend =3D { + blksize: int; + read: string -> int -> int -> int; + write: string -> int -> int -> int; + flush: unit -> unit; + close: unit -> unit; + selectable: Unix.file_descr option; +} + +exception Line_limit_reached +exception Eof_reached +exception Invalid_cache_size + +type t + +val make : int -> int -> backend -> t + +val set_read_cache : t -> int -> unit +val set_write_cache : t -> int -> unit + +val has_read_cache : t -> bool + +val get_fd : t -> Unix.file_descr + +val read_once : t -> string -> int -> int -> int +val write_once : t -> string -> int -> int -> int + +val read : t -> string -> int -> int -> int +val write : t -> string -> int -> int -> int + +val read_line : t -> int -> string +val readf_eof : t -> (string -> int -> int -> unit) -> int -> unit + +val flush : t -> unit +val close : t -> unit diff --git a/tools/ocaml/libs/stdext/varmap.ml b/tools/ocaml/libs/stdext/= varmap.ml new file mode 100644 index 0000000..3704305 --- /dev/null +++ b/tools/ocaml/libs/stdext/varmap.ml @@ -0,0 +1,26 @@ +(* + * Copyright (C) 2009 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 publis= hed + * 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 Failed_assoc of string +exception Failed_revassoc + +type 'a table =3D (string * 'a) list + +let assoc (table: 'a table) x =3D + try snd (List.find (fun (a, b) -> x =3D a) table) + with Not_found -> raise (Failed_assoc x) + +let rev_assoc (table: 'a table) y =3D + try fst (List.find (fun (a, b) -> y =3D b) table) + with Not_found -> raise Failed_revassoc=20 diff --git a/tools/ocaml/libs/stdext/varmap.mli b/tools/ocaml/libs/stdext= /varmap.mli new file mode 100644 index 0000000..8ce5ebf --- /dev/null +++ b/tools/ocaml/libs/stdext/varmap.mli @@ -0,0 +1,22 @@ +(* + * Copyright (C) 2009 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 publis= hed + * 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 Failed_assoc of string +exception Failed_revassoc + +type 'a table =3D (string * 'a) list + +val assoc : 'a table -> string -> 'a +val rev_assoc : 'a table -> 'a -> string diff --git a/tools/ocaml/libs/uuid/META.in b/tools/ocaml/libs/uuid/META.i= n new file mode 100644 index 0000000..f33c980 --- /dev/null +++ b/tools/ocaml/libs/uuid/META.in @@ -0,0 +1,4 @@ +version =3D "@VERSION@" +description =3D "Uuid - universal identifer" +archive(byte) =3D "uuid.cma" +archive(native) =3D "uuid.cmxa" diff --git a/tools/ocaml/libs/uuid/Makefile b/tools/ocaml/libs/uuid/Makef= ile new file mode 100644 index 0000000..8ddb0e2 --- /dev/null +++ b/tools/ocaml/libs/uuid/Makefile @@ -0,0 +1,26 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +OBJS =3D uuid +INTF =3D $(foreach obj, $(OBJS),$(obj).cmi) +LIBS =3D uuid.cma uuid.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +uuid_OBJS =3D $(OBJS) +OCAML_NOC_LIBRARY =3D uuid + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -ldconf ignore uuid META $(INTF) $(LIBS) *.a *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove uuid + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/uuid/uuid.ml b/tools/ocaml/libs/uuid/uuid.m= l new file mode 100644 index 0000000..7c25247 --- /dev/null +++ b/tools/ocaml/libs/uuid/uuid.ml @@ -0,0 +1,88 @@ +(* + * 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 publis= hed + * 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. *) + +(** Internally, a UUID is simply a string. *) +type 'a t =3D string + +type cookie =3D string + +let of_string s =3D s +let to_string s =3D s + +(* deprecated: we don't need to duplicate the uuid prefix/suffix *) +let uuid_of_string =3D of_string +let string_of_uuid =3D to_string + +let string_of_cookie s =3D s + +let cookie_of_string s =3D s + +(** FIXME: using /dev/random is too slow but using /dev/urandom is too + deterministic. *) +let dev_random =3D "/dev/urandom" + +let read_random n =3D=20 + let ic =3D open_in_bin dev_random in + try + let result =3D 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 =3D + Printf.sprintf "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%0= 2x%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) + +(** Return a new random UUID *) +let make_uuid() =3D uuid_of_int_array (read_random 16) + +(** Return a new random, big UUID (hopefully big and random enough to be + unguessable) *) +let make_cookie() =3D + let bytes =3D Array.to_list (read_random 64) in + String.concat "" (List.map (Printf.sprintf "%1x") bytes) +(* + let hexencode x =3D=20 + let nibble x =3D + char_of_int (if x < 10=20 + then int_of_char '0' + x + else int_of_char 'a' + (x - 10)) in + let result =3D String.make (String.length x * 2) ' ' in + for i =3D 0 to String.length x - 1 do + let byte =3D int_of_char x.[i] in + result.[i * 2 + 0] <- nibble((byte lsr 4) land 15); + result.[i * 2 + 1] <- nibble((byte lsr 0) land 15); + done; + result in + let n =3D 64 in + hexencode (String.concat "" (List.map (fun x -> String.make 1 (char_of= _int x)) (Array.to_list (read_n_random_bytes n)))) +*) + +let int_array_of_uuid s =3D + try + let l =3D 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 :=3D [ 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" diff --git a/tools/ocaml/libs/uuid/uuid.mli b/tools/ocaml/libs/uuid/uuid.= mli new file mode 100644 index 0000000..3b4a937 --- /dev/null +++ b/tools/ocaml/libs/uuid/uuid.mli @@ -0,0 +1,53 @@ +(* + * 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 publis= hed + * 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: + 1. to uniquely name things across the cluster + 2. as secure session IDs + There is the additional constraint that current Xen tools use=20 + a particular format of UUID (the 16 byte variety generated by fresh = ()) +*) + +(** A 128-bit UUID referencing a value of type 'a. *) +type 'a t + +(** A 512-bit UUID. *) +type cookie + +(** Create a fresh (unique!) UUID *) +val make_uuid : unit -> 'a t + +(** Create a fresh secure (bigger and hopefully unguessable) UUID *) +val make_cookie : unit -> cookie + +(** Create a type-safe UUID. *) +val of_string : string -> 'a t + +(** Marshal a UUID to a (type-unsafe) string. *) +val to_string : 'a t -> string + +(* deprecated alias for previous one *) +val uuid_of_string : string -> 'a t +val string_of_uuid : 'a t -> string + +val cookie_of_string : string -> cookie + +val string_of_cookie : cookie -> string + +val uuid_of_int_array : int array -> 'a t + +val int_array_of_uuid : 'a t -> int array diff --git a/tools/ocaml/libs/xb/META.in b/tools/ocaml/libs/xb/META.in new file mode 100644 index 0000000..c041010 --- /dev/null +++ b/tools/ocaml/libs/xb/META.in @@ -0,0 +1,4 @@ +version =3D "@VERSION@" +description =3D "XenBus Interface" +archive(byte) =3D "xb.cma" +archive(native) =3D "xb.cmxa" diff --git a/tools/ocaml/libs/xb/Makefile b/tools/ocaml/libs/xb/Makefile new file mode 100644 index 0000000..56afb4a --- /dev/null +++ b/tools/ocaml/libs/xb/Makefile @@ -0,0 +1,41 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +CFLAGS +=3D -I../mmap +OCAMLINCLUDE +=3D -I ../mmap + +.NOTPARALLEL: +# Ocaml is such a PITA! + +PREINTF =3D op.cmi partial.cmi packet.cmi +PREOBJS =3D op partial packet xs_ring +PRELIBS =3D $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJB= S),$(obj).cmx) +OBJS =3D op partial packet xs_ring xb +INTF =3D op.cmi packet.cmi xb.cmi +LIBS =3D xb.cma xb.cmxa + +ALL_OCAML_OBJS =3D $(OBJS) $(PREOJBS) + +all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +xb_OBJS =3D $(OBJS) +xb_C_OBJS =3D xs_ring_stubs xb_stubs +OCAML_LIBRARY =3D xb + +%.mli: %.ml + $(E) " MLI $@" + $(Q)$(OCAMLC) -i $< $o + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove xb + +include $(TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml new file mode 100644 index 0000000..6ea8fe6 --- /dev/null +++ b/tools/ocaml/libs/xb/op.ml @@ -0,0 +1,84 @@ +(* + * 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 publis= hed + * 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 operation =3D Debug | Directory | Read | Getperms | + Watch | Unwatch | Transaction_start | + Transaction_end | Introduce | Release | + Getdomainpath | Write | Mkdir | Rm | + Setperms | Watchevent | Error | Isintroduced | + Resume | Set_target + | Restrict=20 + +(* There are two sets of XB operations: the one coming from open-source = and *) +(* the one coming from our private patch queue. These operations = *) +(* in two differents arrays for make easier the forward compatibility = *) +let operation_c_mapping =3D + [| Debug; Directory; Read; Getperms; + Watch; Unwatch; Transaction_start; + Transaction_end; Introduce; Release; + Getdomainpath; Write; Mkdir; Rm; + Setperms; Watchevent; Error; Isintroduced; + Resume; Set_target |] +let size =3D Array.length operation_c_mapping + +(* [offset_pq] has to be the same as in *) +let offset_pq =3D size +let operation_c_mapping_pq =3D + [| Restrict |] +let size_pq =3D Array.length operation_c_mapping_pq + +let array_search el a =3D + let len =3D Array.length a in + let rec search i =3D + if i > len then raise Not_found; + if a.(i) =3D el then i else search (i + 1) in + search 0 + +let of_cval i =3D + if i >=3D 0 && i < size + then operation_c_mapping.(i) + else if i >=3D offset_pq && i < offset_pq + size_pq + then operation_c_mapping_pq.(i-offset_pq) + else raise Not_found + +let to_cval op =3D + try + array_search op operation_c_mapping + with _ -> offset_pq + array_search op operation_c_mapping_pq + +let to_string ty =3D + match ty with + | Debug -> "DEBUG" + | Directory -> "DIRECTORY" + | Read -> "READ" + | Getperms -> "GET_PERMS" + | Watch -> "WATCH" + | Unwatch -> "UNWATCH" + | Transaction_start -> "TRANSACTION_START" + | Transaction_end -> "TRANSACTION_END" + | Introduce -> "INTRODUCE" + | Release -> "RELEASE" + | Getdomainpath -> "GET_DOMAIN_PATH" + | Write -> "WRITE" + | Mkdir -> "MKDIR" + | Rm -> "RM" + | Setperms -> "SET_PERMS" + | Watchevent -> "WATCH_EVENT" + | Error -> "ERROR" + | Isintroduced -> "IS_INTRODUCED" + | Resume -> "RESUME" + | Set_target -> "SET_TARGET" + | Restrict -> "RESTRICT" diff --git a/tools/ocaml/libs/xb/packet.ml b/tools/ocaml/libs/xb/packet.m= l new file mode 100644 index 0000000..74c04bb --- /dev/null +++ b/tools/ocaml/libs/xb/packet.ml @@ -0,0 +1,50 @@ +(* + * 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 publis= hed + * 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 t =3D +{ + 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 =3D "stub_= string_of_header" + +let create tid rid ty data =3D { tid =3D tid; rid =3D rid; ty =3D ty; da= ta =3D data; } + +let of_partialpkt ppkt =3D + create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.conten= ts ppkt.Partial.buf) + +let to_string pkt =3D + let header =3D string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (St= ring.length pkt.data) in + header ^ pkt.data + +let unpack pkt =3D + pkt.tid, pkt.rid, pkt.ty, pkt.data + +let get_tid pkt =3D pkt.tid +let get_ty pkt =3D pkt.ty +let get_data pkt =3D + let l =3D String.length pkt.data in + if l > 0 && pkt.data.[l - 1] =3D '\000' then + String.sub pkt.data 0 (l - 1) + else + pkt.data +let get_rid pkt =3D pkt.rid \ No newline at end of file diff --git a/tools/ocaml/libs/xb/partial.ml b/tools/ocaml/libs/xb/partial= .ml new file mode 100644 index 0000000..3558889 --- /dev/null +++ b/tools/ocaml/libs/xb/partial.ml @@ -0,0 +1,44 @@ +(* + * 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 publis= hed + * 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 pkt =3D +{ + tid: int; + rid: int; + ty: Op.operation; + len: int; + buf: Buffer.t; +} + +external header_size: unit -> int =3D "stub_header_size" +external header_of_string_internal: string -> int * int * int * int + =3D "stub_header_of_string" + +let of_string s =3D + let tid, rid, opint, dlen =3D header_of_string_internal s in + { + tid =3D tid; + rid =3D rid; + ty =3D (Op.of_cval opint); + len =3D dlen; + buf =3D Buffer.create dlen; + } + +let append pkt s sz =3D + Buffer.add_string pkt.buf (String.sub s 0 sz) + +let to_complete pkt =3D + pkt.len - (Buffer.length pkt.buf) diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml new file mode 100644 index 0000000..4d02376 --- /dev/null +++ b/tools/ocaml/libs/xb/xb.ml @@ -0,0 +1,189 @@ +(* + * 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 publis= hed + * 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. + *) + +module Op =3D struct include Op end +module Packet =3D struct include Packet end + +exception End_of_file +exception Eagain +exception Noent +exception Invalid + +type backend_mmap =3D +{ + mmap: Mmap.mmap_interface; (* mmaped interface =3D xs_ring *) + eventchn_notify: unit -> unit; (* function to notify through eventchn *= ) + mutable work_again: bool; +} + +type backend_fd =3D +{ + fd: Unix.file_descr; +} + +type backend =3D Fd of backend_fd | Mmap of backend_mmap + +type partial_buf =3D HaveHdr of Partial.pkt | NoHdr of int * string + +type t =3D +{ + backend: backend; + pkt_in: Packet.t Queue.t; + pkt_out: Packet.t Queue.t; + mutable partial_in: partial_buf; + mutable partial_out: string; +} + +let init_partial_in () =3D NoHdr + (Partial.header_size (), String.make (Partial.header_size()) '\000') + +let queue con pkt =3D Queue.push pkt con.pkt_out + +let read_fd back con s len =3D + let rd =3D Unix.read back.fd s 0 len in + if rd =3D 0 then + raise End_of_file; + rd + +let read_mmap back con s len =3D + let rd =3D Xs_ring.read back.mmap s len in + back.work_again <- (rd > 0); + if rd > 0 then + back.eventchn_notify (); + rd + +let read con s len =3D + match con.backend with + | Fd backfd -> read_fd backfd con s len + | Mmap backmmap -> read_mmap backmmap con s len + +let write_fd back con s len =3D + Unix.write back.fd s 0 len + +let write_mmap back con s len =3D + let ws =3D Xs_ring.write back.mmap s len in + if ws > 0 then + back.eventchn_notify (); + ws + +let write con s len =3D + match con.backend with + | Fd backfd -> write_fd backfd con s len + | Mmap backmmap -> write_mmap backmmap con s len + +let output con =3D + (* get the output string from a string_of(packet) or partial_out *) + let s =3D if String.length con.partial_out > 0 then + con.partial_out + else if Queue.length con.pkt_out > 0 then + Packet.to_string (Queue.pop con.pkt_out) + else + "" in + (* send data from s, and save the unsent data to partial_out *) + if s <> "" then ( + let len =3D String.length s in + let sz =3D write con s len in + let left =3D String.sub s sz (len - sz) in + con.partial_out <- left + ); + (* after sending one packet, partial is empty *) + con.partial_out =3D "" + +let input con =3D + let newpacket =3D ref false in + let to_read =3D + match con.partial_in with + | HaveHdr partial_pkt -> Partial.to_complete partial_pkt + | NoHdr (i, buf) -> i in + + (* try to get more data from input stream *) + let s =3D String.make to_read '\000' in + let sz =3D if to_read > 0 then read con s to_read else 0 in + + ( + match con.partial_in with + | HaveHdr partial_pkt -> + (* we complete the data *) + if sz > 0 then + Partial.append partial_pkt s sz; + if Partial.to_complete partial_pkt =3D 0 then ( + let pkt =3D Packet.of_partialpkt partial_pkt in + con.partial_in <- init_partial_in (); + Queue.push pkt con.pkt_in; + newpacket :=3D true + ) + | NoHdr (i, buf) -> + (* we complete the partial header *) + if sz > 0 then + String.blit s 0 buf (Partial.header_size () - i) sz; + con.partial_in <- if sz =3D i then + HaveHdr (Partial.of_string buf) else NoHdr (i - sz, buf) + ); + !newpacket + +let newcon backend =3D { + backend =3D backend; + pkt_in =3D Queue.create (); + pkt_out =3D Queue.create (); + partial_in =3D init_partial_in (); + partial_out =3D ""; + } + +let open_fd fd =3D newcon (Fd { fd =3D fd; }) + +let open_mmap mmap notifyfct =3D + newcon (Mmap { + mmap =3D mmap; + eventchn_notify =3D notifyfct; + work_again =3D false; }) + +let close con =3D + match con.backend with + | Fd backend -> Unix.close backend.fd + | Mmap backend -> Mmap.unmap backend.mmap + +let is_fd con =3D + match con.backend with + | Fd _ -> true + | Mmap _ -> false + +let is_mmap con =3D not (is_fd con) + +let output_len con =3D Queue.length con.pkt_out +let has_new_output con =3D Queue.length con.pkt_out > 0 +let has_old_output con =3D String.length con.partial_out > 0 + +let has_output con =3D has_new_output con || has_old_output con + +let peek_output con =3D Queue.peek con.pkt_out + +let input_len con =3D Queue.length con.pkt_in +let has_in_packet con =3D Queue.length con.pkt_in > 0 +let get_in_packet con =3D Queue.pop con.pkt_in +let has_more_input con =3D + match con.backend with + | Fd _ -> false + | Mmap backend -> backend.work_again + +let is_selectable con =3D + match con.backend with + | Fd _ -> true + | Mmap _ -> false + +let get_fd con =3D + match con.backend with + | Fd backend -> backend.fd + | Mmap _ -> raise (Failure "get_fd") diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli new file mode 100644 index 0000000..6cbf0a8 --- /dev/null +++ b/tools/ocaml/libs/xb/xb.mli @@ -0,0 +1,83 @@ +module Op: +sig + type operation =3D Op.operation =3D + | 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 + +exception End_of_file +exception Eagain +exception Noent +exception Invalid + +type t + +(** queue a packet into the output queue for later sending *) +val queue : t -> Packet.t -> unit + +(** process the output queue, return if a packet has been totally sent *= ) +val output : t -> bool + +(** process the input queue, return if a packet has been totally receive= d *) +val input : t -> bool + +(** create new connection using a fd interface *) +val open_fd : Unix.file_descr -> t +(** create new connection using a mmap intf and a function to notify eve= ntchn *) +val open_mmap : Mmap.mmap_interface -> (unit -> unit) -> t + +(* close a connection *) +val close : t -> unit + +val is_fd : t -> bool +val is_mmap : t -> bool + +val output_len : t -> int +val has_new_output : t -> bool +val has_old_output : t -> bool +val has_output : t -> bool +val peek_output : t -> Packet.t + +val input_len : t -> int +val has_in_packet : t -> bool +val get_in_packet : t -> Packet.t +val has_more_input : t -> bool + +val is_selectable : t -> bool +val get_fd : t -> Unix.file_descr diff --git a/tools/ocaml/libs/xb/xb_stubs.c b/tools/ocaml/libs/xb/xb_stub= s.c new file mode 100644 index 0000000..b4d1ee6 --- /dev/null +++ b/tools/ocaml/libs/xb/xb_stubs.c @@ -0,0 +1,74 @@ +/* + * 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 publis= hed + * 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 __XEN_TOOLS__ + +#include +#define u32 uint32_t +#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) !=3D sizeof(struct xsd_sockmsg)) + caml_failwith("xb header incomplete"); + ret =3D caml_alloc_tuple(4); + hdr =3D (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, val= ue len) +{ + CAMLparam4(tid, rid, ty, len); + CAMLlocal1(ret); + struct xsd_sockmsg xsd =3D { + .type =3D Int_val(ty), + .tx_id =3D Int_val(tid), + .req_id =3D Int_val(rid), + .len =3D Int_val(len), + }; + + ret =3D caml_alloc_string(sizeof(struct xsd_sockmsg)); + memcpy(String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); + + CAMLreturn(ret); +} diff --git a/tools/ocaml/libs/xb/xs_ring.ml b/tools/ocaml/libs/xb/xs_ring= .ml new file mode 100644 index 0000000..00c18d5 --- /dev/null +++ b/tools/ocaml/libs/xb/xs_ring.ml @@ -0,0 +1,18 @@ +(* + * 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 publis= hed + * 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. + *) + +external read: Mmap.mmap_interface -> string -> int -> int =3D "ml_inter= face_read" +external write: Mmap.mmap_interface -> string -> int -> int =3D "ml_inte= rface_write" diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs= _ring_stubs.c new file mode 100644 index 0000000..9aef23e --- /dev/null +++ b/tools/ocaml/libs/xb/xs_ring_stubs.c @@ -0,0 +1,117 @@ +/* + * 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 publis= hed + * 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 + +#define __XEN_TOOLS__ + +#include +#define u32 uint32_t +#include + +#include +#include +#include +#include +#include +#include + +#include "mmap_stubs.h" + +#define GET_C_STRUCT(a) ((struct mmap_interface *) a) + +#ifndef xen_mb +#define xen_mb() mb() +#endif + +static int xs_ring_read(struct mmap_interface *interface, + char *buffer, int len) +{ + struct xenstore_domain_interface *intf =3D interface->addr; + XENSTORE_RING_IDX cons, prod; + int to_read; + + cons =3D intf->req_cons; + prod =3D intf->req_prod; + xen_mb(); + if (prod =3D=3D cons) + return 0; + if (MASK_XENSTORE_IDX(prod) > MASK_XENSTORE_IDX(cons))=20 + to_read =3D prod - cons; + else + to_read =3D XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons); + if (to_read < len) + len =3D to_read; + memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len); + xen_mb(); + intf->req_cons +=3D len; + return len; +} + +static int xs_ring_write(struct mmap_interface *interface, + char *buffer, int len) +{ + struct xenstore_domain_interface *intf =3D interface->addr; + XENSTORE_RING_IDX cons, prod; + int can_write; + + cons =3D intf->rsp_cons; + prod =3D intf->rsp_prod; + xen_mb(); + if ( (prod - cons) >=3D XENSTORE_RING_SIZE ) + return 0; + if (MASK_XENSTORE_IDX(prod) >=3D MASK_XENSTORE_IDX(cons)) + can_write =3D XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod); + else=20 + can_write =3D MASK_XENSTORE_IDX(cons) - MASK_XENSTORE_IDX(prod); + if (can_write < len) + len =3D can_write; + memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len); + xen_mb(); + intf->rsp_prod +=3D len; + return len; +} + +CAMLprim value ml_interface_read(value interface, value buffer, value le= n) +{ + CAMLparam3(interface, buffer, len); + CAMLlocal1(result); + int res; + + res =3D xs_ring_read(GET_C_STRUCT(interface), + String_val(buffer), Int_val(len)); + if (res =3D=3D -1) + caml_failwith("huh"); + result =3D Val_int(res); + CAMLreturn(result); +} + +CAMLprim value ml_interface_write(value interface, value buffer, value l= en) +{ + CAMLparam3(interface, buffer, len); + CAMLlocal1(result); + int res; + + res =3D xs_ring_write(GET_C_STRUCT(interface), + String_val(buffer), Int_val(len)); + result =3D Val_int(res); + CAMLreturn(result); +} diff --git a/tools/ocaml/libs/xc/META.in b/tools/ocaml/libs/xc/META.in new file mode 100644 index 0000000..e46d7dd --- /dev/null +++ b/tools/ocaml/libs/xc/META.in @@ -0,0 +1,4 @@ +version =3D "@VERSION@" +description =3D "Xen Control Interface" +archive(byte) =3D "xc.cma" +archive(native) =3D "xc.cmxa" diff --git a/tools/ocaml/libs/xc/Makefile b/tools/ocaml/libs/xc/Makefile new file mode 100644 index 0000000..9e361b5 --- /dev/null +++ b/tools/ocaml/libs/xc/Makefile @@ -0,0 +1,28 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +CFLAGS +=3D -I../mmap -I./ +OCAMLINCLUDE +=3D -I ../mmap -I ../uuid + +OBJS =3D xc +INTF =3D xc.cmi +LIBS =3D xc.cma xc.cmxa + +xc_OBJS =3D $(OBJS) +xc_C_OBJS =3D xc_lib xc_stubs + +OCAML_LIBRARY =3D xc + +all: $(INTF) $(LIBS) + +libs: $(LIBS) + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -ldconf ignore xc META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove xc + +include $(TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xc/xc.h b/tools/ocaml/libs/xc/xc.h new file mode 100644 index 0000000..8ef7009 --- /dev/null +++ b/tools/ocaml/libs/xc/xc.h @@ -0,0 +1,191 @@ +/* + * 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 publis= hed + * 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 __XEN_TOOLS__ + +#include +#include +#include +#include +#include +#include +#if XEN_SYSCTL_INTERFACE_VERSION < 4 +#include +#else +#include +#endif +#include +#include +#include +#include +#include "xc_e820.h" + +typedef xen_domctl_getdomaininfo_t xc_domaininfo_t; +typedef xen_domctl_getvcpuinfo_t xc_vcpuinfo_t; +typedef xen_sysctl_physinfo_t xc_physinfo_t; + +struct xc_core_header { + unsigned int xch_magic; + unsigned int xch_nr_vcpus; + unsigned int xch_nr_pages; + unsigned int xch_ctxt_offset; + unsigned int xch_index_offset; + unsigned int xch_pages_offset; +}; + +typedef union { +#if defined(__i386__) || defined(__x86_64__) + vcpu_guest_context_x86_64_t x64; + vcpu_guest_context_x86_32_t x32; +#endif + vcpu_guest_context_t c; +} vcpu_guest_context_any_t; + +char * xc_error_get(void); +void xc_error_clear(void); + +int xc_using_injection(void); + +int xc_interface_open(void); +int xc_interface_close(int handle); + +int xc_domain_create(int handle, unsigned int ssidref, + xen_domain_handle_t dhandle, + unsigned int flags, unsigned int *pdomid); +int xc_domain_pause(int handle, unsigned int domid); +int xc_domain_unpause(int handle, unsigned int domid); +int xc_domain_resume_fast(int handle, unsigned int domid); +int xc_domain_destroy(int handle, unsigned int domid); +int xc_domain_shutdown(int handle, int domid, int reason); + +int xc_vcpu_setaffinity(int handle, unsigned int domid, int vcpu, + uint64_t cpumap); +int xc_vcpu_getaffinity(int handle, unsigned int domid, int vcpu, + uint64_t *cpumap); + +int xc_domain_getinfolist(int handle, unsigned int first_domain, + unsigned int max_domains, xc_domaininfo_t *inf= o); +int xc_domain_getinfo(int handle, unsigned int first_domain, + xc_domaininfo_t *info); + +int xc_domain_setmaxmem(int handle, unsigned int domid, unsigned int max= _memkb); +int xc_domain_set_memmap_limit(int handle, unsigned int domid, + unsigned long map_limitkb); + +int xc_domain_set_time_offset(int handle, unsigned int domid, int time_o= ffset); + +int xc_domain_memory_increase_reservation(int handle, unsigned int domid= , + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start); +int xc_domain_memory_decrease_reservation(int handle, unsigned int domid= , + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start); +int xc_domain_memory_populate_physmap(int handle, unsigned int domid, + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start); +int xc_domain_setvmxassist(int handle, unsigned int domid, int use_vmxas= sist); +int xc_domain_max_vcpus(int handle, unsigned int domid, unsigned int max= ); +int xc_domain_sethandle(int handle, unsigned int domid, + xen_domain_handle_t dhandle); +int xc_vcpu_getinfo(int handle, unsigned int domid, unsigned int vcpu, + xc_vcpuinfo_t *info); +int xc_domain_ioport_permission(int handle, unsigned int domid, + unsigned int first_port, unsigned int nr= _ports, + unsigned int allow_access); +int xc_vcpu_setcontext(int handle, unsigned int domid, + unsigned int vcpu, vcpu_guest_context_any_t *ctxt= ); +int xc_vcpu_getcontext(int handle, unsigned int domid, + unsigned int vcpu, vcpu_guest_context_any_t *ctxt= ); +int xc_domain_irq_permission(int handle, unsigned int domid, + unsigned char pirq, unsigned char allow_acc= ess); +int xc_domain_iomem_permission(int handle, unsigned int domid, + unsigned long first_mfn, unsigned long nr= _mfns, + unsigned char allow_access); +long long xc_domain_get_cpu_usage(int handle, unsigned int domid, + unsigned int vcpu); +void *xc_map_foreign_range(int handle, unsigned int domid, + int size, int prot, unsigned long mfn); +int xc_map_foreign_ranges(int handle, unsigned int domid, + privcmd_mmap_entry_t *entries, int nr); +int xc_readconsolering(int handle, char **pbuffer, + unsigned int *pnr_chars, int clear); +int xc_send_debug_keys(int handle, char *keys); +int xc_physinfo(int handle, xc_physinfo_t *put_info); +int xc_pcpu_info(int handle, int max_cpus, uint64_t *info, int *nr_cpus)= ; +int xc_sched_id(int handle, int *sched_id); +int xc_version(int handle, int cmd, void *arg); +int xc_evtchn_alloc_unbound(int handle, unsigned int domid, + unsigned int remote_domid); +int xc_evtchn_reset(int handle, unsigned int domid); + +int xc_sched_credit_domain_set(int handle, unsigned int domid, + struct xen_domctl_sched_credit *sdom); +int xc_sched_credit_domain_get(int handle, unsigned int domid, + struct xen_domctl_sched_credit *sdom); +int xc_shadow_allocation_get(int handle, unsigned int domid, + uint32_t *mb); +int xc_shadow_allocation_set(int handle, unsigned int domid, + uint32_t mb); +int xc_domain_get_pfn_list(int handle, unsigned int domid, + xen_pfn_t *pfn_array, unsigned long max_pfns)= ; +int xc_hvm_check_pvdriver(int handle, unsigned int domid); + +int xc_domain_assign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func); +int xc_domain_deassign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func); +int xc_domain_test_assign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func= ); +int xc_domain_watchdog(int handle, int id, uint32_t timeout); +int xc_domain_set_machine_address_size(int xc, uint32_t domid, unsigned = int width); +int xc_domain_get_machine_address_size(int xc, uint32_t domid); + +int xc_domain_cpuid_set(int xc, unsigned int domid, int hvm, + uint32_t input, uint32_t oinput, + char *config[4], char *config_out[4]); +int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm); +int xc_cpuid_check(uint32_t input, uint32_t optsubinput, + char *config[4], char *config_out[4]); + +int xc_domain_send_s3resume(int handle, unsigned int domid); +int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_alig= n); +int xc_domain_set_hpet(int handle, unsigned int domid, int hpet); +int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode); +int xc_domain_get_acpi_s_state(int handle, unsigned int domid); + +#if XEN_SYSCTL_INTERFACE_VERSION >=3D 6 +#define SAFEDIV(a, b) (((b) > 0) ? (a) / (b) : (a)) +#define COMPAT_FIELD_physinfo_get_nr_cpus(p) (p).nr_cpus +#define COMPAT_FIELD_physinfo_get_sockets_per_node(p) \ + SAFEDIV((p).nr_cpus, ((p).threads_per_core * (p).cores_per_socket * (p)= .nr_nodes)) +#else +#define COMPAT_FIELD_physinfo_get_nr_cpus(p) \ + ((p).threads_per_core * (p).sockets_per_node * \ + (p).cores_per_socket * (p).threads_per_core) +#define COMPAT_FIELD_physinfo_get_sockets_per_node(p) (p).sockets_per_no= de +#endif + +#if __XEN_LATEST_INTERFACE_VERSION__ >=3D 0x00030209 +#define COMPAT_FIELD_ADDRESS_BITS mem_flags +#else +#define COMPAT_FIELD_ADDRESS_BITS address_bits +#endif diff --git a/tools/ocaml/libs/xc/xc.ml b/tools/ocaml/libs/xc/xc.ml new file mode 100644 index 0000000..b9dd284 --- /dev/null +++ b/tools/ocaml/libs/xc/xc.ml @@ -0,0 +1,340 @@ +(* + * 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 publis= hed + * 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 =3D int + +(* ** xenctrl.h ** *) + +type vcpuinfo =3D +{ + online: bool; + blocked: bool; + running: bool; + cputime: int64; + cpumap: int32; +} + +type domaininfo =3D +{ + 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 =3D +{ + weight : int; + cap : int; +} + +type physinfo_cap_flag =3D + | CAP_HVM + | CAP_DirectIO + +type physinfo =3D +{ + 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 =3D +{ + major : int; + minor : int; + extra : string; +} + + +type compile_info =3D +{ + compiler : string; + compile_by : string; + compile_domain : string; + compile_date : string; +} + +type shutdown_reason =3D Poweroff | Reboot | Suspend | Crash | Halt + +type domain_create_flag =3D CDF_HVM | CDF_HAP + +exception Error of string + +type handle + +(* this is only use by coredumping *) +external sizeof_core_header: unit -> int + =3D "stub_sizeof_core_header" +external sizeof_vcpu_guest_context: unit -> int + =3D "stub_sizeof_vcpu_guest_context" +external sizeof_xen_pfn: unit -> int =3D "stub_sizeof_xen_pfn" +(* end of use *) + +external interface_open: unit -> handle =3D "stub_xc_interface_open" +external interface_close: handle -> unit =3D "stub_xc_interface_close" + +external using_injection: unit -> bool =3D "stub_xc_using_injection" + +let with_intf f =3D + let xc =3D interface_open () in + let r =3D try f xc with exn -> interface_close xc; raise exn in + interface_close xc; + r + +external _domain_create: handle -> int32 -> domain_create_flag list -> i= nt array -> domid + =3D "stub_xc_domain_create" + +let domain_create handle n flags uuid =3D + _domain_create handle n flags (Uuid.int_array_of_uuid uuid) + +external _domain_sethandle: handle -> domid -> int array -> unit + =3D "stub_xc_domain_sethandle" + +let domain_sethandle handle n uuid =3D + _domain_sethandle handle n (Uuid.int_array_of_uuid uuid) + +external domain_setvmxassist: handle -> domid -> bool -> unit + =3D "stub_xc_domain_setvmxassist" + +external domain_max_vcpus: handle -> domid -> int -> unit + =3D "stub_xc_domain_max_vcpus" + +external domain_pause: handle -> domid -> unit =3D "stub_xc_domain_pause= " +external domain_unpause: handle -> domid -> unit =3D "stub_xc_domain_unp= ause" +external domain_resume_fast: handle -> domid -> unit =3D "stub_xc_domain= _resume_fast" +external domain_destroy: handle -> domid -> unit =3D "stub_xc_domain_des= troy" + +external domain_shutdown: handle -> domid -> shutdown_reason -> unit + =3D "stub_xc_domain_shutdown" + +external _domain_getinfolist: handle -> domid -> int -> domaininfo list + =3D "stub_xc_domain_getinfolist" + +let domain_getinfolist handle first_domain =3D + let nb =3D 2 in + let last_domid l =3D (List.hd l).domid + 1 in + let rec __getlist from =3D + let l =3D _domain_getinfolist handle from nb in + (if List.length l =3D nb then __getlist (last_domid l) else []) @ l + in + List.rev (__getlist first_domain) + +external domain_getinfo: handle -> domid -> domaininfo=3D "stub_xc_domai= n_getinfo" + +external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo + =3D "stub_xc_vcpu_getinfo" + +external domain_ioport_permission: handle -> domid -> int -> int -> bool= -> unit + =3D "stub_xc_domain_ioport_permission" +external domain_iomem_permission: handle -> domid -> nativeint -> native= int -> bool -> unit + =3D "stub_xc_domain_iomem_permission" +external domain_irq_permission: handle -> domid -> int -> bool -> unit + =3D "stub_xc_domain_irq_permission" + +external vcpu_affinity_set: handle -> domid -> int -> int64 -> unit + =3D "stub_xc_vcpu_setaffinity" +external vcpu_affinity_get: handle -> domid -> int -> int64 + =3D "stub_xc_vcpu_getaffinity" + +external vcpu_context_get: handle -> domid -> int -> string + =3D "stub_xc_vcpu_context_get" + +external sched_id: handle -> int =3D "stub_xc_sched_id" + +external sched_credit_domain_set: handle -> domid -> sched_control -> un= it + =3D "stub_sched_credit_domain_set" +external sched_credit_domain_get: handle -> domid -> sched_control + =3D "stub_sched_credit_domain_get" + +external shadow_allocation_set: handle -> domid -> int -> unit + =3D "stub_shadow_allocation_set" +external shadow_allocation_get: handle -> domid -> int + =3D "stub_shadow_allocation_get" + +external evtchn_alloc_unbound: handle -> domid -> domid -> int + =3D "stub_xc_evtchn_alloc_unbound" +external evtchn_reset: handle -> domid -> unit =3D "stub_xc_evtchn_reset= " + +external readconsolering: handle -> string =3D "stub_xc_readconsolering" + +external send_debug_keys: handle -> string -> unit =3D "stub_xc_send_deb= ug_keys" +external physinfo: handle -> physinfo =3D "stub_xc_physinfo" +external pcpu_info: handle -> int -> int64 array =3D "stub_xc_pcpu_info" + +external domain_setmaxmem: handle -> domid -> int64 -> unit + =3D "stub_xc_domain_setmaxmem" +external domain_set_memmap_limit: handle -> domid -> int64 -> unit + =3D "stub_xc_domain_set_memmap_limit" +external domain_memory_increase_reservation: handle -> domid -> int64 ->= unit + =3D "stub_xc_domain_memory_increase_reservation" + +external domain_set_machine_address_size: handle -> domid -> int -> unit + =3D "stub_xc_domain_set_machine_address_size" +external domain_get_machine_address_size: handle -> domid -> int + =3D "stub_xc_domain_get_machine_address_size" + +external domain_cpuid_set: handle -> domid -> bool -> (int64 * (int64 op= tion)) + -> string option array + -> string option array + =3D "stub_xc_domain_cpuid_set" +external domain_cpuid_apply: handle -> domid -> bool -> unit + =3D "stub_xc_domain_cpuid_apply" +external cpuid_check: (int64 * (int64 option)) -> string option array ->= (bool * string option array) + =3D "stub_xc_cpuid_check" + +external map_foreign_range: handle -> domid -> int + -> nativeint -> Mmap.mmap_interface + =3D "stub_map_foreign_range" + +external domain_get_pfn_list: handle -> domid -> nativeint -> nativeint = array + =3D "stub_xc_domain_get_pfn_list" + +external domain_assign_device: handle -> domid -> (int * int * int * int= ) -> unit + =3D "stub_xc_domain_assign_device" +external domain_deassign_device: handle -> domid -> (int * int * int * i= nt) -> unit + =3D "stub_xc_domain_deassign_device" +external domain_test_assign_device: handle -> domid -> (int * int * int = * int) -> bool + =3D "stub_xc_domain_test_assign_device" + +external domain_set_timer_mode: handle -> domid -> int -> unit =3D "stub= _xc_domain_set_timer_mode" +external domain_set_hpet: handle -> domid -> int -> unit =3D "stub_xc_do= main_set_hpet" +external domain_set_vpt_align: handle -> domid -> int -> unit =3D "stub_= xc_domain_set_vpt_align" + +external domain_send_s3resume: handle -> domid -> unit =3D "stub_xc_doma= in_send_s3resume" +external domain_get_acpi_s_state: handle -> domid -> int =3D "stub_xc_do= main_get_acpi_s_state" + +(** check if some hvm domain got pv driver or not *) +external hvm_check_pvdriver: handle -> domid -> bool + =3D "stub_xc_hvm_check_pvdriver" + +external version: handle -> version =3D "stub_xc_version_version" +external version_compile_info: handle -> compile_info + =3D "stub_xc_version_compile_info" +external version_changeset: handle -> string =3D "stub_xc_version_change= set" +external version_capabilities: handle -> string =3D + "stub_xc_version_capabilities" + +external watchdog : handle -> int -> int32 -> int + =3D "stub_xc_watchdog" + +(* core dump structure *) +type core_magic =3D Magic_hvm | Magic_pv + +type core_header =3D { + 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 =3D "stub_marshall_= core_header" + +(* coredump *) +let coredump xch domid fd =3D + let dump s =3D + let wd =3D Unix.write fd s 0 (String.length s) in + if wd <> String.length s then + failwith "error while writing"; + in + + let info =3D domain_getinfo xch domid in + + let nrpages =3D info.total_memory_pages in + let ctxt =3D Array.make info.max_vcpu_id None in + let nr_vcpus =3D ref 0 in + for i =3D 0 to info.max_vcpu_id - 1 + do + ctxt.(i) <- try + let v =3D 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 =3D + 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 =3D { + xch_magic =3D if info.hvm_guest then Magic_hvm else Magic_pv; + xch_nr_vcpus =3D !nr_vcpus; + xch_nr_pages =3D nrpages; + xch_ctxt_offset =3D Int64.of_int (sizeof_core_header ()); + xch_index_offset =3D Int64.of_int (sizeof_core_header () + + sizeof_vcpu_guest_context ()); + xch_pages_offset =3D page_offset; + } in + + dump (marshall_core_header header); + for i =3D 0 to info.max_vcpu_id - 1 + do + match ctxt.(i) with + | None -> () + | Some ctxt_i -> dump ctxt_i + done; + let pfns =3D 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 =3D Mmap.getpagesize () in + for i =3D 0 to Nativeint.to_int nrpages - 1 + do + let page =3D map_foreign_range xch domid page_size pfns.(i) in + let data =3D 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 =3D "stub_pages_to_kib" +let pages_to_mib pages =3D Int64.div (pages_to_kib pages) 1024L + +let _ =3D Callback.register_exception "xc.error" (Error "register_callba= ck") diff --git a/tools/ocaml/libs/xc/xc.mli b/tools/ocaml/libs/xc/xc.mli new file mode 100644 index 0000000..dc55b67 --- /dev/null +++ b/tools/ocaml/libs/xc/xc.mli @@ -0,0 +1,196 @@ +(* + * 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 publis= hed + * 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 =3D int +type vcpuinfo =3D { + online : bool; + blocked : bool; + running : bool; + cputime : int64; + cpumap : int32; +} +type domaininfo =3D { + 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 =3D { weight : int; cap : int; } +type physinfo_cap_flag =3D CAP_HVM | CAP_DirectIO +type physinfo =3D { + 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 =3D { major : int; minor : int; extra : string; } +type compile_info =3D { + compiler : string; + compile_by : string; + compile_domain : string; + compile_date : string; +} +type shutdown_reason =3D Poweroff | Reboot | Suspend | Crash | Halt + +type domain_create_flag =3D CDF_HVM | CDF_HAP + +exception Error of string +type handle +external sizeof_core_header : unit -> int =3D "stub_sizeof_core_header" +external sizeof_vcpu_guest_context : unit -> int + =3D "stub_sizeof_vcpu_guest_context" +external sizeof_xen_pfn : unit -> int =3D "stub_sizeof_xen_pfn" +external interface_open : unit -> handle =3D "stub_xc_interface_open" +external using_injection : unit -> bool =3D "stub_xc_using_injection" +external interface_close : handle -> unit =3D "stub_xc_interface_close" +val with_intf : (handle -> 'a) -> 'a +external _domain_create : handle -> int32 -> domain_create_flag list -> = int array -> domid + =3D "stub_xc_domain_create" +val domain_create : handle -> int32 -> domain_create_flag list -> 'a Uui= d.t -> domid +external _domain_sethandle : handle -> domid -> int array -> unit + =3D "stub_xc_domain_sethandle" +val domain_sethandle : handle -> domid -> 'a Uuid.t -> unit +external domain_setvmxassist: handle -> domid -> bool -> unit + =3D "stub_xc_domain_setvmxassist" +external domain_max_vcpus : handle -> domid -> int -> unit + =3D "stub_xc_domain_max_vcpus" +external domain_pause : handle -> domid -> unit =3D "stub_xc_domain_paus= e" +external domain_unpause : handle -> domid -> unit =3D "stub_xc_domain_un= pause" +external domain_resume_fast : handle -> domid -> unit + =3D "stub_xc_domain_resume_fast" +external domain_destroy : handle -> domid -> unit =3D "stub_xc_domain_de= stroy" +external domain_shutdown : handle -> domid -> shutdown_reason -> unit + =3D "stub_xc_domain_shutdown" +external _domain_getinfolist : handle -> domid -> int -> domaininfo list + =3D "stub_xc_domain_getinfolist" +val domain_getinfolist : handle -> domid -> domaininfo list +external domain_getinfo : handle -> domid -> domaininfo + =3D "stub_xc_domain_getinfo" +external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo + =3D "stub_xc_vcpu_getinfo" +external domain_ioport_permission: handle -> domid -> int -> int -> bool= -> unit + =3D "stub_xc_domain_ioport_permission" +external domain_iomem_permission: handle -> domid -> nativeint -> native= int -> bool -> unit + =3D "stub_xc_domain_iomem_permission" +external domain_irq_permission: handle -> domid -> int -> bool -> unit + =3D "stub_xc_domain_irq_permission" +external vcpu_affinity_set : handle -> domid -> int -> int64 -> unit + =3D "stub_xc_vcpu_setaffinity" +external vcpu_affinity_get : handle -> domid -> int -> int64 + =3D "stub_xc_vcpu_getaffinity" +external vcpu_context_get : handle -> domid -> int -> string + =3D "stub_xc_vcpu_context_get" +external sched_id : handle -> int =3D "stub_xc_sched_id" +external sched_credit_domain_set : handle -> domid -> sched_control -> u= nit + =3D "stub_sched_credit_domain_set" +external sched_credit_domain_get : handle -> domid -> sched_control + =3D "stub_sched_credit_domain_get" +external shadow_allocation_set : handle -> domid -> int -> unit + =3D "stub_shadow_allocation_set" +external shadow_allocation_get : handle -> domid -> int + =3D "stub_shadow_allocation_get" +external evtchn_alloc_unbound : handle -> domid -> domid -> int + =3D "stub_xc_evtchn_alloc_unbound" +external evtchn_reset : handle -> domid -> unit =3D "stub_xc_evtchn_rese= t" +external readconsolering : handle -> string =3D "stub_xc_readconsolering= " +external send_debug_keys : handle -> string -> unit =3D "stub_xc_send_de= bug_keys" +external physinfo : handle -> physinfo =3D "stub_xc_physinfo" +external pcpu_info: handle -> int -> int64 array =3D "stub_xc_pcpu_info" +external domain_setmaxmem : handle -> domid -> int64 -> unit + =3D "stub_xc_domain_setmaxmem" +external domain_set_memmap_limit : handle -> domid -> int64 -> unit + =3D "stub_xc_domain_set_memmap_limit" +external domain_memory_increase_reservation : + handle -> domid -> int64 -> unit + =3D "stub_xc_domain_memory_increase_reservation" +external map_foreign_range : + handle -> domid -> int -> nativeint -> Mmap.mmap_interface + =3D "stub_map_foreign_range" +external domain_get_pfn_list : + handle -> domid -> nativeint -> nativeint array + =3D "stub_xc_domain_get_pfn_list" + +external domain_assign_device: handle -> domid -> (int * int * int * int= ) -> unit + =3D "stub_xc_domain_assign_device" +external domain_deassign_device: handle -> domid -> (int * int * int * i= nt) -> unit + =3D "stub_xc_domain_deassign_device" +external domain_test_assign_device: handle -> domid -> (int * int * int = * int) -> bool + =3D "stub_xc_domain_test_assign_device" + +external domain_set_timer_mode: handle -> domid -> int -> unit =3D "stub= _xc_domain_set_timer_mode" +external domain_set_hpet: handle -> domid -> int -> unit =3D "stub_xc_do= main_set_hpet" +external domain_set_vpt_align: handle -> domid -> int -> unit =3D "stub_= xc_domain_set_vpt_align" + +external domain_send_s3resume: handle -> domid -> unit + =3D "stub_xc_domain_send_s3resume" +external domain_get_acpi_s_state: handle -> domid -> int =3D "stub_xc_do= main_get_acpi_s_state" + +external hvm_check_pvdriver : handle -> domid -> bool + =3D "stub_xc_hvm_check_pvdriver" +external version : handle -> version =3D "stub_xc_version_version" +external version_compile_info : handle -> compile_info + =3D "stub_xc_version_compile_info" +external version_changeset : handle -> string =3D "stub_xc_version_chang= eset" +external version_capabilities : handle -> string + =3D "stub_xc_version_capabilities" +type core_magic =3D Magic_hvm | Magic_pv +type core_header =3D { + 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 + =3D "stub_marshall_core_header" +val coredump : handle -> domid -> Unix.file_descr -> unit +external pages_to_kib : int64 -> int64 =3D "stub_pages_to_kib" +val pages_to_mib : int64 -> int64 +external watchdog : handle -> int -> int32 -> int + =3D "stub_xc_watchdog" + +external domain_set_machine_address_size: handle -> domid -> int -> unit + =3D "stub_xc_domain_set_machine_address_size" +external domain_get_machine_address_size: handle -> domid -> int + =3D "stub_xc_domain_get_machine_address_size" + +external domain_cpuid_set: handle -> domid -> bool -> (int64 * (int64 op= tion)) + -> string option array + -> string option array + =3D "stub_xc_domain_cpuid_set" +external domain_cpuid_apply: handle -> domid -> bool -> unit + =3D "stub_xc_domain_cpuid_apply" +external cpuid_check: (int64 * (int64 option)) -> string option array ->= (bool * string option array) + =3D "stub_xc_cpuid_check" + diff --git a/tools/ocaml/libs/xc/xc_cpufeature.h b/tools/ocaml/libs/xc/xc= _cpufeature.h new file mode 100644 index 0000000..047a6c9 --- /dev/null +++ b/tools/ocaml/libs/xc/xc_cpufeature.h @@ -0,0 +1,116 @@ +#ifndef __LIBXC_CPUFEATURE_H +#define __LIBXC_CPUFEATURE_H + +/* Intel-defined CPU features, CPUID level 0x00000001 (edx), word 0 */ +#define X86_FEATURE_FPU (0*32+ 0) /* Onboard FPU */ +#define X86_FEATURE_VME (0*32+ 1) /* Virtual Mode Extensions */ +#define X86_FEATURE_DE (0*32+ 2) /* Debugging Extensions */ +#define X86_FEATURE_PSE (0*32+ 3) /* Page Size Extensions */ +#define X86_FEATURE_TSC (0*32+ 4) /* Time Stamp Counter */ +#define X86_FEATURE_MSR (0*32+ 5) /* Model-Specific Registers, RDMSR, W= RMSR */ +#define X86_FEATURE_PAE (0*32+ 6) /* Physical Address Extensions */ +#define X86_FEATURE_MCE (0*32+ 7) /* Machine Check Architecture */ +#define X86_FEATURE_CX8 (0*32+ 8) /* CMPXCHG8 instruction */ +#define X86_FEATURE_APIC (0*32+ 9) /* Onboard APIC */ +#define X86_FEATURE_SEP (0*32+11) /* SYSENTER/SYSEXIT */ +#define X86_FEATURE_MTRR (0*32+12) /* Memory Type Range Registers */ +#define X86_FEATURE_PGE (0*32+13) /* Page Global Enable */ +#define X86_FEATURE_MCA (0*32+14) /* Machine Check Architecture */ +#define X86_FEATURE_CMOV (0*32+15) /* CMOV instruction (FCMOVCC and FCOM= I too if FPU present) */ +#define X86_FEATURE_PAT (0*32+16) /* Page Attribute Table */ +#define X86_FEATURE_PSE36 (0*32+17) /* 36-bit PSEs */ +#define X86_FEATURE_PN (0*32+18) /* Processor serial number */ +#define X86_FEATURE_CLFLSH (0*32+19) /* Supports the CLFLUSH instruction= */ +#define X86_FEATURE_DS (0*32+21) /* Debug Store */ +#define X86_FEATURE_ACPI (0*32+22) /* ACPI via MSR */ +#define X86_FEATURE_MMX (0*32+23) /* Multimedia Extensions */ +#define X86_FEATURE_FXSR (0*32+24) /* FXSAVE and FXRSTOR instructions (f= ast save and restore */ + /* of FPU context), and CR4.OSFXSR available */ +#define X86_FEATURE_XMM (0*32+25) /* Streaming SIMD Extensions */ +#define X86_FEATURE_XMM2 (0*32+26) /* Streaming SIMD Extensions-2 */ +#define X86_FEATURE_SELFSNOOP (0*32+27) /* CPU self snoop */ +#define X86_FEATURE_HT (0*32+28) /* Hyper-Threading */ +#define X86_FEATURE_ACC (0*32+29) /* Automatic clock control */ +#define X86_FEATURE_IA64 (0*32+30) /* IA-64 processor */ +#define X86_FEATURE_PBE (0*32+31) /* Pending Break Enable */ + +/* AMD-defined CPU features, CPUID level 0x80000001, word 1 */ +/* Don't duplicate feature flags which are redundant with Intel! */ +#define X86_FEATURE_SYSCALL (1*32+11) /* SYSCALL/SYSRET */ +#define X86_FEATURE_MP (1*32+19) /* MP Capable. */ +#define X86_FEATURE_NX (1*32+20) /* Execute Disable */ +#define X86_FEATURE_MMXEXT (1*32+22) /* AMD MMX extensions */ +#define X86_FEATURE_FFXSR (1*32+25) /* FFXSR instruction optimizat= ions */ +#define X86_FEATURE_PAGE1GB (1*32+26) /* 1Gb large page support */ +#define X86_FEATURE_RDTSCP (1*32+27) /* RDTSCP */ +#define X86_FEATURE_LM (1*32+29) /* Long Mode (x86-64) */ +#define X86_FEATURE_3DNOWEXT (1*32+30) /* AMD 3DNow! extensions */ +#define X86_FEATURE_3DNOW (1*32+31) /* 3DNow! */ + +/* Transmeta-defined CPU features, CPUID level 0x80860001, word 2 */ +#define X86_FEATURE_RECOVERY (2*32+ 0) /* CPU in recovery mode */ +#define X86_FEATURE_LONGRUN (2*32+ 1) /* Longrun power control */ +#define X86_FEATURE_LRTI (2*32+ 3) /* LongRun table interface */ + +/* Other features, Linux-defined mapping, word 3 */ +/* This range is used for feature bits which conflict or are synthesized= */ +#define X86_FEATURE_CXMMX (3*32+ 0) /* Cyrix MMX extensions */ +#define X86_FEATURE_K6_MTRR (3*32+ 1) /* AMD K6 nonstandard MTRRs */ +#define X86_FEATURE_CYRIX_ARR (3*32+ 2) /* Cyrix ARRs (=3D MTRRs) */ +#define X86_FEATURE_CENTAUR_MCR (3*32+ 3) /* Centaur MCRs (=3D MTRRs) */ +/* cpu types for specific tunings: */ +#define X86_FEATURE_K8 (3*32+ 4) /* Opteron, Athlon64 */ +#define X86_FEATURE_K7 (3*32+ 5) /* Athlon */ +#define X86_FEATURE_P3 (3*32+ 6) /* P3 */ +#define X86_FEATURE_P4 (3*32+ 7) /* P4 */ +#define X86_FEATURE_CONSTANT_TSC (3*32+ 8) /* TSC ticks at a constant ra= te */ + +/* Intel-defined CPU features, CPUID level 0x00000001 (ecx), word 4 */ +#define X86_FEATURE_XMM3 (4*32+ 0) /* Streaming SIMD Extensions-3 */ +#define X86_FEATURE_DTES64 (4*32+ 2) /* 64-bit Debug Store */ +#define X86_FEATURE_MWAIT (4*32+ 3) /* Monitor/Mwait support */ +#define X86_FEATURE_DSCPL (4*32+ 4) /* CPL Qualified Debug Store */ +#define X86_FEATURE_VMXE (4*32+ 5) /* Virtual Machine Extensions */ +#define X86_FEATURE_SMXE (4*32+ 6) /* Safer Mode Extensions */ +#define X86_FEATURE_EST (4*32+ 7) /* Enhanced SpeedStep */ +#define X86_FEATURE_TM2 (4*32+ 8) /* Thermal Monitor 2 */ +#define X86_FEATURE_SSSE3 (4*32+ 9) /* Supplemental Streaming SIMD Exten= sions-3 */ +#define X86_FEATURE_CID (4*32+10) /* Context ID */ +#define X86_FEATURE_CX16 (4*32+13) /* CMPXCHG16B */ +#define X86_FEATURE_XTPR (4*32+14) /* Send Task Priority Messages */ +#define X86_FEATURE_PDCM (4*32+15) /* Perf/Debug Capability MSR */ +#define X86_FEATURE_DCA (4*32+18) /* Direct Cache Access */ +#define X86_FEATURE_SSE4_1 (4*32+19) /* Streaming SIMD Extensions 4.1 */ +#define X86_FEATURE_SSE4_2 (4*32+20) /* Streaming SIMD Extensions 4.2 */ +#define X86_FEATURE_POPCNT (4*32+23) /* POPCNT instruction */ +#define X86_FEATURE_HYPERVISOR (4*32+31) /* Running under some hyperviso= r */ + +/* VIA/Cyrix/Centaur-defined CPU features, CPUID level 0xC0000001, word = 5 */ +#define X86_FEATURE_XSTORE (5*32+ 2) /* on-CPU RNG present (xstore insn)= */ +#define X86_FEATURE_XSTORE_EN (5*32+ 3) /* on-CPU RNG enabled */ +#define X86_FEATURE_XCRYPT (5*32+ 6) /* on-CPU crypto (xcrypt insn) */ +#define X86_FEATURE_XCRYPT_EN (5*32+ 7) /* on-CPU crypto enabled */ +#define X86_FEATURE_ACE2 (5*32+ 8) /* Advanced Cryptography Engine v2 */ +#define X86_FEATURE_ACE2_EN (5*32+ 9) /* ACE v2 enabled */ +#define X86_FEATURE_PHE (5*32+ 10) /* PadLock Hash Engine */ +#define X86_FEATURE_PHE_EN (5*32+ 11) /* PHE enabled */ +#define X86_FEATURE_PMM (5*32+ 12) /* PadLock Montgomery Multiplier */ +#define X86_FEATURE_PMM_EN (5*32+ 13) /* PMM enabled */ + +/* More extended AMD flags: CPUID level 0x80000001, ecx, word 6 */ +#define X86_FEATURE_LAHF_LM (6*32+ 0) /* LAHF/SAHF in long mode */ +#define X86_FEATURE_CMP_LEGACY (6*32+ 1) /* If yes HyperThreading not va= lid */ +#define X86_FEATURE_SVME (6*32+ 2) /* Secure Virtual Machine */ +#define X86_FEATURE_EXTAPICSPACE (6*32+ 3) /* Extended APIC space */ +#define X86_FEATURE_ALTMOVCR (6*32+ 4) /* LOCK MOV CR accesses CR+8 */ +#define X86_FEATURE_ABM (6*32+ 5) /* Advanced Bit Manipulation */ +#define X86_FEATURE_SSE4A (6*32+ 6) /* AMD Streaming SIMD Extensions-4a = */ +#define X86_FEATURE_MISALIGNSSE (6*32+ 7) /* Misaligned SSE Access */ +#define X86_FEATURE_3DNOWPF (6*32+ 8) /* 3DNow! Prefetch */ +#define X86_FEATURE_OSVW (6*32+ 9) /* OS Visible Workaround */ +#define X86_FEATURE_IBS (6*32+ 10) /* Instruction Based Sampling */ +#define X86_FEATURE_SSE5 (6*32+ 11) /* AMD Streaming SIMD Extensions-5 *= / +#define X86_FEATURE_SKINIT (6*32+ 12) /* SKINIT, STGI/CLGI, DEV */ +#define X86_FEATURE_WDT (6*32+ 13) /* Watchdog Timer */ + +#endif /* __LIBXC_CPUFEATURE_H */ diff --git a/tools/ocaml/libs/xc/xc_cpuid.h b/tools/ocaml/libs/xc/xc_cpui= d.h new file mode 100644 index 0000000..43743ef --- /dev/null +++ b/tools/ocaml/libs/xc/xc_cpuid.h @@ -0,0 +1,285 @@ +#ifndef XC_CPUID_H +#define XC_CPUID_H + +#ifdef XEN_DOMCTL_set_cpuid + +#include "xc_cpufeature.h" + +#define bitmaskof(idx) (1u << ((idx) & 31)) +#define clear_bit(idx, dst) ((dst) &=3D ~(1u << ((idx) & 31))) +#define set_bit(idx, dst) ((dst) |=3D (1u << ((idx) & 31))) + +#define DEF_MAX_BASE 0x00000004u +#define DEF_MAX_EXT 0x80000008u + +static void xc_cpuid(uint32_t eax, uint32_t ecx, uint32_t regs[4]) +{ + unsigned int realecx =3D (ecx =3D=3D XEN_CPUID_INPUT_UNUSED) ? 0 : ecx; + asm ( +#ifdef __i386__ + "push %%ebx; cpuid; mov %%ebx,%1; pop %%ebx" +#else + "push %%rbx; cpuid; mov %%ebx,%1; pop %%rbx" +#endif + : "=3Da" (regs[0]), "=3Dr" (regs[1]), "=3Dc" (regs[2]), "=3Dd" (reg= s[3]) + : "0" (eax), "2" (realecx)); +} + +enum { CPU_BRAND_INTEL, CPU_BRAND_AMD, CPU_BRAND_UNKNOWN }; + +static int xc_cpuid_brand_get(void) +{ + uint32_t regs[4]; + char str[13]; + uint32_t *istr =3D (uint32_t *) str; + + xc_cpuid(0, 0, regs); + istr[0] =3D regs[1]; + istr[1] =3D regs[3]; + istr[2] =3D regs[2]; + str[12] =3D '\0'; + if (strcmp(str, "AuthenticAMD") =3D=3D 0) { + return CPU_BRAND_AMD; + } else if (strcmp(str, "GenuineIntel") =3D=3D 0) { + return CPU_BRAND_INTEL; + } else + return CPU_BRAND_UNKNOWN; +} + +static int hypervisor_is_64bit(int xc) +{ + xen_capabilities_info_t xen_caps; + return ((xc_version(xc, XENVER_capabilities, &xen_caps) =3D=3D 0) && + (strstr(xen_caps, "x86_64") !=3D NULL)); +} + +static void do_hvm_cpuid_policy(int xc, int domid, uint32_t input, uint3= 2_t regs[4]) +{ + unsigned long is_pae; + int brand; + + /* pae ? */ + xc_get_hvm_param(xc, domid, HVM_PARAM_PAE_ENABLED, &is_pae); + is_pae =3D !!is_pae; + + switch (input) { + case 0x00000000: + if (regs[0] > DEF_MAX_BASE) + regs[0] =3D DEF_MAX_BASE; + break; + case 0x00000001: + regs[2] &=3D (bitmaskof(X86_FEATURE_XMM3) | + bitmaskof(X86_FEATURE_SSSE3) | + bitmaskof(X86_FEATURE_CX16) | + bitmaskof(X86_FEATURE_SSE4_1) | + bitmaskof(X86_FEATURE_SSE4_2) | + bitmaskof(X86_FEATURE_POPCNT)); + + regs[2] |=3D bitmaskof(X86_FEATURE_HYPERVISOR); + + regs[3] &=3D (bitmaskof(X86_FEATURE_FPU) | + bitmaskof(X86_FEATURE_VME) | + bitmaskof(X86_FEATURE_DE) | + bitmaskof(X86_FEATURE_PSE) | + bitmaskof(X86_FEATURE_TSC) | + bitmaskof(X86_FEATURE_MSR) | + bitmaskof(X86_FEATURE_PAE) | + bitmaskof(X86_FEATURE_MCE) | + bitmaskof(X86_FEATURE_CX8) | + bitmaskof(X86_FEATURE_APIC) | + bitmaskof(X86_FEATURE_SEP) | + bitmaskof(X86_FEATURE_MTRR) | + bitmaskof(X86_FEATURE_PGE) | + bitmaskof(X86_FEATURE_MCA) | + bitmaskof(X86_FEATURE_CMOV) | + bitmaskof(X86_FEATURE_PAT) | + bitmaskof(X86_FEATURE_CLFLSH) | + bitmaskof(X86_FEATURE_MMX) | + bitmaskof(X86_FEATURE_FXSR) | + bitmaskof(X86_FEATURE_XMM) | + bitmaskof(X86_FEATURE_XMM2)); + /* We always support MTRR MSRs. */ + regs[3] |=3D bitmaskof(X86_FEATURE_MTRR); + + if (!is_pae) + clear_bit(X86_FEATURE_PAE, regs[3]); + break; + case 0x80000000: + if (regs[0] > DEF_MAX_EXT) + regs[0] =3D DEF_MAX_EXT; + break; + case 0x80000001: + if (!is_pae) + clear_bit(X86_FEATURE_NX, regs[3]); + break; + case 0x80000008: + regs[0] &=3D 0x0000ffffu; + regs[1] =3D regs[2] =3D regs[3] =3D 0; + break; + case 0x00000002: /* Intel cache info (dumped by AMD policy) */ + case 0x00000004: /* Intel cache info (dumped by AMD policy) */ + case 0x80000002: /* Processor name string */ + case 0x80000003: /* ... continued */ + case 0x80000004: /* ... continued */ + case 0x80000005: /* AMD L1 cache/TLB info (dumped by Intel policy) */ + case 0x80000006: /* AMD L2/3 cache/TLB info ; Intel L2 cache features *= / + break; + default: + regs[0] =3D regs[1] =3D regs[2] =3D regs[3] =3D 0; + break; + } +=09 + brand =3D xc_cpuid_brand_get(); + if (brand =3D=3D CPU_BRAND_AMD) { + switch (input) { + case 0x00000001: + /* Mask Intel-only features. */ + regs[2] &=3D ~(bitmaskof(X86_FEATURE_SSSE3) | + bitmaskof(X86_FEATURE_SSE4_1) | + bitmaskof(X86_FEATURE_SSE4_2)); + break; + + case 0x00000002: + case 0x00000004: + regs[0] =3D regs[1] =3D regs[2] =3D 0; + break; + + case 0x80000001: { + int is_64bit =3D hypervisor_is_64bit(xc) && is_pae; + + if (!is_pae) + clear_bit(X86_FEATURE_PAE, regs[3]); + clear_bit(X86_FEATURE_PSE36, regs[3]); + + /* Filter all other features according to a whitelist. */ + regs[2] &=3D ((is_64bit ? bitmaskof(X86_FEATURE_LAHF_LM) : 0) | + bitmaskof(X86_FEATURE_ALTMOVCR) | + bitmaskof(X86_FEATURE_ABM) | + bitmaskof(X86_FEATURE_SSE4A) | + bitmaskof(X86_FEATURE_MISALIGNSSE) | + bitmaskof(X86_FEATURE_3DNOWPF)); + regs[3] &=3D (0x0183f3ff | /* features shared with 0x00000001:EDX */ + (is_pae ? bitmaskof(X86_FEATURE_NX) : 0) | + (is_64bit ? bitmaskof(X86_FEATURE_LM) : 0) | + bitmaskof(X86_FEATURE_SYSCALL) | + bitmaskof(X86_FEATURE_MP) | + bitmaskof(X86_FEATURE_MMXEXT) | + bitmaskof(X86_FEATURE_FFXSR) | + bitmaskof(X86_FEATURE_3DNOW) | + bitmaskof(X86_FEATURE_3DNOWEXT)); + break; + } + } + } else if (brand =3D=3D CPU_BRAND_INTEL) { + switch (input) { + case 0x00000001: + /* Mask AMD-only features. */ + regs[2] &=3D ~(bitmaskof(X86_FEATURE_POPCNT)); + break; + + case 0x00000004: + regs[0] &=3D 0x3FF; + regs[3] &=3D 0x3FF; + break; + + case 0x80000001: + { + int is_64bit =3D hypervisor_is_64bit(xc) && is_pae; + + /* Only a few features are advertised in Intel's 0x80000001. */ + regs[2] &=3D (is_64bit ? bitmaskof(X86_FEATURE_LAHF_LM) : 0); + regs[3] &=3D ((is_pae ? bitmaskof(X86_FEATURE_NX) : 0) | + (is_64bit ? bitmaskof(X86_FEATURE_LM) : 0) | + (is_64bit ? bitmaskof(X86_FEATURE_SYSCALL) : 0)); + break; + } + case 0x80000005: + { + regs[0] =3D regs[1] =3D regs[2] =3D 0; + break; + } + } + } +} + +static void do_pv_cpuid_policy(int xc, int domid, uint32_t input, uint32= _t regs[4]) +{ + int brand; + int guest_64_bits, xen_64_bits; + int ret; +=09 + ret =3D xc_domain_get_machine_address_size(xc, domid); + if (ret < 0) + return; + guest_64_bits =3D (ret =3D=3D 64); + xen_64_bits =3D hypervisor_is_64bit(xc); + brand =3D xc_cpuid_brand_get(); + + if ((input & 0x7fffffff) =3D=3D 1) { + clear_bit(X86_FEATURE_VME, regs[3]); + clear_bit(X86_FEATURE_PSE, regs[3]); + clear_bit(X86_FEATURE_PGE, regs[3]); + clear_bit(X86_FEATURE_MCE, regs[3]); + clear_bit(X86_FEATURE_MCA, regs[3]); + clear_bit(X86_FEATURE_MTRR, regs[3]); + clear_bit(X86_FEATURE_PSE36, regs[3]); + } + + switch (input) { + case 1: + if (!xen_64_bits || brand =3D=3D CPU_BRAND_AMD) + clear_bit(X86_FEATURE_SEP, regs[3]); + clear_bit(X86_FEATURE_DS, regs[3]); + clear_bit(X86_FEATURE_ACC, regs[3]); + clear_bit(X86_FEATURE_PBE, regs[3]); + + clear_bit(X86_FEATURE_DTES64, regs[2]); + clear_bit(X86_FEATURE_MWAIT, regs[2]); + clear_bit(X86_FEATURE_DSCPL, regs[2]); + clear_bit(X86_FEATURE_VMXE, regs[2]); + clear_bit(X86_FEATURE_SMXE, regs[2]); + clear_bit(X86_FEATURE_EST, regs[2]); + clear_bit(X86_FEATURE_TM2, regs[2]); + if (!guest_64_bits) + clear_bit(X86_FEATURE_CX16, regs[2]); + clear_bit(X86_FEATURE_XTPR, regs[2]); + clear_bit(X86_FEATURE_PDCM, regs[2]); + clear_bit(X86_FEATURE_DCA, regs[2]); + break; + case 0x80000001: + if (!guest_64_bits) { + clear_bit(X86_FEATURE_LM, regs[3]); + clear_bit(X86_FEATURE_LAHF_LM, regs[2]); + if (brand !=3D CPU_BRAND_AMD) + clear_bit(X86_FEATURE_SYSCALL, regs[3]); + } else + set_bit(X86_FEATURE_SYSCALL, regs[3]); + clear_bit(X86_FEATURE_PAGE1GB, regs[3]); + clear_bit(X86_FEATURE_RDTSCP, regs[3]); + + clear_bit(X86_FEATURE_SVME, regs[2]); + clear_bit(X86_FEATURE_OSVW, regs[2]); + clear_bit(X86_FEATURE_IBS, regs[2]); + clear_bit(X86_FEATURE_SKINIT, regs[2]); + clear_bit(X86_FEATURE_WDT, regs[2]); + break; + case 5: /* MONITOR/MWAIT */ + case 0xa: /* Architectural Performance Monitor Features */ + case 0x8000000a: /* SVM revision and features */ + case 0x8000001b: /* Instruction Based Sampling */ + regs[0] =3D regs[1] =3D regs[2] =3D regs[3] =3D 0; + break; + } +} + +static void do_cpuid_policy(int xc, int domid, int hvm, uint32_t input, = uint32_t regs[4]) +{ + if (hvm) + do_hvm_cpuid_policy(xc, domid, input, regs); + else + do_pv_cpuid_policy(xc, domid, input, regs); +} + +#endif + +#endif diff --git a/tools/ocaml/libs/xc/xc_e820.h b/tools/ocaml/libs/xc/xc_e820.= h new file mode 100644 index 0000000..52bbb0f --- /dev/null +++ b/tools/ocaml/libs/xc/xc_e820.h @@ -0,0 +1,20 @@ +#ifndef __XC_E820_H__ +#define __XC_E820_H__ + +#include + +/* + * PC BIOS standard E820 types and structure. + */ +#define E820_RAM 1 +#define E820_RESERVED 2 +#define E820_ACPI 3 +#define E820_NVS 4 + +struct e820entry { + uint64_t addr; + uint64_t size; + uint32_t type; +} __attribute__((packed)); + +#endif /* __XC_E820_H__ */ diff --git a/tools/ocaml/libs/xc/xc_lib.c b/tools/ocaml/libs/xc/xc_lib.c new file mode 100644 index 0000000..7fffc43 --- /dev/null +++ b/tools/ocaml/libs/xc/xc_lib.c @@ -0,0 +1,1502 @@ +/* + * 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 publis= hed + * 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 "xc.h" + +#define PAGE_SHIFT 12 +#define PAGE_SIZE (1UL << PAGE_SHIFT) +#define PAGE_MASK (~(PAGE_SIZE-1)) + +#define MIN(a, b) (((a) < (b)) ? (a) : (b)) + +#define DECLARE_DOMCTL(_cmd, _domain) \ + struct xen_domctl domctl =3D { \ + .cmd =3D _cmd, \ + .domain =3D _domain, \ + .interface_version =3D XEN_DOMCTL_INTERFACE_VERSION, \ + } + +#define DECLARE_SYSCTL(_cmd) \ + struct xen_sysctl sysctl =3D { \ + .cmd =3D _cmd, \ + .interface_version =3D XEN_SYSCTL_INTERFACE_VERSION, \ + } + +#define DECLARE_HYPERCALL2(_cmd, _arg0, _arg1) \ + privcmd_hypercall_t hypercall =3D { \ + .op =3D _cmd, \ + .arg[0] =3D (unsigned long) _arg0,\ + .arg[1] =3D (unsigned long) _arg1,\ + } +#define DECLARE_HYPERCALL0(_cmd) DECLARE_HYPERCALL2(_cmd, 0, 0); +#define DECLARE_HYPERCALL1(_cmd, _arg0) DECLARE_HYPERCALL2(_cmd, _arg0, = 0); + +/*---- Errors handlings ----*/ +#ifndef WITHOUT_GOOD_ERROR +#define ERROR_STRLEN 256 + +static char __error_str[ERROR_STRLEN]; + +char * xc_error_get(void) +{ + return __error_str; +} + +static void xc_error_set(const char *fmt, ...) +{ + va_list ap; + char __errordup[ERROR_STRLEN]; + + va_start(ap, fmt); + vsnprintf(__errordup, ERROR_STRLEN, fmt, ap); + va_end(ap); + memcpy(__error_str, __errordup, ERROR_STRLEN); +} + +static void xc_error_dom_set(unsigned int domid, const char *fmt, ...) +{ + va_list ap; + char __errordup[ERROR_STRLEN]; + int i; + + i =3D snprintf(__errordup, ERROR_STRLEN, "domain %u - ", domid); + va_start(ap, fmt); + i +=3D vsnprintf(__errordup + i, ERROR_STRLEN - i, fmt, ap); + va_end(ap); + snprintf(__errordup + i, ERROR_STRLEN - i, + " failed: %s", xc_error_get()); + memcpy(__error_str, __errordup, ERROR_STRLEN); +} + +void xc_error_clear(void) +{ + memset(__error_str, '\0', ERROR_STRLEN); +} +#else +char * xc_error_get(void) +{ + return ""; +} +#define xc_error_set(fmt, ...) do {} while (0) +#define xc_error_dom_set(id, fmt, ...) do {} while (0) +#define xc_error_clear() do {} while (0) +#endif + +#define xc_error_hypercall(_h, _r) \ + xc_error_set("hypercall %lld fail: %d: %s (ret %d)", _h.op, errno, errn= o ? strerror(errno) : strerror(-_r), _r) + +int xc_using_injection(void) +{ + return 0; +} + +/*---- Trivia ----*/ +int xc_interface_open(void) +{ + int fd, ret; + + fd =3D open("/proc/xen/privcmd", O_RDWR); + if (fd =3D=3D -1) { + xc_error_set("open /proc/xen/privcmd failed: %s", + strerror(errno)); + return -1; + } + + ret =3D fcntl(fd, F_GETFD); + if (ret < 0) { + xc_error_set("cannot get handle flags: %s", + strerror(errno)); + goto out; + } + + ret =3D fcntl(fd, F_SETFD, ret | FD_CLOEXEC); + if (ret < 0) { + xc_error_set("cannot set handle flags: %s", + strerror(errno)); + goto out; + } + + return fd; +out: + close(fd); + return -1; +} + +int xc_interface_close(int handle) +{ + int ret; + + ret =3D close(handle); + if (ret !=3D 0) + xc_error_set("close xc failed: %s", strerror(errno)); + return ret; +} + +/*---- Low private operations ----*/ +static int do_xen_hypercall(int handle, privcmd_hypercall_t *hypercall) +{ + return ioctl(handle, IOCTL_PRIVCMD_HYPERCALL, (unsigned long) hypercall= ); +} + +static int do_domctl(int handle, struct xen_domctl *domctl) +{ + int ret; + DECLARE_HYPERCALL1(__HYPERVISOR_domctl, domctl); + + if (mlock(domctl, sizeof(*domctl)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret < 0) + xc_error_hypercall(hypercall, ret); + + munlock(domctl, sizeof(*domctl)); + return ret; +} + +static int do_sysctl(int handle, struct xen_sysctl *sysctl) +{ + int ret; + DECLARE_HYPERCALL1(__HYPERVISOR_sysctl, sysctl); + + if (mlock(sysctl, sizeof(*sysctl)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret < 0) + xc_error_hypercall(hypercall, ret); + + munlock(sysctl, sizeof(*sysctl)); + return ret; +} + +static int do_evtchnctl(int handle, int cmd, void *arg, size_t arg_size) +{ + DECLARE_HYPERCALL2(__HYPERVISOR_event_channel_op, cmd, arg); + int ret; + + if (mlock(arg, arg_size) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret < 0) + xc_error_hypercall(hypercall, ret); + munlock(arg, arg_size); + return ret; +} + +static int do_memctl_reservation(int handle, int cmd, + struct xen_memory_reservation *reservat= ion) +{ + int ret; + DECLARE_HYPERCALL2(__HYPERVISOR_memory_op, cmd, reservation); + xen_pfn_t *extent_start; + + if (cmd !=3D XENMEM_increase_reservation && + cmd !=3D XENMEM_decrease_reservation && + cmd !=3D XENMEM_populate_physmap) { + xc_error_set("do_memctl_reservation: unknown cmd %d", cmd); + return -EINVAL; + } + + if (mlock(reservation, sizeof(*reservation)) =3D=3D -1) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -ENOMEM; + } + get_xen_guest_handle(extent_start, reservation->extent_start); + if (extent_start && mlock(extent_start, reservation->nr_extents + * sizeof(xen_pfn_t)) =3D=3D -1) { + xc_error_set("mlock failed: %s", strerror(errno)); + munlock(reservation, sizeof(*reservation)); + return -3; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + munlock(extent_start, reservation->nr_extents * sizeof(xen_pfn_t)); + get_xen_guest_handle(extent_start, reservation->extent_start); + munlock(reservation, sizeof(*reservation)); + return ret; +} + +static int do_ioctl(int handle, int cmd, void *arg) +{ + return ioctl(handle, cmd, arg); +} + +static void * do_mmap(void *start, size_t length, int prot, int flags, + int fd, off_t offset) +{ + return mmap(start, length, prot, flags, fd, offset); +} + +int xc_get_hvm_param(int handle, unsigned int domid, + int param, unsigned long *value) +{ + struct xen_hvm_param arg =3D { + .domid =3D domid, + .index =3D param, + }; + DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_get_param, + (unsigned long) &arg); + int ret; + + if (mlock(&arg, sizeof(arg)) =3D=3D -1) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + *value =3D arg.value; + munlock(&arg, sizeof(arg)); + return ret; +} + +static int xc_set_hvm_param(int handle, unsigned int domid, + int param, unsigned long value) +{ + struct xen_hvm_param arg =3D { + .domid =3D domid, + .index =3D param, + .value =3D value, + }; + DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_set_param, (unsigned long= ) &arg); + int ret; + + if (mlock(&arg, sizeof(arg)) =3D=3D -1) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + munlock(&arg, sizeof(arg)); + return ret; +} + + +/*---- XC API ----*/ +int xc_domain_create(int handle, unsigned int ssidref, + xen_domain_handle_t dhandle, + unsigned int flags, unsigned int *pdomid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_createdomain, *pdomid); + domctl.u.createdomain.ssidref =3D ssidref; + domctl.u.createdomain.flags =3D flags; + memcpy(domctl.u.createdomain.handle, dhandle, sizeof(xen_domain_handle_= t)); + + ret =3D do_domctl(handle, &domctl); + if (ret !=3D 0) { + xc_error_set("creating domain failed: %s", xc_error_get()); + return ret; + } + *pdomid =3D domctl.domain; + return 0; +} + +int xc_domain_pause(int handle, unsigned int domid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_pausedomain, domid); + + ret =3D do_domctl(handle, &domctl); + if (ret !=3D 0) + xc_error_dom_set(domid, "pause"); + return ret; +} + +int xc_domain_unpause(int handle, unsigned int domid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_unpausedomain, domid); + + ret =3D do_domctl(handle, &domctl); + if (ret !=3D 0) + xc_error_dom_set(domid, "unpause"); + return ret; +} + +/* return 1 if hvm domain got pv driver, 0 if not. -1 is error occurs */ +int xc_hvm_check_pvdriver(int handle, unsigned int domid) +{ + int ret; + unsigned long irq =3D 0; + xc_domaininfo_t info; + + ret =3D xc_domain_getinfolist(handle, domid, 1, &info); + if (ret !=3D 1) { + xc_error_set("domain getinfo failed: %s", strerror(errno)); + xc_error_dom_set(domid, "hvm_check_pvdriver"); + return -1; + } + + if (!(info.flags & XEN_DOMINF_hvm_guest)) { + xc_error_set("domain is not hvm"); + xc_error_dom_set(domid, "hvm_check_pvdriver"); + return -1; + } + xc_get_hvm_param(handle, domid, HVM_PARAM_CALLBACK_IRQ, &irq); + return irq; +} + +static int modify_returncode_register(int handle, unsigned int domid) +{ + int ret; + xc_domaininfo_t info; + xen_capabilities_info_t caps; + vcpu_guest_context_any_t context; + + ret =3D xc_domain_getinfolist(handle, domid, 1, &info); + if (ret !=3D 1) { + xc_error_set("domain getinfo failed: %s", strerror(errno)); + return -1; + } + + /* HVM guests without PV drivers do not have a return code to modify */ + if (info.flags & XEN_DOMINF_hvm_guest) { + unsigned long irq =3D 0; + xc_get_hvm_param(handle, domid, HVM_PARAM_CALLBACK_IRQ, &irq); + if (!irq) + return 0; + } + + ret =3D xc_version(handle, XENVER_capabilities, &caps); + if (ret) { + xc_error_set("could not get Xen capabilities"); + return ret; + } + + ret =3D xc_vcpu_getcontext(handle, domid, 0, &context); + if (ret) { + xc_error_set("could not get vcpu 0 context"); + return ret; + } + + if (!(info.flags & XEN_DOMINF_hvm_guest)) + context.c.user_regs.eax =3D 1; + else if (strstr(caps, "x86_64")) + context.x64.user_regs.eax =3D 1; + else + context.x32.user_regs.eax =3D 1; + + ret =3D xc_vcpu_setcontext(handle, domid, 0, &context); + if (ret) { + xc_error_set("could not set vcpu 0 context"); + return ret; + } + return 0; +} + +int xc_domain_resume_fast(int handle, unsigned int domid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_resumedomain, domid); + + ret =3D modify_returncode_register(handle, domid); + if (ret !=3D 0) { + xc_error_dom_set(domid, "resume_fast"); + return ret; + } + + ret =3D do_domctl(handle, &domctl); + if (ret !=3D 0) + xc_error_dom_set(domid, "resume_fast"); + return ret; +} + +int xc_domain_destroy(int handle, unsigned int domid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_destroydomain, domid); + + do { + ret =3D do_domctl(handle, &domctl); + } while (ret && (errno =3D=3D EAGAIN)); + if (ret !=3D 0) + xc_error_dom_set(domid, "destroy"); + return ret; +} + +int xc_domain_shutdown(int handle, int domid, int reason) +{ + sched_remote_shutdown_t arg =3D { + .domain_id =3D domid, + .reason =3D reason, + }; + DECLARE_HYPERCALL2(__HYPERVISOR_sched_op, SCHEDOP_remote_shutdown, &arg= ); + int ret; + + if (mlock(&arg, sizeof(arg)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + xc_error_dom_set(domid, "shutdown %d", reason); + return -1; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret < 0) { + xc_error_hypercall(hypercall, ret); + xc_error_dom_set(domid, "shutdown %d", reason); + } + munlock(&arg, sizeof(arg)); + return ret; +} + +int xc_vcpu_setaffinity(int handle, unsigned int domid, int vcpu, + uint64_t cpumap) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_setvcpuaffinity, domid); + domctl.u.vcpuaffinity.vcpu =3D vcpu; + domctl.u.vcpuaffinity.cpumap.nr_cpus =3D sizeof(cpumap) * 8; + + set_xen_guest_handle(domctl.u.vcpuaffinity.cpumap.bitmap, (uint8_t *) &= cpumap); + + if (mlock(&cpumap, sizeof(cpumap)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + xc_error_dom_set(domid, "vcpu %d set affinity", vcpu); + return -1; + } + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "vcpu %d set affinity", vcpu); + munlock(&cpumap, sizeof(cpumap)); + return ret; +} + +int xc_vcpu_getaffinity(int handle, unsigned int domid, int vcpu, + uint64_t *cpumap) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getvcpuaffinity, domid); + domctl.u.vcpuaffinity.vcpu =3D vcpu; + domctl.u.vcpuaffinity.cpumap.nr_cpus =3D sizeof(*cpumap) * 8; + + set_xen_guest_handle(domctl.u.vcpuaffinity.cpumap.bitmap, cpumap); + + if (mlock(cpumap, sizeof(*cpumap)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + xc_error_dom_set(domid, "vcpu %d get affinity", vcpu); + return -1; + } + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "vcpu %d get affinity", vcpu); + munlock(cpumap, sizeof(*cpumap)); + return ret; +} + +int xc_vcpu_context_get(int handle, unsigned int domid, unsigned short v= cpu, + struct vcpu_guest_context *ctxt) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getvcpucontext, domid); + domctl.u.vcpucontext.vcpu =3D vcpu; + + set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt); + + if (mlock(ctxt, sizeof(struct vcpu_guest_context)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + xc_error_dom_set(domid, "vcpu %d get context", vcpu); + return -1; + } + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "vcpu %d get context", vcpu); + munlock(ctxt, sizeof(struct vcpu_guest_context)); + + return ret; +} + +int xc_domain_getinfolist(int handle, unsigned int first_domain, + unsigned int max_domains, xc_domaininfo_t *inf= o) +{ + int ret; + DECLARE_SYSCTL(XEN_SYSCTL_getdomaininfolist); + sysctl.u.getdomaininfolist.first_domain =3D first_domain; + sysctl.u.getdomaininfolist.max_domains =3D max_domains; + set_xen_guest_handle(sysctl.u.getdomaininfolist.buffer, info); + + if (mlock(info, max_domains * sizeof(xc_domaininfo_t)) !=3D 0) { + xc_error_set("getinfolist(%d, %u, %u, %x (%d)) failed: mlock failed: %= s", + handle, first_domain, max_domains, info, sizeof(xc_domaininfo_t)= , + strerror(errno)); + return -1; + } + + ret =3D do_sysctl(handle, &sysctl); + if (ret < 0) + xc_error_set("getinfolist(%d, %u, %u, %x (%d)) failed: %s",=20 + handle, first_domain, max_domains, info, sizeof(xc_domaininfo_t)= , + xc_error_get()); + else + ret =3D sysctl.u.getdomaininfolist.num_domains; + + munlock(info, max_domains * sizeof(xc_domaininfo_t)); + return ret; +} + +int xc_domain_getinfo(int handle, unsigned int domid, xc_domaininfo_t *i= nfo) +{ + int ret; + ret =3D xc_domain_getinfolist(handle, domid, 1, info); + if (ret !=3D 1) { + xc_error_set("getinfo failed: domain %d: %s", domid, xc_error_get()); + return -1; + } + + /* If the requested domain didn't exist but there exists one with a=20 + higher domain ID, this will be returned. We consider this an error s= ince + we only wanted info about a specific domain. */ + if (info->domain !=3D domid) { + xc_error_set("getinfo failed: domain %d nolonger exists", domid); + return -1; + } + + return 0; +} + +int xc_domain_setmaxmem(int handle, unsigned int domid, unsigned int max= _memkb) +{ + DECLARE_DOMCTL(XEN_DOMCTL_max_mem, domid); + domctl.u.max_mem.max_memkb =3D max_memkb; + int ret; + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "set max memory to %u", max_memkb); + return ret; +} + +int xc_domain_set_memmap_limit(int handle, unsigned int domid, + unsigned long map_limitkb) +{ + int ret; + struct xen_foreign_memory_map fmap =3D { + .domid =3D domid, + .map =3D { .nr_entries =3D 1 } + }; + struct e820entry e820 =3D { + .addr =3D 0, + .size =3D (uint64_t)map_limitkb << 10, + .type =3D E820_RAM + }; + DECLARE_HYPERCALL2(__HYPERVISOR_memory_op, XENMEM_set_memory_map, &fmap= ); + + set_xen_guest_handle(fmap.map.buffer, &e820); + + if (mlock(&fmap, sizeof(fmap)) !=3D 0) { + xc_error_set("set_memmap_limit failed: mlock failed: %s", + strerror(errno)); + return -1; + } + + if (mlock(&e820, sizeof(e820)) !=3D 0) { + xc_error_set("set_memmap_limit failed: mlock failed: %s", + strerror(errno)); + munlock(&fmap, sizeof(fmap)); + return -1; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + + munlock(&e820, sizeof(e820)); + munlock(&fmap, sizeof(fmap)); + return ret; +} + +int xc_domain_set_time_offset(int handle, unsigned int domid, int time_o= ffset) +{ + DECLARE_DOMCTL(XEN_DOMCTL_settimeoffset, domid); + domctl.u.settimeoffset.time_offset_seconds =3D time_offset; + int ret; + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "set time offset %d", time_offset); + return ret; +} + +int xc_domain_memory_increase_reservation(int handle, unsigned int domid= , + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start) +{ + int ret; + struct xen_memory_reservation reservation =3D { + .nr_extents =3D nr_extents, + .extent_order =3D extent_order, + .COMPAT_FIELD_ADDRESS_BITS =3D address_bits, + .domid =3D domid + }; + + set_xen_guest_handle(reservation.extent_start, extent_start); + + ret =3D do_memctl_reservation(handle, XENMEM_increase_reservation, + &reservation); + if (ret !=3D nr_extents) { + xc_error_dom_set(domid, "increase reservation to %lu", + nr_extents); + return (ret >=3D 0) ? -1 : ret; + } + return 0; +} + +int xc_domain_memory_decrease_reservation(int handle, unsigned int domid= , + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start) +{ + int ret; + struct xen_memory_reservation reservation =3D { + .nr_extents =3D nr_extents, + .extent_order =3D extent_order, + .COMPAT_FIELD_ADDRESS_BITS =3D 0, + .domid =3D domid + }; + + set_xen_guest_handle(reservation.extent_start, extent_start); + if (!extent_start) { + xc_error_set("decrease reservation: extent start is NULL"); + return -EINVAL; + } + + ret =3D do_memctl_reservation(handle, XENMEM_decrease_reservation, + &reservation); + if (ret < nr_extents) { + xc_error_dom_set(domid, "decrease reservation to %lu", + nr_extents); + return (ret >=3D 0) ? -1 : ret; + } + return 0; +} + +int xc_domain_memory_populate_physmap(int handle, unsigned int domid, + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start) +{ + int ret; + struct xen_memory_reservation reservation =3D { + .nr_extents =3D nr_extents, + .extent_order =3D extent_order, + .COMPAT_FIELD_ADDRESS_BITS =3D address_bits, + .domid =3D domid + }; + + set_xen_guest_handle(reservation.extent_start, extent_start); + ret =3D do_memctl_reservation(handle, XENMEM_populate_physmap, + &reservation); + if (ret < nr_extents) { + xc_error_dom_set(domid, "populate physmap"); + return (ret >=3D 0) ? -1 : ret; + } + return 0; +} + +int xc_domain_setvmxassist(int handle, unsigned int domid, int use_vmxas= sist) +{ + int ret =3D 0; +#ifdef XEN_DOMCTL_setvmxassist + DECLARE_DOMCTL(XEN_DOMCTL_setvmxassist, domid); + domctl.u.setvmxassist.use_vmxassist =3D use_vmxassist; + + ret =3D do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "setting vmxassist to %d", + use_vmxassist); +#endif + return ret; +} + +int xc_domain_max_vcpus(int handle, unsigned int domid, unsigned int max= ) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_max_vcpus, domid); + domctl.u.max_vcpus.max =3D max; + + ret =3D do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "setting max vcpus to %d", max); + return ret; +} + +int xc_domain_sethandle(int handle, unsigned int domid, + xen_domain_handle_t dhandle) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_setdomainhandle, domid); + memcpy(domctl.u.setdomainhandle.handle, dhandle, sizeof(xen_domain_hand= le_t)); + + ret =3D do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "set handle"); + return ret; +} + +int xc_vcpu_getinfo(int handle, unsigned int domid, unsigned int vcpu, + xc_vcpuinfo_t *info) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getvcpuinfo, domid); + domctl.u.getvcpuinfo.vcpu =3D vcpu; + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) { + xc_error_dom_set(domid, "vcpu %u getinfo", vcpu); + return ret; + } + memcpy(info, &domctl.u.getvcpuinfo, sizeof(*info)); + return ret; +} + +int xc_domain_ioport_permission(int handle, unsigned int domid, + unsigned int first_port, unsigned int nr= _ports, + unsigned int allow_access) +{ + DECLARE_DOMCTL(XEN_DOMCTL_ioport_permission, domid); + domctl.u.ioport_permission.first_port =3D first_port; + domctl.u.ioport_permission.nr_ports =3D nr_ports; + domctl.u.ioport_permission.allow_access =3D allow_access; + + return do_domctl(handle, &domctl); +} + +int xc_vcpu_getcontext(int handle, unsigned int domid, + unsigned int vcpu, vcpu_guest_context_any_t *ctxt= ) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getvcpucontext, domid); + domctl.u.vcpucontext.vcpu =3D vcpu; + set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt); + + if (mlock(ctxt, sizeof(*ctxt)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "vcpu %u getcontext", vcpu); + munlock(ctxt, sizeof(*ctxt)); + return ret; +} + +int xc_vcpu_setcontext(int handle, unsigned int domid, + unsigned int vcpu, vcpu_guest_context_any_t *ctxt= ) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_setvcpucontext, domid); + domctl.u.vcpucontext.vcpu =3D vcpu; + set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt); + + if (mlock(ctxt, sizeof(*ctxt)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "vcpu %u setcontext", vcpu); + + munlock(ctxt, sizeof(*ctxt)); + return ret; +} + +int xc_domain_irq_permission(int handle, unsigned int domid, + unsigned char pirq, unsigned char allow_acc= ess) +{ + DECLARE_DOMCTL(XEN_DOMCTL_irq_permission, domid); + domctl.u.irq_permission.pirq =3D pirq; + domctl.u.irq_permission.allow_access =3D allow_access; + int ret; + + ret =3D do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "irq permission %u to %u", + pirq, allow_access); + return ret; +} + +int xc_domain_iomem_permission(int handle, unsigned int domid, + unsigned long first_mfn, unsigned long nr= _mfns, + unsigned char allow_access) +{ + DECLARE_DOMCTL(XEN_DOMCTL_iomem_permission, domid); + domctl.u.iomem_permission.first_mfn =3D first_mfn; + domctl.u.iomem_permission.nr_mfns =3D nr_mfns; + domctl.u.iomem_permission.allow_access =3D allow_access; + int ret; + + ret =3D do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "iomem permission [%lu, %lu] to %u", + first_mfn, first_mfn + nr_mfns, allow_access); + return ret; +} + +long long xc_domain_get_cpu_usage(int handle, unsigned int domid, + unsigned int vcpu) +{ + DECLARE_DOMCTL(XEN_DOMCTL_getvcpuinfo, domid); + domctl.u.getvcpuinfo.vcpu =3D vcpu; + + if (do_domctl(handle, &domctl) < 0) { + xc_error_dom_set(domid, "get cpu %d usage", vcpu); + return -1; + } + return domctl.u.getvcpuinfo.cpu_time; +} + +void *xc_map_foreign_range(int handle, unsigned int domid, + int size, int prot, unsigned long mfn) +{ + privcmd_mmap_entry_t entry =3D { + .mfn =3D mfn, + .npages =3D (size + PAGE_SIZE - 1) >> PAGE_SHIFT, + }; + privcmd_mmap_t ioctlx =3D { + .num =3D 1, + .dom =3D domid, + .entry =3D &entry, + }; + void *addr; + + addr =3D do_mmap(NULL, size, prot, MAP_SHARED, handle, 0); + if (addr =3D=3D MAP_FAILED) { + xc_error_set("mmap failed: %s", strerror(errno)); + xc_error_dom_set(domid, "map foreign range [%lx,%lx] prot %u", + mfn, mfn + size, prot); + return NULL; + } + entry.va =3D (unsigned long) addr; + if (do_ioctl(handle, IOCTL_PRIVCMD_MMAP, &ioctlx) < 0) { + xc_error_set("ioctl failed: %s", strerror(errno)); + xc_error_dom_set(domid, "map foreign range [%lx,%lx] prot %u", + mfn, mfn + size, prot); + munmap(addr, size); + return NULL; + } + return addr; +} + +int xc_map_foreign_ranges(int handle, unsigned int domid, + privcmd_mmap_entry_t *entries, int nr) +{ + privcmd_mmap_t ioctlx =3D { + .num =3D nr, + .dom =3D domid, + .entry =3D entries, + }; + int ret; + + ret =3D do_ioctl(handle, IOCTL_PRIVCMD_MMAP, &ioctlx); + if (ret < 0) { + xc_error_set("ioctl failed: %s", strerror(errno)); + xc_error_dom_set(domid, "map foreign ranges"); + return -1; + } + return ret; +} + +int xc_readconsolering(int handle, char **pbuffer, + unsigned int *pnr_chars, int clear) +{ + int ret; + DECLARE_SYSCTL(XEN_SYSCTL_readconsole); + char *buffer =3D *pbuffer; + unsigned int nr_chars =3D *pnr_chars; + + set_xen_guest_handle(sysctl.u.readconsole.buffer, buffer); + sysctl.u.readconsole.count =3D nr_chars; + sysctl.u.readconsole.clear =3D clear; + + if (mlock(buffer, nr_chars) !=3D 0) { + xc_error_set("read console ring: mlock failed: %s", + strerror(errno)); + return -1; + } + + ret =3D do_sysctl(handle, &sysctl); + if (ret !=3D 0) + xc_error_set("read console ring failed: %s", xc_error_get()); + else + *pnr_chars =3D sysctl.u.readconsole.count; + + munlock(buffer, nr_chars); + return ret; +} + +int xc_send_debug_keys(int handle, char *keys) +{ + int ret; + DECLARE_SYSCTL(XEN_SYSCTL_debug_keys); + + set_xen_guest_handle(sysctl.u.debug_keys.keys, keys); + sysctl.u.debug_keys.nr_keys =3D strlen(keys); + + if (mlock(keys, sysctl.u.debug_keys.nr_keys) !=3D 0) { + xc_error_set("send debug keys: mlock failed: %s", + strerror(errno)); + return -1; + } + + ret =3D do_sysctl(handle, &sysctl); + if (ret !=3D 0) + xc_error_set("send debug keys: %s", xc_error_get()); + + munlock(keys, sysctl.u.debug_keys.nr_keys); + return ret; +} + +int xc_physinfo(int handle, xc_physinfo_t *put_info) +{ + DECLARE_SYSCTL(XEN_SYSCTL_physinfo); + int ret; + + ret =3D do_sysctl(handle, &sysctl); + if (ret) { + xc_error_set("physinfo failed: %s", xc_error_get()); + return ret; + } + memcpy(put_info, &sysctl.u.physinfo, sizeof(*put_info)); + return 0; +} + +int xc_pcpu_info(int handle, int max_cpus, uint64_t *info, int *nr_cpus) +{ + DECLARE_SYSCTL(XEN_SYSCTL_getcpuinfo); + int ret; + + sysctl.u.getcpuinfo.max_cpus =3D max_cpus; + set_xen_guest_handle(sysctl.u.getcpuinfo.info, info); + + if (mlock(info, sizeof(*info) * max_cpus) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_sysctl(handle, &sysctl); + if (ret) + xc_error_set("pcpu info failed: %s", xc_error_get()); + else if (ret =3D=3D 0 && nr_cpus) + *nr_cpus =3D sysctl.u.getcpuinfo.nr_cpus; + munlock(info, sizeof(*info) * max_cpus); + return ret; +} + +int xc_sched_id(int handle, int *sched_id) +{ + DECLARE_SYSCTL(XEN_SYSCTL_sched_id); + int ret; + + ret =3D do_sysctl(handle, &sysctl); + if (ret) { + xc_error_set("sched id failed: %s", xc_error_get()); + return ret; + } + *sched_id =3D sysctl.u.sched_id.sched_id; + return 0; +} + +int xc_version(int handle, int cmd, void *arg) +{ + int argsize; + int ret; + DECLARE_HYPERCALL2(__HYPERVISOR_xen_version, cmd, arg); + + switch (cmd) { + case XENVER_extraversion: + argsize =3D sizeof(xen_extraversion_t); break; + case XENVER_compile_info: + argsize =3D sizeof(xen_compile_info_t); break; + case XENVER_capabilities: + argsize =3D sizeof(xen_capabilities_info_t); break; + case XENVER_changeset: + argsize =3D sizeof(xen_changeset_info_t); break; + case XENVER_platform_parameters: + argsize =3D sizeof(xen_platform_parameters_t); break; + case XENVER_version: + argsize =3D 0; break; + default: + xc_error_set("version: unknown command"); + return -1; + } + if (argsize && mlock(arg, argsize) =3D=3D -1) { + xc_error_set("version: mlock failed: %s", strerror(errno)); + return -ENOMEM; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + + if (argsize) + munlock(arg, argsize); + return ret; +} + +int xc_evtchn_alloc_unbound(int handle, unsigned int domid, + unsigned int remote_domid) +{ + struct evtchn_alloc_unbound arg =3D { + .dom =3D domid, + .remote_dom =3D remote_domid, + }; + int ret; + + ret =3D do_evtchnctl(handle, EVTCHNOP_alloc_unbound, &arg, sizeof(arg))= ; + if (ret) { + xc_error_dom_set(domid, "alloc unbound evtchn to %d", + remote_domid); + return ret; + } + return arg.port; +} + +int xc_evtchn_reset(int handle, unsigned int domid) +{ + struct evtchn_reset arg =3D { + .dom =3D domid, + }; + int ret; + + ret =3D do_evtchnctl(handle, EVTCHNOP_reset, &arg, sizeof(arg)); + if (ret) + xc_error_dom_set(domid, "reset evtchn of %d", domid); + return ret; +} + +int xc_sched_credit_domain_set(int handle, unsigned int domid, + struct xen_domctl_sched_credit *sdom) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_scheduler_op, domid); + domctl.u.scheduler_op.sched_id =3D XEN_SCHEDULER_CREDIT; + domctl.u.scheduler_op.cmd =3D XEN_DOMCTL_SCHEDOP_putinfo; + domctl.u.scheduler_op.u.credit =3D *sdom; + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "credit scheduler domain set"); + return ret; +} + +int xc_sched_credit_domain_get(int handle, unsigned int domid, + struct xen_domctl_sched_credit *sdom) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_scheduler_op, domid); + + domctl.u.scheduler_op.sched_id =3D XEN_SCHEDULER_CREDIT; + domctl.u.scheduler_op.cmd =3D XEN_DOMCTL_SCHEDOP_getinfo; + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "credit scheduler domain get"); + else + *sdom =3D domctl.u.scheduler_op.u.credit; + return ret; +} + +int xc_shadow_allocation_get(int handle, unsigned int domid, uint32_t *m= b) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_shadow_op, domid); + + domctl.u.shadow_op.op =3D XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION; + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "shadow allocation get"); + else + *mb =3D domctl.u.shadow_op.mb; + return ret; +} + +int xc_shadow_allocation_set(int handle, unsigned int domid, uint32_t mb= ) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_shadow_op, domid); + + domctl.u.shadow_op.op =3D XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION; + domctl.u.shadow_op.mb =3D mb; + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "shadow allocation set"); + return ret; +} + +int xc_domain_get_pfn_list(int handle, unsigned int domid, + xen_pfn_t *pfn_array, unsigned long max_pfns) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getmemlist, domid); + + domctl.u.getmemlist.max_pfns =3D max_pfns; + set_xen_guest_handle(domctl.u.getmemlist.buffer, pfn_array); + + if (mlock(pfn_array, max_pfns * sizeof(xen_pfn_t)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "get pfn list"); + + munlock(pfn_array, max_pfns * sizeof(xen_pfn_t)); + return (ret < 0) ? ret : domctl.u.getmemlist.num_pfns; +} + +#define MARSHALL_BDF(d,b,s,f) \ + (((b) & 0xff) << 16 | ((s) & 0x1f) << 11 | ((f) & 0x7) << 8) + +int xc_domain_assign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func) +{ + int ret =3D -EBADF; +#ifdef XEN_DOMCTL_assign_device + DECLARE_DOMCTL(XEN_DOMCTL_assign_device, domid); + + domctl.u.assign_device.machine_bdf =3D MARSHALL_BDF(domain, bus, slot, = func); + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "assign device"); +#endif + return ret; +} + +int xc_domain_deassign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func) +{ + int ret =3D -EBADF; +#ifdef XEN_DOMCTL_deassign_device + DECLARE_DOMCTL(XEN_DOMCTL_deassign_device, domid); + + domctl.u.assign_device.machine_bdf =3D MARSHALL_BDF(domain, bus, slot, = func); + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "deassign device"); +#endif + return ret; +} + +int xc_domain_test_assign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func= ) +{ + int ret =3D -EBADF; +#ifdef XEN_DOMCTL_test_assign_device + DECLARE_DOMCTL(XEN_DOMCTL_test_assign_device, domid); + domctl.u.assign_device.machine_bdf =3D MARSHALL_BDF(domain, bus, slot, = func); + + ret =3D do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "test assign device"); +#endif + return ret; +} + +int xc_domain_watchdog(int handle, int id, uint32_t timeout) +{ + int ret =3D -EBADF; +#ifdef SCHEDOP_watchdog + sched_watchdog_t arg =3D { + .id =3D (uint32_t) id, + .timeout =3D timeout, + }; + DECLARE_HYPERCALL2(__HYPERVISOR_sched_op, SCHEDOP_watchdog, &arg); + + if (mlock(&arg, sizeof(arg)) !=3D 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret =3D do_xen_hypercall(handle, &hypercall); + if (ret < 0) { + xc_error_hypercall(hypercall, ret); + } + munlock(&arg, sizeof(arg)); +#endif + return ret; +} + +int xc_domain_set_machine_address_size(int xc, uint32_t domid, unsigned = int width) +{ + DECLARE_DOMCTL(XEN_DOMCTL_set_machine_address_size, domid); + int rc; + + domctl.u.address_size.size =3D width; + rc =3D do_domctl(xc, &domctl); + if (rc !=3D 0) + xc_error_dom_set(domid, "set machine address size"); + + return rc; +} + +int xc_domain_get_machine_address_size(int xc, uint32_t domid) +{ + DECLARE_DOMCTL(XEN_DOMCTL_get_machine_address_size, domid); + int rc; + + rc =3D do_domctl(xc, &domctl); + if (rc !=3D 0) + xc_error_dom_set(domid, "get machine address size"); + return rc =3D=3D 0 ? domctl.u.address_size.size : rc; +} + +#include "xc_cpuid.h" +int xc_domain_cpuid_set(int xc, unsigned int domid, int hvm, + uint32_t input, uint32_t oinput, + char *config[4], char *config_out[4]) +{ + int ret =3D -EBADF; +#ifdef XEN_DOMCTL_set_cpuid + DECLARE_DOMCTL(XEN_DOMCTL_set_cpuid, domid); + uint32_t regs[4], polregs[4]; + int i, j; + + xc_cpuid(input, oinput, regs); + memcpy(polregs, regs, sizeof(regs)); + do_cpuid_policy(xc, domid, hvm, input, polregs); + + for (i =3D 0; i < 4; i++) { + if (!config[i]) { + regs[i] =3D polregs[i]; + continue; + } + =09 + for (j =3D 0; j < 32; j++) { + unsigned char val, polval; + + val =3D !!((regs[i] & (1U << (31 - j)))); + polval =3D !!((regs[i] & (1U << (31 - j)))); + + switch (config[i][j]) { + case '1': val =3D 1; break; /* force to true */ + case '0': val =3D 0; break; /* force to false */ + case 'x': val =3D polval; break; + case 'k': case 's': break; + default: + xc_error_dom_set(domid, "domain cpuid set: invalid config"); + ret =3D -EINVAL; + goto out; + } + + if (val) + set_bit(31 - j, regs[i]); + else + clear_bit(31 - j, regs[i]); + + if (config_out && config_out[i]) { + config_out[i][j] =3D (config[i][j] =3D=3D 's') + ? '0' + val + : config[i][j]; + } + } + } + + domctl.u.cpuid.input[0] =3D input; + domctl.u.cpuid.input[1] =3D oinput; + domctl.u.cpuid.eax =3D regs[0]; + domctl.u.cpuid.ebx =3D regs[1]; + domctl.u.cpuid.ecx =3D regs[2]; + domctl.u.cpuid.edx =3D regs[3]; + ret =3D do_domctl(xc, &domctl); + if (ret) { + xc_error_dom_set(domid, "cpuid set"); + goto out; + } +out: +#endif + return ret; +} + +int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm) +{ + int ret =3D -EBADF; +#ifdef XEN_DOMCTL_set_cpuid + uint32_t regs[4], base_max, ext_max, eax, ecx; + + /* determinate cpuid range */ + xc_cpuid(0, 0, regs); + base_max =3D MIN(regs[0], DEF_MAX_BASE); + xc_cpuid(0x80000000, 0, regs); + ext_max =3D MIN(regs[0], DEF_MAX_EXT); + + eax =3D ecx =3D 0; + while (!(eax & 0x80000000) || (eax <=3D ext_max)) { + xc_cpuid(eax, ecx, regs); + + do_cpuid_policy(xc, domid, hvm, eax, regs); + =09 + if (regs[0] || regs[1] || regs[2] || regs[3]) { + DECLARE_DOMCTL(XEN_DOMCTL_set_cpuid, domid); + =09 + domctl.u.cpuid.input[0] =3D eax; + domctl.u.cpuid.input[1] =3D (eax =3D=3D 4) ? ecx : XEN_CPUID_INPUT_UN= USED; + domctl.u.cpuid.eax =3D regs[0]; + domctl.u.cpuid.ebx =3D regs[1]; + domctl.u.cpuid.ecx =3D regs[2]; + domctl.u.cpuid.edx =3D regs[3]; + + ret =3D do_domctl(xc, &domctl); + if (ret) { + xc_error_dom_set(domid, "cpuid apply"); + goto out; + } + + /* we repeat when doing node 4 (cache descriptor leaves) increasing e= cx=20 + * until the cpuid eax value masked is 0 */ + if (eax =3D=3D 4) { + ecx++; + if ((regs[0] & 0x1f) !=3D 0) + continue; + ecx =3D 0; + } + } + + eax++; + if (!(eax & 0x80000000) && (eax > base_max)) + eax =3D 0x80000000; + } + ret =3D 0; +out: +#endif + return ret; +} + +/* + * return 1 on checking success=20 + * 0 on checking failure + * -EINVAL if the config contains unknown character + */ +int xc_cpuid_check(uint32_t input, uint32_t optsubinput, + char *config[4], char *config_out[4]) +{ + int ret =3D -EBADF; +#ifdef XEN_DOMCTL_set_cpuid + uint32_t regs[4]; + int i, j; + + xc_cpuid(input, optsubinput, regs); + + ret =3D 1; + for (i =3D 0; i < 4; i++) { + if (!config[i]) + continue; + for (j =3D 0; j < 32; j++) { + unsigned char val; + + val =3D !!((regs[i] & (1U << (31 - j)))); + + switch (config[i][j]) { + case '1': if (!val) { ret =3D 0; goto out; }; break; + case '0': if (val) { ret =3D 0; goto out; }; break; + case 'x': case 's': break; + default: + xc_error_set("cpuid check: invalid config"); + ret =3D -EINVAL; + goto out; + } + + if (config_out && config_out[i]) { + config_out[i][j] =3D (config[i][j] =3D=3D 's') + ? '0' + val + : config[i][j]; + } + } + }=20 +out: +#endif + return ret; +} + +#ifndef HVM_PARAM_HPET_ENABLED +#define HVM_PARAM_HPET_ENABLED 11 +#endif + +#ifndef HVM_PARAM_ACPI_S_STATE +#define HVM_PARAM_ACPI_S_STATE 14 +#endif + +#ifndef HVM_PARAM_VPT_ALIGN +#define HVM_PARAM_VPT_ALIGN 16 +#endif + +int xc_domain_send_s3resume(int handle, unsigned int domid) +{ + return xc_set_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, 0); +} + +int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode) +{ + return xc_set_hvm_param(handle, domid, + HVM_PARAM_TIMER_MODE, (unsigned long) mode); +} + +int xc_domain_set_hpet(int handle, unsigned int domid, int hpet) +{ + return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigne= d long) hpet); +} + +int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_alig= n) +{ + return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigne= d long) vpt_align); +} + +int xc_domain_get_acpi_s_state(int handle, unsigned int domid) +{ + int ret; + unsigned long value; + + ret =3D xc_get_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, &value)= ; + if (ret !=3D 0) + xc_error_dom_set(domid, "get acpi s-state"); + return value; +} diff --git a/tools/ocaml/libs/xc/xc_stubs.c b/tools/ocaml/libs/xc/xc_stub= s.c new file mode 100644 index 0000000..b43a750 --- /dev/null +++ b/tools/ocaml/libs/xc/xc_stubs.c @@ -0,0 +1,1170 @@ +/* + * 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 publis= hed + * 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 + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include + +#include +#include +#include + +#include "xc.h" + +#include "mmap_stubs.h" + +#define PAGE_SHIFT 12 +#define PAGE_SIZE (1UL << PAGE_SHIFT) +#define PAGE_MASK (~(PAGE_SIZE-1)) + +#define _H(__h) (Int_val(__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) =3D=3D 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 =3D (uint32_t) Int64_val(Field(input, 0)); \ + i2 =3D ((Field(input, 1) =3D=3D Val_none) ? 0xffffffff : (uint32_t) Int= 64_val(Field(Field(input, 1), 0))); + +/** + * Convert the given number of pages to an amount in MiB, rounded up. + */ +void failwith_xc(void) +{ + caml_raise_with_string(*caml_named_value("xc.error"), xc_error_get()); +} + +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 =3D (Field(header, 0)) + ? XC_CORE_MAGIC + : XC_CORE_MAGIC_HVM; + c_header.xch_nr_vcpus =3D Int_val(Field(header, 1)); + c_header.xch_nr_pages =3D Nativeint_val(Field(header, 2)); + c_header.xch_ctxt_offset =3D Int64_val(Field(header, 3)); + c_header.xch_index_offset =3D Int64_val(Field(header, 4)); + c_header.xch_pages_offset =3D Int64_val(Field(header, 5)); + + s =3D caml_alloc_string(sizeof(c_header)); + memcpy(String_val(s), (char *) &c_header, sizeof(c_header)); + CAMLreturn(s); +} + +CAMLprim value stub_xc_interface_open() +{ + int handle; + handle =3D xc_interface_open(); + if (handle =3D=3D -1) + failwith_xc(); + return Val_int(handle); +} + + +CAMLprim value stub_xc_interface_open_fake() +{ + return Val_int(-1); +} + +CAMLprim value stub_xc_using_injection() +{ + if (xc_using_injection ()){ + return Val_int(1); + } else { + return Val_int(0); + } +} + +CAMLprim value stub_xc_interface_close(value xc_handle) +{ + CAMLparam1(xc_handle); + + int handle =3D _H(xc_handle); + // caml_enter_blocking_section(); + xc_interface_close(handle); + // caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +static int domain_create_flag_table[] =3D { + XEN_DOMCTL_CDF_hvm_guest, + XEN_DOMCTL_CDF_hap, +}; + +CAMLprim value stub_xc_domain_create(value xc_handle, value ssidref, + value flags, value handle) +{ + CAMLparam4(xc_handle, ssidref, flags, handle); + + uint32_t domid =3D 0; + xen_domain_handle_t h =3D { 0 }; + int result; + int i; + int c_xc_handle =3D _H(xc_handle); + uint32_t c_ssidref =3D Int32_val(ssidref); + unsigned int c_flags =3D 0; + value l; + + if (Wosize_val(handle) !=3D 16) + caml_invalid_argument("Handle not a 16-integer array"); + + for (i =3D 0; i < sizeof(h); i++) { + h[i] =3D Int_val(Field(handle, i)) & 0xff; + } + + for (l =3D flags; l !=3D Val_none; l =3D Field(l, 1)) { + int v =3D Int_val(Field(l, 0)); + c_flags |=3D domain_create_flag_table[v]; + } + + // caml_enter_blocking_section(); + result =3D xc_domain_create(c_xc_handle, c_ssidref, h, c_flags, &domid)= ; + // caml_leave_blocking_section(); + + if (result < 0) + failwith_xc(); + + CAMLreturn(Val_int(domid)); +} + +CAMLprim value stub_xc_domain_setvmxassist(value xc_handle, value domid, + value use_vmxassist) +{ + CAMLparam3(xc_handle, domid, use_vmxassist); + int r; + + r =3D xc_domain_setvmxassist(_H(xc_handle), _D(domid), + Bool_val(use_vmxassist)); + if (r) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_max_vcpus(value xc_handle, value domid, + value max_vcpus) +{ + CAMLparam3(xc_handle, domid, max_vcpus); + int r; + + r =3D xc_domain_max_vcpus(_H(xc_handle), _D(domid), Int_val(max_vcpus))= ; + if (r) + failwith_xc(); + + CAMLreturn(Val_unit); +} + + +value stub_xc_domain_sethandle(value xc_handle, value domid, value handl= e) +{ + CAMLparam3(xc_handle, domid, handle); + xen_domain_handle_t h =3D { 0 }; + int i; + + if (Wosize_val(handle) !=3D 16) + caml_invalid_argument("Handle not a 16-integer array"); + + for (i =3D 0; i < sizeof(h); i++) { + h[i] =3D Int_val(Field(handle, i)) & 0xff; + } + + i =3D xc_domain_sethandle(_H(xc_handle), _D(domid), h); + if (i) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +static value dom_op(value xc_handle, value domid, int (*fn)(int, uint32_= t)) +{ + CAMLparam2(xc_handle, domid); + + int c_xc_handle =3D _H(xc_handle); + uint32_t c_domid =3D _D(domid); + + // caml_enter_blocking_section(); + int result =3D fn(c_xc_handle, c_domid); + // caml_leave_blocking_section(); + if (result) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_pause(value xc_handle, value domid) +{ + return dom_op(xc_handle, domid, xc_domain_pause); +} + + +CAMLprim value stub_xc_domain_unpause(value xc_handle, value domid) +{ + return dom_op(xc_handle, domid, xc_domain_unpause); +} + +CAMLprim value stub_xc_domain_destroy(value xc_handle, value domid) +{ + return dom_op(xc_handle, domid, xc_domain_destroy); +} + +CAMLprim value stub_xc_domain_resume_fast(value xc_handle, value domid) +{ + return dom_op(xc_handle, domid, xc_domain_resume_fast); +} + +CAMLprim value stub_xc_domain_shutdown(value handle, value domid, value = reason) +{ + CAMLparam3(handle, domid, reason); + int ret; + + ret =3D xc_domain_shutdown(_H(handle), _D(domid), Int_val(reason)); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +static value alloc_domaininfo(xc_domaininfo_t * info) +{ + CAMLparam0(); + CAMLlocal2(result, tmp); + int i; + + result =3D 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_shutdownshif= t) + & 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 =3D caml_alloc_small(16, 0); + for (i =3D 0; i < 16; i++) { + Field(tmp, i) =3D Val_int(info->handle[i]); + } + + Store_field(result, 15, tmp); + + CAMLreturn(result); +} + +CAMLprim value stub_xc_domain_getinfolist(value xc_handle, value first_d= omain, value nb) +{ + CAMLparam3(xc_handle, first_domain, nb); + CAMLlocal2(result, temp); + xc_domaininfo_t * info; + int i, ret, toalloc; + + /* get the minimum number of allocate byte we need and bump it up to pa= ge boundary */ + toalloc =3D (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff; + ret =3D posix_memalign((void **) ((void *) &info), 4096, toalloc); + if (ret) + caml_raise_out_of_memory(); + + result =3D temp =3D Val_emptylist; + + int c_xc_handle =3D _H(xc_handle); + uint32_t c_first_domain =3D _D(first_domain); + unsigned int c_max_domains =3D Int_val(nb); + // caml_enter_blocking_section(); + int retval =3D xc_domain_getinfolist(c_xc_handle, c_first_domain, + c_max_domains, info); + // caml_leave_blocking_section(); + + if (retval < 0) { + free(info); + failwith_xc(); + } + for (i =3D 0; i < retval; i++) { + result =3D caml_alloc_small(2, Tag_cons); + Field(result, 0) =3D Val_int(0); + Field(result, 1) =3D temp; + temp =3D result; + + Store_field(result, 0, alloc_domaininfo(info + i)); + } + + free(info); + CAMLreturn(result); +} + +CAMLprim value stub_xc_domain_getinfo(value xc_handle, value domid) +{ + CAMLparam2(xc_handle, domid); + CAMLlocal1(result); + xc_domaininfo_t info; + int ret; + + ret =3D xc_domain_getinfo(_H(xc_handle), _D(domid), &info); + if (ret !=3D 0) + failwith_xc(); + + result =3D alloc_domaininfo(&info); + CAMLreturn(result); +} + +CAMLprim value stub_xc_vcpu_getinfo(value xc_handle, value domid, value = vcpu) +{ + CAMLparam3(xc_handle, domid, vcpu); + CAMLlocal1(result); + xc_vcpuinfo_t info; + int retval; + + int c_xc_handle =3D _H(xc_handle); + uint32_t c_domid =3D _D(domid); + uint32_t c_vcpu =3D Int_val(vcpu); + // caml_enter_blocking_section(); + retval =3D xc_vcpu_getinfo(c_xc_handle, c_domid, + c_vcpu, &info); + // caml_leave_blocking_section(); + if (retval < 0) + failwith_xc(); + + result =3D 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 xc_handle, value domid, + value cpu) +{ + CAMLparam3(xc_handle, domid, cpu); + CAMLlocal1(context); + int ret; + struct vcpu_guest_context ctxt; + + ret =3D xc_vcpu_getcontext(_H(xc_handle), _D(domid), Int_val(cpu), &ctx= t); + + context =3D caml_alloc_string(sizeof(ctxt)); + memcpy(String_val(context), (char *) &ctxt, sizeof(ctxt)); + + CAMLreturn(context); +} + +CAMLprim value stub_xc_vcpu_setaffinity(value xc_handle, value domid, + value vcpu, value cpumap) +{ + CAMLparam4(xc_handle, domid, vcpu, cpumap); + uint64_t c_cpumap; + int retval; + + c_cpumap =3D Int64_val(cpumap); + retval =3D xc_vcpu_setaffinity(_H(xc_handle), _D(domid), + Int_val(vcpu), c_cpumap); + if (retval < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_vcpu_getaffinity(value xc_handle, value domid, + value vcpu) +{ + CAMLparam3(xc_handle, domid, vcpu); + CAMLlocal1(ret); + uint64_t cpumap; + int retval; + + retval =3D xc_vcpu_getaffinity(_H(xc_handle), _D(domid), + Int_val(vcpu), &cpumap); + if (retval < 0) + failwith_xc(); + ret =3D caml_copy_int64(cpumap); + CAMLreturn(ret); +} + +CAMLprim value stub_xc_sched_id(value xc_handle) +{ + CAMLparam1(xc_handle); + int sched_id; + + if (xc_sched_id(_H(xc_handle), &sched_id)) + failwith_xc(); + CAMLreturn(Val_int(sched_id)); +} + +CAMLprim value stub_xc_evtchn_alloc_unbound(value xc_handle, + value local_domid, + value remote_domid) +{ + CAMLparam3(xc_handle, local_domid, remote_domid); + + int c_xc_handle =3D _H(xc_handle); + uint32_t c_local_domid =3D _D(local_domid); + uint32_t c_remote_domid =3D _D(remote_domid); + + // caml_enter_blocking_section(); + int result =3D xc_evtchn_alloc_unbound(c_xc_handle, c_local_domid, + c_remote_domid); + // caml_leave_blocking_section(); + + if (result < 0) + failwith_xc(); + CAMLreturn(Val_int(result)); +} + +CAMLprim value stub_xc_evtchn_reset(value handle, value domid) +{ + CAMLparam2(handle, domid); + int r; + + r =3D xc_evtchn_reset(_H(handle), _D(domid)); + if (r < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + + +#define RING_SIZE 32768 +static char ring[RING_SIZE]; + +CAMLprim value stub_xc_readconsolering(value xc_handle) +{ + unsigned int size =3D RING_SIZE; + char *ring_ptr =3D ring; + + CAMLparam1(xc_handle); + int c_xc_handle =3D _H(xc_handle); + + // caml_enter_blocking_section(); + int retval =3D xc_readconsolering(c_xc_handle, &ring_ptr, &size, 0); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + ring[size] =3D '\0'; + CAMLreturn(caml_copy_string(ring)); +} + +CAMLprim value stub_xc_send_debug_keys(value xc_handle, value keys) +{ + CAMLparam2(xc_handle, keys); + int r; + + r =3D xc_send_debug_keys(_H(xc_handle), String_val(keys)); + if (r) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_physinfo(value xc_handle) +{ + CAMLparam1(xc_handle); + CAMLlocal3(physinfo, cap_list, tmp); + xc_physinfo_t c_physinfo; + int r; + + // caml_enter_blocking_section(); + r =3D xc_physinfo(_H(xc_handle), &c_physinfo); + // caml_leave_blocking_section(); + + if (r) + failwith_xc(); + + tmp =3D cap_list =3D Val_emptylist; + for (r =3D 0; r < 2; r++) { + if ((c_physinfo.capabilities >> r) & 1) { + tmp =3D caml_alloc_small(2, Tag_cons); + Field(tmp, 0) =3D Val_int(r); + Field(tmp, 1) =3D cap_list; + cap_list =3D tmp; + } + } + + physinfo =3D 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 xc_handle, value nr_cpus) +{ + CAMLparam2(xc_handle, nr_cpus); + CAMLlocal2(pcpus, v); + uint64_t *info; + int r, size; + + if (Int_val(nr_cpus) < 1) + caml_invalid_argument("nr_cpus"); +=09 + info =3D calloc(Int_val(nr_cpus) + 1, sizeof(uint64_t)); + if (!info) + caml_raise_out_of_memory(); + + // caml_enter_blocking_section(); + r =3D xc_pcpu_info(_H(xc_handle), Int_val(nr_cpus), info, &size); + // caml_leave_blocking_section(); + + if (r) { + free(info); + failwith_xc(); + } + + if (size > 0) { + int i; + pcpus =3D caml_alloc(size, 0); + for (i =3D 0; i < size; i++) { + v =3D caml_copy_int64(info[i]); + caml_modify(&Field(pcpus, i), v); + } + } else + pcpus =3D Atom(0); + free(info); + CAMLreturn(pcpus); +} + +CAMLprim value stub_xc_domain_setmaxmem(value xc_handle, value domid, + value max_memkb) +{ + CAMLparam3(xc_handle, domid, max_memkb); + + int c_xc_handle =3D _H(xc_handle); + uint32_t c_domid =3D _D(domid); + unsigned int c_max_memkb =3D Int64_val(max_memkb); + // caml_enter_blocking_section(); + int retval =3D xc_domain_setmaxmem(c_xc_handle, c_domid, + c_max_memkb); + // caml_leave_blocking_section(); + if (retval) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_memmap_limit(value xc_handle, value do= mid, + value map_limitkb) +{ + CAMLparam3(xc_handle, domid, map_limitkb); + unsigned long v; + int retval; + + v =3D Int64_val(map_limitkb); + retval =3D xc_domain_set_memmap_limit(_H(xc_handle), _D(domid), v); + if (retval) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_memory_increase_reservation(value xc_handl= e, + value domid, + value mem_kb) +{ + CAMLparam3(xc_handle, domid, mem_kb); + + unsigned long nr_extents =3D ((unsigned long)(Int64_val(mem_kb))) >> (P= AGE_SHIFT - 10); + + int c_xc_handle =3D _H(xc_handle); + uint32_t c_domid =3D _D(domid); + // caml_enter_blocking_section(); + int retval =3D xc_domain_memory_increase_reservation(c_xc_handle, c_dom= id, + nr_extents, 0, 0, NU= LL); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_machine_address_size(value xc_handle, + value domid, + value width) +{ + CAMLparam3(xc_handle, domid, width); + int c_xc_handle =3D _H(xc_handle); + uint32_t c_domid =3D _D(domid); + int c_width =3D Int_val(width); + + int retval =3D xc_domain_set_machine_address_size(c_xc_handle, c_domid,= c_width); + if (retval) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_get_machine_address_size(value xc_handle, + value domid) +{ + CAMLparam2(xc_handle, domid); + int retval; + + retval =3D xc_domain_get_machine_address_size(_H(xc_handle), _D(domid))= ; + if (retval < 0) + failwith_xc(); + CAMLreturn(Val_int(retval)); +} + +CAMLprim value stub_xc_domain_cpuid_set(value xc_handle, value domid, + value is_hvm, value input, + value config) +{ + CAMLparam5(xc_handle, domid, is_hvm, input, config); + CAMLlocal2(array, tmp); + int r; + char *c_config[4], *out_config[4]; + uint32_t c_input, c_oinput; + + c_config[0] =3D string_of_option_array(config, 0); + c_config[1] =3D string_of_option_array(config, 1); + c_config[2] =3D string_of_option_array(config, 2); + c_config[3] =3D string_of_option_array(config, 3); + + cpuid_input_of_val(c_input, c_oinput, input); + + array =3D caml_alloc(4, 0); + for (r =3D 0; r < 4; r++) { + tmp =3D Val_none; + if (c_config[r]) { + tmp =3D caml_alloc_small(1, 0); + Field(tmp, 0) =3D caml_alloc_string(32); + } + Store_field(array, r, tmp); + } + + for (r =3D 0; r < 4; r++) + out_config[r] =3D (c_config[r]) ? String_val(Field(Field(array, r), 0)= ) : NULL; + + r =3D xc_domain_cpuid_set(_H(xc_handle), _D(domid), Bool_val(is_hvm), + c_input, c_oinput, c_config, out_config); + if (r < 0) + failwith_xc(); + CAMLreturn(array); +} + +CAMLprim value stub_xc_domain_cpuid_apply(value xc_handle, value domid, = value is_hvm) +{ + CAMLparam3(xc_handle, domid, is_hvm); + int r; + r =3D xc_domain_cpuid_apply(_H(xc_handle), _D(domid), Bool_val(is_hvm))= ; + if (r < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_cpuid_check(value input, value config) +{ + CAMLparam2(input, config); + CAMLlocal3(ret, array, tmp); + int r; + uint32_t c_input, c_oinput; + char *c_config[4], *out_config[4]; + + c_config[0] =3D string_of_option_array(config, 0); + c_config[1] =3D string_of_option_array(config, 1); + c_config[2] =3D string_of_option_array(config, 2); + c_config[3] =3D string_of_option_array(config, 3); + + cpuid_input_of_val(c_input, c_oinput, input); + + array =3D caml_alloc(4, 0); + for (r =3D 0; r < 4; r++) { + tmp =3D Val_none; + if (c_config[r]) { + tmp =3D caml_alloc_small(1, 0); + Field(tmp, 0) =3D caml_alloc_string(32); + } + Store_field(array, r, tmp); + } + + for (r =3D 0; r < 4; r++) + out_config[r] =3D (c_config[r]) ? String_val(Field(Field(array, r), 0)= ) : NULL; + + r =3D xc_cpuid_check(c_input, c_oinput, c_config, out_config); + if (r < 0) + failwith_xc(); + + ret =3D 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 xc_handle) +{ + CAMLparam1(xc_handle); + CAMLlocal1(result); + xen_extraversion_t extra; + long packed; + int retval; + + int c_xc_handle =3D _H(xc_handle); + // caml_enter_blocking_section(); + packed =3D xc_version(c_xc_handle, XENVER_version, NULL); + retval =3D xc_version(c_xc_handle, XENVER_extraversion, &extra); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + + result =3D 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 xc_handle) +{ + CAMLparam1(xc_handle); + CAMLlocal1(result); + xen_compile_info_t ci; + int retval; + + int c_xc_handle =3D _H(xc_handle); + // caml_enter_blocking_section(); + retval =3D xc_version(c_xc_handle, XENVER_compile_info, &ci); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + + result =3D 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 xc_handle, int code, void *i= nfo) +{ + CAMLparam1(xc_handle); + int retval; + + int c_xc_handle =3D _H(xc_handle); + // caml_enter_blocking_section(); + retval =3D xc_version(c_xc_handle, code, info); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + + CAMLreturn(caml_copy_string((char *)info)); +} + + +CAMLprim value stub_xc_version_changeset(value xc_handle) +{ + xen_changeset_info_t ci; + + return xc_version_single_string(xc_handle, XENVER_changeset, &ci); +} + + +CAMLprim value stub_xc_version_capabilities(value xc_handle) +{ + xen_capabilities_info_t ci; + + return xc_version_single_string(xc_handle, 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 xc_handle, value dom, + value size, value mfn) +{ + CAMLparam4(xc_handle, dom, size, mfn); + CAMLlocal1(result); + struct mmap_interface *intf; + + result =3D caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + intf =3D (struct mmap_interface *) result; + + intf->len =3D Int_val(size); + + int c_xc_handle =3D _H(xc_handle); + uint32_t c_dom =3D _D(dom); + unsigned long c_mfn =3D Nativeint_val(mfn); + // caml_enter_blocking_section(); + intf->addr =3D xc_map_foreign_range(c_xc_handle, 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 xc_handle, value domid= ) +{ + CAMLparam2(xc_handle, domid); + CAMLlocal1(sdom); + struct xen_domctl_sched_credit c_sdom; + int ret; + + // caml_enter_blocking_section(); + ret =3D xc_sched_credit_domain_get(_H(xc_handle), _D(domid), &c_sdom); + // caml_leave_blocking_section(); + if (ret !=3D 0) + failwith_xc(); + + sdom =3D 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 xc_handle, value domid= , + value sdom) +{ + CAMLparam3(xc_handle, domid, sdom); + struct xen_domctl_sched_credit c_sdom; + int ret; + + c_sdom.weight =3D Int_val(Field(sdom, 0)); + c_sdom.cap =3D Int_val(Field(sdom, 1)); + // caml_enter_blocking_section(); + ret =3D xc_sched_credit_domain_set(_H(xc_handle), _D(domid), &c_sdom); + // caml_leave_blocking_section(); + if (ret !=3D 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_shadow_allocation_get(value xc_handle, value domid) +{ + CAMLparam2(xc_handle, domid); + CAMLlocal1(mb); + uint32_t c_mb; + int ret; + + // caml_enter_blocking_section(); + ret =3D xc_shadow_allocation_get(_H(xc_handle), _D(domid), &c_mb); + // caml_leave_blocking_section(); + if (ret !=3D 0) + failwith_xc(); + + mb =3D Val_int(c_mb); + CAMLreturn(mb); +} + +CAMLprim value stub_shadow_allocation_set(value xc_handle, value domid, + value mb) +{ + CAMLparam3(xc_handle, domid, mb); + uint32_t c_mb; + int ret; + + c_mb =3D Int_val(mb); + // caml_enter_blocking_section(); + ret =3D xc_shadow_allocation_set(_H(xc_handle), _D(domid), c_mb); + // caml_leave_blocking_section(); + if (ret !=3D 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_get_pfn_list(value xc_handle, value domid, + value nr_pfns) +{ + CAMLparam3(xc_handle, domid, nr_pfns); + CAMLlocal2(array, v); + unsigned long c_nr_pfns; + long ret, i; + xen_pfn_t *c_array; + + c_nr_pfns =3D Nativeint_val(nr_pfns); + + c_array =3D malloc(sizeof(xen_pfn_t) * c_nr_pfns); + if (!c_array) + caml_raise_out_of_memory(); + + ret =3D xc_domain_get_pfn_list(_H(xc_handle), _D(domid), + c_array, c_nr_pfns); + if (ret < 0) { + free(c_array); + failwith_xc(); + } + + array =3D caml_alloc(ret, 0); + for (i =3D 0; i < ret; i++) { + v =3D caml_copy_nativeint(c_array[i]); + Store_field(array, i, v); + } + free(c_array); + + CAMLreturn(array); +} + +CAMLprim value stub_xc_domain_ioport_permission(value xc_handle, value d= omid, + value start_port, value nr_ports, + value allow) +{ + CAMLparam5(xc_handle, domid, start_port, nr_ports, allow); + uint32_t c_start_port, c_nr_ports; + uint8_t c_allow; + int ret; + + c_start_port =3D Int_val(start_port); + c_nr_ports =3D Int_val(nr_ports); + c_allow =3D Bool_val(allow); + + ret =3D xc_domain_ioport_permission(_H(xc_handle), _D(domid), + c_start_port, c_nr_ports, c_allow); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_iomem_permission(value xc_handle, value do= mid, + value start_pfn, value nr_pfns, + value allow) +{ + CAMLparam5(xc_handle, domid, start_pfn, nr_pfns, allow); + unsigned long c_start_pfn, c_nr_pfns; + uint8_t c_allow; + int ret; + + c_start_pfn =3D Nativeint_val(start_pfn); + c_nr_pfns =3D Nativeint_val(nr_pfns); + c_allow =3D Bool_val(allow); + + ret =3D xc_domain_iomem_permission(_H(xc_handle), _D(domid), + c_start_pfn, c_nr_pfns, c_allow); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_irq_permission(value xc_handle, value domi= d, + value pirq, value allow) +{ + CAMLparam4(xc_handle, domid, pirq, allow); + uint8_t c_pirq; + uint8_t c_allow; + int ret; + + c_pirq =3D Int_val(pirq); + c_allow =3D Bool_val(allow); + + ret =3D xc_domain_irq_permission(_H(xc_handle), _D(domid), + c_pirq, c_allow); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_hvm_check_pvdriver(value xc_handle, value domid) +{ + CAMLparam2(xc_handle, domid); + int ret; + + ret =3D xc_hvm_check_pvdriver(_H(xc_handle), _D(domid)); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_bool(ret)); +} + +CAMLprim value stub_xc_domain_test_assign_device(value xc_handle, value = domid, value desc) +{ + CAMLparam3(xc_handle, domid, desc); + int ret; + int domain, bus, slot, func; + + domain =3D Int_val(Field(desc, 0)); + bus =3D Int_val(Field(desc, 1)); + slot =3D Int_val(Field(desc, 2)); + func =3D Int_val(Field(desc, 3)); + + ret =3D xc_domain_test_assign_device(_H(xc_handle), _D(domid), + domain, bus, slot, func); + CAMLreturn(Val_bool(ret =3D=3D 0)); +} + +CAMLprim value stub_xc_domain_assign_device(value xc_handle, value domid= , value desc) +{ + CAMLparam3(xc_handle, domid, desc); + int ret; + int domain, bus, slot, func; + + domain =3D Int_val(Field(desc, 0)); + bus =3D Int_val(Field(desc, 1)); + slot =3D Int_val(Field(desc, 2)); + func =3D Int_val(Field(desc, 3)); + + ret =3D xc_domain_assign_device(_H(xc_handle), _D(domid), + domain, bus, slot, func); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_deassign_device(value xc_handle, value dom= id, value desc) +{ + CAMLparam3(xc_handle, domid, desc); + int ret; + int domain, bus, slot, func; + + domain =3D Int_val(Field(desc, 0)); + bus =3D Int_val(Field(desc, 1)); + slot =3D Int_val(Field(desc, 2)); + func =3D Int_val(Field(desc, 3)); + + ret =3D xc_domain_deassign_device(_H(xc_handle), _D(domid), + domain, bus, slot, func); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_timer_mode(value handle, value id, val= ue mode) +{ + CAMLparam3(handle, id, mode); + int ret; + + ret =3D xc_domain_set_timer_mode(_H(handle), _D(id), Int_val(mode)); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_hpet(value handle, value id, value mod= e) +{ + CAMLparam3(handle, id, mode); + int ret; + + ret =3D xc_domain_set_hpet(_H(handle), _D(id), Int_val(mode)); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_vpt_align(value handle, value id, valu= e mode) +{ + CAMLparam3(handle, id, mode); + int ret; + + ret =3D xc_domain_set_vpt_align(_H(handle), _D(id), Int_val(mode)); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_watchdog(value handle, value domid, value timeout= ) +{ + CAMLparam3(handle, domid, timeout); + int ret; + unsigned int c_timeout =3D Int32_val(timeout); + + ret =3D xc_domain_watchdog(_H(handle), _D(domid), c_timeout); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value stub_xc_domain_send_s3resume(value handle, value domid) +{ + CAMLparam2(handle, domid); + xc_domain_send_s3resume(_H(handle), _D(domid)); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_get_acpi_s_state(value handle, value domid= ) +{ + CAMLparam2(handle, domid); + int ret; + + ret =3D xc_domain_get_acpi_s_state(_H(handle), _D(domid)); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_int(ret)); +} + +/* + * Local variables: + * indent-tabs-mode: t + * c-basic-offset: 8 + * tab-width: 8 + * End: + */ diff --git a/tools/ocaml/libs/xs/META.in b/tools/ocaml/libs/xs/META.in new file mode 100644 index 0000000..77d93b5 --- /dev/null +++ b/tools/ocaml/libs/xs/META.in @@ -0,0 +1,4 @@ +version =3D "@VERSION@" +description =3D "XenStore Interface" +archive(byte) =3D "xs.cma" +archive(native) =3D "xs.cmxa" diff --git a/tools/ocaml/libs/xs/Makefile b/tools/ocaml/libs/xs/Makefile new file mode 100644 index 0000000..87cd375 --- /dev/null +++ b/tools/ocaml/libs/xs/Makefile @@ -0,0 +1,42 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +OCAMLINCLUDE +=3D -I ../xb/ + +.NOTPARALLEL: +# Ocaml is such a PITA! + +PREINTF =3D xsraw.cmi xst.cmi +PREOBJS =3D queueop xsraw xst +PRELIBS =3D $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJB= S),$(obj).cmx) +OBJS =3D queueop xsraw xst xs +INTF =3D xsraw.cmi xst.cmi xs.cmi +LIBS =3D xs.cma xs.cmxa + +all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +xs_OBJS =3D $(OBJS) +OCAML_NOC_LIBRARY =3D xs + +#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) + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.= cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove xs + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/xs/queueop.ml b/tools/ocaml/libs/xs/queueop= .ml new file mode 100644 index 0000000..cb298f5 --- /dev/null +++ b/tools/ocaml/libs/xs/queueop.ml @@ -0,0 +1,73 @@ +(* + * 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 publis= hed + * 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. + *) + +let data_concat ls =3D (String.concat "\000" ls) ^ "\000" +let queue_path ty (tid: int) (path: string) con =3D + let data =3D data_concat [ path; ] in + Xb.queue con (Xb.Packet.create tid 0 ty data) + +(* operations *) +let directory tid path con =3D queue_path Xb.Op.Directory tid path con +let read tid path con =3D queue_path Xb.Op.Read tid path con + +let getperms tid path con =3D queue_path Xb.Op.Getperms tid path con + +let debug commands con =3D + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands)) + +let watch path data con =3D + let data =3D data_concat [ path; data; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) + +let unwatch path data con =3D + let data =3D data_concat [ path; data; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) + +let transaction_start con =3D + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat= [])) + +let transaction_end tid commit con =3D + let data =3D data_concat [ (if commit then "T" else "F"); ] in + Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data) + +let introduce domid mfn port con =3D + let data =3D data_concat [ Printf.sprintf "%u" domid; + Printf.sprintf "%nu" mfn; + string_of_int port; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data) + +let release domid con =3D + let data =3D data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Release data) + +let resume domid con =3D + let data =3D data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) + +let getdomainpath domid con =3D + let data =3D data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data) + +let write tid path value con =3D + let data =3D path ^ "\000" ^ value (* no NULL at the end *) in + Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Write data) + +let mkdir tid path con =3D queue_path Xb.Op.Mkdir tid path con +let rm tid path con =3D queue_path Xb.Op.Rm tid path con + +let setperms tid path perms con =3D + let data =3D data_concat [ path; perms ] in + Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data) diff --git a/tools/ocaml/libs/xs/xs.ml b/tools/ocaml/libs/xs/xs.ml new file mode 100644 index 0000000..768778f --- /dev/null +++ b/tools/ocaml/libs/xs/xs.ml @@ -0,0 +1,170 @@ +(* + * 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 publis= hed + * 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 perms =3D Xsraw.perms +type con =3D Xsraw.con +type domid =3D int + +type xsh =3D +{ + con: con; + debug: string list -> string; + directory: string -> string list; + read: string -> string; + readv: string -> string list -> string list; + write: string -> string -> unit; + writev: string -> (string * string) list -> unit; + mkdir: string -> unit; + rm: string -> unit; + getperms: string -> perms; + setperms: string -> perms -> unit; + setpermsv: string -> string list -> perms -> unit; + introduce: domid -> nativeint -> int -> unit; + release: domid -> unit; + resume: domid -> unit; + getdomainpath: domid -> string; + watch: string -> string -> unit; + unwatch: string -> string -> unit; +} + +let get_operations con =3D { + con =3D con; + debug =3D (fun commands -> Xsraw.debug commands con); + directory =3D (fun path -> Xsraw.directory 0 path con); + read =3D (fun path -> Xsraw.read 0 path con); + readv =3D (fun dir vec -> Xsraw.readv 0 dir vec con); + write =3D (fun path value -> Xsraw.write 0 path value con); + writev =3D (fun dir vec -> Xsraw.writev 0 dir vec con); + mkdir =3D (fun path -> Xsraw.mkdir 0 path con); + rm =3D (fun path -> Xsraw.rm 0 path con); + getperms =3D (fun path -> Xsraw.getperms 0 path con); + setperms =3D (fun path perms -> Xsraw.setperms 0 path perms con); + setpermsv =3D (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con= ); + introduce =3D (fun id mfn port -> Xsraw.introduce id mfn port con); + release =3D (fun id -> Xsraw.release id con); + resume =3D (fun id -> Xsraw.resume id con); + getdomainpath =3D (fun id -> Xsraw.getdomainpath id con); + watch =3D (fun path data -> Xsraw.watch path data con); + unwatch =3D (fun path data -> Xsraw.unwatch path data con); +} + +let transaction xsh =3D Xst.transaction xsh.con + +let has_watchevents xsh =3D Xsraw.has_watchevents xsh.con +let get_watchevent xsh =3D Xsraw.get_watchevent xsh.con + +let read_watchevent xsh =3D Xsraw.read_watchevent xsh.con + +let make fd =3D get_operations (Xsraw.open_fd fd) +let get_fd xsh =3D Xb.get_fd xsh.con.Xsraw.xb + +exception Timeout + +(* Should never be thrown, indicates a bug in the read_watchevent_timeto= ut function *) +exception Timeout_with_nonempty_queue + +(* Just in case we screw up: poll the callback every couple of seconds r= ather + than wait for the whole timeout period *) +let max_blocking_time =3D 5. (* seconds *) + +let read_watchevent_timeout xsh timeout callback =3D + let start_time =3D Unix.gettimeofday () in + let end_time =3D start_time +. timeout in + + let left =3D ref timeout in + + (* Returns true if a watch event in the queue satisfied us *) + let process_queued_events () =3D=20 + let success =3D ref false in + while Xsraw.has_watchevents xsh.con && not(!success) + do + success :=3D callback (Xsraw.get_watchevent xsh.con) + done; + !success in + (* Returns true if a watch event read from the socket satisfied us *) + let process_incoming_event () =3D=20 + let fd =3D get_fd xsh in + let r, _, _ =3D Unix.select [ fd ] [] [] (min max_blocking_time !left)= in + + (* If data is available for reading then read it *) + if r =3D [] + then false (* timeout, either a max_blocking_time or global *) + else callback (Xsraw.read_watchevent xsh.con) in + + let success =3D ref false in + while !left > 0. && not(!success) + do + (* NB the 'callback' might call back into Xs functions + and as a side-effect, watches might be queued. Hence + we must process the queue on every loop iteration *) + + (* First process all queued watch events *) + if not(!success) + then success :=3D process_queued_events (); + (* Then block for one more watch event *) + if not(!success) + then success :=3D process_incoming_event (); + (* Just in case our callback caused events to be queued + and this is our last time round the loop: this prevents + us throwing the Timeout_with_nonempty_queue spuriously *) + if not(!success) + then success :=3D process_queued_events (); + + (* Update the time left *) + let current_time =3D Unix.gettimeofday () in + left :=3D end_time -. current_time + done; + if not(!success) then begin + (* Sanity check: it should be impossible for any + events to be queued here *) + if Xsraw.has_watchevents xsh.con + then raise Timeout_with_nonempty_queue + else raise Timeout + end + + +let monitor_paths xsh l time callback =3D + let unwatch () =3D + List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in + List.iter (fun (w,v) -> xsh.watch w v) l; + begin try + read_watchevent_timeout xsh time callback; + with + exn -> unwatch (); raise exn; + end; + unwatch () + +let daemon_socket =3D "/var/run/xenstored/socket" + +(** Throws this rather than a miscellaneous Unix.connect failed *) +exception Failed_to_connect + +let daemon_open () =3D + try + let sockaddr =3D Unix.ADDR_UNIX(daemon_socket) in + let sock =3D Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.connect sock sockaddr; + Unix.set_close_on_exec sock; + make sock + with _ -> raise Failed_to_connect + +let domain_open () =3D + let path =3D "/proc/xen/xenbus" in + let fd =3D Unix.openfile path [ Unix.O_RDWR ] 0o550 in + Unix.set_close_on_exec fd; + make fd + +let close xsh =3D Xsraw.close xsh.con diff --git a/tools/ocaml/libs/xs/xs.mli b/tools/ocaml/libs/xs/xs.mli new file mode 100644 index 0000000..ce505b6 --- /dev/null +++ b/tools/ocaml/libs/xs/xs.mli @@ -0,0 +1,90 @@ +(* + * 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 publis= hed + * 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 Timeout + +(** Throws this rather than a miscellaneous Unix.connect failed *) +exception Failed_to_connect + +(** perms contains 3 things: + - owner domid. + - other perm: applied to domain that is not owner or in ACL. + - ACL: list of per-domain permission + *) +type perms =3D Xsraw.perms + +type domid =3D int +type con + +type xsh =3D { + con : con; + debug: string list -> string; + directory : string -> string list; + read : string -> string; + readv : string -> string list -> string list; + write : string -> string -> unit; + writev : string -> (string * string) list -> unit; + mkdir : string -> unit; + rm : string -> unit; + getperms : string -> perms; + setperms : string -> perms -> unit; + setpermsv : string -> string list -> perms -> unit; + introduce : domid -> nativeint -> int -> unit; + release : domid -> unit; + resume : domid -> unit; + getdomainpath : domid -> string; + watch : string -> string -> unit; + unwatch : string -> string -> unit; +} + +(** get operations provide a vector of xenstore function that apply to o= ne + connection *) +val get_operations : con -> xsh + +(** create a transaction with a vector of function that can be applied + into the transaction. *) +val transaction : xsh -> (Xst.ops -> 'a) -> 'a + +(** watch manipulation on a connection *) +val has_watchevents : xsh -> bool +val get_watchevent : xsh -> string * string +val read_watchevent : xsh -> string * string + +(** get_fd return the fd of the connection to be able to select on it. + NOTE: it works only for socket-based connection *) +val get_fd : xsh -> Unix.file_descr + +(** wait for watchevent with a timeout. Until the callback return true, + every watch during the time specified, will be pass to the callback. + NOTE: it works only when use with a socket-based connection *) +val read_watchevent_timeout : xsh -> float -> (string * string -> bool) = -> unit + +(** register a set of watches, then wait for watchevent. + remove all watches previously set before giving back the hand. *) +val monitor_paths : xsh + -> (string * string) list + -> float + -> (string * string -> bool) + -> unit + +(** open a socket-based xenstored connection *) +val daemon_open : unit -> xsh + +(** open a mmap-based xenstored connection *) +val domain_open : unit -> xsh + +(** close any xenstored connection *) +val close : xsh -> unit diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml new file mode 100644 index 0000000..370d38e --- /dev/null +++ b/tools/ocaml/libs/xs/xsraw.ml @@ -0,0 +1,265 @@ +(* + * 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 publis= hed + * 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 Partial_not_empty +exception Unexpected_packet of string + +(** Thrown when a path looks invalid e.g. if it contains "//" *) +exception Invalid_path of string + +let unexpected_packet expected received =3D + let s =3D Printf.sprintf "expecting %s received %s" + (Xb.Op.to_string expected) + (Xb.Op.to_string received) in + raise (Unexpected_packet s) + +type con =3D { + xb: Xb.t; + watchevents: (string * string) Queue.t; +} + +let close con =3D + Xb.close con.xb + +let open_fd fd =3D { + xb =3D Xb.open_fd fd; + watchevents =3D Queue.create (); +} + +let rec split_string ?limit:(limit=3D(-1)) c s =3D + let i =3D try String.index s c with Not_found -> -1 in + let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - 1= in + if i =3D -1 || nlimit =3D 0 then + [ s ] + else + let a =3D String.sub s 0 i + and b =3D String.sub s (i + 1) (String.length s - i - 1) in + a :: (split_string ~limit: nlimit c b) + +type perm =3D PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR + +type perms =3D int * perm * (int * perm) list + +let string_of_perms perms =3D + let owner, other, acl =3D perms in + let char_of_perm perm =3D + match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' + | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in + let string_of_perm (id, perm) =3D Printf.sprintf "%c%u" (char_of_perm p= erm) id in + String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) + +let perms_of_string s =3D + let perm_of_char c =3D + match c with 'n' -> PERM_NONE | 'r' -> PERM_READ + | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR + | c -> invalid_arg (Printf.sprintf "unknown permission type= : %c" c) in + let perm_of_string s =3D + if String.length s < 2=20 + then invalid_arg (Printf.sprintf "perm of string: length =3D %d; conte= nts=3D\"%s\"" (String.length s) s)=20 + else + begin + int_of_string (String.sub s 1 (String.length s - 1)), + perm_of_char s.[0] + end in + let rec split s =3D + try let i =3D String.index s '\000' in + String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 -= i)) + with Not_found -> if s =3D "" then [] else [ s ] in + let l =3D List.map perm_of_string (split s) in + match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, []) + +(* send one packet - can sleep *) +let pkt_send con =3D + if Xb.has_old_output con.xb then + raise Partial_not_empty; + let workdone =3D ref false in + while not !workdone + do + workdone :=3D Xb.output con.xb + done + +(* receive one packet - can sleep *) +let pkt_recv con =3D + let workdone =3D ref false in + while not !workdone + do + workdone :=3D Xb.input con.xb + done; + Xb.get_in_packet con.xb + +let pkt_recv_timeout con timeout =3D + let fd =3D Xb.get_fd con.xb in + let r, _, _ =3D Unix.select [ fd ] [] [] timeout in + if r =3D [] then + true, None + else ( + let workdone =3D Xb.input con.xb in + if workdone then + false, (Some (Xb.get_in_packet con.xb)) + else + false, None + ) + +let queue_watchevent con data =3D + let ls =3D split_string ~limit:2 '\000' data in + if List.length ls !=3D 2 then + raise (Xb.Packet.DataError "arguments number mismatch"); + let event =3D List.nth ls 0 + and event_data =3D List.nth ls 1 in + Queue.push (event, event_data) con.watchevents + +let has_watchevents con =3D Queue.length con.watchevents > 0 +let get_watchevent con =3D Queue.pop con.watchevents + +let read_watchevent con =3D + let pkt =3D pkt_recv con in + match Xb.Packet.get_ty pkt with + | Xb.Op.Watchevent -> + queue_watchevent con (Xb.Packet.get_data pkt); + Queue.pop con.watchevents + | ty -> unexpected_packet Xb.Op.Watchevent ty + +(* send one packet in the queue, and wait for reply *) +let rec sync_recv ty con =3D + let pkt =3D pkt_recv con in + match Xb.Packet.get_ty pkt with + | Xb.Op.Error -> ( + match Xb.Packet.get_data pkt with + | "ENOENT" -> raise Xb.Noent + | "EAGAIN" -> raise Xb.Eagain + | "EINVAL" -> raise Xb.Invalid + | s -> raise (Xb.Packet.Error s)) + | Xb.Op.Watchevent -> + queue_watchevent con (Xb.Packet.get_data pkt); + sync_recv ty con + | rty when rty =3D ty -> Xb.Packet.get_data pkt + | rty -> unexpected_packet ty rty + +let sync f con =3D + (* queue a query using function f *) + f con.xb; + if Xb.output_len con.xb =3D 0 then + Printf.printf "output len =3D 0\n%!"; + let ty =3D Xb.Packet.get_ty (Xb.peek_output con.xb) in + pkt_send con; + sync_recv ty con + +let ack s =3D + if s =3D "OK" then () else raise (Xb.Packet.DataError s) + +(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT = watches) *) +let validate_path path =3D + (* Paths shouldn't have a "//" in the middle *) + let bad =3D "//" in + for offset =3D 0 to String.length path - (String.length bad) do + if String.sub path offset (String.length bad) =3D bad then + raise (Invalid_path path) + done; + (* Paths shouldn't have a "/" at the end, except for the root *) + if path <> "/" && path <> "" && path.[String.length path - 1] =3D '/' t= hen + raise (Invalid_path path) + +(** Check to see if a path is suitable for watches *) +let validate_watch_path path =3D + (* Check for stuff like @releaseDomain etc first *) + if path <> "" && path.[0] =3D '@' then () + else validate_path path + +let debug command con =3D + sync (Queueop.debug command) con + +let directory tid path con =3D + validate_path path; + let data =3D sync (Queueop.directory tid path) con in + split_string '\000' data + +let read tid path con =3D + validate_path path; + sync (Queueop.read tid path) con + +let readv tid dir vec con =3D + List.map (fun path -> validate_path path; read tid path con) + (if dir <> "" then + (List.map (fun v -> dir ^ "/" ^ v) vec) else vec) + +let getperms tid path con =3D + validate_path path; + perms_of_string (sync (Queueop.getperms tid path) con) + +let watch path data con =3D + validate_watch_path path; + ack (sync (Queueop.watch path data) con) + +let unwatch path data con =3D + validate_watch_path path; + ack (sync (Queueop.unwatch path data) con) + +let transaction_start con =3D + let data =3D sync (Queueop.transaction_start) con in + try + int_of_string data + with + _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" = data)) + +let transaction_end tid commit con =3D + try + ack (sync (Queueop.transaction_end tid commit) con); + true + with + Xb.Eagain -> false + +let introduce domid mfn port con =3D + ack (sync (Queueop.introduce domid mfn port) con) + +let release domid con =3D + ack (sync (Queueop.release domid) con) + +let resume domid con =3D + ack (sync (Queueop.resume domid) con) + +let getdomainpath domid con =3D + sync (Queueop.getdomainpath domid) con + +let write tid path value con =3D + validate_path path; + ack (sync (Queueop.write tid path value) con) + +let writev tid dir vec con =3D + List.iter (fun (entry, value) -> + let path =3D (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + write tid path value con) vec + +let mkdir tid path con =3D + validate_path path; + ack (sync (Queueop.mkdir tid path) con) + +let rm tid path con =3D + validate_path path; + try + ack (sync (Queueop.rm tid path) con) + with + Xb.Noent -> () + +let setperms tid path perms con =3D + validate_path path; + ack (sync (Queueop.setperms tid path (string_of_perms perms)) con) + +let setpermsv tid dir vec perms con =3D + List.iter (fun entry -> + let path =3D (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + setperms tid path perms con) vec diff --git a/tools/ocaml/libs/xs/xsraw.mli b/tools/ocaml/libs/xs/xsraw.ml= i new file mode 100644 index 0000000..42f87b6 --- /dev/null +++ b/tools/ocaml/libs/xs/xsraw.mli @@ -0,0 +1,60 @@ +(* + * 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 publis= hed + * 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 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 =3D { xb : 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 +type perm =3D PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR +type perms =3D int * perm * (int * perm) list +val string_of_perms : int * perm * (int * perm) list -> string +val perms_of_string : string -> int * perm * (int * perm) list +val pkt_send : con -> unit +val pkt_recv : con -> Xb.Packet.t +val pkt_recv_timeout : con -> float -> bool * Xb.Packet.t option +val 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 ack : string -> unit +val validate_path : string -> unit +val validate_watch_path : string -> unit +val directory : int -> string -> con -> string list +val debug : string list -> con -> string +val read : int -> string -> con -> string +val readv : int -> string -> string list -> con -> string list +val getperms : int -> string -> con -> int * perm * (int * perm) list +val watch : string -> string -> con -> unit +val unwatch : string -> string -> con -> unit +val transaction_start : con -> int +val transaction_end : int -> bool -> con -> bool +val introduce : int -> nativeint -> int -> con -> unit +val release : int -> con -> unit +val resume : int -> con -> unit +val getdomainpath : int -> con -> string +val write : int -> string -> string -> con -> unit +val writev : int -> string -> (string * string) list -> con -> unit +val mkdir : int -> string -> con -> unit +val rm : int -> string -> con -> unit +val setperms : int -> string -> int * perm * (int * perm) list -> con ->= unit +val setpermsv : + int -> + string -> string list -> int * perm * (int * perm) list -> con -> unit diff --git a/tools/ocaml/libs/xs/xst.ml b/tools/ocaml/libs/xs/xst.ml new file mode 100644 index 0000000..16affd2 --- /dev/null +++ b/tools/ocaml/libs/xs/xst.ml @@ -0,0 +1,61 @@ +(* + * 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 publis= hed + * 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 ops =3D +{ + directory: string -> string list; + read: string -> string; + readv: string -> string list -> string list; + write: string -> string -> unit; + writev: string -> (string * string) list -> unit; + mkdir: string -> unit; + rm: string -> unit; + getperms: string -> Xsraw.perms; + setperms: string -> Xsraw.perms -> unit; + setpermsv: string -> string list -> Xsraw.perms -> unit; +} + +let get_operations tid xsh =3D { + directory =3D (fun path -> Xsraw.directory tid path xsh); + read =3D (fun path -> Xsraw.read tid path xsh); + readv =3D (fun dir vec -> Xsraw.readv tid dir vec xsh); + write =3D (fun path value -> Xsraw.write tid path value xsh); + writev =3D (fun dir vec -> Xsraw.writev tid dir vec xsh); + mkdir =3D (fun path -> Xsraw.mkdir tid path xsh); + rm =3D (fun path -> Xsraw.rm tid path xsh); + getperms =3D (fun path -> Xsraw.getperms tid path xsh); + setperms =3D (fun path perms -> Xsraw.setperms tid path perms xsh); + setpermsv =3D (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms x= sh); +} + +let transaction xsh (f: ops -> 'a) : 'a =3D + let commited =3D ref false and result =3D ref None in + while not !commited + do + let tid =3D Xsraw.transaction_start xsh in + let t =3D get_operations tid xsh in + + begin try + result :=3D Some (f t) + with exn -> + ignore (Xsraw.transaction_end tid false xsh); + raise exn + end; + commited :=3D Xsraw.transaction_end tid true xsh + done; + match !result with + | None -> failwith "internal error in transaction" + | Some result -> result diff --git a/tools/ocaml/libs/xs/xst.mli b/tools/ocaml/libs/xs/xst.mli new file mode 100644 index 0000000..5ae5604 --- /dev/null +++ b/tools/ocaml/libs/xs/xst.mli @@ -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 publis= hed + * 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 ops =3D { + directory : string -> string list; + read : string -> string; + readv : string -> string list -> string list; + write : string -> string -> unit; + writev : string -> (string * string) list -> unit; + mkdir : string -> unit; + rm : string -> unit; + getperms : string -> Xsraw.perms; + setperms : string -> Xsraw.perms -> unit; + setpermsv : string -> string list -> Xsraw.perms -> unit; +} + +val get_operations : int -> Xsraw.con -> ops +val transaction : Xsraw.con -> (ops -> 'a) -> 'a --------------1.7.0 Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Xen-devel mailing list Xen-devel@lists.xensource.com http://lists.xensource.com/xen-devel --------------1.7.0--