[PATCH v5 00/12] libxl: ocaml: improve the bindings

[PATCH v5 00/12] libxl: ocaml: improve the bindings

[Rob Hoes]

This series contains version 5 of the remaining patches to fix the OCaml
bindings to libxl.

The main changes are a fix for a deadlock issue identified by Ian Jackson
(patches 8-9), and some fixes for issues found by Coverity (patches 10-11).

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

[PATCH v5 01/12] 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 3253675..f51c345 100644
--- a/.gitignore
+++ b/.gitignore
@@ -384,6 +384,7 @@ tools/ocaml/libs/xl/_libxl_types.mli.in
 tools/ocaml/libs/xl/xenlight.ml
 tools/ocaml/libs/xl/xenlight.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 v5 02/12] 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 f51c345..88a8c75 100644
--- a/.gitignore
+++ b/.gitignore
@@ -385,7 +385,8 @@ tools/ocaml/libs/xl/xenlight.ml
 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/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 v5 03/12] 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>

---
v5: Added better commit message.
---
 tools/ocaml/libs/xl/xenlight.ml.in   |   66 +++++++
 tools/ocaml/libs/xl/xenlight.mli.in  |   47 +++++
 tools/ocaml/libs/xl/xenlight_stubs.c |  325 ++++++++++++++++++++++++++++++++++
 3 files changed, 438 insertions(+)

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index a281425..9eba5d7 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -25,10 +25,76 @@ 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 type EVENT_USERS =
+	sig
+		type osevent_user
+		type event_user
+		type async_user
+	end
+
+module Async = functor (S: EVENT_USERS) -> struct
+	type for_libxl
+	type event_hooks
+	type osevent_hooks
+
+	module OseventSet = Set.Make(struct type t = S.osevent_user;; let compare = Pervasives.compare end)
+	module EventSet = Set.Make(struct type t = S.event_user;; let compare = Pervasives.compare end)
+	module AsyncSet = Set.Make(struct type t = S.async_user;; let compare = Pervasives.compare end)
+
+	let osevent_users = ref OseventSet.empty
+	let event_users = ref EventSet.empty
+	let async_users = ref AsyncSet.empty
+	let async_callback_ref = ref None
+
+	external osevent_register_hooks' : ctx -> S.osevent_user -> 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_users := OseventSet.add user !osevent_users;
+		osevent_register_hooks' ctx user
+
+	let async f user =
+		async_users := AsyncSet.add user !async_users;
+		f ?async:(Some user) ()
+
+	let async_callback' result user =
+		async_users := AsyncSet.remove user !async_users;
+		match !async_callback_ref with
+		| None -> ()
+		| Some f -> f ~result ~user
+
+	let async_register_callback ~async_callback =
+		async_callback_ref := Some 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 -> S.event_user -> 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_users := EventSet.add user !event_users;
+		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..28e0eb2 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -27,7 +27,54 @@ 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 type EVENT_USERS =
+	sig
+		type osevent_user
+		type event_user
+		type async_user
+	end
+
+module Async : functor (S: EVENT_USERS) -> sig
+	type for_libxl
+	type event_hooks
+	type osevent_hooks
+
+	val osevent_register_hooks : ctx ->
+		user:S.osevent_user ->
+		fd_register:(S.osevent_user -> Unix.file_descr -> event list -> for_libxl -> unit) ->
+		fd_modify:(S.osevent_user -> Unix.file_descr -> event list -> unit) ->
+		fd_deregister:(S.osevent_user -> Unix.file_descr -> unit) ->
+		timeout_register:(S.osevent_user -> int -> int -> for_libxl -> unit) ->
+		timeout_modify:(S.osevent_user -> 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 : (?async:S.async_user -> unit -> 'a) -> S.async_user -> 'a
+
+	val async_register_callback :
+		async_callback:(result:error option -> user:S.async_user -> unit) ->
+		unit
+
+	external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death"
+
+	val event_register_callbacks : ctx ->
+		user:S.event_user ->
+		event_occurs_callback:(S.event_user -> Event.t -> unit) ->
+		event_disaster_callback:(S.event_user -> 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 80a5986..598a1ac 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,26 @@ static char *String_option_val(value v)
 
 #include "_libxl_types.inc"
 
+void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
+{
+	CAMLparam0();
+	CAMLlocal1(error);
+	int *task = (int *) for_callback;
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_async_callback");
+	}
+
+	if (rc == 0)
+		error = Val_none;
+	else
+		error = Val_some(Val_error(rc));
+
+	caml_callback2(*func, error, (value) for_callback);
+}
+
 #define _STRINGIFY(x) #x
 #define STRINGIFY(x) _STRINGIFY(x)
 
@@ -703,6 +725,309 @@ 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;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_register");
+	}
+
+	args[0] = (value) user;
+	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;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_modify");
+	}
+
+	args[0] = (value) user;
+	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;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_deregister");
+	}
+
+	args[0] = (value) user;
+	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;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_timeout_register");
+	}
+
+	args[0] = (value) user;
+	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;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_timeout_modify");
+	}
+
+	caml_callback(*func, (value) user);
+	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;
+
+	hooks = malloc(sizeof(*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;
+
+	libxl_osevent_register_hooks(CTX, hooks, (void *) user);
+	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;
+	void *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] = (value) 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] = (value) 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));
+	c_user->user = (void *) user;
+	c_user->ctx = CTX;
+
+	hooks = malloc(sizeof(*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

[PATCH v5 04/12] libxl: ocaml: allow device operations to be called asynchronously

[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       |    6 +++---
 tools/ocaml/libs/xl/xenlight_stubs.c |   14 +++++++++++---
 2 files changed, 14 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 598a1ac..23f0836 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -396,15 +396,23 @@ 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;					\
 									\
 	device_##type##_val(CTX, &c_info, info);			\
 									\
-	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info, 0); \
+	if (async != Val_none) {					\
+		ao_how.callback = async_callback;			\
+		ao_how.u.for_callback = (void *) Some_val(async);	\
+	}								\
+									\
+	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 v5 05/12] 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 23f0836..59ab54f 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -395,7 +395,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)					\
 {									\
@@ -411,7 +411,7 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 		ao_how.u.for_callback = (void *) Some_val(async);	\
 	}								\
 									\
