libxl: ocaml: improve the bindings

libxl: ocaml: improve the bindings

[Rob Hoes]

This is version 7 of the remaining patches to fix the OCaml bindings to libxl.

There were only minor changes in patch 3, 6, and 8.

For convenience, the patches in this series may be pulled using:
git pull git://github.com/robhoes/xen.git hydrogen-upstream-v7

[PATCH v7 1/9] libxl: ocaml: add simple test case for xentoollog

[Rob Hoes]

Add a simple noddy test case (tools/ocaml/test) for the the Xentoollog OCaml
module.

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>

---
v5: Add the test case that was omitted from a previous patch, and fixed the
Makefile.
---
 .gitignore                |    1 +
 .hgignore                 |    1 +
 tools/ocaml/Makefile      |    2 +-
 tools/ocaml/test/Makefile |   28 ++++++++++++++++++++++++++++
 tools/ocaml/test/xtl.ml   |   40 ++++++++++++++++++++++++++++++++++++++++
 5 files changed, 71 insertions(+), 1 deletion(-)
 create mode 100644 tools/ocaml/test/Makefile
 create mode 100644 tools/ocaml/test/xtl.ml

diff --git a/.gitignore b/.gitignore
index 93aae71..20f20ed 100644
--- a/.gitignore
+++ b/.gitignore
@@ -385,6 +385,7 @@ tools/ocaml/libs/xentoollog/_xtl_levels.*
 tools/ocaml/libs/xentoollog/xentoollog.ml
 tools/ocaml/libs/xentoollog/xentoollog.mli
 tools/ocaml/xenstored/oxenstored
+tools/ocaml/test/xtl
 
 tools/debugger/kdd/kdd
 tools/firmware/etherboot/ipxe.tar.gz
diff --git a/.hgignore b/.hgignore
index 05cb0de..bb1b67d 100644
--- a/.hgignore
+++ b/.hgignore
@@ -308,6 +308,7 @@
 ^tools/ocaml/libs/xl/xenlight\.ml$
 ^tools/ocaml/libs/xl/xenlight\.mli$
 ^tools/ocaml/xenstored/oxenstored$
+^tools/ocaml/test/xtl$
 ^tools/autom4te\.cache$
 ^tools/config\.h$
 ^tools/config\.log$
diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile
index 6b22bbe..8e4ca36 100644
--- a/tools/ocaml/Makefile
+++ b/tools/ocaml/Makefile
@@ -1,7 +1,7 @@
 XEN_ROOT = $(CURDIR)/../..
 include $(XEN_ROOT)/tools/Rules.mk
 
-SUBDIRS_PROGRAMS = xenstored
+SUBDIRS_PROGRAMS = xenstored test
 
 SUBDIRS = libs $(SUBDIRS_PROGRAMS)
 
diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile
new file mode 100644
index 0000000..3a35d04
--- /dev/null
+++ b/tools/ocaml/test/Makefile
@@ -0,0 +1,28 @@
+XEN_ROOT = $(CURDIR)/../../..
+OCAML_TOPLEVEL = $(CURDIR)/..
+include $(OCAML_TOPLEVEL)/common.make
+
+OCAMLINCLUDE += \
+	-I $(OCAML_TOPLEVEL)/libs/xentoollog
+
+OBJS = xtl
+
+PROGRAMS = xtl
+
+xtl_LIBS =  \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
+	-cclib $(LDLIBS_libxenctrl)
+
+xtl_OBJS = xtl
+
+OCAML_PROGRAM = xtl
+
+all: $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+install: all
+	$(INSTALL_DIR) $(DESTDIR)$(BINDIR)
+	$(INSTALL_PROG) $(PROGRAMS) $(DESTDIR)$(BINDIR)
+
+include $(OCAML_TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/test/xtl.ml b/tools/ocaml/test/xtl.ml
new file mode 100644
index 0000000..db30aae
--- /dev/null
+++ b/tools/ocaml/test/xtl.ml
@@ -0,0 +1,40 @@
+open Arg
+open Printf
+open Xentoollog
+
+let stdio_vmessage min_level level errno ctx msg =
+	let level_str = level_to_string level
+	and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d" s
+	and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in
+	if compare min_level level <= 0 then begin
+		printf "%s%s%s: %s\n" level_str ctx_str errno_str msg;
+		flush stdout;
+	end
+
+let stdio_progress ctx what percent dne total =
+	let nl = if dne = total then "\n" else "" in
+	printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl;
+	flush stdout
+
+let create_stdio_logger ?(level=Info) () =
+	let cbs = {
+		vmessage = stdio_vmessage level;
+		progress = stdio_progress; } in
+	create "Xentoollog.stdio_logger" cbs
+
+let do_test level = 
+  let lgr = create_stdio_logger ~level:level () in
+  begin
+    test lgr;
+  end
+
+let () =
+  let debug_level = ref Info in
+  let speclist = [
+    ("-v", Arg.Unit (fun () -> debug_level := Debug), "Verbose");
+    ("-q", Arg.Unit (fun () -> debug_level := Critical), "Quiet");
+  ] in
+  let usage_msg = "usage: xtl [OPTIONS]" in
+  Arg.parse speclist (fun s -> ()) usage_msg;
+
+  do_test !debug_level
-- 
1.7.10.4

[PATCH v7 2/9] libxl: ocaml: implement some simple tests

[Rob Hoes]

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>
---
 .gitignore                          |    3 ++-
 .hgignore                           |    2 ++
 tools/ocaml/test/Makefile           |   30 ++++++++++++++++++++++++++----
 tools/ocaml/test/list_domains.ml    |   28 ++++++++++++++++++++++++++++
 tools/ocaml/test/raise_exception.ml |   11 +++++++++++
 tools/ocaml/test/send_debug_keys.ml |   15 +++++++++++++++
 6 files changed, 84 insertions(+), 5 deletions(-)
 create mode 100644 tools/ocaml/test/list_domains.ml
 create mode 100644 tools/ocaml/test/raise_exception.ml
 create mode 100644 tools/ocaml/test/send_debug_keys.ml

diff --git a/.gitignore b/.gitignore
index 20f20ed..ce5fd39 100644
--- a/.gitignore
+++ b/.gitignore
@@ -386,7 +386,8 @@ tools/ocaml/libs/xentoollog/xentoollog.ml
 tools/ocaml/libs/xentoollog/xentoollog.mli
 tools/ocaml/xenstored/oxenstored
 tools/ocaml/test/xtl
-
+tools/ocaml/test/send_debug_keys
+tools/ocaml/test/list_domains
 tools/debugger/kdd/kdd
 tools/firmware/etherboot/ipxe.tar.gz
 tools/firmware/etherboot/ipxe/
diff --git a/.hgignore b/.hgignore
index bb1b67d..ee5c084 100644
--- a/.hgignore
+++ b/.hgignore
@@ -309,6 +309,8 @@
 ^tools/ocaml/libs/xl/xenlight\.mli$
 ^tools/ocaml/xenstored/oxenstored$
 ^tools/ocaml/test/xtl$
+^tools/ocaml/test/send_debug_keys$
+^tools/ocaml/test/list_domains$
 ^tools/autom4te\.cache$
 ^tools/config\.h$
 ^tools/config\.log$
diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile
index 3a35d04..dfa6437 100644
--- a/tools/ocaml/test/Makefile
+++ b/tools/ocaml/test/Makefile
@@ -2,12 +2,16 @@ XEN_ROOT = $(CURDIR)/../../..
 OCAML_TOPLEVEL = $(CURDIR)/..
 include $(OCAML_TOPLEVEL)/common.make
 
+CFLAGS += $(CFLAGS_libxenlight)
+LIBS_xenlight = $(LDLIBS_libxenlight)
+
 OCAMLINCLUDE += \
-	-I $(OCAML_TOPLEVEL)/libs/xentoollog
+	-I $(OCAML_TOPLEVEL)/libs/xentoollog \
+	-I $(OCAML_TOPLEVEL)/libs/xl
 
-OBJS = xtl
+OBJS = xtl send_debug_keys list_domains raise_exception
 
-PROGRAMS = xtl
+PROGRAMS = xtl send_debug_keys list_domains raise_exception
 
 xtl_LIBS =  \
 	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
@@ -15,7 +19,25 @@ xtl_LIBS =  \
 
 xtl_OBJS = xtl
 
-OCAML_PROGRAM = xtl
+send_debug_keys_LIBS =  \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
+
+send_debug_keys_OBJS = xtl send_debug_keys
+
+list_domains_LIBS =  \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
+
+list_domains_OBJS = xtl list_domains
+
+raise_exception_LIBS =  \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
+
+raise_exception_OBJS = raise_exception
+
+OCAML_PROGRAM = xtl send_debug_keys list_domains raise_exception
 
 all: $(PROGRAMS)
 
diff --git a/tools/ocaml/test/list_domains.ml b/tools/ocaml/test/list_domains.ml
new file mode 100644
index 0000000..c82d40d
--- /dev/null
+++ b/tools/ocaml/test/list_domains.ml
@@ -0,0 +1,28 @@
+open Arg
+open Printf
+open Xenlight
+
+let bool_as_char b c = if b then c else '-'
+
+let print_dominfo dominfo =
+  let id = dominfo.Xenlight.Dominfo.domid
+  and running = bool_as_char dominfo.Xenlight.Dominfo.running 'r'
+  and blocked = bool_as_char dominfo.Xenlight.Dominfo.blocked 'b'
+  and paused = bool_as_char dominfo.Xenlight.Dominfo.paused 'p'
+  and shutdown = bool_as_char dominfo.Xenlight.Dominfo.shutdown 's'
+  and dying = bool_as_char dominfo.Xenlight.Dominfo.dying 'd'
+  and memory = dominfo.Xenlight.Dominfo.current_memkb
+  in
+  printf "Dom %d: %c%c%c%c%c %LdKB\n" id running blocked paused shutdown dying memory
+
+let _ =
+  let logger = Xtl.create_stdio_logger (*~level:Xentoollog.Debug*) () in
+  let ctx = Xenlight.ctx_alloc logger in
+  try
+    let domains = Xenlight.Dominfo.list ctx in
+    List.iter (fun d -> print_dominfo d) domains
+  with Xenlight.Error(err, fn) -> begin
+    printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
+  end
+
+
diff --git a/tools/ocaml/test/raise_exception.ml b/tools/ocaml/test/raise_exception.ml
new file mode 100644
index 0000000..d4371f5
--- /dev/null
+++ b/tools/ocaml/test/raise_exception.ml
@@ -0,0 +1,11 @@
+open Printf
+open Xentoollog
+open Xenlight
+
+let _ = 
+  try
+    Xenlight.test_raise_exception ()
+  with Xenlight.Error(err, fn) -> begin
+    printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
+  end
+
diff --git a/tools/ocaml/test/send_debug_keys.ml b/tools/ocaml/test/send_debug_keys.ml
new file mode 100644
index 0000000..b9cd61e
--- /dev/null
+++ b/tools/ocaml/test/send_debug_keys.ml
@@ -0,0 +1,15 @@
+open Arg
+open Printf
+open Xenlight
+
+let send_keys ctx s = 
+  printf "Sending debug key %s\n" s;
+  Xenlight.send_debug_keys ctx s;
+  ()
+  
+let _ = 
+  let logger = Xtl.create_stdio_logger () in
+  let ctx = Xenlight.ctx_alloc logger in
+  Arg.parse [
+  ] (fun s -> send_keys ctx s) "usage: send_debug_keys <keys>"
+
-- 
1.7.10.4

[PATCH v7 3/9] libxl: ocaml: event management

[Rob Hoes]

Having bindings to the low-level functions libxl_osevent_register_hooks and
related, allows to run an event loop in OCaml; either one we write ourselves,
or one that is available elsewhere.

The Lwt cooperative threads library (http://ocsigen.org/lwt/), which is quite
popular these days, has an event loop that can be easily extended to poll any
additional fds that we get from libxl. Lwt provides a "lightweight" threading
model, which does not let you run any other (POSIX) threads in your
application, and therefore excludes an event loop implemented in the C
bindings.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>

---
v7: Added comment in source to explain the unregistering of for_callback.
---
 tools/ocaml/libs/xl/xenlight.ml.in   |   37 ++++
 tools/ocaml/libs/xl/xenlight.mli.in  |   38 ++++
 tools/ocaml/libs/xl/xenlight_stubs.c |  354 ++++++++++++++++++++++++++++++++++
 3 files changed, 429 insertions(+)

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index a281425..46106b5 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -25,10 +25,47 @@ external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
 
 external test_raise_exception: unit -> unit = "stub_raise_exception"
 
+type event =
+	| POLLIN (* There is data to read *)
+	| POLLPRI (* There is urgent data to read *)
+	| POLLOUT (* Writing now will not block *)
+	| POLLERR (* Error condition (revents only) *)
+	| POLLHUP (* Device has been disconnected (revents only) *)
+	| POLLNVAL (* Invalid request: fd not open (revents only). *)
+
 external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 
+module Async = struct
+	type for_libxl
+	type event_hooks
+	type osevent_hooks
+
+	external osevent_register_hooks' : ctx -> 'a -> osevent_hooks = "stub_libxl_osevent_register_hooks"
+	external osevent_occurred_fd : ctx -> for_libxl -> Unix.file_descr -> event list -> event list -> unit = "stub_libxl_osevent_occurred_fd"
+	external osevent_occurred_timeout : ctx -> for_libxl -> unit = "stub_libxl_osevent_occurred_timeout"
+
+	let osevent_register_hooks ctx ~user ~fd_register ~fd_modify ~fd_deregister ~timeout_register ~timeout_modify =
+		Callback.register "libxl_fd_register" fd_register;
+		Callback.register "libxl_fd_modify" fd_modify;
+		Callback.register "libxl_fd_deregister" fd_deregister;
+		Callback.register "libxl_timeout_register" timeout_register;
+		Callback.register "libxl_timeout_modify" timeout_modify;
+		osevent_register_hooks' ctx user
+
+	let async_register_callback ~async_callback =
+		Callback.register "libxl_async_callback" async_callback
+
+	external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death"
+	external event_register_callbacks' : ctx -> 'a -> event_hooks = "stub_libxl_event_register_callbacks"
+
+	let event_register_callbacks ctx ~user ~event_occurs_callback ~event_disaster_callback =
+		Callback.register "libxl_event_occurs_callback" event_occurs_callback;
+		Callback.register "libxl_event_disaster_callback" event_disaster_callback;
+		event_register_callbacks' ctx user
+end
+
 let register_exceptions () =
 	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""))
 
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index d663196..170e0e0 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -27,7 +27,45 @@ external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
 
 external test_raise_exception: unit -> unit = "stub_raise_exception"
 
