Xen project Mailing List

[xen master] tools/ocaml: Drop libxl and xentoollog bindings

Date: Sun, 12 Feb 2023 07:56:12 +0000

Delivery-date: Sun, 12 Feb 2023 07:56:13 +0000

List-id: "Change log for Mercurial $receive only$" <xen-changelog.lists.xenproject.org>

commit e51d31f79edc10f8d622e7f5bf4b935af6d4618f Author: Andrew Cooper <andrew.cooper3@xxxxxxxxxx> AuthorDate: Thu Feb 9 15:25:10 2023 +0000 Commit: Andrew Cooper <andrew.cooper3@xxxxxxxxxx> CommitDate: Thu Feb 9 18:26:17 2023 +0000 tools/ocaml: Drop libxl and xentoollog bindings There are significant issues with these bindings (they segfault for starters) and their companion half in Xapi was deleted in 2018 https://github.com/xapi-project/xen-api/commit/203292ebe0c487d7ae4adb961a6d080f4fbe933d owing to there having been no development of these bindings since 2014. In the unlikely event that we'd want to reinstate them, they'd need reworking basically from scratch anyway. Signed-off-by: Andrew Cooper <andrew.cooper3@xxxxxxxxxx> Acked-by: Christian Lindig <christian.lindig@xxxxxxxxxx> --- tools/ocaml/Makefile | 4 - tools/ocaml/libs/Makefile | 3 +- tools/ocaml/libs/xentoollog/META.in | 4 - tools/ocaml/libs/xentoollog/Makefile | 65 - tools/ocaml/libs/xentoollog/caml_xentoollog.h | 24 - tools/ocaml/libs/xentoollog/genlevels.py | 130 -- tools/ocaml/libs/xentoollog/xentoollog.ml.in | 48 - tools/ocaml/libs/xentoollog/xentoollog.mli.in | 43 - tools/ocaml/libs/xentoollog/xentoollog_stubs.c | 205 --- tools/ocaml/libs/xl/META.in | 5 - tools/ocaml/libs/xl/Makefile | 71 - tools/ocaml/libs/xl/genwrap.py | 582 --------- tools/ocaml/libs/xl/xenlight.ml.in | 94 -- tools/ocaml/libs/xl/xenlight.mli.in | 93 -- tools/ocaml/libs/xl/xenlight_stubs.c | 1663 ------------------------ tools/ocaml/test/Makefile | 55 - tools/ocaml/test/dmesg.ml | 17 - tools/ocaml/test/list_domains.ml | 26 - tools/ocaml/test/raise_exception.ml | 9 - tools/ocaml/test/send_debug_keys.ml | 13 - tools/ocaml/test/xtl.ml | 39 - 21 files changed, 1 insertion(+), 3192 deletions(-) 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 <ian.campbell@xxxxxxxxxx> - * Author Rob Hoes <rob.hoes@xxxxxxxxxx> - * - * 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 <mli> <ml> <c-inc>", 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 <ian.campbell@xxxxxxxxxx> - * - * 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 <ian.campbell@xxxxxxxxxx> - * - * 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 <errno> or None - context: Some <string> or None - message: The log message (already formatted) - progress: - context: Some <string> 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 <ian.campbell@xxxxxxxxxx> - * - * 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 <stdio.h> -#include <string.h> -#include <unistd.h> -#include <errno.h> - -#define CAML_NAME_SPACE -#include <caml/alloc.h> -#include <caml/memory.h> -#include <caml/signals.h> -#include <caml/fail.h> -#include <caml/callback.h> -#include <caml/custom.h> - -#include <xentoollog.h> - -#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 <idl> <mli> <ml> <c-inc>", 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 <vincent.hanquez@xxxxxxxxxxxxx> - * - * 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 <vincent.hanquez@xxxxxxxxxxxxx> - * - * 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 <vincent.hanquez@xxxxxxxxxxxxx> - * - * 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 <stdlib.h> - -#define CAML_NAME_SPACE -#include <caml/alloc.h> -#include <caml/memory.h> -#include <caml/signals.h> -#include <caml/fail.h> -#include <caml/callback.h> -#include <caml/custom.h> - -#include <sys/mman.h> -#include <stdint.h> -#include <string.h> - -#include <libxl.h> -#include <libxl_utils.h> - -#include <unistd.h> -#include <assert.h> - -#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; i<len; i++) { - if (Int_val(Field(v, i))) - libxl_bitmap_set(c_val, i); - else - libxl_bitmap_reset(c_val, i); - } - CAMLreturn(0); -} - -static value Val_uuid (libxl_uuid *c_val) -{ - CAMLparam0(); - CAMLlocal1(v); - uint8_t *uuid = libxl_uuid_bytearray(c_val); - int i; - - v = caml_alloc_tuple(16); - - for(i=0; i<16; i++) - Store_field(v, i, Val_int(uuid[i])); - - CAMLreturn(v); -} - -static int Uuid_val(libxl_uuid *c_val, value v) -{ - CAMLparam1(v); - int i; - uint8_t *uuid = libxl_uuid_bytearray(c_val); - - for(i=0; i<16; i++) - uuid[i] = Int_val(Field(v, i)); - - CAMLreturn(0); -} - -static value Val_defbool(libxl_defbool c_val) -{ - CAMLparam0(); - CAMLlocal2(v1, v2); - bool b; - - if (libxl_defbool_is_default(c_val)) - v2 = Val_none; - else { - b = libxl_defbool_val(c_val); - v1 = b ? Val_bool(true) : Val_bool(false); - v2 = Val_some(v1); - } - CAMLreturn(v2); -} - -static libxl_defbool Defbool_val(value v) -{ - CAMLparam1(v); - libxl_defbool db; - if (v == Val_none) - libxl_defbool_unset(&db); - else { - bool b = Bool_val(Some_val(v)); - libxl_defbool_set(&db, b); - } - CAMLreturnT(libxl_defbool, db); -} - -static value Val_hwcap(libxl_hwcap *c_val) -{ - CAMLparam0(); - CAMLlocal1(hwcap); - int i; - - hwcap = caml_alloc_tuple(8); - for (i = 0; i < 8; i++) - Store_field(hwcap, i, caml_copy_int32((*c_val)[i])); - - CAMLreturn(hwcap); -} - -static value Val_ms_vm_genid (libxl_ms_vm_genid *c_val) -{ - CAMLparam0(); - CAMLlocal1(v); - int i; - - v = caml_alloc_tuple(LIBXL_MS_VM_GENID_LEN); - - for(i=0; i<LIBXL_MS_VM_GENID_LEN; i++) - Store_field(v, i, Val_int(c_val->bytes[i])); - - CAMLreturn(v); -} - -static int Ms_vm_genid_val(libxl_ms_vm_genid *c_val, value v) -{ - CAMLparam1(v); - int i; - - for(i=0; i<LIBXL_MS_VM_GENID_LEN; i++) - c_val->bytes[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. */

©2013 Xen Project, A Linux Foundation Collaborative Project. All Rights Reserved.
Linux Foundation is a registered trademark of The Linux Foundation.
Xen Project is a trademark of The Linux Foundation.