-	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);				\
@@ -423,15 +423,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)
 {
@@ -472,6 +473,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 v5 06/12] libxl: ocaml: add VM lifecycle operations

[Rob Hoes]

Also, reorganise toplevel OCaml functions into modules of Xenlight.

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   |   21 ++++-
 tools/ocaml/libs/xl/xenlight.mli.in  |   21 ++++-
 tools/ocaml/libs/xl/xenlight_stubs.c |  157 ++++++++++++++++++++++++++++++++--
 tools/ocaml/test/send_debug_keys.ml  |    2 +-
 4 files changed, 188 insertions(+), 13 deletions(-)

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index 9eba5d7..f04e75f 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 type EVENT_USERS =
 	sig
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index 28e0eb2..2fadaf7 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 type EVENT_USERS =
 	sig
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 59ab54f..1212cfb 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -392,6 +392,156 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 	caml_callback2(*func, error, (value) for_callback);
 }
 
+static libxl_asyncop_how *aohow_val(value async, libxl_asyncop_how *ao_how)
+{
+	CAMLparam1(async);
+
+	if (async != Val_none) {
+		ao_how->callback = async_callback;
+		ao_how->u.for_callback = (void *) Some_val(async);
+		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)
 
@@ -406,13 +556,8 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 									\
 	device_##type##_val(CTX, &c_info, info);			\
 									\
-	if (async != Val_none) {					\
-		ao_how.callback = async_callback;			\
-		ao_how.u.for_callback = (void *) Some_val(async);	\
-	}								\
-									\
 	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 v5 07/12] 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 f04e75f..dcd30df 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
 
@@ -111,5 +118,6 @@ module Async = functor (S: EVENT_USERS) -> 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 2fadaf7..8f93651 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 1212cfb..88cca20 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -918,6 +918,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 v5 08/12] 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.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
CC: Ian Campbell <ian.campbell@citrix.com>
CC: Ian Jackson <ian.jackson@eu.citrix.com>
CC: Dave Scott <dave.scott@eu.citrix.com>
---
 tools/ocaml/libs/xentoollog/Makefile           |    3 +
 tools/ocaml/libs/xentoollog/xentoollog_stubs.c |   12 +-
 tools/ocaml/libs/xl/Makefile                   |    5 +-
 tools/ocaml/libs/xl/xenlight_stubs.c           |  255 +++++++++++++++++++-----
 4 files changed, 221 insertions(+), 54 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 3b2f91b..87ea53e 100644
--- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
+++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
@@ -31,6 +31,10 @@
 
 #include "caml_xentoollog.h"
 
+#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 +85,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;
@@ -103,7 +108,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,
@@ -111,6 +117,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;
@@ -129,7 +136,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 88cca20..01ba3fe 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -34,6 +34,10 @@
 
 #include "caml_xentoollog.h"
 
+#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 +378,7 @@ static char *String_option_val(value v)
 
 void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 {
+	caml_leave_blocking_section();
 	CAMLparam0();
 	CAMLlocal1(error);
 	int *task = (int *) for_callback;
@@ -390,19 +395,22 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 		error = Val_some(Val_error(rc));
 
 	caml_callback2(*func, error, (value) for_callback);
+	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;
 
 	if (async != Val_none) {
+		libxl_asyncop_how *ao_how = malloc(sizeof(*ao_how));
 		ao_how->callback = async_callback;
 		ao_how->u.for_callback = (void *) Some_val(async);
-		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)
@@ -411,7 +419,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);
@@ -420,9 +428,14 @@ 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();
+
+	if (ao_how)
+		free(ao_how);
 	libxl_domain_config_dispose(&c_dconfig);
 
 	if (ret != 0)
@@ -439,7 +452,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);
@@ -455,9 +469,16 @@ 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();
 
+	if (ao_how)
+		free(ao_how);
 	libxl_domain_config_dispose(&c_dconfig);
 	libxl_domain_restore_params_dispose(&c_params);
 
@@ -471,8 +492,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");
 
@@ -483,8 +508,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");
 
@@ -495,9 +524,16 @@ 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();
+
+	if (ao_how)
+		free(ao_how);
 
-	ret = libxl_domain_destroy(CTX, Int_val(domid), aohow_val(async, &ao_how));
 	if (ret != 0)
 		failwith_xl(ret, "domain_destroy");
 
@@ -508,10 +544,17 @@ 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();
+
+	if (ao_how)
+		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");
 
@@ -522,8 +565,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");
 
@@ -534,8 +581,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");
 
@@ -552,13 +603,17 @@ 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();					\
 									\
+	if (ao_how)							\
+		free(ao_how);						\
 	libxl_device_##type##_dispose(&c_info);				\
 									\
 	if (ret != 0)							\
@@ -584,9 +639,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);
 }
 
@@ -596,11 +658,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");
 
@@ -624,11 +687,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");
 
@@ -651,9 +715,20 @@ 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 = malloc((caml_string_length(vdev) + 1) * sizeof(char *));
+	strcpy(c_vdev, 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);
 }
 
@@ -663,11 +738,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");
 
@@ -690,10 +766,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);
 
@@ -708,10 +787,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);
 
@@ -729,7 +811,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");
 
@@ -754,7 +839,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");
@@ -773,7 +860,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");
@@ -801,7 +890,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");
 
@@ -826,8 +918,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);
@@ -841,8 +937,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");
 
@@ -858,10 +958,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);
 
@@ -875,12 +978,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");
@@ -892,8 +998,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");
@@ -909,7 +1019,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)
@@ -933,9 +1046,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;
@@ -965,7 +1081,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");
@@ -982,7 +1100,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);
 }