+type event =
+	| POLLIN (* There is data to read *)
+	| POLLPRI (* There is urgent data to read *)
+	| POLLOUT (* Writing now will not block *)
+	| POLLERR (* Error condition (revents only) *)
+	| POLLHUP (* Device has been disconnected (revents only) *)
+	| POLLNVAL (* Invalid request: fd not open (revents only). *)
+
 external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 
+module Async : sig
+	type for_libxl
+	type event_hooks
+	type osevent_hooks
+
+	val osevent_register_hooks : ctx ->
+		user:'a ->
+		fd_register:('a -> Unix.file_descr -> event list -> for_libxl -> unit) ->
+		fd_modify:('a -> Unix.file_descr -> event list -> unit) ->
+		fd_deregister:('a -> Unix.file_descr -> unit) ->
+		timeout_register:('a -> int -> int -> for_libxl -> unit) ->
+		timeout_modify:('a -> unit) ->
+		osevent_hooks
+
+	external osevent_occurred_fd : ctx -> for_libxl -> Unix.file_descr -> event list -> event list -> unit = "stub_libxl_osevent_occurred_fd"
+	external osevent_occurred_timeout : ctx -> for_libxl -> unit = "stub_libxl_osevent_occurred_timeout"
+
+	val async_register_callback :
+		async_callback:(result:error option -> user:'a -> unit) ->
+		unit
+
+	external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death"
+
+	val event_register_callbacks : ctx ->
+		user:'a ->
+		event_occurs_callback:('a -> Event.t -> unit) ->
+		event_disaster_callback:('a -> event_type -> string -> int -> unit) ->
+		event_hooks
+end
+
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 4ea2047..39a9632 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -30,6 +30,8 @@
 #include <libxl.h>
 #include <libxl_utils.h>
 
+#include <unistd.h>
+
 #include "caml_xentoollog.h"
 
 #define Ctx_val(x)(*((libxl_ctx **) Data_custom_val(x)))
@@ -370,6 +372,35 @@ static char *String_option_val(value v)
 
 #include "_libxl_types.inc"
 
+void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
+{
+	CAMLparam0();
+	CAMLlocal2(error, tmp);
+	static value *func = NULL;
+	value *p = (value *) for_callback;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_async_callback");
+	}
+
+	if (rc == 0)
+		error = Val_none;
+	else {
+		tmp = Val_error(rc);
+		error = Val_some(tmp);
+	}
+
+	/* for_callback is a pointer to a "value" that was malloc'ed and
+	 * registered with the OCaml GC. The value is handed back to OCaml
+	 * in the following callback, after which the pointer is unregistered
+	 * and freed. */
+	caml_callback2(*func, error, *p);
+
+	caml_remove_global_root(p);
+	free(p);
+}
+
 #define _STRINGIFY(x) #x
 #define STRINGIFY(x) _STRINGIFY(x)
 
@@ -703,6 +734,329 @@ value stub_xl_send_debug_keys(value ctx, value keys)
 	CAMLreturn(Val_unit);
 }
 
+
+/* Event handling */
+
+short Poll_val(value event)
+{
+	CAMLparam1(event);
+	short res = -1;
+
+	switch (Int_val(event)) {
+		case 0: res = POLLIN; break;
+		case 1: res = POLLPRI; break;
+		case 2: res = POLLOUT; break;
+		case 3: res = POLLERR; break;
+		case 4: res = POLLHUP; break;
+		case 5: res = POLLNVAL; break;
+	}
+
+	CAMLreturn(res);
+}
+
+short Poll_events_val(value event_list)
+{
+	CAMLparam1(event_list);
+	short events = 0;
+
+	while (event_list != Val_emptylist) {
+		events |= Poll_val(Field(event_list, 0));
+		event_list = Field(event_list, 1);
+	}
+
+	CAMLreturn(events);
+}
+
+value Val_poll(short event)
+{
+	CAMLparam0();
+	CAMLlocal1(res);
+
+	switch (event) {
+		case POLLIN: res = Val_int(0); break;
+		case POLLPRI: res = Val_int(1); break;
+		case POLLOUT: res = Val_int(2); break;
+		case POLLERR: res = Val_int(3); break;
+		case POLLHUP: res = Val_int(4); break;
+		case POLLNVAL: res = Val_int(5); break;
+		default: failwith_xl(ERROR_FAIL, "cannot convert poll event value"); break;
+	}
+
+	CAMLreturn(res);
+}
+
+value add_event(value event_list, short event)
+{
+	CAMLparam1(event_list);
+	CAMLlocal1(new_list);
+
+	new_list = caml_alloc(2, 0);
+	Store_field(new_list, 0, Val_poll(event));
+	Store_field(new_list, 1, event_list);
+
+	CAMLreturn(new_list);
+}
+
+value Val_poll_events(short events)
+{
+	CAMLparam0();
+	CAMLlocal1(event_list);
+
+	event_list = Val_emptylist;
+	if (events & POLLIN)
+		event_list = add_event(event_list, POLLIN);
+	if (events & POLLPRI)
+		event_list = add_event(event_list, POLLPRI);
+	if (events & POLLOUT)
+		event_list = add_event(event_list, POLLOUT);
+	if (events & POLLERR)
+		event_list = add_event(event_list, POLLERR);
+	if (events & POLLHUP)
+		event_list = add_event(event_list, POLLHUP);
+	if (events & POLLNVAL)
+		event_list = add_event(event_list, POLLNVAL);
+
+	CAMLreturn(event_list);
+}
+
+int fd_register(void *user, int fd, void **for_app_registration_out,
+                     short events, void *for_libxl)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 4);
+	static value *func = NULL;
+	value *p = (value *) user;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_register");
+	}
+
+	args[0] = *p;
+	args[1] = Val_int(fd);
+	args[2] = Val_poll_events(events);
+	args[3] = (value) for_libxl;
+
+	caml_callbackN(*func, 4, args);
+	CAMLreturn(0);
+}
+
+int fd_modify(void *user, int fd, void **for_app_registration_update,
+                   short events)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 3);
+	static value *func = NULL;
+	value *p = (value *) user;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_modify");
+	}
+
+	args[0] = *p;
+	args[1] = Val_int(fd);
+	args[2] = Val_poll_events(events);
+
+	caml_callbackN(*func, 3, args);
+	CAMLreturn(0);
+}
+
+void fd_deregister(void *user, int fd, void *for_app_registration)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 2);
+	static value *func = NULL;
+	value *p = (value *) user;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_deregister");
+	}
+
+	args[0] = *p;
+	args[1] = Val_int(fd);
+
+	caml_callbackN(*func, 2, args);
+	CAMLreturn0;
+}
+
+int timeout_register(void *user, void **for_app_registration_out,
+                          struct timeval abs, void *for_libxl)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 4);
+	static value *func = NULL;
+	value *p = (value *) user;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_timeout_register");
+	}
+
+	args[0] = *p;
+	args[1] = Val_int(abs.tv_sec);
+	args[2] = Val_int(abs.tv_usec);
+	args[3] = (value) for_libxl;
+
+	caml_callbackN(*func, 4, args);
+	CAMLreturn(0);
+}
+
+int timeout_modify(void *user, void **for_app_registration_update,
+                         struct timeval abs)
+{
+	CAMLparam0();
+	static value *func = NULL;
+	value *p = (value *) user;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_timeout_modify");
+	}
+
+	caml_callback(*func, *p);
+	CAMLreturn(0);
+}
+
+void timeout_deregister(void *user, void *for_app_registration)
+{
+	failwith_xl(ERROR_FAIL, "timeout_deregister not yet implemented");
+	return;
+}
+
+value stub_libxl_osevent_register_hooks(value ctx, value user)
+{
+	CAMLparam2(ctx, user);
+	CAMLlocal1(result);
+	libxl_osevent_hooks *hooks;
+	value *p;
+
+	hooks = malloc(sizeof(*hooks));
+	if (!hooks)
+		failwith_xl(ERROR_NOMEM, "cannot allocate osevent hooks");
+	hooks->fd_register = fd_register;
+	hooks->fd_modify = fd_modify;
+	hooks->fd_deregister = fd_deregister;
+	hooks->timeout_register = timeout_register;
+	hooks->timeout_modify = timeout_modify;
+	hooks->timeout_deregister = timeout_deregister;
+
+	p = malloc(sizeof(value));
+	if (!p)
+		failwith_xl(ERROR_NOMEM, "cannot allocate value");
+	*p = user;
+	caml_register_global_root(p);
+
+	libxl_osevent_register_hooks(CTX, hooks, (void *) p);
+
+	result = caml_alloc(1, Abstract_tag);
+	*((libxl_osevent_hooks **) result) = hooks;
+
+	CAMLreturn(result);
+}
+
+value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd,
+	value events, value revents)
+{
+	CAMLparam5(ctx, for_libxl, fd, events, revents);
+	libxl_osevent_occurred_fd(CTX, (void *) for_libxl, Int_val(fd),
+		Poll_events_val(events), Poll_events_val(revents));
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_osevent_occurred_timeout(value ctx, value for_libxl)
+{
+	CAMLparam2(ctx, for_libxl);
+	libxl_osevent_occurred_timeout(CTX, (void *) for_libxl);
+	CAMLreturn(Val_unit);
+}
+
+struct user_with_ctx {
+	libxl_ctx *ctx;
+	value user;
+};
+
+void event_occurs(void *user, libxl_event *event)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 2);
+	struct user_with_ctx *c_user = (struct user_with_ctx *) user;
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_event_occurs_callback");
+	}
+
+	args[0] = c_user->user;
+	args[1] = Val_event(event);
+	libxl_event_free(c_user->ctx, event);
+
+	caml_callbackN(*func, 2, args);
+	CAMLreturn0;
+}
+
+void disaster(void *user, libxl_event_type type,
+                     const char *msg, int errnoval)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 4);
+	struct user_with_ctx *c_user = (struct user_with_ctx *) user;
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_event_disaster_callback");
+	}
+
+	args[0] = c_user->user;
+	args[1] = Val_event_type(type);
+	args[2] = caml_copy_string(msg);
+	args[3] = Val_int(errnoval);
+
+	caml_callbackN(*func, 4, args);
+	CAMLreturn0;
+}
+
+value stub_libxl_event_register_callbacks(value ctx, value user)
+{
+	CAMLparam2(ctx, user);
+	CAMLlocal1(result);
+	struct user_with_ctx *c_user = NULL;
+	libxl_event_hooks *hooks;
+
+	c_user = malloc(sizeof(*c_user));
+	if (!c_user)
+		failwith_xl(ERROR_NOMEM, "cannot allocate user value");
+	c_user->user = user;
+	c_user->ctx = CTX;
+	caml_register_global_root(&c_user->user);
+
+	hooks = malloc(sizeof(*hooks));
+	if (!hooks)
+		failwith_xl(ERROR_NOMEM, "cannot allocate event hooks");
+	hooks->event_occurs_mask = LIBXL_EVENTMASK_ALL;
+	hooks->event_occurs = event_occurs;
+	hooks->disaster = disaster;
+
+	libxl_event_register_callbacks(CTX, hooks, (void *) c_user);
+	result = caml_alloc(1, Abstract_tag);
+	*((libxl_event_hooks **) result) = hooks;
+
+	CAMLreturn(result);
+}
+
+value stub_libxl_evenable_domain_death(value ctx, value domid, value user)
+{
+	CAMLparam3(ctx, domid, user);
+	libxl_evgen_domain_death *evgen_out;
+
+	libxl_evenable_domain_death(CTX, Int_val(domid), Int_val(user), &evgen_out);
+
+	CAMLreturn(Val_unit);
+}
+
 /*
  * Local variables:
  *  indent-tabs-mode: t
-- 
1.7.10.4

Re: [PATCH v7 3/9] libxl: ocaml: event management

[Ian Campbell]

On Tue, 2013-12-10 at 16:48 +0000, Rob Hoes wrote:
> Having bindings to the low-level functions libxl_osevent_register_hooks and
> related, allows to run an event loop in OCaml; either one we write ourselves,
> or one that is available elsewhere.
> 
> The Lwt cooperative threads library (http://ocsigen.org/lwt/), which is quite
> popular these days, has an event loop that can be easily extended to poll any
> additional fds that we get from libxl. Lwt provides a "lightweight" threading
> model, which does not let you run any other (POSIX) threads in your
> application, and therefore excludes an event loop implemented in the C
> bindings.
> 
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> Acked-by: David Scott <dave.scott@eu.citrix.com>

Acked-by: Ian Campbell <ian.campbell@citrix.com>

[PATCH v7 4/9] libxl: ocaml: allow device operations to be called asynchronously

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Campbell <ian.campbell@citrix.com>
CC: David Scott <dave.scott@eu.citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |    6 +++---
 tools/ocaml/libs/xl/xenlight_stubs.c |   18 +++++++++++++++---
 2 files changed, 18 insertions(+), 6 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index f5d2224..dd43069 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -22,9 +22,9 @@ builtins = {
     "libxl_cpuid_policy_list": ("unit",                "%(c)s = 0",                         "Val_unit"),
     }
 
-DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "unit"]),
-                     ("remove",         ["ctx", "t", "domid", "unit"]),
-                     ("destroy",        ["ctx", "t", "domid", "unit"]),
+DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
+                     ("remove",         ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
+                     ("destroy",        ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
                    ]
 
 functions = { # ( name , [type1,type2,....] )
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 39a9632..1a0fab3 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -405,15 +405,27 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 #define STRINGIFY(x) _STRINGIFY(x)
 
 #define _DEVICE_ADDREMOVE(type,op)					\
-value stub_xl_device_##type##_##op(value ctx, value info, value domid)	\
+value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
+	value async, value unit)					\
 {									\
-	CAMLparam3(ctx, info, domid);					\
+	CAMLparam5(ctx, info, domid, async, unit);			\
 	libxl_device_##type c_info;					\
 	int ret, marker_var;						\
+	libxl_asyncop_how ao_how;					\
+	value *p;							\
 									\
 	device_##type##_val(CTX, &c_info, info);			\
 									\
-	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info, 0); \
+	if (async != Val_none) {					\
+		p = malloc(sizeof(value));				\
+		*p = Some_val(async);					\
+		caml_register_global_root(p);				\
+		ao_how.callback = async_callback;			\
+		ao_how.u.for_callback = (void *) p;			\
+	}								\
+									\
+	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info,	\
+		async != Val_none ? &ao_how : NULL);			\
 									\
 	libxl_device_##type##_dispose(&c_info);				\
 									\
-- 
1.7.10.4

[PATCH v7 5/9] libxl: ocaml: add disk and cdrom helper functions

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>
Acked-by: Ian Campbell <ian.campbell@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |   17 +++++++-----
 tools/ocaml/libs/xl/xenlight_stubs.c |   50 ++++++++++++++++++++++++++++++----
 2 files changed, 55 insertions(+), 12 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index dd43069..5e43831 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -26,18 +26,21 @@ DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "?async:'a", "unit
                      ("remove",         ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
                      ("destroy",        ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
                    ]
+DEVICE_LIST =      [ ("list",           ["ctx", "domid", "t list"]),
+                   ]
 
 functions = { # ( name , [type1,type2,....] )
     "device_vfb":     DEVICE_FUNCTIONS,
     "device_vkb":     DEVICE_FUNCTIONS,
-    "device_disk":    DEVICE_FUNCTIONS,
-    "device_nic":     DEVICE_FUNCTIONS +
-                      [ ("list",           ["ctx", "domid", "t list"]),
-                        ("of_devid",       ["ctx", "domid", "int", "t"]),
+    "device_disk":    DEVICE_FUNCTIONS + DEVICE_LIST +
+                      [ ("insert",         ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
+                        ("of_vdev",        ["ctx", "domid", "string", "t"]),
+                      ],
+    "device_nic":     DEVICE_FUNCTIONS + DEVICE_LIST +
+                      [ ("of_devid",       ["ctx", "domid", "int", "t"]),
                       ],
-    "device_pci":     DEVICE_FUNCTIONS +
-                      [ ("list",              ["ctx", "domid", "t list"]),
-                        ("assignable_add",    ["ctx", "t", "bool", "unit"]),
+    "device_pci":     DEVICE_FUNCTIONS + DEVICE_LIST +
+                      [ ("assignable_add",    ["ctx", "t", "bool", "unit"]),
                         ("assignable_remove", ["ctx", "t", "bool", "unit"]),
                         ("assignable_list",   ["ctx", "t list"]),
                       ],
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 1a0fab3..7221726 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -404,7 +404,7 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 #define _STRINGIFY(x) #x
 #define STRINGIFY(x) _STRINGIFY(x)
 
-#define _DEVICE_ADDREMOVE(type,op)					\
+#define _DEVICE_ADDREMOVE(type,fn,op)					\
 value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 	value async, value unit)					\
 {									\
@@ -424,7 +424,7 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 		ao_how.u.for_callback = (void *) p;			\
 	}								\
 									\
-	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info,	\
+	ret = libxl_##fn##_##op(CTX, Int_val(domid), &c_info,		\
 		async != Val_none ? &ao_how : NULL);			\
 									\
 	libxl_device_##type##_dispose(&c_info);				\
@@ -436,15 +436,16 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 }
 
 #define DEVICE_ADDREMOVE(type) \
-	_DEVICE_ADDREMOVE(type, add) \
- 	_DEVICE_ADDREMOVE(type, remove) \
- 	_DEVICE_ADDREMOVE(type, destroy)
+	_DEVICE_ADDREMOVE(type, device_##type, add) \
+ 	_DEVICE_ADDREMOVE(type, device_##type, remove) \
+ 	_DEVICE_ADDREMOVE(type, device_##type, destroy)
 
 DEVICE_ADDREMOVE(disk)
 DEVICE_ADDREMOVE(nic)
 DEVICE_ADDREMOVE(vfb)
 DEVICE_ADDREMOVE(vkb)
 DEVICE_ADDREMOVE(pci)
+_DEVICE_ADDREMOVE(disk, cdrom, insert)
 
 value stub_xl_device_nic_of_devid(value ctx, value domid, value devid)
 {
@@ -485,6 +486,45 @@ value stub_xl_device_nic_list(value ctx, value domid)
 	CAMLreturn(list);
 }
 
+value stub_xl_device_disk_list(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	CAMLlocal2(list, temp);
+	libxl_device_disk *c_list;
+	int i, nb;
+	uint32_t c_domid;
+
+	c_domid = Int_val(domid);
+
+	c_list = libxl_device_disk_list(CTX, c_domid, &nb);
+	if (!c_list)
+		failwith_xl(ERROR_FAIL, "disk_list");
+
+	list = temp = Val_emptylist;
+	for (i = 0; i < nb; i++) {
+		list = caml_alloc_small(2, Tag_cons);
+		Field(list, 0) = Val_int(0);
+		Field(list, 1) = temp;
+		temp = list;
+		Store_field(list, 0, Val_device_disk(&c_list[i]));
+		libxl_device_disk_dispose(&c_list[i]);
+	}
+	free(c_list);
+
+	CAMLreturn(list);
+}
+
+value stub_xl_device_disk_of_vdev(value ctx, value domid, value vdev)
+{
+	CAMLparam3(ctx, domid, vdev);
+	CAMLlocal1(disk);
+	libxl_device_disk c_disk;
+	libxl_vdev_to_device_disk(CTX, Int_val(domid), String_val(vdev), &c_disk);
+	disk = Val_device_disk(&c_disk);
+	libxl_device_disk_dispose(&c_disk);
+	CAMLreturn(disk);
+}
+
 value stub_xl_device_pci_list(value ctx, value domid)
 {
 	CAMLparam2(ctx, domid);
-- 
1.7.10.4

[PATCH v7 6/9] libxl: ocaml: add VM lifecycle operations

[Rob Hoes]

Also:
* Reorganise toplevel OCaml functions into modules of Xenlight.
* Factor out the management of ao_how into the function aohow_val. The ao_how
  is now malloc'ed, just to make this function a little easier to use.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Campbell <ian.campbell@citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>

---
v7: Add a comment to explain the registration for the for_callback value.
---
 tools/ocaml/libs/xl/xenlight.ml.in   |   21 ++++-
 tools/ocaml/libs/xl/xenlight.mli.in  |   21 ++++-
 tools/ocaml/libs/xl/xenlight_stubs.c |  173 ++++++++++++++++++++++++++++++++--
 tools/ocaml/test/send_debug_keys.ml  |    2 +-
 4 files changed, 200 insertions(+), 17 deletions(-)

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index 46106b5..fc05112 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -33,9 +33,24 @@ type event =
 	| POLLHUP (* Device has been disconnected (revents only) *)
 	| POLLNVAL (* Invalid request: fd not open (revents only). *)
 
-external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+module Domain = struct
+	external create_new : ctx -> Domain_config.t -> ?async:'a -> unit -> domid = "stub_libxl_domain_create_new"
+	external create_restore : ctx -> Domain_config.t -> (Unix.file_descr * Domain_restore_params.t) ->
+		?async:'a -> unit -> domid = "stub_libxl_domain_create_restore"
+	external shutdown : ctx -> domid -> unit = "stub_libxl_domain_shutdown"
+	external reboot : ctx -> domid -> unit = "stub_libxl_domain_reboot"
+	external destroy : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_destroy"
+	external suspend : ctx -> domid -> Unix.file_descr -> ?async:'a -> unit -> unit = "stub_libxl_domain_suspend"
+	external pause : ctx -> domid -> unit = "stub_libxl_domain_pause"
+	external unpause : ctx -> domid -> unit = "stub_libxl_domain_unpause"
+
+	external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
+	external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
+end
+
+module Host = struct
+	external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+end
 
 module Async = struct
 	type for_libxl
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index 170e0e0..ee4efd8 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -35,9 +35,24 @@ type event =
 	| POLLHUP (* Device has been disconnected (revents only) *)
 	| POLLNVAL (* Invalid request: fd not open (revents only). *)
 
-external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+module Domain : sig
+	external create_new : ctx -> Domain_config.t -> ?async:'a -> unit -> domid = "stub_libxl_domain_create_new"
+	external create_restore : ctx -> Domain_config.t -> (Unix.file_descr * Domain_restore_params.t) ->
+		?async:'a -> unit -> domid = "stub_libxl_domain_create_restore"
+	external shutdown : ctx -> domid -> unit = "stub_libxl_domain_shutdown"
+	external reboot : ctx -> domid -> unit = "stub_libxl_domain_reboot"
+	external destroy : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_destroy"
+	external suspend : ctx -> domid -> Unix.file_descr -> ?async:'a -> unit -> unit = "stub_libxl_domain_suspend"
+	external pause : ctx -> domid -> unit = "stub_libxl_domain_pause"
+	external unpause : ctx -> domid -> unit = "stub_libxl_domain_unpause"
+
+	external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
+	external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
+end
+
+module Host : sig
+	external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+end
 
 module Async : sig
 	type for_libxl
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 7221726..0602286 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -401,6 +401,168 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 	free(p);
 }
 
+static libxl_asyncop_how *aohow_val(value async, libxl_asyncop_how *ao_how)
+{
+	CAMLparam1(async);
+	value *p;
+
+	if (async != Val_none) {
+		/* for_callback must be a pointer to a "value" that is malloc'ed and
+		 * registered with the OCaml GC. This ensures that the GC does not remove
+		 * the corresponding OCaml heap blocks, and allows the GC to update the value
+		 * when blocks are moved around, while libxl is free to copy the pointer if
+		 * it needs to.
+		 * The for_callback pointer must always be non-NULL. */
+		p = malloc(sizeof(value));
+		if (!p)
+			failwith_xl(ERROR_NOMEM, "cannot allocate value");
+		*p = Some_val(async);
+		caml_register_global_root(p);
+		ao_how->callback = async_callback;
+		ao_how->u.for_callback = (void *) p;
+		CAMLreturnT(libxl_asyncop_how *, ao_how);
+	}
+	else
+		CAMLreturnT(libxl_asyncop_how *, NULL);
+}
+
+value stub_libxl_domain_create_new(value ctx, value domain_config, value async, value unit)
+{
+	CAMLparam4(ctx, async, domain_config, unit);
+	int ret;
+	libxl_domain_config c_dconfig;
+	uint32_t c_domid;
+	libxl_asyncop_how ao_how;
+
+	libxl_domain_config_init(&c_dconfig);
+	ret = domain_config_val(CTX, &c_dconfig, domain_config);
+	if (ret != 0) {
+		libxl_domain_config_dispose(&c_dconfig);
+		failwith_xl(ret, "domain_create_new");
+	}
+
+	ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid,
+		aohow_val(async, &ao_how), NULL);
+
+	libxl_domain_config_dispose(&c_dconfig);
+
+	if (ret != 0)
+		failwith_xl(ret, "domain_create_new");
+
+	CAMLreturn(Val_int(c_domid));
+}
+
+value stub_libxl_domain_create_restore(value ctx, value domain_config, value params,
+	value async, value unit)
+{
+	CAMLparam5(ctx, domain_config, params, async, unit);
+	int ret;
+	libxl_domain_config c_dconfig;
+	libxl_domain_restore_params c_params;
+	uint32_t c_domid;
+	libxl_asyncop_how ao_how;
+
+	libxl_domain_config_init(&c_dconfig);
+	ret = domain_config_val(CTX, &c_dconfig, domain_config);
+	if (ret != 0) {
+		libxl_domain_config_dispose(&c_dconfig);
+		failwith_xl(ret, "domain_create_restore");
+	}
+
+	libxl_domain_restore_params_init(&c_params);
+	ret = domain_restore_params_val(CTX, &c_params, Field(params, 1));
+	if (ret != 0) {
+		libxl_domain_restore_params_dispose(&c_params);
+		failwith_xl(ret, "domain_create_restore");
+	}
+
+	ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, Int_val(Field(params, 0)),
+		&c_params, aohow_val(async, &ao_how), NULL);
+
+	libxl_domain_config_dispose(&c_dconfig);
+	libxl_domain_restore_params_dispose(&c_params);
+
+	if (ret != 0)
+		failwith_xl(ret, "domain_create_restore");
+
+	CAMLreturn(Val_int(c_domid));
+}
+
+value stub_libxl_domain_shutdown(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+
+	ret = libxl_domain_shutdown(CTX, Int_val(domid));
+	if (ret != 0)
+		failwith_xl(ret, "domain_shutdown");
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_reboot(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+
+	ret = libxl_domain_reboot(CTX, Int_val(domid));
+	if (ret != 0)
+		failwith_xl(ret, "domain_reboot");
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_destroy(value ctx, value domid, value async, value unit)
+{
+	CAMLparam4(ctx, domid, async, unit);
+	int ret;
+	libxl_asyncop_how ao_how;
+
+	ret = libxl_domain_destroy(CTX, Int_val(domid), aohow_val(async, &ao_how));
+	if (ret != 0)
+		failwith_xl(ret, "domain_destroy");
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_suspend(value ctx, value domid, value fd, value async, value unit)
+{
+	CAMLparam5(ctx, domid, fd, async, unit);
+	int ret;
+	libxl_asyncop_how ao_how;
+
+	ret = libxl_domain_suspend(CTX, Int_val(domid), Int_val(fd), 0,
+		aohow_val(async, &ao_how));
+	if (ret != 0)
+		failwith_xl(ret, "domain_suspend");
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_pause(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+
+	ret = libxl_domain_pause(CTX, Int_val(domid));
+	if (ret != 0)
+		failwith_xl(ret, "domain_pause");
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_unpause(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+
+	ret = libxl_domain_unpause(CTX, Int_val(domid));
+	if (ret != 0)
+		failwith_xl(ret, "domain_unpause");
+
+	CAMLreturn(Val_unit);
+}
+
 #define _STRINGIFY(x) #x
 #define STRINGIFY(x) _STRINGIFY(x)
 
@@ -412,20 +574,11 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 	libxl_device_##type c_info;					\
 	int ret, marker_var;						\
 	libxl_asyncop_how ao_how;					\
-	value *p;							\
 									\
 	device_##type##_val(CTX, &c_info, info);			\
 									\
-	if (async != Val_none) {					\
-		p = malloc(sizeof(value));				\
-		*p = Some_val(async);					\
-		caml_register_global_root(p);				\
-		ao_how.callback = async_callback;			\
-		ao_how.u.for_callback = (void *) p;			\
-	}								\
-									\
 	ret = libxl_##fn##_##op(CTX, Int_val(domid), &c_info,		\
-		async != Val_none ? &ao_how : NULL);			\
+		aohow_val(async, &ao_how));				\
 									\
 	libxl_device_##type##_dispose(&c_info);				\
 									\
diff --git a/tools/ocaml/test/send_debug_keys.ml b/tools/ocaml/test/send_debug_keys.ml
index b9cd61e..2cca322 100644
--- a/tools/ocaml/test/send_debug_keys.ml
+++ b/tools/ocaml/test/send_debug_keys.ml
@@ -4,7 +4,7 @@ open Xenlight
 
 let send_keys ctx s = 
   printf "Sending debug key %s\n" s;
-  Xenlight.send_debug_keys ctx s;
+  Xenlight.Host.send_debug_keys ctx s;
   ()
   
 let _ = 
-- 
1.7.10.4

[PATCH v7 7/9] libxl: ocaml: add console reader functions

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>
Acked-by: Ian Campbell <ian.campbell@citrix.com>
---
 tools/ocaml/libs/xl/xenlight.ml.in   |   10 ++++-
 tools/ocaml/libs/xl/xenlight.mli.in  |    7 ++++
 tools/ocaml/libs/xl/xenlight_stubs.c |   68 ++++++++++++++++++++++++++++++++++
 tools/ocaml/test/Makefile            |   12 ++++--
 tools/ocaml/test/dmesg.ml            |   18 +++++++++
 5 files changed, 111 insertions(+), 4 deletions(-)
 create mode 100644 tools/ocaml/test/dmesg.ml

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index fc05112..47f3487 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -49,6 +49,13 @@ module Domain = struct
 end
 
 module Host = struct
+	type console_reader
+	exception End_of_file
+
+	external xen_console_read_start : ctx -> int -> console_reader  = "stub_libxl_xen_console_read_start"
+	external xen_console_read_line : ctx -> console_reader -> string = "stub_libxl_xen_console_read_line"
+	external xen_console_read_finish : ctx -> console_reader -> unit = "stub_libxl_xen_console_read_finish"
+
 	external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 end
 
@@ -82,5 +89,6 @@ module Async = struct
 end
 
 let register_exceptions () =
-	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""))
+	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""));
+	Callback.register_exception "Xenlight.Host.End_of_file" (Host.End_of_file)
 
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index ee4efd8..794dbf1 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -51,6 +51,13 @@ module Domain : sig
 end
 
 module Host : sig
