libxl: ocaml: improve the bindings

libxl: ocaml: improve the bindings

[Rob Hoes]

The following series of patches fill in most of the gaps in the OCaml bindings
to libxl, to make them useful for clients such as xapi/xenopsd (from
XenServer). There are a number of bugfixes to the existing bindings as well. I
have an experimental version of xenopsd that successfully uses the new
bindings.

This is version 3 of this patch series to fix the OCaml binding to libxl. I
believe I have addressed all the points raised by Ian Jackson's review of
version 2. See the individual patches for detailed changes with respect to v2.

For convenience, the patches in this series may be pulled using:

git pull git://github.com/robhoes/xen.git hydrogen-upstream-v3-rebased

---
Resend note: rebased to current master, to take into account the changed
interface to libxl_domain_create_restore.

[PATCH v3-RESEND 01/28] libxl: idl: allow KeyedUnion members to be empty

[Rob Hoes]

This is useful when the key enum has an "invalid" option and avoids
the need to declare a dummy struct. Use this for domain_build_info
resulting in the generated API changing like so:
    --- tools/libxl/_libxl_BACKUP_types.h
    +++ tools/libxl/_libxl_types.h
    @@ -377,8 +377,6 @@ typedef struct libxl_domain_build_info {
                 const char * features;
                 libxl_defbool e820_host;
             } pv;
    -        struct {
    -        } invalid;
         } u;
     } libxl_domain_build_info;
     void libxl_domain_build_info_dispose(libxl_domain_build_info *p);

+ a related change to the JSON generation.

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>
---
 tools/libxl/gentest.py      |    3 ++-
 tools/libxl/gentypes.py     |   11 ++++++++---
 tools/libxl/libxl_types.idl |    2 +-
 3 files changed, 11 insertions(+), 5 deletions(-)

diff --git a/tools/libxl/gentest.py b/tools/libxl/gentest.py
index 84b4fd7..6fab493 100644
--- a/tools/libxl/gentest.py
+++ b/tools/libxl/gentest.py
@@ -46,7 +46,8 @@ def gen_rand_init(ty, v, indent = "    ", parent = None):
         for f in ty.fields:
             (nparent,fexpr) = ty.member(v, f, parent is None)
             s += "case %s:\n" % f.enumname
-            s += gen_rand_init(f.type, fexpr, indent + "    ", nparent)
+            if f.type is not None:
+                s += gen_rand_init(f.type, fexpr, indent + "    ", nparent)
             s += "    break;\n"
         s += "}\n"
     elif isinstance(ty, idl.Struct) \
diff --git a/tools/libxl/gentypes.py b/tools/libxl/gentypes.py
index 30f29ba..be06257 100644
--- a/tools/libxl/gentypes.py
+++ b/tools/libxl/gentypes.py
@@ -45,6 +45,8 @@ def libxl_C_type_define(ty, indent = ""):
             s += "typedef %s %s {\n" % (ty.kind, ty.typename)
 
         for f in ty.fields:
+            if isinstance(ty, idl.KeyedUnion) and f.type is None: continue
+            
             x = libxl_C_instance_of(f.type, f.name)
             if f.const:
                 x = "const " + x
@@ -67,7 +69,8 @@ def libxl_C_type_dispose(ty, v, indent = "    ", parent = None):
         for f in ty.fields:
             (nparent,fexpr) = ty.member(v, f, parent is None)
             s += "case %s:\n" % f.enumname
-            s += libxl_C_type_dispose(f.type, fexpr, indent + "    ", nparent)
+            if f.type is not None:
+                s += libxl_C_type_dispose(f.type, fexpr, indent + "    ", nparent)
             s += "    break;\n"
         s += "}\n"
     elif isinstance(ty, idl.Array):
@@ -115,7 +118,8 @@ def _libxl_C_type_init(ty, v, indent = "    ", parent = None, subinit=False):
             for f in ty.fields:
                 (nparent,fexpr) = ty.member(v, f, parent is None)
                 s += "case %s:\n" % f.enumname
-                s += _libxl_C_type_init(f.type, fexpr, "    ", nparent)
+                if f.type is not None:
+                    s += _libxl_C_type_init(f.type, fexpr, "    ", nparent)
                 s += "    break;\n"
             s += "}\n"
         else:
@@ -214,7 +218,8 @@ def libxl_C_type_gen_json(ty, v, indent = "    ", parent = None):
         for f in ty.fields:
             (nparent,fexpr) = ty.member(v, f, parent is None)
             s += "case %s:\n" % f.enumname
-            s += libxl_C_type_gen_json(f.type, fexpr, indent + "    ", nparent)
+            if f.type is not None:
+                s += libxl_C_type_gen_json(f.type, fexpr, indent + "    ", nparent)
             s += "    break;\n"
         s += "}\n"
     elif isinstance(ty, idl.Struct) and (parent is None or ty.json_fn is None):
diff --git a/tools/libxl/libxl_types.idl b/tools/libxl/libxl_types.idl
index d2cea8a..5c43d6f 100644
--- a/tools/libxl/libxl_types.idl
+++ b/tools/libxl/libxl_types.idl
@@ -362,7 +362,7 @@ libxl_domain_build_info = Struct("domain_build_info",[
                                       # Use host's E820 for PCI passthrough.
                                       ("e820_host", libxl_defbool),
                                       ])),
-                 ("invalid", Struct(None, [])),
+                 ("invalid", None),
                  ], keyvar_init_val = "LIBXL_DOMAIN_TYPE_INVALID")),
     ], dir=DIR_IN
 )
-- 
1.7.10.4

[PATCH v3-RESEND 02/28] libxl: ocaml: support for Arrays in bindings generator.

[Rob Hoes]

No change in generated code because no arrays are currently generated.

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py |   11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 5757218..1b68b6b 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -143,7 +143,14 @@ def c_val(ty, c, o, indent="", parent = None):
             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):
-        raise("Cannot handle Array type\n")
+        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
@@ -207,7 +214,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
         s += "\t    value 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]", "")
+        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}"
-- 
1.7.10.4

[PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Rob Hoes]

Do this by adding a "xl_" prefix to all names.

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

---
New in v3:
* Using common prefixes rather than changing names on a case by case basis.
---
 tools/ocaml/libs/xl/genwrap.py |    5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 1b68b6b..a14fcfe 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -70,8 +70,11 @@ def ocaml_type_of(ty):
     else:
         return ty.rawname
 
+def munge_name(name):
+    return "xl_" + name
+
 def ocaml_instance_of(type, name):
-    return "%s : %s" % (name, ocaml_type_of(type))
+    return "%s : %s" % (munge_name(name), ocaml_type_of(type))
 
 def gen_ocaml_ml(ty, interface, indent=""):
 
-- 
1.7.10.4

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Do this by adding a "xl_" prefix to all names.

Does this not result in pretty fugly looking ocaml code with lots of
spurious "xl_" everywhere?

> 
> Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> 
> ---
> New in v3:
> * Using common prefixes rather than changing names on a case by case basis.
> ---
>  tools/ocaml/libs/xl/genwrap.py |    5 ++++-
>  1 file changed, 4 insertions(+), 1 deletion(-)
> 
> diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
> index 1b68b6b..a14fcfe 100644
> --- a/tools/ocaml/libs/xl/genwrap.py
> +++ b/tools/ocaml/libs/xl/genwrap.py
> @@ -70,8 +70,11 @@ def ocaml_type_of(ty):
>      else:
>          return ty.rawname
>  
> +def munge_name(name):
> +    return "xl_" + name
> +
>  def ocaml_instance_of(type, name):
> -    return "%s : %s" % (name, ocaml_type_of(type))
> +    return "%s : %s" % (munge_name(name), ocaml_type_of(type))
>  
>  def gen_ocaml_ml(ty, interface, indent=""):
>  

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Rob Hoes]

On 24 Oct 2013, at 23:04, Ian Campbell <ian.campbell@citrix.com>
 wrote:

> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
>> Do this by adding a "xl_" prefix to all names.
> 
> Does this not result in pretty fugly looking ocaml code with lots of
> spurious "xl_" everywhere?

Yes… I'm not too happy about that, but I think it is the only easy enough way of making this transformation "injective", as IanJ suggested. The alternative would be to change the munge function on a case-by-case basis, e.g. whenever someone adds a name which happens to be an OCaml keyword to the libxl IDL.

>> 
>> Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
>> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
>> 
>> ---
>> New in v3:
>> * Using common prefixes rather than changing names on a case by case basis.
>> ---
>> tools/ocaml/libs/xl/genwrap.py |    5 ++++-
>> 1 file changed, 4 insertions(+), 1 deletion(-)
>> 
>> diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
>> index 1b68b6b..a14fcfe 100644
>> --- a/tools/ocaml/libs/xl/genwrap.py
>> +++ b/tools/ocaml/libs/xl/genwrap.py
>> @@ -70,8 +70,11 @@ def ocaml_type_of(ty):
>>     else:
>>         return ty.rawname
>> 
>> +def munge_name(name):
>> +    return "xl_" + name
>> +
>> def ocaml_instance_of(type, name):
>> -    return "%s : %s" % (name, ocaml_type_of(type))
>> +    return "%s : %s" % (munge_name(name), ocaml_type_of(type))
>> 
>> def gen_ocaml_ml(ty, interface, indent=""):
>> 
> 
> 

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Ian Campbell]

On Thu, 2013-10-24 at 23:11 +0100, Rob Hoes wrote:
> On 24 Oct 2013, at 23:04, Ian Campbell <ian.campbell@citrix.com>
>  wrote:
> 
> > On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> >> Do this by adding a "xl_" prefix to all names.
> > 
> > Does this not result in pretty fugly looking ocaml code with lots of
> > spurious "xl_" everywhere?
> 
> Yes… I'm not too happy about that, but I think it is the only easy
> enough way of making this transformation "injective", as IanJ
> suggested.

If the result of making the transformation injective is that the ocaml
code looks like libxl.xl_domain_build.xl_max_memkb then I think the cure
has been worse than the disease.

I would suggest that if libxl has a structure which has both type and ty
fields then we have a bug in our API due to the use of confusingly
similar field names which are not easily discriminated i.e. they should
have been foo_type and bar_type (but perhaps due to API stability they
would have to be type and bar_type in practice).

The approach used here could be made slightly more palatable by only
applying it to names of the form "([prefix])*[keyword]", by applying a
new prefix. i.e. type -> xl_type -> xl_xl_type.

>  The alternative would be to change the munge function on a
> case-by-case basis, e.g. whenever someone adds a name which happens to
> be an OCaml keyword to the libxl IDL.

There aren't all that many ocaml keywords, I suppose? I expect many of
them are unlikely field names. If we don't want to enumerate them up
front (which I would accept, it's a bit tedious) I'd be perfectly happy
to fault things in as the libxl IDL gains new inconveniently named
fields, it'll break the build so we should notice pretty quickly!

Ian.


_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xen.org
http://lists.xen.org/xen-devel

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Rob Hoes]

> On Thu, 2013-10-24 at 23:11 +0100, Rob Hoes wrote:
> > On 24 Oct 2013, at 23:04, Ian Campbell <ian.campbell@citrix.com>
> >  wrote:
> >
> > > On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > >> Do this by adding a "xl_" prefix to all names.
> > >
> > > Does this not result in pretty fugly looking ocaml code with lots of
> > > spurious "xl_" everywhere?
> >
> > Yes… I'm not too happy about that, but I think it is the only easy
> > enough way of making this transformation "injective", as IanJ
> > suggested.
> 
> If the result of making the transformation injective is that the ocaml code
> looks like libxl.xl_domain_build.xl_max_memkb then I think the cure has
> been worse than the disease.

It's not quite that bad, because it is only needed for lower-case stuff and therefore excludes module names. Your example would be "Xenlight.Domain_build_info.xl_max_memkb". But yes, it does make things look a bit odd.

> I would suggest that if libxl has a structure which has both type and ty fields
> then we have a bug in our API due to the use of confusingly similar field
> names which are not easily discriminated i.e. they should have been
> foo_type and bar_type (but perhaps due to API stability they would have to
> be type and bar_type in practice).
> 
> The approach used here could be made slightly more palatable by only
> applying it to names of the form "([prefix])*[keyword]", by applying a new
> prefix. i.e. type -> xl_type -> xl_xl_type.
> 
> >  The alternative would be to change the munge function on a
> > case-by-case basis, e.g. whenever someone adds a name which happens
> to
> > be an OCaml keyword to the libxl IDL.
> 
> There aren't all that many ocaml keywords, I suppose? I expect many of
> them are unlikely field names. If we don't want to enumerate them up front
> (which I would accept, it's a bit tedious) I'd be perfectly happy to fault things
> in as the libxl IDL gains new inconveniently named fields, it'll break the
> build so we should notice pretty quickly!

I'd be very happy with that, if it is acceptable to you and IanJ!

Cheers,
Rob

_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xen.org
http://lists.xen.org/xen-devel

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Ian Jackson]

Rob Hoes writes ("RE: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names."):
> > There aren't all that many ocaml keywords, I suppose? I expect
> > many of them are unlikely field names. If we don't want to
> > enumerate them up front (which I would accept, it's a bit tedious)
> > I'd be perfectly happy to fault things in as the libxl IDL gains
> > new inconveniently named fields, it'll break the build so we
> > should notice pretty quickly!
> 
> I'd be very happy with that, if it is acceptable to you and IanJ!

That would be fine by me.  I would marginally prefer to simply dump a
list of the ocaml keywords into the ocaml idl generator.

(I definitely agree with Ian that the transformation should be such
that most words are unchanged.  I think  s/^(xl_)*(KEYWORD)$/xl_$&/
should do it.)

Ian.

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Ian Campbell]

On Mon, 2013-10-28 at 15:24 +0000, Ian Jackson wrote:
> Rob Hoes writes ("RE: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names."):
> > > There aren't all that many ocaml keywords, I suppose? I expect
> > > many of them are unlikely field names. If we don't want to
> > > enumerate them up front (which I would accept, it's a bit tedious)
> > > I'd be perfectly happy to fault things in as the libxl IDL gains
> > > new inconveniently named fields, it'll break the build so we
> > > should notice pretty quickly!
> > 
> > I'd be very happy with that, if it is acceptable to you and IanJ!
> 
> That would be fine by me.  I would marginally prefer to simply dump a
> list of the ocaml keywords into the ocaml idl generator.

http://caml.inria.fr/pub/docs/manual-ocaml-4.01/manual044.html seems to
have a list, I suppose it is reasonably static across ocaml updates?
It's not too insane to include it all now. Using most of them in our ABI
would be a bug in our ABI IMHO and/or are already C reserved words (e.g.
"else", "false" etc).

Ian.

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Ian Jackson]

Ian Campbell writes ("Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names."):
> On Mon, 2013-10-28 at 15:24 +0000, Ian Jackson wrote:
> > That would be fine by me.  I would marginally prefer to simply dump a
> > list of the ocaml keywords into the ocaml idl generator.
> 
> http://caml.inria.fr/pub/docs/manual-ocaml-4.01/manual044.html seems to
> have a list, I suppose it is reasonably static across ocaml updates?
> It's not too insane to include it all now. Using most of them in our ABI
> would be a bug in our ABI IMHO

Right.

> and/or are already C reserved words (e.g. "else", "false" etc).

Irrelevant now, but I would be tempted to say that if we would really
want to pick a C reserved word for an IDL item we should do a similar
workaround for C.  Ie I don't think C should be special.  But C's set
of reserved words is small enough that it's not very likely.

And even more irrelevant: this happened to me in a previous life.  We
had an IDL-based code generator.  One of the fields in one of our
structs was called "export".  A few years later, the C++ people
decided to introduce a new keyword, "export".  We were quite cross...

Ian.

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Ian Campbell]

On Thu, 2013-10-31 at 14:27 +0000, Ian Jackson wrote:
> Ian Campbell writes ("Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names."):
> > On Mon, 2013-10-28 at 15:24 +0000, Ian Jackson wrote:
> > > That would be fine by me.  I would marginally prefer to simply dump a
> > > list of the ocaml keywords into the ocaml idl generator.
> > 
> > http://caml.inria.fr/pub/docs/manual-ocaml-4.01/manual044.html seems to
> > have a list, I suppose it is reasonably static across ocaml updates?
> > It's not too insane to include it all now. Using most of them in our ABI
> > would be a bug in our ABI IMHO
> 
> Right.
> 
> > and/or are already C reserved words (e.g. "else", "false" etc).
> 
> Irrelevant now, but I would be tempted to say that if we would really
> want to pick a C reserved word for an IDL item we should do a similar
> workaround for C.  Ie I don't think C should be special.

Sounds reasonable.

>   But C's set
> of reserved words is small enough that it's not very likely.

Yes.

> And even more irrelevant: this happened to me in a previous life.  We
> had an IDL-based code generator.  One of the fields in one of our
> structs was called "export".  A few years later, the C++ people
> decided to introduce a new keyword, "export".  We were quite cross...

I can imagine ;-)

Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid reserved words in type and field names.

[Rob Hoes]

> On Thu, 2013-10-31 at 14:27 +0000, Ian Jackson wrote:
> > Ian Campbell writes ("Re: [PATCH v3-RESEND 03/28] libxl: ocaml: avoid
> reserved words in type and field names."):
> > > On Mon, 2013-10-28 at 15:24 +0000, Ian Jackson wrote:
> > > > That would be fine by me.  I would marginally prefer to simply
> > > > dump a list of the ocaml keywords into the ocaml idl generator.
> > >
> > > http://caml.inria.fr/pub/docs/manual-ocaml-4.01/manual044.html
> seems
> > > to have a list, I suppose it is reasonably static across ocaml updates?
> > > It's not too insane to include it all now. Using most of them in our
> > > ABI would be a bug in our ABI IMHO
> >
> > Right.
> >
> > > and/or are already C reserved words (e.g. "else", "false" etc).
> >
> > Irrelevant now, but I would be tempted to say that if we would really
> > want to pick a C reserved word for an IDL item we should do a similar
> > workaround for C.  Ie I don't think C should be special.
> 
> Sounds reasonable.

Ok, so I'll change the patch to include the list of OCaml keywords, and have the munge function add an "xl_" prefix to those and only those names that are in the list.

Thanks,
Rob

> >   But C's set
> > of reserved words is small enough that it's not very likely.
> 
> Yes.
> 
> > And even more irrelevant: this happened to me in a previous life.  We
> > had an IDL-based code generator.  One of the fields in one of our
> > structs was called "export".  A few years later, the C++ people
> > decided to introduce a new keyword, "export".  We were quite cross...
> 
> I can imagine ;-)
> 

[PATCH v3-RESEND 04/28] libxl: ocaml: support for KeyedUnion in the bindings generator.

[Rob Hoes]

A KeyedUnion consists of two fields in the containing struct. First an
enum field ("e") used as a descriminator and second a union ("u")
containing potentially anonymous structs associated with each enum
value.

We map the anonymous structs to structs named after the descriminator
field ("e") and the specific enum values. We then declare an ocaml
variant type name e__union mapping each enum value to its associated
struct.

So given IDL:

foo = Enumeration("foo", [
    (0, "BAR"),
    (1, "BAZ"),
])
s = Struct("s", [
    ("u", KeyedUnion(none, foo, "blargle", [
        ("bar", Struct(...xxx...)),
        ("baz", Struct(...yyy...)),
    ])),
])

We generate C:

enum foo { BAR, BAZ };
struct s {
    enum foo blargle;
    union {
        struct { ...xxx... } bar;
        struct { ...yyy... } baz;
    } u;
}

and map this to ocaml

type foo = BAR | BAZ;

module S = struct

    type blargle_bar = ...xxx...;

    type blargle_baz = ...yyy...;

    type blargle__union = Bar of blargle_bar | Baz of blargle_baz;

    type t =
    {
        blargle : blargle__union;
    }
end

These type names are OK because they are already within the namespace
associated with the struct "s".

If the struct associated with bar is empty then we don't bother with
blargle_bar of "of blargle_bar".

No actually change in the generated code since we don't generate any
KeyedUnions yet.

The actual implementation was inspired by
http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php#ref_constvrnt

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/libxl/idl.py             |    3 +
 tools/ocaml/libs/xl/genwrap.py |  162 +++++++++++++++++++++++++++++++++++-----
 2 files changed, 147 insertions(+), 18 deletions(-)

diff --git a/tools/libxl/idl.py b/tools/libxl/idl.py
index 7d95e3f..f4908dd 100644
--- a/tools/libxl/idl.py
+++ b/tools/libxl/idl.py
@@ -216,6 +216,9 @@ class Struct(Aggregate):
         kwargs.setdefault('passby', PASS_BY_REFERENCE)
         Aggregate.__init__(self, "struct", name, fields, **kwargs)
 
+    def has_fields(self):
+        return len(self.fields) != 0
+
 class Union(Aggregate):
     def __init__(self, name, fields, **kwargs):
         # Generally speaking some intelligence is required to free a
diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index a14fcfe..ad14cad 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -65,6 +65,8 @@ def ocaml_type_of(ty):
         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):
         return ty.rawname.capitalize() + ".t"
     else:
