@@ -4,10 +4,6 @@ include $(XEN_ROOT)/tools/Rules.mk
SUBDIRS := libs
SUBDIRS += xenstored
-ifeq ($(CONFIG_TESTS),y)
-SUBDIRS += test
-endif
-
.NOTPARALLEL:
# targets here must be run in order, otherwise we can try
# to build programs before the libraries are done
@@ -5,7 +5,7 @@ SUBDIRS= \
mmap \
xentoollog \
eventchn xc \
- xb xs xl
+ xb xs
.PHONY: all
all: subdirs-all
deleted file mode 100644
@@ -1,5 +0,0 @@
-version = "@VERSION@"
-description = "Xen Toolstack Library"
-requires = "xentoollog"
-archive(byte) = "xenlight.cma"
-archive(native) = "xenlight.cmxa"
deleted file mode 100644
@@ -1,71 +0,0 @@
-OCAML_TOPLEVEL=$(CURDIR)/../..
-XEN_ROOT=$(OCAML_TOPLEVEL)/../..
-include $(OCAML_TOPLEVEL)/common.make
-
-# ignore unused generated functions and allow mixed declarations and code
-CFLAGS += -Wno-unused -Wno-declaration-after-statement
-
-CFLAGS += $(CFLAGS_libxenlight)
-CFLAGS += -I ../xentoollog
-CFLAGS += $(APPEND_CFLAGS)
-
-OBJS = xenlight
-INTF = xenlight.cmi
-LIBS = xenlight.cma xenlight.cmxa
-
-OCAMLINCLUDE += -I ../xentoollog
-
-LIBS_xenlight = $(call xenlibs-ldflags-ldlibs,light)
-
-xenlight_OBJS = $(OBJS)
-xenlight_C_OBJS = xenlight_stubs
-
-OCAML_LIBRARY = xenlight
-
-GENERATED_FILES += xenlight.ml xenlight.ml.tmp xenlight.mli xenlight.mli.tmp
-GENERATED_FILES += _libxl_types.ml.in _libxl_types.mli.in
-GENERATED_FILES += _libxl_types.inc META
-
-all: $(INTF) $(LIBS)
-
-xenlight.ml: xenlight.ml.in _libxl_types.ml.in
- $(Q)sed -e '1i\
-(*\
- * AUTO-GENERATED FILE DO NOT EDIT\
- * Generated from xenlight.ml.in and _libxl_types.ml.in\
- *)\
-' \
- -e '/^(\* @@LIBXL_TYPES@@ \*)$$/r_libxl_types.ml.in' \
- < xenlight.ml.in > xenlight.ml.tmp
- $(Q)mv xenlight.ml.tmp xenlight.ml
-
-xenlight.mli: xenlight.mli.in _libxl_types.mli.in
- $(Q)sed -e '1i\
-(*\
- * AUTO-GENERATED FILE DO NOT EDIT\
- * Generated from xenlight.mli.in and _libxl_types.mli.in\
- *)\
-' \
- -e '/^(\* @@LIBXL_TYPES@@ \*)$$/r_libxl_types.mli.in' \
- < xenlight.mli.in > xenlight.mli.tmp
- $(Q)mv xenlight.mli.tmp xenlight.mli
-
-_libxl_types.ml.in _libxl_types.mli.in _libxl_types.inc: genwrap.py $(XEN_ROOT)/tools/libs/light/libxl_types.idl \
- $(XEN_ROOT)/tools/libs/light/idl.py
- PYTHONPATH=$(XEN_ROOT)/tools/libs/light $(PYTHON) genwrap.py \
- $(XEN_ROOT)/tools/libs/light/libxl_types.idl \
- _libxl_types.mli.in _libxl_types.ml.in _libxl_types.inc
-
-libs: $(LIBS)
-
-.PHONY: install
-install: $(LIBS) META
- mkdir -p $(OCAMLDESTDIR)
- $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xenlight
- $(OCAMLFIND) install -destdir $(OCAMLDESTDIR) -ldconf ignore xenlight META $(INTF) $(LIBS) *.a *.so *.cmx
-
-.PHONY: uninstall
-uninstall:
- $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xenlight
-
-include $(OCAML_TOPLEVEL)/Makefile.rules
deleted file mode 100644
@@ -1,582 +0,0 @@
-#!/usr/bin/python
-
-from __future__ import print_function
-
-import sys,os
-from functools import reduce
-
-import idl
-
-# typename -> ( ocaml_type, c_from_ocaml, ocaml_from_c )
-builtins = {
- "bool": ("bool", "%(c)s = Bool_val(%(o)s)", "Val_bool(%(c)s)" ),
- "int": ("int", "%(c)s = Int_val(%(o)s)", "Val_int(%(c)s)" ),
- "char *": ("string option", "%(c)s = String_option_val(%(o)s)", "Val_string_option(%(c)s)"),
- "libxl_domid": ("domid", "%(c)s = Int_val(%(o)s)", "Val_int(%(c)s)" ),
- "libxl_devid": ("devid", "%(c)s = Int_val(%(o)s)", "Val_int(%(c)s)" ),
- "libxl_defbool": ("bool option", "%(c)s = Defbool_val(%(o)s)", "Val_defbool(%(c)s)" ),
- "libxl_uuid": ("int array", "Uuid_val(&%(c)s, %(o)s)", "Val_uuid(&%(c)s)"),
- "libxl_bitmap": ("bool array", "Bitmap_val(ctx, &%(c)s, %(o)s)", "Val_bitmap(&%(c)s)"),
- "libxl_key_value_list": ("(string * string) list", "libxl_key_value_list_val(&%(c)s, %(o)s)", "Val_key_value_list(&%(c)s)"),
- "libxl_string_list": ("string list", "libxl_string_list_val(&%(c)s, %(o)s)", "Val_string_list(&%(c)s)"),
- "libxl_mac": ("int array", "Mac_val(&%(c)s, %(o)s)", "Val_mac(&%(c)s)"),
- "libxl_hwcap": ("int32 array", None, "Val_hwcap(&%(c)s)"),
- "libxl_ms_vm_genid": ("int array", "Ms_vm_genid_val(&%(c)s, %(o)s)", "Val_ms_vm_genid(&%(c)s)"),
- # The following needs to be sorted out later
- "libxl_cpuid_policy_list": ("unit", "%(c)s = 0", "Val_unit"),
- }
-
-DEVICE_FUNCTIONS = [ ("add", ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
- ("remove", ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
- ("destroy", ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
- ]
-DEVICE_LIST = [ ("list", ["ctx", "domid", "t list"]),
- ]
-
-functions = { # ( name , [type1,type2,....] )
- "device_vfb": DEVICE_FUNCTIONS,
- "device_vkb": DEVICE_FUNCTIONS,
- "device_disk": DEVICE_FUNCTIONS + DEVICE_LIST +
- [ ("insert", ["ctx", "t", "domid", "?async:'a", "unit", "unit"]),
- ("of_vdev", ["ctx", "domid", "string", "t"]),
- ],
- "device_nic": DEVICE_FUNCTIONS + DEVICE_LIST +
- [ ("of_devid", ["ctx", "domid", "int", "t"]),
- ],
- "device_pci": DEVICE_FUNCTIONS + DEVICE_LIST +
- [ ("assignable_add", ["ctx", "t", "bool", "unit"]),
- ("assignable_remove", ["ctx", "t", "bool", "unit"]),
- ("assignable_list", ["ctx", "t list"]),
- ],
- "dominfo": [ ("list", ["ctx", "t list"]),
- ("get", ["ctx", "domid", "t"]),
- ],
- "physinfo": [ ("get", ["ctx", "t"]),
- ],
- "cputopology": [ ("get", ["ctx", "t array"]),
- ],
- "domain_sched_params":
- [ ("get", ["ctx", "domid", "t"]),
- ("set", ["ctx", "domid", "t", "unit"]),
- ],
-}
-def stub_fn_name(ty, name):
- return "stub_xl_%s_%s" % (ty.rawname,name)
-
-def ocaml_type_of(ty):
- if ty.rawname in ["domid","devid"]:
- return ty.rawname
- elif isinstance(ty,idl.UInt):
- if ty.width in [8, 16]:
- # handle as ints
- width = None
- elif ty.width in [32, 64]:
- width = ty.width
- else:
- raise NotImplementedError("Cannot handle %d-bit int" % ty.width)
- if width:
- return "int%d" % ty.width
- else:
- return "int"
- elif isinstance(ty,idl.Array):
- return "%s array" % ocaml_type_of(ty.elem_type)
- elif isinstance(ty,idl.Builtin):
- if ty.typename not in builtins:
- raise NotImplementedError("Unknown Builtin %s (%s)" % (ty.typename, type(ty)))
- typename,_,_ = builtins[ty.typename]
- if not typename:
- raise NotImplementedError("No typename for Builtin %s (%s)" % (ty.typename, type(ty)))
- return typename
- elif isinstance(ty,idl.KeyedUnion):
- return ty.union_name
- elif isinstance(ty,idl.Aggregate):
- if ty.rawname is None:
- return ty.anon_struct
- else:
- return ty.rawname.capitalize() + ".t"
- else:
- return ty.rawname
-
-ocaml_keywords = ['and', 'as', 'assert', 'begin', 'end', 'class', 'constraint',
- 'do', 'done', 'downto', 'else', 'if', 'end', 'exception', 'external', 'false',
- 'for', 'fun', 'function', 'functor', 'if', 'in', 'include', 'inherit',
- 'initializer', 'lazy', 'let', 'match', 'method', 'module', 'mutable', 'new',
- 'object', 'of', 'open', 'or', 'private', 'rec', 'sig', 'struct', 'then', 'to',
- 'true', 'try', 'type', 'val', 'virtual', 'when', 'while', 'with']
-
-def munge_name(name):
- if name in ocaml_keywords:
- return "xl_" + name
- else:
- return name
-
-def ocaml_instance_of_field(f):
- if isinstance(f.type, idl.KeyedUnion):
- name = f.type.keyvar.name
- else:
- name = f.name
- return "%s : %s" % (munge_name(name), ocaml_type_of(f.type))
-
-def gen_struct(ty, indent):
- s = ""
- for f in ty.fields:
- if f.type.private:
- continue
- x = ocaml_instance_of_field(f)
- x = x.replace("\n", "\n"+indent)
- s += indent + x + ";\n"
- return s
-
-def gen_ocaml_keyedunions(ty, interface, indent, parent = None):
- s = ""
- union_type = ""
-
- if ty.rawname is not None:
- # Non-anonymous types need no special handling
- pass
- elif isinstance(ty, idl.KeyedUnion):
- if parent is None:
- nparent = ty.keyvar.name
- else:
- nparent = parent + "_" + ty.keyvar.name
-
- for f in ty.fields:
- if f.type is None: continue
- if f.type.rawname is not None: continue
- if isinstance(f.type, idl.Struct) and not f.type.has_fields(): continue
- s += "\ntype %s_%s =\n" % (nparent,f.name)
- s += "{\n"
- s += gen_struct(f.type, indent + "\t")
- s += "}\n"
-
- name = "%s__union" % ty.keyvar.name
- s += "\n"
- s += "type %s = " % name
- u = []
- for f in ty.fields:
- if f.type is None:
- u.append("%s" % (f.name.capitalize()))
- elif isinstance(f.type, idl.Struct):
- if f.type.rawname is not None:
- u.append("%s of %s.t" % (f.name.capitalize(), f.type.rawname.capitalize()))
- elif f.type.has_fields():
- u.append("%s of %s_%s" % (f.name.capitalize(), nparent, f.name))
- else:
- u.append("%s" % (f.name.capitalize()))
- else:
- raise NotImplementedError("Cannot handle KeyedUnion fields which are not Structs")
-
- s += " | ".join(u) + "\n"
- ty.union_name = name
-
- union_type = "?%s:%s" % (munge_name(nparent), ty.keyvar.type.rawname)
-
- if s == "":
- return None, None
- return s.replace("\n", "\n%s" % indent), union_type
-
-def gen_ocaml_anonstruct(ty, interface, indent, parent = None):
- s= ""
-
- if ty.rawname is not None:
- # Non-anonymous types need no special handling
- pass
- elif isinstance(ty, idl.Struct):
- name = "%s__anon" % parent
- s += "type %s = {\n" % name
- s += gen_struct(ty, indent)
- s += "}\n"
- ty.anon_struct = name
- if s == "":
- return None
- s = indent + s
- return s.replace("\n", "\n%s" % indent)
-
-def gen_ocaml_ml(ty, interface, indent=""):
-
- if interface:
- s = ("""(* %s interface *)\n""" % ty.typename)
- else:
- s = ("""(* %s implementation *)\n""" % ty.typename)
-
- if isinstance(ty, idl.Enumeration):
- s += "type %s = \n" % ty.rawname
- for v in ty.values:
- s += "\t | %s\n" % v.rawname
-
- if interface:
- s += "\nval string_of_%s : %s -> string\n" % (ty.rawname, ty.rawname)
- else:
- s += "\nlet string_of_%s = function\n" % ty.rawname
- for v in ty.values:
- s += '\t| %s -> "%s"\n' % (v.rawname, v.valuename)
-
- elif isinstance(ty, idl.Aggregate):
- s += ""
-
- if ty.typename is None:
- raise NotImplementedError("%s has no typename" % type(ty))
- else:
-
- module_name = ty.rawname[0].upper() + ty.rawname[1:]
-
- if interface:
- s += "module %s : sig\n" % module_name
- else:
- s += "module %s = struct\n" % module_name
-
- # Handle KeyedUnions...
- union_types = []
- for f in ty.fields:
- ku, union_type = gen_ocaml_keyedunions(f.type, interface, "\t")
- if ku is not None:
- s += ku
- s += "\n"
- if union_type is not None:
- union_types.append(union_type)
-
- # Handle anonymous structs...
- for f in ty.fields:
- anon = gen_ocaml_anonstruct(f.type, interface, "\t", f.name)
- if anon is not None:
- s += anon
- s += "\n"
-
- s += "\ttype t =\n"
- s += "\t{\n"
- s += gen_struct(ty, "\t\t")
- s += "\t}\n"
-
- if ty.init_fn is not None:
- union_args = "".join([u + " -> " for u in union_types])
- if interface:
- s += "\tval default : ctx -> %sunit -> t\n" % union_args
- else:
- s += "\texternal default : ctx -> %sunit -> t = \"stub_libxl_%s_init\"\n" % (union_args, ty.rawname)
-
- if ty.rawname in functions:
- for name,args in functions[ty.rawname]:
- s += "\texternal %s : " % name
- s += " -> ".join(args)
- s += " = \"%s\"\n" % stub_fn_name(ty,name)
-
- s += "end\n"
-
- else:
- raise NotImplementedError("%s" % type(ty))
- return s.replace("\n", "\n%s" % indent)
-
-def c_val(ty, c, o, indent="", parent = None):
- s = indent
- if isinstance(ty,idl.UInt):
- if ty.width in [8, 16]:
- # handle as ints
- width = None
- elif ty.width in [32, 64]:
- width = ty.width
- else:
- raise NotImplementedError("Cannot handle %d-bit int" % ty.width)
- if width:
- s += "%s = Int%d_val(%s);" % (c, width, o)
- else:
- s += "%s = Int_val(%s);" % (c, o)
- elif isinstance(ty,idl.Builtin):
- if ty.typename not in builtins:
- raise NotImplementedError("Unknown Builtin %s (%s)" % (ty.typename, type(ty)))
- _,fn,_ = builtins[ty.typename]
- if not fn:
- raise NotImplementedError("No c_val fn for Builtin %s (%s)" % (ty.typename, type(ty)))
- s += "%s;" % (fn % { "o": o, "c": c })
- elif isinstance (ty,idl.Array):
- s += "{\n"
- s += "\tint i;\n"
- s += "\t%s = Wosize_val(%s);\n" % (parent + ty.lenvar.name, o)
- s += "\t%s = (%s) calloc(%s, sizeof(*%s));\n" % (c, ty.typename, parent + ty.lenvar.name, c)
- s += "\tfor(i=0; i<%s; i++) {\n" % (parent + ty.lenvar.name)
- s += c_val(ty.elem_type, c+"[i]", "Field(%s, i)" % o, indent="\t\t", parent=parent) + "\n"
- s += "\t}\n"
- s += "}\n"
- elif isinstance(ty,idl.Enumeration) and (parent is None):
- n = 0
- s += "switch(Int_val(%s)) {\n" % o
- for e in ty.values:
- s += " case %d: *%s = %s; break;\n" % (n, c, e.name)
- n += 1
- s += " default: failwith_xl(ERROR_FAIL, \"cannot convert value to %s\"); break;\n" % ty.typename
- s += "}"
- elif isinstance(ty, idl.KeyedUnion):
- s += "{\n"
- s += "\tif(Is_long(%s)) {\n" % o
- n = 0
- s += "\t\tswitch(Int_val(%s)) {\n" % o
- for f in ty.fields:
- if f.type is None or not f.type.has_fields():
- s += "\t\t case %d: %s = %s; break;\n" % (n,
- parent + ty.keyvar.name,
- f.enumname)
- n += 1
- s += "\t\t default: failwith_xl(ERROR_FAIL, \"variant handling bug %s%s (long)\"); break;\n" % (parent, ty.keyvar.name)
- s += "\t\t}\n"
- s += "\t} else {\n"
- s += "\t\t/* Is block... */\n"
- s += "\t\tswitch(Tag_val(%s)) {\n" % o
- n = 0
- for f in ty.fields:
- if f.type is not None and f.type.has_fields():
- if f.type.private:
- continue
- s += "\t\t case %d:\n" % (n)
- s += "\t\t %s = %s;\n" % (parent + ty.keyvar.name, f.enumname)
- (nparent,fexpr) = ty.member(c, f, False)
- s += "%s" % c_val(f.type, fexpr, "Field(%s, 0)" % o, parent=nparent, indent=indent+"\t\t ")
- s += "break;\n"
- n += 1
- s += "\t\t default: failwith_xl(ERROR_FAIL, \"variant handling bug %s%s (block)\"); break;\n" % (parent, ty.keyvar.name)
- s += "\t\t}\n"
- s += "\t}\n"
- s += "}"
- elif isinstance(ty, idl.Aggregate) and (parent is None or ty.rawname is None):
- n = 0
- for f in ty.fields:
- if f.type.private:
- continue
- (nparent,fexpr) = ty.member(c, f, ty.rawname is not None)
- s += "%s\n" % c_val(f.type, fexpr, "Field(%s, %d)" % (o,n), parent=nparent)
- n = n + 1
- else:
- s += "%s_val(ctx, %s, %s);" % (ty.rawname, ty.pass_arg(c, parent is None, passby=idl.PASS_BY_REFERENCE), o)
-
- return s.replace("\n", "\n%s" % indent)
-
-def gen_c_val(ty, indent=""):
- s = "/* Convert caml value to %s */\n" % ty.rawname
-
- s += "static int %s_val (libxl_ctx *ctx, %s, value v)\n" % (ty.rawname, ty.make_arg("c_val", passby=idl.PASS_BY_REFERENCE))
- s += "{\n"
- s += "\tCAMLparam1(v);\n"
- s += "\n"
-
- s += c_val(ty, "c_val", "v", indent="\t") + "\n"
-
- s += "\tCAMLreturn(0);\n"
- s += "}\n"
-
- return s.replace("\n", "\n%s" % indent)
-
-def ocaml_Val(ty, o, c, indent="", parent = None):
- s = indent
- if isinstance(ty,idl.UInt):
- if ty.width in [8, 16]:
- # handle as ints
- width = None
- elif ty.width in [32, 64]:
- width = ty.width
- else:
- raise NotImplementedError("Cannot handle %d-bit int" % ty.width)
- if width:
- s += "%s = caml_copy_int%d(%s);" % (o, width, c)
- else:
- s += "%s = Val_int(%s);" % (o, c)
- elif isinstance(ty,idl.Builtin):
- if ty.typename not in builtins:
- raise NotImplementedError("Unknown Builtin %s (%s)" % (ty.typename, type(ty)))
- _,_,fn = builtins[ty.typename]
- if not fn:
- raise NotImplementedError("No ocaml Val fn for Builtin %s (%s)" % (ty.typename, type(ty)))
- s += "%s = %s;" % (o, fn % { "c": c })
- elif isinstance(ty, idl.Array):
- s += "{\n"
- s += "\t int i;\n"
- s += "\t CAMLlocal1(array_elem);\n"
- s += "\t %s = caml_alloc(%s,0);\n" % (o, parent + ty.lenvar.name)
- s += "\t for(i=0; i<%s; i++) {\n" % (parent + ty.lenvar.name)
- s += "\t %s\n" % ocaml_Val(ty.elem_type, "array_elem", c + "[i]", "", parent=parent)
- s += "\t Store_field(%s, i, array_elem);\n" % o
- s += "\t }\n"
- s += "\t}"
- elif isinstance(ty,idl.Enumeration) and (parent is None):
- n = 0
- s += "switch(%s) {\n" % c
- for e in ty.values:
- s += " case %s: %s = Val_int(%d); break;\n" % (e.name, o, n)
- n += 1
- s += " default: failwith_xl(ERROR_FAIL, \"cannot convert value from %s\"); break;\n" % ty.typename
- s += "}"
- elif isinstance(ty, idl.KeyedUnion):
- n = 0
- m = 0
- s += "switch(%s) {\n" % (parent + ty.keyvar.name)
- for f in ty.fields:
- s += "\t case %s:\n" % f.enumname
- if f.type is None:
- s += "\t /* %d: None */\n" % n
- s += "\t %s = Val_long(%d);\n" % (o,n)
- n += 1
- elif not f.type.has_fields():
- s += "\t /* %d: Long */\n" % n
- s += "\t %s = Val_long(%d);\n" % (o,n)
- n += 1
- else:
- s += "\t /* %d: Block */\n" % m
- (nparent,fexpr) = ty.member(c, f, parent is None)
- s += "\t {\n"
- s += "\t\t CAMLlocal1(tmp);\n"
- s += "\t\t %s = caml_alloc(%d,%d);\n" % (o, 1, m)
- s += ocaml_Val(f.type, 'tmp', fexpr, indent="\t\t ", parent=nparent)
- s += "\n"
- s += "\t\t Store_field(%s, 0, tmp);\n" % o
- s += "\t }\n"
- m += 1
- #s += "\t %s = caml_alloc(%d,%d);\n" % (o,len(f.type.fields),n)
- s += "\t break;\n"
- s += "\t default: failwith_xl(ERROR_FAIL, \"cannot convert value from %s\"); break;\n" % ty.typename
- s += "\t}"
- elif isinstance(ty,idl.Aggregate) and (parent is None or ty.rawname is None):
- s += "{\n"
- if ty.rawname is None:
- fn = "anon_field"
- else:
- fn = "%s_field" % ty.rawname
- s += "\tCAMLlocal1(%s);\n" % fn
- s += "\n"
- s += "\t%s = caml_alloc_tuple(%d);\n" % (o, len(ty.fields))
-
- n = 0
- for f in ty.fields:
- if f.type.private:
- continue
-
- (nparent,fexpr) = ty.member(c, f, parent is None)
-
- s += "\n"
- s += "\t%s\n" % ocaml_Val(f.type, fn, ty.pass_arg(fexpr, c), parent=nparent)
- s += "\tStore_field(%s, %d, %s);\n" % (o, n, fn)
- n = n + 1
- s += "}"
- else:
- s += "%s = Val_%s(%s);" % (o, ty.rawname, ty.pass_arg(c, parent is None))
-
- return s.replace("\n", "\n%s" % indent).rstrip(indent)
-
-def gen_Val_ocaml(ty, indent=""):
- s = "/* Convert %s to a caml value */\n" % ty.rawname
-
- s += "static value Val_%s (%s)\n" % (ty.rawname, ty.make_arg(ty.rawname+"_c"))
- s += "{\n"
- s += "\tCAMLparam0();\n"
- s += "\tCAMLlocal1(%s_ocaml);\n" % ty.rawname
-
- s += ocaml_Val(ty, "%s_ocaml" % ty.rawname, "%s_c" % ty.rawname, indent="\t") + "\n"
-
- s += "\tCAMLreturn(%s_ocaml);\n" % ty.rawname
- s += "}\n"
- return s.replace("\n", "\n%s" % indent)
-
-def gen_c_stub_prototype(ty, fns):
- s = "/* Stubs for %s */\n" % ty.rawname
- for name,args in fns:
- # For N args we return one value and take N-1 values as parameters
- s += "value %s(" % stub_fn_name(ty, name)
- s += ", ".join(["value v%d" % v for v in range(1,len(args))])
- s += ");\n"
- return s
-
-def gen_c_default(ty):
- s = "/* Get the defaults for %s */\n" % ty.rawname
- # Handle KeyedUnions...
- union_types = []
- for f in ty.fields:
- if isinstance(f.type, idl.KeyedUnion):
- union_types.append(f.type.keyvar)
-
- s += "value stub_libxl_%s_init(value ctx, %svalue unit)\n" % (ty.rawname,
- "".join(["value " + u.name + ", " for u in union_types]))
- s += "{\n"
- s += "\tCAMLparam%d(ctx, %sunit);\n" % (len(union_types) + 2, "".join([u.name + ", " for u in union_types]))
- s += "\tCAMLlocal1(val);\n"
- s += "\tlibxl_%s c_val;\n" % ty.rawname
- s += "\tlibxl_%s_init(&c_val);\n" % ty.rawname
- for u in union_types:
- s += "\tif (%s != Val_none) {\n" % u.name
- s += "\t\t%s c = 0;\n" % u.type.typename
- s += "\t\t%s_val(CTX, &c, Some_val(%s));\n" % (u.type.rawname, u.name)
- s += "\t\tlibxl_%s_init_%s(&c_val, c);\n" % (ty.rawname, u.name)
- s += "\t}\n"
- s += "\tval = Val_%s(&c_val);\n" % ty.rawname
- if ty.dispose_fn:
- s += "\tlibxl_%s_dispose(&c_val);\n" % ty.rawname
- s += "\tCAMLreturn(val);\n"
- s += "}\n"
- return s
-
-def gen_c_defaults(ty):
- s = gen_c_default(ty)
- return s
-
-def autogen_header(open_comment, close_comment):
- s = open_comment + " AUTO-GENERATED FILE DO NOT EDIT " + close_comment + "\n"
- s += open_comment + " autogenerated by \n"
- s += reduce(lambda x,y: x + " ", range(len(open_comment + " ")), "")
- s += "%s" % " ".join(sys.argv)
- s += "\n " + close_comment + "\n\n"
- return s
-
-if __name__ == '__main__':
- if len(sys.argv) < 4:
- print("Usage: genwrap.py <idl> <mli> <ml> <c-inc>", file=sys.stderr)
- sys.exit(1)
-
- (_,types) = idl.parse(sys.argv[1])
-
- # Do not generate these yet.
- blacklist = [
- "cpupoolinfo",
- "vcpuinfo",
- ]
-
- for t in blacklist:
- if t not in [ty.rawname for ty in types]:
- print("unknown type %s in blacklist" % t)
-
- types = [ty for ty in types if not ty.rawname in blacklist]
-
- _ml = sys.argv[3]
- ml = open(_ml, 'w')
- ml.write(autogen_header("(*", "*)"))
-
- _mli = sys.argv[2]
- mli = open(_mli, 'w')
- mli.write(autogen_header("(*", "*)"))
-
- _cinc = sys.argv[4]
- cinc = open(_cinc, 'w')
- cinc.write(autogen_header("/*", "*/"))
-
- for ty in types:
- if ty.private:
- continue
- #sys.stdout.write(" TYPE %-20s " % ty.rawname)
- ml.write(gen_ocaml_ml(ty, False))
- ml.write("\n")
-
- mli.write(gen_ocaml_ml(ty, True))
- mli.write("\n")
-
- if ty.marshal_in():
- cinc.write(gen_c_val(ty))
- cinc.write("\n")
- cinc.write(gen_Val_ocaml(ty))
- cinc.write("\n")
- if ty.rawname in functions:
- cinc.write(gen_c_stub_prototype(ty, functions[ty.rawname]))
- cinc.write("\n")
- if ty.init_fn is not None:
- cinc.write(gen_c_defaults(ty))
- cinc.write("\n")
- #sys.stdout.write("\n")
-
- ml.write("(* END OF AUTO-GENERATED CODE *)\n")
- ml.close()
- mli.write("(* END OF AUTO-GENERATED CODE *)\n")
- mli.close()
- cinc.close()
deleted file mode 100644
@@ -1,94 +0,0 @@
-(*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-type ctx
-type domid = int
-type devid = int
-
-(* @@LIBXL_TYPES@@ *)
-
-exception Error of (error * string)
-
-external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
-
-external test_raise_exception: unit -> unit = "stub_raise_exception"
-
-type event =
- | POLLIN (* There is data to read *)
- | POLLPRI (* There is urgent data to read *)
- | POLLOUT (* Writing now will not block *)
- | POLLERR (* Error condition (revents only) *)
- | POLLHUP (* Device has been disconnected (revents only) *)
- | POLLNVAL (* Invalid request: fd not open (revents only). *)
-
-module Domain = struct
- external create_new : ctx -> Domain_config.t -> ?async:'a -> unit -> domid = "stub_libxl_domain_create_new"
- external create_restore : ctx -> Domain_config.t -> (Unix.file_descr * Domain_restore_params.t) ->
- ?async:'a -> unit -> domid = "stub_libxl_domain_create_restore"
- external shutdown : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_shutdown"
- external reboot : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_reboot"
- external destroy : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_destroy"
- external suspend : ctx -> domid -> Unix.file_descr -> ?async:'a -> unit -> unit = "stub_libxl_domain_suspend"
- external pause : ctx -> domid -> ?async:'a -> unit = "stub_libxl_domain_pause"
- external unpause : ctx -> domid -> ?async:'a -> unit = "stub_libxl_domain_unpause"
-
- external send_trigger : ctx -> domid -> trigger -> int -> ?async:'a -> unit = "stub_xl_send_trigger"
- external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
-end
-
-module Host = struct
- type console_reader
- exception End_of_file
-
- external xen_console_read_start : ctx -> int -> console_reader = "stub_libxl_xen_console_read_start"
- external xen_console_read_line : ctx -> console_reader -> string = "stub_libxl_xen_console_read_line"
- external xen_console_read_finish : ctx -> console_reader -> unit = "stub_libxl_xen_console_read_finish"
-
- external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
-end
-
-module Async = struct
- type for_libxl
- type event_hooks
- type osevent_hooks
-
- external osevent_register_hooks' : ctx -> 'a -> osevent_hooks = "stub_libxl_osevent_register_hooks"
- external osevent_occurred_fd : ctx -> for_libxl -> Unix.file_descr -> event list -> event list -> unit = "stub_libxl_osevent_occurred_fd"
- external osevent_occurred_timeout : ctx -> for_libxl -> unit = "stub_libxl_osevent_occurred_timeout"
-
- let osevent_register_hooks ctx ~user ~fd_register ~fd_modify ~fd_deregister ~timeout_register ~timeout_fire_now =
- Callback.register "libxl_fd_register" fd_register;
- Callback.register "libxl_fd_modify" fd_modify;
- Callback.register "libxl_fd_deregister" fd_deregister;
- Callback.register "libxl_timeout_register" timeout_register;
- Callback.register "libxl_timeout_fire_now" timeout_fire_now;
- osevent_register_hooks' ctx user
-
- let async_register_callback ~async_callback =
- Callback.register "libxl_async_callback" async_callback
-
- external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death"
- external event_register_callbacks' : ctx -> 'a -> event_hooks = "stub_libxl_event_register_callbacks"
-
- let event_register_callbacks ctx ~user ~event_occurs_callback ~event_disaster_callback =
- Callback.register "libxl_event_occurs_callback" event_occurs_callback;
- Callback.register "libxl_event_disaster_callback" event_disaster_callback;
- event_register_callbacks' ctx user
-end
-
-let register_exceptions () =
- Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""));
- Callback.register_exception "Xenlight.Host.End_of_file" (Host.End_of_file)
-
deleted file mode 100644
@@ -1,93 +0,0 @@
-(*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-type ctx
-type domid = int
-type devid = int
-
-(* @@LIBXL_TYPES@@ *)
-
-exception Error of (error * string)
-
-val register_exceptions: unit -> unit
-
-external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
-
-external test_raise_exception: unit -> unit = "stub_raise_exception"
-
-type event =
- | POLLIN (* There is data to read *)
- | POLLPRI (* There is urgent data to read *)
- | POLLOUT (* Writing now will not block *)
- | POLLERR (* Error condition (revents only) *)
- | POLLHUP (* Device has been disconnected (revents only) *)
- | POLLNVAL (* Invalid request: fd not open (revents only). *)
-
-module Domain : sig
- external create_new : ctx -> Domain_config.t -> ?async:'a -> unit -> domid = "stub_libxl_domain_create_new"
- external create_restore : ctx -> Domain_config.t -> (Unix.file_descr * Domain_restore_params.t) ->
- ?async:'a -> unit -> domid = "stub_libxl_domain_create_restore"
- external shutdown : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_shutdown"
- external reboot : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_reboot"
- external destroy : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_destroy"
- external suspend : ctx -> domid -> Unix.file_descr -> ?async:'a -> unit -> unit = "stub_libxl_domain_suspend"
- external pause : ctx -> domid -> ?async:'a -> unit = "stub_libxl_domain_pause"
- external unpause : ctx -> domid -> ?async:'a -> unit = "stub_libxl_domain_unpause"
-
- external send_trigger : ctx -> domid -> trigger -> int -> ?async:'a -> unit = "stub_xl_send_trigger"
- external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
-end
-
-module Host : sig
- type console_reader
- exception End_of_file
-
- external xen_console_read_start : ctx -> int -> console_reader = "stub_libxl_xen_console_read_start"
- external xen_console_read_line : ctx -> console_reader -> string = "stub_libxl_xen_console_read_line"
- external xen_console_read_finish : ctx -> console_reader -> unit = "stub_libxl_xen_console_read_finish"
-
- external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
-end
-
-module Async : sig
- type for_libxl
- type event_hooks
- type osevent_hooks
-
- val osevent_register_hooks : ctx ->
- user:'a ->
- fd_register:('a -> Unix.file_descr -> event list -> for_libxl -> 'b) ->
- fd_modify:('a -> Unix.file_descr -> 'b -> event list -> 'b) ->
- fd_deregister:('a -> Unix.file_descr -> 'b -> unit) ->
- timeout_register:('a -> int64 -> int64 -> for_libxl -> 'c) ->
- timeout_fire_now:('a -> 'c -> 'c) ->
- osevent_hooks
-
- external osevent_occurred_fd : ctx -> for_libxl -> Unix.file_descr -> event list -> event list -> unit = "stub_libxl_osevent_occurred_fd"
- external osevent_occurred_timeout : ctx -> for_libxl -> unit = "stub_libxl_osevent_occurred_timeout"
-
- val async_register_callback :
- async_callback:(result:error option -> user:'a -> unit) ->
- unit
-
- external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death"
-
- val event_register_callbacks : ctx ->
- user:'a ->
- event_occurs_callback:('a -> Event.t -> unit) ->
- event_disaster_callback:('a -> event_type -> string -> int -> unit) ->
- event_hooks
-end
-
deleted file mode 100644
@@ -1,1663 +0,0 @@
-/*
- * Copyright (C) 2009-2011 Citrix Ltd.
- * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
-
-#include <stdlib.h>
-
-#define CAML_NAME_SPACE
-#include <caml/alloc.h>
-#include <caml/memory.h>
-#include <caml/signals.h>
-#include <caml/fail.h>
-#include <caml/callback.h>
-#include <caml/custom.h>
-
-#include <sys/mman.h>
-#include <stdint.h>
-#include <string.h>
-
-#include <libxl.h>
-#include <libxl_utils.h>
-
-#include <unistd.h>
-#include <assert.h>
-
-#include "caml_xentoollog.h"
-
-/*
- * Starting with ocaml-3.09.3, CAMLreturn can only be used for ``value''
- * types. CAMLreturnT was only added in 3.09.4, so we define our own
- * version here if needed.
- */
-#ifndef CAMLreturnT
-#define CAMLreturnT(type, result) do { \
- type caml__temp_result = (result); \
- caml_local_roots = caml__frame; \
- return (caml__temp_result); \
-} while (0)
-#endif
-
-/* The following is equal to the CAMLreturn macro, but without the return */
-#define CAMLdone do{ \
-caml_local_roots = caml__frame; \
-}while (0)
-
-#define Ctx_val(x)(*((libxl_ctx **) Data_custom_val(x)))
-#define CTX ((libxl_ctx *) Ctx_val(ctx))
-
-static char * dup_String_val(value s)
-{
- int len;
- char *c;
- len = caml_string_length(s);
- c = calloc(len + 1, sizeof(char));
- if (!c)
- caml_raise_out_of_memory();
- memcpy(c, String_val(s), len);
- return c;
-}
-
-/* Forward reference: this is defined in the auto-generated include file below. */
-static value Val_error (libxl_error error_c);
-
-static void failwith_xl(int error, char *fname)
-{
- CAMLparam0();
- CAMLlocal1(arg);
- static const value *exc = NULL;
-
- /* First time around, lookup by name */
- if (!exc)
- exc = caml_named_value("Xenlight.Error");
-
- if (!exc)
- caml_invalid_argument("Exception Xenlight.Error not initialized, please link xenlight.cma");
-
- arg = caml_alloc(2, 0);
-
- Store_field(arg, 0, Val_error(error));
- Store_field(arg, 1, caml_copy_string(fname));
-
- caml_raise_with_arg(*exc, arg);
- CAMLreturn0;
-}
-
-CAMLprim value stub_raise_exception(value unit)
-{
- CAMLparam1(unit);
- failwith_xl(ERROR_FAIL, "test exception");
- CAMLreturn(Val_unit);
-}
-
-void ctx_finalize(value ctx)
-{
- libxl_ctx_free(CTX);
-}
-
-static struct custom_operations libxl_ctx_custom_operations = {
- "libxl_ctx_custom_operations",
- ctx_finalize /* custom_finalize_default */,
- custom_compare_default,
- custom_hash_default,
- custom_serialize_default,
- custom_deserialize_default
-};
-
-CAMLprim value stub_libxl_ctx_alloc(value logger)
-{
- CAMLparam1(logger);
- CAMLlocal1(handle);
- libxl_ctx *ctx;
- int ret;
-
- ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (xentoollog_logger *) Xtl_val(logger));
- if (ret != 0) \
- failwith_xl(ERROR_FAIL, "cannot init context");
-
- handle = caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0, 1);
- Ctx_val(handle) = ctx;
-
- CAMLreturn(handle);
-}
-
-static int list_len(value v)
-{
- int len = 0;
- while ( v != Val_emptylist ) {
- len++;
- v = Field(v, 1);
- }
- return len;
-}
-
-static int libxl_key_value_list_val(libxl_key_value_list *c_val,
- value v)
-{
- CAMLparam1(v);
- CAMLlocal1(elem);
- int nr, i;
- libxl_key_value_list array;
-
- nr = list_len(v);
-
- array = calloc((nr + 1) * 2, sizeof(char *));
- if (!array)
- caml_raise_out_of_memory();
-
- for (i=0; v != Val_emptylist; i++, v = Field(v, 1) ) {
- elem = Field(v, 0);
-
- array[i * 2] = dup_String_val(Field(elem, 0));
- array[i * 2 + 1] = dup_String_val(Field(elem, 1));
- }
-
- *c_val = array;
- CAMLreturn(0);
-}
-
-static value Val_key_value_list(libxl_key_value_list *c_val)
-{
- CAMLparam0();
- CAMLlocal5(list, cons, key, val, kv);
- int i;
-
- list = Val_emptylist;
- for (i = libxl_string_list_length((libxl_string_list *) c_val) - 1; i >= 0; i -= 2) {
- val = caml_copy_string((*c_val)[i]);
- key = caml_copy_string((*c_val)[i - 1]);
- kv = caml_alloc_tuple(2);
- Store_field(kv, 0, key);
- Store_field(kv, 1, val);
-
- cons = caml_alloc(2, 0);
- Store_field(cons, 0, kv); // head
- Store_field(cons, 1, list); // tail
- list = cons;
- }
-
- CAMLreturn(list);
-}
-
-static int libxl_string_list_val(libxl_string_list *c_val, value v)
-{
- CAMLparam1(v);
- int nr, i;
- libxl_string_list array;
-
- nr = list_len(v);
-
- array = calloc(nr + 1, sizeof(char *));
- if (!array)
- caml_raise_out_of_memory();
-
- for (i=0; v != Val_emptylist; i++, v = Field(v, 1) )
- array[i] = dup_String_val(Field(v, 0));
-
- *c_val = array;
- CAMLreturn(0);
-}
-
-static value Val_string_list(libxl_string_list *c_val)
-{
- CAMLparam0();
- CAMLlocal3(list, cons, string);
- int i;
-
- list = Val_emptylist;
- for (i = libxl_string_list_length(c_val) - 1; i >= 0; i--) {
- string = caml_copy_string((*c_val)[i]);
- cons = caml_alloc(2, 0);
- Store_field(cons, 0, string); // head
- Store_field(cons, 1, list); // tail
- list = cons;
- }
-
- CAMLreturn(list);
-}
-
-/* Option type support as per http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php */
-#ifndef Val_none
-#define Val_none Val_int(0)
-#endif
-#ifndef Some_val
-#define Some_val(v) Field(v,0)
-#endif
-
-static value Val_some(value v)
-{
- CAMLparam1(v);
- CAMLlocal1(some);
- some = caml_alloc(1, 0);
- Store_field(some, 0, v);
- CAMLreturn(some);
-}
-
-static value Val_mac (libxl_mac *c_val)
-{
- CAMLparam0();
- CAMLlocal1(v);
- int i;
-
- v = caml_alloc_tuple(6);
-
- for(i=0; i<6; i++)
- Store_field(v, i, Val_int((*c_val)[i]));
-
- CAMLreturn(v);
-}
-
-static int Mac_val(libxl_mac *c_val, value v)
-{
- CAMLparam1(v);
- int i;
-
- for(i=0; i<6; i++)
- (*c_val)[i] = Int_val(Field(v, i));
-
- CAMLreturn(0);
-}
-
-static value Val_bitmap (libxl_bitmap *c_val)
-{
- CAMLparam0();
- CAMLlocal1(v);
- int i;
-
- if (c_val->size == 0)
- v = Atom(0);
- else {
- v = caml_alloc(8 * (c_val->size), 0);
- libxl_for_each_bit(i, *c_val) {
- if (libxl_bitmap_test(c_val, i))
- Store_field(v, i, Val_true);
- else
- Store_field(v, i, Val_false);
- }
- }
- CAMLreturn(v);
-}
-
-static int Bitmap_val(libxl_ctx *ctx, libxl_bitmap *c_val, value v)
-{
- CAMLparam1(v);
- int i, len = Wosize_val(v);
-
- c_val->size = 0;
- if (len > 0 && libxl_bitmap_alloc(ctx, c_val, len))
- failwith_xl(ERROR_NOMEM, "cannot allocate bitmap");
- for (i=0; i<len; i++) {
- if (Int_val(Field(v, i)))
- libxl_bitmap_set(c_val, i);
- else
- libxl_bitmap_reset(c_val, i);
- }
- CAMLreturn(0);
-}
-
-static value Val_uuid (libxl_uuid *c_val)
-{
- CAMLparam0();
- CAMLlocal1(v);
- uint8_t *uuid = libxl_uuid_bytearray(c_val);
- int i;
-
- v = caml_alloc_tuple(16);
-
- for(i=0; i<16; i++)
- Store_field(v, i, Val_int(uuid[i]));
-
- CAMLreturn(v);
-}
-
-static int Uuid_val(libxl_uuid *c_val, value v)
-{
- CAMLparam1(v);
- int i;
- uint8_t *uuid = libxl_uuid_bytearray(c_val);
-
- for(i=0; i<16; i++)
- uuid[i] = Int_val(Field(v, i));
-
- CAMLreturn(0);
-}
-
-static value Val_defbool(libxl_defbool c_val)
-{
- CAMLparam0();
- CAMLlocal2(v1, v2);
- bool b;
-
- if (libxl_defbool_is_default(c_val))
- v2 = Val_none;
- else {
- b = libxl_defbool_val(c_val);
- v1 = b ? Val_bool(true) : Val_bool(false);
- v2 = Val_some(v1);
- }
- CAMLreturn(v2);
-}
-
-static libxl_defbool Defbool_val(value v)
-{
- CAMLparam1(v);
- libxl_defbool db;
- if (v == Val_none)
- libxl_defbool_unset(&db);
- else {
- bool b = Bool_val(Some_val(v));
- libxl_defbool_set(&db, b);
- }
- CAMLreturnT(libxl_defbool, db);
-}
-
-static value Val_hwcap(libxl_hwcap *c_val)
-{
- CAMLparam0();
- CAMLlocal1(hwcap);
- int i;
-
- hwcap = caml_alloc_tuple(8);
- for (i = 0; i < 8; i++)
- Store_field(hwcap, i, caml_copy_int32((*c_val)[i]));
-
- CAMLreturn(hwcap);
-}
-
-static value Val_ms_vm_genid (libxl_ms_vm_genid *c_val)
-{
- CAMLparam0();
- CAMLlocal1(v);
- int i;
-
- v = caml_alloc_tuple(LIBXL_MS_VM_GENID_LEN);
-
- for(i=0; i<LIBXL_MS_VM_GENID_LEN; i++)
- Store_field(v, i, Val_int(c_val->bytes[i]));
-
- CAMLreturn(v);
-}
-
-static int Ms_vm_genid_val(libxl_ms_vm_genid *c_val, value v)
-{
- CAMLparam1(v);
- int i;
-
- for(i=0; i<LIBXL_MS_VM_GENID_LEN; i++)
- c_val->bytes[i] = Int_val(Field(v, i));
-
- CAMLreturn(0);
-}
-
-static value Val_string_option(const char *c_val)
-{
- CAMLparam0();
- CAMLlocal2(tmp1, tmp2);
- if (c_val) {
- tmp1 = caml_copy_string(c_val);
- tmp2 = Val_some(tmp1);
- CAMLreturn(tmp2);
- }
- else
- CAMLreturn(Val_none);
-}
-
-static char *String_option_val(value v)
-{
- CAMLparam1(v);
- char *s = NULL;
- if (v != Val_none)
- s = dup_String_val(Some_val(v));
- CAMLreturnT(char *, s);
-}
-
-#include "_libxl_types.inc"
-
-void async_callback(libxl_ctx *ctx, int rc, void *for_callback)
-{
- caml_leave_blocking_section();
- CAMLparam0();
- CAMLlocal2(error, tmp);
- static const value *func = NULL;
- value *p = (value *) for_callback;
-
- if (func == NULL) {
- /* First time around, lookup by name */
- func = caml_named_value("libxl_async_callback");
- }
-
- if (rc == 0)
- error = Val_none;
- else {
- tmp = Val_error(rc);
- error = Val_some(tmp);
- }
-
- /* for_callback is a pointer to a "value" that was malloc'ed and
- * registered with the OCaml GC. The value is handed back to OCaml
- * in the following callback, after which the pointer is unregistered
- * and freed. */
- caml_callback2(*func, error, *p);
-
- caml_remove_global_root(p);
- free(p);
-
- CAMLdone;
- caml_enter_blocking_section();
-}
-
-static libxl_asyncop_how *aohow_val(value async)
-{
- CAMLparam1(async);
- libxl_asyncop_how *ao_how = NULL;
- value *p;
-
- if (async != Val_none) {
- /* for_callback must be a pointer to a "value" that is malloc'ed and
- * registered with the OCaml GC. This ensures that the GC does not remove
- * the corresponding OCaml heap blocks, and allows the GC to update the value
- * when blocks are moved around, while libxl is free to copy the pointer if
- * it needs to.
- * The for_callback pointer must always be non-NULL. */
- p = malloc(sizeof(value));
- if (!p)
- failwith_xl(ERROR_NOMEM, "cannot allocate value");
- *p = Some_val(async);
- caml_register_global_root(p);
- ao_how = malloc(sizeof(*ao_how));
- ao_how->callback = async_callback;
- ao_how->u.for_callback = (void *) p;
- }
-
- CAMLreturnT(libxl_asyncop_how *, ao_how);
-}
-
-value stub_libxl_domain_create_new(value ctx, value domain_config, value async, value unit)
-{
- CAMLparam4(ctx, async, domain_config, unit);
- int ret;
- libxl_domain_config c_dconfig;
- uint32_t c_domid;
- libxl_asyncop_how *ao_how;
-
- libxl_domain_config_init(&c_dconfig);
- ret = domain_config_val(CTX, &c_dconfig, domain_config);
- if (ret != 0) {
- libxl_domain_config_dispose(&c_dconfig);
- failwith_xl(ret, "domain_create_new");
- }
-
- ao_how = aohow_val(async);
-
- caml_enter_blocking_section();
- ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid, ao_how, NULL);
- caml_leave_blocking_section();
-
- free(ao_how);
- libxl_domain_config_dispose(&c_dconfig);
-
- if (ret != 0)
- failwith_xl(ret, "domain_create_new");
-
- CAMLreturn(Val_int(c_domid));
-}
-
-value stub_libxl_domain_create_restore(value ctx, value domain_config, value params,
- value async, value unit)
-{
- CAMLparam5(ctx, domain_config, params, async, unit);
- int ret;
- libxl_domain_config c_dconfig;
- libxl_domain_restore_params c_params;
- uint32_t c_domid;
- libxl_asyncop_how *ao_how;
- int restore_fd;
-
- libxl_domain_config_init(&c_dconfig);
- ret = domain_config_val(CTX, &c_dconfig, domain_config);
- if (ret != 0) {
- libxl_domain_config_dispose(&c_dconfig);
- failwith_xl(ret, "domain_create_restore");
- }
-
- libxl_domain_restore_params_init(&c_params);
- ret = domain_restore_params_val(CTX, &c_params, Field(params, 1));
- if (ret != 0) {
- libxl_domain_restore_params_dispose(&c_params);
- failwith_xl(ret, "domain_create_restore");
- }
-
- ao_how = aohow_val(async);
- restore_fd = Int_val(Field(params, 0));
-
- caml_enter_blocking_section();
- ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, restore_fd,
- -1, &c_params, ao_how, NULL);
- caml_leave_blocking_section();
-
- free(ao_how);
- libxl_domain_config_dispose(&c_dconfig);
- libxl_domain_restore_params_dispose(&c_params);
-
- if (ret != 0)
- failwith_xl(ret, "domain_create_restore");
-
- CAMLreturn(Val_int(c_domid));
-}
-
-value stub_libxl_domain_shutdown(value ctx, value domid, value async, value unit)
-{
- CAMLparam4(ctx, domid, async, unit);
- int ret;
- uint32_t c_domid = Int_val(domid);
- libxl_asyncop_how *ao_how = aohow_val(async);
-
- caml_enter_blocking_section();
- ret = libxl_domain_shutdown(CTX, c_domid, ao_how);
- caml_leave_blocking_section();
-
- free(ao_how);
-
- if (ret != 0)
- failwith_xl(ret, "domain_shutdown");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_libxl_domain_reboot(value ctx, value domid, value async, value unit)
-{
- CAMLparam4(ctx, domid, async, unit);
- int ret;
- uint32_t c_domid = Int_val(domid);
- libxl_asyncop_how *ao_how = aohow_val(async);
-
- caml_enter_blocking_section();
- ret = libxl_domain_reboot(CTX, c_domid, ao_how);
- caml_leave_blocking_section();
-
- free(ao_how);
-
- if (ret != 0)
- failwith_xl(ret, "domain_reboot");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_libxl_domain_destroy(value ctx, value domid, value async, value unit)
-{
- CAMLparam4(ctx, domid, async, unit);
- int ret;
- uint32_t c_domid = Int_val(domid);
- libxl_asyncop_how *ao_how = aohow_val(async);
-
- caml_enter_blocking_section();
- ret = libxl_domain_destroy(CTX, c_domid, ao_how);
- caml_leave_blocking_section();
-
- free(ao_how);
-
- if (ret != 0)
- failwith_xl(ret, "domain_destroy");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_libxl_domain_suspend(value ctx, value domid, value fd, value async, value unit)
-{
- CAMLparam5(ctx, domid, fd, async, unit);
- int ret;
- uint32_t c_domid = Int_val(domid);
- int c_fd = Int_val(fd);
- libxl_asyncop_how *ao_how = aohow_val(async);
-
- caml_enter_blocking_section();
- ret = libxl_domain_suspend(CTX, c_domid, c_fd, 0, ao_how);
- caml_leave_blocking_section();
-
- free(ao_how);
-
- if (ret != 0)
- failwith_xl(ret, "domain_suspend");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_libxl_domain_pause(value ctx, value domid, value async)
-{
- CAMLparam3(ctx, domid, async);
- int ret;
- uint32_t c_domid = Int_val(domid);
- libxl_asyncop_how *ao_how = aohow_val(async);
-
- caml_enter_blocking_section();
- ret = libxl_domain_pause(CTX, c_domid, ao_how);
- caml_leave_blocking_section();
-
- free(ao_how);
-
- if (ret != 0)
- failwith_xl(ret, "domain_pause");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_libxl_domain_unpause(value ctx, value domid, value async)
-{
- CAMLparam3(ctx, domid, async);
- int ret;
- uint32_t c_domid = Int_val(domid);
- libxl_asyncop_how *ao_how = aohow_val(async);
-
- caml_enter_blocking_section();
- ret = libxl_domain_unpause(CTX, c_domid, ao_how);
- caml_leave_blocking_section();
-
- free(ao_how);
-
- if (ret != 0)
- failwith_xl(ret, "domain_unpause");
-
- CAMLreturn(Val_unit);
-}
-
-#define _STRINGIFY(x) #x
-#define STRINGIFY(x) _STRINGIFY(x)
-
-#define _DEVICE_ADDREMOVE(type,fn,op) \
-value stub_xl_device_##type##_##op(value ctx, value info, value domid, \
- value async, value unit) \
-{ \
- CAMLparam5(ctx, info, domid, async, unit); \
- libxl_device_##type c_info; \
- int ret, marker_var; \
- uint32_t c_domid = Int_val(domid); \
- libxl_asyncop_how *ao_how = aohow_val(async); \
- \
- device_##type##_val(CTX, &c_info, info); \
- \
- caml_enter_blocking_section(); \
- ret = libxl_##fn##_##op(CTX, c_domid, &c_info, ao_how); \
- caml_leave_blocking_section(); \
- \
- free(ao_how); \
- libxl_device_##type##_dispose(&c_info); \
- \
- if (ret != 0) \
- failwith_xl(ret, STRINGIFY(type) "_" STRINGIFY(op)); \
- \
- CAMLreturn(Val_unit); \
-}
-
-#define DEVICE_ADDREMOVE(type) \
- _DEVICE_ADDREMOVE(type, device_##type, add) \
- _DEVICE_ADDREMOVE(type, device_##type, remove) \
- _DEVICE_ADDREMOVE(type, device_##type, destroy)
-
-DEVICE_ADDREMOVE(disk)
-DEVICE_ADDREMOVE(nic)
-DEVICE_ADDREMOVE(vfb)
-DEVICE_ADDREMOVE(vkb)
-DEVICE_ADDREMOVE(pci)
-_DEVICE_ADDREMOVE(disk, cdrom, insert)
-
-value stub_xl_device_nic_of_devid(value ctx, value domid, value devid)
-{
- CAMLparam3(ctx, domid, devid);
- CAMLlocal1(nic);
- libxl_device_nic c_nic;
- uint32_t c_domid = Int_val(domid);
- int c_devid = Int_val(devid);
-
- caml_enter_blocking_section();
- libxl_devid_to_device_nic(CTX, c_domid, c_devid, &c_nic);
- caml_leave_blocking_section();
-
- nic = Val_device_nic(&c_nic);
- libxl_device_nic_dispose(&c_nic);
-
- CAMLreturn(nic);
-}
-
-value stub_xl_device_nic_list(value ctx, value domid)
-{
- CAMLparam2(ctx, domid);
- CAMLlocal2(list, temp);
- libxl_device_nic *c_list;
- int i, nb;
- uint32_t c_domid = Int_val(domid);
-
- caml_enter_blocking_section();
- c_list = libxl_device_nic_list(CTX, c_domid, &nb);
- caml_leave_blocking_section();
-
- if (!c_list)
- failwith_xl(ERROR_FAIL, "nic_list");
-
- list = temp = Val_emptylist;
- for (i = 0; i < nb; i++) {
- list = caml_alloc_small(2, Tag_cons);
- Field(list, 0) = Val_int(0);
- Field(list, 1) = temp;
- temp = list;
- Store_field(list, 0, Val_device_nic(&c_list[i]));
- }
- libxl_device_nic_list_free(c_list, nb);
-
- CAMLreturn(list);
-}
-
-value stub_xl_device_disk_list(value ctx, value domid)
-{
- CAMLparam2(ctx, domid);
- CAMLlocal2(list, temp);
- libxl_device_disk *c_list;
- int i, nb;
- uint32_t c_domid = Int_val(domid);
-
- caml_enter_blocking_section();
- c_list = libxl_device_disk_list(CTX, c_domid, &nb);
- caml_leave_blocking_section();
-
- if (!c_list)
- failwith_xl(ERROR_FAIL, "disk_list");
-
- list = temp = Val_emptylist;
- for (i = 0; i < nb; i++) {
- list = caml_alloc_small(2, Tag_cons);
- Field(list, 0) = Val_int(0);
- Field(list, 1) = temp;
- temp = list;
- Store_field(list, 0, Val_device_disk(&c_list[i]));
- }
- libxl_device_disk_list_free(c_list, nb);
-
- CAMLreturn(list);
-}
-
-value stub_xl_device_disk_of_vdev(value ctx, value domid, value vdev)
-{
- CAMLparam3(ctx, domid, vdev);
- CAMLlocal1(disk);
- libxl_device_disk c_disk;
- char *c_vdev;
- uint32_t c_domid = Int_val(domid);
-
- c_vdev = strdup(String_val(vdev));
-
- caml_enter_blocking_section();
- libxl_vdev_to_device_disk(CTX, c_domid, c_vdev, &c_disk);
- caml_leave_blocking_section();
-
- disk = Val_device_disk(&c_disk);
- libxl_device_disk_dispose(&c_disk);
- free(c_vdev);
-
- CAMLreturn(disk);
-}
-
-value stub_xl_device_pci_list(value ctx, value domid)
-{
- CAMLparam2(ctx, domid);
- CAMLlocal2(list, temp);
- libxl_device_pci *c_list;
- int i, nb;
- uint32_t c_domid = Int_val(domid);
-
- caml_enter_blocking_section();
- c_list = libxl_device_pci_list(CTX, c_domid, &nb);
- caml_leave_blocking_section();
-
- if (!c_list)
- failwith_xl(ERROR_FAIL, "pci_list");
-
- list = temp = Val_emptylist;
- for (i = 0; i < nb; i++) {
- list = caml_alloc_small(2, Tag_cons);
- Field(list, 0) = Val_int(0);
- Field(list, 1) = temp;
- temp = list;
- Store_field(list, 0, Val_device_pci(&c_list[i]));
- libxl_device_pci_dispose(&c_list[i]);
- }
- free(c_list);
-
- CAMLreturn(list);
-}
-
-value stub_xl_device_pci_assignable_add(value ctx, value info, value rebind)
-{
- CAMLparam3(ctx, info, rebind);
- libxl_device_pci c_info;
- int ret, marker_var;
- int c_rebind = (int) Bool_val(rebind);
-
- device_pci_val(CTX, &c_info, info);
-
- caml_enter_blocking_section();
- ret = libxl_device_pci_assignable_add(CTX, &c_info, c_rebind);
- caml_leave_blocking_section();
-
- libxl_device_pci_dispose(&c_info);
-
- if (ret != 0)
- failwith_xl(ret, "pci_assignable_add");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_assignable_remove(value ctx, value info, value rebind)
-{
- CAMLparam3(ctx, info, rebind);
- libxl_device_pci c_info;
- int ret, marker_var;
- int c_rebind = (int) Bool_val(rebind);
-
- device_pci_val(CTX, &c_info, info);
-
- caml_enter_blocking_section();
- ret = libxl_device_pci_assignable_remove(CTX, &c_info, c_rebind);
- caml_leave_blocking_section();
-
- libxl_device_pci_dispose(&c_info);
-
- if (ret != 0)
- failwith_xl(ret, "pci_assignable_remove");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_device_pci_assignable_list(value ctx)
-{
- CAMLparam1(ctx);
- CAMLlocal2(list, temp);
- libxl_device_pci *c_list;
- int i, nb;
- uint32_t c_domid;
-
- caml_enter_blocking_section();
- c_list = libxl_device_pci_assignable_list(CTX, &nb);
- caml_leave_blocking_section();
-
- if (!c_list)
- failwith_xl(ERROR_FAIL, "pci_assignable_list");
-
- list = temp = Val_emptylist;
- for (i = 0; i < nb; i++) {
- list = caml_alloc_small(2, Tag_cons);
- Field(list, 0) = Val_int(0);
- Field(list, 1) = temp;
- temp = list;
- Store_field(list, 0, Val_device_pci(&c_list[i]));
- }
- libxl_device_pci_assignable_list_free(c_list, nb);
-
- CAMLreturn(list);
-}
-
-value stub_xl_physinfo_get(value ctx)
-{
- CAMLparam1(ctx);
- CAMLlocal1(physinfo);
- libxl_physinfo c_physinfo;
- int ret;
-
- caml_enter_blocking_section();
- ret = libxl_get_physinfo(CTX, &c_physinfo);
- caml_leave_blocking_section();
-
- if (ret != 0)
- failwith_xl(ret, "get_physinfo");
-
- physinfo = Val_physinfo(&c_physinfo);
-
- libxl_physinfo_dispose(&c_physinfo);
-
- CAMLreturn(physinfo);
-}
-
-value stub_xl_cputopology_get(value ctx)
-{
- CAMLparam1(ctx);
- CAMLlocal3(topology, v, v0);
- libxl_cputopology *c_topology;
- int i, nr;
-
- caml_enter_blocking_section();
- c_topology = libxl_get_cpu_topology(CTX, &nr);
- caml_leave_blocking_section();
-
- if (!c_topology)
- failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo");
-
- topology = caml_alloc_tuple(nr);
- for (i = 0; i < nr; i++) {
- if (c_topology[i].core != LIBXL_CPUTOPOLOGY_INVALID_ENTRY) {
- v0 = Val_cputopology(&c_topology[i]);
- v = Val_some(v0);
- }
- else
- v = Val_none;
- Store_field(topology, i, v);
- }
-
- libxl_cputopology_list_free(c_topology, nr);
-
- CAMLreturn(topology);
-}
-
-value stub_xl_dominfo_list(value ctx)
-{
- CAMLparam1(ctx);
- CAMLlocal2(domlist, temp);
- libxl_dominfo *c_domlist;
- int i, nb;
-
- caml_enter_blocking_section();
- c_domlist = libxl_list_domain(CTX, &nb);
- caml_leave_blocking_section();
-
- if (!c_domlist)
- failwith_xl(ERROR_FAIL, "dominfo_list");
-
- domlist = temp = Val_emptylist;
- for (i = nb - 1; i >= 0; i--) {
- domlist = caml_alloc_small(2, Tag_cons);
- Field(domlist, 0) = Val_int(0);
- Field(domlist, 1) = temp;
- temp = domlist;
-
- Store_field(domlist, 0, Val_dominfo(&c_domlist[i]));
- }
-
- libxl_dominfo_list_free(c_domlist, nb);
-
- CAMLreturn(domlist);
-}
-
-value stub_xl_dominfo_get(value ctx, value domid)
-{
- CAMLparam2(ctx, domid);
- CAMLlocal1(dominfo);
- libxl_dominfo c_dominfo;
- int ret;
- uint32_t c_domid = Int_val(domid);
-
- caml_enter_blocking_section();
- ret = libxl_domain_info(CTX, &c_dominfo, c_domid);
- caml_leave_blocking_section();
-
- if (ret != 0)
- failwith_xl(ERROR_FAIL, "domain_info");
- dominfo = Val_dominfo(&c_dominfo);
-
- CAMLreturn(dominfo);
-}
-
-value stub_xl_domain_sched_params_get(value ctx, value domid)
-{
- CAMLparam2(ctx, domid);
- CAMLlocal1(scinfo);
- libxl_domain_sched_params c_scinfo;
- int ret;
- uint32_t c_domid = Int_val(domid);
-
- caml_enter_blocking_section();
- ret = libxl_domain_sched_params_get(CTX, c_domid, &c_scinfo);
- caml_leave_blocking_section();
-
- if (ret != 0)
- failwith_xl(ret, "domain_sched_params_get");
-
- scinfo = Val_domain_sched_params(&c_scinfo);
-
- libxl_domain_sched_params_dispose(&c_scinfo);
-
- CAMLreturn(scinfo);
-}
-
-value stub_xl_domain_sched_params_set(value ctx, value domid, value scinfo)
-{
- CAMLparam3(ctx, domid, scinfo);
- libxl_domain_sched_params c_scinfo;
- int ret;
- uint32_t c_domid = Int_val(domid);
-
- domain_sched_params_val(CTX, &c_scinfo, scinfo);
-
- caml_enter_blocking_section();
- ret = libxl_domain_sched_params_set(CTX, c_domid, &c_scinfo);
- caml_leave_blocking_section();
-
- libxl_domain_sched_params_dispose(&c_scinfo);
-
- if (ret != 0)
- failwith_xl(ret, "domain_sched_params_set");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_trigger(value ctx, value domid, value trigger, value vcpuid, value async)
-{
- CAMLparam5(ctx, domid, trigger, vcpuid, async);
- int ret;
- uint32_t c_domid = Int_val(domid);
- libxl_trigger c_trigger = LIBXL_TRIGGER_UNKNOWN;
- int c_vcpuid = Int_val(vcpuid);
- libxl_asyncop_how *ao_how = aohow_val(async);
-
- trigger_val(CTX, &c_trigger, trigger);
-
- caml_enter_blocking_section();
- ret = libxl_send_trigger(CTX, c_domid, c_trigger, c_vcpuid, ao_how);
- caml_leave_blocking_section();
-
- free(ao_how);
-
- if (ret != 0)
- failwith_xl(ret, "send_trigger");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_sysrq(value ctx, value domid, value sysrq)
-{
- CAMLparam3(ctx, domid, sysrq);
- int ret;
- uint32_t c_domid = Int_val(domid);
- int c_sysrq = Int_val(sysrq);
-
- caml_enter_blocking_section();
- ret = libxl_send_sysrq(CTX, c_domid, c_sysrq);
- caml_leave_blocking_section();
-
- if (ret != 0)
- failwith_xl(ret, "send_sysrq");
-
- CAMLreturn(Val_unit);
-}
-
-value stub_xl_send_debug_keys(value ctx, value keys)
-{
- CAMLparam2(ctx, keys);
- int ret;
- char *c_keys;
-
- c_keys = dup_String_val(keys);
-
- caml_enter_blocking_section();
- ret = libxl_send_debug_keys(CTX, c_keys);
- caml_leave_blocking_section();
-
- free(c_keys);
-
- if (ret != 0)
- failwith_xl(ret, "send_debug_keys");
-
- CAMLreturn(Val_unit);
-}
-
-static struct custom_operations libxl_console_reader_custom_operations = {
- "libxl_console_reader_custom_operations",
- custom_finalize_default,
- custom_compare_default,
- custom_hash_default,
- custom_serialize_default,
- custom_deserialize_default
-};
-
-#define Console_reader_val(x)(*((libxl_xen_console_reader **) Data_custom_val(x)))
-
-value stub_libxl_xen_console_read_start(value ctx, value clear)
-{
- CAMLparam2(ctx, clear);
- CAMLlocal1(handle);
- int c_clear = Int_val(clear);
- libxl_xen_console_reader *cr;
-
- caml_enter_blocking_section();
- cr = libxl_xen_console_read_start(CTX, c_clear);
- caml_leave_blocking_section();
-
- handle = caml_alloc_custom(&libxl_console_reader_custom_operations, sizeof(cr), 0, 1);
- Console_reader_val(handle) = cr;
-
- CAMLreturn(handle);
-}
-
-static void raise_eof(void)
-{
- static const value *exc = NULL;
-
- /* First time around, lookup by name */
- if (!exc)
- exc = caml_named_value("Xenlight.Host.End_of_file");
-
- if (!exc)
- caml_invalid_argument("Exception Xenlight.Host.End_of_file not initialized, please link xenlight.cma");
-
- caml_raise_constant(*exc);
-}
-
-value stub_libxl_xen_console_read_line(value ctx, value reader)
-{
- CAMLparam2(ctx, reader);
- CAMLlocal1(line);
- int ret;
- char *c_line;
- libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader);
-
- caml_enter_blocking_section();
- ret = libxl_xen_console_read_line(CTX, cr, &c_line);
- caml_leave_blocking_section();
-
- if (ret < 0)
- failwith_xl(ret, "xen_console_read_line");
- if (ret == 0)
- raise_eof();
-
- line = caml_copy_string(c_line);
-
- CAMLreturn(line);
-}
-
-value stub_libxl_xen_console_read_finish(value ctx, value reader)
-{
- CAMLparam2(ctx, reader);
- libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader);
-
- caml_enter_blocking_section();
- libxl_xen_console_read_finish(CTX, cr);
- caml_leave_blocking_section();
-
- CAMLreturn(Val_unit);
-}
-
-/* Event handling */
-
-short Poll_val(value event)
-{
- CAMLparam1(event);
- short res = -1;
-
- switch (Int_val(event)) {
- case 0: res = POLLIN; break;
- case 1: res = POLLPRI; break;
- case 2: res = POLLOUT; break;
- case 3: res = POLLERR; break;
- case 4: res = POLLHUP; break;
- case 5: res = POLLNVAL; break;
- }
-
- CAMLreturn(res);
-}
-
-short Poll_events_val(value event_list)
-{
- CAMLparam1(event_list);
- short events = 0;
-
- while (event_list != Val_emptylist) {
- events |= Poll_val(Field(event_list, 0));
- event_list = Field(event_list, 1);
- }
-
- CAMLreturn(events);
-}
-
-value Val_poll(short event)
-{
- CAMLparam0();
- CAMLlocal1(res);
-
- switch (event) {
- case POLLIN: res = Val_int(0); break;
- case POLLPRI: res = Val_int(1); break;
- case POLLOUT: res = Val_int(2); break;
- case POLLERR: res = Val_int(3); break;
- case POLLHUP: res = Val_int(4); break;
- case POLLNVAL: res = Val_int(5); break;
- default: failwith_xl(ERROR_FAIL, "cannot convert poll event value"); break;
- }
-
- CAMLreturn(res);
-}
-
-value add_event(value event_list, short event)
-{
- CAMLparam1(event_list);
- CAMLlocal1(new_list);
-
- new_list = caml_alloc(2, 0);
- Store_field(new_list, 0, Val_poll(event));
- Store_field(new_list, 1, event_list);
-
- CAMLreturn(new_list);
-}
-
-value Val_poll_events(short events)
-{
- CAMLparam0();
- CAMLlocal1(event_list);
-
- event_list = Val_emptylist;
- if (events & POLLIN)
- event_list = add_event(event_list, POLLIN);
- if (events & POLLPRI)
- event_list = add_event(event_list, POLLPRI);
- if (events & POLLOUT)
- event_list = add_event(event_list, POLLOUT);
- if (events & POLLERR)
- event_list = add_event(event_list, POLLERR);
- if (events & POLLHUP)
- event_list = add_event(event_list, POLLHUP);
- if (events & POLLNVAL)
- event_list = add_event(event_list, POLLNVAL);
-
- CAMLreturn(event_list);
-}
-
-/* The process for dealing with the for_app_registration_ values in the
- * callbacks below (GC registrations etc) is similar to the way for_callback is
- * handled in the asynchronous operations above. */
-
-int fd_register(void *user, int fd, void **for_app_registration_out,
- short events, void *for_libxl)
-{
- caml_leave_blocking_section();
- CAMLparam0();
- CAMLlocalN(args, 4);
- int ret = 0;
- static const value *func = NULL;
- value *p = (value *) user;
- value *for_app;
-
- if (func == NULL) {
- /* First time around, lookup by name */
- func = caml_named_value("libxl_fd_register");
- }
-
- args[0] = *p;
- args[1] = Val_int(fd);
- args[2] = Val_poll_events(events);
- args[3] = (value) for_libxl;
-
- for_app = malloc(sizeof(value));
- if (!for_app) {
- ret = ERROR_OSEVENT_REG_FAIL;
- goto err;
- }
-
- *for_app = caml_callbackN_exn(*func, 4, args);
- if (Is_exception_result(*for_app)) {
- ret = ERROR_OSEVENT_REG_FAIL;
- free(for_app);
- goto err;
- }
-
- caml_register_global_root(for_app);
- *for_app_registration_out = for_app;
-
-err:
- CAMLdone;
- caml_enter_blocking_section();
- return ret;
-}
-
-int fd_modify(void *user, int fd, void **for_app_registration_update,
- short events)
-{
- caml_leave_blocking_section();
- CAMLparam0();
- CAMLlocalN(args, 4);
- int ret = 0;
- static const value *func = NULL;
- value *p = (value *) user;
- value *for_app = *for_app_registration_update;
-
- /* If for_app == NULL, then something is very wrong */
- assert(for_app);
-
- if (func == NULL) {
- /* First time around, lookup by name */
- func = caml_named_value("libxl_fd_modify");
- }
-
- args[0] = *p;
- args[1] = Val_int(fd);
- args[2] = *for_app;
- args[3] = Val_poll_events(events);
-
- *for_app = caml_callbackN_exn(*func, 4, args);
- if (Is_exception_result(*for_app)) {
- /* If an exception is caught, *for_app_registration_update is not
- * changed. It remains a valid pointer to a value that is registered
- * with the GC. */
- ret = ERROR_OSEVENT_REG_FAIL;
- goto err;
- }
-
- *for_app_registration_update = for_app;
-
-err:
- CAMLdone;
- caml_enter_blocking_section();
- return ret;
-}
-
-void fd_deregister(void *user, int fd, void *for_app_registration)
-{
- caml_leave_blocking_section();
- CAMLparam0();
- CAMLlocalN(args, 3);
- static const value *func = NULL;
- value *p = (value *) user;
- value *for_app = for_app_registration;
-
- /* If for_app == NULL, then something is very wrong */
- assert(for_app);
-
- if (func == NULL) {
- /* First time around, lookup by name */
- func = caml_named_value("libxl_fd_deregister");
- }
-
- args[0] = *p;
- args[1] = Val_int(fd);
- args[2] = *for_app;
-
- caml_callbackN_exn(*func, 3, args);
- /* This hook does not return error codes, so the best thing we can do
- * to avoid trouble, if we catch an exception from the app, is abort. */
- if (Is_exception_result(*for_app))
- abort();
-
- caml_remove_global_root(for_app);
- free(for_app);
-
- CAMLdone;
- caml_enter_blocking_section();
-}
-
-struct timeout_handles {
- void *for_libxl;
- value for_app;
-};
-
-int timeout_register(void *user, void **for_app_registration_out,
- struct timeval abs, void *for_libxl)
-{
- caml_leave_blocking_section();
- CAMLparam0();
- CAMLlocal2(sec, usec);
- CAMLlocalN(args, 4);
- int ret = 0;
- static const value *func = NULL;
- value *p = (value *) user;
- struct timeout_handles *handles;
-
- if (func == NULL) {
- /* First time around, lookup by name */
- func = caml_named_value("libxl_timeout_register");
- }
-
- sec = caml_copy_int64(abs.tv_sec);
- usec = caml_copy_int64(abs.tv_usec);
-
- /* This struct of "handles" will contain "for_libxl" as well as "for_app".
- * We'll give a pointer to the struct to the app, and get it back in
- * occurred_timeout, where we can clean it all up. */
- handles = malloc(sizeof(*handles));
- if (!handles) {
- ret = ERROR_OSEVENT_REG_FAIL;
- goto err;
- }
-
- handles->for_libxl = for_libxl;
-
- args[0] = *p;
- args[1] = sec;
- args[2] = usec;
- args[3] = (value) handles;
-
- handles->for_app = caml_callbackN_exn(*func, 4, args);
- if (Is_exception_result(handles->for_app)) {
- ret = ERROR_OSEVENT_REG_FAIL;
- free(handles);
- goto err;
- }
-
- caml_register_global_root(&handles->for_app);
- *for_app_registration_out = handles;
-
-err:
- CAMLdone;
- caml_enter_blocking_section();
- return ret;
-}
-
-int timeout_modify(void *user, void **for_app_registration_update,
- struct timeval abs)
-{
- caml_leave_blocking_section();
- CAMLparam0();
- CAMLlocal1(for_app_update);
- CAMLlocalN(args, 2);
- int ret = 0;
- static const value *func = NULL;
- value *p = (value *) user;
- struct timeout_handles *handles = *for_app_registration_update;
-
- /* If for_app == NULL, then something is very wrong */
- assert(handles->for_app);
-
- /* Libxl currently promises that timeout_modify is only ever called with
- * abs={0,0}, meaning "right away". We cannot deal with other values. */
- assert(abs.tv_sec == 0 && abs.tv_usec == 0);
-
- if (func == NULL) {
- /* First time around, lookup by name */
- func = caml_named_value("libxl_timeout_fire_now");
- }
-
- args[0] = *p;
- args[1] = handles->for_app;
-
- for_app_update = caml_callbackN_exn(*func, 2, args);
- if (Is_exception_result(for_app_update)) {
- /* If an exception is caught, *for_app_registration_update is not
- * changed. It remains a valid pointer to a value that is registered
- * with the GC. */
- ret = ERROR_OSEVENT_REG_FAIL;
- goto err;
- }
-
- handles->for_app = for_app_update;
-
-err:
- CAMLdone;
- caml_enter_blocking_section();
- return ret;
-}
-
-void timeout_deregister(void *user, void *for_app_registration)
-{
- /* This hook will never be called by libxl. */
- abort();
-}
-
-value stub_libxl_osevent_register_hooks(value ctx, value user)
-{
- CAMLparam2(ctx, user);
- CAMLlocal1(result);
- libxl_osevent_hooks *hooks;
- value *p;
-
- hooks = malloc(sizeof(*hooks));
- if (!hooks)
- failwith_xl(ERROR_NOMEM, "cannot allocate osevent hooks");
- hooks->fd_register = fd_register;
- hooks->fd_modify = fd_modify;
- hooks->fd_deregister = fd_deregister;
- hooks->timeout_register = timeout_register;
- hooks->timeout_modify = timeout_modify;
- hooks->timeout_deregister = timeout_deregister;
-
- p = malloc(sizeof(value));
- if (!p)
- failwith_xl(ERROR_NOMEM, "cannot allocate value");
- *p = user;
- caml_register_global_root(p);
-
- caml_enter_blocking_section();
- libxl_osevent_register_hooks(CTX, hooks, (void *) p);
- caml_leave_blocking_section();
-
- result = caml_alloc(1, Abstract_tag);
- *((libxl_osevent_hooks **) result) = hooks;
-
- CAMLreturn(result);
-}
-
-value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd,
- value events, value revents)
-{
- CAMLparam5(ctx, for_libxl, fd, events, revents);
- int c_fd = Int_val(fd);
- short c_events = Poll_events_val(events);
- short c_revents = Poll_events_val(revents);
-
- caml_enter_blocking_section();
- libxl_osevent_occurred_fd(CTX, (void *) for_libxl, c_fd, c_events, c_revents);
- caml_leave_blocking_section();
-
- CAMLreturn(Val_unit);
-}
-
-value stub_libxl_osevent_occurred_timeout(value ctx, value handles)
-{
- CAMLparam1(ctx);
- struct timeout_handles *c_handles = (struct timeout_handles *) handles;
-
- caml_enter_blocking_section();
- libxl_osevent_occurred_timeout(CTX, (void *) c_handles->for_libxl);
- caml_leave_blocking_section();
-
- caml_remove_global_root(&c_handles->for_app);
- free(c_handles);
-
- CAMLreturn(Val_unit);
-}
-
-struct user_with_ctx {
- libxl_ctx *ctx;
- value user;
-};
-
-void event_occurs(void *user, libxl_event *event)
-{
- caml_leave_blocking_section();
- CAMLparam0();
- CAMLlocalN(args, 2);
- struct user_with_ctx *c_user = (struct user_with_ctx *) user;
- static const value *func = NULL;
-
- if (func == NULL) {
- /* First time around, lookup by name */
- func = caml_named_value("libxl_event_occurs_callback");
- }
-
- args[0] = c_user->user;
- args[1] = Val_event(event);
- libxl_event_free(c_user->ctx, event);
-
- caml_callbackN(*func, 2, args);
- CAMLdone;
- caml_enter_blocking_section();
-}
-
-void disaster(void *user, libxl_event_type type,
- const char *msg, int errnoval)
-{
- caml_leave_blocking_section();
- CAMLparam0();
- CAMLlocalN(args, 4);
- struct user_with_ctx *c_user = (struct user_with_ctx *) user;
- static const value *func = NULL;
-
- if (func == NULL) {
- /* First time around, lookup by name */
- func = caml_named_value("libxl_event_disaster_callback");
- }
-
- args[0] = c_user->user;
- args[1] = Val_event_type(type);
- args[2] = caml_copy_string(msg);
- args[3] = Val_int(errnoval);
-
- caml_callbackN(*func, 4, args);
- CAMLdone;
- caml_enter_blocking_section();
-}
-
-value stub_libxl_event_register_callbacks(value ctx, value user)
-{
- CAMLparam2(ctx, user);
- CAMLlocal1(result);
- struct user_with_ctx *c_user = NULL;
- libxl_event_hooks *hooks;
-
- c_user = malloc(sizeof(*c_user));
- if (!c_user)
- failwith_xl(ERROR_NOMEM, "cannot allocate user value");
- c_user->user = user;
- c_user->ctx = CTX;
- caml_register_global_root(&c_user->user);
-
- hooks = malloc(sizeof(*hooks));
- if (!hooks)
- failwith_xl(ERROR_NOMEM, "cannot allocate event hooks");
- hooks->event_occurs_mask = LIBXL_EVENTMASK_ALL;
- hooks->event_occurs = event_occurs;
- hooks->disaster = disaster;
-
- caml_enter_blocking_section();
- libxl_event_register_callbacks(CTX, hooks, (void *) c_user);
- caml_leave_blocking_section();
-
- result = caml_alloc(1, Abstract_tag);
- *((libxl_event_hooks **) result) = hooks;
-
- CAMLreturn(result);
-}
-
-value stub_libxl_evenable_domain_death(value ctx, value domid, value user)
-{
- CAMLparam3(ctx, domid, user);
- uint32_t c_domid = Int_val(domid);
- int c_user = Int_val(user);
- libxl_evgen_domain_death *evgen_out;
-
- caml_enter_blocking_section();
- libxl_evenable_domain_death(CTX, c_domid, c_user, &evgen_out);
- caml_leave_blocking_section();
-
- CAMLreturn(Val_unit);
-}
-
-/*
- * Local variables:
- * indent-tabs-mode: t
- * c-basic-offset: 8
- * tab-width: 8
- * End:
- */
deleted file mode 100644
@@ -1,55 +0,0 @@
-XEN_ROOT = $(CURDIR)/../../..
-OCAML_TOPLEVEL = $(CURDIR)/..
-include $(OCAML_TOPLEVEL)/common.make
-
-CFLAGS += $(APPEND_CFLAGS)
-
-OCAMLINCLUDE += \
- -I $(OCAML_TOPLEVEL)/libs/xentoollog \
- -I $(OCAML_TOPLEVEL)/libs/xl
-
-OBJS = xtl send_debug_keys list_domains raise_exception dmesg
-
-PROGRAMS = xtl send_debug_keys list_domains raise_exception dmesg
-
-xtl_LIBS = \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
-
-xtl_OBJS = xtl
-
-send_debug_keys_LIBS = \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
-
-send_debug_keys_OBJS = xtl send_debug_keys
-
-list_domains_LIBS = \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
-
-list_domains_OBJS = xtl list_domains
-
-raise_exception_LIBS = \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
-
-raise_exception_OBJS = raise_exception
-
-dmesg_LIBS = \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
- -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
-
-dmesg_OBJS = xtl dmesg
-
-OCAML_PROGRAM = xtl send_debug_keys list_domains raise_exception dmesg
-
-all: $(PROGRAMS)
-
-bins: $(PROGRAMS)
-
-install:
-
-uninstall:
-
-include $(OCAML_TOPLEVEL)/Makefile.rules
deleted file mode 100644
@@ -1,17 +0,0 @@
-
-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
- ()
-
deleted file mode 100644
@@ -1,26 +0,0 @@
-open Printf
-
-let bool_as_char b c = if b then c else '-'
-
-let print_dominfo dominfo =
- let id = dominfo.Xenlight.Dominfo.domid
- and running = bool_as_char dominfo.Xenlight.Dominfo.running 'r'
- and blocked = bool_as_char dominfo.Xenlight.Dominfo.blocked 'b'
- and paused = bool_as_char dominfo.Xenlight.Dominfo.paused 'p'
- and shutdown = bool_as_char dominfo.Xenlight.Dominfo.shutdown 's'
- and dying = bool_as_char dominfo.Xenlight.Dominfo.dying 'd'
- and memory = dominfo.Xenlight.Dominfo.current_memkb
- in
- printf "Dom %d: %c%c%c%c%c %LdKB\n" id running blocked paused shutdown dying memory
-
-let _ =
- let logger = Xtl.create_stdio_logger (*~level:Xentoollog.Debug*) () in
- let ctx = Xenlight.ctx_alloc logger in
- try
- let domains = Xenlight.Dominfo.list ctx in
- List.iter (fun d -> print_dominfo d) domains
- with Xenlight.Error(err, fn) -> begin
- printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
- end
-
-
deleted file mode 100644
@@ -1,9 +0,0 @@
-open Printf
-
-let _ =
- try
- Xenlight.test_raise_exception ()
- with Xenlight.Error(err, fn) -> begin
- printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
- end
-
deleted file mode 100644
@@ -1,13 +0,0 @@
-open Printf
-
-let send_keys ctx s =
- printf "Sending debug key %s\n" s;
- Xenlight.Host.send_debug_keys ctx s;
- ()
-
-let _ =
- let logger = Xtl.create_stdio_logger () in
- let ctx = Xenlight.ctx_alloc logger in
- Arg.parse [
- ] (fun s -> send_keys ctx s) "usage: send_debug_keys <keys>"
-
deleted file mode 100644
@@ -1,39 +0,0 @@
-open Printf
-open Xentoollog
-
-let stdio_vmessage min_level level errno ctx msg =
- let level_str = level_to_string level
- and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d" s
- and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in
- if compare min_level level <= 0 then begin
- printf "%s%s%s: %s\n" level_str ctx_str errno_str msg;
- flush stdout;
- end
-
-let stdio_progress _ctx what percent dne total =
- let nl = if dne = total then "\n" else "" in
- printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl;
- flush stdout
-
-let create_stdio_logger ?(level=Info) () =
- let cbs = {
- vmessage = stdio_vmessage level;
- progress = stdio_progress; } in
- create "Xentoollog.stdio_logger" cbs
-
-let do_test level =
- let lgr = create_stdio_logger ~level:level () in
- begin
- test lgr;
- end
-
-let () =
- let debug_level = ref Info in
- let speclist = [
- ("-v", Arg.Unit (fun () -> debug_level := Debug), "Verbose");
- ("-q", Arg.Unit (fun () -> debug_level := Critical), "Quiet");
- ] in
- let usage_msg = "usage: xtl [OPTIONS]" in
- Arg.parse speclist (fun _ -> ()) usage_msg;
-
- do_test !debug_level
There are significant issues with these bindings, and their companion half in Xapi was deleted in 2018 https://github.com/xapi-project/xen-api/commit/203292ebe0c487d7ae4adb961a6d080f4fbe933d owing to there having been no development of these bindings since 2014. In the unlikely event that we'd want to reinstate them, they'd need reworking basically from scratch anyway. Signed-off-by: Andrew Cooper <andrew.cooper3@citrix.com> --- CC: Christian Lindig <christian.lindig@citrix.com> CC: David Scott <dave@recoil.org> CC: Edwin Török <edwin.torok@cloud.com> CC: Rob Hoes <Rob.Hoes@citrix.com> I'm unsure whether to drop xentoollog. They're technically orphaned by this change, but could be used in principle by the other bindings. --- tools/ocaml/Makefile | 4 - tools/ocaml/libs/Makefile | 2 +- tools/ocaml/libs/xl/META.in | 5 - tools/ocaml/libs/xl/Makefile | 71 -- tools/ocaml/libs/xl/genwrap.py | 582 ------------ tools/ocaml/libs/xl/xenlight.ml.in | 94 -- tools/ocaml/libs/xl/xenlight.mli.in | 93 -- tools/ocaml/libs/xl/xenlight_stubs.c | 1663 ---------------------------------- tools/ocaml/test/Makefile | 55 -- tools/ocaml/test/dmesg.ml | 17 - tools/ocaml/test/list_domains.ml | 26 - tools/ocaml/test/raise_exception.ml | 9 - tools/ocaml/test/send_debug_keys.ml | 13 - tools/ocaml/test/xtl.ml | 39 - 14 files changed, 1 insertion(+), 2672 deletions(-) delete mode 100644 tools/ocaml/libs/xl/META.in delete mode 100644 tools/ocaml/libs/xl/Makefile delete mode 100644 tools/ocaml/libs/xl/genwrap.py delete mode 100644 tools/ocaml/libs/xl/xenlight.ml.in delete mode 100644 tools/ocaml/libs/xl/xenlight.mli.in delete mode 100644 tools/ocaml/libs/xl/xenlight_stubs.c delete mode 100644 tools/ocaml/test/Makefile delete mode 100644 tools/ocaml/test/dmesg.ml delete mode 100644 tools/ocaml/test/list_domains.ml delete mode 100644 tools/ocaml/test/raise_exception.ml delete mode 100644 tools/ocaml/test/send_debug_keys.ml delete mode 100644 tools/ocaml/test/xtl.ml