+	type console_reader
+	exception End_of_file
+
+	external xen_console_read_start : ctx -> int -> console_reader  = "stub_libxl_xen_console_read_start"
+	external xen_console_read_line : ctx -> console_reader -> string = "stub_libxl_xen_console_read_line"
+	external xen_console_read_finish : ctx -> console_reader -> unit = "stub_libxl_xen_console_read_finish"
+
 	external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 end
 
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 0602286..ab2974a 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -939,6 +939,74 @@ value stub_xl_send_debug_keys(value ctx, value keys)
 	CAMLreturn(Val_unit);
 }
 
+static struct custom_operations libxl_console_reader_custom_operations = {
+	"libxl_console_reader_custom_operations",
+	custom_finalize_default,
+	custom_compare_default,
+	custom_hash_default,
+	custom_serialize_default,
+	custom_deserialize_default
+};
+
+#define Console_reader_val(x)(*((libxl_xen_console_reader **) Data_custom_val(x)))
+
+value stub_libxl_xen_console_read_start(value ctx, value clear)
+{
+	CAMLparam2(ctx, clear);
+	CAMLlocal1(handle);
+	libxl_xen_console_reader *cr;
+
+	cr = libxl_xen_console_read_start(CTX, Int_val(clear));
+
+	handle = caml_alloc_custom(&libxl_console_reader_custom_operations, sizeof(cr), 0, 1);
+	Console_reader_val(handle) = cr;
+
+	CAMLreturn(handle);
+}
+
+static void raise_eof(void)
+{
+	static value *exc = NULL;
+
+	/* First time around, lookup by name */
+	if (!exc)
+		exc = caml_named_value("Xenlight.Host.End_of_file");
+
+	if (!exc)
+		caml_invalid_argument("Exception Xenlight.Host.End_of_file not initialized, please link xenlight.cma");
+
+	caml_raise_constant(*exc);
+}
+
+value stub_libxl_xen_console_read_line(value ctx, value reader)
+{
+	CAMLparam2(ctx, reader);
+	CAMLlocal1(line);
+	int ret;
+	char *c_line;
+	libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader);
+
+	ret = libxl_xen_console_read_line(CTX, cr, &c_line);
+
+	if (ret < 0)
+		failwith_xl(ret, "xen_console_read_line");
+	if (ret == 0)
+		raise_eof();
+
+	line = caml_copy_string(c_line);
+
+	CAMLreturn(line);
+}
+
+value stub_libxl_xen_console_read_finish(value ctx, value reader)
+{
+	CAMLparam2(ctx, reader);
+	libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader);
+
+	libxl_xen_console_read_finish(CTX, cr);
+
+	CAMLreturn(Val_unit);
+}
 
 /* Event handling */
 
diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile
index dfa6437..827bd7c 100644
--- a/tools/ocaml/test/Makefile
+++ b/tools/ocaml/test/Makefile
@@ -9,9 +9,9 @@ OCAMLINCLUDE += \
 	-I $(OCAML_TOPLEVEL)/libs/xentoollog \
 	-I $(OCAML_TOPLEVEL)/libs/xl
 
-OBJS = xtl send_debug_keys list_domains raise_exception
+OBJS = xtl send_debug_keys list_domains raise_exception dmesg
 
-PROGRAMS = xtl send_debug_keys list_domains raise_exception
+PROGRAMS = xtl send_debug_keys list_domains raise_exception dmesg
 
 xtl_LIBS =  \
 	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
@@ -37,7 +37,13 @@ raise_exception_LIBS =  \
 
 raise_exception_OBJS = raise_exception
 
-OCAML_PROGRAM = xtl send_debug_keys list_domains raise_exception
+dmesg_LIBS =  \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
+
+dmesg_OBJS = xtl dmesg
+
+OCAML_PROGRAM = xtl send_debug_keys list_domains raise_exception dmesg
 
 all: $(PROGRAMS)
 
diff --git a/tools/ocaml/test/dmesg.ml b/tools/ocaml/test/dmesg.ml
new file mode 100644
index 0000000..864fac4
--- /dev/null
+++ b/tools/ocaml/test/dmesg.ml
@@ -0,0 +1,18 @@
+open Printf
+
+let _ =
+	Xenlight.register_exceptions ();
+	let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in
+	let ctx = Xenlight.ctx_alloc logger in
+
+	let open Xenlight.Host in
+	let reader = xen_console_read_start ctx 0 in
+	(try
+		while true do
+			let line = xen_console_read_line ctx reader in
+			print_string line
+		done
+	with End_of_file -> ());
+	let _ = xen_console_read_finish ctx reader in
+	()
+
-- 
1.7.10.4

