thr3ads.net - Xen devel - [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only) [Nov 2012]

If this information is useful, please help other people find it:
Share via:

Ian Campbell

2012-Nov-20 17:23 UTC

[PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

# HG changeset patch
# User Ian Campbell <ijc@hellion.org.uk>
# Date 1353432141 0
# Node ID 2b433b1523e4295bb1ed74a7b71e2a20e00f1802
# Parent  5173d29f64fa541f6ec0c48481c4957a03f0302c
libxc/ocaml: Add simple binding for xentoollog (output only).

These bindings allow ocaml code to receive log message via xentoollog
but do not support injecting messages into xentoollog from ocaml.
Receiving log messages from libx{c,l} and forwarding them to ocaml is
the use case which is needed by the following patches.

Add a simple noddy test case (tools/ocaml/test).

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>

diff -r 5173d29f64fa -r 2b433b1523e4 .gitignore
--- a/.gitignore	Tue Nov 20 17:22:21 2012 +0000
+++ b/.gitignore	Tue Nov 20 17:22:21 2012 +0000
@@ -364,6 +364,7 @@ tools/ocaml/libs/xl/_libxl_types.mli.in
 tools/ocaml/libs/xl/xenlight.ml
 tools/ocaml/libs/xl/xenlight.mli
 tools/ocaml/xenstored/oxenstored
+tools/ocaml/test/xtl
 
 tools/debugger/kdd/kdd
 tools/firmware/etherboot/ipxe.tar.gz
diff -r 5173d29f64fa -r 2b433b1523e4 .hgignore
--- a/.hgignore	Tue Nov 20 17:22:21 2012 +0000
+++ b/.hgignore	Tue Nov 20 17:22:21 2012 +0000
@@ -305,6 +305,7 @@
 ^tools/ocaml/libs/xl/xenlight\.ml$
 ^tools/ocaml/libs/xl/xenlight\.mli$
 ^tools/ocaml/xenstored/oxenstored$
+^tools/ocaml/test/xtl$
 ^tools/autom4te\.cache$
 ^tools/config\.h$
 ^tools/config\.log$
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/Makefile
--- a/tools/ocaml/Makefile	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/Makefile	Tue Nov 20 17:22:21 2012 +0000
@@ -1,7 +1,7 @@
 XEN_ROOT = $(CURDIR)/../..
 include $(XEN_ROOT)/tools/Rules.mk
 
-SUBDIRS_PROGRAMS = xenstored
+SUBDIRS_PROGRAMS = xenstored test
 
 SUBDIRS = libs $(SUBDIRS_PROGRAMS)
 
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/Makefile.rules
--- a/tools/ocaml/Makefile.rules	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/Makefile.rules	Tue Nov 20 17:22:21 2012 +0000
@@ -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 -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/Makefile
--- a/tools/ocaml/libs/Makefile	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/libs/Makefile	Tue Nov 20 17:22:21 2012 +0000
@@ -3,6 +3,7 @@ include $(XEN_ROOT)/tools/Rules.mk
 
 SUBDIRS= \
 	mmap \
+	xentoollog \
 	xc eventchn \
 	xb xs xl
 
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/xentoollog/META.in
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/META.in	Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Xen Tools Logger Interface"
+archive(byte) = "xentoollog.cma"
+archive(native) = "xentoollog.cmxa"
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/xentoollog/Makefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/Makefile	Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,33 @@
+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
+
+all: $(INTF) $(LIBS)
+
+libs: $(LIBS)
+
+.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 -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/xentoollog/xentoollog.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/xentoollog.ml	Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,101 @@
+(*
+ * 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
+
+type level = Debug
+	     | Verbose
+	     | Detail
+	     | Progress
+	     | Info
+	     | Notice
+	     | Warn
+	     | Error
+	     | Critical
+
+let level_to_string level +  match level with
+  | Debug -> "Debug"
+  | Verbose -> "Verbose"
+  | Detail -> "Detail"
+  | Progress -> "Progress"
+  | Info -> "Info"
+  | Notice -> "Notice"
+  | Warn -> "Warn"
+  | Error -> "Error"
+  | Critical -> "Critical"
+
+let level_to_prio level = 
+  match level with
+  | Debug -> 0
+  | Verbose -> 1
+  | Detail -> 2
+  | Progress -> 3
+  | Info -> 4
+  | Notice -> 5
+  | Warn -> 6
+  | Error -> 7
+  | Critical -> 8
+
+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 create name cbs : handle +  (* Callback names are supposed to be unique *)
+  let suffix = string_of_int (Random.int 1000000) in
+  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*)
+  begin
+    Callback.register vmessage_name cbs.vmessage;
+    Callback.register progress_name cbs.progress;
+    _create_logger (vmessage_name, progress_name)
+  end
+
+
+let stdio_vmessage min_level level errno ctx msg +  let level_int =
level_to_prio level
+  and 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 min_level <= level_int 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 level_int = level_to_prio level
in
+  let cbs = {
+    vmessage = stdio_vmessage level_int;
+    progress = stdio_progress; } in
+  create "Xentoollog.stdio_logger" cbs
+
+external destroy: handle -> unit = "stub_xtl_destroy"
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/xentoollog/xentoollog.mli
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/xentoollog.mli	Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,52 @@
+(*
+ * 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.
+ *)
+
+type level = Debug
+	     | Verbose
+	     | Detail
+	     | Progress (* also used for "progress" messages *)
+	     | Info
+	     | Notice
+	     | Warn
+	     | Error
+	     | Critical
+
+val level_to_string : level -> string
+
+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
+
+val create_stdio_logger : ?level:level -> unit -> handle
+
+external destroy: handle -> unit = "stub_xtl_destroy"
diff -r 5173d29f64fa -r 2b433b1523e4
tools/ocaml/libs/xentoollog/xentoollog_stubs.c
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c	Tue Nov 20 17:22:21 2012
+0000
@@ -0,0 +1,211 @@
+/*
+ * 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 <xentoollog.h>
+
+struct caml_xtl {
+	xentoollog_logger vtable;
+	char *vmessage_cb;
+	char *progress_cb;
+};
+
+#define HND ((struct caml_xtl*)handle)
+#define XTL ((xentoollog_logger *)HND)
+
+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;
+}
+
+static value Val_level(xentoollog_level c_level)
+{
+	/* Must correspond to order in .mli */
+	switch (c_level) {
+	case XTL_NONE: /* Not a real value */
+		caml_raise_sys_error(caml_copy_string("Val_level XTL_NONE"));
+		break;
+	case XTL_DEBUG:    return Val_int(0);
+	case XTL_VERBOSE:  return Val_int(1);
+	case XTL_DETAIL:   return Val_int(2);
+	case XTL_PROGRESS: return Val_int(3);
+	case XTL_INFO:     return Val_int(4);
+	case XTL_NOTICE:   return Val_int(5);
+	case XTL_WARN:     return Val_int(6);
+	case XTL_ERROR:    return Val_int(7);
+	case XTL_CRITICAL: return Val_int(8);
+	case XTL_NUM_LEVELS: /* Not a real value! */
+		caml_raise_sys_error(
+			caml_copy_string("Val_level XTL_NUM_LEVELS"));
+#if 0 /* Let the compiler catch this */
+	default:
+		caml_raise_sys_error(caml_copy_string("Val_level Unknown"));
+		break;
+#endif
+	}
+	abort();
+}
+
+/* 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)
+{
+	struct caml_xtl *xtl = (struct caml_xtl*)logger;
+	value *func = caml_named_value(xtl->vmessage_cb) ;
+	value args[4];
+	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);
+}
+
+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)
+{
+	struct caml_xtl *xtl = (struct caml_xtl*)logger;
+	value *func = caml_named_value(xtl->progress_cb) ;
+	value args[5];
+
+	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);
+}
+
+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);
+}
+
+/* external _create_logger: (string * string) -> handle =
"stub_xtl_create_logger" */
+CAMLprim value stub_xtl_create_logger(value cbs)
+{
+	CAMLparam1(cbs);
+	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));
+	CAMLreturn((value)xtl);
+}
+
+/* external destroy: handle -> unit = "stub_xtl_destroy" */
+CAMLprim value stub_xtl_destroy(value handle)
+{
+	CAMLparam1(handle);
+	xtl_logger_destroy(XTL);
+	CAMLreturn(Val_unit);
+}
+
+/* external test: handle -> unit = "stub_xtl_test" */
+CAMLprim value stub_xtl_test(value handle)
+{
+	unsigned long l;
+	CAMLparam1(handle);
+	xtl_log(XTL, XTL_DEBUG, -1, "debug", "%s -- debug",
__func__);
+	xtl_log(XTL, XTL_INFO, -1, "test", "%s -- test 1",
__func__);
+	xtl_log(XTL, XTL_INFO, ENOSYS, "test errno", "%s -- test
2", __func__);
+	xtl_log(XTL, XTL_CRITICAL, -1, "critical", "%s --
critical", __func__);
+	for (l = 0UL; l<=100UL; l += 10UL) {
+		xtl_progress(XTL, "progress", "testing", l, 100UL);
+		usleep(10000);
+	}
+	CAMLreturn(Val_unit);
+}
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/test/Makefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/test/Makefile	Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,27 @@
+XEN_ROOT = $(CURDIR)/../../..
+OCAML_TOPLEVEL = $(CURDIR)/..
+include $(OCAML_TOPLEVEL)/common.make
+
+OCAMLINCLUDE += \
+	-I $(OCAML_TOPLEVEL)/libs/xentoollog
+
+OBJS = xtl
+
+PROGRAMS = xtl
+
+xtl_LIBS =  \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog
$(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa
+
+xtl_OBJS = xtl
+
+OCAML_PROGRAM = xtl
+
+all: $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+install: all
+	$(INSTALL_DIR) $(DESTDIR)$(BINDIR)
+	$(INSTALL_PROG) $(PROGRAMS) $(DESTDIR)$(BINDIR)
+
+include $(OCAML_TOPLEVEL)/Makefile.rules
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/test/xtl.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/test/xtl.ml	Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,20 @@
+open Arg
+open Xentoollog
+  
+let do_test level = 
+  let lgr = Xentoollog.create_stdio_logger ~level:level () in
+  begin
+    Xentoollog.test lgr;
+    Xentoollog.destroy lgr;
+  end
+
+let () +  let debug_level = ref Xentoollog.Info in
+  let speclist = [
+    ("-v", Arg.Unit (fun () -> debug_level := Xentoollog.Debug),
"Verbose");
+    ("-q", Arg.Unit (fun () -> debug_level :=
Xentoollog.Critical), "Quiet");
+  ] in
+  let usage_msg = "usage: xtl [OPTIONS]" in
+  Arg.parse speclist (fun s -> ()) usage_msg;
+
+  do_test !debug_level

Rob Hoes

2012-Nov-29 17:41 UTC

head link

Re: [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

> # HG changeset patch
> # User Ian Campbell <ijc@hellion.org.uk> # Date 1353432141 0 # Node
ID
> 2b433b1523e4295bb1ed74a7b71e2a20e00f1802
> # Parent  5173d29f64fa541f6ec0c48481c4957a03f0302c
> libxc/ocaml: Add simple binding for xentoollog (output only).
> 
> These bindings allow ocaml code to receive log message via xentoollog but
> do not support injecting messages into xentoollog from ocaml.
> Receiving log messages from libx{c,l} and forwarding them to ocaml is the
> use case which is needed by the following patches.
> 
> Add a simple noddy test case (tools/ocaml/test).
> 
> Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
> 
This is potentially very useful. However, I have a few concerns about the
callbacks to OCaml.

The most important issue is that we''d like to wrap potentially blocking
C code in caml_enter_blocking_section and caml_leave_blocking section calls, to
make sure that this code won''t block the entire OCaml program. Within
such a block, it is not allowed to interact with the OCaml runtime in any way.
This includes callbacks.

I have notice some weird segfaults happening when using this logging code, and
they seemed to have gone away when I removed the blocking_section calls.

I can''t think of a good solution yet, but to make this really useful, I
think we may need to do it slightly differently.

I included some smaller comments below.
> diff -r 5173d29f64fa -r 2b433b1523e4 .gitignore
> --- a/.gitignore	Tue Nov 20 17:22:21 2012 +0000
> +++ b/.gitignore	Tue Nov 20 17:22:21 2012 +0000
> @@ -364,6 +364,7 @@ tools/ocaml/libs/xl/_libxl_types.mli.in
[.....]
> +static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
> +			       xentoollog_level level,
> +			       int errnoval,
> +			       const char *context,
> +			       const char *format,
> +			       va_list al)
> +{
> +	struct caml_xtl *xtl = (struct caml_xtl*)logger;
> +	value *func = caml_named_value(xtl->vmessage_cb) ;
> +	value args[4];
I think it is safer to use this instead:

       CAMLparam0();
       CAMLlocalN(args, 4);
> +	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);
Because of the above, we should also add 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) {
> +	struct caml_xtl *xtl = (struct caml_xtl*)logger;
> +	value *func = caml_named_value(xtl->progress_cb) ;
> +	value args[5];
Here as well:

       CAMLparam0();
       CAMLlocalN(args, 5);
> +
> +	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);
And 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);
> +}
> +
[...]
> diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/test/Makefile
> --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
> +++ b/tools/ocaml/test/Makefile	Tue Nov 20 17:22:21 2012 +0000
> @@ -0,0 +1,27 @@
> +XEN_ROOT = $(CURDIR)/../../..
> +OCAML_TOPLEVEL = $(CURDIR)/..
> +include $(OCAML_TOPLEVEL)/common.make
> +
> +OCAMLINCLUDE += \
> +	-I $(OCAML_TOPLEVEL)/libs/xentoollog
> +
> +OBJS = xtl
> +
> +PROGRAMS = xtl
> +
> +xtl_LIBS =  \
> +	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog
> +$(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa
I had to add "-cclib -lxenctrl" here to get it to link properly.
> +
> +xtl_OBJS = xtl
> +
> +OCAML_PROGRAM = xtl
> +
> +all: $(PROGRAMS)
> +
> +bins: $(PROGRAMS)
> +
> +install: all
> +	$(INSTALL_DIR) $(DESTDIR)$(BINDIR)
> +	$(INSTALL_PROG) $(PROGRAMS) $(DESTDIR)$(BINDIR)
> +
> +include $(OCAML_TOPLEVEL)/Makefile.rules
> diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/test/xtl.ml
> --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
> +++ b/tools/ocaml/test/xtl.ml	Tue Nov 20 17:22:21 2012 +0000
> @@ -0,0 +1,20 @@
> +open Arg
> +open Xentoollog
> +
> +let do_test level > +  let lgr = Xentoollog.create_stdio_logger
~level:level () in
> +  begin
> +    Xentoollog.test lgr;
> +    Xentoollog.destroy lgr;
> +  end
> +
> +let () > +  let debug_level = ref Xentoollog.Info in
> +  let speclist = [
> +    ("-v", Arg.Unit (fun () -> debug_level :=
Xentoollog.Debug), "Verbose");
> +    ("-q", Arg.Unit (fun () -> debug_level :=
Xentoollog.Critical),
> +"Quiet");
> +  ] in
> +  let usage_msg = "usage: xtl [OPTIONS]" in
> +  Arg.parse speclist (fun s -> ()) usage_msg;
> +
> +  do_test !debug_level
> 
Cheers,
Rob

Ian Campbell

2012-Nov-29 18:03 UTC

head link

Re: [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

On Thu, 2012-11-29 at 17:41 +0000, Rob Hoes wrote:> > # HG changeset patch
> > # User Ian Campbell <ijc@hellion.org.uk> # Date 1353432141 0 #
Node ID
> > 2b433b1523e4295bb1ed74a7b71e2a20e00f1802
> > # Parent  5173d29f64fa541f6ec0c48481c4957a03f0302c
> > libxc/ocaml: Add simple binding for xentoollog (output only).
> > 
> > These bindings allow ocaml code to receive log message via xentoollog
but
> > do not support injecting messages into xentoollog from ocaml.
> > Receiving log messages from libx{c,l} and forwarding them to ocaml is
the
> > use case which is needed by the following patches.
> > 
> > Add a simple noddy test case (tools/ocaml/test).
> > 
> > Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
> > 
> 
> This is potentially very useful. However, I have a few concerns about the
callbacks to OCaml.
> 
> The most important issue is that we''d like to wrap potentially
> blocking C code in caml_enter_blocking_section and caml_leave_blocking
> section calls, to make sure that this code won''t block the entire
> OCaml program. Within such a block, it is not allowed to interact with
> the OCaml runtime in any way. This includes callbacks.
> 
> I have notice some weird segfaults happening when using this logging
> code, and they seemed to have gone away when I removed the
> blocking_section calls.
> 
> I can''t think of a good solution yet, but to make this really
useful,
> I think we may need to do it slightly differently.
Can we call leave/enter from the C part of the callback before heading
back to ocaml, or does it not work like that? Would this require us to
*always* call enter/leave when calling into libxl, in case it generates
a callback (i.e. to balance things out correctly)?

Another idea might be to make the bindings use the async interfaces
wherever possible by default, by definition anything potentially
blocking has supports this and that would avoid the need for
enter/leave, but at the expense of making the ocaml callers ugly
perhaps? Or maybe this sort of thing ends up looking very natural in
ocaml? Depends on your application''s event mechanism I suspect.

Last half witted idea: everything could be async but the bindings
include the loop to wait for the async event, i.e. effectively making
the call sync again. This sounds silly but it might allow better control
over the placement of enter/leave vs callbacks, since you would just
drop it over libxl_event_wait?
> I included some smaller comments below.
> 
> > diff -r 5173d29f64fa -r 2b433b1523e4 .gitignore
> > --- a/.gitignore	Tue Nov 20 17:22:21 2012 +0000
> > +++ b/.gitignore	Tue Nov 20 17:22:21 2012 +0000
> > @@ -364,6 +364,7 @@ tools/ocaml/libs/xl/_libxl_types.mli.in
> 
> [.....]
> 
> > +static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
> > +			       xentoollog_level level,
> > +			       int errnoval,
> > +			       const char *context,
> > +			       const char *format,
> > +			       va_list al)
> > +{
> > +	struct caml_xtl *xtl = (struct caml_xtl*)logger;
> > +	value *func = caml_named_value(xtl->vmessage_cb) ;
> > +	value args[4];
> 
> I think it is safer to use this instead:
> 
>        CAMLparam0();
>        CAMLlocalN(args, 4);
> 
> > +	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);
> 
> Because of the above, we should also add 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) {
> > +	struct caml_xtl *xtl = (struct caml_xtl*)logger;
> > +	value *func = caml_named_value(xtl->progress_cb) ;
> > +	value args[5];
> 
> Here as well:
> 
>        CAMLparam0();
>        CAMLlocalN(args, 5);
> 
> > +
> > +	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);
> 
> And 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);
> > +}
> > +
> 
> [...]
> 
> > diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/test/Makefile
> > --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
> > +++ b/tools/ocaml/test/Makefile	Tue Nov 20 17:22:21 2012 +0000
> > @@ -0,0 +1,27 @@
> > +XEN_ROOT = $(CURDIR)/../../..
> > +OCAML_TOPLEVEL = $(CURDIR)/..
> > +include $(OCAML_TOPLEVEL)/common.make
> > +
> > +OCAMLINCLUDE += \
> > +	-I $(OCAML_TOPLEVEL)/libs/xentoollog
> > +
> > +OBJS = xtl
> > +
> > +PROGRAMS = xtl
> > +
> > +xtl_LIBS =  \
> > +	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog
> > +$(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa
> 
> I had to add "-cclib -lxenctrl" here to get it to link properly.
> 
> > +
> > +xtl_OBJS = xtl
> > +
> > +OCAML_PROGRAM = xtl
> > +
> > +all: $(PROGRAMS)
> > +
> > +bins: $(PROGRAMS)
> > +
> > +install: all
> > +	$(INSTALL_DIR) $(DESTDIR)$(BINDIR)
> > +	$(INSTALL_PROG) $(PROGRAMS) $(DESTDIR)$(BINDIR)
> > +
> > +include $(OCAML_TOPLEVEL)/Makefile.rules
> > diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/test/xtl.ml
> > --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
> > +++ b/tools/ocaml/test/xtl.ml	Tue Nov 20 17:22:21 2012 +0000
> > @@ -0,0 +1,20 @@
> > +open Arg
> > +open Xentoollog
> > +
> > +let do_test level > > +  let lgr =
Xentoollog.create_stdio_logger ~level:level () in
> > +  begin
> > +    Xentoollog.test lgr;
> > +    Xentoollog.destroy lgr;
> > +  end
> > +
> > +let () > > +  let debug_level = ref Xentoollog.Info in
> > +  let speclist = [
> > +    ("-v", Arg.Unit (fun () -> debug_level :=
Xentoollog.Debug), "Verbose");
> > +    ("-q", Arg.Unit (fun () -> debug_level :=
Xentoollog.Critical),
> > +"Quiet");
> > +  ] in
> > +  let usage_msg = "usage: xtl [OPTIONS]" in
> > +  Arg.parse speclist (fun s -> ()) usage_msg;
> > +
> > +  do_test !debug_level
> > 
> 
> Cheers,
> Rob

Anil Madhavapeddy

2012-Nov-29 18:20 UTC

head link

Re: [Xen-API] [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

On 29 Nov 2012, at 18:03, Ian Campbell <Ian.Campbell@citrix.com>
wrote:> 
> Another idea might be to make the bindings use the async interfaces
> wherever possible by default, by definition anything potentially
> blocking has supports this and that would avoid the need for
> enter/leave, but at the expense of making the ocaml callers ugly
> perhaps? Or maybe this sort of thing ends up looking very natural in
> ocaml? Depends on your application''s event mechanism I suspect.
> 
> Last half witted idea: everything could be async but the bindings
> include the loop to wait for the async event, i.e. effectively making
> the call sync again. This sounds silly but it might allow better control
> over the placement of enter/leave vs callbacks, since you would just
> drop it over libxl_event_wait?
Making everything explicitly async and non-blocking is by far the
preferred solution in terms of stability, as it largely removes the
need to worry about the GC interface and thread interactions.

There are several libraries to wrap async interfaces in convenient
synchronous programming, most notably Lwt (http://ocsigen.org/lwt).
With this interface, all the OCaml callbacks are implemented in
OCaml, and it just needs a select/epoll or equivalent to wake up
sleeping threads when an IO event occurs.

Dave has already done some bindings to Lwt, so I''ve CCed him...

-anil

Ian Campbell

2012-Nov-30 09:50 UTC

head link

Re: [Xen-API] [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

On Thu, 2012-11-29 at 18:20 +0000, Anil Madhavapeddy
wrote:> On 29 Nov 2012, at 18:03, Ian Campbell <Ian.Campbell@citrix.com>
wrote:
> > 
> > Another idea might be to make the bindings use the async interfaces
> > wherever possible by default, by definition anything potentially
> > blocking has supports this and that would avoid the need for
> > enter/leave, but at the expense of making the ocaml callers ugly
> > perhaps? Or maybe this sort of thing ends up looking very natural in
> > ocaml? Depends on your application''s event mechanism I
suspect.
> > 
> > Last half witted idea: everything could be async but the bindings
> > include the loop to wait for the async event, i.e. effectively making
> > the call sync again. This sounds silly but it might allow better
control
> > over the placement of enter/leave vs callbacks, since you would just
> > drop it over libxl_event_wait?
> 
> Making everything explicitly async and non-blocking is by far the
> preferred solution in terms of stability, as it largely removes the
> need to worry about the GC interface and thread interactions.
> 
> There are several libraries to wrap async interfaces in convenient
> synchronous programming, most notably Lwt (http://ocsigen.org/lwt).
I''ll have to take your word for that ;-)
> With this interface, all the OCaml callbacks are implemented in
> OCaml, and it just needs a select/epoll or equivalent to wake up
> sleeping threads when an IO event occurs.
On the libxl side you''d want to be using the ao_how thing described in
libxl.h[0] and probably the event loop stuff in libxl_event.h[1]. My gut
feeling is that you''d want to go the libxl_osevent_register_hooks route
to integrate libxl into lwt''s event loop rather than the
libxl_osevent_{before,after}poll option.

[0]
http://xenbits.xen.org/hg/xen-unstable.hg/file/1c69c938f641/tools/libxl/libxl.h#l377
[1]
http://xenbits.xen.org/hg/xen-unstable.hg/file/1c69c938f641/tools/libxl/libxl_event.h

Ian.
> 
> Dave has already done some bindings to Lwt, so I''ve CCed him...
> 
> -anil
>

Rob Hoes

2012-Nov-30 10:04 UTC

head link

Re: [Xen-API] [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

> > > Another idea might be to make the bindings use the async
interfaces
> > > wherever possible by default, by definition anything potentially
> > > blocking has supports this and that would avoid the need for
> > > enter/leave, but at the expense of making the ocaml callers ugly
> > > perhaps? Or maybe this sort of thing ends up looking very natural
in
> > > ocaml? Depends on your application''s event mechanism I
suspect.
> > >
> > > Last half witted idea: everything could be async but the bindings
> > > include the loop to wait for the async event, i.e. effectively
> > > making the call sync again. This sounds silly but it might allow
> > > better control over the placement of enter/leave vs callbacks,
since
> > > you would just drop it over libxl_event_wait?
> >
> > Making everything explicitly async and non-blocking is by far the
> > preferred solution in terms of stability, as it largely removes the
> > need to worry about the GC interface and thread interactions.
> >
> > There are several libraries to wrap async interfaces in convenient
> > synchronous programming, most notably Lwt (http://ocsigen.org/lwt).
> 
> I''ll have to take your word for that ;-)
> 
> > With this interface, all the OCaml callbacks are implemented in OCaml,
> > and it just needs a select/epoll or equivalent to wake up sleeping
> > threads when an IO event occurs.
> 
> On the libxl side you''d want to be using the ao_how thing
described in
> libxl.h[0] and probably the event loop stuff in libxl_event.h[1]. My gut
> feeling is that you''d want to go the libxl_osevent_register_hooks
route to
> integrate libxl into lwt''s event loop rather than the
> libxl_osevent_{before,after}poll option.
> 
> [0] http://xenbits.xen.org/hg/xen-
> unstable.hg/file/1c69c938f641/tools/libxl/libxl.h#l377
> [1] http://xenbits.xen.org/hg/xen-
> unstable.hg/file/1c69c938f641/tools/libxl/libxl_event.h
Great, I completely forgot about the possibility of doing async calls to libxl.
This sounds like an ideal solution, especially if we can avoid messing with the
GC system this way (those segfaults are really hard to debug). It may be a nice
excuse to get started with Lwt as well ;)

I''ll do some investigation on how to integrate this.

Cheers,
Rob
> 
> Ian.
> 
> >
> > Dave has already done some bindings to Lwt, so I''ve CCed
him...
> >
> > -anil
> >
>

Xen devel - Nov 2012 - [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

[PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

Re: [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

Re: [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

Re: [Xen-API] [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

Re: [Xen-API] [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)

Re: [Xen-API] [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)