libxl: ocaml: add VM lifecycle operations

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

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

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index 46106b554e4678486fafc22e3f15edac5319c28c..fc051120fd5d3e9b59a1ee2e0fce6b495fffab68 100644 (file)
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -33,9 +33,24 @@ type event =
        | POLLHUP (* Device has been disconnected (revents only) *)
        | POLLNVAL (* Invalid request: fd not open (revents only). *)
 
-external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+module Domain = struct
+       external create_new : ctx -> Domain_config.t -> ?async:'a -> unit -> domid = "stub_libxl_domain_create_new"
+       external create_restore : ctx -> Domain_config.t -> (Unix.file_descr * Domain_restore_params.t) ->
+               ?async:'a -> unit -> domid = "stub_libxl_domain_create_restore"
+       external shutdown : ctx -> domid -> unit = "stub_libxl_domain_shutdown"
+       external reboot : ctx -> domid -> unit = "stub_libxl_domain_reboot"
+       external destroy : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_destroy"
+       external suspend : ctx -> domid -> Unix.file_descr -> ?async:'a -> unit -> unit = "stub_libxl_domain_suspend"
+       external pause : ctx -> domid -> unit = "stub_libxl_domain_pause"
+       external unpause : ctx -> domid -> unit = "stub_libxl_domain_unpause"
+
+       external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
+       external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
+end
+
+module Host = struct
+       external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+end
 
 module Async = struct
        type for_libxl

diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index 170e0e0b700cf772a1efeb71628f20bcffb8ba2b..ee4efd81c1c9e6bd74d9b2745710178e11cd0a99 100644 (file)
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -35,9 +35,24 @@ type event =
        | POLLHUP (* Device has been disconnected (revents only) *)
        | POLLNVAL (* Invalid request: fd not open (revents only). *)
 
-external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+module Domain : sig
+       external create_new : ctx -> Domain_config.t -> ?async:'a -> unit -> domid = "stub_libxl_domain_create_new"
+       external create_restore : ctx -> Domain_config.t -> (Unix.file_descr * Domain_restore_params.t) ->
+               ?async:'a -> unit -> domid = "stub_libxl_domain_create_restore"
+       external shutdown : ctx -> domid -> unit = "stub_libxl_domain_shutdown"
+       external reboot : ctx -> domid -> unit = "stub_libxl_domain_reboot"
+       external destroy : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_destroy"
+       external suspend : ctx -> domid -> Unix.file_descr -> ?async:'a -> unit -> unit = "stub_libxl_domain_suspend"
+       external pause : ctx -> domid -> unit = "stub_libxl_domain_pause"
+       external unpause : ctx -> domid -> unit = "stub_libxl_domain_unpause"
+
+       external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
+       external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
+end
+
+module Host : sig
+       external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+end
 
 module Async : sig
        type for_libxl

diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 46642a659bfb1feb3d3f5d45cb6adb247567cb9d..6297c2f6adfed7294e6bd1471629a3b6c7e81bfa 100644 (file)
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -401,6 +401,168 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
        free(p);
 }
 