@@ -73,8 +75,67 @@ def ocaml_type_of(ty):
 def munge_name(name):
     return "xl_" + name
 
-def ocaml_instance_of(type, name):
-    return "%s : %s" % (munge_name(name), ocaml_type_of(type))
+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):
+    s = ""
+    for f in ty.fields:
+        if f.type.private:
+            continue
+        x = ocaml_instance_of_field(f)
+        x = x.replace("\n", "\n\t\t")
+        s += "\t\t" + x + ";\n"
+    return s
+
+def gen_ocaml_keyedunions(ty, interface, indent, parent = None):
+    s = ""
+    
+    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)
+            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" % (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
+
+    if s == "":
+        return None
+    return s.replace("\n", "\n%s" % indent)
 
 def gen_ocaml_ml(ty, interface, indent=""):
 
@@ -100,16 +161,17 @@ def gen_ocaml_ml(ty, interface, indent=""):
                 s += "module %s : sig\n" % module_name
             else:
                 s += "module %s = struct\n" % module_name
-            s += "\ttype t =\n"
-            s += "\t{\n"
-            
+                
+        # Handle KeyedUnions...
         for f in ty.fields:
-            if f.type.private:
-                continue
-            x = ocaml_instance_of(f.type, f.name)
-            x = x.replace("\n", "\n\t\t")
-            s += "\t\t" + x + ";\n"
-
+            ku = gen_ocaml_keyedunions(f.type, interface, "\t")
+            if ku is not None:
+                s += ku
+                s += "\n"
+
+        s += "\ttype t =\n"
+        s += "\t{\n"
+        s += gen_struct(ty)
         s += "\t}\n"
         
         if functions.has_key(ty.rawname):
@@ -162,12 +224,43 @@ def c_val(ty, c, o, indent="", parent = None):
             n += 1
         s += "    default: failwith_xl(\"cannot convert value to %s\", lg); break;\n" % ty.typename
         s += "}"
-    elif isinstance(ty, idl.Aggregate) and (parent is None):
+    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(\"variant handling bug %s%s (long)\", lg); 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, indent=indent+"\t\t        ")
+                s += "break;\n"
+                n += 1
+        s += "\t\t    default: failwith_xl(\"variant handling bug %s%s (block)\", lg); 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, parent is None)
+            (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:
@@ -189,7 +282,7 @@ def gen_c_val(ty, indent=""):
     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):
@@ -229,9 +322,42 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
             n += 1
         s += "    default: failwith_xl(\"cannot convert value from %s\", lg); break;\n" % ty.typename
         s += "}"
-    elif isinstance(ty,idl.Aggregate) and (parent is None):
+    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(\"cannot convert value from %s\", lg); break;\n" % ty.typename
+        s += "\t}"
+    elif isinstance(ty,idl.Aggregate) and (parent is None or ty.rawname is None):
         s += "{\n"
-        s += "\tvalue %s_field;\n" % ty.rawname
+        if ty.rawname is None:
+            fn = "anon_field"
+        else:
+            fn = "%s_field" % ty.rawname
+        s += "\tvalue %s;\n" % fn
         s += "\n"
         s += "\t%s = caml_alloc_tuple(%d);\n" % (o, len(ty.fields))
         
@@ -243,8 +369,8 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
             (nparent,fexpr) = ty.member(c, f, parent is None)
 
             s += "\n"
-            s += "\t%s\n" % ocaml_Val(f.type, "%s_field" % ty.rawname, ty.pass_arg(fexpr, c), parent=nparent)
-            s += "\tStore_field(%s, %d, %s);\n" % (o, n, "%s_field" % ty.rawname)
+            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:
-- 
1.7.10.4

[PATCH v3-RESEND 05/28] libxl: ocaml: add some more builtin types.

[Rob Hoes]

  * bitmaps
  * string_list
  * key_value_list
  * cpuid_policy_list (left "empty" for now)

None of these are used yet, so no change to the generated code.

Bitmap_val requires a ctx, so leave it as an abort for now.

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |    6 +-
 tools/ocaml/libs/xl/xenlight_stubs.c |  127 ++++++++++++++++++++++++++++++----
 2 files changed, 119 insertions(+), 14 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index ad14cad..d5688c8 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -13,9 +13,13 @@ builtins = {
     "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(gc, lg, &%(c)s, %(o)s)",   "Val_uuid(&%(c)s)"),
-    "libxl_key_value_list": ("(string * string) list", None,                                None),
+    "libxl_bitmap":         ("bool array",             "Bitmap_val(gc, lg, &%(c)s, %(o)s)",   "Val_bitmap(&%(c)s)"),    
+    "libxl_key_value_list": ("(string * string) list", "libxl_key_value_list_val(gc, lg, &%(c)s, %(o)s)", "Val_key_value_list(&%(c)s)"),
+    "libxl_string_list":    ("string list",            "libxl_string_list_val(gc, lg, &%(c)s, %(o)s)", "Val_string_list(&%(c)s)"),
     "libxl_mac":            ("int array",              "Mac_val(gc, lg, &%(c)s, %(o)s)",    "Val_mac(&%(c)s)"),
     "libxl_hwcap":          ("int32 array",            None,                                "Val_hwcap(&%(c)s)"),
+    # The following needs to be sorted out later
+    "libxl_cpuid_policy_list": ("unit",                "%(c)s = 0",                         "Val_unit"),
     }
 
 DEVICE_FUNCTIONS = [ ("add",            ["t", "domid", "unit"]),
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 5f19a82..a7bf6ba 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -27,6 +27,7 @@
 #include <string.h>
 
 #include <libxl.h>
+#include <libxl_utils.h>
 
 struct caml_logger {
 	struct xentoollog_logger logger;
@@ -96,7 +97,6 @@ static void failwith_xl(char *fname, struct caml_logger *lg)
 	caml_raise_with_string(*caml_named_value("xl.error"), s);
 }
 
-#if 0 /* TODO: wrap libxl_domain_create(), these functions will be needed then */
 static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size)
 {
 	void *ptr;
@@ -107,28 +107,103 @@ static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size)
 	return ptr;
 }
 
-static int string_string_tuple_array_val (caml_gc *gc, char ***c_val, value v)
+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(caml_gc *gc, struct caml_logger *lg,
+				    libxl_key_value_list *c_val,
+				    value v)
 {
 	CAMLparam1(v);
-	CAMLlocal1(a);
-	int i;
-	char **array;
+	CAMLlocal1(elem);
+	int nr, i;
+	libxl_key_value_list array;
 
-	for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1)) { i++; }
+	nr = list_len(v);
 
-	array = gc_calloc(gc, (i + 1) * 2, sizeof(char *));
+	array = gc_calloc(gc, (nr + 1) * 2, sizeof(char *));
 	if (!array)
-		return 1;
-	for (i = 0, a = Field(v, 5); a != Val_emptylist; a = Field(a, 1), i++) {
-		value b = Field(a, 0);
-		array[i * 2] = dup_String_val(gc, Field(b, 0));
-		array[i * 2 + 1] = dup_String_val(gc, Field(b, 1));
+		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(gc, Field(elem, 0));
+		array[i * 2 + 1] = dup_String_val(gc, Field(elem, 1));
 	}
+
 	*c_val = array;
 	CAMLreturn(0);
 }
 