[PATCH v7 8/9] libxl: ocaml: drop the ocaml heap lock before calling into libxl

[Rob Hoes]

Ocaml has a heap lock which must be held whenever ocaml code is running. Ocaml
usually drops this lock when it enters a potentially blocking low-level
function, such as writing to a file. Libxl has its own lock, which it may
acquire when being called.

Things get interesting when libxl calls back into ocaml code. There is a risk
of ending up in a deadlock when a thread holds both locks at the same time,
then temporarily drop the ocaml lock, while another thread calls another libxl
function.

To avoid deadlocks, we drop the ocaml heap lock before entering libxl, and
reacquire it in callbacks to ocaml. This way, the ocaml heap lock is never held
together with the libxl lock, except in osevent registration callbacks, and
xentoollog callbacks. If we guarantee to not call any libxl functions inside
those callbacks, we can avoid deadlocks.

This patch handle the dropping and reacquiring of the ocaml heap lock by the
caml_enter_blocking_section and caml_leave_blocking_section functions, and
related macros. We are also careful to not call any functions that access the
ocaml heap while the ocaml heap lock is dropped. This often involves copying
ocaml values to C before dropping the ocaml lock.

The ao_how in aohow_val is now malloc'ed, just to make this function a little
easier to use.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>
Acked-by: Ian Campbell <ian.campbell@citrix.com>

---
v7: Fix the line where ao_how is malloc'ed.
---
 tools/ocaml/libs/xentoollog/Makefile           |    3 +
 tools/ocaml/libs/xentoollog/xentoollog_stubs.c |   13 +-
 tools/ocaml/libs/xl/Makefile                   |    5 +-
 tools/ocaml/libs/xl/xenlight_stubs.c           |  260 +++++++++++++++++++-----
 4 files changed, 224 insertions(+), 57 deletions(-)

diff --git a/tools/ocaml/libs/xentoollog/Makefile b/tools/ocaml/libs/xentoollog/Makefile
index e535ba5..471b428 100644
--- a/tools/ocaml/libs/xentoollog/Makefile
+++ b/tools/ocaml/libs/xentoollog/Makefile
@@ -2,6 +2,9 @@ TOPLEVEL=$(CURDIR)/../..
 XEN_ROOT=$(TOPLEVEL)/../..
 include $(TOPLEVEL)/common.make
 
+# allow mixed declarations and code
+CFLAGS += -Wno-declaration-after-statement
+
 CFLAGS += $(CFLAGS_libxenctrl) $(CFLAGS_libxenguest)
 OCAMLINCLUDE +=
 
diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
index 122ed0d..aadc3d1 100644
--- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
+++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
@@ -31,6 +31,11 @@
 
 #include "caml_xentoollog.h"
 
+/* The following is equal to the CAMLreturn macro, but without the return */
+#define CAMLdone do{ \
+caml_local_roots = caml__frame; \
+}while (0)
+
 #define XTL ((xentoollog_logger *) Xtl_val(handle))
 
 static char * dup_String_val(value s)
@@ -81,6 +86,7 @@ static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
 	const char *format,
 	va_list al)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocalN(args, 4);
 	struct caml_xtl *xtl = (struct caml_xtl*)logger;
@@ -101,7 +107,8 @@ static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
 	free(msg);
 
 	caml_callbackN(*func, 4, args);
-	CAMLreturn0;
+	CAMLdone;
+	caml_enter_blocking_section();
 }
 
 static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
@@ -109,6 +116,7 @@ static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
 	const char *doing_what /* no \r,\n */,
 	int percent, unsigned long done, unsigned long total)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocalN(args, 5);
 	struct caml_xtl *xtl = (struct caml_xtl*)logger;
@@ -125,7 +133,8 @@ static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
 	args[4] = caml_copy_int64(total);
 
 	caml_callbackN(*func, 5, args);
-	CAMLreturn0;
+	CAMLdone;
+	caml_enter_blocking_section();
 }
 
 static void xtl_destroy(struct xentoollog_logger *logger)
diff --git a/tools/ocaml/libs/xl/Makefile b/tools/ocaml/libs/xl/Makefile
index 0408cc2..61eb44c 100644
--- a/tools/ocaml/libs/xl/Makefile
+++ b/tools/ocaml/libs/xl/Makefile
@@ -2,8 +2,9 @@ TOPLEVEL=$(CURDIR)/../..
 XEN_ROOT=$(TOPLEVEL)/../..
 include $(TOPLEVEL)/common.make
 
-# ignore unused generated functions
-CFLAGS += -Wno-unused
+# ignore unused generated functions and allow mixed declarations and code
+CFLAGS += -Wno-unused -Wno-declaration-after-statement
+
 CFLAGS += $(CFLAGS_libxenlight)
 CFLAGS += -I ../xentoollog
 
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index ab2974a..48a3feb 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -34,6 +34,11 @@
 
 #include "caml_xentoollog.h"
 
+/* The following is equal to the CAMLreturn macro, but without the return */
+#define CAMLdone do{ \
+caml_local_roots = caml__frame; \
+}while (0)
+
 #define Ctx_val(x)(*((libxl_ctx **) Data_custom_val(x)))
 #define CTX ((libxl_ctx *) Ctx_val(ctx))
 
@@ -374,6 +379,7 @@ static char *String_option_val(value v)
 
 void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocal2(error, tmp);
 	static value *func = NULL;
@@ -399,11 +405,15 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 
 	caml_remove_global_root(p);
 	free(p);
+
+	CAMLdone;
+	caml_enter_blocking_section();
 }
 
-static libxl_asyncop_how *aohow_val(value async, libxl_asyncop_how *ao_how)
+static libxl_asyncop_how *aohow_val(value async)
 {
 	CAMLparam1(async);
+	libxl_asyncop_how *ao_how = NULL;
 	value *p;
 
 	if (async != Val_none) {
@@ -418,12 +428,12 @@ static libxl_asyncop_how *aohow_val(value async, libxl_asyncop_how *ao_how)
 			failwith_xl(ERROR_NOMEM, "cannot allocate value");
 		*p = Some_val(async);
 		caml_register_global_root(p);
+		ao_how = malloc(sizeof(*ao_how));
 		ao_how->callback = async_callback;
 		ao_how->u.for_callback = (void *) p;
-		CAMLreturnT(libxl_asyncop_how *, ao_how);
 	}
-	else
-		CAMLreturnT(libxl_asyncop_how *, NULL);
+
+	CAMLreturnT(libxl_asyncop_how *, ao_how);
 }
 
 value stub_libxl_domain_create_new(value ctx, value domain_config, value async, value unit)
