diff --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules index 5e6d81e4e992..0745e8312aa9 100644 --- a/tools/ocaml/Makefile.rules +++ b/tools/ocaml/Makefile.rules @@ -24,7 +24,7 @@ ALL_OCAML_OBJS ?= $(OBJS) %.cmi: %.mli $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -c -o $@ $<,MLI,$@) -%.cmx: %.ml +%.cmx %.o: %.ml $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<,MLOPT,$@) %.ml: %.mll diff --git a/tools/ocaml/libs/Makefile b/tools/ocaml/libs/Makefile index bca0fa24bdab..3afdc8964f1f 100644 --- a/tools/ocaml/libs/Makefile +++ b/tools/ocaml/libs/Makefile @@ -3,6 +3,7 @@ include $(XEN_ROOT)/tools/Rules.mk SUBDIRS= \ mmap \ + xentoollog \ xc eventchn \ xb xs xl diff --git a/tools/ocaml/libs/xentoollog/META.in b/tools/ocaml/libs/xentoollog/META.in new file mode 100644 index 000000000000..7b066830ed9e --- /dev/null +++ b/tools/ocaml/libs/xentoollog/META.in @@ -0,0 +1,4 @@ +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 new file mode 100644 index 000000000000..e535ba5c16e7 --- /dev/null +++ b/tools/ocaml/libs/xentoollog/Makefile @@ -0,0 +1,61 @@ +TOPLEVEL=$(CURDIR)/../.. +XEN_ROOT=$(TOPLEVEL)/../.. +include $(TOPLEVEL)/common.make + +CFLAGS += $(CFLAGS_libxenctrl) $(CFLAGS_libxenguest) +OCAMLINCLUDE += + +OBJS = xentoollog +INTF = xentoollog.cmi +LIBS = xentoollog.cma xentoollog.cmxa + +LIBS_xentoollog = $(LDLIBS_libxenctrl) + +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_ROOT)/tools/libxc/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 $(TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xentoollog/caml_xentoollog.h b/tools/ocaml/libs/xentoollog/caml_xentoollog.h new file mode 100644 index 000000000000..0eb7618512b2 --- /dev/null +++ b/tools/ocaml/libs/xentoollog/caml_xentoollog.h @@ -0,0 +1,24 @@ +/* + * Copyright (C) 2013 Citrix Ltd. + * Author Ian Campbell + * Author Rob Hoes + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + */ + +struct caml_xtl { + xentoollog_logger vtable; + char *vmessage_cb; + char *progress_cb; +}; + +#define Xtl_val(x)(*((struct caml_xtl **) Data_custom_val(x))) + diff --git a/tools/ocaml/libs/xentoollog/genlevels.py b/tools/ocaml/libs/xentoollog/genlevels.py new file mode 100755 index 000000000000..6b42f21882f6 --- /dev/null +++ b/tools/ocaml/libs/xentoollog/genlevels.py @@ -0,0 +1,127 @@ +#!/usr/bin/python + +import sys + +def read_levels(): + f = open('../../../libxc/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 >>sys.stderr, "Usage: genlevels.py " + 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 new file mode 100644 index 000000000000..ce9ea1db777c --- /dev/null +++ b/tools/ocaml/libs/xentoollog/xentoollog.ml.in @@ -0,0 +1,48 @@ +(* + * Copyright (C) 2012 Citrix Ltd. + * Author Ian Campbell + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Printf +open Random +open Callback + +(* @@XTL_LEVELS@@ *) + +let compare_level x y = + compare (level_to_prio x) (level_to_prio y) + +type handle + +type logger_cbs = { + vmessage : level -> int option -> string option -> string -> unit; + progress : string option -> string -> int -> int64 -> int64 -> unit; + (*destroy : unit -> unit*) +} + +external _create_logger: (string * string) -> handle = "stub_xtl_create_logger" +external test: handle -> unit = "stub_xtl_test" + +let counter = ref 0L + +let create name cbs : handle = + (* Callback names are supposed to be unique *) + let suffix = Int64.to_string !counter in + counter := Int64.succ !counter; + let vmessage_name = sprintf "%s_vmessage_%s" name suffix in + let progress_name = sprintf "%s_progress_%s" name suffix in + (*let destroy_name = sprintf "%s_destroy" name in*) + Callback.register vmessage_name cbs.vmessage; + Callback.register progress_name cbs.progress; + _create_logger (vmessage_name, progress_name) + diff --git a/tools/ocaml/libs/xentoollog/xentoollog.mli.in b/tools/ocaml/libs/xentoollog/xentoollog.mli.in new file mode 100644 index 000000000000..05c098ae49ac --- /dev/null +++ b/tools/ocaml/libs/xentoollog/xentoollog.mli.in @@ -0,0 +1,43 @@ +(* + * Copyright (C) 2012 Citrix Ltd. + * Author Ian Campbell + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(* @@XTL_LEVELS@@ *) + +val level_to_string : level -> string +val compare_level : level -> level -> int + +type handle + +(** call back arguments. See xentoollog.h for more info. + vmessage: + level: level as above + errno: Some or None + context: Some or None + message: The log message (already formatted) + progress: + context: Some or None + doing_what: string + percent, done, total. +*) +type logger_cbs = { + vmessage : level -> int option -> string option -> string -> unit; + progress : string option -> string -> int -> int64 -> int64 -> unit; + (*destroy : handle -> unit*) +} + +external test: handle -> unit = "stub_xtl_test" + +val create : string -> logger_cbs -> handle + diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c new file mode 100644 index 000000000000..3b2f91bf9fae --- /dev/null +++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c @@ -0,0 +1,196 @@ +/* + * Copyright (C) 2012 Citrix Ltd. + * Author Ian Campbell + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + */ + +#define _GNU_SOURCE +#include +#include +#include +#include + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include +#include + +#include + +#include "caml_xentoollog.h" + +#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 */ +#define Val_none Val_int(0) +#define Some_val(v) Field(v,0) + +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) +{ + CAMLparam0(); + CAMLlocalN(args, 4); + struct caml_xtl *xtl = (struct caml_xtl*)logger; + value *func = caml_named_value(xtl->vmessage_cb) ; + char *msg; + + if (args == NULL) + caml_raise_out_of_memory(); + 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); + CAMLreturn0; +} + +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) +{ + CAMLparam0(); + CAMLlocalN(args, 5); + struct caml_xtl *xtl = (struct caml_xtl*)logger; + value *func = caml_named_value(xtl->progress_cb) ; + + if (args == NULL) + caml_raise_out_of_memory(); + 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); + CAMLreturn0; +} + +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); +} +