tools/ocaml/xenctrl: Add binding for xc_evtchn_status

There is no API or ioctl to query event channel status, it is only
present in xenctrl.h

The C union is mapped to an OCaml variant exposing just the value from
the correct union tag.  This causes the xc bindings to now depend on
evtchn to get a useful API for EVTCHNSTAT_virq.

The information provided here is similar to 'lsevtchn', but rather than
parsing its output it queries the underlying API directly.

Signed-off-by: Edwin Török <edvin.torok@citrix.com>
Reviewed-by: Andrew Cooper <andrew.cooper3@citrix.com>
Acked-by: Christian Lindig <christian.lindig@citrix.com>

diff --git a/tools/ocaml/libs/Makefile b/tools/ocaml/libs/Makefile
index 7e7c27e2d5c276be505ba8e58df7169084dcab7c..5146c524846083f343b5d4c5c2ccbb060dc94a67 100644 (file)
--- a/tools/ocaml/libs/Makefile
+++ b/tools/ocaml/libs/Makefile
@@ -4,7 +4,7 @@ include $(XEN_ROOT)/tools/Rules.mk
 SUBDIRS= \
        mmap \
        xentoollog \
-       xc eventchn \
+       eventchn xc \
        xb xs xl
 
 .PHONY: all

diff --git a/tools/ocaml/libs/xc/META.in b/tools/ocaml/libs/xc/META.in
index 2ff4dcb6bf58a2316590b3e81e7a8bcd52bd5622..6a273936a3909a9bba8fe0227b22ea3e97680606 100644 (file)
--- a/tools/ocaml/libs/xc/META.in
+++ b/tools/ocaml/libs/xc/META.in
@@ -1,5 +1,5 @@
 version = "@VERSION@"
 description = "Xen Control Interface"
-requires = "unix,xenmmap"
+requires = "unix,xenmmap,xeneventchn"
 archive(byte) = "xenctrl.cma"
 archive(native) = "xenctrl.cmxa"

diff --git a/tools/ocaml/libs/xc/Makefile b/tools/ocaml/libs/xc/Makefile
index 3b76e9ad7bbe0a5b238126be0fc955af95531c52..1d9fecb06ef24bccaa6073d815c4bbbc7d35121b 100644 (file)
--- a/tools/ocaml/libs/xc/Makefile
+++ b/tools/ocaml/libs/xc/Makefile
@@ -4,7 +4,7 @@ include $(OCAML_TOPLEVEL)/common.make
 
 CFLAGS += -I../mmap $(CFLAGS_libxenctrl) $(CFLAGS_libxenguest)
 CFLAGS += $(APPEND_CFLAGS)
-OCAMLINCLUDE += -I ../mmap
+OCAMLINCLUDE += -I ../mmap -I ../eventchn
 
 OBJS = xenctrl
 INTF = xenctrl.cmi

diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml
index 4b74e31c75cba0005bb3ed2e8714713537f78d23..b70ab89caa5718b2e85d3c8d00e1d0cf7ba90d3e 100644 (file)
--- a/tools/ocaml/libs/xc/xenctrl.ml
+++ b/tools/ocaml/libs/xc/xenctrl.ml
@@ -277,6 +277,21 @@ external evtchn_alloc_unbound: handle -> domid -> domid -> int
        = "stub_xc_evtchn_alloc_unbound"
 external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset"
 
+(* FIFO has theoretical maximum of 2^28 ports, fits in an int *)
+type evtchn_interdomain = { dom: domid; port: int }
+
+type evtchn_stat =
+  | EVTCHNSTAT_unbound of domid
+  | EVTCHNSTAT_interdomain of evtchn_interdomain
+  | EVTCHNSTAT_pirq of int
+  | EVTCHNSTAT_virq of Xeneventchn.virq_t
+  | EVTCHNSTAT_ipi
+
+type evtchn_status = { vcpu: int; status: evtchn_stat }
+
+external evtchn_status: handle -> domid -> int -> evtchn_status option =
+  "stub_xc_evtchn_status"
+
 external readconsolering: handle -> string = "stub_xc_readconsolering"
 
 external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys"

diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli
index ddfe84dc22a9b4ff4c2b91d8d565df02f4baae2f..f6a777ede686b448015fa670b4ebb4dbc1f26009 100644 (file)
--- a/tools/ocaml/libs/xc/xenctrl.mli
+++ b/tools/ocaml/libs/xc/xenctrl.mli
@@ -205,6 +205,21 @@ external shadow_allocation_get : handle -> domid -> int
 external evtchn_alloc_unbound : handle -> domid -> domid -> int
   = "stub_xc_evtchn_alloc_unbound"
 external evtchn_reset : handle -> domid -> unit = "stub_xc_evtchn_reset"
+
+type evtchn_interdomain = { dom: domid; port: int }
+
+type evtchn_stat =
+  | EVTCHNSTAT_unbound of domid
+  | EVTCHNSTAT_interdomain of evtchn_interdomain
+  | EVTCHNSTAT_pirq of int
+  | EVTCHNSTAT_virq of Xeneventchn.virq_t
+  | EVTCHNSTAT_ipi
+
+type evtchn_status = { vcpu: int; status: evtchn_stat }
+
+external evtchn_status: handle -> domid -> int -> evtchn_status option =
+  "stub_xc_evtchn_status"
+
 external readconsolering : handle -> string = "stub_xc_readconsolering"
 external send_debug_keys : handle -> string -> unit = "stub_xc_send_debug_keys"
 external physinfo : handle -> physinfo = "stub_xc_physinfo"

diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c b/tools/ocaml/libs/xc/xenctrl_stubs.c
index 4e1204085422265897f0ec452b43a7c52b3a47ee..9cbf17103da7db7092f31185dc6032f63d355c56 100644 (file)
--- a/tools/ocaml/libs/xc/xenctrl_stubs.c
+++ b/tools/ocaml/libs/xc/xenctrl_stubs.c
@@ -44,6 +44,10 @@
 #define Val_none (Val_int(0))
 #endif
 
+#ifndef Tag_some
+#define Tag_some 0
+#endif
+
 static void stub_xenctrl_finalize(value v)
 {
        xc_interface_close(_H(v));
@@ -649,6 +653,68 @@ CAMLprim value stub_xc_evtchn_reset(value xch, value domid)
        CAMLreturn(Val_unit);
 }
 
+CAMLprim value stub_xc_evtchn_status(value xch, value domid, value port)
+{
+       CAMLparam3(xch, domid, port);
+       CAMLlocal4(result, result_status, stat, interdomain);
+       xc_evtchn_status_t status = {
+               .dom = _D(domid),
+               .port = Int_val(port),
+       };
+       int rc;
+
+       caml_enter_blocking_section();
+       rc = xc_evtchn_status(_H(xch), &status);
+       caml_leave_blocking_section();
+
+       if ( rc < 0 )
+               failwith_xc(_H(xch));
+
+       switch ( status.status )
+       {
+       case EVTCHNSTAT_closed:
+               CAMLreturn(Val_none); /* Early exit, no allocations needed */
+
+       case EVTCHNSTAT_unbound:
+               stat = caml_alloc(1, 0); /* 1st non-constant constructor */
+               Store_field(stat, 0, Val_int(status.u.unbound.dom));
+               break;
+
+       case EVTCHNSTAT_interdomain:
+               interdomain = caml_alloc_tuple(2);
+               Store_field(interdomain, 0, Val_int(status.u.interdomain.dom));
+               Store_field(interdomain, 1, Val_int(status.u.interdomain.port));
+               stat = caml_alloc(1, 1); /*  2nd non-constant constructor */
+               Store_field(stat, 0, interdomain);
+               break;
+
+       case EVTCHNSTAT_pirq:
+               stat = caml_alloc(1, 2); /* 3rd non-constant constructor */
+               Store_field(stat, 0, Val_int(status.u.pirq));
+               break;
+
+       case EVTCHNSTAT_virq:
+               stat = caml_alloc(1, 3); /* 4th non-constant constructor */
+               Store_field(stat, 0, Val_int(status.u.virq));
+               break;
+
+       case EVTCHNSTAT_ipi:
+               stat = Val_int(0); /* 1st constant constructor */
+               break;
+
+       default:
+               caml_failwith("Unknown evtchn status");
+       }
+
+       result_status = caml_alloc_tuple(2);
+       Store_field(result_status, 0, Val_int(status.vcpu));
+       Store_field(result_status, 1, stat);
+
+       result = caml_alloc_small(1, Tag_some);
+       Store_field(result, 0, result_status);
+
+       CAMLreturn(result);
+}
 
 CAMLprim value stub_xc_readconsolering(value xch)
 {