@@ -432,7 +442,7 @@ value stub_libxl_domain_create_new(value ctx, value domain_config, value async,
 	int ret;
 	libxl_domain_config c_dconfig;
 	uint32_t c_domid;
-	libxl_asyncop_how ao_how;
+	libxl_asyncop_how *ao_how;
 
 	libxl_domain_config_init(&c_dconfig);
 	ret = domain_config_val(CTX, &c_dconfig, domain_config);
@@ -441,9 +451,13 @@ value stub_libxl_domain_create_new(value ctx, value domain_config, value async,
 		failwith_xl(ret, "domain_create_new");
 	}
 
-	ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid,
-		aohow_val(async, &ao_how), NULL);
+	ao_how = aohow_val(async);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid, ao_how, NULL);
+	caml_leave_blocking_section();
 
+	free(ao_how);
 	libxl_domain_config_dispose(&c_dconfig);
 
 	if (ret != 0)
@@ -460,7 +474,8 @@ value stub_libxl_domain_create_restore(value ctx, value domain_config, value par
 	libxl_domain_config c_dconfig;
 	libxl_domain_restore_params c_params;
 	uint32_t c_domid;
-	libxl_asyncop_how ao_how;
+	libxl_asyncop_how *ao_how;
+	int restore_fd;
 
 	libxl_domain_config_init(&c_dconfig);
 	ret = domain_config_val(CTX, &c_dconfig, domain_config);
@@ -476,9 +491,15 @@ value stub_libxl_domain_create_restore(value ctx, value domain_config, value par
 		failwith_xl(ret, "domain_create_restore");
 	}
 
-	ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, Int_val(Field(params, 0)),
-		&c_params, aohow_val(async, &ao_how), NULL);
+	ao_how = aohow_val(async);
+	restore_fd = Int_val(Field(params, 0));
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, restore_fd,
+		&c_params, ao_how, NULL);
+	caml_leave_blocking_section();
 
+	free(ao_how);
 	libxl_domain_config_dispose(&c_dconfig);
 	libxl_domain_restore_params_dispose(&c_params);
 
