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
SUBDIRS= \
mmap \
- xentoollog \
eventchn xc \
- xb xs xl
+ xb xs
.PHONY: all
all: subdirs-all
+++ /dev/null
-version = "@VERSION@"
-description = "Xen Tools Logger Interface"
-archive(byte) = "xentoollog.cma"
-archive(native) = "xentoollog.cmxa"
+++ /dev/null
-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
+++ /dev/null
-/*
- * Copyright (C) 2013 Citrix Ltd.
- * Author Ian Campbell <ian.campbell@citrix.com>
- * Author Rob Hoes <rob.hoes@citrix.com>
- *
- * 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)))
-
+++ /dev/null
-#!/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()
-
+++ /dev/null
-(*
- * Copyright (C) 2012 Citrix Ltd.
- * Author Ian Campbell <ian.campbell@citrix.com>
- *
- * 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)
-
+++ /dev/null
-(*
- * Copyright (C) 2012 Citrix Ltd.
- * Author Ian Campbell <ian.campbell@citrix.com>
- *
- * 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
-
+++ /dev/null
-/*
- * Copyright (C) 2012 Citrix Ltd.
- * Author Ian Campbell <ian.campbell@citrix.com>
- *
- * 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);
-}
-
+++ /dev/null
-version = "@VERSION@"
-description = "Xen Toolstack Library"
-requires = "xentoollog"
-archive(byte) = "xenlight.cma"
-archive(native) = "xenlight.cmxa"
+++ /dev/null
-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
+++ /dev/null
-#!/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()
+++ /dev/null
-(*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
- *
- * 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)
-
+++ /dev/null
-(*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
- *
- * 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
-
+++ /dev/null
-/*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
- *
- * 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. */
- 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:
- */
+++ /dev/null
-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
+++ /dev/null
-
-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
- ()
-
+++ /dev/null
-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
-
-
+++ /dev/null
-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
-
+++ /dev/null
-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 <keys>"
-
+++ /dev/null
-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
projects / xen.git / commitdiff