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. 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.to...@citrix.com> --- Changes since v1: * drop paragraph about where this is used * add comment about max port * use Xeneventchn.virq_t instead of int, add a dependency: xc -> eventchn * initialize struct without memset-ing first * use 2 CAMLreturn, I found an example in the OCaml stdlib that does that so should be future-proof https://github.com/ocaml/ocaml/blob/663e8d219f566095e3a9497c5bae07b6a95cae39/otherlibs/unix/dup_win32.c#L52-L77 * use Tag_some, defining it if needed * fix typo on failwith --- tools/ocaml/libs/Makefile | 2 +- tools/ocaml/libs/xc/META.in | 2 +- tools/ocaml/libs/xc/Makefile | 2 +- tools/ocaml/libs/xc/xenctrl.ml | 15 +++++++ tools/ocaml/libs/xc/xenctrl.mli | 15 +++++++ tools/ocaml/libs/xc/xenctrl_stubs.c | 67 +++++++++++++++++++++++++++++ 6 files changed, 100 insertions(+), 3 deletions(-) diff --git a/tools/ocaml/libs/Makefile b/tools/ocaml/libs/Makefile index 7e7c27e2d5..15f45a6d66 100644 --- 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 2ff4dcb6bf..6a273936a3 100644 --- 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 3b76e9ad7b..1d9fecb06e 100644 --- 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 2ed7454b16..5dac47991e 100644 --- a/tools/ocaml/libs/xc/xenctrl.ml +++ b/tools/ocaml/libs/xc/xenctrl.ml @@ -267,6 +267,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 0f80aafea0..6c9206bc74 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 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 d30585f21c..a492ea17fd 100644 --- 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 + #define string_of_option_array(array, index) \ ((Field(array, index) == Val_none) ? NULL : String_val(Field(Field(array, index), 0))) @@ -641,6 +645,69 @@ 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)); + + if ( status.status == EVTCHNSTAT_closed ) + CAMLreturn(Val_none); + + 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("Unknown evtchn status"); + + } + result_status = caml_alloc_tuple(2); + Store_field(result_status, 0, Val_int(status.vcpu)); + Store_field(result_status, 1, stat); + + /* caml_alloc_some is missing in older versions of OCaml + */ + result = caml_alloc_small(1, Tag_some); + Store_field(result, 0, result_status); + + CAMLreturn(result); +} CAMLprim value stub_xc_readconsolering(value xch) { -- 2.34.1
