From nobody Sun Feb 8 19:59:33 2026 Delivered-To: importer@patchew.org Received-SPF: pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) client-ip=192.237.175.120; envelope-from=xen-devel-bounces@lists.xenproject.org; helo=lists.xenproject.org; Authentication-Results: mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass(p=reject dis=none) header.from=citrix.com ARC-Seal: i=1; a=rsa-sha256; t=1667922125; cv=none; d=zohomail.com; s=zohoarc; b=LtRVr2xeIb2BL/re6mYxoJgdZStbgyKfXv+CCEu/ZnTm9+nLmWFNfJ2eEgjk0UKC2NTr1wY833qeg/J9jtjlt08eChNV4viTT8up7Jk2xFTK3Xbsnib2LkDojL8RPkXpcqwvyyUvnnR4pQXrVY9V5xNqmfyvPRP6pV3KfePit70= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zohomail.com; s=zohoarc; t=1667922125; h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:List-Subscribe:List-Post:List-Id:List-Help:List-Unsubscribe:MIME-Version:Message-ID:References:Sender:Subject:To; bh=qYHHins6fdikgApTyReP/j0xJEGkA3PPex3YR7qS+HQ=; b=AGKOci/RG8Itku/YW4YiDVfTpV+LKmxjR85zTDmFK/T3Q6NJ4qK8IKWKg0PeSFxD5usMUzwDejX/VLjP9t50E8Gi05LO2phO9ft0G4xOvq75pgU4NPi6rZLgwfb++mn8SLdAJTQU95jwIH7MMzo0mys72tM+DwdnQG+qD/Ot5EY= ARC-Authentication-Results: i=1; mx.zohomail.com; dkim=pass; spf=pass (zohomail.com: domain of lists.xenproject.org designates 192.237.175.120 as permitted sender) smtp.mailfrom=xen-devel-bounces@lists.xenproject.org; dmarc=pass header.from= (p=reject dis=none) Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) by mx.zohomail.com with SMTPS id 1667922125511920.0242427873069; Tue, 8 Nov 2022 07:42:05 -0800 (PST) Received: from list by lists.xenproject.org with outflank-mailman.440127.694334 (Exim 4.92) (envelope-from ) id 1osQjH-0002mz-Is; Tue, 08 Nov 2022 15:41:35 +0000 Received: by outflank-mailman (output) from mailman id 440127.694334; Tue, 08 Nov 2022 15:41:35 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQjH-0002ms-Ed; Tue, 08 Nov 2022 15:41:35 +0000 Received: by outflank-mailman (input) for mailman id 440127; Tue, 08 Nov 2022 15:34:57 +0000 Received: from se1-gles-sth1-in.inumbo.com ([159.253.27.254] helo=se1-gles-sth1.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQcq-0001RY-9z for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:57 +0000 Received: from esa2.hc3370-68.iphmx.com (esa2.hc3370-68.iphmx.com [216.71.145.153]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id e3241f77-5f7a-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:34:52 +0100 (CET) X-Outflank-Mailman: Message body and most headers restored to incoming version X-BeenThere: xen-devel@lists.xenproject.org List-Id: Xen developer discussion List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Errors-To: xen-devel-bounces@lists.xenproject.org Precedence: list Sender: "Xen-devel" X-Inumbo-ID: e3241f77-5f7a-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921692; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=5uagkohGTNvF5X+pSiDm0Xmh6rsnPEv8DIR0QFQsA7c=; b=QZncjLGzbpaX5BBWaAJhBawMRIm6jG/Q54CMQLT2aXCpr2+/N2Px9b4a R3I8p3JpwspOLXLTeuWtUIRpdYXrnIPV41jlt+62MCL3sHgm6SYRtib6n IeHjb6mvdj9CUzbDddT3sZANfVUgt7FuMTqls7xYgDL38sYGdqW9RC8TA c=; Authentication-Results: esa2.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 84416538 X-Ironport-Server: esa2.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED 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 X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="84416538" From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= To: CC: Henry Wang , =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 07/15] CODING_STYLE(tools/ocaml): add 'make format' and remove tabs Date: Tue, 8 Nov 2022 15:33:59 +0000 Message-ID: <16f52592270e36670947fbcbe1e4d91f1daf9823.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-ZohoMail-DKIM: pass (identity @citrix.com) X-ZM-MESSAGEID: 1667922128413100001 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=C3=B6r=C3=B6k -- 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/li= bs/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 @@ =20 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)); } =20 static struct custom_operations xenevtchn_ops =3D { - "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 */ }; =20 CAMLprim value stub_eventchn_init(void) { - CAMLparam0(); - CAMLlocal1(result); - xenevtchn_handle *xce; + CAMLparam0(); + CAMLlocal1(result); + xenevtchn_handle *xce; =20 - caml_enter_blocking_section(); - xce =3D xenevtchn_open(NULL, 0); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + xce =3D xenevtchn_open(NULL, 0); + caml_leave_blocking_section(); =20 - if (xce =3D=3D NULL) - caml_failwith("open failed"); + if (xce =3D=3D NULL) + caml_failwith("open failed"); =20 - /* contains file descriptors, trigger full GC at least every 128 allocati= ons */ - result =3D caml_alloc_custom(&xenevtchn_ops, sizeof(xce), 0, 1); - _H(result) =3D xce; - CAMLreturn(result); + /* contains file descriptors, trigger full GC at least every 128 alloc= ations */ + result =3D caml_alloc_custom(&xenevtchn_ops, sizeof(xce), 0, 1); + _H(result) =3D xce; + CAMLreturn(result); } =20 CAMLprim value stub_eventchn_fd(value xce) { - CAMLparam1(xce); - CAMLlocal1(result); - int fd; + CAMLparam1(xce); + CAMLlocal1(result); + int fd; =20 - fd =3D xenevtchn_fd(_H(xce)); - if (fd =3D=3D -1) - caml_failwith("evtchn fd failed"); + fd =3D xenevtchn_fd(_H(xce)); + if (fd =3D=3D -1) + caml_failwith("evtchn fd failed"); =20 - result =3D Val_int(fd); + result =3D Val_int(fd); =20 - CAMLreturn(result); + CAMLreturn(result); } =20 CAMLprim value stub_eventchn_notify(value xce, value port) { - CAMLparam2(xce, port); - int rc; + CAMLparam2(xce, port); + int rc; =20 - caml_enter_blocking_section(); - rc =3D xenevtchn_notify(_H(xce), Int_val(port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc =3D xenevtchn_notify(_H(xce), Int_val(port)); + caml_leave_blocking_section(); =20 - if (rc =3D=3D -1) - caml_failwith("evtchn notify failed"); + if (rc =3D=3D -1) + caml_failwith("evtchn notify failed"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - caml_enter_blocking_section(); - rc =3D xenevtchn_bind_interdomain(_H(xce), Int_val(domid), Int_val(remote= _port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc =3D xenevtchn_bind_interdomain(_H(xce), Int_val(domid), Int_val(rem= ote_port)); + caml_leave_blocking_section(); =20 - if (rc =3D=3D -1) - caml_failwith("evtchn bind_interdomain failed"); - port =3D Val_int(rc); + if (rc =3D=3D -1) + caml_failwith("evtchn bind_interdomain failed"); + port =3D Val_int(rc); =20 - CAMLreturn(port); + CAMLreturn(port); } =20 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; =20 - caml_enter_blocking_section(); - rc =3D xenevtchn_bind_virq(_H(xce), Int_val(virq_type)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc =3D xenevtchn_bind_virq(_H(xce), Int_val(virq_type)); + caml_leave_blocking_section(); =20 - if (rc =3D=3D -1) - caml_failwith("evtchn bind_virq failed"); - port =3D Val_int(rc); + if (rc =3D=3D -1) + caml_failwith("evtchn bind_virq failed"); + port =3D Val_int(rc); =20 - CAMLreturn(port); + CAMLreturn(port); } =20 CAMLprim value stub_eventchn_unbind(value xce, value port) { - CAMLparam2(xce, port); - int rc; + CAMLparam2(xce, port); + int rc; =20 - caml_enter_blocking_section(); - rc =3D xenevtchn_unbind(_H(xce), Int_val(port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc =3D xenevtchn_unbind(_H(xce), Int_val(port)); + caml_leave_blocking_section(); =20 - if (rc =3D=3D -1) - caml_failwith("evtchn unbind failed"); + if (rc =3D=3D -1) + caml_failwith("evtchn unbind failed"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - caml_enter_blocking_section(); - port =3D xenevtchn_pending(_H(xce)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + port =3D xenevtchn_pending(_H(xce)); + caml_leave_blocking_section(); =20 - if (port =3D=3D -1) - caml_failwith("evtchn pending failed"); - result =3D Val_int(port); + if (port =3D=3D -1) + caml_failwith("evtchn pending failed"); + result =3D Val_int(port); =20 - CAMLreturn(result); + CAMLreturn(result); } =20 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; =20 - port =3D Int_val(_port); + port =3D Int_val(_port); =20 - caml_enter_blocking_section(); - rc =3D xenevtchn_unmask(_H(xce), port); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc =3D xenevtchn_unmask(_H(xce), port); + caml_leave_blocking_section(); =20 - 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/mma= p_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 @@ =20 struct mmap_interface { - void *addr; - int len; + void *addr; + int len; }; =20 /* for compatibility with OCaml 4.02.3 */ diff --git a/tools/ocaml/libs/mmap/xenmmap.ml b/tools/ocaml/libs/mmap/xenmm= ap.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 =3D SHARED | PRIVATE =20 (* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *) external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag - -> int -> int -> mmap_interface =3D "stub_mmap_init" + -> int -> int -> mmap_interface =3D "stub_mmap_init" external unmap: mmap_interface -> unit =3D "stub_mmap_final" (* read: interface -> start -> length -> data *) external read: mmap_interface -> int -> int -> string =3D "stub_mmap_read" diff --git a/tools/ocaml/libs/mmap/xenmmap.mli b/tools/ocaml/libs/mmap/xenm= map.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 =3D RDONLY | WRONLY | RDWR type mmap_map_flag =3D SHARED | PRIVATE =20 external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int = -> int - -> mmap_interface =3D "stub_mmap_init" + -> mmap_interface =3D "stub_mmap_init" external unmap : mmap_interface -> unit =3D "stub_mmap_final" external read : mmap_interface -> int -> int -> string =3D "stub_mmap_read" external write : mmap_interface -> string -> int -> int -> unit - =3D "stub_mmap_write" + =3D "stub_mmap_write" =20 external getpagesize : unit -> int =3D "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 *i= ntf, int fd, int pflag, int mflag, int len, int offset) { - intf->len =3D len; - intf->addr =3D mmap(NULL, len, pflag, mflag, fd, offset); - return (intf->addr =3D=3D MAP_FAILED) ? errno : 0; + intf->len =3D len; + intf->addr =3D mmap(NULL, len, pflag, mflag, fd, offset); + return (intf->addr =3D=3D MAP_FAILED) ? errno : 0; } =20 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; =20 - switch (Int_val(pflag)) { - case 0: c_pflag =3D PROT_READ; break; - case 1: c_pflag =3D PROT_WRITE; break; - case 2: c_pflag =3D PROT_READ|PROT_WRITE; break; - default: caml_invalid_argument("protectiontype"); - } + switch (Int_val(pflag)) { + case 0: c_pflag =3D PROT_READ; break; + case 1: c_pflag =3D PROT_WRITE; break; + case 2: c_pflag =3D PROT_READ|PROT_WRITE; break; + default: caml_invalid_argument("protectiontype"); + } =20 - switch (Int_val(mflag)) { - case 0: c_mflag =3D MAP_SHARED; break; - case 1: c_mflag =3D MAP_PRIVATE; break; - default: caml_invalid_argument("maptype"); - } + switch (Int_val(mflag)) { + case 0: c_mflag =3D MAP_SHARED; break; + case 1: c_mflag =3D MAP_PRIVATE; break; + default: caml_invalid_argument("maptype"); + } =20 - result =3D caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + result =3D caml_alloc(sizeof(struct mmap_interface), Abstract_tag); =20 - 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); } =20 CAMLprim value stub_mmap_final(value intf) { - CAMLparam1(intf); + CAMLparam1(intf); =20 - if (Intf_val(intf)->addr !=3D MAP_FAILED) - munmap(Intf_val(intf)->addr, Intf_val(intf)->len); - Intf_val(intf)->addr =3D MAP_FAILED; + if (Intf_val(intf)->addr !=3D MAP_FAILED) + munmap(Intf_val(intf)->addr, Intf_val(intf)->len); + Intf_val(intf)->addr =3D MAP_FAILED; =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - c_start =3D Int_val(start); - c_len =3D Int_val(len); + c_start =3D Int_val(start); + c_len =3D Int_val(len); =20 - 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"); =20 - data =3D caml_alloc_string(c_len); - memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len); + data =3D caml_alloc_string(c_len); + memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len); =20 - CAMLreturn(data); + CAMLreturn(data); } =20 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; =20 - c_start =3D Int_val(start); - c_len =3D Int_val(len); + c_start =3D Int_val(start); + c_len =3D Int_val(len); =20 - 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"); =20 - memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len); + memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 CAMLprim value stub_mmap_getpagesize(value unit) { - CAMLparam1(unit); - CAMLlocal1(data); + CAMLparam1(unit); + CAMLlocal1(data); =20 - data =3D Val_int(getpagesize()); - CAMLreturn(data); + data =3D 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 =3D Debug | Directory | Read | Getperms | Invalid =20 let operation_c_mapping =3D - [| 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 =3D Array.length operation_c_mapping =20 let array_search el a =3D - let len =3D Array.length a in - let rec search i =3D - if i > len then raise Not_found; - if a.(i) =3D el then i else search (i + 1) in - search 0 + let len =3D Array.length a in + let rec search i =3D + if i > len then raise Not_found; + if a.(i) =3D el then i else search (i + 1) in + search 0 =20 let of_cval i =3D - if i >=3D 0 && i < size - then operation_c_mapping.(i) - else Invalid + if i >=3D 0 && i < size + then operation_c_mapping.(i) + else Invalid =20 let to_cval op =3D - array_search op operation_c_mapping + array_search op operation_c_mapping =20 let to_string ty =3D - 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 @@ *) =20 type t =3D -{ - tid: int; - rid: int; - ty: Op.operation; - data: string; -} + { + tid: int; + rid: int; + ty: Op.operation; + data: string; + } =20 exception Error of string exception DataError of string @@ -30,21 +30,21 @@ external string_of_header: int -> int -> int -> int -> = string =3D "stub_string_of_ let create tid rid ty data =3D { tid =3D tid; rid =3D rid; ty =3D ty; data= =3D data; } =20 let of_partialpkt ppkt =3D - 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.content= s ppkt.Partial.buf) =20 let to_string pkt =3D - let header =3D string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (Stri= ng.length pkt.data) in - header ^ pkt.data + let header =3D string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (Str= ing.length pkt.data) in + header ^ pkt.data =20 let unpack pkt =3D - pkt.tid, pkt.rid, pkt.ty, pkt.data + pkt.tid, pkt.rid, pkt.ty, pkt.data =20 let get_tid pkt =3D pkt.tid let get_ty pkt =3D pkt.ty let get_data pkt =3D - let l =3D String.length pkt.data in - if l > 0 && pkt.data.[l - 1] =3D '\000' then - String.sub pkt.data 0 (l - 1) - else - pkt.data + let l =3D String.length pkt.data in + if l > 0 && pkt.data.[l - 1] =3D '\000' then + String.sub pkt.data 0 (l - 1) + else + pkt.data let get_rid pkt =3D 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 @@ *) =20 type pkt =3D -{ - tid: int; - rid: int; - ty: Op.operation; - len: int; - buf: Buffer.t; -} + { + tid: int; + rid: int; + ty: Op.operation; + len: int; + buf: Buffer.t; + } =20 external header_size: unit -> int =3D "stub_header_size" external header_of_string_internal: string -> int * int * int * int - =3D "stub_header_of_string" + =3D "stub_header_of_string" =20 let xenstore_payload_max =3D 4096 (* xen/include/public/io/xs_wire.h *) let xenstore_rel_path_max =3D 2048 (* xen/include/public/io/xs_wire.h *) =20 let of_string s =3D - let tid, rid, opint, dlen =3D 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 =3D max 0 (min xenstore_payload_max dlen) in - { - tid =3D tid; - rid =3D rid; - ty =3D (Op.of_cval opint); - len =3D dlen; - buf =3D Buffer.create dlen; - } + let tid, rid, opint, dlen =3D 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 =3D max 0 (min xenstore_payload_max dlen) in + { + tid =3D tid; + rid =3D rid; + ty =3D (Op.of_cval opint); + len =3D dlen; + buf =3D Buffer.create dlen; + } =20 let append pkt s sz =3D - if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith "Buffe= r.add: cannot grow buffer"; - Buffer.add_substring pkt.buf s 0 sz + if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith "Buff= er.add: cannot grow buffer"; + Buffer.add_substring pkt.buf s 0 sz =20 let to_complete pkt =3D - 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 =3D struct include Op end module Packet =3D struct include Packet end =20 module BoundedQueue : sig - type ('a, 'b) t + type ('a, 'b) t =20 - (** [create ~capacity ~classify ~limit] creates a queue with maximum [cap= acity] 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 ele= ments 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 [ca= pacity] 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 el= ements 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 =20 - (** [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 =20 - (** [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 =20 - (** [push e q] adds [e] at the end of queue [q] if [can_push q], or retur= ns [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 retu= rns [None]. *) + val push: 'a -> ('a, 'b) t -> unit option =20 - (** [pop q] removes and returns first element in [q], or raises [Queue.Em= pty]. *) - val pop: ('a, 'b) t -> 'a + (** [pop q] removes and returns first element in [q], or raises [Queue.E= mpty]. *) + val pop: ('a, 'b) t -> 'a =20 - (** [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 =20 - (** [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 =20 - (** [debug string_of_class q] prints queue usage statistics in an unspeci= fied internal format. *) - val debug: ('b -> string) -> (_, 'b) t -> string + (** [debug string_of_class q] prints queue usage statistics in an unspec= ified internal format. *) + val debug: ('b -> string) -> (_, 'b) t -> string end =3D struct - type ('a, 'b) t =3D - { q: 'a Queue.t - ; capacity: int - ; classify: 'a -> 'b - ; limit: 'b -> int - ; class_count: ('b, int) Hashtbl.t - } + type ('a, 'b) t =3D + { q: 'a Queue.t + ; capacity: int + ; classify: 'a -> 'b + ; limit: 'b -> int + ; class_count: ('b, int) Hashtbl.t + } =20 - let create ~capacity ~classify ~limit =3D - { capacity; q =3D Queue.create (); classify; limit; class_count =3D Hash= tbl.create 3 } + let create ~capacity ~classify ~limit =3D + { capacity; q =3D Queue.create (); classify; limit; class_count =3D Ha= shtbl.create 3 } =20 - let get_count t classification =3D try Hashtbl.find t.class_count classif= ication with Not_found -> 0 + let get_count t classification =3D try Hashtbl.find t.class_count classi= fication with Not_found -> 0 =20 - let can_push_internal t classification class_count =3D - Queue.length t.q < t.capacity && class_count < t.limit classification + let can_push_internal t classification class_count =3D + Queue.length t.q < t.capacity && class_count < t.limit classification =20 - let ok =3D Some () + let ok =3D Some () =20 - let push e t =3D - let classification =3D t.classify e in - let class_count =3D 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 =3D + let classification =3D t.classify e in + let class_count =3D 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 =20 - let can_push t classification =3D - can_push_internal t classification @@ get_count t classification + let can_push t classification =3D + can_push_internal t classification @@ get_count t classification =20 - let clear t =3D - Queue.clear t.q; - Hashtbl.reset t.class_count + let clear t =3D + Queue.clear t.q; + Hashtbl.reset t.class_count =20 - let pop t =3D - let e =3D Queue.pop t.q in - let classification =3D t.classify e in - let () =3D 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 =3D + let e =3D Queue.pop t.q in + let classification =3D t.classify e in + let () =3D match get_count t classification - 1 with + | 0 -> Hashtbl.remove t.class_count classification (* reduces memusa= ge *) + | n -> Hashtbl.replace t.class_count classification n + in + e =20 - let peek t =3D Queue.peek t.q - let length t =3D Queue.length t.q + let peek t =3D Queue.peek t.q + let length t =3D Queue.length t.q =20 - let debug string_of_class t =3D - let b =3D 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 =3D + let b =3D 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 =20 =20 @@ -119,129 +119,129 @@ let _ =3D Callback.register_exception "Xb.Reconnect" Reconnect =20 type backend_mmap =3D -{ - mmap: Xenmmap.mmap_interface; (* mmaped interface =3D xs_ring *) - eventchn_notify: unit -> unit; (* function to notify through eventchn *) - mutable work_again: bool; -} + { + mmap: Xenmmap.mmap_interface; (* mmaped interface =3D xs_ring *) + eventchn_notify: unit -> unit; (* function to notify through eventchn = *) + mutable work_again: bool; + } =20 type backend_fd =3D -{ - fd: Unix.file_descr; -} + { + fd: Unix.file_descr; + } =20 type backend =3D Fd of backend_fd | Xenmmap of backend_mmap =20 type partial_buf =3D HaveHdr of Partial.pkt | NoHdr of int * bytes =20 (* - 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 =3D { maxoutstanding: int; maxwatchevents: int } =20 module Queue =3D BoundedQueue =20 type packet_class =3D - | CommandReply - | Watchevent + | CommandReply + | Watchevent =20 let string_of_packet_class =3D function - | CommandReply -> "command_reply" - | Watchevent -> "watch_event" + | CommandReply -> "command_reply" + | Watchevent -> "watch_event" =20 type t =3D -{ - 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 + } =20 let to_read con =3D - 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 =20 let debug t =3D - Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d byte= s, 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 byt= es, 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) =20 let init_partial_in () =3D NoHdr - (Partial.header_size (), Bytes.make (Partial.header_size()) '\000') + (Partial.header_size (), Bytes.make (Partial.header_size()) '\000') =20 let reconnect t =3D 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 <- "" =20 let queue con pkt =3D Queue.push pkt con.pkt_out =20 let read_fd back _con b len =3D - let rd =3D Unix.read back.fd b 0 len in - if rd =3D 0 then - raise End_of_file; - rd + let rd =3D Unix.read back.fd b 0 len in + if rd =3D 0 then + raise End_of_file; + rd =20 let read_mmap back _con b len =3D - let s =3D Bytes.make len '\000' in - let rd =3D 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 =3D Bytes.make len '\000' in + let rd =3D 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 =20 let read con b len =3D - 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 =20 let write_fd back _con b len =3D - Unix.write_substring back.fd b 0 len + Unix.write_substring back.fd b 0 len =20 let write_mmap back _con s len =3D - let ws =3D Xs_ring.write_substring back.mmap s len in - if ws > 0 then - back.eventchn_notify (); - ws + let ws =3D Xs_ring.write_substring back.mmap s len in + if ws > 0 then + back.eventchn_notify (); + ws =20 let write con s len =3D - 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 =20 (* NB: can throw Reconnect *) let output con =3D - (* get the output string from a string_of(packet) or partial_out *) - let s =3D if String.length con.partial_out > 0 then - con.partial_out - else if Queue.length con.pkt_out > 0 then - let pkt =3D 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 =3D String.length s in - let sz =3D write con s len in - let left =3D String.sub s sz (len - sz) in - con.partial_out <- left - ); - (* after sending one packet, partial is empty *) - con.partial_out =3D "" + (* get the output string from a string_of(packet) or partial_out *) + let s =3D if String.length con.partial_out > 0 then + con.partial_out + else if Queue.length con.pkt_out > 0 then + let pkt =3D 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 =3D String.length s in + let sz =3D write con s len in + let left =3D String.sub s sz (len - sz) in + con.partial_out <- left + ); + (* after sending one packet, partial is empty *) + con.partial_out =3D "" =20 (* 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 =3D Queue.can_push con.pkt_out Comm= andReply =20 (* NB: can throw Reconnect *) let input con =3D - if not (can_input con) then None - else - let to_read =3D to_read con in + if not (can_input con) then None + else + let to_read =3D to_read con in =20 - (* try to get more data from input stream *) - let b =3D Bytes.make to_read '\000' in - let sz =3D if to_read > 0 then read con b to_read else 0 in + (* try to get more data from input stream *) + let b =3D Bytes.make to_read '\000' in + let sz =3D if to_read > 0 then read con b to_read else 0 in =20 - ( - 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 =3D 0 then ( - let pkt =3D 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 =3D i then - HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, b= uf); - 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 =3D 0 then ( + let pkt =3D 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 =3D i then + HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (= i - sz, buf); + None + ) =20 let classify t =3D - match t.Packet.ty with - | Op.Watchevent -> Watchevent - | _ -> CommandReply + match t.Packet.ty with + | Op.Watchevent -> Watchevent + | _ -> CommandReply =20 let newcon ~capacity backend =3D - let limit =3D function - | CommandReply -> capacity.maxoutstanding - | Watchevent -> capacity.maxwatchevents - in - { - backend =3D backend; - pkt_out =3D Queue.create ~capacity:(capacity.maxoutstanding + capacity.ma= xwatchevents) ~classify ~limit; - partial_in =3D init_partial_in (); - partial_out =3D ""; - capacity =3D capacity; - } + let limit =3D function + | CommandReply -> capacity.maxoutstanding + | Watchevent -> capacity.maxwatchevents + in + { + backend =3D backend; + pkt_out =3D Queue.create ~capacity:(capacity.maxoutstanding + capacity= .maxwatchevents) ~classify ~limit; + partial_in =3D init_partial_in (); + partial_out =3D ""; + capacity =3D capacity; + } =20 let open_fd fd =3D newcon (Fd { fd =3D fd; }) =20 let open_mmap mmap notifyfct =3D - (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *) - Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ri= ng.Server_feature.Reconnection); - newcon (Xenmmap { - mmap =3D mmap; - eventchn_notify =3D notifyfct; - work_again =3D false; }) + (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *) + Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_r= ing.Server_feature.Reconnection); + newcon (Xenmmap { + mmap =3D mmap; + eventchn_notify =3D notifyfct; + work_again =3D false; }) =20 let close con =3D - 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 =20 let is_fd con =3D - match con.backend with - | Fd _ -> true - | Xenmmap _ -> false + match con.backend with + | Fd _ -> true + | Xenmmap _ -> false =20 let is_mmap con =3D not (is_fd con) =20 @@ -326,19 +326,19 @@ let has_output con =3D has_new_output con || has_old_= output con let peek_output con =3D Queue.peek con.pkt_out =20 let has_partial_input con =3D 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 =3D - match con.backend with - | Fd _ -> false - | Xenmmap backend -> backend.work_again + match con.backend with + | Fd _ -> false + | Xenmmap backend -> backend.work_again =20 let is_selectable con =3D - match con.backend with - | Fd _ -> true - | Xenmmap _ -> false + match con.backend with + | Fd _ -> true + | Xenmmap _ -> false =20 let get_fd con =3D - 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 =3D - Op.operation =3D - 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 =3D + Op.operation =3D + 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 =3D - Packet.t =3D { - 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 - =3D "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 =3D + Packet.t =3D { + 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 + =3D "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/xenbu= s_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 @@ =20 CAMLprim value stub_header_size(void) { - CAMLparam0(); - CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); + CAMLparam0(); + CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); } =20 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; =20 - if (caml_string_length(s) !=3D sizeof(struct xsd_sockmsg)) - caml_failwith("xb header incomplete"); - ret =3D caml_alloc_tuple(4); - hdr =3D (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) !=3D sizeof(struct xsd_sockmsg)) + caml_failwith("xb header incomplete"); + ret =3D caml_alloc_tuple(4); + hdr =3D (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); } =20 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 =3D { - .type =3D Int_val(ty), - .tx_id =3D Int_val(tid), - .req_id =3D Int_val(rid), - .len =3D Int_val(len), - }; + CAMLparam4(tid, rid, ty, len); + CAMLlocal1(ret); + struct xsd_sockmsg xsd =3D { + .type =3D Int_val(ty), + .tx_id =3D Int_val(tid), + .req_id =3D Int_val(rid), + .len =3D Int_val(len), + }; =20 - ret =3D caml_alloc_string(sizeof(struct xsd_sockmsg)); - memcpy((char *) String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); + ret =3D caml_alloc_string(sizeof(struct xsd_sockmsg)); + memcpy((char *) String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); =20 - 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 @@ *) =20 module Server_feature =3D struct - type t =3D - | Reconnection + type t =3D + | Reconnection end =20 module Server_features =3D Set.Make(struct - type t =3D Server_feature.t - let compare =3D compare -end) + type t =3D Server_feature.t + let compare =3D compare + end) =20 external read: Xenmmap.mmap_interface -> bytes -> int -> int =3D "ml_inter= face_read" external write: Xenmmap.mmap_interface -> bytes -> int -> int =3D "ml_inte= rface_write" @@ -31,18 +31,18 @@ external _internal_set_server_features: Xenmmap.mmap_in= terface -> int -> unit =3D external _internal_get_server_features: Xenmmap.mmap_interface -> int =3D = "ml_interface_get_server_features" [@@noalloc] =20 let write_substring mmap buff len =3D - write mmap (Bytes.unsafe_of_string buff) len + write mmap (Bytes.unsafe_of_string buff) len =20 let get_server_features mmap =3D - (* NB only one feature currently defined above *) - let x =3D _internal_get_server_features mmap in - if x =3D 0 - then Server_features.empty - else Server_features.singleton Server_feature.Reconnection + (* NB only one feature currently defined above *) + let x =3D _internal_get_server_features mmap in + if x =3D 0 + then Server_features.empty + else Server_features.singleton Server_feature.Reconnection =20 let set_server_features mmap set =3D - (* NB only one feature currently defined above *) - let x =3D if set =3D Server_features.empty then 0 else 1 in - _internal_set_server_features mmap x + (* NB only one feature currently defined above *) + let x =3D if set =3D Server_features.empty then 0 else 1 in + _internal_set_server_features mmap x =20 external close: Xenmmap.mmap_interface -> unit =3D "ml_interface_close" [@= @noalloc] diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_r= ing_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); =20 - struct mmap_interface *interface =3D GET_C_STRUCT(ml_interface); - unsigned char *buffer =3D Bytes_val(ml_buffer); - int len =3D Int_val(ml_len); - int result; + struct mmap_interface *interface =3D GET_C_STRUCT(ml_interface); + unsigned char *buffer =3D Bytes_val(ml_buffer); + int len =3D Int_val(ml_len); + int result; =20 - struct xenstore_domain_interface *intf =3D interface->addr; - XENSTORE_RING_IDX cons, prod; /* offsets only */ - int total_data, data; - uint32_t connection; + struct xenstore_domain_interface *intf =3D interface->addr; + XENSTORE_RING_IDX cons, prod; /* offsets only */ + int total_data, data; + uint32_t connection; =20 - cons =3D *(volatile uint32_t*)&intf->req_cons; - prod =3D *(volatile uint32_t*)&intf->req_prod; - connection =3D *(volatile uint32_t*)&intf->connection; + cons =3D *(volatile uint32_t*)&intf->req_cons; + prod =3D *(volatile uint32_t*)&intf->req_prod; + connection =3D *(volatile uint32_t*)&intf->connection; =20 - if (connection !=3D XENSTORE_CONNECTED) - caml_raise_constant(*caml_named_value("Xb.Reconnect")); + if (connection !=3D XENSTORE_CONNECTED) + caml_raise_constant(*caml_named_value("Xb.Reconnect")); =20 - xen_mb(); + xen_mb(); =20 - if ((prod - cons) > XENSTORE_RING_SIZE) - caml_failwith("bad connection"); + if ((prod - cons) > XENSTORE_RING_SIZE) + caml_failwith("bad connection"); =20 - /* Check for any pending data at all. */ - total_data =3D prod - cons; - if (total_data =3D=3D 0) { - /* No pending data at all. */ - result =3D 0; - goto exit; - } - else if (total_data < len) - /* Some data - make a partial read. */ - len =3D total_data; + /* Check for any pending data at all. */ + total_data =3D prod - cons; + if (total_data =3D=3D 0) { + /* No pending data at all. */ + result =3D 0; + goto exit; + } + else if (total_data < len) + /* Some data - make a partial read. */ + len =3D total_data; =20 - /* Check whether data crosses the end of the ring. */ - data =3D 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 =3D 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); + } =20 - xen_mb(); - intf->req_cons +=3D len; - result =3D len; + xen_mb(); + intf->req_cons +=3D len; + result =3D len; exit: - ml_result =3D Val_int(result); - CAMLreturn(ml_result); + ml_result =3D Val_int(result); + CAMLreturn(ml_result); } =20 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); =20 - struct mmap_interface *interface =3D GET_C_STRUCT(ml_interface); - const unsigned char *buffer =3D Bytes_val(ml_buffer); - int len =3D Int_val(ml_len); - int result; + struct mmap_interface *interface =3D GET_C_STRUCT(ml_interface); + const unsigned char *buffer =3D Bytes_val(ml_buffer); + int len =3D Int_val(ml_len); + int result; =20 - struct xenstore_domain_interface *intf =3D interface->addr; - XENSTORE_RING_IDX cons, prod; - int total_space, space; - uint32_t connection; + struct xenstore_domain_interface *intf =3D interface->addr; + XENSTORE_RING_IDX cons, prod; + int total_space, space; + uint32_t connection; =20 - cons =3D *(volatile uint32_t*)&intf->rsp_cons; - prod =3D *(volatile uint32_t*)&intf->rsp_prod; - connection =3D *(volatile uint32_t*)&intf->connection; + cons =3D *(volatile uint32_t*)&intf->rsp_cons; + prod =3D *(volatile uint32_t*)&intf->rsp_prod; + connection =3D *(volatile uint32_t*)&intf->connection; =20 - if (connection !=3D XENSTORE_CONNECTED) - caml_raise_constant(*caml_named_value("Xb.Reconnect")); + if (connection !=3D XENSTORE_CONNECTED) + caml_raise_constant(*caml_named_value("Xb.Reconnect")); =20 - xen_mb(); + xen_mb(); =20 - if ((prod - cons) > XENSTORE_RING_SIZE) - caml_failwith("bad connection"); + if ((prod - cons) > XENSTORE_RING_SIZE) + caml_failwith("bad connection"); =20 - /* Check for space to write the full message. */ - total_space =3D XENSTORE_RING_SIZE - (prod - cons); - if (total_space =3D=3D 0) { - /* No space at all - exit having done nothing. */ - result =3D 0; - goto exit; - } - else if (total_space < len) - /* Some space - make a partial write. */ - len =3D total_space; + /* Check for space to write the full message. */ + total_space =3D XENSTORE_RING_SIZE - (prod - cons); + if (total_space =3D=3D 0) { + /* No space at all - exit having done nothing. */ + result =3D 0; + goto exit; + } + else if (total_space < len) + /* Some space - make a partial write. */ + len =3D total_space; =20 - /* Check for space until the ring wraps. */ - space =3D 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 =3D 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); + } =20 - xen_mb(); - intf->rsp_prod +=3D len; - result =3D len; + xen_mb(); + intf->rsp_prod +=3D len; + result =3D len; exit: - ml_result =3D Val_int(result); - CAMLreturn(ml_result); + ml_result =3D Val_int(result); + CAMLreturn(ml_result); } =20 CAMLprim value ml_interface_set_server_features(value interface, value v) { - CAMLparam2(interface, v); - struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->addr; - if (intf =3D=3D (void*)MAP_FAILED) - caml_failwith("Interface closed"); + CAMLparam2(interface, v); + struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->ad= dr; + if (intf =3D=3D (void*)MAP_FAILED) + caml_failwith("Interface closed"); =20 - intf->server_features =3D Int_val(v); + intf->server_features =3D Int_val(v); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 CAMLprim value ml_interface_get_server_features(value interface) { - CAMLparam1(interface); - struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->addr; + CAMLparam1(interface); + struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->ad= dr; =20 - CAMLreturn(Val_int (intf->server_features)); + CAMLreturn(Val_int (intf->server_features)); } =20 CAMLprim value ml_interface_close(value interface) { - CAMLparam1(interface); - struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->addr; - int i; + CAMLparam1(interface); + struct xenstore_domain_interface *intf =3D GET_C_STRUCT(interface)->ad= dr; + int i; =20 - intf->req_cons =3D intf->req_prod =3D intf->rsp_cons =3D intf->rsp_prod = =3D 0; - /* Ensure the unused space is full of invalid xenstore packets. */ - for (i =3D 0; i < XENSTORE_RING_SIZE; i++) { - intf->req[i] =3D 0xff; /* XS_INVALID =3D 0xffff */ - intf->rsp[i] =3D 0xff; - } - xen_mb (); - intf->connection =3D XENSTORE_CONNECTED; - CAMLreturn(Val_unit); + intf->req_cons =3D intf->req_prod =3D intf->rsp_cons =3D intf->rsp_pro= d =3D 0; + /* Ensure the unused space is full of invalid xenstore packets. */ + for (i =3D 0; i < XENSTORE_RING_SIZE; i++) { + intf->req[i] =3D 0xff; /* XS_INVALID =3D 0xffff */ + intf->rsp[i] =3D 0xff; + } + xen_mb (); + intf->connection =3D 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 () { } } 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 =3D split /\s+/, $1; if ($cline =3D=3D 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 =3D int (* ** xenctrl.h ** *) =20 type vcpuinfo =3D -{ - online: bool; - blocked: bool; - running: bool; - cputime: int64; - cpumap: int32; -} + { + online: bool; + blocked: bool; + running: bool; + cputime: int64; + cpumap: int32; + } =20 type xen_arm_arch_domainconfig =3D -{ - gic_version: int; - nr_spis: int; - clock_frequency: int32; -} + { + gic_version: int; + nr_spis: int; + clock_frequency: int32; + } =20 type x86_arch_emulation_flags =3D - | 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 =20 type x86_arch_misc_flags =3D - | X86_MSR_RELAXED - | X86_ASSISTED_XAPIC - | X86_ASSISTED_X2APIC + | X86_MSR_RELAXED + | X86_ASSISTED_XAPIC + | X86_ASSISTED_X2APIC =20 type xen_x86_arch_domainconfig =3D -{ - 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; + } =20 type arch_domainconfig =3D - | ARM of xen_arm_arch_domainconfig - | X86 of xen_x86_arch_domainconfig + | ARM of xen_arm_arch_domainconfig + | X86 of xen_x86_arch_domainconfig =20 type domain_create_flag =3D - | 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 =20 type domain_create_iommu_opts =3D - | IOMMU_NO_SHAREPT + | IOMMU_NO_SHAREPT =20 type domctl_create_config =3D -{ - 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; + } =20 type domaininfo =3D -{ - 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; + } =20 type sched_control =3D -{ - weight : int; - cap : int; -} + { + weight : int; + cap : int; + } =20 type physinfo_cap_flag =3D - | 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 =20 type arm_physinfo_cap_flag =20 type x86_physinfo_cap_flag =3D - | CAP_X86_ASSISTED_XAPIC - | CAP_X86_ASSISTED_X2APIC + | CAP_X86_ASSISTED_XAPIC + | CAP_X86_ASSISTED_X2APIC =20 type arch_physinfo_cap_flags =3D - | 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 =20 type physinfo =3D -{ - 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; + } =20 type version =3D -{ - major : int; - minor : int; - extra : string; -} + { + major : int; + minor : int; + extra : string; + } =20 =20 type compile_info =3D -{ - compiler : string; - compile_by : string; - compile_domain : string; - compile_date : string; -} + { + compiler : string; + compile_by : string; + compile_domain : string; + compile_date : string; + } =20 type shutdown_reason =3D Poweroff | Reboot | Suspend | Crash | Watchdog | = Soft_reset =20 @@ -186,34 +186,34 @@ let handle =3D ref None let get_handle () =3D !handle =20 let close_handle () =3D - match !handle with - | Some h -> handle :=3D None; interface_close h - | None -> () + match !handle with + | Some h -> handle :=3D None; interface_close h + | None -> () =20 let with_intf f =3D - match !handle with - | Some h -> f h - | None -> - let h =3D - try interface_open () with - | e -> - let msg =3D Printexc.to_string e in - failwith ("failed to open xenctrl: "^msg) - in - handle :=3D Some h; - f h + match !handle with + | Some h -> f h + | None -> + let h =3D + try interface_open () with + | e -> + let msg =3D Printexc.to_string e in + failwith ("failed to open xenctrl: "^msg) + in + handle :=3D Some h; + f h =20 external domain_create_stub: handle -> domid -> domctl_create_config -> do= mid - =3D "stub_xc_domain_create" + =3D "stub_xc_domain_create" =20 let domain_create handle ?(domid=3D0) config =3D - domain_create_stub handle domid config + domain_create_stub handle domid config =20 external domain_sethandle: handle -> domid -> string -> unit - =3D "stub_xc_domain_sethandle" + =3D "stub_xc_domain_sethandle" =20 external domain_max_vcpus: handle -> domid -> int -> unit - =3D "stub_xc_domain_max_vcpus" + =3D "stub_xc_domain_max_vcpus" =20 external domain_pause: handle -> domid -> unit =3D "stub_xc_domain_pause" external domain_unpause: handle -> domid -> unit =3D "stub_xc_domain_unpau= se" @@ -221,54 +221,54 @@ external domain_resume_fast: handle -> domid -> unit = =3D "stub_xc_domain_resume_fa external domain_destroy: handle -> domid -> unit =3D "stub_xc_domain_destr= oy" =20 external domain_shutdown: handle -> domid -> shutdown_reason -> unit - =3D "stub_xc_domain_shutdown" + =3D "stub_xc_domain_shutdown" =20 external _domain_getinfolist: handle -> domid -> int -> domaininfo list - =3D "stub_xc_domain_getinfolist" + =3D "stub_xc_domain_getinfolist" =20 let domain_getinfolist handle first_domain =3D - let nb =3D 2 in - let last_domid l =3D (List.hd l).domid + 1 in - let rec __getlist from =3D - let l =3D _domain_getinfolist handle from nb in - (if List.length l =3D nb then __getlist (last_domid l) else []) @ l - in - List.rev (__getlist first_domain) + let nb =3D 2 in + let last_domid l =3D (List.hd l).domid + 1 in + let rec __getlist from =3D + let l =3D _domain_getinfolist handle from nb in + (if List.length l =3D nb then __getlist (last_domid l) else []) @ l + in + List.rev (__getlist first_domain) =20 external domain_getinfo: handle -> domid -> domaininfo=3D "stub_xc_domain_= getinfo" =20 external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo - =3D "stub_xc_vcpu_getinfo" + =3D "stub_xc_vcpu_getinfo" =20 external domain_ioport_permission: handle -> domid -> int -> int -> bool -= > unit - =3D "stub_xc_domain_ioport_permission" + =3D "stub_xc_domain_ioport_permission" external domain_iomem_permission: handle -> domid -> nativeint -> nativein= t -> bool -> unit - =3D "stub_xc_domain_iomem_permission" + =3D "stub_xc_domain_iomem_permission" external domain_irq_permission: handle -> domid -> int -> bool -> unit - =3D "stub_xc_domain_irq_permission" + =3D "stub_xc_domain_irq_permission" =20 external vcpu_affinity_set: handle -> domid -> int -> bool array -> unit - =3D "stub_xc_vcpu_setaffinity" + =3D "stub_xc_vcpu_setaffinity" external vcpu_affinity_get: handle -> domid -> int -> bool array - =3D "stub_xc_vcpu_getaffinity" + =3D "stub_xc_vcpu_getaffinity" =20 external vcpu_context_get: handle -> domid -> int -> string - =3D "stub_xc_vcpu_context_get" + =3D "stub_xc_vcpu_context_get" =20 external sched_id: handle -> int =3D "stub_xc_sched_id" =20 external sched_credit_domain_set: handle -> domid -> sched_control -> unit - =3D "stub_sched_credit_domain_set" + =3D "stub_sched_credit_domain_set" external sched_credit_domain_get: handle -> domid -> sched_control - =3D "stub_sched_credit_domain_get" + =3D "stub_sched_credit_domain_get" =20 external shadow_allocation_set: handle -> domid -> int -> unit - =3D "stub_shadow_allocation_set" + =3D "stub_shadow_allocation_set" external shadow_allocation_get: handle -> domid -> int - =3D "stub_shadow_allocation_get" + =3D "stub_shadow_allocation_get" =20 external evtchn_alloc_unbound: handle -> domid -> domid -> int - =3D "stub_xc_evtchn_alloc_unbound" + =3D "stub_xc_evtchn_alloc_unbound" external evtchn_reset: handle -> domid -> unit =3D "stub_xc_evtchn_reset" =20 external readconsolering: handle -> string =3D "stub_xc_readconsolering" @@ -278,26 +278,26 @@ external physinfo: handle -> physinfo =3D "stub_xc_ph= ysinfo" external pcpu_info: handle -> int -> int64 array =3D "stub_xc_pcpu_info" =20 external domain_setmaxmem: handle -> domid -> int64 -> unit - =3D "stub_xc_domain_setmaxmem" + =3D "stub_xc_domain_setmaxmem" external domain_set_memmap_limit: handle -> domid -> int64 -> unit - =3D "stub_xc_domain_set_memmap_limit" + =3D "stub_xc_domain_set_memmap_limit" external domain_memory_increase_reservation: handle -> domid -> int64 -> u= nit - =3D "stub_xc_domain_memory_increase_reservation" + =3D "stub_xc_domain_memory_increase_reservation" =20 external map_foreign_range: handle -> domid -> int - -> nativeint -> Xenmmap.mmap_interface - =3D "stub_map_foreign_range" + -> nativeint -> Xenmmap.mmap_interface + =3D "stub_map_foreign_range" =20 external domain_assign_device: handle -> domid -> (int * int * int * int) = -> unit - =3D "stub_xc_domain_assign_device" + =3D "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int= ) -> unit - =3D "stub_xc_domain_deassign_device" + =3D "stub_xc_domain_deassign_device" external domain_test_assign_device: handle -> domid -> (int * int * int * = int) -> bool - =3D "stub_xc_domain_test_assign_device" + =3D "stub_xc_domain_test_assign_device" =20 external version: handle -> version =3D "stub_xc_version_version" external version_compile_info: handle -> compile_info - =3D "stub_xc_version_compile_info" + =3D "stub_xc_version_compile_info" external version_changeset: handle -> string =3D "stub_xc_version_changese= t" external version_capabilities: handle -> string =3D "stub_xc_version_capabilities" @@ -312,7 +312,7 @@ external watchdog : handle -> int -> int32 -> int =20 (** Convert the given number of pages to an amount in KiB, rounded up. - *) +*) external pages_to_kib : int64 -> int64 =3D "stub_pages_to_kib" let pages_to_mib pages =3D Int64.div (pages_to_kib pages) 1024L =20 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 -> domainin= fo external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo =3D "stub_xc_vcpu_getinfo" external domain_ioport_permission: handle -> domid -> int -> int -> bool -= > unit - =3D "stub_xc_domain_ioport_permission" + =3D "stub_xc_domain_ioport_permission" external domain_iomem_permission: handle -> domid -> nativeint -> nativein= t -> bool -> unit - =3D "stub_xc_domain_iomem_permission" + =3D "stub_xc_domain_iomem_permission" external domain_irq_permission: handle -> domid -> int -> bool -> unit - =3D "stub_xc_domain_irq_permission" + =3D "stub_xc_domain_irq_permission" external vcpu_affinity_set : handle -> domid -> int -> bool array -> unit =3D "stub_xc_vcpu_setaffinity" external vcpu_affinity_get : handle -> domid -> int -> bool array @@ -226,11 +226,11 @@ external map_foreign_range : =3D "stub_map_foreign_range" =20 external domain_assign_device: handle -> domid -> (int * int * int * int) = -> unit - =3D "stub_xc_domain_assign_device" + =3D "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int= ) -> unit - =3D "stub_xc_domain_deassign_device" + =3D "stub_xc_domain_deassign_device" external domain_test_assign_device: handle -> domid -> (int * int * int * = int) -> bool - =3D "stub_xc_domain_test_assign_device" + =3D "stub_xc_domain_test_assign_device" =20 external version : handle -> version =3D "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/xenc= trl_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 =20 #define string_of_option_array(array, index) \ - ((Field(array, index) =3D=3D Val_none) ? NULL : String_val(Field(Field(ar= ray, index), 0))) + ((Field(array, index) =3D=3D Val_none) ? NULL : String_val(Field(Field= (array, index), 0))) =20 static void Noreturn failwith_xc(xc_interface *xch) { - char error_str[XC_MAX_ERROR_MSG_LEN + 6]; - if (xch) { - const xc_error *error =3D xc_get_last_error(xch); - if (error->code =3D=3D 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 =3D xc_get_last_error(xch); + if (error->code =3D=3D 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); } =20 CAMLprim value stub_xc_interface_open(void) { - CAMLparam0(); - CAMLlocal1(result); + CAMLparam0(); + CAMLlocal1(result); =20 - result =3D caml_alloc(1, Abstract_tag); - /* Don't assert XC_OPENFLAG_NON_REENTRANT because these bindings - * do not prevent re-entrancy to libxc */ - _H(result) =3D xc_interface_open(NULL, NULL, 0); - if (_H(result) =3D=3D NULL) - failwith_xc(NULL); - CAMLreturn(result); + result =3D caml_alloc(1, Abstract_tag); + /* Don't assert XC_OPENFLAG_NON_REENTRANT because these bindings + * do not prevent re-entrancy to libxc */ + _H(result) =3D xc_interface_open(NULL, NULL, 0); + if (_H(result) =3D=3D NULL) + failwith_xc(NULL); + CAMLreturn(result); } =20 =20 CAMLprim value stub_xc_interface_close(value xch) { - CAMLparam1(xch); + CAMLparam1(xch); =20 - 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(); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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) =20 - 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]) !=3D 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]) !=3D 16 ) + { + char buf[128]; =20 - snprintf(buf, sizeof(buf), - "Xc.int_array_of_uuid_string: %s", uuid); + snprintf(buf, sizeof(buf), + "Xc.int_array_of_uuid_string: %s", uuid); =20 - caml_invalid_argument(buf); - } + caml_invalid_argument(buf); + } =20 #undef X } @@ -121,13 +121,13 @@ static void domain_handle_of_uuid_string(xen_domain_h= andle_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); =20 #if defined(__i386__) || defined(__x86_64__) /* @@ -144,43 +144,43 @@ static value c_bitmap_to_ocaml_list #include "xenctrl_abi_check.h" #endif =20 - list =3D tmp =3D Val_emptylist; + list =3D tmp =3D Val_emptylist; =20 - for ( unsigned int i =3D 0; bitmap; i++, bitmap >>=3D 1 ) - { - if ( !(bitmap & 1) ) - continue; + for ( unsigned int i =3D 0; bitmap; i++, bitmap >>=3D 1 ) + { + if ( !(bitmap & 1) ) + continue; =20 - tmp =3D caml_alloc_small(2, Tag_cons); - Field(tmp, 0) =3D Val_int(i); - Field(tmp, 1) =3D list; - list =3D tmp; - } + tmp =3D caml_alloc_small(2, Tag_cons); + Field(tmp, 0) =3D Val_int(i); + Field(tmp, 1) =3D list; + list =3D tmp; + } =20 - CAMLreturn(list); + CAMLreturn(list); } =20 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 =3D 0; + unsigned int val =3D 0; =20 - for ( ; l !=3D Val_none; l =3D Field(l, 1) ) - val |=3D 1u << Int_val(Field(l, 0)); + for ( ; l !=3D Val_none; l =3D Field(l, 1) ) + val |=3D 1u << Int_val(Field(l, 0)); =20 - return val; + return val; } =20 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); =20 - /* 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) =20 - uint32_t domid =3D Int_val(wanted_domid); - int result; - struct xen_domctl_createdomain cfg =3D { - .ssidref =3D Int32_val(VAL_SSIDREF), - .max_vcpus =3D Int_val(VAL_MAX_VCPUS), - .max_evtchn_port =3D Int_val(VAL_MAX_EVTCHN_PORT), - .max_grant_frames =3D Int_val(VAL_MAX_GRANT_FRAMES), - .max_maptrack_frames =3D Int_val(VAL_MAX_MAPTRACK_FRAMES), - .grant_opts =3D - XEN_DOMCTL_GRANT_version(Int_val(VAL_MAX_GRANT_VERSION)), - .cpupool_id =3D Int32_val(VAL_CPUPOOL_ID), - }; + uint32_t domid =3D Int_val(wanted_domid); + int result; + struct xen_domctl_createdomain cfg =3D { + .ssidref =3D Int32_val(VAL_SSIDREF), + .max_vcpus =3D Int_val(VAL_MAX_VCPUS), + .max_evtchn_port =3D Int_val(VAL_MAX_EVTCHN_PORT), + .max_grant_frames =3D Int_val(VAL_MAX_GRANT_FRAMES), + .max_maptrack_frames =3D Int_val(VAL_MAX_MAPTRACK_FRAMES), + .grant_opts =3D + XEN_DOMCTL_GRANT_version(Int_val(VAL_MAX_GRANT_VERSION)), + .cpupool_id =3D Int32_val(VAL_CPUPOOL_ID), + }; =20 - domain_handle_of_uuid_string(cfg.handle, String_val(VAL_HANDLE)); + domain_handle_of_uuid_string(cfg.handle, String_val(VAL_HANDLE)); =20 - cfg.flags =3D ocaml_list_to_c_bitmap - /* ! domain_create_flag CDF_ lc */ - /* ! XEN_DOMCTL_CDF_ XEN_DOMCTL_CDF_MAX max */ - (VAL_FLAGS); + cfg.flags =3D ocaml_list_to_c_bitmap + /* ! domain_create_flag CDF_ lc */ + /* ! XEN_DOMCTL_CDF_ XEN_DOMCTL_CDF_MAX max */ + (VAL_FLAGS); =20 - cfg.iommu_opts =3D 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 =3D ocaml_list_to_c_bitmap + /* ! domain_create_iommu_opts IOMMU_ lc */ + /* ! XEN_DOMCTL_IOMMU_ XEN_DOMCTL_IOMMU_MAX max */ + (VAL_IOMMU_OPTS); =20 - arch_domconfig =3D Field(VAL_ARCH, 0); - switch ( Tag_val(VAL_ARCH) ) - { - case 0: /* ARM - nothing to do */ - caml_failwith("Unhandled: ARM"); - break; + arch_domconfig =3D Field(VAL_ARCH, 0); + switch ( Tag_val(VAL_ARCH) ) + { + case 0: /* ARM - nothing to do */ + caml_failwith("Unhandled: ARM"); + break; =20 - case 1: /* X86 - emulation flags in the block */ + case 1: /* X86 - emulation flags in the block */ #if defined(__i386__) || defined(__x86_64__) =20 - /* Quick & dirty check for ABI changes. */ - BUILD_BUG_ON(sizeof(cfg) !=3D 64); + /* Quick & dirty check for ABI changes. */ + BUILD_BUG_ON(sizeof(cfg) !=3D 64); =20 /* 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) =20 - cfg.arch.emulation_flags =3D 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 =3D ocaml_list_to_c_bitmap + /* ! x86_arch_emulation_flags X86_EMU_ none */ + /* ! XEN_X86_EMU_ XEN_X86_EMU_ALL all */ + (VAL_EMUL_FLAGS); =20 - cfg.arch.misc_flags =3D 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 =3D ocaml_list_to_c_bitmap + /* ! x86_arch_misc_flags X86_ none */ + /* ! XEN_X86_ XEN_X86_MISC_FLAGS_MAX max */ + (VAL_MISC_FLAGS); =20 #undef VAL_MISC_FLAGS #undef VAL_EMUL_FLAGS =20 #else - caml_failwith("Unhandled: x86"); + caml_failwith("Unhandled: x86"); #endif - break; + break; =20 - default: - caml_failwith("Unhandled domconfig type"); - } + default: + caml_failwith("Unhandled domconfig type"); + } =20 #undef VAL_ARCH #undef VAL_CPUPOOL_ID @@ -269,875 +269,875 @@ CAMLprim value stub_xc_domain_create(value xch, val= ue wanted_domid, value config #undef VAL_HANDLE #undef VAL_SSIDREF =20 - caml_enter_blocking_section(); - result =3D xc_domain_create(_H(xch), &domid, &cfg); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result =3D xc_domain_create(_H(xch), &domid, &cfg); + caml_leave_blocking_section(); =20 - if (result < 0) - failwith_xc(_H(xch)); + if (result < 0) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_int(domid)); + CAMLreturn(Val_int(domid)); } =20 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; =20 - r =3D xc_domain_max_vcpus(_H(xch), _D(domid), Int_val(max_vcpus)); - if (r) - failwith_xc(_H(xch)); + r =3D xc_domain_max_vcpus(_H(xch), _D(domid), Int_val(max_vcpus)); + if (r) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 =20 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; =20 - domain_handle_of_uuid_string(h, String_val(handle)); + domain_handle_of_uuid_string(h, String_val(handle)); =20 - i =3D xc_domain_sethandle(_H(xch), _D(domid), h); - if (i) - failwith_xc(_H(xch)); + i =3D xc_domain_sethandle(_H(xch), _D(domid), h); + if (i) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 static value dom_op(value xch, value domid, int (*fn)(xc_interface *, uint= 32_t)) { - CAMLparam2(xch, domid); - int result; + CAMLparam2(xch, domid); + int result; =20 - uint32_t c_domid =3D _D(domid); + uint32_t c_domid =3D _D(domid); =20 - caml_enter_blocking_section(); - result =3D fn(_H(xch), c_domid); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result =3D 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); } =20 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); } =20 =20 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); } =20 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); } =20 CAMLprim value stub_xc_domain_resume_fast(value xch, value domid) { - CAMLparam2(xch, domid); - int result; + CAMLparam2(xch, domid); + int result; =20 - uint32_t c_domid =3D _D(domid); + uint32_t c_domid =3D _D(domid); =20 - caml_enter_blocking_section(); - result =3D xc_domain_resume(_H(xch), c_domid, 1); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result =3D 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); } =20 CAMLprim value stub_xc_domain_shutdown(value xch, value domid, value reaso= n) { - CAMLparam3(xch, domid, reason); - int ret; + CAMLparam3(xch, domid, reason); + int ret; =20 - ret =3D xc_domain_shutdown(_H(xch), _D(domid), Int_val(reason)); - if (ret < 0) - failwith_xc(_H(xch)); + ret =3D xc_domain_shutdown(_H(xch), _D(domid), Int_val(reason)); + if (ret < 0) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - result =3D caml_alloc_tuple(17); + result =3D caml_alloc_tuple(17); =20 - 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_shutdownshi= ft) + & 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)); =20 tmp =3D caml_alloc_small(16, 0); - for (i =3D 0; i < 16; i++) { - Field(tmp, i) =3D Val_int(info->handle[i]); - } + for (i =3D 0; i < 16; i++) { + Field(tmp, i) =3D Val_int(info->handle[i]); + } =20 - Store_field(result, 15, tmp); + Store_field(result, 15, tmp); =20 #if defined(__i386__) || defined(__x86_64__) - /* - * emulation_flags: x86_arch_emulation_flags list; - */ - emul_list =3D c_bitmap_to_ocaml_list - /* ! x86_arch_emulation_flags */ - (info->arch_config.emulation_flags); + /* + * emulation_flags: x86_arch_emulation_flags list; + */ + emul_list =3D c_bitmap_to_ocaml_list + /* ! x86_arch_emulation_flags */ + (info->arch_config.emulation_flags); =20 - /* xen_x86_arch_domainconfig */ - x86_arch_config =3D caml_alloc_tuple(1); - Store_field(x86_arch_config, 0, emul_list); + /* xen_x86_arch_domainconfig */ + x86_arch_config =3D caml_alloc_tuple(1); + Store_field(x86_arch_config, 0, emul_list); =20 - /* arch_config: arch_domainconfig */ - arch_config =3D caml_alloc_small(1, 1); + /* arch_config: arch_domainconfig */ + arch_config =3D caml_alloc_small(1, 1); =20 - Store_field(arch_config, 0, x86_arch_config); + Store_field(arch_config, 0, x86_arch_config); =20 - Store_field(result, 16, arch_config); + Store_field(result, 16, arch_config); #endif =20 - CAMLreturn(result); + CAMLreturn(result); } =20 CAMLprim value stub_xc_domain_getinfolist(value xch, value first_domain, v= alue 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; =20 - /* get the minimum number of allocate byte we need and bump it up to page= boundary */ - toalloc =3D (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff; - ret =3D 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 p= age boundary */ + toalloc =3D (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff; + ret =3D posix_memalign((void **) ((void *) &info), 4096, toalloc); + if (ret) + caml_raise_out_of_memory(); =20 - result =3D temp =3D Val_emptylist; + result =3D temp =3D Val_emptylist; =20 - c_first_domain =3D _D(first_domain); - c_max_domains =3D Int_val(nb); - caml_enter_blocking_section(); - retval =3D xc_domain_getinfolist(_H(xch), c_first_domain, - c_max_domains, info); - caml_leave_blocking_section(); + c_first_domain =3D _D(first_domain); + c_max_domains =3D Int_val(nb); + caml_enter_blocking_section(); + retval =3D xc_domain_getinfolist(_H(xch), c_first_domain, + c_max_domains, info); + caml_leave_blocking_section(); =20 - if (retval < 0) { - free(info); - failwith_xc(_H(xch)); - } - for (i =3D 0; i < retval; i++) { - result =3D caml_alloc_small(2, Tag_cons); - Field(result, 0) =3D Val_int(0); - Field(result, 1) =3D temp; - temp =3D result; + if (retval < 0) { + free(info); + failwith_xc(_H(xch)); + } + for (i =3D 0; i < retval; i++) { + result =3D caml_alloc_small(2, Tag_cons); + Field(result, 0) =3D Val_int(0); + Field(result, 1) =3D temp; + temp =3D result; =20 - Store_field(result, 0, alloc_domaininfo(info + i)); - } + Store_field(result, 0, alloc_domaininfo(info + i)); + } =20 - free(info); - CAMLreturn(result); + free(info); + CAMLreturn(result); } =20 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; =20 - ret =3D xc_domain_getinfolist(_H(xch), _D(domid), 1, &info); - if (ret !=3D 1) - failwith_xc(_H(xch)); - if (info.domain !=3D _D(domid)) - failwith_xc(_H(xch)); + ret =3D xc_domain_getinfolist(_H(xch), _D(domid), 1, &info); + if (ret !=3D 1) + failwith_xc(_H(xch)); + if (info.domain !=3D _D(domid)) + failwith_xc(_H(xch)); =20 - result =3D alloc_domaininfo(&info); - CAMLreturn(result); + result =3D alloc_domaininfo(&info); + CAMLreturn(result); } =20 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; =20 - uint32_t c_domid =3D _D(domid); - uint32_t c_vcpu =3D Int_val(vcpu); - caml_enter_blocking_section(); - retval =3D 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 =3D _D(domid); + uint32_t c_vcpu =3D Int_val(vcpu); + caml_enter_blocking_section(); + retval =3D xc_vcpu_getinfo(_H(xch), c_domid, + c_vcpu, &info); + caml_leave_blocking_section(); + if (retval < 0) + failwith_xc(_H(xch)); =20 - result =3D 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 =3D 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)); =20 - CAMLreturn(result); + CAMLreturn(result); } =20 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; =20 - ret =3D xc_vcpu_getcontext(_H(xch), _D(domid), Int_val(cpu), &ctxt); - if ( ret < 0 ) - failwith_xc(_H(xch)); + ret =3D xc_vcpu_getcontext(_H(xch), _D(domid), Int_val(cpu), &ctxt); + if ( ret < 0 ) + failwith_xc(_H(xch)); =20 - context =3D caml_alloc_string(sizeof(ctxt)); - memcpy((char *) String_val(context), &ctxt.c, sizeof(ctxt.c)); + context =3D caml_alloc_string(sizeof(ctxt)); + memcpy((char *) String_val(context), &ctxt.c, sizeof(ctxt.c)); =20 - CAMLreturn(context); + CAMLreturn(context); } =20 static int get_cpumap_len(value xch, value cpumap) { - int ml_len =3D Wosize_val(cpumap); - int xc_len =3D xc_get_max_cpus(_H(xch)); + int ml_len =3D Wosize_val(cpumap); + int xc_len =3D xc_get_max_cpus(_H(xch)); =20 - if (ml_len < xc_len) - return ml_len; - else - return xc_len; + if (ml_len < xc_len) + return ml_len; + else + return xc_len; } =20 CAMLprim value stub_xc_vcpu_setaffinity(value xch, value domid, value vcpu, value cpumap) { - CAMLparam4(xch, domid, vcpu, cpumap); - int i, len =3D get_cpumap_len(xch, cpumap); - xc_cpumap_t c_cpumap; - int retval; + CAMLparam4(xch, domid, vcpu, cpumap); + int i, len =3D get_cpumap_len(xch, cpumap); + xc_cpumap_t c_cpumap; + int retval; =20 - c_cpumap =3D xc_cpumap_alloc(_H(xch)); - if (c_cpumap =3D=3D NULL) - failwith_xc(_H(xch)); + c_cpumap =3D xc_cpumap_alloc(_H(xch)); + if (c_cpumap =3D=3D NULL) + failwith_xc(_H(xch)); =20 - for (i=3D0; i=3D 0) { - size +=3D count - 1; - if (size < count) - break; + while (count =3D=3D size && ret >=3D 0) { + size +=3D count - 1; + if (size < count) + break; =20 - ptr =3D realloc(str, size); - if (!ptr) - break; + ptr =3D realloc(str, size); + if (!ptr) + break; =20 - str =3D ptr + count; - count =3D size - count; + str =3D ptr + count; + count =3D size - count; =20 - caml_enter_blocking_section(); - ret =3D xc_readconsolering(_H(xch), str, &count, 0, 1, &index); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D xc_readconsolering(_H(xch), str, &count, 0, 1, &index); + caml_leave_blocking_section(); =20 - count +=3D str - ptr; - str =3D ptr; - } + count +=3D str - ptr; + str =3D ptr; + } =20 - /* - * 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 =3D 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 =3D size; =20 - ring =3D caml_alloc_string(count); - memcpy((char *) String_val(ring), str, count); - free(str); + ring =3D caml_alloc_string(count); + memcpy((char *) String_val(ring), str, count); + free(str); =20 - CAMLreturn(ring); + CAMLreturn(ring); } =20 CAMLprim value stub_xc_send_debug_keys(value xch, value keys) { - CAMLparam2(xch, keys); - int r; + CAMLparam2(xch, keys); + int r; =20 - r =3D xc_send_debug_keys(_H(xch), String_val(keys)); - if (r) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + r =3D xc_send_debug_keys(_H(xch), String_val(keys)); + if (r) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } =20 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; =20 - caml_enter_blocking_section(); - r =3D xc_physinfo(_H(xch), &c_physinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + r =3D xc_physinfo(_H(xch), &c_physinfo); + caml_leave_blocking_section(); =20 - if (r) - failwith_xc(_H(xch)); + if (r) + failwith_xc(_H(xch)); =20 - /* - * capabilities: physinfo_cap_flag list; - */ - cap_list =3D 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 =3D c_bitmap_to_ocaml_list + /* ! physinfo_cap_flag CAP_ lc */ + /* ! XEN_SYSCTL_PHYSCAP_ XEN_SYSCTL_PHYSCAP_MAX max */ + (c_physinfo.capabilities); =20 - physinfo =3D 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 =3D 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)); =20 #if defined(__i386__) || defined(__x86_64__) - arch_cap_list =3D 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 =3D 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); =20 - arch_cap_flags_tag =3D 1; /* tag x86 */ + arch_cap_flags_tag =3D 1; /* tag x86 */ #else - caml_failwith("Unhandled architecture"); + caml_failwith("Unhandled architecture"); #endif =20 - arch_cap_flags =3D 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 =3D caml_alloc_small(1, arch_cap_flags_tag); + Store_field(arch_cap_flags, 0, arch_cap_list); + Store_field(physinfo, 10, arch_cap_flags); =20 - CAMLreturn(physinfo); + CAMLreturn(physinfo); } =20 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; =20 - if (Int_val(nr_cpus) < 1) - caml_invalid_argument("nr_cpus"); + if (Int_val(nr_cpus) < 1) + caml_invalid_argument("nr_cpus"); =20 - info =3D calloc(Int_val(nr_cpus) + 1, sizeof(*info)); - if (!info) - caml_raise_out_of_memory(); + info =3D calloc(Int_val(nr_cpus) + 1, sizeof(*info)); + if (!info) + caml_raise_out_of_memory(); =20 - caml_enter_blocking_section(); - r =3D xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + r =3D xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size); + caml_leave_blocking_section(); =20 - if (r) { - free(info); - failwith_xc(_H(xch)); - } + if (r) { + free(info); + failwith_xc(_H(xch)); + } =20 - if (size > 0) { - int i; - pcpus =3D caml_alloc(size, 0); - for (i =3D 0; i < size; i++) { - v =3D caml_copy_int64(info[i].idletime); - caml_modify(&Field(pcpus, i), v); - } - } else - pcpus =3D Atom(0); - free(info); - CAMLreturn(pcpus); + if (size > 0) { + int i; + pcpus =3D caml_alloc(size, 0); + for (i =3D 0; i < size; i++) { + v =3D caml_copy_int64(info[i].idletime); + caml_modify(&Field(pcpus, i), v); + } + } else + pcpus =3D Atom(0); + free(info); + CAMLreturn(pcpus); } =20 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; =20 - uint32_t c_domid =3D _D(domid); - unsigned int c_max_memkb =3D Int64_val(max_memkb); - caml_enter_blocking_section(); - retval =3D 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 =3D _D(domid); + unsigned int c_max_memkb =3D Int64_val(max_memkb); + caml_enter_blocking_section(); + retval =3D xc_domain_setmaxmem(_H(xch), c_domid, + c_max_memkb); + caml_leave_blocking_section(); + if (retval) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } =20 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; =20 - v =3D Int64_val(map_limitkb); - retval =3D xc_domain_set_memmap_limit(_H(xch), _D(domid), v); - if (retval) - failwith_xc(_H(xch)); + v =3D Int64_val(map_limitkb); + retval =3D xc_domain_set_memmap_limit(_H(xch), _D(domid), v); + if (retval) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - unsigned long nr_extents =3D ((unsigned long)(Int64_val(mem_kb))) >> (XC_= PAGE_SHIFT - 10); + unsigned long nr_extents =3D ((unsigned long)(Int64_val(mem_kb))) >> (= XC_PAGE_SHIFT - 10); =20 - uint32_t c_domid =3D _D(domid); - caml_enter_blocking_section(); - retval =3D xc_domain_increase_reservation_exact(_H(xch), c_domid, - nr_extents, 0, 0, NULL); - caml_leave_blocking_section(); + uint32_t c_domid =3D _D(domid); + caml_enter_blocking_section(); + retval =3D xc_domain_increase_reservation_exact(_H(xch), c_domid, + nr_extents, 0, 0, NULL); + caml_leave_blocking_section(); =20 - if (retval) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (retval) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } =20 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; =20 - caml_enter_blocking_section(); - packed =3D xc_version(_H(xch), XENVER_version, NULL); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + packed =3D xc_version(_H(xch), XENVER_version, NULL); + caml_leave_blocking_section(); =20 - if (packed < 0) - failwith_xc(_H(xch)); + if (packed < 0) + failwith_xc(_H(xch)); =20 - caml_enter_blocking_section(); - retval =3D xc_version(_H(xch), XENVER_extraversion, &extra); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval =3D xc_version(_H(xch), XENVER_extraversion, &extra); + caml_leave_blocking_section(); =20 - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); =20 - result =3D caml_alloc_tuple(3); + result =3D caml_alloc_tuple(3); =20 - 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)); =20 - CAMLreturn(result); + CAMLreturn(result); } =20 =20 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; =20 - caml_enter_blocking_section(); - retval =3D xc_version(_H(xch), XENVER_compile_info, &ci); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval =3D xc_version(_H(xch), XENVER_compile_info, &ci); + caml_leave_blocking_section(); =20 - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); =20 - result =3D caml_alloc_tuple(4); + result =3D caml_alloc_tuple(4); =20 - 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)); =20 - CAMLreturn(result); + CAMLreturn(result); } =20 =20 static value xc_version_single_string(value xch, int code, void *info) { - CAMLparam1(xch); - int retval; + CAMLparam1(xch); + int retval; =20 - caml_enter_blocking_section(); - retval =3D xc_version(_H(xch), code, info); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval =3D xc_version(_H(xch), code, info); + caml_leave_blocking_section(); =20 - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); =20 - CAMLreturn(caml_copy_string((char *)info)); + CAMLreturn(caml_copy_string((char *)info)); } =20 =20 CAMLprim value stub_xc_version_changeset(value xch) { - xen_changeset_info_t ci; + xen_changeset_info_t ci; =20 - return xc_version_single_string(xch, XENVER_changeset, &ci); + return xc_version_single_string(xch, XENVER_changeset, &ci); } =20 =20 CAMLprim value stub_xc_version_capabilities(value xch) { - xen_capabilities_info_t ci; + xen_capabilities_info_t ci; =20 - return xc_version_single_string(xch, XENVER_capabilities, &ci); + return xc_version_single_string(xch, XENVER_capabilities, &ci); } =20 =20 CAMLprim value stub_pages_to_kib(value pages) { - CAMLparam1(pages); + CAMLparam1(pages); =20 - CAMLreturn(caml_copy_int64(Int64_val(pages) << (XC_PAGE_SHIFT - 10))); + CAMLreturn(caml_copy_int64(Int64_val(pages) << (XC_PAGE_SHIFT - 10))); } =20 =20 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; =20 - result =3D caml_alloc(sizeof(struct mmap_interface), Abstract_tag); - intf =3D (struct mmap_interface *) result; + result =3D caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + intf =3D (struct mmap_interface *) result; =20 - intf->len =3D Int_val(size); + intf->len =3D Int_val(size); =20 - c_dom =3D _D(dom); - c_mfn =3D Nativeint_val(mfn); - caml_enter_blocking_section(); - intf->addr =3D 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 =3D _D(dom); + c_mfn =3D Nativeint_val(mfn); + caml_enter_blocking_section(); + intf->addr =3D 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); } =20 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; =20 - caml_enter_blocking_section(); - ret =3D xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom); - caml_leave_blocking_section(); - if (ret !=3D 0) - failwith_xc(_H(xch)); + caml_enter_blocking_section(); + ret =3D xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom); + caml_leave_blocking_section(); + if (ret !=3D 0) + failwith_xc(_H(xch)); =20 - sdom =3D caml_alloc_tuple(2); - Store_field(sdom, 0, Val_int(c_sdom.weight)); - Store_field(sdom, 1, Val_int(c_sdom.cap)); + sdom =3D caml_alloc_tuple(2); + Store_field(sdom, 0, Val_int(c_sdom.weight)); + Store_field(sdom, 1, Val_int(c_sdom.cap)); =20 - CAMLreturn(sdom); + CAMLreturn(sdom); } =20 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; =20 - c_sdom.weight =3D Int_val(Field(sdom, 0)); - c_sdom.cap =3D Int_val(Field(sdom, 1)); - caml_enter_blocking_section(); - ret =3D xc_sched_credit_domain_set(_H(xch), _D(domid), &c_sdom); - caml_leave_blocking_section(); - if (ret !=3D 0) - failwith_xc(_H(xch)); + c_sdom.weight =3D Int_val(Field(sdom, 0)); + c_sdom.cap =3D Int_val(Field(sdom, 1)); + caml_enter_blocking_section(); + ret =3D xc_sched_credit_domain_set(_H(xch), _D(domid), &c_sdom); + caml_leave_blocking_section(); + if (ret !=3D 0) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - caml_enter_blocking_section(); - ret =3D xc_shadow_control(_H(xch), _D(domid), - XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION, - &c_mb, 0); - caml_leave_blocking_section(); - if (ret !=3D 0) - failwith_xc(_H(xch)); + caml_enter_blocking_section(); + ret =3D xc_shadow_control(_H(xch), _D(domid), + XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION, + &c_mb, 0); + caml_leave_blocking_section(); + if (ret !=3D 0) + failwith_xc(_H(xch)); =20 - mb =3D Val_int(c_mb); - CAMLreturn(mb); + mb =3D Val_int(c_mb); + CAMLreturn(mb); } =20 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; =20 - c_mb =3D Int_val(mb); - caml_enter_blocking_section(); - ret =3D xc_shadow_control(_H(xch), _D(domid), - XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION, - &c_mb, 0); - caml_leave_blocking_section(); - if (ret !=3D 0) - failwith_xc(_H(xch)); + c_mb =3D Int_val(mb); + caml_enter_blocking_section(); + ret =3D xc_shadow_control(_H(xch), _D(domid), + XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION, + &c_mb, 0); + caml_leave_blocking_section(); + if (ret !=3D 0) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - c_start_port =3D Int_val(start_port); - c_nr_ports =3D Int_val(nr_ports); - c_allow =3D Bool_val(allow); + c_start_port =3D Int_val(start_port); + c_nr_ports =3D Int_val(nr_ports); + c_allow =3D Bool_val(allow); =20 - ret =3D xc_domain_ioport_permission(_H(xch), _D(domid), - c_start_port, c_nr_ports, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret =3D xc_domain_ioport_permission(_H(xch), _D(domid), + c_start_port, c_nr_ports, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - c_start_pfn =3D Nativeint_val(start_pfn); - c_nr_pfns =3D Nativeint_val(nr_pfns); - c_allow =3D Bool_val(allow); + c_start_pfn =3D Nativeint_val(start_pfn); + c_nr_pfns =3D Nativeint_val(nr_pfns); + c_allow =3D Bool_val(allow); =20 - ret =3D xc_domain_iomem_permission(_H(xch), _D(domid), - c_start_pfn, c_nr_pfns, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret =3D xc_domain_iomem_permission(_H(xch), _D(domid), + c_start_pfn, c_nr_pfns, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - c_pirq =3D Int_val(pirq); - c_allow =3D Bool_val(allow); + c_pirq =3D Int_val(pirq); + c_allow =3D Bool_val(allow); =20 - ret =3D xc_domain_irq_permission(_H(xch), _D(domid), - c_pirq, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret =3D xc_domain_irq_permission(_H(xch), _D(domid), + c_pirq, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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); } =20 CAMLprim value stub_xc_domain_test_assign_device(value xch, value domid, v= alue 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; =20 - domain =3D Int_val(Field(desc, 0)); - bus =3D Int_val(Field(desc, 1)); - dev =3D Int_val(Field(desc, 2)); - func =3D Int_val(Field(desc, 3)); - sbdf =3D encode_sbdf(domain, bus, dev, func); + domain =3D Int_val(Field(desc, 0)); + bus =3D Int_val(Field(desc, 1)); + dev =3D Int_val(Field(desc, 2)); + func =3D Int_val(Field(desc, 3)); + sbdf =3D encode_sbdf(domain, bus, dev, func); =20 - ret =3D xc_test_assign_device(_H(xch), _D(domid), sbdf); + ret =3D xc_test_assign_device(_H(xch), _D(domid), sbdf); =20 - CAMLreturn(Val_bool(ret =3D=3D 0)); + CAMLreturn(Val_bool(ret =3D=3D 0)); } =20 static int domain_assign_device_rdm_flag_table[] =3D { @@ -1147,96 +1147,96 @@ static int domain_assign_device_rdm_flag_table[] = =3D { 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; =20 - domain =3D Int_val(Field(desc, 0)); - bus =3D Int_val(Field(desc, 1)); - dev =3D Int_val(Field(desc, 2)); - func =3D Int_val(Field(desc, 3)); - sbdf =3D encode_sbdf(domain, bus, dev, func); + domain =3D Int_val(Field(desc, 0)); + bus =3D Int_val(Field(desc, 1)); + dev =3D Int_val(Field(desc, 2)); + func =3D Int_val(Field(desc, 3)); + sbdf =3D encode_sbdf(domain, bus, dev, func); =20 - ret =3D Int_val(Field(rflag, 0)); - flag =3D domain_assign_device_rdm_flag_table[ret]; + ret =3D Int_val(Field(rflag, 0)); + flag =3D domain_assign_device_rdm_flag_table[ret]; =20 - ret =3D xc_assign_device(_H(xch), _D(domid), sbdf, flag); + ret =3D xc_assign_device(_H(xch), _D(domid), sbdf, flag); =20 - if (ret < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (ret < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } =20 CAMLprim value stub_xc_domain_deassign_device(value xch, value domid, valu= e 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; =20 - domain =3D Int_val(Field(desc, 0)); - bus =3D Int_val(Field(desc, 1)); - dev =3D Int_val(Field(desc, 2)); - func =3D Int_val(Field(desc, 3)); - sbdf =3D encode_sbdf(domain, bus, dev, func); + domain =3D Int_val(Field(desc, 0)); + bus =3D Int_val(Field(desc, 1)); + dev =3D Int_val(Field(desc, 2)); + func =3D Int_val(Field(desc, 3)); + sbdf =3D encode_sbdf(domain, bus, dev, func); =20 - ret =3D xc_deassign_device(_H(xch), _D(domid), sbdf); + ret =3D xc_deassign_device(_H(xch), _D(domid), sbdf); =20 - if (ret < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (ret < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } =20 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__) =20 - /* Safe, because of the global ocaml lock. */ - static uint32_t fs_len; + /* Safe, because of the global ocaml lock. */ + static uint32_t fs_len; =20 - if (fs_len =3D=3D 0) - { - int ret =3D xc_get_cpu_featureset(_H(xch), 0, &fs_len, NULL); + if (fs_len =3D=3D 0) + { + int ret =3D xc_get_cpu_featureset(_H(xch), 0, &fs_len, NULL); =20 - if (ret || (fs_len =3D=3D 0)) - failwith_xc(_H(xch)); - } + if (ret || (fs_len =3D=3D 0)) + failwith_xc(_H(xch)); + } =20 - { - /* To/from hypervisor to retrieve actual featureset */ - uint32_t fs[fs_len], len =3D fs_len; - unsigned int i; + { + /* To/from hypervisor to retrieve actual featureset */ + uint32_t fs[fs_len], len =3D fs_len; + unsigned int i; =20 - int ret =3D xc_get_cpu_featureset(_H(xch), Int_val(idx), &len, fs); + int ret =3D xc_get_cpu_featureset(_H(xch), Int_val(idx), &len, fs); =20 - if (ret) - failwith_xc(_H(xch)); + if (ret) + failwith_xc(_H(xch)); =20 - bitmap_val =3D caml_alloc(len, 0); + bitmap_val =3D caml_alloc(len, 0); =20 - for (i =3D 0; i < len; ++i) - Store_field(bitmap_val, i, caml_copy_int64(fs[i])); - } + for (i =3D 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); } =20 CAMLprim value stub_xc_watchdog(value xch, value domid, value timeout) { - CAMLparam3(xch, domid, timeout); - int ret; - unsigned int c_timeout =3D Int32_val(timeout); + CAMLparam3(xch, domid, timeout); + int ret; + unsigned int c_timeout =3D Int32_val(timeout); =20 - ret =3D xc_watchdog(_H(xch), _D(domid), c_timeout); - if (ret < 0) - failwith_xc(_H(xch)); + ret =3D xc_watchdog(_H(xch), _D(domid), c_timeout); + if (ret < 0) + failwith_xc(_H(xch)); =20 - CAMLreturn(Val_int(ret)); + CAMLreturn(Val_int(ret)); } =20 /* diff --git a/tools/ocaml/libs/xentoollog/caml_xentoollog.h b/tools/ocaml/li= bs/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 @@ */ =20 struct caml_xtl { - xentoollog_logger vtable; - char *vmessage_cb; - char *progress_cb; + xentoollog_logger vtable; + char *vmessage_cb; + char *progress_cb; }; =20 #define Xtl_val(x)(*((struct caml_xtl **) Data_custom_val(x))) diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/l= ibs/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 =3D caml__frame; \ =20 static char * dup_String_val(value s) { - int len; - char *c; - len =3D caml_string_length(s); - c =3D 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 =3D caml_string_length(s); + c =3D calloc(len + 1, sizeof(char)); + if (!c) + caml_raise_out_of_memory(); + memcpy(c, String_val(s), len); + return c; } =20 #include "_xtl_levels.inc" @@ -62,144 +62,144 @@ static char * dup_String_val(value s) =20 static value Val_some(value v) { - CAMLparam1(v); - CAMLlocal1(some); - some =3D caml_alloc(1, 0); - Store_field(some, 0, v); - CAMLreturn(some); + CAMLparam1(v); + CAMLlocal1(some); + some =3D caml_alloc(1, 0); + Store_field(some, 0, v); + CAMLreturn(some); } =20 static value Val_errno(int errnoval) { - if (errnoval =3D=3D -1) - return Val_none; - return Val_some(Val_int(errnoval)); + if (errnoval =3D=3D -1) + return Val_none; + return Val_some(Val_int(errnoval)); } =20 static value Val_context(const char *context) { - if (context =3D=3D NULL) - return Val_none; - return Val_some(caml_copy_string(context)); + if (context =3D=3D NULL) + return Val_none; + return Val_some(caml_copy_string(context)); } =20 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 =3D (struct caml_xtl*)logger; - const value *func =3D caml_named_value(xtl->vmessage_cb); - char *msg; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + struct caml_xtl *xtl =3D (struct caml_xtl*)logger; + const value *func =3D caml_named_value(xtl->vmessage_cb); + char *msg; =20 - if (func =3D=3D 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 =3D=3D NULL) + caml_raise_sys_error(caml_copy_string("Unable to find callback")); + if (vasprintf(&msg, format, al) < 0) + caml_raise_out_of_memory(); =20 - /* vmessage : level -> int option -> string option -> string -> unit; */ - args[0] =3D Val_level(level); - args[1] =3D Val_errno(errnoval); - args[2] =3D Val_context(context); - args[3] =3D caml_copy_string(msg); + /* vmessage : level -> int option -> string option -> string -> unit; = */ + args[0] =3D Val_level(level); + args[1] =3D Val_errno(errnoval); + args[2] =3D Val_context(context); + args[3] =3D caml_copy_string(msg); =20 - free(msg); + free(msg); =20 - caml_callbackN(*func, 4, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 4, args); + CAMLdone; + caml_enter_blocking_section(); } =20 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 =3D (struct caml_xtl*)logger; - const value *func =3D caml_named_value(xtl->progress_cb); + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 5); + struct caml_xtl *xtl =3D (struct caml_xtl*)logger; + const value *func =3D caml_named_value(xtl->progress_cb); =20 - if (func =3D=3D NULL) - caml_raise_sys_error(caml_copy_string("Unable to find callback")); + if (func =3D=3D NULL) + caml_raise_sys_error(caml_copy_string("Unable to find callback")); =20 - /* progress : string option -> string -> int -> int64 -> int64 -> unit; */ - args[0] =3D Val_context(context); - args[1] =3D caml_copy_string(doing_what); - args[2] =3D Val_int(percent); - args[3] =3D caml_copy_int64(done); - args[4] =3D caml_copy_int64(total); + /* progress : string option -> string -> int -> int64 -> int64 -> unit= ; */ + args[0] =3D Val_context(context); + args[1] =3D caml_copy_string(doing_what); + args[2] =3D Val_int(percent); + args[3] =3D caml_copy_int64(done); + args[4] =3D caml_copy_int64(total); =20 - caml_callbackN(*func, 5, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 5, args); + CAMLdone; + caml_enter_blocking_section(); } =20 static void xtl_destroy(struct xentoollog_logger *logger) { - struct caml_xtl *xtl =3D (struct caml_xtl*)logger; - free(xtl->vmessage_cb); - free(xtl->progress_cb); - free(xtl); + struct caml_xtl *xtl =3D (struct caml_xtl*)logger; + free(xtl->vmessage_cb); + free(xtl->progress_cb); + free(xtl); } =20 void xtl_finalize(value handle) { - xtl_destroy(XTL); + xtl_destroy(XTL); } =20 static struct custom_operations xentoollogger_custom_operations =3D { - "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 }; =20 /* external _create_logger: (string * string) -> handle =3D "stub_xtl_crea= te_logger" */ CAMLprim value stub_xtl_create_logger(value cbs) { - CAMLparam1(cbs); - CAMLlocal1(handle); - struct caml_xtl *xtl =3D malloc(sizeof(*xtl)); - if (xtl =3D=3D NULL) - caml_raise_out_of_memory(); + CAMLparam1(cbs); + CAMLlocal1(handle); + struct caml_xtl *xtl =3D malloc(sizeof(*xtl)); + if (xtl =3D=3D NULL) + caml_raise_out_of_memory(); =20 - memset(xtl, 0, sizeof(*xtl)); + memset(xtl, 0, sizeof(*xtl)); =20 - xtl->vtable.vmessage =3D &stub_xtl_ocaml_vmessage; - xtl->vtable.progress =3D &stub_xtl_ocaml_progress; - xtl->vtable.destroy =3D &xtl_destroy; + xtl->vtable.vmessage =3D &stub_xtl_ocaml_vmessage; + xtl->vtable.progress =3D &stub_xtl_ocaml_progress; + xtl->vtable.destroy =3D &xtl_destroy; =20 - xtl->vmessage_cb =3D dup_String_val(Field(cbs, 0)); - xtl->progress_cb =3D dup_String_val(Field(cbs, 1)); + xtl->vmessage_cb =3D dup_String_val(Field(cbs, 0)); + xtl->progress_cb =3D dup_String_val(Field(cbs, 1)); =20 - handle =3D caml_alloc_custom(&xentoollogger_custom_operations, sizeof(xtl= ), 0, 1); - Xtl_val(handle) =3D xtl; + handle =3D caml_alloc_custom(&xentoollogger_custom_operations, sizeof(= xtl), 0, 1); + Xtl_val(handle) =3D xtl; =20 - CAMLreturn(handle); + CAMLreturn(handle); } =20 /* external test: handle -> unit =3D "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 =3D 0UL; l<=3D100UL; l +=3D 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 =3D 0UL; l<=3D100UL; l +=3D 10UL) { + xtl_progress(XTL, "progress", "testing", l, 100UL); + usleep(10000); + } + CAMLreturn(Val_unit); } =20 diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xen= light_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 =3D caml__frame; \ =20 static char * dup_String_val(value s) { - int len; - char *c; - len =3D caml_string_length(s); - c =3D 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 =3D caml_string_length(s); + c =3D calloc(len + 1, sizeof(char)); + if (!c) + caml_raise_out_of_memory(); + memcpy(c, String_val(s), len); + return c; } =20 /* Forward reference: this is defined in the auto-generated include file b= elow. */ @@ -73,157 +73,157 @@ static value Val_error (libxl_error error_c); =20 static void failwith_xl(int error, char *fname) { - CAMLparam0(); - CAMLlocal1(arg); - static const value *exc =3D NULL; + CAMLparam0(); + CAMLlocal1(arg); + static const value *exc =3D NULL; =20 - /* First time around, lookup by name */ - if (!exc) - exc =3D caml_named_value("Xenlight.Error"); + /* First time around, lookup by name */ + if (!exc) + exc =3D caml_named_value("Xenlight.Error"); =20 - if (!exc) - caml_invalid_argument("Exception Xenlight.Error not initialized, please = link xenlight.cma"); + if (!exc) + caml_invalid_argument("Exception Xenlight.Error not initialized, p= lease link xenlight.cma"); =20 - arg =3D caml_alloc(2, 0); + arg =3D caml_alloc(2, 0); =20 - 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)); =20 - caml_raise_with_arg(*exc, arg); - CAMLreturn0; + caml_raise_with_arg(*exc, arg); + CAMLreturn0; } =20 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); } =20 void ctx_finalize(value ctx) { - libxl_ctx_free(CTX); + libxl_ctx_free(CTX); } =20 static struct custom_operations libxl_ctx_custom_operations =3D { - "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 }; =20 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; =20 - ret =3D libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (xentoollog_logger *) Xtl= _val(logger)); - if (ret !=3D 0) \ - failwith_xl(ERROR_FAIL, "cannot init context"); + ret =3D libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (xentoollog_logger *) = Xtl_val(logger)); + if (ret !=3D 0) \ + failwith_xl(ERROR_FAIL, "cannot init context"); =20 - handle =3D caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0= , 1); - Ctx_val(handle) =3D ctx; + handle =3D caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx)= , 0, 1); + Ctx_val(handle) =3D ctx; =20 - CAMLreturn(handle); + CAMLreturn(handle); } =20 static int list_len(value v) { - int len =3D 0; - while ( v !=3D Val_emptylist ) { - len++; - v =3D Field(v, 1); - } - return len; + int len =3D 0; + while ( v !=3D Val_emptylist ) { + len++; + v =3D Field(v, 1); + } + return len; } =20 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; =20 - nr =3D list_len(v); + nr =3D list_len(v); =20 - array =3D calloc((nr + 1) * 2, sizeof(char *)); - if (!array) - caml_raise_out_of_memory(); + array =3D calloc((nr + 1) * 2, sizeof(char *)); + if (!array) + caml_raise_out_of_memory(); =20 - for (i=3D0; v !=3D Val_emptylist; i++, v =3D Field(v, 1) ) { - elem =3D Field(v, 0); + for (i=3D0; v !=3D Val_emptylist; i++, v =3D Field(v, 1) ) { + elem =3D Field(v, 0); =20 - array[i * 2] =3D dup_String_val(Field(elem, 0)); - array[i * 2 + 1] =3D dup_String_val(Field(elem, 1)); - } + array[i * 2] =3D dup_String_val(Field(elem, 0)); + array[i * 2 + 1] =3D dup_String_val(Field(elem, 1)); + } =20 - *c_val =3D array; - CAMLreturn(0); + *c_val =3D array; + CAMLreturn(0); } =20 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; =20 - list =3D Val_emptylist; - for (i =3D libxl_string_list_length((libxl_string_list *) c_val) - 1; i >= =3D 0; i -=3D 2) { - val =3D caml_copy_string((*c_val)[i]); - key =3D caml_copy_string((*c_val)[i - 1]); - kv =3D caml_alloc_tuple(2); - Store_field(kv, 0, key); - Store_field(kv, 1, val); + list =3D Val_emptylist; + for (i =3D libxl_string_list_length((libxl_string_list *) c_val) - 1; = i >=3D 0; i -=3D 2) { + val =3D caml_copy_string((*c_val)[i]); + key =3D caml_copy_string((*c_val)[i - 1]); + kv =3D caml_alloc_tuple(2); + Store_field(kv, 0, key); + Store_field(kv, 1, val); =20 - cons =3D caml_alloc(2, 0); - Store_field(cons, 0, kv); // head - Store_field(cons, 1, list); // tail - list =3D cons; - } + cons =3D caml_alloc(2, 0); + Store_field(cons, 0, kv); // head + Store_field(cons, 1, list); // tail + list =3D cons; + } =20 - CAMLreturn(list); + CAMLreturn(list); } =20 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; =20 - nr =3D list_len(v); + nr =3D list_len(v); =20 - array =3D calloc(nr + 1, sizeof(char *)); - if (!array) - caml_raise_out_of_memory(); + array =3D calloc(nr + 1, sizeof(char *)); + if (!array) + caml_raise_out_of_memory(); =20 - for (i=3D0; v !=3D Val_emptylist; i++, v =3D Field(v, 1) ) - array[i] =3D dup_String_val(Field(v, 0)); + for (i=3D0; v !=3D Val_emptylist; i++, v =3D Field(v, 1) ) + array[i] =3D dup_String_val(Field(v, 0)); =20 - *c_val =3D array; - CAMLreturn(0); + *c_val =3D array; + CAMLreturn(0); } =20 static value Val_string_list(libxl_string_list *c_val) { - CAMLparam0(); - CAMLlocal3(list, cons, string); - int i; + CAMLparam0(); + CAMLlocal3(list, cons, string); + int i; =20 - list =3D Val_emptylist; - for (i =3D libxl_string_list_length(c_val) - 1; i >=3D 0; i--) { - string =3D caml_copy_string((*c_val)[i]); - cons =3D caml_alloc(2, 0); - Store_field(cons, 0, string); // head - Store_field(cons, 1, list); // tail - list =3D cons; - } + list =3D Val_emptylist; + for (i =3D libxl_string_list_length(c_val) - 1; i >=3D 0; i--) { + string =3D caml_copy_string((*c_val)[i]); + cons =3D caml_alloc(2, 0); + Store_field(cons, 0, string); // head + Store_field(cons, 1, list); // tail + list =3D cons; + } =20 - CAMLreturn(list); + CAMLreturn(list); } =20 /* 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_v= al) =20 static value Val_some(value v) { - CAMLparam1(v); - CAMLlocal1(some); - some =3D caml_alloc(1, 0); - Store_field(some, 0, v); - CAMLreturn(some); + CAMLparam1(v); + CAMLlocal1(some); + some =3D caml_alloc(1, 0); + Store_field(some, 0, v); + CAMLreturn(some); } =20 static value Val_mac (libxl_mac *c_val) { - CAMLparam0(); - CAMLlocal1(v); - int i; + CAMLparam0(); + CAMLlocal1(v); + int i; =20 - v =3D caml_alloc_tuple(6); + v =3D caml_alloc_tuple(6); =20 - for(i=3D0; i<6; i++) - Store_field(v, i, Val_int((*c_val)[i])); + for(i=3D0; i<6; i++) + Store_field(v, i, Val_int((*c_val)[i])); =20 - CAMLreturn(v); + CAMLreturn(v); } =20 static int Mac_val(libxl_mac *c_val, value v) { - CAMLparam1(v); - int i; + CAMLparam1(v); + int i; =20 - for(i=3D0; i<6; i++) - (*c_val)[i] =3D Int_val(Field(v, i)); + for(i=3D0; i<6; i++) + (*c_val)[i] =3D Int_val(Field(v, i)); =20 - CAMLreturn(0); + CAMLreturn(0); } =20 static value Val_bitmap (libxl_bitmap *c_val) { - CAMLparam0(); - CAMLlocal1(v); - int i; + CAMLparam0(); + CAMLlocal1(v); + int i; =20 - if (c_val->size =3D=3D 0) - v =3D Atom(0); - else { - v =3D 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 =3D=3D 0) + v =3D Atom(0); + else { + v =3D 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); } =20 static int Bitmap_val(libxl_ctx *ctx, libxl_bitmap *c_val, value v) { - CAMLparam1(v); - int i, len =3D Wosize_val(v); + CAMLparam1(v); + int i, len =3D Wosize_val(v); =20 - c_val->size =3D 0; - if (len > 0 && libxl_bitmap_alloc(ctx, c_val, len)) - failwith_xl(ERROR_NOMEM, "cannot allocate bitmap"); - for (i=3D0; isize =3D 0; + if (len > 0 && libxl_bitmap_alloc(ctx, c_val, len)) + failwith_xl(ERROR_NOMEM, "cannot allocate bitmap"); + for (i=3D0; ibytes[i])); + for(i=3D0; ibytes[i])); =20 - CAMLreturn(v); + CAMLreturn(v); } =20 static int Ms_vm_genid_val(libxl_ms_vm_genid *c_val, value v) { - CAMLparam1(v); - int i; + CAMLparam1(v); + int i; =20 - for(i=3D0; ibytes[i] =3D Int_val(Field(v, i)); + for(i=3D0; ibytes[i] =3D Int_val(Field(v, i)); =20 - CAMLreturn(0); + CAMLreturn(0); } =20 static value Val_string_option(const char *c_val) { - CAMLparam0(); - CAMLlocal2(tmp1, tmp2); - if (c_val) { - tmp1 =3D caml_copy_string(c_val); - tmp2 =3D Val_some(tmp1); - CAMLreturn(tmp2); - } - else - CAMLreturn(Val_none); + CAMLparam0(); + CAMLlocal2(tmp1, tmp2); + if (c_val) { + tmp1 =3D caml_copy_string(c_val); + tmp2 =3D Val_some(tmp1); + CAMLreturn(tmp2); + } + else + CAMLreturn(Val_none); } =20 static char *String_option_val(value v) { - CAMLparam1(v); - char *s =3D NULL; - if (v !=3D Val_none) - s =3D dup_String_val(Some_val(v)); - CAMLreturnT(char *, s); + CAMLparam1(v); + char *s =3D NULL; + if (v !=3D Val_none) + s =3D dup_String_val(Some_val(v)); + CAMLreturnT(char *, s); } =20 #include "_libxl_types.inc" =20 void async_callback(libxl_ctx *ctx, int rc, void *for_callback) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocal2(error, tmp); - static const value *func =3D NULL; - value *p =3D (value *) for_callback; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocal2(error, tmp); + static const value *func =3D NULL; + value *p =3D (value *) for_callback; =20 - if (func =3D=3D NULL) { - /* First time around, lookup by name */ - func =3D caml_named_value("libxl_async_callback"); - } + if (func =3D=3D NULL) { + /* First time around, lookup by name */ + func =3D caml_named_value("libxl_async_callback"); + } =20 - if (rc =3D=3D 0) - error =3D Val_none; - else { - tmp =3D Val_error(rc); - error =3D Val_some(tmp); - } + if (rc =3D=3D 0) + error =3D Val_none; + else { + tmp =3D Val_error(rc); + error =3D Val_some(tmp); + } =20 - /* 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); =20 - caml_remove_global_root(p); - free(p); + caml_remove_global_root(p); + free(p); =20 - CAMLdone; - caml_enter_blocking_section(); + CAMLdone; + caml_enter_blocking_section(); } =20 static libxl_asyncop_how *aohow_val(value async) { - CAMLparam1(async); - libxl_asyncop_how *ao_how =3D NULL; - value *p; + CAMLparam1(async); + libxl_asyncop_how *ao_how =3D NULL; + value *p; =20 - if (async !=3D 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 =3D malloc(sizeof(value)); - if (!p) - failwith_xl(ERROR_NOMEM, "cannot allocate value"); - *p =3D Some_val(async); - caml_register_global_root(p); - ao_how =3D malloc(sizeof(*ao_how)); - ao_how->callback =3D async_callback; - ao_how->u.for_callback =3D (void *) p; - } + if (async !=3D Val_none) { + /* for_callback must be a pointer to a "value" that is malloc'ed a= nd + * registered with the OCaml GC. This ensures that the GC does not= remove + * the corresponding OCaml heap blocks, and allows the GC to updat= e the value + * when blocks are moved around, while libxl is free to copy the p= ointer if + * it needs to. + * The for_callback pointer must always be non-NULL. */ + p =3D malloc(sizeof(value)); + if (!p) + failwith_xl(ERROR_NOMEM, "cannot allocate value"); + *p =3D Some_val(async); + caml_register_global_root(p); + ao_how =3D malloc(sizeof(*ao_how)); + ao_how->callback =3D async_callback; + ao_how->u.for_callback =3D (void *) p; + } =20 - CAMLreturnT(libxl_asyncop_how *, ao_how); + CAMLreturnT(libxl_asyncop_how *, ao_how); } =20 value stub_libxl_domain_create_new(value ctx, value domain_config, value a= sync, 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; =20 - libxl_domain_config_init(&c_dconfig); - ret =3D domain_config_val(CTX, &c_dconfig, domain_config); - if (ret !=3D 0) { - libxl_domain_config_dispose(&c_dconfig); - failwith_xl(ret, "domain_create_new"); - } + libxl_domain_config_init(&c_dconfig); + ret =3D domain_config_val(CTX, &c_dconfig, domain_config); + if (ret !=3D 0) { + libxl_domain_config_dispose(&c_dconfig); + failwith_xl(ret, "domain_create_new"); + } =20 - ao_how =3D aohow_val(async); + ao_how =3D aohow_val(async); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_create_new(CTX, &c_dconfig, &c_domid, ao_how, NULL); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_create_new(CTX, &c_dconfig, &c_domid, ao_how, NUL= L); + caml_leave_blocking_section(); =20 - free(ao_how); - libxl_domain_config_dispose(&c_dconfig); + free(ao_how); + libxl_domain_config_dispose(&c_dconfig); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_create_new"); + if (ret !=3D 0) + failwith_xl(ret, "domain_create_new"); =20 - CAMLreturn(Val_int(c_domid)); + CAMLreturn(Val_int(c_domid)); } =20 value stub_libxl_domain_create_restore(value ctx, value domain_config, val= ue 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; =20 - libxl_domain_config_init(&c_dconfig); - ret =3D domain_config_val(CTX, &c_dconfig, domain_config); - if (ret !=3D 0) { - libxl_domain_config_dispose(&c_dconfig); - failwith_xl(ret, "domain_create_restore"); - } + libxl_domain_config_init(&c_dconfig); + ret =3D domain_config_val(CTX, &c_dconfig, domain_config); + if (ret !=3D 0) { + libxl_domain_config_dispose(&c_dconfig); + failwith_xl(ret, "domain_create_restore"); + } =20 - libxl_domain_restore_params_init(&c_params); - ret =3D domain_restore_params_val(CTX, &c_params, Field(params, 1)); - if (ret !=3D 0) { - libxl_domain_restore_params_dispose(&c_params); - failwith_xl(ret, "domain_create_restore"); - } + libxl_domain_restore_params_init(&c_params); + ret =3D domain_restore_params_val(CTX, &c_params, Field(params, 1)); + if (ret !=3D 0) { + libxl_domain_restore_params_dispose(&c_params); + failwith_xl(ret, "domain_create_restore"); + } =20 - ao_how =3D aohow_val(async); - restore_fd =3D Int_val(Field(params, 0)); + ao_how =3D aohow_val(async); + restore_fd =3D Int_val(Field(params, 0)); =20 - caml_enter_blocking_section(); - ret =3D 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 =3D libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, restore= _fd, + -1, &c_params, ao_how, NULL); + caml_leave_blocking_section(); =20 - 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); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_create_restore"); + if (ret !=3D 0) + failwith_xl(ret, "domain_create_restore"); =20 - CAMLreturn(Val_int(c_domid)); + CAMLreturn(Val_int(c_domid)); } =20 value stub_libxl_domain_shutdown(value ctx, value domid, value async, valu= e unit) { - CAMLparam4(ctx, domid, async, unit); - int ret; - uint32_t c_domid =3D Int_val(domid); - libxl_asyncop_how *ao_how =3D aohow_val(async); + CAMLparam4(ctx, domid, async, unit); + int ret; + uint32_t c_domid =3D Int_val(domid); + libxl_asyncop_how *ao_how =3D aohow_val(async); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_shutdown(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_shutdown(CTX, c_domid, ao_how); + caml_leave_blocking_section(); =20 - free(ao_how); + free(ao_how); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_shutdown"); + if (ret !=3D 0) + failwith_xl(ret, "domain_shutdown"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_libxl_domain_reboot(value ctx, value domid, value async, value = unit) { - CAMLparam4(ctx, domid, async, unit); - int ret; - uint32_t c_domid =3D Int_val(domid); - libxl_asyncop_how *ao_how =3D aohow_val(async); + CAMLparam4(ctx, domid, async, unit); + int ret; + uint32_t c_domid =3D Int_val(domid); + libxl_asyncop_how *ao_how =3D aohow_val(async); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_reboot(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_reboot(CTX, c_domid, ao_how); + caml_leave_blocking_section(); =20 - free(ao_how); + free(ao_how); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_reboot"); + if (ret !=3D 0) + failwith_xl(ret, "domain_reboot"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_libxl_domain_destroy(value ctx, value domid, value async, value= unit) { - CAMLparam4(ctx, domid, async, unit); - int ret; - uint32_t c_domid =3D Int_val(domid); - libxl_asyncop_how *ao_how =3D aohow_val(async); + CAMLparam4(ctx, domid, async, unit); + int ret; + uint32_t c_domid =3D Int_val(domid); + libxl_asyncop_how *ao_how =3D aohow_val(async); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_destroy(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_destroy(CTX, c_domid, ao_how); + caml_leave_blocking_section(); =20 - free(ao_how); + free(ao_how); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_destroy"); + if (ret !=3D 0) + failwith_xl(ret, "domain_destroy"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_libxl_domain_suspend(value ctx, value domid, value fd, value as= ync, value unit) { - CAMLparam5(ctx, domid, fd, async, unit); - int ret; - uint32_t c_domid =3D Int_val(domid); - int c_fd =3D Int_val(fd); - libxl_asyncop_how *ao_how =3D aohow_val(async); + CAMLparam5(ctx, domid, fd, async, unit); + int ret; + uint32_t c_domid =3D Int_val(domid); + int c_fd =3D Int_val(fd); + libxl_asyncop_how *ao_how =3D aohow_val(async); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_suspend(CTX, c_domid, c_fd, 0, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_suspend(CTX, c_domid, c_fd, 0, ao_how); + caml_leave_blocking_section(); =20 - free(ao_how); + free(ao_how); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_suspend"); + if (ret !=3D 0) + failwith_xl(ret, "domain_suspend"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_libxl_domain_pause(value ctx, value domid, value async) { - CAMLparam3(ctx, domid, async); - int ret; - uint32_t c_domid =3D Int_val(domid); - libxl_asyncop_how *ao_how =3D aohow_val(async); + CAMLparam3(ctx, domid, async); + int ret; + uint32_t c_domid =3D Int_val(domid); + libxl_asyncop_how *ao_how =3D aohow_val(async); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_pause(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_pause(CTX, c_domid, ao_how); + caml_leave_blocking_section(); =20 - free(ao_how); + free(ao_how); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_pause"); + if (ret !=3D 0) + failwith_xl(ret, "domain_pause"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_libxl_domain_unpause(value ctx, value domid, value async) { - CAMLparam3(ctx, domid, async); - int ret; - uint32_t c_domid =3D Int_val(domid); - libxl_asyncop_how *ao_how =3D aohow_val(async); + CAMLparam3(ctx, domid, async); + int ret; + uint32_t c_domid =3D Int_val(domid); + libxl_asyncop_how *ao_how =3D aohow_val(async); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_unpause(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_unpause(CTX, c_domid, ao_how); + caml_leave_blocking_section(); =20 - free(ao_how); + free(ao_how); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_unpause"); + if (ret !=3D 0) + failwith_xl(ret, "domain_unpause"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 #define _STRINGIFY(x) #x #define STRINGIFY(x) _STRINGIFY(x) =20 -#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 =3D Int_val(domid); \ - libxl_asyncop_how *ao_how =3D aohow_val(async); \ - \ - device_##type##_val(CTX, &c_info, info); \ - \ - caml_enter_blocking_section(); \ - ret =3D 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 !=3D 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 =3D Int_val(domid); \ + libxl_asyncop_how *ao_how =3D aohow_val(async); \ + \ + device_##type##_val(CTX, &c_info, info); \ + \ + caml_enter_blocking_section(); \ + ret =3D 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 !=3D 0) \ + failwith_xl(ret, STRINGIFY(type) "_" STRINGIFY(op)); \ + \ + CAMLreturn(Val_unit); \ } =20 #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) =20 DEVICE_ADDREMOVE(disk) DEVICE_ADDREMOVE(nic) @@ -712,558 +712,558 @@ _DEVICE_ADDREMOVE(disk, cdrom, insert) =20 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 =3D Int_val(domid); - int c_devid =3D Int_val(devid); + CAMLparam3(ctx, domid, devid); + CAMLlocal1(nic); + libxl_device_nic c_nic; + uint32_t c_domid =3D Int_val(domid); + int c_devid =3D Int_val(devid); =20 - 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(); =20 - nic =3D Val_device_nic(&c_nic); - libxl_device_nic_dispose(&c_nic); + nic =3D Val_device_nic(&c_nic); + libxl_device_nic_dispose(&c_nic); =20 - CAMLreturn(nic); + CAMLreturn(nic); } =20 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 =3D Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal2(list, temp); + libxl_device_nic *c_list; + int i, nb; + uint32_t c_domid =3D Int_val(domid); =20 - caml_enter_blocking_section(); - c_list =3D libxl_device_nic_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_list =3D libxl_device_nic_list(CTX, c_domid, &nb); + caml_leave_blocking_section(); =20 - if (!c_list) - failwith_xl(ERROR_FAIL, "nic_list"); + if (!c_list) + failwith_xl(ERROR_FAIL, "nic_list"); =20 - list =3D temp =3D Val_emptylist; - for (i =3D 0; i < nb; i++) { - list =3D caml_alloc_small(2, Tag_cons); - Field(list, 0) =3D Val_int(0); - Field(list, 1) =3D temp; - temp =3D list; - Store_field(list, 0, Val_device_nic(&c_list[i])); - } - libxl_device_nic_list_free(c_list, nb); + list =3D temp =3D Val_emptylist; + for (i =3D 0; i < nb; i++) { + list =3D caml_alloc_small(2, Tag_cons); + Field(list, 0) =3D Val_int(0); + Field(list, 1) =3D temp; + temp =3D list; + Store_field(list, 0, Val_device_nic(&c_list[i])); + } + libxl_device_nic_list_free(c_list, nb); =20 - CAMLreturn(list); + CAMLreturn(list); } =20 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 =3D Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal2(list, temp); + libxl_device_disk *c_list; + int i, nb; + uint32_t c_domid =3D Int_val(domid); =20 - caml_enter_blocking_section(); - c_list =3D libxl_device_disk_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_list =3D libxl_device_disk_list(CTX, c_domid, &nb); + caml_leave_blocking_section(); =20 - if (!c_list) - failwith_xl(ERROR_FAIL, "disk_list"); + if (!c_list) + failwith_xl(ERROR_FAIL, "disk_list"); =20 - list =3D temp =3D Val_emptylist; - for (i =3D 0; i < nb; i++) { - list =3D caml_alloc_small(2, Tag_cons); - Field(list, 0) =3D Val_int(0); - Field(list, 1) =3D temp; - temp =3D list; - Store_field(list, 0, Val_device_disk(&c_list[i])); - } - libxl_device_disk_list_free(c_list, nb); + list =3D temp =3D Val_emptylist; + for (i =3D 0; i < nb; i++) { + list =3D caml_alloc_small(2, Tag_cons); + Field(list, 0) =3D Val_int(0); + Field(list, 1) =3D temp; + temp =3D list; + Store_field(list, 0, Val_device_disk(&c_list[i])); + } + libxl_device_disk_list_free(c_list, nb); =20 - CAMLreturn(list); + CAMLreturn(list); } =20 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 =3D Int_val(domid); + CAMLparam3(ctx, domid, vdev); + CAMLlocal1(disk); + libxl_device_disk c_disk; + char *c_vdev; + uint32_t c_domid =3D Int_val(domid); =20 - c_vdev =3D strdup(String_val(vdev)); + c_vdev =3D strdup(String_val(vdev)); =20 - 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(); =20 - disk =3D Val_device_disk(&c_disk); - libxl_device_disk_dispose(&c_disk); - free(c_vdev); + disk =3D Val_device_disk(&c_disk); + libxl_device_disk_dispose(&c_disk); + free(c_vdev); =20 - CAMLreturn(disk); + CAMLreturn(disk); } =20 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 =3D Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal2(list, temp); + libxl_device_pci *c_list; + int i, nb; + uint32_t c_domid =3D Int_val(domid); =20 - caml_enter_blocking_section(); - c_list =3D libxl_device_pci_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_list =3D libxl_device_pci_list(CTX, c_domid, &nb); + caml_leave_blocking_section(); =20 - if (!c_list) - failwith_xl(ERROR_FAIL, "pci_list"); + if (!c_list) + failwith_xl(ERROR_FAIL, "pci_list"); =20 - list =3D temp =3D Val_emptylist; - for (i =3D 0; i < nb; i++) { - list =3D caml_alloc_small(2, Tag_cons); - Field(list, 0) =3D Val_int(0); - Field(list, 1) =3D temp; - temp =3D list; - Store_field(list, 0, Val_device_pci(&c_list[i])); - libxl_device_pci_dispose(&c_list[i]); - } - free(c_list); + list =3D temp =3D Val_emptylist; + for (i =3D 0; i < nb; i++) { + list =3D caml_alloc_small(2, Tag_cons); + Field(list, 0) =3D Val_int(0); + Field(list, 1) =3D temp; + temp =3D list; + Store_field(list, 0, Val_device_pci(&c_list[i])); + libxl_device_pci_dispose(&c_list[i]); + } + free(c_list); =20 - CAMLreturn(list); + CAMLreturn(list); } =20 value stub_xl_device_pci_assignable_add(value ctx, value info, value rebin= d) { - CAMLparam3(ctx, info, rebind); - libxl_device_pci c_info; - int ret, marker_var; - int c_rebind =3D (int) Bool_val(rebind); + CAMLparam3(ctx, info, rebind); + libxl_device_pci c_info; + int ret, marker_var; + int c_rebind =3D (int) Bool_val(rebind); =20 - device_pci_val(CTX, &c_info, info); + device_pci_val(CTX, &c_info, info); =20 - caml_enter_blocking_section(); - ret =3D libxl_device_pci_assignable_add(CTX, &c_info, c_rebind); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_device_pci_assignable_add(CTX, &c_info, c_rebind); + caml_leave_blocking_section(); =20 - libxl_device_pci_dispose(&c_info); + libxl_device_pci_dispose(&c_info); =20 - if (ret !=3D 0) - failwith_xl(ret, "pci_assignable_add"); + if (ret !=3D 0) + failwith_xl(ret, "pci_assignable_add"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_xl_device_pci_assignable_remove(value ctx, value info, value re= bind) { - CAMLparam3(ctx, info, rebind); - libxl_device_pci c_info; - int ret, marker_var; - int c_rebind =3D (int) Bool_val(rebind); + CAMLparam3(ctx, info, rebind); + libxl_device_pci c_info; + int ret, marker_var; + int c_rebind =3D (int) Bool_val(rebind); =20 - device_pci_val(CTX, &c_info, info); + device_pci_val(CTX, &c_info, info); =20 - caml_enter_blocking_section(); - ret =3D libxl_device_pci_assignable_remove(CTX, &c_info, c_rebind); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_device_pci_assignable_remove(CTX, &c_info, c_rebind); + caml_leave_blocking_section(); =20 - libxl_device_pci_dispose(&c_info); + libxl_device_pci_dispose(&c_info); =20 - if (ret !=3D 0) - failwith_xl(ret, "pci_assignable_remove"); + if (ret !=3D 0) + failwith_xl(ret, "pci_assignable_remove"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - caml_enter_blocking_section(); - c_list =3D libxl_device_pci_assignable_list(CTX, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_list =3D libxl_device_pci_assignable_list(CTX, &nb); + caml_leave_blocking_section(); =20 - if (!c_list) - failwith_xl(ERROR_FAIL, "pci_assignable_list"); + if (!c_list) + failwith_xl(ERROR_FAIL, "pci_assignable_list"); =20 - list =3D temp =3D Val_emptylist; - for (i =3D 0; i < nb; i++) { - list =3D caml_alloc_small(2, Tag_cons); - Field(list, 0) =3D Val_int(0); - Field(list, 1) =3D temp; - temp =3D list; - Store_field(list, 0, Val_device_pci(&c_list[i])); - } - libxl_device_pci_assignable_list_free(c_list, nb); + list =3D temp =3D Val_emptylist; + for (i =3D 0; i < nb; i++) { + list =3D caml_alloc_small(2, Tag_cons); + Field(list, 0) =3D Val_int(0); + Field(list, 1) =3D temp; + temp =3D list; + Store_field(list, 0, Val_device_pci(&c_list[i])); + } + libxl_device_pci_assignable_list_free(c_list, nb); =20 - CAMLreturn(list); + CAMLreturn(list); } =20 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; =20 - caml_enter_blocking_section(); - ret =3D libxl_get_physinfo(CTX, &c_physinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_get_physinfo(CTX, &c_physinfo); + caml_leave_blocking_section(); =20 - if (ret !=3D 0) - failwith_xl(ret, "get_physinfo"); + if (ret !=3D 0) + failwith_xl(ret, "get_physinfo"); =20 - physinfo =3D Val_physinfo(&c_physinfo); + physinfo =3D Val_physinfo(&c_physinfo); =20 - libxl_physinfo_dispose(&c_physinfo); + libxl_physinfo_dispose(&c_physinfo); =20 - CAMLreturn(physinfo); + CAMLreturn(physinfo); } =20 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; =20 - caml_enter_blocking_section(); - c_topology =3D libxl_get_cpu_topology(CTX, &nr); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_topology =3D libxl_get_cpu_topology(CTX, &nr); + caml_leave_blocking_section(); =20 - if (!c_topology) - failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo"); + if (!c_topology) + failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo"); =20 - topology =3D caml_alloc_tuple(nr); - for (i =3D 0; i < nr; i++) { - if (c_topology[i].core !=3D LIBXL_CPUTOPOLOGY_INVALID_ENTRY) { - v0 =3D Val_cputopology(&c_topology[i]); - v =3D Val_some(v0); - } - else - v =3D Val_none; - Store_field(topology, i, v); - } + topology =3D caml_alloc_tuple(nr); + for (i =3D 0; i < nr; i++) { + if (c_topology[i].core !=3D LIBXL_CPUTOPOLOGY_INVALID_ENTRY) { + v0 =3D Val_cputopology(&c_topology[i]); + v =3D Val_some(v0); + } + else + v =3D Val_none; + Store_field(topology, i, v); + } =20 - libxl_cputopology_list_free(c_topology, nr); + libxl_cputopology_list_free(c_topology, nr); =20 - CAMLreturn(topology); + CAMLreturn(topology); } =20 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; =20 - caml_enter_blocking_section(); - c_domlist =3D libxl_list_domain(CTX, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_domlist =3D libxl_list_domain(CTX, &nb); + caml_leave_blocking_section(); =20 - if (!c_domlist) - failwith_xl(ERROR_FAIL, "dominfo_list"); + if (!c_domlist) + failwith_xl(ERROR_FAIL, "dominfo_list"); =20 - domlist =3D temp =3D Val_emptylist; - for (i =3D nb - 1; i >=3D 0; i--) { - domlist =3D caml_alloc_small(2, Tag_cons); - Field(domlist, 0) =3D Val_int(0); - Field(domlist, 1) =3D temp; - temp =3D domlist; + domlist =3D temp =3D Val_emptylist; + for (i =3D nb - 1; i >=3D 0; i--) { + domlist =3D caml_alloc_small(2, Tag_cons); + Field(domlist, 0) =3D Val_int(0); + Field(domlist, 1) =3D temp; + temp =3D domlist; =20 - Store_field(domlist, 0, Val_dominfo(&c_domlist[i])); - } + Store_field(domlist, 0, Val_dominfo(&c_domlist[i])); + } =20 - libxl_dominfo_list_free(c_domlist, nb); + libxl_dominfo_list_free(c_domlist, nb); =20 - CAMLreturn(domlist); + CAMLreturn(domlist); } =20 value stub_xl_dominfo_get(value ctx, value domid) { - CAMLparam2(ctx, domid); - CAMLlocal1(dominfo); - libxl_dominfo c_dominfo; - int ret; - uint32_t c_domid =3D Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal1(dominfo); + libxl_dominfo c_dominfo; + int ret; + uint32_t c_domid =3D Int_val(domid); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_info(CTX, &c_dominfo, c_domid); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_info(CTX, &c_dominfo, c_domid); + caml_leave_blocking_section(); =20 - if (ret !=3D 0) - failwith_xl(ERROR_FAIL, "domain_info"); - dominfo =3D Val_dominfo(&c_dominfo); + if (ret !=3D 0) + failwith_xl(ERROR_FAIL, "domain_info"); + dominfo =3D Val_dominfo(&c_dominfo); =20 - CAMLreturn(dominfo); + CAMLreturn(dominfo); } =20 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 =3D Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal1(scinfo); + libxl_domain_sched_params c_scinfo; + int ret; + uint32_t c_domid =3D Int_val(domid); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_sched_params_get(CTX, c_domid, &c_scinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_sched_params_get(CTX, c_domid, &c_scinfo); + caml_leave_blocking_section(); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_sched_params_get"); + if (ret !=3D 0) + failwith_xl(ret, "domain_sched_params_get"); =20 - scinfo =3D Val_domain_sched_params(&c_scinfo); + scinfo =3D Val_domain_sched_params(&c_scinfo); =20 - libxl_domain_sched_params_dispose(&c_scinfo); + libxl_domain_sched_params_dispose(&c_scinfo); =20 - CAMLreturn(scinfo); + CAMLreturn(scinfo); } =20 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 =3D Int_val(domid); + CAMLparam3(ctx, domid, scinfo); + libxl_domain_sched_params c_scinfo; + int ret; + uint32_t c_domid =3D Int_val(domid); =20 - domain_sched_params_val(CTX, &c_scinfo, scinfo); + domain_sched_params_val(CTX, &c_scinfo, scinfo); =20 - caml_enter_blocking_section(); - ret =3D libxl_domain_sched_params_set(CTX, c_domid, &c_scinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_domain_sched_params_set(CTX, c_domid, &c_scinfo); + caml_leave_blocking_section(); =20 - libxl_domain_sched_params_dispose(&c_scinfo); + libxl_domain_sched_params_dispose(&c_scinfo); =20 - if (ret !=3D 0) - failwith_xl(ret, "domain_sched_params_set"); + if (ret !=3D 0) + failwith_xl(ret, "domain_sched_params_set"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_xl_send_trigger(value ctx, value domid, value trigger, value vc= puid, value async) { - CAMLparam5(ctx, domid, trigger, vcpuid, async); - int ret; - uint32_t c_domid =3D Int_val(domid); - libxl_trigger c_trigger =3D LIBXL_TRIGGER_UNKNOWN; - int c_vcpuid =3D Int_val(vcpuid); - libxl_asyncop_how *ao_how =3D aohow_val(async); + CAMLparam5(ctx, domid, trigger, vcpuid, async); + int ret; + uint32_t c_domid =3D Int_val(domid); + libxl_trigger c_trigger =3D LIBXL_TRIGGER_UNKNOWN; + int c_vcpuid =3D Int_val(vcpuid); + libxl_asyncop_how *ao_how =3D aohow_val(async); =20 - trigger_val(CTX, &c_trigger, trigger); + trigger_val(CTX, &c_trigger, trigger); =20 - caml_enter_blocking_section(); - ret =3D libxl_send_trigger(CTX, c_domid, c_trigger, c_vcpuid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_send_trigger(CTX, c_domid, c_trigger, c_vcpuid, ao_how); + caml_leave_blocking_section(); =20 - free(ao_how); + free(ao_how); =20 - if (ret !=3D 0) - failwith_xl(ret, "send_trigger"); + if (ret !=3D 0) + failwith_xl(ret, "send_trigger"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_xl_send_sysrq(value ctx, value domid, value sysrq) { - CAMLparam3(ctx, domid, sysrq); - int ret; - uint32_t c_domid =3D Int_val(domid); - int c_sysrq =3D Int_val(sysrq); + CAMLparam3(ctx, domid, sysrq); + int ret; + uint32_t c_domid =3D Int_val(domid); + int c_sysrq =3D Int_val(sysrq); =20 - caml_enter_blocking_section(); - ret =3D libxl_send_sysrq(CTX, c_domid, c_sysrq); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_send_sysrq(CTX, c_domid, c_sysrq); + caml_leave_blocking_section(); =20 - if (ret !=3D 0) - failwith_xl(ret, "send_sysrq"); + if (ret !=3D 0) + failwith_xl(ret, "send_sysrq"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 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; =20 - c_keys =3D dup_String_val(keys); + c_keys =3D dup_String_val(keys); =20 - caml_enter_blocking_section(); - ret =3D libxl_send_debug_keys(CTX, c_keys); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_send_debug_keys(CTX, c_keys); + caml_leave_blocking_section(); =20 - free(c_keys); + free(c_keys); =20 - if (ret !=3D 0) - failwith_xl(ret, "send_debug_keys"); + if (ret !=3D 0) + failwith_xl(ret, "send_debug_keys"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 static struct custom_operations libxl_console_reader_custom_operations =3D= { - "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 }; =20 #define Console_reader_val(x)(*((libxl_xen_console_reader **) Data_custom_= val(x))) =20 value stub_libxl_xen_console_read_start(value ctx, value clear) { - CAMLparam2(ctx, clear); - CAMLlocal1(handle); - int c_clear =3D Int_val(clear); - libxl_xen_console_reader *cr; + CAMLparam2(ctx, clear); + CAMLlocal1(handle); + int c_clear =3D Int_val(clear); + libxl_xen_console_reader *cr; =20 - caml_enter_blocking_section(); - cr =3D libxl_xen_console_read_start(CTX, c_clear); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + cr =3D libxl_xen_console_read_start(CTX, c_clear); + caml_leave_blocking_section(); =20 - handle =3D caml_alloc_custom(&libxl_console_reader_custom_operations, siz= eof(cr), 0, 1); - Console_reader_val(handle) =3D cr; + handle =3D caml_alloc_custom(&libxl_console_reader_custom_operations, = sizeof(cr), 0, 1); + Console_reader_val(handle) =3D cr; =20 - CAMLreturn(handle); + CAMLreturn(handle); } =20 static void raise_eof(void) { - static const value *exc =3D NULL; + static const value *exc =3D NULL; =20 - /* First time around, lookup by name */ - if (!exc) - exc =3D caml_named_value("Xenlight.Host.End_of_file"); + /* First time around, lookup by name */ + if (!exc) + exc =3D caml_named_value("Xenlight.Host.End_of_file"); =20 - if (!exc) - caml_invalid_argument("Exception Xenlight.Host.End_of_file not initializ= ed, please link xenlight.cma"); + if (!exc) + caml_invalid_argument("Exception Xenlight.Host.End_of_file not ini= tialized, please link xenlight.cma"); =20 - caml_raise_constant(*exc); + caml_raise_constant(*exc); } =20 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 =3D (libxl_xen_console_reader *) Console_rea= der_val(reader); + CAMLparam2(ctx, reader); + CAMLlocal1(line); + int ret; + char *c_line; + libxl_xen_console_reader *cr =3D (libxl_xen_console_reader *) Console_= reader_val(reader); =20 - caml_enter_blocking_section(); - ret =3D libxl_xen_console_read_line(CTX, cr, &c_line); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret =3D libxl_xen_console_read_line(CTX, cr, &c_line); + caml_leave_blocking_section(); =20 - if (ret < 0) - failwith_xl(ret, "xen_console_read_line"); - if (ret =3D=3D 0) - raise_eof(); + if (ret < 0) + failwith_xl(ret, "xen_console_read_line"); + if (ret =3D=3D 0) + raise_eof(); =20 - line =3D caml_copy_string(c_line); + line =3D caml_copy_string(c_line); =20 - CAMLreturn(line); + CAMLreturn(line); } =20 value stub_libxl_xen_console_read_finish(value ctx, value reader) { - CAMLparam2(ctx, reader); - libxl_xen_console_reader *cr =3D (libxl_xen_console_reader *) Console_rea= der_val(reader); + CAMLparam2(ctx, reader); + libxl_xen_console_reader *cr =3D (libxl_xen_console_reader *) Console_= reader_val(reader); =20 - 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(); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 /* Event handling */ =20 short Poll_val(value event) { - CAMLparam1(event); - short res =3D -1; + CAMLparam1(event); + short res =3D -1; =20 - switch (Int_val(event)) { - case 0: res =3D POLLIN; break; - case 1: res =3D POLLPRI; break; - case 2: res =3D POLLOUT; break; - case 3: res =3D POLLERR; break; - case 4: res =3D POLLHUP; break; - case 5: res =3D POLLNVAL; break; - } + switch (Int_val(event)) { + case 0: res =3D POLLIN; break; + case 1: res =3D POLLPRI; break; + case 2: res =3D POLLOUT; break; + case 3: res =3D POLLERR; break; + case 4: res =3D POLLHUP; break; + case 5: res =3D POLLNVAL; break; + } =20 - CAMLreturn(res); + CAMLreturn(res); } =20 short Poll_events_val(value event_list) { - CAMLparam1(event_list); - short events =3D 0; + CAMLparam1(event_list); + short events =3D 0; =20 - while (event_list !=3D Val_emptylist) { - events |=3D Poll_val(Field(event_list, 0)); - event_list =3D Field(event_list, 1); - } + while (event_list !=3D Val_emptylist) { + events |=3D Poll_val(Field(event_list, 0)); + event_list =3D Field(event_list, 1); + } =20 - CAMLreturn(events); + CAMLreturn(events); } =20 value Val_poll(short event) { - CAMLparam0(); - CAMLlocal1(res); + CAMLparam0(); + CAMLlocal1(res); =20 - switch (event) { - case POLLIN: res =3D Val_int(0); break; - case POLLPRI: res =3D Val_int(1); break; - case POLLOUT: res =3D Val_int(2); break; - case POLLERR: res =3D Val_int(3); break; - case POLLHUP: res =3D Val_int(4); break; - case POLLNVAL: res =3D Val_int(5); break; - default: failwith_xl(ERROR_FAIL, "cannot convert poll event value"); bre= ak; - } + switch (event) { + case POLLIN: res =3D Val_int(0); break; + case POLLPRI: res =3D Val_int(1); break; + case POLLOUT: res =3D Val_int(2); break; + case POLLERR: res =3D Val_int(3); break; + case POLLHUP: res =3D Val_int(4); break; + case POLLNVAL: res =3D Val_int(5); break; + default: failwith_xl(ERROR_FAIL, "cannot convert poll event value"= ); break; + } =20 - CAMLreturn(res); + CAMLreturn(res); } =20 value add_event(value event_list, short event) { - CAMLparam1(event_list); - CAMLlocal1(new_list); + CAMLparam1(event_list); + CAMLlocal1(new_list); =20 - new_list =3D caml_alloc(2, 0); - Store_field(new_list, 0, Val_poll(event)); - Store_field(new_list, 1, event_list); + new_list =3D caml_alloc(2, 0); + Store_field(new_list, 0, Val_poll(event)); + Store_field(new_list, 1, event_list); =20 - CAMLreturn(new_list); + CAMLreturn(new_list); } =20 value Val_poll_events(short events) { - CAMLparam0(); - CAMLlocal1(event_list); + CAMLparam0(); + CAMLlocal1(event_list); =20 - event_list =3D Val_emptylist; - if (events & POLLIN) - event_list =3D add_event(event_list, POLLIN); - if (events & POLLPRI) - event_list =3D add_event(event_list, POLLPRI); - if (events & POLLOUT) - event_list =3D add_event(event_list, POLLOUT); - if (events & POLLERR) - event_list =3D add_event(event_list, POLLERR); - if (events & POLLHUP) - event_list =3D add_event(event_list, POLLHUP); - if (events & POLLNVAL) - event_list =3D add_event(event_list, POLLNVAL); + event_list =3D Val_emptylist; + if (events & POLLIN) + event_list =3D add_event(event_list, POLLIN); + if (events & POLLPRI) + event_list =3D add_event(event_list, POLLPRI); + if (events & POLLOUT) + event_list =3D add_event(event_list, POLLOUT); + if (events & POLLERR) + event_list =3D add_event(event_list, POLLERR); + if (events & POLLHUP) + event_list =3D add_event(event_list, POLLHUP); + if (events & POLLNVAL) + event_list =3D add_event(event_list, POLLNVAL); =20 - CAMLreturn(event_list); + CAMLreturn(event_list); } =20 /* 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 =3D 0; - static const value *func =3D NULL; - value *p =3D (value *) user; - value *for_app; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + int ret =3D 0; + static const value *func =3D NULL; + value *p =3D (value *) user; + value *for_app; =20 - if (func =3D=3D NULL) { - /* First time around, lookup by name */ - func =3D caml_named_value("libxl_fd_register"); - } + if (func =3D=3D NULL) { + /* First time around, lookup by name */ + func =3D caml_named_value("libxl_fd_register"); + } =20 - args[0] =3D *p; - args[1] =3D Val_int(fd); - args[2] =3D Val_poll_events(events); - args[3] =3D (value) for_libxl; + args[0] =3D *p; + args[1] =3D Val_int(fd); + args[2] =3D Val_poll_events(events); + args[3] =3D (value) for_libxl; =20 - for_app =3D malloc(sizeof(value)); - if (!for_app) { - ret =3D ERROR_OSEVENT_REG_FAIL; - goto err; - } + for_app =3D malloc(sizeof(value)); + if (!for_app) { + ret =3D ERROR_OSEVENT_REG_FAIL; + goto err; + } =20 - *for_app =3D caml_callbackN_exn(*func, 4, args); - if (Is_exception_result(*for_app)) { - ret =3D ERROR_OSEVENT_REG_FAIL; - free(for_app); - goto err; - } + *for_app =3D caml_callbackN_exn(*func, 4, args); + if (Is_exception_result(*for_app)) { + ret =3D ERROR_OSEVENT_REG_FAIL; + free(for_app); + goto err; + } =20 - caml_register_global_root(for_app); - *for_app_registration_out =3D for_app; + caml_register_global_root(for_app); + *for_app_registration_out =3D for_app; =20 err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + CAMLdone; + caml_enter_blocking_section(); + return ret; } =20 int fd_modify(void *user, int fd, void **for_app_registration_update, short events) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - int ret =3D 0; - static const value *func =3D NULL; - value *p =3D (value *) user; - value *for_app =3D *for_app_registration_update; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + int ret =3D 0; + static const value *func =3D NULL; + value *p =3D (value *) user; + value *for_app =3D *for_app_registration_update; =20 - /* If for_app =3D=3D NULL, then something is very wrong */ - assert(for_app); + /* If for_app =3D=3D NULL, then something is very wrong */ + assert(for_app); =20 - if (func =3D=3D NULL) { - /* First time around, lookup by name */ - func =3D caml_named_value("libxl_fd_modify"); - } + if (func =3D=3D NULL) { + /* First time around, lookup by name */ + func =3D caml_named_value("libxl_fd_modify"); + } =20 - args[0] =3D *p; - args[1] =3D Val_int(fd); - args[2] =3D *for_app; - args[3] =3D Val_poll_events(events); + args[0] =3D *p; + args[1] =3D Val_int(fd); + args[2] =3D *for_app; + args[3] =3D Val_poll_events(events); =20 - *for_app =3D 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 =3D ERROR_OSEVENT_REG_FAIL; - goto err; - } + *for_app =3D 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 register= ed + * with the GC. */ + ret =3D ERROR_OSEVENT_REG_FAIL; + goto err; + } =20 - *for_app_registration_update =3D for_app; + *for_app_registration_update =3D for_app; =20 err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + CAMLdone; + caml_enter_blocking_section(); + return ret; } =20 void fd_deregister(void *user, int fd, void *for_app_registration) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 3); - static const value *func =3D NULL; - value *p =3D (value *) user; - value *for_app =3D for_app_registration; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 3); + static const value *func =3D NULL; + value *p =3D (value *) user; + value *for_app =3D for_app_registration; =20 - /* If for_app =3D=3D NULL, then something is very wrong */ - assert(for_app); + /* If for_app =3D=3D NULL, then something is very wrong */ + assert(for_app); =20 - if (func =3D=3D NULL) { - /* First time around, lookup by name */ - func =3D caml_named_value("libxl_fd_deregister"); - } + if (func =3D=3D NULL) { + /* First time around, lookup by name */ + func =3D caml_named_value("libxl_fd_deregister"); + } =20 - args[0] =3D *p; - args[1] =3D Val_int(fd); - args[2] =3D *for_app; + args[0] =3D *p; + args[1] =3D Val_int(fd); + args[2] =3D *for_app; =20 - 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(); =20 - caml_remove_global_root(for_app); - free(for_app); + caml_remove_global_root(for_app); + free(for_app); =20 - CAMLdone; - caml_enter_blocking_section(); + CAMLdone; + caml_enter_blocking_section(); } =20 struct timeout_handles { - void *for_libxl; - value for_app; + void *for_libxl; + value for_app; }; =20 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 =3D 0; - static const value *func =3D NULL; - value *p =3D (value *) user; - struct timeout_handles *handles; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocal2(sec, usec); + CAMLlocalN(args, 4); + int ret =3D 0; + static const value *func =3D NULL; + value *p =3D (value *) user; + struct timeout_handles *handles; =20 - if (func =3D=3D NULL) { - /* First time around, lookup by name */ - func =3D caml_named_value("libxl_timeout_register"); - } + if (func =3D=3D NULL) { + /* First time around, lookup by name */ + func =3D caml_named_value("libxl_timeout_register"); + } =20 - sec =3D caml_copy_int64(abs.tv_sec); - usec =3D caml_copy_int64(abs.tv_usec); + sec =3D caml_copy_int64(abs.tv_sec); + usec =3D caml_copy_int64(abs.tv_usec); =20 - /* 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 =3D malloc(sizeof(*handles)); - if (!handles) { - ret =3D ERROR_OSEVENT_REG_FAIL; - goto err; - } + /* This struct of "handles" will contain "for_libxl" as well as "for_a= pp". + * 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 =3D malloc(sizeof(*handles)); + if (!handles) { + ret =3D ERROR_OSEVENT_REG_FAIL; + goto err; + } =20 - handles->for_libxl =3D for_libxl; + handles->for_libxl =3D for_libxl; =20 - args[0] =3D *p; - args[1] =3D sec; - args[2] =3D usec; - args[3] =3D (value) handles; + args[0] =3D *p; + args[1] =3D sec; + args[2] =3D usec; + args[3] =3D (value) handles; =20 - handles->for_app =3D caml_callbackN_exn(*func, 4, args); - if (Is_exception_result(handles->for_app)) { - ret =3D ERROR_OSEVENT_REG_FAIL; - free(handles); - goto err; - } + handles->for_app =3D caml_callbackN_exn(*func, 4, args); + if (Is_exception_result(handles->for_app)) { + ret =3D ERROR_OSEVENT_REG_FAIL; + free(handles); + goto err; + } =20 - caml_register_global_root(&handles->for_app); - *for_app_registration_out =3D handles; + caml_register_global_root(&handles->for_app); + *for_app_registration_out =3D handles; =20 err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + CAMLdone; + caml_enter_blocking_section(); + return ret; } =20 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 =3D 0; - static const value *func =3D NULL; - value *p =3D (value *) user; - struct timeout_handles *handles =3D *for_app_registration_update; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocal1(for_app_update); + CAMLlocalN(args, 2); + int ret =3D 0; + static const value *func =3D NULL; + value *p =3D (value *) user; + struct timeout_handles *handles =3D *for_app_registration_update; =20 - /* If for_app =3D=3D NULL, then something is very wrong */ - assert(handles->for_app); + /* If for_app =3D=3D NULL, then something is very wrong */ + assert(handles->for_app); =20 - /* Libxl currently promises that timeout_modify is only ever called with - * abs=3D{0,0}, meaning "right away". We cannot deal with other values. */ - assert(abs.tv_sec =3D=3D 0 && abs.tv_usec =3D=3D 0); + /* Libxl currently promises that timeout_modify is only ever called wi= th + * abs=3D{0,0}, meaning "right away". We cannot deal with other values= . */ + assert(abs.tv_sec =3D=3D 0 && abs.tv_usec =3D=3D 0); =20 - if (func =3D=3D NULL) { - /* First time around, lookup by name */ - func =3D caml_named_value("libxl_timeout_fire_now"); - } + if (func =3D=3D NULL) { + /* First time around, lookup by name */ + func =3D caml_named_value("libxl_timeout_fire_now"); + } =20 - args[0] =3D *p; - args[1] =3D handles->for_app; + args[0] =3D *p; + args[1] =3D handles->for_app; =20 - for_app_update =3D 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 =3D ERROR_OSEVENT_REG_FAIL; - goto err; - } + for_app_update =3D 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 register= ed + * with the GC. */ + ret =3D ERROR_OSEVENT_REG_FAIL; + goto err; + } =20 - handles->for_app =3D for_app_update; + handles->for_app =3D for_app_update; =20 err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + CAMLdone; + caml_enter_blocking_section(); + return ret; } =20 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(); } =20 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; =20 - hooks =3D malloc(sizeof(*hooks)); - if (!hooks) - failwith_xl(ERROR_NOMEM, "cannot allocate osevent hooks"); - hooks->fd_register =3D fd_register; - hooks->fd_modify =3D fd_modify; - hooks->fd_deregister =3D fd_deregister; - hooks->timeout_register =3D timeout_register; - hooks->timeout_modify =3D timeout_modify; - hooks->timeout_deregister =3D timeout_deregister; + hooks =3D malloc(sizeof(*hooks)); + if (!hooks) + failwith_xl(ERROR_NOMEM, "cannot allocate osevent hooks"); + hooks->fd_register =3D fd_register; + hooks->fd_modify =3D fd_modify; + hooks->fd_deregister =3D fd_deregister; + hooks->timeout_register =3D timeout_register; + hooks->timeout_modify =3D timeout_modify; + hooks->timeout_deregister =3D timeout_deregister; =20 - p =3D malloc(sizeof(value)); - if (!p) - failwith_xl(ERROR_NOMEM, "cannot allocate value"); - *p =3D user; - caml_register_global_root(p); + p =3D malloc(sizeof(value)); + if (!p) + failwith_xl(ERROR_NOMEM, "cannot allocate value"); + *p =3D user; + caml_register_global_root(p); =20 - 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(); =20 - result =3D caml_alloc(1, Abstract_tag); - *((libxl_osevent_hooks **) result) =3D hooks; + result =3D caml_alloc(1, Abstract_tag); + *((libxl_osevent_hooks **) result) =3D hooks; =20 - CAMLreturn(result); + CAMLreturn(result); } =20 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 =3D Int_val(fd); - short c_events =3D Poll_events_val(events); - short c_revents =3D Poll_events_val(revents); + CAMLparam5(ctx, for_libxl, fd, events, revents); + int c_fd =3D Int_val(fd); + short c_events =3D Poll_events_val(events); + short c_revents =3D Poll_events_val(revents); =20 - caml_enter_blocking_section(); - libxl_osevent_occurred_fd(CTX, (void *) for_libxl, c_fd, c_events, c_reve= nts); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_osevent_occurred_fd(CTX, (void *) for_libxl, c_fd, c_events, c_r= events); + caml_leave_blocking_section(); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 value stub_libxl_osevent_occurred_timeout(value ctx, value handles) { - CAMLparam1(ctx); - struct timeout_handles *c_handles =3D (struct timeout_handles *) handles; + CAMLparam1(ctx); + struct timeout_handles *c_handles =3D (struct timeout_handles *) handl= es; =20 - 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(); =20 - caml_remove_global_root(&c_handles->for_app); - free(c_handles); + caml_remove_global_root(&c_handles->for_app); + free(c_handles); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 struct user_with_ctx { - libxl_ctx *ctx; - value user; + libxl_ctx *ctx; + value user; }; =20 void event_occurs(void *user, libxl_event *event) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 2); - struct user_with_ctx *c_user =3D (struct user_with_ctx *) user; - static const value *func =3D NULL; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 2); + struct user_with_ctx *c_user =3D (struct user_with_ctx *) user; + static const value *func =3D NULL; =20 - if (func =3D=3D NULL) { - /* First time around, lookup by name */ - func =3D caml_named_value("libxl_event_occurs_callback"); - } + if (func =3D=3D NULL) { + /* First time around, lookup by name */ + func =3D caml_named_value("libxl_event_occurs_callback"); + } =20 - args[0] =3D c_user->user; - args[1] =3D Val_event(event); - libxl_event_free(c_user->ctx, event); + args[0] =3D c_user->user; + args[1] =3D Val_event(event); + libxl_event_free(c_user->ctx, event); =20 - caml_callbackN(*func, 2, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 2, args); + CAMLdone; + caml_enter_blocking_section(); } =20 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 =3D (struct user_with_ctx *) user; - static const value *func =3D NULL; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + struct user_with_ctx *c_user =3D (struct user_with_ctx *) user; + static const value *func =3D NULL; =20 - if (func =3D=3D NULL) { - /* First time around, lookup by name */ - func =3D caml_named_value("libxl_event_disaster_callback"); - } + if (func =3D=3D NULL) { + /* First time around, lookup by name */ + func =3D caml_named_value("libxl_event_disaster_callback"); + } =20 - args[0] =3D c_user->user; - args[1] =3D Val_event_type(type); - args[2] =3D caml_copy_string(msg); - args[3] =3D Val_int(errnoval); + args[0] =3D c_user->user; + args[1] =3D Val_event_type(type); + args[2] =3D caml_copy_string(msg); + args[3] =3D Val_int(errnoval); =20 - caml_callbackN(*func, 4, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 4, args); + CAMLdone; + caml_enter_blocking_section(); } =20 value stub_libxl_event_register_callbacks(value ctx, value user) { - CAMLparam2(ctx, user); - CAMLlocal1(result); - struct user_with_ctx *c_user =3D NULL; - libxl_event_hooks *hooks; + CAMLparam2(ctx, user); + CAMLlocal1(result); + struct user_with_ctx *c_user =3D NULL; + libxl_event_hooks *hooks; =20 - c_user =3D malloc(sizeof(*c_user)); - if (!c_user) - failwith_xl(ERROR_NOMEM, "cannot allocate user value"); - c_user->user =3D user; - c_user->ctx =3D CTX; - caml_register_global_root(&c_user->user); + c_user =3D malloc(sizeof(*c_user)); + if (!c_user) + failwith_xl(ERROR_NOMEM, "cannot allocate user value"); + c_user->user =3D user; + c_user->ctx =3D CTX; + caml_register_global_root(&c_user->user); =20 - hooks =3D malloc(sizeof(*hooks)); - if (!hooks) - failwith_xl(ERROR_NOMEM, "cannot allocate event hooks"); - hooks->event_occurs_mask =3D LIBXL_EVENTMASK_ALL; - hooks->event_occurs =3D event_occurs; - hooks->disaster =3D disaster; + hooks =3D malloc(sizeof(*hooks)); + if (!hooks) + failwith_xl(ERROR_NOMEM, "cannot allocate event hooks"); + hooks->event_occurs_mask =3D LIBXL_EVENTMASK_ALL; + hooks->event_occurs =3D event_occurs; + hooks->disaster =3D disaster; =20 - 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(); =20 - result =3D caml_alloc(1, Abstract_tag); - *((libxl_event_hooks **) result) =3D hooks; + result =3D caml_alloc(1, Abstract_tag); + *((libxl_event_hooks **) result) =3D hooks; =20 - CAMLreturn(result); + CAMLreturn(result); } =20 value stub_libxl_evenable_domain_death(value ctx, value domid, value user) { - CAMLparam3(ctx, domid, user); - uint32_t c_domid =3D Int_val(domid); - int c_user =3D Int_val(user); - libxl_evgen_domain_death *evgen_out; + CAMLparam3(ctx, domid, user); + uint32_t c_domid =3D Int_val(domid); + int c_user =3D Int_val(user); + libxl_evgen_domain_death *evgen_out; =20 - 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(); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 /* 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 =3D (String.concat "\000" ls) ^ "\000" let queue con pkt =3D let r =3D Xb.queue con pkt in assert (r <> None) let queue_path ty (tid: int) (path: string) con =3D - let data =3D data_concat [ path; ] in - queue con (Xb.Packet.create tid 0 ty data) + let data =3D data_concat [ path; ] in + queue con (Xb.Packet.create tid 0 ty data) =20 (* operations *) let directory tid path con =3D queue_path Xb.Op.Directory tid path con @@ -28,48 +28,48 @@ let read tid path con =3D queue_path Xb.Op.Read tid pat= h con let getperms tid path con =3D queue_path Xb.Op.Getperms tid path con =20 let debug commands con =3D - 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)) =20 let watch path data con =3D - let data =3D data_concat [ path; data; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) + let data =3D data_concat [ path; data; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) =20 let unwatch path data con =3D - let data =3D data_concat [ path; data; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) + let data =3D data_concat [ path; data; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) =20 let transaction_start con =3D - 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 [])) =20 let transaction_end tid commit con =3D - let data =3D data_concat [ (if commit then "T" else "F"); ] in - queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data) + let data =3D data_concat [ (if commit then "T" else "F"); ] in + queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data) =20 let introduce domid mfn port con =3D - let data =3D 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 =3D 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) =20 let release domid con =3D - let data =3D data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Release data) + let data =3D data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Release data) =20 let resume domid con =3D - let data =3D data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) + let data =3D data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) =20 let getdomainpath domid con =3D - let data =3D data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data) + let data =3D data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data) =20 let write tid path value con =3D - let data =3D path ^ "\000" ^ value (* no NULL at the end *) in - queue con (Xb.Packet.create tid 0 Xb.Op.Write data) + let data =3D path ^ "\000" ^ value (* no NULL at the end *) in + queue con (Xb.Packet.create tid 0 Xb.Op.Write data) =20 let mkdir tid path con =3D queue_path Xb.Op.Mkdir tid path con let rm tid path con =3D queue_path Xb.Op.Rm tid path con =20 let setperms tid path perms con =3D - let data =3D data_concat [ path; perms ] in - queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data) + let data =3D 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 =3D Xsraw.con type domid =3D int =20 type xsh =3D -{ - 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; + } =20 let get_operations con =3D { - con =3D con; - debug =3D (fun commands -> Xsraw.debug commands con); - directory =3D (fun path -> Xsraw.directory 0 path con); - read =3D (fun path -> Xsraw.read 0 path con); - readv =3D (fun dir vec -> Xsraw.readv 0 dir vec con); - write =3D (fun path value -> Xsraw.write 0 path value con); - writev =3D (fun dir vec -> Xsraw.writev 0 dir vec con); - mkdir =3D (fun path -> Xsraw.mkdir 0 path con); - rm =3D (fun path -> Xsraw.rm 0 path con); - getperms =3D (fun path -> Xsraw.getperms 0 path con); - setperms =3D (fun path perms -> Xsraw.setperms 0 path perms con); - setpermsv =3D (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con); - introduce =3D (fun id mfn port -> Xsraw.introduce id mfn port con); - release =3D (fun id -> Xsraw.release id con); - resume =3D (fun id -> Xsraw.resume id con); - getdomainpath =3D (fun id -> Xsraw.getdomainpath id con); - watch =3D (fun path data -> Xsraw.watch path data con); - unwatch =3D (fun path data -> Xsraw.unwatch path data con); + con =3D con; + debug =3D (fun commands -> Xsraw.debug commands con); + directory =3D (fun path -> Xsraw.directory 0 path con); + read =3D (fun path -> Xsraw.read 0 path con); + readv =3D (fun dir vec -> Xsraw.readv 0 dir vec con); + write =3D (fun path value -> Xsraw.write 0 path value con); + writev =3D (fun dir vec -> Xsraw.writev 0 dir vec con); + mkdir =3D (fun path -> Xsraw.mkdir 0 path con); + rm =3D (fun path -> Xsraw.rm 0 path con); + getperms =3D (fun path -> Xsraw.getperms 0 path con); + setperms =3D (fun path perms -> Xsraw.setperms 0 path perms con); + setpermsv =3D (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con); + introduce =3D (fun id mfn port -> Xsraw.introduce id mfn port con); + release =3D (fun id -> Xsraw.release id con); + resume =3D (fun id -> Xsraw.resume id con); + getdomainpath =3D (fun id -> Xsraw.getdomainpath id con); + watch =3D (fun path data -> Xsraw.watch path data con); + unwatch =3D (fun path data -> Xsraw.unwatch path data con); } =20 let transaction xsh =3D Xst.transaction xsh.con @@ -81,71 +81,71 @@ exception Timeout_with_nonempty_queue let max_blocking_time =3D 5. (* seconds *) =20 let read_watchevent_timeout xsh timeout callback =3D - let start_time =3D Unix.gettimeofday () in - let end_time =3D start_time +. timeout in + let start_time =3D Unix.gettimeofday () in + let end_time =3D start_time +. timeout in =20 - let left =3D ref timeout in + let left =3D ref timeout in =20 - (* Returns true if a watch event in the queue satisfied us *) - let process_queued_events () =3D - let success =3D ref false in - while Xsraw.has_watchevents xsh.con && not(!success) - do - success :=3D 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 () =3D - let fd =3D get_fd xsh in - let r, _, _ =3D Unix.select [ fd ] [] [] (min max_blocking_time !left) in + (* Returns true if a watch event in the queue satisfied us *) + let process_queued_events () =3D + let success =3D ref false in + while Xsraw.has_watchevents xsh.con && not(!success) + do + success :=3D 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 () =3D + let fd =3D get_fd xsh in + let r, _, _ =3D Unix.select [ fd ] [] [] (min max_blocking_time !left)= in =20 - (* If data is available for reading then read it *) - if r =3D [] - 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 =3D [] + then false (* timeout, either a max_blocking_time or global *) + else callback (Xsraw.read_watchevent xsh.con) in =20 - let success =3D 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 =3D 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 *) =20 - (* First process all queued watch events *) - if not(!success) - then success :=3D process_queued_events (); - (* Then block for one more watch event *) - if not(!success) - then success :=3D 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 :=3D process_queued_events (); + (* First process all queued watch events *) + if not(!success) + then success :=3D process_queued_events (); + (* Then block for one more watch event *) + if not(!success) + then success :=3D 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 :=3D process_queued_events (); =20 - (* Update the time left *) - let current_time =3D Unix.gettimeofday () in - left :=3D 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 =3D Unix.gettimeofday () in + left :=3D 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 =20 =20 let monitor_paths xsh l time callback =3D - let unwatch () =3D - 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 () =3D + 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 () =20 let daemon_socket =3D Paths.xen_run_stored ^ "/socket" =20 @@ -153,24 +153,24 @@ let daemon_socket =3D Paths.xen_run_stored ^ "/socket" exception Failed_to_connect =20 let daemon_open () =3D - try - let sockaddr =3D Unix.ADDR_UNIX(daemon_socket) in - let sock =3D 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 =3D Unix.ADDR_UNIX(daemon_socket) in + let sock =3D 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 =20 let domain_open () =3D - let path =3D try - let devpath =3D "/dev/xen/xenbus" in - Unix.access devpath [ Unix.F_OK ]; - devpath - with Unix.Unix_error(_, _, _) -> - "/proc/xen/xenbus" in + let path =3D try + let devpath =3D "/dev/xen/xenbus" in + Unix.access devpath [ Unix.F_OK ]; + devpath + with Unix.Unix_error(_, _, _) -> + "/proc/xen/xenbus" in =20 - let fd =3D Unix.openfile path [ Unix.O_RDWR ] 0o550 in - Unix.set_close_on_exec fd; - make fd + let fd =3D Unix.openfile path [ Unix.O_RDWR ] 0o550 in + Unix.set_close_on_exec fd; + make fd =20 let close xsh =3D 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 =3D Xsraw.perms =20 type domid =3D int type con =20 type xsh =3D { - 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; } =20 (** 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 =20 (** 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 =20 let unexpected_packet expected received =3D - let s =3D Printf.sprintf "expecting %s received %s" - (Xb.Op.to_string expected) - (Xb.Op.to_string received) in - raise (Unexpected_packet s) + let s =3D Printf.sprintf "expecting %s received %s" + (Xb.Op.to_string expected) + (Xb.Op.to_string received) in + raise (Unexpected_packet s) =20 type con =3D { - xb: Xenbus.Xb.t; - watchevents: (string * string) Queue.t; + xb: Xenbus.Xb.t; + watchevents: (string * string) Queue.t; } =20 let close con =3D - Xb.close con.xb + Xb.close con.xb =20 let capacity =3D { Xb.maxoutstanding =3D 1; maxwatchevents =3D 0; } =20 let open_fd fd =3D { - xb =3D Xb.open_fd ~capacity fd; - watchevents =3D Queue.create (); + xb =3D Xb.open_fd ~capacity fd; + watchevents =3D Queue.create (); } =20 let rec split_string ?limit:(limit=3D(-1)) c s =3D - let i =3D try String.index s c with Not_found -> -1 in - let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - 1 in - if i =3D -1 || nlimit =3D 0 then - [ s ] - else - let a =3D String.sub s 0 i - and b =3D String.sub s (i + 1) (String.length s - i - 1) in - a :: (split_string ~limit: nlimit c b) + let i =3D try String.index s c with Not_found -> -1 in + let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - 1 = in + if i =3D -1 || nlimit =3D 0 then + [ s ] + else + let a =3D String.sub s 0 i + and b =3D String.sub s (i + 1) (String.length s - i - 1) in + a :: (split_string ~limit: nlimit c b) =20 type perm =3D PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR =20 type perms =3D int * perm * (int * perm) list =20 let string_of_perms perms =3D - let owner, other, acl =3D perms in - let char_of_perm perm =3D - match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' - | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in - let string_of_perm (id, perm) =3D Printf.sprintf "%c%u" (char_of_perm per= m) id in - String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) + let owner, other, acl =3D perms in + let char_of_perm perm =3D + match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' + | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in + let string_of_perm (id, perm) =3D Printf.sprintf "%c%u" (char_of_perm pe= rm) id in + String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) =20 let perms_of_string s =3D - let perm_of_char c =3D - 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 =3D - if String.length s < 2 - then invalid_arg (Printf.sprintf "perm of string: length =3D %d; content= s=3D\"%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 =3D - try let i =3D 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 =3D "" then [] else [ s ] in - let l =3D 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 =3D + match c with 'n' -> PERM_NONE | 'r' -> PERM_READ + | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR + | c -> invalid_arg (Printf.sprintf "unkn= own permission type: %c" c) in + let perm_of_string s =3D + if String.length s < 2 + then invalid_arg (Printf.sprintf "perm of string: length =3D %d; conte= nts=3D\"%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 =3D + try let i =3D 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 =3D "" then [] else [ s ] in + let l =3D List.map perm_of_string (split s) in + match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, []) =20 (* send one packet - can sleep *) let pkt_send con =3D - if Xb.has_old_output con.xb then - raise Partial_not_empty; - let workdone =3D ref false in - while not !workdone - do - workdone :=3D Xb.output con.xb - done + if Xb.has_old_output con.xb then + raise Partial_not_empty; + let workdone =3D ref false in + while not !workdone + do + workdone :=3D Xb.output con.xb + done =20 (* receive one packet - can sleep *) let rec pkt_recv con =3D - 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 =20 let pkt_recv_timeout con timeout =3D - let fd =3D Xb.get_fd con.xb in - let r, _, _ =3D Unix.select [ fd ] [] [] timeout in - if r =3D [] then - true, None - else - false, Xb.input con.xb + let fd =3D Xb.get_fd con.xb in + let r, _, _ =3D Unix.select [ fd ] [] [] timeout in + if r =3D [] then + true, None + else + false, Xb.input con.xb =20 let queue_watchevent con data =3D - let ls =3D split_string ~limit:2 '\000' data in - if List.length ls !=3D 2 then - raise (Xb.Packet.DataError "arguments number mismatch"); - let event =3D List.nth ls 0 - and event_data =3D List.nth ls 1 in - Queue.push (event, event_data) con.watchevents + let ls =3D split_string ~limit:2 '\000' data in + if List.length ls !=3D 2 then + raise (Xb.Packet.DataError "arguments number mismatch"); + let event =3D List.nth ls 0 + and event_data =3D List.nth ls 1 in + Queue.push (event, event_data) con.watchevents =20 let has_watchevents con =3D Queue.length con.watchevents > 0 let get_watchevent con =3D Queue.pop con.watchevents =20 let read_watchevent con =3D - let pkt =3D 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 =3D 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 =20 (* send one packet in the queue, and wait for reply *) let rec sync_recv ty con =3D - let pkt =3D 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 =3D ty -> Xb.Packet.get_data pkt - | rty -> unexpected_packet ty rty + let pkt =3D 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 =3D ty -> Xb.Packet.get_data pkt + | rty -> unexpected_packet ty rty =20 let sync f con =3D - (* queue a query using function f *) - f con.xb; - if Xb.output_len con.xb =3D 0 then - Printf.printf "output len =3D 0\n%!"; - let ty =3D 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 =3D 0 then + Printf.printf "output len =3D 0\n%!"; + let ty =3D Xb.Packet.get_ty (Xb.peek_output con.xb) in + pkt_send con; + sync_recv ty con =20 let ack s =3D - if s =3D "OK" then () else raise (Xb.Packet.DataError s) + if s =3D "OK" then () else raise (Xb.Packet.DataError s) =20 (** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT wa= tches) *) let validate_path path =3D - (* Paths shouldn't have a "//" in the middle *) - let bad =3D "//" in - for offset =3D 0 to String.length path - (String.length bad) do - if String.sub path offset (String.length bad) =3D 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] =3D '/' then - raise (Invalid_path path) + (* Paths shouldn't have a "//" in the middle *) + let bad =3D "//" in + for offset =3D 0 to String.length path - (String.length bad) do + if String.sub path offset (String.length bad) =3D 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] =3D '/' th= en + raise (Invalid_path path) =20 (** Check to see if a path is suitable for watches *) let validate_watch_path path =3D - (* Check for stuff like @releaseDomain etc first *) - if path <> "" && path.[0] =3D '@' then () - else validate_path path + (* Check for stuff like @releaseDomain etc first *) + if path <> "" && path.[0] =3D '@' then () + else validate_path path =20 let debug command con =3D - sync (Queueop.debug command) con + sync (Queueop.debug command) con =20 let directory tid path con =3D - validate_path path; - let data =3D sync (Queueop.directory tid path) con in - split_string '\000' data + validate_path path; + let data =3D sync (Queueop.directory tid path) con in + split_string '\000' data =20 let read tid path con =3D - validate_path path; - sync (Queueop.read tid path) con + validate_path path; + sync (Queueop.read tid path) con =20 let readv tid dir vec con =3D - 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) =20 let getperms tid path con =3D - validate_path path; - perms_of_string (sync (Queueop.getperms tid path) con) + validate_path path; + perms_of_string (sync (Queueop.getperms tid path) con) =20 let watch path data con =3D - validate_watch_path path; - ack (sync (Queueop.watch path data) con) + validate_watch_path path; + ack (sync (Queueop.watch path data) con) =20 let unwatch path data con =3D - validate_watch_path path; - ack (sync (Queueop.unwatch path data) con) + validate_watch_path path; + ack (sync (Queueop.unwatch path data) con) =20 let transaction_start con =3D - let data =3D sync (Queueop.transaction_start) con in - try - int_of_string data - with - _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" da= ta)) + let data =3D sync (Queueop.transaction_start) con in + try + int_of_string data + with + _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" = data)) =20 let transaction_end tid commit con =3D - 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 =20 let introduce domid mfn port con =3D - ack (sync (Queueop.introduce domid mfn port) con) + ack (sync (Queueop.introduce domid mfn port) con) =20 let release domid con =3D - ack (sync (Queueop.release domid) con) + ack (sync (Queueop.release domid) con) =20 let resume domid con =3D - ack (sync (Queueop.resume domid) con) + ack (sync (Queueop.resume domid) con) =20 let getdomainpath domid con =3D - sync (Queueop.getdomainpath domid) con + sync (Queueop.getdomainpath domid) con =20 let write tid path value con =3D - validate_path path; - ack (sync (Queueop.write tid path value) con) + validate_path path; + ack (sync (Queueop.write tid path value) con) =20 let writev tid dir vec con =3D - List.iter (fun (entry, value) -> - let path =3D (if dir <> "" then dir ^ "/" ^ entry else entry) in - validate_path path; - write tid path value con) vec + List.iter (fun (entry, value) -> + let path =3D (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + write tid path value con) vec =20 let mkdir tid path con =3D - validate_path path; - ack (sync (Queueop.mkdir tid path) con) + validate_path path; + ack (sync (Queueop.mkdir tid path) con) =20 let rm tid path con =3D - 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 -> () =20 let setperms tid path perms con =3D - 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) =20 let setpermsv tid dir vec perms con =3D - List.iter (fun entry -> - let path =3D (if dir <> "" then dir ^ "/" ^ entry else entry) in - validate_path path; - setperms tid path perms con) vec + List.iter (fun entry -> + let path =3D (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 @@ *) =20 type ops =3D -{ - 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; + } =20 let get_operations tid xsh =3D { - directory =3D (fun path -> Xsraw.directory tid path xsh); - read =3D (fun path -> Xsraw.read tid path xsh); - readv =3D (fun dir vec -> Xsraw.readv tid dir vec xsh); - write =3D (fun path value -> Xsraw.write tid path value xsh); - writev =3D (fun dir vec -> Xsraw.writev tid dir vec xsh); - mkdir =3D (fun path -> Xsraw.mkdir tid path xsh); - rm =3D (fun path -> Xsraw.rm tid path xsh); - getperms =3D (fun path -> Xsraw.getperms tid path xsh); - setperms =3D (fun path perms -> Xsraw.setperms tid path perms xsh); - setpermsv =3D (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh= ); + directory =3D (fun path -> Xsraw.directory tid path xsh); + read =3D (fun path -> Xsraw.read tid path xsh); + readv =3D (fun dir vec -> Xsraw.readv tid dir vec xsh); + write =3D (fun path value -> Xsraw.write tid path value xsh); + writev =3D (fun dir vec -> Xsraw.writev tid dir vec xsh); + mkdir =3D (fun path -> Xsraw.mkdir tid path xsh); + rm =3D (fun path -> Xsraw.rm tid path xsh); + getperms =3D (fun path -> Xsraw.getperms tid path xsh); + setperms =3D (fun path perms -> Xsraw.setperms tid path perms xsh); + setpermsv =3D (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xs= h); } =20 let transaction xsh (f: ops -> 'a) : 'a =3D - let commited =3D ref false and result =3D ref None in - while not !commited - do - let tid =3D Xsraw.transaction_start xsh in - let t =3D get_operations tid xsh in + let commited =3D ref false and result =3D ref None in + while not !commited + do + let tid =3D Xsraw.transaction_start xsh in + let t =3D get_operations tid xsh in =20 - begin try - result :=3D Some (f t) - with exn -> - ignore (Xsraw.transaction_end tid false xsh); - raise exn - end; - commited :=3D Xsraw.transaction_end tid true xsh - done; - match !result with - | None -> failwith "internal error in transaction" - | Some result -> result + begin try + result :=3D Some (f t) + with exn -> + ignore (Xsraw.transaction_end tid false xsh); + raise exn + end; + commited :=3D 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 =3D { - 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; } =20 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 @@ =20 let _ =3D - Xenlight.register_exceptions (); - let logger =3D Xtl.create_stdio_logger ~level:Xentoollog.Debug () in - let ctx =3D Xenlight.ctx_alloc logger in + Xenlight.register_exceptions (); + let logger =3D Xtl.create_stdio_logger ~level:Xentoollog.Debug () in + let ctx =3D Xenlight.ctx_alloc logger in =20 - let open Xenlight.Host in - let reader =3D xen_console_read_start ctx 0 in - (try - while true do - let line =3D xen_console_read_line ctx reader in - print_string line - done - with End_of_file -> ()); - let _ =3D xen_console_read_finish ctx reader in - () + let open Xenlight.Host in + let reader =3D xen_console_read_start ctx 0 in + (try + while true do + let line =3D xen_console_read_line ctx reader in + print_string line + done + with End_of_file -> ()); + let _ =3D xen_console_read_finish ctx reader in + () =20 diff --git a/tools/ocaml/test/list_domains.ml b/tools/ocaml/test/list_domai= ns.ml index c8974957fd..94f1cec050 100644 --- a/tools/ocaml/test/list_domains.ml +++ b/tools/ocaml/test/list_domains.ml @@ -20,7 +20,7 @@ let _ =3D let domains =3D 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) f= n; + end =20 =20 diff --git a/tools/ocaml/test/raise_exception.ml b/tools/ocaml/test/raise_e= xception.ml index 5ef7fc0f13..8c24c3555b 100644 --- a/tools/ocaml/test/raise_exception.ml +++ b/tools/ocaml/test/raise_exception.ml @@ -4,6 +4,6 @@ let _ =3D 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) f= n; + end =20 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 =20 let stdio_vmessage min_level level errno ctx msg =3D - let level_str =3D level_to_string level - and errno_str =3D match errno with None -> "" | Some s -> sprintf ": errn= o=3D%d" s - and ctx_str =3D match ctx with None -> "" | Some s -> sprintf ": %s" s in - if compare min_level level <=3D 0 then begin - printf "%s%s%s: %s\n" level_str ctx_str errno_str msg; - flush stdout; - end + let level_str =3D level_to_string level + and errno_str =3D match errno with None -> "" | Some s -> sprintf ": err= no=3D%d" s + and ctx_str =3D match ctx with None -> "" | Some s -> sprintf ": %s" s in + if compare min_level level <=3D 0 then begin + printf "%s%s%s: %s\n" level_str ctx_str errno_str msg; + flush stdout; + end =20 let stdio_progress _ctx what percent dne total =3D - let nl =3D if dne =3D total then "\n" else "" in - printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl; - flush stdout + let nl =3D if dne =3D total then "\n" else "" in + printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl; + flush stdout =20 let create_stdio_logger ?(level=3DInfo) () =3D - let cbs =3D { - vmessage =3D stdio_vmessage level; - progress =3D stdio_progress; } in - create "Xentoollog.stdio_logger" cbs + let cbs =3D { + vmessage =3D stdio_vmessage level; + progress =3D stdio_progress; } in + create "Xentoollog.stdio_logger" cbs =20 let do_test level =3D let lgr =3D 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 @@ *) =20 type ty =3D - | 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) =20 exception Error of (string * string) list =20 let trim_start lc s =3D - let len =3D String.length s and i =3D 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 =3D String.length s and i =3D 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 "" =20 let trim_end lc s =3D - let i =3D ref (String.length s - 1) in - while !i > 0 && (List.mem s.[!i] lc) - do - decr i - done; - if !i >=3D 0 then String.sub s 0 (!i + 1) else "" + let i =3D ref (String.length s - 1) in + while !i > 0 && (List.mem s.[!i] lc) + do + decr i + done; + if !i >=3D 0 then String.sub s 0 (!i + 1) else "" =20 let rec split ?limit:(limit=3D(-1)) c s =3D - let i =3D try String.index s c with Not_found -> -1 in - let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - 1 in - if i =3D -1 || nlimit =3D 0 then - [ s ] - else - let a =3D String.sub s 0 i - and b =3D String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) + let i =3D try String.index s c with Not_found -> -1 in + let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - 1 = in + if i =3D -1 || nlimit =3D 0 then + [ s ] + else + let a =3D String.sub s 0 i + and b =3D String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) =20 let parse_line stream =3D - let lc =3D [ ' '; '\t' ] in - let trim_spaces s =3D trim_end lc (trim_start lc s) in - let to_config s =3D - match split ~limit:2 '=3D' s with - | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) - | _ -> None in - let rec read_filter_line () =3D - try - let line =3D 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 =3D [ ' '; '\t' ] in + let trim_spaces s =3D trim_end lc (trim_start lc s) in + let to_config s =3D + match split ~limit:2 '=3D' s with + | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) + | _ -> None in + let rec read_filter_line () =3D + try + let line =3D 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 () =20 let parse filename =3D - let stream =3D open_in filename in - let cf =3D parse_line stream in - close_in stream; - cf + let stream =3D open_in filename in + let cf =3D parse_line stream in + close_in stream; + cf =20 let validate cf expected other =3D - let err =3D ref [] in - let append x =3D err :=3D x :: !err in - List.iter (fun (k, v) -> - try - if not (List.mem_assoc k expected) then - other k v - else let ty =3D 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 :=3D (bool_of_string v) - | Set_string r -> r :=3D v - | Set_int r -> r :=3D int_of_string v - | Set_float r -> r :=3D (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 !=3D [] then raise (Error !err) + let err =3D ref [] in + let append x =3D err :=3D x :: !err in + List.iter (fun (k, v) -> + try + if not (List.mem_assoc k expected) then + other k v + else let ty =3D 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 :=3D (bool_of_string v) + | Set_string r -> r :=3D v + | Set_int r -> r :=3D int_of_string v + | Set_float r -> r :=3D (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 !=3D [] then raise (Error !err) =20 (** read a filename, parse and validate, and return the errors if any *) let read filename expected other =3D - let cf =3D parse filename in - validate cf expected other + let cf =3D parse filename in + validate cf expected other diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/co= nnection.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 =3D '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 - *) +*) =20 module BoundedPipe : sig - type 'a t + type 'a t =20 - (** [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 =20 - (** [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 =20 - (** [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 =20 - (** [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 =20 - (** [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 =3D struct - (* items are enqueued in [q], and then flushed to [connect_to] *) - type 'a t =3D - { q: 'a Queue.t - ; destination: 'a bounded_sender - ; capacity: int - } + (* items are enqueued in [q], and then flushed to [connect_to] *) + type 'a t =3D + { q: 'a Queue.t + ; destination: 'a bounded_sender + ; capacity: int + } =20 - let create ~capacity ~destination =3D - { q =3D Queue.create (); capacity; destination } + let create ~capacity ~destination =3D + { q =3D Queue.create (); capacity; destination } =20 - let rec flush_pipe t =3D - if not Queue.(is_empty t.q) then - let item =3D Queue.peek t.q in - match t.destination item with - | None -> () (* no room *) - | Some () -> - (* successfully sent item to next stage *) - let _ =3D Queue.pop t.q in - (* continue trying to send more items *) - flush_pipe t + let rec flush_pipe t =3D + if not Queue.(is_empty t.q) then + let item =3D Queue.peek t.q in + match t.destination item with + | None -> () (* no room *) + | Some () -> + (* successfully sent item to next stage *) + let _ =3D Queue.pop t.q in + (* continue trying to send more items *) + flush_pipe t =20 - let push t item =3D - (* first try to flush as many items from this pipe as possible to make r= oom, - 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 recei= ve them - *) - Queue.push item t.q; - Some (flush_pipe t) - end else None + let push t item =3D + (* 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 re= ceive them + *) + Queue.push item t.q; + Some (flush_pipe t) + end else None =20 - let is_empty t =3D Queue.is_empty t.q - let length t =3D Queue.length t.q + let is_empty t =3D Queue.is_empty t.q + let length t =3D Queue.length t.q end =20 type watch =3D { - 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; } =20 and t =3D { - 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 } =20 module Watch =3D struct - module T =3D struct - type t =3D watch + module T =3D struct + type t =3D watch =20 - let compare w1 w2 =3D - (* cannot compare watches from different connections *) - assert (w1.con =3D=3D w2.con); - match String.compare w1.token w2.token with - | 0 -> String.compare w1.path w2.path - | n -> n - end - module Set =3D Set.Make(T) + let compare w1 w2 =3D + (* cannot compare watches from different connections *) + assert (w1.con =3D=3D w2.con); + match String.compare w1.token w2.token with + | 0 -> String.compare w1.path w2.path + | n -> n + end + module Set =3D Set.Make(T) =20 - let flush_events t =3D - BoundedPipe.flush_pipe t.pending_watchevents; - not (BoundedPipe.is_empty t.pending_watchevents) + let flush_events t =3D + BoundedPipe.flush_pipe t.pending_watchevents; + not (BoundedPipe.is_empty t.pending_watchevents) =20 - let pending_watchevents t =3D - BoundedPipe.length t.pending_watchevents + let pending_watchevents t =3D + BoundedPipe.length t.pending_watchevents end =20 let source_flush_watchevents t =3D - BoundedPipe.flush_pipe t.pending_source_watchevents + BoundedPipe.flush_pipe t.pending_source_watchevents =20 let source_pending_watchevents t =3D - BoundedPipe.length t.pending_source_watchevents + BoundedPipe.length t.pending_source_watchevents =20 let mark_as_bad con =3D - match con.dom with - |None -> () - | Some domain -> Domain.mark_as_bad domain + match con.dom with + |None -> () + | Some domain -> Domain.mark_as_bad domain =20 let initial_next_tid =3D 1 =20 let do_reconnect con =3D - 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 *) + () =20 let get_path con =3D -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) =20 let watch_create ~con ~path ~token =3D { - con =3D con; - token =3D token; - path =3D path; - base =3D get_path con; - is_relative =3D path.[0] <> '/' && path.[0] <> '@'; - pending_watchevents =3D BoundedPipe.create ~capacity:!Define.maxwatcheven= ts ~destination:(Xenbus.Xb.queue con.xb) + con =3D con; + token =3D token; + path =3D path; + base =3D get_path con; + is_relative =3D path.[0] <> '/' && path.[0] <> '@'; + pending_watchevents =3D BoundedPipe.create ~capacity:!Define.maxwatcheve= nts ~destination:(Xenbus.Xb.queue con.xb) } =20 let get_con w =3D w.con =20 let number_of_transactions con =3D - Hashtbl.length con.transactions + Hashtbl.length con.transactions =20 let get_domain con =3D con.dom =20 let anon_id_next =3D ref 1 =20 let get_domstr con =3D - 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)) =20 let make_perm dom =3D - let domid =3D - match dom with - | None -> 0 - | Some d -> Domain.get_id d - in - Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid + let domid =3D + match dom with + | None -> 0 + | Some d -> Domain.get_id d + in + Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid =20 let create xbcon dom =3D - let destination (watch, pkt) =3D - BoundedPipe.push watch.pending_watchevents pkt - in - let id =3D - match dom with - | None -> let old =3D !anon_id_next in incr anon_id_next; old - | Some _ -> 0 - in - let con =3D - { - xb =3D xbcon; - dom =3D dom; - transactions =3D Hashtbl.create 5; - next_tid =3D initial_next_tid; - watches =3D Hashtbl.create 8; - nb_watches =3D 0; - anonid =3D id; - stat_nb_ops =3D 0; - perm =3D make_perm dom; + let destination (watch, pkt) =3D + BoundedPipe.push watch.pending_watchevents pkt + in + let id =3D + match dom with + | None -> let old =3D !anon_id_next in incr anon_id_next; old + | Some _ -> 0 + in + let con =3D + { + xb =3D xbcon; + dom =3D dom; + transactions =3D Hashtbl.create 5; + next_tid =3D initial_next_tid; + watches =3D Hashtbl.create 8; + nb_watches =3D 0; + anonid =3D id; + stat_nb_ops =3D 0; + perm =3D make_perm dom; =20 - (* 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 =3D 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 t= he + domain is blocked from sending more commands until it is empty + again though. + *) + pending_source_watchevents =3D BoundedPipe.create ~capacity:Sys.max_= array_length ~destination + } + in + Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con); + con =20 let get_fd con =3D Xenbus.Xb.get_fd con.xb let close con =3D - 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 =20 let get_perm con =3D - con.perm + con.perm =20 let set_target con target_domid =3D - 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.REA= D; Perms.WRITE] target_domid =20 let is_backend_mmap con =3D Xenbus.Xb.is_mmap con.xb =20 let packet_of con tid rid ty data =3D - if (String.length data) > xenstore_payload_max && (is_backend_mmap con) t= hen - 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 =20 let send_reply con tid rid ty data =3D - let result =3D 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 roo= m for an output packet *) - (* and the limit for replies is different from the limit for watch events= *) - assert (result <> None) + let result =3D 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 ro= om for an output packet *) + (* and the limit for replies is different from the limit for watch event= s *) + assert (result <> None) =20 let send_error con tid rid err =3D send_reply con tid rid Xenbus.Xb.Op.Err= or (err ^ "\000") let send_ack con tid rid ty =3D send_reply con tid rid ty "OK\000" =20 let get_watch_path con path =3D - if path.[0] =3D '@' || path.[0] =3D '/' then - path - else - let rpath =3D get_path con in - rpath ^ path + if path.[0] =3D '@' || path.[0] =3D '/' then + path + else + let rpath =3D get_path con in + rpath ^ path =20 let get_watches (con: t) path =3D - 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 [] =20 let get_children_watches con path =3D - let path =3D path ^ "/" in - List.concat (Hashtbl.fold (fun p w l -> - if String.startswith path p then w :: l else l) con.watches []) + let path =3D path ^ "/" in + List.concat (Hashtbl.fold (fun p w l -> + if String.startswith path p then w :: l else l) con.watches []) =20 let is_dom0 con =3D - Perms.Connection.is_dom0 (get_perm con) + Perms.Connection.is_dom0 (get_perm con) =20 let add_watch con (path, apath) token =3D - if !Quota.activate && !Define.maxwatch > 0 && - not (is_dom0 con) && con.nb_watches > !Define.maxwatch then - raise Quota.Limit_reached; - let l =3D get_watches con apath in - if List.exists (fun w -> w.token =3D token) l then - raise Define.Already_exist; - let watch =3D 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 =3D get_watches con apath in + if List.exists (fun w -> w.token =3D token) l then + raise Define.Already_exist; + let watch =3D watch_create ~con ~token ~path in + Hashtbl.replace con.watches apath (watch :: l); + con.nb_watches <- con.nb_watches + 1; + watch =20 let del_watch con path token =3D - let apath =3D get_watch_path con path in - let ws =3D Hashtbl.find con.watches apath in - let w =3D List.find (fun w -> w.token =3D token) ws in - let filtered =3D 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 =3D get_watch_path con path in + let ws =3D Hashtbl.find con.watches apath in + let w =3D List.find (fun w -> w.token =3D token) ws in + let filtered =3D 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 =20 let del_watches con =3D Hashtbl.reset con.watches; @@ -308,101 +308,101 @@ let del_transactions con =3D Hashtbl.reset con.transactions =20 let list_watches con =3D - let ll =3D Hashtbl.fold - (fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) wa= tches :: acc) - con.watches [] in - List.concat ll + let ll =3D Hashtbl.fold + (fun _ watches acc -> List.map (fun watch -> watch.path, watch.token= ) watches :: acc) + con.watches [] in + List.concat ll =20 let dbg fmt =3D Logging.debug "connection" fmt let info fmt =3D Logging.info "connection" fmt =20 let lookup_watch_perm path =3D 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 -> [] =20 let lookup_watch_perms oldroot root path =3D - lookup_watch_perm path oldroot @ lookup_watch_perm path (Some root) + lookup_watch_perm path oldroot @ lookup_watch_perm path (Some root) =20 let fire_single_watch_unchecked source watch =3D - let data =3D Utils.join_by_null [watch.path; watch.token; ""] in - let pkt =3D packet_of watch.con Transaction.none 0 Xenbus.Xb.Op.Watcheven= t data in + let data =3D Utils.join_by_null [watch.path; watch.token; ""] in + let pkt =3D packet_of watch.con Transaction.none 0 Xenbus.Xb.Op.Watcheve= nt data in =20 - 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) wi= th + | 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" =20 let fire_single_watch source (oldroot, root) watch =3D - let abspath =3D get_watch_path watch.con watch.path |> Store.Path.of_stri= ng in - let perms =3D 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 =3D perms |> List.map (Perms.Node.to_string ~sep:" ") |> Strin= g.concat ", " in - let con =3D get_domstr watch.con in - Logging.watch_not_fired ~con perms (Store.Path.to_string abspath) + let abspath =3D get_watch_path watch.con watch.path |> Store.Path.of_str= ing in + let perms =3D 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 =3D perms |> List.map (Perms.Node.to_string ~sep:" ") |> Str= ing.concat ", " in + let con =3D get_domstr watch.con in + Logging.watch_not_fired ~con perms (Store.Path.to_string abspath) =20 let fire_watch source roots watch path =3D - let new_path =3D - if watch.is_relative && path.[0] =3D '/' - then begin - let n =3D String.length watch.base - and m =3D String.length path in - String.sub path n (m - n) - end else - path - in - fire_single_watch source roots { watch with path =3D new_path } + let new_path =3D + if watch.is_relative && path.[0] =3D '/' + then begin + let n =3D String.length watch.base + and m =3D String.length path in + String.sub path n (m - n) + end else + path + in + fire_single_watch source roots { watch with path =3D new_path } =20 (* Search for a valid unused transaction id. *) let rec valid_transaction_id con proposed_id =3D - (* - * 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 =3D if proposed_id <=3D 0 || proposed_id >=3D 0x3fffffff then 1 el= se 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 =3D if proposed_id <=3D 0 || proposed_id >=3D 0x3fffffff then 1 e= lse proposed_id in =20 - 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 =20 let start_transaction con store =3D - if !Define.maxtransaction > 0 && not (is_dom0 con) - && Hashtbl.length con.transactions > !Define.maxtransaction then - raise Quota.Transaction_opened; - let id =3D valid_transaction_id con con.next_tid in - con.next_tid <- id + 1; - let ntrans =3D 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 =3D valid_transaction_id con con.next_tid in + con.next_tid <- id + 1; + let ntrans =3D Transaction.make id store in + Hashtbl.add con.transactions id ntrans; + Logging.start_transaction ~tid:id ~con:(get_domstr con); + id =20 let end_transaction con tid commit =3D - let trans =3D 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 c= on trans + let trans =3D 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 =20 let get_transaction con tid =3D - Hashtbl.find con.transactions tid + Hashtbl.find con.transactions tid =20 let do_input con =3D Xenbus.Xb.input con.xb let has_partial_input con =3D Xenbus.Xb.has_partial_input con.xb @@ -434,53 +434,53 @@ let is_bad con =3D 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 =3D - let has_in =3D has_partial_input con in - let has_out =3D has_output con in - let has_nondefault_perms =3D 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 =3D has_partial_input con in + let has_out =3D has_output con in + let has_nondefault_perms =3D 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 *) =20 let has_transaction_data con =3D - let n =3D number_of_transactions con in - dbg "%s: number of transactions =3D %d" (get_domstr con) n; - n > 0 + let n =3D number_of_transactions con in + dbg "%s: number of transactions =3D %d" (get_domstr con) n; + n > 0 =20 let prevents_live_update con =3D not (is_bad con) - && (has_extra_connection_data con || has_transaction_data con) + && (has_extra_connection_data con || has_tr= ansaction_data con) =20 let has_more_work con =3D - (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 =20 let incr_ops con =3D con.stat_nb_ops <- con.stat_nb_ops + 1 =20 let stats con =3D - Hashtbl.length con.watches, con.stat_nb_ops + Hashtbl.length con.watches, con.stat_nb_ops =20 let dump con chan =3D - let id =3D match con.dom with - | Some dom -> - let domid =3D Domain.get_id dom in - (* dump domain *) - Domain.dump dom chan; - domid - | None -> - let fd =3D 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.hex= ify token) - ) (list_watches con) + let id =3D match con.dom with + | Some dom -> + let domid =3D Domain.get_id dom in + (* dump domain *) + Domain.dump dom chan; + domid + | None -> + let fd =3D 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) =20 let debug con =3D - let domid =3D get_domstr con in - let watches =3D List.map (fun (path, token) -> Printf.sprintf "watch %s: = %s %s\n" domid path token) (list_watches con) in - String.concat "" watches + let domid =3D get_domstr con in + let watches =3D List.map (fun (path, token) -> Printf.sprintf "watch %s:= %s %s\n" domid path token) (list_watches con) in + String.concat "" watches =20 let decr_conflict_credit doms con =3D - match con.dom with - | None -> () (* It's a socket connection. We don't know which domain we'r= e 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/c= onnections.ml index 7d68c583b4..682e1b493c 100644 --- a/tools/ocaml/xenstored/connections.ml +++ b/tools/ocaml/xenstored/connections.ml @@ -18,218 +18,218 @@ let debug fmt =3D Logging.debug "connections" fmt =20 type t =3D { - 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 } =20 let create () =3D { - anonymous =3D Hashtbl.create 37; - domains =3D Hashtbl.create 37; - ports =3D Hashtbl.create 37; - watches =3D Trie.create (); - has_pending_watchevents =3D Connection.Watch.Set.empty; + anonymous =3D Hashtbl.create 37; + domains =3D Hashtbl.create 37; + ports =3D Hashtbl.create 37; + watches =3D Trie.create (); + has_pending_watchevents =3D Connection.Watch.Set.empty; } =20 let get_capacity () =3D - (* not multiplied by maxwatch on purpose: 2nd queue in watch itself! *) - { Xenbus.Xb.maxoutstanding =3D !Define.maxoutstanding; maxwatchevents =3D= !Define.maxwatchevents } + (* not multiplied by maxwatch on purpose: 2nd queue in watch itself! *) + { Xenbus.Xb.maxoutstanding =3D !Define.maxoutstanding; maxwatchevents = =3D !Define.maxwatchevents } =20 let add_anonymous cons fd =3D - let capacity =3D get_capacity () in - let xbcon =3D Xenbus.Xb.open_fd fd ~capacity in - let con =3D Connection.create xbcon None in - Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con + let capacity =3D get_capacity () in + let xbcon =3D Xenbus.Xb.open_fd fd ~capacity in + let con =3D Connection.create xbcon None in + Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con =20 let add_domain cons dom =3D - let capacity =3D get_capacity () in - let xbcon =3D Xenbus.Xb.open_mmap ~capacity (Domain.get_interface dom) (f= un () -> Domain.notify dom) in - let con =3D 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 =3D get_capacity () in + let xbcon =3D Xenbus.Xb.open_mmap ~capacity (Domain.get_interface dom) (= fun () -> Domain.notify dom) in + let con =3D 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 -> () =20 let select ?(only_if =3D (fun _ -> true)) cons =3D - Hashtbl.fold (fun _ con (ins, outs) -> - if (only_if con) then ( - let fd =3D Connection.get_fd con in - let in_fds =3D if Connection.can_input con then fd :: ins else ins in - let out_fds =3D 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 =3D Connection.get_fd con in + let in_fds =3D if Connection.can_input con then fd :: ins else ins= in + let out_fds =3D if Connection.has_output con then fd :: outs else = outs in + in_fds, out_fds + ) else (ins, outs) + ) + cons.anonymous ([], []) =20 let find cons =3D - Hashtbl.find cons.anonymous + Hashtbl.find cons.anonymous =20 let find_domain cons =3D - Hashtbl.find cons.domains + Hashtbl.find cons.domains =20 let find_domain_by_port cons port =3D - Hashtbl.find cons.ports port + Hashtbl.find cons.ports port =20 let del_watches_of_con con watches =3D - match List.filter (fun w -> Connection.get_con w !=3D con) watches with - | [] -> None - | ws -> Some ws + match List.filter (fun w -> Connection.get_con w !=3D con) watches with + | [] -> None + | ws -> Some ws =20 let del_watches cons con =3D - 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 !=3D 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 !=3D con =20 let del_anonymous cons con =3D - 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) =20 let del_domain cons id =3D - try - let con =3D 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 =3D 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) =20 let iter_domains cons fct =3D - Hashtbl.iter (fun _ c -> fct c) cons.domains + Hashtbl.iter (fun _ c -> fct c) cons.domains =20 let iter_anonymous cons fct =3D - Hashtbl.iter (fun _ c -> fct c) cons.anonymous + Hashtbl.iter (fun _ c -> fct c) cons.anonymous =20 let iter cons fct =3D - iter_domains cons fct; iter_anonymous cons fct + iter_domains cons fct; iter_anonymous cons fct =20 let has_more_work cons =3D - 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 [] =20 let key_of_str path =3D - if path.[0] =3D '@' - then [path] - else "" :: Store.Path.to_string_list (Store.Path.of_string path) + if path.[0] =3D '@' + then [path] + else "" :: Store.Path.to_string_list (Store.Path.of_string path) =20 let key_of_path path =3D - "" :: Store.Path.to_string_list path + "" :: Store.Path.to_string_list path =20 let add_watch cons con path token =3D - let apath =3D Connection.get_watch_path con path in - (* fail on invalid paths early by calling key_of_str before adding watch = *) - let key =3D key_of_str apath in - let watch =3D Connection.add_watch con (path, apath) token in - let watches =3D - 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 =3D Connection.get_watch_path con path in + (* fail on invalid paths early by calling key_of_str before adding watch= *) + let key =3D key_of_str apath in + let watch =3D Connection.add_watch con (path, apath) token in + let watches =3D + if Trie.mem cons.watches key + then Trie.find cons.watches key + else [] + in + cons.watches <- Trie.set cons.watches key (watch :: watches); + watch =20 let del_watch cons con path token =3D - let apath, watch =3D Connection.del_watch con path token in - let key =3D key_of_str apath in - let watches =3D Utils.list_remove watch (Trie.find cons.watches key) in - if watches =3D [] then - cons.watches <- Trie.unset cons.watches key - else - cons.watches <- Trie.set cons.watches key watches; - watch + let apath, watch =3D Connection.del_watch con path token in + let key =3D key_of_str apath in + let watches =3D Utils.list_remove watch (Trie.find cons.watches key) in + if watches =3D [] then + cons.watches <- Trie.unset cons.watches key + else + cons.watches <- Trie.set cons.watches key watches; + watch =20 (* path is absolute *) let fire_watches ?oldroot source root cons path recurse =3D - let key =3D key_of_path path in - let path =3D Store.Path.to_string path in - let roots =3D oldroot, root in - let fire_watch _ =3D function - | None -> () - | Some watches -> List.iter (fun w -> Connection.fire_watch source roots= w path) watches - in - let fire_rec _x =3D 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 =3D key_of_path path in + let path =3D Store.Path.to_string path in + let roots =3D oldroot, root in + let fire_watch _ =3D function + | None -> () + | Some watches -> List.iter (fun w -> Connection.fire_watch source roo= ts w path) watches + in + let fire_rec _x =3D 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) =20 let send_watchevents cons con =3D - cons.has_pending_watchevents <- - cons.has_pending_watchevents |> Connection.Watch.Set.filter Connection.W= atch.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 =20 let fire_spec_watches root cons specpath =3D - let source =3D 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 =3D find_domain cons 0 in + iter cons (fun con -> + List.iter (Connection.fire_single_watch source (None, root)) (Connec= tion.get_watches con specpath)) =20 let set_target cons domain target_domain =3D - let con =3D find_domain cons domain in - Connection.set_target con target_domain + let con =3D find_domain cons domain in + Connection.set_target con target_domain =20 let number_of_transactions cons =3D - let res =3D ref 0 in - let aux con =3D - res :=3D Connection.number_of_transactions con + !res - in - iter cons aux; - !res + let res =3D ref 0 in + let aux con =3D + res :=3D Connection.number_of_transactions con + !res + in + iter cons aux; + !res =20 let stats cons =3D - let nb_ops_anon =3D ref 0 - and nb_watchs_anon =3D ref 0 - and nb_ops_dom =3D ref 0 - and nb_watchs_dom =3D ref 0 in - iter_anonymous cons (fun con -> - let con_watchs, con_ops =3D Connection.stats con in - nb_ops_anon :=3D !nb_ops_anon + con_ops; - nb_watchs_anon :=3D !nb_watchs_anon + con_watchs; - ); - iter_domains cons (fun con -> - let con_watchs, con_ops =3D Connection.stats con in - nb_ops_dom :=3D !nb_ops_dom + con_ops; - nb_watchs_dom :=3D !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 =3D ref 0 + and nb_watchs_anon =3D ref 0 + and nb_ops_dom =3D ref 0 + and nb_watchs_dom =3D ref 0 in + iter_anonymous cons (fun con -> + let con_watchs, con_ops =3D Connection.stats con in + nb_ops_anon :=3D !nb_ops_anon + con_ops; + nb_watchs_anon :=3D !nb_watchs_anon + con_watchs; + ); + iter_domains cons (fun con -> + let con_watchs, con_ops =3D Connection.stats con in + nb_ops_dom :=3D !nb_ops_dom + con_ops; + nb_watchs_dom :=3D !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) =20 let debug cons =3D - let anonymous =3D Hashtbl.fold (fun _ con accu -> Connection.debug con ::= accu) cons.anonymous [] in - let domains =3D Hashtbl.fold (fun _ con accu -> Connection.debug con :: a= ccu) cons.domains [] in - String.concat "" (domains @ anonymous) + let anonymous =3D Hashtbl.fold (fun _ con accu -> Connection.debug con := : accu) cons.anonymous [] in + let domains =3D Hashtbl.fold (fun _ con accu -> Connection.debug con :: = accu) cons.domains [] in + String.concat "" (domains @ anonymous) =20 let debug_watchevents cons con =3D - (* =3D=3D (physical equality) - has to be used here because w.con.xb.backend might contain a [unit->un= it] value causing regular - comparison to fail due to having a 'functional value' which cannot be = compared. - *) - let s =3D cons.has_pending_watchevents |> Connection.Watch.Set.filter (fu= n w -> w.con =3D=3D con) in - let pending =3D s |> Connection.Watch.Set.elements - |> List.map (fun w -> Connection.Watch.pending_watchevents w) |> List.fo= ld_left (+) 0 in - Printf.sprintf "Watches with pending events: %d, pending events total: %d= " (Connection.Watch.Set.cardinal s) pending + (* =3D=3D (physical equality) + has to be used here because w.con.xb.backend might contain a [unit->u= nit] value causing regular + comparison to fail due to having a 'functional value' which cannot be= compared. + *) + let s =3D cons.has_pending_watchevents |> Connection.Watch.Set.filter (f= un w -> w.con =3D=3D con) in + let pending =3D 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 =20 let filter ~f cons =3D - let fold _ v acc =3D if f v then v :: acc else acc in - [] - |> Hashtbl.fold fold cons.anonymous - |> Hashtbl.fold fold cons.domains + let fold _ v acc =3D if f v then v :: acc else acc in + [] + |> Hashtbl.fold fold cons.anonymous + |> Hashtbl.fold fold cons.domains =20 let prevents_quit cons =3D 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 =3D ref (1024) (* maximum requests per = transaction *) let maxoutstanding =3D ref (1024) (* maximum outstanding requests, i.e. in= -flight requests / domain *) let maxwatchevents =3D ref (1024) (* - maximum outstanding watch events per watch, - recommended >=3D maxoutstanding to avoid blocking backend transactions du= e to - malicious frontends + maximum outstanding watch events per watch, + recommended >=3D maxoutstanding to avoid blocking backend transactions= due to + malicious frontends *) =20 let gc_max_overhead =3D 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 =3D match c with '0' .. '9' -> true | _ -> false =20 let undec c =3D - 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") =20 let unhex c =3D - let c =3D 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 =3D 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") =20 let string_unescaped s =3D - let len =3D String.length s - and i =3D ref 0 in - let d =3D Buffer.create len in + let len =3D String.length s + and i =3D ref 0 in + let d =3D Buffer.create len in =20 - let read_escape () =3D - incr i; - match s.[!i] with - | 'n' -> '\n' - | 'r' -> '\r' - | '\\' -> '\\' - | '\'' -> '\'' - | '"' -> '"' - | 't' -> '\t' - | 'b' -> '\b' - | 'x' -> - let v =3D (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in - i :=3D !i + 2; - Char.chr v - | c -> - if is_digit c then ( - let v =3D (undec s.[!i]) * 100 + - (undec s.[!i + 1]) * 10 + - (undec s.[!i + 2]) in - i :=3D !i + 2; - Char.chr v - ) else - raise Bad_escape - in + let read_escape () =3D + incr i; + match s.[!i] with + | 'n' -> '\n' + | 'r' -> '\r' + | '\\' -> '\\' + | '\'' -> '\'' + | '"' -> '"' + | 't' -> '\t' + | 'b' -> '\b' + | 'x' -> + let v =3D (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in + i :=3D !i + 2; + Char.chr v + | c -> + if is_digit c then ( + let v =3D (undec s.[!i]) * 100 + + (undec s.[!i + 1]) * 10 + + (undec s.[!i + 2]) in + i :=3D !i + 2; + Char.chr v + ) else + raise Bad_escape + in =20 - while !i < len - do - let c =3D 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 =3D match s.[!i] with + | '\\' -> read_escape () + | c -> c in + Buffer.add_char d c; + incr i + done; + Buffer.contents d =20 (* file -> lines_of_file *) let file_readlines file =3D - let channel =3D open_in file in - let rec input_line_list channel =3D - let line =3D 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 =3D open_in file in + let rec input_line_list channel =3D + let line =3D 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 =20 let rec map_string_list_range l s =3D - 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 =20 let is_digit c =3D - try ignore (int_of_char c); true with _ -> false + try ignore (int_of_char c); true with _ -> false =20 let rec parse_perm s =3D - let len =3D String.length s in - if len =3D 0 then - [] - else - let i =3D ref 1 in - while !i < len && is_digit s.[!i] do incr i done; - let x =3D String.sub s 0 !i - and lx =3D String.sub s !i len in - x :: parse_perm lx + let len =3D String.length s in + if len =3D 0 then + [] + else + let i =3D ref 1 in + while !i < len && is_digit s.[!i] do incr i done; + let x =3D String.sub s 0 !i + and lx =3D String.sub s !i len in + x :: parse_perm lx =20 let read store =3D - (* don't let the permission get on our way, full perm ! *) - let v =3D Store.get_ops store Perms.Connection.full_rights in + (* don't let the permission get on our way, full perm ! *) + let v =3D Store.get_ops store Perms.Connection.full_rights in =20 - (* a line is : path{perm} or path{perm} =3D value *) - let parse_line s =3D - let path, perm, value =3D - let len =3D String.length s in - let si =3D if String.contains s '=3D' then - String.index s '=3D' - else - len - 1 in - let pi =3D String.rindex_from s si '{' in - let epi =3D String.index_from s pi '}' in + (* a line is : path{perm} or path{perm} =3D value *) + let parse_line s =3D + let path, perm, value =3D + let len =3D String.length s in + let si =3D if String.contains s '=3D' then + String.index s '=3D' + else + len - 1 in + let pi =3D String.rindex_from s si '{' in + let epi =3D String.index_from s pi '}' in =20 - if String.contains s '=3D' then - let ss =3D 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 =3D map_string_list_range [ (0, pi); - (pi + 1, epi); - ] s in - (List.nth ss 0, List.nth ss 1, "") - in - let path =3D 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 =3D 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 '=3D' then + let ss =3D 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 =3D map_string_list_range [ (0, pi); + (pi + 1, epi); + ] s in + (List.nth ss 0, List.nth ss 1, "") + in + let path =3D 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 =3D file_readlines xs_daemon_database in + List.iter (fun s -> parse_line s) lines + with exc -> + error "caught exn %s" (Printexc.to_string exc) =20 let write store =3D - if !enable then - try - let tfile =3D Printf.sprintf "%s#" xs_daemon_database in - let channel =3D 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 =3D Printf.sprintf "%s#" xs_daemon_database in + let channel =3D 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 =3D Logging.debug "domain" fmt let warn fmt =3D Logging.warn "domain" fmt =20 type t =3D -{ - 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 cre= dit *) - 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, defa= ult is 0, + usually set to 1 when there is work detecte= d, 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 ano= ther + domain's transaction costs credit. = *) + mutable caused_conflicts: int64; + } =20 let is_dom0 d =3D d.id =3D 0 let get_id domain =3D domain.id @@ -57,51 +57,51 @@ let is_paused_for_conflict dom =3D dom.conflict_credit = <=3D 0.0 let is_free_to_conflict =3D is_dom0 =20 let string_of_port =3D function -| None -> "None" -| Some x -> string_of_int (Xeneventchn.to_int x) + | None -> "None" + | Some x -> string_of_int (Xeneventchn.to_int x) =20 let dump d chan =3D - 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 =20 let notify dom =3D 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 =20 let bind_interdomain dom =3D - 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_p= ort); - 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.remot= e_port (string_of_port dom.port) =20 =20 let close dom =3D - 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; + () =20 let make id mfn remote_port interface eventchn =3D { - id =3D id; - mfn =3D mfn; - remote_port =3D remote_port; - interface =3D interface; - eventchn =3D eventchn; - port =3D None; - bad_client =3D false; - io_credit =3D 0; - conflict_credit =3D !Define.conflict_burst_limit; - caused_conflicts =3D 0L; + id =3D id; + mfn =3D mfn; + remote_port =3D remote_port; + interface =3D interface; + eventchn =3D eventchn; + port =3D None; + bad_client =3D false; + io_credit =3D 0; + conflict_credit =3D !Define.conflict_burst_limit; + caused_conflicts =3D 0L; } =20 let log_and_reset_conflict_stats logfn dom =3D - 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/domai= ns.ml index 17fe2fa257..a36b531663 100644 --- a/tools/ocaml/xenstored/domains.ml +++ b/tools/ocaml/xenstored/domains.ml @@ -21,35 +21,35 @@ let warn fmt =3D Logging.warn "domains" fmt let xc =3D Xenctrl.interface_open () =20 type domains =3D { - eventchn: Event.t; - table: (Xenctrl.domid, Domain.t) Hashtbl.t; + eventchn: Event.t; + table: (Xenctrl.domid, Domain.t) Hashtbl.t; =20 - (* N.B. the Queue module is not thread-safe but oxenstored is single-thre= aded. *) - (* 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-thr= eaded. *) + (* 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; =20 - (* A callback function to be called when we go from zero to one paused do= main. - This will be to reset the countdown until the next unit of credit is i= ssued. *) - on_first_conflict_pause: unit -> unit; + (* A callback function to be called when we go from zero to one paused d= omain. + This will be to reset the countdown until the next unit of credit is = issued. *) + on_first_conflict_pause: unit -> unit; =20 - (* 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 cred= it *) - mutable n_penalised: int; (* Number of domains with less than maximum cre= dit *) + (* 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 th= e first. *) + mutable n_paused: int; (* Number of domains with zero or negative cre= dit *) + mutable n_penalised: int; (* Number of domains with less than maximum cr= edit *) } =20 let init eventchn on_first_conflict_pause =3D { - eventchn =3D eventchn; - table =3D Hashtbl.create 10; - doms_conflict_paused =3D Queue.create (); - doms_with_conflict_penalty =3D Queue.create (); - on_first_conflict_pause =3D on_first_conflict_pause; - n_paused =3D 0; - n_penalised =3D 0; + eventchn =3D eventchn; + table =3D Hashtbl.create 10; + doms_conflict_paused =3D Queue.create (); + doms_with_conflict_penalty =3D Queue.create (); + on_first_conflict_pause =3D on_first_conflict_pause; + n_paused =3D 0; + n_penalised =3D 0; } let del doms id =3D Hashtbl.remove doms.table id let exist doms id =3D Hashtbl.mem doms.table id @@ -58,165 +58,165 @@ let number doms =3D Hashtbl.length doms.table let iter doms fct =3D Hashtbl.iter (fun _ b -> fct b) doms.table =20 let rec is_empty_queue q =3D - Queue.is_empty q || - if !(Queue.peek q) =3D None - then ( - ignore (Queue.pop q); - is_empty_queue q - ) else false + Queue.is_empty q || + if !(Queue.peek q) =3D None + then ( + ignore (Queue.pop q); + is_empty_queue q + ) else false =20 let all_at_max_credit doms =3D - 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 =3D 0 + if !Define.conflict_rate_limit_is_aggregate + then + (* Check both becuase if burst limit is 1.0 then a domain can go strai= ght + * 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 =3D 0 =20 (* Functions to handle queues of domains given that the domain might be de= leted while in a queue. *) let push dom queue =3D - Queue.push (ref (Some dom)) queue + Queue.push (ref (Some dom)) queue =20 let rec pop queue =3D - match !(Queue.pop queue) with - | None -> pop queue - | Some x -> x + match !(Queue.pop queue) with + | None -> pop queue + | Some x -> x =20 let remove_from_queue dom queue =3D - Queue.iter (fun d -> match !d with - | None -> () - | Some x -> if x=3Ddom then d :=3D None) queue + Queue.iter (fun d -> match !d with + | None -> () + | Some x -> if x=3Ddom then d :=3D None) queue =20 let cleanup doms =3D - let notify =3D ref false in - let dead_dom =3D ref [] in + let notify =3D ref false in + let dead_dom =3D ref [] in =20 - Hashtbl.iter (fun id _ -> if id <> 0 then - try - let info =3D Xenctrl.domain_getinfo xc id in - if info.Xenctrl.shutdown || info.Xenctrl.dying then ( - debug "Domain %u died (dying=3D%b, shutdown %b -- code %d)" - id info.Xenctrl.dying info.Xenctrl.shutdown info.X= enctrl.shutdown_code; - if info.Xenctrl.dying then - dead_dom :=3D id :: !dead_dom - else - notify :=3D true; - ) - with Xenctrl.Error _ -> - debug "Domain %u died -- no domain info" id; - dead_dom :=3D id :: !dead_dom; - ) doms.table; - List.iter (fun id -> - let dom =3D Hashtbl.find doms.table id in - Domain.close dom; - Hashtbl.remove doms.table id; - if dom.Domain.conflict_credit <=3D !Define.conflict_burst_limit - then ( - remove_from_queue dom doms.doms_with_conflict_penalty; - if (dom.Domain.conflict_credit <=3D 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 =3D Xenctrl.domain_getinfo xc id in + if info.Xenctrl.shutdown || info.Xenctrl.dying then ( + debug "Domain %u died (dying=3D%b, shutdown %b -- c= ode %d)" + id info.Xenctrl.dying info.Xenctrl.shutdown info.= Xenctrl.shutdown_code; + if info.Xenctrl.dying then + dead_dom :=3D id :: !dead_dom + else + notify :=3D true; + ) + with Xenctrl.Error _ -> + debug "Domain %u died -- no domain info" id; + dead_dom :=3D id :: !dead_dom; + ) doms.table; + List.iter (fun id -> + let dom =3D Hashtbl.find doms.table id in + Domain.close dom; + Hashtbl.remove doms.table id; + if dom.Domain.conflict_credit <=3D !Define.conflict_burst_limit + then ( + remove_from_queue dom doms.doms_with_conflict_penalty; + if (dom.Domain.conflict_credit <=3D 0.) then remove_from_queue dom= doms.doms_conflict_paused + ) + ) !dead_dom; + !notify, !dead_dom =20 let resume _doms _domid =3D - () + () =20 let create doms domid mfn port =3D - let interface =3D Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize= ()) mfn in - let dom =3D Domain.make domid mfn port interface doms.eventchn in - Hashtbl.add doms.table domid dom; - Domain.bind_interdomain dom; - dom + let interface =3D Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesiz= e()) mfn in + let dom =3D Domain.make domid mfn port interface doms.eventchn in + Hashtbl.add doms.table domid dom; + Domain.bind_interdomain dom; + dom =20 let xenstored_kva =3D ref "" let xenstored_port =3D ref "" =20 let create0 doms =3D - let port, interface =3D - ( - let port =3D Utils.read_file_single_integer !xenstored_port - and fd =3D Unix.openfile !xenstored_kva - [ Unix.O_RDWR ] 0o600 in - let interface =3D Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED - (Xenmmap.getpagesize()) 0 in - Unix.close fd; - port, interface - ) - in - let dom =3D 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 =3D + ( + let port =3D Utils.read_file_single_integer !xenstored_port + and fd =3D Unix.openfile !xenstored_kva + [ Unix.O_RDWR ] 0o600 in + let interface =3D Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED + (Xenmmap.getpagesize()) 0 in + Unix.close fd; + port, interface + ) + in + let dom =3D Domain.make 0 Nativeint.zero port interface doms.eventchn in + Hashtbl.add doms.table 0 dom; + Domain.bind_interdomain dom; + Domain.notify dom; + dom =20 let decr_conflict_credit doms dom =3D - dom.Domain.caused_conflicts <- Int64.add 1L dom.Domain.caused_conflicts; - let before =3D dom.Domain.conflict_credit in - let after =3D max (-1.0) (before -. 1.0) in - debug "decr_conflict_credit dom%d %F -> %F" (Domain.get_id dom) before af= ter; - dom.Domain.conflict_credit <- after; - let newly_penalised =3D - before >=3D !Define.conflict_burst_limit - && after < !Define.conflict_burst_limit in - let newly_paused =3D before > 0.0 && after <=3D 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 =3D 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 =3D 1 then doms.on_first_conflict_pause () - ) - ) + dom.Domain.caused_conflicts <- Int64.add 1L dom.Domain.caused_conflicts; + let before =3D dom.Domain.conflict_credit in + let after =3D max (-1.0) (before -. 1.0) in + debug "decr_conflict_credit dom%d %F -> %F" (Domain.get_id dom) before a= fter; + dom.Domain.conflict_credit <- after; + let newly_penalised =3D + before >=3D !Define.conflict_burst_limit + && after < !Define.conflict_burst_limit in + let newly_paused =3D before > 0.0 && after <=3D 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 =3D 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 =3D 1 then doms.on_first_conflict_pause () + ) + ) =20 (* Give one point of credit to one domain, and update the queues appropria= tely. *) let incr_conflict_credit_from_queue doms =3D - let process_queue q requeue_test =3D - let d =3D pop q in - let before =3D d.Domain.conflict_credit in (* just for debug-logging *) - d.Domain.conflict_credit <- min (d.Domain.conflict_credit +. 1.0) !Defin= e.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 =3D cred <=3D 0.0 in - let penalty_queue_test cred =3D 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 =3D + let d =3D pop q in + let before =3D d.Domain.conflict_credit in (* just for debug-logging *) + d.Domain.conflict_credit <- min (d.Domain.conflict_credit +. 1.0) !Def= ine.conflict_burst_limit; + debug "incr_conflict_credit_from_queue: dom%d: %F -> %F" (Domain.get_i= d 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 =3D cred <=3D 0.0 in + let penalty_queue_test cred =3D 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.= *) + ) =20 let incr_conflict_credit doms =3D - 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 =3D - let before =3D dom.Domain.conflict_credit in - let after =3D 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 =3D + let before =3D dom.Domain.conflict_credit in + let after =3D 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) bef= ore after; =20 - if before <=3D 0.0 && after > 0.0 - then doms.n_paused <- doms.n_paused - 1; + if before <=3D 0.0 && after > 0.0 + then doms.n_paused <- doms.n_paused - 1; =20 - if before < !Define.conflict_burst_limit - && after >=3D !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 >=3D !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 @@ =20 (**************** high level binding ****************) type t =3D { - handle: Xeneventchn.handle; - mutable virq_port: Xeneventchn.t option; + handle: Xeneventchn.handle; + mutable virq_port: Xeneventchn.t option; } =20 let init () =3D { handle =3D Xeneventchn.init (); virq_port =3D None; } diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/histo= ry.ml index ba5c9cb571..f03fb18329 100644 --- a/tools/ocaml/xenstored/history.ml +++ b/tools/ocaml/xenstored/history.ml @@ -13,11 +13,11 @@ *) =20 type history_record =3D { - 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 finishe= d *) + 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 finish= ed *) } =20 let history : history_record list ref =3D ref [] @@ -26,38 +26,38 @@ let history : history_record list ref =3D ref [] (* There is scope for optimisation here, replacing List.filter with someth= ing more efficient, * probably on a different list-like structure. *) let trim ?txn () =3D - Transaction.trim_short_running_transactions txn; - history :=3D 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) !his= tory - ) + Transaction.trim_short_running_transactions txn; + history :=3D 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 + ) =20 let end_transaction txn con tid commit =3D - let success =3D Connection.end_transaction con tid commit in - trim ~txn (); - success + let success =3D Connection.end_transaction con tid commit in + trim ~txn (); + success =20 let reconnect con =3D - trim (); - Connection.do_reconnect con + trim (); + Connection.do_reconnect con =20 let push (x: history_record) =3D - let dom =3D 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 :=3D x :: = !history + let dom =3D 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 :=3D x ::= !history =20 (* Find the connections from records since commit-count [since] for which = [f record] returns [true] *) let filter_connections ~ignore ~since ~f =3D - (* The "mem" call is an optimisation, to avoid calling f if we have picke= d 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 =3D=3D 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 pick= ed 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 =3D=3D 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/loggi= ng.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 *) =20 type log_destination =3D - | File of string - | Syslog of Syslog.facility + | File of string + | Syslog of Syslog.facility =20 let log_destination_of_string s =3D - let prefix =3D "syslog:" in - let len_prefix =3D String.length prefix in - let len =3D 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 =3D "syslog:" in + let len_prefix =3D String.length prefix in + let len =3D String.length s in + if String.startswith prefix s + then Syslog(Syslog.facility_of_string (String.sub s len_prefix (len - le= n_prefix))) + else File s =20 (* The prefix of a log line depends on the log destination *) let prefix log_destination ?level ?key date =3D match log_destination with - | File _ -> - let level =3D match level with - | Some x -> Printf.sprintf "|%5s" x - | None -> "" in - let key =3D match key with - | Some x -> "|" ^ x - | None -> "" in - Printf.sprintf "[%s%s%s] " date level key - | Syslog _ -> - let key =3D match key with - | Some x -> "[" ^ x ^ "] " - | None -> "" in - (* Syslog handles the date and level internally *) - key + | File _ -> + let level =3D match level with + | Some x -> Printf.sprintf "|%5s" x + | None -> "" in + let key =3D match key with + | Some x -> "|" ^ x + | None -> "" in + Printf.sprintf "[%s%s%s] " date level key + | Syslog _ -> + let key =3D match key with + | Some x -> "[" ^ x ^ "] " + | None -> "" in + (* Syslog handles the date and level internally *) + key =20 type level =3D Debug | Info | Warn | Error | Null =20 type logger =3D - { 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 } =20 let truncate_line nb_chars line =3D - if String.length line > nb_chars - 1 then - let len =3D max (nb_chars - 1) 2 in - let dst_line =3D 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 =3D max (nb_chars - 1) 2 in + let dst_line =3D 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 =20 let log_rotate ref_ch log_file log_nb_files =3D - let file n =3D sprintf "%s.%i" log_file n in - let log_files =3D - let rec aux accu n =3D - if n >=3D log_nb_files then accu - else - if n =3D 1 && Sys.file_exists log_file - then aux [log_file,1] 2 - else - let file =3D 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 :=3D open_out log_file + let file n =3D sprintf "%s.%i" log_file n in + let log_files =3D + let rec aux accu n =3D + if n >=3D log_nb_files then accu + else + if n =3D 1 && Sys.file_exists log_file + then aux [log_file,1] 2 + else + let file =3D 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 :=3D open_out log_file =20 let make_file_logger log_file log_nb_files log_nb_lines log_nb_chars post_= rotate =3D - let channel =3D ref (open_out_gen [Open_append; Open_creat] 0o644 log_fil= e) in - let counter =3D ref 0 in - let stop() =3D - try flush !channel; close_out !channel - with _ -> () in - let restart() =3D - stop(); - channel :=3D open_out_gen [Open_append; Open_creat] 0o644 log_file in - let rotate() =3D - log_rotate channel log_file log_nb_files; - (post_rotate (): unit); - counter :=3D 0 in - let write ?level:_ s =3D - let s =3D if log_nb_chars > 0 then truncate_line log_nb_chars s else s in - let s =3D s ^ "\n" in - output_string !channel s; - flush !channel; - incr counter; - if !counter > log_nb_lines then rotate() in - { stop=3Dstop; restart=3Drestart; rotate=3Drotate; write=3Dwrite } + let channel =3D ref (open_out_gen [Open_append; Open_creat] 0o644 log_fi= le) in + let counter =3D ref 0 in + let stop() =3D + try flush !channel; close_out !channel + with _ -> () in + let restart() =3D + stop(); + channel :=3D open_out_gen [Open_append; Open_creat] 0o644 log_file in + let rotate() =3D + log_rotate channel log_file log_nb_files; + (post_rotate (): unit); + counter :=3D 0 in + let write ?level:_ s =3D + let s =3D if log_nb_chars > 0 then truncate_line log_nb_chars s else s= in + let s =3D s ^ "\n" in + output_string !channel s; + flush !channel; + incr counter; + if !counter > log_nb_lines then rotate() in + { stop=3Dstop; restart=3Drestart; rotate=3Drotate; write=3Dwrite } =20 exception Unknown_level of string =20 let int_of_level =3D function - | Debug -> 0 | Info -> 1 | Warn -> 2 - | Error -> 3 | Null -> max_int + | Debug -> 0 | Info -> 1 | Warn -> 2 + | Error -> 3 | Null -> max_int =20 let string_of_level =3D function - | Debug -> "debug" | Info -> "info" | Warn -> "warn" - | Error -> "error" | Null -> "null" + | Debug -> "debug" | Info -> "info" | Warn -> "warn" + | Error -> "error" | Null -> "null" =20 let level_of_string =3D 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) =20 let string_of_date () =3D - let time =3D Unix.gettimeofday () in - let tm =3D Unix.gmtime time in - let msec =3D 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 =3D Unix.gettimeofday () in + let tm =3D Unix.gmtime time in + let msec =3D 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)) =20 (* We can defer to syslog for log management *) let make_syslog_logger facility =3D - (* 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 () =3D - let tz_is_set =3D - 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 () =3D () in - let write ?level s =3D - let level =3D 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 =3D nothing; restart =3D nothing; rotate =3D nothing; write=3Dwrit= e } + (* 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 lik= e to + avoid this cost given that we are not a mobile environment and we log + almost every xenstore entry update/watch. *) + let () =3D + let tz_is_set =3D + 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 () =3D () in + let write ?level s =3D + let level =3D 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 =3D nothing; restart =3D nothing; rotate =3D nothing; write=3Dwri= te } =20 let xenstored_log_destination =3D ref (File (Paths.xen_log_dir ^ "/xenstor= ed.log")) let xenstored_log_level =3D ref Warn @@ -164,34 +164,34 @@ let xenstored_logger =3D ref (None: logger option) let debug_enabled () =3D !xenstored_log_level =3D Debug =20 let set_xenstored_log_destination s =3D - xenstored_log_destination :=3D log_destination_of_string s + xenstored_log_destination :=3D log_destination_of_string s =20 let set_xenstored_logger logger =3D - xenstored_logger :=3D Some logger; - logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d.= %d" - Define.xenstored_major Define.xenstored_minor) + xenstored_logger :=3D Some logger; + logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d= .%d" + Define.xenstored_major Define.xenstored_mino= r) =20 =20 let init_xenstored_log () =3D match !xenstored_log_destination with - | File file -> - if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then - let logger =3D - 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 =3D + 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) =20 =20 let xenstored_logging level key (fmt: (_,_,_,_) format4) =3D - match !xenstored_logger with - | Some logger when int_of_level level >=3D int_of_level !xenstored_log_le= vel -> - let date =3D string_of_date() in - let level' =3D string_of_level level in - let prefix =3D prefix !xenstored_log_destination ~level:level' ~key dat= e 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 >=3D int_of_level !xenstored_log_l= evel -> + let date =3D string_of_date() in + let level' =3D string_of_level level in + let prefix =3D prefix !xenstored_log_destination ~level:level' ~key da= te in + Printf.ksprintf (fun s -> logger.write ~level (prefix ^ s)) fmt + | _ -> Printf.ksprintf ignore fmt =20 let debug key =3D xenstored_logging Debug key let info key =3D xenstored_logging Info key @@ -201,66 +201,66 @@ let error key =3D xenstored_logging Error key (* Access logger *) =20 type access_type =3D - | 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 =20 let string_of_tid ~con tid =3D - if tid =3D 0 - then sprintf "%-12s" con - else sprintf "%-12s" (sprintf "%s.%i" con tid) + if tid =3D 0 + then sprintf "%-12s" con + else sprintf "%-12s" (sprintf "%s.%i" con tid) =20 let string_of_access_type =3D 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" =20 - | XbOp op -> match op with - | Xenbus.Xb.Op.Debug -> "debug " + | XbOp op -> match op with + | Xenbus.Xb.Op.Debug -> "debug " =20 - | 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 " =20 - | Xenbus.Xb.Op.Watch -> "watch " - | Xenbus.Xb.Op.Unwatch -> "unwatch " + | Xenbus.Xb.Op.Watch -> "watch " + | Xenbus.Xb.Op.Unwatch -> "unwatch " =20 - | 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 " =20 - | 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 " =20 - | 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" =20 - | 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 + *) =20 let sanitize_data data =3D - let data =3D String.init - (String.length data) - (fun i -> let c =3D data.[i] in if c =3D '\000' then ' ' else c) - in - String.escaped data + let data =3D String.init + (String.length data) + (fun i -> let c =3D data.[i] in if c =3D '\000' then ' ' else c) + in + String.escaped data =20 let activate_access_log =3D ref true let access_log_destination =3D ref (File (Paths.xen_log_dir ^ "/xenstored-= access.log")) @@ -273,72 +273,72 @@ let access_log_special_ops =3D ref false let access_logger =3D ref None =20 let set_access_log_destination s =3D - access_log_destination :=3D log_destination_of_string s + access_log_destination :=3D log_destination_of_string s =20 let init_access_log post_rotate =3D match !access_log_destination with - | File file -> - if !access_log_nb_files > 0 then - let logger =3D - make_file_logger - file !access_log_nb_files !access_log_nb_lines - !access_log_nb_chars post_rotate in - access_logger :=3D Some logger - | Syslog facility -> - access_logger :=3D Some (make_syslog_logger facility) + | File file -> + if !access_log_nb_files > 0 then + let logger =3D + make_file_logger + file !access_log_nb_files !access_log_nb_lines + !access_log_nb_chars post_rotate in + access_logger :=3D Some logger + | Syslog facility -> + access_logger :=3D Some (make_syslog_logger facility) =20 let access_logging ~con ~tid ?(data=3D"") ~level access_type =3D - try - maybe - (fun logger -> - let date =3D string_of_date() in - let tid =3D string_of_tid ~con tid in - let access_type =3D string_of_access_type access_type in - let data =3D sanitize_data data in - let prefix =3D prefix !access_log_destination date in - let msg =3D 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 =3D string_of_date() in + let tid =3D string_of_tid ~con tid in + let access_type =3D string_of_access_type access_type in + let data =3D sanitize_data data in + let prefix =3D prefix !access_log_destination date in + let msg =3D Printf.sprintf "%s %s %s %s" prefix tid access_type d= ata in + logger.write ~level msg) + !access_logger + with _ -> () =20 let new_connection =3D access_logging ~level:Debug Newconn let end_connection =3D access_logging ~level:Debug Endconn let read_coalesce ~tid ~con data =3D - 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 =3D access_logging Coalesce ~data:("write "^data) = ~level:Debug let conflict =3D access_logging Conflict ~level:Debug let commit =3D access_logging Commit ~level:Debug =20 let xb_op ~tid ~con ~ty data =3D - let print =3D 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.Getdomain= path | 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 =3D 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.Getdoma= inpath | 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 =20 let start_transaction ~tid ~con =3D - if !access_log_transaction_ops && tid <> 0 - then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~leve= l:Debug + if !access_log_transaction_ops && tid <> 0 + then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~lev= el:Debug =20 let end_transaction ~tid ~con =3D - 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 =20 let live_update () =3D - 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" =20 let xb_answer ~tid ~con ~ty data =3D - let print, level =3D 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 =3D match ty with + | Xenbus.Xb.Op.Error when String.startswith "ENOENT" data -> !access_l= og_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 =20 let watch_not_fired ~con perms path =3D - let data =3D Printf.sprintf "EPERM perms=3D[%s] path=3D%s" perms path in - access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info + let data =3D Printf.sprintf "EPERM perms=3D[%s] path=3D%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 =3D { - tid: int; - rid: int; - ty: Xenbus.Xb.Op.operation; - data: string; + tid: int; + rid: int; + ty: Xenbus.Xb.Op.operation; + data: string; } =20 type response =3D - | Ack of (unit -> unit) (* function is the action to execute after sendi= ng the ack *) - | Reply of string - | Error of string + | Ack of (unit -> unit) (* function is the action to execute after send= ing the ack *) + | Reply of string + | Error of string =20 let response_equal a b =3D - match (a, b) with - | (Ack _, Ack _) -> true (* just consider the response, not the post-resp= onse action *) - | (x, y) -> x =3D y + match (a, b) with + | (Ack _, Ack _) -> true (* just consider the response, not the post-res= ponse action *) + | (x, y) -> x =3D y diff --git a/tools/ocaml/xenstored/parse_arg.ml b/tools/ocaml/xenstored/par= se_arg.ml index 7c0478e76a..1a85b14ef5 100644 --- a/tools/ocaml/xenstored/parse_arg.ml +++ b/tools/ocaml/xenstored/parse_arg.ml @@ -15,59 +15,59 @@ *) =20 type config =3D -{ - 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; + } =20 let do_argv =3D - let pidfile =3D ref "" and tracefile =3D ref "" (* old xenstored compatib= ility *) - and domain_init =3D ref true - and activate_access_log =3D ref true - and daemonize =3D ref true - and reraise_top_level =3D ref false - and config_file =3D ref "" - and restart =3D ref false - and live_reload =3D ref false - and disable_socket =3D ref false - in + let pidfile =3D ref "" and tracefile =3D ref "" (* old xenstored compati= bility *) + and domain_init =3D ref true + and activate_access_log =3D ref true + and daemonize =3D ref true + and reraise_top_level =3D ref false + and config_file =3D ref "" + and restart =3D ref false + and live_reload =3D ref false + and disable_socket =3D ref false + in =20 - let speclist =3D - [ ("--no-domain-init", Arg.Unit (fun () -> domain_init :=3D 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 :=3D false), - "to request that the daemon does not fork"); - ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level :=3D tru= e), - "reraise exceptions caught at the top level"); - ("--no-access-log", Arg.Unit (fun () -> activate_access_log :=3D 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 :=3D true), "D= isable socket"); - ] in - let usage_msg =3D "usage : xenstored [--config-file ] [--no-dom= ain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable= -socket]" in - Arg.parse speclist (fun _ -> ()) usage_msg; - { - domain_init =3D !domain_init; - activate_access_log =3D !activate_access_log; - daemonize =3D !daemonize; - reraise_top_level =3D !reraise_top_level; - config_file =3D if !config_file <> "" then Some !config_file else None; - pidfile =3D if !pidfile <> "" then Some !pidfile else None; - tracefile =3D if !tracefile <> "" then Some !tracefile else None; - restart =3D !restart; - live_reload =3D !live_reload; - disable_socket =3D !disable_socket; - } + let speclist =3D + [ ("--no-domain-init", Arg.Unit (fun () -> domain_init :=3D 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 :=3D false), + "to request that the daemon does not fork"); + ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level :=3D t= rue), + "reraise exceptions caught at the top level"); + ("--no-access-log", Arg.Unit (fun () -> activate_access_log :=3D fal= se), + "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 :=3D true), = "Disable socket"); + ] in + let usage_msg =3D "usage : xenstored [--config-file ] [--no-do= main-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disabl= e-socket]" in + Arg.parse speclist (fun _ -> ()) usage_msg; + { + domain_init =3D !domain_init; + activate_access_log =3D !activate_access_log; + daemonize =3D !daemonize; + reraise_top_level =3D !reraise_top_level; + config_file =3D if !config_file <> "" then Some !config_file else None; + pidfile =3D if !pidfile <> "" then Some !pidfile else None; + tracefile =3D if !tracefile <> "" then Some !tracefile else None; + restart =3D !restart; + live_reload =3D !live_reload; + disable_socket =3D !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 =3D ref true type permty =3D READ | WRITE | RDWR | NONE =20 let char_of_permty perm =3D - match perm with - | READ -> 'r' - | WRITE -> 'w' - | RDWR -> 'b' - | NONE -> 'n' + match perm with + | READ -> 'r' + | WRITE -> 'w' + | RDWR -> 'b' + | NONE -> 'n' =20 let permty_of_char c =3D - 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" =20 =20 (* node permissions *) module Node =3D struct =20 -type t =3D -{ - owner: Xenctrl.domid; - other: permty; - acl: (Xenctrl.domid * permty) list; -} + type t =3D + { + owner: Xenctrl.domid; + other: permty; + acl: (Xenctrl.domid * permty) list; + } =20 -let create owner other acl =3D - { owner =3D owner; other =3D other; acl =3D acl } + let create owner other acl =3D + { owner =3D owner; other =3D other; acl =3D acl } =20 -let get_other perms =3D perms.other -let get_acl perms =3D perms.acl -let get_owner perm =3D perm.owner + let get_other perms =3D perms.other + let get_acl perms =3D perms.acl + let get_owner perm =3D perm.owner =20 -(** [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 =3D - let acl =3D List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.a= cl in - if perm.owner =3D domid then None else Some { perm with acl; owner =3D pe= rm.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 =3D + let acl =3D List.filter (fun (acl_domid, _) -> acl_domid <> domid) per= m.acl in + if perm.owner =3D domid then None else Some { perm with acl; owner =3D= perm.owner } =20 -let default0 =3D create 0 NONE [] + let default0 =3D create 0 NONE [] =20 -let perm_of_string s =3D - let ty =3D permty_of_char s.[0] - and id =3D int_of_string (String.sub s 1 (String.length s - 1)) in - (id, ty) + let perm_of_string s =3D + let ty =3D permty_of_char s.[0] + and id =3D int_of_string (String.sub s 1 (String.length s - 1)) in + (id, ty) =20 -let of_strings ls =3D - let vect =3D 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 =3D + let vect =3D List.map (perm_of_string) ls in + match vect with + | [] -> invalid_arg "permvec empty" + | h :: l -> create (fst h) (snd h) l =20 -(* [s] must end with '\000' *) -let of_string s =3D - let ls =3D String.split '\000' s in - let ls =3D if ls =3D [] then ls else List.rev (List.tl (List.rev ls)) in - of_strings ls + (* [s] must end with '\000' *) + let of_string s =3D + let ls =3D String.split '\000' s in + let ls =3D if ls =3D [] then ls else List.rev (List.tl (List.rev ls)) = in + of_strings ls =20 -let string_of_perm perm =3D - Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm) + let string_of_perm perm =3D + Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm) =20 -let to_string ?(sep=3D"\000") permvec =3D - let l =3D ((permvec.owner, permvec.other) :: permvec.acl) in - String.concat sep (List.map string_of_perm l) + let to_string ?(sep=3D"\000") permvec =3D + let l =3D ((permvec.owner, permvec.other) :: permvec.acl) in + String.concat sep (List.map string_of_perm l) =20 end =20 @@ -99,87 +99,87 @@ end module Connection =3D struct =20 -type elt =3D Xenctrl.domid * (permty list) -type t =3D - { main: elt; - target: elt option; } + type elt =3D Xenctrl.domid * (permty list) + type t =3D + { main: elt; + target: elt option; } =20 -let full_rights : t =3D - { main =3D 0, [READ; WRITE]; - target =3D None } + let full_rights : t =3D + { main =3D 0, [READ; WRITE]; + target =3D None } =20 -let create ?(perms=3D[NONE]) domid : t =3D - { main =3D (domid, perms); - target =3D None } + let create ?(perms=3D[NONE]) domid : t =3D + { main =3D (domid, perms); + target =3D None } =20 -let set_target (connection:t) ?(perms=3D[NONE]) domid =3D - { connection with target =3D Some (domid, perms) } + let set_target (connection:t) ?(perms=3D[NONE]) domid =3D + { connection with target =3D Some (domid, perms) } =20 -let get_owners (connection:t) =3D - match connection.main, connection.target with - | c1, Some c2 -> [ fst c1; fst c2 ] - | c1, None -> [ fst c1 ] + let get_owners (connection:t) =3D + match connection.main, connection.target with + | c1, Some c2 -> [ fst c1; fst c2 ] + | c1, None -> [ fst c1 ] =20 -let is_owner (connection:t) id =3D - match connection.target with - | Some target -> fst connection.main =3D id || fst target =3D id - | None -> fst connection.main =3D id + let is_owner (connection:t) id =3D + match connection.target with + | Some target -> fst connection.main =3D id || fst target =3D id + | None -> fst connection.main =3D id =20 -let is_dom0 (connection:t) =3D - is_owner connection 0 + let is_dom0 (connection:t) =3D + is_owner connection 0 =20 -let elt_to_string (i,p) =3D - Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.= map char_of_permty p))) + let elt_to_string (i,p) =3D + Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (Li= st.map char_of_permty p))) =20 -let to_string connection =3D - Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may el= t_to_string connection.target)) + let to_string connection =3D + Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may= elt_to_string connection.target)) end =20 (* check if owner of the current connection and of the current node are th= e same *) let check_owner (connection:Connection.t) (node:Node.t) =3D - 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 =20 (* check if the current connection lacks the requested perm on the current= node *) let lacks (connection:Connection.t) request (node:Node.t) =3D - let check_acl domainid =3D - let perm =3D - 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 =3D + let perm =3D + 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)) =20 (* check if the current connection has the requested perm on the current n= ode. -* Raises an exception if it doesn't. *) + * Raises an exception if it doesn't. *) let check connection request node =3D - if lacks connection request node - then raise Define.Permission_denied + if lacks connection request node + then raise Define.Permission_denied =20 (* check if the current connection has the requested perm on the current n= ode *) let has connection request node =3D not (lacks connection request node) =20 let can_fire_watch connection perms =3D - not !watch_activate - || List.exists (has connection READ) perms + not !watch_activate + || List.exists (has connection READ) perms =20 let equiv perm1 perm2 =3D - (Node.to_string perm1) =3D (Node.to_string perm2) + (Node.to_string perm1) =3D (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 =3D { - mutable read: bool; - mutable write: bool; - mutable except: bool; + mutable read: bool; + mutable write: bool; + mutable except: bool; } =20 external select_on_poll: (Unix.file_descr * event) array -> int -> int =3D= "stub_select_on_poll" @@ -28,40 +28,40 @@ external set_fd_limit: int -> unit =3D "stub_set_fd_lim= it" (* The rlim_max given to setrlimit must not go above the system level nr_o= pen, which we can read from /proc/sys. *) let get_sys_fs_nr_open () =3D - try - let ch =3D open_in "/proc/sys/fs/nr_open" in - let v =3D int_of_string (input_line ch) in - close_in_noerr ch; v - with _ -> 1024 * 1024 + try + let ch =3D open_in "/proc/sys/fs/nr_open" in + let v =3D int_of_string (input_line ch) in + close_in_noerr ch; v + with _ -> 1024 * 1024 =20 let init_event () =3D {read =3D false; write =3D false; except =3D false} =20 let poll_select in_fds out_fds exc_fds timeout =3D - let h =3D Hashtbl.create 57 in - let add_event event_set fd =3D - let e =3D - try Hashtbl.find h fd - with Not_found -> - let e =3D 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 =3D Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in - let i =3D ref (-1) in - Hashtbl.iter (fun fd event -> incr i; Array.set a !i (fd, event)) h; - let n =3D select_on_poll a (int_of_float (timeout *. 1000.)) in - let r =3D [], [], [] in - if n =3D 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 =3D Hashtbl.create 57 in + let add_event event_set fd =3D + let e =3D + try Hashtbl.find h fd + with Not_found -> + let e =3D 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 =3D Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in + let i =3D ref (-1) in + Hashtbl.iter (fun fd event -> incr i; Array.set a !i (fd, event)) h; + let n =3D select_on_poll a (int_of_float (timeout *. 1000.)) in + let r =3D [], [], [] in + if n =3D 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 =20 let () =3D - 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 @@ =20 (** 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 -> f= loat - -> 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/proce= ss.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 =3D ref false =20 let c_int_of_string s =3D - let v =3D ref 0 in - let is_digit c =3D c >=3D '0' && c <=3D '9' in - let len =3D String.length s in - let i =3D 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 =3D (Char.code s.[!i]) - (Char.code '0') in - v :=3D !v * 10 + x; - incr i - done; - !v + let v =3D ref 0 in + let is_digit c =3D c >=3D '0' && c <=3D '9' in + let len =3D String.length s in + let i =3D 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 =3D (Char.code s.[!i]) - (Char.code '0') in + v :=3D !v * 10 + x; + incr i + done; + !v =20 (* 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 =3D - let limit =3D match limit with None -> 8 | Some x -> x in - String.split ~limit c s + let limit =3D match limit with None -> 8 | Some x -> x in + String.split ~limit c s =20 let split_one_path data con =3D - let args =3D split (Some 2) '\000' data in - match args with - | path :: "" :: [] -> Store.Path.create path (Connection.get_path con) - | _ -> raise Invalid_Cmd_Args + let args =3D split (Some 2) '\000' data in + match args with + | path :: "" :: [] -> Store.Path.create path (Connection.get_path con) + | _ -> raise Invalid_Cmd_Args =20 let process_watch source t cons =3D - let oldroot =3D t.Transaction.oldroot in - let newroot =3D Store.get_root t.Transaction.store in - let ops =3D Transaction.get_paths t |> List.rev in - let do_op_watch op cons =3D - let recurse, oldroot, root =3D 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 =3D t.Transaction.oldroot in + let newroot =3D Store.get_root t.Transaction.store in + let ops =3D Transaction.get_paths t |> List.rev in + let do_op_watch op cons =3D + let recurse, oldroot, root =3D 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 =20 let create_implicit_path t perm path =3D - let dirname =3D Store.Path.get_parent path in - if not (Transaction.path_exists t dirname) then ( - let rec check_path p =3D - match p with - | [] -> [] - | h :: l -> - if Transaction.path_exists t h then - check_path l - else - p in - let ret =3D 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 =3D Store.Path.get_parent path in + if not (Transaction.path_exists t dirname) then ( + let rec check_path p =3D + match p with + | [] -> [] + | h :: l -> + if Transaction.path_exists t h then + check_path l + else + p in + let ret =3D check_path (List.tl (Store.Path.get_hierarchy dirname)) in + List.iter (fun s -> Transaction.mkdir ~with_watch:false t perm s) ret + ) =20 module LiveUpdate =3D struct -type t =3D - { binary: string - ; cmdline: string list - ; deadline: float - ; force: bool - ; result: string list - ; pending: bool } + type t =3D + { binary: string + ; cmdline: string list + ; deadline: float + ; force: bool + ; result: string list + ; pending: bool } =20 -let state =3D ref - { binary=3D Sys.executable_name - ; cmdline=3D (Sys.argv |> Array.to_list |> List.tl) - ; deadline=3D 0. - ; force=3D false - ; result =3D [] - ; pending=3D false } + let state =3D ref + { binary=3D Sys.executable_name + ; cmdline=3D (Sys.argv |> Array.to_list |> List.tl) + ; deadline=3D 0. + ; force=3D false + ; result =3D [] + ; pending=3D false } =20 -let debug =3D Printf.eprintf + let debug =3D Printf.eprintf =20 -let forced_args =3D ["--live"; "--restart"] -let args_of_t t =3D - let filtered =3D List.filter (fun x -> not @@ List.mem x forced_args) t.c= mdline in - (t.binary, forced_args @ filtered) + let forced_args =3D ["--live"; "--restart"] + let args_of_t t =3D + let filtered =3D List.filter (fun x -> not @@ List.mem x forced_args) = t.cmdline in + (t.binary, forced_args @ filtered) =20 -let string_of_t t =3D - let executable, rest =3D args_of_t t in - Filename.quote_command executable rest + let string_of_t t =3D + let executable, rest =3D args_of_t t in + Filename.quote_command executable rest =20 -let launch_exn t =3D - let executable, rest =3D args_of_t t in - let args =3D Array.of_list (executable :: rest) in - info "Launching %s, args: %s" executable (String.concat " " rest); - Unix.execv args.(0) args + let launch_exn t =3D + let executable, rest =3D args_of_t t in + let args =3D Array.of_list (executable :: rest) in + info "Launching %s, args: %s" executable (String.concat " " rest); + Unix.execv args.(0) args =20 -let validate_exn t =3D - (* --help must be last to check validity of earlier arguments *) - let t' =3D {t with cmdline=3D t.cmdline @ ["--help"]} in - let cmd =3D 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 =3D + (* --help must be last to check validity of earlier arguments *) + let t' =3D {t with cmdline=3D t.cmdline @ ["--help"]} in + let cmd =3D 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 n= umber %d" cmd n) + | _, Unix.WSTOPPED n -> + invalid_arg (Printf.sprintf "Command %s stopped by ocaml signal = number %d" cmd n) + ) =20 -let parse_live_update args =3D - try - (state :=3D - match args with - | ["-f"; file] -> - validate_exn {!state with binary=3D file} - | ["-a"] -> - debug "Live update aborted" ; - {!state with pending=3D false; result =3D []} - | "-c" :: cmdline -> - validate_exn {!state with cmdline =3D !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 =3D ref 60 in - let force =3D 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 =3D Unix.gettimeofday () +. float !timeout - ; force=3D !force; pending=3D 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 :=3D { !state with result =3D [] }; - 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 =3D + try + (state :=3D + match args with + | ["-f"; file] -> + validate_exn {!state with binary=3D file} + | ["-a"] -> + debug "Live update aborted" ; + {!state with pending=3D false; result =3D []} + | "-c" :: cmdline -> + validate_exn {!state with cmdline =3D !state.cmdline @ cmdline} + | "-s" :: _ -> + (match !state.pending, !state.result with + | true, _ -> !state (* no change to state, avoid resetting tim= eout *) + | false, _ :: _ -> !state (* we got a pending result to delive= r *) + | false, [] -> + let timeout =3D ref 60 in + let force =3D 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 transac= tions after timeout elapsed" + ) + ] + (fun x -> raise (Arg.Bad x)) + "live-update -s" ; + debug "Live update process queued" ; + {!state with deadline =3D Unix.gettimeofday () +. float !tim= eout + ; force=3D !force; pending=3D 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 :=3D { !state with result =3D [] }; + 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)) =20 - let should_run cons =3D - let t =3D !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 =3D 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 :=3D { t with pending =3D false; result =3D msgs}; - false - end - end else false + let should_run cons =3D + let t =3D !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 domain= s:" (List.length l); + let msgs =3D List.rev_map (fun con -> Printf.sprintf "%s: %d tx, o= ut: %b, perm: %s" + (Connection.get_domstr con) + (Connection.number_of_transactions con) + (Connection.has_output con) + (Connection.get_perm con |> Perms.Conn= ection.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 :=3D { t with pending =3D false; result =3D msgs}; + false + end + end else false =20 - let completed () =3D - state :=3D { !state with result =3D ["OK"] } + let completed () =3D + state :=3D { !state with result =3D ["OK"] } end =20 (* packets *) let do_debug con t _domains cons data =3D - 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 =3D 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:"=3D=3D=3D=3D=3D=3D=3D>= " msg; - None - | "quota" :: domid :: _ -> - let domid =3D int_of_string domid in - let quota =3D (Store.get_quota t.Transaction.store) in - Some (Quota.to_string quota domid ^ "\000") - | "watches" :: _ -> - let watches =3D Connections.debug cons in - Some (watches ^ "\000") - | "xenbus" :: domid :: _ -> - let domid =3D int_of_string domid in - let con =3D Connections.find_domain cons domid in - let s =3D Printf.sprintf "xenbus: %s; overflow queue length: %d, can_inp= ut: %b, has_more_input: %b, has_old_output: %b, has_new_output: %b, has_mor= e_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 =3D int_of_string domid in - let con =3D Connections.find_domain cons domid in - may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connecti= on.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 =3D params |> List.rev |> List.tl |> List.r= ev in + LiveUpdate.parse_live_update dropped_trailing_nul + | "print" :: msg :: _ -> + Logging.xb_op ~tid:0 ~ty:Xenbus.Xb.Op.Debug ~con:"=3D=3D=3D=3D=3D=3D= =3D>" msg; + None + | "quota" :: domid :: _ -> + let domid =3D int_of_string domid in + let quota =3D (Store.get_quota t.Transaction.store) in + Some (Quota.to_string quota domid ^ "\000") + | "watches" :: _ -> + let watches =3D Connections.debug cons in + Some (watches ^ "\000") + | "xenbus" :: domid :: _ -> + let domid =3D int_of_string domid in + let con =3D Connections.find_domain cons domid in + let s =3D 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 =3D int_of_string domid in + let con =3D Connections.find_domain cons domid in + may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Conn= ection.get_domain con) + | _ -> None + with _ -> None =20 let do_directory con t _domains _cons data =3D - let path =3D split_one_path data con in - let entries =3D Transaction.ls t (Connection.get_perm con) path in - if List.length entries > 0 then - (Utils.join_by_null entries) ^ "\000" - else - "" + let path =3D split_one_path data con in + let entries =3D Transaction.ls t (Connection.get_perm con) path in + if List.length entries > 0 then + (Utils.join_by_null entries) ^ "\000" + else + "" =20 let do_read con t _domains _cons data =3D - let path =3D split_one_path data con in - Transaction.read t (Connection.get_perm con) path + let path =3D split_one_path data con in + Transaction.read t (Connection.get_perm con) path =20 let do_getperms con t _domains _cons data =3D - let path =3D split_one_path data con in - let perms =3D Transaction.getperms t (Connection.get_perm con) path in - Perms.Node.to_string perms ^ "\000" + let path =3D split_one_path data con in + let perms =3D Transaction.getperms t (Connection.get_perm con) path in + Perms.Node.to_string perms ^ "\000" =20 let do_getdomainpath _con _t _domains _cons data =3D - let domid =3D - 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 =3D + match (split None '\000' data) with + | domid :: "" :: [] -> c_int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + sprintf "/local/domain/%u\000" domid =20 let do_write con t _domains _cons data =3D - let path, value =3D - 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 =3D + match (split (Some 2) '\000' data) with + | path :: value :: [] -> Store.Path.create path (Connection.get_path c= on), value + | _ -> raise Invalid_Cmd_Args + in + create_implicit_path t (Connection.get_perm con) path; + Transaction.write t (Connection.get_perm con) path value =20 let do_mkdir con t _domains _cons data =3D - let path =3D 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 =3D 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 -> () =20 let do_rm con t _domains _cons data =3D - let path =3D split_one_path data con in - try - Transaction.rm t (Connection.get_perm con) path - with - Define.Doesnt_exist -> () + let path =3D split_one_path data con in + try + Transaction.rm t (Connection.get_perm con) path + with + Define.Doesnt_exist -> () =20 let do_setperms con t _domains _cons data =3D - let path, perms =3D - 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 =3D + 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 =20 let do_error _con _t _domains _cons _data =3D - raise Define.Unknown_operation + raise Define.Unknown_operation =20 let do_isintroduced con _t domains _cons data =3D - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid =3D - match (split None '\000' data) with - | domid :: _ -> int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - if domid =3D 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 =3D + match (split None '\000' data) with + | domid :: _ -> int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + if domid =3D Define.domid_self || Domains.exist domains domid then "T\00= 0" else "F\000" =20 (* only in xen >=3D 4.2 *) let do_reset_watches con _t _domains cons _data =3D @@ -335,432 +335,432 @@ let do_reset_watches con _t _domains cons _data =3D =20 (* only in >=3D xen3.3 = *) let do_set_target con _t _domains cons data =3D - 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_s= tring 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_s= tring domid) (c_int_of_string target_domid) + | _ -> raise Invalid_Cmd_Args =20 (*------------- Generic handling of ty ------------------*) let send_response ty con t rid response =3D - 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 =20 let reply_ack fct con t doms cons data =3D - fct con t doms cons data; - Packet.Ack (fun () -> - if Transaction.get_id t =3D Transaction.none then - process_watch con t cons - ) + fct con t doms cons data; + Packet.Ack (fun () -> + if Transaction.get_id t =3D Transaction.none then + process_watch con t cons + ) =20 let reply_data fct con t doms cons data =3D - let ret =3D fct con t doms cons data in - Packet.Reply ret + let ret =3D fct con t doms cons data in + Packet.Reply ret =20 let reply_data_or_ack fct con t doms cons data =3D - 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 () -> ()) =20 let reply_none fct con t doms cons data =3D - (* let the function reply *) - fct con t doms cons data + (* let the function reply *) + fct con t doms cons data =20 (* Functions for 'simple' operations that cannot be part of a transaction = *) let function_of_type_simple_op ty =3D - 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_simpl= e_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 =20 let input_handle_error ~cons ~doms ~fct ~con ~t ~req =3D - let reply_error e =3D - 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 =3D + 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" =20 let write_access_log ~ty ~tid ~con ~data =3D - Logging.xb_op ~ty ~tid ~con data + Logging.xb_op ~ty ~tid ~con data =20 let write_answer_log ~ty ~tid ~con ~data =3D - Logging.xb_answer ~ty ~tid ~con data + Logging.xb_answer ~ty ~tid ~con data =20 let write_response_log ~ty ~tid ~con ~response =3D - 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 =20 let record_commit ~con ~tid ~before ~after =3D - let inc r =3D r :=3D Int64.add 1L !r in - let finish_count =3D inc Transaction.counter; !Transaction.counter in - History.push {History.con=3Dcon; tid=3Dtid; before=3Dbefore; after=3Dafte= r; finish_count=3Dfinish_count} + let inc r =3D r :=3D Int64.add 1L !r in + let finish_count =3D inc Transaction.counter; !Transaction.counter in + History.push {History.con=3Dcon; tid=3Dtid; before=3Dbefore; after=3Daft= er; finish_count=3Dfinish_count} =20 (* 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 =3D - match t.Transaction.ty with - | Transaction.No -> - error "attempted to replay a non-full transaction"; - false - | Transaction.Full(id, _oldstore, cstore) -> - let tid =3D Connection.start_transaction c cstore in - let replay_t =3D Transaction.make ~internal:true tid cstore in - let con =3D 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 =3D Connection.start_transaction c cstore in + let replay_t =3D Transaction.make ~internal:true tid cstore in + let con =3D sprintf "r(%d):%s" id (Connection.get_domstr c) in =20 - let perform_exn ~wlog txn (request, response) =3D - if wlog then write_access_log ~ty:request.Packet.ty ~tid ~con ~data:req= uest.Packet.data; - let fct =3D function_of_type_simple_op request.Packet.ty in - let response' =3D input_handle_error ~cons ~doms ~fct ~con:c ~t:txn ~re= q:request in - if wlog then write_response_log ~ty:request.Packet.ty ~tid ~con ~respon= se: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_operation= s t); (* May throw EAGAIN *) + let perform_exn ~wlog txn (request, response) =3D + if wlog then write_access_log ~ty:request.Packet.ty ~tid ~con ~data:= request.Packet.data; + let fct =3D function_of_type_simple_op request.Packet.ty in + let response' =3D 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 ~res= ponse:response'; + if not(Packet.response_equal response response') then raise Transact= ion_again + in + finally + (fun () -> + try + Logging.start_transaction ~con ~tid; + List.iter (perform_exn ~wlog:true replay_t) (Transaction.get_op= erations t); (* May throw EAGAIN *) =20 - Logging.end_transaction ~con ~tid; - Transaction.commit ~con replay_t - with - | Transaction_again -> ( - Transaction.failed_commits :=3D Int64.add !Transaction.failed_commits = 1L; - let victim_domstr =3D Connection.get_domstr c in - debug "Apportioning blame for EAGAIN in txn %d, domain=3D%s" id victim= _domstr; - let punish guilty_con =3D - 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 =3D ( - let can_apply_on store =3D ( - let store =3D Store.copy store in - let trial_t =3D Transaction.make ~internal:true Transaction.none sto= re in - try List.iter (perform_exn ~wlog:false trial_t) (Transaction.get_ope= rations 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 =3D History.filter_connections ~ignore:c ~since:t.Tran= saction.start_count ~f:judge_and_sentence in - if Hashtbl.length guilty_cons =3D 0 then ( - debug "Found no culprit for conflict in %s: must be self or not in hi= story." con; - Transaction.failed_commits_no_culprit :=3D Int64.add !Transaction.fai= led_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 :=3D Int64.add !Transaction.failed= _commits 1L; + let victim_domstr =3D Connection.get_domstr c in + debug "Apportioning blame for EAGAIN in txn %d, domain=3D%s" = id victim_domstr; + let punish guilty_con =3D + 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 =3D ( + let can_apply_on store =3D ( + let store =3D Store.copy store in + let trial_t =3D Transaction.make ~internal:true Transacti= on.none store in + try List.iter (perform_exn ~wlog:false trial_t) (Transact= ion.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 =3D History.filter_connections ~ignore:c ~sin= ce:t.Transaction.start_count ~f:judge_and_sentence in + if Hashtbl.length guilty_cons =3D 0 then ( + debug "Found no culprit for conflict in %s: must be self or= not in history." con; + Transaction.failed_commits_no_culprit :=3D Int64.add !Trans= action.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 + ) =20 let do_watch con _t _domains cons data =3D - let (node, token) =3D - match (split None '\000' data) with - | [node; token; ""] -> node, token - | _ -> raise Invalid_Cmd_Args - in - let watch =3D 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) =3D + match (split None '\000' data) with + | [node; token; ""] -> node, token + | _ -> raise Invalid_Cmd_Args + in + let watch =3D 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) =20 let do_unwatch con _t _domains cons data =3D - let (node, token) =3D - 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) =3D + match (split None '\000' data) with + | [node; token; ""] -> node, token + | _ -> raise Invalid_Cmd_Args + in + ignore @@ Connections.del_watch cons con node token =20 let do_transaction_start con t _domains _cons _data =3D - if Transaction.get_id t <> Transaction.none then - raise Transaction_nested; - let store =3D 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 =3D Transaction.get_store t in + string_of_int (Connection.start_transaction con store) ^ "\000" =20 let do_transaction_end con t domains cons data =3D - let commit =3D - match (split None '\000' data) with - | "T" :: _ -> true - | "F" :: _ -> false - | x :: _ -> raise (Invalid_argument x) - | _ -> raise Invalid_Cmd_Args - in - let commit =3D commit && not (Transaction.is_read_only t) in - let success =3D - let commit =3D 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 =3D + match (split None '\000' data) with + | "T" :: _ -> true + | "F" :: _ -> false + | x :: _ -> raise (Invalid_argument x) + | _ -> raise Invalid_Cmd_Args + in + let commit =3D commit && not (Transaction.is_read_only t) in + let success =3D + let commit =3D if commit then Some (fun con trans -> transaction_repla= y 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 =20 let do_introduce con t domains cons data =3D - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let (domid, mfn, port) =3D - 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 =3D - if Domains.exist domains domid then - let edom =3D Domains.find domains domid in - if (Domain.get_mfn edom) =3D mfn && (Connections.find_domain cons domid= ) !=3D 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 =3D 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 th= en - raise Domain_not_match + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let (domid, mfn, port) =3D + 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 =3D + if Domains.exist domains domid then + let edom =3D Domains.find domains domid in + if (Domain.get_mfn edom) =3D mfn && (Connections.find_domain cons do= mid) !=3D 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 =3D 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 t= hen + raise Domain_not_match =20 let do_release con t domains cons data =3D - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid =3D - match (split None '\000' data) with - | [domid;""] -> int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - let fire_spec_watches =3D 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.Pa= th.release_domain - else raise Invalid_Cmd_Args + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let domid =3D + match (split None '\000' data) with + | [domid;""] -> int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + let fire_spec_watches =3D 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.P= ath.release_domain + else raise Invalid_Cmd_Args =20 let do_resume con _t domains _cons data =3D - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid =3D - 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 =3D + 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 =20 let function_of_type ty =3D - 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 =20 (** * Determines which individual (non-transactional) operations we want to r= etain. * We only want to retain operations that have side-effects in the store s= ince * these can be the cause of transactions failing. - *) +*) let retain_op_in_history ty =3D - 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 =20 let maybe_ignore_transaction =3D 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 =20 =20 let () =3D Printexc.record_backtrace true =20 (** * Nothrow guarantee. - *) +*) let process_packet ~store ~cons ~doms ~con ~req =3D - let ty =3D req.Packet.ty in - let tid =3D maybe_ignore_transaction ty req.Packet.tid in - let rid =3D req.Packet.rid in - try - let fct =3D function_of_type ty in - let t =3D - if tid =3D Transaction.none then - Transaction.make tid store - else - Connection.get_transaction con tid - in + let ty =3D req.Packet.ty in + let tid =3D maybe_ignore_transaction ty req.Packet.tid in + let rid =3D req.Packet.rid in + try + let fct =3D function_of_type ty in + let t =3D + if tid =3D Transaction.none then + Transaction.make tid store + else + Connection.get_transaction con tid + in =20 - let execute () =3D input_handle_error ~cons ~doms ~fct ~con ~t ~req in + let execute () =3D input_handle_error ~cons ~doms ~fct ~con ~t ~req in =20 - let response =3D - (* Note that transactions are recorded in history separately. *) - if tid =3D Transaction.none && retain_op_in_history ty then begin - let before =3D Store.copy store in - let response =3D execute () in - let after =3D Store.copy store in - record_commit ~con ~tid ~before ~after; - response - end else execute () - in + let response =3D + (* Note that transactions are recorded in history separately. *) + if tid =3D Transaction.none && retain_op_in_history ty then begin + let before =3D Store.copy store in + let response =3D execute () in + let after =3D Store.copy store in + record_commit ~con ~tid ~before ~after; + response + end else execute () + in =20 - let response =3D 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 nee= d to replay the transaction *) - Transaction.add_operation t req response; - response - with Quota.Limit_reached -> - Packet.Error "EQUOTA" - in + let response =3D 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 =20 - (* Put the response on the wire *) - send_response ty con t rid response - with exn -> - let bt =3D 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 =3D Printexc.get_backtrace () in + error "process packet: %s. %s" (Printexc.to_string exn) bt; + Connection.send_error con tid rid "EIO" =20 let do_input store cons doms con =3D - let newpacket =3D - 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 =3D + 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_domst= r con)); + Connection.mark_as_bad con; + None + in =20 - match newpacket with - | None -> () - | Some packet -> - let tid, rid, ty, data =3D Xenbus.Xb.Packet.unpack packet in - let req =3D {Packet.tid=3Dtid; Packet.rid=3Drid; Packet.ty=3Dty; Packet.= data=3Ddata} in + match newpacket with + | None -> () + | Some packet -> + let tid, rid, ty, data =3D Xenbus.Xb.Packet.unpack packet in + let req =3D {Packet.tid=3Dtid; Packet.rid=3Drid; Packet.ty=3Dty; Packe= t.data=3Ddata} in =20 - (* 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 =20 let do_output _store _cons _doms con =3D - Connection.source_flush_watchevents con; - if Connection.has_output con then ( - if Connection.has_new_output con then ( - let packet =3D Connection.peek_output con in - let tid, _rid, ty, data =3D 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 =3D Connection.peek_output con in + let tid, _rid, ty, data =3D 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) + ) =20 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 =3D ref (1000) let maxsize =3D ref (2048) =20 type t =3D { - 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 *) } =20 let to_string quota domid =3D - if Hashtbl.mem quota.cur domid - then Printf.sprintf "dom%i quota: %i/%i" domid (Hashtbl.find quota.cur do= mid) 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 d= omid) quota.maxent + else Printf.sprintf "dom%i quota: not set" domid =20 let create () =3D - { maxent =3D !maxent; maxsize =3D !maxsize; cur =3D Hashtbl.create 100; } + { maxent =3D !maxent; maxsize =3D !maxsize; cur =3D Hashtbl.create 100; } =20 let copy quota =3D { quota with cur =3D (Hashtbl.copy quota.cur) } =20 let del quota id =3D Hashtbl.remove quota.cur id =20 let _check quota id size =3D - 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 =3D Hashtbl.find quota.cur id in - if entry >=3D 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 =3D Hashtbl.find quota.cur id in + if entry >=3D quota.maxent then ( + warn "domain %u cannot create entry: quota reached" id; + raise Limit_reached + ) =20 let check quota id size =3D - if !activate then - _check quota id size + if !activate then + _check quota id size =20 let get_entry quota id =3D Hashtbl.find quota.cur id =20 let set_entry quota id nb =3D - if nb =3D 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 =3D 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 =20 let del_entry quota id =3D - try - let nb =3D get_entry quota id in - set_entry quota id (nb - 1) - with Not_found -> () + try + let nb =3D get_entry quota id in + set_entry quota id (nb - 1) + with Not_found -> () =20 let add_entry quota id =3D - let nb =3D try get_entry quota id with Not_found -> 0 in - set_entry quota id (nb + 1) + let nb =3D try get_entry quota id with Not_found -> 0 in + set_entry quota id (nb + 1) =20 let add quota diff =3D - 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 =20 let merge orig_quota mod_quota dest_quota =3D - Hashtbl.iter (fun id nb -> let diff =3D 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 =3D nb - (try get_entry orig_quota i= d with Not_found -> 0) in + if diff <> 0 then + set_entry dest_quota id ((try get_entry dest_quota id with Not_fou= nd -> 0) + diff)) mod_quota.cur diff --git a/tools/ocaml/xenstored/select_stubs.c b/tools/ocaml/xenstored/s= elect_stubs.c index af72b84fa2..f2ef1ec3de 100644 --- a/tools/ocaml/xenstored/select_stubs.c +++ b/tools/ocaml/xenstored/select_stubs.c @@ -25,56 +25,56 @@ =20 CAMLprim value stub_select_on_poll(value fd_events, value timeo) { =20 - CAMLparam2(fd_events, timeo); - CAMLlocal1(events); - int i, rc, c_len =3D Wosize_val(fd_events), c_timeo =3D Int_val(timeo); - struct pollfd c_fds[c_len]; + CAMLparam2(fd_events, timeo); + CAMLlocal1(events); + int i, rc, c_len =3D Wosize_val(fd_events), c_timeo =3D Int_val(timeo); + struct pollfd c_fds[c_len]; =20 =20 - for (i =3D 0; i < c_len; i++) { + for (i =3D 0; i < c_len; i++) { =20 - events =3D Field(Field(fd_events, i), 1); + events =3D Field(Field(fd_events, i), 1); =20 - c_fds[i].fd =3D Int_val(Field(Field(fd_events, i), 0)); - c_fds[i].events =3D c_fds[i].revents =3D 0; - c_fds[i].events |=3D Bool_val(Field(events, 0)) ? POLLIN : 0; - c_fds[i].events |=3D Bool_val(Field(events, 1)) ? POLLOUT: 0; - c_fds[i].events |=3D Bool_val(Field(events, 2)) ? POLLPRI: 0; + c_fds[i].fd =3D Int_val(Field(Field(fd_events, i), 0)); + c_fds[i].events =3D c_fds[i].revents =3D 0; + c_fds[i].events |=3D Bool_val(Field(events, 0)) ? POLLIN : 0; + c_fds[i].events |=3D Bool_val(Field(events, 1)) ? POLLOUT: 0; + c_fds[i].events |=3D Bool_val(Field(events, 2)) ? POLLPRI: 0; =20 - }; + }; =20 - caml_enter_blocking_section(); - rc =3D poll(c_fds, c_len, c_timeo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc =3D poll(c_fds, c_len, c_timeo); + caml_leave_blocking_section(); =20 - if (rc < 0) uerror("poll", Nothing); + if (rc < 0) uerror("poll", Nothing); =20 - if (rc > 0) { + if (rc > 0) { =20 - for (i =3D 0; i < c_len; i++) { + for (i =3D 0; i < c_len; i++) { =20 - events =3D Field(Field(fd_events, i), 1); + events =3D Field(Field(fd_events, i), 1); =20 - if (c_fds[i].revents & POLLNVAL) unix_error(EBADF, "select", Nothing); - Field(events, 0) =3D Val_bool(c_fds[i].events & POLLIN && c_fds[i].rev= ents & (POLLIN |POLLHUP|POLLERR)); - Field(events, 1) =3D Val_bool(c_fds[i].events & POLLOUT && c_fds[i].rev= ents & (POLLOUT|POLLHUP|POLLERR)); - Field(events, 2) =3D Val_bool(c_fds[i].revents & POLLPRI); + if (c_fds[i].revents & POLLNVAL) unix_error(EBADF, "select", N= othing); + Field(events, 0) =3D Val_bool(c_fds[i].events & POLLIN && c_f= ds[i].revents & (POLLIN |POLLHUP|POLLERR)); + Field(events, 1) =3D Val_bool(c_fds[i].events & POLLOUT && c_f= ds[i].revents & (POLLOUT|POLLHUP|POLLERR)); + Field(events, 2) =3D Val_bool(c_fds[i].revents & POLLPRI); =20 - } + } =20 - } + } =20 - CAMLreturn(Val_int(rc)); + CAMLreturn(Val_int(rc)); } =20 =20 CAMLprim value stub_set_fd_limit(value limit) { =20 - CAMLparam1(limit); - struct rlimit rl; + CAMLparam1(limit); + struct rlimit rl; =20 - rl.rlim_cur =3D rl.rlim_max =3D Int_val(limit); - if (setrlimit(RLIMIT_NOFILE, &rl) !=3D 0) uerror("setrlimit", Nothing); - CAMLreturn(Val_unit); + rl.rlim_cur =3D rl.rlim_max =3D Int_val(limit); + if (setrlimit(RLIMIT_NOFILE, &rl) !=3D 0) uerror("setrlimit", Nothing); + CAMLreturn(Val_unit); =20 } 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 =3D Right of 'a | Left of 'b =20 (** apply the clean_f function after fct function has been called. * Even if fct raises an exception, clean_f is applied - *) +*) let exnhook =3D ref None =20 let finally fct clean_f =3D - let result =3D try - fct (); - with - exn -> - (match !exnhook with None -> () | Some f -> f exn); - clean_f (); raise exn in - clean_f (); - result + let result =3D try + fct (); + with + exn -> + (match !exnhook with None -> () | Some f -> f exn); + clean_f (); raise exn in + clean_f (); + result =20 (** if v is not none, apply f on it and return some value else return none= . *) let may f v =3D - match v with Some x -> Some (f x) | None -> None + match v with Some x -> Some (f x) | None -> None =20 (** default value to d if v is none. *) let default d v =3D - match v with Some x -> x | None -> d + match v with Some x -> x | None -> d =20 (** apply f on v if not none *) let maybe f v =3D - match v with None -> () | Some x -> f x + match v with None -> () | Some x -> f x =20 module Filename =3D struct - include Filename - let quote_command cmd args =3D - cmd :: args |> List.map quote |> String.concat " " + include Filename + let quote_command cmd args =3D + cmd :: args |> List.map quote |> String.concat " " end =20 module Map =3D struct - module Make(Ord: Map.OrderedType) =3D struct + module Make(Ord: Map.OrderedType) =3D struct =20 - include Map.Make(Ord) + include Map.Make(Ord) =20 - let find_opt k t =3D try Some (find k t) with Not_found -> None + let find_opt k t =3D try Some (find k t) with Not_found -> None =20 - let update k f t =3D - let r =3D find_opt k t in - let r' =3D f r in - match r, r' with - | None, None -> t - | Some _, None -> remove k t - | Some r, Some r' when r =3D=3D r' -> t - | _, Some r' -> add k r' t + let update k f t =3D + let r =3D find_opt k t in + let r' =3D f r in + match r, r' with + | None, None -> t + | Some _, None -> remove k t + | Some r, Some r' when r =3D=3D r' -> t + | _, Some r' -> add k r' t =20 - end + end end =20 module String =3D struct include String =20 -let of_char c =3D String.make 1 c + let of_char c =3D String.make 1 c =20 -let rec split ?limit:(limit=3D(-1)) c s =3D - let i =3D try String.index s c with Not_found -> -1 in - let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - 1 in - if i =3D -1 || nlimit =3D 0 then - [ s ] - else - let a =3D String.sub s 0 i - and b =3D String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) + let rec split ?limit:(limit=3D(-1)) c s =3D + let i =3D try String.index s c with Not_found -> -1 in + let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - = 1 in + if i =3D -1 || nlimit =3D 0 then + [ s ] + else + let a =3D String.sub s 0 i + and b =3D String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) =20 -let fold_left f accu string =3D - let accu =3D ref accu in - for i =3D 0 to length string - 1 do - accu :=3D f !accu string.[i] - done; - !accu + let fold_left f accu string =3D + let accu =3D ref accu in + for i =3D 0 to length string - 1 do + accu :=3D f !accu string.[i] + done; + !accu =20 -(** True if string 'x' starts with prefix 'prefix' *) -let startswith prefix x =3D - let x_l =3D String.length x and prefix_l =3D String.length prefix in - prefix_l <=3D x_l && String.sub x 0 prefix_l =3D prefix + (** True if string 'x' starts with prefix 'prefix' *) + let startswith prefix x =3D + let x_l =3D String.length x and prefix_l =3D String.length prefix in + prefix_l <=3D x_l && String.sub x 0 prefix_l =3D prefix end =20 module Unixext =3D struct =20 -(** remove a file, but doesn't raise an exception if the file is already r= emoved *) -let unlink_safe file =3D - 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 =3D + try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ = -> () =20 -(** create a directory but doesn't raise an exception if the directory alr= eady exist *) -let mkdir_safe dir perm =3D - try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + (** create a directory but doesn't raise an exception if the directory a= lready exist *) + let mkdir_safe dir perm =3D + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () =20 -(** create a directory, and create parent if doesn't exist *) -let mkdir_rec dir perm =3D - let rec p_mkdir dir =3D - let p_name =3D 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 =3D + let rec p_mkdir dir =3D + let p_name =3D Filename.dirname dir in + if p_name <> "/" && p_name <> "." + then p_mkdir p_name; + mkdir_safe dir perm in + p_mkdir dir =20 -(** daemonize a process *) -(* !! Must call this before spawning any threads !! *) -let daemonize () =3D - match Unix.fork () with - | 0 -> - if Unix.setsid () =3D=3D -1 then - failwith "Unix.setsid failed"; + (** daemonize a process *) + (* !! Must call this before spawning any threads !! *) + let daemonize () =3D + match Unix.fork () with + | 0 -> + if Unix.setsid () =3D=3D -1 then + failwith "Unix.setsid failed"; =20 - begin match Unix.fork () with - | 0 -> - let nullfd =3D 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 =3D 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 =20 -(** write a pidfile file *) -let pidfile_write filename =3D - let fd =3D Unix.openfile filename - [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] - 0o640 in - finally - (fun () -> - let pid =3D Unix.getpid () in - let buf =3D string_of_int pid ^ "\n" in - let len =3D 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 =3D + let fd =3D Unix.openfile filename + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] + 0o640 in + finally + (fun () -> + let pid =3D Unix.getpid () in + let buf =3D string_of_int pid ^ "\n" in + let len =3D String.length buf in + if Unix.write_substring fd buf 0 len <> len + then failwith "pidfile_write failed"; + ) + (fun () -> Unix.close fd) =20 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 =3D Map.Make(Symbol) =20 module Node =3D struct =20 -type t =3D { - name: Symbol.t; - perms: Perms.Node.t; - value: string; - children: t SymbolMap.t; -} + type t =3D { + name: Symbol.t; + perms: Perms.Node.t; + value: string; + children: t SymbolMap.t; + } =20 -let create _name _perms _value =3D - { name =3D Symbol.of_string _name; perms =3D _perms; value =3D _value; ch= ildren =3D SymbolMap.empty; } + let create _name _perms _value =3D + { name =3D Symbol.of_string _name; perms =3D _perms; value =3D _value;= children =3D SymbolMap.empty; } =20 -let get_owner node =3D Perms.Node.get_owner node.perms -let get_children node =3D node.children -let get_value node =3D node.value -let get_perms node =3D node.perms -let get_name node =3D Symbol.to_string node.name + let get_owner node =3D Perms.Node.get_owner node.perms + let get_children node =3D node.children + let get_value node =3D node.value + let get_perms node =3D node.perms + let get_name node =3D Symbol.to_string node.name =20 -let set_value node nvalue =3D - if node.value =3D nvalue - then node - else { node with value =3D nvalue } + let set_value node nvalue =3D + if node.value =3D nvalue + then node + else { node with value =3D nvalue } =20 -let set_perms node nperms =3D { node with perms =3D nperms } + let set_perms node nperms =3D { node with perms =3D nperms } =20 -let add_child node child =3D - let children =3D SymbolMap.add child.name child node.children in - { node with children } + let add_child node child =3D + let children =3D SymbolMap.add child.name child node.children in + { node with children } =20 -let exists node childname =3D - let childname =3D Symbol.of_string childname in - SymbolMap.mem childname node.children + let exists node childname =3D + let childname =3D Symbol.of_string childname in + SymbolMap.mem childname node.children =20 -let find node childname =3D - let childname =3D Symbol.of_string childname in - SymbolMap.find childname node.children + let find node childname =3D + let childname =3D Symbol.of_string childname in + SymbolMap.find childname node.children =20 -let replace_child node child nchild =3D - { node with - children =3D SymbolMap.update child.name - (function None -> None | Some _ -> Some nchild) - node.children - } + let replace_child node child nchild =3D + { node with + children =3D SymbolMap.update child.name + (function None -> None | Some _ -> Some nchild) + node.children + } =20 -let del_childname node childname =3D - let sym =3D Symbol.of_string childname in - { node with children =3D - SymbolMap.update sym - (function None -> raise Not_found | Some _ -> None) - node.children - } + let del_childname node childname =3D + let sym =3D Symbol.of_string childname in + { node with children =3D + SymbolMap.update sym + (function None -> raise Not_found | Some _ -> None) + node.children + } =20 -let del_all_children node =3D - { node with children =3D SymbolMap.empty } + let del_all_children node =3D + { node with children =3D SymbolMap.empty } =20 -(* check if the current node can be accessed by the current connection wit= h rperm permissions *) -let check_perm node connection request =3D - Perms.check connection request node.perms + (* check if the current node can be accessed by the current connection w= ith rperm permissions *) + let check_perm node connection request =3D + Perms.check connection request node.perms =20 -(* check if the current node is owned by the current connection *) -let check_owner node connection =3D - 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 =3D + 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 =20 -let rec recurse fct node =3D fct node; SymbolMap.iter (fun _ -> recurse fc= t) node.children + let rec recurse fct node =3D fct node; SymbolMap.iter (fun _ -> recurse = fct) node.children =20 -(** [recurse_filter_map f tree] applies [f] on each node in the tree recur= sively, - possibly removing some nodes. - Note that the nodes removed this way won't generate watch events. -*) -let recurse_filter_map f =3D - let invalid =3D -1 in - let is_valid _ node =3D node.perms.owner <> invalid in - let rec walk node =3D - (* Map.filter_map is Ocaml 4.11+ only *) - let node =3D - { node with children =3D - SymbolMap.map walk node.children |> SymbolMap.filter is_valid } in - match f node with - | Some keep -> keep - | None -> { node with perms =3D {node.perms with owner =3D invalid } } - in - walk + (** [recurse_filter_map f tree] applies [f] on each node in the tree rec= ursively, + possibly removing some nodes. + Note that the nodes removed this way won't generate watch events. + *) + let recurse_filter_map f =3D + let invalid =3D -1 in + let is_valid _ node =3D node.perms.owner <> invalid in + let rec walk node =3D + (* Map.filter_map is Ocaml 4.11+ only *) + let node =3D + { node with children =3D + SymbolMap.map walk node.children |> SymbolMap.filter= is_valid } in + match f node with + | Some keep -> keep + | None -> { node with perms =3D {node.perms with owner =3D invalid }= } + in + walk =20 -let unpack node =3D (Symbol.to_string node.name, node.perms, node.value) + let unpack node =3D (Symbol.to_string node.name, node.perms, node.value) =20 end =20 module Path =3D struct =20 -(* represent a path in a store. - * [] -> "/" - * [ "local"; "domain"; "1" ] -> "/local/domain/1" - *) -type t =3D string list + (* represent a path in a store. + * [] -> "/" + * [ "local"; "domain"; "1" ] -> "/local/domain/1" + *) + type t =3D string list =20 -let char_is_valid c =3D - (c >=3D 'a' && c <=3D 'z') || - (c >=3D 'A' && c <=3D 'Z') || - (c >=3D '0' && c <=3D '9') || - c =3D '_' || c =3D '-' || c =3D '@' + let char_is_valid c =3D + (c >=3D 'a' && c <=3D 'z') || + (c >=3D 'A' && c <=3D 'Z') || + (c >=3D '0' && c <=3D '9') || + c =3D '_' || c =3D '-' || c =3D '@' =20 -let name_is_valid name =3D - name <> "" && String.fold_left (fun accu c -> accu && char_is_valid c) tr= ue name + let name_is_valid name =3D + name <> "" && String.fold_left (fun accu c -> accu && char_is_valid c)= true name =20 -let is_valid path =3D - List.for_all name_is_valid path + let is_valid path =3D + List.for_all name_is_valid path =20 -let of_string s =3D - if s.[0] =3D '@' - then [s] - else if s =3D "/" - then [] - else match String.split '/' s with - | "" :: path when is_valid path -> path - | _ -> raise Define.Invalid_path + let of_string s =3D + if s.[0] =3D '@' + then [s] + else if s =3D "/" + then [] + else match String.split '/' s with + | "" :: path when is_valid path -> path + | _ -> raise Define.Invalid_path =20 -let of_path_and_name path name =3D - match path, name with - | [], "" -> [] - | _ -> path @ [name] + let of_path_and_name path name =3D + match path, name with + | [], "" -> [] + | _ -> path @ [name] =20 -let create path connection_path =3D - of_string (Utils.path_validate path connection_path) + let create path connection_path =3D + of_string (Utils.path_validate path connection_path) =20 -let to_string t =3D - "/" ^ (String.concat "/" t) + let to_string t =3D + "/" ^ (String.concat "/" t) =20 -let to_string_list x =3D x + let to_string_list x =3D x =20 -let get_parent t =3D - if t =3D [] then [] else List.rev (List.tl (List.rev t)) + let get_parent t =3D + if t =3D [] then [] else List.rev (List.tl (List.rev t)) =20 -let get_hierarchy path =3D - Utils.get_hierarchy path + let get_hierarchy path =3D + Utils.get_hierarchy path =20 -let get_common_prefix p1 p2 =3D - let rec compare l1 l2 =3D - match l1, l2 with - | h1 :: tl1, h2 :: tl2 -> - if h1 =3D 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 =3D + let rec compare l1 l2 =3D + match l1, l2 with + | h1 :: tl1, h2 :: tl2 -> + if h1 =3D h2 then h1 :: (compare tl1 tl2) else [] + | _, [] | [], _ -> + (* if l1 or l2 is empty, we found the equal part already *) + [] + in + compare p1 p2 =20 -let rec lookup_modify node path fct =3D - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> fct node h - | h :: l -> - let (n, c) =3D - if not (Node.exists node h) then - raise (Define.Lookup_Doesnt_exist h) - else - (node, Node.find node h) in - let nc =3D lookup_modify c l fct in - Node.replace_child n c nc + let rec lookup_modify node path fct =3D + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> fct node h + | h :: l -> + let (n, c) =3D + if not (Node.exists node h) then + raise (Define.Lookup_Doesnt_exist h) + else + (node, Node.find node h) in + let nc =3D lookup_modify c l fct in + Node.replace_child n c nc =20 -let apply_modify rnode path fct =3D - lookup_modify rnode path fct + let apply_modify rnode path fct =3D + lookup_modify rnode path fct =20 -let rec lookup_get node path =3D - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> - (try - Node.find node h - with Not_found -> - raise Define.Doesnt_exist) - | h :: l -> let cnode =3D Node.find node h in lookup_get cnode l + let rec lookup_get node path =3D + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> + (try + Node.find node h + with Not_found -> + raise Define.Doesnt_exist) + | h :: l -> let cnode =3D Node.find node h in lookup_get cnode l =20 -let get_node rnode path =3D - if path =3D [] then - Some rnode - else ( - try Some (lookup_get rnode path) with Define.Doesnt_exist -> None - ) + let get_node rnode path =3D + if path =3D [] then + Some rnode + else ( + try Some (lookup_get rnode path) with Define.Doesnt_exist -> None + ) =20 -(* 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 =3D 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 fl= ag on the existence of the full path *) + let rec get_deepest_existing_node node =3D function + | [] -> node, true + | h :: t -> + try get_deepest_existing_node (Node.find node h) t + with Not_found -> node, false =20 -let set_node rnode path nnode =3D - if path =3D [] then - nnode - else - let set_node node name =3D - try - let ent =3D 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 =3D + if path =3D [] then + nnode + else + let set_node node name =3D + try + let ent =3D 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 =20 -(* read | ls | getperms use this *) -let rec lookup node path fct =3D - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> fct node h - | h :: l -> let cnode =3D Node.find node h in lookup cnode l fct + (* read | ls | getperms use this *) + let rec lookup node path fct =3D + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> fct node h + | h :: l -> let cnode =3D Node.find node h in lookup cnode l fct =20 -let apply rnode path fct =3D - lookup rnode path fct + let apply rnode path fct =3D + lookup rnode path fct =20 -let introduce_domain =3D "@introduceDomain" -let release_domain =3D "@releaseDomain" -let specials =3D List.map of_string [ introduce_domain; release_domain ] + let introduce_domain =3D "@introduceDomain" + let release_domain =3D "@releaseDomain" + let specials =3D List.map of_string [ introduce_domain; release_domain ] =20 end =20 (* The Store.t type *) type t =3D -{ - 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; + } =20 let get_root store =3D store.root let set_root store root =3D store.root <- root @@ -254,149 +254,149 @@ let set_quota store quota =3D store.quota <- quota =20 (* modifying functions *) let path_mkdir store perm path =3D - let do_mkdir node name =3D - try - let ent =3D 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 =3D [] then - store.root - else - Path.apply_modify store.root path do_mkdir + let do_mkdir node name =3D + try + let ent =3D 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 =3D [] then + store.root + else + Path.apply_modify store.root path do_mkdir =20 let path_write store perm path value =3D - let node_created =3D ref false in - let do_write node name =3D - try - let ent =3D Node.find node name in - Node.check_perm ent perm Perms.WRITE; - let nent =3D Node.set_value ent value in - Node.replace_child node ent nent - with Not_found -> - node_created :=3D true; - Node.check_perm node perm Perms.WRITE; - Node.add_child node (Node.create name node.Node.perms value) in - if path =3D [] then ( - Node.check_perm store.root perm Perms.WRITE; - Node.set_value store.root value, false - ) else - let root =3D Path.apply_modify store.root path do_write in - root, !node_created + let node_created =3D ref false in + let do_write node name =3D + try + let ent =3D Node.find node name in + Node.check_perm ent perm Perms.WRITE; + let nent =3D Node.set_value ent value in + Node.replace_child node ent nent + with Not_found -> + node_created :=3D true; + Node.check_perm node perm Perms.WRITE; + Node.add_child node (Node.create name node.Node.perms value) in + if path =3D [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.set_value store.root value, false + ) else + let root =3D Path.apply_modify store.root path do_write in + root, !node_created =20 let path_rm store perm path =3D - let do_rm node name =3D - try - let ent =3D 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 =3D [] 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 =3D + try + let ent =3D 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 =3D [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.del_all_children store.root + ) else + Path.apply_modify store.root path do_rm =20 let path_setperms store perm path perms =3D - if path =3D [] then ( - Node.check_perm store.root perm Perms.WRITE; - Node.set_perms store.root perms - ) else - let do_setperms node name =3D - let c =3D Node.find node name in - Node.check_owner c perm; - Node.check_perm c perm Perms.WRITE; - let nc =3D Node.set_perms c perms in - Node.replace_child node c nc - in - Path.apply_modify store.root path do_setperms + if path =3D [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.set_perms store.root perms + ) else + let do_setperms node name =3D + let c =3D Node.find node name in + Node.check_owner c perm; + Node.check_perm c perm Perms.WRITE; + let nc =3D Node.set_perms c perms in + Node.replace_child node c nc + in + Path.apply_modify store.root path do_setperms =20 (* accessing functions *) let get_node store path =3D - Path.get_node store.root path + Path.get_node store.root path =20 let get_deepest_existing_node store path =3D - Path.get_deepest_existing_node store.root path + Path.get_deepest_existing_node store.root path =20 let read store perm path =3D - let do_read node name =3D - let ent =3D Node.find node name in - Node.check_perm ent perm Perms.READ; - ent.Node.value - in - if path =3D [] then ( - let ent =3D 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 =3D + let ent =3D Node.find node name in + Node.check_perm ent perm Perms.READ; + ent.Node.value + in + if path =3D [] then ( + let ent =3D store.root in + Node.check_perm ent perm Perms.READ; + ent.Node.value + ) else + Path.apply store.root path do_read =20 let ls store perm path =3D - let children =3D - if path =3D [] then ( - Node.check_perm store.root perm Perms.READ; - Node.get_children store.root - ) else - let do_ls node name =3D - let cnode =3D 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 =3D + if path =3D [] then ( + Node.check_perm store.root perm Perms.READ; + Node.get_children store.root + ) else + let do_ls node name =3D + let cnode =3D 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 [] =20 let getperms store perm path =3D - if path =3D [] then ( - Node.check_perm store.root perm Perms.READ; - Node.get_perms store.root - ) else - let fct n name =3D - let c =3D Node.find n name in - Node.check_perm c perm Perms.READ; - c.Node.perms in - Path.apply store.root path fct + if path =3D [] then ( + Node.check_perm store.root perm Perms.READ; + Node.get_perms store.root + ) else + let fct n name =3D + let c =3D Node.find n name in + Node.check_perm c perm Perms.READ; + c.Node.perms in + Path.apply store.root path fct =20 let path_exists store path =3D - if path =3D [] then - true - else - try - let check_exist node name =3D - ignore(Node.find node name); - true in - Path.apply store.root path check_exist - with Not_found -> false + if path =3D [] then + true + else + try + let check_exist node name =3D + ignore(Node.find node name); + true in + Path.apply store.root path check_exist + with Not_found -> false =20 =20 (* others utils *) let traversal root_node f =3D - let rec _traversal path node =3D - f path node; - let node_path =3D 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 =3D + f path node; + let node_path =3D Path.of_path_and_name path (Symbol.to_string node.No= de.name) in + SymbolMap.iter (fun _ -> _traversal node_path) node.Node.children + in + _traversal [] root_node =20 let dump_store_buf root_node =3D - let buf =3D Buffer.create 8192 in - let dump_node path node =3D - let pathstr =3D 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 nod= e))); - if String.length node.Node.value > 0 then - Printf.bprintf buf " =3D %s\n" (String.escaped node.Node.value) - else - Printf.bprintf buf "\n"; - in - traversal root_node dump_node; - buf + let buf =3D Buffer.create 8192 in + let dump_node path node =3D + let pathstr =3D String.concat "/" path in + Printf.bprintf buf "%s/%s{%s}" pathstr (Symbol.to_string node.Node.nam= e) + (String.escaped (Perms.Node.to_string (Node.get_perms node))); + if String.length node.Node.value > 0 then + Printf.bprintf buf " =3D %s\n" (String.escaped node.Node.value) + else + Printf.bprintf buf "\n"; + in + traversal root_node dump_node; + buf =20 let dump_store chan root_node =3D - let buf =3D dump_store_buf root_node in - output_string chan (Buffer.contents buf); - Buffer.reset buf + let buf =3D dump_store_buf root_node in + output_string chan (Buffer.contents buf); + Buffer.reset buf =20 let dump_fct store f =3D traversal store.root f let dump store out_chan =3D dump_store out_chan store.root @@ -406,109 +406,109 @@ let dump_buffer store =3D dump_store_buf store.root =20 (* modifying functions with quota udpate *) let set_node store path node orig_quota mod_quota =3D - let root =3D Path.set_node store.root path node in - store.root <- root; - Quota.merge orig_quota mod_quota store.quota + let root =3D Path.set_node store.root path node in + store.root <- root; + Quota.merge orig_quota mod_quota store.quota =20 let write store perm path value =3D - let node, existing =3D get_deepest_existing_node store path in - let owner =3D 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 =3D path_write store perm path value in - store.root <- root; - if node_created - then Quota.add_entry store.quota owner + let node, existing =3D get_deepest_existing_node store path in + let owner =3D 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 =3D path_write store perm path value in + store.root <- root; + if node_created + then Quota.add_entry store.quota owner =20 let mkdir store perm path =3D - let node, existing =3D get_deepest_existing_node store path in - let owner =3D 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 sto= re.quota owner 0; - store.root <- path_mkdir store perm path; - if not existing then - Quota.add_entry store.quota owner + let node, existing =3D get_deepest_existing_node store path in + let owner =3D 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 st= ore.quota owner 0; + store.root <- path_mkdir store perm path; + if not existing then + Quota.add_entry store.quota owner =20 let rm store perm path =3D - let rmed_node =3D 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 no= de)) rmed_node + let rmed_node =3D 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 =20 let setperms store perm path nperms =3D - match Path.get_node store.root path with - | None -> raise Define.Doesnt_exist - | Some node -> - let old_owner =3D Node.get_owner node in - let new_owner =3D Perms.Node.get_owner nperms in - if not ((old_owner =3D new_owner) || (Perms.Connection.is_dom0 perm)) th= en - 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 =3D Node.get_owner node in + let new_owner =3D Perms.Node.get_owner nperms in + if not ((old_owner =3D 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 =20 let reset_permissions store domid =3D - 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" (No= de.get_name node); + Some { node with perms } + ) store.root =20 type ops =3D { - 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; } =20 let get_ops store perms =3D { - store =3D store; - write =3D write store perms; - mkdir =3D mkdir store perms; - rm =3D rm store perms; - setperms =3D setperms store perms; - ls =3D ls store perms; - read =3D read store perms; - getperms =3D getperms store perms; - path_exists =3D path_exists store; + store =3D store; + write =3D write store perms; + mkdir =3D mkdir store perms; + rm =3D rm store perms; + setperms =3D setperms store perms; + ls =3D ls store perms; + read =3D read store perms; + getperms =3D getperms store perms; + path_exists =3D path_exists store; } =20 let create () =3D { - stat_transaction_coalesce =3D 0; - stat_transaction_abort =3D 0; - root =3D Node.create "" Perms.Node.default0 ""; - quota =3D Quota.create (); + stat_transaction_coalesce =3D 0; + stat_transaction_abort =3D 0; + root =3D Node.create "" Perms.Node.default0 ""; + quota =3D Quota.create (); } let copy store =3D { - stat_transaction_coalesce =3D store.stat_transaction_coalesce; - stat_transaction_abort =3D store.stat_transaction_abort; - root =3D store.root; - quota =3D Quota.copy store.quota; + stat_transaction_coalesce =3D store.stat_transaction_coalesce; + stat_transaction_abort =3D store.stat_transaction_abort; + root =3D store.root; + quota =3D Quota.copy store.quota; } =20 let incr_transaction_coalesce store =3D - store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1 + store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1 let incr_transaction_abort store =3D - store.stat_transaction_abort <- store.stat_transaction_abort + 1 + store.stat_transaction_abort <- store.stat_transaction_abort + 1 =20 let stats store =3D - let nb_nodes =3D 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 =3D 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 =3D Weak.Make(struct type t =3D string let equal (x:string) (y:string) =3D (x =3D y) let hash =3D Hashtbl.hash -end) + end) =20 type t =3D string =20 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 =3D Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug type facility =3D 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 =20 external log : facility -> level -> string -> unit =3D "stub_syslog" =20 exception Unknown_facility of string let facility_of_string s =3D - 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/s= yslog_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 =20 static int __syslog_level_table[] =3D { - 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 }; =20 static int __syslog_facility_table[] =3D { - 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 }; =20 value stub_syslog(value facility, value level, value msg) { - CAMLparam3(facility, level, msg); - const char *c_msg =3D strdup(String_val(msg)); - int c_facility =3D __syslog_facility_table[Int_val(facility)] - | __syslog_level_table[Int_val(level)]; + CAMLparam3(facility, level, msg); + const char *c_msg =3D strdup(String_val(msg)); + int c_facility =3D __syslog_facility_table[Int_val(facility)] + | __syslog_level_table[Int_val(level)]; =20 - 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(); =20 - 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 @@ =20 CAMLprim value ocaml_sd_notify_ready(value ignore) { - CAMLparam1(ignore); + CAMLparam1(ignore); =20 - sd_notify(1, "READY=3D1"); + sd_notify(1, "READY=3D1"); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } =20 #else =20 CAMLprim value ocaml_sd_notify_ready(value ignore) { - CAMLparam1(ignore); + CAMLparam1(ignore); =20 - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } #endif diff --git a/tools/ocaml/xenstored/transaction.ml b/tools/ocaml/xenstored/t= ransaction.ml index 294143e233..9ce0e61e03 100644 --- a/tools/ocaml/xenstored/transaction.ml +++ b/tools/ocaml/xenstored/transaction.ml @@ -23,71 +23,71 @@ let test_eagain =3D ref false let do_coalesce =3D ref true =20 let check_parents_perms_identical root1 root2 path =3D - let hierarch =3D Store.Path.get_hierarchy path in - let permdiff =3D List.fold_left (fun acc path -> - let n1 =3D Store.Path.get_node root1 path - and n2 =3D 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 =3D Store.Path.get_hierarchy path in + let permdiff =3D List.fold_left (fun acc path -> + let n1 =3D Store.Path.get_node root1 path + and n2 =3D 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 n= 2)) || acc + | _ -> + true || acc + ) false hierarch in + (not permdiff) =20 let get_lowest path1 path2 =3D - 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) =20 let test_coalesce oldroot currentroot optpath =3D - match optpath with - | None -> true - | Some path -> - let oldnode =3D Store.Path.get_node oldroot path - and currentnode =3D Store.Path.get_node currentroot path in + match optpath with + | None -> true + | Some path -> + let oldnode =3D Store.Path.get_node oldroot path + and currentnode =3D Store.Path.get_node currentroot path in =20 - match oldnode, currentnode with - | (Some oldnode), (Some currentnode) -> - if oldnode =3D=3D 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 =3D Store.Path.get_node currentroot (Store.Path.get_parent pa= th) 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 =3D=3D 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 ve= rsion, + just sneak it in as a child of the parent node if it exists, or= else fail *) + let pnode =3D Store.Path.get_node currentroot (Store.Path.get_pare= nt path) in + match pnode with + | None -> false (* ok it doesn't exists, just bail out. *) + | Some _ -> true + ) + | _ -> + false =20 let can_coalesce oldroot currentroot path =3D - 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 =20 type ty =3D No | Full of ( - int * (* Transaction id *) - Store.t * (* Original store *) - Store.t (* A pointer to the canonical store: its root changes on e= ach transaction-commit *) -) + int * (* Transaction id *) + Store.t * (* Original store *) + Store.t (* A pointer to the canonical store: its root changes o= n each transaction-commit *) + ) =20 type t =3D { - 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 =3D match t.ty with No -> none | Full (id, _, _) -> id =20 @@ -95,48 +95,48 @@ let counter =3D ref 0L let failed_commits =3D ref 0L let failed_commits_no_culprit =3D ref 0L let reset_conflict_stats () =3D - failed_commits :=3D 0L; - failed_commits_no_culprit :=3D 0L + failed_commits :=3D 0L; + failed_commits_no_culprit :=3D 0L =20 (* Scope for optimisation: different data-structure and functions to searc= h/filter it *) let short_running_txns =3D ref [] =20 let oldest_short_running_transaction () =3D - let rec last =3D function - | [] -> None - | [x] -> Some x - | _ :: xs -> last xs - in last !short_running_txns + let rec last =3D function + | [] -> None + | [x] -> Some x + | _ :: xs -> last xs + in last !short_running_txns =20 let trim_short_running_transactions txn =3D - let cutoff =3D Unix.gettimeofday () -. !Define.conflict_max_history_secon= ds in - let keep =3D match txn with - | None -> (function (start_time, _) -> start_time >=3D cutoff) - | Some t -> (function (start_time, tx) -> start_time >=3D cutoff && tx != =3D t) - in - short_running_txns :=3D List.filter - keep - !short_running_txns + let cutoff =3D Unix.gettimeofday () -. !Define.conflict_max_history_seco= nds in + let keep =3D match txn with + | None -> (function (start_time, _) -> start_time >=3D cutoff) + | Some t -> (function (start_time, tx) -> start_time >=3D cutoff && tx= !=3D t) + in + short_running_txns :=3D List.filter + keep + !short_running_txns =20 let make ?(internal=3Dfalse) id store =3D - let ty =3D if id =3D none then No else Full(id, Store.copy store, store) = in - let txn =3D { - ty =3D ty; - start_count =3D !counter; - store =3D if id =3D none then store else Store.copy store; - quota =3D Quota.copy store.Store.quota; - oldroot =3D Store.get_root store; - paths =3D []; - operations =3D []; - quota_reached =3D false; - read_lowpath =3D None; - write_lowpath =3D None; - } in - if id <> none && not internal then ( - let now =3D Unix.gettimeofday () in - short_running_txns :=3D (now, txn) :: !short_running_txns - ); - txn + let ty =3D if id =3D none then No else Full(id, Store.copy store, store)= in + let txn =3D { + ty =3D ty; + start_count =3D !counter; + store =3D if id =3D none then store else Store.copy store; + quota =3D Quota.copy store.Store.quota; + oldroot =3D Store.get_root store; + paths =3D []; + operations =3D []; + quota_reached =3D false; + read_lowpath =3D None; + write_lowpath =3D None; + } in + if id <> none && not internal then ( + let now =3D Unix.gettimeofday () in + short_running_txns :=3D (now, txn) :: !short_running_txns + ); + txn =20 let get_store t =3D t.store let get_paths t =3D t.paths @@ -148,115 +148,115 @@ let add_wop t ty path =3D t.paths <- (ty, path) :: = t.paths let get_operations t =3D List.rev t.operations =20 let check_quota_exn ~perm t =3D - if !Define.maxrequests >=3D 0 - && not (Perms.Connection.is_dom0 perm) - && (t.quota_reached || List.length t.operations >=3D !Define.maxrequests) - then begin - t.quota_reached <- true; - raise Quota.Limit_reached; - end + if !Define.maxrequests >=3D 0 + && not (Perms.Connection.is_dom0 perm) + && (t.quota_reached || List.length t.operations >=3D !Define.maxrequests) + then begin + t.quota_reached <- true; + raise Quota.Limit_reached; + end =20 let add_operation t request response =3D - t.operations <- (request, response) :: t.operations + t.operations <- (request, response) :: t.operations let set_read_lowpath t path =3D t.read_lowpath <- get_lowest path t.read_l= owpath let set_write_lowpath t path =3D t.write_lowpath <- get_lowest path t.writ= e_lowpath =20 let path_exists t path =3D Store.path_exists t.store path =20 let write t perm path value =3D - let path_exists =3D 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 =3D 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 =20 let mkdir ?(with_watch=3Dtrue) t perm path =3D - 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 =20 let setperms t perm path perms =3D - 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 =20 let rm t perm path =3D - 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 =20 let ls t perm path =3D - let r =3D Store.ls t.store perm path in - set_read_lowpath t path; - r + let r =3D Store.ls t.store perm path in + set_read_lowpath t path; + r =20 let read t perm path =3D - let r =3D Store.read t.store perm path in - set_read_lowpath t path; - r + let r =3D Store.read t.store perm path in + set_read_lowpath t path; + r =20 let getperms t perm path =3D - let r =3D Store.getperms t.store perm path in - set_read_lowpath t path; - r + let r =3D Store.getperms t.store perm path in + set_read_lowpath t path; + r =20 let commit ~con t =3D - let has_write_ops =3D List.length t.paths > 0 in - let has_coalesced =3D ref false in - let has_commited =3D - match t.ty with - | No -> true - | Full (_id, oldstore, cstore) -> (* "cstore" meaning current canon= ical store *) - let commit_partial oldroot cstore store =3D - (* 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 =3D Store.get_node store p in + let has_write_ops =3D List.length t.paths > 0 in + let has_coalesced =3D ref false in + let has_commited =3D + match t.ty with + | No -> true + | Full (_id, oldstore, cstore) -> (* "cstore" meaning current ca= nonical store *) + let commit_partial oldroot cstore store =3D + (* 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 th= en ( + maybe (fun p -> + let n =3D Store.get_node store p in =20 - (* 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 :=3D 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 =3D - if oldroot =3D=3D 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 =3D 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.Stor= e.quota) n; + Logging.write_coalesce ~tid:(get_id t) ~con (Store.Path.to_s= tring p); + ) t.write_lowpath; + maybe (fun p -> + Logging.read_coalesce ~tid:(get_id t) ~con (Store.Path.to_st= ring p) + ) t.read_lowpath; + has_coalesced :=3D 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 =3D + if oldroot =3D=3D 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 =3D 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 =3D Map.Make(String) =20 module Node =3D struct - type 'a t =3D { - key: string; - value: 'a option; - children: 'a t StringMap.t; - } + type 'a t =3D { + key: string; + value: 'a option; + children: 'a t StringMap.t; + } =20 - let _create key value =3D { - key =3D key; - value =3D Some value; - children =3D StringMap.empty; - } + let _create key value =3D { + key =3D key; + value =3D Some value; + children =3D StringMap.empty; + } =20 - let empty key =3D { - key =3D key; - value =3D None; - children =3D StringMap.empty; - } + let empty key =3D { + key =3D key; + value =3D None; + children =3D StringMap.empty; + } =20 - let _get_key node =3D node.key - let get_value node =3D - match node.value with - | None -> raise Not_found - | Some value -> value + let _get_key node =3D node.key + let get_value node =3D + match node.value with + | None -> raise Not_found + | Some value -> value =20 - let _get_children node =3D node.children + let _get_children node =3D node.children =20 - let set_value node value =3D - { node with value =3D Some value } - let set_children node children =3D - { node with children =3D children } + let set_value node value =3D + { node with value =3D Some value } + let set_children node children =3D + { node with children =3D children } =20 - let _add_child node child =3D - { node with children =3D StringMap.add child.key child node.children } + let _add_child node child =3D + { node with children =3D StringMap.add child.key child node.children } end =20 type 'a t =3D 'a Node.t StringMap.t =20 let mem_node nodes key =3D - StringMap.mem key nodes + StringMap.mem key nodes =20 let find_node nodes key =3D - StringMap.find key nodes + StringMap.find key nodes =20 let replace_node nodes key node =3D - StringMap.update key (function None -> None | Some _ -> Some node) nodes + StringMap.update key (function None -> None | Some _ -> Some node) nodes =20 let remove_node nodes key =3D - StringMap.update key (function None -> raise Not_found | Some _ -> None) = nodes + StringMap.update key (function None -> raise Not_found | Some _ -> None)= nodes =20 let create () =3D StringMap.empty =20 let rec iter f tree =3D - let aux key node =3D - f key node.Node.value; - iter f node.Node.children - in - StringMap.iter aux tree + let aux key node =3D + f key node.Node.value; + iter f node.Node.children + in + StringMap.iter aux tree =20 let rec map f tree =3D - let aux node =3D - let value =3D - match node.Node.value with - | None -> None - | Some value -> f value - in - { node with Node.value =3D value; Node.children =3D map f node.Node.chil= dren } - in - tree |> StringMap.map aux - |> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.is= _empty n.Node.children)) + let aux node =3D + let value =3D + match node.Node.value with + | None -> None + | Some value -> f value + in + { node with Node.value =3D value; Node.children =3D map f node.Node.ch= ildren } + in + tree |> StringMap.map aux + |> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.i= s_empty n.Node.children)) =20 let rec fold f tree acc =3D - let aux key node accu =3D - fold f node.Node.children (f key node.Node.value accu) - in - StringMap.fold aux tree acc + let aux key node accu =3D + fold f node.Node.children (f key node.Node.value accu) + in + StringMap.fold aux tree acc =20 (* return a sub-trie *) let rec sub_node tree =3D function - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node =3D find_node tree h in - if t =3D [] - 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 =3D find_node tree h in + if t =3D [] + then node + else sub_node node.Node.children t + end else + raise Not_found =20 let sub tree path =3D - try (sub_node tree path).Node.children - with Not_found -> StringMap.empty + try (sub_node tree path).Node.children + with Not_found -> StringMap.empty =20 let find tree path =3D - Node.get_value (sub_node tree path) + Node.get_value (sub_node tree path) =20 (* return false if the node doesn't exists or if it is not associated to a= ny value *) let rec mem tree =3D function - | [] -> false - | h::t -> - mem_node tree h - && (let node =3D find_node tree h in - if t =3D [] - then node.Node.value <> None - else mem node.Node.children t) + | [] -> false + | h::t -> + mem_node tree h + && (let node =3D find_node tree h in + if t =3D [] + then node.Node.value <> None + else mem node.Node.children t) =20 (* Iterate over the longest valid prefix *) let rec iter_path f tree =3D function - | [] -> () - | h::l -> - if mem_node tree h - then begin - let node =3D 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 =3D find_node tree h in + f node.Node.key node.Node.value; + iter_path f node.Node.children l + end =20 let rec set_node node path value =3D - if path =3D [] - then Node.set_value node value - else begin - let children =3D set node.Node.children path value in - Node.set_children node children - end + if path =3D [] + then Node.set_value node value + else begin + let children =3D set node.Node.children path value in + Node.set_children node children + end =20 and set tree path value =3D - match path with - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node =3D find_node tree h in - replace_node tree h (set_node node t value) - end else begin - let node =3D 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 =3D find_node tree h in + replace_node tree h (set_node node t value) + end else begin + let node =3D Node.empty h in + StringMap.add node.Node.key (set_node node t value) tree + end =20 let rec unset tree =3D function - | [] -> tree - | h::t -> - if mem_node tree h - then begin - let node =3D find_node tree h in - let children =3D unset node.Node.children t in - let new_node =3D - if t =3D [] - then Node.set_children (Node.empty h) children - else Node.set_children node children - in - if StringMap.is_empty children && new_node.Node.value =3D 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 =3D find_node tree h in + let children =3D unset node.Node.children t in + let new_node =3D + if t =3D [] + then Node.set_children (Node.empty h) children + else Node.set_children node children + in + if StringMap.is_empty children && new_node.Node.value =3D None + then remove_node tree h + else replace_node tree h new_node + end else + raise Not_found =20 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 @@ =20 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 contai= ns values + of type [string * 'a option]. *) =20 val create : unit -> 'a t (** Creates an empty trie. *) =20 val mem : 'a t -> string list -> bool (** [mem t k] returns true if a value is associated with the key [k] in th= e trie [t]. - Otherwise, it returns false. *) + Otherwise, it returns false. *) =20 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]. *) =20 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].= *) =20 val unset : 'a t -> string list -> 'a t (** [unset k v] removes the association of value [v] with the key [k] in t= he 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. *) =20 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 ar= gument 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. *) =20 val iter_path : (string -> 'a option -> unit) -> 'a t -> string list -> un= it (** [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 prefi= x of [p]. *) + If [p] is not a valid path of [t], it iterates on the longest valid pr= efix of [p]. *) =20 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 val= ue. *) =20 val map : ('a -> 'b option) -> 'a t -> 'b t (** [map f t] maps [f] over every values stored in [t]. The return value o= f [f] is of type 'c option - as one may wants to remove value associated to a key. This function is no= t tail-recursive. *) + as one may wants to remove value associated to a key. This function is= not tail-recursive. *) =20 val sub : 'a t -> string list -> 'a t (** [sub t p] returns the sub-trie associated with the path [p] in the tri= e [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 =20 (* lists utils *) let filter_out filter l =3D - List.filter (fun x -> not (List.mem x filter)) l + List.filter (fun x -> not (List.mem x filter)) l =20 let filter_in filter l =3D - List.filter (fun x -> List.mem x filter) l + List.filter (fun x -> List.mem x filter) l =20 let list_remove element l =3D - List.filter (fun e -> e !=3D element) l + List.filter (fun e -> e !=3D element) l =20 let list_tl_multi n l =3D - let rec do_tl i x =3D - if i =3D 0 then x else do_tl (i - 1) (List.tl x) - in - do_tl n l + let rec do_tl i x =3D + if i =3D 0 then x else do_tl (i - 1) (List.tl x) + in + do_tl n l =20 (* string utils *) let get_hierarchy path =3D - let l =3D List.length path in - let revpath =3D List.rev path in - let rec sub i =3D - let x =3D List.rev (list_tl_multi (l - i) revpath) in - if i =3D l then [ x ] else x :: sub (i + 1) - in - sub 0 + let l =3D List.length path in + let revpath =3D List.rev path in + let rec sub i =3D + let x =3D List.rev (list_tl_multi (l - i) revpath) in + if i =3D l then [ x ] else x :: sub (i + 1) + in + sub 0 =20 let hexify s =3D - let hexseq_of_char c =3D sprintf "%02x" (Char.code c) in - let hs =3D Bytes.create (String.length s * 2) in - String.iteri (fun i c -> - let seq =3D 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 =3D sprintf "%02x" (Char.code c) in + let hs =3D Bytes.create (String.length s * 2) in + String.iteri (fun i c -> + let seq =3D 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 =20 let unhexify hs =3D - let char_of_hexseq seq0 seq1 =3D Char.chr (int_of_string (sprintf "0x%c%c= " seq0 seq1)) in - let b =3D Bytes.create (String.length hs / 2) in - for i =3D 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 =3D Char.chr (int_of_string (sprintf "0x%c%= c" seq0 seq1)) in + let b =3D Bytes.create (String.length hs / 2) in + for i =3D 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 =20 let trim_path path =3D - try - let rindex =3D String.rindex path '/' in - String.sub path 0 rindex - with - Not_found -> "" + try + let rindex =3D String.rindex path '/' in + String.sub path 0 rindex + with + Not_found -> "" =20 let join_by_null ls =3D String.concat "\000" ls =20 (* unix utils *) let create_unix_socket name =3D - Unixext.unlink_safe name; - Unixext.mkdir_rec (Filename.dirname name) 0o700; - let sockaddr =3D Unix.ADDR_UNIX(name) in - let sock =3D 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 =3D Unix.ADDR_UNIX(name) in + let sock =3D Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.bind sock sockaddr; + Unix.listen sock 1; + sock =20 let read_file_single_integer filename =3D - let fd =3D Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in - let buf =3D Bytes.make 20 '\000' in - let sz =3D Unix.read fd buf 0 20 in - Unix.close fd; - int_of_string (Bytes.sub_string buf 0 sz) + let fd =3D Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in + let buf =3D Bytes.make 20 '\000' in + let sz =3D Unix.read fd buf 0 20 in + Unix.close fd; + int_of_string (Bytes.sub_string buf 0 sz) =20 (* @path may be guest data and needs its length validating. @connection_p= ath * is generated locally in xenstored and always of the form "/local/domain= /$N/" *) let path_validate path connection_path =3D - let len =3D String.length path in + let len =3D String.length path in =20 - if len =3D 0 then raise Define.Invalid_path; + if len =3D 0 then raise Define.Invalid_path; =20 - let abs_path =3D - match String.get path 0 with - | '/' | '@' -> path - | _ -> connection_path ^ path - in + let abs_path =3D + match String.get path 0 with + | '/' | '@' -> path + | _ -> connection_path ^ path + in =20 - (* 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. =20 - This prevents paths becoming invalid across migrate when the length - of the domid changes in @param connection_path. - *) - let len =3D String.length abs_path in - let on_absolute _ _ =3D len in - let on_relative _ offset =3D len - offset in - let len =3D Scanf.ksscanf abs_path on_absolute "/local/domain/%d/%n" on_r= elative 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 =3D String.length abs_path in + let on_absolute _ _ =3D len in + let on_relative _ offset =3D len - offset in + let len =3D Scanf.ksscanf abs_path on_absolute "/local/domain/%d/%n" on_= relative in + if len > !Define.path_max then raise Define.Invalid_path; =20 - abs_path + abs_path =20 module FD : sig - type t =3D Unix.file_descr - val of_int: int -> t - val to_int : t -> int + type t =3D Unix.file_descr + val of_int: int -> t + val to_int : t -> int end =3D struct - type t =3D Unix.file_descr - (* This is like Obj.magic but just for these types, - and relies on Unix.file_descr =3D int *) - external to_int : t -> int =3D "%identity" - external of_int : int -> t =3D "%identity" + type t =3D Unix.file_descr + (* This is like Obj.magic but just for these types, + and relies on Unix.file_descr =3D int *) + external to_int : t -> int =3D "%identity" + external of_int : int -> t =3D "%identity" end diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xen= stored.ml index ffd43a4eee..34612814e1 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -26,589 +26,589 @@ let info fmt =3D Logging.info "xenstored" fmt =20 (*------------ event klass processors --------------*) let process_connection_fds store cons domains rset wset =3D - let try_fct fct c =3D - 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 =3D - 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 =3D + 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 =3D + 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 =20 let process_domains store cons domains =3D - let do_io_domain domain =3D - if Domain.is_bad_domain domain - || Domain.get_io_credit domain <=3D 0 - || Domain.is_paused_for_conflict domain - then () (* nothing to do *) - else ( - let con =3D 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 =3D + if Domain.is_bad_domain domain + || Domain.get_io_credit domain <=3D 0 + || Domain.is_paused_for_conflict domain + then () (* nothing to do *) + else ( + let con =3D 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 =20 let sigusr1_handler store =3D - try - let channel =3D 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 =3D 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 _ -> + () =20 let sighup_handler _ =3D - 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 =20 let config_filename cf =3D - 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" =20 let default_pidfile =3D Paths.xen_run_dir ^ "/xenstored.pid" =20 let ring_scan_interval =3D ref 20 =20 let parse_config filename =3D - let pidfile =3D ref default_pidfile in - let options =3D [ - ("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_hi= story_seconds); - ("conflict-rate-limit-is-aggregate", Config.Set_bool Define.conflict_rat= e_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_destinati= on); - ("xenstored-log-level", Config.String - (fun s -> Logging.xenstored_log_level :=3D 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_trans= action_ops); - ("access-log-special-ops", Config.Set_bool Logging.access_log_special_op= s); - ("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 =3D ref default_pidfile in + let options =3D [ + ("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_r= ate_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_destina= tion); + ("xenstored-log-level", Config.String + (fun s -> Logging.xenstored_log_level :=3D Logging.level_of_string = s)); + ("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_fil= es); + ("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lin= es); + ("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_cha= rs); + ("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_tra= nsaction_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 =20 module DB =3D struct =20 -exception Bad_format of string + exception Bad_format of string =20 -let dump_format_header =3D "$xenstored-dump-format" + let dump_format_header =3D "$xenstored-dump-format" =20 -let from_channel_f chan global_f socket_f domain_f watch_f store_f =3D - let unhexify s =3D Utils.unhexify s in - let getpath s =3D - let u =3D Utils.unhexify s in - debug "Path: %s" u; - Store.Path.of_string u in - let header =3D input_line chan in - if header <> dump_format_header then - raise (Bad_format "header"); - let quit =3D ref false in - while not !quit - do - try - let line =3D input_line chan in - let l =3D 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 :=3D true - done; - info "Completed loading xenstore dump" + let from_channel_f chan global_f socket_f domain_f watch_f store_f =3D + let unhexify s =3D Utils.unhexify s in + let getpath s =3D + let u =3D Utils.unhexify s in + debug "Path: %s" u; + Store.Path.of_string u in + let header =3D input_line chan in + if header <> dump_format_header then + raise (Bad_format "header"); + let quit =3D ref false in + while not !quit + do + try + let line =3D input_line chan in + let l =3D 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 :=3D true + done; + info "Completed loading xenstore dump" =20 -let from_channel store cons doms chan =3D - (* don't let the permission get on our way, full perm ! *) - let op =3D Store.get_ops store Perms.Connection.full_rights in - let rwro =3D ref (None) in - let global_f ~rw =3D - let get_listen_sock sockfd =3D - let fd =3D sockfd |> int_of_string |> Utils.FD.of_int in - Unix.listen fd 1; - Some fd - in - rwro :=3D get_listen_sock rw - in - let socket_f ~fd =3D - let ufd =3D Utils.FD.of_int fd in - let is_valid =3D try (Unix.fstat ufd).Unix.st_kind =3D 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 =3D - let ndom =3D - 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 =3D - 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 =3D - ignore (Connections.add_watch cons (get_con id) path token) - in - let store_f path perms value =3D - 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 =3D + (* don't let the permission get on our way, full perm ! *) + let op =3D Store.get_ops store Perms.Connection.full_rights in + let rwro =3D ref (None) in + let global_f ~rw =3D + let get_listen_sock sockfd =3D + let fd =3D sockfd |> int_of_string |> Utils.FD.of_int in + Unix.listen fd 1; + Some fd + in + rwro :=3D get_listen_sock rw + in + let socket_f ~fd =3D + let ufd =3D Utils.FD.of_int fd in + let is_valid =3D try (Unix.fstat ufd).Unix.st_kind =3D Unix.S_SOCK w= ith _ -> 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 =3D + let ndom =3D + 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 =3D + 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 =3D + ignore (Connections.add_watch cons (get_con id) path token) + in + let store_f path perms value =3D + 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 =20 -let from_file store cons doms file =3D - info "Loading xenstore dump from %s" file; - let channel =3D open_in file in - finally (fun () -> from_channel store doms cons channel) - (fun () -> close_in channel) + let from_file store cons doms file =3D + info "Loading xenstore dump from %s" file; + let channel =3D open_in file in + finally (fun () -> from_channel store doms cons channel) + (fun () -> close_in channel) =20 -let to_channel store cons rw chan =3D - let hexify s =3D Utils.hexify s in + let to_channel store cons rw chan =3D + let hexify s =3D Utils.hexify s in =20 - fprintf chan "%s\n" dump_format_header; - let fdopt =3D 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 =3D 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); =20 - (* dump connections related to domains: domid, mfn, eventchn port/ socket= s, and watches *) - Connections.iter cons (fun con -> Connection.dump con chan); + (* dump connections related to domains: domid, mfn, eventchn port/ soc= kets, and watches *) + Connections.iter cons (fun con -> Connection.dump con chan); =20 - (* dump the store *) - Store.dump_fct store (fun path node -> - let name, perms, value =3D Store.Node.unpack node in - let fullpath =3D Store.Path.to_string (Store.Path.of_path_and_name path = name) in - let permstr =3D Perms.Node.to_string perms in - fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexi= fy value) - ); - flush chan; - () + (* dump the store *) + Store.dump_fct store (fun path node -> + let name, perms, value =3D Store.Node.unpack node in + let fullpath =3D Store.Path.to_string (Store.Path.of_path_and_name= path name) in + let permstr =3D Perms.Node.to_string perms in + fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr)= (hexify value) + ); + flush chan; + () =20 =20 -let to_file store cons fds file =3D - let channel =3D open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o6= 00 file in - finally (fun () -> to_channel store cons fds channel) - (fun () -> close_out channel) + let to_file store cons fds file =3D + let channel =3D 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 =20 (* - 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. =20 - 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 <=3D 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 <=3D max_overhead, because compaction is only + triggerred at the end of major GC cycles. =20 - 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). =20 - 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). =20 - 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. =20 - wasted =3D live * space_overhead / 100 + wasted =3D live * space_overhead / 100 =20 - 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. =20 - 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. Howe= ver + 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. =20 - 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 ke= ep - the default allocation policy (next-fit/best-fit depending on version). + The allocation policy could also be tweaked, e.g. first fit would redu= ce + 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). =20 - 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. setti= ng + 'ulimit -v' to 75% of RAM, however getting the kernel to actually retu= rn + 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. *) =20 let tweak_gc () =3D - Gc.set { (Gc.get ()) with Gc.max_overhead =3D !Define.gc_max_overhead } + Gc.set { (Gc.get ()) with Gc.max_overhead =3D !Define.gc_max_overhead } =20 =20 let _ =3D - let cf =3D do_argv in - let pidfile =3D - if Sys.file_exists (config_filename cf) then - parse_config (config_filename cf) - else - default_pidfile - in + let cf =3D do_argv in + let pidfile =3D + if Sys.file_exists (config_filename cf) then + parse_config (config_filename cf) + else + default_pidfile + in =20 - tweak_gc (); + tweak_gc (); =20 - (try - Unixext.mkdir_rec (Filename.dirname pidfile) 0o755 - with _ -> - () - ); + (try + Unixext.mkdir_rec (Filename.dirname pidfile) 0o755 + with _ -> + () + ); =20 - let rw_sock =3D - 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 =3D + if cf.disable_socket || cf.live_reload then + None + else + Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daem= on_socket) + in =20 - 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; =20 - (try Unixext.pidfile_write pidfile with _ -> ()); + (try Unixext.pidfile_write pidfile with _ -> ()); =20 - (* 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; =20 - let store =3D Store.create () in - let eventchn =3D Event.init () in - let next_frequent_ops =3D ref 0. in - let advance_next_frequent_ops () =3D - next_frequent_ops :=3D (Unix.gettimeofday () +. !Define.conflict_max_his= tory_seconds) - in - let delay_next_frequent_ops_by duration =3D - next_frequent_ops :=3D !next_frequent_ops +. duration - in - let domains =3D Domains.init eventchn advance_next_frequent_ops in + let store =3D Store.create () in + let eventchn =3D Event.init () in + let next_frequent_ops =3D ref 0. in + let advance_next_frequent_ops () =3D + next_frequent_ops :=3D (Unix.gettimeofday () +. !Define.conflict_max_h= istory_seconds) + in + let delay_next_frequent_ops_by duration =3D + next_frequent_ops :=3D !next_frequent_ops +. duration + in + let domains =3D Domains.init eventchn advance_next_frequent_ops in =20 - (* For things that need to be done periodically but more often - * than the periodic_ops function *) - let frequent_ops () =3D - if Unix.gettimeofday () > !next_frequent_ops then ( - History.trim (); - Domains.incr_conflict_credit domains; - advance_next_frequent_ops () - ) in - let cons =3D Connections.create () in + (* For things that need to be done periodically but more often + * than the periodic_ops function *) + let frequent_ops () =3D + if Unix.gettimeofday () > !next_frequent_ops then ( + History.trim (); + Domains.incr_conflict_credit domains; + advance_next_frequent_ops () + ) in + let cons =3D Connections.create () in =20 - let quit =3D ref false in + let quit =3D ref false in =20 - Logging.init_xenstored_log(); - List.iter (fun path -> - Store.write store Perms.Connection.full_rights path "") Store.Path.speci= als; + Logging.init_xenstored_log(); + List.iter (fun path -> + Store.write store Perms.Connection.full_rights path "") Store.Path.s= pecials; =20 - let rw_sock =3D - if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( - let rwro =3D 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 =3D + if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( + let rwro =3D 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 + ); =20 - let localpath =3D Store.Path.of_string "/local" in - if not (Store.path_exists store localpath) then - Store.mkdir store (Perms.Connection.create 0) localpath; + let localpath =3D Store.Path.of_string "/local" in + if not (Store.path_exists store localpath) then + Store.mkdir store (Perms.Connection.create 0) localpath; =20 - 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 =20 - (* required for xenstore-control to detect availability of live-update *) - let tool_path =3D 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 =3D 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; =20 - Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler); - Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun _ -> - info "Received SIGTERM"; - quit :=3D true)); - Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun _ -> sigusr1_handler s= tore)); - 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 :=3D true)); + Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun _ -> sigusr1_handler = store)); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; =20 - if cf.activate_access_log then begin - let post_rotate () =3D DB.to_file store cons (None) Disk.xs_daemon_datab= ase in - Logging.init_access_log post_rotate - end; + if cf.activate_access_log then begin + let post_rotate () =3D DB.to_file store cons (None) Disk.xs_daemon_dat= abase in + Logging.init_access_log post_rotate + end; =20 - let spec_fds =3D - (match rw_sock with None -> [] | Some x -> [ x ]) @ - (if cf.domain_init then [ Event.fd eventchn ] else []) - in + let spec_fds =3D + (match rw_sock with None -> [] | Some x -> [ x ]) @ + (if cf.domain_init then [ Event.fd eventchn ] else []) + in =20 - let process_special_fds rset =3D - let accept_connection fd =3D - let (cfd, _addr) =3D Unix.accept fd in - debug "new connection through socket"; - Connections.add_anonymous cons cfd - and handle_eventchn _fd =3D - let port =3D Event.pending eventchn in - debug "pending port %d" (Xeneventchn.to_int port); - finally (fun () -> - if Some port =3D eventchn.Event.virq_port then ( - let (notify, deaddom) =3D 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 =3D 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 =3D - if List.mem fd set then - fct fd in + let process_special_fds rset =3D + let accept_connection fd =3D + let (cfd, _addr) =3D Unix.accept fd in + debug "new connection through socket"; + Connections.add_anonymous cons cfd + and handle_eventchn _fd =3D + let port =3D Event.pending eventchn in + debug "pending port %d" (Xeneventchn.to_int port); + finally (fun () -> + if Some port =3D eventchn.Event.virq_port then ( + let (notify, deaddom) =3D 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 =3D 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 =3D + if List.mem fd set then + fct fd in =20 - 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 =20 - let ring_scan_checker dom =3D - (* 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 =3D 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 =3D 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 =3D + (* 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 =3D 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 =3D 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 =20 - let last_stat_time =3D ref 0. in - let last_scan_time =3D ref 0. in + let last_stat_time =3D ref 0. in + let last_scan_time =3D ref 0. in =20 - let periodic_ops now =3D - debug "periodic_ops starting"; + let periodic_ops now =3D + debug "periodic_ops starting"; =20 - (* scan all the xs rings as a safenet for ill-behaved clients *) - if !ring_scan_interval >=3D 0 && now > (!last_scan_time +. float !ring_s= can_interval) then - (last_scan_time :=3D now; Domains.iter domains ring_scan_checker); + (* scan all the xs rings as a safenet for ill-behaved clients *) + if !ring_scan_interval >=3D 0 && now > (!last_scan_time +. float !ring= _scan_interval) then + (last_scan_time :=3D now; Domains.iter domains ring_scan_checker); =20 - (* 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 -. !la= st_stat_time); - last_stat_time :=3D 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 :=3D 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 (); =20 - let gc =3D Gc.stat () in - let (lanon, lanon_ops, lanon_watchs, - ldom, ldom_ops, ldom_watchs) =3D Connections.stats cons in - let store_nodes, store_abort, store_coalesce =3D Store.stats store in - let symtbl_len, symtbl_entries =3D Symbol.stats () in + let gc =3D Gc.stat () in + let (lanon, lanon_ops, lanon_watchs, + ldom, ldom_ops, ldom_watchs) =3D Connections.stats cons in + let store_nodes, store_abort, store_coalesce =3D Store.stats store in + let symtbl_len, symtbl_entries =3D Symbol.stats () in =20 - 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 =3D 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 =3D 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 =20 - let period_ops_interval =3D 15. in - let period_start =3D ref 0. in + let period_ops_interval =3D 15. in + let period_start =3D ref 0. in =20 - let main_loop () =3D - let is_peaceful c =3D - match Connection.get_domain c with - | None -> true (* Treat socket-connections as exempt, and free to confl= ict. *) - | Some dom -> not (Domain.is_paused_for_conflict dom) - in - frequent_ops (); - let mw =3D Connections.has_more_work cons in - let peaceful_mw =3D 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 =3D Unix.gettimeofday () in - let timeout =3D - let until_next_activity =3D - if Domains.all_at_max_credit domains - then period_ops_interval - else min (max 0. (!next_frequent_ops -. start_time)) period_ops_interv= al in - if peaceful_mw <> [] then 0. else until_next_activity - in - let inset, outset =3D Connections.select ~only_if:is_peaceful cons in - let rset, wset, _ =3D - try - Poll.poll_select (spec_fds @ inset) outset [] timeout - with Unix.Unix_error(Unix.EINTR, _, _) -> - [], [], [] in - let sfds, cfds =3D - List.partition (fun fd -> List.mem fd spec_fds) rset in - if List.length sfds > 0 then - process_special_fds sfds; + let main_loop () =3D + let is_peaceful c =3D + match Connection.get_domain c with + | None -> true (* Treat socket-connections as exempt, and free to co= nflict. *) + | Some dom -> not (Domain.is_paused_for_conflict dom) + in + frequent_ops (); + let mw =3D Connections.has_more_work cons in + let peaceful_mw =3D 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 =3D Unix.gettimeofday () in + let timeout =3D + let until_next_activity =3D + if Domains.all_at_max_credit domains + then period_ops_interval + else min (max 0. (!next_frequent_ops -. start_time)) period_ops_in= terval in + if peaceful_mw <> [] then 0. else until_next_activity + in + let inset, outset =3D Connections.select ~only_if:is_peaceful cons in + let rset, wset, _ =3D + try + Poll.poll_select (spec_fds @ inset) outset [] timeout + with Unix.Unix_error(Unix.EINTR, _, _) -> + [], [], [] in + let sfds, cfds =3D + List.partition (fun fd -> List.mem fd spec_fds) rset in + if List.length sfds > 0 then + process_special_fds sfds; =20 - if List.length cfds > 0 || List.length wset > 0 then - process_connection_fds store cons domains cfds wset; - if timeout <> 0. then ( - let now =3D Unix.gettimeofday () in - if now > !period_start +. period_ops_interval then - (period_start :=3D 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 =3D Unix.gettimeofday () in + if now > !period_start +. period_ops_interval then + (period_start :=3D now; periodic_ops now) + ); =20 - process_domains store cons domains - in + process_domains store cons domains + in =20 - Systemd.sd_notify_ready (); - let live_update =3D ref false in - while not (!quit && Connections.prevents_quit cons =3D []) - do - try - main_loop (); - live_update :=3D 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 :=3D true; - end - with exc -> - let bt =3D 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 =3D ref false in + while not (!quit && Connections.prevents_quit cons =3D []) + do + try + main_loop (); + live_update :=3D 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 :=3D true; + end + with exc -> + let bt =3D 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 | Non= e -> ()); =20 - 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 --=20 2.34.1