@@ -1074,6 +1194,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;
@@ -1089,12 +1210,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;
@@ -1109,11 +1233,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;
@@ -1127,12 +1254,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;
@@ -1148,12 +1277,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;
 
@@ -1163,13 +1295,16 @@ int timeout_modify(void *user, void **for_app_registration_update,
 	}
 
 	caml_callback(*func, (value) user);
-	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)
@@ -1186,7 +1321,10 @@ value stub_libxl_osevent_register_hooks(value ctx, value user)
 	hooks->timeout_modify = timeout_modify;
 	hooks->timeout_deregister = timeout_deregister;
 
+	caml_enter_blocking_section();
 	libxl_osevent_register_hooks(CTX, hooks, (void *) user);
+	caml_leave_blocking_section();
+
 	result = caml_alloc(1, Abstract_tag);
 	*((libxl_osevent_hooks **) result) = hooks;
 
@@ -1197,15 +1335,23 @@ value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd,
 	value events, value revents)
 {
 	CAMLparam5(ctx, for_libxl, fd, events, revents);
+
+	caml_enter_blocking_section();
 	libxl_osevent_occurred_fd(CTX, (void *) for_libxl, Int_val(fd),
 		Poll_events_val(events), Poll_events_val(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);
 }
 
@@ -1216,6 +1362,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;
@@ -1231,12 +1378,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;
@@ -1253,7 +1402,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)
@@ -1272,7 +1422,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;
 
@@ -1284,7 +1437,9 @@ value stub_libxl_evenable_domain_death(value ctx, value domid, value user)
 	CAMLparam3(ctx, domid, user);
 	libxl_evgen_domain_death *evgen_out;
 
+	caml_enter_blocking_section();
 	libxl_evenable_domain_death(CTX, Int_val(domid), Int_val(user), &evgen_out);
+	caml_leave_blocking_section();
 
 	CAMLreturn(Val_unit);
 }
-- 
1.7.10.4

[PATCH v5 09/12] libxl: ocaml: add some missing CAML macros

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
CC: Ian Campbell <ian.campbell@citrix.com>
CC: Ian Jackson <ian.jackson@eu.citrix.com>
CC: Dave Scott <dave.scott@eu.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 01ba3fe..7012045 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -58,6 +58,7 @@ static value Val_error (libxl_error error_c);
 
 static void failwith_xl(int error, char *fname)
 {
+	CAMLparam0();
 	CAMLlocal1(arg);
 	static value *exc = NULL;
 
@@ -74,6 +75,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)
@@ -337,7 +339,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)
@@ -368,10 +370,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

[PATCH v5 10/12] libxl: ocaml: fix memory corruption when converting string and key/values lists

[Rob Hoes]