@@ -492,8 +513,12 @@ value stub_libxl_domain_shutdown(value ctx, value domid)
 {
 	CAMLparam2(ctx, domid);
 	int ret;
+	uint32_t c_domid = Int_val(domid);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_shutdown(CTX, c_domid);
+	caml_leave_blocking_section();
 
-	ret = libxl_domain_shutdown(CTX, Int_val(domid));
 	if (ret != 0)
 		failwith_xl(ret, "domain_shutdown");
 
@@ -504,8 +529,12 @@ value stub_libxl_domain_reboot(value ctx, value domid)
 {
 	CAMLparam2(ctx, domid);
 	int ret;
+	uint32_t c_domid = Int_val(domid);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_reboot(CTX, c_domid);
+	caml_leave_blocking_section();
 
-	ret = libxl_domain_reboot(CTX, Int_val(domid));
 	if (ret != 0)
 		failwith_xl(ret, "domain_reboot");
 
@@ -516,9 +545,15 @@ value stub_libxl_domain_destroy(value ctx, value domid, value async, value unit)
 {
 	CAMLparam4(ctx, domid, async, unit);
 	int ret;
-	libxl_asyncop_how ao_how;
+	uint32_t c_domid = Int_val(domid);
+	libxl_asyncop_how *ao_how = aohow_val(async);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_destroy(CTX, c_domid, ao_how);
+	caml_leave_blocking_section();
+
+	free(ao_how);
 
-	ret = libxl_domain_destroy(CTX, Int_val(domid), aohow_val(async, &ao_how));
 	if (ret != 0)
 		failwith_xl(ret, "domain_destroy");
 
@@ -529,10 +564,16 @@ value stub_libxl_domain_suspend(value ctx, value domid, value fd, value async, v
 {
 	CAMLparam5(ctx, domid, fd, async, unit);
 	int ret;
-	libxl_asyncop_how ao_how;
+	uint32_t c_domid = Int_val(domid);
+	int c_fd = Int_val(fd);
+	libxl_asyncop_how *ao_how = aohow_val(async);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_suspend(CTX, c_domid, c_fd, 0, ao_how);
+	caml_leave_blocking_section();
+
+	free(ao_how);
 
-	ret = libxl_domain_suspend(CTX, Int_val(domid), Int_val(fd), 0,
-		aohow_val(async, &ao_how));
 	if (ret != 0)
 		failwith_xl(ret, "domain_suspend");
 
@@ -543,8 +584,12 @@ value stub_libxl_domain_pause(value ctx, value domid)
 {
 	CAMLparam2(ctx, domid);
 	int ret;
+	uint32_t c_domid = Int_val(domid);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_pause(CTX, c_domid);
+	caml_leave_blocking_section();
 
-	ret = libxl_domain_pause(CTX, Int_val(domid));
 	if (ret != 0)
 		failwith_xl(ret, "domain_pause");
 
@@ -555,8 +600,12 @@ value stub_libxl_domain_unpause(value ctx, value domid)
 {
 	CAMLparam2(ctx, domid);
 	int ret;
+	uint32_t c_domid = Int_val(domid);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_unpause(CTX, c_domid);
+	caml_leave_blocking_section();
 
-	ret = libxl_domain_unpause(CTX, Int_val(domid));
 	if (ret != 0)
 		failwith_xl(ret, "domain_unpause");
 
@@ -573,13 +622,16 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 	CAMLparam5(ctx, info, domid, async, unit);			\
 	libxl_device_##type c_info;					\
 	int ret, marker_var;						\
-	libxl_asyncop_how ao_how;					\
+	uint32_t c_domid = Int_val(domid);				\
+	libxl_asyncop_how *ao_how = aohow_val(async);			\
 									\
 	device_##type##_val(CTX, &c_info, info);			\
 									\
-	ret = libxl_##fn##_##op(CTX, Int_val(domid), &c_info,		\
-		aohow_val(async, &ao_how));				\
+	caml_enter_blocking_section();					\
+	ret = libxl_##fn##_##op(CTX, c_domid, &c_info, ao_how);		\
+	caml_leave_blocking_section();					\
 									\
+	free(ao_how);							\
 	libxl_device_##type##_dispose(&c_info);				\
 									\
 	if (ret != 0)							\
@@ -605,9 +657,16 @@ value stub_xl_device_nic_of_devid(value ctx, value domid, value devid)
 	CAMLparam3(ctx, domid, devid);
 	CAMLlocal1(nic);
 	libxl_device_nic c_nic;
-	libxl_devid_to_device_nic(CTX, Int_val(domid), Int_val(devid), &c_nic);
+	uint32_t c_domid = Int_val(domid);
+	int c_devid = Int_val(devid);
+
+	caml_enter_blocking_section();
+	libxl_devid_to_device_nic(CTX, c_domid, c_devid, &c_nic);
+	caml_leave_blocking_section();
+
 	nic = Val_device_nic(&c_nic);
 	libxl_device_nic_dispose(&c_nic);
+
 	CAMLreturn(nic);
 }
 
@@ -617,11 +676,12 @@ value stub_xl_device_nic_list(value ctx, value domid)
 	CAMLlocal2(list, temp);
 	libxl_device_nic *c_list;
 	int i, nb;
-	uint32_t c_domid;
-
-	c_domid = Int_val(domid);
+	uint32_t c_domid = Int_val(domid);
 
+	caml_enter_blocking_section();
 	c_list = libxl_device_nic_list(CTX, c_domid, &nb);
+	caml_leave_blocking_section();
+
 	if (!c_list)
 		failwith_xl(ERROR_FAIL, "nic_list");
 
@@ -645,11 +705,12 @@ value stub_xl_device_disk_list(value ctx, value domid)
 	CAMLlocal2(list, temp);
 	libxl_device_disk *c_list;
 	int i, nb;
-	uint32_t c_domid;
-
-	c_domid = Int_val(domid);
+	uint32_t c_domid = Int_val(domid);
 
+	caml_enter_blocking_section();
 	c_list = libxl_device_disk_list(CTX, c_domid, &nb);
+	caml_leave_blocking_section();
+
 	if (!c_list)
 		failwith_xl(ERROR_FAIL, "disk_list");
 
@@ -672,9 +733,19 @@ value stub_xl_device_disk_of_vdev(value ctx, value domid, value vdev)
 	CAMLparam3(ctx, domid, vdev);
 	CAMLlocal1(disk);
 	libxl_device_disk c_disk;
-	libxl_vdev_to_device_disk(CTX, Int_val(domid), String_val(vdev), &c_disk);
+	char *c_vdev;
+	uint32_t c_domid = Int_val(domid);
+
+	c_vdev = strdup(String_val(vdev));
+
+	caml_enter_blocking_section();
+	libxl_vdev_to_device_disk(CTX, c_domid, c_vdev, &c_disk);
+	caml_leave_blocking_section();
+
 	disk = Val_device_disk(&c_disk);
 	libxl_device_disk_dispose(&c_disk);
+	free(c_vdev);
+
 	CAMLreturn(disk);
 }
 
@@ -684,11 +755,12 @@ value stub_xl_device_pci_list(value ctx, value domid)
 	CAMLlocal2(list, temp);
 	libxl_device_pci *c_list;
 	int i, nb;
-	uint32_t c_domid;
-
-	c_domid = Int_val(domid);
+	uint32_t c_domid = Int_val(domid);
 
+	caml_enter_blocking_section();
 	c_list = libxl_device_pci_list(CTX, c_domid, &nb);
+	caml_leave_blocking_section();
+
 	if (!c_list)
 		failwith_xl(ERROR_FAIL, "pci_list");
 
@@ -711,10 +783,13 @@ value stub_xl_device_pci_assignable_add(value ctx, value info, value rebind)
 	CAMLparam3(ctx, info, rebind);
 	libxl_device_pci c_info;
 	int ret, marker_var;
+	int c_rebind = (int) Bool_val(rebind);
 
 	device_pci_val(CTX, &c_info, info);
 
-	ret = libxl_device_pci_assignable_add(CTX, &c_info, (int) Bool_val(rebind));
+	caml_enter_blocking_section();
+	ret = libxl_device_pci_assignable_add(CTX, &c_info, c_rebind);
+	caml_leave_blocking_section();
 
 	libxl_device_pci_dispose(&c_info);
 
@@ -729,10 +804,13 @@ value stub_xl_device_pci_assignable_remove(value ctx, value info, value rebind)
 	CAMLparam3(ctx, info, rebind);
 	libxl_device_pci c_info;
 	int ret, marker_var;
+	int c_rebind = (int) Bool_val(rebind);
 
 	device_pci_val(CTX, &c_info, info);
 
-	ret = libxl_device_pci_assignable_remove(CTX, &c_info, (int) Bool_val(rebind));
+	caml_enter_blocking_section();
+	ret = libxl_device_pci_assignable_remove(CTX, &c_info, c_rebind);
+	caml_leave_blocking_section();
 
 	libxl_device_pci_dispose(&c_info);
 
@@ -750,7 +828,10 @@ value stub_xl_device_pci_assignable_list(value ctx)
 	int i, nb;
 	uint32_t c_domid;
 
+	caml_enter_blocking_section();
 	c_list = libxl_device_pci_assignable_list(CTX, &nb);
+	caml_leave_blocking_section();
+
 	if (!c_list)
 		failwith_xl(ERROR_FAIL, "pci_assignable_list");
 
@@ -775,7 +856,9 @@ value stub_xl_physinfo_get(value ctx)
 	libxl_physinfo c_physinfo;
 	int ret;
 
+	caml_enter_blocking_section();
 	ret = libxl_get_physinfo(CTX, &c_physinfo);
+	caml_leave_blocking_section();
 
 	if (ret != 0)
 		failwith_xl(ret, "get_physinfo");
@@ -794,7 +877,9 @@ value stub_xl_cputopology_get(value ctx)
 	libxl_cputopology *c_topology;
 	int i, nr;
 
+	caml_enter_blocking_section();
 	c_topology = libxl_get_cpu_topology(CTX, &nr);
+	caml_leave_blocking_section();
 
 	if (!c_topology)
 		failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo");
@@ -822,7 +907,10 @@ value stub_xl_dominfo_list(value ctx)
 	libxl_dominfo *c_domlist;
 	int i, nb;
 
+	caml_enter_blocking_section();
 	c_domlist = libxl_list_domain(CTX, &nb);
+	caml_leave_blocking_section();
+
 	if (!c_domlist)
 		failwith_xl(ERROR_FAIL, "dominfo_list");
 
@@ -847,8 +935,12 @@ value stub_xl_dominfo_get(value ctx, value domid)
 	CAMLlocal1(dominfo);
 	libxl_dominfo c_dominfo;
 	int ret;
+	uint32_t c_domid = Int_val(domid);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_info(CTX, &c_dominfo, c_domid);
+	caml_leave_blocking_section();
 
-	ret = libxl_domain_info(CTX, &c_dominfo, Int_val(domid));
 	if (ret != 0)
 		failwith_xl(ERROR_FAIL, "domain_info");
 	dominfo = Val_dominfo(&c_dominfo);
@@ -862,8 +954,12 @@ value stub_xl_domain_sched_params_get(value ctx, value domid)
 	CAMLlocal1(scinfo);
 	libxl_domain_sched_params c_scinfo;
 	int ret;
+	uint32_t c_domid = Int_val(domid);
+
+	caml_enter_blocking_section();
+	ret = libxl_domain_sched_params_get(CTX, c_domid, &c_scinfo);
+	caml_leave_blocking_section();
 
-	ret = libxl_domain_sched_params_get(CTX, Int_val(domid), &c_scinfo);
 	if (ret != 0)
 		failwith_xl(ret, "domain_sched_params_get");
 
@@ -879,10 +975,13 @@ value stub_xl_domain_sched_params_set(value ctx, value domid, value scinfo)
 	CAMLparam3(ctx, domid, scinfo);
 	libxl_domain_sched_params c_scinfo;
 	int ret;
+	uint32_t c_domid = Int_val(domid);
 
 	domain_sched_params_val(CTX, &c_scinfo, scinfo);
 
-	ret = libxl_domain_sched_params_set(CTX, Int_val(domid), &c_scinfo);
+	caml_enter_blocking_section();
+	ret = libxl_domain_sched_params_set(CTX, c_domid, &c_scinfo);
+	caml_leave_blocking_section();
 
 	libxl_domain_sched_params_dispose(&c_scinfo);
 
@@ -896,12 +995,15 @@ value stub_xl_send_trigger(value ctx, value domid, value trigger, value vcpuid)
 {
 	CAMLparam4(ctx, domid, trigger, vcpuid);
 	int ret;
+	uint32_t c_domid = Int_val(domid);
 	libxl_trigger c_trigger = LIBXL_TRIGGER_UNKNOWN;
+	int c_vcpuid = Int_val(vcpuid);
 
 	trigger_val(CTX, &c_trigger, trigger);
 
-	ret = libxl_send_trigger(CTX, Int_val(domid),
-				 c_trigger, Int_val(vcpuid));
+	caml_enter_blocking_section();
+	ret = libxl_send_trigger(CTX, c_domid, c_trigger, c_vcpuid);
+	caml_leave_blocking_section();
 
 	if (ret != 0)
 		failwith_xl(ret, "send_trigger");
@@ -913,8 +1015,12 @@ value stub_xl_send_sysrq(value ctx, value domid, value sysrq)
 {
 	CAMLparam3(ctx, domid, sysrq);
 	int ret;
+	uint32_t c_domid = Int_val(domid);
+	int c_sysrq = Int_val(sysrq);
 
-	ret = libxl_send_sysrq(CTX, Int_val(domid), Int_val(sysrq));
+	caml_enter_blocking_section();
+	ret = libxl_send_sysrq(CTX, c_domid, c_sysrq);
+	caml_leave_blocking_section();
 
 	if (ret != 0)
 		failwith_xl(ret, "send_sysrq");
@@ -930,7 +1036,10 @@ value stub_xl_send_debug_keys(value ctx, value keys)
 
 	c_keys = dup_String_val(keys);
 
+	caml_enter_blocking_section();
 	ret = libxl_send_debug_keys(CTX, c_keys);
+	caml_leave_blocking_section();
+
 	free(c_keys);
 
 	if (ret != 0)
@@ -954,9 +1063,12 @@ value stub_libxl_xen_console_read_start(value ctx, value clear)
 {
 	CAMLparam2(ctx, clear);
 	CAMLlocal1(handle);
+	int c_clear = Int_val(clear);
 	libxl_xen_console_reader *cr;
 
-	cr = libxl_xen_console_read_start(CTX, Int_val(clear));
+	caml_enter_blocking_section();
+	cr = libxl_xen_console_read_start(CTX, c_clear);
+	caml_leave_blocking_section();
 
 	handle = caml_alloc_custom(&libxl_console_reader_custom_operations, sizeof(cr), 0, 1);
 	Console_reader_val(handle) = cr;
@@ -986,7 +1098,9 @@ value stub_libxl_xen_console_read_line(value ctx, value reader)
 	char *c_line;
 	libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader);
 
+	caml_enter_blocking_section();
 	ret = libxl_xen_console_read_line(CTX, cr, &c_line);
+	caml_leave_blocking_section();
 
 	if (ret < 0)
 		failwith_xl(ret, "xen_console_read_line");
@@ -1003,7 +1117,9 @@ value stub_libxl_xen_console_read_finish(value ctx, value reader)
 	CAMLparam2(ctx, reader);
 	libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader);
 
+	caml_enter_blocking_section();
 	libxl_xen_console_read_finish(CTX, cr);
+	caml_leave_blocking_section();
 
 	CAMLreturn(Val_unit);
 }
@@ -1095,6 +1211,7 @@ value Val_poll_events(short events)
 int fd_register(void *user, int fd, void **for_app_registration_out,
                      short events, void *for_libxl)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocalN(args, 4);
 	static value *func = NULL;
@@ -1111,12 +1228,15 @@ int fd_register(void *user, int fd, void **for_app_registration_out,
 	args[3] = (value) for_libxl;
 
 	caml_callbackN(*func, 4, args);
-	CAMLreturn(0);
+	CAMLdone;
+	caml_enter_blocking_section();
+	return 0;
 }
 
 int fd_modify(void *user, int fd, void **for_app_registration_update,
                    short events)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocalN(args, 3);
 	static value *func = NULL;
@@ -1132,11 +1252,14 @@ int fd_modify(void *user, int fd, void **for_app_registration_update,
 	args[2] = Val_poll_events(events);
 
 	caml_callbackN(*func, 3, args);
-	CAMLreturn(0);
+	CAMLdone;
+	caml_enter_blocking_section();
+	return 0;
 }
 
 void fd_deregister(void *user, int fd, void *for_app_registration)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocalN(args, 2);
 	static value *func = NULL;
@@ -1151,12 +1274,14 @@ void fd_deregister(void *user, int fd, void *for_app_registration)
 	args[1] = Val_int(fd);
 
 	caml_callbackN(*func, 2, args);
-	CAMLreturn0;
+	CAMLdone;
+	caml_enter_blocking_section();
 }
 
 int timeout_register(void *user, void **for_app_registration_out,
                           struct timeval abs, void *for_libxl)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocalN(args, 4);
 	static value *func = NULL;
@@ -1173,12 +1298,15 @@ int timeout_register(void *user, void **for_app_registration_out,
 	args[3] = (value) for_libxl;
 
 	caml_callbackN(*func, 4, args);
-	CAMLreturn(0);
+	CAMLdone;
+	caml_enter_blocking_section();
+	return 0;
 }
 
 int timeout_modify(void *user, void **for_app_registration_update,
                          struct timeval abs)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	static value *func = NULL;
 	value *p = (value *) user;
@@ -1189,13 +1317,16 @@ int timeout_modify(void *user, void **for_app_registration_update,
 	}
 
 	caml_callback(*func, *p);
-	CAMLreturn(0);
+	CAMLdone;
+	caml_enter_blocking_section();
+	return 0;
 }
 
 void timeout_deregister(void *user, void *for_app_registration)
 {
+	caml_leave_blocking_section();
 	failwith_xl(ERROR_FAIL, "timeout_deregister not yet implemented");
-	return;
+	caml_enter_blocking_section();
 }
 
 value stub_libxl_osevent_register_hooks(value ctx, value user)
@@ -1221,7 +1352,9 @@ value stub_libxl_osevent_register_hooks(value ctx, value user)
 	*p = user;
 	caml_register_global_root(p);
 
+	caml_enter_blocking_section();
 	libxl_osevent_register_hooks(CTX, hooks, (void *) p);
+	caml_leave_blocking_section();
 
 	result = caml_alloc(1, Abstract_tag);
 	*((libxl_osevent_hooks **) result) = hooks;
@@ -1233,15 +1366,25 @@ value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd,
 	value events, value revents)
 {
 	CAMLparam5(ctx, for_libxl, fd, events, revents);
-	libxl_osevent_occurred_fd(CTX, (void *) for_libxl, Int_val(fd),
-		Poll_events_val(events), Poll_events_val(revents));
+	int c_fd = Int_val(fd);
+	short c_events = Poll_events_val(events);
+	short c_revents = Poll_events_val(revents);
+
+	caml_enter_blocking_section();
+	libxl_osevent_occurred_fd(CTX, (void *) for_libxl, c_fd, c_events, c_revents);
+	caml_leave_blocking_section();
+
 	CAMLreturn(Val_unit);
 }
 
 value stub_libxl_osevent_occurred_timeout(value ctx, value for_libxl)
 {
 	CAMLparam2(ctx, for_libxl);
+
+	caml_enter_blocking_section();
 	libxl_osevent_occurred_timeout(CTX, (void *) for_libxl);
+	caml_leave_blocking_section();
+
 	CAMLreturn(Val_unit);
 }
 
@@ -1252,6 +1395,7 @@ struct user_with_ctx {
 
 void event_occurs(void *user, libxl_event *event)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocalN(args, 2);
 	struct user_with_ctx *c_user = (struct user_with_ctx *) user;
@@ -1267,12 +1411,14 @@ void event_occurs(void *user, libxl_event *event)
 	libxl_event_free(c_user->ctx, event);
 
 	caml_callbackN(*func, 2, args);
-	CAMLreturn0;
+	CAMLdone;
+	caml_enter_blocking_section();
 }
 
 void disaster(void *user, libxl_event_type type,
                      const char *msg, int errnoval)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocalN(args, 4);
 	struct user_with_ctx *c_user = (struct user_with_ctx *) user;
@@ -1289,7 +1435,8 @@ void disaster(void *user, libxl_event_type type,
 	args[3] = Val_int(errnoval);
 
 	caml_callbackN(*func, 4, args);
-	CAMLreturn0;
+	CAMLdone;
+	caml_enter_blocking_section();
 }
 
 value stub_libxl_event_register_callbacks(value ctx, value user)
@@ -1313,7 +1460,10 @@ value stub_libxl_event_register_callbacks(value ctx, value user)
 	hooks->event_occurs = event_occurs;
 	hooks->disaster = disaster;
 
+	caml_enter_blocking_section();
 	libxl_event_register_callbacks(CTX, hooks, (void *) c_user);
+	caml_leave_blocking_section();
+
 	result = caml_alloc(1, Abstract_tag);
 	*((libxl_event_hooks **) result) = hooks;
 
@@ -1323,9 +1473,13 @@ value stub_libxl_event_register_callbacks(value ctx, value user)
 value stub_libxl_evenable_domain_death(value ctx, value domid, value user)
 {
 	CAMLparam3(ctx, domid, user);
+	uint32_t c_domid = Int_val(domid);
+	int c_user = Int_val(user);
 	libxl_evgen_domain_death *evgen_out;
 
-	libxl_evenable_domain_death(CTX, Int_val(domid), Int_val(user), &evgen_out);
+	caml_enter_blocking_section();
+	libxl_evenable_domain_death(CTX, c_domid, c_user, &evgen_out);
+	caml_leave_blocking_section();
 
 	CAMLreturn(Val_unit);
 }
-- 
1.7.10.4

[PATCH v7 9/9] libxl: ocaml: add some missing CAML macros

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>
Acked-by: Ian Campbell <ian.campbell@citrix.com>
---
 tools/ocaml/libs/xl/xenlight_stubs.c |    7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 48a3feb..a923694 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -59,6 +59,7 @@ static value Val_error (libxl_error error_c);
 
 static void failwith_xl(int error, char *fname)
 {
+	CAMLparam0();
 	CAMLlocal1(arg);
 	static value *exc = NULL;
 
@@ -75,6 +76,7 @@ static void failwith_xl(int error, char *fname)
 	Store_field(arg, 1, caml_copy_string(fname));
 
 	caml_raise_with_arg(*exc, arg);
+	CAMLreturn0;
 }
 
 CAMLprim value stub_raise_exception(value unit)
@@ -338,7 +340,7 @@ static libxl_defbool Defbool_val(value v)
 		bool b = Bool_val(Some_val(v));
 		libxl_defbool_set(&db, b);
 	}