+static libxl_asyncop_how *aohow_val(value async, libxl_asyncop_how *ao_how)
+{
+       CAMLparam1(async);
+       value *p;
+
+       if (async != Val_none) {
+               /* for_callback must be a pointer to a "value" that is malloc'ed and
+                * registered with the OCaml GC. This ensures that the GC does not remove
+                * the corresponding OCaml heap blocks, and allows the GC to update the value
+                * when blocks are moved around, while libxl is free to copy the pointer if
+                * it needs to.
+                * The for_callback pointer must always be non-NULL. */
+               p = malloc(sizeof(value));
+               if (!p)
+                       failwith_xl(ERROR_NOMEM, "cannot allocate value");
+               *p = Some_val(async);
+               caml_register_global_root(p);
+               ao_how->callback = async_callback;
+               ao_how->u.for_callback = (void *) p;
+               CAMLreturnT(libxl_asyncop_how *, ao_how);
+       }
+       else
+               CAMLreturnT(libxl_asyncop_how *, NULL);
+}
+
+value stub_libxl_domain_create_new(value ctx, value domain_config, value async, value unit)
+{
+       CAMLparam4(ctx, async, domain_config, unit);
+       int ret;
+       libxl_domain_config c_dconfig;
+       uint32_t c_domid;
+       libxl_asyncop_how ao_how;
+
+       libxl_domain_config_init(&c_dconfig);
+       ret = domain_config_val(CTX, &c_dconfig, domain_config);
+       if (ret != 0) {
+               libxl_domain_config_dispose(&c_dconfig);
+               failwith_xl(ret, "domain_create_new");
+       }
+
+       ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid,
+               aohow_val(async, &ao_how), NULL);
+
+       libxl_domain_config_dispose(&c_dconfig);
+
+       if (ret != 0)
+               failwith_xl(ret, "domain_create_new");
+
+       CAMLreturn(Val_int(c_domid));
+}
+
+value stub_libxl_domain_create_restore(value ctx, value domain_config, value params,
+       value async, value unit)
+{
+       CAMLparam5(ctx, domain_config, params, async, unit);
+       int ret;
+       libxl_domain_config c_dconfig;
+       libxl_domain_restore_params c_params;
+       uint32_t c_domid;
+       libxl_asyncop_how ao_how;
+
+       libxl_domain_config_init(&c_dconfig);
+       ret = domain_config_val(CTX, &c_dconfig, domain_config);
+       if (ret != 0) {
+               libxl_domain_config_dispose(&c_dconfig);
+               failwith_xl(ret, "domain_create_restore");
+       }
+
+       libxl_domain_restore_params_init(&c_params);
+       ret = domain_restore_params_val(CTX, &c_params, Field(params, 1));
+       if (ret != 0) {
+               libxl_domain_restore_params_dispose(&c_params);
+               failwith_xl(ret, "domain_create_restore");
+       }
+
+       ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, Int_val(Field(params, 0)),
+               &c_params, aohow_val(async, &ao_how), NULL);
+
+       libxl_domain_config_dispose(&c_dconfig);
+       libxl_domain_restore_params_dispose(&c_params);
+
+       if (ret != 0)
+               failwith_xl(ret, "domain_create_restore");
+
+       CAMLreturn(Val_int(c_domid));
+}
+
+value stub_libxl_domain_shutdown(value ctx, value domid)
+{
+       CAMLparam2(ctx, domid);
+       int ret;
+
+       ret = libxl_domain_shutdown(CTX, Int_val(domid));
+       if (ret != 0)
+               failwith_xl(ret, "domain_shutdown");
+
+       CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_reboot(value ctx, value domid)
+{
+       CAMLparam2(ctx, domid);
+       int ret;
+
+       ret = libxl_domain_reboot(CTX, Int_val(domid));
+       if (ret != 0)
+               failwith_xl(ret, "domain_reboot");
+
+       CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_destroy(value ctx, value domid, value async, value unit)
+{
+       CAMLparam4(ctx, domid, async, unit);
+       int ret;
+       libxl_asyncop_how ao_how;
+
+       ret = libxl_domain_destroy(CTX, Int_val(domid), aohow_val(async, &ao_how));
+       if (ret != 0)
+               failwith_xl(ret, "domain_destroy");
+
+       CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_suspend(value ctx, value domid, value fd, value async, value unit)
+{
+       CAMLparam5(ctx, domid, fd, async, unit);
+       int ret;
+       libxl_asyncop_how ao_how;
+
+       ret = libxl_domain_suspend(CTX, Int_val(domid), Int_val(fd), 0,
+               aohow_val(async, &ao_how));
+       if (ret != 0)
+               failwith_xl(ret, "domain_suspend");
+
+       CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_pause(value ctx, value domid)
+{
+       CAMLparam2(ctx, domid);
+       int ret;
+
+       ret = libxl_domain_pause(CTX, Int_val(domid));
+       if (ret != 0)
+               failwith_xl(ret, "domain_pause");
+
+       CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_unpause(value ctx, value domid)
+{
+       CAMLparam2(ctx, domid);
+       int ret;
+
+       ret = libxl_domain_unpause(CTX, Int_val(domid));
+       if (ret != 0)
+               failwith_xl(ret, "domain_unpause");
+
+       CAMLreturn(Val_unit);
+}
+
 #define _STRINGIFY(x) #x
 #define STRINGIFY(x) _STRINGIFY(x)
 
@@ -412,20 +574,11 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,    \
        libxl_device_##type c_info;                                     \
        int ret, marker_var;                                            \
        libxl_asyncop_how ao_how;                                       \
-       value *p;                                                       \
                                                                        \
        device_##type##_val(CTX, &c_info, info);                        \
                                                                        \
-       if (async != Val_none) {                                        \
-               p = malloc(sizeof(value));                              \
-               *p = Some_val(async);                                   \
-               caml_register_global_root(p);                           \
-               ao_how.callback = async_callback;                       \
-               ao_how.u.for_callback = (void *) p;                     \
-       }                                                               \
-                                                                       \
        ret = libxl_##fn##_##op(CTX, Int_val(domid), &c_info,           \
-               async != Val_none ? &ao_how : NULL);                    \
+               aohow_val(async, &ao_how));                             \
                                                                        \
        libxl_device_##type##_dispose(&c_info);                         \
                                                                        \

diff --git a/tools/ocaml/test/send_debug_keys.ml b/tools/ocaml/test/send_debug_keys.ml
index 5900cf9e704898785ff87ae0bcc6cad33fdb5154..0a42c3ad7e1bb6e98e9588d983355eb2e5de8b51 100644 (file)
--- 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 _ =