Found by Coverty. CIDs: 1128562 1128563 1128564 1128565.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/xenlight_stubs.c |    6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 7012045..a2d47f9 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -159,8 +159,8 @@ static value Val_key_value_list(libxl_key_value_list *c_val)
 
 	list = Val_emptylist;
 	for (i = libxl_string_list_length((libxl_string_list *) c_val) - 1; i >= 0; i -= 2) {
-		val = caml_copy_string((char *) c_val[i]);
-		key = caml_copy_string((char *) c_val[i - 1]);
+		val = caml_copy_string((*c_val)[i]);
+		key = caml_copy_string((*c_val)[i - 1]);
 		kv = caml_alloc_tuple(2);
 		Store_field(kv, 0, key);
 		Store_field(kv, 1, val);
@@ -201,7 +201,7 @@ static value Val_string_list(libxl_string_list *c_val)
 
 	list = Val_emptylist;
 	for (i = libxl_string_list_length(c_val) - 1; i >= 0; i--) {
-		string = caml_copy_string((char *) c_val[i]);
+		string = caml_copy_string((*c_val)[i]);
 		cons = caml_alloc(2, 0);
 		Store_field(cons, 0, string);   // head
 		Store_field(cons, 1, list);     // tail
-- 
1.7.10.4

[PATCH v5 11/12] libxl: ocaml: remove dead code in xentoollog bindings

[Rob Hoes]

Found by Coverty. CIDs: 1128567 1128568 1128576 1128577.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xentoollog/xentoollog_stubs.c |    4 ----
 1 file changed, 4 deletions(-)

diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
index 87ea53e..46f7f87 100644
--- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
+++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
@@ -92,8 +92,6 @@ static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
 	value *func = caml_named_value(xtl->vmessage_cb) ;
 	char *msg;
 
-	if (args == NULL)
-		caml_raise_out_of_memory();
 	if (func == NULL)
 		caml_raise_sys_error(caml_copy_string("Unable to find callback"));
 	if (vasprintf(&msg, format, al) < 0)
@@ -123,8 +121,6 @@ static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
 	struct caml_xtl *xtl = (struct caml_xtl*)logger;
 	value *func = caml_named_value(xtl->progress_cb) ;
 
-	if (args == NULL)
-		caml_raise_out_of_memory();
 	if (func == NULL)
 		caml_raise_sys_error(caml_copy_string("Unable to find callback"));
 
-- 
1.7.10.4

[PATCH v5 12/12] libxl: ocaml: git/hgignore generated files

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 .gitignore |    5 +++++
 .hgignore  |    5 +++++
 2 files changed, 10 insertions(+)

diff --git a/.gitignore b/.gitignore
index 88a8c75..a676f00 100644
--- a/.gitignore
+++ b/.gitignore
@@ -383,6 +383,11 @@ tools/ocaml/libs/xl/_libxl_types.ml.in
 tools/ocaml/libs/xl/_libxl_types.mli.in
 tools/ocaml/libs/xl/xenlight.ml
 tools/ocaml/libs/xl/xenlight.mli
+tools/ocaml/libs/xentoollog/_xtl_levels.inc
+tools/ocaml/libs/xentoollog/_xtl_levels.ml.in
+tools/ocaml/libs/xentoollog/_xtl_levels.mli.in
+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
diff --git a/.hgignore b/.hgignore
index ee5c084..0523148 100644
--- a/.hgignore
+++ b/.hgignore
@@ -307,6 +307,11 @@
 ^tools/ocaml/libs/xl/_libxl_types\.inc$
 ^tools/ocaml/libs/xl/xenlight\.ml$
 ^tools/ocaml/libs/xl/xenlight\.mli$
+^tools/ocaml/libs/xentoollog/_xtl_levels.inc$
+^tools/ocaml/libs/xentoollog/_xtl_levels.ml.in$
+^tools/ocaml/libs/xentoollog/_xtl_levels.mli.in$
+^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$
-- 
1.7.10.4

Re: [PATCH v5 10/12] libxl: ocaml: fix memory corruption when converting string and key/values lists

[Andrew Cooper]

On 26/11/13 17:52, Rob Hoes wrote:
> Found by Coverty. CIDs: 1128562 1128563 1128564 1128565.
>
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

It is worth further stating that this is due to incorrect indirections,
just like b0be2b126ea75a83a3778b4e1710d248f92cf528

Reviewed-by: Andrew Cooper <andrew.cooper3@citrix.com>

FWIW, the libxl_string_list tyepdef makes it far too easy to do this. 
It might be worth trying to turn it into an opaque type to reduce these
kinds of errors.

> ---
>  tools/ocaml/libs/xl/xenlight_stubs.c |    6 +++---
>  1 file changed, 3 insertions(+), 3 deletions(-)
>
> diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
> index 7012045..a2d47f9 100644
> --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> @@ -159,8 +159,8 @@ static value Val_key_value_list(libxl_key_value_list *c_val)
>  
>  	list = Val_emptylist;
>  	for (i = libxl_string_list_length((libxl_string_list *) c_val) - 1; i >= 0; i -= 2) {
> -		val = caml_copy_string((char *) c_val[i]);
> -		key = caml_copy_string((char *) c_val[i - 1]);
> +		val = caml_copy_string((*c_val)[i]);
> +		key = caml_copy_string((*c_val)[i - 1]);
>  		kv = caml_alloc_tuple(2);
>  		Store_field(kv, 0, key);
>  		Store_field(kv, 1, val);
> @@ -201,7 +201,7 @@ static value Val_string_list(libxl_string_list *c_val)
>  
>  	list = Val_emptylist;
>  	for (i = libxl_string_list_length(c_val) - 1; i >= 0; i--) {
> -		string = caml_copy_string((char *) c_val[i]);
> +		string = caml_copy_string((*c_val)[i]);
>  		cons = caml_alloc(2, 0);
>  		Store_field(cons, 0, string);   // head
>  		Store_field(cons, 1, list);     // tail

Re: [PATCH v5 11/12] libxl: ocaml: remove dead code in xentoollog bindings

[Andrew Cooper]

On 26/11/13 17:52, Rob Hoes wrote:
> Found by Coverty. CIDs: 1128567 1128568 1128576 1128577.
>
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

Reviewed-by: Andrew Cooper <andrew.cooper3@citrix.com>

> ---
>  tools/ocaml/libs/xentoollog/xentoollog_stubs.c |    4 ----
>  1 file changed, 4 deletions(-)
>
> diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
> index 87ea53e..46f7f87 100644
> --- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
> +++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
> @@ -92,8 +92,6 @@ static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
>  	value *func = caml_named_value(xtl->vmessage_cb) ;
>  	char *msg;
>  
> -	if (args == NULL)
> -		caml_raise_out_of_memory();
>  	if (func == NULL)
>  		caml_raise_sys_error(caml_copy_string("Unable to find callback"));
>  	if (vasprintf(&msg, format, al) < 0)
> @@ -123,8 +121,6 @@ static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
>  	struct caml_xtl *xtl = (struct caml_xtl*)logger;
>  	value *func = caml_named_value(xtl->progress_cb) ;
>  
> -	if (args == NULL)
> -		caml_raise_out_of_memory();
>  	if (func == NULL)
>  		caml_raise_sys_error(caml_copy_string("Unable to find callback"));
>  

Re: [PATCH v5 08/12] libxl: ocaml: drop the ocaml heap lock before calling into libxl

[David Scott]

On 26/11/13 17:52, Rob Hoes wrote:
> 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.

I think the approach sounds good. One or two questions inline: (I think 
only the last comment about Poll_events_val is significant)


>
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> CC: Ian Campbell <ian.campbell@citrix.com>
> CC: Ian Jackson <ian.jackson@eu.citrix.com>
> CC: Dave Scott <dave.scott@eu.citrix.com>
> ---
>   tools/ocaml/libs/xentoollog/Makefile           |    3 +
>   tools/ocaml/libs/xentoollog/xentoollog_stubs.c |   12 +-
>   tools/ocaml/libs/xl/Makefile                   |    5 +-
>   tools/ocaml/libs/xl/xenlight_stubs.c           |  255 +++++++++++++++++++-----
>   4 files changed, 221 insertions(+), 54 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 3b2f91b..87ea53e 100644
> --- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
> +++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
> @@ -31,6 +31,10 @@
>
>   #include "caml_xentoollog.h"
>
> +#define CAMLdone do{ \
> +caml_local_roots = caml__frame; \
> +}while (0)

Might be worth a comment explaining that this is intended to be 
"CAMLreturn" without the return.

> +
>   #define XTL ((xentoollog_logger *) Xtl_val(handle))
>
>   static char * dup_String_val(value s)
> @@ -81,6 +85,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;
> @@ -103,7 +108,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,
> @@ -111,6 +117,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;
> @@ -129,7 +136,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 88cca20..01ba3fe 100644
> --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> @@ -34,6 +34,10 @@
>
>   #include "caml_xentoollog.h"
>
> +#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 +378,7 @@ static char *String_option_val(value v)
>
>   void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
>   {
> +	caml_leave_blocking_section();
>   	CAMLparam0();
>   	CAMLlocal1(error);
>   	int *task = (int *) for_callback;
> @@ -390,19 +395,22 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
>   		error = Val_some(Val_error(rc));
>
>   	caml_callback2(*func, error, (value) for_callback);
> +	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;
>
>   	if (async != Val_none) {
> +		libxl_asyncop_how *ao_how = malloc(sizeof(*ao_how));
>   		ao_how->callback = async_callback;
>   		ao_how->u.for_callback = (void *) Some_val(async);
> -		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)
> @@ -411,7 +419,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);
> @@ -420,9 +428,14 @@ 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();
> +
> +	if (ao_how)
> +		free(ao_how);
>   	libxl_domain_config_dispose(&c_dconfig);
>
>   	if (ret != 0)
> @@ -439,7 +452,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);
> @@ -455,9 +469,16 @@ 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();
>
> +	if (ao_how)
> +		free(ao_how);
>   	libxl_domain_config_dispose(&c_dconfig);
>   	libxl_domain_restore_params_dispose(&c_params);
>
> @@ -471,8 +492,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");
>
> @@ -483,8 +508,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");
>
> @@ -495,9 +524,16 @@ 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();
> +
> +	if (ao_how)
> +		free(ao_how);
>
> -	ret = libxl_domain_destroy(CTX, Int_val(domid), aohow_val(async, &ao_how));
>   	if (ret != 0)
>   		failwith_xl(ret, "domain_destroy");
>
> @@ -508,10 +544,17 @@ 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();
> +
> +	if (ao_how)
> +		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");
>
> @@ -522,8 +565,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");
>
> @@ -534,8 +581,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");
>
> @@ -552,13 +603,17 @@ 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();					\
>   									\
> +	if (ao_how)							\
> +		free(ao_how);						\
>   	libxl_device_##type##_dispose(&c_info);				\
>   									\
>   	if (ret != 0)							\
> @@ -584,9 +639,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);
>   }
>
> @@ -596,11 +658,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");
>
> @@ -624,11 +687,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");
>
> @@ -651,9 +715,20 @@ 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 = malloc((caml_string_length(vdev) + 1) * sizeof(char *));
> +	strcpy(c_vdev, String_val(vdev));