-	return db;
+	CAMLreturnT(libxl_defbool, db);
 }
 
 static value Val_hwcap(libxl_hwcap *c_val)
@@ -369,10 +371,11 @@ static value Val_string_option(const char *c_val)
 
 static char *String_option_val(value v)
 {
+	CAMLparam1(v);
 	char *s = NULL;
 	if (v != Val_none)
 		s = dup_String_val(Some_val(v));
-	return s;
+	CAMLreturnT(char *, s);
 }
 
 #include "_libxl_types.inc"
-- 
1.7.10.4

Re: libxl: ocaml: improve the bindings

[Ian Campbell]

On Tue, 2013-12-10 at 16:48 +0000, Rob Hoes wrote:
> This is version 7 of the remaining patches to fix the OCaml bindings to libxl.
> 
> There were only minor changes in patch 3, 6, and 8.

Applied. thanks.

Re: libxl: ocaml: improve the bindings

[Rob Hoes]

On 11 Dec 2013, at 13:37, Ian Campbell <Ian.Campbell@citrix.com> wrote:
> On Tue, 2013-12-10 at 16:48 +0000, Rob Hoes wrote:
>> This is version 7 of the remaining patches to fix the OCaml bindings to libxl.
>> 
>> There were only minor changes in patch 3, 6, and 8.
> 
> Applied. thanks.

Thanks Ian.

I’d really like to thank you, Ian Jackson, and Dave Scott for all the feedback you have given on these patches. The review process led to some important improvements and ensured that some nasty, critical issues were found and fixed early. It is very important to get such a fundamental piece of software absolutely right!

Cheers,
Rob

Re: libxl: ocaml: improve the bindings

[Ian Campbell]

On Wed, 2013-12-11 at 13:57 +0000, Rob Hoes wrote:
> On 11 Dec 2013, at 13:37, Ian Campbell <Ian.Campbell@citrix.com> wrote:
> > On Tue, 2013-12-10 at 16:48 +0000, Rob Hoes wrote:
> >> This is version 7 of the remaining patches to fix the OCaml bindings to libxl.
> >> 
> >> There were only minor changes in patch 3, 6, and 8.
> > 
> > Applied. thanks.
> 
> Thanks Ian.
> 
> I’d really like to thank you, Ian Jackson, and Dave Scott for all the
> feedback you have given on these patches. The review process led to
> some important improvements and ensured that some nasty, critical
> issues were found and fixed early.

No problem! Thanks for doing the actual work!

>  It is very important to get such a fundamental piece of software
> absolutely right!

If it is "absolutely right" then someone owes someone a beer (I'm not
sure who though!) ;-)

Ian.


_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xen.org
http://lists.xen.org/xen-devel

libxl: ocaml: improve the bindings

[Rob Hoes]

The following series of patches fill in most of the gaps in the OCaml bindings
to libxl, to make them useful for clients such as xapi/xenopsd (from
XenServer). There are a number of bugfixes to the existing bindings as well. I
have an experimental version of xenopsd that successfully uses the new
bindings.

This is version 3 of this patch series to fix the OCaml binding to libxl. I
believe I have addressed all the points raised by Ian Jackson's review of
version 2. See the individual patches for detailed changes with respect to v2.

For convenience, the patches in this series may be pulled using:

git pull git://github.com/robhoes/xen.git hydrogen-upstream-v3-rebased

---
Resend note: rebased to current master, to take into account the changed
interface to libxl_domain_create_restore.

Re: libxl: ocaml: improve the bindings

[David Scott]

Hi Rob,

On 21/10/13 14:32, Rob Hoes wrote:
> The following series of patches fill in most of the gaps in the OCaml bindings
> to libxl, to make them useful for clients such as xapi/xenopsd (from
> XenServer). There are a number of bugfixes to the existing bindings as well. I
> have an experimental version of xenopsd that successfully uses the new
> bindings.
>
> This is version 3 of this patch series to fix the OCaml binding to libxl. I
> believe I have addressed all the points raised by Ian Jackson's review of
> version 2. See the individual patches for detailed changes with respect to v2.

I'm happy with all the tools/ocaml patches:

Acked-by: David Scott <dave.scott@eu.citrix.com>

Cheers,
Dave

libxl: ocaml: improve the bindings

[Rob Hoes]

This is version 2 of this patch series to fix the OCaml binding to libxl.

I believe I have addressed all the points raised by Dave Scott and Ian Campbell. Sorry for the delay in getting this new series out!

The main changes are:
* Several fixes to ensure the bindings play well with the OCaml GC. This includes properly using macros such as CAMLparam* and CAMLreturn* for _all_ OCaml values (even intermediate ones), and using "custom" blocks to encapsulate pointers to C code (including handy "finalize" functions for cleanup.
* Fixes in the way KeyedUnions are handled.
* Use the libxl init function to generate default records for libxl types.
* Improve the functions that deal with event handling. We now have some higher-level functions to makes this easier as well as safer, and errors are translated properly.

---------

The following series of patches fill in most of the gaps in the OCaml bindings to libxl, to make them useful for clients such as xapi/xenopsd (from XCP).
There are a number of bugfixes to the existing bindings as well. I have an experimental version of xenopsd that successfully uses the new bindings.

An earlier version of the first half of the series was submitted to the last by Ian Campbell on 20 Nov 2012. With his permission, I have updated most of them to fix some issues (which were discussed on the mailing list at the time). I have left Ian's signed-off-by line on those patches (please let me know if that is not appropriate).

For convenience, the patches in this series may be pulled using:

git pull git://github.com/robhoes/xen.git hydrogen-upstream-v2

Cheers,
Rob

Re: libxl: ocaml: improve the bindings

[Rob Hoes]

Hi,

I'd like to ask for the patches to the libxl OCaml bindings, which I submitted a while ago, to be considered for Xen 4.4.

I have rebased the series onto the current master branch, and there were no conflicts. The rebased version can be pulled using "git pull https://github.com/robhoes/xen.git hydrogen-upstream-v2-rebased".

Thanks,
Rob

> -----Original Message-----
> From: xen-devel-bounces@lists.xen.org [mailto:xen-devel-
> bounces@lists.xen.org] On Behalf Of Rob Hoes
> Sent: 13 June 2013 4:25 PM
> To: xen-devel@lists.xen.org
> Subject: [Xen-devel] libxl: ocaml: improve the bindings
> 
> This is version 2 of this patch series to fix the OCaml binding to libxl.
> 
> I believe I have addressed all the points raised by Dave Scott and Ian
> Campbell. Sorry for the delay in getting this new series out!
> 
> The main changes are:
> * Several fixes to ensure the bindings play well with the OCaml GC. This
> includes properly using macros such as CAMLparam* and CAMLreturn* for
> _all_ OCaml values (even intermediate ones), and using "custom" blocks to
> encapsulate pointers to C code (including handy "finalize" functions for
> cleanup.
> * Fixes in the way KeyedUnions are handled.
> * Use the libxl init function to generate default records for libxl types.
> * Improve the functions that deal with event handling. We now have some
> higher-level functions to makes this easier as well as safer, and errors are
> translated properly.
> 
> ---------
> 
> The following series of patches fill in most of the gaps in the OCaml
> bindings to libxl, to make them useful for clients such as xapi/xenopsd
> (from XCP).
> There are a number of bugfixes to the existing bindings as well. I have an
> experimental version of xenopsd that successfully uses the new bindings.
> 
> An earlier version of the first half of the series was submitted to the last by
> Ian Campbell on 20 Nov 2012. With his permission, I have updated most of
> them to fix some issues (which were discussed on the mailing list at the
> time). I have left Ian's signed-off-by line on those patches (please let me
> know if that is not appropriate).
> 
> For convenience, the patches in this series may be pulled using:
> 
> git pull git://github.com/robhoes/xen.git hydrogen-upstream-v2
> 	
> Cheers,
> Rob
> 
> 
> _______________________________________________
> Xen-devel mailing list
> Xen-devel@lists.xen.org
> http://lists.xen.org/xen-devel

Re: libxl: ocaml: improve the bindings

[Ian Campbell]

On Thu, 2013-08-22 at 11:21 +0100, Rob Hoes wrote:
> Hi,
> 
> I'd like to ask for the patches to the libxl OCaml bindings, which I
> submitted a while ago, to be considered for Xen 4.4.
> 
> I have rebased the series onto the current master branch, and there
> were no conflicts. The rebased version can be pulled using "git pull
> https://github.com/robhoes/xen.git hydrogen-upstream-v2-rebased".

Please can you also repost as patches here.

Ian.