[PATCH v1 2/5] tools/ocaml/libs/xc: add binding to xc_evtchn_status

[Edwin Török <edvin.torok@xxxxxxxxxx>]

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.

Querying event channel status is useful when analyzing Windows VMs that
may have reset and changed the xenstore event channel port number from
what it initially got booted with.
The information provided here is similar to 'lstevtchn', but rather than
parsing its output it queries the underlying API directly.

Signed-off-by: Edwin Török <edvin.torok@xxxxxxxxxx>
---
 tools/ocaml/libs/xc/xenctrl.ml      | 14 +++++++
 tools/ocaml/libs/xc/xenctrl.mli     | 15 +++++++
 tools/ocaml/libs/xc/xenctrl_stubs.c | 65 +++++++++++++++++++++++++++++
 3 files changed, 94 insertions(+)

diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml
index 2ed7454b16..c21e391f98 100644
--- a/tools/ocaml/libs/xc/xenctrl.ml
+++ b/tools/ocaml/libs/xc/xenctrl.ml
@@ -267,6 +267,20 @@ 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 int
+  | 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 0f80aafea0..60e7902e66 100644
--- a/tools/ocaml/libs/xc/xenctrl.mli
+++ b/tools/ocaml/libs/xc/xenctrl.mli
@@ -206,6 +206,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 int
+  | 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 d30585f21c..67f3648391 100644
--- a/tools/ocaml/libs/xc/xenctrl_stubs.c
+++ b/tools/ocaml/libs/xc/xenctrl_stubs.c
@@ -641,6 +641,71 @@ 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;
+    int rc;
+
+    memset(&status, 0, sizeof(status));
+    status.dom = _D(domid);
+    status.port = Int_val(port);
+
+    caml_enter_blocking_section();
+    rc = xc_evtchn_status(_H(xch), &status);
+    caml_leave_blocking_section();
+
+    if ( rc < 0 )
+        failwith_xc(_H(xch));
+
+    if ( status.status == EVTCHNSTAT_closed )
+        result = Val_none;
+    else
+    {
+        switch ( status.status )
+        {
+        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("Unkown evtchn status");
+        }
+        result_status = caml_alloc_tuple(2);
+        Store_field(result_status, 0, Val_int(status.vcpu));
+        Store_field(result_status, 1, stat);
+
+        /* Tag_some and caml_alloc_some are missing in older versions of OCaml
+         */
+        result = caml_alloc_small(1, 0);
+        Store_field(result, 0, result_status);
+    }
+
+    CAMLreturn(result);
+}
 
 CAMLprim value stub_xc_readconsolering(value xch)
 {
-- 
2.34.1