Perhaps this would be clearer as 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);
>   }
>
> @@ -663,11 +738,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");
>
> @@ -690,10 +766,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);
>
> @@ -708,10 +787,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);
>
> @@ -729,7 +811,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");
>
> @@ -754,7 +839,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");
> @@ -773,7 +860,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");
> @@ -801,7 +890,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");
>
> @@ -826,8 +918,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);
> @@ -841,8 +937,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");
>
> @@ -858,10 +958,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);
>
> @@ -875,12 +978,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");
> @@ -892,8 +998,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");
> @@ -909,7 +1019,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)
> @@ -933,9 +1046,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;
> @@ -965,7 +1081,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");
> @@ -982,7 +1100,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);
>   }
> @@ -1074,6 +1194,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;
> @@ -1089,12 +1210,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;
> @@ -1109,11 +1233,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;
> @@ -1127,12 +1254,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;
> @@ -1148,12 +1277,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;
>
> @@ -1163,13 +1295,16 @@ int timeout_modify(void *user, void **for_app_registration_update,
>   	}
>
>   	caml_callback(*func, (value) user);
> -	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)
> @@ -1186,7 +1321,10 @@ value stub_libxl_osevent_register_hooks(value ctx, value user)
>   	hooks->timeout_modify = timeout_modify;
>   	hooks->timeout_deregister = timeout_deregister;
>
> +	caml_enter_blocking_section();
>   	libxl_osevent_register_hooks(CTX, hooks, (void *) user);
> +	caml_leave_blocking_section();
> +
>   	result = caml_alloc(1, Abstract_tag);
>   	*((libxl_osevent_hooks **) result) = hooks;
>
> @@ -1197,15 +1335,23 @@ value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd,
>   	value events, value revents)
>   {
>   	CAMLparam5(ctx, for_libxl, fd, events, revents);
> +
> +	caml_enter_blocking_section();
>   	libxl_osevent_occurred_fd(CTX, (void *) for_libxl, Int_val(fd),
>   		Poll_events_val(events), Poll_events_val(revents));

Is the "events" OCaml value being accessed here without the heap lock?

> +	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);
>   }
>
> @@ -1216,6 +1362,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;
> @@ -1231,12 +1378,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;
> @@ -1253,7 +1402,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)
> @@ -1272,7 +1422,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;
>
> @@ -1284,7 +1437,9 @@ value stub_libxl_evenable_domain_death(value ctx, value domid, value user)
>   	CAMLparam3(ctx, domid, user);
>   	libxl_evgen_domain_death *evgen_out;
>
> +	caml_enter_blocking_section();
>   	libxl_evenable_domain_death(CTX, Int_val(domid), Int_val(user), &evgen_out);
> +	caml_leave_blocking_section();
>
>   	CAMLreturn(Val_unit);
>   }
>

Re: [PATCH v5 09/12] libxl: ocaml: add some missing CAML macros

[David Scott]

This one (and the later patches in the series the series: ie 10 - 12 
inclusive) looks fine to me

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


On 26/11/13 17:52, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> CC: Ian Campbell <ian.campbell@citrix.com>
> CC: Ian Jackson <ian.jackson@eu.citrix.com>
> CC: Dave Scott <dave.scott@eu.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 01ba3fe..7012045 100644
> --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> @@ -58,6 +58,7 @@ static value Val_error (libxl_error error_c);
>
>   static void failwith_xl(int error, char *fname)
>   {
> +	CAMLparam0();
>   	CAMLlocal1(arg);
>   	static value *exc = NULL;
>
> @@ -74,6 +75,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)
> @@ -337,7 +339,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)
> @@ -368,10 +370,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"
>

