diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index 85bfd087c9..1557fd6c3c 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -4,10 +4,6 @@ include $(XEN_ROOT)/tools/Rules.mk SUBDIRS := libs SUBDIRS += xenstored -ifeq ($(CONFIG_TESTS),y) -SUBDIRS += test -endif - .NOTPARALLEL: # targets here must be run in order, otherwise we can try # to build programs before the libraries are done diff --git a/tools/ocaml/libs/Makefile b/tools/ocaml/libs/Makefile index 5146c52484..89350aa12f 100644 --- a/tools/ocaml/libs/Makefile +++ b/tools/ocaml/libs/Makefile @@ -3,9 +3,8 @@ include $(XEN_ROOT)/tools/Rules.mk SUBDIRS= \ mmap \ - xentoollog \ eventchn xc \ - xb xs xl + xb xs .PHONY: all all: subdirs-all diff --git a/tools/ocaml/libs/xentoollog/META.in b/tools/ocaml/libs/xentoollog/META.in deleted file mode 100644 index 7b066830ed..0000000000 --- a/tools/ocaml/libs/xentoollog/META.in +++ /dev/null @@ -1,4 +0,0 @@ -version = "@VERSION@" -description = "Xen Tools Logger Interface" -archive(byte) = "xentoollog.cma" -archive(native) = "xentoollog.cmxa" diff --git a/tools/ocaml/libs/xentoollog/Makefile b/tools/ocaml/libs/xentoollog/Makefile deleted file mode 100644 index 1645b40faf..0000000000 --- a/tools/ocaml/libs/xentoollog/Makefile +++ /dev/null @@ -1,65 +0,0 @@ -OCAML_TOPLEVEL=$(CURDIR)/../.. -XEN_ROOT=$(OCAML_TOPLEVEL)/../.. -include $(OCAML_TOPLEVEL)/common.make - -# allow mixed declarations and code -CFLAGS += -Wno-declaration-after-statement - -CFLAGS += $(CFLAGS_libxentoollog) -CFLAGS += $(APPEND_CFLAGS) -OCAMLINCLUDE += - -OBJS = xentoollog -INTF = xentoollog.cmi -LIBS = xentoollog.cma xentoollog.cmxa - -LIBS_xentoollog = $(call xenlibs-ldflags-ldlibs,toollog) - -xentoollog_OBJS = $(OBJS) -xentoollog_C_OBJS = xentoollog_stubs - -OCAML_LIBRARY = xentoollog - -GENERATED_FILES += xentoollog.ml xentoollog.ml.tmp xentoollog.mli xentoollog.mli.tmp -GENERATED_FILES += _xtl_levels.mli.in _xtl_levels.ml.in _xtl_levels.inc META - -all: $(INTF) $(LIBS) - -xentoollog.ml: xentoollog.ml.in _xtl_levels.ml.in - $(Q)sed -e '1i\ -(*\ - * AUTO-GENERATED FILE DO NOT EDIT\ - * Generated from xentoollog.ml.in and _xtl_levels.ml.in\ - *)\ -' \ - -e '/^(\* @@XTL_LEVELS@@ \*)$$/r_xtl_levels.ml.in' \ - < xentoollog.ml.in > xentoollog.ml.tmp - $(Q)mv xentoollog.ml.tmp xentoollog.ml - -xentoollog.mli: xentoollog.mli.in _xtl_levels.mli.in - $(Q)sed -e '1i\ -(*\ - * AUTO-GENERATED FILE DO NOT EDIT\ - * Generated from xentoollog.mli.in and _xtl_levels.mli.in\ - *)\ -' \ - -e '/^(\* @@XTL_LEVELS@@ \*)$$/r_xtl_levels.mli.in' \ - < xentoollog.mli.in > xentoollog.mli.tmp - $(Q)mv xentoollog.mli.tmp xentoollog.mli - -libs: $(LIBS) - -_xtl_levels.ml.in _xtl_levels.mli.in _xtl_levels.inc: genlevels.py $(XEN_INCLUDE)/xentoollog.h - $(PYTHON) genlevels.py _xtl_levels.mli.in _xtl_levels.ml.in _xtl_levels.inc - -.PHONY: install -install: $(LIBS) META - mkdir -p $(OCAMLDESTDIR) - ocamlfind remove -destdir $(OCAMLDESTDIR) xentoollog - ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xentoollog META $(INTF) $(LIBS) *.a *.so *.cmx - -.PHONY: uninstall -uninstall: - ocamlfind remove -destdir $(OCAMLDESTDIR) xentoollog - -include $(OCAML_TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xentoollog/caml_xentoollog.h b/tools/ocaml/libs/xentoollog/caml_xentoollog.h deleted file mode 100644 index 0eb7618512..0000000000 --- a/tools/ocaml/libs/xentoollog/caml_xentoollog.h +++ /dev/null @@ -1,24 +0,0 @@ -/* - * Copyright (C) 2013 Citrix Ltd. - * Author Ian Campbell - * Author Rob Hoes - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - */ - -struct caml_xtl { - xentoollog_logger vtable; - char *vmessage_cb; - char *progress_cb; -}; - -#define Xtl_val(x)(*((struct caml_xtl **) Data_custom_val(x))) - diff --git a/tools/ocaml/libs/xentoollog/genlevels.py b/tools/ocaml/libs/xentoollog/genlevels.py deleted file mode 100755 index 11a623e459..0000000000 --- a/tools/ocaml/libs/xentoollog/genlevels.py +++ /dev/null @@ -1,130 +0,0 @@ -#!/usr/bin/python - -from __future__ import print_function - -import sys -from functools import reduce - -def read_levels(): - f = open('../../../include/xentoollog.h', 'r') - - levels = [] - record = False - for l in f.readlines(): - if 'XTL_NUM_LEVELS' in l: - break - if record == True: - levels.append(l.split(',')[0].strip()) - if 'XTL_NONE' in l: - record = True - - f.close() - - olevels = [level[4:].capitalize() for level in levels] - - return levels, olevels - -# .ml - -def gen_ml(olevels): - s = "" - - s += "type level = \n" - for level in olevels: - s += '\t| %s\n' % level - - s += "\nlet level_to_string level =\n" - s += "\tmatch level with\n" - for level in olevels: - s += '\t| %s -> "%s"\n' % (level, level) - - s += "\nlet level_to_prio level =\n" - s += "\tmatch level with\n" - for index,level in enumerate(olevels): - s += '\t| %s -> %d\n' % (level, index) - - return s - -# .mli - -def gen_mli(olevels): - s = "" - - s += "type level = \n" - for level in olevels: - s += '\t| %s\n' % level - - return s - -# .c - -def gen_c(level): - s = "" - - s += "static value Val_level(xentoollog_level c_level)\n" - s += "{\n" - s += "\tswitch (c_level) {\n" - s += "\tcase XTL_NONE: /* Not a real value */\n" - s += '\t\tcaml_raise_sys_error(caml_copy_string("Val_level XTL_NONE"));\n' - s += "\t\tbreak;\n" - - for index,level in enumerate(levels): - s += "\tcase %s:\n\t\treturn Val_int(%d);\n" % (level, index) - - s += """\tcase XTL_NUM_LEVELS: /* Not a real value! */ - \t\tcaml_raise_sys_error( - \t\t\tcaml_copy_string("Val_level XTL_NUM_LEVELS")); - #if 0 /* Let the compiler catch this */ - \tdefault: - \t\tcaml_raise_sys_error(caml_copy_string("Val_level Unknown")); - \t\tbreak; - #endif - \t} - \tabort(); - } - """ - - return s - -def autogen_header(open_comment, close_comment): - s = open_comment + " AUTO-GENERATED FILE DO NOT EDIT " + close_comment + "\n" - s += open_comment + " autogenerated by \n" - s += reduce(lambda x,y: x + " ", range(len(open_comment + " ")), "") - s += "%s" % " ".join(sys.argv) - s += "\n " + close_comment + "\n\n" - return s - -if __name__ == '__main__': - if len(sys.argv) < 3: - print("Usage: genlevels.py ", file=sys.stderr) - sys.exit(1) - - levels, olevels = read_levels() - - _mli = sys.argv[1] - mli = open(_mli, 'w') - mli.write(autogen_header("(*", "*)")) - - _ml = sys.argv[2] - ml = open(_ml, 'w') - ml.write(autogen_header("(*", "*)")) - - _cinc = sys.argv[3] - cinc = open(_cinc, 'w') - cinc.write(autogen_header("/*", "*/")) - - mli.write(gen_mli(olevels)) - mli.write("\n") - - ml.write(gen_ml(olevels)) - ml.write("\n") - - cinc.write(gen_c(levels)) - cinc.write("\n") - - ml.write("(* END OF AUTO-GENERATED CODE *)\n") - ml.close() - mli.write("(* END OF AUTO-GENERATED CODE *)\n") - mli.close() - cinc.close() - diff --git a/tools/ocaml/libs/xentoollog/xentoollog.ml.in b/tools/ocaml/libs/xentoollog/xentoollog.ml.in deleted file mode 100644 index ce9ea1db77..0000000000 --- a/tools/ocaml/libs/xentoollog/xentoollog.ml.in +++ /dev/null @@ -1,48 +0,0 @@ -(* - * Copyright (C) 2012 Citrix Ltd. - * Author Ian Campbell - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -open Printf -open Random -open Callback - -(* @@XTL_LEVELS@@ *) - -let compare_level x y = - compare (level_to_prio x) (level_to_prio y) - -type handle - -type logger_cbs = { - vmessage : level -> int option -> string option -> string -> unit; - progress : string option -> string -> int -> int64 -> int64 -> unit; - (*destroy : unit -> unit*) -} - -external _create_logger: (string * string) -> handle = "stub_xtl_create_logger" -external test: handle -> unit = "stub_xtl_test" - -let counter = ref 0L - -let create name cbs : handle = - (* Callback names are supposed to be unique *) - let suffix = Int64.to_string !counter in - counter := Int64.succ !counter; - let vmessage_name = sprintf "%s_vmessage_%s" name suffix in - let progress_name = sprintf "%s_progress_%s" name suffix in - (*let destroy_name = sprintf "%s_destroy" name in*) - Callback.register vmessage_name cbs.vmessage; - Callback.register progress_name cbs.progress; - _create_logger (vmessage_name, progress_name) - diff --git a/tools/ocaml/libs/xentoollog/xentoollog.mli.in b/tools/ocaml/libs/xentoollog/xentoollog.mli.in deleted file mode 100644 index 05c098ae49..0000000000 --- a/tools/ocaml/libs/xentoollog/xentoollog.mli.in +++ /dev/null @@ -1,43 +0,0 @@ -(* - * Copyright (C) 2012 Citrix Ltd. - * Author Ian Campbell - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(* @@XTL_LEVELS@@ *) - -val level_to_string : level -> string -val compare_level : level -> level -> int - -type handle - -(** call back arguments. See xentoollog.h for more info. - vmessage: - level: level as above - errno: Some or None - context: Some or None - message: The log message (already formatted) - progress: - context: Some or None - doing_what: string - percent, done, total. -*) -type logger_cbs = { - vmessage : level -> int option -> string option -> string -> unit; - progress : string option -> string -> int -> int64 -> int64 -> unit; - (*destroy : handle -> unit*) -} - -external test: handle -> unit = "stub_xtl_test" - -val create : string -> logger_cbs -> handle - diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c deleted file mode 100644 index e4306a0c2f..0000000000 --- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c +++ /dev/null @@ -1,205 +0,0 @@ -/* - * Copyright (C) 2012 Citrix Ltd. - * Author Ian Campbell - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - */ - -#define _GNU_SOURCE -#include -#include -#include -#include - -#define CAML_NAME_SPACE -#include -#include -#include -#include -#include -#include - -#include - -#include "caml_xentoollog.h" - -/* The following is equal to the CAMLreturn macro, but without the return */ -#define CAMLdone do{ \ -caml_local_roots = caml__frame; \ -}while (0) - -#define XTL ((xentoollog_logger *) Xtl_val(handle)) - -static char * dup_String_val(value s) -{ - int len; - char *c; - len = caml_string_length(s); - c = calloc(len + 1, sizeof(char)); - if (!c) - caml_raise_out_of_memory(); - memcpy(c, String_val(s), len); - return c; -} - -#include "_xtl_levels.inc" - -/* Option type support as per http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php */ -#ifndef Val_none -#define Val_none Val_int(0) -#endif -#ifndef Some_val -#define Some_val(v) Field(v,0) -#endif - -static value Val_some(value v) -{ - CAMLparam1(v); - CAMLlocal1(some); - some = caml_alloc(1, 0); - Store_field(some, 0, v); - CAMLreturn(some); -} - -static value Val_errno(int errnoval) -{ - if (errnoval == -1) - return Val_none; - return Val_some(Val_int(errnoval)); -} - -static value Val_context(const char *context) -{ - if (context == NULL) - return Val_none; - return Val_some(caml_copy_string(context)); -} - -static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger, - xentoollog_level level, - int errnoval, - const char *context, - const char *format, - va_list al) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - struct caml_xtl *xtl = (struct caml_xtl*)logger; - const value *func = caml_named_value(xtl->vmessage_cb); - char *msg; - - if (func == NULL) - caml_raise_sys_error(caml_copy_string("Unable to find callback")); - if (vasprintf(&msg, format, al) < 0) - caml_raise_out_of_memory(); - - /* vmessage : level -> int option -> string option -> string -> unit; */ - args[0] = Val_level(level); - args[1] = Val_errno(errnoval); - args[2] = Val_context(context); - args[3] = caml_copy_string(msg); - - free(msg); - - caml_callbackN(*func, 4, args); - CAMLdone; - caml_enter_blocking_section(); -} - -static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger, - const char *context, - const char *doing_what /* no \r,\n */, - int percent, unsigned long done, unsigned long total) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 5); - struct caml_xtl *xtl = (struct caml_xtl*)logger; - const value *func = caml_named_value(xtl->progress_cb); - - if (func == NULL) - caml_raise_sys_error(caml_copy_string("Unable to find callback")); - - /* progress : string option -> string -> int -> int64 -> int64 -> unit; */ - args[0] = Val_context(context); - args[1] = caml_copy_string(doing_what); - args[2] = Val_int(percent); - args[3] = caml_copy_int64(done); - args[4] = caml_copy_int64(total); - - caml_callbackN(*func, 5, args); - CAMLdone; - caml_enter_blocking_section(); -} - -static void xtl_destroy(struct xentoollog_logger *logger) -{ - struct caml_xtl *xtl = (struct caml_xtl*)logger; - free(xtl->vmessage_cb); - free(xtl->progress_cb); - free(xtl); -} - -void xtl_finalize(value handle) -{ - xtl_destroy(XTL); -} - -static struct custom_operations xentoollogger_custom_operations = { - "xentoollogger_custom_operations", - xtl_finalize /* custom_finalize_default */, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -/* external _create_logger: (string * string) -> handle = "stub_xtl_create_logger" */ -CAMLprim value stub_xtl_create_logger(value cbs) -{ - CAMLparam1(cbs); - CAMLlocal1(handle); - struct caml_xtl *xtl = malloc(sizeof(*xtl)); - if (xtl == NULL) - caml_raise_out_of_memory(); - - memset(xtl, 0, sizeof(*xtl)); - - xtl->vtable.vmessage = &stub_xtl_ocaml_vmessage; - xtl->vtable.progress = &stub_xtl_ocaml_progress; - xtl->vtable.destroy = &xtl_destroy; - - xtl->vmessage_cb = dup_String_val(Field(cbs, 0)); - xtl->progress_cb = dup_String_val(Field(cbs, 1)); - - handle = caml_alloc_custom(&xentoollogger_custom_operations, sizeof(xtl), 0, 1); - Xtl_val(handle) = xtl; - - CAMLreturn(handle); -} - -/* external test: handle -> unit = "stub_xtl_test" */ -CAMLprim value stub_xtl_test(value handle) -{ - unsigned long l; - CAMLparam1(handle); - xtl_log(XTL, XTL_DEBUG, -1, "debug", "%s -- debug", __func__); - xtl_log(XTL, XTL_INFO, -1, "test", "%s -- test 1", __func__); - xtl_log(XTL, XTL_INFO, ENOSYS, "test errno", "%s -- test 2", __func__); - xtl_log(XTL, XTL_CRITICAL, -1, "critical", "%s -- critical", __func__); - for (l = 0UL; l<=100UL; l += 10UL) { - xtl_progress(XTL, "progress", "testing", l, 100UL); - usleep(10000); - } - CAMLreturn(Val_unit); -} - diff --git a/tools/ocaml/libs/xl/META.in b/tools/ocaml/libs/xl/META.in deleted file mode 100644 index 3f0c5526cb..0000000000 --- a/tools/ocaml/libs/xl/META.in +++ /dev/null @@ -1,5 +0,0 @@ -version = "@VERSION@" -description = "Xen Toolstack Library" -requires = "xentoollog" -archive(byte) = "xenlight.cma" -archive(native) = "xenlight.cmxa" diff --git a/tools/ocaml/libs/xl/Makefile b/tools/ocaml/libs/xl/Makefile deleted file mode 100644 index 22d6c93aae..0000000000 --- a/tools/ocaml/libs/xl/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -OCAML_TOPLEVEL=$(CURDIR)/../.. -XEN_ROOT=$(OCAML_TOPLEVEL)/../.. -include $(OCAML_TOPLEVEL)/common.make - -# ignore unused generated functions and allow mixed declarations and code -CFLAGS += -Wno-unused -Wno-declaration-after-statement - -CFLAGS += $(CFLAGS_libxenlight) -CFLAGS += -I ../xentoollog -CFLAGS += $(APPEND_CFLAGS) - -OBJS = xenlight -INTF = xenlight.cmi -LIBS = xenlight.cma xenlight.cmxa - -OCAMLINCLUDE += -I ../xentoollog - -LIBS_xenlight = $(call xenlibs-ldflags-ldlibs,light) - -xenlight_OBJS = $(OBJS) -xenlight_C_OBJS = xenlight_stubs - -OCAML_LIBRARY = xenlight - -GENERATED_FILES += xenlight.ml xenlight.ml.tmp xenlight.mli xenlight.mli.tmp -GENERATED_FILES += _libxl_types.ml.in _libxl_types.mli.in -GENERATED_FILES += _libxl_types.inc META - -all: $(INTF) $(LIBS) - -xenlight.ml: xenlight.ml.in _libxl_types.ml.in - $(Q)sed -e '1i\ -(*\ - * AUTO-GENERATED FILE DO NOT EDIT\ - * Generated from xenlight.ml.in and _libxl_types.ml.in\ - *)\ -' \ - -e '/^(\* @@LIBXL_TYPES@@ \*)$$/r_libxl_types.ml.in' \ - < xenlight.ml.in > xenlight.ml.tmp - $(Q)mv xenlight.ml.tmp xenlight.ml - -xenlight.mli: xenlight.mli.in _libxl_types.mli.in - $(Q)sed -e '1i\ -(*\ - * AUTO-GENERATED FILE DO NOT EDIT\ - * Generated from xenlight.mli.in and _libxl_types.mli.in\ - *)\ -' \ - -e '/^(\* @@LIBXL_TYPES@@ \*)$$/r_libxl_types.mli.in' \ - < xenlight.mli.in > xenlight.mli.tmp - $(Q)mv xenlight.mli.tmp xenlight.mli - -_libxl_types.ml.in _libxl_types.mli.in _libxl_types.inc: genwrap.py $(XEN_ROOT)/tools/libs/light/libxl_types.idl \ - $(XEN_ROOT)/tools/libs/light/idl.py - PYTHONPATH=$(XEN_ROOT)/tools/libs/light $(PYTHON) genwrap.py \ - $(XEN_ROOT)/tools/libs/light/libxl_types.idl \ - _libxl_types.mli.in _libxl_types.ml.in _libxl_types.inc - -libs: $(LIBS) - -.PHONY: install -install: $(LIBS) META - mkdir -p $(OCAMLDESTDIR) - $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xenlight - $(OCAMLFIND) install -destdir $(OCAMLDESTDIR) -ldconf ignore xenlight META $(INTF) $(LIBS) *.a *.so *.cmx - -.PHONY: uninstall -uninstall: - $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xenlight - -include $(OCAML_TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py deleted file mode 100644 index 7bf26bdcd8..0000000000 --- a/tools/ocaml/libs/xl/genwrap.py +++ /dev/null @@ -1,582 +0,0 @@ -#!/usr/bin/python - -from __future__ import print_function - -import sys,os -from functools import reduce - -import idl - -# typename -> ( ocaml_type, c_from_ocaml, ocaml_from_c ) -builtins = { - "bool": ("bool", "%(c)s = Bool_val(%(o)s)", "Val_bool(%(c)s)" ), - "int": ("int", "%(c)s = Int_val(%(o)s)", "Val_int(%(c)s)" ), - "char *": ("string option", "%(c)s = String_option_val(%(o)s)", "Val_string_option(%(c)s)"), - "libxl_domid": ("domid", "%(c)s = Int_val(%(o)s)", "Val_int(%(c)s)" ), - "libxl_devid": ("devid", "%(c)s = Int_val(%(o)s)", "Val_int(%(c)s)" ), - "libxl_defbool": ("bool option", "%(c)s = Defbool_val(%(o)s)", "Val_defbool(%(c)s)" ), - "libxl_uuid": ("int array", "Uuid_val(&%(c)s, %(o)s)", "Val_uuid(&%(c)s)"), - "libxl_bitmap": ("bool array", "Bitmap_val(ctx, &%(c)s, %(o)s)", "Val_bitmap(&%(c)s)"), - "libxl_key_value_list": ("(string * string) list", "libxl_key_value_list_val(&%(c)s, %(o)s)", "Val_key_value_list(&%(c)s)"), - "libxl_string_list": ("string list", "libxl_string_list_val(&%(c)s, %(o)s)", "Val_string_list(&%(c)s)"), - "libxl_mac": ("int array", "Mac_val(&%(c)s, %(o)s)", "Val_mac(&%(c)s)"), - "libxl_hwcap": ("int32 array", None, "Val_hwcap(&%(c)s)"), - "libxl_ms_vm_genid": ("int array", "Ms_vm_genid_val(&%(c)s, %(o)s)", "Val_ms_vm_genid(&%(c)s)"), - # The following needs to be sorted out later - "libxl_cpuid_policy_list": ("unit", "%(c)s = 0", "Val_unit"), - } - -DEVICE_FUNCTIONS = [ ("add", ["ctx", "t", "domid", "?async:'a", "unit", "unit"]), - ("remove", ["ctx", "t", "domid", "?async:'a", "unit", "unit"]), - ("destroy", ["ctx", "t", "domid", "?async:'a", "unit", "unit"]), - ] -DEVICE_LIST = [ ("list", ["ctx", "domid", "t list"]), - ] - -functions = { # ( name , [type1,type2,....] ) - "device_vfb": DEVICE_FUNCTIONS, - "device_vkb": DEVICE_FUNCTIONS, - "device_disk": DEVICE_FUNCTIONS + DEVICE_LIST + - [ ("insert", ["ctx", "t", "domid", "?async:'a", "unit", "unit"]), - ("of_vdev", ["ctx", "domid", "string", "t"]), - ], - "device_nic": DEVICE_FUNCTIONS + DEVICE_LIST + - [ ("of_devid", ["ctx", "domid", "int", "t"]), - ], - "device_pci": DEVICE_FUNCTIONS + DEVICE_LIST + - [ ("assignable_add", ["ctx", "t", "bool", "unit"]), - ("assignable_remove", ["ctx", "t", "bool", "unit"]), - ("assignable_list", ["ctx", "t list"]), - ], - "dominfo": [ ("list", ["ctx", "t list"]), - ("get", ["ctx", "domid", "t"]), - ], - "physinfo": [ ("get", ["ctx", "t"]), - ], - "cputopology": [ ("get", ["ctx", "t array"]), - ], - "domain_sched_params": - [ ("get", ["ctx", "domid", "t"]), - ("set", ["ctx", "domid", "t", "unit"]), - ], -} -def stub_fn_name(ty, name): - return "stub_xl_%s_%s" % (ty.rawname,name) - -def ocaml_type_of(ty): - if ty.rawname in ["domid","devid"]: - return ty.rawname - elif isinstance(ty,idl.UInt): - if ty.width in [8, 16]: - # handle as ints - width = None - elif ty.width in [32, 64]: - width = ty.width - else: - raise NotImplementedError("Cannot handle %d-bit int" % ty.width) - if width: - return "int%d" % ty.width - else: - return "int" - elif isinstance(ty,idl.Array): - return "%s array" % ocaml_type_of(ty.elem_type) - elif isinstance(ty,idl.Builtin): - if ty.typename not in builtins: - raise NotImplementedError("Unknown Builtin %s (%s)" % (ty.typename, type(ty))) - typename,_,_ = builtins[ty.typename] - if not typename: - raise NotImplementedError("No typename for Builtin %s (%s)" % (ty.typename, type(ty))) - return typename - elif isinstance(ty,idl.KeyedUnion): - return ty.union_name - elif isinstance(ty,idl.Aggregate): - if ty.rawname is None: - return ty.anon_struct - else: - return ty.rawname.capitalize() + ".t" - else: - return ty.rawname - -ocaml_keywords = ['and', 'as', 'assert', 'begin', 'end', 'class', 'constraint', - 'do', 'done', 'downto', 'else', 'if', 'end', 'exception', 'external', 'false', - 'for', 'fun', 'function', 'functor', 'if', 'in', 'include', 'inherit', - 'initializer', 'lazy', 'let', 'match', 'method', 'module', 'mutable', 'new', - 'object', 'of', 'open', 'or', 'private', 'rec', 'sig', 'struct', 'then', 'to', - 'true', 'try', 'type', 'val', 'virtual', 'when', 'while', 'with'] - -def munge_name(name): - if name in ocaml_keywords: - return "xl_" + name - else: - return name - -def ocaml_instance_of_field(f): - if isinstance(f.type, idl.KeyedUnion): - name = f.type.keyvar.name - else: - name = f.name - return "%s : %s" % (munge_name(name), ocaml_type_of(f.type)) - -def gen_struct(ty, indent): - s = "" - for f in ty.fields: - if f.type.private: - continue - x = ocaml_instance_of_field(f) - x = x.replace("\n", "\n"+indent) - s += indent + x + ";\n" - return s - -def gen_ocaml_keyedunions(ty, interface, indent, parent = None): - s = "" - union_type = "" - - if ty.rawname is not None: - # Non-anonymous types need no special handling - pass - elif isinstance(ty, idl.KeyedUnion): - if parent is None: - nparent = ty.keyvar.name - else: - nparent = parent + "_" + ty.keyvar.name - - for f in ty.fields: - if f.type is None: continue - if f.type.rawname is not None: continue - if isinstance(f.type, idl.Struct) and not f.type.has_fields(): continue - s += "\ntype %s_%s =\n" % (nparent,f.name) - s += "{\n" - s += gen_struct(f.type, indent + "\t") - s += "}\n" - - name = "%s__union" % ty.keyvar.name - s += "\n" - s += "type %s = " % name - u = [] - for f in ty.fields: - if f.type is None: - u.append("%s" % (f.name.capitalize())) - elif isinstance(f.type, idl.Struct): - if f.type.rawname is not None: - u.append("%s of %s.t" % (f.name.capitalize(), f.type.rawname.capitalize())) - elif f.type.has_fields(): - u.append("%s of %s_%s" % (f.name.capitalize(), nparent, f.name)) - else: - u.append("%s" % (f.name.capitalize())) - else: - raise NotImplementedError("Cannot handle KeyedUnion fields which are not Structs") - - s += " | ".join(u) + "\n" - ty.union_name = name - - union_type = "?%s:%s" % (munge_name(nparent), ty.keyvar.type.rawname) - - if s == "": - return None, None - return s.replace("\n", "\n%s" % indent), union_type - -def gen_ocaml_anonstruct(ty, interface, indent, parent = None): - s= "" - - if ty.rawname is not None: - # Non-anonymous types need no special handling - pass - elif isinstance(ty, idl.Struct): - name = "%s__anon" % parent - s += "type %s = {\n" % name - s += gen_struct(ty, indent) - s += "}\n" - ty.anon_struct = name - if s == "": - return None - s = indent + s - return s.replace("\n", "\n%s" % indent) - -def gen_ocaml_ml(ty, interface, indent=""): - - if interface: - s = ("""(* %s interface *)\n""" % ty.typename) - else: - s = ("""(* %s implementation *)\n""" % ty.typename) - - if isinstance(ty, idl.Enumeration): - s += "type %s = \n" % ty.rawname - for v in ty.values: - s += "\t | %s\n" % v.rawname - - if interface: - s += "\nval string_of_%s : %s -> string\n" % (ty.rawname, ty.rawname) - else: - s += "\nlet string_of_%s = function\n" % ty.rawname - for v in ty.values: - s += '\t| %s -> "%s"\n' % (v.rawname, v.valuename) - - elif isinstance(ty, idl.Aggregate): - s += "" - - if ty.typename is None: - raise NotImplementedError("%s has no typename" % type(ty)) - else: - - module_name = ty.rawname[0].upper() + ty.rawname[1:] - - if interface: - s += "module %s : sig\n" % module_name - else: - s += "module %s = struct\n" % module_name - - # Handle KeyedUnions... - union_types = [] - for f in ty.fields: - ku, union_type = gen_ocaml_keyedunions(f.type, interface, "\t") - if ku is not None: - s += ku - s += "\n" - if union_type is not None: - union_types.append(union_type) - - # Handle anonymous structs... - for f in ty.fields: - anon = gen_ocaml_anonstruct(f.type, interface, "\t", f.name) - if anon is not None: - s += anon - s += "\n" - - s += "\ttype t =\n" - s += "\t{\n" - s += gen_struct(ty, "\t\t") - s += "\t}\n" - - if ty.init_fn is not None: - union_args = "".join([u + " -> " for u in union_types]) - if interface: - s += "\tval default : ctx -> %sunit -> t\n" % union_args - else: - s += "\texternal default : ctx -> %sunit -> t = \"stub_libxl_%s_init\"\n" % (union_args, ty.rawname) - - if ty.rawname in functions: - for name,args in functions[ty.rawname]: - s += "\texternal %s : " % name - s += " -> ".join(args) - s += " = \"%s\"\n" % stub_fn_name(ty,name) - - s += "end\n" - - else: - raise NotImplementedError("%s" % type(ty)) - return s.replace("\n", "\n%s" % indent) - -def c_val(ty, c, o, indent="", parent = None): - s = indent - if isinstance(ty,idl.UInt): - if ty.width in [8, 16]: - # handle as ints - width = None - elif ty.width in [32, 64]: - width = ty.width - else: - raise NotImplementedError("Cannot handle %d-bit int" % ty.width) - if width: - s += "%s = Int%d_val(%s);" % (c, width, o) - else: - s += "%s = Int_val(%s);" % (c, o) - elif isinstance(ty,idl.Builtin): - if ty.typename not in builtins: - raise NotImplementedError("Unknown Builtin %s (%s)" % (ty.typename, type(ty))) - _,fn,_ = builtins[ty.typename] - if not fn: - raise NotImplementedError("No c_val fn for Builtin %s (%s)" % (ty.typename, type(ty))) - s += "%s;" % (fn % { "o": o, "c": c }) - elif isinstance (ty,idl.Array): - s += "{\n" - s += "\tint i;\n" - s += "\t%s = Wosize_val(%s);\n" % (parent + ty.lenvar.name, o) - s += "\t%s = (%s) calloc(%s, sizeof(*%s));\n" % (c, ty.typename, parent + ty.lenvar.name, c) - s += "\tfor(i=0; i<%s; i++) {\n" % (parent + ty.lenvar.name) - s += c_val(ty.elem_type, c+"[i]", "Field(%s, i)" % o, indent="\t\t", parent=parent) + "\n" - s += "\t}\n" - s += "}\n" - elif isinstance(ty,idl.Enumeration) and (parent is None): - n = 0 - s += "switch(Int_val(%s)) {\n" % o - for e in ty.values: - s += " case %d: *%s = %s; break;\n" % (n, c, e.name) - n += 1 - s += " default: failwith_xl(ERROR_FAIL, \"cannot convert value to %s\"); break;\n" % ty.typename - s += "}" - elif isinstance(ty, idl.KeyedUnion): - s += "{\n" - s += "\tif(Is_long(%s)) {\n" % o - n = 0 - s += "\t\tswitch(Int_val(%s)) {\n" % o - for f in ty.fields: - if f.type is None or not f.type.has_fields(): - s += "\t\t case %d: %s = %s; break;\n" % (n, - parent + ty.keyvar.name, - f.enumname) - n += 1 - s += "\t\t default: failwith_xl(ERROR_FAIL, \"variant handling bug %s%s (long)\"); break;\n" % (parent, ty.keyvar.name) - s += "\t\t}\n" - s += "\t} else {\n" - s += "\t\t/* Is block... */\n" - s += "\t\tswitch(Tag_val(%s)) {\n" % o - n = 0 - for f in ty.fields: - if f.type is not None and f.type.has_fields(): - if f.type.private: - continue - s += "\t\t case %d:\n" % (n) - s += "\t\t %s = %s;\n" % (parent + ty.keyvar.name, f.enumname) - (nparent,fexpr) = ty.member(c, f, False) - s += "%s" % c_val(f.type, fexpr, "Field(%s, 0)" % o, parent=nparent, indent=indent+"\t\t ") - s += "break;\n" - n += 1 - s += "\t\t default: failwith_xl(ERROR_FAIL, \"variant handling bug %s%s (block)\"); break;\n" % (parent, ty.keyvar.name) - s += "\t\t}\n" - s += "\t}\n" - s += "}" - elif isinstance(ty, idl.Aggregate) and (parent is None or ty.rawname is None): - n = 0 - for f in ty.fields: - if f.type.private: - continue - (nparent,fexpr) = ty.member(c, f, ty.rawname is not None) - s += "%s\n" % c_val(f.type, fexpr, "Field(%s, %d)" % (o,n), parent=nparent) - n = n + 1 - else: - s += "%s_val(ctx, %s, %s);" % (ty.rawname, ty.pass_arg(c, parent is None, passby=idl.PASS_BY_REFERENCE), o) - - return s.replace("\n", "\n%s" % indent) - -def gen_c_val(ty, indent=""): - s = "/* Convert caml value to %s */\n" % ty.rawname - - s += "static int %s_val (libxl_ctx *ctx, %s, value v)\n" % (ty.rawname, ty.make_arg("c_val", passby=idl.PASS_BY_REFERENCE)) - s += "{\n" - s += "\tCAMLparam1(v);\n" - s += "\n" - - s += c_val(ty, "c_val", "v", indent="\t") + "\n" - - s += "\tCAMLreturn(0);\n" - s += "}\n" - - return s.replace("\n", "\n%s" % indent) - -def ocaml_Val(ty, o, c, indent="", parent = None): - s = indent - if isinstance(ty,idl.UInt): - if ty.width in [8, 16]: - # handle as ints - width = None - elif ty.width in [32, 64]: - width = ty.width - else: - raise NotImplementedError("Cannot handle %d-bit int" % ty.width) - if width: - s += "%s = caml_copy_int%d(%s);" % (o, width, c) - else: - s += "%s = Val_int(%s);" % (o, c) - elif isinstance(ty,idl.Builtin): - if ty.typename not in builtins: - raise NotImplementedError("Unknown Builtin %s (%s)" % (ty.typename, type(ty))) - _,_,fn = builtins[ty.typename] - if not fn: - raise NotImplementedError("No ocaml Val fn for Builtin %s (%s)" % (ty.typename, type(ty))) - s += "%s = %s;" % (o, fn % { "c": c }) - elif isinstance(ty, idl.Array): - s += "{\n" - s += "\t int i;\n" - s += "\t CAMLlocal1(array_elem);\n" - s += "\t %s = caml_alloc(%s,0);\n" % (o, parent + ty.lenvar.name) - s += "\t for(i=0; i<%s; i++) {\n" % (parent + ty.lenvar.name) - s += "\t %s\n" % ocaml_Val(ty.elem_type, "array_elem", c + "[i]", "", parent=parent) - s += "\t Store_field(%s, i, array_elem);\n" % o - s += "\t }\n" - s += "\t}" - elif isinstance(ty,idl.Enumeration) and (parent is None): - n = 0 - s += "switch(%s) {\n" % c - for e in ty.values: - s += " case %s: %s = Val_int(%d); break;\n" % (e.name, o, n) - n += 1 - s += " default: failwith_xl(ERROR_FAIL, \"cannot convert value from %s\"); break;\n" % ty.typename - s += "}" - elif isinstance(ty, idl.KeyedUnion): - n = 0 - m = 0 - s += "switch(%s) {\n" % (parent + ty.keyvar.name) - for f in ty.fields: - s += "\t case %s:\n" % f.enumname - if f.type is None: - s += "\t /* %d: None */\n" % n - s += "\t %s = Val_long(%d);\n" % (o,n) - n += 1 - elif not f.type.has_fields(): - s += "\t /* %d: Long */\n" % n - s += "\t %s = Val_long(%d);\n" % (o,n) - n += 1 - else: - s += "\t /* %d: Block */\n" % m - (nparent,fexpr) = ty.member(c, f, parent is None) - s += "\t {\n" - s += "\t\t CAMLlocal1(tmp);\n" - s += "\t\t %s = caml_alloc(%d,%d);\n" % (o, 1, m) - s += ocaml_Val(f.type, 'tmp', fexpr, indent="\t\t ", parent=nparent) - s += "\n" - s += "\t\t Store_field(%s, 0, tmp);\n" % o - s += "\t }\n" - m += 1 - #s += "\t %s = caml_alloc(%d,%d);\n" % (o,len(f.type.fields),n) - s += "\t break;\n" - s += "\t default: failwith_xl(ERROR_FAIL, \"cannot convert value from %s\"); break;\n" % ty.typename - s += "\t}" - elif isinstance(ty,idl.Aggregate) and (parent is None or ty.rawname is None): - s += "{\n" - if ty.rawname is None: - fn = "anon_field" - else: - fn = "%s_field" % ty.rawname - s += "\tCAMLlocal1(%s);\n" % fn - s += "\n" - s += "\t%s = caml_alloc_tuple(%d);\n" % (o, len(ty.fields)) - - n = 0 - for f in ty.fields: - if f.type.private: - continue - - (nparent,fexpr) = ty.member(c, f, parent is None) - - s += "\n" - s += "\t%s\n" % ocaml_Val(f.type, fn, ty.pass_arg(fexpr, c), parent=nparent) - s += "\tStore_field(%s, %d, %s);\n" % (o, n, fn) - n = n + 1 - s += "}" - else: - s += "%s = Val_%s(%s);" % (o, ty.rawname, ty.pass_arg(c, parent is None)) - - return s.replace("\n", "\n%s" % indent).rstrip(indent) - -def gen_Val_ocaml(ty, indent=""): - s = "/* Convert %s to a caml value */\n" % ty.rawname - - s += "static value Val_%s (%s)\n" % (ty.rawname, ty.make_arg(ty.rawname+"_c")) - s += "{\n" - s += "\tCAMLparam0();\n" - s += "\tCAMLlocal1(%s_ocaml);\n" % ty.rawname - - s += ocaml_Val(ty, "%s_ocaml" % ty.rawname, "%s_c" % ty.rawname, indent="\t") + "\n" - - s += "\tCAMLreturn(%s_ocaml);\n" % ty.rawname - s += "}\n" - return s.replace("\n", "\n%s" % indent) - -def gen_c_stub_prototype(ty, fns): - s = "/* Stubs for %s */\n" % ty.rawname - for name,args in fns: - # For N args we return one value and take N-1 values as parameters - s += "value %s(" % stub_fn_name(ty, name) - s += ", ".join(["value v%d" % v for v in range(1,len(args))]) - s += ");\n" - return s - -def gen_c_default(ty): - s = "/* Get the defaults for %s */\n" % ty.rawname - # Handle KeyedUnions... - union_types = [] - for f in ty.fields: - if isinstance(f.type, idl.KeyedUnion): - union_types.append(f.type.keyvar) - - s += "value stub_libxl_%s_init(value ctx, %svalue unit)\n" % (ty.rawname, - "".join(["value " + u.name + ", " for u in union_types])) - s += "{\n" - s += "\tCAMLparam%d(ctx, %sunit);\n" % (len(union_types) + 2, "".join([u.name + ", " for u in union_types])) - s += "\tCAMLlocal1(val);\n" - s += "\tlibxl_%s c_val;\n" % ty.rawname - s += "\tlibxl_%s_init(&c_val);\n" % ty.rawname - for u in union_types: - s += "\tif (%s != Val_none) {\n" % u.name - s += "\t\t%s c = 0;\n" % u.type.typename - s += "\t\t%s_val(CTX, &c, Some_val(%s));\n" % (u.type.rawname, u.name) - s += "\t\tlibxl_%s_init_%s(&c_val, c);\n" % (ty.rawname, u.name) - s += "\t}\n" - s += "\tval = Val_%s(&c_val);\n" % ty.rawname - if ty.dispose_fn: - s += "\tlibxl_%s_dispose(&c_val);\n" % ty.rawname - s += "\tCAMLreturn(val);\n" - s += "}\n" - return s - -def gen_c_defaults(ty): - s = gen_c_default(ty) - return s - -def autogen_header(open_comment, close_comment): - s = open_comment + " AUTO-GENERATED FILE DO NOT EDIT " + close_comment + "\n" - s += open_comment + " autogenerated by \n" - s += reduce(lambda x,y: x + " ", range(len(open_comment + " ")), "") - s += "%s" % " ".join(sys.argv) - s += "\n " + close_comment + "\n\n" - return s - -if __name__ == '__main__': - if len(sys.argv) < 4: - print("Usage: genwrap.py ", file=sys.stderr) - sys.exit(1) - - (_,types) = idl.parse(sys.argv[1]) - - # Do not generate these yet. - blacklist = [ - "cpupoolinfo", - "vcpuinfo", - ] - - for t in blacklist: - if t not in [ty.rawname for ty in types]: - print("unknown type %s in blacklist" % t) - - types = [ty for ty in types if not ty.rawname in blacklist] - - _ml = sys.argv[3] - ml = open(_ml, 'w') - ml.write(autogen_header("(*", "*)")) - - _mli = sys.argv[2] - mli = open(_mli, 'w') - mli.write(autogen_header("(*", "*)")) - - _cinc = sys.argv[4] - cinc = open(_cinc, 'w') - cinc.write(autogen_header("/*", "*/")) - - for ty in types: - if ty.private: - continue - #sys.stdout.write(" TYPE %-20s " % ty.rawname) - ml.write(gen_ocaml_ml(ty, False)) - ml.write("\n") - - mli.write(gen_ocaml_ml(ty, True)) - mli.write("\n") - - if ty.marshal_in(): - cinc.write(gen_c_val(ty)) - cinc.write("\n") - cinc.write(gen_Val_ocaml(ty)) - cinc.write("\n") - if ty.rawname in functions: - cinc.write(gen_c_stub_prototype(ty, functions[ty.rawname])) - cinc.write("\n") - if ty.init_fn is not None: - cinc.write(gen_c_defaults(ty)) - cinc.write("\n") - #sys.stdout.write("\n") - - ml.write("(* END OF AUTO-GENERATED CODE *)\n") - ml.close() - mli.write("(* END OF AUTO-GENERATED CODE *)\n") - mli.close() - cinc.close() diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in deleted file mode 100644 index 6989bb6638..0000000000 --- a/tools/ocaml/libs/xl/xenlight.ml.in +++ /dev/null @@ -1,94 +0,0 @@ -(* - * Copyright (C) 2009-2011 Citrix Ltd. - * Author Vincent Hanquez - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -type ctx -type domid = int -type devid = int - -(* @@LIBXL_TYPES@@ *) - -exception Error of (error * string) - -external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc" - -external test_raise_exception: unit -> unit = "stub_raise_exception" - -type event = - | POLLIN (* There is data to read *) - | POLLPRI (* There is urgent data to read *) - | POLLOUT (* Writing now will not block *) - | POLLERR (* Error condition (revents only) *) - | POLLHUP (* Device has been disconnected (revents only) *) - | POLLNVAL (* Invalid request: fd not open (revents only). *) - -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 -> ?async:'a -> unit -> unit = "stub_libxl_domain_shutdown" - external reboot : ctx -> domid -> ?async:'a -> unit -> 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 -> ?async:'a -> unit = "stub_libxl_domain_pause" - external unpause : ctx -> domid -> ?async:'a -> unit = "stub_libxl_domain_unpause" - - external send_trigger : ctx -> domid -> trigger -> int -> ?async:'a -> unit = "stub_xl_send_trigger" - external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq" -end - -module Host = struct - type console_reader - exception End_of_file - - external xen_console_read_start : ctx -> int -> console_reader = "stub_libxl_xen_console_read_start" - external xen_console_read_line : ctx -> console_reader -> string = "stub_libxl_xen_console_read_line" - external xen_console_read_finish : ctx -> console_reader -> unit = "stub_libxl_xen_console_read_finish" - - external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys" -end - -module Async = struct - type for_libxl - type event_hooks - type osevent_hooks - - external osevent_register_hooks' : ctx -> 'a -> osevent_hooks = "stub_libxl_osevent_register_hooks" - external osevent_occurred_fd : ctx -> for_libxl -> Unix.file_descr -> event list -> event list -> unit = "stub_libxl_osevent_occurred_fd" - external osevent_occurred_timeout : ctx -> for_libxl -> unit = "stub_libxl_osevent_occurred_timeout" - - let osevent_register_hooks ctx ~user ~fd_register ~fd_modify ~fd_deregister ~timeout_register ~timeout_fire_now = - Callback.register "libxl_fd_register" fd_register; - Callback.register "libxl_fd_modify" fd_modify; - Callback.register "libxl_fd_deregister" fd_deregister; - Callback.register "libxl_timeout_register" timeout_register; - Callback.register "libxl_timeout_fire_now" timeout_fire_now; - osevent_register_hooks' ctx user - - let async_register_callback ~async_callback = - Callback.register "libxl_async_callback" async_callback - - external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death" - external event_register_callbacks' : ctx -> 'a -> event_hooks = "stub_libxl_event_register_callbacks" - - let event_register_callbacks ctx ~user ~event_occurs_callback ~event_disaster_callback = - Callback.register "libxl_event_occurs_callback" event_occurs_callback; - Callback.register "libxl_event_disaster_callback" event_disaster_callback; - event_register_callbacks' ctx user -end - -let register_exceptions () = - Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, "")); - Callback.register_exception "Xenlight.Host.End_of_file" (Host.End_of_file) - diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in deleted file mode 100644 index b98a3db7e7..0000000000 --- a/tools/ocaml/libs/xl/xenlight.mli.in +++ /dev/null @@ -1,93 +0,0 @@ -(* - * Copyright (C) 2009-2011 Citrix Ltd. - * Author Vincent Hanquez - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -type ctx -type domid = int -type devid = int - -(* @@LIBXL_TYPES@@ *) - -exception Error of (error * string) - -val register_exceptions: unit -> unit - -external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc" - -external test_raise_exception: unit -> unit = "stub_raise_exception" - -type event = - | POLLIN (* There is data to read *) - | POLLPRI (* There is urgent data to read *) - | POLLOUT (* Writing now will not block *) - | POLLERR (* Error condition (revents only) *) - | POLLHUP (* Device has been disconnected (revents only) *) - | POLLNVAL (* Invalid request: fd not open (revents only). *) - -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 -> ?async:'a -> unit -> unit = "stub_libxl_domain_shutdown" - external reboot : ctx -> domid -> ?async:'a -> unit -> 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 -> ?async:'a -> unit = "stub_libxl_domain_pause" - external unpause : ctx -> domid -> ?async:'a -> unit = "stub_libxl_domain_unpause" - - external send_trigger : ctx -> domid -> trigger -> int -> ?async:'a -> unit = "stub_xl_send_trigger" - external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq" -end - -module Host : sig - type console_reader - exception End_of_file - - external xen_console_read_start : ctx -> int -> console_reader = "stub_libxl_xen_console_read_start" - external xen_console_read_line : ctx -> console_reader -> string = "stub_libxl_xen_console_read_line" - external xen_console_read_finish : ctx -> console_reader -> unit = "stub_libxl_xen_console_read_finish" - - external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys" -end - -module Async : sig - type for_libxl - type event_hooks - type osevent_hooks - - val osevent_register_hooks : ctx -> - user:'a -> - fd_register:('a -> Unix.file_descr -> event list -> for_libxl -> 'b) -> - fd_modify:('a -> Unix.file_descr -> 'b -> event list -> 'b) -> - fd_deregister:('a -> Unix.file_descr -> 'b -> unit) -> - timeout_register:('a -> int64 -> int64 -> for_libxl -> 'c) -> - timeout_fire_now:('a -> 'c -> 'c) -> - osevent_hooks - - external osevent_occurred_fd : ctx -> for_libxl -> Unix.file_descr -> event list -> event list -> unit = "stub_libxl_osevent_occurred_fd" - external osevent_occurred_timeout : ctx -> for_libxl -> unit = "stub_libxl_osevent_occurred_timeout" - - val async_register_callback : - async_callback:(result:error option -> user:'a -> unit) -> - unit - - external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death" - - val event_register_callbacks : ctx -> - user:'a -> - event_occurs_callback:('a -> Event.t -> unit) -> - event_disaster_callback:('a -> event_type -> string -> int -> unit) -> - event_hooks -end - diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c deleted file mode 100644 index 45b8af61c7..0000000000 --- a/tools/ocaml/libs/xl/xenlight_stubs.c +++ /dev/null @@ -1,1663 +0,0 @@ -/* - * Copyright (C) 2009-2011 Citrix Ltd. - * Author Vincent Hanquez - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - */ - -#include - -#define CAML_NAME_SPACE -#include -#include -#include -#include -#include -#include - -#include -#include -#include - -#include -#include - -#include -#include - -#include "caml_xentoollog.h" - -/* - * Starting with ocaml-3.09.3, CAMLreturn can only be used for ``value'' - * types. CAMLreturnT was only added in 3.09.4, so we define our own - * version here if needed. - */ -#ifndef CAMLreturnT -#define CAMLreturnT(type, result) do { \ - type caml__temp_result = (result); \ - caml_local_roots = caml__frame; \ - return (caml__temp_result); \ -} while (0) -#endif - -/* The following is equal to the CAMLreturn macro, but without the return */ -#define CAMLdone do{ \ -caml_local_roots = caml__frame; \ -}while (0) - -#define Ctx_val(x)(*((libxl_ctx **) Data_custom_val(x))) -#define CTX ((libxl_ctx *) Ctx_val(ctx)) - -static char * dup_String_val(value s) -{ - int len; - char *c; - len = caml_string_length(s); - c = calloc(len + 1, sizeof(char)); - if (!c) - caml_raise_out_of_memory(); - memcpy(c, String_val(s), len); - return c; -} - -/* Forward reference: this is defined in the auto-generated include file below. */ -static value Val_error (libxl_error error_c); - -static void failwith_xl(int error, char *fname) -{ - CAMLparam0(); - CAMLlocal1(arg); - static const value *exc = NULL; - - /* First time around, lookup by name */ - if (!exc) - exc = caml_named_value("Xenlight.Error"); - - if (!exc) - caml_invalid_argument("Exception Xenlight.Error not initialized, please link xenlight.cma"); - - arg = caml_alloc(2, 0); - - Store_field(arg, 0, Val_error(error)); - Store_field(arg, 1, caml_copy_string(fname)); - - caml_raise_with_arg(*exc, arg); - CAMLreturn0; -} - -CAMLprim value stub_raise_exception(value unit) -{ - CAMLparam1(unit); - failwith_xl(ERROR_FAIL, "test exception"); - CAMLreturn(Val_unit); -} - -void ctx_finalize(value ctx) -{ - libxl_ctx_free(CTX); -} - -static struct custom_operations libxl_ctx_custom_operations = { - "libxl_ctx_custom_operations", - ctx_finalize /* custom_finalize_default */, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -CAMLprim value stub_libxl_ctx_alloc(value logger) -{ - CAMLparam1(logger); - CAMLlocal1(handle); - libxl_ctx *ctx; - int ret; - - ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (xentoollog_logger *) Xtl_val(logger)); - if (ret != 0) \ - failwith_xl(ERROR_FAIL, "cannot init context"); - - handle = caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0, 1); - Ctx_val(handle) = ctx; - - CAMLreturn(handle); -} - -static int list_len(value v) -{ - int len = 0; - while ( v != Val_emptylist ) { - len++; - v = Field(v, 1); - } - return len; -} - -static int libxl_key_value_list_val(libxl_key_value_list *c_val, - value v) -{ - CAMLparam1(v); - CAMLlocal1(elem); - int nr, i; - libxl_key_value_list array; - - nr = list_len(v); - - array = calloc((nr + 1) * 2, sizeof(char *)); - if (!array) - caml_raise_out_of_memory(); - - for (i=0; v != Val_emptylist; i++, v = Field(v, 1) ) { - elem = Field(v, 0); - - array[i * 2] = dup_String_val(Field(elem, 0)); - array[i * 2 + 1] = dup_String_val(Field(elem, 1)); - } - - *c_val = array; - CAMLreturn(0); -} - -static value Val_key_value_list(libxl_key_value_list *c_val) -{ - CAMLparam0(); - CAMLlocal5(list, cons, key, val, kv); - int i; - - list = Val_emptylist; - for (i = libxl_string_list_length((libxl_string_list *) c_val) - 1; i >= 0; i -= 2) { - val = caml_copy_string((*c_val)[i]); - key = caml_copy_string((*c_val)[i - 1]); - kv = caml_alloc_tuple(2); - Store_field(kv, 0, key); - Store_field(kv, 1, val); - - cons = caml_alloc(2, 0); - Store_field(cons, 0, kv); // head - Store_field(cons, 1, list); // tail - list = cons; - } - - CAMLreturn(list); -} - -static int libxl_string_list_val(libxl_string_list *c_val, value v) -{ - CAMLparam1(v); - int nr, i; - libxl_string_list array; - - nr = list_len(v); - - array = calloc(nr + 1, sizeof(char *)); - if (!array) - caml_raise_out_of_memory(); - - for (i=0; v != Val_emptylist; i++, v = Field(v, 1) ) - array[i] = dup_String_val(Field(v, 0)); - - *c_val = array; - CAMLreturn(0); -} - -static value Val_string_list(libxl_string_list *c_val) -{ - CAMLparam0(); - CAMLlocal3(list, cons, string); - int i; - - list = Val_emptylist; - for (i = libxl_string_list_length(c_val) - 1; i >= 0; i--) { - string = caml_copy_string((*c_val)[i]); - cons = caml_alloc(2, 0); - Store_field(cons, 0, string); // head - Store_field(cons, 1, list); // tail - list = cons; - } - - CAMLreturn(list); -} - -/* Option type support as per http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php */ -#ifndef Val_none -#define Val_none Val_int(0) -#endif -#ifndef Some_val -#define Some_val(v) Field(v,0) -#endif - -static value Val_some(value v) -{ - CAMLparam1(v); - CAMLlocal1(some); - some = caml_alloc(1, 0); - Store_field(some, 0, v); - CAMLreturn(some); -} - -static value Val_mac (libxl_mac *c_val) -{ - CAMLparam0(); - CAMLlocal1(v); - int i; - - v = caml_alloc_tuple(6); - - for(i=0; i<6; i++) - Store_field(v, i, Val_int((*c_val)[i])); - - CAMLreturn(v); -} - -static int Mac_val(libxl_mac *c_val, value v) -{ - CAMLparam1(v); - int i; - - for(i=0; i<6; i++) - (*c_val)[i] = Int_val(Field(v, i)); - - CAMLreturn(0); -} - -static value Val_bitmap (libxl_bitmap *c_val) -{ - CAMLparam0(); - CAMLlocal1(v); - int i; - - if (c_val->size == 0) - v = Atom(0); - else { - v = caml_alloc(8 * (c_val->size), 0); - libxl_for_each_bit(i, *c_val) { - if (libxl_bitmap_test(c_val, i)) - Store_field(v, i, Val_true); - else - Store_field(v, i, Val_false); - } - } - CAMLreturn(v); -} - -static int Bitmap_val(libxl_ctx *ctx, libxl_bitmap *c_val, value v) -{ - CAMLparam1(v); - int i, len = Wosize_val(v); - - c_val->size = 0; - if (len > 0 && libxl_bitmap_alloc(ctx, c_val, len)) - failwith_xl(ERROR_NOMEM, "cannot allocate bitmap"); - for (i=0; ibytes[i])); - - CAMLreturn(v); -} - -static int Ms_vm_genid_val(libxl_ms_vm_genid *c_val, value v) -{ - CAMLparam1(v); - int i; - - for(i=0; ibytes[i] = Int_val(Field(v, i)); - - CAMLreturn(0); -} - -static value Val_string_option(const char *c_val) -{ - CAMLparam0(); - CAMLlocal2(tmp1, tmp2); - if (c_val) { - tmp1 = caml_copy_string(c_val); - tmp2 = Val_some(tmp1); - CAMLreturn(tmp2); - } - else - CAMLreturn(Val_none); -} - -static char *String_option_val(value v) -{ - CAMLparam1(v); - char *s = NULL; - if (v != Val_none) - s = dup_String_val(Some_val(v)); - CAMLreturnT(char *, s); -} - -#include "_libxl_types.inc" - -void async_callback(libxl_ctx *ctx, int rc, void *for_callback) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocal2(error, tmp); - static const value *func = NULL; - value *p = (value *) for_callback; - - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_async_callback"); - } - - if (rc == 0) - error = Val_none; - else { - tmp = Val_error(rc); - error = Val_some(tmp); - } - - /* for_callback is a pointer to a "value" that was malloc'ed and - * registered with the OCaml GC. The value is handed back to OCaml - * in the following callback, after which the pointer is unregistered - * and freed. */ - caml_callback2(*func, error, *p); - - caml_remove_global_root(p); - free(p); - - CAMLdone; - caml_enter_blocking_section(); -} - -static libxl_asyncop_how *aohow_val(value async) -{ - CAMLparam1(async); - libxl_asyncop_how *ao_how = NULL; - 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 = malloc(sizeof(*ao_how)); - ao_how->callback = async_callback; - ao_how->u.for_callback = (void *) p; - } - - CAMLreturnT(libxl_asyncop_how *, ao_how); -} - -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"); - } - - ao_how = aohow_val(async); - - caml_enter_blocking_section(); - ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid, ao_how, NULL); - caml_leave_blocking_section(); - - free(ao_how); - 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; - int restore_fd; - - 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"); - } - - ao_how = aohow_val(async); - restore_fd = Int_val(Field(params, 0)); - - caml_enter_blocking_section(); - ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, restore_fd, - -1, &c_params, ao_how, NULL); - caml_leave_blocking_section(); - - free(ao_how); - 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, value async, value unit) -{ - CAMLparam4(ctx, domid, async, unit); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); - - caml_enter_blocking_section(); - ret = libxl_domain_shutdown(CTX, c_domid, ao_how); - caml_leave_blocking_section(); - - free(ao_how); - - if (ret != 0) - failwith_xl(ret, "domain_shutdown"); - - CAMLreturn(Val_unit); -} - -value stub_libxl_domain_reboot(value ctx, value domid, value async, value unit) -{ - CAMLparam4(ctx, domid, async, unit); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); - - caml_enter_blocking_section(); - ret = libxl_domain_reboot(CTX, c_domid, ao_how); - caml_leave_blocking_section(); - - free(ao_how); - - 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; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); - - caml_enter_blocking_section(); - ret = libxl_domain_destroy(CTX, c_domid, ao_how); - caml_leave_blocking_section(); - - free(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; - uint32_t c_domid = Int_val(domid); - int c_fd = Int_val(fd); - libxl_asyncop_how *ao_how = aohow_val(async); - - caml_enter_blocking_section(); - ret = libxl_domain_suspend(CTX, c_domid, c_fd, 0, ao_how); - caml_leave_blocking_section(); - - free(ao_how); - - if (ret != 0) - failwith_xl(ret, "domain_suspend"); - - CAMLreturn(Val_unit); -} - -value stub_libxl_domain_pause(value ctx, value domid, value async) -{ - CAMLparam3(ctx, domid, async); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); - - caml_enter_blocking_section(); - ret = libxl_domain_pause(CTX, c_domid, ao_how); - caml_leave_blocking_section(); - - free(ao_how); - - if (ret != 0) - failwith_xl(ret, "domain_pause"); - - CAMLreturn(Val_unit); -} - -value stub_libxl_domain_unpause(value ctx, value domid, value async) -{ - CAMLparam3(ctx, domid, async); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); - - caml_enter_blocking_section(); - ret = libxl_domain_unpause(CTX, c_domid, ao_how); - caml_leave_blocking_section(); - - free(ao_how); - - if (ret != 0) - failwith_xl(ret, "domain_unpause"); - - CAMLreturn(Val_unit); -} - -#define _STRINGIFY(x) #x -#define STRINGIFY(x) _STRINGIFY(x) - -#define _DEVICE_ADDREMOVE(type,fn,op) \ -value stub_xl_device_##type##_##op(value ctx, value info, value domid, \ - value async, value unit) \ -{ \ - CAMLparam5(ctx, info, domid, async, unit); \ - libxl_device_##type c_info; \ - int ret, marker_var; \ - uint32_t c_domid = Int_val(domid); \ - libxl_asyncop_how *ao_how = aohow_val(async); \ - \ - device_##type##_val(CTX, &c_info, info); \ - \ - caml_enter_blocking_section(); \ - ret = libxl_##fn##_##op(CTX, c_domid, &c_info, ao_how); \ - caml_leave_blocking_section(); \ - \ - free(ao_how); \ - libxl_device_##type##_dispose(&c_info); \ - \ - if (ret != 0) \ - failwith_xl(ret, STRINGIFY(type) "_" STRINGIFY(op)); \ - \ - CAMLreturn(Val_unit); \ -} - -#define DEVICE_ADDREMOVE(type) \ - _DEVICE_ADDREMOVE(type, device_##type, add) \ - _DEVICE_ADDREMOVE(type, device_##type, remove) \ - _DEVICE_ADDREMOVE(type, device_##type, destroy) - -DEVICE_ADDREMOVE(disk) -DEVICE_ADDREMOVE(nic) -DEVICE_ADDREMOVE(vfb) -DEVICE_ADDREMOVE(vkb) -DEVICE_ADDREMOVE(pci) -_DEVICE_ADDREMOVE(disk, cdrom, insert) - -value stub_xl_device_nic_of_devid(value ctx, value domid, value devid) -{ - CAMLparam3(ctx, domid, devid); - CAMLlocal1(nic); - libxl_device_nic c_nic; - uint32_t c_domid = Int_val(domid); - int c_devid = Int_val(devid); - - caml_enter_blocking_section(); - libxl_devid_to_device_nic(CTX, c_domid, c_devid, &c_nic); - caml_leave_blocking_section(); - - nic = Val_device_nic(&c_nic); - libxl_device_nic_dispose(&c_nic); - - CAMLreturn(nic); -} - -value stub_xl_device_nic_list(value ctx, value domid) -{ - CAMLparam2(ctx, domid); - CAMLlocal2(list, temp); - libxl_device_nic *c_list; - int i, nb; - uint32_t c_domid = Int_val(domid); - - caml_enter_blocking_section(); - c_list = libxl_device_nic_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); - - if (!c_list) - failwith_xl(ERROR_FAIL, "nic_list"); - - list = temp = Val_emptylist; - for (i = 0; i < nb; i++) { - list = caml_alloc_small(2, Tag_cons); - Field(list, 0) = Val_int(0); - Field(list, 1) = temp; - temp = list; - Store_field(list, 0, Val_device_nic(&c_list[i])); - } - libxl_device_nic_list_free(c_list, nb); - - CAMLreturn(list); -} - -value stub_xl_device_disk_list(value ctx, value domid) -{ - CAMLparam2(ctx, domid); - CAMLlocal2(list, temp); - libxl_device_disk *c_list; - int i, nb; - uint32_t c_domid = Int_val(domid); - - caml_enter_blocking_section(); - c_list = libxl_device_disk_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); - - if (!c_list) - failwith_xl(ERROR_FAIL, "disk_list"); - - list = temp = Val_emptylist; - for (i = 0; i < nb; i++) { - list = caml_alloc_small(2, Tag_cons); - Field(list, 0) = Val_int(0); - Field(list, 1) = temp; - temp = list; - Store_field(list, 0, Val_device_disk(&c_list[i])); - } - libxl_device_disk_list_free(c_list, nb); - - CAMLreturn(list); -} - -value stub_xl_device_disk_of_vdev(value ctx, value domid, value vdev) -{ - CAMLparam3(ctx, domid, vdev); - CAMLlocal1(disk); - libxl_device_disk c_disk; - char *c_vdev; - uint32_t c_domid = Int_val(domid); - - c_vdev = strdup(String_val(vdev)); - - caml_enter_blocking_section(); - libxl_vdev_to_device_disk(CTX, c_domid, c_vdev, &c_disk); - caml_leave_blocking_section(); - - disk = Val_device_disk(&c_disk); - libxl_device_disk_dispose(&c_disk); - free(c_vdev); - - CAMLreturn(disk); -} - -value stub_xl_device_pci_list(value ctx, value domid) -{ - CAMLparam2(ctx, domid); - CAMLlocal2(list, temp); - libxl_device_pci *c_list; - int i, nb; - uint32_t c_domid = Int_val(domid); - - caml_enter_blocking_section(); - c_list = libxl_device_pci_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); - - if (!c_list) - failwith_xl(ERROR_FAIL, "pci_list"); - - list = temp = Val_emptylist; - for (i = 0; i < nb; i++) { - list = caml_alloc_small(2, Tag_cons); - Field(list, 0) = Val_int(0); - Field(list, 1) = temp; - temp = list; - Store_field(list, 0, Val_device_pci(&c_list[i])); - libxl_device_pci_dispose(&c_list[i]); - } - free(c_list); - - CAMLreturn(list); -} - -value stub_xl_device_pci_assignable_add(value ctx, value info, value rebind) -{ - CAMLparam3(ctx, info, rebind); - libxl_device_pci c_info; - int ret, marker_var; - int c_rebind = (int) Bool_val(rebind); - - device_pci_val(CTX, &c_info, info); - - caml_enter_blocking_section(); - ret = libxl_device_pci_assignable_add(CTX, &c_info, c_rebind); - caml_leave_blocking_section(); - - libxl_device_pci_dispose(&c_info); - - if (ret != 0) - failwith_xl(ret, "pci_assignable_add"); - - CAMLreturn(Val_unit); -} - -value stub_xl_device_pci_assignable_remove(value ctx, value info, value rebind) -{ - CAMLparam3(ctx, info, rebind); - libxl_device_pci c_info; - int ret, marker_var; - int c_rebind = (int) Bool_val(rebind); - - device_pci_val(CTX, &c_info, info); - - caml_enter_blocking_section(); - ret = libxl_device_pci_assignable_remove(CTX, &c_info, c_rebind); - caml_leave_blocking_section(); - - libxl_device_pci_dispose(&c_info); - - if (ret != 0) - failwith_xl(ret, "pci_assignable_remove"); - - CAMLreturn(Val_unit); -} - -value stub_xl_device_pci_assignable_list(value ctx) -{ - CAMLparam1(ctx); - CAMLlocal2(list, temp); - libxl_device_pci *c_list; - int i, nb; - uint32_t c_domid; - - caml_enter_blocking_section(); - c_list = libxl_device_pci_assignable_list(CTX, &nb); - caml_leave_blocking_section(); - - if (!c_list) - failwith_xl(ERROR_FAIL, "pci_assignable_list"); - - list = temp = Val_emptylist; - for (i = 0; i < nb; i++) { - list = caml_alloc_small(2, Tag_cons); - Field(list, 0) = Val_int(0); - Field(list, 1) = temp; - temp = list; - Store_field(list, 0, Val_device_pci(&c_list[i])); - } - libxl_device_pci_assignable_list_free(c_list, nb); - - CAMLreturn(list); -} - -value stub_xl_physinfo_get(value ctx) -{ - CAMLparam1(ctx); - CAMLlocal1(physinfo); - libxl_physinfo c_physinfo; - int ret; - - caml_enter_blocking_section(); - ret = libxl_get_physinfo(CTX, &c_physinfo); - caml_leave_blocking_section(); - - if (ret != 0) - failwith_xl(ret, "get_physinfo"); - - physinfo = Val_physinfo(&c_physinfo); - - libxl_physinfo_dispose(&c_physinfo); - - CAMLreturn(physinfo); -} - -value stub_xl_cputopology_get(value ctx) -{ - CAMLparam1(ctx); - CAMLlocal3(topology, v, v0); - libxl_cputopology *c_topology; - int i, nr; - - caml_enter_blocking_section(); - c_topology = libxl_get_cpu_topology(CTX, &nr); - caml_leave_blocking_section(); - - if (!c_topology) - failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo"); - - topology = caml_alloc_tuple(nr); - for (i = 0; i < nr; i++) { - if (c_topology[i].core != LIBXL_CPUTOPOLOGY_INVALID_ENTRY) { - v0 = Val_cputopology(&c_topology[i]); - v = Val_some(v0); - } - else - v = Val_none; - Store_field(topology, i, v); - } - - libxl_cputopology_list_free(c_topology, nr); - - CAMLreturn(topology); -} - -value stub_xl_dominfo_list(value ctx) -{ - CAMLparam1(ctx); - CAMLlocal2(domlist, temp); - libxl_dominfo *c_domlist; - int i, nb; - - caml_enter_blocking_section(); - c_domlist = libxl_list_domain(CTX, &nb); - caml_leave_blocking_section(); - - if (!c_domlist) - failwith_xl(ERROR_FAIL, "dominfo_list"); - - domlist = temp = Val_emptylist; - for (i = nb - 1; i >= 0; i--) { - domlist = caml_alloc_small(2, Tag_cons); - Field(domlist, 0) = Val_int(0); - Field(domlist, 1) = temp; - temp = domlist; - - Store_field(domlist, 0, Val_dominfo(&c_domlist[i])); - } - - libxl_dominfo_list_free(c_domlist, nb); - - CAMLreturn(domlist); -} - -value stub_xl_dominfo_get(value ctx, value domid) -{ - CAMLparam2(ctx, domid); - CAMLlocal1(dominfo); - libxl_dominfo c_dominfo; - int ret; - uint32_t c_domid = Int_val(domid); - - caml_enter_blocking_section(); - ret = libxl_domain_info(CTX, &c_dominfo, c_domid); - caml_leave_blocking_section(); - - if (ret != 0) - failwith_xl(ERROR_FAIL, "domain_info"); - dominfo = Val_dominfo(&c_dominfo); - - CAMLreturn(dominfo); -} - -value stub_xl_domain_sched_params_get(value ctx, value domid) -{ - CAMLparam2(ctx, domid); - CAMLlocal1(scinfo); - libxl_domain_sched_params c_scinfo; - int ret; - uint32_t c_domid = Int_val(domid); - - caml_enter_blocking_section(); - ret = libxl_domain_sched_params_get(CTX, c_domid, &c_scinfo); - caml_leave_blocking_section(); - - if (ret != 0) - failwith_xl(ret, "domain_sched_params_get"); - - scinfo = Val_domain_sched_params(&c_scinfo); - - libxl_domain_sched_params_dispose(&c_scinfo); - - CAMLreturn(scinfo); -} - -value stub_xl_domain_sched_params_set(value ctx, value domid, value scinfo) -{ - CAMLparam3(ctx, domid, scinfo); - libxl_domain_sched_params c_scinfo; - int ret; - uint32_t c_domid = Int_val(domid); - - domain_sched_params_val(CTX, &c_scinfo, scinfo); - - caml_enter_blocking_section(); - ret = libxl_domain_sched_params_set(CTX, c_domid, &c_scinfo); - caml_leave_blocking_section(); - - libxl_domain_sched_params_dispose(&c_scinfo); - - if (ret != 0) - failwith_xl(ret, "domain_sched_params_set"); - - CAMLreturn(Val_unit); -} - -value stub_xl_send_trigger(value ctx, value domid, value trigger, value vcpuid, value async) -{ - CAMLparam5(ctx, domid, trigger, vcpuid, async); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_trigger c_trigger = LIBXL_TRIGGER_UNKNOWN; - int c_vcpuid = Int_val(vcpuid); - libxl_asyncop_how *ao_how = aohow_val(async); - - trigger_val(CTX, &c_trigger, trigger); - - caml_enter_blocking_section(); - ret = libxl_send_trigger(CTX, c_domid, c_trigger, c_vcpuid, ao_how); - caml_leave_blocking_section(); - - free(ao_how); - - if (ret != 0) - failwith_xl(ret, "send_trigger"); - - CAMLreturn(Val_unit); -} - -value stub_xl_send_sysrq(value ctx, value domid, value sysrq) -{ - CAMLparam3(ctx, domid, sysrq); - int ret; - uint32_t c_domid = Int_val(domid); - int c_sysrq = Int_val(sysrq); - - caml_enter_blocking_section(); - ret = libxl_send_sysrq(CTX, c_domid, c_sysrq); - caml_leave_blocking_section(); - - if (ret != 0) - failwith_xl(ret, "send_sysrq"); - - CAMLreturn(Val_unit); -} - -value stub_xl_send_debug_keys(value ctx, value keys) -{ - CAMLparam2(ctx, keys); - int ret; - char *c_keys; - - c_keys = dup_String_val(keys); - - caml_enter_blocking_section(); - ret = libxl_send_debug_keys(CTX, c_keys); - caml_leave_blocking_section(); - - free(c_keys); - - if (ret != 0) - failwith_xl(ret, "send_debug_keys"); - - CAMLreturn(Val_unit); -} - -static struct custom_operations libxl_console_reader_custom_operations = { - "libxl_console_reader_custom_operations", - custom_finalize_default, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -#define Console_reader_val(x)(*((libxl_xen_console_reader **) Data_custom_val(x))) - -value stub_libxl_xen_console_read_start(value ctx, value clear) -{ - CAMLparam2(ctx, clear); - CAMLlocal1(handle); - int c_clear = Int_val(clear); - libxl_xen_console_reader *cr; - - caml_enter_blocking_section(); - cr = libxl_xen_console_read_start(CTX, c_clear); - caml_leave_blocking_section(); - - handle = caml_alloc_custom(&libxl_console_reader_custom_operations, sizeof(cr), 0, 1); - Console_reader_val(handle) = cr; - - CAMLreturn(handle); -} - -static void raise_eof(void) -{ - static const value *exc = NULL; - - /* First time around, lookup by name */ - if (!exc) - exc = caml_named_value("Xenlight.Host.End_of_file"); - - if (!exc) - caml_invalid_argument("Exception Xenlight.Host.End_of_file not initialized, please link xenlight.cma"); - - caml_raise_constant(*exc); -} - -value stub_libxl_xen_console_read_line(value ctx, value reader) -{ - CAMLparam2(ctx, reader); - CAMLlocal1(line); - int ret; - char *c_line; - libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader); - - caml_enter_blocking_section(); - ret = libxl_xen_console_read_line(CTX, cr, &c_line); - caml_leave_blocking_section(); - - if (ret < 0) - failwith_xl(ret, "xen_console_read_line"); - if (ret == 0) - raise_eof(); - - line = caml_copy_string(c_line); - - CAMLreturn(line); -} - -value stub_libxl_xen_console_read_finish(value ctx, value reader) -{ - CAMLparam2(ctx, reader); - libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader); - - caml_enter_blocking_section(); - libxl_xen_console_read_finish(CTX, cr); - caml_leave_blocking_section(); - - CAMLreturn(Val_unit); -} - -/* Event handling */ - -short Poll_val(value event) -{ - CAMLparam1(event); - short res = -1; - - switch (Int_val(event)) { - case 0: res = POLLIN; break; - case 1: res = POLLPRI; break; - case 2: res = POLLOUT; break; - case 3: res = POLLERR; break; - case 4: res = POLLHUP; break; - case 5: res = POLLNVAL; break; - } - - CAMLreturn(res); -} - -short Poll_events_val(value event_list) -{ - CAMLparam1(event_list); - short events = 0; - - while (event_list != Val_emptylist) { - events |= Poll_val(Field(event_list, 0)); - event_list = Field(event_list, 1); - } - - CAMLreturn(events); -} - -value Val_poll(short event) -{ - CAMLparam0(); - CAMLlocal1(res); - - switch (event) { - case POLLIN: res = Val_int(0); break; - case POLLPRI: res = Val_int(1); break; - case POLLOUT: res = Val_int(2); break; - case POLLERR: res = Val_int(3); break; - case POLLHUP: res = Val_int(4); break; - case POLLNVAL: res = Val_int(5); break; - default: failwith_xl(ERROR_FAIL, "cannot convert poll event value"); break; - } - - CAMLreturn(res); -} - -value add_event(value event_list, short event) -{ - CAMLparam1(event_list); - CAMLlocal1(new_list); - - new_list = caml_alloc(2, 0); - Store_field(new_list, 0, Val_poll(event)); - Store_field(new_list, 1, event_list); - - CAMLreturn(new_list); -} - -value Val_poll_events(short events) -{ - CAMLparam0(); - CAMLlocal1(event_list); - - event_list = Val_emptylist; - if (events & POLLIN) - event_list = add_event(event_list, POLLIN); - if (events & POLLPRI) - event_list = add_event(event_list, POLLPRI); - if (events & POLLOUT) - event_list = add_event(event_list, POLLOUT); - if (events & POLLERR) - event_list = add_event(event_list, POLLERR); - if (events & POLLHUP) - event_list = add_event(event_list, POLLHUP); - if (events & POLLNVAL) - event_list = add_event(event_list, POLLNVAL); - - CAMLreturn(event_list); -} - -/* The process for dealing with the for_app_registration_ values in the - * callbacks below (GC registrations etc) is similar to the way for_callback is - * handled in the asynchronous operations above. */ - -int fd_register(void *user, int fd, void **for_app_registration_out, - short events, void *for_libxl) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - int ret = 0; - static const value *func = NULL; - value *p = (value *) user; - value *for_app; - - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_fd_register"); - } - - args[0] = *p; - args[1] = Val_int(fd); - args[2] = Val_poll_events(events); - args[3] = (value) for_libxl; - - for_app = malloc(sizeof(value)); - if (!for_app) { - ret = ERROR_OSEVENT_REG_FAIL; - goto err; - } - - *for_app = caml_callbackN_exn(*func, 4, args); - if (Is_exception_result(*for_app)) { - ret = ERROR_OSEVENT_REG_FAIL; - free(for_app); - goto err; - } - - caml_register_global_root(for_app); - *for_app_registration_out = for_app; - -err: - CAMLdone; - caml_enter_blocking_section(); - return ret; -} - -int fd_modify(void *user, int fd, void **for_app_registration_update, - short events) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - int ret = 0; - static const value *func = NULL; - value *p = (value *) user; - value *for_app = *for_app_registration_update; - - /* If for_app == NULL, then something is very wrong */ - assert(for_app); - - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_fd_modify"); - } - - args[0] = *p; - args[1] = Val_int(fd); - args[2] = *for_app; - args[3] = Val_poll_events(events); - - *for_app = caml_callbackN_exn(*func, 4, args); - if (Is_exception_result(*for_app)) { - /* If an exception is caught, *for_app_registration_update is not - * changed. It remains a valid pointer to a value that is registered - * with the GC. */ - ret = ERROR_OSEVENT_REG_FAIL; - goto err; - } - - *for_app_registration_update = for_app; - -err: - CAMLdone; - caml_enter_blocking_section(); - return ret; -} - -void fd_deregister(void *user, int fd, void *for_app_registration) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 3); - static const value *func = NULL; - value *p = (value *) user; - value *for_app = for_app_registration; - - /* If for_app == NULL, then something is very wrong */ - assert(for_app); - - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_fd_deregister"); - } - - args[0] = *p; - args[1] = Val_int(fd); - args[2] = *for_app; - - caml_callbackN_exn(*func, 3, args); - /* This hook does not return error codes, so the best thing we can do - * to avoid trouble, if we catch an exception from the app, is abort. */ - if (Is_exception_result(*for_app)) - abort(); - - caml_remove_global_root(for_app); - free(for_app); - - CAMLdone; - caml_enter_blocking_section(); -} - -struct timeout_handles { - void *for_libxl; - value for_app; -}; - -int timeout_register(void *user, void **for_app_registration_out, - struct timeval abs, void *for_libxl) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocal2(sec, usec); - CAMLlocalN(args, 4); - int ret = 0; - static const value *func = NULL; - value *p = (value *) user; - struct timeout_handles *handles; - - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_timeout_register"); - } - - sec = caml_copy_int64(abs.tv_sec); - usec = caml_copy_int64(abs.tv_usec); - - /* This struct of "handles" will contain "for_libxl" as well as "for_app". - * We'll give a pointer to the struct to the app, and get it back in - * occurred_timeout, where we can clean it all up. */ - handles = malloc(sizeof(*handles)); - if (!handles) { - ret = ERROR_OSEVENT_REG_FAIL; - goto err; - } - - handles->for_libxl = for_libxl; - - args[0] = *p; - args[1] = sec; - args[2] = usec; - args[3] = (value) handles; - - handles->for_app = caml_callbackN_exn(*func, 4, args); - if (Is_exception_result(handles->for_app)) { - ret = ERROR_OSEVENT_REG_FAIL; - free(handles); - goto err; - } - - caml_register_global_root(&handles->for_app); - *for_app_registration_out = handles; - -err: - CAMLdone; - caml_enter_blocking_section(); - return ret; -} - -int timeout_modify(void *user, void **for_app_registration_update, - struct timeval abs) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocal1(for_app_update); - CAMLlocalN(args, 2); - int ret = 0; - static const value *func = NULL; - value *p = (value *) user; - struct timeout_handles *handles = *for_app_registration_update; - - /* If for_app == NULL, then something is very wrong */ - assert(handles->for_app); - - /* Libxl currently promises that timeout_modify is only ever called with - * abs={0,0}, meaning "right away". We cannot deal with other values. */ - assert(abs.tv_sec == 0 && abs.tv_usec == 0); - - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_timeout_fire_now"); - } - - args[0] = *p; - args[1] = handles->for_app; - - for_app_update = caml_callbackN_exn(*func, 2, args); - if (Is_exception_result(for_app_update)) { - /* If an exception is caught, *for_app_registration_update is not - * changed. It remains a valid pointer to a value that is registered - * with the GC. */ - ret = ERROR_OSEVENT_REG_FAIL; - goto err; - } - - handles->for_app = for_app_update; - -err: - CAMLdone; - caml_enter_blocking_section(); - return ret; -} - -void timeout_deregister(void *user, void *for_app_registration) -{ - /* This hook will never be called by libxl. */ - abort(); -} - -value stub_libxl_osevent_register_hooks(value ctx, value user) -{ - CAMLparam2(ctx, user); - CAMLlocal1(result); - libxl_osevent_hooks *hooks; - value *p; - - hooks = malloc(sizeof(*hooks)); - if (!hooks) - failwith_xl(ERROR_NOMEM, "cannot allocate osevent hooks"); - hooks->fd_register = fd_register; - hooks->fd_modify = fd_modify; - hooks->fd_deregister = fd_deregister; - hooks->timeout_register = timeout_register; - hooks->timeout_modify = timeout_modify; - hooks->timeout_deregister = timeout_deregister; - - p = malloc(sizeof(value)); - if (!p) - failwith_xl(ERROR_NOMEM, "cannot allocate value"); - *p = user; - caml_register_global_root(p); - - caml_enter_blocking_section(); - libxl_osevent_register_hooks(CTX, hooks, (void *) p); - caml_leave_blocking_section(); - - result = caml_alloc(1, Abstract_tag); - *((libxl_osevent_hooks **) result) = hooks; - - CAMLreturn(result); -} - -value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd, - value events, value revents) -{ - CAMLparam5(ctx, for_libxl, fd, events, revents); - int c_fd = Int_val(fd); - short c_events = Poll_events_val(events); - short c_revents = Poll_events_val(revents); - - caml_enter_blocking_section(); - libxl_osevent_occurred_fd(CTX, (void *) for_libxl, c_fd, c_events, c_revents); - caml_leave_blocking_section(); - - CAMLreturn(Val_unit); -} - -value stub_libxl_osevent_occurred_timeout(value ctx, value handles) -{ - CAMLparam1(ctx); - struct timeout_handles *c_handles = (struct timeout_handles *) handles; - - caml_enter_blocking_section(); - libxl_osevent_occurred_timeout(CTX, (void *) c_handles->for_libxl); - caml_leave_blocking_section(); - - caml_remove_global_root(&c_handles->for_app); - free(c_handles); - - CAMLreturn(Val_unit); -} - -struct user_with_ctx { - libxl_ctx *ctx; - value user; -}; - -void event_occurs(void *user, libxl_event *event) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 2); - struct user_with_ctx *c_user = (struct user_with_ctx *) user; - static const value *func = NULL; - - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_event_occurs_callback"); - } - - args[0] = c_user->user; - args[1] = Val_event(event); - libxl_event_free(c_user->ctx, event); - - caml_callbackN(*func, 2, args); - CAMLdone; - caml_enter_blocking_section(); -} - -void disaster(void *user, libxl_event_type type, - const char *msg, int errnoval) -{ - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - struct user_with_ctx *c_user = (struct user_with_ctx *) user; - static const value *func = NULL; - - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_event_disaster_callback"); - } - - args[0] = c_user->user; - args[1] = Val_event_type(type); - args[2] = caml_copy_string(msg); - args[3] = Val_int(errnoval); - - caml_callbackN(*func, 4, args); - CAMLdone; - caml_enter_blocking_section(); -} - -value stub_libxl_event_register_callbacks(value ctx, value user) -{ - CAMLparam2(ctx, user); - CAMLlocal1(result); - struct user_with_ctx *c_user = NULL; - libxl_event_hooks *hooks; - - c_user = malloc(sizeof(*c_user)); - if (!c_user) - failwith_xl(ERROR_NOMEM, "cannot allocate user value"); - c_user->user = user; - c_user->ctx = CTX; - caml_register_global_root(&c_user->user); - - hooks = malloc(sizeof(*hooks)); - if (!hooks) - failwith_xl(ERROR_NOMEM, "cannot allocate event hooks"); - hooks->event_occurs_mask = LIBXL_EVENTMASK_ALL; - hooks->event_occurs = event_occurs; - hooks->disaster = disaster; - - caml_enter_blocking_section(); - libxl_event_register_callbacks(CTX, hooks, (void *) c_user); - caml_leave_blocking_section(); - - result = caml_alloc(1, Abstract_tag); - *((libxl_event_hooks **) result) = hooks; - - CAMLreturn(result); -} - -value stub_libxl_evenable_domain_death(value ctx, value domid, value user) -{ - CAMLparam3(ctx, domid, user); - uint32_t c_domid = Int_val(domid); - int c_user = Int_val(user); - libxl_evgen_domain_death *evgen_out; - - caml_enter_blocking_section(); - libxl_evenable_domain_death(CTX, c_domid, c_user, &evgen_out); - caml_leave_blocking_section(); - - CAMLreturn(Val_unit); -} - -/* - * Local variables: - * indent-tabs-mode: t - * c-basic-offset: 8 - * tab-width: 8 - * End: - */ diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile deleted file mode 100644 index 256c830c51..0000000000 --- a/tools/ocaml/test/Makefile +++ /dev/null @@ -1,55 +0,0 @@ -XEN_ROOT = $(CURDIR)/../../.. -OCAML_TOPLEVEL = $(CURDIR)/.. -include $(OCAML_TOPLEVEL)/common.make - -CFLAGS += $(APPEND_CFLAGS) - -OCAMLINCLUDE += \ - -I $(OCAML_TOPLEVEL)/libs/xentoollog \ - -I $(OCAML_TOPLEVEL)/libs/xl - -OBJS = xtl send_debug_keys list_domains raise_exception dmesg - -PROGRAMS = xtl send_debug_keys list_domains raise_exception dmesg - -xtl_LIBS = \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa - -xtl_OBJS = xtl - -send_debug_keys_LIBS = \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa - -send_debug_keys_OBJS = xtl send_debug_keys - -list_domains_LIBS = \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa - -list_domains_OBJS = xtl list_domains - -raise_exception_LIBS = \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa - -raise_exception_OBJS = raise_exception - -dmesg_LIBS = \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \ - -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa - -dmesg_OBJS = xtl dmesg - -OCAML_PROGRAM = xtl send_debug_keys list_domains raise_exception dmesg - -all: $(PROGRAMS) - -bins: $(PROGRAMS) - -install: - -uninstall: - -include $(OCAML_TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/test/dmesg.ml b/tools/ocaml/test/dmesg.ml deleted file mode 100644 index f9efe5dc30..0000000000 --- a/tools/ocaml/test/dmesg.ml +++ /dev/null @@ -1,17 +0,0 @@ - -let _ = - Xenlight.register_exceptions (); - let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in - let ctx = Xenlight.ctx_alloc logger in - - let open Xenlight.Host in - let reader = xen_console_read_start ctx 0 in - (try - while true do - let line = xen_console_read_line ctx reader in - print_string line - done - with End_of_file -> ()); - let _ = xen_console_read_finish ctx reader in - () - diff --git a/tools/ocaml/test/list_domains.ml b/tools/ocaml/test/list_domains.ml deleted file mode 100644 index 94f1cec050..0000000000 --- a/tools/ocaml/test/list_domains.ml +++ /dev/null @@ -1,26 +0,0 @@ -open Printf - -let bool_as_char b c = if b then c else '-' - -let print_dominfo dominfo = - let id = dominfo.Xenlight.Dominfo.domid - and running = bool_as_char dominfo.Xenlight.Dominfo.running 'r' - and blocked = bool_as_char dominfo.Xenlight.Dominfo.blocked 'b' - and paused = bool_as_char dominfo.Xenlight.Dominfo.paused 'p' - and shutdown = bool_as_char dominfo.Xenlight.Dominfo.shutdown 's' - and dying = bool_as_char dominfo.Xenlight.Dominfo.dying 'd' - and memory = dominfo.Xenlight.Dominfo.current_memkb - in - printf "Dom %d: %c%c%c%c%c %LdKB\n" id running blocked paused shutdown dying memory - -let _ = - let logger = Xtl.create_stdio_logger (*~level:Xentoollog.Debug*) () in - let ctx = Xenlight.ctx_alloc logger in - try - let domains = Xenlight.Dominfo.list ctx in - List.iter (fun d -> print_dominfo d) domains - with Xenlight.Error(err, fn) -> begin - printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn; - end - - diff --git a/tools/ocaml/test/raise_exception.ml b/tools/ocaml/test/raise_exception.ml deleted file mode 100644 index 8c24c3555b..0000000000 --- a/tools/ocaml/test/raise_exception.ml +++ /dev/null @@ -1,9 +0,0 @@ -open Printf - -let _ = - try - Xenlight.test_raise_exception () - with Xenlight.Error(err, fn) -> begin - printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn; - end - diff --git a/tools/ocaml/test/send_debug_keys.ml b/tools/ocaml/test/send_debug_keys.ml deleted file mode 100644 index 67b1605dfe..0000000000 --- a/tools/ocaml/test/send_debug_keys.ml +++ /dev/null @@ -1,13 +0,0 @@ -open Printf - -let send_keys ctx s = - printf "Sending debug key %s\n" s; - Xenlight.Host.send_debug_keys ctx s; - () - -let _ = - let logger = Xtl.create_stdio_logger () in - let ctx = Xenlight.ctx_alloc logger in - Arg.parse [ - ] (fun s -> send_keys ctx s) "usage: send_debug_keys " - diff --git a/tools/ocaml/test/xtl.ml b/tools/ocaml/test/xtl.ml deleted file mode 100644 index 458b11bbaa..0000000000 --- a/tools/ocaml/test/xtl.ml +++ /dev/null @@ -1,39 +0,0 @@ -open Printf -open Xentoollog - -let stdio_vmessage min_level level errno ctx msg = - let level_str = level_to_string level - and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d" s - and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in - if compare min_level level <= 0 then begin - printf "%s%s%s: %s\n" level_str ctx_str errno_str msg; - flush stdout; - end - -let stdio_progress _ctx what percent dne total = - let nl = if dne = total then "\n" else "" in - printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl; - flush stdout - -let create_stdio_logger ?(level=Info) () = - let cbs = { - vmessage = stdio_vmessage level; - progress = stdio_progress; } in - create "Xentoollog.stdio_logger" cbs - -let do_test level = - let lgr = create_stdio_logger ~level:level () in - begin - test lgr; - end - -let () = - let debug_level = ref Info in - let speclist = [ - ("-v", Arg.Unit (fun () -> debug_level := Debug), "Verbose"); - ("-q", Arg.Unit (fun () -> debug_level := Critical), "Quiet"); - ] in - let usage_msg = "usage: xtl [OPTIONS]" in - Arg.parse speclist (fun _ -> ()) usage_msg; - - do_test !debug_level