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>

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

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"

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

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"

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"

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)
 {