Skip to content

Commit

Permalink
libxl: ocaml: propagate the libxl return error code in exceptions
Browse files Browse the repository at this point in the history 
Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
  • Loading branch information
@robhoes
robhoes committed Apr 16, 2013
1 parent f82210d commit 4cfd4ef
Show file tree
Hide file tree
Showing 4 changed files with 123 additions and 26 deletions.
10 changes: 5 additions & 5 deletions tools/ocaml/libs/xl/genwrap.py
View file
Original file line number Diff line number Diff line change
Expand Up @@ -229,7 +229,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"
Expand All @@ -242,7 +242,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"
Expand All @@ -258,7 +258,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 += "}"
Expand Down Expand Up @@ -327,7 +327,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None, struct_tag = 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
Expand All @@ -351,7 +351,7 @@ def ocaml_Val(ty, o, c, indent="", parent = None, struct_tag = 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"
Expand Down
45 changes: 40 additions & 5 deletions tools/ocaml/libs/xl/xenlight.ml.in
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,20 +13,55 @@
* GNU Lesser General Public License for more details.
*)

exception Error of string
type error =
Nonspecific |
Version |
Fail |
Ni |
Nomem |
Inval |
Badfail |
Guest_Timedout |
Timedout |
Noparavirt |
Not_Ready |
Osevent_Reg_Fail |
Bufferfull |
Unknown_Child

type domid = int
type devid = int
let string_of_error error =
match error with
| Nonspecific -> "Non specific"
| Version -> "Version"
| Fail -> "Fail"
| Ni -> "Ni"
| Nomem -> "Nomem"
| Inval -> "Inval"
| Badfail -> "Badfail"
| Guest_Timedout -> "Guest Timedout"
| Timedout -> "Timedout"
| Noparavirt -> "Noparavirt"
| Not_Ready -> "Not Ready"
| Osevent_Reg_Fail -> "Osevent Reg Fail"
| Bufferfull -> "Bufferfull"
| Unknown_Child -> "Unknown Child"

(* @@LIBXL_TYPES@@ *)
exception Error of (error * string)

type ctx

external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
external ctx_free: ctx -> unit = "stub_libxl_ctx_free"

external test_raise_exception: unit -> unit = "stub_raise_exception"

type domid = int
type devid = int

(* @@LIBXL_TYPES@@ *)

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 _ = Callback.register_exception "Xenlight.Error" (Error(Fail, ""))
28 changes: 24 additions & 4 deletions tools/ocaml/libs/xl/xenlight.mli.in
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,18 +13,38 @@
* GNU Lesser General Public License for more details.
*)

exception Error of string
type error =
Nonspecific |
Version |
Fail |
Ni |
Nomem |
Inval |
Badfail |
Guest_Timedout |
Timedout |
Noparavirt |
Not_Ready |
Osevent_Reg_Fail |
Bufferfull |
Unknown_Child

type domid = int
type devid = int
val string_of_error: error -> string

(* @@LIBXL_TYPES@@ *)
exception Error of (error * string)

type ctx

external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
external ctx_free: ctx -> unit = "stub_libxl_ctx_free"

external test_raise_exception: unit = "stub_raise_exception"

type domid = int
type devid = int

(* @@LIBXL_TYPES@@ *)

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"
66 changes: 54 additions & 12 deletions tools/ocaml/libs/xl/xenlight_stubs.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,12 +43,54 @@ static char * dup_String_val(value s)
return c;
}

static void failwith_xl(char *fname)
static value Val_error(int error)
{
switch (error) {
case ERROR_NONSPECIFIC: return Val_int(0);
case ERROR_VERSION: return Val_int(1);
case ERROR_FAIL: return Val_int(2);
case ERROR_NI: return Val_int(3);
case ERROR_NOMEM: return Val_int(4);
case ERROR_INVAL: return Val_int(5);
case ERROR_BADFAIL: return Val_int(6);
case ERROR_GUEST_TIMEDOUT: return Val_int(7);
case ERROR_TIMEDOUT: return Val_int(8);
case ERROR_NOPARAVIRT: return Val_int(9);
case ERROR_NOT_READY: return Val_int(10);
case ERROR_OSEVENT_REG_FAIL: return Val_int(11);
case ERROR_BUFFERFULL: return Val_int(12);
case ERROR_UNKNOWN_CHILD: return Val_int(13);
#if 0 /* Let the compiler catch this */
default:
caml_raise_sys_error(caml_copy_string("Unknown libxl ERROR"));
break;
#endif
}
/* Should not reach here */
abort();
}

static void failwith_xl(int error, char *fname)
{
CAMLlocal1(arg);
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);

arg = caml_alloc_small(2, 0);

Field(arg, 0) = Val_error(error);
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);
}

CAMLprim value stub_libxl_ctx_alloc(value logger)
Expand All @@ -59,7 +101,7 @@ CAMLprim value stub_libxl_ctx_alloc(value logger)

ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (struct xentoollog_logger *) logger);
if (ret != 0) \
failwith_xl("cannot init context");
failwith_xl(ERROR_FAIL, "cannot init context");
CAMLreturn((value)ctx);
}

Expand Down Expand Up @@ -185,7 +227,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);
Expand Down Expand Up @@ -281,7 +323,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); \
}
Expand All @@ -307,7 +349,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);

Expand All @@ -326,7 +368,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++) {
Expand All @@ -351,7 +393,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);

Expand All @@ -373,7 +415,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);
}
Expand All @@ -390,7 +432,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);
}
Expand All @@ -403,7 +445,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);
}
Expand All @@ -418,7 +460,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);

Expand Down

0 comments on commit 4cfd4ef

Please sign in to comment.