-#endif
+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((char *) c_val[i]);
+		key = caml_copy_string((char *) 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(caml_gc *gc, struct caml_logger *lg,
+				 libxl_string_list *c_val,
+				 value v)
+{
+	CAMLparam1(v);
+	int nr, i;
+	libxl_string_list array;
+
+	nr = list_len(v);
+
+	array = gc_calloc(gc, (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(gc, 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((char *) 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 */
 #define Val_none Val_int(0)
@@ -168,6 +243,32 @@ static int Mac_val(caml_gc *gc, struct caml_logger *lg, libxl_mac *c_val, value
 	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(caml_gc *gc, struct caml_logger *lg,
+		      libxl_bitmap *c_val, value v)
+{
+	abort(); /* XXX */
+}
+
 static value Val_uuid (libxl_uuid *c_val)
 {
 	CAMLparam0();
-- 
1.7.10.4

[PATCH v3-RESEND 06/28] libxc: ocaml: add simple binding for xentoollog (output only).

[Rob Hoes]

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>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

---
New in v3:
* Auto-generate the log-level converters from xentoollog.h.
* Move the stdio logger from the library to the test suite.
* Use a counter instead of a random number when registering a callback.
---
 .gitignore                                     |    1 +
 .hgignore                                      |    1 +
 tools/ocaml/Makefile                           |    2 +-
 tools/ocaml/Makefile.rules                     |    2 +-
 tools/ocaml/libs/Makefile                      |    1 +
 tools/ocaml/libs/xentoollog/META.in            |    4 +
 tools/ocaml/libs/xentoollog/Makefile           |   61 ++++++++
 tools/ocaml/libs/xentoollog/caml_xentoollog.h  |   24 +++
 tools/ocaml/libs/xentoollog/genlevels.py       |  127 +++++++++++++++
 tools/ocaml/libs/xentoollog/xentoollog.ml.in   |   48 ++++++
 tools/ocaml/libs/xentoollog/xentoollog.mli.in  |   43 ++++++
 tools/ocaml/libs/xentoollog/xentoollog_stubs.c |  196 ++++++++++++++++++++++++
 tools/ocaml/test/Makefile                      |   28 ++++
 tools/ocaml/test/xtl.ml                        |   40 +++++
 14 files changed, 576 insertions(+), 2 deletions(-)
 create mode 100644 tools/ocaml/libs/xentoollog/META.in
 create mode 100644 tools/ocaml/libs/xentoollog/Makefile
 create mode 100644 tools/ocaml/libs/xentoollog/caml_xentoollog.h
 create mode 100755 tools/ocaml/libs/xentoollog/genlevels.py
 create mode 100644 tools/ocaml/libs/xentoollog/xentoollog.ml.in
 create mode 100644 tools/ocaml/libs/xentoollog/xentoollog.mli.in
 create mode 100644 tools/ocaml/libs/xentoollog/xentoollog_stubs.c
 create mode 100644 tools/ocaml/test/Makefile
 create mode 100644 tools/ocaml/test/xtl.ml

diff --git a/.gitignore b/.gitignore
index 3253675..f51c345 100644
--- a/.gitignore
+++ b/.gitignore
@@ -384,6 +384,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 --git a/.hgignore b/.hgignore
index 05cb0de..bb1b67d 100644
--- a/.hgignore
+++ b/.hgignore
@@ -308,6 +308,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 --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile
index 6b22bbe..8e4ca36 100644
--- a/tools/ocaml/Makefile
+++ b/tools/ocaml/Makefile
@@ -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 --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules
index 5e6d81e..0745e83 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 bca0fa2..3afdc89 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 0000000..7b06683
--- /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 0000000..e535ba5
--- /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 0000000..0eb7618
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/caml_xentoollog.h
@@ -0,0 +1,24 @@
+/*
+ * 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)))
+
diff --git a/tools/ocaml/libs/xentoollog/genlevels.py b/tools/ocaml/libs/xentoollog/genlevels.py
new file mode 100755
index 0000000..6b42f21
--- /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 <mli> <ml> <c-inc>"
+		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 0000000..ce9ea1d
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/xentoollog.ml.in
@@ -0,0 +1,48 @@
+(*
+ * 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)
+
diff --git a/tools/ocaml/libs/xentoollog/xentoollog.mli.in b/tools/ocaml/libs/xentoollog/xentoollog.mli.in
new file mode 100644
index 0000000..05c098a
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/xentoollog.mli.in
@@ -0,0 +1,43 @@
+(*
+ * 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
+
diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
new file mode 100644
index 0000000..3b2f91b
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
@@ -0,0 +1,196 @@
+/*
+ * 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"
+
+#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);
+}
+
diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile
new file mode 100644
index 0000000..980054c
--- /dev/null
+++ b/tools/ocaml/test/Makefile
@@ -0,0 +1,28 @@
+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 \
+	-cclib -lxenctrl
+
+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 --git a/tools/ocaml/test/xtl.ml b/tools/ocaml/test/xtl.ml
new file mode 100644
index 0000000..db30aae
--- /dev/null
+++ b/tools/ocaml/test/xtl.ml
@@ -0,0 +1,40 @@
+open Arg
+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 s -> ()) usage_msg;
+
+  do_test !debug_level
-- 
1.7.10.4

Re: [PATCH v3-RESEND 06/28] libxc: ocaml: add simple binding for xentoollog (output only).

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> [...]

> +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();

Coverity is rightly pointing out that an array cannot be NULL. Would you
mind fixing as part of the resend of the remainder of this series?

[...]
> +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();

Another one.

Ian.

Re: [PATCH v3-RESEND 06/28] libxc: ocaml: add simple binding for xentoollog (output only).

[Rob Hoes]

IanC wrote:
> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > [...]
> 
> > +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();
> 
> Coverity is rightly pointing out that an array cannot be NULL. Would you
> mind fixing as part of the resend of the remainder of this series?

Sure, I'll fix that.

Andrew Cooper showed me another issue found by Coverity. We have a fix, which I'll submit as well.

Rob

> [...]
> > +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();
> 
> Another one.
> 
> Ian.

Re: [PATCH v3-RESEND 06/28] libxc: ocaml: add simple binding for xentoollog (output only).

[Andrew Cooper]

On 14/11/13 14:11, Rob Hoes wrote:
> IanC wrote:
>> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
>>> [...]
>>> +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();
>> Coverity is rightly pointing out that an array cannot be NULL. Would you
>> mind fixing as part of the resend of the remainder of this series?
> Sure, I'll fix that.
>
> Andrew Cooper showed me another issue found by Coverity. We have a fix, which I'll submit as well.
>
> Rob

Following our bit of debugging in this area, I notice that the current
series leaves some intermediate files around.

tools/ocaml/libs/xentoollog/_xtl_levels.inc
tools/ocaml/libs/xentoollog/_xtl_levels.ml.in
tools/ocaml/libs/xentoollog/_xtl_levels.mli.in
tools/ocaml/libs/xentoollog/xentoollog.ml
tools/ocaml/libs/xentoollog/xentoollog.mli

When fixing this stuff up, do you mind also modifying
.gitignore/.hgignore for all the intermediate files creates?

~Andrew

[PATCH v3-RESEND 07/28] libxl: ocaml: allocate a long lived libxl context.

[Rob Hoes]

Rather than allocating a new context for every libxl call begin to
switch to a model where a context is allocated by the caller and may
then be used for multiple calls down into the library.

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

---
New in v3:
* Removed unneeded bits of the patch (which were anyway removed in a later
  patch).
---
 tools/ocaml/libs/xl/META.in          |    1 +
 tools/ocaml/libs/xl/Makefile         |    3 +++
 tools/ocaml/libs/xl/xenlight.ml.in   |    4 ++++
 tools/ocaml/libs/xl/xenlight.mli.in  |    4 ++++
 tools/ocaml/libs/xl/xenlight_stubs.c |   37 ++++++++++++++++++++++++++++++++++
 5 files changed, 49 insertions(+)

diff --git a/tools/ocaml/libs/xl/META.in b/tools/ocaml/libs/xl/META.in
index fe2c60b..3f0c552 100644
--- a/tools/ocaml/libs/xl/META.in
+++ b/tools/ocaml/libs/xl/META.in
@@ -1,4 +1,5 @@
 version = "@VERSION@"
 description = "Xen Toolstack Library"
+requires = "xentoollog"
 archive(byte) = "xenlight.cma"
 archive(native) = "xenlight.cmxa"
diff --git a/tools/ocaml/libs/xl/Makefile b/tools/ocaml/libs/xl/Makefile
index c9e5274..6917a20 100644
--- a/tools/ocaml/libs/xl/Makefile
+++ b/tools/ocaml/libs/xl/Makefile
@@ -5,11 +5,14 @@ include $(TOPLEVEL)/common.make
 # ignore unused generated functions
 CFLAGS += -Wno-unused
 CFLAGS += $(CFLAGS_libxenlight)
+CFLAGS += -I ../xentoollog
 
 OBJS = xenlight
 INTF = xenlight.cmi
 LIBS = xenlight.cma xenlight.cmxa
 
+OCAMLINCLUDE += -I ../xentoollog
+
 LIBS_xenlight = $(LDLIBS_libxenlight)
 
 xenlight_OBJS = $(OBJS)
diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index dcc1a38..3d663d8 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -20,6 +20,10 @@ type devid = int
 
 (* @@LIBXL_TYPES@@ *)
 
+type ctx
+
+external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
+
 external send_trigger : domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index 3fd0165..96d859c 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -20,6 +20,10 @@ type devid = int
 
 (* @@LIBXL_TYPES@@ *)
 
+type ctx
+
+external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
+
 external send_trigger : domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index a7bf6ba..c26226f 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -21,6 +21,7 @@
 #include <caml/signals.h>
 #include <caml/fail.h>
 #include <caml/callback.h>
+#include <caml/custom.h>
 
 #include <sys/mman.h>
 #include <stdint.h>
@@ -29,6 +30,11 @@
 #include <libxl.h>
 #include <libxl_utils.h>
 
+#include "caml_xentoollog.h"
+
+#define Ctx_val(x)(*((libxl_ctx **) Data_custom_val(x)))
+#define CTX ((libxl_ctx *) Ctx_val(ctx))
+
 struct caml_logger {
 	struct xentoollog_logger logger;
 	int log_offset;
@@ -97,6 +103,37 @@ static void failwith_xl(char *fname, struct caml_logger *lg)
 	caml_raise_with_string(*caml_named_value("xl.error"), s);
 }
 
+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("cannot init context", NULL);
+
+	handle = caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0, 1);
+	Ctx_val(handle) = ctx;
+
+	CAMLreturn(handle);
+}
+
 static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size)
 {
 	void *ptr;
-- 
1.7.10.4

[PATCH v3-RESEND 08/28] libxl: ocaml: switch all functions over to take a context.

[Rob Hoes]

Since the context has a logger we can get rid of the logger built into these
bindings and use the xentoollog bindings instead.

The gc is of limited use when most things are freed with libxl_FOO_dispose,
so get rid of that too.

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |   44 ++--
 tools/ocaml/libs/xl/xenlight.ml.in   |   11 +-
 tools/ocaml/libs/xl/xenlight.mli.in  |    9 +-
 tools/ocaml/libs/xl/xenlight_stubs.c |  474 +++++++++-------------------------
 4 files changed, 153 insertions(+), 385 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index d5688c8..2a90681 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -8,23 +8,23 @@ import idl
 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",                 "%(c)s = dup_String_val(gc, %(o)s)", "caml_copy_string(%(c)s)"),
+    "char *":               ("string",                 "%(c)s = dup_String_val(%(o)s)", "caml_copy_string(%(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(gc, lg, &%(c)s, %(o)s)",   "Val_uuid(&%(c)s)"),
-    "libxl_bitmap":         ("bool array",             "Bitmap_val(gc, lg, &%(c)s, %(o)s)",   "Val_bitmap(&%(c)s)"),    
-    "libxl_key_value_list": ("(string * string) list", "libxl_key_value_list_val(gc, lg, &%(c)s, %(o)s)", "Val_key_value_list(&%(c)s)"),
-    "libxl_string_list":    ("string list",            "libxl_string_list_val(gc, lg, &%(c)s, %(o)s)", "Val_string_list(&%(c)s)"),
-    "libxl_mac":            ("int array",              "Mac_val(gc, lg, &%(c)s, %(o)s)",    "Val_mac(&%(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)"),
     # The following needs to be sorted out later
     "libxl_cpuid_policy_list": ("unit",                "%(c)s = 0",                         "Val_unit"),
     }
 
-DEVICE_FUNCTIONS = [ ("add",            ["t", "domid", "unit"]),
-                     ("remove",         ["t", "domid", "unit"]),
-                     ("destroy",        ["t", "domid", "unit"]),
+DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "unit"]),
+                     ("remove",         ["ctx", "t", "domid", "unit"]),
+                     ("destroy",        ["ctx", "t", "domid", "unit"]),
                    ]
 
 functions = { # ( name , [type1,type2,....] )
@@ -33,13 +33,13 @@ functions = { # ( name , [type1,type2,....] )
     "device_disk":    DEVICE_FUNCTIONS,
     "device_nic":     DEVICE_FUNCTIONS,
     "device_pci":     DEVICE_FUNCTIONS,
-    "physinfo":       [ ("get",            ["unit", "t"]),
+    "physinfo":       [ ("get",            ["ctx", "t"]),
                       ],
-    "cputopology":    [ ("get",            ["unit", "t array"]),
+    "cputopology":    [ ("get",            ["ctx", "t array"]),
                       ],
     "domain_sched_params":
-                      [ ("get",            ["domid", "t"]),
-                        ("set",            ["domid", "t", "unit"]),
+                      [ ("get",            ["ctx", "domid", "t"]),
+                        ("set",            ["ctx", "domid", "t", "unit"]),
                       ],
 }
 def stub_fn_name(ty, name):
@@ -226,7 +226,7 @@ def c_val(ty, c, o, indent="", parent = None):
         for e in ty.values:
             s += "    case %d: *%s = %s; break;\n" % (n, c, e.name)
             n += 1
-        s += "    default: failwith_xl(\"cannot convert value to %s\", lg); break;\n" % ty.typename
+        s += "    default: failwith_xl(\"cannot convert value to %s\"); break;\n" % ty.typename
         s += "}"
     elif isinstance(ty, idl.KeyedUnion):
         s += "{\n"
@@ -239,7 +239,7 @@ def c_val(ty, c, o, indent="", parent = None):
                                                     parent + ty.keyvar.name,
                                                     f.enumname)
                 n += 1
-        s += "\t\t    default: failwith_xl(\"variant handling bug %s%s (long)\", lg); break;\n" % (parent, ty.keyvar.name)        
+        s += "\t\t    default: failwith_xl(\"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"
@@ -255,7 +255,7 @@ def c_val(ty, c, o, indent="", parent = None):
                 s += "%s" % c_val(f.type, fexpr, "Field(%s, 0)" % o, indent=indent+"\t\t        ")
                 s += "break;\n"
                 n += 1
-        s += "\t\t    default: failwith_xl(\"variant handling bug %s%s (block)\", lg); break;\n" % (parent, ty.keyvar.name)
+        s += "\t\t    default: failwith_xl(\"variant handling bug %s%s (block)\"); break;\n" % (parent, ty.keyvar.name)
         s += "\t\t}\n"
         s += "\t}\n"
         s += "}"
@@ -268,14 +268,14 @@ def c_val(ty, c, o, indent="", parent = None):
             s += "%s\n" % c_val(f.type, fexpr, "Field(%s, %d)" % (o,n), parent=nparent)
             n = n + 1
     else:
-        s += "%s_val(gc, lg, %s, %s);" % (ty.rawname, ty.pass_arg(c, parent is None, passby=idl.PASS_BY_REFERENCE), o)
+        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 (caml_gc *gc, struct caml_logger *lg, %s, value v)\n" % (ty.rawname, ty.make_arg("c_val", passby=idl.PASS_BY_REFERENCE))
+    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"
@@ -324,7 +324,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
         for e in ty.values:
             s += "    case %s: %s = Int_val(%d); break;\n" % (e.name, o, n)
             n += 1
-        s += "    default: failwith_xl(\"cannot convert value from %s\", lg); break;\n" % ty.typename
+        s += "    default: failwith_xl(\"cannot convert value from %s\"); break;\n" % ty.typename
         s += "}"
     elif isinstance(ty, idl.KeyedUnion):
         n = 0
@@ -353,7 +353,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
                 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(\"cannot convert value from %s\", lg); break;\n" % ty.typename
+        s += "\t    default: failwith_xl(\"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"
@@ -378,14 +378,14 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
             n = n + 1
         s += "}"
     else:
-        s += "%s = Val_%s(gc, lg, %s);" % (o, ty.rawname, ty.pass_arg(c, parent is None))
+        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 (caml_gc *gc, struct caml_logger *lg, %s)\n" % (ty.rawname, ty.make_arg(ty.rawname+"_c"))
+    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
diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index 3d663d8..dffba72 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -15,17 +15,16 @@
 
 exception Error of string
 
+type ctx
 type domid = int
 type devid = int
 
 (* @@LIBXL_TYPES@@ *)
 
-type ctx
-
 external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
 
-external send_trigger : domid -> trigger -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
+external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
+external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
+external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 
-let _ = Callback.register_exception "xl.error" (Error "register_callback")
+let _ = Callback.register_exception "Xenlight.Error" (Error(""))
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index 96d859c..e2686bb 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -15,15 +15,14 @@
 
 exception Error of string
 
+type ctx
 type domid = int
 type devid = int
 
 (* @@LIBXL_TYPES@@ *)
 
-type ctx
-
 external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
 
-external send_trigger : domid -> trigger -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : domid -> string -> unit = "stub_xl_send_debug_keys"
+external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
+external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
+external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index c26226f..dd6c781 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -35,47 +35,7 @@
 #define Ctx_val(x)(*((libxl_ctx **) Data_custom_val(x)))
 #define CTX ((libxl_ctx *) Ctx_val(ctx))
 
-struct caml_logger {
-	struct xentoollog_logger logger;
-	int log_offset;
-	char log_buf[2048];
-};
-
-typedef struct caml_gc {
-	int offset;
-	void *ptrs[64];
-} caml_gc;
-
-static void log_vmessage(struct xentoollog_logger *logger, xentoollog_level level,
-                  int errnoval, const char *context, const char *format, va_list al)
-{
-	struct caml_logger *ologger = (struct caml_logger *) logger;
-
-	ologger->log_offset += vsnprintf(ologger->log_buf + ologger->log_offset,
-	                                 2048 - ologger->log_offset, format, al);
-}
-
-static void log_destroy(struct xentoollog_logger *logger)
-{
-}
-
-#define INIT_STRUCT() libxl_ctx *ctx; struct caml_logger lg; struct caml_gc gc; gc.offset = 0;
-
-#define INIT_CTX()  \
-	lg.logger.vmessage = log_vmessage; \
-	lg.logger.destroy = log_destroy; \
-	lg.logger.progress = NULL; \
-	caml_enter_blocking_section(); \
-	ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (struct xentoollog_logger *) &lg); \
-	if (ret != 0) \
-		failwith_xl("cannot init context", &lg);
-
-#define FREE_CTX()  \
-	gc_free(&gc); \
-	caml_leave_blocking_section(); \
-	libxl_ctx_free(ctx)
-
-static char * dup_String_val(caml_gc *gc, value s)
+static char * dup_String_val(value s)
 {
 	int len;
 	char *c;
@@ -83,24 +43,16 @@ static char * dup_String_val(caml_gc *gc, value s)
 	c = calloc(len + 1, sizeof(char));
 	if (!c)
 		caml_raise_out_of_memory();
-	gc->ptrs[gc->offset++] = c;
 	memcpy(c, String_val(s), len);
 	return c;
 }
 
-static void gc_free(caml_gc *gc)
-{
-	int i;
-	for (i = 0; i < gc->offset; i++) {
-		free(gc->ptrs[i]);
-	}
-}
-
-static void failwith_xl(char *fname, struct caml_logger *lg)
+static void failwith_xl(char *fname)
 {
-	char *s;
-	s = (lg) ? lg->log_buf : fname;
-	caml_raise_with_string(*caml_named_value("xl.error"), s);
+	value *exc = caml_named_value("Xenlight.Error");
+	if (!exc)
+		caml_invalid_argument("Exception Xenlight.Error not initialized, please link xl.cma");
+	caml_raise_with_string(*exc, fname);
 }
 
 void ctx_finalize(value ctx)
@@ -126,7 +78,7 @@ CAMLprim value stub_libxl_ctx_alloc(value logger)
 
 	ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (xentoollog_logger *) Xtl_val(logger));
 	if (ret != 0) \
-		failwith_xl("cannot init context", NULL);
+		failwith_xl("cannot init context");
 
 	handle = caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0, 1);
 	Ctx_val(handle) = ctx;
@@ -134,16 +86,6 @@ CAMLprim value stub_libxl_ctx_alloc(value logger)
 	CAMLreturn(handle);
 }
 
-static void * gc_calloc(caml_gc *gc, size_t nmemb, size_t size)
-{
-	void *ptr;
-	ptr = calloc(nmemb, size);
-	if (!ptr)
-		caml_raise_out_of_memory();
-	gc->ptrs[gc->offset++] = ptr;
-	return ptr;
-}
-
 static int list_len(value v)
 {
 	int len = 0;
@@ -154,9 +96,8 @@ static int list_len(value v)
 	return len;
 }
 
-static int libxl_key_value_list_val(caml_gc *gc, struct caml_logger *lg,
-				    libxl_key_value_list *c_val,
-				    value v)
+static int libxl_key_value_list_val(libxl_key_value_list *c_val,
+	value v)
 {
 	CAMLparam1(v);
 	CAMLlocal1(elem);
@@ -165,15 +106,15 @@ static int libxl_key_value_list_val(caml_gc *gc, struct caml_logger *lg,
 
 	nr = list_len(v);
 
-	array = gc_calloc(gc, (nr + 1) * 2, sizeof(char *));
+	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(gc, Field(elem, 0));
-		array[i * 2 + 1] = dup_String_val(gc, Field(elem, 1));
+		array[i * 2] = dup_String_val(Field(elem, 0));
+		array[i * 2 + 1] = dup_String_val(Field(elem, 1));
 	}
 
 	*c_val = array;
@@ -203,9 +144,7 @@ static value Val_key_value_list(libxl_key_value_list *c_val)
 	CAMLreturn(list);
 }
 
-static int libxl_string_list_val(caml_gc *gc, struct caml_logger *lg,
-				 libxl_string_list *c_val,
-				 value v)
+static int libxl_string_list_val(libxl_string_list *c_val, value v)
 {
 	CAMLparam1(v);
 	int nr, i;
@@ -213,12 +152,12 @@ static int libxl_string_list_val(caml_gc *gc, struct caml_logger *lg,
 
 	nr = list_len(v);
 
-	array = gc_calloc(gc, (nr + 1), sizeof(char *));
+	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(gc, Field(v, 0));
+		array[i] = dup_String_val(Field(v, 0));
 
 	*c_val = array;
 	CAMLreturn(0);
@@ -269,7 +208,7 @@ static value Val_mac (libxl_mac *c_val)
 	CAMLreturn(v);
 }
 
-static int Mac_val(caml_gc *gc, struct caml_logger *lg, libxl_mac *c_val, value v)
+static int Mac_val(libxl_mac *c_val, value v)
 {
 	CAMLparam1(v);
 	int i;
@@ -300,10 +239,21 @@ static value Val_bitmap (libxl_bitmap *c_val)
 	CAMLreturn(v);
 }
 
-static int Bitmap_val(caml_gc *gc, struct caml_logger *lg,
-		      libxl_bitmap *c_val, value v)
+static int Bitmap_val(libxl_ctx *ctx, libxl_bitmap *c_val, value v)
 {
-	abort(); /* XXX */
+	CAMLparam1(v);
+	int i, len = Wosize_val(v);
+
+	c_val->size = 0;
+	if (len > 0 && libxl_bitmap_alloc(ctx, c_val, len))
+		failwith_xl("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)
@@ -321,7 +271,7 @@ static value Val_uuid (libxl_uuid *c_val)
 	CAMLreturn(v);
 }
 
-static int Uuid_val(caml_gc *gc, struct caml_logger *lg, libxl_uuid *c_val, value v)
+static int Uuid_val(libxl_uuid *c_val, value v)
 {
 	CAMLparam1(v);
 	int i;
@@ -375,254 +325,76 @@ static value Val_hwcap(libxl_hwcap *c_val)
 
 #include "_libxl_types.inc"
 
-value stub_xl_device_disk_add(value info, value domid)
-{
-	CAMLparam2(info, domid);
-	libxl_device_disk c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_disk_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_disk_add(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("disk_add", &lg);
-	FREE_CTX();
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_disk_del(value info, value domid)
-{
-	CAMLparam2(info, domid);
-	libxl_device_disk c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_disk_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_disk_remove(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("disk_del", &lg);
-	FREE_CTX();
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_nic_add(value info, value domid)
-{
-	CAMLparam2(info, domid);
-	libxl_device_nic c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_nic_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_nic_add(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("nic_add", &lg);
-	FREE_CTX();
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_nic_del(value info, value domid)
-{
-	CAMLparam2(info, domid);
-	libxl_device_nic c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_nic_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_nic_remove(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("nic_del", &lg);
-	FREE_CTX();
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_add(value info, value domid)
-{
-	CAMLparam2(info, domid);
-	libxl_device_vkb c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_vkb_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_vkb_add(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("vkb_add", &lg);
-	FREE_CTX();
-
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_remove(value info, value domid)
-{
-	CAMLparam1(domid);
-	libxl_device_vkb c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_vkb_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_vkb_remove(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("vkb_clean_shutdown", &lg);
-	FREE_CTX();
-
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vkb_destroy(value info, value domid)
-{
-	CAMLparam1(domid);
-	libxl_device_vkb c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_vkb_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_vkb_destroy(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("vkb_hard_shutdown", &lg);
-	FREE_CTX();
-
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_add(value info, value domid)
-{
-	CAMLparam2(info, domid);
-	libxl_device_vfb c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_vfb_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_vfb_add(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("vfb_add", &lg);
-	FREE_CTX();
-
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_remove(value info, value domid)
-{
-	CAMLparam1(domid);
-	libxl_device_vfb c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_vfb_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_vfb_remove(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("vfb_clean_shutdown", &lg);
-	FREE_CTX();
-
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_vfb_destroy(value info, value domid)
-{
-	CAMLparam1(domid);
-	libxl_device_vfb c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_vfb_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_vfb_destroy(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("vfb_hard_shutdown", &lg);
-	FREE_CTX();
-
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_add(value info, value domid)
-{
-	CAMLparam2(info, domid);
-	libxl_device_pci c_info;
-	int ret;
-	INIT_STRUCT();
-
-	device_pci_val(&gc, &lg, &c_info, info);
-
-	INIT_CTX();
-	ret = libxl_device_pci_add(ctx, Int_val(domid), &c_info, 0);
-	if (ret != 0)
-		failwith_xl("pci_add", &lg);
-	FREE_CTX();
-
-	CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_remove(value info, value domid)
-{
-	CAMLparam2(info, domid);
-	libxl_device_pci c_info;
+#define _STRINGIFY(x) #x
+#define STRINGIFY(x) _STRINGIFY(x)
+
+#define _DEVICE_ADDREMOVE(type,op)					\
+value stub_xl_device_##type##_##op(value ctx, value info, value domid)	\
+{									\
+	CAMLparam3(ctx, info, domid);					\
+	libxl_device_##type c_info;					\
+	int ret, marker_var;						\
+									\
+	device_##type##_val(CTX, &c_info, info);			\
+									\
+	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info, 0); \
+									\
+	libxl_device_##type##_dispose(&c_info);				\
+									\
+	if (ret != 0)							\
+		failwith_xl(STRINGIFY(type) "_" STRINGIFY(op));		\
+									\
+	CAMLreturn(Val_unit);						\
+}
+
+#define DEVICE_ADDREMOVE(type) \
+	_DEVICE_ADDREMOVE(type, add) \
+ 	_DEVICE_ADDREMOVE(type, remove) \
+ 	_DEVICE_ADDREMOVE(type, destroy)
+
+DEVICE_ADDREMOVE(disk)
+DEVICE_ADDREMOVE(nic)
+DEVICE_ADDREMOVE(vfb)
+DEVICE_ADDREMOVE(vkb)
+DEVICE_ADDREMOVE(pci)
+
+value stub_xl_physinfo_get(value ctx)
+{
+	CAMLparam1(ctx);
+	CAMLlocal1(physinfo);
+	libxl_physinfo c_physinfo;
 	int ret;
-	INIT_STRUCT();
 
-	device_pci_val(&gc, &lg, &c_info, info);
+	ret = libxl_get_physinfo(CTX, &c_physinfo);
 
-	INIT_CTX();
-	ret = libxl_device_pci_remove(ctx, Int_val(domid), &c_info, 0);
 	if (ret != 0)
-		failwith_xl("pci_remove", &lg);
-	FREE_CTX();
-
-	CAMLreturn(Val_unit);
-}
+		failwith_xl("get_physinfo");
 
-value stub_xl_physinfo_get(value unit)
-{
-	CAMLparam1(unit);
-	CAMLlocal1(physinfo);
-	libxl_physinfo c_physinfo;
-	int ret;
-	INIT_STRUCT();
+	physinfo = Val_physinfo(&c_physinfo);
 
-	INIT_CTX();
-	ret = libxl_get_physinfo(ctx, &c_physinfo);
-	if (ret != 0)
-		failwith_xl("physinfo", &lg);
-	FREE_CTX();
+	libxl_physinfo_dispose(&c_physinfo);
 
-	physinfo = Val_physinfo(&gc, &lg, &c_physinfo);
 	CAMLreturn(physinfo);
 }
 
-value stub_xl_cputopology_get(value unit)
+value stub_xl_cputopology_get(value ctx)
 {
-	CAMLparam1(unit);
-	CAMLlocal2(topology, v);
+	CAMLparam1(ctx);
+	CAMLlocal3(topology, v, v0);
 	libxl_cputopology *c_topology;
-	int i, nr, ret;
-	INIT_STRUCT();
+	int i, nr;
 
-	INIT_CTX();
+	c_topology = libxl_get_cpu_topology(CTX, &nr);
 
-	c_topology = libxl_get_cpu_topology(ctx, &nr);
-	if (ret != 0)
-		failwith_xl("topologyinfo", &lg);
+	if (!c_topology)
+		failwith_xl("topologyinfo");
 
 	topology = caml_alloc_tuple(nr);
 	for (i = 0; i < nr; i++) {
-		if (c_topology[i].core != LIBXL_CPUTOPOLOGY_INVALID_ENTRY)
-			v = Val_some(Val_cputopology(&gc, &lg, &c_topology[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);
@@ -630,91 +402,89 @@ value stub_xl_cputopology_get(value unit)
 
 	libxl_cputopology_list_free(c_topology, nr);
 
-	FREE_CTX();
 	CAMLreturn(topology);
 }
 
-value stub_xl_domain_sched_params_get(value domid)
+value stub_xl_domain_sched_params_get(value ctx, value domid)
 {
-	CAMLparam1(domid);
+	CAMLparam2(ctx, domid);
 	CAMLlocal1(scinfo);
 	libxl_domain_sched_params c_scinfo;
 	int ret;
-	INIT_STRUCT();
 
-	INIT_CTX();
-	ret = libxl_domain_sched_params_get(ctx, Int_val(domid), &c_scinfo);
+	ret = libxl_domain_sched_params_get(CTX, Int_val(domid), &c_scinfo);
 	if (ret != 0)
-		failwith_xl("domain_sched_params_get", &lg);
-	FREE_CTX();
+		failwith_xl("domain_sched_params_get");
+
+	scinfo = Val_domain_sched_params(&c_scinfo);
+
+	libxl_domain_sched_params_dispose(&c_scinfo);
 
-	scinfo = Val_domain_sched_params(&gc, &lg, &c_scinfo);
 	CAMLreturn(scinfo);
 }
 
-value stub_xl_domain_sched_params_set(value domid, value scinfo)
+value stub_xl_domain_sched_params_set(value ctx, value domid, value scinfo)
 {
-	CAMLparam2(domid, scinfo);
+	CAMLparam3(ctx, domid, scinfo);
 	libxl_domain_sched_params c_scinfo;
 	int ret;
-	INIT_STRUCT();
 
-	domain_sched_params_val(&gc, &lg, &c_scinfo, scinfo);
+	domain_sched_params_val(CTX, &c_scinfo, scinfo);
+
+	ret = libxl_domain_sched_params_set(CTX, Int_val(domid), &c_scinfo);
+
+	libxl_domain_sched_params_dispose(&c_scinfo);
 
-	INIT_CTX();
-	ret = libxl_domain_sched_params_set(ctx, Int_val(domid), &c_scinfo);
 	if (ret != 0)
-		failwith_xl("domain_sched_params_set", &lg);
-	FREE_CTX();
+		failwith_xl("domain_sched_params_set");
 
 	CAMLreturn(Val_unit);
 }
 
-value stub_xl_send_trigger(value domid, value trigger, value vcpuid)
+value stub_xl_send_trigger(value ctx, value domid, value trigger, value vcpuid)
 {
-	CAMLparam3(domid, trigger, vcpuid);
+	CAMLparam4(ctx, domid, trigger, vcpuid);
 	int ret;
 	libxl_trigger c_trigger = LIBXL_TRIGGER_UNKNOWN;
-	INIT_STRUCT();
 
-	trigger_val(&gc, &lg, &c_trigger, trigger);
+	trigger_val(CTX, &c_trigger, trigger);
+
+	ret = libxl_send_trigger(CTX, Int_val(domid),
+				 c_trigger, Int_val(vcpuid));
 
-	INIT_CTX();
-	ret = libxl_send_trigger(ctx, Int_val(domid), c_trigger, Int_val(vcpuid));
 	if (ret != 0)
-		failwith_xl("send_trigger", &lg);
-	FREE_CTX();
+		failwith_xl("send_trigger");
+
 	CAMLreturn(Val_unit);
 }
 
-value stub_xl_send_sysrq(value domid, value sysrq)
+value stub_xl_send_sysrq(value ctx, value domid, value sysrq)
 {
-	CAMLparam2(domid, sysrq);
+	CAMLparam3(ctx, domid, sysrq);
 	int ret;
-	INIT_STRUCT();
 
-	INIT_CTX();
-	ret = libxl_send_sysrq(ctx, Int_val(domid), Int_val(sysrq));
+	ret = libxl_send_sysrq(CTX, Int_val(domid), Int_val(sysrq));
+
 	if (ret != 0)
-		failwith_xl("send_sysrq", &lg);
-	FREE_CTX();
+		failwith_xl("send_sysrq");
+
 	CAMLreturn(Val_unit);
 }
 
-value stub_xl_send_debug_keys(value keys)
+value stub_xl_send_debug_keys(value ctx, value keys)
 {
-	CAMLparam1(keys);
+	CAMLparam2(ctx, keys);
 	int ret;
 	char *c_keys;
-	INIT_STRUCT();
 
-	c_keys = dup_String_val(&gc, keys);
+	c_keys = dup_String_val(keys);
 
-	INIT_CTX();
-	ret = libxl_send_debug_keys(ctx, c_keys);
+	ret = libxl_send_debug_keys(CTX, c_keys);
 	if (ret != 0)
-		failwith_xl("send_debug_keys", &lg);
-	FREE_CTX();
+		failwith_xl("send_debug_keys");
+
+	free(c_keys);
+
 	CAMLreturn(Val_unit);
 }
 
-- 
1.7.10.4

[PATCH v3-RESEND 09/28] libxl: make the libxl error type an IDL enum

[Rob Hoes]

This makes it easier to use in language bindings.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

---
New in v3:
* New patch to simplify the (following) exception handling patch.
---
 tools/libxl/libxl.h         |   18 ------------------
 tools/libxl/libxl_device.c  |    6 +++---
 tools/libxl/libxl_types.idl |   17 +++++++++++++++++
 3 files changed, 20 insertions(+), 21 deletions(-)

diff --git a/tools/libxl/libxl.h b/tools/libxl/libxl.h
index 1c6675d..9379694 100644
--- a/tools/libxl/libxl.h
+++ b/tools/libxl/libxl.h
@@ -459,24 +459,6 @@ typedef struct libxl__ctx libxl_ctx;
 
 const libxl_version_info* libxl_get_version_info(libxl_ctx *ctx);
 
-enum {
-    ERROR_NONSPECIFIC = -1,
-    ERROR_VERSION = -2,
-    ERROR_FAIL = -3,
-    ERROR_NI = -4,
-    ERROR_NOMEM = -5,
-    ERROR_INVAL = -6,
-    ERROR_BADFAIL = -7,
-    ERROR_GUEST_TIMEDOUT = -8,
-    ERROR_TIMEDOUT = -9,
-    ERROR_NOPARAVIRT = -10,
-    ERROR_NOT_READY = -11,
-    ERROR_OSEVENT_REG_FAIL = -12,
-    ERROR_BUFFERFULL = -13,
-    ERROR_UNKNOWN_CHILD = -14,
-};
-
-
 /*
  * Some libxl operations can take a long time.  These functions take a
  * parameter to control their concurrency:
diff --git a/tools/libxl/libxl_device.c b/tools/libxl/libxl_device.c
index 16a92a4..11c53cf 100644
--- a/tools/libxl/libxl_device.c
+++ b/tools/libxl/libxl_device.c
@@ -497,7 +497,7 @@ static void multidev_one_callback(libxl__egc *egc, libxl__ao_device *aodev)
 {
     STATE_AO_GC(aodev->ao);
     libxl__multidev *multidev = aodev->multidev;
-    int i, error = 0;
+    int i, err = 0;
 
     aodev->active = 0;
 
@@ -506,10 +506,10 @@ static void multidev_one_callback(libxl__egc *egc, libxl__ao_device *aodev)
             return;
 
         if (multidev->array[i]->rc)
-            error = multidev->array[i]->rc;
+            err = multidev->array[i]->rc;
     }
 
-    multidev->callback(egc, multidev, error);
+    multidev->callback(egc, multidev, err);
     return;
 }
 
diff --git a/tools/libxl/libxl_types.idl b/tools/libxl/libxl_types.idl
index 5c43d6f..778a416 100644
--- a/tools/libxl/libxl_types.idl
+++ b/tools/libxl/libxl_types.idl
@@ -28,6 +28,23 @@ MemKB = UInt(64, init_val = "LIBXL_MEMKB_DEFAULT")
 # Constants / Enumerations
 #
 
+libxl_error = Enumeration("error", [
+    (-1, "NONSPECIFIC"),
+    (-2, "VERSION"),
+    (-3, "FAIL"),
+    (-4, "NI"),
+    (-5, "NOMEM"),
+    (-6, "INVAL"),
+    (-7, "BADFAIL"),
+    (-8, "GUEST_TIMEDOUT"),
+    (-9, "TIMEDOUT"),
+    (-10, "NOPARAVIRT"),
+    (-11, "NOT_READY"),
+    (-12, "OSEVENT_REG_FAIL"),
+    (-13, "BUFFERFULL"),
+    (-14, "UNKNOWN_CHILD"),
+    ], namespace = "")
+
 libxl_domain_type = Enumeration("domain_type", [
     (-1, "INVALID"),
     (1, "HVM"),
-- 
1.7.10.4

Re: [PATCH v3-RESEND 09/28] libxl: make the libxl error type an IDL enum

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> diff --git a/tools/libxl/libxl_device.c b/tools/libxl/libxl_device.c
> index 16a92a4..11c53cf 100644
> --- a/tools/libxl/libxl_device.c
> +++ b/tools/libxl/libxl_device.c
> @@ -497,7 +497,7 @@ static void multidev_one_callback(libxl__egc *egc, libxl__ao_device *aodev)
>  {
>      STATE_AO_GC(aodev->ao);
>      libxl__multidev *multidev = aodev->multidev;
> -    int i, error = 0;
> +    int i, err = 0;

Why the spurious s/error/err/ ?

> diff --git a/tools/libxl/libxl_types.idl b/tools/libxl/libxl_types.idl
> index 5c43d6f..778a416 100644
> --- a/tools/libxl/libxl_types.idl
> +++ b/tools/libxl/libxl_types.idl
> @@ -28,6 +28,23 @@ MemKB = UInt(64, init_val = "LIBXL_MEMKB_DEFAULT")
>  # Constants / Enumerations
>  #
>  
> +libxl_error = Enumeration("error", [
[...]
> +    ], namespace = "")

Ah, because you've defined "enum error" as an unnamespaced type.
Irrespective of the clash you've found I think this is a no go since an
application might reasonably be using "error" (also, err is a standard
function too, see err.h and/or err(3)).

Assuming the idl doesn't support anonymous enums (I don't recall writing
anything to do that ;-)) and you quite reasonably don't want to add such
support I think enum libxl_error as the name is fine.

I wonder if we should begin transitioning over to using this as the
return type. Probably mostly involves horrible pain...

> +
>  libxl_domain_type = Enumeration("domain_type", [
>      (-1, "INVALID"),
>      (1, "HVM"),

Re: [PATCH v3-RESEND 09/28] libxl: make the libxl error type an IDL enum

[Rob Hoes]

> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > diff --git a/tools/libxl/libxl_device.c b/tools/libxl/libxl_device.c
> > index 16a92a4..11c53cf 100644
> > --- a/tools/libxl/libxl_device.c
> > +++ b/tools/libxl/libxl_device.c
> > @@ -497,7 +497,7 @@ static void multidev_one_callback(libxl__egc *egc,
> > libxl__ao_device *aodev)  {
> >      STATE_AO_GC(aodev->ao);
> >      libxl__multidev *multidev = aodev->multidev;
> > -    int i, error = 0;
> > +    int i, err = 0;
> 
> Why the spurious s/error/err/ ?
> 
> > diff --git a/tools/libxl/libxl_types.idl b/tools/libxl/libxl_types.idl
> > index 5c43d6f..778a416 100644
> > --- a/tools/libxl/libxl_types.idl
> > +++ b/tools/libxl/libxl_types.idl
> > @@ -28,6 +28,23 @@ MemKB = UInt(64, init_val =
> "LIBXL_MEMKB_DEFAULT")
> > # Constants / Enumerations  #
> >
> > +libxl_error = Enumeration("error", [
> [...]
> > +    ], namespace = "")
> 
> Ah, because you've defined "enum error" as an unnamespaced type.
> Irrespective of the clash you've found I think this is a no go since an
> application might reasonably be using "error" (also, err is a standard
> function too, see err.h and/or err(3)).

Yes, I wanted to make sure that the enum value names did not change. With the default namespace, you'd get values such as "LIBXL_ERROR_FAIL" rather than "ERROR_FAIL".

> Assuming the idl doesn't support anonymous enums (I don't recall writing
> anything to do that ;-)) and you quite reasonably don't want to add such
> support I think enum libxl_error as the name is fine.

I think the IDL constructs enums as follows, for each value: namespace + "_" + enum name + "_" + value name. So naming the enum "libxl_error" again gives values such as "LIBXL_ERROR_FAIL", and we're back to square one :)

Perhaps we need another option in the IDL for this?

> I wonder if we should begin transitioning over to using this as the return
> type. Probably mostly involves horrible pain...
> 
> > +
> >  libxl_domain_type = Enumeration("domain_type", [
> >      (-1, "INVALID"),
> >      (1, "HVM"),
> 

Re: [PATCH v3-RESEND 09/28] libxl: make the libxl error type an IDL enum

[Ian Campbell]

On Mon, 2013-11-04 at 14:48 +0000, Rob Hoes wrote:
> > On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > > diff --git a/tools/libxl/libxl_device.c b/tools/libxl/libxl_device.c
> > > index 16a92a4..11c53cf 100644
> > > --- a/tools/libxl/libxl_device.c
> > > +++ b/tools/libxl/libxl_device.c
> > > @@ -497,7 +497,7 @@ static void multidev_one_callback(libxl__egc *egc,
> > > libxl__ao_device *aodev)  {
> > >      STATE_AO_GC(aodev->ao);
> > >      libxl__multidev *multidev = aodev->multidev;
> > > -    int i, error = 0;
> > > +    int i, err = 0;
> > 
> > Why the spurious s/error/err/ ?
> > 
> > > diff --git a/tools/libxl/libxl_types.idl b/tools/libxl/libxl_types.idl
> > > index 5c43d6f..778a416 100644
> > > --- a/tools/libxl/libxl_types.idl
> > > +++ b/tools/libxl/libxl_types.idl
> > > @@ -28,6 +28,23 @@ MemKB = UInt(64, init_val =
> > "LIBXL_MEMKB_DEFAULT")
> > > # Constants / Enumerations  #
> > >
> > > +libxl_error = Enumeration("error", [
> > [...]
> > > +    ], namespace = "")
> > 
> > Ah, because you've defined "enum error" as an unnamespaced type.
> > Irrespective of the clash you've found I think this is a no go since an
> > application might reasonably be using "error" (also, err is a standard
> > function too, see err.h and/or err(3)).
> 
> Yes, I wanted to make sure that the enum value names did not change.
> With the default namespace, you'd get values such as
> "LIBXL_ERROR_FAIL" rather than "ERROR_FAIL".

OH, right, that makes sense.

> 
> > Assuming the idl doesn't support anonymous enums (I don't recall writing
> > anything to do that ;-)) and you quite reasonably don't want to add such
> > support I think enum libxl_error as the name is fine.
> 
> I think the IDL constructs enums as follows, for each value: namespace
> + "_" + enum name + "_" + value name. So naming the enum "libxl_error"
> again gives values such as "LIBXL_ERROR_FAIL", and we're back to
> square one :)
> 
> Perhaps we need another option in the IDL for this?

Yes, I think so. Something like a value_namespace option to the
containing enum would do the trick I think? Something like this
(untested, needs a corresponding idl.txt update) would allow you to pass
value_namespace = ""

diff --git a/tools/libxl/idl.py b/tools/libxl/idl.py
index 7d95e3f..0425384 100644
--- a/tools/libxl/idl.py
+++ b/tools/libxl/idl.py
@@ -136,7 +136,7 @@ class EnumerationValue(object):
 
         self.valuename = str.upper(name)
         self.rawname = str.upper(enum.rawname) + "_" + self.valuename
-        self.name = str.upper(enum.namespace) + self.rawname
+        self.name = str.upper(enum.value_namespace) + self.rawname
         self.value = value
 
 class Enumeration(Type):
@@ -144,6 +144,8 @@ class Enumeration(Type):
         kwargs.setdefault('dispose_fn', None)
         Type.__init__(self, typename, **kwargs)
 
+        self.value_namespace = kwargs.setdefault('value_namespace', self.namespace)
+
         self.values = []
         for v in values:
             # (value, name)

Ian.

[PATCH v3-RESEND 10/28] libxl: ocaml: generate string_of_* functions for enums

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

---
New in v3:
* New patch, which allowed us to remove the hand-written string_of_error
  function.
---
 tools/ocaml/libs/xl/genwrap.py |    9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 2a90681..d8d675c 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -152,6 +152,15 @@ def gen_ocaml_ml(ty, interface, indent=""):
         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
+            n = len(ty.rawname) + 1
+            for v in ty.values:
+                s += '\t| %s -> "%s"\n' % (v.rawname, v.rawname[n:])
+
     elif isinstance(ty, idl.Aggregate):
         s += ""
         
-- 
1.7.10.4

Re: [PATCH v3-RESEND 10/28] libxl: ocaml: generate string_of_* functions for enums

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> +        if interface:
> +            s += "\nval string_of_%s : %s -> string\n" % (ty.rawname, ty.rawname)
> +        else:
> +            s += "\nlet string_of_%s = function\n" % ty.rawname
> +            n = len(ty.rawname) + 1
> +            for v in ty.values:
> +                s += '\t| %s -> "%s"\n' % (v.rawname, v.rawname[n:])

Is n here trying to strip the libxl_ prefix? Oh no, its the enum name
prefix.

v.valuename is unhelpfully upper-cased (this might be an error in id.py
TBH). But I think v.valuename.lower() (or whatever case munging ocaml
requires) would be fine here.

Or you could trivially add v.basename or something similar to
tools/libxl/idl.{txt,py} I think.

Ian.

Re: [PATCH v3-RESEND 10/28] libxl: ocaml: generate string_of_* functions for enums

[Rob Hoes]

> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> > +        if interface:
> > +            s += "\nval string_of_%s : %s -> string\n" % (ty.rawname,
> ty.rawname)
> > +        else:
> > +            s += "\nlet string_of_%s = function\n" % ty.rawname
> > +            n = len(ty.rawname) + 1
> > +            for v in ty.values:
> > +                s += '\t| %s -> "%s"\n' % (v.rawname, v.rawname[n:])
> 
> Is n here trying to strip the libxl_ prefix? Oh no, its the enum name prefix.
> 
> v.valuename is unhelpfully upper-cased (this might be an error in id.py TBH).
> But I think v.valuename.lower() (or whatever case munging ocaml
> requires) would be fine here.

Ah, just v.valuename is fine. I missed that one (I should read idl.txt again ;)).

Cheers,
Rob

> Or you could trivially add v.basename or something similar to
> tools/libxl/idl.{txt,py} I think.
> 
> Ian.

[PATCH v3-RESEND 11/28] libxl: ocaml: propagate the libxl return error code in exceptions

[Rob Hoes]

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

---
New in v3:
* Now using the auto-generated error type.
---
 tools/ocaml/libs/xl/genwrap.py       |   10 +++----
 tools/ocaml/libs/xl/xenlight.ml.in   |   10 +++++--
 tools/ocaml/libs/xl/xenlight.mli.in  |    9 ++++--
 tools/ocaml/libs/xl/xenlight_stubs.c |   50 ++++++++++++++++++++++++----------
 4 files changed, 55 insertions(+), 24 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index d8d675c..611d892 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -235,7 +235,7 @@ def c_val(ty, c, o, indent="", parent = None):
         for e in ty.values:
             s += "    case %d: *%s = %s; break;\n" % (n, c, e.name)
             n += 1
-        s += "    default: failwith_xl(\"cannot convert value to %s\"); break;\n" % ty.typename
+        s += "    default: failwith_xl(ERROR_FAIL, \"cannot convert value to %s\"); break;\n" % ty.typename
         s += "}"
     elif isinstance(ty, idl.KeyedUnion):
         s += "{\n"
@@ -248,7 +248,7 @@ def c_val(ty, c, o, indent="", parent = None):
                                                     parent + ty.keyvar.name,
                                                     f.enumname)
                 n += 1
-        s += "\t\t    default: failwith_xl(\"variant handling bug %s%s (long)\"); break;\n" % (parent, ty.keyvar.name)        
+        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"
@@ -264,7 +264,7 @@ def c_val(ty, c, o, indent="", parent = None):
                 s += "%s" % c_val(f.type, fexpr, "Field(%s, 0)" % o, indent=indent+"\t\t        ")
                 s += "break;\n"
                 n += 1
-        s += "\t\t    default: failwith_xl(\"variant handling bug %s%s (block)\"); break;\n" % (parent, ty.keyvar.name)
+        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 += "}"
@@ -333,7 +333,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
         for e in ty.values:
             s += "    case %s: %s = Int_val(%d); break;\n" % (e.name, o, n)
             n += 1
-        s += "    default: failwith_xl(\"cannot convert value from %s\"); break;\n" % ty.typename
+        s += "    default: failwith_xl(ERROR_FAIL, \"cannot convert value from %s\"); break;\n" % ty.typename
         s += "}"
     elif isinstance(ty, idl.KeyedUnion):
         n = 0
@@ -362,7 +362,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
                 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(\"cannot convert value from %s\"); break;\n" % ty.typename
+        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"
diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index dffba72..a281425 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -13,18 +13,22 @@
  * GNU Lesser General Public License for more details.
  *)
 
-exception Error of string
-
 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"
+
 external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 
-let _ = Callback.register_exception "Xenlight.Error" (Error(""))
+let register_exceptions () =
+	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""))
+
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index e2686bb..d663196 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -13,16 +13,21 @@
  * GNU Lesser General Public License for more details.
  *)
 
-exception Error of string
-
 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"
+
 external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index dd6c781..a6f6e6f 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -47,12 +47,34 @@ static char * dup_String_val(value s)
 	return c;
 }
 
-static void failwith_xl(char *fname)
+/* Forward reference: this is defined in the auto-generated include file below. */
+static value Val_error (error error_c);
+
+static void failwith_xl(int error, char *fname)
 {
-	value *exc = caml_named_value("Xenlight.Error");
+	CAMLlocal1(arg);
+	static 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 xl.cma");
-	caml_raise_with_string(*exc, fname);
+		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);
+}
+
+CAMLprim value stub_raise_exception(value unit)
+{
+	CAMLparam1(unit);
+	failwith_xl(ERROR_FAIL, "test exception");
+	CAMLreturn(Val_unit);
 }
 
 void ctx_finalize(value ctx)
@@ -78,7 +100,7 @@ CAMLprim value stub_libxl_ctx_alloc(value logger)
 
 	ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (xentoollog_logger *) Xtl_val(logger));
 	if (ret != 0) \
-		failwith_xl("cannot init context");
+		failwith_xl(ERROR_FAIL, "cannot init context");
 
 	handle = caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0, 1);
 	Ctx_val(handle) = ctx;
@@ -246,7 +268,7 @@ static int Bitmap_val(libxl_ctx *ctx, libxl_bitmap *c_val, value v)
 
 	c_val->size = 0;
 	if (len > 0 && libxl_bitmap_alloc(ctx, c_val, len))
-		failwith_xl("cannot allocate bitmap");
+		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);
@@ -342,7 +364,7 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid)	\
 	libxl_device_##type##_dispose(&c_info);				\
 									\
 	if (ret != 0)							\
-		failwith_xl(STRINGIFY(type) "_" STRINGIFY(op));		\
+		failwith_xl(ret, STRINGIFY(type) "_" STRINGIFY(op));	\
 									\
 	CAMLreturn(Val_unit);						\
 }
@@ -368,7 +390,7 @@ value stub_xl_physinfo_get(value ctx)
 	ret = libxl_get_physinfo(CTX, &c_physinfo);
 
 	if (ret != 0)
-		failwith_xl("get_physinfo");
+		failwith_xl(ret, "get_physinfo");
 
 	physinfo = Val_physinfo(&c_physinfo);
 
@@ -387,7 +409,7 @@ value stub_xl_cputopology_get(value ctx)
 	c_topology = libxl_get_cpu_topology(CTX, &nr);
 
 	if (!c_topology)
-		failwith_xl("topologyinfo");
+		failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo");
 
 	topology = caml_alloc_tuple(nr);
 	for (i = 0; i < nr; i++) {
@@ -414,7 +436,7 @@ value stub_xl_domain_sched_params_get(value ctx, value domid)
 
 	ret = libxl_domain_sched_params_get(CTX, Int_val(domid), &c_scinfo);
 	if (ret != 0)
-		failwith_xl("domain_sched_params_get");
+		failwith_xl(ret, "domain_sched_params_get");
 
 	scinfo = Val_domain_sched_params(&c_scinfo);
 
@@ -436,7 +458,7 @@ value stub_xl_domain_sched_params_set(value ctx, value domid, value scinfo)
 	libxl_domain_sched_params_dispose(&c_scinfo);
 
 	if (ret != 0)
-		failwith_xl("domain_sched_params_set");
+		failwith_xl(ret, "domain_sched_params_set");
 
 	CAMLreturn(Val_unit);
 }
@@ -453,7 +475,7 @@ value stub_xl_send_trigger(value ctx, value domid, value trigger, value vcpuid)
 				 c_trigger, Int_val(vcpuid));
 
 	if (ret != 0)
-		failwith_xl("send_trigger");
+		failwith_xl(ret, "send_trigger");
 
 	CAMLreturn(Val_unit);
 }
@@ -466,7 +488,7 @@ value stub_xl_send_sysrq(value ctx, value domid, value sysrq)
 	ret = libxl_send_sysrq(CTX, Int_val(domid), Int_val(sysrq));
 
 	if (ret != 0)
-		failwith_xl("send_sysrq");
+		failwith_xl(ret, "send_sysrq");
 
 	CAMLreturn(Val_unit);
 }
@@ -481,7 +503,7 @@ value stub_xl_send_debug_keys(value ctx, value keys)
 
 	ret = libxl_send_debug_keys(CTX, c_keys);
 	if (ret != 0)
-		failwith_xl("send_debug_keys");
+		failwith_xl(ret, "send_debug_keys");
 
 	free(c_keys);
 
-- 
1.7.10.4

[PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof

[Rob Hoes]

The Val_* functions potentially allocate new values on the OCaml heap, and may
trigger an iteration of the OCaml GC.  Therefore, it is important to assign
values produced by Val_* immediately to variables declared with CAMLlocal
macros, which register the values with the GC.

This leads to slightly weird looking C code, but avoids hard to find segfaults.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/xenlight_stubs.c |   12 +++++++-----
 1 file changed, 7 insertions(+), 5 deletions(-)

diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index a6f6e6f..d15a625 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -308,15 +308,17 @@ static int Uuid_val(libxl_uuid *c_val, value v)
 static value Val_defbool(libxl_defbool c_val)
 {
 	CAMLparam0();
-	CAMLlocal1(v);
+	CAMLlocal2(v1, v2);
+	bool b;
 
 	if (libxl_defbool_is_default(c_val))
-		v = Val_none;
+		v2 = Val_none;
 	else {
-		bool b = libxl_defbool_val(c_val);
-		v = Val_some(b ? Val_bool(true) : Val_bool(false));
+		b = libxl_defbool_val(c_val);
+		v1 = b ? Val_bool(true) : Val_bool(false);
+		v2 = Val_some(v1);
 	}
-	CAMLreturn(v);
+	CAMLreturn(v2);
 }
 
 static libxl_defbool Defbool_val(value v)
-- 
1.7.10.4

Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> The Val_* functions potentially allocate new values on the OCaml heap, and may
> trigger an iteration of the OCaml GC.  Therefore, it is important to assign
> values produced by Val_* immediately to variables declared with CAMLlocal
> macros, which register the values with the GC.

Bonkers stuff ;-)

> This leads to slightly weird looking C code, but avoids hard to find segfaults.
> 
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof

[Ian Jackson]

Ian Campbell writes ("Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof"):
> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > The Val_* functions potentially allocate new values on the OCaml heap, and may
> > trigger an iteration of the OCaml GC.  Therefore, it is important to assign
> > values produced by Val_* immediately to variables declared with CAMLlocal
> > macros, which register the values with the GC.
> 
> Bonkers stuff ;-)

Even given this explanation, I still don't understand why the fix is
correct and complete.

What difference do you think it makes whether things are "assigned to
variables" or not ?

Bonus if your explanation refers to sequence points.

Ian.

Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof

[Ian Jackson]

Ian Jackson writes ("Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof"):
> What difference do you think it makes whether things are "assigned to
> variables" or not ?
> 
> Bonus if your explanation refers to sequence points.

Perhaps these special CAMLlocal macros make the things volatile or
something, I guess.

Perhaps you could refer me to the Ocaml docs ?

Ian.

Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof

[Ian Campbell]

On Thu, 2013-10-31 at 18:57 +0000, Ian Jackson wrote:
> Ian Jackson writes ("Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof"):
> > What difference do you think it makes whether things are "assigned to
> > variables" or not ?
> > 
> > Bonus if your explanation refers to sequence points.
> 
> Perhaps these special CAMLlocal macros make the things volatile or
> something, I guess.

They seem to end up being structs.

> Perhaps you could refer me to the Ocaml docs ?

Hah!

I usually scrobble around under /usr/include/caml/*.h

I also referenced
http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php in the
past (and there's a link in the series somewhere) but sadly it appears
to be 404 now -- Rob can you find a replacement?

(CCing Dave, who seems to understand some off this stuff)

Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof

[Dave Scott]

Hi,

> On Oct 31, 2013, at 7:10 PM, "Ian Campbell" <Ian.Campbell@citrix.com> wrote:
> 
>> On Thu, 2013-10-31 at 18:57 +0000, Ian Jackson wrote:
>> Ian Jackson writes ("Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof"):
>>> What difference do you think it makes whether things are "assigned to
>>> variables" or not ?
>>> 
>>> Bonus if your explanation refers to sequence points.
>> 
>> Perhaps these special CAMLlocal macros make the things volatile or
>> something, I guess.
> 
> They seem to end up being structs.

IIRC the CAML{param,local} macros put the values into structs which can be reached from a GC root (the previous interface used macros called something like "Begin_roots" "End_roots"). Any value you've allocated and you want to keep had better be reachable when the GC comes calling -- so I tend to obsessively use the macros everywhere. You can optimise them away but if you call a function which ends up allocating, one time in a hundred the minor heap will be full, it'll do a sweep and deallocate anything unreachable. Having been bitten too many times, I'd rather sacrifice a little performance for safety there :)

It is quite hard to write good ocaml c stubs, because you're caught between the two worlds. To appease the GC you have to write some fairly unidiomatic C. FYI there's an exciting new way of building C stubs through a library called "ctypes" being written by Jeremy Yallop from OCamlLabs-- we should check it out for version 2 of these bindings...

Cheers,
Dave

Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof

[Ian Jackson]

Ian Jackson writes ("Re: [PATCH v3-RESEND 12/28] libxl: ocaml: make Val_defbool GC-proof"):
> Bonus if your explanation refers to sequence points.

Andrew Cooper has helped explain, and Ian Campbell pointed me at
caml/memory.h.

AIUI now: Val_bool and Val_some allocate.  So they may enter the GC
and therefore at that point you're not allowed to have any
ocaml-allocated values (such as the results from Val_bool) which
aren't in the GC root set.  Assigning the return value to the
CAMLlocal variable puts it in the GC root set.

So if that's right, I approve of the patch.

Ian.

(I still think the docs are pretty poor.)

[PATCH v3-RESEND 13/28] libxl: ocaml: add domain_build/create_info/config and events to the bindings.

[Rob Hoes]

We now have enough infrastructure in place to do this trivially.

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>
---
 tools/libxl/libxl_types.idl    |    2 +-
 tools/ocaml/libs/xl/genwrap.py |    4 ----
 2 files changed, 1 insertion(+), 5 deletions(-)

diff --git a/tools/libxl/libxl_types.idl b/tools/libxl/libxl_types.idl
index 778a416..ee3efba 100644
--- a/tools/libxl/libxl_types.idl
+++ b/tools/libxl/libxl_types.idl
@@ -464,7 +464,7 @@ libxl_domain_config = Struct("domain_config", [
     ("on_reboot", libxl_action_on_shutdown),
     ("on_watchdog", libxl_action_on_shutdown),
     ("on_crash", libxl_action_on_shutdown),
-    ])
+    ], dir=DIR_IN)
 
 libxl_diskinfo = Struct("diskinfo", [
     ("backend", string),
diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 611d892..8154458 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -432,11 +432,7 @@ if __name__ == '__main__':
     # Do not generate these yet.
     blacklist = [
         "cpupoolinfo",
-        "domain_create_info",
-        "domain_build_info",
-        "domain_config",
         "vcpuinfo",
-        "event",
         ]
 
     for t in blacklist:
-- 
1.7.10.4

[PATCH v3-RESEND 14/28] libxl: ocaml: add META to list of generated files in Makefile

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Campbell <ian.campbell@citrix.com>
Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>
---
 tools/ocaml/libs/xl/Makefile |    2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tools/ocaml/libs/xl/Makefile b/tools/ocaml/libs/xl/Makefile
index 6917a20..0408cc2 100644
--- a/tools/ocaml/libs/xl/Makefile
+++ b/tools/ocaml/libs/xl/Makefile
@@ -22,7 +22,7 @@ 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
+GENERATED_FILES += _libxl_types.inc META
 
 all: $(INTF) $(LIBS)
 
-- 
1.7.10.4

Re: [PATCH v3-RESEND 14/28] libxl: ocaml: add META to list of generated files in Makefile

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> Acked-by: Ian Campbell <ian.campbell@citrix.com>
> Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>

Pretty certain this one safely stands alone, applied, thanks.

If you want to highlight any others which are acked and which have no
dependencies (or whose dependencies are recursively so) please do. Or
feel free to not bother and they'll get swept along with the eventual
commit.

Ian.

[PATCH v3-RESEND 15/28] libxl: ocaml: fix the handling of enums in the bindings generator

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Campbell <ian.campbell@citrix.com>
Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py |    2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 8154458..acd2728 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -331,7 +331,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
         n = 0
         s += "switch(%s) {\n" % c
         for e in ty.values:
-            s += "    case %s: %s = Int_val(%d); break;\n" % (e.name, o, n)
+            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 += "}"
-- 
1.7.10.4

[PATCH v3-RESEND 16/28] libxl: ocaml: use the "string option" type for IDL strings

[Rob Hoes]

The libxl IDL is based on C type "char *", and therefore "strings" can
by NULL, or be an actual string. In ocaml, it is common to encode such
things as option types.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |    2 +-
 tools/ocaml/libs/xl/xenlight_stubs.c |   21 +++++++++++++++++++++
 2 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index acd2728..5cbb748 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -8,7 +8,7 @@ import idl
 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",                 "%(c)s = dup_String_val(%(o)s)", "caml_copy_string(%(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)" ),
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index d15a625..152600b 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -347,6 +347,27 @@ static value Val_hwcap(libxl_hwcap *c_val)
 	CAMLreturn(hwcap);
 }
 
+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)
+{
+	char *s = NULL;
+	if (v != Val_none)
+		s = dup_String_val(Some_val(v));
+	return s;
+}
+
 #include "_libxl_types.inc"
 
 #define _STRINGIFY(x) #x
-- 
1.7.10.4

Re: [PATCH v3-RESEND 16/28] libxl: ocaml: use the "string option" type for IDL strings

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> The libxl IDL is based on C type "char *", and therefore "strings" can
> by NULL, or be an actual string. In ocaml, it is common to encode such
> things as option types.
> 
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

Re: [PATCH v3-RESEND 16/28] libxl: ocaml: use the "string option" type for IDL strings

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> The libxl IDL is based on C type "char *", and therefore "strings" can
> by NULL, or be an actual string. In ocaml, it is common to encode such
> things as option types.
> 
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

[PATCH v3-RESEND 17/28] libxl: ocaml: add dominfo_list and dominfo_get

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |    3 +++
 tools/ocaml/libs/xl/xenlight_stubs.c |   41 ++++++++++++++++++++++++++++++++++
 2 files changed, 44 insertions(+)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 5cbb748..daeffdf 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -33,6 +33,9 @@ functions = { # ( name , [type1,type2,....] )
     "device_disk":    DEVICE_FUNCTIONS,
     "device_nic":     DEVICE_FUNCTIONS,
     "device_pci":     DEVICE_FUNCTIONS,
+    "dominfo":        [ ("list",           ["ctx", "t list"]),
+                        ("get",            ["ctx", "domid", "t"]),
+                      ],
     "physinfo":       [ ("get",            ["ctx", "t"]),
                       ],
     "cputopology":    [ ("get",            ["ctx", "t array"]),
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 152600b..7502f6d 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -450,6 +450,47 @@ value stub_xl_cputopology_get(value ctx)
 	CAMLreturn(topology);
 }
 
+value stub_xl_dominfo_list(value ctx)
+{
+	CAMLparam1(ctx);
+	CAMLlocal2(domlist, temp);
+	libxl_dominfo *c_domlist;
+	int i, nb;
+
+	c_domlist = libxl_list_domain(CTX, &nb);
+	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;
+
+	ret = libxl_domain_info(CTX, &c_dominfo, Int_val(domid));
+	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);
-- 
1.7.10.4

[PATCH v3-RESEND 18/28] libxl: ocaml: implement some simple tests

[Rob Hoes]

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: Ian Jackson <ian.jackson@eu.citrix.com>
---
 .gitignore                          |    3 ++-
 .hgignore                           |    2 ++
 tools/ocaml/test/Makefile           |   30 ++++++++++++++++++++++++++----
 tools/ocaml/test/list_domains.ml    |   28 ++++++++++++++++++++++++++++
 tools/ocaml/test/raise_exception.ml |   11 +++++++++++
 tools/ocaml/test/send_debug_keys.ml |   15 +++++++++++++++
 6 files changed, 84 insertions(+), 5 deletions(-)
 create mode 100644 tools/ocaml/test/list_domains.ml
 create mode 100644 tools/ocaml/test/raise_exception.ml
 create mode 100644 tools/ocaml/test/send_debug_keys.ml

diff --git a/.gitignore b/.gitignore
index f51c345..88a8c75 100644
--- a/.gitignore
+++ b/.gitignore
@@ -385,7 +385,8 @@ tools/ocaml/libs/xl/xenlight.ml
 tools/ocaml/libs/xl/xenlight.mli
 tools/ocaml/xenstored/oxenstored
 tools/ocaml/test/xtl
-
+tools/ocaml/test/send_debug_keys
+tools/ocaml/test/list_domains
 tools/debugger/kdd/kdd
 tools/firmware/etherboot/ipxe.tar.gz
 tools/firmware/etherboot/ipxe/
diff --git a/.hgignore b/.hgignore
index bb1b67d..ee5c084 100644
--- a/.hgignore
+++ b/.hgignore
@@ -309,6 +309,8 @@
 ^tools/ocaml/libs/xl/xenlight\.mli$
 ^tools/ocaml/xenstored/oxenstored$
 ^tools/ocaml/test/xtl$
+^tools/ocaml/test/send_debug_keys$
+^tools/ocaml/test/list_domains$
 ^tools/autom4te\.cache$
 ^tools/config\.h$
 ^tools/config\.log$
diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile
index 980054c..8387d43 100644
--- a/tools/ocaml/test/Makefile
+++ b/tools/ocaml/test/Makefile
@@ -2,12 +2,16 @@ XEN_ROOT = $(CURDIR)/../../..
 OCAML_TOPLEVEL = $(CURDIR)/..
 include $(OCAML_TOPLEVEL)/common.make
 
+CFLAGS += $(CFLAGS_libxenlight)
+LIBS_xenlight = $(LDLIBS_libxenlight)
+
 OCAMLINCLUDE += \
-	-I $(OCAML_TOPLEVEL)/libs/xentoollog
+	-I $(OCAML_TOPLEVEL)/libs/xentoollog \
+	-I $(OCAML_TOPLEVEL)/libs/xl
 
-OBJS = xtl
+OBJS = xtl send_debug_keys list_domains raise_exception
 
-PROGRAMS = xtl
+PROGRAMS = xtl send_debug_keys list_domains raise_exception
 
 xtl_LIBS =  \
 	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
@@ -15,7 +19,25 @@ xtl_LIBS =  \
 
 xtl_OBJS = xtl
 
-OCAML_PROGRAM = 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
+
+OCAML_PROGRAM = xtl send_debug_keys list_domains raise_exception
 
 all: $(PROGRAMS)
 
diff --git a/tools/ocaml/test/list_domains.ml b/tools/ocaml/test/list_domains.ml
new file mode 100644
index 0000000..15598e0
--- /dev/null
+++ b/tools/ocaml/test/list_domains.ml
@@ -0,0 +1,28 @@
+open Arg
+open Printf
+open Xenlight
+
+let bool_as_char b c = if b then c else '-'
+
+let print_dominfo dominfo =
+  let id = dominfo.Xenlight.Dominfo.xl_domid
+  and running = bool_as_char dominfo.Xenlight.Dominfo.xl_running 'r'
+  and blocked = bool_as_char dominfo.Xenlight.Dominfo.xl_blocked 'b'
+  and paused = bool_as_char dominfo.Xenlight.Dominfo.xl_paused 'p'
+  and shutdown = bool_as_char dominfo.Xenlight.Dominfo.xl_shutdown 's'
+  and dying = bool_as_char dominfo.Xenlight.Dominfo.xl_dying 'd'
+  and memory = dominfo.Xenlight.Dominfo.xl_current_memkb
+  in
+  printf "Dom %d: %c%c%c%c%c %LdKB\n" id running blocked paused shutdown dying memory
+
+let _ =
+  let logger = Xtl.create_stdio_logger (*~level:Xentoollog.Debug*) () in
+  let ctx = Xenlight.ctx_alloc logger in
+  try
+    let domains = Xenlight.Dominfo.list ctx in
+    List.iter (fun d -> print_dominfo d) domains
+  with Xenlight.Error(err, fn) -> begin
+    printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
+  end
+
+
diff --git a/tools/ocaml/test/raise_exception.ml b/tools/ocaml/test/raise_exception.ml
new file mode 100644
index 0000000..d4371f5
--- /dev/null
+++ b/tools/ocaml/test/raise_exception.ml
@@ -0,0 +1,11 @@
+open Printf
+open Xentoollog
+open Xenlight
+
+let _ = 
+  try
+    Xenlight.test_raise_exception ()
+  with Xenlight.Error(err, fn) -> begin
+    printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
+  end
+
diff --git a/tools/ocaml/test/send_debug_keys.ml b/tools/ocaml/test/send_debug_keys.ml
new file mode 100644
index 0000000..b9cd61e
--- /dev/null
+++ b/tools/ocaml/test/send_debug_keys.ml
@@ -0,0 +1,15 @@
+open Arg
+open Printf
+open Xenlight
+
+let send_keys ctx s = 
+  printf "Sending debug key %s\n" s;
+  Xenlight.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>"
+
-- 
1.7.10.4

[PATCH v3-RESEND 19/28] libxl: ocaml: event management

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/xenlight.ml.in   |   66 +++++++
 tools/ocaml/libs/xl/xenlight.mli.in  |   47 +++++
 tools/ocaml/libs/xl/xenlight_stubs.c |  325 ++++++++++++++++++++++++++++++++++
 3 files changed, 438 insertions(+)

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index a281425..9eba5d7 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -25,10 +25,76 @@ 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). *)
+
 external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 
+module type EVENT_USERS =
+	sig
+		type osevent_user
+		type event_user
+		type async_user
+	end
+
+module Async = functor (S: EVENT_USERS) -> struct
+	type for_libxl
+	type event_hooks
+	type osevent_hooks
+
+	module OseventSet = Set.Make(struct type t = S.osevent_user;; let compare = Pervasives.compare end)
+	module EventSet = Set.Make(struct type t = S.event_user;; let compare = Pervasives.compare end)
+	module AsyncSet = Set.Make(struct type t = S.async_user;; let compare = Pervasives.compare end)
+
+	let osevent_users = ref OseventSet.empty
+	let event_users = ref EventSet.empty
+	let async_users = ref AsyncSet.empty
+	let async_callback_ref = ref None
+
+	external osevent_register_hooks' : ctx -> S.osevent_user -> 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_modify =
+		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_modify" timeout_modify;
+		osevent_users := OseventSet.add user !osevent_users;
+		osevent_register_hooks' ctx user
+
+	let async f user =
+		async_users := AsyncSet.add user !async_users;
+		f ?async:(Some user) ()
+
+	let async_callback' result user =
+		async_users := AsyncSet.remove user !async_users;
+		match !async_callback_ref with
+		| None -> ()
+		| Some f -> f ~result ~user
+
+	let async_register_callback ~async_callback =
+		async_callback_ref := Some 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 -> S.event_user -> 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_users := EventSet.add user !event_users;
+		event_register_callbacks' ctx user
+end
+
 let register_exceptions () =
 	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""))
 
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index d663196..28e0eb2 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -27,7 +27,54 @@ 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). *)
+
 external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 
+module type EVENT_USERS =
+	sig
+		type osevent_user
+		type event_user
+		type async_user
+	end
+
+module Async : functor (S: EVENT_USERS) -> sig
+	type for_libxl
+	type event_hooks
+	type osevent_hooks
+
+	val osevent_register_hooks : ctx ->
+		user:S.osevent_user ->
+		fd_register:(S.osevent_user -> Unix.file_descr -> event list -> for_libxl -> unit) ->
+		fd_modify:(S.osevent_user -> Unix.file_descr -> event list -> unit) ->
+		fd_deregister:(S.osevent_user -> Unix.file_descr -> unit) ->
+		timeout_register:(S.osevent_user -> int -> int -> for_libxl -> unit) ->
+		timeout_modify:(S.osevent_user -> unit) ->
+		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 : (?async:S.async_user -> unit -> 'a) -> S.async_user -> 'a
+
+	val async_register_callback :
+		async_callback:(result:error option -> user:S.async_user -> unit) ->
+		unit
+
+	external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death"
+
+	val event_register_callbacks : ctx ->
+		user:S.event_user ->
+		event_occurs_callback:(S.event_user -> Event.t -> unit) ->
+		event_disaster_callback:(S.event_user -> event_type -> string -> int -> unit) ->
+		event_hooks
+end
+
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 7502f6d..5b38e7c 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -30,6 +30,8 @@
 #include <libxl.h>
 #include <libxl_utils.h>
 
+#include <unistd.h>
+
 #include "caml_xentoollog.h"
 
 #define Ctx_val(x)(*((libxl_ctx **) Data_custom_val(x)))
@@ -370,6 +372,26 @@ static char *String_option_val(value v)
 
 #include "_libxl_types.inc"
 
+void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
+{
+	CAMLparam0();
+	CAMLlocal1(error);
+	int *task = (int *) for_callback;
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_async_callback");
+	}
+
+	if (rc == 0)
+		error = Val_none;
+	else
+		error = Val_some(Val_error(rc));
+
+	caml_callback2(*func, error, (value) for_callback);
+}
+
 #define _STRINGIFY(x) #x
 #define STRINGIFY(x) _STRINGIFY(x)
 
@@ -574,6 +596,309 @@ value stub_xl_send_debug_keys(value ctx, value keys)
 	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);
+}
+
+int fd_register(void *user, int fd, void **for_app_registration_out,
+                     short events, void *for_libxl)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 4);
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_register");
+	}
+
+	args[0] = (value) user;
+	args[1] = Val_int(fd);
+	args[2] = Val_poll_events(events);
+	args[3] = (value) for_libxl;
+
+	caml_callbackN(*func, 4, args);
+	CAMLreturn(0);
+}
+
+int fd_modify(void *user, int fd, void **for_app_registration_update,
+                   short events)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 3);
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_modify");
+	}
+
+	args[0] = (value) user;
+	args[1] = Val_int(fd);
+	args[2] = Val_poll_events(events);
+
+	caml_callbackN(*func, 3, args);
+	CAMLreturn(0);
+}
+
+void fd_deregister(void *user, int fd, void *for_app_registration)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 2);
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_fd_deregister");
+	}
+
+	args[0] = (value) user;
+	args[1] = Val_int(fd);
+
+	caml_callbackN(*func, 2, args);
+	CAMLreturn0;
+}
+
+int timeout_register(void *user, void **for_app_registration_out,
+                          struct timeval abs, void *for_libxl)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 4);
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_timeout_register");
+	}
+
+	args[0] = (value) user;
+	args[1] = Val_int(abs.tv_sec);
+	args[2] = Val_int(abs.tv_usec);
+	args[3] = (value) for_libxl;
+
+	caml_callbackN(*func, 4, args);
+	CAMLreturn(0);
+}
+
+int timeout_modify(void *user, void **for_app_registration_update,
+                         struct timeval abs)
+{
+	CAMLparam0();
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_timeout_modify");
+	}
+
+	caml_callback(*func, (value) user);
+	CAMLreturn(0);
+}
+
+void timeout_deregister(void *user, void *for_app_registration)
+{
+	failwith_xl(ERROR_FAIL, "timeout_deregister not yet implemented");
+	return;
+}
+
+value stub_libxl_osevent_register_hooks(value ctx, value user)
+{
+	CAMLparam2(ctx, user);
+	CAMLlocal1(result);
+	libxl_osevent_hooks *hooks;
+
+	hooks = malloc(sizeof(*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;
+
+	libxl_osevent_register_hooks(CTX, hooks, (void *) user);
+	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);
+	libxl_osevent_occurred_fd(CTX, (void *) for_libxl, Int_val(fd),
+		Poll_events_val(events), Poll_events_val(revents));
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_osevent_occurred_timeout(value ctx, value for_libxl)
+{
+	CAMLparam2(ctx, for_libxl);
+	libxl_osevent_occurred_timeout(CTX, (void *) for_libxl);
+	CAMLreturn(Val_unit);
+}
+
+struct user_with_ctx {
+	libxl_ctx *ctx;
+	void *user;
+};
+
+void event_occurs(void *user, libxl_event *event)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 2);
+	struct user_with_ctx *c_user = (struct user_with_ctx *) user;
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_event_occurs_callback");
+	}
+
+	args[0] = (value) c_user->user;
+	args[1] = Val_event(event);
+	libxl_event_free(c_user->ctx, event);
+
+	caml_callbackN(*func, 2, args);
+	CAMLreturn0;
+}
+
+void disaster(void *user, libxl_event_type type,
+                     const char *msg, int errnoval)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 4);
+	struct user_with_ctx *c_user = (struct user_with_ctx *) user;
+	static value *func = NULL;
+
+	if (func == NULL) {
+		/* First time around, lookup by name */
+		func = caml_named_value("libxl_event_disaster_callback");
+	}
+
+	args[0] = (value) 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);
+	CAMLreturn0;
+}
+
+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));
+	c_user->user = (void *) user;
+	c_user->ctx = CTX;
+
+	hooks = malloc(sizeof(*hooks));
+	hooks->event_occurs_mask = LIBXL_EVENTMASK_ALL;
+	hooks->event_occurs = event_occurs;
+	hooks->disaster = disaster;
+
+	libxl_event_register_callbacks(CTX, hooks, (void *) c_user);
+	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);
+	libxl_evgen_domain_death *evgen_out;
+
+	libxl_evenable_domain_death(CTX, Int_val(domid), Int_val(user), &evgen_out);
+
+	CAMLreturn(Val_unit);
+}
+
 /*
  * Local variables:
  *  indent-tabs-mode: t
-- 
1.7.10.4

[PATCH v3-RESEND 20/28] libxl: ocaml: allow device operations to be called asynchronously

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |    6 +++---
 tools/ocaml/libs/xl/xenlight_stubs.c |   14 +++++++++++---
 2 files changed, 14 insertions(+), 6 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index daeffdf..721a336 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -22,9 +22,9 @@ builtins = {
     "libxl_cpuid_policy_list": ("unit",                "%(c)s = 0",                         "Val_unit"),
     }
 
-DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "unit"]),
-                     ("remove",         ["ctx", "t", "domid", "unit"]),
-                     ("destroy",        ["ctx", "t", "domid", "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"]),
                    ]
 
 functions = { # ( name , [type1,type2,....] )
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 5b38e7c..7e56db9 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -396,15 +396,23 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 #define STRINGIFY(x) _STRINGIFY(x)
 
 #define _DEVICE_ADDREMOVE(type,op)					\
-value stub_xl_device_##type##_##op(value ctx, value info, value domid)	\
+value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
+	value async, value unit)					\
 {									\
-	CAMLparam3(ctx, info, domid);					\
+	CAMLparam5(ctx, info, domid, async, unit);			\
 	libxl_device_##type c_info;					\
 	int ret, marker_var;						\
+	libxl_asyncop_how ao_how;					\
 									\
 	device_##type##_val(CTX, &c_info, info);			\
 									\
-	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info, 0); \
+	if (async != Val_none) {					\
+		ao_how.callback = async_callback;			\
+		ao_how.u.for_callback = (void *) Some_val(async);	\
+	}								\
+									\
+	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info,	\
+		async != Val_none ? &ao_how : NULL);			\
 									\
 	libxl_device_##type##_dispose(&c_info);				\
 									\
-- 
1.7.10.4

Re: [PATCH v3-RESEND 20/28] libxl: ocaml: allow device operations to be called asynchronously

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> ---
>  tools/ocaml/libs/xl/genwrap.py       |    6 +++---
>  tools/ocaml/libs/xl/xenlight_stubs.c |   14 +++++++++++---
>  2 files changed, 14 insertions(+), 6 deletions(-)
> 
> diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
> index daeffdf..721a336 100644
> --- a/tools/ocaml/libs/xl/genwrap.py
> +++ b/tools/ocaml/libs/xl/genwrap.py
> @@ -22,9 +22,9 @@ builtins = {
>      "libxl_cpuid_policy_list": ("unit",                "%(c)s = 0",                         "Val_unit"),
>      }
>  
> -DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "unit"]),
> -                     ("remove",         ["ctx", "t", "domid", "unit"]),
> -                     ("destroy",        ["ctx", "t", "domid", "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"]),

I probably don't speak enough ocaml to make heads or tails of it but can
you include the resulting ocaml type in the changelog? Is it really
        ctx-> t -> ?async -> () -> ()
?

I guess I don't fully grok "-> ()" if it can chain like that ;-)


>                     ]
>  
>  functions = { # ( name , [type1,type2,....] )
> diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
> index 5b38e7c..7e56db9 100644
> --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> @@ -396,15 +396,23 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
>  #define STRINGIFY(x) _STRINGIFY(x)
>  
>  #define _DEVICE_ADDREMOVE(type,op)					\
> -value stub_xl_device_##type##_##op(value ctx, value info, value domid)	\
> +value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
> +	value async, value unit)					\
>  {									\
> -	CAMLparam3(ctx, info, domid);					\
> +	CAMLparam5(ctx, info, domid, async, unit);			\

Only one unit here?

>  	libxl_device_##type c_info;					\
>  	int ret, marker_var;						\
> +	libxl_asyncop_how ao_how;					\
>  									\
>  	device_##type##_val(CTX, &c_info, info);			\
>  									\
> -	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info, 0); \
> +	if (async != Val_none) {					\
> +		ao_how.callback = async_callback;			\
> +		ao_how.u.for_callback = (void *) Some_val(async);	\
> +	}								\
> +									\
> +	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info,	\
> +		async != Val_none ? &ao_how : NULL);			\
>  									\
>  	libxl_device_##type##_dispose(&c_info);				\
>  									\

Re: [PATCH v3-RESEND 20/28] libxl: ocaml: allow device operations to be called asynchronously

[Rob Hoes]

> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> > ---
> >  tools/ocaml/libs/xl/genwrap.py       |    6 +++---
> >  tools/ocaml/libs/xl/xenlight_stubs.c |   14 +++++++++++---
> >  2 files changed, 14 insertions(+), 6 deletions(-)
> >
> > diff --git a/tools/ocaml/libs/xl/genwrap.py
> > b/tools/ocaml/libs/xl/genwrap.py index daeffdf..721a336 100644
> > --- a/tools/ocaml/libs/xl/genwrap.py
> > +++ b/tools/ocaml/libs/xl/genwrap.py
> > @@ -22,9 +22,9 @@ builtins = {
> >      "libxl_cpuid_policy_list": ("unit",                "%(c)s = 0",
> "Val_unit"),
> >      }
> >
> > -DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "unit"]),
> > -                     ("remove",         ["ctx", "t", "domid", "unit"]),
> > -                     ("destroy",        ["ctx", "t", "domid", "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"]),
> 
> I probably don't speak enough ocaml to make heads or tails of it but can you
> include the resulting ocaml type in the changelog? Is it really
>         ctx-> t -> ?async -> () -> ()
> ?	
> 
> I guess I don't fully grok "-> ()" if it can chain like that ;-)

The type of the function is "ctx-> t -> domid -> ?async -> () -> ()". The last () is the return type. The one before that is the type of the last argument of the function, which means you always have to call the function with () at the end. This used to mark "the end" of the function. It is not allowed in OCaml for functions to have optional arguments at the end.

Synchronous example:
    remove ctx my_disk 666 ()

Asynchronous example:
    remove ctx my_disk 666 ~async:my_user_id ()

The manual says: "A function taking some optional arguments must also take at least one non-optional argument. The criterion for deciding whether an optional argument has been omitted is the non-labeled application of an argument appearing after this optional argument in the function type." [http://caml.inria.fr/pub/docs/manual-ocaml-4.00/manual006.html]

So another option would be to move the ?async argument further to the left, and skip the extra (), e.g. "ctx -> ?async -> t -> domid -> ()". But I wanted to keep the async stuff at the end (like in the libxl function), and adding a () is quite common in OCaml.
 
Rob

> 
> >                     ]
> >
> >  functions = { # ( name , [type1,type2,....] ) diff --git
> > a/tools/ocaml/libs/xl/xenlight_stubs.c
> > b/tools/ocaml/libs/xl/xenlight_stubs.c
> > index 5b38e7c..7e56db9 100644
> > --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> > +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> > @@ -396,15 +396,23 @@ void async_callback(libxl_ctx *ctx, int rc, void
> > *for_callback)  #define STRINGIFY(x) _STRINGIFY(x)
> >
> >  #define _DEVICE_ADDREMOVE(type,op)
> 	\
> > -value stub_xl_device_##type##_##op(value ctx, value info, value domid)
> 	\
> > +value stub_xl_device_##type##_##op(value ctx, value info, value domid,
> 	\
> > +	value async, value unit)					\
> >  {									\
> > -	CAMLparam3(ctx, info, domid);
> 	\
> > +	CAMLparam5(ctx, info, domid, async, unit);			\
> 
> Only one unit here?
> 
> >  	libxl_device_##type c_info;					\
> >  	int ret, marker_var;						\
> > +	libxl_asyncop_how ao_how;					\
> >  									\
> >  	device_##type##_val(CTX, &c_info, info);			\
> >  									\
> > -	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info, 0); \
> > +	if (async != Val_none) {					\
> > +		ao_how.callback = async_callback;			\
> > +		ao_how.u.for_callback = (void *) Some_val(async);	\
> > +	}								\
> > +									\
> > +	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info,
> 	\
> > +		async != Val_none ? &ao_how : NULL);			\
> >  									\
> >  	libxl_device_##type##_dispose(&c_info);
> 	\
> >  									\
> 

Re: [PATCH v3-RESEND 20/28] libxl: ocaml: allow device operations to be called asynchronously

[Ian Campbell]

On Wed, 2013-11-06 at 11:46 +0000, Rob Hoes wrote:
> > On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > > Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> > > ---
> > >  tools/ocaml/libs/xl/genwrap.py       |    6 +++---
> > >  tools/ocaml/libs/xl/xenlight_stubs.c |   14 +++++++++++---
> > >  2 files changed, 14 insertions(+), 6 deletions(-)
> > >
> > > diff --git a/tools/ocaml/libs/xl/genwrap.py
> > > b/tools/ocaml/libs/xl/genwrap.py index daeffdf..721a336 100644
> > > --- a/tools/ocaml/libs/xl/genwrap.py
> > > +++ b/tools/ocaml/libs/xl/genwrap.py
> > > @@ -22,9 +22,9 @@ builtins = {
> > >      "libxl_cpuid_policy_list": ("unit",                "%(c)s = 0",
> > "Val_unit"),
> > >      }
> > >
> > > -DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "unit"]),
> > > -                     ("remove",         ["ctx", "t", "domid", "unit"]),
> > > -                     ("destroy",        ["ctx", "t", "domid", "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"]),
> > 
> > I probably don't speak enough ocaml to make heads or tails of it but can you
> > include the resulting ocaml type in the changelog? Is it really
> >         ctx-> t -> ?async -> () -> ()
> > ?	
> > 
> > I guess I don't fully grok "-> ()" if it can chain like that ;-)
> 
> The type of the function is "ctx-> t -> domid -> ?async -> () -> ()".
> The last () is the return type. The one before that is the type of the
> last argument of the function, which means you always have to call the
> function with () at the end. This used to mark "the end" of the
> function. It is not allowed in OCaml for functions to have optional
> arguments at the end.

Ah, yes, someone taught me that once before! 

[...]
> So another option would be to move the ?async argument further to the
> left, and skip the extra (), e.g. "ctx -> ?async -> t -> domid -> ()".
> But I wanted to keep the async stuff at the end (like in the libxl
> function), and adding a () is quite common in OCaml.

Right, assuming you are happy that the ordering you have is logical from
an ocaml pov (which may differ from libxl/C) it sounds fine to me.

Thanks for (re)educating me!

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

Ian.

[PATCH v3-RESEND 21/28] libxl: ocaml: add NIC helper functions

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |    5 ++++-
 tools/ocaml/libs/xl/xenlight_stubs.c |   36 ++++++++++++++++++++++++++++++++++
 2 files changed, 40 insertions(+), 1 deletion(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 721a336..c037515 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -31,7 +31,10 @@ functions = { # ( name , [type1,type2,....] )
     "device_vfb":     DEVICE_FUNCTIONS,
     "device_vkb":     DEVICE_FUNCTIONS,
     "device_disk":    DEVICE_FUNCTIONS,
-    "device_nic":     DEVICE_FUNCTIONS,
+    "device_nic":     DEVICE_FUNCTIONS +
+                      [ ("list",           ["ctx", "domid", "t list"]),
+                        ("of_devid",       ["ctx", "domid", "int", "t"]),
+                      ],
     "device_pci":     DEVICE_FUNCTIONS,
     "dominfo":        [ ("list",           ["ctx", "t list"]),
                         ("get",            ["ctx", "domid", "t"]),
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 7e56db9..b921229 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -433,6 +433,42 @@ DEVICE_ADDREMOVE(vfb)
 DEVICE_ADDREMOVE(vkb)
 DEVICE_ADDREMOVE(pci)
 
+value stub_xl_device_nic_of_devid(value ctx, value domid, value devid)
+{
+	CAMLparam3(ctx, domid, devid);
+	libxl_device_nic nic;
+	libxl_devid_to_device_nic(CTX, Int_val(domid), Int_val(devid), &nic);
+	CAMLreturn(Val_device_nic(&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;
+
+	c_domid = Int_val(domid);
+
+	c_list = libxl_device_nic_list(CTX, c_domid, &nb);
+	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_dispose(&c_list[i]);
+	}
+	free(c_list);
+
+	CAMLreturn(list);
+}
+
 value stub_xl_physinfo_get(value ctx)
 {
 	CAMLparam1(ctx);
-- 
1.7.10.4

Re: [PATCH v3-RESEND 21/28] libxl: ocaml: add NIC helper functions

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> ---
>  tools/ocaml/libs/xl/genwrap.py       |    5 ++++-
>  tools/ocaml/libs/xl/xenlight_stubs.c |   36 ++++++++++++++++++++++++++++++++++
>  2 files changed, 40 insertions(+), 1 deletion(-)
> 
> diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
> index 721a336..c037515 100644
> --- a/tools/ocaml/libs/xl/genwrap.py
> +++ b/tools/ocaml/libs/xl/genwrap.py
> @@ -31,7 +31,10 @@ functions = { # ( name , [type1,type2,....] )
>      "device_vfb":     DEVICE_FUNCTIONS,
>      "device_vkb":     DEVICE_FUNCTIONS,
>      "device_disk":    DEVICE_FUNCTIONS,
> -    "device_nic":     DEVICE_FUNCTIONS,
> +    "device_nic":     DEVICE_FUNCTIONS +
> +                      [ ("list",           ["ctx", "domid", "t list"]),
> +                        ("of_devid",       ["ctx", "domid", "int", "t"]),
> +                      ],
>      "device_pci":     DEVICE_FUNCTIONS,
>      "dominfo":        [ ("list",           ["ctx", "t list"]),
>                          ("get",            ["ctx", "domid", "t"]),
> diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
> index 7e56db9..b921229 100644
> --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> @@ -433,6 +433,42 @@ DEVICE_ADDREMOVE(vfb)
>  DEVICE_ADDREMOVE(vkb)
>  DEVICE_ADDREMOVE(pci)
>  
> +value stub_xl_device_nic_of_devid(value ctx, value domid, value devid)
> +{
> +	CAMLparam3(ctx, domid, devid);
> +	libxl_device_nic nic;
> +	libxl_devid_to_device_nic(CTX, Int_val(domid), Int_val(devid), &nic);
> +	CAMLreturn(Val_device_nic(&nic));

You need to libxl_device_nic_dispose(&nic) I think.

> +}
> +
> +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;
> +
> +	c_domid = Int_val(domid);
> +
> +	c_list = libxl_device_nic_list(CTX, c_domid, &nb);
> +	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_dispose(&c_list[i]);
> +	}
> +	free(c_list);
> +
> +	CAMLreturn(list);
> +}
> +
>  value stub_xl_physinfo_get(value ctx)
>  {
>  	CAMLparam1(ctx);

Re: [PATCH v3-RESEND 21/28] libxl: ocaml: add NIC helper functions

[Rob Hoes]

> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> > ---
> >  tools/ocaml/libs/xl/genwrap.py       |    5 ++++-
> >  tools/ocaml/libs/xl/xenlight_stubs.c |   36
> ++++++++++++++++++++++++++++++++++
> >  2 files changed, 40 insertions(+), 1 deletion(-)
> >
> > diff --git a/tools/ocaml/libs/xl/genwrap.py
> > b/tools/ocaml/libs/xl/genwrap.py index 721a336..c037515 100644
> > --- a/tools/ocaml/libs/xl/genwrap.py
> > +++ b/tools/ocaml/libs/xl/genwrap.py
> > @@ -31,7 +31,10 @@ functions = { # ( name , [type1,type2,....] )
> >      "device_vfb":     DEVICE_FUNCTIONS,
> >      "device_vkb":     DEVICE_FUNCTIONS,
> >      "device_disk":    DEVICE_FUNCTIONS,
> > -    "device_nic":     DEVICE_FUNCTIONS,
> > +    "device_nic":     DEVICE_FUNCTIONS +
> > +                      [ ("list",           ["ctx", "domid", "t list"]),
> > +                        ("of_devid",       ["ctx", "domid", "int", "t"]),
> > +                      ],
> >      "device_pci":     DEVICE_FUNCTIONS,
> >      "dominfo":        [ ("list",           ["ctx", "t list"]),
> >                          ("get",            ["ctx", "domid", "t"]),
> > diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c
> > b/tools/ocaml/libs/xl/xenlight_stubs.c
> > index 7e56db9..b921229 100644
> > --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> > +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> > @@ -433,6 +433,42 @@ DEVICE_ADDREMOVE(vfb)
> >  DEVICE_ADDREMOVE(vkb)
> >  DEVICE_ADDREMOVE(pci)
> >
> > +value stub_xl_device_nic_of_devid(value ctx, value domid, value
> > +devid) {
> > +	CAMLparam3(ctx, domid, devid);
> > +	libxl_device_nic nic;
> > +	libxl_devid_to_device_nic(CTX, Int_val(domid), Int_val(devid),
> &nic);
> > +	CAMLreturn(Val_device_nic(&nic));
> 
> You need to libxl_device_nic_dispose(&nic) I think.

Ok, will add that (and for the following disk-related patch as well).

Rob

> > +}
> > +
> > +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;
> > +
> > +	c_domid = Int_val(domid);
> > +
> > +	c_list = libxl_device_nic_list(CTX, c_domid, &nb);
> > +	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_dispose(&c_list[i]);
> > +	}
> > +	free(c_list);
> > +
> > +	CAMLreturn(list);
> > +}
> > +
> >  value stub_xl_physinfo_get(value ctx)  {
> >  	CAMLparam1(ctx);
> 

[PATCH v3-RESEND 22/28] libxl: ocaml: add PCI device helper functions

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |    7 ++-
 tools/ocaml/libs/xl/xenlight_stubs.c |   90 ++++++++++++++++++++++++++++++++++
 2 files changed, 96 insertions(+), 1 deletion(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index c037515..819df3a 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -35,7 +35,12 @@ functions = { # ( name , [type1,type2,....] )
                       [ ("list",           ["ctx", "domid", "t list"]),
                         ("of_devid",       ["ctx", "domid", "int", "t"]),
                       ],
-    "device_pci":     DEVICE_FUNCTIONS,
+    "device_pci":     DEVICE_FUNCTIONS +
+                      [ ("list",              ["ctx", "domid", "t 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"]),
                       ],
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index b921229..bfbbe57 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -469,6 +469,96 @@ value stub_xl_device_nic_list(value ctx, value domid)
 	CAMLreturn(list);
 }
 
+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;
+
+	c_domid = Int_val(domid);
+
+	c_list = libxl_device_pci_list(CTX, c_domid, &nb);
+	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;
+
+	device_pci_val(CTX, &c_info, info);
+
+	ret = libxl_device_pci_assignable_add(CTX, &c_info, (int) Bool_val(rebind));
+
+	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;
+
+	device_pci_val(CTX, &c_info, info);
+
+	ret = libxl_device_pci_assignable_remove(CTX, &c_info, (int) Bool_val(rebind));
+
+	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;
+
+	c_list = libxl_device_pci_assignable_list(CTX, &nb);
+	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_dispose(&c_list[i]);
+	}
+	free(c_list);
+
+	CAMLreturn(list);
+}
+
 value stub_xl_physinfo_get(value ctx)
 {
 	CAMLparam1(ctx);
-- 
1.7.10.4

Re: [PATCH v3-RESEND 22/28] libxl: ocaml: add PCI device helper functions

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

[PATCH v3-RESEND 23/28] libxl: ocaml: add disk and cdrom helper functions

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py       |   17 +++++++-----
 tools/ocaml/libs/xl/xenlight_stubs.c |   47 ++++++++++++++++++++++++++++++----
 2 files changed, 52 insertions(+), 12 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 819df3a..192bec2 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -26,18 +26,21 @@ DEVICE_FUNCTIONS = [ ("add",            ["ctx", "t", "domid", "?async:'a", "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_nic":     DEVICE_FUNCTIONS +
-                      [ ("list",           ["ctx", "domid", "t list"]),
-                        ("of_devid",       ["ctx", "domid", "int", "t"]),
+    "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 +
-                      [ ("list",              ["ctx", "domid", "t list"]),
-                        ("assignable_add",    ["ctx", "t", "bool", "unit"]),
+    "device_pci":     DEVICE_FUNCTIONS + DEVICE_LIST +
+                      [ ("assignable_add",    ["ctx", "t", "bool", "unit"]),
                         ("assignable_remove", ["ctx", "t", "bool", "unit"]),
                         ("assignable_list",   ["ctx", "t list"]),
                       ],
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index bfbbe57..928cad6 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -395,7 +395,7 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 #define _STRINGIFY(x) #x
 #define STRINGIFY(x) _STRINGIFY(x)
 
-#define _DEVICE_ADDREMOVE(type,op)					\
+#define _DEVICE_ADDREMOVE(type,fn,op)					\
 value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 	value async, value unit)					\
 {									\
@@ -411,7 +411,7 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 		ao_how.u.for_callback = (void *) Some_val(async);	\
 	}								\
 									\
-	ret = libxl_device_##type##_##op(CTX, Int_val(domid), &c_info,	\
+	ret = libxl_##fn##_##op(CTX, Int_val(domid), &c_info,		\
 		async != Val_none ? &ao_how : NULL);			\
 									\
 	libxl_device_##type##_dispose(&c_info);				\
@@ -423,15 +423,16 @@ value stub_xl_device_##type##_##op(value ctx, value info, value domid,	\
 }
 
 #define DEVICE_ADDREMOVE(type) \
-	_DEVICE_ADDREMOVE(type, add) \
- 	_DEVICE_ADDREMOVE(type, remove) \
- 	_DEVICE_ADDREMOVE(type, destroy)
+	_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)
 {
@@ -469,6 +470,42 @@ value stub_xl_device_nic_list(value ctx, value domid)
 	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;
+
+	c_domid = Int_val(domid);
+
+	c_list = libxl_device_disk_list(CTX, c_domid, &nb);
+	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_dispose(&c_list[i]);
+	}
+	free(c_list);
+
+	CAMLreturn(list);
+}
+
+value stub_xl_device_disk_of_vdev(value ctx, value domid, value vdev)
+{
+	CAMLparam3(ctx, domid, vdev);
+	libxl_device_disk disk;
+	libxl_vdev_to_device_disk(CTX, Int_val(domid), String_val(vdev), &disk);
+	CAMLreturn(Val_device_disk(&disk));
+}
+
 value stub_xl_device_pci_list(value ctx, value domid)
 {
 	CAMLparam2(ctx, domid);
-- 
1.7.10.4

Re: [PATCH v3-RESEND 23/28] libxl: ocaml: add disk and cdrom helper functions

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> +value stub_xl_device_disk_of_vdev(value ctx, value domid, value vdev)
> +{
> +	CAMLparam3(ctx, domid, vdev);
> +	libxl_device_disk disk;
> +	libxl_vdev_to_device_disk(CTX, Int_val(domid), String_val(vdev), &disk);
> +	CAMLreturn(Val_device_disk(&disk));

Needs to dispose of the C disk.

Ian.

[PATCH v3-RESEND 24/28] libxl: ocaml: add VM lifecycle operations

[Rob Hoes]

Also, reorganise toplevel OCaml functions into modules of Xenlight.

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/xenlight.ml.in   |   22 +++-
 tools/ocaml/libs/xl/xenlight.mli.in  |   22 +++-
 tools/ocaml/libs/xl/xenlight_stubs.c |  208 ++++++++++++++++++++++++++++++++++
 tools/ocaml/test/send_debug_keys.ml  |    2 +-
 4 files changed, 247 insertions(+), 7 deletions(-)

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index 9eba5d7..8388c5f 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -33,9 +33,25 @@ type event =
 	| POLLHUP (* Device has been disconnected (revents only) *)
 	| POLLNVAL (* Invalid request: fd not open (revents only). *)
 
-external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+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 -> unit = "stub_libxl_domain_shutdown"
+	external wait_shutdown : ctx -> domid -> unit = "stub_libxl_domain_wait_shutdown"
+	external reboot : ctx -> domid -> 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 -> unit = "stub_libxl_domain_pause"
+	external unpause : ctx -> domid -> unit = "stub_libxl_domain_unpause"
+
+	external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
+	external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
+end
+
+module Host = struct
+	external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+end
 
 module type EVENT_USERS =
 	sig
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index 28e0eb2..31faf26 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -35,9 +35,25 @@ type event =
 	| POLLHUP (* Device has been disconnected (revents only) *)
 	| POLLNVAL (* Invalid request: fd not open (revents only). *)
 
-external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
-external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
-external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+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 -> unit = "stub_libxl_domain_shutdown"
+	external wait_shutdown : ctx -> domid -> unit = "stub_libxl_domain_wait_shutdown"
+	external reboot : ctx -> domid -> 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 -> unit = "stub_libxl_domain_pause"
+	external unpause : ctx -> domid -> unit = "stub_libxl_domain_unpause"
+
+	external send_trigger : ctx -> domid -> trigger -> int -> unit = "stub_xl_send_trigger"
+	external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
+end
+
+module Host : sig
+	external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
+end
 
 module type EVENT_USERS =
 	sig
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 928cad6..84e1ad1 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -392,6 +392,214 @@ void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
 	caml_callback2(*func, error, (value) for_callback);
 }
 
+static int domain_wait_event(libxl_ctx *ctx, int domid, libxl_event **event_r)
+{
+	int ret;
+	for (;;) {
+		ret = libxl_event_wait(ctx, event_r, LIBXL_EVENTMASK_ALL, 0,0);
+		if (ret) {
+			return ret;
+		}
+		if ((*event_r)->domid != domid) {
+			libxl_event_free(CTX, *event_r);
+			continue;
+		}
+		return ret;
+	}
+}
+
+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;
+
+	if (async != Val_none) {
+		ao_how.callback = async_callback;
+		ao_how.u.for_callback = (void *) Some_val(async);
+	}
+
+	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");
+	}
+
+	ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid,
+		async != Val_none ? &ao_how : NULL, NULL);
+
+	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;
+
+	if (async != Val_none) {
+		ao_how.callback = async_callback;
+		ao_how.u.for_callback = (void *) Some_val(async);
+	}
+
+	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");
+	}
+
+	ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, Int_val(Field(params, 0)),
+		&c_params, async != Val_none ? &ao_how : NULL, NULL);
+
+	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_wait_shutdown(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+	libxl_event *event;
+	libxl_evgen_domain_death *deathw;
+	ret = libxl_evenable_domain_death(CTX, Int_val(domid), 0, &deathw);
+	if (ret)
+		failwith_xl(ret, "domain_wait_shutdown");
+
+	for (;;) {
+		ret = domain_wait_event(CTX, Int_val(domid), &event);
+		if (ret) {
+			libxl_evdisable_domain_death(CTX, deathw);
+			failwith_xl(ret, "domain_wait_shutdown");
+		}
+
+		switch (event->type) {
+		case LIBXL_EVENT_TYPE_DOMAIN_DEATH:
+			goto done;
+		case LIBXL_EVENT_TYPE_DOMAIN_SHUTDOWN:
+			goto done;
+		default:
+			break;
+		}
+		libxl_event_free(CTX, event);
+	}
+done:
+	libxl_event_free(CTX, event);
+	libxl_evdisable_domain_death(CTX, deathw);
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_shutdown(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+
+	ret = libxl_domain_shutdown(CTX, Int_val(domid));
+	if (ret != 0)
+		failwith_xl(ret, "domain_shutdown");
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_reboot(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+
+	ret = libxl_domain_reboot(CTX, Int_val(domid));
+	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;
+	libxl_asyncop_how ao_how;
+
+	if (async != Val_none) {
+		ao_how.callback = async_callback;
+		ao_how.u.for_callback = (void *) Some_val(async);
+	}
+
+	ret = libxl_domain_destroy(CTX, Int_val(domid),
+		async != Val_none ? &ao_how : NULL);
+	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;
+	libxl_asyncop_how ao_how;
+
+	if (async != Val_none) {
+		ao_how.callback = async_callback;
+		ao_how.u.for_callback = (void *) Some_val(async);
+	}
+
+	ret = libxl_domain_suspend(CTX, Int_val(domid), Int_val(fd), 0,
+		async != Val_none ? &ao_how : NULL);
+	if (ret != 0)
+		failwith_xl(ret, "domain_suspend");
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_pause(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+
+	ret = libxl_domain_pause(CTX, Int_val(domid));
+	if (ret != 0)
+		failwith_xl(ret, "domain_pause");
+
+	CAMLreturn(Val_unit);
+}
+
+value stub_libxl_domain_unpause(value ctx, value domid)
+{
+	CAMLparam2(ctx, domid);
+	int ret;
+
+	ret = libxl_domain_unpause(CTX, Int_val(domid));
+	if (ret != 0)
+		failwith_xl(ret, "domain_unpause");
+
+	CAMLreturn(Val_unit);
+}
+
 #define _STRINGIFY(x) #x
 #define STRINGIFY(x) _STRINGIFY(x)
 
diff --git a/tools/ocaml/test/send_debug_keys.ml b/tools/ocaml/test/send_debug_keys.ml
index b9cd61e..2cca322 100644
--- a/tools/ocaml/test/send_debug_keys.ml
+++ b/tools/ocaml/test/send_debug_keys.ml
@@ -4,7 +4,7 @@ open Xenlight
 
 let send_keys ctx s = 
   printf "Sending debug key %s\n" s;
-  Xenlight.send_debug_keys ctx s;
+  Xenlight.Host.send_debug_keys ctx s;
   ()
   
 let _ = 
-- 
1.7.10.4

Re: [PATCH v3-RESEND 24/28] libxl: ocaml: add VM lifecycle operations

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:

> +static int domain_wait_event(libxl_ctx *ctx, int domid, libxl_event **event_r)

Do you not have the infrastructure in place to bind this to ocaml and do
the next level of the call chain in ocaml instead of C?
> +{
> +	int ret;
> +	for (;;) {
> +		ret = libxl_event_wait(ctx, event_r, LIBXL_EVENTMASK_ALL, 0,0);
> +		if (ret) {
> +			return ret;
> +		}
> +		if ((*event_r)->domid != domid) {
> +			libxl_event_free(CTX, *event_r);
> +			continue;
> +		}
> +		return ret;
> +	}
> +}
> +
> +value stub_libxl_domain_create_new(value ctx, value domain_config, value async, value unit)
> +{
> [...]
> +	libxl_asyncop_how ao_how;
> +
> +	if (async != Val_none) {
> +		ao_how.callback = async_callback;
> +		ao_how.u.for_callback = (void *) Some_val(async);
> +	}
[...]
> +		async != Val_none ? &ao_how : NULL, NULL);

Lots of this patten. What about
#define OCAML_ASYNC_HOW \
	libxl_asyncop_how _ao_how; \
	libxl_asyncop_how *ao_how = NULL; \
	if (async != Val_none) \
		_ao_how.callback = ...
		_ao_how.u.for_callback = ...
		ao_how = &_ao_how

Then an unconditional ao_how at the point of use?

This relies on this file being compiled to allow mixed code and variable
definitions. We do that for libxl itself, not sure about here. Could be
enabled.

Or at least the initialisation of ao_how could be made a function.
Perhaps 
	static value Val_oahow(value aohow struct aohow *c_aohow)
	{
		if (aohow == Val_none) return NULL;

		c_aohow->etc 
		return c_aohow
	}

then 
	libxl_aohow aohow;

	libxl_do_foo(....
		Val_aohow(async, &aohow), ...);

> +value stub_libxl_domain_wait_shutdown(value ctx, value domid)
> +{

This is the thing I meant could you do in ocaml above...

> +	CAMLparam2(ctx, domid);
> +	int ret;
> +	libxl_event *event;
> +	libxl_evgen_domain_death *deathw;
> +	ret = libxl_evenable_domain_death(CTX, Int_val(domid), 0, &deathw);
> +	if (ret)
> +		failwith_xl(ret, "domain_wait_shutdown");
> +
> +	for (;;) {
> +		ret = domain_wait_event(CTX, Int_val(domid), &event);
> +		if (ret) {
> +			libxl_evdisable_domain_death(CTX, deathw);
> +			failwith_xl(ret, "domain_wait_shutdown");
> +		}
> +
> +		switch (event->type) {
> +		case LIBXL_EVENT_TYPE_DOMAIN_DEATH:
> +			goto done;
> +		case LIBXL_EVENT_TYPE_DOMAIN_SHUTDOWN:
> +			goto done;
> +		default:
> +			break;
> +		}
> +		libxl_event_free(CTX, event);
> +	}
> +done:
> +	libxl_event_free(CTX, event);

I don't know, but this might be clearer with
	the_right-type type = event->type;
	lbixl_event_free(...)
before the switch, which then becomes switch(type)?

Ian.

Re: [PATCH v3-RESEND 24/28] libxl: ocaml: add VM lifecycle operations

[Rob Hoes]

> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> 
> > +static int domain_wait_event(libxl_ctx *ctx, int domid, libxl_event
> > +**event_r)
> 
> Do you not have the infrastructure in place to bind this to ocaml and do the
> next level of the call chain in ocaml instead of C?

It turns out that we are not actually using this anymore in our code, nor the wait_shutdown function introduced in this patch. We already have the lower-level event functionality implemented. I'll remove these from the patch.

> > +{
> > +	int ret;
> > +	for (;;) {
> > +		ret = libxl_event_wait(ctx, event_r, LIBXL_EVENTMASK_ALL,
> 0,0);
> > +		if (ret) {
> > +			return ret;
> > +		}
> > +		if ((*event_r)->domid != domid) {
> > +			libxl_event_free(CTX, *event_r);
> > +			continue;
> > +		}
> > +		return ret;
> > +	}
> > +}
> > +
> > +value stub_libxl_domain_create_new(value ctx, value domain_config,
> > +value async, value unit) {
> > [...]
> > +	libxl_asyncop_how ao_how;
> > +
> > +	if (async != Val_none) {
> > +		ao_how.callback = async_callback;
> > +		ao_how.u.for_callback = (void *) Some_val(async);
> > +	}
> [...]
> > +		async != Val_none ? &ao_how : NULL, NULL);
> 
> Lots of this patten. What about
> #define OCAML_ASYNC_HOW \
> 	libxl_asyncop_how _ao_how; \
> 	libxl_asyncop_how *ao_how = NULL; \
> 	if (async != Val_none) \
> 		_ao_how.callback = ...
> 		_ao_how.u.for_callback = ...
> 		ao_how = &_ao_how
> 
> Then an unconditional ao_how at the point of use?
> 
> This relies on this file being compiled to allow mixed code and variable
> definitions. We do that for libxl itself, not sure about here. Could be
> enabled.
> 
> Or at least the initialisation of ao_how could be made a function.
> Perhaps
> 	static value Val_oahow(value aohow struct aohow *c_aohow)
> 	{
> 		if (aohow == Val_none) return NULL;
> 
> 		c_aohow->etc
> 		return c_aohow
> 	}
> 
> then
> 	libxl_aohow aohow;
> 
> 	libxl_do_foo(....
> 		Val_aohow(async, &aohow), ...);

Yes, we should really separate this out indeed. I'll do that now.

Rob

> > +value stub_libxl_domain_wait_shutdown(value ctx, value domid) {
> 
> This is the thing I meant could you do in ocaml above...
> 
> > +	CAMLparam2(ctx, domid);
> > +	int ret;
> > +	libxl_event *event;
> > +	libxl_evgen_domain_death *deathw;
> > +	ret = libxl_evenable_domain_death(CTX, Int_val(domid), 0,
> &deathw);
> > +	if (ret)
> > +		failwith_xl(ret, "domain_wait_shutdown");
> > +
> > +	for (;;) {
> > +		ret = domain_wait_event(CTX, Int_val(domid), &event);
> > +		if (ret) {
> > +			libxl_evdisable_domain_death(CTX, deathw);
> > +			failwith_xl(ret, "domain_wait_shutdown");
> > +		}
> > +
> > +		switch (event->type) {
> > +		case LIBXL_EVENT_TYPE_DOMAIN_DEATH:
> > +			goto done;
> > +		case LIBXL_EVENT_TYPE_DOMAIN_SHUTDOWN:
> > +			goto done;
> > +		default:
> > +			break;
> > +		}
> > +		libxl_event_free(CTX, event);
> > +	}
> > +done:
> > +	libxl_event_free(CTX, event);
> 
> I don't know, but this might be clearer with
> 	the_right-type type = event->type;
> 	lbixl_event_free(...)
> before the switch, which then becomes switch(type)?
> 
> Ian.

[PATCH v3-RESEND 25/28] libxl: ocaml: in send_debug_keys, clean up before raising exception

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/xenlight_stubs.c |    4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 84e1ad1..0c45743 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -967,11 +967,11 @@ value stub_xl_send_debug_keys(value ctx, value keys)
 	c_keys = dup_String_val(keys);
 
 	ret = libxl_send_debug_keys(CTX, c_keys);
+	free(c_keys);
+
 	if (ret != 0)
 		failwith_xl(ret, "send_debug_keys");
 
-	free(c_keys);
-
 	CAMLreturn(Val_unit);
 }
 
-- 
1.7.10.4

Re: [PATCH v3-RESEND 25/28] libxl: ocaml: in send_debug_keys, clean up before raising exception

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

I must confess I wasn't paying attention to this sort of issue in the
previous patches I looked at. I presume you have cast your eye over them
as part of making this fix?

Re: [PATCH v3-RESEND 25/28] libxl: ocaml: in send_debug_keys, clean up before raising exception

[Rob Hoes]

> On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> > Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
> 
> Acked-by: Ian Campbell <ian.campbell@citrix.com>
> 
> I must confess I wasn't paying attention to this sort of issue in the previous
> patches I looked at. I presume you have cast your eye over them as part of
> making this fix?

I did indeed! This was one of the issues that came up in the first version of the series.

Cheers,
Rob

[PATCH v3-RESEND 26/28] libxl: ocaml: provide defaults for libxl types

[Rob Hoes]

Libxl functions such as libxl_domain_create_new take large structs
of configuration parameters. Often, we would like to use the default
values for many of these parameters.

The struct and keyed-union types in libxl have init functions, which
fill in the defaults for a given type. This commit provides an OCaml
interface to obtain records of defaults by calling the relevant init
function.

These default records can be used as a base to construct your own
records, and to selectively override parameters where needed.

For example, a Domain_create_info record can now be created as follows:

  Xenlight.Domain_create_info.({ default ctx () with
    ty = Xenlight.DOMAIN_TYPE_PV;
    name = Some vm_name;
    uuid = vm_uuid;
  })

For types with KeyedUnion fields, such as Domain_build_info, a record
with defaults is obtained by specifying the type key:

  Xenlight.Domain_build_info.default ctx ~ty:Xenlight.DOMAIN_TYPE_HVM ()

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py |   61 +++++++++++++++++++++++++++++++++++-----
 1 file changed, 54 insertions(+), 7 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 192bec2..64e509b 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -112,6 +112,7 @@ def gen_struct(ty):
 
 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
@@ -151,9 +152,11 @@ def gen_ocaml_keyedunions(ty, interface, indent, parent = None):
         s += " | ".join(u) + "\n"
         ty.union_name = name
 
+        union_type = "?%s:%s" % (munge_name(nparent), ty.keyvar.type.rawname)
+
     if s == "":
-        return None
-    return s.replace("\n", "\n%s" % indent)
+        return None, None
+    return s.replace("\n", "\n%s" % indent), union_type
 
 def gen_ocaml_ml(ty, interface, indent=""):
 
@@ -190,17 +193,27 @@ def gen_ocaml_ml(ty, interface, indent=""):
                 s += "module %s = struct\n" % module_name
                 
         # Handle KeyedUnions...
+        union_types = []
         for f in ty.fields:
-            ku = gen_ocaml_keyedunions(f.type, interface, "\t")
+            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)
 
         s += "\ttype t =\n"
         s += "\t{\n"
         s += gen_struct(ty)
         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 functions.has_key(ty.rawname):
             for name,args in functions[ty.rawname]:
                 s += "\texternal %s : " % name
@@ -428,6 +441,38 @@ def gen_c_stub_prototype(ty, fns):
         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"
@@ -480,12 +525,14 @@ if __name__ == '__main__':
         if ty.marshal_in():
             cinc.write(gen_c_val(ty))
             cinc.write("\n")
-        if ty.marshal_out():
-            cinc.write(gen_Val_ocaml(ty))
-            cinc.write("\n")
+        cinc.write(gen_Val_ocaml(ty))
+        cinc.write("\n")
         if functions.has_key(ty.rawname):
             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")
-- 
1.7.10.4

Re: [PATCH v3-RESEND 26/28] libxl: ocaml: provide defaults for libxl types

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Libxl functions such as libxl_domain_create_new take large structs
> of configuration parameters. Often, we would like to use the default
> values for many of these parameters.
> 
> The struct and keyed-union types in libxl have init functions, which
> fill in the defaults for a given type. This commit provides an OCaml
> interface to obtain records of defaults by calling the relevant init
> function.
> 
> These default records can be used as a base to construct your own
> records, and to selectively override parameters where needed.
> 
> For example, a Domain_create_info record can now be created as follows:
> 
>   Xenlight.Domain_create_info.({ default ctx () with
>     ty = Xenlight.DOMAIN_TYPE_PV;
>     name = Some vm_name;
>     uuid = vm_uuid;
>   })
> 
> For types with KeyedUnion fields, such as Domain_build_info, a record
> with defaults is obtained by specifying the type key:
> 
>   Xenlight.Domain_build_info.default ctx ~ty:Xenlight.DOMAIN_TYPE_HVM ()
> 
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

I have a feeling some of this could be done better, but that's my fault
for laying such crappy groundwork, sorry!

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

[PATCH v3-RESEND 27/28] libxl: ocaml: use CAMLlocal1 macro rather than value-type in auto-generated C-code

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
---
 tools/ocaml/libs/xl/genwrap.py |    4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/tools/ocaml/libs/xl/genwrap.py b/tools/ocaml/libs/xl/genwrap.py
index 64e509b..3d5e386 100644
--- a/tools/ocaml/libs/xl/genwrap.py
+++ b/tools/ocaml/libs/xl/genwrap.py
@@ -347,7 +347,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
     elif isinstance(ty, idl.Array):
         s += "{\n"
         s += "\t    int i;\n"
-        s += "\t    value array_elem;\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)
@@ -397,7 +397,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None):
             fn = "anon_field"
         else:
             fn = "%s_field" % ty.rawname
-        s += "\tvalue %s;\n" % fn
+        s += "\tCAMLlocal1(%s);\n" % fn
         s += "\n"
         s += "\t%s = caml_alloc_tuple(%d);\n" % (o, len(ty.fields))
         
-- 
1.7.10.4

Re: [PATCH v3-RESEND 27/28] libxl: ocaml: use CAMLlocal1 macro rather than value-type in auto-generated C-code

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

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

[PATCH v3-RESEND 28/28] libxl: ocaml: add console reader functions

[Rob Hoes]

Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

---
New in v3:
* Replacing the "add xen_console_read" patch, with the more light-weight
  line-by-line reader functions.
---
 tools/ocaml/libs/xl/xenlight.ml.in   |   10 ++++-
 tools/ocaml/libs/xl/xenlight.mli.in  |    7 ++++
 tools/ocaml/libs/xl/xenlight_stubs.c |   68 ++++++++++++++++++++++++++++++++++
 tools/ocaml/test/Makefile            |   12 ++++--
 tools/ocaml/test/dmesg.ml            |   18 +++++++++
 5 files changed, 111 insertions(+), 4 deletions(-)
 create mode 100644 tools/ocaml/test/dmesg.ml

diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
index 8388c5f..6c95f14 100644
--- a/tools/ocaml/libs/xl/xenlight.ml.in
+++ b/tools/ocaml/libs/xl/xenlight.ml.in
@@ -50,6 +50,13 @@ module Domain = struct
 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
 
@@ -112,5 +119,6 @@ module Async = functor (S: EVENT_USERS) -> struct
 end
 
 let register_exceptions () =
-	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""))
+	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""));
+	Callback.register_exception "Xenlight.Host.End_of_file" (Host.End_of_file)
 
diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
index 31faf26..e489d19 100644
--- a/tools/ocaml/libs/xl/xenlight.mli.in
+++ b/tools/ocaml/libs/xl/xenlight.mli.in
@@ -52,6 +52,13 @@ module Domain : sig
 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
 
diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
index 0c45743..cab4ed4 100644
--- a/tools/ocaml/libs/xl/xenlight_stubs.c
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c
@@ -975,6 +975,74 @@ value stub_xl_send_debug_keys(value ctx, value 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);
+	libxl_xen_console_reader *cr;
+
+	cr = libxl_xen_console_read_start(CTX, Int_val(clear));
+
+	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 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);
+
+	ret = libxl_xen_console_read_line(CTX, cr, &c_line);
+
+	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);
+
+	libxl_xen_console_read_finish(CTX, cr);
+
+	CAMLreturn(Val_unit);
+}
 
 /* Event handling */
 
diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile
index 8387d43..e6ba865 100644
--- a/tools/ocaml/test/Makefile
+++ b/tools/ocaml/test/Makefile
@@ -9,9 +9,9 @@ OCAMLINCLUDE += \
 	-I $(OCAML_TOPLEVEL)/libs/xentoollog \
 	-I $(OCAML_TOPLEVEL)/libs/xl
 
-OBJS = xtl send_debug_keys list_domains raise_exception
+OBJS = xtl send_debug_keys list_domains raise_exception dmesg
 
-PROGRAMS = xtl send_debug_keys list_domains raise_exception
+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 \
@@ -37,7 +37,13 @@ raise_exception_LIBS =  \
 
 raise_exception_OBJS = raise_exception
 
-OCAML_PROGRAM = xtl send_debug_keys list_domains 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)
 
diff --git a/tools/ocaml/test/dmesg.ml b/tools/ocaml/test/dmesg.ml
new file mode 100644
index 0000000..864fac4
--- /dev/null
+++ b/tools/ocaml/test/dmesg.ml
@@ -0,0 +1,18 @@
+open Printf
+
+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
+	()
+
-- 
1.7.10.4

Re: [PATCH v3-RESEND 28/28] libxl: ocaml: add console reader functions

[Ian Campbell]

On Mon, 2013-10-21 at 14:32 +0100, Rob Hoes wrote:
> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>

In so far as I have any clue at all what the right way to do these sorts
of complex type ocaml bindings:
Acked-by: Ian Campbell <ian.campbell@citrix.com>

> 
> ---
> New in v3:
> * Replacing the "add xen_console_read" patch, with the more light-weight
>   line-by-line reader functions.
> ---
>  tools/ocaml/libs/xl/xenlight.ml.in   |   10 ++++-
>  tools/ocaml/libs/xl/xenlight.mli.in  |    7 ++++
>  tools/ocaml/libs/xl/xenlight_stubs.c |   68 ++++++++++++++++++++++++++++++++++
>  tools/ocaml/test/Makefile            |   12 ++++--
>  tools/ocaml/test/dmesg.ml            |   18 +++++++++
>  5 files changed, 111 insertions(+), 4 deletions(-)
>  create mode 100644 tools/ocaml/test/dmesg.ml
> 
> diff --git a/tools/ocaml/libs/xl/xenlight.ml.in b/tools/ocaml/libs/xl/xenlight.ml.in
> index 8388c5f..6c95f14 100644
> --- a/tools/ocaml/libs/xl/xenlight.ml.in
> +++ b/tools/ocaml/libs/xl/xenlight.ml.in
> @@ -50,6 +50,13 @@ module Domain = struct
>  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
>  
> @@ -112,5 +119,6 @@ module Async = functor (S: EVENT_USERS) -> struct
>  end
>  
>  let register_exceptions () =
> -	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""))
> +	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""));
> +	Callback.register_exception "Xenlight.Host.End_of_file" (Host.End_of_file)
>  
> diff --git a/tools/ocaml/libs/xl/xenlight.mli.in b/tools/ocaml/libs/xl/xenlight.mli.in
> index 31faf26..e489d19 100644
> --- a/tools/ocaml/libs/xl/xenlight.mli.in
> +++ b/tools/ocaml/libs/xl/xenlight.mli.in
> @@ -52,6 +52,13 @@ module Domain : sig
>  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
>  
> diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c
> index 0c45743..cab4ed4 100644
> --- a/tools/ocaml/libs/xl/xenlight_stubs.c
> +++ b/tools/ocaml/libs/xl/xenlight_stubs.c
> @@ -975,6 +975,74 @@ value stub_xl_send_debug_keys(value ctx, value 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);
> +	libxl_xen_console_reader *cr;
> +
> +	cr = libxl_xen_console_read_start(CTX, Int_val(clear));
> +
> +	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 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);
> +
> +	ret = libxl_xen_console_read_line(CTX, cr, &c_line);
> +
> +	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);
> +
> +	libxl_xen_console_read_finish(CTX, cr);
> +
> +	CAMLreturn(Val_unit);
> +}
>  
>  /* Event handling */
>  
> diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile
> index 8387d43..e6ba865 100644
> --- a/tools/ocaml/test/Makefile
> +++ b/tools/ocaml/test/Makefile
> @@ -9,9 +9,9 @@ OCAMLINCLUDE += \
>  	-I $(OCAML_TOPLEVEL)/libs/xentoollog \
>  	-I $(OCAML_TOPLEVEL)/libs/xl
>  
> -OBJS = xtl send_debug_keys list_domains raise_exception
> +OBJS = xtl send_debug_keys list_domains raise_exception dmesg
>  
> -PROGRAMS = xtl send_debug_keys list_domains raise_exception
> +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 \
> @@ -37,7 +37,13 @@ raise_exception_LIBS =  \
>  
>  raise_exception_OBJS = raise_exception
>  
> -OCAML_PROGRAM = xtl send_debug_keys list_domains 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)
>  
> diff --git a/tools/ocaml/test/dmesg.ml b/tools/ocaml/test/dmesg.ml
> new file mode 100644
> index 0000000..864fac4
> --- /dev/null
> +++ b/tools/ocaml/test/dmesg.ml
> @@ -0,0 +1,18 @@
> +open Printf
> +
> +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
> +	()
> +

Re: libxl: ocaml: improve the bindings

[David Scott]

Hi Rob,

On 21/10/13 14:32, Rob Hoes wrote:
> The following series of patches fill in most of the gaps in the OCaml bindings
> to libxl, to make them useful for clients such as xapi/xenopsd (from
> XenServer). There are a number of bugfixes to the existing bindings as well. I
> have an experimental version of xenopsd that successfully uses the new
> bindings.
>
> This is version 3 of this patch series to fix the OCaml binding to libxl. I
> believe I have addressed all the points raised by Ian Jackson's review of
> version 2. See the individual patches for detailed changes with respect to v2.

I'm happy with all the tools/ocaml patches:

Acked-by: David Scott <dave.scott@eu.citrix.com>

Cheers,
Dave

libxl: ocaml: improve the bindings

[Rob Hoes]

This is version 7 of the remaining patches to fix the OCaml bindings to libxl.

There were only minor changes in patch 3, 6, and 8.

For convenience, the patches in this series may be pulled using:
git pull git://github.com/robhoes/xen.git hydrogen-upstream-v7

Re: libxl: ocaml: improve the bindings

[Ian Campbell]

On Tue, 2013-12-10 at 16:48 +0000, Rob Hoes wrote:
> This is version 7 of the remaining patches to fix the OCaml bindings to libxl.
> 
> There were only minor changes in patch 3, 6, and 8.

Applied. thanks.

Re: libxl: ocaml: improve the bindings

[Rob Hoes]

On 11 Dec 2013, at 13:37, Ian Campbell <Ian.Campbell@citrix.com> wrote:
> On Tue, 2013-12-10 at 16:48 +0000, Rob Hoes wrote:
>> This is version 7 of the remaining patches to fix the OCaml bindings to libxl.
>> 
>> There were only minor changes in patch 3, 6, and 8.
> 
> Applied. thanks.

Thanks Ian.

I’d really like to thank you, Ian Jackson, and Dave Scott for all the feedback you have given on these patches. The review process led to some important improvements and ensured that some nasty, critical issues were found and fixed early. It is very important to get such a fundamental piece of software absolutely right!

Cheers,
Rob

Re: libxl: ocaml: improve the bindings

[Ian Campbell]

On Wed, 2013-12-11 at 13:57 +0000, Rob Hoes wrote:
> On 11 Dec 2013, at 13:37, Ian Campbell <Ian.Campbell@citrix.com> wrote:
> > On Tue, 2013-12-10 at 16:48 +0000, Rob Hoes wrote:
> >> This is version 7 of the remaining patches to fix the OCaml bindings to libxl.
> >> 
> >> There were only minor changes in patch 3, 6, and 8.
> > 
> > Applied. thanks.
> 
> Thanks Ian.
> 
> I’d really like to thank you, Ian Jackson, and Dave Scott for all the
> feedback you have given on these patches. The review process led to
> some important improvements and ensured that some nasty, critical
> issues were found and fixed early.

No problem! Thanks for doing the actual work!

>  It is very important to get such a fundamental piece of software
> absolutely right!

If it is "absolutely right" then someone owes someone a beer (I'm not
sure who though!) ;-)

Ian.


_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xen.org
http://lists.xen.org/xen-devel

libxl: ocaml: improve the bindings

[Rob Hoes]

This is version 2 of this patch series to fix the OCaml binding to libxl.

I believe I have addressed all the points raised by Dave Scott and Ian Campbell. Sorry for the delay in getting this new series out!

The main changes are:
* Several fixes to ensure the bindings play well with the OCaml GC. This includes properly using macros such as CAMLparam* and CAMLreturn* for _all_ OCaml values (even intermediate ones), and using "custom" blocks to encapsulate pointers to C code (including handy "finalize" functions for cleanup.
* Fixes in the way KeyedUnions are handled.
* Use the libxl init function to generate default records for libxl types.
* Improve the functions that deal with event handling. We now have some higher-level functions to makes this easier as well as safer, and errors are translated properly.

---------

The following series of patches fill in most of the gaps in the OCaml bindings to libxl, to make them useful for clients such as xapi/xenopsd (from XCP).
There are a number of bugfixes to the existing bindings as well. I have an experimental version of xenopsd that successfully uses the new bindings.

An earlier version of the first half of the series was submitted to the last by Ian Campbell on 20 Nov 2012. With his permission, I have updated most of them to fix some issues (which were discussed on the mailing list at the time). I have left Ian's signed-off-by line on those patches (please let me know if that is not appropriate).

For convenience, the patches in this series may be pulled using:

git pull git://github.com/robhoes/xen.git hydrogen-upstream-v2

Cheers,
Rob

Re: libxl: ocaml: improve the bindings

[Rob Hoes]

Hi,

I'd like to ask for the patches to the libxl OCaml bindings, which I submitted a while ago, to be considered for Xen 4.4.

I have rebased the series onto the current master branch, and there were no conflicts. The rebased version can be pulled using "git pull https://github.com/robhoes/xen.git hydrogen-upstream-v2-rebased".

Thanks,
Rob

> -----Original Message-----
> From: xen-devel-bounces@lists.xen.org [mailto:xen-devel-
> bounces@lists.xen.org] On Behalf Of Rob Hoes
> Sent: 13 June 2013 4:25 PM
> To: xen-devel@lists.xen.org
> Subject: [Xen-devel] libxl: ocaml: improve the bindings
> 
> This is version 2 of this patch series to fix the OCaml binding to libxl.
> 
> I believe I have addressed all the points raised by Dave Scott and Ian
> Campbell. Sorry for the delay in getting this new series out!
> 
> The main changes are:
> * Several fixes to ensure the bindings play well with the OCaml GC. This
> includes properly using macros such as CAMLparam* and CAMLreturn* for
> _all_ OCaml values (even intermediate ones), and using "custom" blocks to
> encapsulate pointers to C code (including handy "finalize" functions for
> cleanup.
> * Fixes in the way KeyedUnions are handled.
> * Use the libxl init function to generate default records for libxl types.
> * Improve the functions that deal with event handling. We now have some
> higher-level functions to makes this easier as well as safer, and errors are
> translated properly.
> 
> ---------
> 
> The following series of patches fill in most of the gaps in the OCaml
> bindings to libxl, to make them useful for clients such as xapi/xenopsd
> (from XCP).
> There are a number of bugfixes to the existing bindings as well. I have an
> experimental version of xenopsd that successfully uses the new bindings.
> 
> An earlier version of the first half of the series was submitted to the last by
> Ian Campbell on 20 Nov 2012. With his permission, I have updated most of
> them to fix some issues (which were discussed on the mailing list at the
> time). I have left Ian's signed-off-by line on those patches (please let me
> know if that is not appropriate).
> 
> For convenience, the patches in this series may be pulled using:
> 
> git pull git://github.com/robhoes/xen.git hydrogen-upstream-v2
> 	
> Cheers,
> Rob
> 
> 
> _______________________________________________
> Xen-devel mailing list
> Xen-devel@lists.xen.org
> http://lists.xen.org/xen-devel

Re: libxl: ocaml: improve the bindings

[Ian Campbell]

On Thu, 2013-08-22 at 11:21 +0100, Rob Hoes wrote:
> Hi,
> 
> I'd like to ask for the patches to the libxl OCaml bindings, which I
> submitted a while ago, to be considered for Xen 4.4.
> 
> I have rebased the series onto the current master branch, and there
> were no conflicts. The rebased version can be pulled using "git pull
> https://github.com/robhoes/xen.git hydrogen-upstream-v2-rebased".

Please can you also repost as patches here.

Ian.