Re: [PATCH v5 08/12] libxl: ocaml: drop the ocaml heap lock before calling into libxl

[Rob Hoes]

On 26 Nov 2013, at 18:27, David Scott <dave.scott@eu.citrix.com> wrote:
> On 26/11/13 17:52, Rob Hoes wrote:
>> 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.
> 
> I think the approach sounds good. One or two questions inline: (I think 
> only the last comment about Poll_events_val is significant)
> 
>> [...]
>>  #include "caml_xentoollog.h"
>> 
>> +#define CAMLdone do{ \
>> +caml_local_roots = caml__frame; \
>> +}while (0)
> 
> Might be worth a comment explaining that this is intended to be 
> "CAMLreturn" without the return.

Ok, I’ll add that.

>> […]
>> @@ -651,9 +715,20 @@ 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 = malloc((caml_string_length(vdev) + 1) * sizeof(char *));
>> +	strcpy(c_vdev, String_val(vdev));
> 
> Perhaps this would be clearer as strdup(String_val(vdev))?

I guess so! I just copied the example from the OCaml manual, but strdup looks easier indeed.

>> […]
>> @@ -1197,15 +1335,23 @@ value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd,
>>  	value events, value revents)
>>  {
>>  	CAMLparam5(ctx, for_libxl, fd, events, revents);
>> +
>> +	caml_enter_blocking_section();
>>  	libxl_osevent_occurred_fd(CTX, (void *) for_libxl, Int_val(fd),
>>  		Poll_events_val(events), Poll_events_val(revents));
> 
> Is the "events" OCaml value being accessed here without the heap lock?

Yep, I missed that one!

I’ll send an updated patch in a minute…

Cheers,
Rob

Re: [PATCH v5 00/12] libxl: ocaml: improve the bindings

[Ian Campbell]

On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
> This series contains version 5 of the remaining patches to fix the OCaml
> bindings to libxl.

Since we are now into the freeze period we (really, you ;-) need to make
an argument to the release manager (George) for why this should go in
now. His guidance is in
http://article.gmane.org/gmane.comp.emulators.xen.devel/180209.

The benefit of this series is that it allows for ocaml based xen
toolstacks (specifically xapi) to start making the transition to using
libxl. It would be awesome if 4.4 provided a decent baseline for that.

The risk is that we break the bindings for some existing users, but I am
99.9% certain there can be none of those. Effectively Rob is the only
user today. The bindings in 4.3 were not really usable, at least not in
anger.

Overall I think the benefits outweigh the risks.

(sorry if we made this argument on a previous posting, I don't see it in
my QUEUE if so)

Ian.

> The main changes are a fix for a deadlock issue identified by Ian Jackson
> (patches 8-9), and some fixes for issues found by Coverity (patches 10-11).
> 
> For convenience, the patches in this series may be pulled using:
> git pull git://github.com/robhoes/xen.git hydrogen-upstream-v5
> 

Re: [PATCH v5 00/12] libxl: ocaml: improve the bindings

[Rob Hoes]

Ian Campbell wrote:
> On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
> > This series contains version 5 of the remaining patches to fix the
> > OCaml bindings to libxl.
> 
> Since we are now into the freeze period we (really, you ;-) need to make
> an argument to the release manager (George) for why this should go in now.
> His guidance is in
> http://article.gmane.org/gmane.comp.emulators.xen.devel/180209.
> 
> The benefit of this series is that it allows for ocaml based xen
> toolstacks (specifically xapi) to start making the transition to using
> libxl. It would be awesome if 4.4 provided a decent baseline for that.

I would indeed be great if we can start using libxl from Xen 4.4 out of the box!

> The risk is that we break the bindings for some existing users, but I am
> 99.9% certain there can be none of those. Effectively Rob is the only user
> today. The bindings in 4.3 were not really usable, at least not in anger.

I don't think anyone would have been really able to use the bindings as they were, because they were incomplete and caused memory corruption. In a way, you could consider the whole series to be one large bug fix :)

About 80% of my original series has already been merged. This contained really just the ground work. This version adds some essential bindings to VM lifecycle operations, the event system, and some bug fixes. These patches only affect files in tools/ocaml (plus .git/.hgignore).

Rob

> Overall I think the benefits outweigh the risks.
> 
> (sorry if we made this argument on a previous posting, I don't see it in
> my QUEUE if so)
> 
> Ian.
> 
> > The main changes are a fix for a deadlock issue identified by Ian
> > Jackson (patches 8-9), and some fixes for issues found by Coverity
> (patches 10-11).
> >
> > For convenience, the patches in this series may be pulled using:
> > git pull git://github.com/robhoes/xen.git hydrogen-upstream-v5
> >
> 

Re: [PATCH v5 09/12] libxl: ocaml: add some missing CAML macros

[Ian Campbell]

On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> CC: Ian Campbell <ian.campbell@citrix.com>
> CC: Ian Jackson <ian.jackson@eu.citrix.com>
> CC: Dave Scott <dave.scott@eu.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 01ba3fe..7012045 100644
> --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> @@ -58,6 +58,7 @@ static value Val_error (libxl_error error_c);
>  
>  static void failwith_xl(int error, char *fname)
>  {
> +	CAMLparam0();
>  	CAMLlocal1(arg);
>  	static value *exc = NULL;
>  
> @@ -74,6 +75,7 @@ static void failwith_xl(int error, char *fname)
>  	Store_field(arg, 1, caml_copy_string(fname));
>  
>  	caml_raise_with_arg(*exc, arg);
> +	CAMLreturn0;


raise_with_arg has Noreturn, although this is probably harmless enough
and might keep some stupider compilers happy.

>  }
>  
>  CAMLprim value stub_raise_exception(value unit)
> @@ -337,7 +339,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)
> @@ -368,10 +370,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"

Re: [PATCH v5 09/12] libxl: ocaml: add some missing CAML macros

[Ian Campbell]

