Xen project Mailing List

[PATCH for-4.17 v3 07/15] CODING_STYLE(tools/ocaml): add 'make format' and remove tabs

From: Edwin Török <edvin.torok@xxxxxxxxxx>

Date: Tue, 8 Nov 2022 15:33:59 +0000

Authentication-results: esa2.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none

Cc: Henry Wang <Henry.Wang@xxxxxxx>, Edwin Török <edvin.torok@xxxxxxxxxx>, Christian Lindig <christian.lindig@xxxxxxxxxx>, David Scott <dave@xxxxxxxxxx>, Wei Liu <wl@xxxxxxx>, Anthony PERARD <anthony.perard@xxxxxxxxxx>

Delivery-date: Tue, 08 Nov 2022 15:41:36 +0000

Ironport-data: A9a23:5WvP0qo4pcGI+zz7A9k2q1ELAideBmIUZRIvgKrLsJaIsI4StFCzt garIBnTaf+NNzagfIt/aoXn908G6sDQy4I1SQs9qS89FntB+ZuZCYyVIHmrMnLJJKUvbq7FA +Y2MYCccZ9uHhcwgj/3b9ANeFEljfngqoLUUbKCYWYpAFc+E0/NsDo788YhmIlknNOlNA2Ev NL2sqX3NUSsnjV5KQr40YrawP9UlKm06W1wUmAWP6gR5gaHzylNVvrzGInqR5fGatgMdgKFb 76rIIGRpgvx4xorA9W5pbf3GmVirmn6ZFXmZtJ+AsBOszAazsAA+v9T2Mk0MC+7vw6hjdFpo OihgLTrIesf0g8gr8xGO/VQO3kW0aSrY9YrK1Dn2SCY5xWun3cBX5yCpaz5VGEV0r8fPI1Ay RAXADERVUqRmfKZ+qmUadVnr/4NNPT5AoxK7xmMzRmBZRonaZXKQqGM7t5ExjYgwMtJGJ4yZ eJAN2ApNk6ZJUQSZBFHU/rSn8/x7pX7WzBUtlOT47Yw+W/Q5AdwzKLsIJzefdniqcB9zhrE/ zybpDSR7hcyHcaN5AKrq1uX3+7gkRvhSq43P6+0+as/6LGU7jNKU0BHPbehmtG1g1Czc8hSI EsV/mwpt6da3FOvZsnwWVu/unHslg4RXZ9cHvM37CmJy7HI+ECJC24cVDlDZdc68sgsSlQC9 lKPhcKvOjVpv5WcU3fb/bCRxQ5eIgBMczVEP3VdC1JYvZ+z++nfky4jUP5iDJXvnMPlNgvr7 BO2pwEEqa0un/AEgvDTEU/8vxqgoZ3ATwgQ7wrRX3644g4RWLNJd7BE+nCAs68ecd/xok2p+ SFdxpPAtLxm4YSlznTlfQkbIF2+Cx9p2hX4iEUnIZQu/i/FF5WLLdEJu2EWyKuE3685ld7Vj K374105CHx7ZiHCgUpLj2WZWqwXIVDIT4iNaxwtRoMmj1gYXFbvENtSTUCRxXvxt0MnjLsyP 5yWGe71UyhFWfg5lWLuHblNuVPO+szZ7TqNLa0XMjz9iebODJJrYett3KSyghARs/rf/VS9H yd3PMqW0RRPONASkQGOmbP+7DkicxAGOHwBg5UGK7HZeVE+SDhJ5j246epJRrGJVp99zo/gl kxRkGcBoLYjrRUr8Tm3V00=

Ironport-hdrordr: A9a23:ko8fdKlkbAAA8ynBoPiw1EbzBFbpDfIU3DAbv31ZSRFFG/Fxl6 iV8sjzsiWE8Qr5OUtQ/+xoV5PhfZqxz/JICMwqTNKftWrdyQyVxeNZnOjfKlTbckWUnINgPO VbAsxD4bXLfCBHZK3BgTVQfexO/DD+ytHLudvj

List-id: Xen developer discussion <xen-devel.lists.xenproject.org>

See CODING_STYLE: Xen uses spaces, not tabs. * OCaml code: Using `ocp-indent` for now to just make minimal modifications in tabs vs spaces and get the right indentation. We can introduce `ocamlformat` later. * C stubs: just replace tabs with spaces now, using `indent` or `clang-format` would change code too much for 4.17. This avoids perpetuating a formatting style that is inconsistent with the rest of Xen, and that makes preparing and submitting patches more difficult (OCaml indentation tools usually only support spaces, not tabs). Contains a bugfix for `abi-check` script to handle the change in the amount of whitespace. No functional change. Signed-off-by: Edwin Török <edvin.torok@xxxxxxxxxx> -- Reason for inclusion in 4.17: - makes it easier to backport changes from master to 4.17 - avoid perpetuating a different coding style (I thought tabs were mandated by Xen, and was about to fix up my editor config to match when I realized Xen already mandates the use of spaces) - should make submitting patches for OCaml easier (OCaml indentation tools know only about spaces, so I either can't use them, or have to manually adjust indentation every time I submit a patch) - it can be verified that the only change here is the Makefile change for the new rule, 'git log -p -1 -w' should be otherwise empty Changes since v2: - new in v3 --- tools/ocaml/Makefile | 5 + tools/ocaml/libs/eventchn/xeneventchn_stubs.c | 170 +- tools/ocaml/libs/mmap/mmap_stubs.h | 4 +- tools/ocaml/libs/mmap/xenmmap.ml | 2 +- tools/ocaml/libs/mmap/xenmmap.mli | 4 +- tools/ocaml/libs/mmap/xenmmap_stubs.c | 112 +- tools/ocaml/libs/xb/op.ml | 76 +- tools/ocaml/libs/xb/packet.ml | 30 +- tools/ocaml/libs/xb/partial.ml | 48 +- tools/ocaml/libs/xb/xb.ml | 422 ++-- tools/ocaml/libs/xb/xb.mli | 106 +- tools/ocaml/libs/xb/xenbus_stubs.c | 50 +- tools/ocaml/libs/xb/xs_ring.ml | 28 +- tools/ocaml/libs/xb/xs_ring_stubs.c | 214 +- tools/ocaml/libs/xc/abi-check | 2 +- tools/ocaml/libs/xc/xenctrl.ml | 330 +-- tools/ocaml/libs/xc/xenctrl.mli | 12 +- tools/ocaml/libs/xc/xenctrl_stubs.c | 1424 ++++++------ tools/ocaml/libs/xentoollog/caml_xentoollog.h | 6 +- .../ocaml/libs/xentoollog/xentoollog_stubs.c | 196 +- tools/ocaml/libs/xl/xenlight_stubs.c | 2022 ++++++++--------- tools/ocaml/libs/xs/queueop.ml | 48 +- tools/ocaml/libs/xs/xs.ml | 220 +- tools/ocaml/libs/xs/xs.mli | 46 +- tools/ocaml/libs/xs/xsraw.ml | 300 +-- tools/ocaml/libs/xs/xst.ml | 76 +- tools/ocaml/libs/xs/xst.mli | 20 +- tools/ocaml/test/dmesg.ml | 26 +- tools/ocaml/test/list_domains.ml | 4 +- tools/ocaml/test/raise_exception.ml | 4 +- tools/ocaml/test/xtl.ml | 28 +- tools/ocaml/xenstored/config.ml | 156 +- tools/ocaml/xenstored/connection.ml | 594 ++--- tools/ocaml/xenstored/connections.ml | 304 +-- tools/ocaml/xenstored/define.ml | 6 +- tools/ocaml/xenstored/disk.ml | 218 +- tools/ocaml/xenstored/domain.ml | 100 +- tools/ocaml/xenstored/domains.ml | 310 +-- tools/ocaml/xenstored/event.ml | 4 +- tools/ocaml/xenstored/history.ml | 62 +- tools/ocaml/xenstored/logging.ml | 434 ++-- tools/ocaml/xenstored/packet.ml | 20 +- tools/ocaml/xenstored/parse_arg.ml | 106 +- tools/ocaml/xenstored/perms.ml | 216 +- tools/ocaml/xenstored/poll.ml | 68 +- tools/ocaml/xenstored/poll.mli | 4 +- tools/ocaml/xenstored/process.ml | 1212 +++++----- tools/ocaml/xenstored/quota.ml | 74 +- tools/ocaml/xenstored/select_stubs.c | 62 +- tools/ocaml/xenstored/stdext.ml | 190 +- tools/ocaml/xenstored/store.ml | 752 +++--- tools/ocaml/xenstored/symbol.ml | 2 +- tools/ocaml/xenstored/syslog.ml | 48 +- tools/ocaml/xenstored/syslog_stubs.c | 30 +- tools/ocaml/xenstored/systemd_stubs.c | 10 +- tools/ocaml/xenstored/transaction.ml | 352 +-- tools/ocaml/xenstored/trie.ml | 222 +- tools/ocaml/xenstored/trie.mli | 22 +- tools/ocaml/xenstored/utils.ml | 146 +- tools/ocaml/xenstored/xenstored.ml | 1018 ++++----- 60 files changed, 6391 insertions(+), 6386 deletions(-) diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index a7c04b6546..274ba15d75 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -34,3 +34,8 @@ build-tools-oxenstored: $(MAKE) -s -C libs/xb $(MAKE) -s -C libs/xc $(MAKE) -C xenstored + +.PHONY: format +format: + git ls-files '*.ml' '*.mli' | xargs -n1 ocp-indent -i + git ls-files '*.c' '*.h' | xargs -n1 sed -ie 's/\t/ /g' diff --git a/tools/ocaml/libs/eventchn/xeneventchn_stubs.c b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c index 67af116377..2263c4caa1 100644 --- a/tools/ocaml/libs/eventchn/xeneventchn_stubs.c +++ b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c @@ -44,149 +44,149 @@ static void stub_evtchn_finalize(value v) { - /* docs say to not use any CAMLparam* macros here */ - xenevtchn_close(_H(v)); + /* docs say to not use any CAMLparam* macros here */ + xenevtchn_close(_H(v)); } static struct custom_operations xenevtchn_ops = { - "xenevtchn", - stub_evtchn_finalize, - custom_compare_default, /* raises Failure, cannot compare */ - custom_hash_default, /* ignored */ - custom_serialize_default, /* raises Failure, can't serialize */ - custom_deserialize_default, /* raises Failure, can't deserialize */ - custom_compare_ext_default /* raises Failure */ + "xenevtchn", + stub_evtchn_finalize, + custom_compare_default, /* raises Failure, cannot compare */ + custom_hash_default, /* ignored */ + custom_serialize_default, /* raises Failure, can't serialize */ + custom_deserialize_default, /* raises Failure, can't deserialize */ + custom_compare_ext_default /* raises Failure */ }; CAMLprim value stub_eventchn_init(void) { - CAMLparam0(); - CAMLlocal1(result); - xenevtchn_handle *xce; + CAMLparam0(); + CAMLlocal1(result); + xenevtchn_handle *xce; - caml_enter_blocking_section(); - xce = xenevtchn_open(NULL, 0); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + xce = xenevtchn_open(NULL, 0); + caml_leave_blocking_section(); - if (xce == NULL) - caml_failwith("open failed"); + if (xce == NULL) + caml_failwith("open failed"); - /* contains file descriptors, trigger full GC at least every 128 allocations */ - result = caml_alloc_custom(&xenevtchn_ops, sizeof(xce), 0, 1); - _H(result) = xce; - CAMLreturn(result); + /* contains file descriptors, trigger full GC at least every 128 allocations */ + result = caml_alloc_custom(&xenevtchn_ops, sizeof(xce), 0, 1); + _H(result) = xce; + CAMLreturn(result); } CAMLprim value stub_eventchn_fd(value xce) { - CAMLparam1(xce); - CAMLlocal1(result); - int fd; + CAMLparam1(xce); + CAMLlocal1(result); + int fd; - fd = xenevtchn_fd(_H(xce)); - if (fd == -1) - caml_failwith("evtchn fd failed"); + fd = xenevtchn_fd(_H(xce)); + if (fd == -1) + caml_failwith("evtchn fd failed"); - result = Val_int(fd); + result = Val_int(fd); - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_eventchn_notify(value xce, value port) { - CAMLparam2(xce, port); - int rc; + CAMLparam2(xce, port); + int rc; - caml_enter_blocking_section(); - rc = xenevtchn_notify(_H(xce), Int_val(port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_notify(_H(xce), Int_val(port)); + caml_leave_blocking_section(); - if (rc == -1) - caml_failwith("evtchn notify failed"); + if (rc == -1) + caml_failwith("evtchn notify failed"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_eventchn_bind_interdomain(value xce, value domid, value remote_port) { - CAMLparam3(xce, domid, remote_port); - CAMLlocal1(port); - xenevtchn_port_or_error_t rc; + CAMLparam3(xce, domid, remote_port); + CAMLlocal1(port); + xenevtchn_port_or_error_t rc; - caml_enter_blocking_section(); - rc = xenevtchn_bind_interdomain(_H(xce), Int_val(domid), Int_val(remote_port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_bind_interdomain(_H(xce), Int_val(domid), Int_val(remote_port)); + caml_leave_blocking_section(); - if (rc == -1) - caml_failwith("evtchn bind_interdomain failed"); - port = Val_int(rc); + if (rc == -1) + caml_failwith("evtchn bind_interdomain failed"); + port = Val_int(rc); - CAMLreturn(port); + CAMLreturn(port); } CAMLprim value stub_eventchn_bind_virq(value xce, value virq_type) { - CAMLparam2(xce, virq_type); - CAMLlocal1(port); - xenevtchn_port_or_error_t rc; + CAMLparam2(xce, virq_type); + CAMLlocal1(port); + xenevtchn_port_or_error_t rc; - caml_enter_blocking_section(); - rc = xenevtchn_bind_virq(_H(xce), Int_val(virq_type)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_bind_virq(_H(xce), Int_val(virq_type)); + caml_leave_blocking_section(); - if (rc == -1) - caml_failwith("evtchn bind_virq failed"); - port = Val_int(rc); + if (rc == -1) + caml_failwith("evtchn bind_virq failed"); + port = Val_int(rc); - CAMLreturn(port); + CAMLreturn(port); } CAMLprim value stub_eventchn_unbind(value xce, value port) { - CAMLparam2(xce, port); - int rc; + CAMLparam2(xce, port); + int rc; - caml_enter_blocking_section(); - rc = xenevtchn_unbind(_H(xce), Int_val(port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_unbind(_H(xce), Int_val(port)); + caml_leave_blocking_section(); - if (rc == -1) - caml_failwith("evtchn unbind failed"); + if (rc == -1) + caml_failwith("evtchn unbind failed"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_eventchn_pending(value xce) { - CAMLparam1(xce); - CAMLlocal1(result); - xenevtchn_port_or_error_t port; + CAMLparam1(xce); + CAMLlocal1(result); + xenevtchn_port_or_error_t port; - caml_enter_blocking_section(); - port = xenevtchn_pending(_H(xce)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + port = xenevtchn_pending(_H(xce)); + caml_leave_blocking_section(); - if (port == -1) - caml_failwith("evtchn pending failed"); - result = Val_int(port); + if (port == -1) + caml_failwith("evtchn pending failed"); + result = Val_int(port); - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_eventchn_unmask(value xce, value _port) { - CAMLparam2(xce, _port); - evtchn_port_t port; - int rc; + CAMLparam2(xce, _port); + evtchn_port_t port; + int rc; - port = Int_val(_port); + port = Int_val(_port); - caml_enter_blocking_section(); - rc = xenevtchn_unmask(_H(xce), port); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_unmask(_H(xce), port); + caml_leave_blocking_section(); - if (rc) - caml_failwith("evtchn unmask failed"); - CAMLreturn(Val_unit); + if (rc) + caml_failwith("evtchn unmask failed"); + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/mmap_stubs.h index 5c65cc86fb..14f0c0a704 100644 --- a/tools/ocaml/libs/mmap/mmap_stubs.h +++ b/tools/ocaml/libs/mmap/mmap_stubs.h @@ -26,8 +26,8 @@ struct mmap_interface { - void *addr; - int len; + void *addr; + int len; }; /* for compatibility with OCaml 4.02.3 */ diff --git a/tools/ocaml/libs/mmap/xenmmap.ml b/tools/ocaml/libs/mmap/xenmmap.ml index 44b67c89d2..fd6735649f 100644 --- a/tools/ocaml/libs/mmap/xenmmap.ml +++ b/tools/ocaml/libs/mmap/xenmmap.ml @@ -21,7 +21,7 @@ type mmap_map_flag = SHARED | PRIVATE (* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *) external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag - -> int -> int -> mmap_interface = "stub_mmap_init" + -> int -> int -> mmap_interface = "stub_mmap_init" external unmap: mmap_interface -> unit = "stub_mmap_final" (* read: interface -> start -> length -> data *) external read: mmap_interface -> int -> int -> string = "stub_mmap_read" diff --git a/tools/ocaml/libs/mmap/xenmmap.mli b/tools/ocaml/libs/mmap/xenmmap.mli index 8f92ed6310..d097b68a8f 100644 --- a/tools/ocaml/libs/mmap/xenmmap.mli +++ b/tools/ocaml/libs/mmap/xenmmap.mli @@ -19,10 +19,10 @@ type mmap_prot_flag = RDONLY | WRONLY | RDWR type mmap_map_flag = SHARED | PRIVATE external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int - -> mmap_interface = "stub_mmap_init" + -> mmap_interface = "stub_mmap_init" external unmap : mmap_interface -> unit = "stub_mmap_final" external read : mmap_interface -> int -> int -> string = "stub_mmap_read" external write : mmap_interface -> string -> int -> int -> unit - = "stub_mmap_write" + = "stub_mmap_write" external getpagesize : unit -> int = "stub_mmap_getpagesize" diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c b/tools/ocaml/libs/mmap/xenmmap_stubs.c index 141dedb78c..bf864a7c32 100644 --- a/tools/ocaml/libs/mmap/xenmmap_stubs.c +++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c @@ -34,97 +34,97 @@ static int mmap_interface_init(struct mmap_interface *intf, int fd, int pflag, int mflag, int len, int offset) { - intf->len = len; - intf->addr = mmap(NULL, len, pflag, mflag, fd, offset); - return (intf->addr == MAP_FAILED) ? errno : 0; + intf->len = len; + intf->addr = mmap(NULL, len, pflag, mflag, fd, offset); + return (intf->addr == MAP_FAILED) ? errno : 0; } CAMLprim value stub_mmap_init(value fd, value pflag, value mflag, value len, value offset) { - CAMLparam5(fd, pflag, mflag, len, offset); - CAMLlocal1(result); - int c_pflag, c_mflag; + CAMLparam5(fd, pflag, mflag, len, offset); + CAMLlocal1(result); + int c_pflag, c_mflag; - switch (Int_val(pflag)) { - case 0: c_pflag = PROT_READ; break; - case 1: c_pflag = PROT_WRITE; break; - case 2: c_pflag = PROT_READ|PROT_WRITE; break; - default: caml_invalid_argument("protectiontype"); - } + switch (Int_val(pflag)) { + case 0: c_pflag = PROT_READ; break; + case 1: c_pflag = PROT_WRITE; break; + case 2: c_pflag = PROT_READ|PROT_WRITE; break; + default: caml_invalid_argument("protectiontype"); + } - switch (Int_val(mflag)) { - case 0: c_mflag = MAP_SHARED; break; - case 1: c_mflag = MAP_PRIVATE; break; - default: caml_invalid_argument("maptype"); - } + switch (Int_val(mflag)) { + case 0: c_mflag = MAP_SHARED; break; + case 1: c_mflag = MAP_PRIVATE; break; + default: caml_invalid_argument("maptype"); + } - result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); - if (mmap_interface_init(Intf_val(result), Int_val(fd), - c_pflag, c_mflag, - Int_val(len), Int_val(offset))) - caml_failwith("mmap"); - CAMLreturn(result); + if (mmap_interface_init(Intf_val(result), Int_val(fd), + c_pflag, c_mflag, + Int_val(len), Int_val(offset))) + caml_failwith("mmap"); + CAMLreturn(result); } CAMLprim value stub_mmap_final(value intf) { - CAMLparam1(intf); + CAMLparam1(intf); - if (Intf_val(intf)->addr != MAP_FAILED) - munmap(Intf_val(intf)->addr, Intf_val(intf)->len); - Intf_val(intf)->addr = MAP_FAILED; + if (Intf_val(intf)->addr != MAP_FAILED) + munmap(Intf_val(intf)->addr, Intf_val(intf)->len); + Intf_val(intf)->addr = MAP_FAILED; - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_mmap_read(value intf, value start, value len) { - CAMLparam3(intf, start, len); - CAMLlocal1(data); - int c_start; - int c_len; + CAMLparam3(intf, start, len); + CAMLlocal1(data); + int c_start; + int c_len; - c_start = Int_val(start); - c_len = Int_val(len); + c_start = Int_val(start); + c_len = Int_val(len); - if (c_start > Intf_val(intf)->len) - caml_invalid_argument("start invalid"); - if (c_start + c_len > Intf_val(intf)->len) - caml_invalid_argument("len invalid"); + if (c_start > Intf_val(intf)->len) + caml_invalid_argument("start invalid"); + if (c_start + c_len > Intf_val(intf)->len) + caml_invalid_argument("len invalid"); - data = caml_alloc_string(c_len); - memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len); + data = caml_alloc_string(c_len); + memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len); - CAMLreturn(data); + CAMLreturn(data); } CAMLprim value stub_mmap_write(value intf, value data, value start, value len) { - CAMLparam4(intf, data, start, len); - int c_start; - int c_len; + CAMLparam4(intf, data, start, len); + int c_start; + int c_len; - c_start = Int_val(start); - c_len = Int_val(len); + c_start = Int_val(start); + c_len = Int_val(len); - if (c_start > Intf_val(intf)->len) - caml_invalid_argument("start invalid"); - if (c_start + c_len > Intf_val(intf)->len) - caml_invalid_argument("len invalid"); + if (c_start > Intf_val(intf)->len) + caml_invalid_argument("start invalid"); + if (c_start + c_len > Intf_val(intf)->len) + caml_invalid_argument("len invalid"); - memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len); + memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_mmap_getpagesize(value unit) { - CAMLparam1(unit); - CAMLlocal1(data); + CAMLparam1(unit); + CAMLlocal1(data); - data = Val_int(getpagesize()); - CAMLreturn(data); + data = Val_int(getpagesize()); + CAMLreturn(data); } diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml index 9bcab0f38c..c94116a8cc 100644 --- a/tools/ocaml/libs/xb/op.ml +++ b/tools/ocaml/libs/xb/op.ml @@ -23,50 +23,50 @@ type operation = Debug | Directory | Read | Getperms | Invalid let operation_c_mapping = - [| Debug; Directory; Read; Getperms; - Watch; Unwatch; Transaction_start; - Transaction_end; Introduce; Release; - Getdomainpath; Write; Mkdir; Rm; - Setperms; Watchevent; Error; Isintroduced; - Resume; Set_target; Invalid; Reset_watches |] + [| Debug; Directory; Read; Getperms; + Watch; Unwatch; Transaction_start; + Transaction_end; Introduce; Release; + Getdomainpath; Write; Mkdir; Rm; + Setperms; Watchevent; Error; Isintroduced; + Resume; Set_target; Invalid; Reset_watches |] let size = Array.length operation_c_mapping let array_search el a = - let len = Array.length a in - let rec search i = - if i > len then raise Not_found; - if a.(i) = el then i else search (i + 1) in - search 0 + let len = Array.length a in + let rec search i = + if i > len then raise Not_found; + if a.(i) = el then i else search (i + 1) in + search 0 let of_cval i = - if i >= 0 && i < size - then operation_c_mapping.(i) - else Invalid + if i >= 0 && i < size + then operation_c_mapping.(i) + else Invalid let to_cval op = - array_search op operation_c_mapping + array_search op operation_c_mapping let to_string ty = - match ty with - | Debug -> "DEBUG" - | Directory -> "DIRECTORY" - | Read -> "READ" - | Getperms -> "GET_PERMS" - | Watch -> "WATCH" - | Unwatch -> "UNWATCH" - | Transaction_start -> "TRANSACTION_START" - | Transaction_end -> "TRANSACTION_END" - | Introduce -> "INTRODUCE" - | Release -> "RELEASE" - | Getdomainpath -> "GET_DOMAIN_PATH" - | Write -> "WRITE" - | Mkdir -> "MKDIR" - | Rm -> "RM" - | Setperms -> "SET_PERMS" - | Watchevent -> "WATCH_EVENT" - | Error -> "ERROR" - | Isintroduced -> "IS_INTRODUCED" - | Resume -> "RESUME" - | Set_target -> "SET_TARGET" - | Reset_watches -> "RESET_WATCHES" - | Invalid -> "INVALID" + match ty with + | Debug -> "DEBUG" + | Directory -> "DIRECTORY" + | Read -> "READ" + | Getperms -> "GET_PERMS" + | Watch -> "WATCH" + | Unwatch -> "UNWATCH" + | Transaction_start -> "TRANSACTION_START" + | Transaction_end -> "TRANSACTION_END" + | Introduce -> "INTRODUCE" + | Release -> "RELEASE" + | Getdomainpath -> "GET_DOMAIN_PATH" + | Write -> "WRITE" + | Mkdir -> "MKDIR" + | Rm -> "RM" + | Setperms -> "SET_PERMS" + | Watchevent -> "WATCH_EVENT" + | Error -> "ERROR" + | Isintroduced -> "IS_INTRODUCED" + | Resume -> "RESUME" + | Set_target -> "SET_TARGET" + | Reset_watches -> "RESET_WATCHES" + | Invalid -> "INVALID" diff --git a/tools/ocaml/libs/xb/packet.ml b/tools/ocaml/libs/xb/packet.ml index 74c04bb7ae..cd169c066b 100644 --- a/tools/ocaml/libs/xb/packet.ml +++ b/tools/ocaml/libs/xb/packet.ml @@ -15,12 +15,12 @@ *) type t = -{ - tid: int; - rid: int; - ty: Op.operation; - data: string; -} + { + tid: int; + rid: int; + ty: Op.operation; + data: string; + } exception Error of string exception DataError of string @@ -30,21 +30,21 @@ external string_of_header: int -> int -> int -> int -> string = "stub_string_of_ let create tid rid ty data = { tid = tid; rid = rid; ty = ty; data = data; } let of_partialpkt ppkt = - create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf) + create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf) let to_string pkt = - let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in - header ^ pkt.data + let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in + header ^ pkt.data let unpack pkt = - pkt.tid, pkt.rid, pkt.ty, pkt.data + pkt.tid, pkt.rid, pkt.ty, pkt.data let get_tid pkt = pkt.tid let get_ty pkt = pkt.ty let get_data pkt = - let l = String.length pkt.data in - if l > 0 && pkt.data.[l - 1] = '\000' then - String.sub pkt.data 0 (l - 1) - else - pkt.data + let l = String.length pkt.data in + if l > 0 && pkt.data.[l - 1] = '\000' then + String.sub pkt.data 0 (l - 1) + else + pkt.data let get_rid pkt = pkt.rid \ No newline at end of file diff --git a/tools/ocaml/libs/xb/partial.ml b/tools/ocaml/libs/xb/partial.ml index 3aa8927eb7..0494c6a9c7 100644 --- a/tools/ocaml/libs/xb/partial.ml +++ b/tools/ocaml/libs/xb/partial.ml @@ -15,39 +15,39 @@ *) type pkt = -{ - tid: int; - rid: int; - ty: Op.operation; - len: int; - buf: Buffer.t; -} + { + tid: int; + rid: int; + ty: Op.operation; + len: int; + buf: Buffer.t; + } external header_size: unit -> int = "stub_header_size" external header_of_string_internal: string -> int * int * int * int - = "stub_header_of_string" + = "stub_header_of_string" let xenstore_payload_max = 4096 (* xen/include/public/io/xs_wire.h *) let xenstore_rel_path_max = 2048 (* xen/include/public/io/xs_wire.h *) let of_string s = - let tid, rid, opint, dlen = header_of_string_internal s in - (* A packet which is bigger than xenstore_payload_max is illegal. - This will leave the guest connection is a bad state and will - be hard to recover from without restarting the connection - (ie rebooting the guest) *) - let dlen = max 0 (min xenstore_payload_max dlen) in - { - tid = tid; - rid = rid; - ty = (Op.of_cval opint); - len = dlen; - buf = Buffer.create dlen; - } + let tid, rid, opint, dlen = header_of_string_internal s in + (* A packet which is bigger than xenstore_payload_max is illegal. + This will leave the guest connection is a bad state and will + be hard to recover from without restarting the connection + (ie rebooting the guest) *) + let dlen = max 0 (min xenstore_payload_max dlen) in + { + tid = tid; + rid = rid; + ty = (Op.of_cval opint); + len = dlen; + buf = Buffer.create dlen; + } let append pkt s sz = - if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith "Buffer.add: cannot grow buffer"; - Buffer.add_substring pkt.buf s 0 sz + if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith "Buffer.add: cannot grow buffer"; + Buffer.add_substring pkt.buf s 0 sz let to_complete pkt = - pkt.len - (Buffer.length pkt.buf) + pkt.len - (Buffer.length pkt.buf) diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml index b292ed7a87..40d2c9956a 100644 --- a/tools/ocaml/libs/xb/xb.ml +++ b/tools/ocaml/libs/xb/xb.ml @@ -18,94 +18,94 @@ module Op = struct include Op end module Packet = struct include Packet end module BoundedQueue : sig - type ('a, 'b) t + type ('a, 'b) t - (** [create ~capacity ~classify ~limit] creates a queue with maximum [capacity] elements. - This is burst capacity, each element is further classified according to [classify], - and each class can have its own [limit]. - [capacity] is enforced as an overall limit. - The [limit] can be dynamic, and can be smaller than the number of elements already queued of that class, - in which case those elements are considered to use "burst capacity". - *) - val create: capacity:int -> classify:('a -> 'b) -> limit:('b -> int) -> ('a, 'b) t + (** [create ~capacity ~classify ~limit] creates a queue with maximum [capacity] elements. + This is burst capacity, each element is further classified according to [classify], + and each class can have its own [limit]. + [capacity] is enforced as an overall limit. + The [limit] can be dynamic, and can be smaller than the number of elements already queued of that class, + in which case those elements are considered to use "burst capacity". + *) + val create: capacity:int -> classify:('a -> 'b) -> limit:('b -> int) -> ('a, 'b) t - (** [clear q] discards all elements from [q] *) - val clear: ('a, 'b) t -> unit + (** [clear q] discards all elements from [q] *) + val clear: ('a, 'b) t -> unit - (** [can_push q] when [length q < capacity]. *) - val can_push: ('a, 'b) t -> 'b -> bool + (** [can_push q] when [length q < capacity]. *) + val can_push: ('a, 'b) t -> 'b -> bool - (** [push e q] adds [e] at the end of queue [q] if [can_push q], or returns [None]. *) - val push: 'a -> ('a, 'b) t -> unit option + (** [push e q] adds [e] at the end of queue [q] if [can_push q], or returns [None]. *) + val push: 'a -> ('a, 'b) t -> unit option - (** [pop q] removes and returns first element in [q], or raises [Queue.Empty]. *) - val pop: ('a, 'b) t -> 'a + (** [pop q] removes and returns first element in [q], or raises [Queue.Empty]. *) + val pop: ('a, 'b) t -> 'a - (** [peek q] returns the first element in [q], or raises [Queue.Empty]. *) - val peek : ('a, 'b) t -> 'a + (** [peek q] returns the first element in [q], or raises [Queue.Empty]. *) + val peek : ('a, 'b) t -> 'a - (** [length q] returns the current number of elements in [q] *) - val length: ('a, 'b) t -> int + (** [length q] returns the current number of elements in [q] *) + val length: ('a, 'b) t -> int - (** [debug string_of_class q] prints queue usage statistics in an unspecified internal format. *) - val debug: ('b -> string) -> (_, 'b) t -> string + (** [debug string_of_class q] prints queue usage statistics in an unspecified internal format. *) + val debug: ('b -> string) -> (_, 'b) t -> string end = struct - type ('a, 'b) t = - { q: 'a Queue.t - ; capacity: int - ; classify: 'a -> 'b - ; limit: 'b -> int - ; class_count: ('b, int) Hashtbl.t - } + type ('a, 'b) t = + { q: 'a Queue.t + ; capacity: int + ; classify: 'a -> 'b + ; limit: 'b -> int + ; class_count: ('b, int) Hashtbl.t + } - let create ~capacity ~classify ~limit = - { capacity; q = Queue.create (); classify; limit; class_count = Hashtbl.create 3 } + let create ~capacity ~classify ~limit = + { capacity; q = Queue.create (); classify; limit; class_count = Hashtbl.create 3 } - let get_count t classification = try Hashtbl.find t.class_count classification with Not_found -> 0 + let get_count t classification = try Hashtbl.find t.class_count classification with Not_found -> 0 - let can_push_internal t classification class_count = - Queue.length t.q < t.capacity && class_count < t.limit classification + let can_push_internal t classification class_count = + Queue.length t.q < t.capacity && class_count < t.limit classification - let ok = Some () + let ok = Some () - let push e t = - let classification = t.classify e in - let class_count = get_count t classification in - if can_push_internal t classification class_count then begin - Queue.push e t.q; - Hashtbl.replace t.class_count classification (class_count + 1); - ok - end - else - None + let push e t = + let classification = t.classify e in + let class_count = get_count t classification in + if can_push_internal t classification class_count then begin + Queue.push e t.q; + Hashtbl.replace t.class_count classification (class_count + 1); + ok + end + else + None - let can_push t classification = - can_push_internal t classification @@ get_count t classification + let can_push t classification = + can_push_internal t classification @@ get_count t classification - let clear t = - Queue.clear t.q; - Hashtbl.reset t.class_count + let clear t = + Queue.clear t.q; + Hashtbl.reset t.class_count - let pop t = - let e = Queue.pop t.q in - let classification = t.classify e in - let () = match get_count t classification - 1 with - | 0 -> Hashtbl.remove t.class_count classification (* reduces memusage *) - | n -> Hashtbl.replace t.class_count classification n - in - e + let pop t = + let e = Queue.pop t.q in + let classification = t.classify e in + let () = match get_count t classification - 1 with + | 0 -> Hashtbl.remove t.class_count classification (* reduces memusage *) + | n -> Hashtbl.replace t.class_count classification n + in + e - let peek t = Queue.peek t.q - let length t = Queue.length t.q + let peek t = Queue.peek t.q + let length t = Queue.length t.q - let debug string_of_class t = - let b = Buffer.create 128 in - Printf.bprintf b "BoundedQueue capacity: %d, used: {" t.capacity; - Hashtbl.iter (fun packet_class count -> - Printf.bprintf b " %s: %d" (string_of_class packet_class) count - ) t.class_count; - Printf.bprintf b "}"; - Buffer.contents b + let debug string_of_class t = + let b = Buffer.create 128 in + Printf.bprintf b "BoundedQueue capacity: %d, used: {" t.capacity; + Hashtbl.iter (fun packet_class count -> + Printf.bprintf b " %s: %d" (string_of_class packet_class) count + ) t.class_count; + Printf.bprintf b "}"; + Buffer.contents b end @@ -119,129 +119,129 @@ let _ = Callback.register_exception "Xb.Reconnect" Reconnect type backend_mmap = -{ - mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *) - eventchn_notify: unit -> unit; (* function to notify through eventchn *) - mutable work_again: bool; -} + { + mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *) + eventchn_notify: unit -> unit; (* function to notify through eventchn *) + mutable work_again: bool; + } type backend_fd = -{ - fd: Unix.file_descr; -} + { + fd: Unix.file_descr; + } type backend = Fd of backend_fd | Xenmmap of backend_mmap type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * bytes (* - separate capacity reservation for replies and watch events: - this allows a domain to keep working even when under a constant flood of - watch events + separate capacity reservation for replies and watch events: + this allows a domain to keep working even when under a constant flood of + watch events *) type capacity = { maxoutstanding: int; maxwatchevents: int } module Queue = BoundedQueue type packet_class = - | CommandReply - | Watchevent + | CommandReply + | Watchevent let string_of_packet_class = function - | CommandReply -> "command_reply" - | Watchevent -> "watch_event" + | CommandReply -> "command_reply" + | Watchevent -> "watch_event" type t = -{ - backend: backend; - pkt_out: (Packet.t, packet_class) Queue.t; - mutable partial_in: partial_buf; - mutable partial_out: string; - capacity: capacity -} + { + backend: backend; + pkt_out: (Packet.t, packet_class) Queue.t; + mutable partial_in: partial_buf; + mutable partial_out: string; + capacity: capacity + } let to_read con = - match con.partial_in with - | HaveHdr partial_pkt -> Partial.to_complete partial_pkt - | NoHdr (i, _) -> i + match con.partial_in with + | HaveHdr partial_pkt -> Partial.to_complete partial_pkt + | NoHdr (i, _) -> i let debug t = - Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d bytes, pkt_out: %d packets, %s" - (to_read t) - (String.length t.partial_out) - (Queue.length t.pkt_out) - (BoundedQueue.debug string_of_packet_class t.pkt_out) + Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d bytes, pkt_out: %d packets, %s" + (to_read t) + (String.length t.partial_out) + (Queue.length t.pkt_out) + (BoundedQueue.debug string_of_packet_class t.pkt_out) let init_partial_in () = NoHdr - (Partial.header_size (), Bytes.make (Partial.header_size()) '\000') + (Partial.header_size (), Bytes.make (Partial.header_size()) '\000') let reconnect t = match t.backend with - | Fd _ -> - (* should never happen, so close the connection *) - raise End_of_file - | Xenmmap backend -> - Xs_ring.close backend.mmap; - backend.eventchn_notify (); - (* Clear our old connection state *) - Queue.clear t.pkt_out; - t.partial_in <- init_partial_in (); - t.partial_out <- "" + | Fd _ -> + (* should never happen, so close the connection *) + raise End_of_file + | Xenmmap backend -> + Xs_ring.close backend.mmap; + backend.eventchn_notify (); + (* Clear our old connection state *) + Queue.clear t.pkt_out; + t.partial_in <- init_partial_in (); + t.partial_out <- "" let queue con pkt = Queue.push pkt con.pkt_out let read_fd back _con b len = - let rd = Unix.read back.fd b 0 len in - if rd = 0 then - raise End_of_file; - rd + let rd = Unix.read back.fd b 0 len in + if rd = 0 then + raise End_of_file; + rd let read_mmap back _con b len = - let s = Bytes.make len '\000' in - let rd = Xs_ring.read back.mmap s len in - Bytes.blit s 0 b 0 rd; - back.work_again <- (rd > 0); - if rd > 0 then - back.eventchn_notify (); - rd + let s = Bytes.make len '\000' in + let rd = Xs_ring.read back.mmap s len in + Bytes.blit s 0 b 0 rd; + back.work_again <- (rd > 0); + if rd > 0 then + back.eventchn_notify (); + rd let read con b len = - match con.backend with - | Fd backfd -> read_fd backfd con b len - | Xenmmap backmmap -> read_mmap backmmap con b len + match con.backend with + | Fd backfd -> read_fd backfd con b len + | Xenmmap backmmap -> read_mmap backmmap con b len let write_fd back _con b len = - Unix.write_substring back.fd b 0 len + Unix.write_substring back.fd b 0 len let write_mmap back _con s len = - let ws = Xs_ring.write_substring back.mmap s len in - if ws > 0 then - back.eventchn_notify (); - ws + let ws = Xs_ring.write_substring back.mmap s len in + if ws > 0 then + back.eventchn_notify (); + ws let write con s len = - match con.backend with - | Fd backfd -> write_fd backfd con s len - | Xenmmap backmmap -> write_mmap backmmap con s len + match con.backend with + | Fd backfd -> write_fd backfd con s len + | Xenmmap backmmap -> write_mmap backmmap con s len (* NB: can throw Reconnect *) let output con = - (* get the output string from a string_of(packet) or partial_out *) - let s = if String.length con.partial_out > 0 then - con.partial_out - else if Queue.length con.pkt_out > 0 then - let pkt = Queue.pop con.pkt_out in - Packet.to_string pkt - else - "" in - (* send data from s, and save the unsent data to partial_out *) - if s <> "" then ( - let len = String.length s in - let sz = write con s len in - let left = String.sub s sz (len - sz) in - con.partial_out <- left - ); - (* after sending one packet, partial is empty *) - con.partial_out = "" + (* get the output string from a string_of(packet) or partial_out *) + let s = if String.length con.partial_out > 0 then + con.partial_out + else if Queue.length con.pkt_out > 0 then + let pkt = Queue.pop con.pkt_out in + Packet.to_string pkt + else + "" in + (* send data from s, and save the unsent data to partial_out *) + if s <> "" then ( + let len = String.length s in + let sz = write con s len in + let left = String.sub s sz (len - sz) in + con.partial_out <- left + ); + (* after sending one packet, partial is empty *) + con.partial_out = "" (* we can only process an input packet if we're guaranteed to have room to store the response packet *) @@ -249,71 +249,71 @@ let can_input con = Queue.can_push con.pkt_out CommandReply (* NB: can throw Reconnect *) let input con = - if not (can_input con) then None - else - let to_read = to_read con in + if not (can_input con) then None + else + let to_read = to_read con in - (* try to get more data from input stream *) - let b = Bytes.make to_read '\000' in - let sz = if to_read > 0 then read con b to_read else 0 in + (* try to get more data from input stream *) + let b = Bytes.make to_read '\000' in + let sz = if to_read > 0 then read con b to_read else 0 in - ( - match con.partial_in with - | HaveHdr partial_pkt -> - (* we complete the data *) - if sz > 0 then - Partial.append partial_pkt (Bytes.to_string b) sz; - if Partial.to_complete partial_pkt = 0 then ( - let pkt = Packet.of_partialpkt partial_pkt in - con.partial_in <- init_partial_in (); - Some pkt - ) else None - | NoHdr (i, buf) -> - (* we complete the partial header *) - if sz > 0 then - Bytes.blit b 0 buf (Partial.header_size () - i) sz; - con.partial_in <- if sz = i then - HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, buf); - None - ) + ( + match con.partial_in with + | HaveHdr partial_pkt -> + (* we complete the data *) + if sz > 0 then + Partial.append partial_pkt (Bytes.to_string b) sz; + if Partial.to_complete partial_pkt = 0 then ( + let pkt = Packet.of_partialpkt partial_pkt in + con.partial_in <- init_partial_in (); + Some pkt + ) else None + | NoHdr (i, buf) -> + (* we complete the partial header *) + if sz > 0 then + Bytes.blit b 0 buf (Partial.header_size () - i) sz; + con.partial_in <- if sz = i then + HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, buf); + None + ) let classify t = - match t.Packet.ty with - | Op.Watchevent -> Watchevent - | _ -> CommandReply + match t.Packet.ty with + | Op.Watchevent -> Watchevent + | _ -> CommandReply let newcon ~capacity backend = - let limit = function - | CommandReply -> capacity.maxoutstanding - | Watchevent -> capacity.maxwatchevents - in - { - backend = backend; - pkt_out = Queue.create ~capacity:(capacity.maxoutstanding + capacity.maxwatchevents) ~classify ~limit; - partial_in = init_partial_in (); - partial_out = ""; - capacity = capacity; - } + let limit = function + | CommandReply -> capacity.maxoutstanding + | Watchevent -> capacity.maxwatchevents + in + { + backend = backend; + pkt_out = Queue.create ~capacity:(capacity.maxoutstanding + capacity.maxwatchevents) ~classify ~limit; + partial_in = init_partial_in (); + partial_out = ""; + capacity = capacity; + } let open_fd fd = newcon (Fd { fd = fd; }) let open_mmap mmap notifyfct = - (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *) - Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection); - newcon (Xenmmap { - mmap = mmap; - eventchn_notify = notifyfct; - work_again = false; }) + (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *) + Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection); + newcon (Xenmmap { + mmap = mmap; + eventchn_notify = notifyfct; + work_again = false; }) let close con = - match con.backend with - | Fd backend -> Unix.close backend.fd - | Xenmmap backend -> Xenmmap.unmap backend.mmap + match con.backend with + | Fd backend -> Unix.close backend.fd + | Xenmmap backend -> Xenmmap.unmap backend.mmap let is_fd con = - match con.backend with - | Fd _ -> true - | Xenmmap _ -> false + match con.backend with + | Fd _ -> true + | Xenmmap _ -> false let is_mmap con = not (is_fd con) @@ -326,19 +326,19 @@ let has_output con = has_new_output con || has_old_output con let peek_output con = Queue.peek con.pkt_out let has_partial_input con = match con.partial_in with - | HaveHdr _ -> true - | NoHdr (n, _) -> n < Partial.header_size () + | HaveHdr _ -> true + | NoHdr (n, _) -> n < Partial.header_size () let has_more_input con = - match con.backend with - | Fd _ -> false - | Xenmmap backend -> backend.work_again + match con.backend with + | Fd _ -> false + | Xenmmap backend -> backend.work_again let is_selectable con = - match con.backend with - | Fd _ -> true - | Xenmmap _ -> false + match con.backend with + | Fd _ -> true + | Xenmmap _ -> false let get_fd con = - match con.backend with - | Fd backend -> backend.fd - | Xenmmap _ -> raise (Failure "get_fd") + match con.backend with + | Fd backend -> backend.fd + | Xenmmap _ -> raise (Failure "get_fd") diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli index 71b2754ca7..e6bb3809dc 100644 --- a/tools/ocaml/libs/xb/xb.mli +++ b/tools/ocaml/libs/xb/xb.mli @@ -1,58 +1,58 @@ module Op : - sig - type operation = - Op.operation = - Debug - | Directory - | Read - | Getperms - | Watch - | Unwatch - | Transaction_start - | Transaction_end - | Introduce - | Release - | Getdomainpath - | Write - | Mkdir - | Rm - | Setperms - | Watchevent - | Error - | Isintroduced - | Resume - | Set_target - | Reset_watches - | Invalid - val operation_c_mapping : operation array - val size : int - val array_search : 'a -> 'a array -> int - val of_cval : int -> operation - val to_cval : operation -> int - val to_string : operation -> string - end +sig + type operation = + Op.operation = + Debug + | Directory + | Read + | Getperms + | Watch + | Unwatch + | Transaction_start + | Transaction_end + | Introduce + | Release + | Getdomainpath + | Write + | Mkdir + | Rm + | Setperms + | Watchevent + | Error + | Isintroduced + | Resume + | Set_target + | Reset_watches + | Invalid + val operation_c_mapping : operation array + val size : int + val array_search : 'a -> 'a array -> int + val of_cval : int -> operation + val to_cval : operation -> int + val to_string : operation -> string +end module Packet : - sig - type t = - Packet.t = { - tid : int; - rid : int; - ty : Op.operation; - data : string; - } - exception Error of string - exception DataError of string - external string_of_header : int -> int -> int -> int -> string - = "stub_string_of_header" - val create : int -> int -> Op.operation -> string -> t - val of_partialpkt : Partial.pkt -> t - val to_string : t -> string - val unpack : t -> int * int * Op.operation * string - val get_tid : t -> int - val get_ty : t -> Op.operation - val get_data : t -> string - val get_rid : t -> int - end +sig + type t = + Packet.t = { + tid : int; + rid : int; + ty : Op.operation; + data : string; + } + exception Error of string + exception DataError of string + external string_of_header : int -> int -> int -> int -> string + = "stub_string_of_header" + val create : int -> int -> Op.operation -> string -> t + val of_partialpkt : Partial.pkt -> t + val to_string : t -> string + val unpack : t -> int * int * Op.operation * string + val get_tid : t -> int + val get_ty : t -> Op.operation + val get_data : t -> string + val get_rid : t -> int +end exception End_of_file exception Eagain exception Noent diff --git a/tools/ocaml/libs/xb/xenbus_stubs.c b/tools/ocaml/libs/xb/xenbus_stubs.c index 3065181a55..e5206f64d4 100644 --- a/tools/ocaml/libs/xb/xenbus_stubs.c +++ b/tools/ocaml/libs/xb/xenbus_stubs.c @@ -32,40 +32,40 @@ CAMLprim value stub_header_size(void) { - CAMLparam0(); - CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); + CAMLparam0(); + CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); } CAMLprim value stub_header_of_string(value s) { - CAMLparam1(s); - CAMLlocal1(ret); - const struct xsd_sockmsg *hdr; + CAMLparam1(s); + CAMLlocal1(ret); + const struct xsd_sockmsg *hdr; - if (caml_string_length(s) != sizeof(struct xsd_sockmsg)) - caml_failwith("xb header incomplete"); - ret = caml_alloc_tuple(4); - hdr = (const struct xsd_sockmsg *) String_val(s); - Store_field(ret, 0, Val_int(hdr->tx_id)); - Store_field(ret, 1, Val_int(hdr->req_id)); - Store_field(ret, 2, Val_int(hdr->type)); - Store_field(ret, 3, Val_int(hdr->len)); - CAMLreturn(ret); + if (caml_string_length(s) != sizeof(struct xsd_sockmsg)) + caml_failwith("xb header incomplete"); + ret = caml_alloc_tuple(4); + hdr = (const struct xsd_sockmsg *) String_val(s); + Store_field(ret, 0, Val_int(hdr->tx_id)); + Store_field(ret, 1, Val_int(hdr->req_id)); + Store_field(ret, 2, Val_int(hdr->type)); + Store_field(ret, 3, Val_int(hdr->len)); + CAMLreturn(ret); } CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len) { - CAMLparam4(tid, rid, ty, len); - CAMLlocal1(ret); - struct xsd_sockmsg xsd = { - .type = Int_val(ty), - .tx_id = Int_val(tid), - .req_id = Int_val(rid), - .len = Int_val(len), - }; + CAMLparam4(tid, rid, ty, len); + CAMLlocal1(ret); + struct xsd_sockmsg xsd = { + .type = Int_val(ty), + .tx_id = Int_val(tid), + .req_id = Int_val(rid), + .len = Int_val(len), + }; - ret = caml_alloc_string(sizeof(struct xsd_sockmsg)); - memcpy((char *) String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); + ret = caml_alloc_string(sizeof(struct xsd_sockmsg)); + memcpy((char *) String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); - CAMLreturn(ret); + CAMLreturn(ret); } diff --git a/tools/ocaml/libs/xb/xs_ring.ml b/tools/ocaml/libs/xb/xs_ring.ml index db7f86bd27..2a27aa56c2 100644 --- a/tools/ocaml/libs/xb/xs_ring.ml +++ b/tools/ocaml/libs/xb/xs_ring.ml @@ -15,14 +15,14 @@ *) module Server_feature = struct - type t = - | Reconnection + type t = + | Reconnection end module Server_features = Set.Make(struct - type t = Server_feature.t - let compare = compare -end) + type t = Server_feature.t + let compare = compare + end) external read: Xenmmap.mmap_interface -> bytes -> int -> int = "ml_interface_read" external write: Xenmmap.mmap_interface -> bytes -> int -> int = "ml_interface_write" @@ -31,18 +31,18 @@ external _internal_set_server_features: Xenmmap.mmap_interface -> int -> unit = external _internal_get_server_features: Xenmmap.mmap_interface -> int = "ml_interface_get_server_features" [@@noalloc] let write_substring mmap buff len = - write mmap (Bytes.unsafe_of_string buff) len + write mmap (Bytes.unsafe_of_string buff) len let get_server_features mmap = - (* NB only one feature currently defined above *) - let x = _internal_get_server_features mmap in - if x = 0 - then Server_features.empty - else Server_features.singleton Server_feature.Reconnection + (* NB only one feature currently defined above *) + let x = _internal_get_server_features mmap in + if x = 0 + then Server_features.empty + else Server_features.singleton Server_feature.Reconnection let set_server_features mmap set = - (* NB only one feature currently defined above *) - let x = if set = Server_features.empty then 0 else 1 in - _internal_set_server_features mmap x + (* NB only one feature currently defined above *) + let x = if set = Server_features.empty then 0 else 1 in + _internal_set_server_features mmap x external close: Xenmmap.mmap_interface -> unit = "ml_interface_close" [@@noalloc] diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_ring_stubs.c index cc9114029f..1e472d0bbf 100644 --- a/tools/ocaml/libs/xb/xs_ring_stubs.c +++ b/tools/ocaml/libs/xb/xs_ring_stubs.c @@ -49,153 +49,153 @@ CAMLprim value ml_interface_read(value ml_interface, value ml_buffer, value ml_len) { - CAMLparam3(ml_interface, ml_buffer, ml_len); - CAMLlocal1(ml_result); + CAMLparam3(ml_interface, ml_buffer, ml_len); + CAMLlocal1(ml_result); - struct mmap_interface *interface = GET_C_STRUCT(ml_interface); - unsigned char *buffer = Bytes_val(ml_buffer); - int len = Int_val(ml_len); - int result; + struct mmap_interface *interface = GET_C_STRUCT(ml_interface); + unsigned char *buffer = Bytes_val(ml_buffer); + int len = Int_val(ml_len); + int result; - struct xenstore_domain_interface *intf = interface->addr; - XENSTORE_RING_IDX cons, prod; /* offsets only */ - int total_data, data; - uint32_t connection; + struct xenstore_domain_interface *intf = interface->addr; + XENSTORE_RING_IDX cons, prod; /* offsets only */ + int total_data, data; + uint32_t connection; - cons = *(volatile uint32_t*)&intf->req_cons; - prod = *(volatile uint32_t*)&intf->req_prod; - connection = *(volatile uint32_t*)&intf->connection; + cons = *(volatile uint32_t*)&intf->req_cons; + prod = *(volatile uint32_t*)&intf->req_prod; + connection = *(volatile uint32_t*)&intf->connection; - if (connection != XENSTORE_CONNECTED) - caml_raise_constant(*caml_named_value("Xb.Reconnect")); + if (connection != XENSTORE_CONNECTED) + caml_raise_constant(*caml_named_value("Xb.Reconnect")); - xen_mb(); + xen_mb(); - if ((prod - cons) > XENSTORE_RING_SIZE) - caml_failwith("bad connection"); + if ((prod - cons) > XENSTORE_RING_SIZE) + caml_failwith("bad connection"); - /* Check for any pending data at all. */ - total_data = prod - cons; - if (total_data == 0) { - /* No pending data at all. */ - result = 0; - goto exit; - } - else if (total_data < len) - /* Some data - make a partial read. */ - len = total_data; + /* Check for any pending data at all. */ + total_data = prod - cons; + if (total_data == 0) { + /* No pending data at all. */ + result = 0; + goto exit; + } + else if (total_data < len) + /* Some data - make a partial read. */ + len = total_data; - /* Check whether data crosses the end of the ring. */ - data = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons); - if (len < data) - /* Data within the remaining part of the ring. */ - memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len); - else { - /* Data crosses the ring boundary. Read both halves. */ - memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), data); - memcpy(buffer + data, intf->req, len - data); - } + /* Check whether data crosses the end of the ring. */ + data = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons); + if (len < data) + /* Data within the remaining part of the ring. */ + memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len); + else { + /* Data crosses the ring boundary. Read both halves. */ + memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), data); + memcpy(buffer + data, intf->req, len - data); + } - xen_mb(); - intf->req_cons += len; - result = len; + xen_mb(); + intf->req_cons += len; + result = len; exit: - ml_result = Val_int(result); - CAMLreturn(ml_result); + ml_result = Val_int(result); + CAMLreturn(ml_result); } CAMLprim value ml_interface_write(value ml_interface, value ml_buffer, value ml_len) { - CAMLparam3(ml_interface, ml_buffer, ml_len); - CAMLlocal1(ml_result); + CAMLparam3(ml_interface, ml_buffer, ml_len); + CAMLlocal1(ml_result); - struct mmap_interface *interface = GET_C_STRUCT(ml_interface); - const unsigned char *buffer = Bytes_val(ml_buffer); - int len = Int_val(ml_len); - int result; + struct mmap_interface *interface = GET_C_STRUCT(ml_interface); + const unsigned char *buffer = Bytes_val(ml_buffer); + int len = Int_val(ml_len); + int result; - struct xenstore_domain_interface *intf = interface->addr; - XENSTORE_RING_IDX cons, prod; - int total_space, space; - uint32_t connection; + struct xenstore_domain_interface *intf = interface->addr; + XENSTORE_RING_IDX cons, prod; + int total_space, space; + uint32_t connection; - cons = *(volatile uint32_t*)&intf->rsp_cons; - prod = *(volatile uint32_t*)&intf->rsp_prod; - connection = *(volatile uint32_t*)&intf->connection; + cons = *(volatile uint32_t*)&intf->rsp_cons; + prod = *(volatile uint32_t*)&intf->rsp_prod; + connection = *(volatile uint32_t*)&intf->connection; - if (connection != XENSTORE_CONNECTED) - caml_raise_constant(*caml_named_value("Xb.Reconnect")); + if (connection != XENSTORE_CONNECTED) + caml_raise_constant(*caml_named_value("Xb.Reconnect")); - xen_mb(); + xen_mb(); - if ((prod - cons) > XENSTORE_RING_SIZE) - caml_failwith("bad connection"); + if ((prod - cons) > XENSTORE_RING_SIZE) + caml_failwith("bad connection"); - /* Check for space to write the full message. */ - total_space = XENSTORE_RING_SIZE - (prod - cons); - if (total_space == 0) { - /* No space at all - exit having done nothing. */ - result = 0; - goto exit; - } - else if (total_space < len) - /* Some space - make a partial write. */ - len = total_space; + /* Check for space to write the full message. */ + total_space = XENSTORE_RING_SIZE - (prod - cons); + if (total_space == 0) { + /* No space at all - exit having done nothing. */ + result = 0; + goto exit; + } + else if (total_space < len) + /* Some space - make a partial write. */ + len = total_space; - /* Check for space until the ring wraps. */ - space = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod); - if (len < space) - /* Message fits inside the remaining part of the ring. */ - memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len); - else { - /* Message wraps around the end of the ring. Write both halves. */ - memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, space); - memcpy(intf->rsp, buffer + space, len - space); - } + /* Check for space until the ring wraps. */ + space = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod); + if (len < space) + /* Message fits inside the remaining part of the ring. */ + memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len); + else { + /* Message wraps around the end of the ring. Write both halves. */ + memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, space); + memcpy(intf->rsp, buffer + space, len - space); + } - xen_mb(); - intf->rsp_prod += len; - result = len; + xen_mb(); + intf->rsp_prod += len; + result = len; exit: - ml_result = Val_int(result); - CAMLreturn(ml_result); + ml_result = Val_int(result); + CAMLreturn(ml_result); } CAMLprim value ml_interface_set_server_features(value interface, value v) { - CAMLparam2(interface, v); - struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; - if (intf == (void*)MAP_FAILED) - caml_failwith("Interface closed"); + CAMLparam2(interface, v); + struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; + if (intf == (void*)MAP_FAILED) + caml_failwith("Interface closed"); - intf->server_features = Int_val(v); + intf->server_features = Int_val(v); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value ml_interface_get_server_features(value interface) { - CAMLparam1(interface); - struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; + CAMLparam1(interface); + struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; - CAMLreturn(Val_int (intf->server_features)); + CAMLreturn(Val_int (intf->server_features)); } CAMLprim value ml_interface_close(value interface) { - CAMLparam1(interface); - struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; - int i; + CAMLparam1(interface); + struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; + int i; - intf->req_cons = intf->req_prod = intf->rsp_cons = intf->rsp_prod = 0; - /* Ensure the unused space is full of invalid xenstore packets. */ - for (i = 0; i < XENSTORE_RING_SIZE; i++) { - intf->req[i] = 0xff; /* XS_INVALID = 0xffff */ - intf->rsp[i] = 0xff; - } - xen_mb (); - intf->connection = XENSTORE_CONNECTED; - CAMLreturn(Val_unit); + intf->req_cons = intf->req_prod = intf->rsp_cons = intf->rsp_prod = 0; + /* Ensure the unused space is full of invalid xenstore packets. */ + for (i = 0; i < XENSTORE_RING_SIZE; i++) { + intf->req[i] = 0xff; /* XS_INVALID = 0xffff */ + intf->rsp[i] = 0xff; + } + xen_mb (); + intf->connection = XENSTORE_CONNECTED; + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/libs/xc/abi-check b/tools/ocaml/libs/xc/abi-check index 3cbdec582f..dc5bfd6cd8 100755 --- a/tools/ocaml/libs/xc/abi-check +++ b/tools/ocaml/libs/xc/abi-check @@ -39,7 +39,7 @@ while (<C_FILE>) { } } else { $cline++; - m{^\s+/\* \s+ ! \s+ (.*?) \s* \*/\s*$}x or + m{^\s*/\*\s+! \s+ (.*?) \s* \*/\s*$}x or die "at line $cline of annotation, did not expect $_ ?"; my @vals = split /\s+/, $1; if ($cline == 1 && !@vals) { diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml index 28ed642231..2ad4a671a5 100644 --- a/tools/ocaml/libs/xc/xenctrl.ml +++ b/tools/ocaml/libs/xc/xenctrl.ml @@ -20,157 +20,157 @@ type domid = int (* ** xenctrl.h ** *) type vcpuinfo = -{ - online: bool; - blocked: bool; - running: bool; - cputime: int64; - cpumap: int32; -} + { + online: bool; + blocked: bool; + running: bool; + cputime: int64; + cpumap: int32; + } type xen_arm_arch_domainconfig = -{ - gic_version: int; - nr_spis: int; - clock_frequency: int32; -} + { + gic_version: int; + nr_spis: int; + clock_frequency: int32; + } type x86_arch_emulation_flags = - | X86_EMU_LAPIC - | X86_EMU_HPET - | X86_EMU_PM - | X86_EMU_RTC - | X86_EMU_IOAPIC - | X86_EMU_PIC - | X86_EMU_VGA - | X86_EMU_IOMMU - | X86_EMU_PIT - | X86_EMU_USE_PIRQ - | X86_EMU_VPCI + | X86_EMU_LAPIC + | X86_EMU_HPET + | X86_EMU_PM + | X86_EMU_RTC + | X86_EMU_IOAPIC + | X86_EMU_PIC + | X86_EMU_VGA + | X86_EMU_IOMMU + | X86_EMU_PIT + | X86_EMU_USE_PIRQ + | X86_EMU_VPCI type x86_arch_misc_flags = - | X86_MSR_RELAXED - | X86_ASSISTED_XAPIC - | X86_ASSISTED_X2APIC + | X86_MSR_RELAXED + | X86_ASSISTED_XAPIC + | X86_ASSISTED_X2APIC type xen_x86_arch_domainconfig = -{ - emulation_flags: x86_arch_emulation_flags list; - misc_flags: x86_arch_misc_flags list; -} + { + emulation_flags: x86_arch_emulation_flags list; + misc_flags: x86_arch_misc_flags list; + } type arch_domainconfig = - | ARM of xen_arm_arch_domainconfig - | X86 of xen_x86_arch_domainconfig + | ARM of xen_arm_arch_domainconfig + | X86 of xen_x86_arch_domainconfig type domain_create_flag = - | CDF_HVM - | CDF_HAP - | CDF_S3_INTEGRITY - | CDF_OOS_OFF - | CDF_XS_DOMAIN - | CDF_IOMMU - | CDF_NESTED_VIRT - | CDF_VPMU + | CDF_HVM + | CDF_HAP + | CDF_S3_INTEGRITY + | CDF_OOS_OFF + | CDF_XS_DOMAIN + | CDF_IOMMU + | CDF_NESTED_VIRT + | CDF_VPMU type domain_create_iommu_opts = - | IOMMU_NO_SHAREPT + | IOMMU_NO_SHAREPT type domctl_create_config = -{ - ssidref: int32; - handle: string; - flags: domain_create_flag list; - iommu_opts: domain_create_iommu_opts list; - max_vcpus: int; - max_evtchn_port: int; - max_grant_frames: int; - max_maptrack_frames: int; - max_grant_version: int; - cpupool_id: int32; - arch: arch_domainconfig; -} + { + ssidref: int32; + handle: string; + flags: domain_create_flag list; + iommu_opts: domain_create_iommu_opts list; + max_vcpus: int; + max_evtchn_port: int; + max_grant_frames: int; + max_maptrack_frames: int; + max_grant_version: int; + cpupool_id: int32; + arch: arch_domainconfig; + } type domaininfo = -{ - domid : domid; - dying : bool; - shutdown : bool; - paused : bool; - blocked : bool; - running : bool; - hvm_guest : bool; - shutdown_code : int; - total_memory_pages: nativeint; - max_memory_pages : nativeint; - shared_info_frame : int64; - cpu_time : int64; - nr_online_vcpus : int; - max_vcpu_id : int; - ssidref : int32; - handle : int array; - arch_config : arch_domainconfig; -} + { + domid : domid; + dying : bool; + shutdown : bool; + paused : bool; + blocked : bool; + running : bool; + hvm_guest : bool; + shutdown_code : int; + total_memory_pages: nativeint; + max_memory_pages : nativeint; + shared_info_frame : int64; + cpu_time : int64; + nr_online_vcpus : int; + max_vcpu_id : int; + ssidref : int32; + handle : int array; + arch_config : arch_domainconfig; + } type sched_control = -{ - weight : int; - cap : int; -} + { + weight : int; + cap : int; + } type physinfo_cap_flag = - | CAP_HVM - | CAP_PV - | CAP_DirectIO - | CAP_HAP - | CAP_Shadow - | CAP_IOMMU_HAP_PT_SHARE - | CAP_Vmtrace - | CAP_Vpmu - | CAP_Gnttab_v1 - | CAP_Gnttab_v2 + | CAP_HVM + | CAP_PV + | CAP_DirectIO + | CAP_HAP + | CAP_Shadow + | CAP_IOMMU_HAP_PT_SHARE + | CAP_Vmtrace + | CAP_Vpmu + | CAP_Gnttab_v1 + | CAP_Gnttab_v2 type arm_physinfo_cap_flag type x86_physinfo_cap_flag = - | CAP_X86_ASSISTED_XAPIC - | CAP_X86_ASSISTED_X2APIC + | CAP_X86_ASSISTED_XAPIC + | CAP_X86_ASSISTED_X2APIC type arch_physinfo_cap_flags = - | ARM of arm_physinfo_cap_flag list - | X86 of x86_physinfo_cap_flag list + | ARM of arm_physinfo_cap_flag list + | X86 of x86_physinfo_cap_flag list type physinfo = -{ - threads_per_core : int; - cores_per_socket : int; - nr_cpus : int; - max_node_id : int; - cpu_khz : int; - total_pages : nativeint; - free_pages : nativeint; - scrub_pages : nativeint; - (* XXX hw_cap *) - capabilities : physinfo_cap_flag list; - max_nr_cpus : int; - arch_capabilities : arch_physinfo_cap_flags; -} + { + threads_per_core : int; + cores_per_socket : int; + nr_cpus : int; + max_node_id : int; + cpu_khz : int; + total_pages : nativeint; + free_pages : nativeint; + scrub_pages : nativeint; + (* XXX hw_cap *) + capabilities : physinfo_cap_flag list; + max_nr_cpus : int; + arch_capabilities : arch_physinfo_cap_flags; + } type version = -{ - major : int; - minor : int; - extra : string; -} + { + major : int; + minor : int; + extra : string; + } type compile_info = -{ - compiler : string; - compile_by : string; - compile_domain : string; - compile_date : string; -} + { + compiler : string; + compile_by : string; + compile_domain : string; + compile_date : string; + } type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Watchdog | Soft_reset @@ -186,34 +186,34 @@ let handle = ref None let get_handle () = !handle let close_handle () = - match !handle with - | Some h -> handle := None; interface_close h - | None -> () + match !handle with + | Some h -> handle := None; interface_close h + | None -> () let with_intf f = - match !handle with - | Some h -> f h - | None -> - let h = - try interface_open () with - | e -> - let msg = Printexc.to_string e in - failwith ("failed to open xenctrl: "^msg) - in - handle := Some h; - f h + match !handle with + | Some h -> f h + | None -> + let h = + try interface_open () with + | e -> + let msg = Printexc.to_string e in + failwith ("failed to open xenctrl: "^msg) + in + handle := Some h; + f h external domain_create_stub: handle -> domid -> domctl_create_config -> domid - = "stub_xc_domain_create" + = "stub_xc_domain_create" let domain_create handle ?(domid=0) config = - domain_create_stub handle domid config + domain_create_stub handle domid config external domain_sethandle: handle -> domid -> string -> unit - = "stub_xc_domain_sethandle" + = "stub_xc_domain_sethandle" external domain_max_vcpus: handle -> domid -> int -> unit - = "stub_xc_domain_max_vcpus" + = "stub_xc_domain_max_vcpus" external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause" external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause" @@ -221,54 +221,54 @@ external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fa external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy" external domain_shutdown: handle -> domid -> shutdown_reason -> unit - = "stub_xc_domain_shutdown" + = "stub_xc_domain_shutdown" external _domain_getinfolist: handle -> domid -> int -> domaininfo list - = "stub_xc_domain_getinfolist" + = "stub_xc_domain_getinfolist" let domain_getinfolist handle first_domain = - let nb = 2 in - let last_domid l = (List.hd l).domid + 1 in - let rec __getlist from = - let l = _domain_getinfolist handle from nb in - (if List.length l = nb then __getlist (last_domid l) else []) @ l - in - List.rev (__getlist first_domain) + let nb = 2 in + let last_domid l = (List.hd l).domid + 1 in + let rec __getlist from = + let l = _domain_getinfolist handle from nb in + (if List.length l = nb then __getlist (last_domid l) else []) @ l + in + List.rev (__getlist first_domain) external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo" external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo - = "stub_xc_vcpu_getinfo" + = "stub_xc_vcpu_getinfo" external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit - = "stub_xc_domain_ioport_permission" + = "stub_xc_domain_ioport_permission" external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit - = "stub_xc_domain_iomem_permission" + = "stub_xc_domain_iomem_permission" external domain_irq_permission: handle -> domid -> int -> bool -> unit - = "stub_xc_domain_irq_permission" + = "stub_xc_domain_irq_permission" external vcpu_affinity_set: handle -> domid -> int -> bool array -> unit - = "stub_xc_vcpu_setaffinity" + = "stub_xc_vcpu_setaffinity" external vcpu_affinity_get: handle -> domid -> int -> bool array - = "stub_xc_vcpu_getaffinity" + = "stub_xc_vcpu_getaffinity" external vcpu_context_get: handle -> domid -> int -> string - = "stub_xc_vcpu_context_get" + = "stub_xc_vcpu_context_get" external sched_id: handle -> int = "stub_xc_sched_id" external sched_credit_domain_set: handle -> domid -> sched_control -> unit - = "stub_sched_credit_domain_set" + = "stub_sched_credit_domain_set" external sched_credit_domain_get: handle -> domid -> sched_control - = "stub_sched_credit_domain_get" + = "stub_sched_credit_domain_get" external shadow_allocation_set: handle -> domid -> int -> unit - = "stub_shadow_allocation_set" + = "stub_shadow_allocation_set" external shadow_allocation_get: handle -> domid -> int - = "stub_shadow_allocation_get" + = "stub_shadow_allocation_get" external evtchn_alloc_unbound: handle -> domid -> domid -> int - = "stub_xc_evtchn_alloc_unbound" + = "stub_xc_evtchn_alloc_unbound" external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset" external readconsolering: handle -> string = "stub_xc_readconsolering" @@ -278,26 +278,26 @@ external physinfo: handle -> physinfo = "stub_xc_physinfo" external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info" external domain_setmaxmem: handle -> domid -> int64 -> unit - = "stub_xc_domain_setmaxmem" + = "stub_xc_domain_setmaxmem" external domain_set_memmap_limit: handle -> domid -> int64 -> unit - = "stub_xc_domain_set_memmap_limit" + = "stub_xc_domain_set_memmap_limit" external domain_memory_increase_reservation: handle -> domid -> int64 -> unit - = "stub_xc_domain_memory_increase_reservation" + = "stub_xc_domain_memory_increase_reservation" external map_foreign_range: handle -> domid -> int - -> nativeint -> Xenmmap.mmap_interface - = "stub_map_foreign_range" + -> nativeint -> Xenmmap.mmap_interface + = "stub_map_foreign_range" external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit - = "stub_xc_domain_assign_device" + = "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit - = "stub_xc_domain_deassign_device" + = "stub_xc_domain_deassign_device" external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool - = "stub_xc_domain_test_assign_device" + = "stub_xc_domain_test_assign_device" external version: handle -> version = "stub_xc_version_version" external version_compile_info: handle -> compile_info - = "stub_xc_version_compile_info" + = "stub_xc_version_compile_info" external version_changeset: handle -> string = "stub_xc_version_changeset" external version_capabilities: handle -> string = "stub_xc_version_capabilities" @@ -312,7 +312,7 @@ external watchdog : handle -> int -> int32 -> int (** Convert the given number of pages to an amount in KiB, rounded up. - *) +*) external pages_to_kib : int64 -> int64 = "stub_pages_to_kib" let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli index c2076d60c9..dd8d0aefcf 100644 --- a/tools/ocaml/libs/xc/xenctrl.mli +++ b/tools/ocaml/libs/xc/xenctrl.mli @@ -187,11 +187,11 @@ external domain_getinfo : handle -> domid -> domaininfo external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo = "stub_xc_vcpu_getinfo" external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit - = "stub_xc_domain_ioport_permission" + = "stub_xc_domain_ioport_permission" external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit - = "stub_xc_domain_iomem_permission" + = "stub_xc_domain_iomem_permission" external domain_irq_permission: handle -> domid -> int -> bool -> unit - = "stub_xc_domain_irq_permission" + = "stub_xc_domain_irq_permission" external vcpu_affinity_set : handle -> domid -> int -> bool array -> unit = "stub_xc_vcpu_setaffinity" external vcpu_affinity_get : handle -> domid -> int -> bool array @@ -226,11 +226,11 @@ external map_foreign_range : = "stub_map_foreign_range" external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit - = "stub_xc_domain_assign_device" + = "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit - = "stub_xc_domain_deassign_device" + = "stub_xc_domain_deassign_device" external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool - = "stub_xc_domain_test_assign_device" + = "stub_xc_domain_test_assign_device" external version : handle -> version = "stub_xc_version_version" external version_compile_info : handle -> compile_info diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c b/tools/ocaml/libs/xc/xenctrl_stubs.c index 8cd11060ec..e2d897581f 100644 --- a/tools/ocaml/libs/xc/xenctrl_stubs.c +++ b/tools/ocaml/libs/xc/xenctrl_stubs.c @@ -45,71 +45,71 @@ #endif #define string_of_option_array(array, index) \ - ((Field(array, index) == Val_none) ? NULL : String_val(Field(Field(array, index), 0))) + ((Field(array, index) == Val_none) ? NULL : String_val(Field(Field(array, index), 0))) static void Noreturn failwith_xc(xc_interface *xch) { - char error_str[XC_MAX_ERROR_MSG_LEN + 6]; - if (xch) { - const xc_error *error = xc_get_last_error(xch); - if (error->code == XC_ERROR_NONE) - snprintf(error_str, sizeof(error_str), - "%d: %s", errno, strerror(errno)); - else - snprintf(error_str, sizeof(error_str), - "%d: %s: %s", error->code, - xc_error_code_to_desc(error->code), - error->message); - } else { - snprintf(error_str, sizeof(error_str), - "Unable to open XC interface"); - } - caml_raise_with_string(*caml_named_value("xc.error"), error_str); + char error_str[XC_MAX_ERROR_MSG_LEN + 6]; + if (xch) { + const xc_error *error = xc_get_last_error(xch); + if (error->code == XC_ERROR_NONE) + snprintf(error_str, sizeof(error_str), + "%d: %s", errno, strerror(errno)); + else + snprintf(error_str, sizeof(error_str), + "%d: %s: %s", error->code, + xc_error_code_to_desc(error->code), + error->message); + } else { + snprintf(error_str, sizeof(error_str), + "Unable to open XC interface"); + } + caml_raise_with_string(*caml_named_value("xc.error"), error_str); } CAMLprim value stub_xc_interface_open(void) { - CAMLparam0(); - CAMLlocal1(result); + CAMLparam0(); + CAMLlocal1(result); - result = caml_alloc(1, Abstract_tag); - /* Don't assert XC_OPENFLAG_NON_REENTRANT because these bindings - * do not prevent re-entrancy to libxc */ - _H(result) = xc_interface_open(NULL, NULL, 0); - if (_H(result) == NULL) - failwith_xc(NULL); - CAMLreturn(result); + result = caml_alloc(1, Abstract_tag); + /* Don't assert XC_OPENFLAG_NON_REENTRANT because these bindings + * do not prevent re-entrancy to libxc */ + _H(result) = xc_interface_open(NULL, NULL, 0); + if (_H(result) == NULL) + failwith_xc(NULL); + CAMLreturn(result); } CAMLprim value stub_xc_interface_close(value xch) { - CAMLparam1(xch); + CAMLparam1(xch); - caml_enter_blocking_section(); - xc_interface_close(_H(xch)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + xc_interface_close(_H(xch)); + caml_leave_blocking_section(); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static void domain_handle_of_uuid_string(xen_domain_handle_t h, - const char *uuid) + const char *uuid) { #define X "%02"SCNx8 #define UUID_FMT (X X X X "-" X X "-" X X "-" X X "-" X X X X X X) - if ( sscanf(uuid, UUID_FMT, &h[0], &h[1], &h[2], &h[3], &h[4], - &h[5], &h[6], &h[7], &h[8], &h[9], &h[10], &h[11], - &h[12], &h[13], &h[14], &h[15]) != 16 ) - { - char buf[128]; + if ( sscanf(uuid, UUID_FMT, &h[0], &h[1], &h[2], &h[3], &h[4], + &h[5], &h[6], &h[7], &h[8], &h[9], &h[10], &h[11], + &h[12], &h[13], &h[14], &h[15]) != 16 ) + { + char buf[128]; - snprintf(buf, sizeof(buf), - "Xc.int_array_of_uuid_string: %s", uuid); + snprintf(buf, sizeof(buf), + "Xc.int_array_of_uuid_string: %s", uuid); - caml_invalid_argument(buf); - } + caml_invalid_argument(buf); + } #undef X } @@ -121,13 +121,13 @@ static void domain_handle_of_uuid_string(xen_domain_handle_t h, static value c_bitmap_to_ocaml_list /* ! */ /* - * All calls to this function must be in a form suitable - * for xenctrl_abi_check. The parsing there is ad-hoc. - */ + * All calls to this function must be in a form suitable + * for xenctrl_abi_check. The parsing there is ad-hoc. + */ (unsigned int bitmap) { - CAMLparam0(); - CAMLlocal2(list, tmp); + CAMLparam0(); + CAMLlocal2(list, tmp); #if defined(__i386__) || defined(__x86_64__) /* @@ -144,43 +144,43 @@ static value c_bitmap_to_ocaml_list #include "xenctrl_abi_check.h" #endif - list = tmp = Val_emptylist; + list = tmp = Val_emptylist; - for ( unsigned int i = 0; bitmap; i++, bitmap >>= 1 ) - { - if ( !(bitmap & 1) ) - continue; + for ( unsigned int i = 0; bitmap; i++, bitmap >>= 1 ) + { + if ( !(bitmap & 1) ) + continue; - tmp = caml_alloc_small(2, Tag_cons); - Field(tmp, 0) = Val_int(i); - Field(tmp, 1) = list; - list = tmp; - } + tmp = caml_alloc_small(2, Tag_cons); + Field(tmp, 0) = Val_int(i); + Field(tmp, 1) = list; + list = tmp; + } - CAMLreturn(list); + CAMLreturn(list); } static unsigned int ocaml_list_to_c_bitmap(value l) /* ! */ /* - * All calls to this function must be in a form suitable - * for xenctrl_abi_check. The parsing there is ad-hoc. - */ + * All calls to this function must be in a form suitable + * for xenctrl_abi_check. The parsing there is ad-hoc. + */ { - unsigned int val = 0; + unsigned int val = 0; - for ( ; l != Val_none; l = Field(l, 1) ) - val |= 1u << Int_val(Field(l, 0)); + for ( ; l != Val_none; l = Field(l, 1) ) + val |= 1u << Int_val(Field(l, 0)); - return val; + return val; } CAMLprim value stub_xc_domain_create(value xch, value wanted_domid, value config) { - CAMLparam3(xch, wanted_domid, config); - CAMLlocal2(l, arch_domconfig); + CAMLparam3(xch, wanted_domid, config); + CAMLlocal2(l, arch_domconfig); - /* Mnemonics for the named fields inside domctl_create_config */ + /* Mnemonics for the named fields inside domctl_create_config */ #define VAL_SSIDREF Field(config, 0) #define VAL_HANDLE Field(config, 1) #define VAL_FLAGS Field(config, 2) @@ -193,69 +193,69 @@ CAMLprim value stub_xc_domain_create(value xch, value wanted_domid, value config #define VAL_CPUPOOL_ID Field(config, 9) #define VAL_ARCH Field(config, 10) - uint32_t domid = Int_val(wanted_domid); - int result; - struct xen_domctl_createdomain cfg = { - .ssidref = Int32_val(VAL_SSIDREF), - .max_vcpus = Int_val(VAL_MAX_VCPUS), - .max_evtchn_port = Int_val(VAL_MAX_EVTCHN_PORT), - .max_grant_frames = Int_val(VAL_MAX_GRANT_FRAMES), - .max_maptrack_frames = Int_val(VAL_MAX_MAPTRACK_FRAMES), - .grant_opts = - XEN_DOMCTL_GRANT_version(Int_val(VAL_MAX_GRANT_VERSION)), - .cpupool_id = Int32_val(VAL_CPUPOOL_ID), - }; + uint32_t domid = Int_val(wanted_domid); + int result; + struct xen_domctl_createdomain cfg = { + .ssidref = Int32_val(VAL_SSIDREF), + .max_vcpus = Int_val(VAL_MAX_VCPUS), + .max_evtchn_port = Int_val(VAL_MAX_EVTCHN_PORT), + .max_grant_frames = Int_val(VAL_MAX_GRANT_FRAMES), + .max_maptrack_frames = Int_val(VAL_MAX_MAPTRACK_FRAMES), + .grant_opts = + XEN_DOMCTL_GRANT_version(Int_val(VAL_MAX_GRANT_VERSION)), + .cpupool_id = Int32_val(VAL_CPUPOOL_ID), + }; - domain_handle_of_uuid_string(cfg.handle, String_val(VAL_HANDLE)); + domain_handle_of_uuid_string(cfg.handle, String_val(VAL_HANDLE)); - cfg.flags = ocaml_list_to_c_bitmap - /* ! domain_create_flag CDF_ lc */ - /* ! XEN_DOMCTL_CDF_ XEN_DOMCTL_CDF_MAX max */ - (VAL_FLAGS); + cfg.flags = ocaml_list_to_c_bitmap + /* ! domain_create_flag CDF_ lc */ + /* ! XEN_DOMCTL_CDF_ XEN_DOMCTL_CDF_MAX max */ + (VAL_FLAGS); - cfg.iommu_opts = ocaml_list_to_c_bitmap - /* ! domain_create_iommu_opts IOMMU_ lc */ - /* ! XEN_DOMCTL_IOMMU_ XEN_DOMCTL_IOMMU_MAX max */ - (VAL_IOMMU_OPTS); + cfg.iommu_opts = ocaml_list_to_c_bitmap + /* ! domain_create_iommu_opts IOMMU_ lc */ + /* ! XEN_DOMCTL_IOMMU_ XEN_DOMCTL_IOMMU_MAX max */ + (VAL_IOMMU_OPTS); - arch_domconfig = Field(VAL_ARCH, 0); - switch ( Tag_val(VAL_ARCH) ) - { - case 0: /* ARM - nothing to do */ - caml_failwith("Unhandled: ARM"); - break; + arch_domconfig = Field(VAL_ARCH, 0); + switch ( Tag_val(VAL_ARCH) ) + { + case 0: /* ARM - nothing to do */ + caml_failwith("Unhandled: ARM"); + break; - case 1: /* X86 - emulation flags in the block */ + case 1: /* X86 - emulation flags in the block */ #if defined(__i386__) || defined(__x86_64__) - /* Quick & dirty check for ABI changes. */ - BUILD_BUG_ON(sizeof(cfg) != 64); + /* Quick & dirty check for ABI changes. */ + BUILD_BUG_ON(sizeof(cfg) != 64); /* Mnemonics for the named fields inside xen_x86_arch_domainconfig */ #define VAL_EMUL_FLAGS Field(arch_domconfig, 0) #define VAL_MISC_FLAGS Field(arch_domconfig, 1) - cfg.arch.emulation_flags = ocaml_list_to_c_bitmap - /* ! x86_arch_emulation_flags X86_EMU_ none */ - /* ! XEN_X86_EMU_ XEN_X86_EMU_ALL all */ - (VAL_EMUL_FLAGS); + cfg.arch.emulation_flags = ocaml_list_to_c_bitmap + /* ! x86_arch_emulation_flags X86_EMU_ none */ + /* ! XEN_X86_EMU_ XEN_X86_EMU_ALL all */ + (VAL_EMUL_FLAGS); - cfg.arch.misc_flags = ocaml_list_to_c_bitmap - /* ! x86_arch_misc_flags X86_ none */ - /* ! XEN_X86_ XEN_X86_MISC_FLAGS_MAX max */ - (VAL_MISC_FLAGS); + cfg.arch.misc_flags = ocaml_list_to_c_bitmap + /* ! x86_arch_misc_flags X86_ none */ + /* ! XEN_X86_ XEN_X86_MISC_FLAGS_MAX max */ + (VAL_MISC_FLAGS); #undef VAL_MISC_FLAGS #undef VAL_EMUL_FLAGS #else - caml_failwith("Unhandled: x86"); + caml_failwith("Unhandled: x86"); #endif - break; + break; - default: - caml_failwith("Unhandled domconfig type"); - } + default: + caml_failwith("Unhandled domconfig type"); + } #undef VAL_ARCH #undef VAL_CPUPOOL_ID @@ -269,875 +269,875 @@ CAMLprim value stub_xc_domain_create(value xch, value wanted_domid, value config #undef VAL_HANDLE #undef VAL_SSIDREF - caml_enter_blocking_section(); - result = xc_domain_create(_H(xch), &domid, &cfg); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result = xc_domain_create(_H(xch), &domid, &cfg); + caml_leave_blocking_section(); - if (result < 0) - failwith_xc(_H(xch)); + if (result < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_int(domid)); + CAMLreturn(Val_int(domid)); } CAMLprim value stub_xc_domain_max_vcpus(value xch, value domid, value max_vcpus) { - CAMLparam3(xch, domid, max_vcpus); - int r; + CAMLparam3(xch, domid, max_vcpus); + int r; - r = xc_domain_max_vcpus(_H(xch), _D(domid), Int_val(max_vcpus)); - if (r) - failwith_xc(_H(xch)); + r = xc_domain_max_vcpus(_H(xch), _D(domid), Int_val(max_vcpus)); + if (r) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_xc_domain_sethandle(value xch, value domid, value handle) { - CAMLparam3(xch, domid, handle); - xen_domain_handle_t h; - int i; + CAMLparam3(xch, domid, handle); + xen_domain_handle_t h; + int i; - domain_handle_of_uuid_string(h, String_val(handle)); + domain_handle_of_uuid_string(h, String_val(handle)); - i = xc_domain_sethandle(_H(xch), _D(domid), h); - if (i) - failwith_xc(_H(xch)); + i = xc_domain_sethandle(_H(xch), _D(domid), h); + if (i) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static value dom_op(value xch, value domid, int (*fn)(xc_interface *, uint32_t)) { - CAMLparam2(xch, domid); - int result; + CAMLparam2(xch, domid); + int result; - uint32_t c_domid = _D(domid); + uint32_t c_domid = _D(domid); - caml_enter_blocking_section(); - result = fn(_H(xch), c_domid); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result = fn(_H(xch), c_domid); + caml_leave_blocking_section(); if (result) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_pause(value xch, value domid) { - return dom_op(xch, domid, xc_domain_pause); + return dom_op(xch, domid, xc_domain_pause); } CAMLprim value stub_xc_domain_unpause(value xch, value domid) { - return dom_op(xch, domid, xc_domain_unpause); + return dom_op(xch, domid, xc_domain_unpause); } CAMLprim value stub_xc_domain_destroy(value xch, value domid) { - return dom_op(xch, domid, xc_domain_destroy); + return dom_op(xch, domid, xc_domain_destroy); } CAMLprim value stub_xc_domain_resume_fast(value xch, value domid) { - CAMLparam2(xch, domid); - int result; + CAMLparam2(xch, domid); + int result; - uint32_t c_domid = _D(domid); + uint32_t c_domid = _D(domid); - caml_enter_blocking_section(); - result = xc_domain_resume(_H(xch), c_domid, 1); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result = xc_domain_resume(_H(xch), c_domid, 1); + caml_leave_blocking_section(); if (result) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_shutdown(value xch, value domid, value reason) { - CAMLparam3(xch, domid, reason); - int ret; + CAMLparam3(xch, domid, reason); + int ret; - ret = xc_domain_shutdown(_H(xch), _D(domid), Int_val(reason)); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_domain_shutdown(_H(xch), _D(domid), Int_val(reason)); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static value alloc_domaininfo(xc_domaininfo_t * info) { - CAMLparam0(); - CAMLlocal5(result, tmp, arch_config, x86_arch_config, emul_list); - int i; + CAMLparam0(); + CAMLlocal5(result, tmp, arch_config, x86_arch_config, emul_list); + int i; - result = caml_alloc_tuple(17); + result = caml_alloc_tuple(17); - Store_field(result, 0, Val_int(info->domain)); - Store_field(result, 1, Val_bool(info->flags & XEN_DOMINF_dying)); - Store_field(result, 2, Val_bool(info->flags & XEN_DOMINF_shutdown)); - Store_field(result, 3, Val_bool(info->flags & XEN_DOMINF_paused)); - Store_field(result, 4, Val_bool(info->flags & XEN_DOMINF_blocked)); - Store_field(result, 5, Val_bool(info->flags & XEN_DOMINF_running)); - Store_field(result, 6, Val_bool(info->flags & XEN_DOMINF_hvm_guest)); - Store_field(result, 7, Val_int((info->flags >> XEN_DOMINF_shutdownshift) - & XEN_DOMINF_shutdownmask)); - Store_field(result, 8, caml_copy_nativeint(info->tot_pages)); - Store_field(result, 9, caml_copy_nativeint(info->max_pages)); - Store_field(result, 10, caml_copy_int64(info->shared_info_frame)); - Store_field(result, 11, caml_copy_int64(info->cpu_time)); - Store_field(result, 12, Val_int(info->nr_online_vcpus)); - Store_field(result, 13, Val_int(info->max_vcpu_id)); - Store_field(result, 14, caml_copy_int32(info->ssidref)); + Store_field(result, 0, Val_int(info->domain)); + Store_field(result, 1, Val_bool(info->flags & XEN_DOMINF_dying)); + Store_field(result, 2, Val_bool(info->flags & XEN_DOMINF_shutdown)); + Store_field(result, 3, Val_bool(info->flags & XEN_DOMINF_paused)); + Store_field(result, 4, Val_bool(info->flags & XEN_DOMINF_blocked)); + Store_field(result, 5, Val_bool(info->flags & XEN_DOMINF_running)); + Store_field(result, 6, Val_bool(info->flags & XEN_DOMINF_hvm_guest)); + Store_field(result, 7, Val_int((info->flags >> XEN_DOMINF_shutdownshift) + & XEN_DOMINF_shutdownmask)); + Store_field(result, 8, caml_copy_nativeint(info->tot_pages)); + Store_field(result, 9, caml_copy_nativeint(info->max_pages)); + Store_field(result, 10, caml_copy_int64(info->shared_info_frame)); + Store_field(result, 11, caml_copy_int64(info->cpu_time)); + Store_field(result, 12, Val_int(info->nr_online_vcpus)); + Store_field(result, 13, Val_int(info->max_vcpu_id)); + Store_field(result, 14, caml_copy_int32(info->ssidref)); tmp = caml_alloc_small(16, 0); - for (i = 0; i < 16; i++) { - Field(tmp, i) = Val_int(info->handle[i]); - } + for (i = 0; i < 16; i++) { + Field(tmp, i) = Val_int(info->handle[i]); + } - Store_field(result, 15, tmp); + Store_field(result, 15, tmp); #if defined(__i386__) || defined(__x86_64__) - /* - * emulation_flags: x86_arch_emulation_flags list; - */ - emul_list = c_bitmap_to_ocaml_list - /* ! x86_arch_emulation_flags */ - (info->arch_config.emulation_flags); + /* + * emulation_flags: x86_arch_emulation_flags list; + */ + emul_list = c_bitmap_to_ocaml_list + /* ! x86_arch_emulation_flags */ + (info->arch_config.emulation_flags); - /* xen_x86_arch_domainconfig */ - x86_arch_config = caml_alloc_tuple(1); - Store_field(x86_arch_config, 0, emul_list); + /* xen_x86_arch_domainconfig */ + x86_arch_config = caml_alloc_tuple(1); + Store_field(x86_arch_config, 0, emul_list); - /* arch_config: arch_domainconfig */ - arch_config = caml_alloc_small(1, 1); + /* arch_config: arch_domainconfig */ + arch_config = caml_alloc_small(1, 1); - Store_field(arch_config, 0, x86_arch_config); + Store_field(arch_config, 0, x86_arch_config); - Store_field(result, 16, arch_config); + Store_field(result, 16, arch_config); #endif - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_xc_domain_getinfolist(value xch, value first_domain, value nb) { - CAMLparam3(xch, first_domain, nb); - CAMLlocal2(result, temp); - xc_domaininfo_t * info; - int i, ret, toalloc, retval; - unsigned int c_max_domains; - uint32_t c_first_domain; + CAMLparam3(xch, first_domain, nb); + CAMLlocal2(result, temp); + xc_domaininfo_t * info; + int i, ret, toalloc, retval; + unsigned int c_max_domains; + uint32_t c_first_domain; - /* get the minimum number of allocate byte we need and bump it up to page boundary */ - toalloc = (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff; - ret = posix_memalign((void **) ((void *) &info), 4096, toalloc); - if (ret) - caml_raise_out_of_memory(); + /* get the minimum number of allocate byte we need and bump it up to page boundary */ + toalloc = (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff; + ret = posix_memalign((void **) ((void *) &info), 4096, toalloc); + if (ret) + caml_raise_out_of_memory(); - result = temp = Val_emptylist; + result = temp = Val_emptylist; - c_first_domain = _D(first_domain); - c_max_domains = Int_val(nb); - caml_enter_blocking_section(); - retval = xc_domain_getinfolist(_H(xch), c_first_domain, - c_max_domains, info); - caml_leave_blocking_section(); + c_first_domain = _D(first_domain); + c_max_domains = Int_val(nb); + caml_enter_blocking_section(); + retval = xc_domain_getinfolist(_H(xch), c_first_domain, + c_max_domains, info); + caml_leave_blocking_section(); - if (retval < 0) { - free(info); - failwith_xc(_H(xch)); - } - for (i = 0; i < retval; i++) { - result = caml_alloc_small(2, Tag_cons); - Field(result, 0) = Val_int(0); - Field(result, 1) = temp; - temp = result; + if (retval < 0) { + free(info); + failwith_xc(_H(xch)); + } + for (i = 0; i < retval; i++) { + result = caml_alloc_small(2, Tag_cons); + Field(result, 0) = Val_int(0); + Field(result, 1) = temp; + temp = result; - Store_field(result, 0, alloc_domaininfo(info + i)); - } + Store_field(result, 0, alloc_domaininfo(info + i)); + } - free(info); - CAMLreturn(result); + free(info); + CAMLreturn(result); } CAMLprim value stub_xc_domain_getinfo(value xch, value domid) { - CAMLparam2(xch, domid); - CAMLlocal1(result); - xc_domaininfo_t info; - int ret; + CAMLparam2(xch, domid); + CAMLlocal1(result); + xc_domaininfo_t info; + int ret; - ret = xc_domain_getinfolist(_H(xch), _D(domid), 1, &info); - if (ret != 1) - failwith_xc(_H(xch)); - if (info.domain != _D(domid)) - failwith_xc(_H(xch)); + ret = xc_domain_getinfolist(_H(xch), _D(domid), 1, &info); + if (ret != 1) + failwith_xc(_H(xch)); + if (info.domain != _D(domid)) + failwith_xc(_H(xch)); - result = alloc_domaininfo(&info); - CAMLreturn(result); + result = alloc_domaininfo(&info); + CAMLreturn(result); } CAMLprim value stub_xc_vcpu_getinfo(value xch, value domid, value vcpu) { - CAMLparam3(xch, domid, vcpu); - CAMLlocal1(result); - xc_vcpuinfo_t info; - int retval; + CAMLparam3(xch, domid, vcpu); + CAMLlocal1(result); + xc_vcpuinfo_t info; + int retval; - uint32_t c_domid = _D(domid); - uint32_t c_vcpu = Int_val(vcpu); - caml_enter_blocking_section(); - retval = xc_vcpu_getinfo(_H(xch), c_domid, - c_vcpu, &info); - caml_leave_blocking_section(); - if (retval < 0) - failwith_xc(_H(xch)); + uint32_t c_domid = _D(domid); + uint32_t c_vcpu = Int_val(vcpu); + caml_enter_blocking_section(); + retval = xc_vcpu_getinfo(_H(xch), c_domid, + c_vcpu, &info); + caml_leave_blocking_section(); + if (retval < 0) + failwith_xc(_H(xch)); - result = caml_alloc_tuple(5); - Store_field(result, 0, Val_bool(info.online)); - Store_field(result, 1, Val_bool(info.blocked)); - Store_field(result, 2, Val_bool(info.running)); - Store_field(result, 3, caml_copy_int64(info.cpu_time)); - Store_field(result, 4, caml_copy_int32(info.cpu)); + result = caml_alloc_tuple(5); + Store_field(result, 0, Val_bool(info.online)); + Store_field(result, 1, Val_bool(info.blocked)); + Store_field(result, 2, Val_bool(info.running)); + Store_field(result, 3, caml_copy_int64(info.cpu_time)); + Store_field(result, 4, caml_copy_int32(info.cpu)); - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_xc_vcpu_context_get(value xch, value domid, value cpu) { - CAMLparam3(xch, domid, cpu); - CAMLlocal1(context); - int ret; - vcpu_guest_context_any_t ctxt; + CAMLparam3(xch, domid, cpu); + CAMLlocal1(context); + int ret; + vcpu_guest_context_any_t ctxt; - ret = xc_vcpu_getcontext(_H(xch), _D(domid), Int_val(cpu), &ctxt); - if ( ret < 0 ) - failwith_xc(_H(xch)); + ret = xc_vcpu_getcontext(_H(xch), _D(domid), Int_val(cpu), &ctxt); + if ( ret < 0 ) + failwith_xc(_H(xch)); - context = caml_alloc_string(sizeof(ctxt)); - memcpy((char *) String_val(context), &ctxt.c, sizeof(ctxt.c)); + context = caml_alloc_string(sizeof(ctxt)); + memcpy((char *) String_val(context), &ctxt.c, sizeof(ctxt.c)); - CAMLreturn(context); + CAMLreturn(context); } static int get_cpumap_len(value xch, value cpumap) { - int ml_len = Wosize_val(cpumap); - int xc_len = xc_get_max_cpus(_H(xch)); + int ml_len = Wosize_val(cpumap); + int xc_len = xc_get_max_cpus(_H(xch)); - if (ml_len < xc_len) - return ml_len; - else - return xc_len; + if (ml_len < xc_len) + return ml_len; + else + return xc_len; } CAMLprim value stub_xc_vcpu_setaffinity(value xch, value domid, value vcpu, value cpumap) { - CAMLparam4(xch, domid, vcpu, cpumap); - int i, len = get_cpumap_len(xch, cpumap); - xc_cpumap_t c_cpumap; - int retval; + CAMLparam4(xch, domid, vcpu, cpumap); + int i, len = get_cpumap_len(xch, cpumap); + xc_cpumap_t c_cpumap; + int retval; - c_cpumap = xc_cpumap_alloc(_H(xch)); - if (c_cpumap == NULL) - failwith_xc(_H(xch)); + c_cpumap = xc_cpumap_alloc(_H(xch)); + if (c_cpumap == NULL) + failwith_xc(_H(xch)); - for (i=0; i<len; i++) { - if (Bool_val(Field(cpumap, i))) - c_cpumap[i/8] |= 1 << (i&7); - } - retval = xc_vcpu_setaffinity(_H(xch), _D(domid), - Int_val(vcpu), - c_cpumap, NULL, - XEN_VCPUAFFINITY_HARD); - free(c_cpumap); + for (i=0; i<len; i++) { + if (Bool_val(Field(cpumap, i))) + c_cpumap[i/8] |= 1 << (i&7); + } + retval = xc_vcpu_setaffinity(_H(xch), _D(domid), + Int_val(vcpu), + c_cpumap, NULL, + XEN_VCPUAFFINITY_HARD); + free(c_cpumap); - if (retval < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (retval < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_vcpu_getaffinity(value xch, value domid, value vcpu) { - CAMLparam3(xch, domid, vcpu); - CAMLlocal1(ret); - xc_cpumap_t c_cpumap; - int i, len = xc_get_max_cpus(_H(xch)); - int retval; + CAMLparam3(xch, domid, vcpu); + CAMLlocal1(ret); + xc_cpumap_t c_cpumap; + int i, len = xc_get_max_cpus(_H(xch)); + int retval; - if (len < 1) - failwith_xc(_H(xch)); + if (len < 1) + failwith_xc(_H(xch)); - c_cpumap = xc_cpumap_alloc(_H(xch)); - if (c_cpumap == NULL) - failwith_xc(_H(xch)); + c_cpumap = xc_cpumap_alloc(_H(xch)); + if (c_cpumap == NULL) + failwith_xc(_H(xch)); - retval = xc_vcpu_getaffinity(_H(xch), _D(domid), - Int_val(vcpu), - c_cpumap, NULL, - XEN_VCPUAFFINITY_HARD); - if (retval < 0) { - free(c_cpumap); - failwith_xc(_H(xch)); - } + retval = xc_vcpu_getaffinity(_H(xch), _D(domid), + Int_val(vcpu), + c_cpumap, NULL, + XEN_VCPUAFFINITY_HARD); + if (retval < 0) { + free(c_cpumap); + failwith_xc(_H(xch)); + } - ret = caml_alloc(len, 0); + ret = caml_alloc(len, 0); - for (i=0; i<len; i++) { - if (c_cpumap[i/8] & 1 << (i&7)) - Store_field(ret, i, Val_true); - else - Store_field(ret, i, Val_false); - } + for (i=0; i<len; i++) { + if (c_cpumap[i/8] & 1 << (i&7)) + Store_field(ret, i, Val_true); + else + Store_field(ret, i, Val_false); + } - free(c_cpumap); + free(c_cpumap); - CAMLreturn(ret); + CAMLreturn(ret); } CAMLprim value stub_xc_sched_id(value xch) { - CAMLparam1(xch); - int sched_id; + CAMLparam1(xch); + int sched_id; - if (xc_sched_id(_H(xch), &sched_id)) - failwith_xc(_H(xch)); - CAMLreturn(Val_int(sched_id)); + if (xc_sched_id(_H(xch), &sched_id)) + failwith_xc(_H(xch)); + CAMLreturn(Val_int(sched_id)); } CAMLprim value stub_xc_evtchn_alloc_unbound(value xch, value local_domid, value remote_domid) { - CAMLparam3(xch, local_domid, remote_domid); - int result; + CAMLparam3(xch, local_domid, remote_domid); + int result; - uint32_t c_local_domid = _D(local_domid); - uint32_t c_remote_domid = _D(remote_domid); + uint32_t c_local_domid = _D(local_domid); + uint32_t c_remote_domid = _D(remote_domid); - caml_enter_blocking_section(); - result = xc_evtchn_alloc_unbound(_H(xch), c_local_domid, - c_remote_domid); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result = xc_evtchn_alloc_unbound(_H(xch), c_local_domid, + c_remote_domid); + caml_leave_blocking_section(); - if (result < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_int(result)); + if (result < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_int(result)); } CAMLprim value stub_xc_evtchn_reset(value xch, value domid) { - CAMLparam2(xch, domid); - int r; + CAMLparam2(xch, domid); + int r; - r = xc_evtchn_reset(_H(xch), _D(domid)); - if (r < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + r = xc_evtchn_reset(_H(xch), _D(domid)); + if (r < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_readconsolering(value xch) { - /* Safe to use outside of blocking sections because of Ocaml GC lock. */ - static unsigned int conring_size = 16384 + 1; + /* Safe to use outside of blocking sections because of Ocaml GC lock. */ + static unsigned int conring_size = 16384 + 1; - unsigned int count = conring_size, size = count, index = 0; - char *str = NULL, *ptr; - int ret; + unsigned int count = conring_size, size = count, index = 0; + char *str = NULL, *ptr; + int ret; - CAMLparam1(xch); - CAMLlocal1(ring); + CAMLparam1(xch); + CAMLlocal1(ring); - str = malloc(size); - if (!str) - caml_raise_out_of_memory(); + str = malloc(size); + if (!str) + caml_raise_out_of_memory(); - /* Hopefully our conring_size guess is sufficient */ - caml_enter_blocking_section(); - ret = xc_readconsolering(_H(xch), str, &count, 0, 0, &index); - caml_leave_blocking_section(); + /* Hopefully our conring_size guess is sufficient */ + caml_enter_blocking_section(); + ret = xc_readconsolering(_H(xch), str, &count, 0, 0, &index); + caml_leave_blocking_section(); - if (ret < 0) { - free(str); - failwith_xc(_H(xch)); - } + if (ret < 0) { + free(str); + failwith_xc(_H(xch)); + } - while (count == size && ret >= 0) { - size += count - 1; - if (size < count) - break; + while (count == size && ret >= 0) { + size += count - 1; + if (size < count) + break; - ptr = realloc(str, size); - if (!ptr) - break; + ptr = realloc(str, size); + if (!ptr) + break; - str = ptr + count; - count = size - count; + str = ptr + count; + count = size - count; - caml_enter_blocking_section(); - ret = xc_readconsolering(_H(xch), str, &count, 0, 1, &index); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = xc_readconsolering(_H(xch), str, &count, 0, 1, &index); + caml_leave_blocking_section(); - count += str - ptr; - str = ptr; - } + count += str - ptr; + str = ptr; + } - /* - * If we didn't break because of an overflow with size, and we have - * needed to realloc() ourself more space, update our tracking of the - * real console ring size. - */ - if (size > conring_size) - conring_size = size; + /* + * If we didn't break because of an overflow with size, and we have + * needed to realloc() ourself more space, update our tracking of the + * real console ring size. + */ + if (size > conring_size) + conring_size = size; - ring = caml_alloc_string(count); - memcpy((char *) String_val(ring), str, count); - free(str); + ring = caml_alloc_string(count); + memcpy((char *) String_val(ring), str, count); + free(str); - CAMLreturn(ring); + CAMLreturn(ring); } CAMLprim value stub_xc_send_debug_keys(value xch, value keys) { - CAMLparam2(xch, keys); - int r; + CAMLparam2(xch, keys); + int r; - r = xc_send_debug_keys(_H(xch), String_val(keys)); - if (r) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + r = xc_send_debug_keys(_H(xch), String_val(keys)); + if (r) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_physinfo(value xch) { - CAMLparam1(xch); - CAMLlocal4(physinfo, cap_list, arch_cap_flags, arch_cap_list); - xc_physinfo_t c_physinfo; - int r, arch_cap_flags_tag; + CAMLparam1(xch); + CAMLlocal4(physinfo, cap_list, arch_cap_flags, arch_cap_list); + xc_physinfo_t c_physinfo; + int r, arch_cap_flags_tag; - caml_enter_blocking_section(); - r = xc_physinfo(_H(xch), &c_physinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + r = xc_physinfo(_H(xch), &c_physinfo); + caml_leave_blocking_section(); - if (r) - failwith_xc(_H(xch)); + if (r) + failwith_xc(_H(xch)); - /* - * capabilities: physinfo_cap_flag list; - */ - cap_list = c_bitmap_to_ocaml_list - /* ! physinfo_cap_flag CAP_ lc */ - /* ! XEN_SYSCTL_PHYSCAP_ XEN_SYSCTL_PHYSCAP_MAX max */ - (c_physinfo.capabilities); + /* + * capabilities: physinfo_cap_flag list; + */ + cap_list = c_bitmap_to_ocaml_list + /* ! physinfo_cap_flag CAP_ lc */ + /* ! XEN_SYSCTL_PHYSCAP_ XEN_SYSCTL_PHYSCAP_MAX max */ + (c_physinfo.capabilities); - physinfo = caml_alloc_tuple(11); - Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core)); - Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket)); - Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus)); - Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id)); - Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz)); - Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages)); - Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages)); - Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages)); - Store_field(physinfo, 8, cap_list); - Store_field(physinfo, 9, Val_int(c_physinfo.max_cpu_id + 1)); + physinfo = caml_alloc_tuple(11); + Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core)); + Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket)); + Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus)); + Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id)); + Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz)); + Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages)); + Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages)); + Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages)); + Store_field(physinfo, 8, cap_list); + Store_field(physinfo, 9, Val_int(c_physinfo.max_cpu_id + 1)); #if defined(__i386__) || defined(__x86_64__) - arch_cap_list = c_bitmap_to_ocaml_list - /* ! x86_physinfo_cap_flag CAP_X86_ none */ - /* ! XEN_SYSCTL_PHYSCAP_X86_ XEN_SYSCTL_PHYSCAP_X86_MAX max */ - (c_physinfo.arch_capabilities); + arch_cap_list = c_bitmap_to_ocaml_list + /* ! x86_physinfo_cap_flag CAP_X86_ none */ + /* ! XEN_SYSCTL_PHYSCAP_X86_ XEN_SYSCTL_PHYSCAP_X86_MAX max */ + (c_physinfo.arch_capabilities); - arch_cap_flags_tag = 1; /* tag x86 */ + arch_cap_flags_tag = 1; /* tag x86 */ #else - caml_failwith("Unhandled architecture"); + caml_failwith("Unhandled architecture"); #endif - arch_cap_flags = caml_alloc_small(1, arch_cap_flags_tag); - Store_field(arch_cap_flags, 0, arch_cap_list); - Store_field(physinfo, 10, arch_cap_flags); + arch_cap_flags = caml_alloc_small(1, arch_cap_flags_tag); + Store_field(arch_cap_flags, 0, arch_cap_list); + Store_field(physinfo, 10, arch_cap_flags); - CAMLreturn(physinfo); + CAMLreturn(physinfo); } CAMLprim value stub_xc_pcpu_info(value xch, value nr_cpus) { - CAMLparam2(xch, nr_cpus); - CAMLlocal2(pcpus, v); - xc_cpuinfo_t *info; - int r, size; + CAMLparam2(xch, nr_cpus); + CAMLlocal2(pcpus, v); + xc_cpuinfo_t *info; + int r, size; - if (Int_val(nr_cpus) < 1) - caml_invalid_argument("nr_cpus"); + if (Int_val(nr_cpus) < 1) + caml_invalid_argument("nr_cpus"); - info = calloc(Int_val(nr_cpus) + 1, sizeof(*info)); - if (!info) - caml_raise_out_of_memory(); + info = calloc(Int_val(nr_cpus) + 1, sizeof(*info)); + if (!info) + caml_raise_out_of_memory(); - caml_enter_blocking_section(); - r = xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + r = xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size); + caml_leave_blocking_section(); - if (r) { - free(info); - failwith_xc(_H(xch)); - } + if (r) { + free(info); + failwith_xc(_H(xch)); + } - if (size > 0) { - int i; - pcpus = caml_alloc(size, 0); - for (i = 0; i < size; i++) { - v = caml_copy_int64(info[i].idletime); - caml_modify(&Field(pcpus, i), v); - } - } else - pcpus = Atom(0); - free(info); - CAMLreturn(pcpus); + if (size > 0) { + int i; + pcpus = caml_alloc(size, 0); + for (i = 0; i < size; i++) { + v = caml_copy_int64(info[i].idletime); + caml_modify(&Field(pcpus, i), v); + } + } else + pcpus = Atom(0); + free(info); + CAMLreturn(pcpus); } CAMLprim value stub_xc_domain_setmaxmem(value xch, value domid, value max_memkb) { - CAMLparam3(xch, domid, max_memkb); - int retval; + CAMLparam3(xch, domid, max_memkb); + int retval; - uint32_t c_domid = _D(domid); - unsigned int c_max_memkb = Int64_val(max_memkb); - caml_enter_blocking_section(); - retval = xc_domain_setmaxmem(_H(xch), c_domid, - c_max_memkb); - caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + uint32_t c_domid = _D(domid); + unsigned int c_max_memkb = Int64_val(max_memkb); + caml_enter_blocking_section(); + retval = xc_domain_setmaxmem(_H(xch), c_domid, + c_max_memkb); + caml_leave_blocking_section(); + if (retval) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_set_memmap_limit(value xch, value domid, value map_limitkb) { - CAMLparam3(xch, domid, map_limitkb); - unsigned long v; - int retval; + CAMLparam3(xch, domid, map_limitkb); + unsigned long v; + int retval; - v = Int64_val(map_limitkb); - retval = xc_domain_set_memmap_limit(_H(xch), _D(domid), v); - if (retval) - failwith_xc(_H(xch)); + v = Int64_val(map_limitkb); + retval = xc_domain_set_memmap_limit(_H(xch), _D(domid), v); + if (retval) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_memory_increase_reservation(value xch, value domid, value mem_kb) { - CAMLparam3(xch, domid, mem_kb); - int retval; + CAMLparam3(xch, domid, mem_kb); + int retval; - unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (XC_PAGE_SHIFT - 10); + unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (XC_PAGE_SHIFT - 10); - uint32_t c_domid = _D(domid); - caml_enter_blocking_section(); - retval = xc_domain_increase_reservation_exact(_H(xch), c_domid, - nr_extents, 0, 0, NULL); - caml_leave_blocking_section(); + uint32_t c_domid = _D(domid); + caml_enter_blocking_section(); + retval = xc_domain_increase_reservation_exact(_H(xch), c_domid, + nr_extents, 0, 0, NULL); + caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (retval) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_version_version(value xch) { - CAMLparam1(xch); - CAMLlocal1(result); - xen_extraversion_t extra; - long packed; - int retval; + CAMLparam1(xch); + CAMLlocal1(result); + xen_extraversion_t extra; + long packed; + int retval; - caml_enter_blocking_section(); - packed = xc_version(_H(xch), XENVER_version, NULL); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + packed = xc_version(_H(xch), XENVER_version, NULL); + caml_leave_blocking_section(); - if (packed < 0) - failwith_xc(_H(xch)); + if (packed < 0) + failwith_xc(_H(xch)); - caml_enter_blocking_section(); - retval = xc_version(_H(xch), XENVER_extraversion, &extra); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval = xc_version(_H(xch), XENVER_extraversion, &extra); + caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); - result = caml_alloc_tuple(3); + result = caml_alloc_tuple(3); - Store_field(result, 0, Val_int(packed >> 16)); - Store_field(result, 1, Val_int(packed & 0xffff)); - Store_field(result, 2, caml_copy_string(extra)); + Store_field(result, 0, Val_int(packed >> 16)); + Store_field(result, 1, Val_int(packed & 0xffff)); + Store_field(result, 2, caml_copy_string(extra)); - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_xc_version_compile_info(value xch) { - CAMLparam1(xch); - CAMLlocal1(result); - xen_compile_info_t ci; - int retval; + CAMLparam1(xch); + CAMLlocal1(result); + xen_compile_info_t ci; + int retval; - caml_enter_blocking_section(); - retval = xc_version(_H(xch), XENVER_compile_info, &ci); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval = xc_version(_H(xch), XENVER_compile_info, &ci); + caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); - result = caml_alloc_tuple(4); + result = caml_alloc_tuple(4); - Store_field(result, 0, caml_copy_string(ci.compiler)); - Store_field(result, 1, caml_copy_string(ci.compile_by)); - Store_field(result, 2, caml_copy_string(ci.compile_domain)); - Store_field(result, 3, caml_copy_string(ci.compile_date)); + Store_field(result, 0, caml_copy_string(ci.compiler)); + Store_field(result, 1, caml_copy_string(ci.compile_by)); + Store_field(result, 2, caml_copy_string(ci.compile_domain)); + Store_field(result, 3, caml_copy_string(ci.compile_date)); - CAMLreturn(result); + CAMLreturn(result); } static value xc_version_single_string(value xch, int code, void *info) { - CAMLparam1(xch); - int retval; + CAMLparam1(xch); + int retval; - caml_enter_blocking_section(); - retval = xc_version(_H(xch), code, info); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval = xc_version(_H(xch), code, info); + caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); - CAMLreturn(caml_copy_string((char *)info)); + CAMLreturn(caml_copy_string((char *)info)); } CAMLprim value stub_xc_version_changeset(value xch) { - xen_changeset_info_t ci; + xen_changeset_info_t ci; - return xc_version_single_string(xch, XENVER_changeset, &ci); + return xc_version_single_string(xch, XENVER_changeset, &ci); } CAMLprim value stub_xc_version_capabilities(value xch) { - xen_capabilities_info_t ci; + xen_capabilities_info_t ci; - return xc_version_single_string(xch, XENVER_capabilities, &ci); + return xc_version_single_string(xch, XENVER_capabilities, &ci); } CAMLprim value stub_pages_to_kib(value pages) { - CAMLparam1(pages); + CAMLparam1(pages); - CAMLreturn(caml_copy_int64(Int64_val(pages) << (XC_PAGE_SHIFT - 10))); + CAMLreturn(caml_copy_int64(Int64_val(pages) << (XC_PAGE_SHIFT - 10))); } CAMLprim value stub_map_foreign_range(value xch, value dom, value size, value mfn) { - CAMLparam4(xch, dom, size, mfn); - CAMLlocal1(result); - struct mmap_interface *intf; - uint32_t c_dom; - unsigned long c_mfn; + CAMLparam4(xch, dom, size, mfn); + CAMLlocal1(result); + struct mmap_interface *intf; + uint32_t c_dom; + unsigned long c_mfn; - result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); - intf = (struct mmap_interface *) result; + result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + intf = (struct mmap_interface *) result; - intf->len = Int_val(size); + intf->len = Int_val(size); - c_dom = _D(dom); - c_mfn = Nativeint_val(mfn); - caml_enter_blocking_section(); - intf->addr = xc_map_foreign_range(_H(xch), c_dom, - intf->len, PROT_READ|PROT_WRITE, - c_mfn); - caml_leave_blocking_section(); - if (!intf->addr) - caml_failwith("xc_map_foreign_range error"); - CAMLreturn(result); + c_dom = _D(dom); + c_mfn = Nativeint_val(mfn); + caml_enter_blocking_section(); + intf->addr = xc_map_foreign_range(_H(xch), c_dom, + intf->len, PROT_READ|PROT_WRITE, + c_mfn); + caml_leave_blocking_section(); + if (!intf->addr) + caml_failwith("xc_map_foreign_range error"); + CAMLreturn(result); } CAMLprim value stub_sched_credit_domain_get(value xch, value domid) { - CAMLparam2(xch, domid); - CAMLlocal1(sdom); - struct xen_domctl_sched_credit c_sdom; - int ret; + CAMLparam2(xch, domid); + CAMLlocal1(sdom); + struct xen_domctl_sched_credit c_sdom; + int ret; - caml_enter_blocking_section(); - ret = xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom); - caml_leave_blocking_section(); - if (ret != 0) - failwith_xc(_H(xch)); + caml_enter_blocking_section(); + ret = xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom); + caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(_H(xch)); - sdom = caml_alloc_tuple(2); - Store_field(sdom, 0, Val_int(c_sdom.weight)); - Store_field(sdom, 1, Val_int(c_sdom.cap)); + sdom = caml_alloc_tuple(2); + Store_field(sdom, 0, Val_int(c_sdom.weight)); + Store_field(sdom, 1, Val_int(c_sdom.cap)); - CAMLreturn(sdom); + CAMLreturn(sdom); } CAMLprim value stub_sched_credit_domain_set(value xch, value domid, value sdom) { - CAMLparam3(xch, domid, sdom); - struct xen_domctl_sched_credit c_sdom; - int ret; + CAMLparam3(xch, domid, sdom); + struct xen_domctl_sched_credit c_sdom; + int ret; - c_sdom.weight = Int_val(Field(sdom, 0)); - c_sdom.cap = Int_val(Field(sdom, 1)); - caml_enter_blocking_section(); - ret = xc_sched_credit_domain_set(_H(xch), _D(domid), &c_sdom); - caml_leave_blocking_section(); - if (ret != 0) - failwith_xc(_H(xch)); + c_sdom.weight = Int_val(Field(sdom, 0)); + c_sdom.cap = Int_val(Field(sdom, 1)); + caml_enter_blocking_section(); + ret = xc_sched_credit_domain_set(_H(xch), _D(domid), &c_sdom); + caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_shadow_allocation_get(value xch, value domid) { - CAMLparam2(xch, domid); - CAMLlocal1(mb); - unsigned int c_mb; - int ret; + CAMLparam2(xch, domid); + CAMLlocal1(mb); + unsigned int c_mb; + int ret; - caml_enter_blocking_section(); - ret = xc_shadow_control(_H(xch), _D(domid), - XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION, - &c_mb, 0); - caml_leave_blocking_section(); - if (ret != 0) - failwith_xc(_H(xch)); + caml_enter_blocking_section(); + ret = xc_shadow_control(_H(xch), _D(domid), + XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION, + &c_mb, 0); + caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(_H(xch)); - mb = Val_int(c_mb); - CAMLreturn(mb); + mb = Val_int(c_mb); + CAMLreturn(mb); } CAMLprim value stub_shadow_allocation_set(value xch, value domid, - value mb) + value mb) { - CAMLparam3(xch, domid, mb); - unsigned int c_mb; - int ret; + CAMLparam3(xch, domid, mb); + unsigned int c_mb; + int ret; - c_mb = Int_val(mb); - caml_enter_blocking_section(); - ret = xc_shadow_control(_H(xch), _D(domid), - XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION, - &c_mb, 0); - caml_leave_blocking_section(); - if (ret != 0) - failwith_xc(_H(xch)); + c_mb = Int_val(mb); + caml_enter_blocking_section(); + ret = xc_shadow_control(_H(xch), _D(domid), + XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION, + &c_mb, 0); + caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_ioport_permission(value xch, value domid, - value start_port, value nr_ports, - value allow) + value start_port, value nr_ports, + value allow) { - CAMLparam5(xch, domid, start_port, nr_ports, allow); - uint32_t c_start_port, c_nr_ports; - uint8_t c_allow; - int ret; + CAMLparam5(xch, domid, start_port, nr_ports, allow); + uint32_t c_start_port, c_nr_ports; + uint8_t c_allow; + int ret; - c_start_port = Int_val(start_port); - c_nr_ports = Int_val(nr_ports); - c_allow = Bool_val(allow); + c_start_port = Int_val(start_port); + c_nr_ports = Int_val(nr_ports); + c_allow = Bool_val(allow); - ret = xc_domain_ioport_permission(_H(xch), _D(domid), - c_start_port, c_nr_ports, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_domain_ioport_permission(_H(xch), _D(domid), + c_start_port, c_nr_ports, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_iomem_permission(value xch, value domid, - value start_pfn, value nr_pfns, - value allow) + value start_pfn, value nr_pfns, + value allow) { - CAMLparam5(xch, domid, start_pfn, nr_pfns, allow); - unsigned long c_start_pfn, c_nr_pfns; - uint8_t c_allow; - int ret; + CAMLparam5(xch, domid, start_pfn, nr_pfns, allow); + unsigned long c_start_pfn, c_nr_pfns; + uint8_t c_allow; + int ret; - c_start_pfn = Nativeint_val(start_pfn); - c_nr_pfns = Nativeint_val(nr_pfns); - c_allow = Bool_val(allow); + c_start_pfn = Nativeint_val(start_pfn); + c_nr_pfns = Nativeint_val(nr_pfns); + c_allow = Bool_val(allow); - ret = xc_domain_iomem_permission(_H(xch), _D(domid), - c_start_pfn, c_nr_pfns, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_domain_iomem_permission(_H(xch), _D(domid), + c_start_pfn, c_nr_pfns, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_irq_permission(value xch, value domid, - value pirq, value allow) + value pirq, value allow) { - CAMLparam4(xch, domid, pirq, allow); - uint32_t c_pirq; - bool c_allow; - int ret; + CAMLparam4(xch, domid, pirq, allow); + uint32_t c_pirq; + bool c_allow; + int ret; - c_pirq = Int_val(pirq); - c_allow = Bool_val(allow); + c_pirq = Int_val(pirq); + c_allow = Bool_val(allow); - ret = xc_domain_irq_permission(_H(xch), _D(domid), - c_pirq, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_domain_irq_permission(_H(xch), _D(domid), + c_pirq, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static uint32_t encode_sbdf(int domain, int bus, int dev, int func) { - return ((uint32_t)domain & 0xffff) << 16 | - ((uint32_t)bus & 0xff) << 8 | - ((uint32_t)dev & 0x1f) << 3 | - ((uint32_t)func & 0x7); + return ((uint32_t)domain & 0xffff) << 16 | + ((uint32_t)bus & 0xff) << 8 | + ((uint32_t)dev & 0x1f) << 3 | + ((uint32_t)func & 0x7); } CAMLprim value stub_xc_domain_test_assign_device(value xch, value domid, value desc) { - CAMLparam3(xch, domid, desc); - int ret; - int domain, bus, dev, func; - uint32_t sbdf; + CAMLparam3(xch, domid, desc); + int ret; + int domain, bus, dev, func; + uint32_t sbdf; - domain = Int_val(Field(desc, 0)); - bus = Int_val(Field(desc, 1)); - dev = Int_val(Field(desc, 2)); - func = Int_val(Field(desc, 3)); - sbdf = encode_sbdf(domain, bus, dev, func); + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + dev = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + sbdf = encode_sbdf(domain, bus, dev, func); - ret = xc_test_assign_device(_H(xch), _D(domid), sbdf); + ret = xc_test_assign_device(_H(xch), _D(domid), sbdf); - CAMLreturn(Val_bool(ret == 0)); + CAMLreturn(Val_bool(ret == 0)); } static int domain_assign_device_rdm_flag_table[] = { @@ -1147,96 +1147,96 @@ static int domain_assign_device_rdm_flag_table[] = { CAMLprim value stub_xc_domain_assign_device(value xch, value domid, value desc, value rflag) { - CAMLparam4(xch, domid, desc, rflag); - int ret; - int domain, bus, dev, func; - uint32_t sbdf, flag; + CAMLparam4(xch, domid, desc, rflag); + int ret; + int domain, bus, dev, func; + uint32_t sbdf, flag; - domain = Int_val(Field(desc, 0)); - bus = Int_val(Field(desc, 1)); - dev = Int_val(Field(desc, 2)); - func = Int_val(Field(desc, 3)); - sbdf = encode_sbdf(domain, bus, dev, func); + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + dev = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + sbdf = encode_sbdf(domain, bus, dev, func); - ret = Int_val(Field(rflag, 0)); - flag = domain_assign_device_rdm_flag_table[ret]; + ret = Int_val(Field(rflag, 0)); + flag = domain_assign_device_rdm_flag_table[ret]; - ret = xc_assign_device(_H(xch), _D(domid), sbdf, flag); + ret = xc_assign_device(_H(xch), _D(domid), sbdf, flag); - if (ret < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (ret < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_deassign_device(value xch, value domid, value desc) { - CAMLparam3(xch, domid, desc); - int ret; - int domain, bus, dev, func; - uint32_t sbdf; + CAMLparam3(xch, domid, desc); + int ret; + int domain, bus, dev, func; + uint32_t sbdf; - domain = Int_val(Field(desc, 0)); - bus = Int_val(Field(desc, 1)); - dev = Int_val(Field(desc, 2)); - func = Int_val(Field(desc, 3)); - sbdf = encode_sbdf(domain, bus, dev, func); + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + dev = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + sbdf = encode_sbdf(domain, bus, dev, func); - ret = xc_deassign_device(_H(xch), _D(domid), sbdf); + ret = xc_deassign_device(_H(xch), _D(domid), sbdf); - if (ret < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (ret < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_get_cpu_featureset(value xch, value idx) { - CAMLparam2(xch, idx); - CAMLlocal1(bitmap_val); + CAMLparam2(xch, idx); + CAMLlocal1(bitmap_val); #if defined(__i386__) || defined(__x86_64__) - /* Safe, because of the global ocaml lock. */ - static uint32_t fs_len; + /* Safe, because of the global ocaml lock. */ + static uint32_t fs_len; - if (fs_len == 0) - { - int ret = xc_get_cpu_featureset(_H(xch), 0, &fs_len, NULL); + if (fs_len == 0) + { + int ret = xc_get_cpu_featureset(_H(xch), 0, &fs_len, NULL); - if (ret || (fs_len == 0)) - failwith_xc(_H(xch)); - } + if (ret || (fs_len == 0)) + failwith_xc(_H(xch)); + } - { - /* To/from hypervisor to retrieve actual featureset */ - uint32_t fs[fs_len], len = fs_len; - unsigned int i; + { + /* To/from hypervisor to retrieve actual featureset */ + uint32_t fs[fs_len], len = fs_len; + unsigned int i; - int ret = xc_get_cpu_featureset(_H(xch), Int_val(idx), &len, fs); + int ret = xc_get_cpu_featureset(_H(xch), Int_val(idx), &len, fs); - if (ret) - failwith_xc(_H(xch)); + if (ret) + failwith_xc(_H(xch)); - bitmap_val = caml_alloc(len, 0); + bitmap_val = caml_alloc(len, 0); - for (i = 0; i < len; ++i) - Store_field(bitmap_val, i, caml_copy_int64(fs[i])); - } + for (i = 0; i < len; ++i) + Store_field(bitmap_val, i, caml_copy_int64(fs[i])); + } #else - caml_failwith("xc_get_cpu_featureset: not implemented"); + caml_failwith("xc_get_cpu_featureset: not implemented"); #endif - CAMLreturn(bitmap_val); + CAMLreturn(bitmap_val); } CAMLprim value stub_xc_watchdog(value xch, value domid, value timeout) { - CAMLparam3(xch, domid, timeout); - int ret; - unsigned int c_timeout = Int32_val(timeout); + CAMLparam3(xch, domid, timeout); + int ret; + unsigned int c_timeout = Int32_val(timeout); - ret = xc_watchdog(_H(xch), _D(domid), c_timeout); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_watchdog(_H(xch), _D(domid), c_timeout); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_int(ret)); + CAMLreturn(Val_int(ret)); } /* diff --git a/tools/ocaml/libs/xentoollog/caml_xentoollog.h b/tools/ocaml/libs/xentoollog/caml_xentoollog.h index 0eb7618512..5ad4a4d5b2 100644 --- a/tools/ocaml/libs/xentoollog/caml_xentoollog.h +++ b/tools/ocaml/libs/xentoollog/caml_xentoollog.h @@ -15,9 +15,9 @@ */ struct caml_xtl { - xentoollog_logger vtable; - char *vmessage_cb; - char *progress_cb; + 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/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c index e4306a0c2f..8f1ced1fa0 100644 --- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c +++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c @@ -40,14 +40,14 @@ caml_local_roots = caml__frame; \ 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; + 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" @@ -62,144 +62,144 @@ static char * dup_String_val(value s) static value Val_some(value v) { - CAMLparam1(v); - CAMLlocal1(some); - some = caml_alloc(1, 0); - Store_field(some, 0, v); - CAMLreturn(some); + 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)); + 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)); + 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) + xentoollog_level level, + int errnoval, + const char *context, + const char *format, + va_list al) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - struct caml_xtl *xtl = (struct caml_xtl*)logger; - const value *func = caml_named_value(xtl->vmessage_cb); - char *msg; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + struct caml_xtl *xtl = (struct caml_xtl*)logger; + const value *func = caml_named_value(xtl->vmessage_cb); + char *msg; - 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(); + 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); + /* 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); + free(msg); - caml_callbackN(*func, 4, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 4, args); + CAMLdone; + caml_enter_blocking_section(); } 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) + const char *context, + const char *doing_what /* no \r,\n */, + int percent, unsigned long done, unsigned long total) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 5); - struct caml_xtl *xtl = (struct caml_xtl*)logger; - const value *func = caml_named_value(xtl->progress_cb); + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 5); + struct caml_xtl *xtl = (struct caml_xtl*)logger; + const value *func = caml_named_value(xtl->progress_cb); - if (func == NULL) - caml_raise_sys_error(caml_copy_string("Unable to find callback")); + 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); + /* 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); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 5, args); + CAMLdone; + caml_enter_blocking_section(); } 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); + 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); + 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 + "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(); + CAMLparam1(cbs); + CAMLlocal1(handle); + struct caml_xtl *xtl = malloc(sizeof(*xtl)); + if (xtl == NULL) + caml_raise_out_of_memory(); - memset(xtl, 0, sizeof(*xtl)); + 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->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)); + 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; + handle = caml_alloc_custom(&xentoollogger_custom_operations, sizeof(xtl), 0, 1); + Xtl_val(handle) = xtl; - CAMLreturn(handle); + 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); + 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/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c index 45b8af61c7..9dbf5e9660 100644 --- a/tools/ocaml/libs/xl/xenlight_stubs.c +++ b/tools/ocaml/libs/xl/xenlight_stubs.c @@ -58,14 +58,14 @@ caml_local_roots = caml__frame; \ 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; + 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. */ @@ -73,157 +73,157 @@ static value Val_error (libxl_error error_c); static void failwith_xl(int error, char *fname) { - CAMLparam0(); - CAMLlocal1(arg); - static const value *exc = NULL; + CAMLparam0(); + CAMLlocal1(arg); + static const value *exc = NULL; - /* First time around, lookup by name */ - if (!exc) - exc = caml_named_value("Xenlight.Error"); + /* 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"); + if (!exc) + caml_invalid_argument("Exception Xenlight.Error not initialized, please link xenlight.cma"); - arg = caml_alloc(2, 0); + arg = caml_alloc(2, 0); - Store_field(arg, 0, Val_error(error)); - Store_field(arg, 1, caml_copy_string(fname)); + Store_field(arg, 0, Val_error(error)); + Store_field(arg, 1, caml_copy_string(fname)); - caml_raise_with_arg(*exc, arg); - CAMLreturn0; + 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); + CAMLparam1(unit); + failwith_xl(ERROR_FAIL, "test exception"); + CAMLreturn(Val_unit); } void ctx_finalize(value ctx) { - libxl_ctx_free(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 + "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; + 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"); + 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; + handle = caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0, 1); + Ctx_val(handle) = ctx; - CAMLreturn(handle); + CAMLreturn(handle); } static int list_len(value v) { - int len = 0; - while ( v != Val_emptylist ) { - len++; - v = Field(v, 1); - } - return len; + 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) + value v) { - CAMLparam1(v); - CAMLlocal1(elem); - int nr, i; - libxl_key_value_list array; + CAMLparam1(v); + CAMLlocal1(elem); + int nr, i; + libxl_key_value_list array; - nr = list_len(v); + nr = list_len(v); - array = calloc((nr + 1) * 2, sizeof(char *)); - if (!array) - caml_raise_out_of_memory(); + 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); + 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)); - } + array[i * 2] = dup_String_val(Field(elem, 0)); + array[i * 2 + 1] = dup_String_val(Field(elem, 1)); + } - *c_val = array; - CAMLreturn(0); + *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; + 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); + 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; - } + cons = caml_alloc(2, 0); + Store_field(cons, 0, kv); // head + Store_field(cons, 1, list); // tail + list = cons; + } - CAMLreturn(list); + CAMLreturn(list); } static int libxl_string_list_val(libxl_string_list *c_val, value v) { - CAMLparam1(v); - int nr, i; - libxl_string_list array; + CAMLparam1(v); + int nr, i; + libxl_string_list array; - nr = list_len(v); + nr = list_len(v); - array = calloc(nr + 1, sizeof(char *)); - if (!array) - caml_raise_out_of_memory(); + 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)); + for (i=0; v != Val_emptylist; i++, v = Field(v, 1) ) + array[i] = dup_String_val(Field(v, 0)); - *c_val = array; - CAMLreturn(0); + *c_val = array; + CAMLreturn(0); } static value Val_string_list(libxl_string_list *c_val) { - CAMLparam0(); - CAMLlocal3(list, cons, string); - int i; + 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; - } + 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); + CAMLreturn(list); } /* Option type support as per http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php */ @@ -236,472 +236,472 @@ static value Val_string_list(libxl_string_list *c_val) static value Val_some(value v) { - CAMLparam1(v); - CAMLlocal1(some); - some = caml_alloc(1, 0); - Store_field(some, 0, v); - CAMLreturn(some); + 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; + CAMLparam0(); + CAMLlocal1(v); + int i; - v = caml_alloc_tuple(6); + v = caml_alloc_tuple(6); - for(i=0; i<6; i++) - Store_field(v, i, Val_int((*c_val)[i])); + for(i=0; i<6; i++) + Store_field(v, i, Val_int((*c_val)[i])); - CAMLreturn(v); + CAMLreturn(v); } static int Mac_val(libxl_mac *c_val, value v) { - CAMLparam1(v); - int i; + CAMLparam1(v); + int i; - for(i=0; i<6; i++) - (*c_val)[i] = Int_val(Field(v, i)); + for(i=0; i<6; i++) + (*c_val)[i] = Int_val(Field(v, i)); - CAMLreturn(0); + CAMLreturn(0); } static value Val_bitmap (libxl_bitmap *c_val) { - CAMLparam0(); - CAMLlocal1(v); - int i; + 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); + 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); + 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); + 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; + CAMLparam0(); + CAMLlocal1(v); + uint8_t *uuid = libxl_uuid_bytearray(c_val); + int i; - v = caml_alloc_tuple(16); + v = caml_alloc_tuple(16); - for(i=0; i<16; i++) - Store_field(v, i, Val_int(uuid[i])); + for(i=0; i<16; i++) + Store_field(v, i, Val_int(uuid[i])); - CAMLreturn(v); + CAMLreturn(v); } static int Uuid_val(libxl_uuid *c_val, value v) { - CAMLparam1(v); - int i; - uint8_t *uuid = libxl_uuid_bytearray(c_val); + 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)); + for(i=0; i<16; i++) + uuid[i] = Int_val(Field(v, i)); - CAMLreturn(0); + CAMLreturn(0); } static value Val_defbool(libxl_defbool c_val) { - CAMLparam0(); - CAMLlocal2(v1, v2); - bool b; + 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); + 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); + 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; + 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])); + hwcap = caml_alloc_tuple(8); + for (i = 0; i < 8; i++) + Store_field(hwcap, i, caml_copy_int32((*c_val)[i])); - CAMLreturn(hwcap); + CAMLreturn(hwcap); } static value Val_ms_vm_genid (libxl_ms_vm_genid *c_val) { - CAMLparam0(); - CAMLlocal1(v); - int i; + CAMLparam0(); + CAMLlocal1(v); + int i; - v = caml_alloc_tuple(LIBXL_MS_VM_GENID_LEN); + 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])); + for(i=0; i<LIBXL_MS_VM_GENID_LEN; i++) + Store_field(v, i, Val_int(c_val->bytes[i])); - CAMLreturn(v); + CAMLreturn(v); } static int Ms_vm_genid_val(libxl_ms_vm_genid *c_val, value v) { - CAMLparam1(v); - int i; + CAMLparam1(v); + int i; - for(i=0; i<LIBXL_MS_VM_GENID_LEN; i++) - c_val->bytes[i] = Int_val(Field(v, i)); + for(i=0; i<LIBXL_MS_VM_GENID_LEN; i++) + c_val->bytes[i] = Int_val(Field(v, i)); - CAMLreturn(0); + 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); + 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); + 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; + 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 (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); - } + 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); + /* 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); + caml_remove_global_root(p); + free(p); - CAMLdone; - caml_enter_blocking_section(); + CAMLdone; + caml_enter_blocking_section(); } static libxl_asyncop_how *aohow_val(value async) { - CAMLparam1(async); - libxl_asyncop_how *ao_how = NULL; - value *p; + 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; - } + 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); + 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; + 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"); - } + 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); + 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(); + 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); + free(ao_how); + libxl_domain_config_dispose(&c_dconfig); - if (ret != 0) - failwith_xl(ret, "domain_create_new"); + if (ret != 0) + failwith_xl(ret, "domain_create_new"); - CAMLreturn(Val_int(c_domid)); + CAMLreturn(Val_int(c_domid)); } value stub_libxl_domain_create_restore(value ctx, value domain_config, value params, - value async, value unit) + 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; + 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_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"); - } + 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)); + 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(); + 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); + 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"); + if (ret != 0) + failwith_xl(ret, "domain_create_restore"); - CAMLreturn(Val_int(c_domid)); + 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); + 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(); + caml_enter_blocking_section(); + ret = libxl_domain_shutdown(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_shutdown"); + if (ret != 0) + failwith_xl(ret, "domain_shutdown"); - CAMLreturn(Val_unit); + 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); + 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(); + caml_enter_blocking_section(); + ret = libxl_domain_reboot(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_reboot"); + if (ret != 0) + failwith_xl(ret, "domain_reboot"); - CAMLreturn(Val_unit); + 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); + 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(); + caml_enter_blocking_section(); + ret = libxl_domain_destroy(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_destroy"); + if (ret != 0) + failwith_xl(ret, "domain_destroy"); - CAMLreturn(Val_unit); + 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); + 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(); + caml_enter_blocking_section(); + ret = libxl_domain_suspend(CTX, c_domid, c_fd, 0, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_suspend"); + if (ret != 0) + failwith_xl(ret, "domain_suspend"); - CAMLreturn(Val_unit); + 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); + 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(); + caml_enter_blocking_section(); + ret = libxl_domain_pause(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_pause"); + if (ret != 0) + failwith_xl(ret, "domain_pause"); - CAMLreturn(Val_unit); + 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); + 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(); + caml_enter_blocking_section(); + ret = libxl_domain_unpause(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_unpause"); + if (ret != 0) + failwith_xl(ret, "domain_unpause"); - CAMLreturn(Val_unit); + 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,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(type, device_##type, add) \ + _DEVICE_ADDREMOVE(type, device_##type, remove) \ + _DEVICE_ADDREMOVE(type, device_##type, destroy) DEVICE_ADDREMOVE(disk) DEVICE_ADDREMOVE(nic) @@ -712,558 +712,558 @@ _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); + 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(); + 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); + nic = Val_device_nic(&c_nic); + libxl_device_nic_dispose(&c_nic); - CAMLreturn(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); + 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(); + 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"); + 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); + 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); + 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); + 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(); + 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"); + 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); + 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); + 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); + 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)); + 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(); + 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); + disk = Val_device_disk(&c_disk); + libxl_device_disk_dispose(&c_disk); + free(c_vdev); - CAMLreturn(disk); + 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); + 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(); + 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"); + 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); + 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); + 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); + 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); + 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(); + 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); + libxl_device_pci_dispose(&c_info); - if (ret != 0) - failwith_xl(ret, "pci_assignable_add"); + if (ret != 0) + failwith_xl(ret, "pci_assignable_add"); - CAMLreturn(Val_unit); + 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); + 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); + 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(); + 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); + libxl_device_pci_dispose(&c_info); - if (ret != 0) - failwith_xl(ret, "pci_assignable_remove"); + if (ret != 0) + failwith_xl(ret, "pci_assignable_remove"); - CAMLreturn(Val_unit); + 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; + 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(); + 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"); + 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); + 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); + CAMLreturn(list); } value stub_xl_physinfo_get(value ctx) { - CAMLparam1(ctx); - CAMLlocal1(physinfo); - libxl_physinfo c_physinfo; - int ret; + 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(); + caml_enter_blocking_section(); + ret = libxl_get_physinfo(CTX, &c_physinfo); + caml_leave_blocking_section(); - if (ret != 0) - failwith_xl(ret, "get_physinfo"); + if (ret != 0) + failwith_xl(ret, "get_physinfo"); - physinfo = Val_physinfo(&c_physinfo); + physinfo = Val_physinfo(&c_physinfo); - libxl_physinfo_dispose(&c_physinfo); + libxl_physinfo_dispose(&c_physinfo); - CAMLreturn(physinfo); + CAMLreturn(physinfo); } value stub_xl_cputopology_get(value ctx) { - CAMLparam1(ctx); - CAMLlocal3(topology, v, v0); - libxl_cputopology *c_topology; - int i, nr; + 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(); + 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"); + 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); - } + 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); + libxl_cputopology_list_free(c_topology, nr); - CAMLreturn(topology); + CAMLreturn(topology); } value stub_xl_dominfo_list(value ctx) { - CAMLparam1(ctx); - CAMLlocal2(domlist, temp); - libxl_dominfo *c_domlist; - int i, nb; + 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(); + caml_enter_blocking_section(); + c_domlist = libxl_list_domain(CTX, &nb); + caml_leave_blocking_section(); - if (!c_domlist) - failwith_xl(ERROR_FAIL, "dominfo_list"); + 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; + 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])); - } + Store_field(domlist, 0, Val_dominfo(&c_domlist[i])); + } - libxl_dominfo_list_free(c_domlist, nb); + libxl_dominfo_list_free(c_domlist, nb); - CAMLreturn(domlist); + 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); + 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(); + 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); + if (ret != 0) + failwith_xl(ERROR_FAIL, "domain_info"); + dominfo = Val_dominfo(&c_dominfo); - CAMLreturn(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); + 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(); + 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"); + if (ret != 0) + failwith_xl(ret, "domain_sched_params_get"); - scinfo = Val_domain_sched_params(&c_scinfo); + scinfo = Val_domain_sched_params(&c_scinfo); - libxl_domain_sched_params_dispose(&c_scinfo); + libxl_domain_sched_params_dispose(&c_scinfo); - CAMLreturn(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); + 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); + 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(); + 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); + libxl_domain_sched_params_dispose(&c_scinfo); - if (ret != 0) - failwith_xl(ret, "domain_sched_params_set"); + if (ret != 0) + failwith_xl(ret, "domain_sched_params_set"); - CAMLreturn(Val_unit); + 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); + 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); + 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(); + caml_enter_blocking_section(); + ret = libxl_send_trigger(CTX, c_domid, c_trigger, c_vcpuid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "send_trigger"); + if (ret != 0) + failwith_xl(ret, "send_trigger"); - CAMLreturn(Val_unit); + 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); + 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(); + 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"); + if (ret != 0) + failwith_xl(ret, "send_sysrq"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_xl_send_debug_keys(value ctx, value keys) { - CAMLparam2(ctx, keys); - int ret; - char *c_keys; + CAMLparam2(ctx, keys); + int ret; + char *c_keys; - c_keys = dup_String_val(keys); + c_keys = dup_String_val(keys); - caml_enter_blocking_section(); - ret = libxl_send_debug_keys(CTX, c_keys); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_send_debug_keys(CTX, c_keys); + caml_leave_blocking_section(); - free(c_keys); + free(c_keys); - if (ret != 0) - failwith_xl(ret, "send_debug_keys"); + if (ret != 0) + failwith_xl(ret, "send_debug_keys"); - CAMLreturn(Val_unit); + 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 + "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; + 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(); + 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; + handle = caml_alloc_custom(&libxl_console_reader_custom_operations, sizeof(cr), 0, 1); + Console_reader_val(handle) = cr; - CAMLreturn(handle); + CAMLreturn(handle); } static void raise_eof(void) { - static const value *exc = NULL; + static const value *exc = NULL; - /* First time around, lookup by name */ - if (!exc) - exc = caml_named_value("Xenlight.Host.End_of_file"); + /* 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"); + if (!exc) + caml_invalid_argument("Exception Xenlight.Host.End_of_file not initialized, please link xenlight.cma"); - caml_raise_constant(*exc); + 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); + 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(); + 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(); + if (ret < 0) + failwith_xl(ret, "xen_console_read_line"); + if (ret == 0) + raise_eof(); - line = caml_copy_string(c_line); + line = caml_copy_string(c_line); - CAMLreturn(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); + 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(); + caml_enter_blocking_section(); + libxl_xen_console_read_finish(CTX, cr); + caml_leave_blocking_section(); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } /* Event handling */ short Poll_val(value event) { - CAMLparam1(event); - short res = -1; + 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; - } + 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); + CAMLreturn(res); } short Poll_events_val(value event_list) { - CAMLparam1(event_list); - short events = 0; + CAMLparam1(event_list); + short events = 0; - while (event_list != Val_emptylist) { - events |= Poll_val(Field(event_list, 0)); - event_list = Field(event_list, 1); - } + while (event_list != Val_emptylist) { + events |= Poll_val(Field(event_list, 0)); + event_list = Field(event_list, 1); + } - CAMLreturn(events); + CAMLreturn(events); } value Val_poll(short event) { - CAMLparam0(); - CAMLlocal1(res); + 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; - } + 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); + CAMLreturn(res); } value add_event(value event_list, short event) { - CAMLparam1(event_list); - CAMLlocal1(new_list); + 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); + new_list = caml_alloc(2, 0); + Store_field(new_list, 0, Val_poll(event)); + Store_field(new_list, 1, event_list); - CAMLreturn(new_list); + CAMLreturn(new_list); } value Val_poll_events(short events) { - CAMLparam0(); - CAMLlocal1(event_list); + 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); + 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); + CAMLreturn(event_list); } /* The process for dealing with the for_app_registration_ values in the @@ -1273,385 +1273,385 @@ value Val_poll_events(short events) 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; + 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"); - } + 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; + 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 = 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; - } + *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; + caml_register_global_root(for_app); + *for_app_registration_out = for_app; err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + 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; + 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 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"); - } + 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); + 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 = 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; + *for_app_registration_update = for_app; err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + 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; + 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 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"); - } + 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; + 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_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); + caml_remove_global_root(for_app); + free(for_app); - CAMLdone; - caml_enter_blocking_section(); + CAMLdone; + caml_enter_blocking_section(); } struct timeout_handles { - void *for_libxl; - value for_app; + 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; + 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"); - } + 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); + 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; - } + /* 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; + handles->for_libxl = for_libxl; - args[0] = *p; - args[1] = sec; - args[2] = usec; - args[3] = (value) handles; + 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; - } + 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; + caml_register_global_root(&handles->for_app); + *for_app_registration_out = handles; err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + 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; + 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); + /* 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); + /* 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"); - } + 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; + 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; - } + 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; + handles->for_app = for_app_update; err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + 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(); + /* 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; + 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; + 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); + 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(); + 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; + result = caml_alloc(1, Abstract_tag); + *((libxl_osevent_hooks **) result) = hooks; - CAMLreturn(result); + CAMLreturn(result); } value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd, - value events, value revents) + 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); + 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(); + 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); + CAMLreturn(Val_unit); } value stub_libxl_osevent_occurred_timeout(value ctx, value handles) { - CAMLparam1(ctx); - struct timeout_handles *c_handles = (struct timeout_handles *) 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_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); + caml_remove_global_root(&c_handles->for_app); + free(c_handles); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } struct user_with_ctx { - libxl_ctx *ctx; - value user; + 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; + 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"); - } + 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); + 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(); + 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; + 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"); - } + 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); + 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(); + 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; + 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); + 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; + 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(); + 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; + result = caml_alloc(1, Abstract_tag); + *((libxl_event_hooks **) result) = hooks; - CAMLreturn(result); + 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; + 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(); + caml_enter_blocking_section(); + libxl_evenable_domain_death(CTX, c_domid, c_user, &evgen_out); + caml_leave_blocking_section(); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } /* diff --git a/tools/ocaml/libs/xs/queueop.ml b/tools/ocaml/libs/xs/queueop.ml index 4e532cdaea..e069ab7a9c 100644 --- a/tools/ocaml/libs/xs/queueop.ml +++ b/tools/ocaml/libs/xs/queueop.ml @@ -18,8 +18,8 @@ open Xenbus let data_concat ls = (String.concat "\000" ls) ^ "\000" let queue con pkt = let r = Xb.queue con pkt in assert (r <> None) let queue_path ty (tid: int) (path: string) con = - let data = data_concat [ path; ] in - queue con (Xb.Packet.create tid 0 ty data) + let data = data_concat [ path; ] in + queue con (Xb.Packet.create tid 0 ty data) (* operations *) let directory tid path con = queue_path Xb.Op.Directory tid path con @@ -28,48 +28,48 @@ let read tid path con = queue_path Xb.Op.Read tid path con let getperms tid path con = queue_path Xb.Op.Getperms tid path con let debug commands con = - queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands)) + queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands)) let watch path data con = - let data = data_concat [ path; data; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) + let data = data_concat [ path; data; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) let unwatch path data con = - let data = data_concat [ path; data; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) + let data = data_concat [ path; data; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) let transaction_start con = - queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat [])) + queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat [])) let transaction_end tid commit con = - let data = data_concat [ (if commit then "T" else "F"); ] in - queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data) + let data = data_concat [ (if commit then "T" else "F"); ] in + queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data) let introduce domid mfn port con = - let data = data_concat [ Printf.sprintf "%u" domid; - Printf.sprintf "%nu" mfn; - string_of_int port; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data) + let data = data_concat [ Printf.sprintf "%u" domid; + Printf.sprintf "%nu" mfn; + string_of_int port; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data) let release domid con = - let data = data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Release data) + let data = data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Release data) let resume domid con = - let data = data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) + let data = data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) let getdomainpath domid con = - let data = data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data) + let data = data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data) let write tid path value con = - let data = path ^ "\000" ^ value (* no NULL at the end *) in - queue con (Xb.Packet.create tid 0 Xb.Op.Write data) + let data = path ^ "\000" ^ value (* no NULL at the end *) in + queue con (Xb.Packet.create tid 0 Xb.Op.Write data) let mkdir tid path con = queue_path Xb.Op.Mkdir tid path con let rm tid path con = queue_path Xb.Op.Rm tid path con let setperms tid path perms con = - let data = data_concat [ path; perms ] in - queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data) + let data = data_concat [ path; perms ] in + queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data) diff --git a/tools/ocaml/libs/xs/xs.ml b/tools/ocaml/libs/xs/xs.ml index 90bd68d73d..55d4f010b6 100644 --- a/tools/ocaml/libs/xs/xs.ml +++ b/tools/ocaml/libs/xs/xs.ml @@ -19,46 +19,46 @@ type con = Xsraw.con type domid = int type xsh = -{ - con: con; - debug: string list -> string; - directory: string -> string list; - read: string -> string; - readv: string -> string list -> string list; - write: string -> string -> unit; - writev: string -> (string * string) list -> unit; - mkdir: string -> unit; - rm: string -> unit; - getperms: string -> perms; - setperms: string -> perms -> unit; - setpermsv: string -> string list -> perms -> unit; - introduce: domid -> nativeint -> int -> unit; - release: domid -> unit; - resume: domid -> unit; - getdomainpath: domid -> string; - watch: string -> string -> unit; - unwatch: string -> string -> unit; -} + { + con: con; + debug: string list -> string; + directory: string -> string list; + read: string -> string; + readv: string -> string list -> string list; + write: string -> string -> unit; + writev: string -> (string * string) list -> unit; + mkdir: string -> unit; + rm: string -> unit; + getperms: string -> perms; + setperms: string -> perms -> unit; + setpermsv: string -> string list -> perms -> unit; + introduce: domid -> nativeint -> int -> unit; + release: domid -> unit; + resume: domid -> unit; + getdomainpath: domid -> string; + watch: string -> string -> unit; + unwatch: string -> string -> unit; + } let get_operations con = { - con = con; - debug = (fun commands -> Xsraw.debug commands con); - directory = (fun path -> Xsraw.directory 0 path con); - read = (fun path -> Xsraw.read 0 path con); - readv = (fun dir vec -> Xsraw.readv 0 dir vec con); - write = (fun path value -> Xsraw.write 0 path value con); - writev = (fun dir vec -> Xsraw.writev 0 dir vec con); - mkdir = (fun path -> Xsraw.mkdir 0 path con); - rm = (fun path -> Xsraw.rm 0 path con); - getperms = (fun path -> Xsraw.getperms 0 path con); - setperms = (fun path perms -> Xsraw.setperms 0 path perms con); - setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con); - introduce = (fun id mfn port -> Xsraw.introduce id mfn port con); - release = (fun id -> Xsraw.release id con); - resume = (fun id -> Xsraw.resume id con); - getdomainpath = (fun id -> Xsraw.getdomainpath id con); - watch = (fun path data -> Xsraw.watch path data con); - unwatch = (fun path data -> Xsraw.unwatch path data con); + con = con; + debug = (fun commands -> Xsraw.debug commands con); + directory = (fun path -> Xsraw.directory 0 path con); + read = (fun path -> Xsraw.read 0 path con); + readv = (fun dir vec -> Xsraw.readv 0 dir vec con); + write = (fun path value -> Xsraw.write 0 path value con); + writev = (fun dir vec -> Xsraw.writev 0 dir vec con); + mkdir = (fun path -> Xsraw.mkdir 0 path con); + rm = (fun path -> Xsraw.rm 0 path con); + getperms = (fun path -> Xsraw.getperms 0 path con); + setperms = (fun path perms -> Xsraw.setperms 0 path perms con); + setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con); + introduce = (fun id mfn port -> Xsraw.introduce id mfn port con); + release = (fun id -> Xsraw.release id con); + resume = (fun id -> Xsraw.resume id con); + getdomainpath = (fun id -> Xsraw.getdomainpath id con); + watch = (fun path data -> Xsraw.watch path data con); + unwatch = (fun path data -> Xsraw.unwatch path data con); } let transaction xsh = Xst.transaction xsh.con @@ -81,71 +81,71 @@ exception Timeout_with_nonempty_queue let max_blocking_time = 5. (* seconds *) let read_watchevent_timeout xsh timeout callback = - let start_time = Unix.gettimeofday () in - let end_time = start_time +. timeout in + let start_time = Unix.gettimeofday () in + let end_time = start_time +. timeout in - let left = ref timeout in + let left = ref timeout in - (* Returns true if a watch event in the queue satisfied us *) - let process_queued_events () = - let success = ref false in - while Xsraw.has_watchevents xsh.con && not(!success) - do - success := callback (Xsraw.get_watchevent xsh.con) - done; - !success in - (* Returns true if a watch event read from the socket satisfied us *) - let process_incoming_event () = - let fd = get_fd xsh in - let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in + (* Returns true if a watch event in the queue satisfied us *) + let process_queued_events () = + let success = ref false in + while Xsraw.has_watchevents xsh.con && not(!success) + do + success := callback (Xsraw.get_watchevent xsh.con) + done; + !success in + (* Returns true if a watch event read from the socket satisfied us *) + let process_incoming_event () = + let fd = get_fd xsh in + let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in - (* If data is available for reading then read it *) - if r = [] - then false (* timeout, either a max_blocking_time or global *) - else callback (Xsraw.read_watchevent xsh.con) in + (* If data is available for reading then read it *) + if r = [] + then false (* timeout, either a max_blocking_time or global *) + else callback (Xsraw.read_watchevent xsh.con) in - let success = ref false in - while !left > 0. && not(!success) - do - (* NB the 'callback' might call back into Xs functions - and as a side-effect, watches might be queued. Hence - we must process the queue on every loop iteration *) + let success = ref false in + while !left > 0. && not(!success) + do + (* NB the 'callback' might call back into Xs functions + and as a side-effect, watches might be queued. Hence + we must process the queue on every loop iteration *) - (* First process all queued watch events *) - if not(!success) - then success := process_queued_events (); - (* Then block for one more watch event *) - if not(!success) - then success := process_incoming_event (); - (* Just in case our callback caused events to be queued - and this is our last time round the loop: this prevents - us throwing the Timeout_with_nonempty_queue spuriously *) - if not(!success) - then success := process_queued_events (); + (* First process all queued watch events *) + if not(!success) + then success := process_queued_events (); + (* Then block for one more watch event *) + if not(!success) + then success := process_incoming_event (); + (* Just in case our callback caused events to be queued + and this is our last time round the loop: this prevents + us throwing the Timeout_with_nonempty_queue spuriously *) + if not(!success) + then success := process_queued_events (); - (* Update the time left *) - let current_time = Unix.gettimeofday () in - left := end_time -. current_time - done; - if not(!success) then begin - (* Sanity check: it should be impossible for any - events to be queued here *) - if Xsraw.has_watchevents xsh.con - then raise Timeout_with_nonempty_queue - else raise Timeout - end + (* Update the time left *) + let current_time = Unix.gettimeofday () in + left := end_time -. current_time + done; + if not(!success) then begin + (* Sanity check: it should be impossible for any + events to be queued here *) + if Xsraw.has_watchevents xsh.con + then raise Timeout_with_nonempty_queue + else raise Timeout + end let monitor_paths xsh l time callback = - let unwatch () = - List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in - List.iter (fun (w,v) -> xsh.watch w v) l; - begin try - read_watchevent_timeout xsh time callback; - with - exn -> unwatch (); raise exn; - end; - unwatch () + let unwatch () = + List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in + List.iter (fun (w,v) -> xsh.watch w v) l; + begin try + read_watchevent_timeout xsh time callback; + with + exn -> unwatch (); raise exn; + end; + unwatch () let daemon_socket = Paths.xen_run_stored ^ "/socket" @@ -153,24 +153,24 @@ let daemon_socket = Paths.xen_run_stored ^ "/socket" exception Failed_to_connect let daemon_open () = - try - let sockaddr = Unix.ADDR_UNIX(daemon_socket) in - let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unix.connect sock sockaddr; - Unix.set_close_on_exec sock; - make sock - with _ -> raise Failed_to_connect + try + let sockaddr = Unix.ADDR_UNIX(daemon_socket) in + let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.connect sock sockaddr; + Unix.set_close_on_exec sock; + make sock + with _ -> raise Failed_to_connect let domain_open () = - let path = try - let devpath = "/dev/xen/xenbus" in - Unix.access devpath [ Unix.F_OK ]; - devpath - with Unix.Unix_error(_, _, _) -> - "/proc/xen/xenbus" in + let path = try + let devpath = "/dev/xen/xenbus" in + Unix.access devpath [ Unix.F_OK ]; + devpath + with Unix.Unix_error(_, _, _) -> + "/proc/xen/xenbus" in - let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in - Unix.set_close_on_exec fd; - make fd + let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in + Unix.set_close_on_exec fd; + make fd let close xsh = Xsraw.close xsh.con diff --git a/tools/ocaml/libs/xs/xs.mli b/tools/ocaml/libs/xs/xs.mli index ce505b659b..cf8855c7d8 100644 --- a/tools/ocaml/libs/xs/xs.mli +++ b/tools/ocaml/libs/xs/xs.mli @@ -23,31 +23,31 @@ exception Failed_to_connect - owner domid. - other perm: applied to domain that is not owner or in ACL. - ACL: list of per-domain permission - *) +*) type perms = Xsraw.perms type domid = int type con type xsh = { - con : con; - debug: string list -> string; - directory : string -> string list; - read : string -> string; - readv : string -> string list -> string list; - write : string -> string -> unit; - writev : string -> (string * string) list -> unit; - mkdir : string -> unit; - rm : string -> unit; - getperms : string -> perms; - setperms : string -> perms -> unit; - setpermsv : string -> string list -> perms -> unit; - introduce : domid -> nativeint -> int -> unit; - release : domid -> unit; - resume : domid -> unit; - getdomainpath : domid -> string; - watch : string -> string -> unit; - unwatch : string -> string -> unit; + con : con; + debug: string list -> string; + directory : string -> string list; + read : string -> string; + readv : string -> string list -> string list; + write : string -> string -> unit; + writev : string -> (string * string) list -> unit; + mkdir : string -> unit; + rm : string -> unit; + getperms : string -> perms; + setperms : string -> perms -> unit; + setpermsv : string -> string list -> perms -> unit; + introduce : domid -> nativeint -> int -> unit; + release : domid -> unit; + resume : domid -> unit; + getdomainpath : domid -> string; + watch : string -> string -> unit; + unwatch : string -> string -> unit; } (** get operations provide a vector of xenstore function that apply to one @@ -75,10 +75,10 @@ val read_watchevent_timeout : xsh -> float -> (string * string -> bool) -> unit (** register a set of watches, then wait for watchevent. remove all watches previously set before giving back the hand. *) val monitor_paths : xsh - -> (string * string) list - -> float - -> (string * string -> bool) - -> unit + -> (string * string) list + -> float + -> (string * string -> bool) + -> unit (** open a socket-based xenstored connection *) val daemon_open : unit -> xsh diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml index cbd1728060..d51e40eed3 100644 --- a/tools/ocaml/libs/xs/xsraw.ml +++ b/tools/ocaml/libs/xs/xsraw.ml @@ -23,239 +23,239 @@ exception Unexpected_packet of string exception Invalid_path of string let unexpected_packet expected received = - let s = Printf.sprintf "expecting %s received %s" - (Xb.Op.to_string expected) - (Xb.Op.to_string received) in - raise (Unexpected_packet s) + let s = Printf.sprintf "expecting %s received %s" + (Xb.Op.to_string expected) + (Xb.Op.to_string received) in + raise (Unexpected_packet s) type con = { - xb: Xenbus.Xb.t; - watchevents: (string * string) Queue.t; + xb: Xenbus.Xb.t; + watchevents: (string * string) Queue.t; } let close con = - Xb.close con.xb + Xb.close con.xb let capacity = { Xb.maxoutstanding = 1; maxwatchevents = 0; } let open_fd fd = { - xb = Xb.open_fd ~capacity fd; - watchevents = Queue.create (); + xb = Xb.open_fd ~capacity fd; + watchevents = Queue.create (); } let rec split_string ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split_string ~limit: nlimit c b) + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split_string ~limit: nlimit c b) type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR type perms = int * perm * (int * perm) list let string_of_perms perms = - let owner, other, acl = perms in - let char_of_perm perm = - match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' - | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in - let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in - String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) + let owner, other, acl = perms in + let char_of_perm perm = + match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' + | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in + let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in + String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) let perms_of_string s = - let perm_of_char c = - match c with 'n' -> PERM_NONE | 'r' -> PERM_READ - | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR - | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in - let perm_of_string s = - if String.length s < 2 - then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s) - else - begin - int_of_string (String.sub s 1 (String.length s - 1)), - perm_of_char s.[0] - end in - let rec split s = - try let i = String.index s '\000' in - String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i)) - with Not_found -> if s = "" then [] else [ s ] in - let l = List.map perm_of_string (split s) in - match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, []) + let perm_of_char c = + match c with 'n' -> PERM_NONE | 'r' -> PERM_READ + | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR + | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in + let perm_of_string s = + if String.length s < 2 + then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s) + else + begin + int_of_string (String.sub s 1 (String.length s - 1)), + perm_of_char s.[0] + end in + let rec split s = + try let i = String.index s '\000' in + String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i)) + with Not_found -> if s = "" then [] else [ s ] in + let l = List.map perm_of_string (split s) in + match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, []) (* send one packet - can sleep *) let pkt_send con = - if Xb.has_old_output con.xb then - raise Partial_not_empty; - let workdone = ref false in - while not !workdone - do - workdone := Xb.output con.xb - done + if Xb.has_old_output con.xb then + raise Partial_not_empty; + let workdone = ref false in + while not !workdone + do + workdone := Xb.output con.xb + done (* receive one packet - can sleep *) let rec pkt_recv con = - match Xb.input con.xb with - | Some packet -> packet - | None -> pkt_recv con + match Xb.input con.xb with + | Some packet -> packet + | None -> pkt_recv con let pkt_recv_timeout con timeout = - let fd = Xb.get_fd con.xb in - let r, _, _ = Unix.select [ fd ] [] [] timeout in - if r = [] then - true, None - else - false, Xb.input con.xb + let fd = Xb.get_fd con.xb in + let r, _, _ = Unix.select [ fd ] [] [] timeout in + if r = [] then + true, None + else + false, Xb.input con.xb let queue_watchevent con data = - let ls = split_string ~limit:2 '\000' data in - if List.length ls != 2 then - raise (Xb.Packet.DataError "arguments number mismatch"); - let event = List.nth ls 0 - and event_data = List.nth ls 1 in - Queue.push (event, event_data) con.watchevents + let ls = split_string ~limit:2 '\000' data in + if List.length ls != 2 then + raise (Xb.Packet.DataError "arguments number mismatch"); + let event = List.nth ls 0 + and event_data = List.nth ls 1 in + Queue.push (event, event_data) con.watchevents let has_watchevents con = Queue.length con.watchevents > 0 let get_watchevent con = Queue.pop con.watchevents let read_watchevent con = - let pkt = pkt_recv con in - match Xb.Packet.get_ty pkt with - | Xb.Op.Watchevent -> - queue_watchevent con (Xb.Packet.get_data pkt); - Queue.pop con.watchevents - | ty -> unexpected_packet Xb.Op.Watchevent ty + let pkt = pkt_recv con in + match Xb.Packet.get_ty pkt with + | Xb.Op.Watchevent -> + queue_watchevent con (Xb.Packet.get_data pkt); + Queue.pop con.watchevents + | ty -> unexpected_packet Xb.Op.Watchevent ty (* send one packet in the queue, and wait for reply *) let rec sync_recv ty con = - let pkt = pkt_recv con in - match Xb.Packet.get_ty pkt with - | Xb.Op.Error -> ( - match Xb.Packet.get_data pkt with - | "ENOENT" -> raise Xb.Noent - | "EAGAIN" -> raise Xb.Eagain - | "EINVAL" -> raise Xb.Invalid - | s -> raise (Xb.Packet.Error s)) - | Xb.Op.Watchevent -> - queue_watchevent con (Xb.Packet.get_data pkt); - sync_recv ty con - | rty when rty = ty -> Xb.Packet.get_data pkt - | rty -> unexpected_packet ty rty + let pkt = pkt_recv con in + match Xb.Packet.get_ty pkt with + | Xb.Op.Error -> ( + match Xb.Packet.get_data pkt with + | "ENOENT" -> raise Xb.Noent + | "EAGAIN" -> raise Xb.Eagain + | "EINVAL" -> raise Xb.Invalid + | s -> raise (Xb.Packet.Error s)) + | Xb.Op.Watchevent -> + queue_watchevent con (Xb.Packet.get_data pkt); + sync_recv ty con + | rty when rty = ty -> Xb.Packet.get_data pkt + | rty -> unexpected_packet ty rty let sync f con = - (* queue a query using function f *) - f con.xb; - if Xb.output_len con.xb = 0 then - Printf.printf "output len = 0\n%!"; - let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in - pkt_send con; - sync_recv ty con + (* queue a query using function f *) + f con.xb; + if Xb.output_len con.xb = 0 then + Printf.printf "output len = 0\n%!"; + let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in + pkt_send con; + sync_recv ty con let ack s = - if s = "OK" then () else raise (Xb.Packet.DataError s) + if s = "OK" then () else raise (Xb.Packet.DataError s) (** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches) *) let validate_path path = - (* Paths shouldn't have a "//" in the middle *) - let bad = "//" in - for offset = 0 to String.length path - (String.length bad) do - if String.sub path offset (String.length bad) = bad then - raise (Invalid_path path) - done; - (* Paths shouldn't have a "/" at the end, except for the root *) - if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then - raise (Invalid_path path) + (* Paths shouldn't have a "//" in the middle *) + let bad = "//" in + for offset = 0 to String.length path - (String.length bad) do + if String.sub path offset (String.length bad) = bad then + raise (Invalid_path path) + done; + (* Paths shouldn't have a "/" at the end, except for the root *) + if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then + raise (Invalid_path path) (** Check to see if a path is suitable for watches *) let validate_watch_path path = - (* Check for stuff like @releaseDomain etc first *) - if path <> "" && path.[0] = '@' then () - else validate_path path + (* Check for stuff like @releaseDomain etc first *) + if path <> "" && path.[0] = '@' then () + else validate_path path let debug command con = - sync (Queueop.debug command) con + sync (Queueop.debug command) con let directory tid path con = - validate_path path; - let data = sync (Queueop.directory tid path) con in - split_string '\000' data + validate_path path; + let data = sync (Queueop.directory tid path) con in + split_string '\000' data let read tid path con = - validate_path path; - sync (Queueop.read tid path) con + validate_path path; + sync (Queueop.read tid path) con let readv tid dir vec con = - List.map (fun path -> validate_path path; read tid path con) - (if dir <> "" then - (List.map (fun v -> dir ^ "/" ^ v) vec) else vec) + List.map (fun path -> validate_path path; read tid path con) + (if dir <> "" then + (List.map (fun v -> dir ^ "/" ^ v) vec) else vec) let getperms tid path con = - validate_path path; - perms_of_string (sync (Queueop.getperms tid path) con) + validate_path path; + perms_of_string (sync (Queueop.getperms tid path) con) let watch path data con = - validate_watch_path path; - ack (sync (Queueop.watch path data) con) + validate_watch_path path; + ack (sync (Queueop.watch path data) con) let unwatch path data con = - validate_watch_path path; - ack (sync (Queueop.unwatch path data) con) + validate_watch_path path; + ack (sync (Queueop.unwatch path data) con) let transaction_start con = - let data = sync (Queueop.transaction_start) con in - try - int_of_string data - with - _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data)) + let data = sync (Queueop.transaction_start) con in + try + int_of_string data + with + _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data)) let transaction_end tid commit con = - try - ack (sync (Queueop.transaction_end tid commit) con); - true - with - Xb.Eagain -> false + try + ack (sync (Queueop.transaction_end tid commit) con); + true + with + Xb.Eagain -> false let introduce domid mfn port con = - ack (sync (Queueop.introduce domid mfn port) con) + ack (sync (Queueop.introduce domid mfn port) con) let release domid con = - ack (sync (Queueop.release domid) con) + ack (sync (Queueop.release domid) con) let resume domid con = - ack (sync (Queueop.resume domid) con) + ack (sync (Queueop.resume domid) con) let getdomainpath domid con = - sync (Queueop.getdomainpath domid) con + sync (Queueop.getdomainpath domid) con let write tid path value con = - validate_path path; - ack (sync (Queueop.write tid path value) con) + validate_path path; + ack (sync (Queueop.write tid path value) con) let writev tid dir vec con = - List.iter (fun (entry, value) -> - let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in - validate_path path; - write tid path value con) vec + List.iter (fun (entry, value) -> + let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + write tid path value con) vec let mkdir tid path con = - validate_path path; - ack (sync (Queueop.mkdir tid path) con) + validate_path path; + ack (sync (Queueop.mkdir tid path) con) let rm tid path con = - validate_path path; - try - ack (sync (Queueop.rm tid path) con) - with - Xb.Noent -> () + validate_path path; + try + ack (sync (Queueop.rm tid path) con) + with + Xb.Noent -> () let setperms tid path perms con = - validate_path path; - ack (sync (Queueop.setperms tid path (string_of_perms perms)) con) + validate_path path; + ack (sync (Queueop.setperms tid path (string_of_perms perms)) con) let setpermsv tid dir vec perms con = - List.iter (fun entry -> - let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in - validate_path path; - setperms tid path perms con) vec + List.iter (fun entry -> + let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + setperms tid path perms con) vec diff --git a/tools/ocaml/libs/xs/xst.ml b/tools/ocaml/libs/xs/xst.ml index 16affd2e07..50a980b915 100644 --- a/tools/ocaml/libs/xs/xst.ml +++ b/tools/ocaml/libs/xs/xst.ml @@ -15,47 +15,47 @@ *) type ops = -{ - directory: string -> string list; - read: string -> string; - readv: string -> string list -> string list; - write: string -> string -> unit; - writev: string -> (string * string) list -> unit; - mkdir: string -> unit; - rm: string -> unit; - getperms: string -> Xsraw.perms; - setperms: string -> Xsraw.perms -> unit; - setpermsv: string -> string list -> Xsraw.perms -> unit; -} + { + directory: string -> string list; + read: string -> string; + readv: string -> string list -> string list; + write: string -> string -> unit; + writev: string -> (string * string) list -> unit; + mkdir: string -> unit; + rm: string -> unit; + getperms: string -> Xsraw.perms; + setperms: string -> Xsraw.perms -> unit; + setpermsv: string -> string list -> Xsraw.perms -> unit; + } let get_operations tid xsh = { - directory = (fun path -> Xsraw.directory tid path xsh); - read = (fun path -> Xsraw.read tid path xsh); - readv = (fun dir vec -> Xsraw.readv tid dir vec xsh); - write = (fun path value -> Xsraw.write tid path value xsh); - writev = (fun dir vec -> Xsraw.writev tid dir vec xsh); - mkdir = (fun path -> Xsraw.mkdir tid path xsh); - rm = (fun path -> Xsraw.rm tid path xsh); - getperms = (fun path -> Xsraw.getperms tid path xsh); - setperms = (fun path perms -> Xsraw.setperms tid path perms xsh); - setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh); + directory = (fun path -> Xsraw.directory tid path xsh); + read = (fun path -> Xsraw.read tid path xsh); + readv = (fun dir vec -> Xsraw.readv tid dir vec xsh); + write = (fun path value -> Xsraw.write tid path value xsh); + writev = (fun dir vec -> Xsraw.writev tid dir vec xsh); + mkdir = (fun path -> Xsraw.mkdir tid path xsh); + rm = (fun path -> Xsraw.rm tid path xsh); + getperms = (fun path -> Xsraw.getperms tid path xsh); + setperms = (fun path perms -> Xsraw.setperms tid path perms xsh); + setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh); } let transaction xsh (f: ops -> 'a) : 'a = - let commited = ref false and result = ref None in - while not !commited - do - let tid = Xsraw.transaction_start xsh in - let t = get_operations tid xsh in + let commited = ref false and result = ref None in + while not !commited + do + let tid = Xsraw.transaction_start xsh in + let t = get_operations tid xsh in - begin try - result := Some (f t) - with exn -> - ignore (Xsraw.transaction_end tid false xsh); - raise exn - end; - commited := Xsraw.transaction_end tid true xsh - done; - match !result with - | None -> failwith "internal error in transaction" - | Some result -> result + begin try + result := Some (f t) + with exn -> + ignore (Xsraw.transaction_end tid false xsh); + raise exn + end; + commited := Xsraw.transaction_end tid true xsh + done; + match !result with + | None -> failwith "internal error in transaction" + | Some result -> result diff --git a/tools/ocaml/libs/xs/xst.mli b/tools/ocaml/libs/xs/xst.mli index 5ae560424c..08d737bc36 100644 --- a/tools/ocaml/libs/xs/xst.mli +++ b/tools/ocaml/libs/xs/xst.mli @@ -14,16 +14,16 @@ * GNU Lesser General Public License for more details. *) type ops = { - directory : string -> string list; - read : string -> string; - readv : string -> string list -> string list; - write : string -> string -> unit; - writev : string -> (string * string) list -> unit; - mkdir : string -> unit; - rm : string -> unit; - getperms : string -> Xsraw.perms; - setperms : string -> Xsraw.perms -> unit; - setpermsv : string -> string list -> Xsraw.perms -> unit; + directory : string -> string list; + read : string -> string; + readv : string -> string list -> string list; + write : string -> string -> unit; + writev : string -> (string * string) list -> unit; + mkdir : string -> unit; + rm : string -> unit; + getperms : string -> Xsraw.perms; + setperms : string -> Xsraw.perms -> unit; + setpermsv : string -> string list -> Xsraw.perms -> unit; } val get_operations : int -> Xsraw.con -> ops diff --git a/tools/ocaml/test/dmesg.ml b/tools/ocaml/test/dmesg.ml index c868024c52..f9efe5dc30 100644 --- a/tools/ocaml/test/dmesg.ml +++ b/tools/ocaml/test/dmesg.ml @@ -1,17 +1,17 @@ let _ = - Xenlight.register_exceptions (); - let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in - let ctx = Xenlight.ctx_alloc logger in + 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 - () + 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 + () diff --git a/tools/ocaml/test/list_domains.ml b/tools/ocaml/test/list_domains.ml index c8974957fd..94f1cec050 100644 --- a/tools/ocaml/test/list_domains.ml +++ b/tools/ocaml/test/list_domains.ml @@ -20,7 +20,7 @@ let _ = 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 + 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 index 5ef7fc0f13..8c24c3555b 100644 --- a/tools/ocaml/test/raise_exception.ml +++ b/tools/ocaml/test/raise_exception.ml @@ -4,6 +4,6 @@ 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 + printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn; + end diff --git a/tools/ocaml/test/xtl.ml b/tools/ocaml/test/xtl.ml index 5f94a76a82..458b11bbaa 100644 --- a/tools/ocaml/test/xtl.ml +++ b/tools/ocaml/test/xtl.ml @@ -2,24 +2,24 @@ 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 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 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 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 diff --git a/tools/ocaml/xenstored/config.ml b/tools/ocaml/xenstored/config.ml index 0ee7bc32ff..95ef745a54 100644 --- a/tools/ocaml/xenstored/config.ml +++ b/tools/ocaml/xenstored/config.ml @@ -15,98 +15,98 @@ *) type ty = - | Set_bool of bool ref - | Set_int of int ref - | Set_string of string ref - | Set_float of float ref - | Unit of (unit -> unit) - | Bool of (bool -> unit) - | Int of (int -> unit) - | String of (string -> unit) - | Float of (float -> unit) + | Set_bool of bool ref + | Set_int of int ref + | Set_string of string ref + | Set_float of float ref + | Unit of (unit -> unit) + | Bool of (bool -> unit) + | Int of (int -> unit) + | String of (string -> unit) + | Float of (float -> unit) exception Error of (string * string) list let trim_start lc s = - let len = String.length s and i = ref 0 in - while !i < len && (List.mem s.[!i] lc) - do - incr i - done; - if !i < len then String.sub s !i (len - !i) else "" + let len = String.length s and i = ref 0 in + while !i < len && (List.mem s.[!i] lc) + do + incr i + done; + if !i < len then String.sub s !i (len - !i) else "" let trim_end lc s = - let i = ref (String.length s - 1) in - while !i > 0 && (List.mem s.[!i] lc) - do - decr i - done; - if !i >= 0 then String.sub s 0 (!i + 1) else "" + let i = ref (String.length s - 1) in + while !i > 0 && (List.mem s.[!i] lc) + do + decr i + done; + if !i >= 0 then String.sub s 0 (!i + 1) else "" let rec split ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) let parse_line stream = - let lc = [ ' '; '\t' ] in - let trim_spaces s = trim_end lc (trim_start lc s) in - let to_config s = - match split ~limit:2 '=' s with - | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) - | _ -> None in - let rec read_filter_line () = - try - let line = trim_spaces (input_line stream) in - if String.length line > 0 && line.[0] <> '#' then - match to_config line with - | None -> read_filter_line () - | Some x -> x :: read_filter_line () - else - read_filter_line () - with - End_of_file -> [] in - read_filter_line () + let lc = [ ' '; '\t' ] in + let trim_spaces s = trim_end lc (trim_start lc s) in + let to_config s = + match split ~limit:2 '=' s with + | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) + | _ -> None in + let rec read_filter_line () = + try + let line = trim_spaces (input_line stream) in + if String.length line > 0 && line.[0] <> '#' then + match to_config line with + | None -> read_filter_line () + | Some x -> x :: read_filter_line () + else + read_filter_line () + with + End_of_file -> [] in + read_filter_line () let parse filename = - let stream = open_in filename in - let cf = parse_line stream in - close_in stream; - cf + let stream = open_in filename in + let cf = parse_line stream in + close_in stream; + cf let validate cf expected other = - let err = ref [] in - let append x = err := x :: !err in - List.iter (fun (k, v) -> - try - if not (List.mem_assoc k expected) then - other k v - else let ty = List.assoc k expected in - match ty with - | Unit f -> f () - | Bool f -> f (bool_of_string v) - | String f -> f v - | Int f -> f (int_of_string v) - | Float f -> f (float_of_string v) - | Set_bool r -> r := (bool_of_string v) - | Set_string r -> r := v - | Set_int r -> r := int_of_string v - | Set_float r -> r := (float_of_string v) - with - | Not_found -> append (k, "unknown key") - | Failure "int_of_string" -> append (k, "expect int arg") - | Failure "bool_of_string" -> append (k, "expect bool arg") - | Failure "float_of_string" -> append (k, "expect float arg") - | exn -> append (k, Printexc.to_string exn) - ) cf; - if !err != [] then raise (Error !err) + let err = ref [] in + let append x = err := x :: !err in + List.iter (fun (k, v) -> + try + if not (List.mem_assoc k expected) then + other k v + else let ty = List.assoc k expected in + match ty with + | Unit f -> f () + | Bool f -> f (bool_of_string v) + | String f -> f v + | Int f -> f (int_of_string v) + | Float f -> f (float_of_string v) + | Set_bool r -> r := (bool_of_string v) + | Set_string r -> r := v + | Set_int r -> r := int_of_string v + | Set_float r -> r := (float_of_string v) + with + | Not_found -> append (k, "unknown key") + | Failure "int_of_string" -> append (k, "expect int arg") + | Failure "bool_of_string" -> append (k, "expect bool arg") + | Failure "float_of_string" -> append (k, "expect float arg") + | exn -> append (k, Printexc.to_string exn) + ) cf; + if !err != [] then raise (Error !err) (** read a filename, parse and validate, and return the errors if any *) let read filename expected other = - let cf = parse filename in - validate cf expected other + let cf = parse filename in + validate cf expected other diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml index 54f7f76516..fcff0f332e 100644 --- a/tools/ocaml/xenstored/connection.ml +++ b/tools/ocaml/xenstored/connection.ml @@ -24,281 +24,281 @@ type 'a bounded_sender = 'a -> unit option (** a bounded sender accepts an ['a] item and returns: None - if there is no room to accept the item Some () - if it has successfully accepted/sent the item - *) +*) module BoundedPipe : sig - type 'a t + type 'a t - (** [create ~capacity ~destination] creates a bounded pipe with a - local buffer holding at most [capacity] items. Once the buffer is - full it will not accept further items. items from the pipe are - flushed into [destination] as long as it accepts items. The - destination could be another pipe. - *) - val create: capacity:int -> destination:'a bounded_sender -> 'a t + (** [create ~capacity ~destination] creates a bounded pipe with a + local buffer holding at most [capacity] items. Once the buffer is + full it will not accept further items. items from the pipe are + flushed into [destination] as long as it accepts items. The + destination could be another pipe. + *) + val create: capacity:int -> destination:'a bounded_sender -> 'a t - (** [is_empty t] returns whether the local buffer of [t] is empty. *) - val is_empty : _ t -> bool + (** [is_empty t] returns whether the local buffer of [t] is empty. *) + val is_empty : _ t -> bool - (** [length t] the number of items in the internal buffer *) - val length: _ t -> int + (** [length t] the number of items in the internal buffer *) + val length: _ t -> int - (** [flush_pipe t] sends as many items from the local buffer as possible, - which could be none. *) - val flush_pipe: _ t -> unit + (** [flush_pipe t] sends as many items from the local buffer as possible, + which could be none. *) + val flush_pipe: _ t -> unit - (** [push t item] tries to [flush_pipe] and then push [item] - into the pipe if its [capacity] allows. - Returns [None] if there is no more room - *) - val push : 'a t -> 'a bounded_sender + (** [push t item] tries to [flush_pipe] and then push [item] + into the pipe if its [capacity] allows. + Returns [None] if there is no more room + *) + val push : 'a t -> 'a bounded_sender end = struct - (* items are enqueued in [q], and then flushed to [connect_to] *) - type 'a t = - { q: 'a Queue.t - ; destination: 'a bounded_sender - ; capacity: int - } + (* items are enqueued in [q], and then flushed to [connect_to] *) + type 'a t = + { q: 'a Queue.t + ; destination: 'a bounded_sender + ; capacity: int + } - let create ~capacity ~destination = - { q = Queue.create (); capacity; destination } + let create ~capacity ~destination = + { q = Queue.create (); capacity; destination } - let rec flush_pipe t = - if not Queue.(is_empty t.q) then - let item = Queue.peek t.q in - match t.destination item with - | None -> () (* no room *) - | Some () -> - (* successfully sent item to next stage *) - let _ = Queue.pop t.q in - (* continue trying to send more items *) - flush_pipe t + let rec flush_pipe t = + if not Queue.(is_empty t.q) then + let item = Queue.peek t.q in + match t.destination item with + | None -> () (* no room *) + | Some () -> + (* successfully sent item to next stage *) + let _ = Queue.pop t.q in + (* continue trying to send more items *) + flush_pipe t - let push t item = - (* first try to flush as many items from this pipe as possible to make room, - it is important to do this first to preserve the order of the items - *) - flush_pipe t; - if Queue.length t.q < t.capacity then begin - (* enqueue, instead of sending directly. - this ensures that [out] sees the items in the same order as we receive them - *) - Queue.push item t.q; - Some (flush_pipe t) - end else None + let push t item = + (* first try to flush as many items from this pipe as possible to make room, + it is important to do this first to preserve the order of the items + *) + flush_pipe t; + if Queue.length t.q < t.capacity then begin + (* enqueue, instead of sending directly. + this ensures that [out] sees the items in the same order as we receive them + *) + Queue.push item t.q; + Some (flush_pipe t) + end else None - let is_empty t = Queue.is_empty t.q - let length t = Queue.length t.q + let is_empty t = Queue.is_empty t.q + let length t = Queue.length t.q end type watch = { - con: t; - token: string; - path: string; - base: string; - is_relative: bool; - pending_watchevents: Xenbus.Xb.Packet.t BoundedPipe.t; + con: t; + token: string; + path: string; + base: string; + is_relative: bool; + pending_watchevents: Xenbus.Xb.Packet.t BoundedPipe.t; } and t = { - xb: Xenbus.Xb.t; - dom: Domain.t option; - transactions: (int, Transaction.t) Hashtbl.t; - mutable next_tid: int; - watches: (string, watch list) Hashtbl.t; - mutable nb_watches: int; - anonid: int; - mutable stat_nb_ops: int; - mutable perm: Perms.Connection.t; - pending_source_watchevents: (watch * Xenbus.Xb.Packet.t) BoundedPipe.t + xb: Xenbus.Xb.t; + dom: Domain.t option; + transactions: (int, Transaction.t) Hashtbl.t; + mutable next_tid: int; + watches: (string, watch list) Hashtbl.t; + mutable nb_watches: int; + anonid: int; + mutable stat_nb_ops: int; + mutable perm: Perms.Connection.t; + pending_source_watchevents: (watch * Xenbus.Xb.Packet.t) BoundedPipe.t } module Watch = struct - module T = struct - type t = watch + module T = struct + type t = watch - let compare w1 w2 = - (* cannot compare watches from different connections *) - assert (w1.con == w2.con); - match String.compare w1.token w2.token with - | 0 -> String.compare w1.path w2.path - | n -> n - end - module Set = Set.Make(T) + let compare w1 w2 = + (* cannot compare watches from different connections *) + assert (w1.con == w2.con); + match String.compare w1.token w2.token with + | 0 -> String.compare w1.path w2.path + | n -> n + end + module Set = Set.Make(T) - let flush_events t = - BoundedPipe.flush_pipe t.pending_watchevents; - not (BoundedPipe.is_empty t.pending_watchevents) + let flush_events t = + BoundedPipe.flush_pipe t.pending_watchevents; + not (BoundedPipe.is_empty t.pending_watchevents) - let pending_watchevents t = - BoundedPipe.length t.pending_watchevents + let pending_watchevents t = + BoundedPipe.length t.pending_watchevents end let source_flush_watchevents t = - BoundedPipe.flush_pipe t.pending_source_watchevents + BoundedPipe.flush_pipe t.pending_source_watchevents let source_pending_watchevents t = - BoundedPipe.length t.pending_source_watchevents + BoundedPipe.length t.pending_source_watchevents let mark_as_bad con = - match con.dom with - |None -> () - | Some domain -> Domain.mark_as_bad domain + match con.dom with + |None -> () + | Some domain -> Domain.mark_as_bad domain let initial_next_tid = 1 let do_reconnect con = - Xenbus.Xb.reconnect con.xb; - (* dom is the same *) - Hashtbl.clear con.transactions; - con.next_tid <- initial_next_tid; - Hashtbl.clear con.watches; - (* anonid is the same *) - con.nb_watches <- 0; - con.stat_nb_ops <- 0; - (* perm is the same *) - () + Xenbus.Xb.reconnect con.xb; + (* dom is the same *) + Hashtbl.clear con.transactions; + con.next_tid <- initial_next_tid; + Hashtbl.clear con.watches; + (* anonid is the same *) + con.nb_watches <- 0; + con.stat_nb_ops <- 0; + (* perm is the same *) + () let get_path con = -Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d) + Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d) let watch_create ~con ~path ~token = { - con = con; - token = token; - path = path; - base = get_path con; - is_relative = path.[0] <> '/' && path.[0] <> '@'; - pending_watchevents = BoundedPipe.create ~capacity:!Define.maxwatchevents ~destination:(Xenbus.Xb.queue con.xb) + con = con; + token = token; + path = path; + base = get_path con; + is_relative = path.[0] <> '/' && path.[0] <> '@'; + pending_watchevents = BoundedPipe.create ~capacity:!Define.maxwatchevents ~destination:(Xenbus.Xb.queue con.xb) } let get_con w = w.con let number_of_transactions con = - Hashtbl.length con.transactions + Hashtbl.length con.transactions let get_domain con = con.dom let anon_id_next = ref 1 let get_domstr con = - match con.dom with - | None -> "A" ^ (string_of_int con.anonid) - | Some dom -> "D" ^ (string_of_int (Domain.get_id dom)) + match con.dom with + | None -> "A" ^ (string_of_int con.anonid) + | Some dom -> "D" ^ (string_of_int (Domain.get_id dom)) let make_perm dom = - let domid = - match dom with - | None -> 0 - | Some d -> Domain.get_id d - in - Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid + let domid = + match dom with + | None -> 0 + | Some d -> Domain.get_id d + in + Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid let create xbcon dom = - let destination (watch, pkt) = - BoundedPipe.push watch.pending_watchevents pkt - in - let id = - match dom with - | None -> let old = !anon_id_next in incr anon_id_next; old - | Some _ -> 0 - in - let con = - { - xb = xbcon; - dom = dom; - transactions = Hashtbl.create 5; - next_tid = initial_next_tid; - watches = Hashtbl.create 8; - nb_watches = 0; - anonid = id; - stat_nb_ops = 0; - perm = make_perm dom; + let destination (watch, pkt) = + BoundedPipe.push watch.pending_watchevents pkt + in + let id = + match dom with + | None -> let old = !anon_id_next in incr anon_id_next; old + | Some _ -> 0 + in + let con = + { + xb = xbcon; + dom = dom; + transactions = Hashtbl.create 5; + next_tid = initial_next_tid; + watches = Hashtbl.create 8; + nb_watches = 0; + anonid = id; + stat_nb_ops = 0; + perm = make_perm dom; - (* the actual capacity will be lower, this is used as an overflow - buffer: anything that doesn't fit elsewhere gets put here, only - limited by the amount of watches that you can generate with a - single xenstore command (which is finite, although possibly very - large in theory for Dom0). Once the pipe here has any contents the - domain is blocked from sending more commands until it is empty - again though. - *) - pending_source_watchevents = BoundedPipe.create ~capacity:Sys.max_array_length ~destination - } - in - Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con); - con + (* the actual capacity will be lower, this is used as an overflow + buffer: anything that doesn't fit elsewhere gets put here, only + limited by the amount of watches that you can generate with a + single xenstore command (which is finite, although possibly very + large in theory for Dom0). Once the pipe here has any contents the + domain is blocked from sending more commands until it is empty + again though. + *) + pending_source_watchevents = BoundedPipe.create ~capacity:Sys.max_array_length ~destination + } + in + Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con); + con let get_fd con = Xenbus.Xb.get_fd con.xb let close con = - Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con); - Xenbus.Xb.close con.xb + Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con); + Xenbus.Xb.close con.xb let get_perm con = - con.perm + con.perm let set_target con target_domid = - con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid + con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid let is_backend_mmap con = Xenbus.Xb.is_mmap con.xb let packet_of con tid rid ty data = - if (String.length data) > xenstore_payload_max && (is_backend_mmap con) then - Xenbus.Xb.Packet.create tid rid Xenbus.Xb.Op.Error "E2BIG\000" - else - Xenbus.Xb.Packet.create tid rid ty data + if (String.length data) > xenstore_payload_max && (is_backend_mmap con) then + Xenbus.Xb.Packet.create tid rid Xenbus.Xb.Op.Error "E2BIG\000" + else + Xenbus.Xb.Packet.create tid rid ty data let send_reply con tid rid ty data = - let result = Xenbus.Xb.queue con.xb (packet_of con tid rid ty data) in - (* should never happen: we only process an input packet when there is room for an output packet *) - (* and the limit for replies is different from the limit for watch events *) - assert (result <> None) + let result = Xenbus.Xb.queue con.xb (packet_of con tid rid ty data) in + (* should never happen: we only process an input packet when there is room for an output packet *) + (* and the limit for replies is different from the limit for watch events *) + assert (result <> None) let send_error con tid rid err = send_reply con tid rid Xenbus.Xb.Op.Error (err ^ "\000") let send_ack con tid rid ty = send_reply con tid rid ty "OK\000" let get_watch_path con path = - if path.[0] = '@' || path.[0] = '/' then - path - else - let rpath = get_path con in - rpath ^ path + if path.[0] = '@' || path.[0] = '/' then + path + else + let rpath = get_path con in + rpath ^ path let get_watches (con: t) path = - if Hashtbl.mem con.watches path - then Hashtbl.find con.watches path - else [] + if Hashtbl.mem con.watches path + then Hashtbl.find con.watches path + else [] let get_children_watches con path = - let path = path ^ "/" in - List.concat (Hashtbl.fold (fun p w l -> - if String.startswith path p then w :: l else l) con.watches []) + let path = path ^ "/" in + List.concat (Hashtbl.fold (fun p w l -> + if String.startswith path p then w :: l else l) con.watches []) let is_dom0 con = - Perms.Connection.is_dom0 (get_perm con) + Perms.Connection.is_dom0 (get_perm con) let add_watch con (path, apath) token = - if !Quota.activate && !Define.maxwatch > 0 && - not (is_dom0 con) && con.nb_watches > !Define.maxwatch then - raise Quota.Limit_reached; - let l = get_watches con apath in - if List.exists (fun w -> w.token = token) l then - raise Define.Already_exist; - let watch = watch_create ~con ~token ~path in - Hashtbl.replace con.watches apath (watch :: l); - con.nb_watches <- con.nb_watches + 1; - watch + if !Quota.activate && !Define.maxwatch > 0 && + not (is_dom0 con) && con.nb_watches > !Define.maxwatch then + raise Quota.Limit_reached; + let l = get_watches con apath in + if List.exists (fun w -> w.token = token) l then + raise Define.Already_exist; + let watch = watch_create ~con ~token ~path in + Hashtbl.replace con.watches apath (watch :: l); + con.nb_watches <- con.nb_watches + 1; + watch let del_watch con path token = - let apath = get_watch_path con path in - let ws = Hashtbl.find con.watches apath in - let w = List.find (fun w -> w.token = token) ws in - let filtered = Utils.list_remove w ws in - if List.length filtered > 0 then - Hashtbl.replace con.watches apath filtered - else - Hashtbl.remove con.watches apath; - con.nb_watches <- con.nb_watches - 1; - apath, w + let apath = get_watch_path con path in + let ws = Hashtbl.find con.watches apath in + let w = List.find (fun w -> w.token = token) ws in + let filtered = Utils.list_remove w ws in + if List.length filtered > 0 then + Hashtbl.replace con.watches apath filtered + else + Hashtbl.remove con.watches apath; + con.nb_watches <- con.nb_watches - 1; + apath, w let del_watches con = Hashtbl.reset con.watches; @@ -308,101 +308,101 @@ let del_transactions con = Hashtbl.reset con.transactions let list_watches con = - let ll = Hashtbl.fold - (fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc) - con.watches [] in - List.concat ll + let ll = Hashtbl.fold + (fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc) + con.watches [] in + List.concat ll let dbg fmt = Logging.debug "connection" fmt let info fmt = Logging.info "connection" fmt let lookup_watch_perm path = function -| None -> [] -| Some root -> - try Store.Path.apply root path @@ fun parent name -> - Store.Node.get_perms parent :: - try [Store.Node.get_perms (Store.Node.find parent name)] - with Not_found -> [] - with Define.Invalid_path | Not_found -> [] + | None -> [] + | Some root -> + try Store.Path.apply root path @@ fun parent name -> + Store.Node.get_perms parent :: + try [Store.Node.get_perms (Store.Node.find parent name)] + with Not_found -> [] + with Define.Invalid_path | Not_found -> [] let lookup_watch_perms oldroot root path = - lookup_watch_perm path oldroot @ lookup_watch_perm path (Some root) + lookup_watch_perm path oldroot @ lookup_watch_perm path (Some root) let fire_single_watch_unchecked source watch = - let data = Utils.join_by_null [watch.path; watch.token; ""] in - let pkt = packet_of watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data in + let data = Utils.join_by_null [watch.path; watch.token; ""] in + let pkt = packet_of watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data in - match BoundedPipe.push source.pending_source_watchevents (watch, pkt) with - | Some () -> () (* packet queued *) - | None -> - (* a well behaved Dom0 shouldn't be able to trigger this, - if it happens it is likely a Dom0 bug causing runaway memory usage - *) - failwith "watch event overflow, cannot happen" + match BoundedPipe.push source.pending_source_watchevents (watch, pkt) with + | Some () -> () (* packet queued *) + | None -> + (* a well behaved Dom0 shouldn't be able to trigger this, + if it happens it is likely a Dom0 bug causing runaway memory usage + *) + failwith "watch event overflow, cannot happen" let fire_single_watch source (oldroot, root) watch = - let abspath = get_watch_path watch.con watch.path |> Store.Path.of_string in - let perms = lookup_watch_perms oldroot root abspath in - if Perms.can_fire_watch watch.con.perm perms then - fire_single_watch_unchecked source watch - else - let perms = perms |> List.map (Perms.Node.to_string ~sep:" ") |> String.concat ", " in - let con = get_domstr watch.con in - Logging.watch_not_fired ~con perms (Store.Path.to_string abspath) + let abspath = get_watch_path watch.con watch.path |> Store.Path.of_string in + let perms = lookup_watch_perms oldroot root abspath in + if Perms.can_fire_watch watch.con.perm perms then + fire_single_watch_unchecked source watch + else + let perms = perms |> List.map (Perms.Node.to_string ~sep:" ") |> String.concat ", " in + let con = get_domstr watch.con in + Logging.watch_not_fired ~con perms (Store.Path.to_string abspath) let fire_watch source roots watch path = - let new_path = - if watch.is_relative && path.[0] = '/' - then begin - let n = String.length watch.base - and m = String.length path in - String.sub path n (m - n) - end else - path - in - fire_single_watch source roots { watch with path = new_path } + let new_path = + if watch.is_relative && path.[0] = '/' + then begin + let n = String.length watch.base + and m = String.length path in + String.sub path n (m - n) + end else + path + in + fire_single_watch source roots { watch with path = new_path } (* Search for a valid unused transaction id. *) let rec valid_transaction_id con proposed_id = - (* - * Clip proposed_id to the range [1, 0x3ffffffe] - * - * The chosen id must not trucate when written into the uint32_t tx_id - * field, and needs to fit within the positive range of a 31 bit ocaml - * integer to function when compiled as 32bit. - * - * Oxenstored therefore supports only 1 billion open transactions. - *) - let id = if proposed_id <= 0 || proposed_id >= 0x3fffffff then 1 else proposed_id in + (* + * Clip proposed_id to the range [1, 0x3ffffffe] + * + * The chosen id must not trucate when written into the uint32_t tx_id + * field, and needs to fit within the positive range of a 31 bit ocaml + * integer to function when compiled as 32bit. + * + * Oxenstored therefore supports only 1 billion open transactions. + *) + let id = if proposed_id <= 0 || proposed_id >= 0x3fffffff then 1 else proposed_id in - if Hashtbl.mem con.transactions id then ( - (* Outstanding transaction with this id. Try the next. *) - valid_transaction_id con (id + 1) - ) else - id + if Hashtbl.mem con.transactions id then ( + (* Outstanding transaction with this id. Try the next. *) + valid_transaction_id con (id + 1) + ) else + id let start_transaction con store = - if !Define.maxtransaction > 0 && not (is_dom0 con) - && Hashtbl.length con.transactions > !Define.maxtransaction then - raise Quota.Transaction_opened; - let id = valid_transaction_id con con.next_tid in - con.next_tid <- id + 1; - let ntrans = Transaction.make id store in - Hashtbl.add con.transactions id ntrans; - Logging.start_transaction ~tid:id ~con:(get_domstr con); - id + if !Define.maxtransaction > 0 && not (is_dom0 con) + && Hashtbl.length con.transactions > !Define.maxtransaction then + raise Quota.Transaction_opened; + let id = valid_transaction_id con con.next_tid in + con.next_tid <- id + 1; + let ntrans = Transaction.make id store in + Hashtbl.add con.transactions id ntrans; + Logging.start_transaction ~tid:id ~con:(get_domstr con); + id let end_transaction con tid commit = - let trans = Hashtbl.find con.transactions tid in - Hashtbl.remove con.transactions tid; - Logging.end_transaction ~tid ~con:(get_domstr con); - match commit with - | None -> true - | Some transaction_replay_f -> - Transaction.commit ~con:(get_domstr con) trans || transaction_replay_f con trans + let trans = Hashtbl.find con.transactions tid in + Hashtbl.remove con.transactions tid; + Logging.end_transaction ~tid ~con:(get_domstr con); + match commit with + | None -> true + | Some transaction_replay_f -> + Transaction.commit ~con:(get_domstr con) trans || transaction_replay_f con trans let get_transaction con tid = - Hashtbl.find con.transactions tid + Hashtbl.find con.transactions tid let do_input con = Xenbus.Xb.input con.xb let has_partial_input con = Xenbus.Xb.has_partial_input con.xb @@ -434,53 +434,53 @@ let is_bad con = match con.dom with None -> false | Some dom -> Domain.is_bad_do Restrictions below can be relaxed once xenstored learns to dump more of its live state in a safe way *) let has_extra_connection_data con = - let has_in = has_partial_input con in - let has_out = has_output con in - let has_nondefault_perms = make_perm con.dom <> con.perm in - has_in || has_out - (* TODO: what about SIGTERM, should use systemd to store FDS - || has_socket (* dom0 sockets not * dumped yet *) *) - || has_nondefault_perms (* set_target not dumped yet *) + let has_in = has_partial_input con in + let has_out = has_output con in + let has_nondefault_perms = make_perm con.dom <> con.perm in + has_in || has_out + (* TODO: what about SIGTERM, should use systemd to store FDS + || has_socket (* dom0 sockets not * dumped yet *) *) + || has_nondefault_perms (* set_target not dumped yet *) let has_transaction_data con = - let n = number_of_transactions con in - dbg "%s: number of transactions = %d" (get_domstr con) n; - n > 0 + let n = number_of_transactions con in + dbg "%s: number of transactions = %d" (get_domstr con) n; + n > 0 let prevents_live_update con = not (is_bad con) - && (has_extra_connection_data con || has_transaction_data con) + && (has_extra_connection_data con || has_transaction_data con) let has_more_work con = - (has_more_input con && can_input con) || not (has_old_output con) && has_new_output con + (has_more_input con && can_input con) || not (has_old_output con) && has_new_output con let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1 let stats con = - Hashtbl.length con.watches, con.stat_nb_ops + Hashtbl.length con.watches, con.stat_nb_ops let dump con chan = - let id = match con.dom with - | Some dom -> - let domid = Domain.get_id dom in - (* dump domain *) - Domain.dump dom chan; - domid - | None -> - let fd = con |> get_fd |> Utils.FD.to_int in - Printf.fprintf chan "socket,%d\n" fd; - -fd - in - (* dump watches *) - List.iter (fun (path, token) -> - Printf.fprintf chan "watch,%d,%s,%s\n" id (Utils.hexify path) (Utils.hexify token) - ) (list_watches con) + let id = match con.dom with + | Some dom -> + let domid = Domain.get_id dom in + (* dump domain *) + Domain.dump dom chan; + domid + | None -> + let fd = con |> get_fd |> Utils.FD.to_int in + Printf.fprintf chan "socket,%d\n" fd; + -fd + in + (* dump watches *) + List.iter (fun (path, token) -> + Printf.fprintf chan "watch,%d,%s,%s\n" id (Utils.hexify path) (Utils.hexify token) + ) (list_watches con) let debug con = - let domid = get_domstr con in - let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in - String.concat "" watches + let domid = get_domstr con in + let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in + String.concat "" watches let decr_conflict_credit doms con = - match con.dom with - | None -> () (* It's a socket connection. We don't know which domain we're in, so treat it as if it's free to conflict *) - | Some dom -> Domains.decr_conflict_credit doms dom + match con.dom with + | None -> () (* It's a socket connection. We don't know which domain we're in, so treat it as if it's free to conflict *) + | Some dom -> Domains.decr_conflict_credit doms dom diff --git a/tools/ocaml/xenstored/connections.ml b/tools/ocaml/xenstored/connections.ml index 7d68c583b4..682e1b493c 100644 --- a/tools/ocaml/xenstored/connections.ml +++ b/tools/ocaml/xenstored/connections.ml @@ -18,218 +18,218 @@ let debug fmt = Logging.debug "connections" fmt type t = { - anonymous: (Unix.file_descr, Connection.t) Hashtbl.t; - domains: (int, Connection.t) Hashtbl.t; - ports: (Xeneventchn.t, Connection.t) Hashtbl.t; - mutable watches: Connection.watch list Trie.t; - mutable has_pending_watchevents: Connection.Watch.Set.t + anonymous: (Unix.file_descr, Connection.t) Hashtbl.t; + domains: (int, Connection.t) Hashtbl.t; + ports: (Xeneventchn.t, Connection.t) Hashtbl.t; + mutable watches: Connection.watch list Trie.t; + mutable has_pending_watchevents: Connection.Watch.Set.t } let create () = { - anonymous = Hashtbl.create 37; - domains = Hashtbl.create 37; - ports = Hashtbl.create 37; - watches = Trie.create (); - has_pending_watchevents = Connection.Watch.Set.empty; + anonymous = Hashtbl.create 37; + domains = Hashtbl.create 37; + ports = Hashtbl.create 37; + watches = Trie.create (); + has_pending_watchevents = Connection.Watch.Set.empty; } let get_capacity () = - (* not multiplied by maxwatch on purpose: 2nd queue in watch itself! *) - { Xenbus.Xb.maxoutstanding = !Define.maxoutstanding; maxwatchevents = !Define.maxwatchevents } + (* not multiplied by maxwatch on purpose: 2nd queue in watch itself! *) + { Xenbus.Xb.maxoutstanding = !Define.maxoutstanding; maxwatchevents = !Define.maxwatchevents } let add_anonymous cons fd = - let capacity = get_capacity () in - let xbcon = Xenbus.Xb.open_fd fd ~capacity in - let con = Connection.create xbcon None in - Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con + let capacity = get_capacity () in + let xbcon = Xenbus.Xb.open_fd fd ~capacity in + let con = Connection.create xbcon None in + Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con let add_domain cons dom = - let capacity = get_capacity () in - let xbcon = Xenbus.Xb.open_mmap ~capacity (Domain.get_interface dom) (fun () -> Domain.notify dom) in - let con = Connection.create xbcon (Some dom) in - Hashtbl.add cons.domains (Domain.get_id dom) con; - match Domain.get_port dom with - | Some p -> Hashtbl.add cons.ports p con; - | None -> () + let capacity = get_capacity () in + let xbcon = Xenbus.Xb.open_mmap ~capacity (Domain.get_interface dom) (fun () -> Domain.notify dom) in + let con = Connection.create xbcon (Some dom) in + Hashtbl.add cons.domains (Domain.get_id dom) con; + match Domain.get_port dom with + | Some p -> Hashtbl.add cons.ports p con; + | None -> () let select ?(only_if = (fun _ -> true)) cons = - Hashtbl.fold (fun _ con (ins, outs) -> - if (only_if con) then ( - let fd = Connection.get_fd con in - let in_fds = if Connection.can_input con then fd :: ins else ins in - let out_fds = if Connection.has_output con then fd :: outs else outs in - in_fds, out_fds - ) else (ins, outs) - ) - cons.anonymous ([], []) + Hashtbl.fold (fun _ con (ins, outs) -> + if (only_if con) then ( + let fd = Connection.get_fd con in + let in_fds = if Connection.can_input con then fd :: ins else ins in + let out_fds = if Connection.has_output con then fd :: outs else outs in + in_fds, out_fds + ) else (ins, outs) + ) + cons.anonymous ([], []) let find cons = - Hashtbl.find cons.anonymous + Hashtbl.find cons.anonymous let find_domain cons = - Hashtbl.find cons.domains + Hashtbl.find cons.domains let find_domain_by_port cons port = - Hashtbl.find cons.ports port + Hashtbl.find cons.ports port let del_watches_of_con con watches = - match List.filter (fun w -> Connection.get_con w != con) watches with - | [] -> None - | ws -> Some ws + match List.filter (fun w -> Connection.get_con w != con) watches with + | [] -> None + | ws -> Some ws let del_watches cons con = - Connection.del_watches con; - cons.watches <- Trie.map (del_watches_of_con con) cons.watches; - cons.has_pending_watchevents <- - cons.has_pending_watchevents |> Connection.Watch.Set.filter @@ fun w -> - Connection.get_con w != con + Connection.del_watches con; + cons.watches <- Trie.map (del_watches_of_con con) cons.watches; + cons.has_pending_watchevents <- + cons.has_pending_watchevents |> Connection.Watch.Set.filter @@ fun w -> + Connection.get_con w != con let del_anonymous cons con = - try - Hashtbl.remove cons.anonymous (Connection.get_fd con); - del_watches cons con; - Connection.close con - with exn -> - debug "del anonymous %s" (Printexc.to_string exn) + try + Hashtbl.remove cons.anonymous (Connection.get_fd con); + del_watches cons con; + Connection.close con + with exn -> + debug "del anonymous %s" (Printexc.to_string exn) let del_domain cons id = - try - let con = find_domain cons id in - Hashtbl.remove cons.domains id; - (match Connection.get_domain con with - | Some d -> - (match Domain.get_port d with - | Some p -> Hashtbl.remove cons.ports p - | None -> ()) - | None -> ()); - del_watches cons con; - Connection.close con - with exn -> - debug "del domain %u: %s" id (Printexc.to_string exn) + try + let con = find_domain cons id in + Hashtbl.remove cons.domains id; + (match Connection.get_domain con with + | Some d -> + (match Domain.get_port d with + | Some p -> Hashtbl.remove cons.ports p + | None -> ()) + | None -> ()); + del_watches cons con; + Connection.close con + with exn -> + debug "del domain %u: %s" id (Printexc.to_string exn) let iter_domains cons fct = - Hashtbl.iter (fun _ c -> fct c) cons.domains + Hashtbl.iter (fun _ c -> fct c) cons.domains let iter_anonymous cons fct = - Hashtbl.iter (fun _ c -> fct c) cons.anonymous + Hashtbl.iter (fun _ c -> fct c) cons.anonymous let iter cons fct = - iter_domains cons fct; iter_anonymous cons fct + iter_domains cons fct; iter_anonymous cons fct let has_more_work cons = - Hashtbl.fold - (fun _id con acc -> - if Connection.has_more_work con then con :: acc else acc) - cons.domains [] + Hashtbl.fold + (fun _id con acc -> + if Connection.has_more_work con then con :: acc else acc) + cons.domains [] let key_of_str path = - if path.[0] = '@' - then [path] - else "" :: Store.Path.to_string_list (Store.Path.of_string path) + if path.[0] = '@' + then [path] + else "" :: Store.Path.to_string_list (Store.Path.of_string path) let key_of_path path = - "" :: Store.Path.to_string_list path + "" :: Store.Path.to_string_list path let add_watch cons con path token = - let apath = Connection.get_watch_path con path in - (* fail on invalid paths early by calling key_of_str before adding watch *) - let key = key_of_str apath in - let watch = Connection.add_watch con (path, apath) token in - let watches = - if Trie.mem cons.watches key - then Trie.find cons.watches key - else [] - in - cons.watches <- Trie.set cons.watches key (watch :: watches); - watch + let apath = Connection.get_watch_path con path in + (* fail on invalid paths early by calling key_of_str before adding watch *) + let key = key_of_str apath in + let watch = Connection.add_watch con (path, apath) token in + let watches = + if Trie.mem cons.watches key + then Trie.find cons.watches key + else [] + in + cons.watches <- Trie.set cons.watches key (watch :: watches); + watch let del_watch cons con path token = - let apath, watch = Connection.del_watch con path token in - let key = key_of_str apath in - let watches = Utils.list_remove watch (Trie.find cons.watches key) in - if watches = [] then - cons.watches <- Trie.unset cons.watches key - else - cons.watches <- Trie.set cons.watches key watches; - watch + let apath, watch = Connection.del_watch con path token in + let key = key_of_str apath in + let watches = Utils.list_remove watch (Trie.find cons.watches key) in + if watches = [] then + cons.watches <- Trie.unset cons.watches key + else + cons.watches <- Trie.set cons.watches key watches; + watch (* path is absolute *) let fire_watches ?oldroot source root cons path recurse = - let key = key_of_path path in - let path = Store.Path.to_string path in - let roots = oldroot, root in - let fire_watch _ = function - | None -> () - | Some watches -> List.iter (fun w -> Connection.fire_watch source roots w path) watches - in - let fire_rec _x = function - | None -> () - | Some watches -> - List.iter (Connection.fire_single_watch source roots) watches - in - Trie.iter_path fire_watch cons.watches key; - if recurse then - Trie.iter fire_rec (Trie.sub cons.watches key) + let key = key_of_path path in + let path = Store.Path.to_string path in + let roots = oldroot, root in + let fire_watch _ = function + | None -> () + | Some watches -> List.iter (fun w -> Connection.fire_watch source roots w path) watches + in + let fire_rec _x = function + | None -> () + | Some watches -> + List.iter (Connection.fire_single_watch source roots) watches + in + Trie.iter_path fire_watch cons.watches key; + if recurse then + Trie.iter fire_rec (Trie.sub cons.watches key) let send_watchevents cons con = - cons.has_pending_watchevents <- - cons.has_pending_watchevents |> Connection.Watch.Set.filter Connection.Watch.flush_events; - Connection.source_flush_watchevents con + cons.has_pending_watchevents <- + cons.has_pending_watchevents |> Connection.Watch.Set.filter Connection.Watch.flush_events; + Connection.source_flush_watchevents con let fire_spec_watches root cons specpath = - let source = find_domain cons 0 in - iter cons (fun con -> - List.iter (Connection.fire_single_watch source (None, root)) (Connection.get_watches con specpath)) + let source = find_domain cons 0 in + iter cons (fun con -> + List.iter (Connection.fire_single_watch source (None, root)) (Connection.get_watches con specpath)) let set_target cons domain target_domain = - let con = find_domain cons domain in - Connection.set_target con target_domain + let con = find_domain cons domain in + Connection.set_target con target_domain let number_of_transactions cons = - let res = ref 0 in - let aux con = - res := Connection.number_of_transactions con + !res - in - iter cons aux; - !res + let res = ref 0 in + let aux con = + res := Connection.number_of_transactions con + !res + in + iter cons aux; + !res let stats cons = - let nb_ops_anon = ref 0 - and nb_watchs_anon = ref 0 - and nb_ops_dom = ref 0 - and nb_watchs_dom = ref 0 in - iter_anonymous cons (fun con -> - let con_watchs, con_ops = Connection.stats con in - nb_ops_anon := !nb_ops_anon + con_ops; - nb_watchs_anon := !nb_watchs_anon + con_watchs; - ); - iter_domains cons (fun con -> - let con_watchs, con_ops = Connection.stats con in - nb_ops_dom := !nb_ops_dom + con_ops; - nb_watchs_dom := !nb_watchs_dom + con_watchs; - ); - (Hashtbl.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon, - Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom) + let nb_ops_anon = ref 0 + and nb_watchs_anon = ref 0 + and nb_ops_dom = ref 0 + and nb_watchs_dom = ref 0 in + iter_anonymous cons (fun con -> + let con_watchs, con_ops = Connection.stats con in + nb_ops_anon := !nb_ops_anon + con_ops; + nb_watchs_anon := !nb_watchs_anon + con_watchs; + ); + iter_domains cons (fun con -> + let con_watchs, con_ops = Connection.stats con in + nb_ops_dom := !nb_ops_dom + con_ops; + nb_watchs_dom := !nb_watchs_dom + con_watchs; + ); + (Hashtbl.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon, + Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom) let debug cons = - let anonymous = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.anonymous [] in - let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in - String.concat "" (domains @ anonymous) + let anonymous = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.anonymous [] in + let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in + String.concat "" (domains @ anonymous) let debug_watchevents cons con = - (* == (physical equality) - has to be used here because w.con.xb.backend might contain a [unit->unit] value causing regular - comparison to fail due to having a 'functional value' which cannot be compared. - *) - let s = cons.has_pending_watchevents |> Connection.Watch.Set.filter (fun w -> w.con == con) in - let pending = s |> Connection.Watch.Set.elements - |> List.map (fun w -> Connection.Watch.pending_watchevents w) |> List.fold_left (+) 0 in - Printf.sprintf "Watches with pending events: %d, pending events total: %d" (Connection.Watch.Set.cardinal s) pending + (* == (physical equality) + has to be used here because w.con.xb.backend might contain a [unit->unit] value causing regular + comparison to fail due to having a 'functional value' which cannot be compared. + *) + let s = cons.has_pending_watchevents |> Connection.Watch.Set.filter (fun w -> w.con == con) in + let pending = s |> Connection.Watch.Set.elements + |> List.map (fun w -> Connection.Watch.pending_watchevents w) |> List.fold_left (+) 0 in + Printf.sprintf "Watches with pending events: %d, pending events total: %d" (Connection.Watch.Set.cardinal s) pending let filter ~f cons = - let fold _ v acc = if f v then v :: acc else acc in - [] - |> Hashtbl.fold fold cons.anonymous - |> Hashtbl.fold fold cons.domains + let fold _ v acc = if f v then v :: acc else acc in + [] + |> Hashtbl.fold fold cons.anonymous + |> Hashtbl.fold fold cons.domains let prevents_quit cons = filter ~f:Connection.prevents_live_update cons diff --git a/tools/ocaml/xenstored/define.ml b/tools/ocaml/xenstored/define.ml index 327b6d795e..f4f5295930 100644 --- a/tools/ocaml/xenstored/define.ml +++ b/tools/ocaml/xenstored/define.ml @@ -27,9 +27,9 @@ let maxrequests = ref (1024) (* maximum requests per transaction *) let maxoutstanding = ref (1024) (* maximum outstanding requests, i.e. in-flight requests / domain *) let maxwatchevents = ref (1024) (* - maximum outstanding watch events per watch, - recommended >= maxoutstanding to avoid blocking backend transactions due to - malicious frontends + maximum outstanding watch events per watch, + recommended >= maxoutstanding to avoid blocking backend transactions due to + malicious frontends *) let gc_max_overhead = ref 120 (* 120% see comment in xenstored.ml *) diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml index 4739967b61..91f945f2bd 100644 --- a/tools/ocaml/xenstored/disk.ml +++ b/tools/ocaml/xenstored/disk.ml @@ -25,133 +25,133 @@ exception Bad_escape let is_digit c = match c with '0' .. '9' -> true | _ -> false let undec c = - match c with - | '0' .. '9' -> (Char.code c) - (Char.code '0') - | _ -> raise (Failure "undecify") + match c with + | '0' .. '9' -> (Char.code c) - (Char.code '0') + | _ -> raise (Failure "undecify") let unhex c = - let c = Char.lowercase c in - match c with - | '0' .. '9' -> (Char.code c) - (Char.code '0') - | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10 - | _ -> raise (Failure "unhexify") + let c = Char.lowercase c in + match c with + | '0' .. '9' -> (Char.code c) - (Char.code '0') + | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10 + | _ -> raise (Failure "unhexify") let string_unescaped s = - let len = String.length s - and i = ref 0 in - let d = Buffer.create len in + let len = String.length s + and i = ref 0 in + let d = Buffer.create len in - let read_escape () = - incr i; - match s.[!i] with - | 'n' -> '\n' - | 'r' -> '\r' - | '\\' -> '\\' - | '\'' -> '\'' - | '"' -> '"' - | 't' -> '\t' - | 'b' -> '\b' - | 'x' -> - let v = (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in - i := !i + 2; - Char.chr v - | c -> - if is_digit c then ( - let v = (undec s.[!i]) * 100 + - (undec s.[!i + 1]) * 10 + - (undec s.[!i + 2]) in - i := !i + 2; - Char.chr v - ) else - raise Bad_escape - in + let read_escape () = + incr i; + match s.[!i] with + | 'n' -> '\n' + | 'r' -> '\r' + | '\\' -> '\\' + | '\'' -> '\'' + | '"' -> '"' + | 't' -> '\t' + | 'b' -> '\b' + | 'x' -> + let v = (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in + i := !i + 2; + Char.chr v + | c -> + if is_digit c then ( + let v = (undec s.[!i]) * 100 + + (undec s.[!i + 1]) * 10 + + (undec s.[!i + 2]) in + i := !i + 2; + Char.chr v + ) else + raise Bad_escape + in - while !i < len - do - let c = match s.[!i] with - | '\\' -> read_escape () - | c -> c in - Buffer.add_char d c; - incr i - done; - Buffer.contents d + while !i < len + do + let c = match s.[!i] with + | '\\' -> read_escape () + | c -> c in + Buffer.add_char d c; + incr i + done; + Buffer.contents d (* file -> lines_of_file *) let file_readlines file = - let channel = open_in file in - let rec input_line_list channel = - let line = try input_line channel with End_of_file -> "" in - if String.length line > 0 then - line :: input_line_list channel - else ( - close_in channel; - [] - ) in - input_line_list channel + let channel = open_in file in + let rec input_line_list channel = + let line = try input_line channel with End_of_file -> "" in + if String.length line > 0 then + line :: input_line_list channel + else ( + close_in channel; + [] + ) in + input_line_list channel let rec map_string_list_range l s = - match l with - | [] -> [] - | (a,b) :: l -> String.sub s a (b - a) :: map_string_list_range l s + match l with + | [] -> [] + | (a,b) :: l -> String.sub s a (b - a) :: map_string_list_range l s let is_digit c = - try ignore (int_of_char c); true with _ -> false + try ignore (int_of_char c); true with _ -> false let rec parse_perm s = - let len = String.length s in - if len = 0 then - [] - else - let i = ref 1 in - while !i < len && is_digit s.[!i] do incr i done; - let x = String.sub s 0 !i - and lx = String.sub s !i len in - x :: parse_perm lx + let len = String.length s in + if len = 0 then + [] + else + let i = ref 1 in + while !i < len && is_digit s.[!i] do incr i done; + let x = String.sub s 0 !i + and lx = String.sub s !i len in + x :: parse_perm lx let read store = - (* don't let the permission get on our way, full perm ! *) - let v = Store.get_ops store Perms.Connection.full_rights in + (* don't let the permission get on our way, full perm ! *) + let v = Store.get_ops store Perms.Connection.full_rights in - (* a line is : path{perm} or path{perm} = value *) - let parse_line s = - let path, perm, value = - let len = String.length s in - let si = if String.contains s '=' then - String.index s '=' - else - len - 1 in - let pi = String.rindex_from s si '{' in - let epi = String.index_from s pi '}' in + (* a line is : path{perm} or path{perm} = value *) + let parse_line s = + let path, perm, value = + let len = String.length s in + let si = if String.contains s '=' then + String.index s '=' + else + len - 1 in + let pi = String.rindex_from s si '{' in + let epi = String.index_from s pi '}' in - if String.contains s '=' then - let ss = map_string_list_range [ (0, pi); - (pi + 1, epi); - (si + 2, len); ] s in - (List.nth ss 0, List.nth ss 1, List.nth ss 2) - else - let ss = map_string_list_range [ (0, pi); - (pi + 1, epi); - ] s in - (List.nth ss 0, List.nth ss 1, "") - in - let path = Store.Path.of_string path in - v.Store.write path (string_unescaped value); - v.Store.setperms path (Perms.Node.of_strings (parse_perm perm)) in - try - let lines = file_readlines xs_daemon_database in - List.iter (fun s -> parse_line s) lines - with exc -> - error "caught exn %s" (Printexc.to_string exc) + if String.contains s '=' then + let ss = map_string_list_range [ (0, pi); + (pi + 1, epi); + (si + 2, len); ] s in + (List.nth ss 0, List.nth ss 1, List.nth ss 2) + else + let ss = map_string_list_range [ (0, pi); + (pi + 1, epi); + ] s in + (List.nth ss 0, List.nth ss 1, "") + in + let path = Store.Path.of_string path in + v.Store.write path (string_unescaped value); + v.Store.setperms path (Perms.Node.of_strings (parse_perm perm)) in + try + let lines = file_readlines xs_daemon_database in + List.iter (fun s -> parse_line s) lines + with exc -> + error "caught exn %s" (Printexc.to_string exc) let write store = - if !enable then - try - let tfile = Printf.sprintf "%s#" xs_daemon_database in - let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] - 0o600 tfile in - Store.dump store channel; - flush channel; - close_out channel; - Unix.rename tfile xs_daemon_database - with exc -> - error "caught exn %s" (Printexc.to_string exc) + if !enable then + try + let tfile = Printf.sprintf "%s#" xs_daemon_database in + let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] + 0o600 tfile in + Store.dump store channel; + flush channel; + close_out channel; + Unix.rename tfile xs_daemon_database + with exc -> + error "caught exn %s" (Printexc.to_string exc) diff --git a/tools/ocaml/xenstored/domain.ml b/tools/ocaml/xenstored/domain.ml index 81cb59b8f1..4e62a48e8e 100644 --- a/tools/ocaml/xenstored/domain.ml +++ b/tools/ocaml/xenstored/domain.ml @@ -20,22 +20,22 @@ let debug fmt = Logging.debug "domain" fmt let warn fmt = Logging.warn "domain" fmt type t = -{ - id: Xenctrl.domid; - mfn: nativeint; - interface: Xenmmap.mmap_interface; - eventchn: Event.t; - mutable remote_port: int; - mutable port: Xeneventchn.t option; - mutable bad_client: bool; - mutable io_credit: int; (* the rounds of ring process left to do, default is 0, - usually set to 1 when there is work detected, could - also set to n to give "lazy" clients extra credit *) - mutable conflict_credit: float; (* Must be positive to perform writes; a commit - that later causes conflict with another - domain's transaction costs credit. *) - mutable caused_conflicts: int64; -} + { + id: Xenctrl.domid; + mfn: nativeint; + interface: Xenmmap.mmap_interface; + eventchn: Event.t; + mutable remote_port: int; + mutable port: Xeneventchn.t option; + mutable bad_client: bool; + mutable io_credit: int; (* the rounds of ring process left to do, default is 0, + usually set to 1 when there is work detected, could + also set to n to give "lazy" clients extra credit *) + mutable conflict_credit: float; (* Must be positive to perform writes; a commit + that later causes conflict with another + domain's transaction costs credit. *) + mutable caused_conflicts: int64; + } let is_dom0 d = d.id = 0 let get_id domain = domain.id @@ -57,51 +57,51 @@ let is_paused_for_conflict dom = dom.conflict_credit <= 0.0 let is_free_to_conflict = is_dom0 let string_of_port = function -| None -> "None" -| Some x -> string_of_int (Xeneventchn.to_int x) + | None -> "None" + | Some x -> string_of_int (Xeneventchn.to_int x) let dump d chan = - fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.remote_port + fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.remote_port let notify dom = match dom.port with -| None -> - warn "domain %d: attempt to notify on unknown port" dom.id -| Some port -> - Event.notify dom.eventchn port + | None -> + warn "domain %d: attempt to notify on unknown port" dom.id + | Some port -> + Event.notify dom.eventchn port let bind_interdomain dom = - begin match dom.port with - | None -> () - | Some port -> Event.unbind dom.eventchn port - end; - dom.port <- Some (Event.bind_interdomain dom.eventchn dom.id dom.remote_port); - debug "bound domain %d remote port %d to local port %s" dom.id dom.remote_port (string_of_port dom.port) + begin match dom.port with + | None -> () + | Some port -> Event.unbind dom.eventchn port + end; + dom.port <- Some (Event.bind_interdomain dom.eventchn dom.id dom.remote_port); + debug "bound domain %d remote port %d to local port %s" dom.id dom.remote_port (string_of_port dom.port) let close dom = - debug "domain %d unbound port %s" dom.id (string_of_port dom.port); - begin match dom.port with - | None -> () - | Some port -> Event.unbind dom.eventchn port - end; - Xenmmap.unmap dom.interface; - () + debug "domain %d unbound port %s" dom.id (string_of_port dom.port); + begin match dom.port with + | None -> () + | Some port -> Event.unbind dom.eventchn port + end; + Xenmmap.unmap dom.interface; + () let make id mfn remote_port interface eventchn = { - id = id; - mfn = mfn; - remote_port = remote_port; - interface = interface; - eventchn = eventchn; - port = None; - bad_client = false; - io_credit = 0; - conflict_credit = !Define.conflict_burst_limit; - caused_conflicts = 0L; + id = id; + mfn = mfn; + remote_port = remote_port; + interface = interface; + eventchn = eventchn; + port = None; + bad_client = false; + io_credit = 0; + conflict_credit = !Define.conflict_burst_limit; + caused_conflicts = 0L; } let log_and_reset_conflict_stats logfn dom = - if dom.caused_conflicts > 0L then ( - logfn dom.id dom.caused_conflicts; - dom.caused_conflicts <- 0L - ) + if dom.caused_conflicts > 0L then ( + logfn dom.id dom.caused_conflicts; + dom.caused_conflicts <- 0L + ) diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domains.ml index 17fe2fa257..a36b531663 100644 --- a/tools/ocaml/xenstored/domains.ml +++ b/tools/ocaml/xenstored/domains.ml @@ -21,35 +21,35 @@ let warn fmt = Logging.warn "domains" fmt let xc = Xenctrl.interface_open () type domains = { - eventchn: Event.t; - table: (Xenctrl.domid, Domain.t) Hashtbl.t; + eventchn: Event.t; + table: (Xenctrl.domid, Domain.t) Hashtbl.t; - (* N.B. the Queue module is not thread-safe but oxenstored is single-threaded. *) - (* Domains queue up to regain conflict-credit; we have a queue for - domains that are carrying some penalty and so are below the - maximum credit, and another queue for domains that have run out of - credit and so have had their access paused. *) - doms_conflict_paused: (Domain.t option ref) Queue.t; - doms_with_conflict_penalty: (Domain.t option ref) Queue.t; + (* N.B. the Queue module is not thread-safe but oxenstored is single-threaded. *) + (* Domains queue up to regain conflict-credit; we have a queue for + domains that are carrying some penalty and so are below the + maximum credit, and another queue for domains that have run out of + credit and so have had their access paused. *) + doms_conflict_paused: (Domain.t option ref) Queue.t; + doms_with_conflict_penalty: (Domain.t option ref) Queue.t; - (* A callback function to be called when we go from zero to one paused domain. - This will be to reset the countdown until the next unit of credit is issued. *) - on_first_conflict_pause: unit -> unit; + (* A callback function to be called when we go from zero to one paused domain. + This will be to reset the countdown until the next unit of credit is issued. *) + on_first_conflict_pause: unit -> unit; - (* If config is set to use individual instead of aggregate conflict-rate-limiting, - we use these counts instead of the queues. The second one includes the first. *) - mutable n_paused: int; (* Number of domains with zero or negative credit *) - mutable n_penalised: int; (* Number of domains with less than maximum credit *) + (* If config is set to use individual instead of aggregate conflict-rate-limiting, + we use these counts instead of the queues. The second one includes the first. *) + mutable n_paused: int; (* Number of domains with zero or negative credit *) + mutable n_penalised: int; (* Number of domains with less than maximum credit *) } let init eventchn on_first_conflict_pause = { - eventchn = eventchn; - table = Hashtbl.create 10; - doms_conflict_paused = Queue.create (); - doms_with_conflict_penalty = Queue.create (); - on_first_conflict_pause = on_first_conflict_pause; - n_paused = 0; - n_penalised = 0; + eventchn = eventchn; + table = Hashtbl.create 10; + doms_conflict_paused = Queue.create (); + doms_with_conflict_penalty = Queue.create (); + on_first_conflict_pause = on_first_conflict_pause; + n_paused = 0; + n_penalised = 0; } let del doms id = Hashtbl.remove doms.table id let exist doms id = Hashtbl.mem doms.table id @@ -58,165 +58,165 @@ let number doms = Hashtbl.length doms.table let iter doms fct = Hashtbl.iter (fun _ b -> fct b) doms.table let rec is_empty_queue q = - Queue.is_empty q || - if !(Queue.peek q) = None - then ( - ignore (Queue.pop q); - is_empty_queue q - ) else false + Queue.is_empty q || + if !(Queue.peek q) = None + then ( + ignore (Queue.pop q); + is_empty_queue q + ) else false let all_at_max_credit doms = - if !Define.conflict_rate_limit_is_aggregate - then - (* Check both becuase if burst limit is 1.0 then a domain can go straight - * from max-credit to paused without getting into the penalty queue. *) - is_empty_queue doms.doms_with_conflict_penalty - && is_empty_queue doms.doms_conflict_paused - else doms.n_penalised = 0 + if !Define.conflict_rate_limit_is_aggregate + then + (* Check both becuase if burst limit is 1.0 then a domain can go straight + * from max-credit to paused without getting into the penalty queue. *) + is_empty_queue doms.doms_with_conflict_penalty + && is_empty_queue doms.doms_conflict_paused + else doms.n_penalised = 0 (* Functions to handle queues of domains given that the domain might be deleted while in a queue. *) let push dom queue = - Queue.push (ref (Some dom)) queue + Queue.push (ref (Some dom)) queue let rec pop queue = - match !(Queue.pop queue) with - | None -> pop queue - | Some x -> x + match !(Queue.pop queue) with + | None -> pop queue + | Some x -> x let remove_from_queue dom queue = - Queue.iter (fun d -> match !d with - | None -> () - | Some x -> if x=dom then d := None) queue + Queue.iter (fun d -> match !d with + | None -> () + | Some x -> if x=dom then d := None) queue let cleanup doms = - let notify = ref false in - let dead_dom = ref [] in + let notify = ref false in + let dead_dom = ref [] in - Hashtbl.iter (fun id _ -> if id <> 0 then - try - let info = Xenctrl.domain_getinfo xc id in - if info.Xenctrl.shutdown || info.Xenctrl.dying then ( - debug "Domain %u died (dying=%b, shutdown %b -- code %d)" - id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code; - if info.Xenctrl.dying then - dead_dom := id :: !dead_dom - else - notify := true; - ) - with Xenctrl.Error _ -> - debug "Domain %u died -- no domain info" id; - dead_dom := id :: !dead_dom; - ) doms.table; - List.iter (fun id -> - let dom = Hashtbl.find doms.table id in - Domain.close dom; - Hashtbl.remove doms.table id; - if dom.Domain.conflict_credit <= !Define.conflict_burst_limit - then ( - remove_from_queue dom doms.doms_with_conflict_penalty; - if (dom.Domain.conflict_credit <= 0.) then remove_from_queue dom doms.doms_conflict_paused - ) - ) !dead_dom; - !notify, !dead_dom + Hashtbl.iter (fun id _ -> if id <> 0 then + try + let info = Xenctrl.domain_getinfo xc id in + if info.Xenctrl.shutdown || info.Xenctrl.dying then ( + debug "Domain %u died (dying=%b, shutdown %b -- code %d)" + id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code; + if info.Xenctrl.dying then + dead_dom := id :: !dead_dom + else + notify := true; + ) + with Xenctrl.Error _ -> + debug "Domain %u died -- no domain info" id; + dead_dom := id :: !dead_dom; + ) doms.table; + List.iter (fun id -> + let dom = Hashtbl.find doms.table id in + Domain.close dom; + Hashtbl.remove doms.table id; + if dom.Domain.conflict_credit <= !Define.conflict_burst_limit + then ( + remove_from_queue dom doms.doms_with_conflict_penalty; + if (dom.Domain.conflict_credit <= 0.) then remove_from_queue dom doms.doms_conflict_paused + ) + ) !dead_dom; + !notify, !dead_dom let resume _doms _domid = - () + () let create doms domid mfn port = - let interface = Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize()) mfn in - let dom = Domain.make domid mfn port interface doms.eventchn in - Hashtbl.add doms.table domid dom; - Domain.bind_interdomain dom; - dom + let interface = Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize()) mfn in + let dom = Domain.make domid mfn port interface doms.eventchn in + Hashtbl.add doms.table domid dom; + Domain.bind_interdomain dom; + dom let xenstored_kva = ref "" let xenstored_port = ref "" let create0 doms = - let port, interface = - ( - let port = Utils.read_file_single_integer !xenstored_port - and fd = Unix.openfile !xenstored_kva - [ Unix.O_RDWR ] 0o600 in - let interface = Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED - (Xenmmap.getpagesize()) 0 in - Unix.close fd; - port, interface - ) - in - let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in - Hashtbl.add doms.table 0 dom; - Domain.bind_interdomain dom; - Domain.notify dom; - dom + let port, interface = + ( + let port = Utils.read_file_single_integer !xenstored_port + and fd = Unix.openfile !xenstored_kva + [ Unix.O_RDWR ] 0o600 in + let interface = Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED + (Xenmmap.getpagesize()) 0 in + Unix.close fd; + port, interface + ) + in + let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in + Hashtbl.add doms.table 0 dom; + Domain.bind_interdomain dom; + Domain.notify dom; + dom let decr_conflict_credit doms dom = - dom.Domain.caused_conflicts <- Int64.add 1L dom.Domain.caused_conflicts; - let before = dom.Domain.conflict_credit in - let after = max (-1.0) (before -. 1.0) in - debug "decr_conflict_credit dom%d %F -> %F" (Domain.get_id dom) before after; - dom.Domain.conflict_credit <- after; - let newly_penalised = - before >= !Define.conflict_burst_limit - && after < !Define.conflict_burst_limit in - let newly_paused = before > 0.0 && after <= 0.0 in - if !Define.conflict_rate_limit_is_aggregate then ( - if newly_penalised - && after > 0.0 - then ( - push dom doms.doms_with_conflict_penalty - ) else if newly_paused - then ( - let first_pause = Queue.is_empty doms.doms_conflict_paused in - push dom doms.doms_conflict_paused; - if first_pause then doms.on_first_conflict_pause () - ) else ( - (* The queues are correct already: no further action needed. *) - ) - ) else ( - if newly_penalised then doms.n_penalised <- doms.n_penalised + 1; - if newly_paused then ( - doms.n_paused <- doms.n_paused + 1; - if doms.n_paused = 1 then doms.on_first_conflict_pause () - ) - ) + dom.Domain.caused_conflicts <- Int64.add 1L dom.Domain.caused_conflicts; + let before = dom.Domain.conflict_credit in + let after = max (-1.0) (before -. 1.0) in + debug "decr_conflict_credit dom%d %F -> %F" (Domain.get_id dom) before after; + dom.Domain.conflict_credit <- after; + let newly_penalised = + before >= !Define.conflict_burst_limit + && after < !Define.conflict_burst_limit in + let newly_paused = before > 0.0 && after <= 0.0 in + if !Define.conflict_rate_limit_is_aggregate then ( + if newly_penalised + && after > 0.0 + then ( + push dom doms.doms_with_conflict_penalty + ) else if newly_paused + then ( + let first_pause = Queue.is_empty doms.doms_conflict_paused in + push dom doms.doms_conflict_paused; + if first_pause then doms.on_first_conflict_pause () + ) else ( + (* The queues are correct already: no further action needed. *) + ) + ) else ( + if newly_penalised then doms.n_penalised <- doms.n_penalised + 1; + if newly_paused then ( + doms.n_paused <- doms.n_paused + 1; + if doms.n_paused = 1 then doms.on_first_conflict_pause () + ) + ) (* Give one point of credit to one domain, and update the queues appropriately. *) let incr_conflict_credit_from_queue doms = - let process_queue q requeue_test = - let d = pop q in - let before = d.Domain.conflict_credit in (* just for debug-logging *) - d.Domain.conflict_credit <- min (d.Domain.conflict_credit +. 1.0) !Define.conflict_burst_limit; - debug "incr_conflict_credit_from_queue: dom%d: %F -> %F" (Domain.get_id d) before d.Domain.conflict_credit; - if requeue_test d.Domain.conflict_credit then ( - push d q (* Make it queue up again for its next point of credit. *) - ) - in - let paused_queue_test cred = cred <= 0.0 in - let penalty_queue_test cred = cred < !Define.conflict_burst_limit in - try process_queue doms.doms_conflict_paused paused_queue_test - with Queue.Empty -> ( - try process_queue doms.doms_with_conflict_penalty penalty_queue_test - with Queue.Empty -> () (* Both queues are empty: nothing to do here. *) - ) + let process_queue q requeue_test = + let d = pop q in + let before = d.Domain.conflict_credit in (* just for debug-logging *) + d.Domain.conflict_credit <- min (d.Domain.conflict_credit +. 1.0) !Define.conflict_burst_limit; + debug "incr_conflict_credit_from_queue: dom%d: %F -> %F" (Domain.get_id d) before d.Domain.conflict_credit; + if requeue_test d.Domain.conflict_credit then ( + push d q (* Make it queue up again for its next point of credit. *) + ) + in + let paused_queue_test cred = cred <= 0.0 in + let penalty_queue_test cred = cred < !Define.conflict_burst_limit in + try process_queue doms.doms_conflict_paused paused_queue_test + with Queue.Empty -> ( + try process_queue doms.doms_with_conflict_penalty penalty_queue_test + with Queue.Empty -> () (* Both queues are empty: nothing to do here. *) + ) let incr_conflict_credit doms = - if !Define.conflict_rate_limit_is_aggregate - then incr_conflict_credit_from_queue doms - else ( - (* Give a point of credit to every domain, subject only to the cap. *) - let inc dom = - let before = dom.Domain.conflict_credit in - let after = min (before +. 1.0) !Define.conflict_burst_limit in - dom.Domain.conflict_credit <- after; - debug "incr_conflict_credit dom%d: %F -> %F" (Domain.get_id dom) before after; + if !Define.conflict_rate_limit_is_aggregate + then incr_conflict_credit_from_queue doms + else ( + (* Give a point of credit to every domain, subject only to the cap. *) + let inc dom = + let before = dom.Domain.conflict_credit in + let after = min (before +. 1.0) !Define.conflict_burst_limit in + dom.Domain.conflict_credit <- after; + debug "incr_conflict_credit dom%d: %F -> %F" (Domain.get_id dom) before after; - if before <= 0.0 && after > 0.0 - then doms.n_paused <- doms.n_paused - 1; + if before <= 0.0 && after > 0.0 + then doms.n_paused <- doms.n_paused - 1; - if before < !Define.conflict_burst_limit - && after >= !Define.conflict_burst_limit - then doms.n_penalised <- doms.n_penalised - 1 - in - if doms.n_penalised > 0 then iter doms inc - ) + if before < !Define.conflict_burst_limit + && after >= !Define.conflict_burst_limit + then doms.n_penalised <- doms.n_penalised - 1 + in + if doms.n_penalised > 0 then iter doms inc + ) diff --git a/tools/ocaml/xenstored/event.ml b/tools/ocaml/xenstored/event.ml index ccca90b6fc..b10027f004 100644 --- a/tools/ocaml/xenstored/event.ml +++ b/tools/ocaml/xenstored/event.ml @@ -16,8 +16,8 @@ (**************** high level binding ****************) type t = { - handle: Xeneventchn.handle; - mutable virq_port: Xeneventchn.t option; + handle: Xeneventchn.handle; + mutable virq_port: Xeneventchn.t option; } let init () = { handle = Xeneventchn.init (); virq_port = None; } diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/history.ml index ba5c9cb571..f03fb18329 100644 --- a/tools/ocaml/xenstored/history.ml +++ b/tools/ocaml/xenstored/history.ml @@ -13,11 +13,11 @@ *) type history_record = { - con: Connection.t; (* connection that made a change *) - tid: int; (* transaction id of the change (may be Transaction.none) *) - before: Store.t; (* the store before the change *) - after: Store.t; (* the store after the change *) - finish_count: int64; (* the commit-count at which the transaction finished *) + con: Connection.t; (* connection that made a change *) + tid: int; (* transaction id of the change (may be Transaction.none) *) + before: Store.t; (* the store before the change *) + after: Store.t; (* the store after the change *) + finish_count: int64; (* the commit-count at which the transaction finished *) } let history : history_record list ref = ref [] @@ -26,38 +26,38 @@ let history : history_record list ref = ref [] (* There is scope for optimisation here, replacing List.filter with something more efficient, * probably on a different list-like structure. *) let trim ?txn () = - Transaction.trim_short_running_transactions txn; - history := match Transaction.oldest_short_running_transaction () with - | None -> [] (* We have no open transaction, so no history is needed *) - | Some (_, txn) -> ( - (* keep records with finish_count recent enough to be relevant *) - List.filter (fun r -> r.finish_count > txn.Transaction.start_count) !history - ) + Transaction.trim_short_running_transactions txn; + history := match Transaction.oldest_short_running_transaction () with + | None -> [] (* We have no open transaction, so no history is needed *) + | Some (_, txn) -> ( + (* keep records with finish_count recent enough to be relevant *) + List.filter (fun r -> r.finish_count > txn.Transaction.start_count) !history + ) let end_transaction txn con tid commit = - let success = Connection.end_transaction con tid commit in - trim ~txn (); - success + let success = Connection.end_transaction con tid commit in + trim ~txn (); + success let reconnect con = - trim (); - Connection.do_reconnect con + trim (); + Connection.do_reconnect con let push (x: history_record) = - let dom = x.con.Connection.dom in - match dom with - | None -> () (* treat socket connections as always free to conflict *) - | Some d -> if not (Domain.is_free_to_conflict d) then history := x :: !history + let dom = x.con.Connection.dom in + match dom with + | None -> () (* treat socket connections as always free to conflict *) + | Some d -> if not (Domain.is_free_to_conflict d) then history := x :: !history (* Find the connections from records since commit-count [since] for which [f record] returns [true] *) let filter_connections ~ignore ~since ~f = - (* The "mem" call is an optimisation, to avoid calling f if we have picked con already. *) - (* Using a hash table rather than a list is to optimise the "mem" call. *) - List.fold_left (fun acc hist_rec -> - if hist_rec.finish_count > since - && not (hist_rec.con == ignore) - && not (Hashtbl.mem acc hist_rec.con) - && f hist_rec - then Hashtbl.replace acc hist_rec.con (); - acc - ) (Hashtbl.create 1023) !history + (* The "mem" call is an optimisation, to avoid calling f if we have picked con already. *) + (* Using a hash table rather than a list is to optimise the "mem" call. *) + List.fold_left (fun acc hist_rec -> + if hist_rec.finish_count > since + && not (hist_rec.con == ignore) + && not (Hashtbl.mem acc hist_rec.con) + && f hist_rec + then Hashtbl.replace acc hist_rec.con (); + acc + ) (Hashtbl.create 1023) !history diff --git a/tools/ocaml/xenstored/logging.ml b/tools/ocaml/xenstored/logging.ml index 39c3036155..021ebc465b 100644 --- a/tools/ocaml/xenstored/logging.ml +++ b/tools/ocaml/xenstored/logging.ml @@ -21,138 +21,138 @@ open Printf (* Logger common *) type log_destination = - | File of string - | Syslog of Syslog.facility + | File of string + | Syslog of Syslog.facility let log_destination_of_string s = - let prefix = "syslog:" in - let len_prefix = String.length prefix in - let len = String.length s in - if String.startswith prefix s - then Syslog(Syslog.facility_of_string (String.sub s len_prefix (len - len_prefix))) - else File s + let prefix = "syslog:" in + let len_prefix = String.length prefix in + let len = String.length s in + if String.startswith prefix s + then Syslog(Syslog.facility_of_string (String.sub s len_prefix (len - len_prefix))) + else File s (* The prefix of a log line depends on the log destination *) let prefix log_destination ?level ?key date = match log_destination with - | File _ -> - let level = match level with - | Some x -> Printf.sprintf "|%5s" x - | None -> "" in - let key = match key with - | Some x -> "|" ^ x - | None -> "" in - Printf.sprintf "[%s%s%s] " date level key - | Syslog _ -> - let key = match key with - | Some x -> "[" ^ x ^ "] " - | None -> "" in - (* Syslog handles the date and level internally *) - key + | File _ -> + let level = match level with + | Some x -> Printf.sprintf "|%5s" x + | None -> "" in + let key = match key with + | Some x -> "|" ^ x + | None -> "" in + Printf.sprintf "[%s%s%s] " date level key + | Syslog _ -> + let key = match key with + | Some x -> "[" ^ x ^ "] " + | None -> "" in + (* Syslog handles the date and level internally *) + key type level = Debug | Info | Warn | Error | Null type logger = - { stop: unit -> unit; - restart: unit -> unit; - rotate: unit -> unit; - write: ?level:level -> string -> unit } + { stop: unit -> unit; + restart: unit -> unit; + rotate: unit -> unit; + write: ?level:level -> string -> unit } let truncate_line nb_chars line = - if String.length line > nb_chars - 1 then - let len = max (nb_chars - 1) 2 in - let dst_line = Bytes.create len in - Bytes.blit_string line 0 dst_line 0 (len - 2); - Bytes.set dst_line (len-2) '.'; - Bytes.set dst_line (len-1) '.'; - Bytes.unsafe_to_string dst_line - else line + if String.length line > nb_chars - 1 then + let len = max (nb_chars - 1) 2 in + let dst_line = Bytes.create len in + Bytes.blit_string line 0 dst_line 0 (len - 2); + Bytes.set dst_line (len-2) '.'; + Bytes.set dst_line (len-1) '.'; + Bytes.unsafe_to_string dst_line + else line let log_rotate ref_ch log_file log_nb_files = - let file n = sprintf "%s.%i" log_file n in - let log_files = - let rec aux accu n = - if n >= log_nb_files then accu - else - if n = 1 && Sys.file_exists log_file - then aux [log_file,1] 2 - else - let file = file (n-1) in - if Sys.file_exists file then - aux ((file, n) :: accu) (n+1) - else accu in - aux [] 1 in - List.iter (fun (f, n) -> Unix.rename f (file n)) log_files; - close_out !ref_ch; - ref_ch := open_out log_file + let file n = sprintf "%s.%i" log_file n in + let log_files = + let rec aux accu n = + if n >= log_nb_files then accu + else + if n = 1 && Sys.file_exists log_file + then aux [log_file,1] 2 + else + let file = file (n-1) in + if Sys.file_exists file then + aux ((file, n) :: accu) (n+1) + else accu in + aux [] 1 in + List.iter (fun (f, n) -> Unix.rename f (file n)) log_files; + close_out !ref_ch; + ref_ch := open_out log_file let make_file_logger log_file log_nb_files log_nb_lines log_nb_chars post_rotate = - let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in - let counter = ref 0 in - let stop() = - try flush !channel; close_out !channel - with _ -> () in - let restart() = - stop(); - channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in - let rotate() = - log_rotate channel log_file log_nb_files; - (post_rotate (): unit); - counter := 0 in - let write ?level:_ s = - let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in - let s = s ^ "\n" in - output_string !channel s; - flush !channel; - incr counter; - if !counter > log_nb_lines then rotate() in - { stop=stop; restart=restart; rotate=rotate; write=write } + let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in + let counter = ref 0 in + let stop() = + try flush !channel; close_out !channel + with _ -> () in + let restart() = + stop(); + channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in + let rotate() = + log_rotate channel log_file log_nb_files; + (post_rotate (): unit); + counter := 0 in + let write ?level:_ s = + let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in + let s = s ^ "\n" in + output_string !channel s; + flush !channel; + incr counter; + if !counter > log_nb_lines then rotate() in + { stop=stop; restart=restart; rotate=rotate; write=write } exception Unknown_level of string let int_of_level = function - | Debug -> 0 | Info -> 1 | Warn -> 2 - | Error -> 3 | Null -> max_int + | Debug -> 0 | Info -> 1 | Warn -> 2 + | Error -> 3 | Null -> max_int let string_of_level = function - | Debug -> "debug" | Info -> "info" | Warn -> "warn" - | Error -> "error" | Null -> "null" + | Debug -> "debug" | Info -> "info" | Warn -> "warn" + | Error -> "error" | Null -> "null" let level_of_string = function - | "debug" -> Debug | "info" -> Info | "warn" -> Warn - | "error" -> Error | "null" -> Null | s -> raise (Unknown_level s) + | "debug" -> Debug | "info" -> Info | "warn" -> Warn + | "error" -> Error | "null" -> Null | s -> raise (Unknown_level s) let string_of_date () = - let time = Unix.gettimeofday () in - let tm = Unix.gmtime time in - let msec = time -. (floor time) in - sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ" - (1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday - tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec - (int_of_float (1000.0 *. msec)) + let time = Unix.gettimeofday () in + let tm = Unix.gmtime time in + let msec = time -. (floor time) in + sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ" + (1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday + tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + (int_of_float (1000.0 *. msec)) (* We can defer to syslog for log management *) let make_syslog_logger facility = - (* When TZ is unset in the environment, each syslog call will stat the - /etc/localtime file at least three times during the process. We'd like to - avoid this cost given that we are not a mobile environment and we log - almost every xenstore entry update/watch. *) - let () = - let tz_is_set = - try String.length (Unix.getenv "TZ") > 0 - with Not_found -> false in - if not tz_is_set then Unix.putenv "TZ" "/etc/localtime" in - let nothing () = () in - let write ?level s = - let level = match level with - | Some Error -> Syslog.Err - | Some Warn -> Syslog.Warning - | Some Info -> Syslog.Info - | Some Debug -> Syslog.Debug - | Some Null -> Syslog.Debug - | None -> Syslog.Debug in - (* Syslog handles the date and level internally *) - Syslog.log facility level s in - { stop = nothing; restart = nothing; rotate = nothing; write=write } + (* When TZ is unset in the environment, each syslog call will stat the + /etc/localtime file at least three times during the process. We'd like to + avoid this cost given that we are not a mobile environment and we log + almost every xenstore entry update/watch. *) + let () = + let tz_is_set = + try String.length (Unix.getenv "TZ") > 0 + with Not_found -> false in + if not tz_is_set then Unix.putenv "TZ" "/etc/localtime" in + let nothing () = () in + let write ?level s = + let level = match level with + | Some Error -> Syslog.Err + | Some Warn -> Syslog.Warning + | Some Info -> Syslog.Info + | Some Debug -> Syslog.Debug + | Some Null -> Syslog.Debug + | None -> Syslog.Debug in + (* Syslog handles the date and level internally *) + Syslog.log facility level s in + { stop = nothing; restart = nothing; rotate = nothing; write=write } let xenstored_log_destination = ref (File (Paths.xen_log_dir ^ "/xenstored.log")) let xenstored_log_level = ref Warn @@ -164,34 +164,34 @@ let xenstored_logger = ref (None: logger option) let debug_enabled () = !xenstored_log_level = Debug let set_xenstored_log_destination s = - xenstored_log_destination := log_destination_of_string s + xenstored_log_destination := log_destination_of_string s let set_xenstored_logger logger = - xenstored_logger := Some logger; - logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d.%d" - Define.xenstored_major Define.xenstored_minor) + xenstored_logger := Some logger; + logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d.%d" + Define.xenstored_major Define.xenstored_minor) let init_xenstored_log () = match !xenstored_log_destination with - | File file -> - if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then - let logger = - make_file_logger - file !xenstored_log_nb_files !xenstored_log_nb_lines - !xenstored_log_nb_chars ignore in - set_xenstored_logger logger - | Syslog facility -> - set_xenstored_logger (make_syslog_logger facility) + | File file -> + if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then + let logger = + make_file_logger + file !xenstored_log_nb_files !xenstored_log_nb_lines + !xenstored_log_nb_chars ignore in + set_xenstored_logger logger + | Syslog facility -> + set_xenstored_logger (make_syslog_logger facility) let xenstored_logging level key (fmt: (_,_,_,_) format4) = - match !xenstored_logger with - | Some logger when int_of_level level >= int_of_level !xenstored_log_level -> - let date = string_of_date() in - let level' = string_of_level level in - let prefix = prefix !xenstored_log_destination ~level:level' ~key date in - Printf.ksprintf (fun s -> logger.write ~level (prefix ^ s)) fmt - | _ -> Printf.ksprintf ignore fmt + match !xenstored_logger with + | Some logger when int_of_level level >= int_of_level !xenstored_log_level -> + let date = string_of_date() in + let level' = string_of_level level in + let prefix = prefix !xenstored_log_destination ~level:level' ~key date in + Printf.ksprintf (fun s -> logger.write ~level (prefix ^ s)) fmt + | _ -> Printf.ksprintf ignore fmt let debug key = xenstored_logging Debug key let info key = xenstored_logging Info key @@ -201,66 +201,66 @@ let error key = xenstored_logging Error key (* Access logger *) type access_type = - | Coalesce - | Conflict - | Commit - | Newconn - | Endconn - | Watch_not_fired - | XbOp of Xenbus.Xb.Op.operation + | Coalesce + | Conflict + | Commit + | Newconn + | Endconn + | Watch_not_fired + | XbOp of Xenbus.Xb.Op.operation let string_of_tid ~con tid = - if tid = 0 - then sprintf "%-12s" con - else sprintf "%-12s" (sprintf "%s.%i" con tid) + if tid = 0 + then sprintf "%-12s" con + else sprintf "%-12s" (sprintf "%s.%i" con tid) let string_of_access_type = function - | Coalesce -> "coalesce " - | Conflict -> "conflict " - | Commit -> "commit " - | Newconn -> "newconn " - | Endconn -> "endconn " - | Watch_not_fired -> "w notfired" + | Coalesce -> "coalesce " + | Conflict -> "conflict " + | Commit -> "commit " + | Newconn -> "newconn " + | Endconn -> "endconn " + | Watch_not_fired -> "w notfired" - | XbOp op -> match op with - | Xenbus.Xb.Op.Debug -> "debug " + | XbOp op -> match op with + | Xenbus.Xb.Op.Debug -> "debug " - | Xenbus.Xb.Op.Directory -> "directory" - | Xenbus.Xb.Op.Read -> "read " - | Xenbus.Xb.Op.Getperms -> "getperms " + | Xenbus.Xb.Op.Directory -> "directory" + | Xenbus.Xb.Op.Read -> "read " + | Xenbus.Xb.Op.Getperms -> "getperms " - | Xenbus.Xb.Op.Watch -> "watch " - | Xenbus.Xb.Op.Unwatch -> "unwatch " + | Xenbus.Xb.Op.Watch -> "watch " + | Xenbus.Xb.Op.Unwatch -> "unwatch " - | Xenbus.Xb.Op.Transaction_start -> "t start " - | Xenbus.Xb.Op.Transaction_end -> "t end " + | Xenbus.Xb.Op.Transaction_start -> "t start " + | Xenbus.Xb.Op.Transaction_end -> "t end " - | Xenbus.Xb.Op.Introduce -> "introduce" - | Xenbus.Xb.Op.Release -> "release " - | Xenbus.Xb.Op.Getdomainpath -> "getdomain" - | Xenbus.Xb.Op.Isintroduced -> "is introduced" - | Xenbus.Xb.Op.Resume -> "resume " + | Xenbus.Xb.Op.Introduce -> "introduce" + | Xenbus.Xb.Op.Release -> "release " + | Xenbus.Xb.Op.Getdomainpath -> "getdomain" + | Xenbus.Xb.Op.Isintroduced -> "is introduced" + | Xenbus.Xb.Op.Resume -> "resume " - | Xenbus.Xb.Op.Write -> "write " - | Xenbus.Xb.Op.Mkdir -> "mkdir " - | Xenbus.Xb.Op.Rm -> "rm " - | Xenbus.Xb.Op.Setperms -> "setperms " - | Xenbus.Xb.Op.Reset_watches -> "reset watches" - | Xenbus.Xb.Op.Set_target -> "settarget" + | Xenbus.Xb.Op.Write -> "write " + | Xenbus.Xb.Op.Mkdir -> "mkdir " + | Xenbus.Xb.Op.Rm -> "rm " + | Xenbus.Xb.Op.Setperms -> "setperms " + | Xenbus.Xb.Op.Reset_watches -> "reset watches" + | Xenbus.Xb.Op.Set_target -> "settarget" - | Xenbus.Xb.Op.Error -> "error " - | Xenbus.Xb.Op.Watchevent -> "w event " - | Xenbus.Xb.Op.Invalid -> "invalid " - (* - | x -> Xenbus.Xb.Op.to_string x - *) + | Xenbus.Xb.Op.Error -> "error " + | Xenbus.Xb.Op.Watchevent -> "w event " + | Xenbus.Xb.Op.Invalid -> "invalid " + (* + | x -> Xenbus.Xb.Op.to_string x + *) let sanitize_data data = - let data = String.init - (String.length data) - (fun i -> let c = data.[i] in if c = '\000' then ' ' else c) - in - String.escaped data + let data = String.init + (String.length data) + (fun i -> let c = data.[i] in if c = '\000' then ' ' else c) + in + String.escaped data let activate_access_log = ref true let access_log_destination = ref (File (Paths.xen_log_dir ^ "/xenstored-access.log")) @@ -273,72 +273,72 @@ let access_log_special_ops = ref false let access_logger = ref None let set_access_log_destination s = - access_log_destination := log_destination_of_string s + access_log_destination := log_destination_of_string s let init_access_log post_rotate = match !access_log_destination with - | File file -> - if !access_log_nb_files > 0 then - let logger = - make_file_logger - file !access_log_nb_files !access_log_nb_lines - !access_log_nb_chars post_rotate in - access_logger := Some logger - | Syslog facility -> - access_logger := Some (make_syslog_logger facility) + | File file -> + if !access_log_nb_files > 0 then + let logger = + make_file_logger + file !access_log_nb_files !access_log_nb_lines + !access_log_nb_chars post_rotate in + access_logger := Some logger + | Syslog facility -> + access_logger := Some (make_syslog_logger facility) let access_logging ~con ~tid ?(data="") ~level access_type = - try - maybe - (fun logger -> - let date = string_of_date() in - let tid = string_of_tid ~con tid in - let access_type = string_of_access_type access_type in - let data = sanitize_data data in - let prefix = prefix !access_log_destination date in - let msg = Printf.sprintf "%s %s %s %s" prefix tid access_type data in - logger.write ~level msg) - !access_logger - with _ -> () + try + maybe + (fun logger -> + let date = string_of_date() in + let tid = string_of_tid ~con tid in + let access_type = string_of_access_type access_type in + let data = sanitize_data data in + let prefix = prefix !access_log_destination date in + let msg = Printf.sprintf "%s %s %s %s" prefix tid access_type data in + logger.write ~level msg) + !access_logger + with _ -> () let new_connection = access_logging ~level:Debug Newconn let end_connection = access_logging ~level:Debug Endconn let read_coalesce ~tid ~con data = - if !access_log_read_ops - then access_logging Coalesce ~tid ~con ~data:("read "^data) ~level:Debug + if !access_log_read_ops + then access_logging Coalesce ~tid ~con ~data:("read "^data) ~level:Debug let write_coalesce data = access_logging Coalesce ~data:("write "^data) ~level:Debug let conflict = access_logging Conflict ~level:Debug let commit = access_logging Commit ~level:Debug let xb_op ~tid ~con ~ty data = - let print = match ty with - | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops - | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end -> - false (* transactions are managed below *) - | Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume -> - !access_log_special_ops - | _ -> true in - if print then access_logging ~tid ~con ~data (XbOp ty) ~level:Info + let print = match ty with + | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops + | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end -> + false (* transactions are managed below *) + | Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume -> + !access_log_special_ops + | _ -> true in + if print then access_logging ~tid ~con ~data (XbOp ty) ~level:Info let start_transaction ~tid ~con = - if !access_log_transaction_ops && tid <> 0 - then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~level:Debug + if !access_log_transaction_ops && tid <> 0 + then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~level:Debug let end_transaction ~tid ~con = - if !access_log_transaction_ops && tid <> 0 - then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) ~level:Debug + if !access_log_transaction_ops && tid <> 0 + then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) ~level:Debug let live_update () = - xb_op ~tid:0 ~con:"" ~ty:Xenbus.Xb.Op.Debug "Live update begin" + xb_op ~tid:0 ~con:"" ~ty:Xenbus.Xb.Op.Debug "Live update begin" let xb_answer ~tid ~con ~ty data = - let print, level = match ty with - | Xenbus.Xb.Op.Error when String.startswith "ENOENT" data -> !access_log_read_ops , Warn - | Xenbus.Xb.Op.Error -> true , Warn - | Xenbus.Xb.Op.Watchevent -> true , Info - | _ -> false, Debug - in - if print then access_logging ~tid ~con ~data (XbOp ty) ~level + let print, level = match ty with + | Xenbus.Xb.Op.Error when String.startswith "ENOENT" data -> !access_log_read_ops , Warn + | Xenbus.Xb.Op.Error -> true , Warn + | Xenbus.Xb.Op.Watchevent -> true , Info + | _ -> false, Debug + in + if print then access_logging ~tid ~con ~data (XbOp ty) ~level let watch_not_fired ~con perms path = - let data = Printf.sprintf "EPERM perms=[%s] path=%s" perms path in - access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info + let data = Printf.sprintf "EPERM perms=[%s] path=%s" perms path in + access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info diff --git a/tools/ocaml/xenstored/packet.ml b/tools/ocaml/xenstored/packet.ml index aeae0a4f57..7c25117937 100644 --- a/tools/ocaml/xenstored/packet.ml +++ b/tools/ocaml/xenstored/packet.ml @@ -1,16 +1,16 @@ type request = { - tid: int; - rid: int; - ty: Xenbus.Xb.Op.operation; - data: string; + tid: int; + rid: int; + ty: Xenbus.Xb.Op.operation; + data: string; } type response = - | Ack of (unit -> unit) (* function is the action to execute after sending the ack *) - | Reply of string - | Error of string + | Ack of (unit -> unit) (* function is the action to execute after sending the ack *) + | Reply of string + | Error of string let response_equal a b = - match (a, b) with - | (Ack _, Ack _) -> true (* just consider the response, not the post-response action *) - | (x, y) -> x = y + match (a, b) with + | (Ack _, Ack _) -> true (* just consider the response, not the post-response action *) + | (x, y) -> x = y diff --git a/tools/ocaml/xenstored/parse_arg.ml b/tools/ocaml/xenstored/parse_arg.ml index 7c0478e76a..1a85b14ef5 100644 --- a/tools/ocaml/xenstored/parse_arg.ml +++ b/tools/ocaml/xenstored/parse_arg.ml @@ -15,59 +15,59 @@ *) type config = -{ - domain_init: bool; - activate_access_log: bool; - daemonize: bool; - reraise_top_level: bool; - config_file: string option; - pidfile: string option; (* old xenstored compatibility *) - tracefile: string option; (* old xenstored compatibility *) - restart: bool; - live_reload: bool; - disable_socket: bool; -} + { + domain_init: bool; + activate_access_log: bool; + daemonize: bool; + reraise_top_level: bool; + config_file: string option; + pidfile: string option; (* old xenstored compatibility *) + tracefile: string option; (* old xenstored compatibility *) + restart: bool; + live_reload: bool; + disable_socket: bool; + } let do_argv = - let pidfile = ref "" and tracefile = ref "" (* old xenstored compatibility *) - and domain_init = ref true - and activate_access_log = ref true - and daemonize = ref true - and reraise_top_level = ref false - and config_file = ref "" - and restart = ref false - and live_reload = ref false - and disable_socket = ref false - in + let pidfile = ref "" and tracefile = ref "" (* old xenstored compatibility *) + and domain_init = ref true + and activate_access_log = ref true + and daemonize = ref true + and reraise_top_level = ref false + and config_file = ref "" + and restart = ref false + and live_reload = ref false + and disable_socket = ref false + in - let speclist = - [ ("--no-domain-init", Arg.Unit (fun () -> domain_init := false), - "to state that xenstored should not initialise dom0"); - ("--config-file", Arg.Set_string config_file, - "set an alternative location for the configuration file"); - ("--no-fork", Arg.Unit (fun () -> daemonize := false), - "to request that the daemon does not fork"); - ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level := true), - "reraise exceptions caught at the top level"); - ("--no-access-log", Arg.Unit (fun () -> activate_access_log := false), - "do not create a xenstore-access.log file"); - ("--pid-file", Arg.Set_string pidfile, ""); (* for compatibility *) - ("-T", Arg.Set_string tracefile, ""); (* for compatibility *) - ("--restart", Arg.Set restart, "Read database on starting"); - ("--live", Arg.Set live_reload, "Read live dump on startup"); - ("--disable-socket", Arg.Unit (fun () -> disable_socket := true), "Disable socket"); - ] in - let usage_msg = "usage : xenstored [--config-file <filename>] [--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable-socket]" in - Arg.parse speclist (fun _ -> ()) usage_msg; - { - domain_init = !domain_init; - activate_access_log = !activate_access_log; - daemonize = !daemonize; - reraise_top_level = !reraise_top_level; - config_file = if !config_file <> "" then Some !config_file else None; - pidfile = if !pidfile <> "" then Some !pidfile else None; - tracefile = if !tracefile <> "" then Some !tracefile else None; - restart = !restart; - live_reload = !live_reload; - disable_socket = !disable_socket; - } + let speclist = + [ ("--no-domain-init", Arg.Unit (fun () -> domain_init := false), + "to state that xenstored should not initialise dom0"); + ("--config-file", Arg.Set_string config_file, + "set an alternative location for the configuration file"); + ("--no-fork", Arg.Unit (fun () -> daemonize := false), + "to request that the daemon does not fork"); + ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level := true), + "reraise exceptions caught at the top level"); + ("--no-access-log", Arg.Unit (fun () -> activate_access_log := false), + "do not create a xenstore-access.log file"); + ("--pid-file", Arg.Set_string pidfile, ""); (* for compatibility *) + ("-T", Arg.Set_string tracefile, ""); (* for compatibility *) + ("--restart", Arg.Set restart, "Read database on starting"); + ("--live", Arg.Set live_reload, "Read live dump on startup"); + ("--disable-socket", Arg.Unit (fun () -> disable_socket := true), "Disable socket"); + ] in + let usage_msg = "usage : xenstored [--config-file <filename>] [--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable-socket]" in + Arg.parse speclist (fun _ -> ()) usage_msg; + { + domain_init = !domain_init; + activate_access_log = !activate_access_log; + daemonize = !daemonize; + reraise_top_level = !reraise_top_level; + config_file = if !config_file <> "" then Some !config_file else None; + pidfile = if !pidfile <> "" then Some !pidfile else None; + tracefile = if !tracefile <> "" then Some !tracefile else None; + restart = !restart; + live_reload = !live_reload; + disable_socket = !disable_socket; + } diff --git a/tools/ocaml/xenstored/perms.ml b/tools/ocaml/xenstored/perms.ml index 84f2503e8e..14f8e334fe 100644 --- a/tools/ocaml/xenstored/perms.ml +++ b/tools/ocaml/xenstored/perms.ml @@ -25,72 +25,72 @@ let watch_activate = ref true type permty = READ | WRITE | RDWR | NONE let char_of_permty perm = - match perm with - | READ -> 'r' - | WRITE -> 'w' - | RDWR -> 'b' - | NONE -> 'n' + match perm with + | READ -> 'r' + | WRITE -> 'w' + | RDWR -> 'b' + | NONE -> 'n' let permty_of_char c = - match c with - | 'r' -> READ - | 'w' -> WRITE - | 'b' -> RDWR - | 'n' -> NONE - | _ -> invalid_arg "unknown permission type" + match c with + | 'r' -> READ + | 'w' -> WRITE + | 'b' -> RDWR + | 'n' -> NONE + | _ -> invalid_arg "unknown permission type" (* node permissions *) module Node = struct -type t = -{ - owner: Xenctrl.domid; - other: permty; - acl: (Xenctrl.domid * permty) list; -} + type t = + { + owner: Xenctrl.domid; + other: permty; + acl: (Xenctrl.domid * permty) list; + } -let create owner other acl = - { owner = owner; other = other; acl = acl } + let create owner other acl = + { owner = owner; other = other; acl = acl } -let get_other perms = perms.other -let get_acl perms = perms.acl -let get_owner perm = perm.owner + let get_other perms = perms.other + let get_acl perms = perms.acl + let get_owner perm = perm.owner -(** [remote_domid ~domid perm] removes all ACLs for [domid] from perm. -* If [domid] was the owner then it is changed to Dom0. -* This is used for cleaning up after dead domains. -* *) -let remove_domid ~domid perm = - let acl = List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.acl in - if perm.owner = domid then None else Some { perm with acl; owner = perm.owner } + (** [remote_domid ~domid perm] removes all ACLs for [domid] from perm. + * If [domid] was the owner then it is changed to Dom0. + * This is used for cleaning up after dead domains. + * *) + let remove_domid ~domid perm = + let acl = List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.acl in + if perm.owner = domid then None else Some { perm with acl; owner = perm.owner } -let default0 = create 0 NONE [] + let default0 = create 0 NONE [] -let perm_of_string s = - let ty = permty_of_char s.[0] - and id = int_of_string (String.sub s 1 (String.length s - 1)) in - (id, ty) + let perm_of_string s = + let ty = permty_of_char s.[0] + and id = int_of_string (String.sub s 1 (String.length s - 1)) in + (id, ty) -let of_strings ls = - let vect = List.map (perm_of_string) ls in - match vect with - | [] -> invalid_arg "permvec empty" - | h :: l -> create (fst h) (snd h) l + let of_strings ls = + let vect = List.map (perm_of_string) ls in + match vect with + | [] -> invalid_arg "permvec empty" + | h :: l -> create (fst h) (snd h) l -(* [s] must end with '\000' *) -let of_string s = - let ls = String.split '\000' s in - let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in - of_strings ls + (* [s] must end with '\000' *) + let of_string s = + let ls = String.split '\000' s in + let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in + of_strings ls -let string_of_perm perm = - Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm) + let string_of_perm perm = + Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm) -let to_string ?(sep="\000") permvec = - let l = ((permvec.owner, permvec.other) :: permvec.acl) in - String.concat sep (List.map string_of_perm l) + let to_string ?(sep="\000") permvec = + let l = ((permvec.owner, permvec.other) :: permvec.acl) in + String.concat sep (List.map string_of_perm l) end @@ -99,87 +99,87 @@ end module Connection = struct -type elt = Xenctrl.domid * (permty list) -type t = - { main: elt; - target: elt option; } + type elt = Xenctrl.domid * (permty list) + type t = + { main: elt; + target: elt option; } -let full_rights : t = - { main = 0, [READ; WRITE]; - target = None } + let full_rights : t = + { main = 0, [READ; WRITE]; + target = None } -let create ?(perms=[NONE]) domid : t = - { main = (domid, perms); - target = None } + let create ?(perms=[NONE]) domid : t = + { main = (domid, perms); + target = None } -let set_target (connection:t) ?(perms=[NONE]) domid = - { connection with target = Some (domid, perms) } + let set_target (connection:t) ?(perms=[NONE]) domid = + { connection with target = Some (domid, perms) } -let get_owners (connection:t) = - match connection.main, connection.target with - | c1, Some c2 -> [ fst c1; fst c2 ] - | c1, None -> [ fst c1 ] + let get_owners (connection:t) = + match connection.main, connection.target with + | c1, Some c2 -> [ fst c1; fst c2 ] + | c1, None -> [ fst c1 ] -let is_owner (connection:t) id = - match connection.target with - | Some target -> fst connection.main = id || fst target = id - | None -> fst connection.main = id + let is_owner (connection:t) id = + match connection.target with + | Some target -> fst connection.main = id || fst target = id + | None -> fst connection.main = id -let is_dom0 (connection:t) = - is_owner connection 0 + let is_dom0 (connection:t) = + is_owner connection 0 -let elt_to_string (i,p) = - Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p))) + let elt_to_string (i,p) = + Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p))) -let to_string connection = - Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target)) + let to_string connection = + Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target)) end (* check if owner of the current connection and of the current node are the same *) let check_owner (connection:Connection.t) (node:Node.t) = - if !activate && not (Connection.is_dom0 connection) - then Connection.is_owner connection (Node.get_owner node) - else true + if !activate && not (Connection.is_dom0 connection) + then Connection.is_owner connection (Node.get_owner node) + else true (* check if the current connection lacks the requested perm on the current node *) let lacks (connection:Connection.t) request (node:Node.t) = - let check_acl domainid = - let perm = - if List.mem_assoc domainid (Node.get_acl node) - then List.assoc domainid (Node.get_acl node) - else Node.get_other node - in - match perm, request with - | NONE, _ -> - info "Permission denied: Domain %d has no permission" domainid; - false - | RDWR, _ -> true - | READ, READ -> true - | WRITE, WRITE -> true - | READ, _ -> - info "Permission denied: Domain %d has read only access" domainid; - false - | WRITE, _ -> - info "Permission denied: Domain %d has write only access" domainid; - false - in - !activate - && not (Connection.is_dom0 connection) - && not (check_owner connection node) - && not (List.exists check_acl (Connection.get_owners connection)) + let check_acl domainid = + let perm = + if List.mem_assoc domainid (Node.get_acl node) + then List.assoc domainid (Node.get_acl node) + else Node.get_other node + in + match perm, request with + | NONE, _ -> + info "Permission denied: Domain %d has no permission" domainid; + false + | RDWR, _ -> true + | READ, READ -> true + | WRITE, WRITE -> true + | READ, _ -> + info "Permission denied: Domain %d has read only access" domainid; + false + | WRITE, _ -> + info "Permission denied: Domain %d has write only access" domainid; + false + in + !activate + && not (Connection.is_dom0 connection) + && not (check_owner connection node) + && not (List.exists check_acl (Connection.get_owners connection)) (* check if the current connection has the requested perm on the current node. -* Raises an exception if it doesn't. *) + * Raises an exception if it doesn't. *) let check connection request node = - if lacks connection request node - then raise Define.Permission_denied + if lacks connection request node + then raise Define.Permission_denied (* check if the current connection has the requested perm on the current node *) let has connection request node = not (lacks connection request node) let can_fire_watch connection perms = - not !watch_activate - || List.exists (has connection READ) perms + not !watch_activate + || List.exists (has connection READ) perms let equiv perm1 perm2 = - (Node.to_string perm1) = (Node.to_string perm2) + (Node.to_string perm1) = (Node.to_string perm2) diff --git a/tools/ocaml/xenstored/poll.ml b/tools/ocaml/xenstored/poll.ml index 26f8620dfc..80951c7d36 100644 --- a/tools/ocaml/xenstored/poll.ml +++ b/tools/ocaml/xenstored/poll.ml @@ -17,9 +17,9 @@ subscription flags used by poll, which have a correspondence to the readfds, writefds, exceptfds concept as in select. *) type event = { - mutable read: bool; - mutable write: bool; - mutable except: bool; + mutable read: bool; + mutable write: bool; + mutable except: bool; } external select_on_poll: (Unix.file_descr * event) array -> int -> int = "stub_select_on_poll" @@ -28,40 +28,40 @@ external set_fd_limit: int -> unit = "stub_set_fd_limit" (* The rlim_max given to setrlimit must not go above the system level nr_open, which we can read from /proc/sys. *) let get_sys_fs_nr_open () = - try - let ch = open_in "/proc/sys/fs/nr_open" in - let v = int_of_string (input_line ch) in - close_in_noerr ch; v - with _ -> 1024 * 1024 + try + let ch = open_in "/proc/sys/fs/nr_open" in + let v = int_of_string (input_line ch) in + close_in_noerr ch; v + with _ -> 1024 * 1024 let init_event () = {read = false; write = false; except = false} let poll_select in_fds out_fds exc_fds timeout = - let h = Hashtbl.create 57 in - let add_event event_set fd = - let e = - try Hashtbl.find h fd - with Not_found -> - let e = init_event () in - Hashtbl.add h fd e; e in - event_set e in - List.iter (add_event (fun x -> x.read <- true)) in_fds; - List.iter (add_event (fun x -> x.write <- true)) out_fds; - List.iter (add_event (fun x -> x.except <- true)) exc_fds; - (* Unix.stdin and init_event are dummy input as stubs, which will - always be overwritten later on. *) - let a = Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in - let i = ref (-1) in - Hashtbl.iter (fun fd event -> incr i; Array.set a !i (fd, event)) h; - let n = select_on_poll a (int_of_float (timeout *. 1000.)) in - let r = [], [], [] in - if n = 0 then r else - Array.fold_right - (fun (fd, event) (r, w, x) -> - (if event.read then fd :: r else r), - (if event.write then fd :: w else w), - (if event.except then fd :: x else x)) - a r + let h = Hashtbl.create 57 in + let add_event event_set fd = + let e = + try Hashtbl.find h fd + with Not_found -> + let e = init_event () in + Hashtbl.add h fd e; e in + event_set e in + List.iter (add_event (fun x -> x.read <- true)) in_fds; + List.iter (add_event (fun x -> x.write <- true)) out_fds; + List.iter (add_event (fun x -> x.except <- true)) exc_fds; + (* Unix.stdin and init_event are dummy input as stubs, which will + always be overwritten later on. *) + let a = Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in + let i = ref (-1) in + Hashtbl.iter (fun fd event -> incr i; Array.set a !i (fd, event)) h; + let n = select_on_poll a (int_of_float (timeout *. 1000.)) in + let r = [], [], [] in + if n = 0 then r else + Array.fold_right + (fun (fd, event) (r, w, x) -> + (if event.read then fd :: r else r), + (if event.write then fd :: w else w), + (if event.except then fd :: x else x)) + a r let () = - set_fd_limit (get_sys_fs_nr_open ()) + set_fd_limit (get_sys_fs_nr_open ()) diff --git a/tools/ocaml/xenstored/poll.mli b/tools/ocaml/xenstored/poll.mli index f73465b99f..e759608b1a 100644 --- a/tools/ocaml/xenstored/poll.mli +++ b/tools/ocaml/xenstored/poll.mli @@ -15,5 +15,5 @@ (** Same interface and semantics as [Unix.select], implemented using poll(3). *) val poll_select: - Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float - -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list + Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float + -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml index 72a79e9328..30e62377ce 100644 --- a/tools/ocaml/xenstored/process.ml +++ b/tools/ocaml/xenstored/process.ml @@ -31,302 +31,302 @@ exception Invalid_Cmd_Args let allow_debug = ref false let c_int_of_string s = - let v = ref 0 in - let is_digit c = c >= '0' && c <= '9' in - let len = String.length s in - let i = ref 0 in - while !i < len && not (is_digit s.[!i]) do incr i done; - while !i < len && is_digit s.[!i] - do - let x = (Char.code s.[!i]) - (Char.code '0') in - v := !v * 10 + x; - incr i - done; - !v + let v = ref 0 in + let is_digit c = c >= '0' && c <= '9' in + let len = String.length s in + let i = ref 0 in + while !i < len && not (is_digit s.[!i]) do incr i done; + while !i < len && is_digit s.[!i] + do + let x = (Char.code s.[!i]) - (Char.code '0') in + v := !v * 10 + x; + incr i + done; + !v (* when we don't want a limit, apply a max limit of 8 arguments. no arguments take more than 3 currently, which is pointless to split more than needed. *) let split limit c s = - let limit = match limit with None -> 8 | Some x -> x in - String.split ~limit c s + let limit = match limit with None -> 8 | Some x -> x in + String.split ~limit c s let split_one_path data con = - let args = split (Some 2) '\000' data in - match args with - | path :: "" :: [] -> Store.Path.create path (Connection.get_path con) - | _ -> raise Invalid_Cmd_Args + let args = split (Some 2) '\000' data in + match args with + | path :: "" :: [] -> Store.Path.create path (Connection.get_path con) + | _ -> raise Invalid_Cmd_Args let process_watch source t cons = - let oldroot = t.Transaction.oldroot in - let newroot = Store.get_root t.Transaction.store in - let ops = Transaction.get_paths t |> List.rev in - let do_op_watch op cons = - let recurse, oldroot, root = match (fst op) with - | Xenbus.Xb.Op.Write|Xenbus.Xb.Op.Mkdir -> false, None, newroot - | Xenbus.Xb.Op.Rm -> true, None, oldroot - | Xenbus.Xb.Op.Setperms -> false, Some oldroot, newroot - | _ -> raise (Failure "huh ?") in - Connections.fire_watches ?oldroot source root cons (snd op) recurse in - List.iter (fun op -> do_op_watch op cons) ops; - Connections.send_watchevents cons source + let oldroot = t.Transaction.oldroot in + let newroot = Store.get_root t.Transaction.store in + let ops = Transaction.get_paths t |> List.rev in + let do_op_watch op cons = + let recurse, oldroot, root = match (fst op) with + | Xenbus.Xb.Op.Write|Xenbus.Xb.Op.Mkdir -> false, None, newroot + | Xenbus.Xb.Op.Rm -> true, None, oldroot + | Xenbus.Xb.Op.Setperms -> false, Some oldroot, newroot + | _ -> raise (Failure "huh ?") in + Connections.fire_watches ?oldroot source root cons (snd op) recurse in + List.iter (fun op -> do_op_watch op cons) ops; + Connections.send_watchevents cons source let create_implicit_path t perm path = - let dirname = Store.Path.get_parent path in - if not (Transaction.path_exists t dirname) then ( - let rec check_path p = - match p with - | [] -> [] - | h :: l -> - if Transaction.path_exists t h then - check_path l - else - p in - let ret = check_path (List.tl (Store.Path.get_hierarchy dirname)) in - List.iter (fun s -> Transaction.mkdir ~with_watch:false t perm s) ret - ) + let dirname = Store.Path.get_parent path in + if not (Transaction.path_exists t dirname) then ( + let rec check_path p = + match p with + | [] -> [] + | h :: l -> + if Transaction.path_exists t h then + check_path l + else + p in + let ret = check_path (List.tl (Store.Path.get_hierarchy dirname)) in + List.iter (fun s -> Transaction.mkdir ~with_watch:false t perm s) ret + ) module LiveUpdate = struct -type t = - { binary: string - ; cmdline: string list - ; deadline: float - ; force: bool - ; result: string list - ; pending: bool } + type t = + { binary: string + ; cmdline: string list + ; deadline: float + ; force: bool + ; result: string list + ; pending: bool } -let state = ref - { binary= Sys.executable_name - ; cmdline= (Sys.argv |> Array.to_list |> List.tl) - ; deadline= 0. - ; force= false - ; result = [] - ; pending= false } + let state = ref + { binary= Sys.executable_name + ; cmdline= (Sys.argv |> Array.to_list |> List.tl) + ; deadline= 0. + ; force= false + ; result = [] + ; pending= false } -let debug = Printf.eprintf + let debug = Printf.eprintf -let forced_args = ["--live"; "--restart"] -let args_of_t t = - let filtered = List.filter (fun x -> not @@ List.mem x forced_args) t.cmdline in - (t.binary, forced_args @ filtered) + let forced_args = ["--live"; "--restart"] + let args_of_t t = + let filtered = List.filter (fun x -> not @@ List.mem x forced_args) t.cmdline in + (t.binary, forced_args @ filtered) -let string_of_t t = - let executable, rest = args_of_t t in - Filename.quote_command executable rest + let string_of_t t = + let executable, rest = args_of_t t in + Filename.quote_command executable rest -let launch_exn t = - let executable, rest = args_of_t t in - let args = Array.of_list (executable :: rest) in - info "Launching %s, args: %s" executable (String.concat " " rest); - Unix.execv args.(0) args + let launch_exn t = + let executable, rest = args_of_t t in + let args = Array.of_list (executable :: rest) in + info "Launching %s, args: %s" executable (String.concat " " rest); + Unix.execv args.(0) args -let validate_exn t = - (* --help must be last to check validity of earlier arguments *) - let t' = {t with cmdline= t.cmdline @ ["--help"]} in - let cmd = string_of_t t' in - debug "Executing %s" cmd ; - match Unix.fork () with - | 0 -> ( try launch_exn t' with _ -> exit 2 ) - | pid -> ( - match Unix.waitpid [] pid with - | _, Unix.WEXITED 0 -> - debug "Live update validated cmdline %s" cmd; - t - | _, Unix.WEXITED n -> - invalid_arg (Printf.sprintf "Command %s exited with code %d" cmd n) - | _, Unix.WSIGNALED n -> - invalid_arg (Printf.sprintf "Command %s killed by ocaml signal number %d" cmd n) - | _, Unix.WSTOPPED n -> - invalid_arg (Printf.sprintf "Command %s stopped by ocaml signal number %d" cmd n) - ) + let validate_exn t = + (* --help must be last to check validity of earlier arguments *) + let t' = {t with cmdline= t.cmdline @ ["--help"]} in + let cmd = string_of_t t' in + debug "Executing %s" cmd ; + match Unix.fork () with + | 0 -> ( try launch_exn t' with _ -> exit 2 ) + | pid -> ( + match Unix.waitpid [] pid with + | _, Unix.WEXITED 0 -> + debug "Live update validated cmdline %s" cmd; + t + | _, Unix.WEXITED n -> + invalid_arg (Printf.sprintf "Command %s exited with code %d" cmd n) + | _, Unix.WSIGNALED n -> + invalid_arg (Printf.sprintf "Command %s killed by ocaml signal number %d" cmd n) + | _, Unix.WSTOPPED n -> + invalid_arg (Printf.sprintf "Command %s stopped by ocaml signal number %d" cmd n) + ) -let parse_live_update args = - try - (state := - match args with - | ["-f"; file] -> - validate_exn {!state with binary= file} - | ["-a"] -> - debug "Live update aborted" ; - {!state with pending= false; result = []} - | "-c" :: cmdline -> - validate_exn {!state with cmdline = !state.cmdline @ cmdline} - | "-s" :: _ -> - (match !state.pending, !state.result with - | true, _ -> !state (* no change to state, avoid resetting timeout *) - | false, _ :: _ -> !state (* we got a pending result to deliver *) - | false, [] -> - let timeout = ref 60 in - let force = ref false in - Arg.parse_argv ~current:(ref 0) (Array.of_list args) - [ ( "-t" - , Arg.Set_int timeout - , "timeout in seconds to wait for active transactions to finish" - ) - ; ( "-F" - , Arg.Set force - , "force live update to happen even with running transactions after timeout elapsed" - ) - ] - (fun x -> raise (Arg.Bad x)) - "live-update -s" ; - debug "Live update process queued" ; - {!state with deadline = Unix.gettimeofday () +. float !timeout - ; force= !force; pending= true}) - | _ -> - invalid_arg ("Unknown arguments: " ^ String.concat "," args)) ; - match !state.pending, !state.result with - | true, _ -> Some "BUSY" - | false, (_ :: _ as result) -> - (* xenstore-control has read the result, clear it *) - state := { !state with result = [] }; - Some (String.concat "\n" result) - | false, [] -> None - with - | Arg.Bad s | Arg.Help s | Invalid_argument s -> - Some s - | Unix.Unix_error (e, fn, args) -> - Some (Printf.sprintf "%s(%s): %s" fn args (Unix.error_message e)) + let parse_live_update args = + try + (state := + match args with + | ["-f"; file] -> + validate_exn {!state with binary= file} + | ["-a"] -> + debug "Live update aborted" ; + {!state with pending= false; result = []} + | "-c" :: cmdline -> + validate_exn {!state with cmdline = !state.cmdline @ cmdline} + | "-s" :: _ -> + (match !state.pending, !state.result with + | true, _ -> !state (* no change to state, avoid resetting timeout *) + | false, _ :: _ -> !state (* we got a pending result to deliver *) + | false, [] -> + let timeout = ref 60 in + let force = ref false in + Arg.parse_argv ~current:(ref 0) (Array.of_list args) + [ ( "-t" + , Arg.Set_int timeout + , "timeout in seconds to wait for active transactions to finish" + ) + ; ( "-F" + , Arg.Set force + , "force live update to happen even with running transactions after timeout elapsed" + ) + ] + (fun x -> raise (Arg.Bad x)) + "live-update -s" ; + debug "Live update process queued" ; + {!state with deadline = Unix.gettimeofday () +. float !timeout + ; force= !force; pending= true}) + | _ -> + invalid_arg ("Unknown arguments: " ^ String.concat "," args)) ; + match !state.pending, !state.result with + | true, _ -> Some "BUSY" + | false, (_ :: _ as result) -> + (* xenstore-control has read the result, clear it *) + state := { !state with result = [] }; + Some (String.concat "\n" result) + | false, [] -> None + with + | Arg.Bad s | Arg.Help s | Invalid_argument s -> + Some s + | Unix.Unix_error (e, fn, args) -> + Some (Printf.sprintf "%s(%s): %s" fn args (Unix.error_message e)) - let should_run cons = - let t = !state in - if t.pending then begin - match Connections.prevents_quit cons with - | [] -> true - | _ when Unix.gettimeofday () < t.deadline -> false - | l -> - warn "timeout reached: have to wait, migrate or shutdown %d domains:" (List.length l); - let msgs = List.rev_map (fun con -> Printf.sprintf "%s: %d tx, out: %b, perm: %s" - (Connection.get_domstr con) - (Connection.number_of_transactions con) - (Connection.has_output con) - (Connection.get_perm con |> Perms.Connection.to_string) - ) l in - List.iter (warn "Live-update: %s") msgs; - if t.force then begin - warn "Live update forced, some domain connections may break!"; - true - end else begin - warn "Live update aborted (see above for domains preventing it)"; - state := { t with pending = false; result = msgs}; - false - end - end else false + let should_run cons = + let t = !state in + if t.pending then begin + match Connections.prevents_quit cons with + | [] -> true + | _ when Unix.gettimeofday () < t.deadline -> false + | l -> + warn "timeout reached: have to wait, migrate or shutdown %d domains:" (List.length l); + let msgs = List.rev_map (fun con -> Printf.sprintf "%s: %d tx, out: %b, perm: %s" + (Connection.get_domstr con) + (Connection.number_of_transactions con) + (Connection.has_output con) + (Connection.get_perm con |> Perms.Connection.to_string) + ) l in + List.iter (warn "Live-update: %s") msgs; + if t.force then begin + warn "Live update forced, some domain connections may break!"; + true + end else begin + warn "Live update aborted (see above for domains preventing it)"; + state := { t with pending = false; result = msgs}; + false + end + end else false - let completed () = - state := { !state with result = ["OK"] } + let completed () = + state := { !state with result = ["OK"] } end (* packets *) let do_debug con t _domains cons data = - if not (Connection.is_dom0 con) && not !allow_debug - then None - else try match split None '\000' data with - | "live-update" :: params -> - let dropped_trailing_nul = params |> List.rev |> List.tl |> List.rev in - LiveUpdate.parse_live_update dropped_trailing_nul - | "print" :: msg :: _ -> - Logging.xb_op ~tid:0 ~ty:Xenbus.Xb.Op.Debug ~con:"=======>" msg; - None - | "quota" :: domid :: _ -> - let domid = int_of_string domid in - let quota = (Store.get_quota t.Transaction.store) in - Some (Quota.to_string quota domid ^ "\000") - | "watches" :: _ -> - let watches = Connections.debug cons in - Some (watches ^ "\000") - | "xenbus" :: domid :: _ -> - let domid = int_of_string domid in - let con = Connections.find_domain cons domid in - let s = Printf.sprintf "xenbus: %s; overflow queue length: %d, can_input: %b, has_more_input: %b, has_old_output: %b, has_new_output: %b, has_more_work: %b. pending: %s" - (Xenbus.Xb.debug con.xb) - (Connection.source_pending_watchevents con) - (Connection.can_input con) - (Connection.has_more_input con) - (Connection.has_old_output con) - (Connection.has_new_output con) - (Connection.has_more_work con) - (Connections.debug_watchevents cons con) - in - Some s - | "mfn" :: domid :: _ -> - let domid = int_of_string domid in - let con = Connections.find_domain cons domid in - may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connection.get_domain con) - | _ -> None - with _ -> None + if not (Connection.is_dom0 con) && not !allow_debug + then None + else try match split None '\000' data with + | "live-update" :: params -> + let dropped_trailing_nul = params |> List.rev |> List.tl |> List.rev in + LiveUpdate.parse_live_update dropped_trailing_nul + | "print" :: msg :: _ -> + Logging.xb_op ~tid:0 ~ty:Xenbus.Xb.Op.Debug ~con:"=======>" msg; + None + | "quota" :: domid :: _ -> + let domid = int_of_string domid in + let quota = (Store.get_quota t.Transaction.store) in + Some (Quota.to_string quota domid ^ "\000") + | "watches" :: _ -> + let watches = Connections.debug cons in + Some (watches ^ "\000") + | "xenbus" :: domid :: _ -> + let domid = int_of_string domid in + let con = Connections.find_domain cons domid in + let s = Printf.sprintf "xenbus: %s; overflow queue length: %d, can_input: %b, has_more_input: %b, has_old_output: %b, has_new_output: %b, has_more_work: %b. pending: %s" + (Xenbus.Xb.debug con.xb) + (Connection.source_pending_watchevents con) + (Connection.can_input con) + (Connection.has_more_input con) + (Connection.has_old_output con) + (Connection.has_new_output con) + (Connection.has_more_work con) + (Connections.debug_watchevents cons con) + in + Some s + | "mfn" :: domid :: _ -> + let domid = int_of_string domid in + let con = Connections.find_domain cons domid in + may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connection.get_domain con) + | _ -> None + with _ -> None let do_directory con t _domains _cons data = - let path = split_one_path data con in - let entries = Transaction.ls t (Connection.get_perm con) path in - if List.length entries > 0 then - (Utils.join_by_null entries) ^ "\000" - else - "" + let path = split_one_path data con in + let entries = Transaction.ls t (Connection.get_perm con) path in + if List.length entries > 0 then + (Utils.join_by_null entries) ^ "\000" + else + "" let do_read con t _domains _cons data = - let path = split_one_path data con in - Transaction.read t (Connection.get_perm con) path + let path = split_one_path data con in + Transaction.read t (Connection.get_perm con) path let do_getperms con t _domains _cons data = - let path = split_one_path data con in - let perms = Transaction.getperms t (Connection.get_perm con) path in - Perms.Node.to_string perms ^ "\000" + let path = split_one_path data con in + let perms = Transaction.getperms t (Connection.get_perm con) path in + Perms.Node.to_string perms ^ "\000" let do_getdomainpath _con _t _domains _cons data = - let domid = - match (split None '\000' data) with - | domid :: "" :: [] -> c_int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - sprintf "/local/domain/%u\000" domid + let domid = + match (split None '\000' data) with + | domid :: "" :: [] -> c_int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + sprintf "/local/domain/%u\000" domid let do_write con t _domains _cons data = - let path, value = - match (split (Some 2) '\000' data) with - | path :: value :: [] -> Store.Path.create path (Connection.get_path con), value - | _ -> raise Invalid_Cmd_Args - in - create_implicit_path t (Connection.get_perm con) path; - Transaction.write t (Connection.get_perm con) path value + let path, value = + match (split (Some 2) '\000' data) with + | path :: value :: [] -> Store.Path.create path (Connection.get_path con), value + | _ -> raise Invalid_Cmd_Args + in + create_implicit_path t (Connection.get_perm con) path; + Transaction.write t (Connection.get_perm con) path value let do_mkdir con t _domains _cons data = - let path = split_one_path data con in - create_implicit_path t (Connection.get_perm con) path; - try - Transaction.mkdir t (Connection.get_perm con) path - with - Define.Already_exist -> () + let path = split_one_path data con in + create_implicit_path t (Connection.get_perm con) path; + try + Transaction.mkdir t (Connection.get_perm con) path + with + Define.Already_exist -> () let do_rm con t _domains _cons data = - let path = split_one_path data con in - try - Transaction.rm t (Connection.get_perm con) path - with - Define.Doesnt_exist -> () + let path = split_one_path data con in + try + Transaction.rm t (Connection.get_perm con) path + with + Define.Doesnt_exist -> () let do_setperms con t _domains _cons data = - let path, perms = - match (split (Some 2) '\000' data) with - | path :: perms :: _ -> - Store.Path.create path (Connection.get_path con), - (Perms.Node.of_string perms) - | _ -> raise Invalid_Cmd_Args - in - Transaction.setperms t (Connection.get_perm con) path perms + let path, perms = + match (split (Some 2) '\000' data) with + | path :: perms :: _ -> + Store.Path.create path (Connection.get_path con), + (Perms.Node.of_string perms) + | _ -> raise Invalid_Cmd_Args + in + Transaction.setperms t (Connection.get_perm con) path perms let do_error _con _t _domains _cons _data = - raise Define.Unknown_operation + raise Define.Unknown_operation let do_isintroduced con _t domains _cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid = - match (split None '\000' data) with - | domid :: _ -> int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - if domid = Define.domid_self || Domains.exist domains domid then "T\000" else "F\000" + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let domid = + match (split None '\000' data) with + | domid :: _ -> int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + if domid = Define.domid_self || Domains.exist domains domid then "T\000" else "F\000" (* only in xen >= 4.2 *) let do_reset_watches con _t _domains cons _data = @@ -335,432 +335,432 @@ let do_reset_watches con _t _domains cons _data = (* only in >= xen3.3 *) let do_set_target con _t _domains cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - match split None '\000' data with - | [ domid; target_domid; "" ] -> Connections.set_target cons (c_int_of_string domid) (c_int_of_string target_domid) - | _ -> raise Invalid_Cmd_Args + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + match split None '\000' data with + | [ domid; target_domid; "" ] -> Connections.set_target cons (c_int_of_string domid) (c_int_of_string target_domid) + | _ -> raise Invalid_Cmd_Args (*------------- Generic handling of ty ------------------*) let send_response ty con t rid response = - match response with - | Packet.Ack f -> - Connection.send_ack con (Transaction.get_id t) rid ty; - (* Now do any necessary follow-up actions *) - f () - | Packet.Reply ret -> - Connection.send_reply con (Transaction.get_id t) rid ty ret - | Packet.Error e -> - Connection.send_error con (Transaction.get_id t) rid e + match response with + | Packet.Ack f -> + Connection.send_ack con (Transaction.get_id t) rid ty; + (* Now do any necessary follow-up actions *) + f () + | Packet.Reply ret -> + Connection.send_reply con (Transaction.get_id t) rid ty ret + | Packet.Error e -> + Connection.send_error con (Transaction.get_id t) rid e let reply_ack fct con t doms cons data = - fct con t doms cons data; - Packet.Ack (fun () -> - if Transaction.get_id t = Transaction.none then - process_watch con t cons - ) + fct con t doms cons data; + Packet.Ack (fun () -> + if Transaction.get_id t = Transaction.none then + process_watch con t cons + ) let reply_data fct con t doms cons data = - let ret = fct con t doms cons data in - Packet.Reply ret + let ret = fct con t doms cons data in + Packet.Reply ret let reply_data_or_ack fct con t doms cons data = - match fct con t doms cons data with - | Some ret -> Packet.Reply ret - | None -> Packet.Ack (fun () -> ()) + match fct con t doms cons data with + | Some ret -> Packet.Reply ret + | None -> Packet.Ack (fun () -> ()) let reply_none fct con t doms cons data = - (* let the function reply *) - fct con t doms cons data + (* let the function reply *) + fct con t doms cons data (* Functions for 'simple' operations that cannot be part of a transaction *) let function_of_type_simple_op ty = - match ty with - | Xenbus.Xb.Op.Debug - | Xenbus.Xb.Op.Watch - | Xenbus.Xb.Op.Unwatch - | Xenbus.Xb.Op.Transaction_start - | Xenbus.Xb.Op.Transaction_end - | Xenbus.Xb.Op.Introduce - | Xenbus.Xb.Op.Release - | Xenbus.Xb.Op.Isintroduced - | Xenbus.Xb.Op.Resume - | Xenbus.Xb.Op.Set_target - | Xenbus.Xb.Op.Reset_watches - | Xenbus.Xb.Op.Invalid -> error "called function_of_type_simple_op on operation %s" (Xenbus.Xb.Op.to_string ty); - raise (Invalid_argument (Xenbus.Xb.Op.to_string ty)) - | Xenbus.Xb.Op.Directory -> reply_data do_directory - | Xenbus.Xb.Op.Read -> reply_data do_read - | Xenbus.Xb.Op.Getperms -> reply_data do_getperms - | Xenbus.Xb.Op.Getdomainpath -> reply_data do_getdomainpath - | Xenbus.Xb.Op.Write -> reply_ack do_write - | Xenbus.Xb.Op.Mkdir -> reply_ack do_mkdir - | Xenbus.Xb.Op.Rm -> reply_ack do_rm - | Xenbus.Xb.Op.Setperms -> reply_ack do_setperms - | _ -> reply_ack do_error + match ty with + | Xenbus.Xb.Op.Debug + | Xenbus.Xb.Op.Watch + | Xenbus.Xb.Op.Unwatch + | Xenbus.Xb.Op.Transaction_start + | Xenbus.Xb.Op.Transaction_end + | Xenbus.Xb.Op.Introduce + | Xenbus.Xb.Op.Release + | Xenbus.Xb.Op.Isintroduced + | Xenbus.Xb.Op.Resume + | Xenbus.Xb.Op.Set_target + | Xenbus.Xb.Op.Reset_watches + | Xenbus.Xb.Op.Invalid -> error "called function_of_type_simple_op on operation %s" (Xenbus.Xb.Op.to_string ty); + raise (Invalid_argument (Xenbus.Xb.Op.to_string ty)) + | Xenbus.Xb.Op.Directory -> reply_data do_directory + | Xenbus.Xb.Op.Read -> reply_data do_read + | Xenbus.Xb.Op.Getperms -> reply_data do_getperms + | Xenbus.Xb.Op.Getdomainpath -> reply_data do_getdomainpath + | Xenbus.Xb.Op.Write -> reply_ack do_write + | Xenbus.Xb.Op.Mkdir -> reply_ack do_mkdir + | Xenbus.Xb.Op.Rm -> reply_ack do_rm + | Xenbus.Xb.Op.Setperms -> reply_ack do_setperms + | _ -> reply_ack do_error let input_handle_error ~cons ~doms ~fct ~con ~t ~req = - let reply_error e = - Packet.Error e in - try - Transaction.check_quota_exn ~perm:(Connection.get_perm con) t; - fct con t doms cons req.Packet.data - with - | Define.Invalid_path -> reply_error "EINVAL" - | Define.Already_exist -> reply_error "EEXIST" - | Define.Doesnt_exist -> reply_error "ENOENT" - | Define.Lookup_Doesnt_exist _ -> reply_error "ENOENT" - | Define.Permission_denied -> reply_error "EACCES" - | Not_found -> reply_error "ENOENT" - | Invalid_Cmd_Args -> reply_error "EINVAL" - | Invalid_argument _ -> reply_error "EINVAL" - | Transaction_again -> reply_error "EAGAIN" - | Transaction_nested -> reply_error "EBUSY" - | Domain_not_match -> reply_error "EINVAL" - | Quota.Limit_reached -> reply_error "EQUOTA" - | Quota.Data_too_big -> reply_error "E2BIG" - | Quota.Transaction_opened -> reply_error "EQUOTA" - | (Failure "int_of_string") -> reply_error "EINVAL" - | Define.Unknown_operation -> reply_error "ENOSYS" + let reply_error e = + Packet.Error e in + try + Transaction.check_quota_exn ~perm:(Connection.get_perm con) t; + fct con t doms cons req.Packet.data + with + | Define.Invalid_path -> reply_error "EINVAL" + | Define.Already_exist -> reply_error "EEXIST" + | Define.Doesnt_exist -> reply_error "ENOENT" + | Define.Lookup_Doesnt_exist _ -> reply_error "ENOENT" + | Define.Permission_denied -> reply_error "EACCES" + | Not_found -> reply_error "ENOENT" + | Invalid_Cmd_Args -> reply_error "EINVAL" + | Invalid_argument _ -> reply_error "EINVAL" + | Transaction_again -> reply_error "EAGAIN" + | Transaction_nested -> reply_error "EBUSY" + | Domain_not_match -> reply_error "EINVAL" + | Quota.Limit_reached -> reply_error "EQUOTA" + | Quota.Data_too_big -> reply_error "E2BIG" + | Quota.Transaction_opened -> reply_error "EQUOTA" + | (Failure "int_of_string") -> reply_error "EINVAL" + | Define.Unknown_operation -> reply_error "ENOSYS" let write_access_log ~ty ~tid ~con ~data = - Logging.xb_op ~ty ~tid ~con data + Logging.xb_op ~ty ~tid ~con data let write_answer_log ~ty ~tid ~con ~data = - Logging.xb_answer ~ty ~tid ~con data + Logging.xb_answer ~ty ~tid ~con data let write_response_log ~ty ~tid ~con ~response = - match response with - | Packet.Ack _ -> write_answer_log ~ty ~tid ~con ~data:"" - | Packet.Reply x -> write_answer_log ~ty ~tid ~con ~data:x - | Packet.Error e -> write_answer_log ~ty:(Xenbus.Xb.Op.Error) ~tid ~con ~data:e + match response with + | Packet.Ack _ -> write_answer_log ~ty ~tid ~con ~data:"" + | Packet.Reply x -> write_answer_log ~ty ~tid ~con ~data:x + | Packet.Error e -> write_answer_log ~ty:(Xenbus.Xb.Op.Error) ~tid ~con ~data:e let record_commit ~con ~tid ~before ~after = - let inc r = r := Int64.add 1L !r in - let finish_count = inc Transaction.counter; !Transaction.counter in - History.push {History.con=con; tid=tid; before=before; after=after; finish_count=finish_count} + let inc r = r := Int64.add 1L !r in + let finish_count = inc Transaction.counter; !Transaction.counter in + History.push {History.con=con; tid=tid; before=before; after=after; finish_count=finish_count} (* Replay a stored transaction against a fresh store, check the responses are all equivalent: if so, commit the transaction. Otherwise send the abort to the client. *) let transaction_replay c t doms cons = - match t.Transaction.ty with - | Transaction.No -> - error "attempted to replay a non-full transaction"; - false - | Transaction.Full(id, _oldstore, cstore) -> - let tid = Connection.start_transaction c cstore in - let replay_t = Transaction.make ~internal:true tid cstore in - let con = sprintf "r(%d):%s" id (Connection.get_domstr c) in + match t.Transaction.ty with + | Transaction.No -> + error "attempted to replay a non-full transaction"; + false + | Transaction.Full(id, _oldstore, cstore) -> + let tid = Connection.start_transaction c cstore in + let replay_t = Transaction.make ~internal:true tid cstore in + let con = sprintf "r(%d):%s" id (Connection.get_domstr c) in - let perform_exn ~wlog txn (request, response) = - if wlog then write_access_log ~ty:request.Packet.ty ~tid ~con ~data:request.Packet.data; - let fct = function_of_type_simple_op request.Packet.ty in - let response' = input_handle_error ~cons ~doms ~fct ~con:c ~t:txn ~req:request in - if wlog then write_response_log ~ty:request.Packet.ty ~tid ~con ~response:response'; - if not(Packet.response_equal response response') then raise Transaction_again - in - finally - (fun () -> - try - Logging.start_transaction ~con ~tid; - List.iter (perform_exn ~wlog:true replay_t) (Transaction.get_operations t); (* May throw EAGAIN *) + let perform_exn ~wlog txn (request, response) = + if wlog then write_access_log ~ty:request.Packet.ty ~tid ~con ~data:request.Packet.data; + let fct = function_of_type_simple_op request.Packet.ty in + let response' = input_handle_error ~cons ~doms ~fct ~con:c ~t:txn ~req:request in + if wlog then write_response_log ~ty:request.Packet.ty ~tid ~con ~response:response'; + if not(Packet.response_equal response response') then raise Transaction_again + in + finally + (fun () -> + try + Logging.start_transaction ~con ~tid; + List.iter (perform_exn ~wlog:true replay_t) (Transaction.get_operations t); (* May throw EAGAIN *) - Logging.end_transaction ~con ~tid; - Transaction.commit ~con replay_t - with - | Transaction_again -> ( - Transaction.failed_commits := Int64.add !Transaction.failed_commits 1L; - let victim_domstr = Connection.get_domstr c in - debug "Apportioning blame for EAGAIN in txn %d, domain=%s" id victim_domstr; - let punish guilty_con = - debug "Blaming domain %s for conflict with domain %s txn %d" - (Connection.get_domstr guilty_con) victim_domstr id; - Connection.decr_conflict_credit doms guilty_con - in - let judge_and_sentence hist_rec = ( - let can_apply_on store = ( - let store = Store.copy store in - let trial_t = Transaction.make ~internal:true Transaction.none store in - try List.iter (perform_exn ~wlog:false trial_t) (Transaction.get_operations t); - true - with Transaction_again -> false - ) in - if can_apply_on hist_rec.History.before - && not (can_apply_on hist_rec.History.after) - then (punish hist_rec.History.con; true) - else false - ) in - let guilty_cons = History.filter_connections ~ignore:c ~since:t.Transaction.start_count ~f:judge_and_sentence in - if Hashtbl.length guilty_cons = 0 then ( - debug "Found no culprit for conflict in %s: must be self or not in history." con; - Transaction.failed_commits_no_culprit := Int64.add !Transaction.failed_commits_no_culprit 1L - ); - false - ) - | e -> - info "transaction_replay %d caught: %s" tid (Printexc.to_string e); - false - ) - (fun () -> - ignore @@ Connection.end_transaction c tid None - ) + Logging.end_transaction ~con ~tid; + Transaction.commit ~con replay_t + with + | Transaction_again -> ( + Transaction.failed_commits := Int64.add !Transaction.failed_commits 1L; + let victim_domstr = Connection.get_domstr c in + debug "Apportioning blame for EAGAIN in txn %d, domain=%s" id victim_domstr; + let punish guilty_con = + debug "Blaming domain %s for conflict with domain %s txn %d" + (Connection.get_domstr guilty_con) victim_domstr id; + Connection.decr_conflict_credit doms guilty_con + in + let judge_and_sentence hist_rec = ( + let can_apply_on store = ( + let store = Store.copy store in + let trial_t = Transaction.make ~internal:true Transaction.none store in + try List.iter (perform_exn ~wlog:false trial_t) (Transaction.get_operations t); + true + with Transaction_again -> false + ) in + if can_apply_on hist_rec.History.before + && not (can_apply_on hist_rec.History.after) + then (punish hist_rec.History.con; true) + else false + ) in + let guilty_cons = History.filter_connections ~ignore:c ~since:t.Transaction.start_count ~f:judge_and_sentence in + if Hashtbl.length guilty_cons = 0 then ( + debug "Found no culprit for conflict in %s: must be self or not in history." con; + Transaction.failed_commits_no_culprit := Int64.add !Transaction.failed_commits_no_culprit 1L + ); + false + ) + | e -> + info "transaction_replay %d caught: %s" tid (Printexc.to_string e); + false + ) + (fun () -> + ignore @@ Connection.end_transaction c tid None + ) let do_watch con _t _domains cons data = - let (node, token) = - match (split None '\000' data) with - | [node; token; ""] -> node, token - | _ -> raise Invalid_Cmd_Args - in - let watch = Connections.add_watch cons con node token in - Packet.Ack (fun () -> - (* xenstore.txt says this watch is fired immediately, - implying even if path doesn't exist or is unreadable *) - Connection.fire_single_watch_unchecked con watch) + let (node, token) = + match (split None '\000' data) with + | [node; token; ""] -> node, token + | _ -> raise Invalid_Cmd_Args + in + let watch = Connections.add_watch cons con node token in + Packet.Ack (fun () -> + (* xenstore.txt says this watch is fired immediately, + implying even if path doesn't exist or is unreadable *) + Connection.fire_single_watch_unchecked con watch) let do_unwatch con _t _domains cons data = - let (node, token) = - match (split None '\000' data) with - | [node; token; ""] -> node, token - | _ -> raise Invalid_Cmd_Args - in - ignore @@ Connections.del_watch cons con node token + let (node, token) = + match (split None '\000' data) with + | [node; token; ""] -> node, token + | _ -> raise Invalid_Cmd_Args + in + ignore @@ Connections.del_watch cons con node token let do_transaction_start con t _domains _cons _data = - if Transaction.get_id t <> Transaction.none then - raise Transaction_nested; - let store = Transaction.get_store t in - string_of_int (Connection.start_transaction con store) ^ "\000" + if Transaction.get_id t <> Transaction.none then + raise Transaction_nested; + let store = Transaction.get_store t in + string_of_int (Connection.start_transaction con store) ^ "\000" let do_transaction_end con t domains cons data = - let commit = - match (split None '\000' data) with - | "T" :: _ -> true - | "F" :: _ -> false - | x :: _ -> raise (Invalid_argument x) - | _ -> raise Invalid_Cmd_Args - in - let commit = commit && not (Transaction.is_read_only t) in - let success = - let commit = if commit then Some (fun con trans -> transaction_replay con trans domains cons) else None in - History.end_transaction t con (Transaction.get_id t) commit in - if not success then - raise Transaction_again; - if commit then begin - process_watch con t cons; - match t.Transaction.ty with - | Transaction.No -> - () (* no need to record anything *) - | Transaction.Full(id, oldstore, cstore) -> - record_commit ~con ~tid:id ~before:oldstore ~after:cstore - end + let commit = + match (split None '\000' data) with + | "T" :: _ -> true + | "F" :: _ -> false + | x :: _ -> raise (Invalid_argument x) + | _ -> raise Invalid_Cmd_Args + in + let commit = commit && not (Transaction.is_read_only t) in + let success = + let commit = if commit then Some (fun con trans -> transaction_replay con trans domains cons) else None in + History.end_transaction t con (Transaction.get_id t) commit in + if not success then + raise Transaction_again; + if commit then begin + process_watch con t cons; + match t.Transaction.ty with + | Transaction.No -> + () (* no need to record anything *) + | Transaction.Full(id, oldstore, cstore) -> + record_commit ~con ~tid:id ~before:oldstore ~after:cstore + end let do_introduce con t domains cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let (domid, mfn, port) = - match (split None '\000' data) with - | domid :: mfn :: port :: _ -> - int_of_string domid, Nativeint.of_string mfn, int_of_string port - | _ -> raise Invalid_Cmd_Args; - in - let dom = - if Domains.exist domains domid then - let edom = Domains.find domains domid in - if (Domain.get_mfn edom) = mfn && (Connections.find_domain cons domid) != con then begin - (* Use XS_INTRODUCE for recreating the xenbus event-channel. *) - edom.remote_port <- port; - Domain.bind_interdomain edom; - end; - edom - else try - let ndom = Domains.create domains domid mfn port in - Connections.add_domain cons ndom; - Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.introduce_domain; - ndom - with _ -> raise Invalid_Cmd_Args - in - if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn then - raise Domain_not_match + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let (domid, mfn, port) = + match (split None '\000' data) with + | domid :: mfn :: port :: _ -> + int_of_string domid, Nativeint.of_string mfn, int_of_string port + | _ -> raise Invalid_Cmd_Args; + in + let dom = + if Domains.exist domains domid then + let edom = Domains.find domains domid in + if (Domain.get_mfn edom) = mfn && (Connections.find_domain cons domid) != con then begin + (* Use XS_INTRODUCE for recreating the xenbus event-channel. *) + edom.remote_port <- port; + Domain.bind_interdomain edom; + end; + edom + else try + let ndom = Domains.create domains domid mfn port in + Connections.add_domain cons ndom; + Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.introduce_domain; + ndom + with _ -> raise Invalid_Cmd_Args + in + if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn then + raise Domain_not_match let do_release con t domains cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid = - match (split None '\000' data) with - | [domid;""] -> int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - let fire_spec_watches = Domains.exist domains domid in - Domains.del domains domid; - Connections.del_domain cons domid; - Store.reset_permissions (Transaction.get_store t) domid; - if fire_spec_watches - then Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.release_domain - else raise Invalid_Cmd_Args + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let domid = + match (split None '\000' data) with + | [domid;""] -> int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + let fire_spec_watches = Domains.exist domains domid in + Domains.del domains domid; + Connections.del_domain cons domid; + Store.reset_permissions (Transaction.get_store t) domid; + if fire_spec_watches + then Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.release_domain + else raise Invalid_Cmd_Args let do_resume con _t domains _cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid = - match (split None '\000' data) with - | domid :: _ -> int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - if Domains.exist domains domid - then Domains.resume domains domid - else raise Invalid_Cmd_Args + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let domid = + match (split None '\000' data) with + | domid :: _ -> int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + if Domains.exist domains domid + then Domains.resume domains domid + else raise Invalid_Cmd_Args let function_of_type ty = - match ty with - | Xenbus.Xb.Op.Debug -> reply_data_or_ack do_debug - | Xenbus.Xb.Op.Watch -> reply_none do_watch - | Xenbus.Xb.Op.Unwatch -> reply_ack do_unwatch - | Xenbus.Xb.Op.Transaction_start -> reply_data do_transaction_start - | Xenbus.Xb.Op.Transaction_end -> reply_ack do_transaction_end - | Xenbus.Xb.Op.Introduce -> reply_ack do_introduce - | Xenbus.Xb.Op.Release -> reply_ack do_release - | Xenbus.Xb.Op.Isintroduced -> reply_data do_isintroduced - | Xenbus.Xb.Op.Resume -> reply_ack do_resume - | Xenbus.Xb.Op.Set_target -> reply_ack do_set_target - | Xenbus.Xb.Op.Reset_watches -> reply_ack do_reset_watches - | Xenbus.Xb.Op.Invalid -> reply_ack do_error - | _ -> function_of_type_simple_op ty + match ty with + | Xenbus.Xb.Op.Debug -> reply_data_or_ack do_debug + | Xenbus.Xb.Op.Watch -> reply_none do_watch + | Xenbus.Xb.Op.Unwatch -> reply_ack do_unwatch + | Xenbus.Xb.Op.Transaction_start -> reply_data do_transaction_start + | Xenbus.Xb.Op.Transaction_end -> reply_ack do_transaction_end + | Xenbus.Xb.Op.Introduce -> reply_ack do_introduce + | Xenbus.Xb.Op.Release -> reply_ack do_release + | Xenbus.Xb.Op.Isintroduced -> reply_data do_isintroduced + | Xenbus.Xb.Op.Resume -> reply_ack do_resume + | Xenbus.Xb.Op.Set_target -> reply_ack do_set_target + | Xenbus.Xb.Op.Reset_watches -> reply_ack do_reset_watches + | Xenbus.Xb.Op.Invalid -> reply_ack do_error + | _ -> function_of_type_simple_op ty (** * Determines which individual (non-transactional) operations we want to retain. * We only want to retain operations that have side-effects in the store since * these can be the cause of transactions failing. - *) +*) let retain_op_in_history ty = - match ty with - | Xenbus.Xb.Op.Write - | Xenbus.Xb.Op.Mkdir - | Xenbus.Xb.Op.Rm - | Xenbus.Xb.Op.Setperms -> true - | Xenbus.Xb.Op.Debug - | Xenbus.Xb.Op.Directory - | Xenbus.Xb.Op.Read - | Xenbus.Xb.Op.Getperms - | Xenbus.Xb.Op.Watch - | Xenbus.Xb.Op.Unwatch - | Xenbus.Xb.Op.Transaction_start - | Xenbus.Xb.Op.Transaction_end - | Xenbus.Xb.Op.Introduce - | Xenbus.Xb.Op.Release - | Xenbus.Xb.Op.Getdomainpath - | Xenbus.Xb.Op.Watchevent - | Xenbus.Xb.Op.Error - | Xenbus.Xb.Op.Isintroduced - | Xenbus.Xb.Op.Resume - | Xenbus.Xb.Op.Set_target - | Xenbus.Xb.Op.Reset_watches - | Xenbus.Xb.Op.Invalid -> false + match ty with + | Xenbus.Xb.Op.Write + | Xenbus.Xb.Op.Mkdir + | Xenbus.Xb.Op.Rm + | Xenbus.Xb.Op.Setperms -> true + | Xenbus.Xb.Op.Debug + | Xenbus.Xb.Op.Directory + | Xenbus.Xb.Op.Read + | Xenbus.Xb.Op.Getperms + | Xenbus.Xb.Op.Watch + | Xenbus.Xb.Op.Unwatch + | Xenbus.Xb.Op.Transaction_start + | Xenbus.Xb.Op.Transaction_end + | Xenbus.Xb.Op.Introduce + | Xenbus.Xb.Op.Release + | Xenbus.Xb.Op.Getdomainpath + | Xenbus.Xb.Op.Watchevent + | Xenbus.Xb.Op.Error + | Xenbus.Xb.Op.Isintroduced + | Xenbus.Xb.Op.Resume + | Xenbus.Xb.Op.Set_target + | Xenbus.Xb.Op.Reset_watches + | Xenbus.Xb.Op.Invalid -> false let maybe_ignore_transaction = function - | Xenbus.Xb.Op.Watch | Xenbus.Xb.Op.Unwatch -> fun tid -> - if tid <> Transaction.none then - debug "Ignoring transaction ID %d for watch/unwatch" tid; - Transaction.none - | _ -> fun x -> x + | Xenbus.Xb.Op.Watch | Xenbus.Xb.Op.Unwatch -> fun tid -> + if tid <> Transaction.none then + debug "Ignoring transaction ID %d for watch/unwatch" tid; + Transaction.none + | _ -> fun x -> x let () = Printexc.record_backtrace true (** * Nothrow guarantee. - *) +*) let process_packet ~store ~cons ~doms ~con ~req = - let ty = req.Packet.ty in - let tid = maybe_ignore_transaction ty req.Packet.tid in - let rid = req.Packet.rid in - try - let fct = function_of_type ty in - let t = - if tid = Transaction.none then - Transaction.make tid store - else - Connection.get_transaction con tid - in + let ty = req.Packet.ty in + let tid = maybe_ignore_transaction ty req.Packet.tid in + let rid = req.Packet.rid in + try + let fct = function_of_type ty in + let t = + if tid = Transaction.none then + Transaction.make tid store + else + Connection.get_transaction con tid + in - let execute () = input_handle_error ~cons ~doms ~fct ~con ~t ~req in + let execute () = input_handle_error ~cons ~doms ~fct ~con ~t ~req in - let response = - (* Note that transactions are recorded in history separately. *) - if tid = Transaction.none && retain_op_in_history ty then begin - let before = Store.copy store in - let response = execute () in - let after = Store.copy store in - record_commit ~con ~tid ~before ~after; - response - end else execute () - in + let response = + (* Note that transactions are recorded in history separately. *) + if tid = Transaction.none && retain_op_in_history ty then begin + let before = Store.copy store in + let response = execute () in + let after = Store.copy store in + record_commit ~con ~tid ~before ~after; + response + end else execute () + in - let response = try - Transaction.check_quota_exn ~perm:(Connection.get_perm con) t; - if tid <> Transaction.none then - (* Remember the request and response for this operation in case we need to replay the transaction *) - Transaction.add_operation t req response; - response - with Quota.Limit_reached -> - Packet.Error "EQUOTA" - in + let response = try + Transaction.check_quota_exn ~perm:(Connection.get_perm con) t; + if tid <> Transaction.none then + (* Remember the request and response for this operation in case we need to replay the transaction *) + Transaction.add_operation t req response; + response + with Quota.Limit_reached -> + Packet.Error "EQUOTA" + in - (* Put the response on the wire *) - send_response ty con t rid response - with exn -> - let bt = Printexc.get_backtrace () in - error "process packet: %s. %s" (Printexc.to_string exn) bt; - Connection.send_error con tid rid "EIO" + (* Put the response on the wire *) + send_response ty con t rid response + with exn -> + let bt = Printexc.get_backtrace () in + error "process packet: %s. %s" (Printexc.to_string exn) bt; + Connection.send_error con tid rid "EIO" let do_input store cons doms con = - let newpacket = - try - if Connection.can_input con then Connection.do_input con - else None - with Xenbus.Xb.Reconnect -> - info "%s requests a reconnect" (Connection.get_domstr con); - History.reconnect con; - info "%s reconnection complete" (Connection.get_domstr con); - None - | Invalid_argument exp | Failure exp -> - error "caught exception %s" exp; - error "got a bad client %s" (sprintf "%-8s" (Connection.get_domstr con)); - Connection.mark_as_bad con; - None - in + let newpacket = + try + if Connection.can_input con then Connection.do_input con + else None + with Xenbus.Xb.Reconnect -> + info "%s requests a reconnect" (Connection.get_domstr con); + History.reconnect con; + info "%s reconnection complete" (Connection.get_domstr con); + None + | Invalid_argument exp | Failure exp -> + error "caught exception %s" exp; + error "got a bad client %s" (sprintf "%-8s" (Connection.get_domstr con)); + Connection.mark_as_bad con; + None + in - match newpacket with - | None -> () - | Some packet -> - let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in - let req = {Packet.tid=tid; Packet.rid=rid; Packet.ty=ty; Packet.data=data} in + match newpacket with + | None -> () + | Some packet -> + let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in + let req = {Packet.tid=tid; Packet.rid=rid; Packet.ty=ty; Packet.data=data} in - (* As we don't log IO, do not call an unnecessary sanitize_data - info "[%s] -> [%d] %s \"%s\"" - (Connection.get_domstr con) tid - (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *) - process_packet ~store ~cons ~doms ~con ~req; - write_access_log ~ty ~tid ~con:(Connection.get_domstr con) ~data; - Connection.incr_ops con + (* As we don't log IO, do not call an unnecessary sanitize_data + info "[%s] -> [%d] %s \"%s\"" + (Connection.get_domstr con) tid + (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *) + process_packet ~store ~cons ~doms ~con ~req; + write_access_log ~ty ~tid ~con:(Connection.get_domstr con) ~data; + Connection.incr_ops con let do_output _store _cons _doms con = - Connection.source_flush_watchevents con; - if Connection.has_output con then ( - if Connection.has_new_output con then ( - let packet = Connection.peek_output con in - let tid, _rid, ty, data = Xenbus.Xb.Packet.unpack packet in - (* As we don't log IO, do not call an unnecessary sanitize_data - info "[%s] <- %s \"%s\"" - (Connection.get_domstr con) - (Xenbus.Xb.Op.to_string ty) (sanitize_data data);*) - write_answer_log ~ty ~tid ~con:(Connection.get_domstr con) ~data; - ); - try - ignore (Connection.do_output con) - with Xenbus.Xb.Reconnect -> - info "%s requests a reconnect" (Connection.get_domstr con); - History.reconnect con; - info "%s reconnection complete" (Connection.get_domstr con) - ) + Connection.source_flush_watchevents con; + if Connection.has_output con then ( + if Connection.has_new_output con then ( + let packet = Connection.peek_output con in + let tid, _rid, ty, data = Xenbus.Xb.Packet.unpack packet in + (* As we don't log IO, do not call an unnecessary sanitize_data + info "[%s] <- %s \"%s\"" + (Connection.get_domstr con) + (Xenbus.Xb.Op.to_string ty) (sanitize_data data);*) + write_answer_log ~ty ~tid ~con:(Connection.get_domstr con) ~data; + ); + try + ignore (Connection.do_output con) + with Xenbus.Xb.Reconnect -> + info "%s requests a reconnect" (Connection.get_domstr con); + History.reconnect con; + info "%s reconnection complete" (Connection.get_domstr con) + ) diff --git a/tools/ocaml/xenstored/quota.ml b/tools/ocaml/xenstored/quota.ml index 6e3d6401ae..300d78a50b 100644 --- a/tools/ocaml/xenstored/quota.ml +++ b/tools/ocaml/xenstored/quota.ml @@ -24,65 +24,65 @@ let maxent = ref (1000) let maxsize = ref (2048) type t = { - maxent: int; (* max entities per domU *) - maxsize: int; (* max size of data store in one node *) - cur: (Xenctrl.domid, int) Hashtbl.t; (* current domains quota *) + maxent: int; (* max entities per domU *) + maxsize: int; (* max size of data store in one node *) + cur: (Xenctrl.domid, int) Hashtbl.t; (* current domains quota *) } let to_string quota domid = - if Hashtbl.mem quota.cur domid - then Printf.sprintf "dom%i quota: %i/%i" domid (Hashtbl.find quota.cur domid) quota.maxent - else Printf.sprintf "dom%i quota: not set" domid + if Hashtbl.mem quota.cur domid + then Printf.sprintf "dom%i quota: %i/%i" domid (Hashtbl.find quota.cur domid) quota.maxent + else Printf.sprintf "dom%i quota: not set" domid let create () = - { maxent = !maxent; maxsize = !maxsize; cur = Hashtbl.create 100; } + { maxent = !maxent; maxsize = !maxsize; cur = Hashtbl.create 100; } let copy quota = { quota with cur = (Hashtbl.copy quota.cur) } let del quota id = Hashtbl.remove quota.cur id let _check quota id size = - if size > quota.maxsize then ( - warn "domain %u err create entry: data too big %d" id size; - raise Data_too_big - ); - if id > 0 && Hashtbl.mem quota.cur id then - let entry = Hashtbl.find quota.cur id in - if entry >= quota.maxent then ( - warn "domain %u cannot create entry: quota reached" id; - raise Limit_reached - ) + if size > quota.maxsize then ( + warn "domain %u err create entry: data too big %d" id size; + raise Data_too_big + ); + if id > 0 && Hashtbl.mem quota.cur id then + let entry = Hashtbl.find quota.cur id in + if entry >= quota.maxent then ( + warn "domain %u cannot create entry: quota reached" id; + raise Limit_reached + ) let check quota id size = - if !activate then - _check quota id size + if !activate then + _check quota id size let get_entry quota id = Hashtbl.find quota.cur id let set_entry quota id nb = - if nb = 0 - then Hashtbl.remove quota.cur id - else begin - if Hashtbl.mem quota.cur id then - Hashtbl.replace quota.cur id nb - else - Hashtbl.add quota.cur id nb - end + if nb = 0 + then Hashtbl.remove quota.cur id + else begin + if Hashtbl.mem quota.cur id then + Hashtbl.replace quota.cur id nb + else + Hashtbl.add quota.cur id nb + end let del_entry quota id = - try - let nb = get_entry quota id in - set_entry quota id (nb - 1) - with Not_found -> () + try + let nb = get_entry quota id in + set_entry quota id (nb - 1) + with Not_found -> () let add_entry quota id = - let nb = try get_entry quota id with Not_found -> 0 in - set_entry quota id (nb + 1) + let nb = try get_entry quota id with Not_found -> 0 in + set_entry quota id (nb + 1) let add quota diff = - Hashtbl.iter (fun id nb -> set_entry quota id (get_entry quota id + nb)) diff.cur + Hashtbl.iter (fun id nb -> set_entry quota id (get_entry quota id + nb)) diff.cur let merge orig_quota mod_quota dest_quota = - Hashtbl.iter (fun id nb -> let diff = nb - (try get_entry orig_quota id with Not_found -> 0) in - if diff <> 0 then - set_entry dest_quota id ((try get_entry dest_quota id with Not_found -> 0) + diff)) mod_quota.cur + Hashtbl.iter (fun id nb -> let diff = nb - (try get_entry orig_quota id with Not_found -> 0) in + if diff <> 0 then + set_entry dest_quota id ((try get_entry dest_quota id with Not_found -> 0) + diff)) mod_quota.cur diff --git a/tools/ocaml/xenstored/select_stubs.c b/tools/ocaml/xenstored/select_stubs.c index af72b84fa2..f2ef1ec3de 100644 --- a/tools/ocaml/xenstored/select_stubs.c +++ b/tools/ocaml/xenstored/select_stubs.c @@ -25,56 +25,56 @@ CAMLprim value stub_select_on_poll(value fd_events, value timeo) { - CAMLparam2(fd_events, timeo); - CAMLlocal1(events); - int i, rc, c_len = Wosize_val(fd_events), c_timeo = Int_val(timeo); - struct pollfd c_fds[c_len]; + CAMLparam2(fd_events, timeo); + CAMLlocal1(events); + int i, rc, c_len = Wosize_val(fd_events), c_timeo = Int_val(timeo); + struct pollfd c_fds[c_len]; - for (i = 0; i < c_len; i++) { + for (i = 0; i < c_len; i++) { - events = Field(Field(fd_events, i), 1); + events = Field(Field(fd_events, i), 1); - c_fds[i].fd = Int_val(Field(Field(fd_events, i), 0)); - c_fds[i].events = c_fds[i].revents = 0; - c_fds[i].events |= Bool_val(Field(events, 0)) ? POLLIN : 0; - c_fds[i].events |= Bool_val(Field(events, 1)) ? POLLOUT: 0; - c_fds[i].events |= Bool_val(Field(events, 2)) ? POLLPRI: 0; + c_fds[i].fd = Int_val(Field(Field(fd_events, i), 0)); + c_fds[i].events = c_fds[i].revents = 0; + c_fds[i].events |= Bool_val(Field(events, 0)) ? POLLIN : 0; + c_fds[i].events |= Bool_val(Field(events, 1)) ? POLLOUT: 0; + c_fds[i].events |= Bool_val(Field(events, 2)) ? POLLPRI: 0; - }; + }; - caml_enter_blocking_section(); - rc = poll(c_fds, c_len, c_timeo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = poll(c_fds, c_len, c_timeo); + caml_leave_blocking_section(); - if (rc < 0) uerror("poll", Nothing); + if (rc < 0) uerror("poll", Nothing); - if (rc > 0) { + if (rc > 0) { - for (i = 0; i < c_len; i++) { + for (i = 0; i < c_len; i++) { - events = Field(Field(fd_events, i), 1); + events = Field(Field(fd_events, i), 1); - if (c_fds[i].revents & POLLNVAL) unix_error(EBADF, "select", Nothing); - Field(events, 0) = Val_bool(c_fds[i].events & POLLIN && c_fds[i].revents & (POLLIN |POLLHUP|POLLERR)); - Field(events, 1) = Val_bool(c_fds[i].events & POLLOUT && c_fds[i].revents & (POLLOUT|POLLHUP|POLLERR)); - Field(events, 2) = Val_bool(c_fds[i].revents & POLLPRI); + if (c_fds[i].revents & POLLNVAL) unix_error(EBADF, "select", Nothing); + Field(events, 0) = Val_bool(c_fds[i].events & POLLIN && c_fds[i].revents & (POLLIN |POLLHUP|POLLERR)); + Field(events, 1) = Val_bool(c_fds[i].events & POLLOUT && c_fds[i].revents & (POLLOUT|POLLHUP|POLLERR)); + Field(events, 2) = Val_bool(c_fds[i].revents & POLLPRI); - } + } - } + } - CAMLreturn(Val_int(rc)); + CAMLreturn(Val_int(rc)); } CAMLprim value stub_set_fd_limit(value limit) { - CAMLparam1(limit); - struct rlimit rl; + CAMLparam1(limit); + struct rlimit rl; - rl.rlim_cur = rl.rlim_max = Int_val(limit); - if (setrlimit(RLIMIT_NOFILE, &rl) != 0) uerror("setrlimit", Nothing); - CAMLreturn(Val_unit); + rl.rlim_cur = rl.rlim_max = Int_val(limit); + if (setrlimit(RLIMIT_NOFILE, &rl) != 0) uerror("setrlimit", Nothing); + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/xenstored/stdext.ml b/tools/ocaml/xenstored/stdext.ml index 116920917a..0ee4a5ab9c 100644 --- a/tools/ocaml/xenstored/stdext.ml +++ b/tools/ocaml/xenstored/stdext.ml @@ -19,137 +19,137 @@ type ('a, 'b) either = Right of 'a | Left of 'b (** apply the clean_f function after fct function has been called. * Even if fct raises an exception, clean_f is applied - *) +*) let exnhook = ref None let finally fct clean_f = - let result = try - fct (); - with - exn -> - (match !exnhook with None -> () | Some f -> f exn); - clean_f (); raise exn in - clean_f (); - result + let result = try + fct (); + with + exn -> + (match !exnhook with None -> () | Some f -> f exn); + clean_f (); raise exn in + clean_f (); + result (** if v is not none, apply f on it and return some value else return none. *) let may f v = - match v with Some x -> Some (f x) | None -> None + match v with Some x -> Some (f x) | None -> None (** default value to d if v is none. *) let default d v = - match v with Some x -> x | None -> d + match v with Some x -> x | None -> d (** apply f on v if not none *) let maybe f v = - match v with None -> () | Some x -> f x + match v with None -> () | Some x -> f x module Filename = struct - include Filename - let quote_command cmd args = - cmd :: args |> List.map quote |> String.concat " " + include Filename + let quote_command cmd args = + cmd :: args |> List.map quote |> String.concat " " end module Map = struct - module Make(Ord: Map.OrderedType) = struct + module Make(Ord: Map.OrderedType) = struct - include Map.Make(Ord) + include Map.Make(Ord) - let find_opt k t = try Some (find k t) with Not_found -> None + let find_opt k t = try Some (find k t) with Not_found -> None - let update k f t = - let r = find_opt k t in - let r' = f r in - match r, r' with - | None, None -> t - | Some _, None -> remove k t - | Some r, Some r' when r == r' -> t - | _, Some r' -> add k r' t + let update k f t = + let r = find_opt k t in + let r' = f r in + match r, r' with + | None, None -> t + | Some _, None -> remove k t + | Some r, Some r' when r == r' -> t + | _, Some r' -> add k r' t - end + end end module String = struct include String -let of_char c = String.make 1 c + let of_char c = String.make 1 c -let rec split ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) + let rec split ?limit:(limit=(-1)) c s = + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) -let fold_left f accu string = - let accu = ref accu in - for i = 0 to length string - 1 do - accu := f !accu string.[i] - done; - !accu + let fold_left f accu string = + let accu = ref accu in + for i = 0 to length string - 1 do + accu := f !accu string.[i] + done; + !accu -(** True if string 'x' starts with prefix 'prefix' *) -let startswith prefix x = - let x_l = String.length x and prefix_l = String.length prefix in - prefix_l <= x_l && String.sub x 0 prefix_l = prefix + (** True if string 'x' starts with prefix 'prefix' *) + let startswith prefix x = + let x_l = String.length x and prefix_l = String.length prefix in + prefix_l <= x_l && String.sub x 0 prefix_l = prefix end module Unixext = struct -(** remove a file, but doesn't raise an exception if the file is already removed *) -let unlink_safe file = - try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () + (** remove a file, but doesn't raise an exception if the file is already removed *) + let unlink_safe file = + try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () -(** create a directory but doesn't raise an exception if the directory already exist *) -let mkdir_safe dir perm = - try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + (** create a directory but doesn't raise an exception if the directory already exist *) + let mkdir_safe dir perm = + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () -(** create a directory, and create parent if doesn't exist *) -let mkdir_rec dir perm = - let rec p_mkdir dir = - let p_name = Filename.dirname dir in - if p_name <> "/" && p_name <> "." - then p_mkdir p_name; - mkdir_safe dir perm in - p_mkdir dir + (** create a directory, and create parent if doesn't exist *) + let mkdir_rec dir perm = + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name <> "/" && p_name <> "." + then p_mkdir p_name; + mkdir_safe dir perm in + p_mkdir dir -(** daemonize a process *) -(* !! Must call this before spawning any threads !! *) -let daemonize () = - match Unix.fork () with - | 0 -> - if Unix.setsid () == -1 then - failwith "Unix.setsid failed"; + (** daemonize a process *) + (* !! Must call this before spawning any threads !! *) + let daemonize () = + match Unix.fork () with + | 0 -> + if Unix.setsid () == -1 then + failwith "Unix.setsid failed"; - begin match Unix.fork () with - | 0 -> - let nullfd = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0 in - begin try - Unix.dup2 nullfd Unix.stdin; - Unix.dup2 nullfd Unix.stdout; - Unix.dup2 nullfd Unix.stderr; - with exn -> Unix.close nullfd; raise exn - end; - Unix.close nullfd - | _ -> exit 0 - end - | _ -> exit 0 + begin match Unix.fork () with + | 0 -> + let nullfd = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0 in + begin try + Unix.dup2 nullfd Unix.stdin; + Unix.dup2 nullfd Unix.stdout; + Unix.dup2 nullfd Unix.stderr; + with exn -> Unix.close nullfd; raise exn + end; + Unix.close nullfd + | _ -> exit 0 + end + | _ -> exit 0 -(** write a pidfile file *) -let pidfile_write filename = - let fd = Unix.openfile filename - [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] - 0o640 in - finally - (fun () -> - let pid = Unix.getpid () in - let buf = string_of_int pid ^ "\n" in - let len = String.length buf in - if Unix.write_substring fd buf 0 len <> len - then failwith "pidfile_write failed"; - ) - (fun () -> Unix.close fd) + (** write a pidfile file *) + let pidfile_write filename = + let fd = Unix.openfile filename + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] + 0o640 in + finally + (fun () -> + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" in + let len = String.length buf in + if Unix.write_substring fd buf 0 len <> len + then failwith "pidfile_write failed"; + ) + (fun () -> Unix.close fd) end diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml index 70f0c83de4..14ec404988 100644 --- a/tools/ocaml/xenstored/store.ml +++ b/tools/ocaml/xenstored/store.ml @@ -20,231 +20,231 @@ module SymbolMap = Map.Make(Symbol) module Node = struct -type t = { - name: Symbol.t; - perms: Perms.Node.t; - value: string; - children: t SymbolMap.t; -} + type t = { + name: Symbol.t; + perms: Perms.Node.t; + value: string; + children: t SymbolMap.t; + } -let create _name _perms _value = - { name = Symbol.of_string _name; perms = _perms; value = _value; children = SymbolMap.empty; } + let create _name _perms _value = + { name = Symbol.of_string _name; perms = _perms; value = _value; children = SymbolMap.empty; } -let get_owner node = Perms.Node.get_owner node.perms -let get_children node = node.children -let get_value node = node.value -let get_perms node = node.perms -let get_name node = Symbol.to_string node.name + let get_owner node = Perms.Node.get_owner node.perms + let get_children node = node.children + let get_value node = node.value + let get_perms node = node.perms + let get_name node = Symbol.to_string node.name -let set_value node nvalue = - if node.value = nvalue - then node - else { node with value = nvalue } + let set_value node nvalue = + if node.value = nvalue + then node + else { node with value = nvalue } -let set_perms node nperms = { node with perms = nperms } + let set_perms node nperms = { node with perms = nperms } -let add_child node child = - let children = SymbolMap.add child.name child node.children in - { node with children } + let add_child node child = + let children = SymbolMap.add child.name child node.children in + { node with children } -let exists node childname = - let childname = Symbol.of_string childname in - SymbolMap.mem childname node.children + let exists node childname = + let childname = Symbol.of_string childname in + SymbolMap.mem childname node.children -let find node childname = - let childname = Symbol.of_string childname in - SymbolMap.find childname node.children + let find node childname = + let childname = Symbol.of_string childname in + SymbolMap.find childname node.children -let replace_child node child nchild = - { node with - children = SymbolMap.update child.name - (function None -> None | Some _ -> Some nchild) - node.children - } + let replace_child node child nchild = + { node with + children = SymbolMap.update child.name + (function None -> None | Some _ -> Some nchild) + node.children + } -let del_childname node childname = - let sym = Symbol.of_string childname in - { node with children = - SymbolMap.update sym - (function None -> raise Not_found | Some _ -> None) - node.children - } + let del_childname node childname = + let sym = Symbol.of_string childname in + { node with children = + SymbolMap.update sym + (function None -> raise Not_found | Some _ -> None) + node.children + } -let del_all_children node = - { node with children = SymbolMap.empty } + let del_all_children node = + { node with children = SymbolMap.empty } -(* check if the current node can be accessed by the current connection with rperm permissions *) -let check_perm node connection request = - Perms.check connection request node.perms + (* check if the current node can be accessed by the current connection with rperm permissions *) + let check_perm node connection request = + Perms.check connection request node.perms -(* check if the current node is owned by the current connection *) -let check_owner node connection = - if not (Perms.check_owner connection node.perms) - then begin - Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node); - raise Define.Permission_denied; - end + (* check if the current node is owned by the current connection *) + let check_owner node connection = + if not (Perms.check_owner connection node.perms) + then begin + Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node); + raise Define.Permission_denied; + end -let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct) node.children + let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct) node.children -(** [recurse_filter_map f tree] applies [f] on each node in the tree recursively, - possibly removing some nodes. - Note that the nodes removed this way won't generate watch events. -*) -let recurse_filter_map f = - let invalid = -1 in - let is_valid _ node = node.perms.owner <> invalid in - let rec walk node = - (* Map.filter_map is Ocaml 4.11+ only *) - let node = - { node with children = - SymbolMap.map walk node.children |> SymbolMap.filter is_valid } in - match f node with - | Some keep -> keep - | None -> { node with perms = {node.perms with owner = invalid } } - in - walk + (** [recurse_filter_map f tree] applies [f] on each node in the tree recursively, + possibly removing some nodes. + Note that the nodes removed this way won't generate watch events. + *) + let recurse_filter_map f = + let invalid = -1 in + let is_valid _ node = node.perms.owner <> invalid in + let rec walk node = + (* Map.filter_map is Ocaml 4.11+ only *) + let node = + { node with children = + SymbolMap.map walk node.children |> SymbolMap.filter is_valid } in + match f node with + | Some keep -> keep + | None -> { node with perms = {node.perms with owner = invalid } } + in + walk -let unpack node = (Symbol.to_string node.name, node.perms, node.value) + let unpack node = (Symbol.to_string node.name, node.perms, node.value) end module Path = struct -(* represent a path in a store. - * [] -> "/" - * [ "local"; "domain"; "1" ] -> "/local/domain/1" - *) -type t = string list + (* represent a path in a store. + * [] -> "/" + * [ "local"; "domain"; "1" ] -> "/local/domain/1" + *) + type t = string list -let char_is_valid c = - (c >= 'a' && c <= 'z') || - (c >= 'A' && c <= 'Z') || - (c >= '0' && c <= '9') || - c = '_' || c = '-' || c = '@' + let char_is_valid c = + (c >= 'a' && c <= 'z') || + (c >= 'A' && c <= 'Z') || + (c >= '0' && c <= '9') || + c = '_' || c = '-' || c = '@' -let name_is_valid name = - name <> "" && String.fold_left (fun accu c -> accu && char_is_valid c) true name + let name_is_valid name = + name <> "" && String.fold_left (fun accu c -> accu && char_is_valid c) true name -let is_valid path = - List.for_all name_is_valid path + let is_valid path = + List.for_all name_is_valid path -let of_string s = - if s.[0] = '@' - then [s] - else if s = "/" - then [] - else match String.split '/' s with - | "" :: path when is_valid path -> path - | _ -> raise Define.Invalid_path + let of_string s = + if s.[0] = '@' + then [s] + else if s = "/" + then [] + else match String.split '/' s with + | "" :: path when is_valid path -> path + | _ -> raise Define.Invalid_path -let of_path_and_name path name = - match path, name with - | [], "" -> [] - | _ -> path @ [name] + let of_path_and_name path name = + match path, name with + | [], "" -> [] + | _ -> path @ [name] -let create path connection_path = - of_string (Utils.path_validate path connection_path) + let create path connection_path = + of_string (Utils.path_validate path connection_path) -let to_string t = - "/" ^ (String.concat "/" t) + let to_string t = + "/" ^ (String.concat "/" t) -let to_string_list x = x + let to_string_list x = x -let get_parent t = - if t = [] then [] else List.rev (List.tl (List.rev t)) + let get_parent t = + if t = [] then [] else List.rev (List.tl (List.rev t)) -let get_hierarchy path = - Utils.get_hierarchy path + let get_hierarchy path = + Utils.get_hierarchy path -let get_common_prefix p1 p2 = - let rec compare l1 l2 = - match l1, l2 with - | h1 :: tl1, h2 :: tl2 -> - if h1 = h2 then h1 :: (compare tl1 tl2) else [] - | _, [] | [], _ -> - (* if l1 or l2 is empty, we found the equal part already *) - [] - in - compare p1 p2 + let get_common_prefix p1 p2 = + let rec compare l1 l2 = + match l1, l2 with + | h1 :: tl1, h2 :: tl2 -> + if h1 = h2 then h1 :: (compare tl1 tl2) else [] + | _, [] | [], _ -> + (* if l1 or l2 is empty, we found the equal part already *) + [] + in + compare p1 p2 -let rec lookup_modify node path fct = - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> fct node h - | h :: l -> - let (n, c) = - if not (Node.exists node h) then - raise (Define.Lookup_Doesnt_exist h) - else - (node, Node.find node h) in - let nc = lookup_modify c l fct in - Node.replace_child n c nc + let rec lookup_modify node path fct = + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> fct node h + | h :: l -> + let (n, c) = + if not (Node.exists node h) then + raise (Define.Lookup_Doesnt_exist h) + else + (node, Node.find node h) in + let nc = lookup_modify c l fct in + Node.replace_child n c nc -let apply_modify rnode path fct = - lookup_modify rnode path fct + let apply_modify rnode path fct = + lookup_modify rnode path fct -let rec lookup_get node path = - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> - (try - Node.find node h - with Not_found -> - raise Define.Doesnt_exist) - | h :: l -> let cnode = Node.find node h in lookup_get cnode l + let rec lookup_get node path = + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> + (try + Node.find node h + with Not_found -> + raise Define.Doesnt_exist) + | h :: l -> let cnode = Node.find node h in lookup_get cnode l -let get_node rnode path = - if path = [] then - Some rnode - else ( - try Some (lookup_get rnode path) with Define.Doesnt_exist -> None - ) + let get_node rnode path = + if path = [] then + Some rnode + else ( + try Some (lookup_get rnode path) with Define.Doesnt_exist -> None + ) -(* get the deepest existing node for this path, return the node and a flag on the existence of the full path *) -let rec get_deepest_existing_node node = function - | [] -> node, true - | h :: t -> - try get_deepest_existing_node (Node.find node h) t - with Not_found -> node, false + (* get the deepest existing node for this path, return the node and a flag on the existence of the full path *) + let rec get_deepest_existing_node node = function + | [] -> node, true + | h :: t -> + try get_deepest_existing_node (Node.find node h) t + with Not_found -> node, false -let set_node rnode path nnode = - if path = [] then - nnode - else - let set_node node name = - try - let ent = Node.find node name in - Node.replace_child node ent nnode - with Not_found -> - Node.add_child node nnode - in - apply_modify rnode path set_node + let set_node rnode path nnode = + if path = [] then + nnode + else + let set_node node name = + try + let ent = Node.find node name in + Node.replace_child node ent nnode + with Not_found -> + Node.add_child node nnode + in + apply_modify rnode path set_node -(* read | ls | getperms use this *) -let rec lookup node path fct = - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> fct node h - | h :: l -> let cnode = Node.find node h in lookup cnode l fct + (* read | ls | getperms use this *) + let rec lookup node path fct = + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> fct node h + | h :: l -> let cnode = Node.find node h in lookup cnode l fct -let apply rnode path fct = - lookup rnode path fct + let apply rnode path fct = + lookup rnode path fct -let introduce_domain = "@introduceDomain" -let release_domain = "@releaseDomain" -let specials = List.map of_string [ introduce_domain; release_domain ] + let introduce_domain = "@introduceDomain" + let release_domain = "@releaseDomain" + let specials = List.map of_string [ introduce_domain; release_domain ] end (* The Store.t type *) type t = -{ - mutable stat_transaction_coalesce: int; - mutable stat_transaction_abort: int; - mutable root: Node.t; - mutable quota: Quota.t; -} + { + mutable stat_transaction_coalesce: int; + mutable stat_transaction_abort: int; + mutable root: Node.t; + mutable quota: Quota.t; + } let get_root store = store.root let set_root store root = store.root <- root @@ -254,149 +254,149 @@ let set_quota store quota = store.quota <- quota (* modifying functions *) let path_mkdir store perm path = - let do_mkdir node name = - try - let ent = Node.find node name in - Node.check_perm ent perm Perms.WRITE; - raise Define.Already_exist - with Not_found -> - Node.check_perm node perm Perms.WRITE; - Node.add_child node (Node.create name node.Node.perms "") in - if path = [] then - store.root - else - Path.apply_modify store.root path do_mkdir + let do_mkdir node name = + try + let ent = Node.find node name in + Node.check_perm ent perm Perms.WRITE; + raise Define.Already_exist + with Not_found -> + Node.check_perm node perm Perms.WRITE; + Node.add_child node (Node.create name node.Node.perms "") in + if path = [] then + store.root + else + Path.apply_modify store.root path do_mkdir let path_write store perm path value = - let node_created = ref false in - let do_write node name = - try - let ent = Node.find node name in - Node.check_perm ent perm Perms.WRITE; - let nent = Node.set_value ent value in - Node.replace_child node ent nent - with Not_found -> - node_created := true; - Node.check_perm node perm Perms.WRITE; - Node.add_child node (Node.create name node.Node.perms value) in - if path = [] then ( - Node.check_perm store.root perm Perms.WRITE; - Node.set_value store.root value, false - ) else - let root = Path.apply_modify store.root path do_write in - root, !node_created + let node_created = ref false in + let do_write node name = + try + let ent = Node.find node name in + Node.check_perm ent perm Perms.WRITE; + let nent = Node.set_value ent value in + Node.replace_child node ent nent + with Not_found -> + node_created := true; + Node.check_perm node perm Perms.WRITE; + Node.add_child node (Node.create name node.Node.perms value) in + if path = [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.set_value store.root value, false + ) else + let root = Path.apply_modify store.root path do_write in + root, !node_created let path_rm store perm path = - let do_rm node name = - try - let ent = Node.find node name in - Node.check_perm ent perm Perms.WRITE; - Node.del_childname node name - with Not_found -> - raise Define.Doesnt_exist in - if path = [] then ( - Node.check_perm store.root perm Perms.WRITE; - Node.del_all_children store.root - ) else - Path.apply_modify store.root path do_rm + let do_rm node name = + try + let ent = Node.find node name in + Node.check_perm ent perm Perms.WRITE; + Node.del_childname node name + with Not_found -> + raise Define.Doesnt_exist in + if path = [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.del_all_children store.root + ) else + Path.apply_modify store.root path do_rm let path_setperms store perm path perms = - if path = [] then ( - Node.check_perm store.root perm Perms.WRITE; - Node.set_perms store.root perms - ) else - let do_setperms node name = - let c = Node.find node name in - Node.check_owner c perm; - Node.check_perm c perm Perms.WRITE; - let nc = Node.set_perms c perms in - Node.replace_child node c nc - in - Path.apply_modify store.root path do_setperms + if path = [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.set_perms store.root perms + ) else + let do_setperms node name = + let c = Node.find node name in + Node.check_owner c perm; + Node.check_perm c perm Perms.WRITE; + let nc = Node.set_perms c perms in + Node.replace_child node c nc + in + Path.apply_modify store.root path do_setperms (* accessing functions *) let get_node store path = - Path.get_node store.root path + Path.get_node store.root path let get_deepest_existing_node store path = - Path.get_deepest_existing_node store.root path + Path.get_deepest_existing_node store.root path let read store perm path = - let do_read node name = - let ent = Node.find node name in - Node.check_perm ent perm Perms.READ; - ent.Node.value - in - if path = [] then ( - let ent = store.root in - Node.check_perm ent perm Perms.READ; - ent.Node.value - ) else - Path.apply store.root path do_read + let do_read node name = + let ent = Node.find node name in + Node.check_perm ent perm Perms.READ; + ent.Node.value + in + if path = [] then ( + let ent = store.root in + Node.check_perm ent perm Perms.READ; + ent.Node.value + ) else + Path.apply store.root path do_read let ls store perm path = - let children = - if path = [] then ( - Node.check_perm store.root perm Perms.READ; - Node.get_children store.root - ) else - let do_ls node name = - let cnode = Node.find node name in - Node.check_perm cnode perm Perms.READ; - cnode.Node.children in - Path.apply store.root path do_ls in - SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children [] + let children = + if path = [] then ( + Node.check_perm store.root perm Perms.READ; + Node.get_children store.root + ) else + let do_ls node name = + let cnode = Node.find node name in + Node.check_perm cnode perm Perms.READ; + cnode.Node.children in + Path.apply store.root path do_ls in + SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children [] let getperms store perm path = - if path = [] then ( - Node.check_perm store.root perm Perms.READ; - Node.get_perms store.root - ) else - let fct n name = - let c = Node.find n name in - Node.check_perm c perm Perms.READ; - c.Node.perms in - Path.apply store.root path fct + if path = [] then ( + Node.check_perm store.root perm Perms.READ; + Node.get_perms store.root + ) else + let fct n name = + let c = Node.find n name in + Node.check_perm c perm Perms.READ; + c.Node.perms in + Path.apply store.root path fct let path_exists store path = - if path = [] then - true - else - try - let check_exist node name = - ignore(Node.find node name); - true in - Path.apply store.root path check_exist - with Not_found -> false + if path = [] then + true + else + try + let check_exist node name = + ignore(Node.find node name); + true in + Path.apply store.root path check_exist + with Not_found -> false (* others utils *) let traversal root_node f = - let rec _traversal path node = - f path node; - let node_path = Path.of_path_and_name path (Symbol.to_string node.Node.name) in - SymbolMap.iter (fun _ -> _traversal node_path) node.Node.children - in - _traversal [] root_node + let rec _traversal path node = + f path node; + let node_path = Path.of_path_and_name path (Symbol.to_string node.Node.name) in + SymbolMap.iter (fun _ -> _traversal node_path) node.Node.children + in + _traversal [] root_node let dump_store_buf root_node = - let buf = Buffer.create 8192 in - let dump_node path node = - let pathstr = String.concat "/" path in - Printf.bprintf buf "%s/%s{%s}" pathstr (Symbol.to_string node.Node.name) - (String.escaped (Perms.Node.to_string (Node.get_perms node))); - if String.length node.Node.value > 0 then - Printf.bprintf buf " = %s\n" (String.escaped node.Node.value) - else - Printf.bprintf buf "\n"; - in - traversal root_node dump_node; - buf + let buf = Buffer.create 8192 in + let dump_node path node = + let pathstr = String.concat "/" path in + Printf.bprintf buf "%s/%s{%s}" pathstr (Symbol.to_string node.Node.name) + (String.escaped (Perms.Node.to_string (Node.get_perms node))); + if String.length node.Node.value > 0 then + Printf.bprintf buf " = %s\n" (String.escaped node.Node.value) + else + Printf.bprintf buf "\n"; + in + traversal root_node dump_node; + buf let dump_store chan root_node = - let buf = dump_store_buf root_node in - output_string chan (Buffer.contents buf); - Buffer.reset buf + let buf = dump_store_buf root_node in + output_string chan (Buffer.contents buf); + Buffer.reset buf let dump_fct store f = traversal store.root f let dump store out_chan = dump_store out_chan store.root @@ -406,109 +406,109 @@ let dump_buffer store = dump_store_buf store.root (* modifying functions with quota udpate *) let set_node store path node orig_quota mod_quota = - let root = Path.set_node store.root path node in - store.root <- root; - Quota.merge orig_quota mod_quota store.quota + let root = Path.set_node store.root path node in + store.root <- root; + Quota.merge orig_quota mod_quota store.quota let write store perm path value = - let node, existing = get_deepest_existing_node store path in - let owner = Node.get_owner node in - if existing || (Perms.Connection.is_dom0 perm) then - (* Only check the string length limit *) - Quota.check store.quota (-1) (String.length value) - else - (* Check the domain entries limit too *) - Quota.check store.quota owner (String.length value); - let root, node_created = path_write store perm path value in - store.root <- root; - if node_created - then Quota.add_entry store.quota owner + let node, existing = get_deepest_existing_node store path in + let owner = Node.get_owner node in + if existing || (Perms.Connection.is_dom0 perm) then + (* Only check the string length limit *) + Quota.check store.quota (-1) (String.length value) + else + (* Check the domain entries limit too *) + Quota.check store.quota owner (String.length value); + let root, node_created = path_write store perm path value in + store.root <- root; + if node_created + then Quota.add_entry store.quota owner let mkdir store perm path = - let node, existing = get_deepest_existing_node store path in - let owner = Node.get_owner node in - (* It's upt to the mkdir logic to decide what to do with existing path *) - if not (existing || (Perms.Connection.is_dom0 perm)) then Quota.check store.quota owner 0; - store.root <- path_mkdir store perm path; - if not existing then - Quota.add_entry store.quota owner + let node, existing = get_deepest_existing_node store path in + let owner = Node.get_owner node in + (* It's upt to the mkdir logic to decide what to do with existing path *) + if not (existing || (Perms.Connection.is_dom0 perm)) then Quota.check store.quota owner 0; + store.root <- path_mkdir store perm path; + if not existing then + Quota.add_entry store.quota owner let rm store perm path = - let rmed_node = Path.get_node store.root path in - match rmed_node with - | None -> raise Define.Doesnt_exist - | Some rmed_node -> - store.root <- path_rm store perm path; - Node.recurse (fun node -> Quota.del_entry store.quota (Node.get_owner node)) rmed_node + let rmed_node = Path.get_node store.root path in + match rmed_node with + | None -> raise Define.Doesnt_exist + | Some rmed_node -> + store.root <- path_rm store perm path; + Node.recurse (fun node -> Quota.del_entry store.quota (Node.get_owner node)) rmed_node let setperms store perm path nperms = - match Path.get_node store.root path with - | None -> raise Define.Doesnt_exist - | Some node -> - let old_owner = Node.get_owner node in - let new_owner = Perms.Node.get_owner nperms in - if not ((old_owner = new_owner) || (Perms.Connection.is_dom0 perm)) then - raise Define.Permission_denied; - store.root <- path_setperms store perm path nperms; - Quota.del_entry store.quota old_owner; - Quota.add_entry store.quota new_owner + match Path.get_node store.root path with + | None -> raise Define.Doesnt_exist + | Some node -> + let old_owner = Node.get_owner node in + let new_owner = Perms.Node.get_owner nperms in + if not ((old_owner = new_owner) || (Perms.Connection.is_dom0 perm)) then + raise Define.Permission_denied; + store.root <- path_setperms store perm path nperms; + Quota.del_entry store.quota old_owner; + Quota.add_entry store.quota new_owner let reset_permissions store domid = - Logging.info "store|node" "Cleaning up xenstore ACLs for domid %d" domid; - store.root <- Node.recurse_filter_map (fun node -> - match Perms.Node.remove_domid ~domid node.perms with - | None -> None - | Some perms -> - if perms <> node.perms then - Logging.debug "store|node" "Changed permissions for node %s" (Node.get_name node); - Some { node with perms } - ) store.root + Logging.info "store|node" "Cleaning up xenstore ACLs for domid %d" domid; + store.root <- Node.recurse_filter_map (fun node -> + match Perms.Node.remove_domid ~domid node.perms with + | None -> None + | Some perms -> + if perms <> node.perms then + Logging.debug "store|node" "Changed permissions for node %s" (Node.get_name node); + Some { node with perms } + ) store.root type ops = { - store: t; - write: Path.t -> string -> unit; - mkdir: Path.t -> unit; - rm: Path.t -> unit; - setperms: Path.t -> Perms.Node.t -> unit; - ls: Path.t -> string list; - read: Path.t -> string; - getperms: Path.t -> Perms.Node.t; - path_exists: Path.t -> bool; + store: t; + write: Path.t -> string -> unit; + mkdir: Path.t -> unit; + rm: Path.t -> unit; + setperms: Path.t -> Perms.Node.t -> unit; + ls: Path.t -> string list; + read: Path.t -> string; + getperms: Path.t -> Perms.Node.t; + path_exists: Path.t -> bool; } let get_ops store perms = { - store = store; - write = write store perms; - mkdir = mkdir store perms; - rm = rm store perms; - setperms = setperms store perms; - ls = ls store perms; - read = read store perms; - getperms = getperms store perms; - path_exists = path_exists store; + store = store; + write = write store perms; + mkdir = mkdir store perms; + rm = rm store perms; + setperms = setperms store perms; + ls = ls store perms; + read = read store perms; + getperms = getperms store perms; + path_exists = path_exists store; } let create () = { - stat_transaction_coalesce = 0; - stat_transaction_abort = 0; - root = Node.create "" Perms.Node.default0 ""; - quota = Quota.create (); + stat_transaction_coalesce = 0; + stat_transaction_abort = 0; + root = Node.create "" Perms.Node.default0 ""; + quota = Quota.create (); } let copy store = { - stat_transaction_coalesce = store.stat_transaction_coalesce; - stat_transaction_abort = store.stat_transaction_abort; - root = store.root; - quota = Quota.copy store.quota; + stat_transaction_coalesce = store.stat_transaction_coalesce; + stat_transaction_abort = store.stat_transaction_abort; + root = store.root; + quota = Quota.copy store.quota; } let incr_transaction_coalesce store = - store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1 + store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1 let incr_transaction_abort store = - store.stat_transaction_abort <- store.stat_transaction_abort + 1 + store.stat_transaction_abort <- store.stat_transaction_abort + 1 let stats store = - let nb_nodes = ref 0 in - traversal store.root (fun _path _node -> - incr nb_nodes - ); - !nb_nodes, store.stat_transaction_abort, store.stat_transaction_coalesce + let nb_nodes = ref 0 in + traversal store.root (fun _path _node -> + incr nb_nodes + ); + !nb_nodes, store.stat_transaction_abort, store.stat_transaction_coalesce diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml index 72a84ebf80..02298a04ca 100644 --- a/tools/ocaml/xenstored/symbol.ml +++ b/tools/ocaml/xenstored/symbol.ml @@ -18,7 +18,7 @@ module WeakTable = Weak.Make(struct type t = string let equal (x:string) (y:string) = (x = y) let hash = Hashtbl.hash -end) + end) type t = string diff --git a/tools/ocaml/xenstored/syslog.ml b/tools/ocaml/xenstored/syslog.ml index a95da2fd7b..cc5816a868 100644 --- a/tools/ocaml/xenstored/syslog.ml +++ b/tools/ocaml/xenstored/syslog.ml @@ -15,32 +15,32 @@ type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern | Local0 | Local1 | Local2 | Local3 - | Local4 | Local5 | Local6 | Local7 - | Lpr | Mail | News | Syslog | User | Uucp + | Local4 | Local5 | Local6 | Local7 + | Lpr | Mail | News | Syslog | User | Uucp external log : facility -> level -> string -> unit = "stub_syslog" exception Unknown_facility of string let facility_of_string s = - match s with - |"auth"->Auth - |"authpriv"->Authpriv - |"cron"->Cron - |"daemon"->Daemon - |"ftp"->Ftp - |"kern"->Kern - |"local0"->Local0 - |"local1"->Local1 - |"local2"->Local2 - |"local3"->Local3 - |"local4"->Local4 - |"local5"->Local5 - |"local6"->Local6 - |"local7"->Local7 - |"lpr"->Lpr - |"mail"->Mail - |"news"->News - |"syslog"->Syslog - |"user"->User - |"uucp"->Uucp - |_-> raise (Unknown_facility s) + match s with + |"auth"->Auth + |"authpriv"->Authpriv + |"cron"->Cron + |"daemon"->Daemon + |"ftp"->Ftp + |"kern"->Kern + |"local0"->Local0 + |"local1"->Local1 + |"local2"->Local2 + |"local3"->Local3 + |"local4"->Local4 + |"local5"->Local5 + |"local6"->Local6 + |"local7"->Local7 + |"lpr"->Lpr + |"mail"->Mail + |"news"->News + |"syslog"->Syslog + |"user"->User + |"uucp"->Uucp + |_-> raise (Unknown_facility s) diff --git a/tools/ocaml/xenstored/syslog_stubs.c b/tools/ocaml/xenstored/syslog_stubs.c index 875d48ad57..4e5e49b557 100644 --- a/tools/ocaml/xenstored/syslog_stubs.c +++ b/tools/ocaml/xenstored/syslog_stubs.c @@ -21,28 +21,28 @@ #include <caml/signals.h> static int __syslog_level_table[] = { - LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, - LOG_NOTICE, LOG_INFO, LOG_DEBUG + LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, + LOG_NOTICE, LOG_INFO, LOG_DEBUG }; static int __syslog_facility_table[] = { - LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN, - LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, - LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7, - LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP + LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN, + LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, + LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7, + LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP }; value stub_syslog(value facility, value level, value msg) { - CAMLparam3(facility, level, msg); - const char *c_msg = strdup(String_val(msg)); - int c_facility = __syslog_facility_table[Int_val(facility)] - | __syslog_level_table[Int_val(level)]; + CAMLparam3(facility, level, msg); + const char *c_msg = strdup(String_val(msg)); + int c_facility = __syslog_facility_table[Int_val(facility)] + | __syslog_level_table[Int_val(level)]; - caml_enter_blocking_section(); - syslog(c_facility, "%s", c_msg); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + syslog(c_facility, "%s", c_msg); + caml_leave_blocking_section(); - free((void*)c_msg); - CAMLreturn(Val_unit); + free((void*)c_msg); + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/xenstored/systemd_stubs.c b/tools/ocaml/xenstored/systemd_stubs.c index f4c875075a..f36f7300cf 100644 --- a/tools/ocaml/xenstored/systemd_stubs.c +++ b/tools/ocaml/xenstored/systemd_stubs.c @@ -29,19 +29,19 @@ CAMLprim value ocaml_sd_notify_ready(value ignore) { - CAMLparam1(ignore); + CAMLparam1(ignore); - sd_notify(1, "READY=1"); + sd_notify(1, "READY=1"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } #else CAMLprim value ocaml_sd_notify_ready(value ignore) { - CAMLparam1(ignore); + CAMLparam1(ignore); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } #endif diff --git a/tools/ocaml/xenstored/transaction.ml b/tools/ocaml/xenstored/transaction.ml index 294143e233..9ce0e61e03 100644 --- a/tools/ocaml/xenstored/transaction.ml +++ b/tools/ocaml/xenstored/transaction.ml @@ -23,71 +23,71 @@ let test_eagain = ref false let do_coalesce = ref true let check_parents_perms_identical root1 root2 path = - let hierarch = Store.Path.get_hierarchy path in - let permdiff = List.fold_left (fun acc path -> - let n1 = Store.Path.get_node root1 path - and n2 = Store.Path.get_node root2 path in - match n1, n2 with - | Some n1, Some n2 -> - not (Perms.equiv (Store.Node.get_perms n1) (Store.Node.get_perms n2)) || acc - | _ -> - true || acc - ) false hierarch in - (not permdiff) + let hierarch = Store.Path.get_hierarchy path in + let permdiff = List.fold_left (fun acc path -> + let n1 = Store.Path.get_node root1 path + and n2 = Store.Path.get_node root2 path in + match n1, n2 with + | Some n1, Some n2 -> + not (Perms.equiv (Store.Node.get_perms n1) (Store.Node.get_perms n2)) || acc + | _ -> + true || acc + ) false hierarch in + (not permdiff) let get_lowest path1 path2 = - match path2 with - | None -> Some path1 - | Some path2 -> Some (Store.Path.get_common_prefix path1 path2) + match path2 with + | None -> Some path1 + | Some path2 -> Some (Store.Path.get_common_prefix path1 path2) let test_coalesce oldroot currentroot optpath = - match optpath with - | None -> true - | Some path -> - let oldnode = Store.Path.get_node oldroot path - and currentnode = Store.Path.get_node currentroot path in + match optpath with + | None -> true + | Some path -> + let oldnode = Store.Path.get_node oldroot path + and currentnode = Store.Path.get_node currentroot path in - match oldnode, currentnode with - | (Some oldnode), (Some currentnode) -> - if oldnode == currentnode then ( - check_parents_perms_identical oldroot currentroot path - ) else ( - false - ) - | None, None -> ( - (* ok then it doesn't exists in the old version and the current version, - just sneak it in as a child of the parent node if it exists, or else fail *) - let pnode = Store.Path.get_node currentroot (Store.Path.get_parent path) in - match pnode with - | None -> false (* ok it doesn't exists, just bail out. *) - | Some _ -> true - ) - | _ -> - false + match oldnode, currentnode with + | (Some oldnode), (Some currentnode) -> + if oldnode == currentnode then ( + check_parents_perms_identical oldroot currentroot path + ) else ( + false + ) + | None, None -> ( + (* ok then it doesn't exists in the old version and the current version, + just sneak it in as a child of the parent node if it exists, or else fail *) + let pnode = Store.Path.get_node currentroot (Store.Path.get_parent path) in + match pnode with + | None -> false (* ok it doesn't exists, just bail out. *) + | Some _ -> true + ) + | _ -> + false let can_coalesce oldroot currentroot path = - if !do_coalesce then - try test_coalesce oldroot currentroot path with _ -> false - else - false + if !do_coalesce then + try test_coalesce oldroot currentroot path with _ -> false + else + false type ty = No | Full of ( - int * (* Transaction id *) - Store.t * (* Original store *) - Store.t (* A pointer to the canonical store: its root changes on each transaction-commit *) -) + int * (* Transaction id *) + Store.t * (* Original store *) + Store.t (* A pointer to the canonical store: its root changes on each transaction-commit *) + ) type t = { - ty: ty; - start_count: int64; - store: Store.t; (* This is the store that we change in write operations. *) - quota: Quota.t; - oldroot: Store.Node.t; - mutable paths: (Xenbus.Xb.Op.operation * Store.Path.t) list; - mutable operations: (Packet.request * Packet.response) list; - mutable quota_reached: bool; - mutable read_lowpath: Store.Path.t option; - mutable write_lowpath: Store.Path.t option; + ty: ty; + start_count: int64; + store: Store.t; (* This is the store that we change in write operations. *) + quota: Quota.t; + oldroot: Store.Node.t; + mutable paths: (Xenbus.Xb.Op.operation * Store.Path.t) list; + mutable operations: (Packet.request * Packet.response) list; + mutable quota_reached: bool; + mutable read_lowpath: Store.Path.t option; + mutable write_lowpath: Store.Path.t option; } let get_id t = match t.ty with No -> none | Full (id, _, _) -> id @@ -95,48 +95,48 @@ let counter = ref 0L let failed_commits = ref 0L let failed_commits_no_culprit = ref 0L let reset_conflict_stats () = - failed_commits := 0L; - failed_commits_no_culprit := 0L + failed_commits := 0L; + failed_commits_no_culprit := 0L (* Scope for optimisation: different data-structure and functions to search/filter it *) let short_running_txns = ref [] let oldest_short_running_transaction () = - let rec last = function - | [] -> None - | [x] -> Some x - | _ :: xs -> last xs - in last !short_running_txns + let rec last = function + | [] -> None + | [x] -> Some x + | _ :: xs -> last xs + in last !short_running_txns let trim_short_running_transactions txn = - let cutoff = Unix.gettimeofday () -. !Define.conflict_max_history_seconds in - let keep = match txn with - | None -> (function (start_time, _) -> start_time >= cutoff) - | Some t -> (function (start_time, tx) -> start_time >= cutoff && tx != t) - in - short_running_txns := List.filter - keep - !short_running_txns + let cutoff = Unix.gettimeofday () -. !Define.conflict_max_history_seconds in + let keep = match txn with + | None -> (function (start_time, _) -> start_time >= cutoff) + | Some t -> (function (start_time, tx) -> start_time >= cutoff && tx != t) + in + short_running_txns := List.filter + keep + !short_running_txns let make ?(internal=false) id store = - let ty = if id = none then No else Full(id, Store.copy store, store) in - let txn = { - ty = ty; - start_count = !counter; - store = if id = none then store else Store.copy store; - quota = Quota.copy store.Store.quota; - oldroot = Store.get_root store; - paths = []; - operations = []; - quota_reached = false; - read_lowpath = None; - write_lowpath = None; - } in - if id <> none && not internal then ( - let now = Unix.gettimeofday () in - short_running_txns := (now, txn) :: !short_running_txns - ); - txn + let ty = if id = none then No else Full(id, Store.copy store, store) in + let txn = { + ty = ty; + start_count = !counter; + store = if id = none then store else Store.copy store; + quota = Quota.copy store.Store.quota; + oldroot = Store.get_root store; + paths = []; + operations = []; + quota_reached = false; + read_lowpath = None; + write_lowpath = None; + } in + if id <> none && not internal then ( + let now = Unix.gettimeofday () in + short_running_txns := (now, txn) :: !short_running_txns + ); + txn let get_store t = t.store let get_paths t = t.paths @@ -148,115 +148,115 @@ let add_wop t ty path = t.paths <- (ty, path) :: t.paths let get_operations t = List.rev t.operations let check_quota_exn ~perm t = - if !Define.maxrequests >= 0 - && not (Perms.Connection.is_dom0 perm) - && (t.quota_reached || List.length t.operations >= !Define.maxrequests) - then begin - t.quota_reached <- true; - raise Quota.Limit_reached; - end + if !Define.maxrequests >= 0 + && not (Perms.Connection.is_dom0 perm) + && (t.quota_reached || List.length t.operations >= !Define.maxrequests) + then begin + t.quota_reached <- true; + raise Quota.Limit_reached; + end let add_operation t request response = - t.operations <- (request, response) :: t.operations + t.operations <- (request, response) :: t.operations let set_read_lowpath t path = t.read_lowpath <- get_lowest path t.read_lowpath let set_write_lowpath t path = t.write_lowpath <- get_lowest path t.write_lowpath let path_exists t path = Store.path_exists t.store path let write t perm path value = - let path_exists = path_exists t path in - Store.write t.store perm path value; - if path_exists - then set_write_lowpath t path - else set_write_lowpath t (Store.Path.get_parent path); - add_wop t Xenbus.Xb.Op.Write path + let path_exists = path_exists t path in + Store.write t.store perm path value; + if path_exists + then set_write_lowpath t path + else set_write_lowpath t (Store.Path.get_parent path); + add_wop t Xenbus.Xb.Op.Write path let mkdir ?(with_watch=true) t perm path = - Store.mkdir t.store perm path; - set_write_lowpath t (Store.Path.get_parent path); - if with_watch then - add_wop t Xenbus.Xb.Op.Mkdir path + Store.mkdir t.store perm path; + set_write_lowpath t (Store.Path.get_parent path); + if with_watch then + add_wop t Xenbus.Xb.Op.Mkdir path let setperms t perm path perms = - Store.setperms t.store perm path perms; - set_write_lowpath t path; - add_wop t Xenbus.Xb.Op.Setperms path + Store.setperms t.store perm path perms; + set_write_lowpath t path; + add_wop t Xenbus.Xb.Op.Setperms path let rm t perm path = - Store.rm t.store perm path; - set_write_lowpath t (Store.Path.get_parent path); - add_wop t Xenbus.Xb.Op.Rm path + Store.rm t.store perm path; + set_write_lowpath t (Store.Path.get_parent path); + add_wop t Xenbus.Xb.Op.Rm path let ls t perm path = - let r = Store.ls t.store perm path in - set_read_lowpath t path; - r + let r = Store.ls t.store perm path in + set_read_lowpath t path; + r let read t perm path = - let r = Store.read t.store perm path in - set_read_lowpath t path; - r + let r = Store.read t.store perm path in + set_read_lowpath t path; + r let getperms t perm path = - let r = Store.getperms t.store perm path in - set_read_lowpath t path; - r + let r = Store.getperms t.store perm path in + set_read_lowpath t path; + r let commit ~con t = - let has_write_ops = List.length t.paths > 0 in - let has_coalesced = ref false in - let has_commited = - match t.ty with - | No -> true - | Full (_id, oldstore, cstore) -> (* "cstore" meaning current canonical store *) - let commit_partial oldroot cstore store = - (* get the lowest path of the query and verify that it hasn't - been modified by others transactions. *) - if can_coalesce oldroot (Store.get_root cstore) t.read_lowpath - && can_coalesce oldroot (Store.get_root cstore) t.write_lowpath then ( - maybe (fun p -> - let n = Store.get_node store p in + let has_write_ops = List.length t.paths > 0 in + let has_coalesced = ref false in + let has_commited = + match t.ty with + | No -> true + | Full (_id, oldstore, cstore) -> (* "cstore" meaning current canonical store *) + let commit_partial oldroot cstore store = + (* get the lowest path of the query and verify that it hasn't + been modified by others transactions. *) + if can_coalesce oldroot (Store.get_root cstore) t.read_lowpath + && can_coalesce oldroot (Store.get_root cstore) t.write_lowpath then ( + maybe (fun p -> + let n = Store.get_node store p in - (* it has to be in the store, otherwise it means bugs - in the lowpath registration. we don't need to handle none. *) - maybe (fun n -> Store.set_node cstore p n t.quota store.Store.quota) n; - Logging.write_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p); - ) t.write_lowpath; - maybe (fun p -> - Logging.read_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p) - ) t.read_lowpath; - has_coalesced := true; - Store.incr_transaction_coalesce cstore; - true - ) else ( - (* cannot do anything simple, just discard the queries, - and the client need to redo it later *) - Store.incr_transaction_abort cstore; - false - ) - in - let try_commit oldroot cstore store = - if oldroot == Store.get_root cstore then ( - (* move the new root to the current store, if the oldroot - has not been modified *) - if has_write_ops then ( - Store.set_root cstore (Store.get_root store); - Store.set_quota cstore (Store.get_quota store) - ); - true - ) else - (* we try a partial commit if possible *) - commit_partial oldroot cstore store - in - if !test_eagain && Random.int 3 = 0 then - false - else - try_commit (Store.get_root oldstore) cstore t.store - in - if has_commited && has_write_ops then - Disk.write t.store; - if not has_commited - then Logging.conflict ~tid:(get_id t) ~con - else if not !has_coalesced - then Logging.commit ~tid:(get_id t) ~con; - has_commited + (* it has to be in the store, otherwise it means bugs + in the lowpath registration. we don't need to handle none. *) + maybe (fun n -> Store.set_node cstore p n t.quota store.Store.quota) n; + Logging.write_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p); + ) t.write_lowpath; + maybe (fun p -> + Logging.read_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p) + ) t.read_lowpath; + has_coalesced := true; + Store.incr_transaction_coalesce cstore; + true + ) else ( + (* cannot do anything simple, just discard the queries, + and the client need to redo it later *) + Store.incr_transaction_abort cstore; + false + ) + in + let try_commit oldroot cstore store = + if oldroot == Store.get_root cstore then ( + (* move the new root to the current store, if the oldroot + has not been modified *) + if has_write_ops then ( + Store.set_root cstore (Store.get_root store); + Store.set_quota cstore (Store.get_quota store) + ); + true + ) else + (* we try a partial commit if possible *) + commit_partial oldroot cstore store + in + if !test_eagain && Random.int 3 = 0 then + false + else + try_commit (Store.get_root oldstore) cstore t.store + in + if has_commited && has_write_ops then + Disk.write t.store; + if not has_commited + then Logging.conflict ~tid:(get_id t) ~con + else if not !has_coalesced + then Logging.commit ~tid:(get_id t) ~con; + has_commited diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml index ca38b26632..bef97cdbdb 100644 --- a/tools/ocaml/xenstored/trie.ml +++ b/tools/ocaml/xenstored/trie.ml @@ -19,159 +19,159 @@ module StringMap = Map.Make(String) module Node = struct - type 'a t = { - key: string; - value: 'a option; - children: 'a t StringMap.t; - } + type 'a t = { + key: string; + value: 'a option; + children: 'a t StringMap.t; + } - let _create key value = { - key = key; - value = Some value; - children = StringMap.empty; - } + let _create key value = { + key = key; + value = Some value; + children = StringMap.empty; + } - let empty key = { - key = key; - value = None; - children = StringMap.empty; - } + let empty key = { + key = key; + value = None; + children = StringMap.empty; + } - let _get_key node = node.key - let get_value node = - match node.value with - | None -> raise Not_found - | Some value -> value + let _get_key node = node.key + let get_value node = + match node.value with + | None -> raise Not_found + | Some value -> value - let _get_children node = node.children + let _get_children node = node.children - let set_value node value = - { node with value = Some value } - let set_children node children = - { node with children = children } + let set_value node value = + { node with value = Some value } + let set_children node children = + { node with children = children } - let _add_child node child = - { node with children = StringMap.add child.key child node.children } + let _add_child node child = + { node with children = StringMap.add child.key child node.children } end type 'a t = 'a Node.t StringMap.t let mem_node nodes key = - StringMap.mem key nodes + StringMap.mem key nodes let find_node nodes key = - StringMap.find key nodes + StringMap.find key nodes let replace_node nodes key node = - StringMap.update key (function None -> None | Some _ -> Some node) nodes + StringMap.update key (function None -> None | Some _ -> Some node) nodes let remove_node nodes key = - StringMap.update key (function None -> raise Not_found | Some _ -> None) nodes + StringMap.update key (function None -> raise Not_found | Some _ -> None) nodes let create () = StringMap.empty let rec iter f tree = - let aux key node = - f key node.Node.value; - iter f node.Node.children - in - StringMap.iter aux tree + let aux key node = + f key node.Node.value; + iter f node.Node.children + in + StringMap.iter aux tree let rec map f tree = - let aux node = - let value = - match node.Node.value with - | None -> None - | Some value -> f value - in - { node with Node.value = value; Node.children = map f node.Node.children } - in - tree |> StringMap.map aux - |> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.is_empty n.Node.children)) + let aux node = + let value = + match node.Node.value with + | None -> None + | Some value -> f value + in + { node with Node.value = value; Node.children = map f node.Node.children } + in + tree |> StringMap.map aux + |> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.is_empty n.Node.children)) let rec fold f tree acc = - let aux key node accu = - fold f node.Node.children (f key node.Node.value accu) - in - StringMap.fold aux tree acc + let aux key node accu = + fold f node.Node.children (f key node.Node.value accu) + in + StringMap.fold aux tree acc (* return a sub-trie *) let rec sub_node tree = function - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - if t = [] - then node - else sub_node node.Node.children t - end else - raise Not_found + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + if t = [] + then node + else sub_node node.Node.children t + end else + raise Not_found let sub tree path = - try (sub_node tree path).Node.children - with Not_found -> StringMap.empty + try (sub_node tree path).Node.children + with Not_found -> StringMap.empty let find tree path = - Node.get_value (sub_node tree path) + Node.get_value (sub_node tree path) (* return false if the node doesn't exists or if it is not associated to any value *) let rec mem tree = function - | [] -> false - | h::t -> - mem_node tree h - && (let node = find_node tree h in - if t = [] - then node.Node.value <> None - else mem node.Node.children t) + | [] -> false + | h::t -> + mem_node tree h + && (let node = find_node tree h in + if t = [] + then node.Node.value <> None + else mem node.Node.children t) (* Iterate over the longest valid prefix *) let rec iter_path f tree = function - | [] -> () - | h::l -> - if mem_node tree h - then begin - let node = find_node tree h in - f node.Node.key node.Node.value; - iter_path f node.Node.children l - end + | [] -> () + | h::l -> + if mem_node tree h + then begin + let node = find_node tree h in + f node.Node.key node.Node.value; + iter_path f node.Node.children l + end let rec set_node node path value = - if path = [] - then Node.set_value node value - else begin - let children = set node.Node.children path value in - Node.set_children node children - end + if path = [] + then Node.set_value node value + else begin + let children = set node.Node.children path value in + Node.set_children node children + end and set tree path value = - match path with - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - replace_node tree h (set_node node t value) - end else begin - let node = Node.empty h in - StringMap.add node.Node.key (set_node node t value) tree - end + match path with + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + replace_node tree h (set_node node t value) + end else begin + let node = Node.empty h in + StringMap.add node.Node.key (set_node node t value) tree + end let rec unset tree = function - | [] -> tree - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - let children = unset node.Node.children t in - let new_node = - if t = [] - then Node.set_children (Node.empty h) children - else Node.set_children node children - in - if StringMap.is_empty children && new_node.Node.value = None - then remove_node tree h - else replace_node tree h new_node - end else - raise Not_found + | [] -> tree + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + let children = unset node.Node.children t in + let new_node = + if t = [] + then Node.set_children (Node.empty h) children + else Node.set_children node children + in + if StringMap.is_empty children && new_node.Node.value = None + then remove_node tree h + else replace_node tree h new_node + end else + raise Not_found diff --git a/tools/ocaml/xenstored/trie.mli b/tools/ocaml/xenstored/trie.mli index 27785154f5..9e7afff788 100644 --- a/tools/ocaml/xenstored/trie.mli +++ b/tools/ocaml/xenstored/trie.mli @@ -17,44 +17,44 @@ type 'a t (** The type of tries. ['a] the type of values. - Internally, a trie is represented as a labeled tree, where node contains values - of type [string * 'a option]. *) + Internally, a trie is represented as a labeled tree, where node contains values + of type [string * 'a option]. *) val create : unit -> 'a t (** Creates an empty trie. *) val mem : 'a t -> string list -> bool (** [mem t k] returns true if a value is associated with the key [k] in the trie [t]. - Otherwise, it returns false. *) + Otherwise, it returns false. *) val find : 'a t -> string list -> 'a (** [find t k] returns the value associated with the key [k] in the trie [t]. - Returns [Not_found] if no values are associated with [k] in [t]. *) + Returns [Not_found] if no values are associated with [k] in [t]. *) val set : 'a t -> string list -> 'a -> 'a t (** [set t k v] associates the value [v] with the key [k] in the trie [t]. *) val unset : 'a t -> string list -> 'a t (** [unset k v] removes the association of value [v] with the key [k] in the trie [t]. - Moreover, it automatically clean the trie, ie. it removes recursively - every nodes of [t] containing no values and having no chil. *) + Moreover, it automatically clean the trie, ie. it removes recursively + every nodes of [t] containing no values and having no chil. *) val iter : (string -> 'a option -> unit) -> 'a t -> unit (** [iter f t] applies the function [f] to every node of the trie [t]. - As nodes of the trie [t] do not necessary contains a value, the second argument of - [f] is an option type. *) + As nodes of the trie [t] do not necessary contains a value, the second argument of + [f] is an option type. *) val iter_path : (string -> 'a option -> unit) -> 'a t -> string list -> unit (** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t]. - If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) + If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) val fold : (string -> 'a option -> 'c -> 'c) -> 'a t -> 'c -> 'c (** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *) val map : ('a -> 'b option) -> 'a t -> 'b t (** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option - as one may wants to remove value associated to a key. This function is not tail-recursive. *) + as one may wants to remove value associated to a key. This function is not tail-recursive. *) val sub : 'a t -> string list -> 'a t (** [sub t p] returns the sub-trie associated with the path [p] in the trie [t]. - If [p] is not a valid path of [t], it returns an empty trie. *) + If [p] is not a valid path of [t], it returns an empty trie. *) diff --git a/tools/ocaml/xenstored/utils.ml b/tools/ocaml/xenstored/utils.ml index dd03b2b5bc..eac56ec5d6 100644 --- a/tools/ocaml/xenstored/utils.ml +++ b/tools/ocaml/xenstored/utils.ml @@ -19,111 +19,111 @@ open Stdext (* lists utils *) let filter_out filter l = - List.filter (fun x -> not (List.mem x filter)) l + List.filter (fun x -> not (List.mem x filter)) l let filter_in filter l = - List.filter (fun x -> List.mem x filter) l + List.filter (fun x -> List.mem x filter) l let list_remove element l = - List.filter (fun e -> e != element) l + List.filter (fun e -> e != element) l let list_tl_multi n l = - let rec do_tl i x = - if i = 0 then x else do_tl (i - 1) (List.tl x) - in - do_tl n l + let rec do_tl i x = + if i = 0 then x else do_tl (i - 1) (List.tl x) + in + do_tl n l (* string utils *) let get_hierarchy path = - let l = List.length path in - let revpath = List.rev path in - let rec sub i = - let x = List.rev (list_tl_multi (l - i) revpath) in - if i = l then [ x ] else x :: sub (i + 1) - in - sub 0 + let l = List.length path in + let revpath = List.rev path in + let rec sub i = + let x = List.rev (list_tl_multi (l - i) revpath) in + if i = l then [ x ] else x :: sub (i + 1) + in + sub 0 let hexify s = - let hexseq_of_char c = sprintf "%02x" (Char.code c) in - let hs = Bytes.create (String.length s * 2) in - String.iteri (fun i c -> - let seq = hexseq_of_char c in - Bytes.set hs (i * 2) seq.[0]; - Bytes.set hs (i * 2 + 1) seq.[1]; - ) s; - Bytes.unsafe_to_string hs + let hexseq_of_char c = sprintf "%02x" (Char.code c) in + let hs = Bytes.create (String.length s * 2) in + String.iteri (fun i c -> + let seq = hexseq_of_char c in + Bytes.set hs (i * 2) seq.[0]; + Bytes.set hs (i * 2 + 1) seq.[1]; + ) s; + Bytes.unsafe_to_string hs let unhexify hs = - let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in - let b = Bytes.create (String.length hs / 2) in - for i = 0 to Bytes.length b - 1 - do - Bytes.set b i (char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]) - done; - Bytes.unsafe_to_string b + let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in + let b = Bytes.create (String.length hs / 2) in + for i = 0 to Bytes.length b - 1 + do + Bytes.set b i (char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]) + done; + Bytes.unsafe_to_string b let trim_path path = - try - let rindex = String.rindex path '/' in - String.sub path 0 rindex - with - Not_found -> "" + try + let rindex = String.rindex path '/' in + String.sub path 0 rindex + with + Not_found -> "" let join_by_null ls = String.concat "\000" ls (* unix utils *) let create_unix_socket name = - Unixext.unlink_safe name; - Unixext.mkdir_rec (Filename.dirname name) 0o700; - let sockaddr = Unix.ADDR_UNIX(name) in - let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unix.bind sock sockaddr; - Unix.listen sock 1; - sock + Unixext.unlink_safe name; + Unixext.mkdir_rec (Filename.dirname name) 0o700; + let sockaddr = Unix.ADDR_UNIX(name) in + let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.bind sock sockaddr; + Unix.listen sock 1; + sock let read_file_single_integer filename = - let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in - let buf = Bytes.make 20 '\000' in - let sz = Unix.read fd buf 0 20 in - Unix.close fd; - int_of_string (Bytes.sub_string buf 0 sz) + let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in + let buf = Bytes.make 20 '\000' in + let sz = Unix.read fd buf 0 20 in + Unix.close fd; + int_of_string (Bytes.sub_string buf 0 sz) (* @path may be guest data and needs its length validating. @connection_path * is generated locally in xenstored and always of the form "/local/domain/$N/" *) let path_validate path connection_path = - let len = String.length path in + let len = String.length path in - if len = 0 then raise Define.Invalid_path; + if len = 0 then raise Define.Invalid_path; - let abs_path = - match String.get path 0 with - | '/' | '@' -> path - | _ -> connection_path ^ path - in + let abs_path = + match String.get path 0 with + | '/' | '@' -> path + | _ -> connection_path ^ path + in - (* Regardless whether client specified absolute or relative path, - canonicalize it (above) and, for domain-relative paths, check the - length of the relative part. + (* Regardless whether client specified absolute or relative path, + canonicalize it (above) and, for domain-relative paths, check the + length of the relative part. - This prevents paths becoming invalid across migrate when the length - of the domid changes in @param connection_path. - *) - let len = String.length abs_path in - let on_absolute _ _ = len in - let on_relative _ offset = len - offset in - let len = Scanf.ksscanf abs_path on_absolute "/local/domain/%d/%n" on_relative in - if len > !Define.path_max then raise Define.Invalid_path; + This prevents paths becoming invalid across migrate when the length + of the domid changes in @param connection_path. + *) + let len = String.length abs_path in + let on_absolute _ _ = len in + let on_relative _ offset = len - offset in + let len = Scanf.ksscanf abs_path on_absolute "/local/domain/%d/%n" on_relative in + if len > !Define.path_max then raise Define.Invalid_path; - abs_path + abs_path module FD : sig - type t = Unix.file_descr - val of_int: int -> t - val to_int : t -> int + type t = Unix.file_descr + val of_int: int -> t + val to_int : t -> int end = struct - type t = Unix.file_descr - (* This is like Obj.magic but just for these types, - and relies on Unix.file_descr = int *) - external to_int : t -> int = "%identity" - external of_int : int -> t = "%identity" + type t = Unix.file_descr + (* This is like Obj.magic but just for these types, + and relies on Unix.file_descr = int *) + external to_int : t -> int = "%identity" + external of_int : int -> t = "%identity" end diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml index ffd43a4eee..34612814e1 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -26,589 +26,589 @@ let info fmt = Logging.info "xenstored" fmt (*------------ event klass processors --------------*) let process_connection_fds store cons domains rset wset = - let try_fct fct c = - try - fct store cons domains c - with - | Unix.Unix_error(err, "write", _) -> - Connections.del_anonymous cons c; - error "closing socket connection: write error: %s" - (Unix.error_message err) - | Unix.Unix_error(err, "read", _) -> - Connections.del_anonymous cons c; - if err <> Unix.ECONNRESET then - error "closing socket connection: read error: %s" - (Unix.error_message err) - | Xenbus.Xb.End_of_file -> - Connections.del_anonymous cons c; - debug "closing socket connection" - in - let process_fdset_with fds fct = - List.iter - (fun fd -> - try try_fct fct (Connections.find cons fd) - with Not_found -> () - ) fds in - process_fdset_with rset Process.do_input; - process_fdset_with wset Process.do_output + let try_fct fct c = + try + fct store cons domains c + with + | Unix.Unix_error(err, "write", _) -> + Connections.del_anonymous cons c; + error "closing socket connection: write error: %s" + (Unix.error_message err) + | Unix.Unix_error(err, "read", _) -> + Connections.del_anonymous cons c; + if err <> Unix.ECONNRESET then + error "closing socket connection: read error: %s" + (Unix.error_message err) + | Xenbus.Xb.End_of_file -> + Connections.del_anonymous cons c; + debug "closing socket connection" + in + let process_fdset_with fds fct = + List.iter + (fun fd -> + try try_fct fct (Connections.find cons fd) + with Not_found -> () + ) fds in + process_fdset_with rset Process.do_input; + process_fdset_with wset Process.do_output let process_domains store cons domains = - let do_io_domain domain = - if Domain.is_bad_domain domain - || Domain.get_io_credit domain <= 0 - || Domain.is_paused_for_conflict domain - then () (* nothing to do *) - else ( - let con = Connections.find_domain cons (Domain.get_id domain) in - Process.do_input store cons domains con; - Process.do_output store cons domains con; - Domain.decr_io_credit domain - ) in - Domains.iter domains do_io_domain + let do_io_domain domain = + if Domain.is_bad_domain domain + || Domain.get_io_credit domain <= 0 + || Domain.is_paused_for_conflict domain + then () (* nothing to do *) + else ( + let con = Connections.find_domain cons (Domain.get_id domain) in + Process.do_input store cons domains con; + Process.do_output store cons domains con; + Domain.decr_io_credit domain + ) in + Domains.iter domains do_io_domain let sigusr1_handler store = - try - let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] - 0o600 (Paths.xen_run_stored ^ "/db.debug") in - finally (fun () -> Store.dump store channel) - (fun () -> close_out channel) - with _ -> - () + try + let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] + 0o600 (Paths.xen_run_stored ^ "/db.debug") in + finally (fun () -> Store.dump store channel) + (fun () -> close_out channel) + with _ -> + () let sighup_handler _ = - maybe (fun logger -> logger.Logging.restart()) !Logging.xenstored_logger; - maybe (fun logger -> logger.Logging.restart()) !Logging.access_logger + maybe (fun logger -> logger.Logging.restart()) !Logging.xenstored_logger; + maybe (fun logger -> logger.Logging.restart()) !Logging.access_logger let config_filename cf = - match cf.config_file with - | Some name -> name - | None -> Define.default_config_dir ^ "/oxenstored.conf" + match cf.config_file with + | Some name -> name + | None -> Define.default_config_dir ^ "/oxenstored.conf" let default_pidfile = Paths.xen_run_dir ^ "/xenstored.pid" let ring_scan_interval = ref 20 let parse_config filename = - let pidfile = ref default_pidfile in - let options = [ - ("merge-activate", Config.Set_bool Transaction.do_coalesce); - ("conflict-burst-limit", Config.Set_float Define.conflict_burst_limit); - ("conflict-max-history-seconds", Config.Set_float Define.conflict_max_history_seconds); - ("conflict-rate-limit-is-aggregate", Config.Set_bool Define.conflict_rate_limit_is_aggregate); - ("perms-activate", Config.Set_bool Perms.activate); - ("perms-watch-activate", Config.Set_bool Perms.watch_activate); - ("quota-activate", Config.Set_bool Quota.activate); - ("quota-maxwatch", Config.Set_int Define.maxwatch); - ("quota-transaction", Config.Set_int Define.maxtransaction); - ("quota-maxentity", Config.Set_int Quota.maxent); - ("quota-maxsize", Config.Set_int Quota.maxsize); - ("quota-maxrequests", Config.Set_int Define.maxrequests); - ("quota-maxoutstanding", Config.Set_int Define.maxoutstanding); - ("quota-maxwatchevents", Config.Set_int Define.maxwatchevents); - ("quota-path-max", Config.Set_int Define.path_max); - ("gc-max-overhead", Config.Set_int Define.gc_max_overhead); - ("test-eagain", Config.Set_bool Transaction.test_eagain); - ("persistent", Config.Set_bool Disk.enable); - ("xenstored-log-file", Config.String Logging.set_xenstored_log_destination); - ("xenstored-log-level", Config.String - (fun s -> Logging.xenstored_log_level := Logging.level_of_string s)); - ("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_files); - ("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lines); - ("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_chars); - ("access-log-file", Config.String Logging.set_access_log_destination); - ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files); - ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines); - ("access-log-nb-chars", Config.Set_int Logging.access_log_nb_chars); - ("access-log-read-ops", Config.Set_bool Logging.access_log_read_ops); - ("access-log-transactions-ops", Config.Set_bool Logging.access_log_transaction_ops); - ("access-log-special-ops", Config.Set_bool Logging.access_log_special_ops); - ("allow-debug", Config.Set_bool Process.allow_debug); - ("ring-scan-interval", Config.Set_int ring_scan_interval); - ("pid-file", Config.Set_string pidfile); - ("xenstored-kva", Config.Set_string Domains.xenstored_kva); - ("xenstored-port", Config.Set_string Domains.xenstored_port); ] in - begin try Config.read filename options (fun _ _ -> raise Not_found) - with - | Config.Error err -> List.iter (fun (k, e) -> - match e with - | "unknown key" -> eprintf "config: unknown key %s\n" k - | _ -> eprintf "config: %s: %s\n" k e - ) err; - | Sys_error m -> eprintf "error: config: %s\n" m; - end; - !pidfile + let pidfile = ref default_pidfile in + let options = [ + ("merge-activate", Config.Set_bool Transaction.do_coalesce); + ("conflict-burst-limit", Config.Set_float Define.conflict_burst_limit); + ("conflict-max-history-seconds", Config.Set_float Define.conflict_max_history_seconds); + ("conflict-rate-limit-is-aggregate", Config.Set_bool Define.conflict_rate_limit_is_aggregate); + ("perms-activate", Config.Set_bool Perms.activate); + ("perms-watch-activate", Config.Set_bool Perms.watch_activate); + ("quota-activate", Config.Set_bool Quota.activate); + ("quota-maxwatch", Config.Set_int Define.maxwatch); + ("quota-transaction", Config.Set_int Define.maxtransaction); + ("quota-maxentity", Config.Set_int Quota.maxent); + ("quota-maxsize", Config.Set_int Quota.maxsize); + ("quota-maxrequests", Config.Set_int Define.maxrequests); + ("quota-maxoutstanding", Config.Set_int Define.maxoutstanding); + ("quota-maxwatchevents", Config.Set_int Define.maxwatchevents); + ("quota-path-max", Config.Set_int Define.path_max); + ("gc-max-overhead", Config.Set_int Define.gc_max_overhead); + ("test-eagain", Config.Set_bool Transaction.test_eagain); + ("persistent", Config.Set_bool Disk.enable); + ("xenstored-log-file", Config.String Logging.set_xenstored_log_destination); + ("xenstored-log-level", Config.String + (fun s -> Logging.xenstored_log_level := Logging.level_of_string s)); + ("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_files); + ("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lines); + ("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_chars); + ("access-log-file", Config.String Logging.set_access_log_destination); + ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files); + ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines); + ("access-log-nb-chars", Config.Set_int Logging.access_log_nb_chars); + ("access-log-read-ops", Config.Set_bool Logging.access_log_read_ops); + ("access-log-transactions-ops", Config.Set_bool Logging.access_log_transaction_ops); + ("access-log-special-ops", Config.Set_bool Logging.access_log_special_ops); + ("allow-debug", Config.Set_bool Process.allow_debug); + ("ring-scan-interval", Config.Set_int ring_scan_interval); + ("pid-file", Config.Set_string pidfile); + ("xenstored-kva", Config.Set_string Domains.xenstored_kva); + ("xenstored-port", Config.Set_string Domains.xenstored_port); ] in + begin try Config.read filename options (fun _ _ -> raise Not_found) + with + | Config.Error err -> List.iter (fun (k, e) -> + match e with + | "unknown key" -> eprintf "config: unknown key %s\n" k + | _ -> eprintf "config: %s: %s\n" k e + ) err; + | Sys_error m -> eprintf "error: config: %s\n" m; + end; + !pidfile module DB = struct -exception Bad_format of string + exception Bad_format of string -let dump_format_header = "$xenstored-dump-format" + let dump_format_header = "$xenstored-dump-format" -let from_channel_f chan global_f socket_f domain_f watch_f store_f = - let unhexify s = Utils.unhexify s in - let getpath s = - let u = Utils.unhexify s in - debug "Path: %s" u; - Store.Path.of_string u in - let header = input_line chan in - if header <> dump_format_header then - raise (Bad_format "header"); - let quit = ref false in - while not !quit - do - try - let line = input_line chan in - let l = String.split ',' line in - try - match l with - | "global" :: rw :: _ -> - (* there might be more parameters here, - e.g. a RO socket from a previous version: ignore it *) - global_f ~rw - | "socket" :: fd :: [] -> - socket_f ~fd:(int_of_string fd) - | "dom" :: domid :: mfn :: port :: []-> - domain_f (int_of_string domid) - (Nativeint.of_string mfn) - (int_of_string port) - | "watch" :: domid :: path :: token :: [] -> - watch_f (int_of_string domid) - (unhexify path) (unhexify token) - | "store" :: path :: perms :: value :: [] -> - store_f (getpath path) - (Perms.Node.of_string (unhexify perms ^ "\000")) - (unhexify value) - | _ -> - info "restoring: ignoring unknown line: %s" line - with exn -> - info "restoring: ignoring unknown line: %s (exception: %s)" - line (Printexc.to_string exn); - () - with End_of_file -> - quit := true - done; - info "Completed loading xenstore dump" + let from_channel_f chan global_f socket_f domain_f watch_f store_f = + let unhexify s = Utils.unhexify s in + let getpath s = + let u = Utils.unhexify s in + debug "Path: %s" u; + Store.Path.of_string u in + let header = input_line chan in + if header <> dump_format_header then + raise (Bad_format "header"); + let quit = ref false in + while not !quit + do + try + let line = input_line chan in + let l = String.split ',' line in + try + match l with + | "global" :: rw :: _ -> + (* there might be more parameters here, + e.g. a RO socket from a previous version: ignore it *) + global_f ~rw + | "socket" :: fd :: [] -> + socket_f ~fd:(int_of_string fd) + | "dom" :: domid :: mfn :: port :: []-> + domain_f (int_of_string domid) + (Nativeint.of_string mfn) + (int_of_string port) + | "watch" :: domid :: path :: token :: [] -> + watch_f (int_of_string domid) + (unhexify path) (unhexify token) + | "store" :: path :: perms :: value :: [] -> + store_f (getpath path) + (Perms.Node.of_string (unhexify perms ^ "\000")) + (unhexify value) + | _ -> + info "restoring: ignoring unknown line: %s" line + with exn -> + info "restoring: ignoring unknown line: %s (exception: %s)" + line (Printexc.to_string exn); + () + with End_of_file -> + quit := true + done; + info "Completed loading xenstore dump" -let from_channel store cons doms chan = - (* don't let the permission get on our way, full perm ! *) - let op = Store.get_ops store Perms.Connection.full_rights in - let rwro = ref (None) in - let global_f ~rw = - let get_listen_sock sockfd = - let fd = sockfd |> int_of_string |> Utils.FD.of_int in - Unix.listen fd 1; - Some fd - in - rwro := get_listen_sock rw - in - let socket_f ~fd = - let ufd = Utils.FD.of_int fd in - let is_valid = try (Unix.fstat ufd).Unix.st_kind = Unix.S_SOCK with _ -> false in - if is_valid then - Connections.add_anonymous cons ufd - else - warn "Ignoring invalid socket FD %d" fd - in - let domain_f domid mfn port = - let ndom = - if domid > 0 then - Domains.create doms domid mfn port - else - Domains.create0 doms - in - Connections.add_domain cons ndom; - in - let get_con id = - if id < 0 then Connections.find cons (Utils.FD.of_int (-id)) - else Connections.find_domain cons id - in - let watch_f id path token = - ignore (Connections.add_watch cons (get_con id) path token) - in - let store_f path perms value = - op.Store.write path value; - op.Store.setperms path perms - in - from_channel_f chan global_f socket_f domain_f watch_f store_f; - !rwro + let from_channel store cons doms chan = + (* don't let the permission get on our way, full perm ! *) + let op = Store.get_ops store Perms.Connection.full_rights in + let rwro = ref (None) in + let global_f ~rw = + let get_listen_sock sockfd = + let fd = sockfd |> int_of_string |> Utils.FD.of_int in + Unix.listen fd 1; + Some fd + in + rwro := get_listen_sock rw + in + let socket_f ~fd = + let ufd = Utils.FD.of_int fd in + let is_valid = try (Unix.fstat ufd).Unix.st_kind = Unix.S_SOCK with _ -> false in + if is_valid then + Connections.add_anonymous cons ufd + else + warn "Ignoring invalid socket FD %d" fd + in + let domain_f domid mfn port = + let ndom = + if domid > 0 then + Domains.create doms domid mfn port + else + Domains.create0 doms + in + Connections.add_domain cons ndom; + in + let get_con id = + if id < 0 then Connections.find cons (Utils.FD.of_int (-id)) + else Connections.find_domain cons id + in + let watch_f id path token = + ignore (Connections.add_watch cons (get_con id) path token) + in + let store_f path perms value = + op.Store.write path value; + op.Store.setperms path perms + in + from_channel_f chan global_f socket_f domain_f watch_f store_f; + !rwro -let from_file store cons doms file = - info "Loading xenstore dump from %s" file; - let channel = open_in file in - finally (fun () -> from_channel store doms cons channel) - (fun () -> close_in channel) + let from_file store cons doms file = + info "Loading xenstore dump from %s" file; + let channel = open_in file in + finally (fun () -> from_channel store doms cons channel) + (fun () -> close_in channel) -let to_channel store cons rw chan = - let hexify s = Utils.hexify s in + let to_channel store cons rw chan = + let hexify s = Utils.hexify s in - fprintf chan "%s\n" dump_format_header; - let fdopt = function None -> -1 | Some fd -> - (* systemd and utils.ml sets it close on exec *) - Unix.clear_close_on_exec fd; - Utils.FD.to_int fd in - fprintf chan "global,%d\n" (fdopt rw); + fprintf chan "%s\n" dump_format_header; + let fdopt = function None -> -1 | Some fd -> + (* systemd and utils.ml sets it close on exec *) + Unix.clear_close_on_exec fd; + Utils.FD.to_int fd in + fprintf chan "global,%d\n" (fdopt rw); - (* dump connections related to domains: domid, mfn, eventchn port/ sockets, and watches *) - Connections.iter cons (fun con -> Connection.dump con chan); + (* dump connections related to domains: domid, mfn, eventchn port/ sockets, and watches *) + Connections.iter cons (fun con -> Connection.dump con chan); - (* dump the store *) - Store.dump_fct store (fun path node -> - let name, perms, value = Store.Node.unpack node in - let fullpath = Store.Path.to_string (Store.Path.of_path_and_name path name) in - let permstr = Perms.Node.to_string perms in - fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexify value) - ); - flush chan; - () + (* dump the store *) + Store.dump_fct store (fun path node -> + let name, perms, value = Store.Node.unpack node in + let fullpath = Store.Path.to_string (Store.Path.of_path_and_name path name) in + let permstr = Perms.Node.to_string perms in + fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexify value) + ); + flush chan; + () -let to_file store cons fds file = - let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o600 file in - finally (fun () -> to_channel store cons fds channel) - (fun () -> close_out channel) + let to_file store cons fds file = + let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o600 file in + finally (fun () -> to_channel store cons fds channel) + (fun () -> close_out channel) end (* - By default OCaml's GC only returns memory to the OS when it exceeds a - configurable 'max overhead' setting. - The default is 500%, that is 5/6th of the OCaml heap needs to be free - and only 1/6th live for a compaction to be triggerred that would - release memory back to the OS. - If the limit is not hit then the OCaml process can reuse that memory - for its own purposes, but other processes won't be able to use it. + By default OCaml's GC only returns memory to the OS when it exceeds a + configurable 'max overhead' setting. + The default is 500%, that is 5/6th of the OCaml heap needs to be free + and only 1/6th live for a compaction to be triggerred that would + release memory back to the OS. + If the limit is not hit then the OCaml process can reuse that memory + for its own purposes, but other processes won't be able to use it. - There is also a 'space overhead' setting that controls how much work - each major GC slice does, and by default aims at having no more than - 80% or 120% (depending on version) garbage values compared to live - values. - This doesn't have as much relevance to memory returned to the OS as - long as space_overhead <= max_overhead, because compaction is only - triggerred at the end of major GC cycles. + There is also a 'space overhead' setting that controls how much work + each major GC slice does, and by default aims at having no more than + 80% or 120% (depending on version) garbage values compared to live + values. + This doesn't have as much relevance to memory returned to the OS as + long as space_overhead <= max_overhead, because compaction is only + triggerred at the end of major GC cycles. - The defaults are too large once the program starts using ~100MiB of - memory, at which point ~500MiB would be unavailable to other processes - (which would be fine if this was the main process in this VM, but it is - not). + The defaults are too large once the program starts using ~100MiB of + memory, at which point ~500MiB would be unavailable to other processes + (which would be fine if this was the main process in this VM, but it is + not). - Max overhead can also be set to 0, however this is for testing purposes - only (setting it lower than 'space overhead' wouldn't help because the - major GC wouldn't run fast enough, and compaction does have a - performance cost: we can only compact contiguous regions, so memory has - to be moved around). + Max overhead can also be set to 0, however this is for testing purposes + only (setting it lower than 'space overhead' wouldn't help because the + major GC wouldn't run fast enough, and compaction does have a + performance cost: we can only compact contiguous regions, so memory has + to be moved around). - Max overhead controls how often the heap is compacted, which is useful - if there are burst of activity followed by long periods of idle state, - or if a domain quits, etc. Compaction returns memory to the OS. + Max overhead controls how often the heap is compacted, which is useful + if there are burst of activity followed by long periods of idle state, + or if a domain quits, etc. Compaction returns memory to the OS. - wasted = live * space_overhead / 100 + wasted = live * space_overhead / 100 - For globally overriding the GC settings one can use OCAMLRUNPARAM, - however we provide a config file override to be consistent with other - oxenstored settings. + For globally overriding the GC settings one can use OCAMLRUNPARAM, + however we provide a config file override to be consistent with other + oxenstored settings. - One might want to dynamically adjust the overhead setting based on used - memory, i.e. to use a fixed upper bound in bytes, not percentage. However - measurements show that such adjustments increase GC overhead massively, - while still not guaranteeing that memory is returned any more quickly - than with a percentage based setting. + One might want to dynamically adjust the overhead setting based on used + memory, i.e. to use a fixed upper bound in bytes, not percentage. However + measurements show that such adjustments increase GC overhead massively, + while still not guaranteeing that memory is returned any more quickly + than with a percentage based setting. - The allocation policy could also be tweaked, e.g. first fit would reduce - fragmentation and thus memory usage, but the documentation warns that it - can be sensibly slower, and indeed one of our own testcases can trigger - such a corner case where it is multiple times slower, so it is best to keep - the default allocation policy (next-fit/best-fit depending on version). + The allocation policy could also be tweaked, e.g. first fit would reduce + fragmentation and thus memory usage, but the documentation warns that it + can be sensibly slower, and indeed one of our own testcases can trigger + such a corner case where it is multiple times slower, so it is best to keep + the default allocation policy (next-fit/best-fit depending on version). - There are other tweaks that can be attempted in the future, e.g. setting - 'ulimit -v' to 75% of RAM, however getting the kernel to actually return - NULL from allocations is difficult even with that setting, and without a - NULL the emergency GC won't be triggerred. - Perhaps cgroup limits could help, but for now tweak the safest only. + There are other tweaks that can be attempted in the future, e.g. setting + 'ulimit -v' to 75% of RAM, however getting the kernel to actually return + NULL from allocations is difficult even with that setting, and without a + NULL the emergency GC won't be triggerred. + Perhaps cgroup limits could help, but for now tweak the safest only. *) let tweak_gc () = - Gc.set { (Gc.get ()) with Gc.max_overhead = !Define.gc_max_overhead } + Gc.set { (Gc.get ()) with Gc.max_overhead = !Define.gc_max_overhead } let _ = - let cf = do_argv in - let pidfile = - if Sys.file_exists (config_filename cf) then - parse_config (config_filename cf) - else - default_pidfile - in + let cf = do_argv in + let pidfile = + if Sys.file_exists (config_filename cf) then + parse_config (config_filename cf) + else + default_pidfile + in - tweak_gc (); + tweak_gc (); - (try - Unixext.mkdir_rec (Filename.dirname pidfile) 0o755 - with _ -> - () - ); + (try + Unixext.mkdir_rec (Filename.dirname pidfile) 0o755 + with _ -> + () + ); - let rw_sock = - if cf.disable_socket || cf.live_reload then - None - else - Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket) - in + let rw_sock = + if cf.disable_socket || cf.live_reload then + None + else + Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket) + in - if cf.daemonize && not cf.live_reload then - Unixext.daemonize () - else - printf "Xen Storage Daemon, version %d.%d\n%!" - Define.xenstored_major Define.xenstored_minor; + if cf.daemonize && not cf.live_reload then + Unixext.daemonize () + else + printf "Xen Storage Daemon, version %d.%d\n%!" + Define.xenstored_major Define.xenstored_minor; - (try Unixext.pidfile_write pidfile with _ -> ()); + (try Unixext.pidfile_write pidfile with _ -> ()); - (* for compatilibity with old xenstored *) - begin match cf.pidfile with - | Some pidfile -> Unixext.pidfile_write pidfile - | None -> () end; + (* for compatilibity with old xenstored *) + begin match cf.pidfile with + | Some pidfile -> Unixext.pidfile_write pidfile + | None -> () end; - let store = Store.create () in - let eventchn = Event.init () in - let next_frequent_ops = ref 0. in - let advance_next_frequent_ops () = - next_frequent_ops := (Unix.gettimeofday () +. !Define.conflict_max_history_seconds) - in - let delay_next_frequent_ops_by duration = - next_frequent_ops := !next_frequent_ops +. duration - in - let domains = Domains.init eventchn advance_next_frequent_ops in + let store = Store.create () in + let eventchn = Event.init () in + let next_frequent_ops = ref 0. in + let advance_next_frequent_ops () = + next_frequent_ops := (Unix.gettimeofday () +. !Define.conflict_max_history_seconds) + in + let delay_next_frequent_ops_by duration = + next_frequent_ops := !next_frequent_ops +. duration + in + let domains = Domains.init eventchn advance_next_frequent_ops in - (* For things that need to be done periodically but more often - * than the periodic_ops function *) - let frequent_ops () = - if Unix.gettimeofday () > !next_frequent_ops then ( - History.trim (); - Domains.incr_conflict_credit domains; - advance_next_frequent_ops () - ) in - let cons = Connections.create () in + (* For things that need to be done periodically but more often + * than the periodic_ops function *) + let frequent_ops () = + if Unix.gettimeofday () > !next_frequent_ops then ( + History.trim (); + Domains.incr_conflict_credit domains; + advance_next_frequent_ops () + ) in + let cons = Connections.create () in - let quit = ref false in + let quit = ref false in - Logging.init_xenstored_log(); - List.iter (fun path -> - Store.write store Perms.Connection.full_rights path "") Store.Path.specials; + Logging.init_xenstored_log(); + List.iter (fun path -> + Store.write store Perms.Connection.full_rights path "") Store.Path.specials; - let rw_sock = - if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( - let rwro = DB.from_file store domains cons Disk.xs_daemon_database in - info "Live reload: database loaded"; - Event.bind_dom_exc_virq eventchn; - Process.LiveUpdate.completed (); - rwro - ) else ( - info "No live reload: regular startup"; - if !Disk.enable then ( - info "reading store from disk"; - Disk.read store - ); + let rw_sock = + if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( + let rwro = DB.from_file store domains cons Disk.xs_daemon_database in + info "Live reload: database loaded"; + Event.bind_dom_exc_virq eventchn; + Process.LiveUpdate.completed (); + rwro + ) else ( + info "No live reload: regular startup"; + if !Disk.enable then ( + info "reading store from disk"; + Disk.read store + ); - let localpath = Store.Path.of_string "/local" in - if not (Store.path_exists store localpath) then - Store.mkdir store (Perms.Connection.create 0) localpath; + let localpath = Store.Path.of_string "/local" in + if not (Store.path_exists store localpath) then + Store.mkdir store (Perms.Connection.create 0) localpath; - if cf.domain_init then ( - Connections.add_domain cons (Domains.create0 domains); - Event.bind_dom_exc_virq eventchn - ); - rw_sock - ) in + if cf.domain_init then ( + Connections.add_domain cons (Domains.create0 domains); + Event.bind_dom_exc_virq eventchn + ); + rw_sock + ) in - (* required for xenstore-control to detect availability of live-update *) - let tool_path = Store.Path.of_string "/tool" in - if not (Store.path_exists store tool_path) then - Store.mkdir store Perms.Connection.full_rights tool_path; - Store.write store Perms.Connection.full_rights - (Store.Path.of_string "/tool/xenstored") Sys.executable_name; + (* required for xenstore-control to detect availability of live-update *) + let tool_path = Store.Path.of_string "/tool" in + if not (Store.path_exists store tool_path) then + Store.mkdir store Perms.Connection.full_rights tool_path; + Store.write store Perms.Connection.full_rights + (Store.Path.of_string "/tool/xenstored") Sys.executable_name; - Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler); - Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun _ -> - info "Received SIGTERM"; - quit := true)); - Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun _ -> sigusr1_handler store)); - Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler); + Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun _ -> + info "Received SIGTERM"; + quit := true)); + Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun _ -> sigusr1_handler store)); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; - if cf.activate_access_log then begin - let post_rotate () = DB.to_file store cons (None) Disk.xs_daemon_database in - Logging.init_access_log post_rotate - end; + if cf.activate_access_log then begin + let post_rotate () = DB.to_file store cons (None) Disk.xs_daemon_database in + Logging.init_access_log post_rotate + end; - let spec_fds = - (match rw_sock with None -> [] | Some x -> [ x ]) @ - (if cf.domain_init then [ Event.fd eventchn ] else []) - in + let spec_fds = + (match rw_sock with None -> [] | Some x -> [ x ]) @ + (if cf.domain_init then [ Event.fd eventchn ] else []) + in - let process_special_fds rset = - let accept_connection fd = - let (cfd, _addr) = Unix.accept fd in - debug "new connection through socket"; - Connections.add_anonymous cons cfd - and handle_eventchn _fd = - let port = Event.pending eventchn in - debug "pending port %d" (Xeneventchn.to_int port); - finally (fun () -> - if Some port = eventchn.Event.virq_port then ( - let (notify, deaddom) = Domains.cleanup domains in - List.iter (Store.reset_permissions store) deaddom; - List.iter (Connections.del_domain cons) deaddom; - if deaddom <> [] || notify then - Connections.fire_spec_watches - (Store.get_root store) - cons Store.Path.release_domain - ) - else - let c = Connections.find_domain_by_port cons port in - match Connection.get_domain c with - | Some dom -> Domain.incr_io_credit dom | None -> () - ) (fun () -> Event.unmask eventchn port) - and do_if_set fd set fct = - if List.mem fd set then - fct fd in + let process_special_fds rset = + let accept_connection fd = + let (cfd, _addr) = Unix.accept fd in + debug "new connection through socket"; + Connections.add_anonymous cons cfd + and handle_eventchn _fd = + let port = Event.pending eventchn in + debug "pending port %d" (Xeneventchn.to_int port); + finally (fun () -> + if Some port = eventchn.Event.virq_port then ( + let (notify, deaddom) = Domains.cleanup domains in + List.iter (Store.reset_permissions store) deaddom; + List.iter (Connections.del_domain cons) deaddom; + if deaddom <> [] || notify then + Connections.fire_spec_watches + (Store.get_root store) + cons Store.Path.release_domain + ) + else + let c = Connections.find_domain_by_port cons port in + match Connection.get_domain c with + | Some dom -> Domain.incr_io_credit dom | None -> () + ) (fun () -> Event.unmask eventchn port) + and do_if_set fd set fct = + if List.mem fd set then + fct fd in - maybe (fun fd -> do_if_set fd rset accept_connection) rw_sock; - do_if_set (Event.fd eventchn) rset (handle_eventchn) - in + maybe (fun fd -> do_if_set fd rset accept_connection) rw_sock; + do_if_set (Event.fd eventchn) rset (handle_eventchn) + in - let ring_scan_checker dom = - (* no need to scan domains already marked as for processing *) - if not (Domain.get_io_credit dom > 0) then - debug "Looking up domid %d" (Domain.get_id dom); - let con = Connections.find_domain cons (Domain.get_id dom) in - if not (Connection.has_more_work con) then ( - Process.do_output store cons domains con; - Process.do_input store cons domains con; - if Connection.has_more_work con then - (* Previously thought as no work, but detect some after scan (as - processing a new message involves multiple steps.) It's very - likely to be a "lazy" client, bump its credit. It could be false - positive though (due to time window), but it's no harm to give a - domain extra credit. *) - let n = 32 + 2 * (Domains.number domains) in - info "found lazy domain %d, credit %d" (Domain.get_id dom) n; - Domain.set_io_credit ~n dom - ) in + let ring_scan_checker dom = + (* no need to scan domains already marked as for processing *) + if not (Domain.get_io_credit dom > 0) then + debug "Looking up domid %d" (Domain.get_id dom); + let con = Connections.find_domain cons (Domain.get_id dom) in + if not (Connection.has_more_work con) then ( + Process.do_output store cons domains con; + Process.do_input store cons domains con; + if Connection.has_more_work con then + (* Previously thought as no work, but detect some after scan (as + processing a new message involves multiple steps.) It's very + likely to be a "lazy" client, bump its credit. It could be false + positive though (due to time window), but it's no harm to give a + domain extra credit. *) + let n = 32 + 2 * (Domains.number domains) in + info "found lazy domain %d, credit %d" (Domain.get_id dom) n; + Domain.set_io_credit ~n dom + ) in - let last_stat_time = ref 0. in - let last_scan_time = ref 0. in + let last_stat_time = ref 0. in + let last_scan_time = ref 0. in - let periodic_ops now = - debug "periodic_ops starting"; + let periodic_ops now = + debug "periodic_ops starting"; - (* scan all the xs rings as a safenet for ill-behaved clients *) - if !ring_scan_interval >= 0 && now > (!last_scan_time +. float !ring_scan_interval) then - (last_scan_time := now; Domains.iter domains ring_scan_checker); + (* scan all the xs rings as a safenet for ill-behaved clients *) + if !ring_scan_interval >= 0 && now > (!last_scan_time +. float !ring_scan_interval) then + (last_scan_time := now; Domains.iter domains ring_scan_checker); - (* make sure we don't print general stats faster than 2 min *) - if now > (!last_stat_time +. 120.) then ( - info "Transaction conflict statistics for last %F seconds:" (now -. !last_stat_time); - last_stat_time := now; - Domains.iter domains (Domain.log_and_reset_conflict_stats (info "Dom%d caused %Ld conflicts")); - info "%Ld failed transactions; of these no culprit was found for %Ld" !Transaction.failed_commits !Transaction.failed_commits_no_culprit; - Transaction.reset_conflict_stats (); + (* make sure we don't print general stats faster than 2 min *) + if now > (!last_stat_time +. 120.) then ( + info "Transaction conflict statistics for last %F seconds:" (now -. !last_stat_time); + last_stat_time := now; + Domains.iter domains (Domain.log_and_reset_conflict_stats (info "Dom%d caused %Ld conflicts")); + info "%Ld failed transactions; of these no culprit was found for %Ld" !Transaction.failed_commits !Transaction.failed_commits_no_culprit; + Transaction.reset_conflict_stats (); - let gc = Gc.stat () in - let (lanon, lanon_ops, lanon_watchs, - ldom, ldom_ops, ldom_watchs) = Connections.stats cons in - let store_nodes, store_abort, store_coalesce = Store.stats store in - let symtbl_len, symtbl_entries = Symbol.stats () in + let gc = Gc.stat () in + let (lanon, lanon_ops, lanon_watchs, + ldom, ldom_ops, ldom_watchs) = Connections.stats cons in + let store_nodes, store_abort, store_coalesce = Store.stats store in + let symtbl_len, symtbl_entries = Symbol.stats () in - info "store stat: nodes(%d) t-abort(%d) t-coalesce(%d)" - store_nodes store_abort store_coalesce; - info "sytbl stat: length(%d) entries(%d)" symtbl_len symtbl_entries; - info " con stat: anonymous(%d, %d o, %d w) domains(%d, %d o, %d w)" - lanon lanon_ops lanon_watchs ldom ldom_ops ldom_watchs; - info " mem stat: minor(%.0f) promoted(%.0f) major(%.0f) heap(%d w, %d c) live(%d w, %d b) free(%d w, %d b)" - gc.Gc.minor_words gc.Gc.promoted_words gc.Gc.major_words - gc.Gc.heap_words gc.Gc.heap_chunks - gc.Gc.live_words gc.Gc.live_blocks - gc.Gc.free_words gc.Gc.free_blocks - ); - let elapsed = Unix.gettimeofday () -. now in - debug "periodic_ops took %F seconds." elapsed; - if !quit then ( - match Connections.prevents_quit cons with - | [] -> () - | domains -> List.iter (fun con -> warn "%s prevents live update" - (Connection.get_domstr con)) domains - ); - delay_next_frequent_ops_by elapsed - in + info "store stat: nodes(%d) t-abort(%d) t-coalesce(%d)" + store_nodes store_abort store_coalesce; + info "sytbl stat: length(%d) entries(%d)" symtbl_len symtbl_entries; + info " con stat: anonymous(%d, %d o, %d w) domains(%d, %d o, %d w)" + lanon lanon_ops lanon_watchs ldom ldom_ops ldom_watchs; + info " mem stat: minor(%.0f) promoted(%.0f) major(%.0f) heap(%d w, %d c) live(%d w, %d b) free(%d w, %d b)" + gc.Gc.minor_words gc.Gc.promoted_words gc.Gc.major_words + gc.Gc.heap_words gc.Gc.heap_chunks + gc.Gc.live_words gc.Gc.live_blocks + gc.Gc.free_words gc.Gc.free_blocks + ); + let elapsed = Unix.gettimeofday () -. now in + debug "periodic_ops took %F seconds." elapsed; + if !quit then ( + match Connections.prevents_quit cons with + | [] -> () + | domains -> List.iter (fun con -> warn "%s prevents live update" + (Connection.get_domstr con)) domains + ); + delay_next_frequent_ops_by elapsed + in - let period_ops_interval = 15. in - let period_start = ref 0. in + let period_ops_interval = 15. in + let period_start = ref 0. in - let main_loop () = - let is_peaceful c = - match Connection.get_domain c with - | None -> true (* Treat socket-connections as exempt, and free to conflict. *) - | Some dom -> not (Domain.is_paused_for_conflict dom) - in - frequent_ops (); - let mw = Connections.has_more_work cons in - let peaceful_mw = List.filter is_peaceful mw in - List.iter - (fun c -> - match Connection.get_domain c with - | None -> () | Some d -> Domain.incr_io_credit d) - peaceful_mw; - let start_time = Unix.gettimeofday () in - let timeout = - let until_next_activity = - if Domains.all_at_max_credit domains - then period_ops_interval - else min (max 0. (!next_frequent_ops -. start_time)) period_ops_interval in - if peaceful_mw <> [] then 0. else until_next_activity - in - let inset, outset = Connections.select ~only_if:is_peaceful cons in - let rset, wset, _ = - try - Poll.poll_select (spec_fds @ inset) outset [] timeout - with Unix.Unix_error(Unix.EINTR, _, _) -> - [], [], [] in - let sfds, cfds = - List.partition (fun fd -> List.mem fd spec_fds) rset in - if List.length sfds > 0 then - process_special_fds sfds; + let main_loop () = + let is_peaceful c = + match Connection.get_domain c with + | None -> true (* Treat socket-connections as exempt, and free to conflict. *) + | Some dom -> not (Domain.is_paused_for_conflict dom) + in + frequent_ops (); + let mw = Connections.has_more_work cons in + let peaceful_mw = List.filter is_peaceful mw in + List.iter + (fun c -> + match Connection.get_domain c with + | None -> () | Some d -> Domain.incr_io_credit d) + peaceful_mw; + let start_time = Unix.gettimeofday () in + let timeout = + let until_next_activity = + if Domains.all_at_max_credit domains + then period_ops_interval + else min (max 0. (!next_frequent_ops -. start_time)) period_ops_interval in + if peaceful_mw <> [] then 0. else until_next_activity + in + let inset, outset = Connections.select ~only_if:is_peaceful cons in + let rset, wset, _ = + try + Poll.poll_select (spec_fds @ inset) outset [] timeout + with Unix.Unix_error(Unix.EINTR, _, _) -> + [], [], [] in + let sfds, cfds = + List.partition (fun fd -> List.mem fd spec_fds) rset in + if List.length sfds > 0 then + process_special_fds sfds; - if List.length cfds > 0 || List.length wset > 0 then - process_connection_fds store cons domains cfds wset; - if timeout <> 0. then ( - let now = Unix.gettimeofday () in - if now > !period_start +. period_ops_interval then - (period_start := now; periodic_ops now) - ); + if List.length cfds > 0 || List.length wset > 0 then + process_connection_fds store cons domains cfds wset; + if timeout <> 0. then ( + let now = Unix.gettimeofday () in + if now > !period_start +. period_ops_interval then + (period_start := now; periodic_ops now) + ); - process_domains store cons domains - in + process_domains store cons domains + in - Systemd.sd_notify_ready (); - let live_update = ref false in - while not (!quit && Connections.prevents_quit cons = []) - do - try - main_loop (); - live_update := Process.LiveUpdate.should_run cons; - if !live_update || !quit then begin - (* don't initiate live update if saving state fails *) - DB.to_file store cons (rw_sock) Disk.xs_daemon_database; - quit := true; - end - with exc -> - let bt = Printexc.get_backtrace () in - error "caught exception %s: %s" (Printexc.to_string exc) bt; - if cf.reraise_top_level then - raise exc - done; - info "stopping xenstored"; - (* unlink pidfile so that launch-xenstore works again *) - Unixext.unlink_safe pidfile; - (match cf.pidfile with Some pidfile -> Unixext.unlink_safe pidfile | None -> ()); + Systemd.sd_notify_ready (); + let live_update = ref false in + while not (!quit && Connections.prevents_quit cons = []) + do + try + main_loop (); + live_update := Process.LiveUpdate.should_run cons; + if !live_update || !quit then begin + (* don't initiate live update if saving state fails *) + DB.to_file store cons (rw_sock) Disk.xs_daemon_database; + quit := true; + end + with exc -> + let bt = Printexc.get_backtrace () in + error "caught exception %s: %s" (Printexc.to_string exc) bt; + if cf.reraise_top_level then + raise exc + done; + info "stopping xenstored"; + (* unlink pidfile so that launch-xenstore works again *) + Unixext.unlink_safe pidfile; + (match cf.pidfile with Some pidfile -> Unixext.unlink_safe pidfile | None -> ()); - if !live_update then begin - Logging.live_update (); - Process.LiveUpdate.launch_exn !Process.LiveUpdate.state - end + if !live_update then begin + Logging.live_update (); + Process.LiveUpdate.launch_exn !Process.LiveUpdate.state + end -- 2.34.1

©2013 Xen Project, A Linux Foundation Collaborative Project. All Rights Reserved.
Linux Foundation is a registered trademark of The Linux Foundation.
Xen Project is a trademark of The Linux Foundation.