On Wed, 2013-11-27 at 11:47 +0000, Ian Campbell wrote:
> On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
> > Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> > CC: Ian Campbell <ian.campbell@citrix.com>
> > CC: Ian Jackson <ian.jackson@eu.citrix.com>
> > CC: Dave Scott <dave.scott@eu.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 01ba3fe..7012045 100644
> > --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> > +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> > @@ -58,6 +58,7 @@ static value Val_error (libxl_error error_c);
> >  
> >  static void failwith_xl(int error, char *fname)
> >  {
> > +	CAMLparam0();
> >  	CAMLlocal1(arg);
> >  	static value *exc = NULL;
> >  
> > @@ -74,6 +75,7 @@ static void failwith_xl(int error, char *fname)
> >  	Store_field(arg, 1, caml_copy_string(fname));
> >  
> >  	caml_raise_with_arg(*exc, arg);
> > +	CAMLreturn0;
> 
> 
> raise_with_arg has Noreturn, although this is probably harmless enough
> and might keep some stupider compilers happy.

Oops, meant to say: Nonetheless:

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

Re: [PATCH v5 10/12] libxl: ocaml: fix memory corruption when converting string and key/values lists

[Ian Campbell]

On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
> Found by Coverty. CIDs: 1128562 1128563 1128564 1128565.
> 
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

> ---
>  tools/ocaml/libs/xl/xenlight_stubs.c |    6 +++---
>  1 file changed, 3 insertions(+), 3 deletions(-)
> 
> diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
> index 7012045..a2d47f9 100644
> --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> @@ -159,8 +159,8 @@ static value Val_key_value_list(libxl_key_value_list *c_val)
>  
>  	list = Val_emptylist;
>  	for (i = libxl_string_list_length((libxl_string_list *) c_val) - 1; i >= 0; i -= 2) {
> -		val = caml_copy_string((char *) c_val[i]);
> -		key = caml_copy_string((char *) c_val[i - 1]);
> +		val = caml_copy_string((*c_val)[i]);
> +		key = caml_copy_string((*c_val)[i - 1]);
>  		kv = caml_alloc_tuple(2);
>  		Store_field(kv, 0, key);
>  		Store_field(kv, 1, val);
> @@ -201,7 +201,7 @@ static value Val_string_list(libxl_string_list *c_val)
>  
>  	list = Val_emptylist;
>  	for (i = libxl_string_list_length(c_val) - 1; i >= 0; i--) {
> -		string = caml_copy_string((char *) c_val[i]);
> +		string = caml_copy_string((*c_val)[i]);
>  		cons = caml_alloc(2, 0);
>  		Store_field(cons, 0, string);   // head
>  		Store_field(cons, 1, list);     // tail

Re: [PATCH v5 11/12] libxl: ocaml: remove dead code in xentoollog bindings

[Ian Campbell]

On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
> Found by Coverty. CIDs: 1128567 1128568 1128576 1128577.
> 
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

> ---
>  tools/ocaml/libs/xentoollog/xentoollog_stubs.c |    4 ----
>  1 file changed, 4 deletions(-)
> 
> diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
> index 87ea53e..46f7f87 100644
> --- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
> +++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
> @@ -92,8 +92,6 @@ static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
>  	value *func = caml_named_value(xtl->vmessage_cb) ;
>  	char *msg;
>  
> -	if (args == NULL)
> -		caml_raise_out_of_memory();
>  	if (func == NULL)
>  		caml_raise_sys_error(caml_copy_string("Unable to find callback"));
>  	if (vasprintf(&msg, format, al) < 0)
> @@ -123,8 +121,6 @@ static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
>  	struct caml_xtl *xtl = (struct caml_xtl*)logger;
>  	value *func = caml_named_value(xtl->progress_cb) ;
>  
> -	if (args == NULL)
> -		caml_raise_out_of_memory();
>  	if (func == NULL)
>  		caml_raise_sys_error(caml_copy_string("Unable to find callback"));
>  

Re: [PATCH v5 12/12] libxl: ocaml: git/hgignore generated files

[Ian Campbell]

On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

Re: [PATCH v5 00/12] libxl: ocaml: improve the bindings

[George Dunlap]

On 11/27/2013 11:39 AM, Rob Hoes wrote:
> Ian Campbell wrote:
>> On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
>>> This series contains version 5 of the remaining patches to fix the
>>> OCaml bindings to libxl.
>> Since we are now into the freeze period we (really, you ;-) need to make
>> an argument to the release manager (George) for why this should go in now.
>> His guidance is in
>> http://article.gmane.org/gmane.comp.emulators.xen.devel/180209.
>>
>> The benefit of this series is that it allows for ocaml based xen
>> toolstacks (specifically xapi) to start making the transition to using
>> libxl. It would be awesome if 4.4 provided a decent baseline for that.
> I would indeed be great if we can start using libxl from Xen 4.4 out of the box!
>
>> The risk is that we break the bindings for some existing users, but I am
>> 99.9% certain there can be none of those. Effectively Rob is the only user
>> today. The bindings in 4.3 were not really usable, at least not in anger.
> I don't think anyone would have been really able to use the bindings as they were, because they were incomplete and caused memory corruption. In a way, you could consider the whole series to be one large bug fix :)
>
> About 80% of my original series has already been merged. This contained really just the ground work. This version adds some essential bindings to VM lifecycle operations, the event system, and some bug fixes. These patches only affect files in tools/ocaml (plus .git/.hgignore).

I agree with the cost/benefit analysis.  Assuming that it's accurate 
that the changes are confined to tools/ocaml:

Release-acked-by: George Dunlap <george.dunlap@eu.citrix.com>

  -George

Re: [PATCH v5 03/12] libxl: ocaml: event management

[Ian Jackson]

Rob Hoes writes ("[PATCH v5 03/12] libxl: ocaml: event management"):
> 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.

Subject to my comments on with the locking change patch, I think this
one is OK _if that patch goes in as well_.

Formally speaking that means I shouldn't ack this patch, because
partial application of a series is supposed to still leave the tree
correct.  Or to put it another way, it's a bit odd to find that this
patch introduces wrong code which is to be fixed up later.

Having said that, I don't think much would be served by asking you to
transpose these patches at this stage, even though it would be
preferable.  And I have no other problems with this.  So:

CONDITIONAL Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>

The condition is that
  "libxl: ocaml: drop the ocaml heap lock before calling into libxl"
is committed and pushed simultaneously.

Ian.

Re: [PATCH v5 03/12] libxl: ocaml: event management

[Ian Jackson]

Rob Hoes writes ("[PATCH v5 03/12] libxl: ocaml: event management"):
> 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.

Subject to my comments on with the locking change patch, I think this
one is OK _if that patch goes in as well_.

Formally speaking that means I shouldn't ack this patch, because
partial application of a series is supposed to still leave the tree
correct.  Or to put it another way, it's a bit odd to find that this
patch introduces wrong code which is to be fixed up later.

Having said that, I don't think much would be served by asking you to
transpose these patches at this stage, even though it would be
preferable.  And I have no other problems with this.  So:

CONDITIONAL Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>

The condition is that
  "libxl: ocaml: drop the ocaml heap lock before calling into libxl"
is committed and pushed simultaneously.

Ian.

Re: [PATCH v5 03/12] libxl: ocaml: event management

[Ian Jackson]

Rob Hoes writes ("[PATCH v5 03/12] libxl: ocaml: event management"):
> 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.

Subject to my comments on with the locking change patch, I think this
one is OK _if that patch goes in as well_.

Formally speaking that means I shouldn't ack this patch, because
partial application of a series is supposed to still leave the tree
correct.  Or to put it another way, it's a bit odd to find that this
patch introduces wrong code which is to be fixed up later.

Having said that, I don't think much would be served by asking you to
transpose these patches at this stage, even though it would be
preferable.  And I have no other problems with this.  So:

CONDITIONAL Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>

The condition is that
  "libxl: ocaml: drop the ocaml heap lock before calling into libxl"
is committed and pushed simultaneously.

Ian.

Re: [PATCH v5 03/12] libxl: ocaml: event management

[Ian Jackson]

Rob Hoes writes ("[PATCH v5 03/12] libxl: ocaml: event management"):
> 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.

Subject to my comments on with the locking change patch, I think this
one is OK _if that patch goes in as well_.

Formally speaking that means I shouldn't ack this patch, because
partial application of a series is supposed to still leave the tree
correct.  Or to put it another way, it's a bit odd to find that this
patch introduces wrong code which is to be fixed up later.

Having said that, I don't think much would be served by asking you to
transpose these patches at this stage, even though it would be
preferable.  And I have no other problems with this.  So:

CONDITIONAL Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>

The condition is that
  "libxl: ocaml: drop the ocaml heap lock before calling into libxl"
is committed and pushed simultaneously.

Ian.

Re: [PATCH v5 03/12] libxl: ocaml: event management

[Ian Jackson]

Rob Hoes writes ("[PATCH v5 03/12] libxl: ocaml: event management"):
> 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.

Subject to my comments on with the locking change patch, I think this
one is OK _if that patch goes in as well_.

Formally speaking that means I shouldn't ack this patch, because
partial application of a series is supposed to still leave the tree
correct.  Or to put it another way, it's a bit odd to find that this
patch introduces wrong code which is to be fixed up later.

Having said that, I don't think much would be served by asking you to
transpose these patches at this stage, even though it would be
preferable.  And I have no other problems with this.  So:

CONDITIONAL Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>

The condition is that
  "libxl: ocaml: drop the ocaml heap lock before calling into libxl"
is committed and pushed simultaneously.

Ian.

Re: [PATCH v5 03/12] libxl: ocaml: event management

[Ian Jackson]

Ian Jackson writes ("Re: [PATCH v5 03/12] libxl: ocaml: event management"):
> [the same thing 5 times]

Sorry about that.  My MUA claimed not to have sent it.  I have
restarted it.

Ian.

Re: [PATCH v5 03/12] libxl: ocaml: event management

[Ian Campbell]

On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
>  
> +void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
> +{
> +	CAMLparam0();
> +	CAMLlocal1(error);
> +	int *task = (int *) for_callback;

You don't seem to use this anywhere.

> +	static value *func = NULL;
> +
> +	if (func == NULL) {
> +		/* First time around, lookup by name */
> +		func = caml_named_value("libxl_async_callback");
> +	}
> +
> +	if (rc == 0)
> +		error = Val_none;
> +	else
> +		error = Val_some(Val_error(rc));
> +
> +	caml_callback2(*func, error, (value) for_callback);

Is this cast OK or should you be declaring a CAMLlocal for this value?

Ian.

Re: [PATCH v5 03/12] libxl: ocaml: event management

[Rob Hoes]

On 29 Nov 2013, at 08:40, Ian Campbell <Ian.Campbell@citrix.com> wrote:

> On Tue, 2013-11-26 at 17:52 +0000, Rob Hoes wrote:
>> 
>> +void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
>> +{
>> +	CAMLparam0();
>> +	CAMLlocal1(error);
>> +	int *task = (int *) for_callback;
> 
> You don't seem to use this anywhere.

Right, this seems to be some leftover debugging code.

>> +	static value *func = NULL;
>> +
>> +	if (func == NULL) {
>> +		/* First time around, lookup by name */
>> +		func = caml_named_value("libxl_async_callback");
>> +	}
>> +
>> +	if (rc == 0)
>> +		error = Val_none;
>> +	else
>> +		error = Val_some(Val_error(rc));
>> +
>> +	caml_callback2(*func, error, (value) for_callback);
> 
> Is this cast OK or should you be declaring a CAMLlocal for this value?

If the value is already protected from the GC, then I don’t think so. It depends on what we figure out on the other thread :)

Rob