From patchwork Tue Nov 8 15:33:53 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036474 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id F3CE8C433FE for ; Tue, 8 Nov 2022 15:34:56 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440121.694202 (Exim 4.92) (envelope-from ) id 1osQce-0002Cs-7C; Tue, 08 Nov 2022 15:34:44 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440121.694202; Tue, 08 Nov 2022 15:34:44 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQce-0002Ch-4N; Tue, 08 Nov 2022 15:34:44 +0000 Received: by outflank-mailman (input) for mailman id 440121; Tue, 08 Nov 2022 15:34:42 +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 1osQcc-0001RY-J7 for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:42 +0000 Received: from esa6.hc3370-68.iphmx.com (esa6.hc3370-68.iphmx.com [216.71.155.175]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id daa98f32-5f7a-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:34:39 +0100 (CET) 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: daa98f32-5f7a-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921679; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=rQjCOry0zbEmn2oC12Zes+ysVPjXqsmur55tzbE8yXw=; b=YRfbrNHcw+YM8eG8ORyAI8w5qtpFTzyBl5mgX1XZIa0mue6NUQAKTIZ1 OcPfeE247AlKxiDQ/vMms8lCKg7Gh5SLUMj63KbYNfh8qw9kqwT/kWvhb LKrciB92PQOc16SyiTPU8I4M8gSEbh0E57cBGYiwvv0Aux1Vx5B90XiW6 w=; Authentication-Results: esa6.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 83996668 X-Ironport-Server: esa6.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:CHeWQq3HnZYAnLfe4/bD5d9xkn2cJEfYwER7XKvMYLTBsI5bpz1Vy 2JJUWDVOPjZMWDzeNhxaoi+909VvpGDzYI3GVY/pC1hF35El5HIVI+TRqvS04F+DeWYFR46s J9OAjXkBJppJpMJjk71atANlVEliefTAOK5ULSfUsxIbVcMYD87jh5+kPIOjIdtgNyoayuAo tq3qMDEULOf82cc3lk8tuTS9nuDgNyo4GlC5wVmNagR1LPjvyJ94Kw3dPnZw0TQGuG4LsbiL 87fwbew+H/u/htFIrtJRZ6iLyXm6paLVeS/oiI+t5qK23CulQRrukoPD9IOaF8/ttm8t4sZJ OOhF3CHYVxB0qXkwIzxWvTDes10FfUuFLTveRBTvSEPpqFvnrSFL/hGVSkL0YMkFulfBFlU3 /BIDDA3RTOSmv3r8pK+Fc8viZF2RCXrFNt3VnBIyDjYCbAtQIzZQrWM7thdtNsyrpkQR7CEP ZNfMGcxKkSbC/FMEg5/5JYWkeu2h3+5bzpCr1G9rqsr+WnDigd21dABNfKFIY3bG5sLzi50o EqZ/Tn5IDsgF+Wc7meO81+ng7HktgT0Ddd6+LqQqacx3Qz7KnYoIBEfS1aTu/SyjU+6HdVFJ CQ85S4GvaU0skuxQbHVTxC+5XKJoBMYc95RCPEhrhGAzLLO5ASUDXRCSSROAPQGucksVHoV3 1mGt9rzAHpkt7j9dJ6G3u7K93XoY3FTdDJcI39fJecY3zX9iIQLlDjDHvJjKoWWn8DqRAPQx m+s7ydr0t3/kvU3/6m8+FnGhRelqZ7IUhM5623rY4610u9qTNX7PtL1sDA3+d4Fdd/EFQfZ4 BDojuDEtIgz4YexeDthqQnnNJWg/L67PTLVmjaD9LFxpm32qxZPkW29iQySxXuF0O5eJ1cFg 2eJ42u9AaO/21P7BZKbm6rrV6wXIVHITLwIlpn8N7KimKRZeg6d5z1JbkWNxW3rm0VEufhhZ 8jLLZj1VS5AV/QPIN+KqwA1iOFD+8zD7TmLGcCTI+qPjdJym0J5uZ9aaQDTP4jVHYuPoRnP8 sY3Cid540w3bQA/CwGJmbMuwacidClmWsqt8JQHL4Zu4GNOQQkcNhMY+pt5E6QNokifvr6gE q2VMqOA9GfCuA== IronPort-HdrOrdr: A9a23:9j1UrKpBo47eN31NWZln3Y0aV5oReYIsimQD101hICG8cqSj9v xG+85rrSMc6QxhIU3I9urwW5VoLUmyyXcx2/h0AV7AZniBhILLFvAB0WKK+VSJcEeSmtK1l5 0QFJSWYOeAdmSS5vyb3ODXKbgdKaG8gcWVuds= X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="83996668" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 01/15] tools/ocaml/libs/eventchn: do not leak event channels and OCaml 5.0 compat Date: Tue, 8 Nov 2022 15:33:53 +0000 Message-ID: X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 Add a finalizer on the event channel value, so that it calls `xenevtchn_close` when the value would be GCed. In practice oxenstored seems to be the only user of this, and it creates a single global event channel only, but freeing this could still be useful when run with OCAMLRUNPARAM=c The code was previously casting a C pointer to an OCaml value, which should be avoided: OCaml 5.0 won't support it. (all "naked" C pointers must be wrapped inside an OCaml value, either an Abstract tag, or Nativeint, see the manual https://ocaml.org/manual/intfc.html#ss:c-outside-head) Signed-off-by: Edwin Török Acked-by: Christian Lindig --- Reason for inclusion in 4.17: - Fixes a runtime bug with upcoming OCaml 5.0 (already in beta) Changes since v2: - added Acked-by line - add 4.17 reason --- tools/ocaml/libs/eventchn/xeneventchn_stubs.c | 29 +++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/tools/ocaml/libs/eventchn/xeneventchn_stubs.c b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c index f889a7a2e4..67af116377 100644 --- a/tools/ocaml/libs/eventchn/xeneventchn_stubs.c +++ b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c @@ -33,7 +33,30 @@ #include #include -#define _H(__h) ((xenevtchn_handle *)(__h)) +/* We want to close the event channel when it is no longer in use, + which can only be done safely with a finalizer. + Event channels are typically long lived, so we don't need tighter control over resource deallocation. + Use a custom block +*/ + +/* Access the xenevtchn_t* part of the OCaml custom block */ +#define _H(__h) (*((xenevtchn_handle**)Data_custom_val(__h))) + +static void stub_evtchn_finalize(value v) +{ + /* docs say to not use any CAMLparam* macros here */ + xenevtchn_close(_H(v)); +} + +static struct custom_operations xenevtchn_ops = { + "xenevtchn", + stub_evtchn_finalize, + custom_compare_default, /* raises Failure, cannot compare */ + custom_hash_default, /* ignored */ + custom_serialize_default, /* raises Failure, can't serialize */ + custom_deserialize_default, /* raises Failure, can't deserialize */ + custom_compare_ext_default /* raises Failure */ +}; CAMLprim value stub_eventchn_init(void) { @@ -48,7 +71,9 @@ CAMLprim value stub_eventchn_init(void) if (xce == NULL) caml_failwith("open failed"); - result = (value)xce; + /* contains file descriptors, trigger full GC at least every 128 allocations */ + result = caml_alloc_custom(&xenevtchn_ops, sizeof(xce), 0, 1); + _H(result) = xce; CAMLreturn(result); } From patchwork Tue Nov 8 15:33:54 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036476 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 2E02CC4321E for ; Tue, 8 Nov 2022 15:34:57 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440124.694223 (Exim 4.92) (envelope-from ) id 1osQch-0002hS-EC; Tue, 08 Nov 2022 15:34:47 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440124.694223; Tue, 08 Nov 2022 15:34:47 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQch-0002gc-8p; Tue, 08 Nov 2022 15:34:47 +0000 Received: by outflank-mailman (input) for mailman id 440124; Tue, 08 Nov 2022 15:34:45 +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 1osQcf-0001RY-UK for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:45 +0000 Received: from esa6.hc3370-68.iphmx.com (esa6.hc3370-68.iphmx.com [216.71.155.175]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id dea3d7d7-5f7a-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:34:44 +0100 (CET) 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: dea3d7d7-5f7a-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921684; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=15Hgb+sdjhnccr4MqijiUOJ5Qs+Ch7oxO+EvADCJqio=; b=WRHD33tLaxdZpcMyw14p5Y07FIyljOBgqRa+zRGCsf5WGPeYiVR3OxiY J0LxnKadRNLGztmi9VCKkD3djdr2mTQLk1173EALzs2comeZh4y5Gx5wi fq+OhBRpZAvSDVx8fkzJsjvJsNodUG70b9c5qG+0RacwmPYgt9XwUANPZ M=; Authentication-Results: esa6.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 83996682 X-Ironport-Server: esa6.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:mkHlkaMkoFRuu6PvrR2pl8FynXyQoLVcMsEvi/4bfWQNrUoj0mBRz GsXCDuHM/6OYDejc493b4i09h4C7J+BzN5nSAto+SlhQUwRpJueD7x1DKtS0wC6dZSfER09v 63yTvGacajYm1eF/k/F3oDJ9CU6jufQA+KmU4YoAwgpLSd8UiAtlBl/rOAwh49skLCRDhiE/ Nj/uKUzAnf8s9JPGj9SuvzrRC9H5qyo4mpB5gxmP5ingXeF/5UrJMNHTU2OByOQrrl8RoaSW +vFxbelyWLVlz9F5gSNy+uTnuUiG9Y+DCDW4pZkc/HKbitq/0Te5p0TJvsEAXq7vh3S9zxHJ HehgrTrIeshFvWkdO3wyHC0GQkmVUFN0OevzXRSLaV/ZqAJGpfh66wGMa04AWEX0s9RAEVl+ eIjEi8qQTOd2+Tr2+uwUuY506zPLOGzVG8eknRpzDWfBvc6W5HTBa7N4Le03h9p2JoIR6yHI ZNEN3w/N3wsYDUWUrsTIJ8yguauwGX4aTpbgFmUubA28y7YywkZPL3FYIGEK4LUFZ89ckCwp HDeoG6oEw0mE92t5DuZ9Wy3h9HRtHauMG4VPOLhraM76LGJ/UQMDDUGWF39puO24mauVtQaJ 0EK9y4Gqakp6FftXtT7Rwe/onOPolgbQdU4O8037hucjJXd5QmxD3IBCDVGbbQOuMYoSBQw2 1SOntevAiZg2IB5UlrEqO3S92nrf3FIcylSPkfoUDfp/fHKhoAXpR7Rdex8N4GWkIHzRCqpy CiF+X1Wa6ooseYH0KCy/Fbiij2qp4TUQgNd2jg7Tl5J/SsiOtf7OtXABUzzqK8Zcd3HFgXpU G0swZD20QwYMX2aeMVhqs0pFarh2fuKOSa0bbVHT8h4rGTFF5JOkOltDNBCyKVBaJhsldzBO hW7VeZtCHh7bROXgVdfOd7ZNijT5fGI+BSMfqm8giBySpZwbhSb2ypleFSd2Wvg+GB1z/9ga cvFKJ70VyhKYUiC8NZRb75DuYLHOwhknT+DLXwF50jPPUWiiI69Fu5ebQrmghER56KYugTFm +uzxOPToyiykYTWPEHqzGLkBQlbcCdhXsuu+5U/myzqClMOJVzNwsT5mdsJE7GJVYwO/gsU1 hlRgnNl9Wc= IronPort-HdrOrdr: A9a23:4uIkDaiJIUIvYGmCAsI09W+H7XBQXuIji2hC6mlwRA09TySZ// rBoB19726MtN9xYgBHpTnuAsm9qB/nmaKdpLNhWItKPzOW31dATrsSjrcKqgeIc0aVm9K1l5 0QF5SWYOeAdWSS5vya3ODXKbkdKaG8gcKVuds= X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="83996682" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 02/15] tools/ocaml/libs/xc: OCaml 5.0 compatibility Date: Tue, 8 Nov 2022 15:33:54 +0000 Message-ID: X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 Follow the manual to avoid naked pointers: https://v2.ocaml.org/manual/intfc.html#ss:c-outside-head No functional change, except on OCaml 5.0 where it is a bugfix. Signed-off-by: Edwin Török Acked-by: Christian Lindig --- Reason for inclusion in 4.17: - bugfix for upcoming OCaml 5.0 compiler (already in beta) Changes since v2: - add Acked-by line --- tools/ocaml/libs/mmap/mmap_stubs.h | 5 +++++ tools/ocaml/libs/xc/xenctrl_stubs.c | 11 ++++++----- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/mmap_stubs.h index 65e4239890..5c65cc86fb 100644 --- a/tools/ocaml/libs/mmap/mmap_stubs.h +++ b/tools/ocaml/libs/mmap/mmap_stubs.h @@ -30,4 +30,9 @@ struct mmap_interface int len; }; +/* for compatibility with OCaml 4.02.3 */ +#ifndef Data_abstract_val +#define Data_abstract_val(v) ((void*) Op_val(v)) +#endif + #endif diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c b/tools/ocaml/libs/xc/xenctrl_stubs.c index a8789d19be..8cd11060ec 100644 --- a/tools/ocaml/libs/xc/xenctrl_stubs.c +++ b/tools/ocaml/libs/xc/xenctrl_stubs.c @@ -37,7 +37,7 @@ #include "mmap_stubs.h" -#define _H(__h) ((xc_interface *)(__h)) +#define _H(__h) *((xc_interface **) Data_abstract_val(__h)) #define _D(__d) ((uint32_t)Int_val(__d)) #ifndef Val_none @@ -70,14 +70,15 @@ static void Noreturn failwith_xc(xc_interface *xch) CAMLprim value stub_xc_interface_open(void) { CAMLparam0(); - xc_interface *xch; + CAMLlocal1(result); + result = caml_alloc(1, Abstract_tag); /* Don't assert XC_OPENFLAG_NON_REENTRANT because these bindings * do not prevent re-entrancy to libxc */ - xch = xc_interface_open(NULL, NULL, 0); - if (xch == NULL) + _H(result) = xc_interface_open(NULL, NULL, 0); + if (_H(result) == NULL) failwith_xc(NULL); - CAMLreturn((value)xch); + CAMLreturn(result); } From patchwork Tue Nov 8 15:33:55 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036473 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id D4DE5C4332F for ; Tue, 8 Nov 2022 15:34:56 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440119.694175 (Exim 4.92) (envelope-from ) id 1osQcb-0001aL-My; Tue, 08 Nov 2022 15:34:41 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440119.694175; Tue, 08 Nov 2022 15:34:41 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQcb-0001Zh-J7; Tue, 08 Nov 2022 15:34:41 +0000 Received: by outflank-mailman (input) for mailman id 440119; Tue, 08 Nov 2022 15:34:40 +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 1osQca-0001RY-IV for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:40 +0000 Received: from esa5.hc3370-68.iphmx.com (esa5.hc3370-68.iphmx.com [216.71.155.168]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id da2c792b-5f7a-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:34:39 +0100 (CET) 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: da2c792b-5f7a-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921678; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=g06Eyz8tqCWbarSPvXlT2vv3bAoXEM2vFz5TwhOXiT8=; b=V6rsC8faRbzMWxDU4t08CXyvH+xfOY7TZgrdBaGzP88HjR+SDjBDZm3g GVC3gXjiy96p/coA4+sIIx2YTdk2xfo97jT32lYbgV3X6h4BQYTC8ywc6 ArhZrsgenBrzueWFKFfaBSBw1CtMVbsGBP7/LbH+zV0olfzWVFPgiIvNv 8=; Authentication-Results: esa5.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 83477663 X-Ironport-Server: esa5.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:MuhKVqrukL7MHgKzhD7rzePyu/NeBmIUZRIvgKrLsJaIsI4StFCzt garIBmAb/uLYjChf4pyYIy+/B4D7cfdmIUxHAE5rig8RS1DpJuZCYyVIHmrMnLJJKUvbq7FA +Y2MYCccZ9uHhcwgj/3b9ANeFEljfngqoLUUbKCYWYpAFc+E0/NsDo788YhmIlknNOlNA2Ev NL2sqX3NUSsnjV5KQr40YrawP9UlKm06W1wUmAWP6gR5gaHzylNVvrzGInqR5fGatgMdgKFb 76rIIGRpgvx4xorA9W5pbf3GmVirmn6ZFXmZtJ+AsBOszAazsAA+v9T2Mk0MC+7vw6hjdFpo OihgLTrIesf0g8gr8xGO/VQO3kW0aSrY9YrK1Dn2SCY5xWun3cBX5yCpaz5VGEV0r8fPI1Ay RAXABEcfjatmtOT+rnhcuJh3poZLPbVGYxK7xmMzRmBZRonaZXKQqGM7t5ExjYgwMtJGJ4yZ eJAN2ApNk6ZJUQSZBFHU/rSn8/x7pX7WzBUtlOT47Yw+W/Q5AdwzKLsIJzefdniqcB9zh3E+ T2YoT+R7hcyM9C25RjC/lWXxerVsC34fqxCP5vo6as/6LGU7jNKU0BHPbehmtGmjmauVtQZL FYbkgI+oK53+EG1Q93VWxyjvGXCrhMaQ8BXEeAx9EeK0KW8yyaUAHIVCAFIbtMOvdUzAzct0 zehk9r3CBR1vbaSSHbb8a2bxQ5eIgBMczVEP3VdC1JYvZ+z++nfky4jUP5CAb6ToMDEPAv7m QiBoXBgvbUss+sEgvDTEU/8vxqgoZ3ATwgQ7wrRX3644g4RWLNJd7BE+nCAs68ecd/xok2p+ SFdxpPAtLxm4YSlznTlfQkbIF2+Cx9p2hX4iEUnIZQu/i/FF5WLLdEJu2EWyKuE3685ld7Vj K374105CHx7ZiHCgUpLj2WZWqwXIVDIT4iNaxwtRoMmj1gYXFbvENtSTUCRxXvxt0MnjLsyP 5yWGe71UyhFWfg5lWLuHblNuVPO+szZ7TqNLa0XMjz9iebODJJrYett3KSyghARs/rf/VS9H yd3PMqW0RRPONASkQGOmbP+7DkicxAGOHwBg5UGK7HZeVE+SDhJ5j246epJRrGJVp99zo/gl kxRkGcCoLYjrRUr8Tm3V00= IronPort-HdrOrdr: A9a23:D8IkaqhnYTzWd6p5H/GM+qTIpHBQXuIji2hC6mlwRA09TySZ// rBoB19726MtN9xYgBHpTnuAsm9qB/nmaKdpLNhWItKPzOW31dATrsSjrcKqgeIc0aVm9K1l5 0QF5SWYOeAdWSS5vya3ODXKbkdKaG8gcKVuds= X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="83477663" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 03/15] tools/ocaml/libs/{xb, mmap}: use Data_abstract_val wrapper Date: Tue, 8 Nov 2022 15:33:55 +0000 Message-ID: <6d9e337ef6bfd7540ae5a0d6b4b1b73fd5e84b16.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 This is not strictly necessary since it is essentially a no-op currently: a cast to void* and value*, even in OCaml 5.0. However it does make it clearer that what we have here is not a regular OCaml value, but one allocated with Abstract_tag or Custom_tag, and follows the example from the manual more closely: https://v2.ocaml.org/manual/intfc.html#ss:c-outside-head It also makes it clearer that these modules have been reviewed for compat with OCaml 5.0. No functional change. Signed-off-by: Edwin Török Acked-by: Christian Lindig --- Reason for inclusion in 4.17: - make code follow best practice for upcoming OCaml 5.0 compiler (already in beta) Changes since v2: - add Acked-by line --- tools/ocaml/libs/mmap/xenmmap_stubs.c | 2 +- tools/ocaml/libs/xb/xs_ring_stubs.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c b/tools/ocaml/libs/mmap/xenmmap_stubs.c index e2ce088e25..141dedb78c 100644 --- a/tools/ocaml/libs/mmap/xenmmap_stubs.c +++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c @@ -28,7 +28,7 @@ #include #include -#define Intf_val(a) ((struct mmap_interface *) a) +#define Intf_val(a) ((struct mmap_interface *) Data_abstract_val(a)) static int mmap_interface_init(struct mmap_interface *intf, int fd, int pflag, int mflag, diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_ring_stubs.c index 7a91fdee75..cc9114029f 100644 --- a/tools/ocaml/libs/xb/xs_ring_stubs.c +++ b/tools/ocaml/libs/xb/xs_ring_stubs.c @@ -35,7 +35,7 @@ #include #include "mmap_stubs.h" -#define GET_C_STRUCT(a) ((struct mmap_interface *) a) +#define GET_C_STRUCT(a) ((struct mmap_interface *) Data_abstract_val(a)) /* * Bytes_val has been introduced by Ocaml 4.06.1. So define our own version From patchwork Tue Nov 8 15:33:56 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036472 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 4EA9DC43219 for ; Tue, 8 Nov 2022 15:34:55 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440120.694192 (Exim 4.92) (envelope-from ) id 1osQcd-0001wz-1u; Tue, 08 Nov 2022 15:34:43 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440120.694192; Tue, 08 Nov 2022 15:34:42 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQcc-0001wo-S4; Tue, 08 Nov 2022 15:34:42 +0000 Received: by outflank-mailman (input) for mailman id 440120; Tue, 08 Nov 2022 15:34:41 +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 1osQcb-0001RY-Im for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:41 +0000 Received: from esa1.hc3370-68.iphmx.com (esa1.hc3370-68.iphmx.com [216.71.145.142]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id db8e61fb-5f7a-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:34:39 +0100 (CET) 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: db8e61fb-5f7a-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921679; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=pDZRvWvsQxrzElkdZ92H76eH11jyJymBHtOb1jyOElc=; b=AwzhyVmwrh+xJ/s558SZMuTamdfqoH3pR+82m5jC4nGvwqjb0eRP6EYy atPRCUxlWLMXmcjMjAkkzOWgK+eYdmMZVkhnSm1G4j2AiA//AkkTmqwuK 3wqFBS+AxK1Kd4B22/LefVuSztHqoNpxUPccLec4z/SRmO09auQkj/ZiP E=; Authentication-Results: esa1.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 84828530 X-Ironport-Server: esa1.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:N9NzlqhGNLRZr61w5N2t2kM2X161bBAKZh0ujC45NGQN5FlHY01je htvWTqFMvyOamX3c91yb97j8U8F68XUytFgQAZrqilhQiIb9cadCdqndUqhZCn6wu8v7q5Ex 55HNoSfdpBcolv0/ErF3m3J9CEkvU2wbuOgTrWCYmUpH1QMpB4J0XpLg/Q+jpNjne+3CgaMv cKai8DEMRqu1iUc3lg8sspvkzsy+qWs0N8klgZmP6oS5QeOzyN94K83fsldEVOpGuG4IcbiL wrz5OnR1n/U+R4rFuSknt7TGqHdauePVeQmoiM+t5mK2nCulARrukoIHKN0hXNsoyeIh7hMJ OBl7vRcf+uL0prkw4zxWzEAe8130DYvFLXveRBTuuTLp6HKnueFL1yDwyjaMKVBktubD12i+ tRDAy8IVQGCwNu147SRV+x2n545d5HkadZ3VnFIlVk1DN4jSJHHBa7L+cVZzHE7gcUm8fT2P pRDL2A1NVKZPkMJagx/5JEWxY9EglHyfyNZrhSJorAw4EDYzRBr0airO93QEjCPbZUJzhzI+ zmel4j/Khc4LvjDyxeHzlCHhbD2szj6Q6wCLqLto5aGh3XMnzdOWXX6T2CTrfCnh2akVtlYK khS/TAhxYAt8GS7Q9+7WAe3yFaUsxhZV9dOHukS7ACW1rGS8wufHnIDTDNKdJohrsBebRwn0 EWY2ezgAzNHuaeQD3ma89+pQSiaYHZPazVYPGldEFVDs4KLTJwPYgznFf18FZWkj5rMGhL26 S2PtjFkne5Lgptev0mkxmzvjzWpr5nPawc64ATLQ26ohj9EiJ6Zi5+AsgaCs6sZRGqNZhzY5 SVfxZDChAwbJcvV/BFhVtnhC11ACxytFDTHyWBiEJA6n9hG0y7yJNsAiN2SyaoADyrlRdMLS BWN0e+yzMUJVJdPUUOQS9PZNijS5fK8fekJr9iNBjeOC7AoHON9wAlgZFSLw0fmm1U2nKc0N P+zKJjyUiZGV/0/lGDoF4/xNIPHIQhnmwvuqW3TlUz7gdJymlbJIVv6DLd+Rr9gt/7VyOkk2 91eK9GL231ivB7WO0HqHE96BQ5iEEXX8riv+pEILLXYelo/cIzjYteIqY4cl0Vet/w9vo/1E ruVASe0FHKXaaX7FDi3 IronPort-HdrOrdr: A9a23:hPv71KumwRaMD36XMnDJhnwK7skDTNV00zEX/kB9WHVpmszxra GTdZMgpGfJYVcqKQgdcL+7Scq9qB/nmqKdpLNhWYtKPzOW3ldATrsSj7cKqgeIc0aVm4JgPO VbAs9D4bXLfCNHZK3BgDVQfexP/DD+ytHMudvj X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="84828530" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 04/15] tools/ocaml/xenstored/Makefile: use ocamldep -sort for linking order Date: Tue, 8 Nov 2022 15:33:56 +0000 Message-ID: <2acb17a3046dad442ef0e14c84c7aa5930e69e93.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 A better solution is being worked on for master, but for now use ocamldep -sort instead of a manually established link order. The manually established link order will be wrong when (security) patches introduce new dependencies between files that would require changing the link order. If dune was used as a build system this wouldn't be a problem, but we can't use Dune yet due to OSSTest, which is stuck on Debian oldstable. No functional change. Signed-off-by: Edwin Török Signed-off-by: Edwin Török > Acked-by: Christian Lindig > --- Reason for inclusion in 4.17: Avoids having to put this patch as a prerequisite into a security update. Earlier versions of XSA-326 needed this, and although latest version didn't we don't know whether it might be needed again in the future or not. Changes since v2: - new in v3 (was previously emailed to security team though) --- tools/ocaml/xenstored/Makefile | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile index 6f7333926e..e8aaecf2e6 100644 --- a/tools/ocaml/xenstored/Makefile +++ b/tools/ocaml/xenstored/Makefile @@ -72,7 +72,11 @@ XENSTOREDLIBS = \ PROGRAMS = oxenstored oxenstored_LIBS = $(XENSTOREDLIBS) -oxenstored_OBJS = $(OBJS) +# use ocamldep to figure out link order, otherwise the Makefile would have +# to be continously adjusted for security patches that introduce new +# dependencies between files +oxenstored_MLSORTED = $(shell $(OCAMLDEP) -sort $(OBJS:=.ml)) +oxenstored_OBJS = $(oxenstored_MLSORTED:.ml=) OCAML_PROGRAM = oxenstored From patchwork Tue Nov 8 15:33:57 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036475 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id BB822C4167D for ; Tue, 8 Nov 2022 15:34:57 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440123.694218 (Exim 4.92) (envelope-from ) id 1osQch-0002ae-2G; Tue, 08 Nov 2022 15:34:47 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440123.694218; Tue, 08 Nov 2022 15:34:46 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQcg-0002Z6-Pr; Tue, 08 Nov 2022 15:34:46 +0000 Received: by outflank-mailman (input) for mailman id 440123; Tue, 08 Nov 2022 15:34:45 +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 1osQcf-0001RY-DW for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:45 +0000 Received: from esa1.hc3370-68.iphmx.com (esa1.hc3370-68.iphmx.com [216.71.145.142]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id de6dd23c-5f7a-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:34:44 +0100 (CET) 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: de6dd23c-5f7a-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921684; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=hFwOQ0qz0r8WVELNrCnoJk/t1j0zykfo+WnLiqOMwyw=; b=Klv7V+3Qx1XW93rPVSgJcUaA/Xe61wt0hWQx9Q/r3aX4oYHUle/odHJb pMYtfKjIsXIPtI5niHf5Oiug7UA29hUXm1ilFln2HCMDBUfMJ/F/uePxG qMpSYVT45XWHZcQmpI7MnAxSEKT10WNG1JwcaouU+MdV3WnhjMbSTFYl0 Q=; Authentication-Results: esa1.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 84828538 X-Ironport-Server: esa1.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:6JTXyKJ3uP2D3kF3FE+R3ZUlxSXFcZb7ZxGr2PjKsXjdYENSgTBSz TEdUG+Oa62IM2qgfdglPd++8xsAu5+Dn4BkHQZlqX01Q3x08seUXt7xwmUcnc+xBpaaEB84t ZV2hv3odp1coqr0/0/1WlTZhSAgk/rOHv+kUrWs1hlZHWdMUD0mhQ9oh9k3i4tphcnRKw6Ws Jb5rta31GWNglaYCUpJrfPdwP9TlK6q4mlB5wRuPaojUGL2zBH5MrpOfcldEFOgKmVkNrbSb /rOyri/4lTY838FYj9yuu+mGqGiaue60Tmm0hK6aYD76vRxjnVaPpIAHOgdcS9qZwChxLid/ jnvWauYEm/FNoWU8AgUvoIx/ytWZcWq85efSZSzXFD6I+QrvBIAzt03ZHzaM7H09c4qMFpn/ 9YhJQkPVR6c2L+Jmp6cG9Nz05FLwMnDZOvzu1llxDDdS/0nXYrCU+PB4towMDUY354UW6yEP oxANGQpPE+ojx5nYz/7DLozkPmpgD/jdCdfq3qepLYt4niVxwt0uFToGIqJKobaGJ4F9qqej iXv03mmLEgcD8KS72a361n1utDKmgquDer+E5Xnr6U30TV/3Fc7Fxk+RVa95/6jhSaWS99Zb kAZ5Ccqhawz71CwCMnwWQWip3yJtQJaXMBfe8Ua5QeX2+zr6gCWLmEeS3hKb9lOnMM/WzECz FKCmNLtQzt1v9WopWm1r+nO62noYG5McDFENXRsoRY5D8fL/bAIpxjld9taEpW7kYKoJmvc5 GGws31r71kMtvIj26K+9FHBpjujoJnVUwI4jjnqsnKZAhBRP9D8OdHxgbTPxbMZddvCEAHd1 JQRs5LGhN3iG61hg8BkrA8lOLiyr8iIPzTH6bKEN8lwrm/9k5JPkG053d2fGKuLGpxaEdMKS BWJ0e+02HO0FCrCUEOPS9jtY/nGNIC5fTklP9iNBja0XrB/dRWc4AZlblOK0mbmnSAEyP9hZ sfHL5/0VSxEWcyLKQZaoM9Ej9cWKt0WnzuPFfgXMTz7uVZhWJJlYehcawbfBgzIxKiFvB/U4 75i2ziikn1ivSyXSne/zLP/2nhTfCVkX8ut85wOHgNBSyI/cFwc5zbq6etJU+RYc259zI8kI lnVtpdk9WfC IronPort-HdrOrdr: A9a23:fp48/6sAKgVmYzN+f0e2iV/A7skDTtV00zEX/kB9WHVpmszxra 6TdZMgpGbJYVcqKRcdcL+7WJVoLUmxyXcx2/h1AV7AZniAhILLFvAA0WKK+VSJcEeSygce79 YFT0EXMqyJMbEQt6fHCWeDfOrIuOP3kpyVuQ== X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="84828538" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 05/15] tools/ocaml/Makefile.rules: do not run ocamldep on distclean Date: Tue, 8 Nov 2022 15:33:57 +0000 Message-ID: <62e88f2badd7bb3cfb709254258dc6af40c87a45.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 Fixes: 2f2b76d47c5bcd9 ("tools/ocaml: do not run ocamldep during make clean") Signed-off-by: Edwin Török Signed-off-by: Edwin Török > Acked-by: Christian Lindig > --- Reason for inclusion in 4.17: - addresses review comments received post commit Changes since v2: - add Fixes line - add 4.17 reason --- tools/ocaml/Makefile.rules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules index 0d3c6ac839..e0b9de34e4 100644 --- a/tools/ocaml/Makefile.rules +++ b/tools/ocaml/Makefile.rules @@ -44,7 +44,7 @@ META: META.in ALL_OCAML_OBJ_SOURCES=$(addsuffix .ml, $(ALL_OCAML_OBJS)) -ifneq ($(MAKECMDGOALS),clean) +ifeq (,$(findstring clean,$(MAKECMDGOALS))) .ocamldep.make: $(ALL_OCAML_OBJ_SOURCES) Makefile $(OCAML_TOPLEVEL)/Makefile.rules $(call quiet-command, $(OCAMLDEP) $(ALL_OCAML_OBJ_SOURCES) *.mli $o,MLDEP,) endif From patchwork Tue Nov 8 15:33:58 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036471 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 08CA2C43217 for ; Tue, 8 Nov 2022 15:34:55 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440118.694169 (Exim 4.92) (envelope-from ) id 1osQcb-0001Rq-7w; Tue, 08 Nov 2022 15:34:41 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440118.694169; Tue, 08 Nov 2022 15:34:41 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQcb-0001Rj-4i; Tue, 08 Nov 2022 15:34:41 +0000 Received: by outflank-mailman (input) for mailman id 440118; Tue, 08 Nov 2022 15:34:39 +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 1osQcZ-0001RY-RG for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:39 +0000 Received: from esa1.hc3370-68.iphmx.com (esa1.hc3370-68.iphmx.com [216.71.145.142]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id d97f9394-5f7a-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:34:38 +0100 (CET) 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: d97f9394-5f7a-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921678; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=fcGVjUlcEVSXL3s0Xxex/3prCjVc7v5RHdmr3hXRWPM=; b=X20A+Z8UbcnnlgUnC8rSSi2+HFCrDg/bKckj02rB2ImH+OI1yDy+n4rN ePSr9G5W/DAFu+VYWEkSdJCGhPT2rBwqHorYsv1+3+6In48nnpaMiT2NH xrk8eLpZGT+OBNF4IKB9khC9XjbFV/Dqwy3ibpVs3mXrfQn71bFM99oZ5 c=; Authentication-Results: esa1.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 84828529 X-Ironport-Server: esa1.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:LztBQa6viFvAWBW3r8pWsAxRtDTHchMFZxGqfqrLsTDasY5as4F+v jQcW2iFOKyMYGv3L48ibIu19hkC6JWHx4cyQAY+rSwzHi5G8cbLO4+Ufxz6V8+wwm8vb2o8t plDNYOQRCwQZiWBzvt4GuG59RGQ7YnRGvynTraBYnoqLeNdYH9JoQp5nOIkiZJfj9G8Agec0 fv/uMSaM1K+s9JOGjt8B5mr9VU+4pwehBtC5gZkPKkT7AeE/5UoJMl3yZ+ZfiOQrrZ8RoZWd 86bpJml82XQ+QsaC9/Nut4XpWVTH9Y+lSDX4pZnc/DKbipq/0Te4Y5iXBYoUm9Fii3hojxE4 I4lWapc6+seFvakdOw1C3G0GszlVEFM0OevzXOX6aR/w6BaGpdFLjoH4EweZOUlFuhL7W5mr tcHLQscb1e6hMGw6q++UPA2nJ97I5y+VG8fkikIITDxCP8nRdbIQrnQ5M8e1zA17ixMNa+AP YxDM2MpNUmeJU0UUrsUIMtWcOOAi3XhcjsetFWPoqkf6GnP1g1hlrPqNbI5f/TaGZUPzhvC9 woq+Uz2Iy8jDM6YwgC5rCO3q8+fpSj3SLk7QejQGvlC3wTImz175ActfUS/iem0jAi5Qd03A 1wZ/G8ioLY/8GSvT8LhRFuorXicpBkeVtFMVeog52ml6qfS+RffOWECQRZIctlgv8gzLRQm3 0GEt8nkDjtutPuSU331y1uPhWrsY25PdzZEPHJaC1teizX+nG0tpknkUdNYAa/yt97WHxvtx iqT9jJl37pG2KbnyJ6H1VzAhjutoL3AQQg0+hjbUwqZ0+9pWGK2T9f2sAaGtJ6sOK7cFwDc5 yZcx6By+chUVfmweDqxrPLh9V1Dz9KMK3XijFFmBPHNHBz9qif4Lei8DNyTTXqF0/romxezP ic/WisLvve/2UdGiocmC79d8+xwkcDd+S3ND5g5rrNmO/CdjjOv8iB0flK31GvwikUqmqxXE c7FL5n8UShDUfw9kmreqwIhPVgDn35W+I8ubcqjk0TPPUS2OBZ5tovpwHPRN7tkvctoUS3e8 spFNtvi9vmseLSWX8QWmKZNRW03wY8TXMGr9JYMLbbTe2KL2ggJUpfs/F/oQKQ994w9qwsC1 irVtpNwoLYnuUD6FA== IronPort-HdrOrdr: A9a23:0TZpM63zPs9sUgU7U5WuoQqjBIokLtp133Aq2lEZdPRUGvb3qy nIpoVj6faUskd2ZJhOo7C90cW7LU80sKQFhLX5Xo3SOzUO2lHYT72KhLGKq1aLdhEWtNQtsZ uIG5IOcOEYZmIasS+V2maF+q4bsbu6zJw= X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="84828529" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 06/15] tools/ocaml/Makefile.rules: hide -include on *clean Date: Tue, 8 Nov 2022 15:33:58 +0000 Message-ID: <2a584406ee8cc1fce5175ad04feee6fdb18b6844.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 Fixes: 2f2b76d47c5bcd9 ("tools/ocaml: do not run ocamldep during make clean") Signed-off-by: Edwin Török Signed-off-by: Edwin Török > Acked-by: Christian Lindig > --- Reason for inclusion in 4.17: - addresses review comments received post commit Changes since v2: - add Fixes line - add 4.17 reason --- tools/ocaml/Makefile.rules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules index e0b9de34e4..39ac260a4d 100644 --- a/tools/ocaml/Makefile.rules +++ b/tools/ocaml/Makefile.rules @@ -44,10 +44,8 @@ META: META.in ALL_OCAML_OBJ_SOURCES=$(addsuffix .ml, $(ALL_OCAML_OBJS)) -ifeq (,$(findstring clean,$(MAKECMDGOALS))) .ocamldep.make: $(ALL_OCAML_OBJ_SOURCES) Makefile $(OCAML_TOPLEVEL)/Makefile.rules $(call quiet-command, $(OCAMLDEP) $(ALL_OCAML_OBJ_SOURCES) *.mli $o,MLDEP,) -endif clean: $(CLEAN_HOOKS) $(Q)rm -f .*.d *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot *.spot *.spit $(LIBS) $(PROGRAMS) $(GENERATED_FILES) .ocamldep.make META @@ -94,7 +92,9 @@ define C_PROGRAM_template $(call quiet-command, $(CC) $(LDFLAGS) -o $$@ $$+,BIN,$$@) endef +ifeq (,$(findstring clean,$(MAKECMDGOALS))) -include .ocamldep.make +endif $(foreach lib,$(OCAML_LIBRARY),$(eval $(call OCAML_LIBRARY_template,$(lib)))) $(foreach lib,$(OCAML_NOC_LIBRARY),$(eval $(call OCAML_NOC_LIBRARY_template,$(lib)))) From patchwork Tue Nov 8 15:33:59 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13056135 Return-Path: Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 12427C43217 for ; Tue, 8 Nov 2022 15:41:48 +0000 (UTC) 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 X-Outflank-Mailman: Message body and most headers restored to incoming version 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-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?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , 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 See CODING_STYLE: Xen uses spaces, not tabs. * OCaml code: Using `ocp-indent` for now to just make minimal modifications in tabs vs spaces and get the right indentation. We can introduce `ocamlformat` later. * C stubs: just replace tabs with spaces now, using `indent` or `clang-format` would change code too much for 4.17. This avoids perpetuating a formatting style that is inconsistent with the rest of Xen, and that makes preparing and submitting patches more difficult (OCaml indentation tools usually only support spaces, not tabs). Contains a bugfix for `abi-check` script to handle the change in the amount of whitespace. No functional change. Signed-off-by: Edwin Török --- Reason for inclusion in 4.17: - makes it easier to backport changes from master to 4.17 - avoid perpetuating a different coding style (I thought tabs were mandated by Xen, and was about to fix up my editor config to match when I realized Xen already mandates the use of spaces) - should make submitting patches for OCaml easier (OCaml indentation tools know only about spaces, so I either can't use them, or have to manually adjust indentation every time I submit a patch) - it can be verified that the only change here is the Makefile change for the new rule, 'git log -p -1 -w' should be otherwise empty Changes since v2: - new in v3 --- tools/ocaml/Makefile | 5 + tools/ocaml/libs/eventchn/xeneventchn_stubs.c | 170 +- tools/ocaml/libs/mmap/mmap_stubs.h | 4 +- tools/ocaml/libs/mmap/xenmmap.ml | 2 +- tools/ocaml/libs/mmap/xenmmap.mli | 4 +- tools/ocaml/libs/mmap/xenmmap_stubs.c | 112 +- tools/ocaml/libs/xb/op.ml | 76 +- tools/ocaml/libs/xb/packet.ml | 30 +- tools/ocaml/libs/xb/partial.ml | 48 +- tools/ocaml/libs/xb/xb.ml | 422 ++-- tools/ocaml/libs/xb/xb.mli | 106 +- tools/ocaml/libs/xb/xenbus_stubs.c | 50 +- tools/ocaml/libs/xb/xs_ring.ml | 28 +- tools/ocaml/libs/xb/xs_ring_stubs.c | 214 +- tools/ocaml/libs/xc/abi-check | 2 +- tools/ocaml/libs/xc/xenctrl.ml | 330 +-- tools/ocaml/libs/xc/xenctrl.mli | 12 +- tools/ocaml/libs/xc/xenctrl_stubs.c | 1424 ++++++------ tools/ocaml/libs/xentoollog/caml_xentoollog.h | 6 +- .../ocaml/libs/xentoollog/xentoollog_stubs.c | 196 +- tools/ocaml/libs/xl/xenlight_stubs.c | 2022 ++++++++--------- tools/ocaml/libs/xs/queueop.ml | 48 +- tools/ocaml/libs/xs/xs.ml | 220 +- tools/ocaml/libs/xs/xs.mli | 46 +- tools/ocaml/libs/xs/xsraw.ml | 300 +-- tools/ocaml/libs/xs/xst.ml | 76 +- tools/ocaml/libs/xs/xst.mli | 20 +- tools/ocaml/test/dmesg.ml | 26 +- tools/ocaml/test/list_domains.ml | 4 +- tools/ocaml/test/raise_exception.ml | 4 +- tools/ocaml/test/xtl.ml | 28 +- tools/ocaml/xenstored/config.ml | 156 +- tools/ocaml/xenstored/connection.ml | 594 ++--- tools/ocaml/xenstored/connections.ml | 304 +-- tools/ocaml/xenstored/define.ml | 6 +- tools/ocaml/xenstored/disk.ml | 218 +- tools/ocaml/xenstored/domain.ml | 100 +- tools/ocaml/xenstored/domains.ml | 310 +-- tools/ocaml/xenstored/event.ml | 4 +- tools/ocaml/xenstored/history.ml | 62 +- tools/ocaml/xenstored/logging.ml | 434 ++-- tools/ocaml/xenstored/packet.ml | 20 +- tools/ocaml/xenstored/parse_arg.ml | 106 +- tools/ocaml/xenstored/perms.ml | 216 +- tools/ocaml/xenstored/poll.ml | 68 +- tools/ocaml/xenstored/poll.mli | 4 +- tools/ocaml/xenstored/process.ml | 1212 +++++----- tools/ocaml/xenstored/quota.ml | 74 +- tools/ocaml/xenstored/select_stubs.c | 62 +- tools/ocaml/xenstored/stdext.ml | 190 +- tools/ocaml/xenstored/store.ml | 752 +++--- tools/ocaml/xenstored/symbol.ml | 2 +- tools/ocaml/xenstored/syslog.ml | 48 +- tools/ocaml/xenstored/syslog_stubs.c | 30 +- tools/ocaml/xenstored/systemd_stubs.c | 10 +- tools/ocaml/xenstored/transaction.ml | 352 +-- tools/ocaml/xenstored/trie.ml | 222 +- tools/ocaml/xenstored/trie.mli | 22 +- tools/ocaml/xenstored/utils.ml | 146 +- tools/ocaml/xenstored/xenstored.ml | 1018 ++++----- 60 files changed, 6391 insertions(+), 6386 deletions(-) diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index a7c04b6546..274ba15d75 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -34,3 +34,8 @@ build-tools-oxenstored: $(MAKE) -s -C libs/xb $(MAKE) -s -C libs/xc $(MAKE) -C xenstored + +.PHONY: format +format: + git ls-files '*.ml' '*.mli' | xargs -n1 ocp-indent -i + git ls-files '*.c' '*.h' | xargs -n1 sed -ie 's/\t/ /g' diff --git a/tools/ocaml/libs/eventchn/xeneventchn_stubs.c b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c index 67af116377..2263c4caa1 100644 --- a/tools/ocaml/libs/eventchn/xeneventchn_stubs.c +++ b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c @@ -44,149 +44,149 @@ static void stub_evtchn_finalize(value v) { - /* docs say to not use any CAMLparam* macros here */ - xenevtchn_close(_H(v)); + /* docs say to not use any CAMLparam* macros here */ + xenevtchn_close(_H(v)); } static struct custom_operations xenevtchn_ops = { - "xenevtchn", - stub_evtchn_finalize, - custom_compare_default, /* raises Failure, cannot compare */ - custom_hash_default, /* ignored */ - custom_serialize_default, /* raises Failure, can't serialize */ - custom_deserialize_default, /* raises Failure, can't deserialize */ - custom_compare_ext_default /* raises Failure */ + "xenevtchn", + stub_evtchn_finalize, + custom_compare_default, /* raises Failure, cannot compare */ + custom_hash_default, /* ignored */ + custom_serialize_default, /* raises Failure, can't serialize */ + custom_deserialize_default, /* raises Failure, can't deserialize */ + custom_compare_ext_default /* raises Failure */ }; CAMLprim value stub_eventchn_init(void) { - CAMLparam0(); - CAMLlocal1(result); - xenevtchn_handle *xce; + CAMLparam0(); + CAMLlocal1(result); + xenevtchn_handle *xce; - caml_enter_blocking_section(); - xce = xenevtchn_open(NULL, 0); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + xce = xenevtchn_open(NULL, 0); + caml_leave_blocking_section(); - if (xce == NULL) - caml_failwith("open failed"); + if (xce == NULL) + caml_failwith("open failed"); - /* contains file descriptors, trigger full GC at least every 128 allocations */ - result = caml_alloc_custom(&xenevtchn_ops, sizeof(xce), 0, 1); - _H(result) = xce; - CAMLreturn(result); + /* contains file descriptors, trigger full GC at least every 128 allocations */ + result = caml_alloc_custom(&xenevtchn_ops, sizeof(xce), 0, 1); + _H(result) = xce; + CAMLreturn(result); } CAMLprim value stub_eventchn_fd(value xce) { - CAMLparam1(xce); - CAMLlocal1(result); - int fd; + CAMLparam1(xce); + CAMLlocal1(result); + int fd; - fd = xenevtchn_fd(_H(xce)); - if (fd == -1) - caml_failwith("evtchn fd failed"); + fd = xenevtchn_fd(_H(xce)); + if (fd == -1) + caml_failwith("evtchn fd failed"); - result = Val_int(fd); + result = Val_int(fd); - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_eventchn_notify(value xce, value port) { - CAMLparam2(xce, port); - int rc; + CAMLparam2(xce, port); + int rc; - caml_enter_blocking_section(); - rc = xenevtchn_notify(_H(xce), Int_val(port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_notify(_H(xce), Int_val(port)); + caml_leave_blocking_section(); - if (rc == -1) - caml_failwith("evtchn notify failed"); + if (rc == -1) + caml_failwith("evtchn notify failed"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_eventchn_bind_interdomain(value xce, value domid, value remote_port) { - CAMLparam3(xce, domid, remote_port); - CAMLlocal1(port); - xenevtchn_port_or_error_t rc; + CAMLparam3(xce, domid, remote_port); + CAMLlocal1(port); + xenevtchn_port_or_error_t rc; - caml_enter_blocking_section(); - rc = xenevtchn_bind_interdomain(_H(xce), Int_val(domid), Int_val(remote_port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_bind_interdomain(_H(xce), Int_val(domid), Int_val(remote_port)); + caml_leave_blocking_section(); - if (rc == -1) - caml_failwith("evtchn bind_interdomain failed"); - port = Val_int(rc); + if (rc == -1) + caml_failwith("evtchn bind_interdomain failed"); + port = Val_int(rc); - CAMLreturn(port); + CAMLreturn(port); } CAMLprim value stub_eventchn_bind_virq(value xce, value virq_type) { - CAMLparam2(xce, virq_type); - CAMLlocal1(port); - xenevtchn_port_or_error_t rc; + CAMLparam2(xce, virq_type); + CAMLlocal1(port); + xenevtchn_port_or_error_t rc; - caml_enter_blocking_section(); - rc = xenevtchn_bind_virq(_H(xce), Int_val(virq_type)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_bind_virq(_H(xce), Int_val(virq_type)); + caml_leave_blocking_section(); - if (rc == -1) - caml_failwith("evtchn bind_virq failed"); - port = Val_int(rc); + if (rc == -1) + caml_failwith("evtchn bind_virq failed"); + port = Val_int(rc); - CAMLreturn(port); + CAMLreturn(port); } CAMLprim value stub_eventchn_unbind(value xce, value port) { - CAMLparam2(xce, port); - int rc; + CAMLparam2(xce, port); + int rc; - caml_enter_blocking_section(); - rc = xenevtchn_unbind(_H(xce), Int_val(port)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_unbind(_H(xce), Int_val(port)); + caml_leave_blocking_section(); - if (rc == -1) - caml_failwith("evtchn unbind failed"); + if (rc == -1) + caml_failwith("evtchn unbind failed"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_eventchn_pending(value xce) { - CAMLparam1(xce); - CAMLlocal1(result); - xenevtchn_port_or_error_t port; + CAMLparam1(xce); + CAMLlocal1(result); + xenevtchn_port_or_error_t port; - caml_enter_blocking_section(); - port = xenevtchn_pending(_H(xce)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + port = xenevtchn_pending(_H(xce)); + caml_leave_blocking_section(); - if (port == -1) - caml_failwith("evtchn pending failed"); - result = Val_int(port); + if (port == -1) + caml_failwith("evtchn pending failed"); + result = Val_int(port); - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_eventchn_unmask(value xce, value _port) { - CAMLparam2(xce, _port); - evtchn_port_t port; - int rc; + CAMLparam2(xce, _port); + evtchn_port_t port; + int rc; - port = Int_val(_port); + port = Int_val(_port); - caml_enter_blocking_section(); - rc = xenevtchn_unmask(_H(xce), port); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = xenevtchn_unmask(_H(xce), port); + caml_leave_blocking_section(); - if (rc) - caml_failwith("evtchn unmask failed"); - CAMLreturn(Val_unit); + if (rc) + caml_failwith("evtchn unmask failed"); + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/mmap_stubs.h index 5c65cc86fb..14f0c0a704 100644 --- a/tools/ocaml/libs/mmap/mmap_stubs.h +++ b/tools/ocaml/libs/mmap/mmap_stubs.h @@ -26,8 +26,8 @@ struct mmap_interface { - void *addr; - int len; + void *addr; + int len; }; /* for compatibility with OCaml 4.02.3 */ diff --git a/tools/ocaml/libs/mmap/xenmmap.ml b/tools/ocaml/libs/mmap/xenmmap.ml index 44b67c89d2..fd6735649f 100644 --- a/tools/ocaml/libs/mmap/xenmmap.ml +++ b/tools/ocaml/libs/mmap/xenmmap.ml @@ -21,7 +21,7 @@ type mmap_map_flag = SHARED | PRIVATE (* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *) external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag - -> int -> int -> mmap_interface = "stub_mmap_init" + -> int -> int -> mmap_interface = "stub_mmap_init" external unmap: mmap_interface -> unit = "stub_mmap_final" (* read: interface -> start -> length -> data *) external read: mmap_interface -> int -> int -> string = "stub_mmap_read" diff --git a/tools/ocaml/libs/mmap/xenmmap.mli b/tools/ocaml/libs/mmap/xenmmap.mli index 8f92ed6310..d097b68a8f 100644 --- a/tools/ocaml/libs/mmap/xenmmap.mli +++ b/tools/ocaml/libs/mmap/xenmmap.mli @@ -19,10 +19,10 @@ type mmap_prot_flag = RDONLY | WRONLY | RDWR type mmap_map_flag = SHARED | PRIVATE external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int - -> mmap_interface = "stub_mmap_init" + -> mmap_interface = "stub_mmap_init" external unmap : mmap_interface -> unit = "stub_mmap_final" external read : mmap_interface -> int -> int -> string = "stub_mmap_read" external write : mmap_interface -> string -> int -> int -> unit - = "stub_mmap_write" + = "stub_mmap_write" external getpagesize : unit -> int = "stub_mmap_getpagesize" diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c b/tools/ocaml/libs/mmap/xenmmap_stubs.c index 141dedb78c..bf864a7c32 100644 --- a/tools/ocaml/libs/mmap/xenmmap_stubs.c +++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c @@ -34,97 +34,97 @@ static int mmap_interface_init(struct mmap_interface *intf, int fd, int pflag, int mflag, int len, int offset) { - intf->len = len; - intf->addr = mmap(NULL, len, pflag, mflag, fd, offset); - return (intf->addr == MAP_FAILED) ? errno : 0; + intf->len = len; + intf->addr = mmap(NULL, len, pflag, mflag, fd, offset); + return (intf->addr == MAP_FAILED) ? errno : 0; } CAMLprim value stub_mmap_init(value fd, value pflag, value mflag, value len, value offset) { - CAMLparam5(fd, pflag, mflag, len, offset); - CAMLlocal1(result); - int c_pflag, c_mflag; + CAMLparam5(fd, pflag, mflag, len, offset); + CAMLlocal1(result); + int c_pflag, c_mflag; - switch (Int_val(pflag)) { - case 0: c_pflag = PROT_READ; break; - case 1: c_pflag = PROT_WRITE; break; - case 2: c_pflag = PROT_READ|PROT_WRITE; break; - default: caml_invalid_argument("protectiontype"); - } + switch (Int_val(pflag)) { + case 0: c_pflag = PROT_READ; break; + case 1: c_pflag = PROT_WRITE; break; + case 2: c_pflag = PROT_READ|PROT_WRITE; break; + default: caml_invalid_argument("protectiontype"); + } - switch (Int_val(mflag)) { - case 0: c_mflag = MAP_SHARED; break; - case 1: c_mflag = MAP_PRIVATE; break; - default: caml_invalid_argument("maptype"); - } + switch (Int_val(mflag)) { + case 0: c_mflag = MAP_SHARED; break; + case 1: c_mflag = MAP_PRIVATE; break; + default: caml_invalid_argument("maptype"); + } - result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); - if (mmap_interface_init(Intf_val(result), Int_val(fd), - c_pflag, c_mflag, - Int_val(len), Int_val(offset))) - caml_failwith("mmap"); - CAMLreturn(result); + if (mmap_interface_init(Intf_val(result), Int_val(fd), + c_pflag, c_mflag, + Int_val(len), Int_val(offset))) + caml_failwith("mmap"); + CAMLreturn(result); } CAMLprim value stub_mmap_final(value intf) { - CAMLparam1(intf); + CAMLparam1(intf); - if (Intf_val(intf)->addr != MAP_FAILED) - munmap(Intf_val(intf)->addr, Intf_val(intf)->len); - Intf_val(intf)->addr = MAP_FAILED; + if (Intf_val(intf)->addr != MAP_FAILED) + munmap(Intf_val(intf)->addr, Intf_val(intf)->len); + Intf_val(intf)->addr = MAP_FAILED; - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_mmap_read(value intf, value start, value len) { - CAMLparam3(intf, start, len); - CAMLlocal1(data); - int c_start; - int c_len; + CAMLparam3(intf, start, len); + CAMLlocal1(data); + int c_start; + int c_len; - c_start = Int_val(start); - c_len = Int_val(len); + c_start = Int_val(start); + c_len = Int_val(len); - if (c_start > Intf_val(intf)->len) - caml_invalid_argument("start invalid"); - if (c_start + c_len > Intf_val(intf)->len) - caml_invalid_argument("len invalid"); + if (c_start > Intf_val(intf)->len) + caml_invalid_argument("start invalid"); + if (c_start + c_len > Intf_val(intf)->len) + caml_invalid_argument("len invalid"); - data = caml_alloc_string(c_len); - memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len); + data = caml_alloc_string(c_len); + memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len); - CAMLreturn(data); + CAMLreturn(data); } CAMLprim value stub_mmap_write(value intf, value data, value start, value len) { - CAMLparam4(intf, data, start, len); - int c_start; - int c_len; + CAMLparam4(intf, data, start, len); + int c_start; + int c_len; - c_start = Int_val(start); - c_len = Int_val(len); + c_start = Int_val(start); + c_len = Int_val(len); - if (c_start > Intf_val(intf)->len) - caml_invalid_argument("start invalid"); - if (c_start + c_len > Intf_val(intf)->len) - caml_invalid_argument("len invalid"); + if (c_start > Intf_val(intf)->len) + caml_invalid_argument("start invalid"); + if (c_start + c_len > Intf_val(intf)->len) + caml_invalid_argument("len invalid"); - memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len); + memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_mmap_getpagesize(value unit) { - CAMLparam1(unit); - CAMLlocal1(data); + CAMLparam1(unit); + CAMLlocal1(data); - data = Val_int(getpagesize()); - CAMLreturn(data); + data = Val_int(getpagesize()); + CAMLreturn(data); } diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml index 9bcab0f38c..c94116a8cc 100644 --- a/tools/ocaml/libs/xb/op.ml +++ b/tools/ocaml/libs/xb/op.ml @@ -23,50 +23,50 @@ type operation = Debug | Directory | Read | Getperms | Invalid let operation_c_mapping = - [| Debug; Directory; Read; Getperms; - Watch; Unwatch; Transaction_start; - Transaction_end; Introduce; Release; - Getdomainpath; Write; Mkdir; Rm; - Setperms; Watchevent; Error; Isintroduced; - Resume; Set_target; Invalid; Reset_watches |] + [| Debug; Directory; Read; Getperms; + Watch; Unwatch; Transaction_start; + Transaction_end; Introduce; Release; + Getdomainpath; Write; Mkdir; Rm; + Setperms; Watchevent; Error; Isintroduced; + Resume; Set_target; Invalid; Reset_watches |] let size = Array.length operation_c_mapping let array_search el a = - let len = Array.length a in - let rec search i = - if i > len then raise Not_found; - if a.(i) = el then i else search (i + 1) in - search 0 + let len = Array.length a in + let rec search i = + if i > len then raise Not_found; + if a.(i) = el then i else search (i + 1) in + search 0 let of_cval i = - if i >= 0 && i < size - then operation_c_mapping.(i) - else Invalid + if i >= 0 && i < size + then operation_c_mapping.(i) + else Invalid let to_cval op = - array_search op operation_c_mapping + array_search op operation_c_mapping let to_string ty = - match ty with - | Debug -> "DEBUG" - | Directory -> "DIRECTORY" - | Read -> "READ" - | Getperms -> "GET_PERMS" - | Watch -> "WATCH" - | Unwatch -> "UNWATCH" - | Transaction_start -> "TRANSACTION_START" - | Transaction_end -> "TRANSACTION_END" - | Introduce -> "INTRODUCE" - | Release -> "RELEASE" - | Getdomainpath -> "GET_DOMAIN_PATH" - | Write -> "WRITE" - | Mkdir -> "MKDIR" - | Rm -> "RM" - | Setperms -> "SET_PERMS" - | Watchevent -> "WATCH_EVENT" - | Error -> "ERROR" - | Isintroduced -> "IS_INTRODUCED" - | Resume -> "RESUME" - | Set_target -> "SET_TARGET" - | Reset_watches -> "RESET_WATCHES" - | Invalid -> "INVALID" + match ty with + | Debug -> "DEBUG" + | Directory -> "DIRECTORY" + | Read -> "READ" + | Getperms -> "GET_PERMS" + | Watch -> "WATCH" + | Unwatch -> "UNWATCH" + | Transaction_start -> "TRANSACTION_START" + | Transaction_end -> "TRANSACTION_END" + | Introduce -> "INTRODUCE" + | Release -> "RELEASE" + | Getdomainpath -> "GET_DOMAIN_PATH" + | Write -> "WRITE" + | Mkdir -> "MKDIR" + | Rm -> "RM" + | Setperms -> "SET_PERMS" + | Watchevent -> "WATCH_EVENT" + | Error -> "ERROR" + | Isintroduced -> "IS_INTRODUCED" + | Resume -> "RESUME" + | Set_target -> "SET_TARGET" + | Reset_watches -> "RESET_WATCHES" + | Invalid -> "INVALID" diff --git a/tools/ocaml/libs/xb/packet.ml b/tools/ocaml/libs/xb/packet.ml index 74c04bb7ae..cd169c066b 100644 --- a/tools/ocaml/libs/xb/packet.ml +++ b/tools/ocaml/libs/xb/packet.ml @@ -15,12 +15,12 @@ *) type t = -{ - tid: int; - rid: int; - ty: Op.operation; - data: string; -} + { + tid: int; + rid: int; + ty: Op.operation; + data: string; + } exception Error of string exception DataError of string @@ -30,21 +30,21 @@ external string_of_header: int -> int -> int -> int -> string = "stub_string_of_ let create tid rid ty data = { tid = tid; rid = rid; ty = ty; data = data; } let of_partialpkt ppkt = - create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf) + create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf) let to_string pkt = - let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in - header ^ pkt.data + let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in + header ^ pkt.data let unpack pkt = - pkt.tid, pkt.rid, pkt.ty, pkt.data + pkt.tid, pkt.rid, pkt.ty, pkt.data let get_tid pkt = pkt.tid let get_ty pkt = pkt.ty let get_data pkt = - let l = String.length pkt.data in - if l > 0 && pkt.data.[l - 1] = '\000' then - String.sub pkt.data 0 (l - 1) - else - pkt.data + let l = String.length pkt.data in + if l > 0 && pkt.data.[l - 1] = '\000' then + String.sub pkt.data 0 (l - 1) + else + pkt.data let get_rid pkt = pkt.rid \ No newline at end of file diff --git a/tools/ocaml/libs/xb/partial.ml b/tools/ocaml/libs/xb/partial.ml index 3aa8927eb7..0494c6a9c7 100644 --- a/tools/ocaml/libs/xb/partial.ml +++ b/tools/ocaml/libs/xb/partial.ml @@ -15,39 +15,39 @@ *) type pkt = -{ - tid: int; - rid: int; - ty: Op.operation; - len: int; - buf: Buffer.t; -} + { + tid: int; + rid: int; + ty: Op.operation; + len: int; + buf: Buffer.t; + } external header_size: unit -> int = "stub_header_size" external header_of_string_internal: string -> int * int * int * int - = "stub_header_of_string" + = "stub_header_of_string" let xenstore_payload_max = 4096 (* xen/include/public/io/xs_wire.h *) let xenstore_rel_path_max = 2048 (* xen/include/public/io/xs_wire.h *) let of_string s = - let tid, rid, opint, dlen = header_of_string_internal s in - (* A packet which is bigger than xenstore_payload_max is illegal. - This will leave the guest connection is a bad state and will - be hard to recover from without restarting the connection - (ie rebooting the guest) *) - let dlen = max 0 (min xenstore_payload_max dlen) in - { - tid = tid; - rid = rid; - ty = (Op.of_cval opint); - len = dlen; - buf = Buffer.create dlen; - } + let tid, rid, opint, dlen = header_of_string_internal s in + (* A packet which is bigger than xenstore_payload_max is illegal. + This will leave the guest connection is a bad state and will + be hard to recover from without restarting the connection + (ie rebooting the guest) *) + let dlen = max 0 (min xenstore_payload_max dlen) in + { + tid = tid; + rid = rid; + ty = (Op.of_cval opint); + len = dlen; + buf = Buffer.create dlen; + } let append pkt s sz = - if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith "Buffer.add: cannot grow buffer"; - Buffer.add_substring pkt.buf s 0 sz + if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith "Buffer.add: cannot grow buffer"; + Buffer.add_substring pkt.buf s 0 sz let to_complete pkt = - pkt.len - (Buffer.length pkt.buf) + pkt.len - (Buffer.length pkt.buf) diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml index b292ed7a87..40d2c9956a 100644 --- a/tools/ocaml/libs/xb/xb.ml +++ b/tools/ocaml/libs/xb/xb.ml @@ -18,94 +18,94 @@ module Op = struct include Op end module Packet = struct include Packet end module BoundedQueue : sig - type ('a, 'b) t + type ('a, 'b) t - (** [create ~capacity ~classify ~limit] creates a queue with maximum [capacity] elements. - This is burst capacity, each element is further classified according to [classify], - and each class can have its own [limit]. - [capacity] is enforced as an overall limit. - The [limit] can be dynamic, and can be smaller than the number of elements already queued of that class, - in which case those elements are considered to use "burst capacity". - *) - val create: capacity:int -> classify:('a -> 'b) -> limit:('b -> int) -> ('a, 'b) t + (** [create ~capacity ~classify ~limit] creates a queue with maximum [capacity] elements. + This is burst capacity, each element is further classified according to [classify], + and each class can have its own [limit]. + [capacity] is enforced as an overall limit. + The [limit] can be dynamic, and can be smaller than the number of elements already queued of that class, + in which case those elements are considered to use "burst capacity". + *) + val create: capacity:int -> classify:('a -> 'b) -> limit:('b -> int) -> ('a, 'b) t - (** [clear q] discards all elements from [q] *) - val clear: ('a, 'b) t -> unit + (** [clear q] discards all elements from [q] *) + val clear: ('a, 'b) t -> unit - (** [can_push q] when [length q < capacity]. *) - val can_push: ('a, 'b) t -> 'b -> bool + (** [can_push q] when [length q < capacity]. *) + val can_push: ('a, 'b) t -> 'b -> bool - (** [push e q] adds [e] at the end of queue [q] if [can_push q], or returns [None]. *) - val push: 'a -> ('a, 'b) t -> unit option + (** [push e q] adds [e] at the end of queue [q] if [can_push q], or returns [None]. *) + val push: 'a -> ('a, 'b) t -> unit option - (** [pop q] removes and returns first element in [q], or raises [Queue.Empty]. *) - val pop: ('a, 'b) t -> 'a + (** [pop q] removes and returns first element in [q], or raises [Queue.Empty]. *) + val pop: ('a, 'b) t -> 'a - (** [peek q] returns the first element in [q], or raises [Queue.Empty]. *) - val peek : ('a, 'b) t -> 'a + (** [peek q] returns the first element in [q], or raises [Queue.Empty]. *) + val peek : ('a, 'b) t -> 'a - (** [length q] returns the current number of elements in [q] *) - val length: ('a, 'b) t -> int + (** [length q] returns the current number of elements in [q] *) + val length: ('a, 'b) t -> int - (** [debug string_of_class q] prints queue usage statistics in an unspecified internal format. *) - val debug: ('b -> string) -> (_, 'b) t -> string + (** [debug string_of_class q] prints queue usage statistics in an unspecified internal format. *) + val debug: ('b -> string) -> (_, 'b) t -> string end = struct - type ('a, 'b) t = - { q: 'a Queue.t - ; capacity: int - ; classify: 'a -> 'b - ; limit: 'b -> int - ; class_count: ('b, int) Hashtbl.t - } + type ('a, 'b) t = + { q: 'a Queue.t + ; capacity: int + ; classify: 'a -> 'b + ; limit: 'b -> int + ; class_count: ('b, int) Hashtbl.t + } - let create ~capacity ~classify ~limit = - { capacity; q = Queue.create (); classify; limit; class_count = Hashtbl.create 3 } + let create ~capacity ~classify ~limit = + { capacity; q = Queue.create (); classify; limit; class_count = Hashtbl.create 3 } - let get_count t classification = try Hashtbl.find t.class_count classification with Not_found -> 0 + let get_count t classification = try Hashtbl.find t.class_count classification with Not_found -> 0 - let can_push_internal t classification class_count = - Queue.length t.q < t.capacity && class_count < t.limit classification + let can_push_internal t classification class_count = + Queue.length t.q < t.capacity && class_count < t.limit classification - let ok = Some () + let ok = Some () - let push e t = - let classification = t.classify e in - let class_count = get_count t classification in - if can_push_internal t classification class_count then begin - Queue.push e t.q; - Hashtbl.replace t.class_count classification (class_count + 1); - ok - end - else - None + let push e t = + let classification = t.classify e in + let class_count = get_count t classification in + if can_push_internal t classification class_count then begin + Queue.push e t.q; + Hashtbl.replace t.class_count classification (class_count + 1); + ok + end + else + None - let can_push t classification = - can_push_internal t classification @@ get_count t classification + let can_push t classification = + can_push_internal t classification @@ get_count t classification - let clear t = - Queue.clear t.q; - Hashtbl.reset t.class_count + let clear t = + Queue.clear t.q; + Hashtbl.reset t.class_count - let pop t = - let e = Queue.pop t.q in - let classification = t.classify e in - let () = match get_count t classification - 1 with - | 0 -> Hashtbl.remove t.class_count classification (* reduces memusage *) - | n -> Hashtbl.replace t.class_count classification n - in - e + let pop t = + let e = Queue.pop t.q in + let classification = t.classify e in + let () = match get_count t classification - 1 with + | 0 -> Hashtbl.remove t.class_count classification (* reduces memusage *) + | n -> Hashtbl.replace t.class_count classification n + in + e - let peek t = Queue.peek t.q - let length t = Queue.length t.q + let peek t = Queue.peek t.q + let length t = Queue.length t.q - let debug string_of_class t = - let b = Buffer.create 128 in - Printf.bprintf b "BoundedQueue capacity: %d, used: {" t.capacity; - Hashtbl.iter (fun packet_class count -> - Printf.bprintf b " %s: %d" (string_of_class packet_class) count - ) t.class_count; - Printf.bprintf b "}"; - Buffer.contents b + let debug string_of_class t = + let b = Buffer.create 128 in + Printf.bprintf b "BoundedQueue capacity: %d, used: {" t.capacity; + Hashtbl.iter (fun packet_class count -> + Printf.bprintf b " %s: %d" (string_of_class packet_class) count + ) t.class_count; + Printf.bprintf b "}"; + Buffer.contents b end @@ -119,129 +119,129 @@ let _ = Callback.register_exception "Xb.Reconnect" Reconnect type backend_mmap = -{ - mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *) - eventchn_notify: unit -> unit; (* function to notify through eventchn *) - mutable work_again: bool; -} + { + mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *) + eventchn_notify: unit -> unit; (* function to notify through eventchn *) + mutable work_again: bool; + } type backend_fd = -{ - fd: Unix.file_descr; -} + { + fd: Unix.file_descr; + } type backend = Fd of backend_fd | Xenmmap of backend_mmap type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * bytes (* - separate capacity reservation for replies and watch events: - this allows a domain to keep working even when under a constant flood of - watch events + separate capacity reservation for replies and watch events: + this allows a domain to keep working even when under a constant flood of + watch events *) type capacity = { maxoutstanding: int; maxwatchevents: int } module Queue = BoundedQueue type packet_class = - | CommandReply - | Watchevent + | CommandReply + | Watchevent let string_of_packet_class = function - | CommandReply -> "command_reply" - | Watchevent -> "watch_event" + | CommandReply -> "command_reply" + | Watchevent -> "watch_event" type t = -{ - backend: backend; - pkt_out: (Packet.t, packet_class) Queue.t; - mutable partial_in: partial_buf; - mutable partial_out: string; - capacity: capacity -} + { + backend: backend; + pkt_out: (Packet.t, packet_class) Queue.t; + mutable partial_in: partial_buf; + mutable partial_out: string; + capacity: capacity + } let to_read con = - match con.partial_in with - | HaveHdr partial_pkt -> Partial.to_complete partial_pkt - | NoHdr (i, _) -> i + match con.partial_in with + | HaveHdr partial_pkt -> Partial.to_complete partial_pkt + | NoHdr (i, _) -> i let debug t = - Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d bytes, pkt_out: %d packets, %s" - (to_read t) - (String.length t.partial_out) - (Queue.length t.pkt_out) - (BoundedQueue.debug string_of_packet_class t.pkt_out) + Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d bytes, pkt_out: %d packets, %s" + (to_read t) + (String.length t.partial_out) + (Queue.length t.pkt_out) + (BoundedQueue.debug string_of_packet_class t.pkt_out) let init_partial_in () = NoHdr - (Partial.header_size (), Bytes.make (Partial.header_size()) '\000') + (Partial.header_size (), Bytes.make (Partial.header_size()) '\000') let reconnect t = match t.backend with - | Fd _ -> - (* should never happen, so close the connection *) - raise End_of_file - | Xenmmap backend -> - Xs_ring.close backend.mmap; - backend.eventchn_notify (); - (* Clear our old connection state *) - Queue.clear t.pkt_out; - t.partial_in <- init_partial_in (); - t.partial_out <- "" + | Fd _ -> + (* should never happen, so close the connection *) + raise End_of_file + | Xenmmap backend -> + Xs_ring.close backend.mmap; + backend.eventchn_notify (); + (* Clear our old connection state *) + Queue.clear t.pkt_out; + t.partial_in <- init_partial_in (); + t.partial_out <- "" let queue con pkt = Queue.push pkt con.pkt_out let read_fd back _con b len = - let rd = Unix.read back.fd b 0 len in - if rd = 0 then - raise End_of_file; - rd + let rd = Unix.read back.fd b 0 len in + if rd = 0 then + raise End_of_file; + rd let read_mmap back _con b len = - let s = Bytes.make len '\000' in - let rd = Xs_ring.read back.mmap s len in - Bytes.blit s 0 b 0 rd; - back.work_again <- (rd > 0); - if rd > 0 then - back.eventchn_notify (); - rd + let s = Bytes.make len '\000' in + let rd = Xs_ring.read back.mmap s len in + Bytes.blit s 0 b 0 rd; + back.work_again <- (rd > 0); + if rd > 0 then + back.eventchn_notify (); + rd let read con b len = - match con.backend with - | Fd backfd -> read_fd backfd con b len - | Xenmmap backmmap -> read_mmap backmmap con b len + match con.backend with + | Fd backfd -> read_fd backfd con b len + | Xenmmap backmmap -> read_mmap backmmap con b len let write_fd back _con b len = - Unix.write_substring back.fd b 0 len + Unix.write_substring back.fd b 0 len let write_mmap back _con s len = - let ws = Xs_ring.write_substring back.mmap s len in - if ws > 0 then - back.eventchn_notify (); - ws + let ws = Xs_ring.write_substring back.mmap s len in + if ws > 0 then + back.eventchn_notify (); + ws let write con s len = - match con.backend with - | Fd backfd -> write_fd backfd con s len - | Xenmmap backmmap -> write_mmap backmmap con s len + match con.backend with + | Fd backfd -> write_fd backfd con s len + | Xenmmap backmmap -> write_mmap backmmap con s len (* NB: can throw Reconnect *) let output con = - (* get the output string from a string_of(packet) or partial_out *) - let s = if String.length con.partial_out > 0 then - con.partial_out - else if Queue.length con.pkt_out > 0 then - let pkt = Queue.pop con.pkt_out in - Packet.to_string pkt - else - "" in - (* send data from s, and save the unsent data to partial_out *) - if s <> "" then ( - let len = String.length s in - let sz = write con s len in - let left = String.sub s sz (len - sz) in - con.partial_out <- left - ); - (* after sending one packet, partial is empty *) - con.partial_out = "" + (* get the output string from a string_of(packet) or partial_out *) + let s = if String.length con.partial_out > 0 then + con.partial_out + else if Queue.length con.pkt_out > 0 then + let pkt = Queue.pop con.pkt_out in + Packet.to_string pkt + else + "" in + (* send data from s, and save the unsent data to partial_out *) + if s <> "" then ( + let len = String.length s in + let sz = write con s len in + let left = String.sub s sz (len - sz) in + con.partial_out <- left + ); + (* after sending one packet, partial is empty *) + con.partial_out = "" (* we can only process an input packet if we're guaranteed to have room to store the response packet *) @@ -249,71 +249,71 @@ let can_input con = Queue.can_push con.pkt_out CommandReply (* NB: can throw Reconnect *) let input con = - if not (can_input con) then None - else - let to_read = to_read con in + if not (can_input con) then None + else + let to_read = to_read con in - (* try to get more data from input stream *) - let b = Bytes.make to_read '\000' in - let sz = if to_read > 0 then read con b to_read else 0 in + (* try to get more data from input stream *) + let b = Bytes.make to_read '\000' in + let sz = if to_read > 0 then read con b to_read else 0 in - ( - match con.partial_in with - | HaveHdr partial_pkt -> - (* we complete the data *) - if sz > 0 then - Partial.append partial_pkt (Bytes.to_string b) sz; - if Partial.to_complete partial_pkt = 0 then ( - let pkt = Packet.of_partialpkt partial_pkt in - con.partial_in <- init_partial_in (); - Some pkt - ) else None - | NoHdr (i, buf) -> - (* we complete the partial header *) - if sz > 0 then - Bytes.blit b 0 buf (Partial.header_size () - i) sz; - con.partial_in <- if sz = i then - HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, buf); - None - ) + ( + match con.partial_in with + | HaveHdr partial_pkt -> + (* we complete the data *) + if sz > 0 then + Partial.append partial_pkt (Bytes.to_string b) sz; + if Partial.to_complete partial_pkt = 0 then ( + let pkt = Packet.of_partialpkt partial_pkt in + con.partial_in <- init_partial_in (); + Some pkt + ) else None + | NoHdr (i, buf) -> + (* we complete the partial header *) + if sz > 0 then + Bytes.blit b 0 buf (Partial.header_size () - i) sz; + con.partial_in <- if sz = i then + HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, buf); + None + ) let classify t = - match t.Packet.ty with - | Op.Watchevent -> Watchevent - | _ -> CommandReply + match t.Packet.ty with + | Op.Watchevent -> Watchevent + | _ -> CommandReply let newcon ~capacity backend = - let limit = function - | CommandReply -> capacity.maxoutstanding - | Watchevent -> capacity.maxwatchevents - in - { - backend = backend; - pkt_out = Queue.create ~capacity:(capacity.maxoutstanding + capacity.maxwatchevents) ~classify ~limit; - partial_in = init_partial_in (); - partial_out = ""; - capacity = capacity; - } + let limit = function + | CommandReply -> capacity.maxoutstanding + | Watchevent -> capacity.maxwatchevents + in + { + backend = backend; + pkt_out = Queue.create ~capacity:(capacity.maxoutstanding + capacity.maxwatchevents) ~classify ~limit; + partial_in = init_partial_in (); + partial_out = ""; + capacity = capacity; + } let open_fd fd = newcon (Fd { fd = fd; }) let open_mmap mmap notifyfct = - (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *) - Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection); - newcon (Xenmmap { - mmap = mmap; - eventchn_notify = notifyfct; - work_again = false; }) + (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *) + Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection); + newcon (Xenmmap { + mmap = mmap; + eventchn_notify = notifyfct; + work_again = false; }) let close con = - match con.backend with - | Fd backend -> Unix.close backend.fd - | Xenmmap backend -> Xenmmap.unmap backend.mmap + match con.backend with + | Fd backend -> Unix.close backend.fd + | Xenmmap backend -> Xenmmap.unmap backend.mmap let is_fd con = - match con.backend with - | Fd _ -> true - | Xenmmap _ -> false + match con.backend with + | Fd _ -> true + | Xenmmap _ -> false let is_mmap con = not (is_fd con) @@ -326,19 +326,19 @@ let has_output con = has_new_output con || has_old_output con let peek_output con = Queue.peek con.pkt_out let has_partial_input con = match con.partial_in with - | HaveHdr _ -> true - | NoHdr (n, _) -> n < Partial.header_size () + | HaveHdr _ -> true + | NoHdr (n, _) -> n < Partial.header_size () let has_more_input con = - match con.backend with - | Fd _ -> false - | Xenmmap backend -> backend.work_again + match con.backend with + | Fd _ -> false + | Xenmmap backend -> backend.work_again let is_selectable con = - match con.backend with - | Fd _ -> true - | Xenmmap _ -> false + match con.backend with + | Fd _ -> true + | Xenmmap _ -> false let get_fd con = - match con.backend with - | Fd backend -> backend.fd - | Xenmmap _ -> raise (Failure "get_fd") + match con.backend with + | Fd backend -> backend.fd + | Xenmmap _ -> raise (Failure "get_fd") diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli index 71b2754ca7..e6bb3809dc 100644 --- a/tools/ocaml/libs/xb/xb.mli +++ b/tools/ocaml/libs/xb/xb.mli @@ -1,58 +1,58 @@ module Op : - sig - type operation = - Op.operation = - Debug - | Directory - | Read - | Getperms - | Watch - | Unwatch - | Transaction_start - | Transaction_end - | Introduce - | Release - | Getdomainpath - | Write - | Mkdir - | Rm - | Setperms - | Watchevent - | Error - | Isintroduced - | Resume - | Set_target - | Reset_watches - | Invalid - val operation_c_mapping : operation array - val size : int - val array_search : 'a -> 'a array -> int - val of_cval : int -> operation - val to_cval : operation -> int - val to_string : operation -> string - end +sig + type operation = + Op.operation = + Debug + | Directory + | Read + | Getperms + | Watch + | Unwatch + | Transaction_start + | Transaction_end + | Introduce + | Release + | Getdomainpath + | Write + | Mkdir + | Rm + | Setperms + | Watchevent + | Error + | Isintroduced + | Resume + | Set_target + | Reset_watches + | Invalid + val operation_c_mapping : operation array + val size : int + val array_search : 'a -> 'a array -> int + val of_cval : int -> operation + val to_cval : operation -> int + val to_string : operation -> string +end module Packet : - sig - type t = - Packet.t = { - tid : int; - rid : int; - ty : Op.operation; - data : string; - } - exception Error of string - exception DataError of string - external string_of_header : int -> int -> int -> int -> string - = "stub_string_of_header" - val create : int -> int -> Op.operation -> string -> t - val of_partialpkt : Partial.pkt -> t - val to_string : t -> string - val unpack : t -> int * int * Op.operation * string - val get_tid : t -> int - val get_ty : t -> Op.operation - val get_data : t -> string - val get_rid : t -> int - end +sig + type t = + Packet.t = { + tid : int; + rid : int; + ty : Op.operation; + data : string; + } + exception Error of string + exception DataError of string + external string_of_header : int -> int -> int -> int -> string + = "stub_string_of_header" + val create : int -> int -> Op.operation -> string -> t + val of_partialpkt : Partial.pkt -> t + val to_string : t -> string + val unpack : t -> int * int * Op.operation * string + val get_tid : t -> int + val get_ty : t -> Op.operation + val get_data : t -> string + val get_rid : t -> int +end exception End_of_file exception Eagain exception Noent diff --git a/tools/ocaml/libs/xb/xenbus_stubs.c b/tools/ocaml/libs/xb/xenbus_stubs.c index 3065181a55..e5206f64d4 100644 --- a/tools/ocaml/libs/xb/xenbus_stubs.c +++ b/tools/ocaml/libs/xb/xenbus_stubs.c @@ -32,40 +32,40 @@ CAMLprim value stub_header_size(void) { - CAMLparam0(); - CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); + CAMLparam0(); + CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); } CAMLprim value stub_header_of_string(value s) { - CAMLparam1(s); - CAMLlocal1(ret); - const struct xsd_sockmsg *hdr; + CAMLparam1(s); + CAMLlocal1(ret); + const struct xsd_sockmsg *hdr; - if (caml_string_length(s) != sizeof(struct xsd_sockmsg)) - caml_failwith("xb header incomplete"); - ret = caml_alloc_tuple(4); - hdr = (const struct xsd_sockmsg *) String_val(s); - Store_field(ret, 0, Val_int(hdr->tx_id)); - Store_field(ret, 1, Val_int(hdr->req_id)); - Store_field(ret, 2, Val_int(hdr->type)); - Store_field(ret, 3, Val_int(hdr->len)); - CAMLreturn(ret); + if (caml_string_length(s) != sizeof(struct xsd_sockmsg)) + caml_failwith("xb header incomplete"); + ret = caml_alloc_tuple(4); + hdr = (const struct xsd_sockmsg *) String_val(s); + Store_field(ret, 0, Val_int(hdr->tx_id)); + Store_field(ret, 1, Val_int(hdr->req_id)); + Store_field(ret, 2, Val_int(hdr->type)); + Store_field(ret, 3, Val_int(hdr->len)); + CAMLreturn(ret); } CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len) { - CAMLparam4(tid, rid, ty, len); - CAMLlocal1(ret); - struct xsd_sockmsg xsd = { - .type = Int_val(ty), - .tx_id = Int_val(tid), - .req_id = Int_val(rid), - .len = Int_val(len), - }; + CAMLparam4(tid, rid, ty, len); + CAMLlocal1(ret); + struct xsd_sockmsg xsd = { + .type = Int_val(ty), + .tx_id = Int_val(tid), + .req_id = Int_val(rid), + .len = Int_val(len), + }; - ret = caml_alloc_string(sizeof(struct xsd_sockmsg)); - memcpy((char *) String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); + ret = caml_alloc_string(sizeof(struct xsd_sockmsg)); + memcpy((char *) String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); - CAMLreturn(ret); + CAMLreturn(ret); } diff --git a/tools/ocaml/libs/xb/xs_ring.ml b/tools/ocaml/libs/xb/xs_ring.ml index db7f86bd27..2a27aa56c2 100644 --- a/tools/ocaml/libs/xb/xs_ring.ml +++ b/tools/ocaml/libs/xb/xs_ring.ml @@ -15,14 +15,14 @@ *) module Server_feature = struct - type t = - | Reconnection + type t = + | Reconnection end module Server_features = Set.Make(struct - type t = Server_feature.t - let compare = compare -end) + type t = Server_feature.t + let compare = compare + end) external read: Xenmmap.mmap_interface -> bytes -> int -> int = "ml_interface_read" external write: Xenmmap.mmap_interface -> bytes -> int -> int = "ml_interface_write" @@ -31,18 +31,18 @@ external _internal_set_server_features: Xenmmap.mmap_interface -> int -> unit = external _internal_get_server_features: Xenmmap.mmap_interface -> int = "ml_interface_get_server_features" [@@noalloc] let write_substring mmap buff len = - write mmap (Bytes.unsafe_of_string buff) len + write mmap (Bytes.unsafe_of_string buff) len let get_server_features mmap = - (* NB only one feature currently defined above *) - let x = _internal_get_server_features mmap in - if x = 0 - then Server_features.empty - else Server_features.singleton Server_feature.Reconnection + (* NB only one feature currently defined above *) + let x = _internal_get_server_features mmap in + if x = 0 + then Server_features.empty + else Server_features.singleton Server_feature.Reconnection let set_server_features mmap set = - (* NB only one feature currently defined above *) - let x = if set = Server_features.empty then 0 else 1 in - _internal_set_server_features mmap x + (* NB only one feature currently defined above *) + let x = if set = Server_features.empty then 0 else 1 in + _internal_set_server_features mmap x external close: Xenmmap.mmap_interface -> unit = "ml_interface_close" [@@noalloc] diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_ring_stubs.c index cc9114029f..1e472d0bbf 100644 --- a/tools/ocaml/libs/xb/xs_ring_stubs.c +++ b/tools/ocaml/libs/xb/xs_ring_stubs.c @@ -49,153 +49,153 @@ CAMLprim value ml_interface_read(value ml_interface, value ml_buffer, value ml_len) { - CAMLparam3(ml_interface, ml_buffer, ml_len); - CAMLlocal1(ml_result); + CAMLparam3(ml_interface, ml_buffer, ml_len); + CAMLlocal1(ml_result); - struct mmap_interface *interface = GET_C_STRUCT(ml_interface); - unsigned char *buffer = Bytes_val(ml_buffer); - int len = Int_val(ml_len); - int result; + struct mmap_interface *interface = GET_C_STRUCT(ml_interface); + unsigned char *buffer = Bytes_val(ml_buffer); + int len = Int_val(ml_len); + int result; - struct xenstore_domain_interface *intf = interface->addr; - XENSTORE_RING_IDX cons, prod; /* offsets only */ - int total_data, data; - uint32_t connection; + struct xenstore_domain_interface *intf = interface->addr; + XENSTORE_RING_IDX cons, prod; /* offsets only */ + int total_data, data; + uint32_t connection; - cons = *(volatile uint32_t*)&intf->req_cons; - prod = *(volatile uint32_t*)&intf->req_prod; - connection = *(volatile uint32_t*)&intf->connection; + cons = *(volatile uint32_t*)&intf->req_cons; + prod = *(volatile uint32_t*)&intf->req_prod; + connection = *(volatile uint32_t*)&intf->connection; - if (connection != XENSTORE_CONNECTED) - caml_raise_constant(*caml_named_value("Xb.Reconnect")); + if (connection != XENSTORE_CONNECTED) + caml_raise_constant(*caml_named_value("Xb.Reconnect")); - xen_mb(); + xen_mb(); - if ((prod - cons) > XENSTORE_RING_SIZE) - caml_failwith("bad connection"); + if ((prod - cons) > XENSTORE_RING_SIZE) + caml_failwith("bad connection"); - /* Check for any pending data at all. */ - total_data = prod - cons; - if (total_data == 0) { - /* No pending data at all. */ - result = 0; - goto exit; - } - else if (total_data < len) - /* Some data - make a partial read. */ - len = total_data; + /* Check for any pending data at all. */ + total_data = prod - cons; + if (total_data == 0) { + /* No pending data at all. */ + result = 0; + goto exit; + } + else if (total_data < len) + /* Some data - make a partial read. */ + len = total_data; - /* Check whether data crosses the end of the ring. */ - data = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons); - if (len < data) - /* Data within the remaining part of the ring. */ - memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len); - else { - /* Data crosses the ring boundary. Read both halves. */ - memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), data); - memcpy(buffer + data, intf->req, len - data); - } + /* Check whether data crosses the end of the ring. */ + data = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons); + if (len < data) + /* Data within the remaining part of the ring. */ + memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len); + else { + /* Data crosses the ring boundary. Read both halves. */ + memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), data); + memcpy(buffer + data, intf->req, len - data); + } - xen_mb(); - intf->req_cons += len; - result = len; + xen_mb(); + intf->req_cons += len; + result = len; exit: - ml_result = Val_int(result); - CAMLreturn(ml_result); + ml_result = Val_int(result); + CAMLreturn(ml_result); } CAMLprim value ml_interface_write(value ml_interface, value ml_buffer, value ml_len) { - CAMLparam3(ml_interface, ml_buffer, ml_len); - CAMLlocal1(ml_result); + CAMLparam3(ml_interface, ml_buffer, ml_len); + CAMLlocal1(ml_result); - struct mmap_interface *interface = GET_C_STRUCT(ml_interface); - const unsigned char *buffer = Bytes_val(ml_buffer); - int len = Int_val(ml_len); - int result; + struct mmap_interface *interface = GET_C_STRUCT(ml_interface); + const unsigned char *buffer = Bytes_val(ml_buffer); + int len = Int_val(ml_len); + int result; - struct xenstore_domain_interface *intf = interface->addr; - XENSTORE_RING_IDX cons, prod; - int total_space, space; - uint32_t connection; + struct xenstore_domain_interface *intf = interface->addr; + XENSTORE_RING_IDX cons, prod; + int total_space, space; + uint32_t connection; - cons = *(volatile uint32_t*)&intf->rsp_cons; - prod = *(volatile uint32_t*)&intf->rsp_prod; - connection = *(volatile uint32_t*)&intf->connection; + cons = *(volatile uint32_t*)&intf->rsp_cons; + prod = *(volatile uint32_t*)&intf->rsp_prod; + connection = *(volatile uint32_t*)&intf->connection; - if (connection != XENSTORE_CONNECTED) - caml_raise_constant(*caml_named_value("Xb.Reconnect")); + if (connection != XENSTORE_CONNECTED) + caml_raise_constant(*caml_named_value("Xb.Reconnect")); - xen_mb(); + xen_mb(); - if ((prod - cons) > XENSTORE_RING_SIZE) - caml_failwith("bad connection"); + if ((prod - cons) > XENSTORE_RING_SIZE) + caml_failwith("bad connection"); - /* Check for space to write the full message. */ - total_space = XENSTORE_RING_SIZE - (prod - cons); - if (total_space == 0) { - /* No space at all - exit having done nothing. */ - result = 0; - goto exit; - } - else if (total_space < len) - /* Some space - make a partial write. */ - len = total_space; + /* Check for space to write the full message. */ + total_space = XENSTORE_RING_SIZE - (prod - cons); + if (total_space == 0) { + /* No space at all - exit having done nothing. */ + result = 0; + goto exit; + } + else if (total_space < len) + /* Some space - make a partial write. */ + len = total_space; - /* Check for space until the ring wraps. */ - space = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod); - if (len < space) - /* Message fits inside the remaining part of the ring. */ - memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len); - else { - /* Message wraps around the end of the ring. Write both halves. */ - memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, space); - memcpy(intf->rsp, buffer + space, len - space); - } + /* Check for space until the ring wraps. */ + space = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod); + if (len < space) + /* Message fits inside the remaining part of the ring. */ + memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len); + else { + /* Message wraps around the end of the ring. Write both halves. */ + memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, space); + memcpy(intf->rsp, buffer + space, len - space); + } - xen_mb(); - intf->rsp_prod += len; - result = len; + xen_mb(); + intf->rsp_prod += len; + result = len; exit: - ml_result = Val_int(result); - CAMLreturn(ml_result); + ml_result = Val_int(result); + CAMLreturn(ml_result); } CAMLprim value ml_interface_set_server_features(value interface, value v) { - CAMLparam2(interface, v); - struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; - if (intf == (void*)MAP_FAILED) - caml_failwith("Interface closed"); + CAMLparam2(interface, v); + struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; + if (intf == (void*)MAP_FAILED) + caml_failwith("Interface closed"); - intf->server_features = Int_val(v); + intf->server_features = Int_val(v); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value ml_interface_get_server_features(value interface) { - CAMLparam1(interface); - struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; + CAMLparam1(interface); + struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; - CAMLreturn(Val_int (intf->server_features)); + CAMLreturn(Val_int (intf->server_features)); } CAMLprim value ml_interface_close(value interface) { - CAMLparam1(interface); - struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; - int i; + CAMLparam1(interface); + struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr; + int i; - intf->req_cons = intf->req_prod = intf->rsp_cons = intf->rsp_prod = 0; - /* Ensure the unused space is full of invalid xenstore packets. */ - for (i = 0; i < XENSTORE_RING_SIZE; i++) { - intf->req[i] = 0xff; /* XS_INVALID = 0xffff */ - intf->rsp[i] = 0xff; - } - xen_mb (); - intf->connection = XENSTORE_CONNECTED; - CAMLreturn(Val_unit); + intf->req_cons = intf->req_prod = intf->rsp_cons = intf->rsp_prod = 0; + /* Ensure the unused space is full of invalid xenstore packets. */ + for (i = 0; i < XENSTORE_RING_SIZE; i++) { + intf->req[i] = 0xff; /* XS_INVALID = 0xffff */ + intf->rsp[i] = 0xff; + } + xen_mb (); + intf->connection = XENSTORE_CONNECTED; + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/libs/xc/abi-check b/tools/ocaml/libs/xc/abi-check index 3cbdec582f..dc5bfd6cd8 100755 --- a/tools/ocaml/libs/xc/abi-check +++ b/tools/ocaml/libs/xc/abi-check @@ -39,7 +39,7 @@ while () { } } else { $cline++; - m{^\s+/\* \s+ ! \s+ (.*?) \s* \*/\s*$}x or + m{^\s*/\*\s+! \s+ (.*?) \s* \*/\s*$}x or die "at line $cline of annotation, did not expect $_ ?"; my @vals = split /\s+/, $1; if ($cline == 1 && !@vals) { diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml index 28ed642231..2ad4a671a5 100644 --- a/tools/ocaml/libs/xc/xenctrl.ml +++ b/tools/ocaml/libs/xc/xenctrl.ml @@ -20,157 +20,157 @@ type domid = int (* ** xenctrl.h ** *) type vcpuinfo = -{ - online: bool; - blocked: bool; - running: bool; - cputime: int64; - cpumap: int32; -} + { + online: bool; + blocked: bool; + running: bool; + cputime: int64; + cpumap: int32; + } type xen_arm_arch_domainconfig = -{ - gic_version: int; - nr_spis: int; - clock_frequency: int32; -} + { + gic_version: int; + nr_spis: int; + clock_frequency: int32; + } type x86_arch_emulation_flags = - | X86_EMU_LAPIC - | X86_EMU_HPET - | X86_EMU_PM - | X86_EMU_RTC - | X86_EMU_IOAPIC - | X86_EMU_PIC - | X86_EMU_VGA - | X86_EMU_IOMMU - | X86_EMU_PIT - | X86_EMU_USE_PIRQ - | X86_EMU_VPCI + | X86_EMU_LAPIC + | X86_EMU_HPET + | X86_EMU_PM + | X86_EMU_RTC + | X86_EMU_IOAPIC + | X86_EMU_PIC + | X86_EMU_VGA + | X86_EMU_IOMMU + | X86_EMU_PIT + | X86_EMU_USE_PIRQ + | X86_EMU_VPCI type x86_arch_misc_flags = - | X86_MSR_RELAXED - | X86_ASSISTED_XAPIC - | X86_ASSISTED_X2APIC + | X86_MSR_RELAXED + | X86_ASSISTED_XAPIC + | X86_ASSISTED_X2APIC type xen_x86_arch_domainconfig = -{ - emulation_flags: x86_arch_emulation_flags list; - misc_flags: x86_arch_misc_flags list; -} + { + emulation_flags: x86_arch_emulation_flags list; + misc_flags: x86_arch_misc_flags list; + } type arch_domainconfig = - | ARM of xen_arm_arch_domainconfig - | X86 of xen_x86_arch_domainconfig + | ARM of xen_arm_arch_domainconfig + | X86 of xen_x86_arch_domainconfig type domain_create_flag = - | CDF_HVM - | CDF_HAP - | CDF_S3_INTEGRITY - | CDF_OOS_OFF - | CDF_XS_DOMAIN - | CDF_IOMMU - | CDF_NESTED_VIRT - | CDF_VPMU + | CDF_HVM + | CDF_HAP + | CDF_S3_INTEGRITY + | CDF_OOS_OFF + | CDF_XS_DOMAIN + | CDF_IOMMU + | CDF_NESTED_VIRT + | CDF_VPMU type domain_create_iommu_opts = - | IOMMU_NO_SHAREPT + | IOMMU_NO_SHAREPT type domctl_create_config = -{ - ssidref: int32; - handle: string; - flags: domain_create_flag list; - iommu_opts: domain_create_iommu_opts list; - max_vcpus: int; - max_evtchn_port: int; - max_grant_frames: int; - max_maptrack_frames: int; - max_grant_version: int; - cpupool_id: int32; - arch: arch_domainconfig; -} + { + ssidref: int32; + handle: string; + flags: domain_create_flag list; + iommu_opts: domain_create_iommu_opts list; + max_vcpus: int; + max_evtchn_port: int; + max_grant_frames: int; + max_maptrack_frames: int; + max_grant_version: int; + cpupool_id: int32; + arch: arch_domainconfig; + } type domaininfo = -{ - domid : domid; - dying : bool; - shutdown : bool; - paused : bool; - blocked : bool; - running : bool; - hvm_guest : bool; - shutdown_code : int; - total_memory_pages: nativeint; - max_memory_pages : nativeint; - shared_info_frame : int64; - cpu_time : int64; - nr_online_vcpus : int; - max_vcpu_id : int; - ssidref : int32; - handle : int array; - arch_config : arch_domainconfig; -} + { + domid : domid; + dying : bool; + shutdown : bool; + paused : bool; + blocked : bool; + running : bool; + hvm_guest : bool; + shutdown_code : int; + total_memory_pages: nativeint; + max_memory_pages : nativeint; + shared_info_frame : int64; + cpu_time : int64; + nr_online_vcpus : int; + max_vcpu_id : int; + ssidref : int32; + handle : int array; + arch_config : arch_domainconfig; + } type sched_control = -{ - weight : int; - cap : int; -} + { + weight : int; + cap : int; + } type physinfo_cap_flag = - | CAP_HVM - | CAP_PV - | CAP_DirectIO - | CAP_HAP - | CAP_Shadow - | CAP_IOMMU_HAP_PT_SHARE - | CAP_Vmtrace - | CAP_Vpmu - | CAP_Gnttab_v1 - | CAP_Gnttab_v2 + | CAP_HVM + | CAP_PV + | CAP_DirectIO + | CAP_HAP + | CAP_Shadow + | CAP_IOMMU_HAP_PT_SHARE + | CAP_Vmtrace + | CAP_Vpmu + | CAP_Gnttab_v1 + | CAP_Gnttab_v2 type arm_physinfo_cap_flag type x86_physinfo_cap_flag = - | CAP_X86_ASSISTED_XAPIC - | CAP_X86_ASSISTED_X2APIC + | CAP_X86_ASSISTED_XAPIC + | CAP_X86_ASSISTED_X2APIC type arch_physinfo_cap_flags = - | ARM of arm_physinfo_cap_flag list - | X86 of x86_physinfo_cap_flag list + | ARM of arm_physinfo_cap_flag list + | X86 of x86_physinfo_cap_flag list type physinfo = -{ - threads_per_core : int; - cores_per_socket : int; - nr_cpus : int; - max_node_id : int; - cpu_khz : int; - total_pages : nativeint; - free_pages : nativeint; - scrub_pages : nativeint; - (* XXX hw_cap *) - capabilities : physinfo_cap_flag list; - max_nr_cpus : int; - arch_capabilities : arch_physinfo_cap_flags; -} + { + threads_per_core : int; + cores_per_socket : int; + nr_cpus : int; + max_node_id : int; + cpu_khz : int; + total_pages : nativeint; + free_pages : nativeint; + scrub_pages : nativeint; + (* XXX hw_cap *) + capabilities : physinfo_cap_flag list; + max_nr_cpus : int; + arch_capabilities : arch_physinfo_cap_flags; + } type version = -{ - major : int; - minor : int; - extra : string; -} + { + major : int; + minor : int; + extra : string; + } type compile_info = -{ - compiler : string; - compile_by : string; - compile_domain : string; - compile_date : string; -} + { + compiler : string; + compile_by : string; + compile_domain : string; + compile_date : string; + } type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Watchdog | Soft_reset @@ -186,34 +186,34 @@ let handle = ref None let get_handle () = !handle let close_handle () = - match !handle with - | Some h -> handle := None; interface_close h - | None -> () + match !handle with + | Some h -> handle := None; interface_close h + | None -> () let with_intf f = - match !handle with - | Some h -> f h - | None -> - let h = - try interface_open () with - | e -> - let msg = Printexc.to_string e in - failwith ("failed to open xenctrl: "^msg) - in - handle := Some h; - f h + match !handle with + | Some h -> f h + | None -> + let h = + try interface_open () with + | e -> + let msg = Printexc.to_string e in + failwith ("failed to open xenctrl: "^msg) + in + handle := Some h; + f h external domain_create_stub: handle -> domid -> domctl_create_config -> domid - = "stub_xc_domain_create" + = "stub_xc_domain_create" let domain_create handle ?(domid=0) config = - domain_create_stub handle domid config + domain_create_stub handle domid config external domain_sethandle: handle -> domid -> string -> unit - = "stub_xc_domain_sethandle" + = "stub_xc_domain_sethandle" external domain_max_vcpus: handle -> domid -> int -> unit - = "stub_xc_domain_max_vcpus" + = "stub_xc_domain_max_vcpus" external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause" external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause" @@ -221,54 +221,54 @@ external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fa external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy" external domain_shutdown: handle -> domid -> shutdown_reason -> unit - = "stub_xc_domain_shutdown" + = "stub_xc_domain_shutdown" external _domain_getinfolist: handle -> domid -> int -> domaininfo list - = "stub_xc_domain_getinfolist" + = "stub_xc_domain_getinfolist" let domain_getinfolist handle first_domain = - let nb = 2 in - let last_domid l = (List.hd l).domid + 1 in - let rec __getlist from = - let l = _domain_getinfolist handle from nb in - (if List.length l = nb then __getlist (last_domid l) else []) @ l - in - List.rev (__getlist first_domain) + let nb = 2 in + let last_domid l = (List.hd l).domid + 1 in + let rec __getlist from = + let l = _domain_getinfolist handle from nb in + (if List.length l = nb then __getlist (last_domid l) else []) @ l + in + List.rev (__getlist first_domain) external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo" external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo - = "stub_xc_vcpu_getinfo" + = "stub_xc_vcpu_getinfo" external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit - = "stub_xc_domain_ioport_permission" + = "stub_xc_domain_ioport_permission" external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit - = "stub_xc_domain_iomem_permission" + = "stub_xc_domain_iomem_permission" external domain_irq_permission: handle -> domid -> int -> bool -> unit - = "stub_xc_domain_irq_permission" + = "stub_xc_domain_irq_permission" external vcpu_affinity_set: handle -> domid -> int -> bool array -> unit - = "stub_xc_vcpu_setaffinity" + = "stub_xc_vcpu_setaffinity" external vcpu_affinity_get: handle -> domid -> int -> bool array - = "stub_xc_vcpu_getaffinity" + = "stub_xc_vcpu_getaffinity" external vcpu_context_get: handle -> domid -> int -> string - = "stub_xc_vcpu_context_get" + = "stub_xc_vcpu_context_get" external sched_id: handle -> int = "stub_xc_sched_id" external sched_credit_domain_set: handle -> domid -> sched_control -> unit - = "stub_sched_credit_domain_set" + = "stub_sched_credit_domain_set" external sched_credit_domain_get: handle -> domid -> sched_control - = "stub_sched_credit_domain_get" + = "stub_sched_credit_domain_get" external shadow_allocation_set: handle -> domid -> int -> unit - = "stub_shadow_allocation_set" + = "stub_shadow_allocation_set" external shadow_allocation_get: handle -> domid -> int - = "stub_shadow_allocation_get" + = "stub_shadow_allocation_get" external evtchn_alloc_unbound: handle -> domid -> domid -> int - = "stub_xc_evtchn_alloc_unbound" + = "stub_xc_evtchn_alloc_unbound" external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset" external readconsolering: handle -> string = "stub_xc_readconsolering" @@ -278,26 +278,26 @@ external physinfo: handle -> physinfo = "stub_xc_physinfo" external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info" external domain_setmaxmem: handle -> domid -> int64 -> unit - = "stub_xc_domain_setmaxmem" + = "stub_xc_domain_setmaxmem" external domain_set_memmap_limit: handle -> domid -> int64 -> unit - = "stub_xc_domain_set_memmap_limit" + = "stub_xc_domain_set_memmap_limit" external domain_memory_increase_reservation: handle -> domid -> int64 -> unit - = "stub_xc_domain_memory_increase_reservation" + = "stub_xc_domain_memory_increase_reservation" external map_foreign_range: handle -> domid -> int - -> nativeint -> Xenmmap.mmap_interface - = "stub_map_foreign_range" + -> nativeint -> Xenmmap.mmap_interface + = "stub_map_foreign_range" external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit - = "stub_xc_domain_assign_device" + = "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit - = "stub_xc_domain_deassign_device" + = "stub_xc_domain_deassign_device" external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool - = "stub_xc_domain_test_assign_device" + = "stub_xc_domain_test_assign_device" external version: handle -> version = "stub_xc_version_version" external version_compile_info: handle -> compile_info - = "stub_xc_version_compile_info" + = "stub_xc_version_compile_info" external version_changeset: handle -> string = "stub_xc_version_changeset" external version_capabilities: handle -> string = "stub_xc_version_capabilities" @@ -312,7 +312,7 @@ external watchdog : handle -> int -> int32 -> int (** Convert the given number of pages to an amount in KiB, rounded up. - *) +*) external pages_to_kib : int64 -> int64 = "stub_pages_to_kib" let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli index c2076d60c9..dd8d0aefcf 100644 --- a/tools/ocaml/libs/xc/xenctrl.mli +++ b/tools/ocaml/libs/xc/xenctrl.mli @@ -187,11 +187,11 @@ external domain_getinfo : handle -> domid -> domaininfo external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo = "stub_xc_vcpu_getinfo" external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit - = "stub_xc_domain_ioport_permission" + = "stub_xc_domain_ioport_permission" external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit - = "stub_xc_domain_iomem_permission" + = "stub_xc_domain_iomem_permission" external domain_irq_permission: handle -> domid -> int -> bool -> unit - = "stub_xc_domain_irq_permission" + = "stub_xc_domain_irq_permission" external vcpu_affinity_set : handle -> domid -> int -> bool array -> unit = "stub_xc_vcpu_setaffinity" external vcpu_affinity_get : handle -> domid -> int -> bool array @@ -226,11 +226,11 @@ external map_foreign_range : = "stub_map_foreign_range" external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit - = "stub_xc_domain_assign_device" + = "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit - = "stub_xc_domain_deassign_device" + = "stub_xc_domain_deassign_device" external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool - = "stub_xc_domain_test_assign_device" + = "stub_xc_domain_test_assign_device" external version : handle -> version = "stub_xc_version_version" external version_compile_info : handle -> compile_info diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c b/tools/ocaml/libs/xc/xenctrl_stubs.c index 8cd11060ec..e2d897581f 100644 --- a/tools/ocaml/libs/xc/xenctrl_stubs.c +++ b/tools/ocaml/libs/xc/xenctrl_stubs.c @@ -45,71 +45,71 @@ #endif #define string_of_option_array(array, index) \ - ((Field(array, index) == Val_none) ? NULL : String_val(Field(Field(array, index), 0))) + ((Field(array, index) == Val_none) ? NULL : String_val(Field(Field(array, index), 0))) static void Noreturn failwith_xc(xc_interface *xch) { - char error_str[XC_MAX_ERROR_MSG_LEN + 6]; - if (xch) { - const xc_error *error = xc_get_last_error(xch); - if (error->code == XC_ERROR_NONE) - snprintf(error_str, sizeof(error_str), - "%d: %s", errno, strerror(errno)); - else - snprintf(error_str, sizeof(error_str), - "%d: %s: %s", error->code, - xc_error_code_to_desc(error->code), - error->message); - } else { - snprintf(error_str, sizeof(error_str), - "Unable to open XC interface"); - } - caml_raise_with_string(*caml_named_value("xc.error"), error_str); + char error_str[XC_MAX_ERROR_MSG_LEN + 6]; + if (xch) { + const xc_error *error = xc_get_last_error(xch); + if (error->code == XC_ERROR_NONE) + snprintf(error_str, sizeof(error_str), + "%d: %s", errno, strerror(errno)); + else + snprintf(error_str, sizeof(error_str), + "%d: %s: %s", error->code, + xc_error_code_to_desc(error->code), + error->message); + } else { + snprintf(error_str, sizeof(error_str), + "Unable to open XC interface"); + } + caml_raise_with_string(*caml_named_value("xc.error"), error_str); } CAMLprim value stub_xc_interface_open(void) { - CAMLparam0(); - CAMLlocal1(result); + CAMLparam0(); + CAMLlocal1(result); - result = caml_alloc(1, Abstract_tag); - /* Don't assert XC_OPENFLAG_NON_REENTRANT because these bindings - * do not prevent re-entrancy to libxc */ - _H(result) = xc_interface_open(NULL, NULL, 0); - if (_H(result) == NULL) - failwith_xc(NULL); - CAMLreturn(result); + result = caml_alloc(1, Abstract_tag); + /* Don't assert XC_OPENFLAG_NON_REENTRANT because these bindings + * do not prevent re-entrancy to libxc */ + _H(result) = xc_interface_open(NULL, NULL, 0); + if (_H(result) == NULL) + failwith_xc(NULL); + CAMLreturn(result); } CAMLprim value stub_xc_interface_close(value xch) { - CAMLparam1(xch); + CAMLparam1(xch); - caml_enter_blocking_section(); - xc_interface_close(_H(xch)); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + xc_interface_close(_H(xch)); + caml_leave_blocking_section(); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static void domain_handle_of_uuid_string(xen_domain_handle_t h, - const char *uuid) + const char *uuid) { #define X "%02"SCNx8 #define UUID_FMT (X X X X "-" X X "-" X X "-" X X "-" X X X X X X) - if ( sscanf(uuid, UUID_FMT, &h[0], &h[1], &h[2], &h[3], &h[4], - &h[5], &h[6], &h[7], &h[8], &h[9], &h[10], &h[11], - &h[12], &h[13], &h[14], &h[15]) != 16 ) - { - char buf[128]; + if ( sscanf(uuid, UUID_FMT, &h[0], &h[1], &h[2], &h[3], &h[4], + &h[5], &h[6], &h[7], &h[8], &h[9], &h[10], &h[11], + &h[12], &h[13], &h[14], &h[15]) != 16 ) + { + char buf[128]; - snprintf(buf, sizeof(buf), - "Xc.int_array_of_uuid_string: %s", uuid); + snprintf(buf, sizeof(buf), + "Xc.int_array_of_uuid_string: %s", uuid); - caml_invalid_argument(buf); - } + caml_invalid_argument(buf); + } #undef X } @@ -121,13 +121,13 @@ static void domain_handle_of_uuid_string(xen_domain_handle_t h, static value c_bitmap_to_ocaml_list /* ! */ /* - * All calls to this function must be in a form suitable - * for xenctrl_abi_check. The parsing there is ad-hoc. - */ + * All calls to this function must be in a form suitable + * for xenctrl_abi_check. The parsing there is ad-hoc. + */ (unsigned int bitmap) { - CAMLparam0(); - CAMLlocal2(list, tmp); + CAMLparam0(); + CAMLlocal2(list, tmp); #if defined(__i386__) || defined(__x86_64__) /* @@ -144,43 +144,43 @@ static value c_bitmap_to_ocaml_list #include "xenctrl_abi_check.h" #endif - list = tmp = Val_emptylist; + list = tmp = Val_emptylist; - for ( unsigned int i = 0; bitmap; i++, bitmap >>= 1 ) - { - if ( !(bitmap & 1) ) - continue; + for ( unsigned int i = 0; bitmap; i++, bitmap >>= 1 ) + { + if ( !(bitmap & 1) ) + continue; - tmp = caml_alloc_small(2, Tag_cons); - Field(tmp, 0) = Val_int(i); - Field(tmp, 1) = list; - list = tmp; - } + tmp = caml_alloc_small(2, Tag_cons); + Field(tmp, 0) = Val_int(i); + Field(tmp, 1) = list; + list = tmp; + } - CAMLreturn(list); + CAMLreturn(list); } static unsigned int ocaml_list_to_c_bitmap(value l) /* ! */ /* - * All calls to this function must be in a form suitable - * for xenctrl_abi_check. The parsing there is ad-hoc. - */ + * All calls to this function must be in a form suitable + * for xenctrl_abi_check. The parsing there is ad-hoc. + */ { - unsigned int val = 0; + unsigned int val = 0; - for ( ; l != Val_none; l = Field(l, 1) ) - val |= 1u << Int_val(Field(l, 0)); + for ( ; l != Val_none; l = Field(l, 1) ) + val |= 1u << Int_val(Field(l, 0)); - return val; + return val; } CAMLprim value stub_xc_domain_create(value xch, value wanted_domid, value config) { - CAMLparam3(xch, wanted_domid, config); - CAMLlocal2(l, arch_domconfig); + CAMLparam3(xch, wanted_domid, config); + CAMLlocal2(l, arch_domconfig); - /* Mnemonics for the named fields inside domctl_create_config */ + /* Mnemonics for the named fields inside domctl_create_config */ #define VAL_SSIDREF Field(config, 0) #define VAL_HANDLE Field(config, 1) #define VAL_FLAGS Field(config, 2) @@ -193,69 +193,69 @@ CAMLprim value stub_xc_domain_create(value xch, value wanted_domid, value config #define VAL_CPUPOOL_ID Field(config, 9) #define VAL_ARCH Field(config, 10) - uint32_t domid = Int_val(wanted_domid); - int result; - struct xen_domctl_createdomain cfg = { - .ssidref = Int32_val(VAL_SSIDREF), - .max_vcpus = Int_val(VAL_MAX_VCPUS), - .max_evtchn_port = Int_val(VAL_MAX_EVTCHN_PORT), - .max_grant_frames = Int_val(VAL_MAX_GRANT_FRAMES), - .max_maptrack_frames = Int_val(VAL_MAX_MAPTRACK_FRAMES), - .grant_opts = - XEN_DOMCTL_GRANT_version(Int_val(VAL_MAX_GRANT_VERSION)), - .cpupool_id = Int32_val(VAL_CPUPOOL_ID), - }; + uint32_t domid = Int_val(wanted_domid); + int result; + struct xen_domctl_createdomain cfg = { + .ssidref = Int32_val(VAL_SSIDREF), + .max_vcpus = Int_val(VAL_MAX_VCPUS), + .max_evtchn_port = Int_val(VAL_MAX_EVTCHN_PORT), + .max_grant_frames = Int_val(VAL_MAX_GRANT_FRAMES), + .max_maptrack_frames = Int_val(VAL_MAX_MAPTRACK_FRAMES), + .grant_opts = + XEN_DOMCTL_GRANT_version(Int_val(VAL_MAX_GRANT_VERSION)), + .cpupool_id = Int32_val(VAL_CPUPOOL_ID), + }; - domain_handle_of_uuid_string(cfg.handle, String_val(VAL_HANDLE)); + domain_handle_of_uuid_string(cfg.handle, String_val(VAL_HANDLE)); - cfg.flags = ocaml_list_to_c_bitmap - /* ! domain_create_flag CDF_ lc */ - /* ! XEN_DOMCTL_CDF_ XEN_DOMCTL_CDF_MAX max */ - (VAL_FLAGS); + cfg.flags = ocaml_list_to_c_bitmap + /* ! domain_create_flag CDF_ lc */ + /* ! XEN_DOMCTL_CDF_ XEN_DOMCTL_CDF_MAX max */ + (VAL_FLAGS); - cfg.iommu_opts = ocaml_list_to_c_bitmap - /* ! domain_create_iommu_opts IOMMU_ lc */ - /* ! XEN_DOMCTL_IOMMU_ XEN_DOMCTL_IOMMU_MAX max */ - (VAL_IOMMU_OPTS); + cfg.iommu_opts = ocaml_list_to_c_bitmap + /* ! domain_create_iommu_opts IOMMU_ lc */ + /* ! XEN_DOMCTL_IOMMU_ XEN_DOMCTL_IOMMU_MAX max */ + (VAL_IOMMU_OPTS); - arch_domconfig = Field(VAL_ARCH, 0); - switch ( Tag_val(VAL_ARCH) ) - { - case 0: /* ARM - nothing to do */ - caml_failwith("Unhandled: ARM"); - break; + arch_domconfig = Field(VAL_ARCH, 0); + switch ( Tag_val(VAL_ARCH) ) + { + case 0: /* ARM - nothing to do */ + caml_failwith("Unhandled: ARM"); + break; - case 1: /* X86 - emulation flags in the block */ + case 1: /* X86 - emulation flags in the block */ #if defined(__i386__) || defined(__x86_64__) - /* Quick & dirty check for ABI changes. */ - BUILD_BUG_ON(sizeof(cfg) != 64); + /* Quick & dirty check for ABI changes. */ + BUILD_BUG_ON(sizeof(cfg) != 64); /* Mnemonics for the named fields inside xen_x86_arch_domainconfig */ #define VAL_EMUL_FLAGS Field(arch_domconfig, 0) #define VAL_MISC_FLAGS Field(arch_domconfig, 1) - cfg.arch.emulation_flags = ocaml_list_to_c_bitmap - /* ! x86_arch_emulation_flags X86_EMU_ none */ - /* ! XEN_X86_EMU_ XEN_X86_EMU_ALL all */ - (VAL_EMUL_FLAGS); + cfg.arch.emulation_flags = ocaml_list_to_c_bitmap + /* ! x86_arch_emulation_flags X86_EMU_ none */ + /* ! XEN_X86_EMU_ XEN_X86_EMU_ALL all */ + (VAL_EMUL_FLAGS); - cfg.arch.misc_flags = ocaml_list_to_c_bitmap - /* ! x86_arch_misc_flags X86_ none */ - /* ! XEN_X86_ XEN_X86_MISC_FLAGS_MAX max */ - (VAL_MISC_FLAGS); + cfg.arch.misc_flags = ocaml_list_to_c_bitmap + /* ! x86_arch_misc_flags X86_ none */ + /* ! XEN_X86_ XEN_X86_MISC_FLAGS_MAX max */ + (VAL_MISC_FLAGS); #undef VAL_MISC_FLAGS #undef VAL_EMUL_FLAGS #else - caml_failwith("Unhandled: x86"); + caml_failwith("Unhandled: x86"); #endif - break; + break; - default: - caml_failwith("Unhandled domconfig type"); - } + default: + caml_failwith("Unhandled domconfig type"); + } #undef VAL_ARCH #undef VAL_CPUPOOL_ID @@ -269,875 +269,875 @@ CAMLprim value stub_xc_domain_create(value xch, value wanted_domid, value config #undef VAL_HANDLE #undef VAL_SSIDREF - caml_enter_blocking_section(); - result = xc_domain_create(_H(xch), &domid, &cfg); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result = xc_domain_create(_H(xch), &domid, &cfg); + caml_leave_blocking_section(); - if (result < 0) - failwith_xc(_H(xch)); + if (result < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_int(domid)); + CAMLreturn(Val_int(domid)); } CAMLprim value stub_xc_domain_max_vcpus(value xch, value domid, value max_vcpus) { - CAMLparam3(xch, domid, max_vcpus); - int r; + CAMLparam3(xch, domid, max_vcpus); + int r; - r = xc_domain_max_vcpus(_H(xch), _D(domid), Int_val(max_vcpus)); - if (r) - failwith_xc(_H(xch)); + r = xc_domain_max_vcpus(_H(xch), _D(domid), Int_val(max_vcpus)); + if (r) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_xc_domain_sethandle(value xch, value domid, value handle) { - CAMLparam3(xch, domid, handle); - xen_domain_handle_t h; - int i; + CAMLparam3(xch, domid, handle); + xen_domain_handle_t h; + int i; - domain_handle_of_uuid_string(h, String_val(handle)); + domain_handle_of_uuid_string(h, String_val(handle)); - i = xc_domain_sethandle(_H(xch), _D(domid), h); - if (i) - failwith_xc(_H(xch)); + i = xc_domain_sethandle(_H(xch), _D(domid), h); + if (i) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static value dom_op(value xch, value domid, int (*fn)(xc_interface *, uint32_t)) { - CAMLparam2(xch, domid); - int result; + CAMLparam2(xch, domid); + int result; - uint32_t c_domid = _D(domid); + uint32_t c_domid = _D(domid); - caml_enter_blocking_section(); - result = fn(_H(xch), c_domid); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result = fn(_H(xch), c_domid); + caml_leave_blocking_section(); if (result) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_pause(value xch, value domid) { - return dom_op(xch, domid, xc_domain_pause); + return dom_op(xch, domid, xc_domain_pause); } CAMLprim value stub_xc_domain_unpause(value xch, value domid) { - return dom_op(xch, domid, xc_domain_unpause); + return dom_op(xch, domid, xc_domain_unpause); } CAMLprim value stub_xc_domain_destroy(value xch, value domid) { - return dom_op(xch, domid, xc_domain_destroy); + return dom_op(xch, domid, xc_domain_destroy); } CAMLprim value stub_xc_domain_resume_fast(value xch, value domid) { - CAMLparam2(xch, domid); - int result; + CAMLparam2(xch, domid); + int result; - uint32_t c_domid = _D(domid); + uint32_t c_domid = _D(domid); - caml_enter_blocking_section(); - result = xc_domain_resume(_H(xch), c_domid, 1); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + result = xc_domain_resume(_H(xch), c_domid, 1); + caml_leave_blocking_section(); if (result) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_shutdown(value xch, value domid, value reason) { - CAMLparam3(xch, domid, reason); - int ret; + CAMLparam3(xch, domid, reason); + int ret; - ret = xc_domain_shutdown(_H(xch), _D(domid), Int_val(reason)); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_domain_shutdown(_H(xch), _D(domid), Int_val(reason)); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static value alloc_domaininfo(xc_domaininfo_t * info) { - CAMLparam0(); - CAMLlocal5(result, tmp, arch_config, x86_arch_config, emul_list); - int i; + CAMLparam0(); + CAMLlocal5(result, tmp, arch_config, x86_arch_config, emul_list); + int i; - result = caml_alloc_tuple(17); + result = caml_alloc_tuple(17); - Store_field(result, 0, Val_int(info->domain)); - Store_field(result, 1, Val_bool(info->flags & XEN_DOMINF_dying)); - Store_field(result, 2, Val_bool(info->flags & XEN_DOMINF_shutdown)); - Store_field(result, 3, Val_bool(info->flags & XEN_DOMINF_paused)); - Store_field(result, 4, Val_bool(info->flags & XEN_DOMINF_blocked)); - Store_field(result, 5, Val_bool(info->flags & XEN_DOMINF_running)); - Store_field(result, 6, Val_bool(info->flags & XEN_DOMINF_hvm_guest)); - Store_field(result, 7, Val_int((info->flags >> XEN_DOMINF_shutdownshift) - & XEN_DOMINF_shutdownmask)); - Store_field(result, 8, caml_copy_nativeint(info->tot_pages)); - Store_field(result, 9, caml_copy_nativeint(info->max_pages)); - Store_field(result, 10, caml_copy_int64(info->shared_info_frame)); - Store_field(result, 11, caml_copy_int64(info->cpu_time)); - Store_field(result, 12, Val_int(info->nr_online_vcpus)); - Store_field(result, 13, Val_int(info->max_vcpu_id)); - Store_field(result, 14, caml_copy_int32(info->ssidref)); + Store_field(result, 0, Val_int(info->domain)); + Store_field(result, 1, Val_bool(info->flags & XEN_DOMINF_dying)); + Store_field(result, 2, Val_bool(info->flags & XEN_DOMINF_shutdown)); + Store_field(result, 3, Val_bool(info->flags & XEN_DOMINF_paused)); + Store_field(result, 4, Val_bool(info->flags & XEN_DOMINF_blocked)); + Store_field(result, 5, Val_bool(info->flags & XEN_DOMINF_running)); + Store_field(result, 6, Val_bool(info->flags & XEN_DOMINF_hvm_guest)); + Store_field(result, 7, Val_int((info->flags >> XEN_DOMINF_shutdownshift) + & XEN_DOMINF_shutdownmask)); + Store_field(result, 8, caml_copy_nativeint(info->tot_pages)); + Store_field(result, 9, caml_copy_nativeint(info->max_pages)); + Store_field(result, 10, caml_copy_int64(info->shared_info_frame)); + Store_field(result, 11, caml_copy_int64(info->cpu_time)); + Store_field(result, 12, Val_int(info->nr_online_vcpus)); + Store_field(result, 13, Val_int(info->max_vcpu_id)); + Store_field(result, 14, caml_copy_int32(info->ssidref)); tmp = caml_alloc_small(16, 0); - for (i = 0; i < 16; i++) { - Field(tmp, i) = Val_int(info->handle[i]); - } + for (i = 0; i < 16; i++) { + Field(tmp, i) = Val_int(info->handle[i]); + } - Store_field(result, 15, tmp); + Store_field(result, 15, tmp); #if defined(__i386__) || defined(__x86_64__) - /* - * emulation_flags: x86_arch_emulation_flags list; - */ - emul_list = c_bitmap_to_ocaml_list - /* ! x86_arch_emulation_flags */ - (info->arch_config.emulation_flags); + /* + * emulation_flags: x86_arch_emulation_flags list; + */ + emul_list = c_bitmap_to_ocaml_list + /* ! x86_arch_emulation_flags */ + (info->arch_config.emulation_flags); - /* xen_x86_arch_domainconfig */ - x86_arch_config = caml_alloc_tuple(1); - Store_field(x86_arch_config, 0, emul_list); + /* xen_x86_arch_domainconfig */ + x86_arch_config = caml_alloc_tuple(1); + Store_field(x86_arch_config, 0, emul_list); - /* arch_config: arch_domainconfig */ - arch_config = caml_alloc_small(1, 1); + /* arch_config: arch_domainconfig */ + arch_config = caml_alloc_small(1, 1); - Store_field(arch_config, 0, x86_arch_config); + Store_field(arch_config, 0, x86_arch_config); - Store_field(result, 16, arch_config); + Store_field(result, 16, arch_config); #endif - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_xc_domain_getinfolist(value xch, value first_domain, value nb) { - CAMLparam3(xch, first_domain, nb); - CAMLlocal2(result, temp); - xc_domaininfo_t * info; - int i, ret, toalloc, retval; - unsigned int c_max_domains; - uint32_t c_first_domain; + CAMLparam3(xch, first_domain, nb); + CAMLlocal2(result, temp); + xc_domaininfo_t * info; + int i, ret, toalloc, retval; + unsigned int c_max_domains; + uint32_t c_first_domain; - /* get the minimum number of allocate byte we need and bump it up to page boundary */ - toalloc = (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff; - ret = posix_memalign((void **) ((void *) &info), 4096, toalloc); - if (ret) - caml_raise_out_of_memory(); + /* get the minimum number of allocate byte we need and bump it up to page boundary */ + toalloc = (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff; + ret = posix_memalign((void **) ((void *) &info), 4096, toalloc); + if (ret) + caml_raise_out_of_memory(); - result = temp = Val_emptylist; + result = temp = Val_emptylist; - c_first_domain = _D(first_domain); - c_max_domains = Int_val(nb); - caml_enter_blocking_section(); - retval = xc_domain_getinfolist(_H(xch), c_first_domain, - c_max_domains, info); - caml_leave_blocking_section(); + c_first_domain = _D(first_domain); + c_max_domains = Int_val(nb); + caml_enter_blocking_section(); + retval = xc_domain_getinfolist(_H(xch), c_first_domain, + c_max_domains, info); + caml_leave_blocking_section(); - if (retval < 0) { - free(info); - failwith_xc(_H(xch)); - } - for (i = 0; i < retval; i++) { - result = caml_alloc_small(2, Tag_cons); - Field(result, 0) = Val_int(0); - Field(result, 1) = temp; - temp = result; + if (retval < 0) { + free(info); + failwith_xc(_H(xch)); + } + for (i = 0; i < retval; i++) { + result = caml_alloc_small(2, Tag_cons); + Field(result, 0) = Val_int(0); + Field(result, 1) = temp; + temp = result; - Store_field(result, 0, alloc_domaininfo(info + i)); - } + Store_field(result, 0, alloc_domaininfo(info + i)); + } - free(info); - CAMLreturn(result); + free(info); + CAMLreturn(result); } CAMLprim value stub_xc_domain_getinfo(value xch, value domid) { - CAMLparam2(xch, domid); - CAMLlocal1(result); - xc_domaininfo_t info; - int ret; + CAMLparam2(xch, domid); + CAMLlocal1(result); + xc_domaininfo_t info; + int ret; - ret = xc_domain_getinfolist(_H(xch), _D(domid), 1, &info); - if (ret != 1) - failwith_xc(_H(xch)); - if (info.domain != _D(domid)) - failwith_xc(_H(xch)); + ret = xc_domain_getinfolist(_H(xch), _D(domid), 1, &info); + if (ret != 1) + failwith_xc(_H(xch)); + if (info.domain != _D(domid)) + failwith_xc(_H(xch)); - result = alloc_domaininfo(&info); - CAMLreturn(result); + result = alloc_domaininfo(&info); + CAMLreturn(result); } CAMLprim value stub_xc_vcpu_getinfo(value xch, value domid, value vcpu) { - CAMLparam3(xch, domid, vcpu); - CAMLlocal1(result); - xc_vcpuinfo_t info; - int retval; + CAMLparam3(xch, domid, vcpu); + CAMLlocal1(result); + xc_vcpuinfo_t info; + int retval; - uint32_t c_domid = _D(domid); - uint32_t c_vcpu = Int_val(vcpu); - caml_enter_blocking_section(); - retval = xc_vcpu_getinfo(_H(xch), c_domid, - c_vcpu, &info); - caml_leave_blocking_section(); - if (retval < 0) - failwith_xc(_H(xch)); + uint32_t c_domid = _D(domid); + uint32_t c_vcpu = Int_val(vcpu); + caml_enter_blocking_section(); + retval = xc_vcpu_getinfo(_H(xch), c_domid, + c_vcpu, &info); + caml_leave_blocking_section(); + if (retval < 0) + failwith_xc(_H(xch)); - result = caml_alloc_tuple(5); - Store_field(result, 0, Val_bool(info.online)); - Store_field(result, 1, Val_bool(info.blocked)); - Store_field(result, 2, Val_bool(info.running)); - Store_field(result, 3, caml_copy_int64(info.cpu_time)); - Store_field(result, 4, caml_copy_int32(info.cpu)); + result = caml_alloc_tuple(5); + Store_field(result, 0, Val_bool(info.online)); + Store_field(result, 1, Val_bool(info.blocked)); + Store_field(result, 2, Val_bool(info.running)); + Store_field(result, 3, caml_copy_int64(info.cpu_time)); + Store_field(result, 4, caml_copy_int32(info.cpu)); - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_xc_vcpu_context_get(value xch, value domid, value cpu) { - CAMLparam3(xch, domid, cpu); - CAMLlocal1(context); - int ret; - vcpu_guest_context_any_t ctxt; + CAMLparam3(xch, domid, cpu); + CAMLlocal1(context); + int ret; + vcpu_guest_context_any_t ctxt; - ret = xc_vcpu_getcontext(_H(xch), _D(domid), Int_val(cpu), &ctxt); - if ( ret < 0 ) - failwith_xc(_H(xch)); + ret = xc_vcpu_getcontext(_H(xch), _D(domid), Int_val(cpu), &ctxt); + if ( ret < 0 ) + failwith_xc(_H(xch)); - context = caml_alloc_string(sizeof(ctxt)); - memcpy((char *) String_val(context), &ctxt.c, sizeof(ctxt.c)); + context = caml_alloc_string(sizeof(ctxt)); + memcpy((char *) String_val(context), &ctxt.c, sizeof(ctxt.c)); - CAMLreturn(context); + CAMLreturn(context); } static int get_cpumap_len(value xch, value cpumap) { - int ml_len = Wosize_val(cpumap); - int xc_len = xc_get_max_cpus(_H(xch)); + int ml_len = Wosize_val(cpumap); + int xc_len = xc_get_max_cpus(_H(xch)); - if (ml_len < xc_len) - return ml_len; - else - return xc_len; + if (ml_len < xc_len) + return ml_len; + else + return xc_len; } CAMLprim value stub_xc_vcpu_setaffinity(value xch, value domid, value vcpu, value cpumap) { - CAMLparam4(xch, domid, vcpu, cpumap); - int i, len = get_cpumap_len(xch, cpumap); - xc_cpumap_t c_cpumap; - int retval; + CAMLparam4(xch, domid, vcpu, cpumap); + int i, len = get_cpumap_len(xch, cpumap); + xc_cpumap_t c_cpumap; + int retval; - c_cpumap = xc_cpumap_alloc(_H(xch)); - if (c_cpumap == NULL) - failwith_xc(_H(xch)); + c_cpumap = xc_cpumap_alloc(_H(xch)); + if (c_cpumap == NULL) + failwith_xc(_H(xch)); - for (i=0; i= 0) { - size += count - 1; - if (size < count) - break; + while (count == size && ret >= 0) { + size += count - 1; + if (size < count) + break; - ptr = realloc(str, size); - if (!ptr) - break; + ptr = realloc(str, size); + if (!ptr) + break; - str = ptr + count; - count = size - count; + str = ptr + count; + count = size - count; - caml_enter_blocking_section(); - ret = xc_readconsolering(_H(xch), str, &count, 0, 1, &index); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = xc_readconsolering(_H(xch), str, &count, 0, 1, &index); + caml_leave_blocking_section(); - count += str - ptr; - str = ptr; - } + count += str - ptr; + str = ptr; + } - /* - * If we didn't break because of an overflow with size, and we have - * needed to realloc() ourself more space, update our tracking of the - * real console ring size. - */ - if (size > conring_size) - conring_size = size; + /* + * If we didn't break because of an overflow with size, and we have + * needed to realloc() ourself more space, update our tracking of the + * real console ring size. + */ + if (size > conring_size) + conring_size = size; - ring = caml_alloc_string(count); - memcpy((char *) String_val(ring), str, count); - free(str); + ring = caml_alloc_string(count); + memcpy((char *) String_val(ring), str, count); + free(str); - CAMLreturn(ring); + CAMLreturn(ring); } CAMLprim value stub_xc_send_debug_keys(value xch, value keys) { - CAMLparam2(xch, keys); - int r; + CAMLparam2(xch, keys); + int r; - r = xc_send_debug_keys(_H(xch), String_val(keys)); - if (r) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + r = xc_send_debug_keys(_H(xch), String_val(keys)); + if (r) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_physinfo(value xch) { - CAMLparam1(xch); - CAMLlocal4(physinfo, cap_list, arch_cap_flags, arch_cap_list); - xc_physinfo_t c_physinfo; - int r, arch_cap_flags_tag; + CAMLparam1(xch); + CAMLlocal4(physinfo, cap_list, arch_cap_flags, arch_cap_list); + xc_physinfo_t c_physinfo; + int r, arch_cap_flags_tag; - caml_enter_blocking_section(); - r = xc_physinfo(_H(xch), &c_physinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + r = xc_physinfo(_H(xch), &c_physinfo); + caml_leave_blocking_section(); - if (r) - failwith_xc(_H(xch)); + if (r) + failwith_xc(_H(xch)); - /* - * capabilities: physinfo_cap_flag list; - */ - cap_list = c_bitmap_to_ocaml_list - /* ! physinfo_cap_flag CAP_ lc */ - /* ! XEN_SYSCTL_PHYSCAP_ XEN_SYSCTL_PHYSCAP_MAX max */ - (c_physinfo.capabilities); + /* + * capabilities: physinfo_cap_flag list; + */ + cap_list = c_bitmap_to_ocaml_list + /* ! physinfo_cap_flag CAP_ lc */ + /* ! XEN_SYSCTL_PHYSCAP_ XEN_SYSCTL_PHYSCAP_MAX max */ + (c_physinfo.capabilities); - physinfo = caml_alloc_tuple(11); - Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core)); - Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket)); - Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus)); - Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id)); - Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz)); - Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages)); - Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages)); - Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages)); - Store_field(physinfo, 8, cap_list); - Store_field(physinfo, 9, Val_int(c_physinfo.max_cpu_id + 1)); + physinfo = caml_alloc_tuple(11); + Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core)); + Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket)); + Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus)); + Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id)); + Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz)); + Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages)); + Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages)); + Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages)); + Store_field(physinfo, 8, cap_list); + Store_field(physinfo, 9, Val_int(c_physinfo.max_cpu_id + 1)); #if defined(__i386__) || defined(__x86_64__) - arch_cap_list = c_bitmap_to_ocaml_list - /* ! x86_physinfo_cap_flag CAP_X86_ none */ - /* ! XEN_SYSCTL_PHYSCAP_X86_ XEN_SYSCTL_PHYSCAP_X86_MAX max */ - (c_physinfo.arch_capabilities); + arch_cap_list = c_bitmap_to_ocaml_list + /* ! x86_physinfo_cap_flag CAP_X86_ none */ + /* ! XEN_SYSCTL_PHYSCAP_X86_ XEN_SYSCTL_PHYSCAP_X86_MAX max */ + (c_physinfo.arch_capabilities); - arch_cap_flags_tag = 1; /* tag x86 */ + arch_cap_flags_tag = 1; /* tag x86 */ #else - caml_failwith("Unhandled architecture"); + caml_failwith("Unhandled architecture"); #endif - arch_cap_flags = caml_alloc_small(1, arch_cap_flags_tag); - Store_field(arch_cap_flags, 0, arch_cap_list); - Store_field(physinfo, 10, arch_cap_flags); + arch_cap_flags = caml_alloc_small(1, arch_cap_flags_tag); + Store_field(arch_cap_flags, 0, arch_cap_list); + Store_field(physinfo, 10, arch_cap_flags); - CAMLreturn(physinfo); + CAMLreturn(physinfo); } CAMLprim value stub_xc_pcpu_info(value xch, value nr_cpus) { - CAMLparam2(xch, nr_cpus); - CAMLlocal2(pcpus, v); - xc_cpuinfo_t *info; - int r, size; + CAMLparam2(xch, nr_cpus); + CAMLlocal2(pcpus, v); + xc_cpuinfo_t *info; + int r, size; - if (Int_val(nr_cpus) < 1) - caml_invalid_argument("nr_cpus"); + if (Int_val(nr_cpus) < 1) + caml_invalid_argument("nr_cpus"); - info = calloc(Int_val(nr_cpus) + 1, sizeof(*info)); - if (!info) - caml_raise_out_of_memory(); + info = calloc(Int_val(nr_cpus) + 1, sizeof(*info)); + if (!info) + caml_raise_out_of_memory(); - caml_enter_blocking_section(); - r = xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + r = xc_getcpuinfo(_H(xch), Int_val(nr_cpus), info, &size); + caml_leave_blocking_section(); - if (r) { - free(info); - failwith_xc(_H(xch)); - } + if (r) { + free(info); + failwith_xc(_H(xch)); + } - if (size > 0) { - int i; - pcpus = caml_alloc(size, 0); - for (i = 0; i < size; i++) { - v = caml_copy_int64(info[i].idletime); - caml_modify(&Field(pcpus, i), v); - } - } else - pcpus = Atom(0); - free(info); - CAMLreturn(pcpus); + if (size > 0) { + int i; + pcpus = caml_alloc(size, 0); + for (i = 0; i < size; i++) { + v = caml_copy_int64(info[i].idletime); + caml_modify(&Field(pcpus, i), v); + } + } else + pcpus = Atom(0); + free(info); + CAMLreturn(pcpus); } CAMLprim value stub_xc_domain_setmaxmem(value xch, value domid, value max_memkb) { - CAMLparam3(xch, domid, max_memkb); - int retval; + CAMLparam3(xch, domid, max_memkb); + int retval; - uint32_t c_domid = _D(domid); - unsigned int c_max_memkb = Int64_val(max_memkb); - caml_enter_blocking_section(); - retval = xc_domain_setmaxmem(_H(xch), c_domid, - c_max_memkb); - caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + uint32_t c_domid = _D(domid); + unsigned int c_max_memkb = Int64_val(max_memkb); + caml_enter_blocking_section(); + retval = xc_domain_setmaxmem(_H(xch), c_domid, + c_max_memkb); + caml_leave_blocking_section(); + if (retval) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_set_memmap_limit(value xch, value domid, value map_limitkb) { - CAMLparam3(xch, domid, map_limitkb); - unsigned long v; - int retval; + CAMLparam3(xch, domid, map_limitkb); + unsigned long v; + int retval; - v = Int64_val(map_limitkb); - retval = xc_domain_set_memmap_limit(_H(xch), _D(domid), v); - if (retval) - failwith_xc(_H(xch)); + v = Int64_val(map_limitkb); + retval = xc_domain_set_memmap_limit(_H(xch), _D(domid), v); + if (retval) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_memory_increase_reservation(value xch, value domid, value mem_kb) { - CAMLparam3(xch, domid, mem_kb); - int retval; + CAMLparam3(xch, domid, mem_kb); + int retval; - unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (XC_PAGE_SHIFT - 10); + unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (XC_PAGE_SHIFT - 10); - uint32_t c_domid = _D(domid); - caml_enter_blocking_section(); - retval = xc_domain_increase_reservation_exact(_H(xch), c_domid, - nr_extents, 0, 0, NULL); - caml_leave_blocking_section(); + uint32_t c_domid = _D(domid); + caml_enter_blocking_section(); + retval = xc_domain_increase_reservation_exact(_H(xch), c_domid, + nr_extents, 0, 0, NULL); + caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (retval) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_version_version(value xch) { - CAMLparam1(xch); - CAMLlocal1(result); - xen_extraversion_t extra; - long packed; - int retval; + CAMLparam1(xch); + CAMLlocal1(result); + xen_extraversion_t extra; + long packed; + int retval; - caml_enter_blocking_section(); - packed = xc_version(_H(xch), XENVER_version, NULL); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + packed = xc_version(_H(xch), XENVER_version, NULL); + caml_leave_blocking_section(); - if (packed < 0) - failwith_xc(_H(xch)); + if (packed < 0) + failwith_xc(_H(xch)); - caml_enter_blocking_section(); - retval = xc_version(_H(xch), XENVER_extraversion, &extra); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval = xc_version(_H(xch), XENVER_extraversion, &extra); + caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); - result = caml_alloc_tuple(3); + result = caml_alloc_tuple(3); - Store_field(result, 0, Val_int(packed >> 16)); - Store_field(result, 1, Val_int(packed & 0xffff)); - Store_field(result, 2, caml_copy_string(extra)); + Store_field(result, 0, Val_int(packed >> 16)); + Store_field(result, 1, Val_int(packed & 0xffff)); + Store_field(result, 2, caml_copy_string(extra)); - CAMLreturn(result); + CAMLreturn(result); } CAMLprim value stub_xc_version_compile_info(value xch) { - CAMLparam1(xch); - CAMLlocal1(result); - xen_compile_info_t ci; - int retval; + CAMLparam1(xch); + CAMLlocal1(result); + xen_compile_info_t ci; + int retval; - caml_enter_blocking_section(); - retval = xc_version(_H(xch), XENVER_compile_info, &ci); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval = xc_version(_H(xch), XENVER_compile_info, &ci); + caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); - result = caml_alloc_tuple(4); + result = caml_alloc_tuple(4); - Store_field(result, 0, caml_copy_string(ci.compiler)); - Store_field(result, 1, caml_copy_string(ci.compile_by)); - Store_field(result, 2, caml_copy_string(ci.compile_domain)); - Store_field(result, 3, caml_copy_string(ci.compile_date)); + Store_field(result, 0, caml_copy_string(ci.compiler)); + Store_field(result, 1, caml_copy_string(ci.compile_by)); + Store_field(result, 2, caml_copy_string(ci.compile_domain)); + Store_field(result, 3, caml_copy_string(ci.compile_date)); - CAMLreturn(result); + CAMLreturn(result); } static value xc_version_single_string(value xch, int code, void *info) { - CAMLparam1(xch); - int retval; + CAMLparam1(xch); + int retval; - caml_enter_blocking_section(); - retval = xc_version(_H(xch), code, info); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + retval = xc_version(_H(xch), code, info); + caml_leave_blocking_section(); - if (retval) - failwith_xc(_H(xch)); + if (retval) + failwith_xc(_H(xch)); - CAMLreturn(caml_copy_string((char *)info)); + CAMLreturn(caml_copy_string((char *)info)); } CAMLprim value stub_xc_version_changeset(value xch) { - xen_changeset_info_t ci; + xen_changeset_info_t ci; - return xc_version_single_string(xch, XENVER_changeset, &ci); + return xc_version_single_string(xch, XENVER_changeset, &ci); } CAMLprim value stub_xc_version_capabilities(value xch) { - xen_capabilities_info_t ci; + xen_capabilities_info_t ci; - return xc_version_single_string(xch, XENVER_capabilities, &ci); + return xc_version_single_string(xch, XENVER_capabilities, &ci); } CAMLprim value stub_pages_to_kib(value pages) { - CAMLparam1(pages); + CAMLparam1(pages); - CAMLreturn(caml_copy_int64(Int64_val(pages) << (XC_PAGE_SHIFT - 10))); + CAMLreturn(caml_copy_int64(Int64_val(pages) << (XC_PAGE_SHIFT - 10))); } CAMLprim value stub_map_foreign_range(value xch, value dom, value size, value mfn) { - CAMLparam4(xch, dom, size, mfn); - CAMLlocal1(result); - struct mmap_interface *intf; - uint32_t c_dom; - unsigned long c_mfn; + CAMLparam4(xch, dom, size, mfn); + CAMLlocal1(result); + struct mmap_interface *intf; + uint32_t c_dom; + unsigned long c_mfn; - result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); - intf = (struct mmap_interface *) result; + result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + intf = (struct mmap_interface *) result; - intf->len = Int_val(size); + intf->len = Int_val(size); - c_dom = _D(dom); - c_mfn = Nativeint_val(mfn); - caml_enter_blocking_section(); - intf->addr = xc_map_foreign_range(_H(xch), c_dom, - intf->len, PROT_READ|PROT_WRITE, - c_mfn); - caml_leave_blocking_section(); - if (!intf->addr) - caml_failwith("xc_map_foreign_range error"); - CAMLreturn(result); + c_dom = _D(dom); + c_mfn = Nativeint_val(mfn); + caml_enter_blocking_section(); + intf->addr = xc_map_foreign_range(_H(xch), c_dom, + intf->len, PROT_READ|PROT_WRITE, + c_mfn); + caml_leave_blocking_section(); + if (!intf->addr) + caml_failwith("xc_map_foreign_range error"); + CAMLreturn(result); } CAMLprim value stub_sched_credit_domain_get(value xch, value domid) { - CAMLparam2(xch, domid); - CAMLlocal1(sdom); - struct xen_domctl_sched_credit c_sdom; - int ret; + CAMLparam2(xch, domid); + CAMLlocal1(sdom); + struct xen_domctl_sched_credit c_sdom; + int ret; - caml_enter_blocking_section(); - ret = xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom); - caml_leave_blocking_section(); - if (ret != 0) - failwith_xc(_H(xch)); + caml_enter_blocking_section(); + ret = xc_sched_credit_domain_get(_H(xch), _D(domid), &c_sdom); + caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(_H(xch)); - sdom = caml_alloc_tuple(2); - Store_field(sdom, 0, Val_int(c_sdom.weight)); - Store_field(sdom, 1, Val_int(c_sdom.cap)); + sdom = caml_alloc_tuple(2); + Store_field(sdom, 0, Val_int(c_sdom.weight)); + Store_field(sdom, 1, Val_int(c_sdom.cap)); - CAMLreturn(sdom); + CAMLreturn(sdom); } CAMLprim value stub_sched_credit_domain_set(value xch, value domid, value sdom) { - CAMLparam3(xch, domid, sdom); - struct xen_domctl_sched_credit c_sdom; - int ret; + CAMLparam3(xch, domid, sdom); + struct xen_domctl_sched_credit c_sdom; + int ret; - c_sdom.weight = Int_val(Field(sdom, 0)); - c_sdom.cap = Int_val(Field(sdom, 1)); - caml_enter_blocking_section(); - ret = xc_sched_credit_domain_set(_H(xch), _D(domid), &c_sdom); - caml_leave_blocking_section(); - if (ret != 0) - failwith_xc(_H(xch)); + c_sdom.weight = Int_val(Field(sdom, 0)); + c_sdom.cap = Int_val(Field(sdom, 1)); + caml_enter_blocking_section(); + ret = xc_sched_credit_domain_set(_H(xch), _D(domid), &c_sdom); + caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_shadow_allocation_get(value xch, value domid) { - CAMLparam2(xch, domid); - CAMLlocal1(mb); - unsigned int c_mb; - int ret; + CAMLparam2(xch, domid); + CAMLlocal1(mb); + unsigned int c_mb; + int ret; - caml_enter_blocking_section(); - ret = xc_shadow_control(_H(xch), _D(domid), - XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION, - &c_mb, 0); - caml_leave_blocking_section(); - if (ret != 0) - failwith_xc(_H(xch)); + caml_enter_blocking_section(); + ret = xc_shadow_control(_H(xch), _D(domid), + XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION, + &c_mb, 0); + caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(_H(xch)); - mb = Val_int(c_mb); - CAMLreturn(mb); + mb = Val_int(c_mb); + CAMLreturn(mb); } CAMLprim value stub_shadow_allocation_set(value xch, value domid, - value mb) + value mb) { - CAMLparam3(xch, domid, mb); - unsigned int c_mb; - int ret; + CAMLparam3(xch, domid, mb); + unsigned int c_mb; + int ret; - c_mb = Int_val(mb); - caml_enter_blocking_section(); - ret = xc_shadow_control(_H(xch), _D(domid), - XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION, - &c_mb, 0); - caml_leave_blocking_section(); - if (ret != 0) - failwith_xc(_H(xch)); + c_mb = Int_val(mb); + caml_enter_blocking_section(); + ret = xc_shadow_control(_H(xch), _D(domid), + XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION, + &c_mb, 0); + caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_ioport_permission(value xch, value domid, - value start_port, value nr_ports, - value allow) + value start_port, value nr_ports, + value allow) { - CAMLparam5(xch, domid, start_port, nr_ports, allow); - uint32_t c_start_port, c_nr_ports; - uint8_t c_allow; - int ret; + CAMLparam5(xch, domid, start_port, nr_ports, allow); + uint32_t c_start_port, c_nr_ports; + uint8_t c_allow; + int ret; - c_start_port = Int_val(start_port); - c_nr_ports = Int_val(nr_ports); - c_allow = Bool_val(allow); + c_start_port = Int_val(start_port); + c_nr_ports = Int_val(nr_ports); + c_allow = Bool_val(allow); - ret = xc_domain_ioport_permission(_H(xch), _D(domid), - c_start_port, c_nr_ports, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_domain_ioport_permission(_H(xch), _D(domid), + c_start_port, c_nr_ports, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_iomem_permission(value xch, value domid, - value start_pfn, value nr_pfns, - value allow) + value start_pfn, value nr_pfns, + value allow) { - CAMLparam5(xch, domid, start_pfn, nr_pfns, allow); - unsigned long c_start_pfn, c_nr_pfns; - uint8_t c_allow; - int ret; + CAMLparam5(xch, domid, start_pfn, nr_pfns, allow); + unsigned long c_start_pfn, c_nr_pfns; + uint8_t c_allow; + int ret; - c_start_pfn = Nativeint_val(start_pfn); - c_nr_pfns = Nativeint_val(nr_pfns); - c_allow = Bool_val(allow); + c_start_pfn = Nativeint_val(start_pfn); + c_nr_pfns = Nativeint_val(nr_pfns); + c_allow = Bool_val(allow); - ret = xc_domain_iomem_permission(_H(xch), _D(domid), - c_start_pfn, c_nr_pfns, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_domain_iomem_permission(_H(xch), _D(domid), + c_start_pfn, c_nr_pfns, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_irq_permission(value xch, value domid, - value pirq, value allow) + value pirq, value allow) { - CAMLparam4(xch, domid, pirq, allow); - uint32_t c_pirq; - bool c_allow; - int ret; + CAMLparam4(xch, domid, pirq, allow); + uint32_t c_pirq; + bool c_allow; + int ret; - c_pirq = Int_val(pirq); - c_allow = Bool_val(allow); + c_pirq = Int_val(pirq); + c_allow = Bool_val(allow); - ret = xc_domain_irq_permission(_H(xch), _D(domid), - c_pirq, c_allow); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_domain_irq_permission(_H(xch), _D(domid), + c_pirq, c_allow); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static uint32_t encode_sbdf(int domain, int bus, int dev, int func) { - return ((uint32_t)domain & 0xffff) << 16 | - ((uint32_t)bus & 0xff) << 8 | - ((uint32_t)dev & 0x1f) << 3 | - ((uint32_t)func & 0x7); + return ((uint32_t)domain & 0xffff) << 16 | + ((uint32_t)bus & 0xff) << 8 | + ((uint32_t)dev & 0x1f) << 3 | + ((uint32_t)func & 0x7); } CAMLprim value stub_xc_domain_test_assign_device(value xch, value domid, value desc) { - CAMLparam3(xch, domid, desc); - int ret; - int domain, bus, dev, func; - uint32_t sbdf; + CAMLparam3(xch, domid, desc); + int ret; + int domain, bus, dev, func; + uint32_t sbdf; - domain = Int_val(Field(desc, 0)); - bus = Int_val(Field(desc, 1)); - dev = Int_val(Field(desc, 2)); - func = Int_val(Field(desc, 3)); - sbdf = encode_sbdf(domain, bus, dev, func); + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + dev = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + sbdf = encode_sbdf(domain, bus, dev, func); - ret = xc_test_assign_device(_H(xch), _D(domid), sbdf); + ret = xc_test_assign_device(_H(xch), _D(domid), sbdf); - CAMLreturn(Val_bool(ret == 0)); + CAMLreturn(Val_bool(ret == 0)); } static int domain_assign_device_rdm_flag_table[] = { @@ -1147,96 +1147,96 @@ static int domain_assign_device_rdm_flag_table[] = { CAMLprim value stub_xc_domain_assign_device(value xch, value domid, value desc, value rflag) { - CAMLparam4(xch, domid, desc, rflag); - int ret; - int domain, bus, dev, func; - uint32_t sbdf, flag; + CAMLparam4(xch, domid, desc, rflag); + int ret; + int domain, bus, dev, func; + uint32_t sbdf, flag; - domain = Int_val(Field(desc, 0)); - bus = Int_val(Field(desc, 1)); - dev = Int_val(Field(desc, 2)); - func = Int_val(Field(desc, 3)); - sbdf = encode_sbdf(domain, bus, dev, func); + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + dev = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + sbdf = encode_sbdf(domain, bus, dev, func); - ret = Int_val(Field(rflag, 0)); - flag = domain_assign_device_rdm_flag_table[ret]; + ret = Int_val(Field(rflag, 0)); + flag = domain_assign_device_rdm_flag_table[ret]; - ret = xc_assign_device(_H(xch), _D(domid), sbdf, flag); + ret = xc_assign_device(_H(xch), _D(domid), sbdf, flag); - if (ret < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (ret < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_domain_deassign_device(value xch, value domid, value desc) { - CAMLparam3(xch, domid, desc); - int ret; - int domain, bus, dev, func; - uint32_t sbdf; + CAMLparam3(xch, domid, desc); + int ret; + int domain, bus, dev, func; + uint32_t sbdf; - domain = Int_val(Field(desc, 0)); - bus = Int_val(Field(desc, 1)); - dev = Int_val(Field(desc, 2)); - func = Int_val(Field(desc, 3)); - sbdf = encode_sbdf(domain, bus, dev, func); + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + dev = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + sbdf = encode_sbdf(domain, bus, dev, func); - ret = xc_deassign_device(_H(xch), _D(domid), sbdf); + ret = xc_deassign_device(_H(xch), _D(domid), sbdf); - if (ret < 0) - failwith_xc(_H(xch)); - CAMLreturn(Val_unit); + if (ret < 0) + failwith_xc(_H(xch)); + CAMLreturn(Val_unit); } CAMLprim value stub_xc_get_cpu_featureset(value xch, value idx) { - CAMLparam2(xch, idx); - CAMLlocal1(bitmap_val); + CAMLparam2(xch, idx); + CAMLlocal1(bitmap_val); #if defined(__i386__) || defined(__x86_64__) - /* Safe, because of the global ocaml lock. */ - static uint32_t fs_len; + /* Safe, because of the global ocaml lock. */ + static uint32_t fs_len; - if (fs_len == 0) - { - int ret = xc_get_cpu_featureset(_H(xch), 0, &fs_len, NULL); + if (fs_len == 0) + { + int ret = xc_get_cpu_featureset(_H(xch), 0, &fs_len, NULL); - if (ret || (fs_len == 0)) - failwith_xc(_H(xch)); - } + if (ret || (fs_len == 0)) + failwith_xc(_H(xch)); + } - { - /* To/from hypervisor to retrieve actual featureset */ - uint32_t fs[fs_len], len = fs_len; - unsigned int i; + { + /* To/from hypervisor to retrieve actual featureset */ + uint32_t fs[fs_len], len = fs_len; + unsigned int i; - int ret = xc_get_cpu_featureset(_H(xch), Int_val(idx), &len, fs); + int ret = xc_get_cpu_featureset(_H(xch), Int_val(idx), &len, fs); - if (ret) - failwith_xc(_H(xch)); + if (ret) + failwith_xc(_H(xch)); - bitmap_val = caml_alloc(len, 0); + bitmap_val = caml_alloc(len, 0); - for (i = 0; i < len; ++i) - Store_field(bitmap_val, i, caml_copy_int64(fs[i])); - } + for (i = 0; i < len; ++i) + Store_field(bitmap_val, i, caml_copy_int64(fs[i])); + } #else - caml_failwith("xc_get_cpu_featureset: not implemented"); + caml_failwith("xc_get_cpu_featureset: not implemented"); #endif - CAMLreturn(bitmap_val); + CAMLreturn(bitmap_val); } CAMLprim value stub_xc_watchdog(value xch, value domid, value timeout) { - CAMLparam3(xch, domid, timeout); - int ret; - unsigned int c_timeout = Int32_val(timeout); + CAMLparam3(xch, domid, timeout); + int ret; + unsigned int c_timeout = Int32_val(timeout); - ret = xc_watchdog(_H(xch), _D(domid), c_timeout); - if (ret < 0) - failwith_xc(_H(xch)); + ret = xc_watchdog(_H(xch), _D(domid), c_timeout); + if (ret < 0) + failwith_xc(_H(xch)); - CAMLreturn(Val_int(ret)); + CAMLreturn(Val_int(ret)); } /* diff --git a/tools/ocaml/libs/xentoollog/caml_xentoollog.h b/tools/ocaml/libs/xentoollog/caml_xentoollog.h index 0eb7618512..5ad4a4d5b2 100644 --- a/tools/ocaml/libs/xentoollog/caml_xentoollog.h +++ b/tools/ocaml/libs/xentoollog/caml_xentoollog.h @@ -15,9 +15,9 @@ */ struct caml_xtl { - xentoollog_logger vtable; - char *vmessage_cb; - char *progress_cb; + xentoollog_logger vtable; + char *vmessage_cb; + char *progress_cb; }; #define Xtl_val(x)(*((struct caml_xtl **) Data_custom_val(x))) diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c index e4306a0c2f..8f1ced1fa0 100644 --- a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c +++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c @@ -40,14 +40,14 @@ caml_local_roots = caml__frame; \ static char * dup_String_val(value s) { - int len; - char *c; - len = caml_string_length(s); - c = calloc(len + 1, sizeof(char)); - if (!c) - caml_raise_out_of_memory(); - memcpy(c, String_val(s), len); - return c; + int len; + char *c; + len = caml_string_length(s); + c = calloc(len + 1, sizeof(char)); + if (!c) + caml_raise_out_of_memory(); + memcpy(c, String_val(s), len); + return c; } #include "_xtl_levels.inc" @@ -62,144 +62,144 @@ static char * dup_String_val(value s) static value Val_some(value v) { - CAMLparam1(v); - CAMLlocal1(some); - some = caml_alloc(1, 0); - Store_field(some, 0, v); - CAMLreturn(some); + CAMLparam1(v); + CAMLlocal1(some); + some = caml_alloc(1, 0); + Store_field(some, 0, v); + CAMLreturn(some); } static value Val_errno(int errnoval) { - if (errnoval == -1) - return Val_none; - return Val_some(Val_int(errnoval)); + if (errnoval == -1) + return Val_none; + return Val_some(Val_int(errnoval)); } static value Val_context(const char *context) { - if (context == NULL) - return Val_none; - return Val_some(caml_copy_string(context)); + if (context == NULL) + return Val_none; + return Val_some(caml_copy_string(context)); } static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger, - xentoollog_level level, - int errnoval, - const char *context, - const char *format, - va_list al) + xentoollog_level level, + int errnoval, + const char *context, + const char *format, + va_list al) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - struct caml_xtl *xtl = (struct caml_xtl*)logger; - const value *func = caml_named_value(xtl->vmessage_cb); - char *msg; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + struct caml_xtl *xtl = (struct caml_xtl*)logger; + const value *func = caml_named_value(xtl->vmessage_cb); + char *msg; - if (func == NULL) - caml_raise_sys_error(caml_copy_string("Unable to find callback")); - if (vasprintf(&msg, format, al) < 0) - caml_raise_out_of_memory(); + if (func == NULL) + caml_raise_sys_error(caml_copy_string("Unable to find callback")); + if (vasprintf(&msg, format, al) < 0) + caml_raise_out_of_memory(); - /* vmessage : level -> int option -> string option -> string -> unit; */ - args[0] = Val_level(level); - args[1] = Val_errno(errnoval); - args[2] = Val_context(context); - args[3] = caml_copy_string(msg); + /* vmessage : level -> int option -> string option -> string -> unit; */ + args[0] = Val_level(level); + args[1] = Val_errno(errnoval); + args[2] = Val_context(context); + args[3] = caml_copy_string(msg); - free(msg); + free(msg); - caml_callbackN(*func, 4, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 4, args); + CAMLdone; + caml_enter_blocking_section(); } static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger, - const char *context, - const char *doing_what /* no \r,\n */, - int percent, unsigned long done, unsigned long total) + const char *context, + const char *doing_what /* no \r,\n */, + int percent, unsigned long done, unsigned long total) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 5); - struct caml_xtl *xtl = (struct caml_xtl*)logger; - const value *func = caml_named_value(xtl->progress_cb); + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 5); + struct caml_xtl *xtl = (struct caml_xtl*)logger; + const value *func = caml_named_value(xtl->progress_cb); - if (func == NULL) - caml_raise_sys_error(caml_copy_string("Unable to find callback")); + if (func == NULL) + caml_raise_sys_error(caml_copy_string("Unable to find callback")); - /* progress : string option -> string -> int -> int64 -> int64 -> unit; */ - args[0] = Val_context(context); - args[1] = caml_copy_string(doing_what); - args[2] = Val_int(percent); - args[3] = caml_copy_int64(done); - args[4] = caml_copy_int64(total); + /* progress : string option -> string -> int -> int64 -> int64 -> unit; */ + args[0] = Val_context(context); + args[1] = caml_copy_string(doing_what); + args[2] = Val_int(percent); + args[3] = caml_copy_int64(done); + args[4] = caml_copy_int64(total); - caml_callbackN(*func, 5, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 5, args); + CAMLdone; + caml_enter_blocking_section(); } static void xtl_destroy(struct xentoollog_logger *logger) { - struct caml_xtl *xtl = (struct caml_xtl*)logger; - free(xtl->vmessage_cb); - free(xtl->progress_cb); - free(xtl); + struct caml_xtl *xtl = (struct caml_xtl*)logger; + free(xtl->vmessage_cb); + free(xtl->progress_cb); + free(xtl); } void xtl_finalize(value handle) { - xtl_destroy(XTL); + xtl_destroy(XTL); } static struct custom_operations xentoollogger_custom_operations = { - "xentoollogger_custom_operations", - xtl_finalize /* custom_finalize_default */, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default + "xentoollogger_custom_operations", + xtl_finalize /* custom_finalize_default */, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default }; /* external _create_logger: (string * string) -> handle = "stub_xtl_create_logger" */ CAMLprim value stub_xtl_create_logger(value cbs) { - CAMLparam1(cbs); - CAMLlocal1(handle); - struct caml_xtl *xtl = malloc(sizeof(*xtl)); - if (xtl == NULL) - caml_raise_out_of_memory(); + CAMLparam1(cbs); + CAMLlocal1(handle); + struct caml_xtl *xtl = malloc(sizeof(*xtl)); + if (xtl == NULL) + caml_raise_out_of_memory(); - memset(xtl, 0, sizeof(*xtl)); + memset(xtl, 0, sizeof(*xtl)); - xtl->vtable.vmessage = &stub_xtl_ocaml_vmessage; - xtl->vtable.progress = &stub_xtl_ocaml_progress; - xtl->vtable.destroy = &xtl_destroy; + xtl->vtable.vmessage = &stub_xtl_ocaml_vmessage; + xtl->vtable.progress = &stub_xtl_ocaml_progress; + xtl->vtable.destroy = &xtl_destroy; - xtl->vmessage_cb = dup_String_val(Field(cbs, 0)); - xtl->progress_cb = dup_String_val(Field(cbs, 1)); + xtl->vmessage_cb = dup_String_val(Field(cbs, 0)); + xtl->progress_cb = dup_String_val(Field(cbs, 1)); - handle = caml_alloc_custom(&xentoollogger_custom_operations, sizeof(xtl), 0, 1); - Xtl_val(handle) = xtl; + handle = caml_alloc_custom(&xentoollogger_custom_operations, sizeof(xtl), 0, 1); + Xtl_val(handle) = xtl; - CAMLreturn(handle); + CAMLreturn(handle); } /* external test: handle -> unit = "stub_xtl_test" */ CAMLprim value stub_xtl_test(value handle) { - unsigned long l; - CAMLparam1(handle); - xtl_log(XTL, XTL_DEBUG, -1, "debug", "%s -- debug", __func__); - xtl_log(XTL, XTL_INFO, -1, "test", "%s -- test 1", __func__); - xtl_log(XTL, XTL_INFO, ENOSYS, "test errno", "%s -- test 2", __func__); - xtl_log(XTL, XTL_CRITICAL, -1, "critical", "%s -- critical", __func__); - for (l = 0UL; l<=100UL; l += 10UL) { - xtl_progress(XTL, "progress", "testing", l, 100UL); - usleep(10000); - } - CAMLreturn(Val_unit); + unsigned long l; + CAMLparam1(handle); + xtl_log(XTL, XTL_DEBUG, -1, "debug", "%s -- debug", __func__); + xtl_log(XTL, XTL_INFO, -1, "test", "%s -- test 1", __func__); + xtl_log(XTL, XTL_INFO, ENOSYS, "test errno", "%s -- test 2", __func__); + xtl_log(XTL, XTL_CRITICAL, -1, "critical", "%s -- critical", __func__); + for (l = 0UL; l<=100UL; l += 10UL) { + xtl_progress(XTL, "progress", "testing", l, 100UL); + usleep(10000); + } + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/libs/xl/xenlight_stubs.c b/tools/ocaml/libs/xl/xenlight_stubs.c index 45b8af61c7..9dbf5e9660 100644 --- a/tools/ocaml/libs/xl/xenlight_stubs.c +++ b/tools/ocaml/libs/xl/xenlight_stubs.c @@ -58,14 +58,14 @@ caml_local_roots = caml__frame; \ static char * dup_String_val(value s) { - int len; - char *c; - len = caml_string_length(s); - c = calloc(len + 1, sizeof(char)); - if (!c) - caml_raise_out_of_memory(); - memcpy(c, String_val(s), len); - return c; + int len; + char *c; + len = caml_string_length(s); + c = calloc(len + 1, sizeof(char)); + if (!c) + caml_raise_out_of_memory(); + memcpy(c, String_val(s), len); + return c; } /* Forward reference: this is defined in the auto-generated include file below. */ @@ -73,157 +73,157 @@ static value Val_error (libxl_error error_c); static void failwith_xl(int error, char *fname) { - CAMLparam0(); - CAMLlocal1(arg); - static const value *exc = NULL; + CAMLparam0(); + CAMLlocal1(arg); + static const value *exc = NULL; - /* First time around, lookup by name */ - if (!exc) - exc = caml_named_value("Xenlight.Error"); + /* First time around, lookup by name */ + if (!exc) + exc = caml_named_value("Xenlight.Error"); - if (!exc) - caml_invalid_argument("Exception Xenlight.Error not initialized, please link xenlight.cma"); + if (!exc) + caml_invalid_argument("Exception Xenlight.Error not initialized, please link xenlight.cma"); - arg = caml_alloc(2, 0); + arg = caml_alloc(2, 0); - Store_field(arg, 0, Val_error(error)); - Store_field(arg, 1, caml_copy_string(fname)); + Store_field(arg, 0, Val_error(error)); + Store_field(arg, 1, caml_copy_string(fname)); - caml_raise_with_arg(*exc, arg); - CAMLreturn0; + caml_raise_with_arg(*exc, arg); + CAMLreturn0; } CAMLprim value stub_raise_exception(value unit) { - CAMLparam1(unit); - failwith_xl(ERROR_FAIL, "test exception"); - CAMLreturn(Val_unit); + CAMLparam1(unit); + failwith_xl(ERROR_FAIL, "test exception"); + CAMLreturn(Val_unit); } void ctx_finalize(value ctx) { - libxl_ctx_free(CTX); + libxl_ctx_free(CTX); } static struct custom_operations libxl_ctx_custom_operations = { - "libxl_ctx_custom_operations", - ctx_finalize /* custom_finalize_default */, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default + "libxl_ctx_custom_operations", + ctx_finalize /* custom_finalize_default */, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default }; CAMLprim value stub_libxl_ctx_alloc(value logger) { - CAMLparam1(logger); - CAMLlocal1(handle); - libxl_ctx *ctx; - int ret; + CAMLparam1(logger); + CAMLlocal1(handle); + libxl_ctx *ctx; + int ret; - ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (xentoollog_logger *) Xtl_val(logger)); - if (ret != 0) \ - failwith_xl(ERROR_FAIL, "cannot init context"); + ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (xentoollog_logger *) Xtl_val(logger)); + if (ret != 0) \ + failwith_xl(ERROR_FAIL, "cannot init context"); - handle = caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0, 1); - Ctx_val(handle) = ctx; + handle = caml_alloc_custom(&libxl_ctx_custom_operations, sizeof(ctx), 0, 1); + Ctx_val(handle) = ctx; - CAMLreturn(handle); + CAMLreturn(handle); } static int list_len(value v) { - int len = 0; - while ( v != Val_emptylist ) { - len++; - v = Field(v, 1); - } - return len; + int len = 0; + while ( v != Val_emptylist ) { + len++; + v = Field(v, 1); + } + return len; } static int libxl_key_value_list_val(libxl_key_value_list *c_val, - value v) + value v) { - CAMLparam1(v); - CAMLlocal1(elem); - int nr, i; - libxl_key_value_list array; + CAMLparam1(v); + CAMLlocal1(elem); + int nr, i; + libxl_key_value_list array; - nr = list_len(v); + nr = list_len(v); - array = calloc((nr + 1) * 2, sizeof(char *)); - if (!array) - caml_raise_out_of_memory(); + array = calloc((nr + 1) * 2, sizeof(char *)); + if (!array) + caml_raise_out_of_memory(); - for (i=0; v != Val_emptylist; i++, v = Field(v, 1) ) { - elem = Field(v, 0); + for (i=0; v != Val_emptylist; i++, v = Field(v, 1) ) { + elem = Field(v, 0); - array[i * 2] = dup_String_val(Field(elem, 0)); - array[i * 2 + 1] = dup_String_val(Field(elem, 1)); - } + array[i * 2] = dup_String_val(Field(elem, 0)); + array[i * 2 + 1] = dup_String_val(Field(elem, 1)); + } - *c_val = array; - CAMLreturn(0); + *c_val = array; + CAMLreturn(0); } static value Val_key_value_list(libxl_key_value_list *c_val) { - CAMLparam0(); - CAMLlocal5(list, cons, key, val, kv); - int i; + CAMLparam0(); + CAMLlocal5(list, cons, key, val, kv); + int i; - list = Val_emptylist; - for (i = libxl_string_list_length((libxl_string_list *) c_val) - 1; i >= 0; i -= 2) { - val = caml_copy_string((*c_val)[i]); - key = caml_copy_string((*c_val)[i - 1]); - kv = caml_alloc_tuple(2); - Store_field(kv, 0, key); - Store_field(kv, 1, val); + list = Val_emptylist; + for (i = libxl_string_list_length((libxl_string_list *) c_val) - 1; i >= 0; i -= 2) { + val = caml_copy_string((*c_val)[i]); + key = caml_copy_string((*c_val)[i - 1]); + kv = caml_alloc_tuple(2); + Store_field(kv, 0, key); + Store_field(kv, 1, val); - cons = caml_alloc(2, 0); - Store_field(cons, 0, kv); // head - Store_field(cons, 1, list); // tail - list = cons; - } + cons = caml_alloc(2, 0); + Store_field(cons, 0, kv); // head + Store_field(cons, 1, list); // tail + list = cons; + } - CAMLreturn(list); + CAMLreturn(list); } static int libxl_string_list_val(libxl_string_list *c_val, value v) { - CAMLparam1(v); - int nr, i; - libxl_string_list array; + CAMLparam1(v); + int nr, i; + libxl_string_list array; - nr = list_len(v); + nr = list_len(v); - array = calloc(nr + 1, sizeof(char *)); - if (!array) - caml_raise_out_of_memory(); + array = calloc(nr + 1, sizeof(char *)); + if (!array) + caml_raise_out_of_memory(); - for (i=0; v != Val_emptylist; i++, v = Field(v, 1) ) - array[i] = dup_String_val(Field(v, 0)); + for (i=0; v != Val_emptylist; i++, v = Field(v, 1) ) + array[i] = dup_String_val(Field(v, 0)); - *c_val = array; - CAMLreturn(0); + *c_val = array; + CAMLreturn(0); } static value Val_string_list(libxl_string_list *c_val) { - CAMLparam0(); - CAMLlocal3(list, cons, string); - int i; + CAMLparam0(); + CAMLlocal3(list, cons, string); + int i; - list = Val_emptylist; - for (i = libxl_string_list_length(c_val) - 1; i >= 0; i--) { - string = caml_copy_string((*c_val)[i]); - cons = caml_alloc(2, 0); - Store_field(cons, 0, string); // head - Store_field(cons, 1, list); // tail - list = cons; - } + list = Val_emptylist; + for (i = libxl_string_list_length(c_val) - 1; i >= 0; i--) { + string = caml_copy_string((*c_val)[i]); + cons = caml_alloc(2, 0); + Store_field(cons, 0, string); // head + Store_field(cons, 1, list); // tail + list = cons; + } - CAMLreturn(list); + CAMLreturn(list); } /* Option type support as per http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php */ @@ -236,472 +236,472 @@ static value Val_string_list(libxl_string_list *c_val) static value Val_some(value v) { - CAMLparam1(v); - CAMLlocal1(some); - some = caml_alloc(1, 0); - Store_field(some, 0, v); - CAMLreturn(some); + CAMLparam1(v); + CAMLlocal1(some); + some = caml_alloc(1, 0); + Store_field(some, 0, v); + CAMLreturn(some); } static value Val_mac (libxl_mac *c_val) { - CAMLparam0(); - CAMLlocal1(v); - int i; + CAMLparam0(); + CAMLlocal1(v); + int i; - v = caml_alloc_tuple(6); + v = caml_alloc_tuple(6); - for(i=0; i<6; i++) - Store_field(v, i, Val_int((*c_val)[i])); + for(i=0; i<6; i++) + Store_field(v, i, Val_int((*c_val)[i])); - CAMLreturn(v); + CAMLreturn(v); } static int Mac_val(libxl_mac *c_val, value v) { - CAMLparam1(v); - int i; + CAMLparam1(v); + int i; - for(i=0; i<6; i++) - (*c_val)[i] = Int_val(Field(v, i)); + for(i=0; i<6; i++) + (*c_val)[i] = Int_val(Field(v, i)); - CAMLreturn(0); + CAMLreturn(0); } static value Val_bitmap (libxl_bitmap *c_val) { - CAMLparam0(); - CAMLlocal1(v); - int i; + CAMLparam0(); + CAMLlocal1(v); + int i; - if (c_val->size == 0) - v = Atom(0); - else { - v = caml_alloc(8 * (c_val->size), 0); - libxl_for_each_bit(i, *c_val) { - if (libxl_bitmap_test(c_val, i)) - Store_field(v, i, Val_true); - else - Store_field(v, i, Val_false); - } - } - CAMLreturn(v); + if (c_val->size == 0) + v = Atom(0); + else { + v = caml_alloc(8 * (c_val->size), 0); + libxl_for_each_bit(i, *c_val) { + if (libxl_bitmap_test(c_val, i)) + Store_field(v, i, Val_true); + else + Store_field(v, i, Val_false); + } + } + CAMLreturn(v); } static int Bitmap_val(libxl_ctx *ctx, libxl_bitmap *c_val, value v) { - CAMLparam1(v); - int i, len = Wosize_val(v); + CAMLparam1(v); + int i, len = Wosize_val(v); - c_val->size = 0; - if (len > 0 && libxl_bitmap_alloc(ctx, c_val, len)) - failwith_xl(ERROR_NOMEM, "cannot allocate bitmap"); - for (i=0; isize = 0; + if (len > 0 && libxl_bitmap_alloc(ctx, c_val, len)) + failwith_xl(ERROR_NOMEM, "cannot allocate bitmap"); + for (i=0; ibytes[i])); + for(i=0; ibytes[i])); - CAMLreturn(v); + CAMLreturn(v); } static int Ms_vm_genid_val(libxl_ms_vm_genid *c_val, value v) { - CAMLparam1(v); - int i; + CAMLparam1(v); + int i; - for(i=0; ibytes[i] = Int_val(Field(v, i)); + for(i=0; ibytes[i] = Int_val(Field(v, i)); - CAMLreturn(0); + CAMLreturn(0); } static value Val_string_option(const char *c_val) { - CAMLparam0(); - CAMLlocal2(tmp1, tmp2); - if (c_val) { - tmp1 = caml_copy_string(c_val); - tmp2 = Val_some(tmp1); - CAMLreturn(tmp2); - } - else - CAMLreturn(Val_none); + CAMLparam0(); + CAMLlocal2(tmp1, tmp2); + if (c_val) { + tmp1 = caml_copy_string(c_val); + tmp2 = Val_some(tmp1); + CAMLreturn(tmp2); + } + else + CAMLreturn(Val_none); } static char *String_option_val(value v) { - CAMLparam1(v); - char *s = NULL; - if (v != Val_none) - s = dup_String_val(Some_val(v)); - CAMLreturnT(char *, s); + CAMLparam1(v); + char *s = NULL; + if (v != Val_none) + s = dup_String_val(Some_val(v)); + CAMLreturnT(char *, s); } #include "_libxl_types.inc" void async_callback(libxl_ctx *ctx, int rc, void *for_callback) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocal2(error, tmp); - static const value *func = NULL; - value *p = (value *) for_callback; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocal2(error, tmp); + static const value *func = NULL; + value *p = (value *) for_callback; - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_async_callback"); - } + if (func == NULL) { + /* First time around, lookup by name */ + func = caml_named_value("libxl_async_callback"); + } - if (rc == 0) - error = Val_none; - else { - tmp = Val_error(rc); - error = Val_some(tmp); - } + if (rc == 0) + error = Val_none; + else { + tmp = Val_error(rc); + error = Val_some(tmp); + } - /* for_callback is a pointer to a "value" that was malloc'ed and - * registered with the OCaml GC. The value is handed back to OCaml - * in the following callback, after which the pointer is unregistered - * and freed. */ - caml_callback2(*func, error, *p); + /* for_callback is a pointer to a "value" that was malloc'ed and + * registered with the OCaml GC. The value is handed back to OCaml + * in the following callback, after which the pointer is unregistered + * and freed. */ + caml_callback2(*func, error, *p); - caml_remove_global_root(p); - free(p); + caml_remove_global_root(p); + free(p); - CAMLdone; - caml_enter_blocking_section(); + CAMLdone; + caml_enter_blocking_section(); } static libxl_asyncop_how *aohow_val(value async) { - CAMLparam1(async); - libxl_asyncop_how *ao_how = NULL; - value *p; + CAMLparam1(async); + libxl_asyncop_how *ao_how = NULL; + value *p; - if (async != Val_none) { - /* for_callback must be a pointer to a "value" that is malloc'ed and - * registered with the OCaml GC. This ensures that the GC does not remove - * the corresponding OCaml heap blocks, and allows the GC to update the value - * when blocks are moved around, while libxl is free to copy the pointer if - * it needs to. - * The for_callback pointer must always be non-NULL. */ - p = malloc(sizeof(value)); - if (!p) - failwith_xl(ERROR_NOMEM, "cannot allocate value"); - *p = Some_val(async); - caml_register_global_root(p); - ao_how = malloc(sizeof(*ao_how)); - ao_how->callback = async_callback; - ao_how->u.for_callback = (void *) p; - } + if (async != Val_none) { + /* for_callback must be a pointer to a "value" that is malloc'ed and + * registered with the OCaml GC. This ensures that the GC does not remove + * the corresponding OCaml heap blocks, and allows the GC to update the value + * when blocks are moved around, while libxl is free to copy the pointer if + * it needs to. + * The for_callback pointer must always be non-NULL. */ + p = malloc(sizeof(value)); + if (!p) + failwith_xl(ERROR_NOMEM, "cannot allocate value"); + *p = Some_val(async); + caml_register_global_root(p); + ao_how = malloc(sizeof(*ao_how)); + ao_how->callback = async_callback; + ao_how->u.for_callback = (void *) p; + } - CAMLreturnT(libxl_asyncop_how *, ao_how); + CAMLreturnT(libxl_asyncop_how *, ao_how); } value stub_libxl_domain_create_new(value ctx, value domain_config, value async, value unit) { - CAMLparam4(ctx, async, domain_config, unit); - int ret; - libxl_domain_config c_dconfig; - uint32_t c_domid; - libxl_asyncop_how *ao_how; + CAMLparam4(ctx, async, domain_config, unit); + int ret; + libxl_domain_config c_dconfig; + uint32_t c_domid; + libxl_asyncop_how *ao_how; - libxl_domain_config_init(&c_dconfig); - ret = domain_config_val(CTX, &c_dconfig, domain_config); - if (ret != 0) { - libxl_domain_config_dispose(&c_dconfig); - failwith_xl(ret, "domain_create_new"); - } + libxl_domain_config_init(&c_dconfig); + ret = domain_config_val(CTX, &c_dconfig, domain_config); + if (ret != 0) { + libxl_domain_config_dispose(&c_dconfig); + failwith_xl(ret, "domain_create_new"); + } - ao_how = aohow_val(async); + ao_how = aohow_val(async); - caml_enter_blocking_section(); - ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid, ao_how, NULL); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_create_new(CTX, &c_dconfig, &c_domid, ao_how, NULL); + caml_leave_blocking_section(); - free(ao_how); - libxl_domain_config_dispose(&c_dconfig); + free(ao_how); + libxl_domain_config_dispose(&c_dconfig); - if (ret != 0) - failwith_xl(ret, "domain_create_new"); + if (ret != 0) + failwith_xl(ret, "domain_create_new"); - CAMLreturn(Val_int(c_domid)); + CAMLreturn(Val_int(c_domid)); } value stub_libxl_domain_create_restore(value ctx, value domain_config, value params, - value async, value unit) + value async, value unit) { - CAMLparam5(ctx, domain_config, params, async, unit); - int ret; - libxl_domain_config c_dconfig; - libxl_domain_restore_params c_params; - uint32_t c_domid; - libxl_asyncop_how *ao_how; - int restore_fd; + CAMLparam5(ctx, domain_config, params, async, unit); + int ret; + libxl_domain_config c_dconfig; + libxl_domain_restore_params c_params; + uint32_t c_domid; + libxl_asyncop_how *ao_how; + int restore_fd; - libxl_domain_config_init(&c_dconfig); - ret = domain_config_val(CTX, &c_dconfig, domain_config); - if (ret != 0) { - libxl_domain_config_dispose(&c_dconfig); - failwith_xl(ret, "domain_create_restore"); - } + libxl_domain_config_init(&c_dconfig); + ret = domain_config_val(CTX, &c_dconfig, domain_config); + if (ret != 0) { + libxl_domain_config_dispose(&c_dconfig); + failwith_xl(ret, "domain_create_restore"); + } - libxl_domain_restore_params_init(&c_params); - ret = domain_restore_params_val(CTX, &c_params, Field(params, 1)); - if (ret != 0) { - libxl_domain_restore_params_dispose(&c_params); - failwith_xl(ret, "domain_create_restore"); - } + libxl_domain_restore_params_init(&c_params); + ret = domain_restore_params_val(CTX, &c_params, Field(params, 1)); + if (ret != 0) { + libxl_domain_restore_params_dispose(&c_params); + failwith_xl(ret, "domain_create_restore"); + } - ao_how = aohow_val(async); - restore_fd = Int_val(Field(params, 0)); + ao_how = aohow_val(async); + restore_fd = Int_val(Field(params, 0)); - caml_enter_blocking_section(); - ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, restore_fd, - -1, &c_params, ao_how, NULL); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_create_restore(CTX, &c_dconfig, &c_domid, restore_fd, + -1, &c_params, ao_how, NULL); + caml_leave_blocking_section(); - free(ao_how); - libxl_domain_config_dispose(&c_dconfig); - libxl_domain_restore_params_dispose(&c_params); + free(ao_how); + libxl_domain_config_dispose(&c_dconfig); + libxl_domain_restore_params_dispose(&c_params); - if (ret != 0) - failwith_xl(ret, "domain_create_restore"); + if (ret != 0) + failwith_xl(ret, "domain_create_restore"); - CAMLreturn(Val_int(c_domid)); + CAMLreturn(Val_int(c_domid)); } value stub_libxl_domain_shutdown(value ctx, value domid, value async, value unit) { - CAMLparam4(ctx, domid, async, unit); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); + CAMLparam4(ctx, domid, async, unit); + int ret; + uint32_t c_domid = Int_val(domid); + libxl_asyncop_how *ao_how = aohow_val(async); - caml_enter_blocking_section(); - ret = libxl_domain_shutdown(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_shutdown(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_shutdown"); + if (ret != 0) + failwith_xl(ret, "domain_shutdown"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_libxl_domain_reboot(value ctx, value domid, value async, value unit) { - CAMLparam4(ctx, domid, async, unit); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); + CAMLparam4(ctx, domid, async, unit); + int ret; + uint32_t c_domid = Int_val(domid); + libxl_asyncop_how *ao_how = aohow_val(async); - caml_enter_blocking_section(); - ret = libxl_domain_reboot(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_reboot(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_reboot"); + if (ret != 0) + failwith_xl(ret, "domain_reboot"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_libxl_domain_destroy(value ctx, value domid, value async, value unit) { - CAMLparam4(ctx, domid, async, unit); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); + CAMLparam4(ctx, domid, async, unit); + int ret; + uint32_t c_domid = Int_val(domid); + libxl_asyncop_how *ao_how = aohow_val(async); - caml_enter_blocking_section(); - ret = libxl_domain_destroy(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_destroy(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_destroy"); + if (ret != 0) + failwith_xl(ret, "domain_destroy"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_libxl_domain_suspend(value ctx, value domid, value fd, value async, value unit) { - CAMLparam5(ctx, domid, fd, async, unit); - int ret; - uint32_t c_domid = Int_val(domid); - int c_fd = Int_val(fd); - libxl_asyncop_how *ao_how = aohow_val(async); + CAMLparam5(ctx, domid, fd, async, unit); + int ret; + uint32_t c_domid = Int_val(domid); + int c_fd = Int_val(fd); + libxl_asyncop_how *ao_how = aohow_val(async); - caml_enter_blocking_section(); - ret = libxl_domain_suspend(CTX, c_domid, c_fd, 0, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_suspend(CTX, c_domid, c_fd, 0, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_suspend"); + if (ret != 0) + failwith_xl(ret, "domain_suspend"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_libxl_domain_pause(value ctx, value domid, value async) { - CAMLparam3(ctx, domid, async); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); + CAMLparam3(ctx, domid, async); + int ret; + uint32_t c_domid = Int_val(domid); + libxl_asyncop_how *ao_how = aohow_val(async); - caml_enter_blocking_section(); - ret = libxl_domain_pause(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_pause(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_pause"); + if (ret != 0) + failwith_xl(ret, "domain_pause"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_libxl_domain_unpause(value ctx, value domid, value async) { - CAMLparam3(ctx, domid, async); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_asyncop_how *ao_how = aohow_val(async); + CAMLparam3(ctx, domid, async); + int ret; + uint32_t c_domid = Int_val(domid); + libxl_asyncop_how *ao_how = aohow_val(async); - caml_enter_blocking_section(); - ret = libxl_domain_unpause(CTX, c_domid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_unpause(CTX, c_domid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "domain_unpause"); + if (ret != 0) + failwith_xl(ret, "domain_unpause"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } #define _STRINGIFY(x) #x #define STRINGIFY(x) _STRINGIFY(x) -#define _DEVICE_ADDREMOVE(type,fn,op) \ -value stub_xl_device_##type##_##op(value ctx, value info, value domid, \ - value async, value unit) \ -{ \ - CAMLparam5(ctx, info, domid, async, unit); \ - libxl_device_##type c_info; \ - int ret, marker_var; \ - uint32_t c_domid = Int_val(domid); \ - libxl_asyncop_how *ao_how = aohow_val(async); \ - \ - device_##type##_val(CTX, &c_info, info); \ - \ - caml_enter_blocking_section(); \ - ret = libxl_##fn##_##op(CTX, c_domid, &c_info, ao_how); \ - caml_leave_blocking_section(); \ - \ - free(ao_how); \ - libxl_device_##type##_dispose(&c_info); \ - \ - if (ret != 0) \ - failwith_xl(ret, STRINGIFY(type) "_" STRINGIFY(op)); \ - \ - CAMLreturn(Val_unit); \ +#define _DEVICE_ADDREMOVE(type,fn,op) \ +value stub_xl_device_##type##_##op(value ctx, value info, value domid, \ + value async, value unit) \ +{ \ + CAMLparam5(ctx, info, domid, async, unit); \ + libxl_device_##type c_info; \ + int ret, marker_var; \ + uint32_t c_domid = Int_val(domid); \ + libxl_asyncop_how *ao_how = aohow_val(async); \ + \ + device_##type##_val(CTX, &c_info, info); \ + \ + caml_enter_blocking_section(); \ + ret = libxl_##fn##_##op(CTX, c_domid, &c_info, ao_how); \ + caml_leave_blocking_section(); \ + \ + free(ao_how); \ + libxl_device_##type##_dispose(&c_info); \ + \ + if (ret != 0) \ + failwith_xl(ret, STRINGIFY(type) "_" STRINGIFY(op)); \ + \ + CAMLreturn(Val_unit); \ } #define DEVICE_ADDREMOVE(type) \ - _DEVICE_ADDREMOVE(type, device_##type, add) \ - _DEVICE_ADDREMOVE(type, device_##type, remove) \ - _DEVICE_ADDREMOVE(type, device_##type, destroy) + _DEVICE_ADDREMOVE(type, device_##type, add) \ + _DEVICE_ADDREMOVE(type, device_##type, remove) \ + _DEVICE_ADDREMOVE(type, device_##type, destroy) DEVICE_ADDREMOVE(disk) DEVICE_ADDREMOVE(nic) @@ -712,558 +712,558 @@ _DEVICE_ADDREMOVE(disk, cdrom, insert) value stub_xl_device_nic_of_devid(value ctx, value domid, value devid) { - CAMLparam3(ctx, domid, devid); - CAMLlocal1(nic); - libxl_device_nic c_nic; - uint32_t c_domid = Int_val(domid); - int c_devid = Int_val(devid); + CAMLparam3(ctx, domid, devid); + CAMLlocal1(nic); + libxl_device_nic c_nic; + uint32_t c_domid = Int_val(domid); + int c_devid = Int_val(devid); - caml_enter_blocking_section(); - libxl_devid_to_device_nic(CTX, c_domid, c_devid, &c_nic); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_devid_to_device_nic(CTX, c_domid, c_devid, &c_nic); + caml_leave_blocking_section(); - nic = Val_device_nic(&c_nic); - libxl_device_nic_dispose(&c_nic); + nic = Val_device_nic(&c_nic); + libxl_device_nic_dispose(&c_nic); - CAMLreturn(nic); + CAMLreturn(nic); } value stub_xl_device_nic_list(value ctx, value domid) { - CAMLparam2(ctx, domid); - CAMLlocal2(list, temp); - libxl_device_nic *c_list; - int i, nb; - uint32_t c_domid = Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal2(list, temp); + libxl_device_nic *c_list; + int i, nb; + uint32_t c_domid = Int_val(domid); - caml_enter_blocking_section(); - c_list = libxl_device_nic_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_list = libxl_device_nic_list(CTX, c_domid, &nb); + caml_leave_blocking_section(); - if (!c_list) - failwith_xl(ERROR_FAIL, "nic_list"); + if (!c_list) + failwith_xl(ERROR_FAIL, "nic_list"); - list = temp = Val_emptylist; - for (i = 0; i < nb; i++) { - list = caml_alloc_small(2, Tag_cons); - Field(list, 0) = Val_int(0); - Field(list, 1) = temp; - temp = list; - Store_field(list, 0, Val_device_nic(&c_list[i])); - } - libxl_device_nic_list_free(c_list, nb); + list = temp = Val_emptylist; + for (i = 0; i < nb; i++) { + list = caml_alloc_small(2, Tag_cons); + Field(list, 0) = Val_int(0); + Field(list, 1) = temp; + temp = list; + Store_field(list, 0, Val_device_nic(&c_list[i])); + } + libxl_device_nic_list_free(c_list, nb); - CAMLreturn(list); + CAMLreturn(list); } value stub_xl_device_disk_list(value ctx, value domid) { - CAMLparam2(ctx, domid); - CAMLlocal2(list, temp); - libxl_device_disk *c_list; - int i, nb; - uint32_t c_domid = Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal2(list, temp); + libxl_device_disk *c_list; + int i, nb; + uint32_t c_domid = Int_val(domid); - caml_enter_blocking_section(); - c_list = libxl_device_disk_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_list = libxl_device_disk_list(CTX, c_domid, &nb); + caml_leave_blocking_section(); - if (!c_list) - failwith_xl(ERROR_FAIL, "disk_list"); + if (!c_list) + failwith_xl(ERROR_FAIL, "disk_list"); - list = temp = Val_emptylist; - for (i = 0; i < nb; i++) { - list = caml_alloc_small(2, Tag_cons); - Field(list, 0) = Val_int(0); - Field(list, 1) = temp; - temp = list; - Store_field(list, 0, Val_device_disk(&c_list[i])); - } - libxl_device_disk_list_free(c_list, nb); + list = temp = Val_emptylist; + for (i = 0; i < nb; i++) { + list = caml_alloc_small(2, Tag_cons); + Field(list, 0) = Val_int(0); + Field(list, 1) = temp; + temp = list; + Store_field(list, 0, Val_device_disk(&c_list[i])); + } + libxl_device_disk_list_free(c_list, nb); - CAMLreturn(list); + CAMLreturn(list); } value stub_xl_device_disk_of_vdev(value ctx, value domid, value vdev) { - CAMLparam3(ctx, domid, vdev); - CAMLlocal1(disk); - libxl_device_disk c_disk; - char *c_vdev; - uint32_t c_domid = Int_val(domid); + CAMLparam3(ctx, domid, vdev); + CAMLlocal1(disk); + libxl_device_disk c_disk; + char *c_vdev; + uint32_t c_domid = Int_val(domid); - c_vdev = strdup(String_val(vdev)); + c_vdev = strdup(String_val(vdev)); - caml_enter_blocking_section(); - libxl_vdev_to_device_disk(CTX, c_domid, c_vdev, &c_disk); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_vdev_to_device_disk(CTX, c_domid, c_vdev, &c_disk); + caml_leave_blocking_section(); - disk = Val_device_disk(&c_disk); - libxl_device_disk_dispose(&c_disk); - free(c_vdev); + disk = Val_device_disk(&c_disk); + libxl_device_disk_dispose(&c_disk); + free(c_vdev); - CAMLreturn(disk); + CAMLreturn(disk); } value stub_xl_device_pci_list(value ctx, value domid) { - CAMLparam2(ctx, domid); - CAMLlocal2(list, temp); - libxl_device_pci *c_list; - int i, nb; - uint32_t c_domid = Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal2(list, temp); + libxl_device_pci *c_list; + int i, nb; + uint32_t c_domid = Int_val(domid); - caml_enter_blocking_section(); - c_list = libxl_device_pci_list(CTX, c_domid, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_list = libxl_device_pci_list(CTX, c_domid, &nb); + caml_leave_blocking_section(); - if (!c_list) - failwith_xl(ERROR_FAIL, "pci_list"); + if (!c_list) + failwith_xl(ERROR_FAIL, "pci_list"); - list = temp = Val_emptylist; - for (i = 0; i < nb; i++) { - list = caml_alloc_small(2, Tag_cons); - Field(list, 0) = Val_int(0); - Field(list, 1) = temp; - temp = list; - Store_field(list, 0, Val_device_pci(&c_list[i])); - libxl_device_pci_dispose(&c_list[i]); - } - free(c_list); + list = temp = Val_emptylist; + for (i = 0; i < nb; i++) { + list = caml_alloc_small(2, Tag_cons); + Field(list, 0) = Val_int(0); + Field(list, 1) = temp; + temp = list; + Store_field(list, 0, Val_device_pci(&c_list[i])); + libxl_device_pci_dispose(&c_list[i]); + } + free(c_list); - CAMLreturn(list); + CAMLreturn(list); } value stub_xl_device_pci_assignable_add(value ctx, value info, value rebind) { - CAMLparam3(ctx, info, rebind); - libxl_device_pci c_info; - int ret, marker_var; - int c_rebind = (int) Bool_val(rebind); + CAMLparam3(ctx, info, rebind); + libxl_device_pci c_info; + int ret, marker_var; + int c_rebind = (int) Bool_val(rebind); - device_pci_val(CTX, &c_info, info); + device_pci_val(CTX, &c_info, info); - caml_enter_blocking_section(); - ret = libxl_device_pci_assignable_add(CTX, &c_info, c_rebind); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_device_pci_assignable_add(CTX, &c_info, c_rebind); + caml_leave_blocking_section(); - libxl_device_pci_dispose(&c_info); + libxl_device_pci_dispose(&c_info); - if (ret != 0) - failwith_xl(ret, "pci_assignable_add"); + if (ret != 0) + failwith_xl(ret, "pci_assignable_add"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_xl_device_pci_assignable_remove(value ctx, value info, value rebind) { - CAMLparam3(ctx, info, rebind); - libxl_device_pci c_info; - int ret, marker_var; - int c_rebind = (int) Bool_val(rebind); + CAMLparam3(ctx, info, rebind); + libxl_device_pci c_info; + int ret, marker_var; + int c_rebind = (int) Bool_val(rebind); - device_pci_val(CTX, &c_info, info); + device_pci_val(CTX, &c_info, info); - caml_enter_blocking_section(); - ret = libxl_device_pci_assignable_remove(CTX, &c_info, c_rebind); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_device_pci_assignable_remove(CTX, &c_info, c_rebind); + caml_leave_blocking_section(); - libxl_device_pci_dispose(&c_info); + libxl_device_pci_dispose(&c_info); - if (ret != 0) - failwith_xl(ret, "pci_assignable_remove"); + if (ret != 0) + failwith_xl(ret, "pci_assignable_remove"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_xl_device_pci_assignable_list(value ctx) { - CAMLparam1(ctx); - CAMLlocal2(list, temp); - libxl_device_pci *c_list; - int i, nb; - uint32_t c_domid; + CAMLparam1(ctx); + CAMLlocal2(list, temp); + libxl_device_pci *c_list; + int i, nb; + uint32_t c_domid; - caml_enter_blocking_section(); - c_list = libxl_device_pci_assignable_list(CTX, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_list = libxl_device_pci_assignable_list(CTX, &nb); + caml_leave_blocking_section(); - if (!c_list) - failwith_xl(ERROR_FAIL, "pci_assignable_list"); + if (!c_list) + failwith_xl(ERROR_FAIL, "pci_assignable_list"); - list = temp = Val_emptylist; - for (i = 0; i < nb; i++) { - list = caml_alloc_small(2, Tag_cons); - Field(list, 0) = Val_int(0); - Field(list, 1) = temp; - temp = list; - Store_field(list, 0, Val_device_pci(&c_list[i])); - } - libxl_device_pci_assignable_list_free(c_list, nb); + list = temp = Val_emptylist; + for (i = 0; i < nb; i++) { + list = caml_alloc_small(2, Tag_cons); + Field(list, 0) = Val_int(0); + Field(list, 1) = temp; + temp = list; + Store_field(list, 0, Val_device_pci(&c_list[i])); + } + libxl_device_pci_assignable_list_free(c_list, nb); - CAMLreturn(list); + CAMLreturn(list); } value stub_xl_physinfo_get(value ctx) { - CAMLparam1(ctx); - CAMLlocal1(physinfo); - libxl_physinfo c_physinfo; - int ret; + CAMLparam1(ctx); + CAMLlocal1(physinfo); + libxl_physinfo c_physinfo; + int ret; - caml_enter_blocking_section(); - ret = libxl_get_physinfo(CTX, &c_physinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_get_physinfo(CTX, &c_physinfo); + caml_leave_blocking_section(); - if (ret != 0) - failwith_xl(ret, "get_physinfo"); + if (ret != 0) + failwith_xl(ret, "get_physinfo"); - physinfo = Val_physinfo(&c_physinfo); + physinfo = Val_physinfo(&c_physinfo); - libxl_physinfo_dispose(&c_physinfo); + libxl_physinfo_dispose(&c_physinfo); - CAMLreturn(physinfo); + CAMLreturn(physinfo); } value stub_xl_cputopology_get(value ctx) { - CAMLparam1(ctx); - CAMLlocal3(topology, v, v0); - libxl_cputopology *c_topology; - int i, nr; + CAMLparam1(ctx); + CAMLlocal3(topology, v, v0); + libxl_cputopology *c_topology; + int i, nr; - caml_enter_blocking_section(); - c_topology = libxl_get_cpu_topology(CTX, &nr); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_topology = libxl_get_cpu_topology(CTX, &nr); + caml_leave_blocking_section(); - if (!c_topology) - failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo"); + if (!c_topology) + failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo"); - topology = caml_alloc_tuple(nr); - for (i = 0; i < nr; i++) { - if (c_topology[i].core != LIBXL_CPUTOPOLOGY_INVALID_ENTRY) { - v0 = Val_cputopology(&c_topology[i]); - v = Val_some(v0); - } - else - v = Val_none; - Store_field(topology, i, v); - } + topology = caml_alloc_tuple(nr); + for (i = 0; i < nr; i++) { + if (c_topology[i].core != LIBXL_CPUTOPOLOGY_INVALID_ENTRY) { + v0 = Val_cputopology(&c_topology[i]); + v = Val_some(v0); + } + else + v = Val_none; + Store_field(topology, i, v); + } - libxl_cputopology_list_free(c_topology, nr); + libxl_cputopology_list_free(c_topology, nr); - CAMLreturn(topology); + CAMLreturn(topology); } value stub_xl_dominfo_list(value ctx) { - CAMLparam1(ctx); - CAMLlocal2(domlist, temp); - libxl_dominfo *c_domlist; - int i, nb; + CAMLparam1(ctx); + CAMLlocal2(domlist, temp); + libxl_dominfo *c_domlist; + int i, nb; - caml_enter_blocking_section(); - c_domlist = libxl_list_domain(CTX, &nb); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + c_domlist = libxl_list_domain(CTX, &nb); + caml_leave_blocking_section(); - if (!c_domlist) - failwith_xl(ERROR_FAIL, "dominfo_list"); + if (!c_domlist) + failwith_xl(ERROR_FAIL, "dominfo_list"); - domlist = temp = Val_emptylist; - for (i = nb - 1; i >= 0; i--) { - domlist = caml_alloc_small(2, Tag_cons); - Field(domlist, 0) = Val_int(0); - Field(domlist, 1) = temp; - temp = domlist; + domlist = temp = Val_emptylist; + for (i = nb - 1; i >= 0; i--) { + domlist = caml_alloc_small(2, Tag_cons); + Field(domlist, 0) = Val_int(0); + Field(domlist, 1) = temp; + temp = domlist; - Store_field(domlist, 0, Val_dominfo(&c_domlist[i])); - } + Store_field(domlist, 0, Val_dominfo(&c_domlist[i])); + } - libxl_dominfo_list_free(c_domlist, nb); + libxl_dominfo_list_free(c_domlist, nb); - CAMLreturn(domlist); + CAMLreturn(domlist); } value stub_xl_dominfo_get(value ctx, value domid) { - CAMLparam2(ctx, domid); - CAMLlocal1(dominfo); - libxl_dominfo c_dominfo; - int ret; - uint32_t c_domid = Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal1(dominfo); + libxl_dominfo c_dominfo; + int ret; + uint32_t c_domid = Int_val(domid); - caml_enter_blocking_section(); - ret = libxl_domain_info(CTX, &c_dominfo, c_domid); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_info(CTX, &c_dominfo, c_domid); + caml_leave_blocking_section(); - if (ret != 0) - failwith_xl(ERROR_FAIL, "domain_info"); - dominfo = Val_dominfo(&c_dominfo); + if (ret != 0) + failwith_xl(ERROR_FAIL, "domain_info"); + dominfo = Val_dominfo(&c_dominfo); - CAMLreturn(dominfo); + CAMLreturn(dominfo); } value stub_xl_domain_sched_params_get(value ctx, value domid) { - CAMLparam2(ctx, domid); - CAMLlocal1(scinfo); - libxl_domain_sched_params c_scinfo; - int ret; - uint32_t c_domid = Int_val(domid); + CAMLparam2(ctx, domid); + CAMLlocal1(scinfo); + libxl_domain_sched_params c_scinfo; + int ret; + uint32_t c_domid = Int_val(domid); - caml_enter_blocking_section(); - ret = libxl_domain_sched_params_get(CTX, c_domid, &c_scinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_sched_params_get(CTX, c_domid, &c_scinfo); + caml_leave_blocking_section(); - if (ret != 0) - failwith_xl(ret, "domain_sched_params_get"); + if (ret != 0) + failwith_xl(ret, "domain_sched_params_get"); - scinfo = Val_domain_sched_params(&c_scinfo); + scinfo = Val_domain_sched_params(&c_scinfo); - libxl_domain_sched_params_dispose(&c_scinfo); + libxl_domain_sched_params_dispose(&c_scinfo); - CAMLreturn(scinfo); + CAMLreturn(scinfo); } value stub_xl_domain_sched_params_set(value ctx, value domid, value scinfo) { - CAMLparam3(ctx, domid, scinfo); - libxl_domain_sched_params c_scinfo; - int ret; - uint32_t c_domid = Int_val(domid); + CAMLparam3(ctx, domid, scinfo); + libxl_domain_sched_params c_scinfo; + int ret; + uint32_t c_domid = Int_val(domid); - domain_sched_params_val(CTX, &c_scinfo, scinfo); + domain_sched_params_val(CTX, &c_scinfo, scinfo); - caml_enter_blocking_section(); - ret = libxl_domain_sched_params_set(CTX, c_domid, &c_scinfo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_domain_sched_params_set(CTX, c_domid, &c_scinfo); + caml_leave_blocking_section(); - libxl_domain_sched_params_dispose(&c_scinfo); + libxl_domain_sched_params_dispose(&c_scinfo); - if (ret != 0) - failwith_xl(ret, "domain_sched_params_set"); + if (ret != 0) + failwith_xl(ret, "domain_sched_params_set"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_xl_send_trigger(value ctx, value domid, value trigger, value vcpuid, value async) { - CAMLparam5(ctx, domid, trigger, vcpuid, async); - int ret; - uint32_t c_domid = Int_val(domid); - libxl_trigger c_trigger = LIBXL_TRIGGER_UNKNOWN; - int c_vcpuid = Int_val(vcpuid); - libxl_asyncop_how *ao_how = aohow_val(async); + CAMLparam5(ctx, domid, trigger, vcpuid, async); + int ret; + uint32_t c_domid = Int_val(domid); + libxl_trigger c_trigger = LIBXL_TRIGGER_UNKNOWN; + int c_vcpuid = Int_val(vcpuid); + libxl_asyncop_how *ao_how = aohow_val(async); - trigger_val(CTX, &c_trigger, trigger); + trigger_val(CTX, &c_trigger, trigger); - caml_enter_blocking_section(); - ret = libxl_send_trigger(CTX, c_domid, c_trigger, c_vcpuid, ao_how); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_send_trigger(CTX, c_domid, c_trigger, c_vcpuid, ao_how); + caml_leave_blocking_section(); - free(ao_how); + free(ao_how); - if (ret != 0) - failwith_xl(ret, "send_trigger"); + if (ret != 0) + failwith_xl(ret, "send_trigger"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_xl_send_sysrq(value ctx, value domid, value sysrq) { - CAMLparam3(ctx, domid, sysrq); - int ret; - uint32_t c_domid = Int_val(domid); - int c_sysrq = Int_val(sysrq); + CAMLparam3(ctx, domid, sysrq); + int ret; + uint32_t c_domid = Int_val(domid); + int c_sysrq = Int_val(sysrq); - caml_enter_blocking_section(); - ret = libxl_send_sysrq(CTX, c_domid, c_sysrq); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_send_sysrq(CTX, c_domid, c_sysrq); + caml_leave_blocking_section(); - if (ret != 0) - failwith_xl(ret, "send_sysrq"); + if (ret != 0) + failwith_xl(ret, "send_sysrq"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_xl_send_debug_keys(value ctx, value keys) { - CAMLparam2(ctx, keys); - int ret; - char *c_keys; + CAMLparam2(ctx, keys); + int ret; + char *c_keys; - c_keys = dup_String_val(keys); + c_keys = dup_String_val(keys); - caml_enter_blocking_section(); - ret = libxl_send_debug_keys(CTX, c_keys); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_send_debug_keys(CTX, c_keys); + caml_leave_blocking_section(); - free(c_keys); + free(c_keys); - if (ret != 0) - failwith_xl(ret, "send_debug_keys"); + if (ret != 0) + failwith_xl(ret, "send_debug_keys"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } static struct custom_operations libxl_console_reader_custom_operations = { - "libxl_console_reader_custom_operations", - custom_finalize_default, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default + "libxl_console_reader_custom_operations", + custom_finalize_default, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default }; #define Console_reader_val(x)(*((libxl_xen_console_reader **) Data_custom_val(x))) value stub_libxl_xen_console_read_start(value ctx, value clear) { - CAMLparam2(ctx, clear); - CAMLlocal1(handle); - int c_clear = Int_val(clear); - libxl_xen_console_reader *cr; + CAMLparam2(ctx, clear); + CAMLlocal1(handle); + int c_clear = Int_val(clear); + libxl_xen_console_reader *cr; - caml_enter_blocking_section(); - cr = libxl_xen_console_read_start(CTX, c_clear); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + cr = libxl_xen_console_read_start(CTX, c_clear); + caml_leave_blocking_section(); - handle = caml_alloc_custom(&libxl_console_reader_custom_operations, sizeof(cr), 0, 1); - Console_reader_val(handle) = cr; + handle = caml_alloc_custom(&libxl_console_reader_custom_operations, sizeof(cr), 0, 1); + Console_reader_val(handle) = cr; - CAMLreturn(handle); + CAMLreturn(handle); } static void raise_eof(void) { - static const value *exc = NULL; + static const value *exc = NULL; - /* First time around, lookup by name */ - if (!exc) - exc = caml_named_value("Xenlight.Host.End_of_file"); + /* First time around, lookup by name */ + if (!exc) + exc = caml_named_value("Xenlight.Host.End_of_file"); - if (!exc) - caml_invalid_argument("Exception Xenlight.Host.End_of_file not initialized, please link xenlight.cma"); + if (!exc) + caml_invalid_argument("Exception Xenlight.Host.End_of_file not initialized, please link xenlight.cma"); - caml_raise_constant(*exc); + caml_raise_constant(*exc); } value stub_libxl_xen_console_read_line(value ctx, value reader) { - CAMLparam2(ctx, reader); - CAMLlocal1(line); - int ret; - char *c_line; - libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader); + CAMLparam2(ctx, reader); + CAMLlocal1(line); + int ret; + char *c_line; + libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader); - caml_enter_blocking_section(); - ret = libxl_xen_console_read_line(CTX, cr, &c_line); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + ret = libxl_xen_console_read_line(CTX, cr, &c_line); + caml_leave_blocking_section(); - if (ret < 0) - failwith_xl(ret, "xen_console_read_line"); - if (ret == 0) - raise_eof(); + if (ret < 0) + failwith_xl(ret, "xen_console_read_line"); + if (ret == 0) + raise_eof(); - line = caml_copy_string(c_line); + line = caml_copy_string(c_line); - CAMLreturn(line); + CAMLreturn(line); } value stub_libxl_xen_console_read_finish(value ctx, value reader) { - CAMLparam2(ctx, reader); - libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader); + CAMLparam2(ctx, reader); + libxl_xen_console_reader *cr = (libxl_xen_console_reader *) Console_reader_val(reader); - caml_enter_blocking_section(); - libxl_xen_console_read_finish(CTX, cr); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_xen_console_read_finish(CTX, cr); + caml_leave_blocking_section(); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } /* Event handling */ short Poll_val(value event) { - CAMLparam1(event); - short res = -1; + CAMLparam1(event); + short res = -1; - switch (Int_val(event)) { - case 0: res = POLLIN; break; - case 1: res = POLLPRI; break; - case 2: res = POLLOUT; break; - case 3: res = POLLERR; break; - case 4: res = POLLHUP; break; - case 5: res = POLLNVAL; break; - } + switch (Int_val(event)) { + case 0: res = POLLIN; break; + case 1: res = POLLPRI; break; + case 2: res = POLLOUT; break; + case 3: res = POLLERR; break; + case 4: res = POLLHUP; break; + case 5: res = POLLNVAL; break; + } - CAMLreturn(res); + CAMLreturn(res); } short Poll_events_val(value event_list) { - CAMLparam1(event_list); - short events = 0; + CAMLparam1(event_list); + short events = 0; - while (event_list != Val_emptylist) { - events |= Poll_val(Field(event_list, 0)); - event_list = Field(event_list, 1); - } + while (event_list != Val_emptylist) { + events |= Poll_val(Field(event_list, 0)); + event_list = Field(event_list, 1); + } - CAMLreturn(events); + CAMLreturn(events); } value Val_poll(short event) { - CAMLparam0(); - CAMLlocal1(res); + CAMLparam0(); + CAMLlocal1(res); - switch (event) { - case POLLIN: res = Val_int(0); break; - case POLLPRI: res = Val_int(1); break; - case POLLOUT: res = Val_int(2); break; - case POLLERR: res = Val_int(3); break; - case POLLHUP: res = Val_int(4); break; - case POLLNVAL: res = Val_int(5); break; - default: failwith_xl(ERROR_FAIL, "cannot convert poll event value"); break; - } + switch (event) { + case POLLIN: res = Val_int(0); break; + case POLLPRI: res = Val_int(1); break; + case POLLOUT: res = Val_int(2); break; + case POLLERR: res = Val_int(3); break; + case POLLHUP: res = Val_int(4); break; + case POLLNVAL: res = Val_int(5); break; + default: failwith_xl(ERROR_FAIL, "cannot convert poll event value"); break; + } - CAMLreturn(res); + CAMLreturn(res); } value add_event(value event_list, short event) { - CAMLparam1(event_list); - CAMLlocal1(new_list); + CAMLparam1(event_list); + CAMLlocal1(new_list); - new_list = caml_alloc(2, 0); - Store_field(new_list, 0, Val_poll(event)); - Store_field(new_list, 1, event_list); + new_list = caml_alloc(2, 0); + Store_field(new_list, 0, Val_poll(event)); + Store_field(new_list, 1, event_list); - CAMLreturn(new_list); + CAMLreturn(new_list); } value Val_poll_events(short events) { - CAMLparam0(); - CAMLlocal1(event_list); + CAMLparam0(); + CAMLlocal1(event_list); - event_list = Val_emptylist; - if (events & POLLIN) - event_list = add_event(event_list, POLLIN); - if (events & POLLPRI) - event_list = add_event(event_list, POLLPRI); - if (events & POLLOUT) - event_list = add_event(event_list, POLLOUT); - if (events & POLLERR) - event_list = add_event(event_list, POLLERR); - if (events & POLLHUP) - event_list = add_event(event_list, POLLHUP); - if (events & POLLNVAL) - event_list = add_event(event_list, POLLNVAL); + event_list = Val_emptylist; + if (events & POLLIN) + event_list = add_event(event_list, POLLIN); + if (events & POLLPRI) + event_list = add_event(event_list, POLLPRI); + if (events & POLLOUT) + event_list = add_event(event_list, POLLOUT); + if (events & POLLERR) + event_list = add_event(event_list, POLLERR); + if (events & POLLHUP) + event_list = add_event(event_list, POLLHUP); + if (events & POLLNVAL) + event_list = add_event(event_list, POLLNVAL); - CAMLreturn(event_list); + CAMLreturn(event_list); } /* The process for dealing with the for_app_registration_ values in the @@ -1273,385 +1273,385 @@ value Val_poll_events(short events) int fd_register(void *user, int fd, void **for_app_registration_out, short events, void *for_libxl) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - int ret = 0; - static const value *func = NULL; - value *p = (value *) user; - value *for_app; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + int ret = 0; + static const value *func = NULL; + value *p = (value *) user; + value *for_app; - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_fd_register"); - } + if (func == NULL) { + /* First time around, lookup by name */ + func = caml_named_value("libxl_fd_register"); + } - args[0] = *p; - args[1] = Val_int(fd); - args[2] = Val_poll_events(events); - args[3] = (value) for_libxl; + args[0] = *p; + args[1] = Val_int(fd); + args[2] = Val_poll_events(events); + args[3] = (value) for_libxl; - for_app = malloc(sizeof(value)); - if (!for_app) { - ret = ERROR_OSEVENT_REG_FAIL; - goto err; - } + for_app = malloc(sizeof(value)); + if (!for_app) { + ret = ERROR_OSEVENT_REG_FAIL; + goto err; + } - *for_app = caml_callbackN_exn(*func, 4, args); - if (Is_exception_result(*for_app)) { - ret = ERROR_OSEVENT_REG_FAIL; - free(for_app); - goto err; - } + *for_app = caml_callbackN_exn(*func, 4, args); + if (Is_exception_result(*for_app)) { + ret = ERROR_OSEVENT_REG_FAIL; + free(for_app); + goto err; + } - caml_register_global_root(for_app); - *for_app_registration_out = for_app; + caml_register_global_root(for_app); + *for_app_registration_out = for_app; err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + CAMLdone; + caml_enter_blocking_section(); + return ret; } int fd_modify(void *user, int fd, void **for_app_registration_update, short events) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - int ret = 0; - static const value *func = NULL; - value *p = (value *) user; - value *for_app = *for_app_registration_update; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + int ret = 0; + static const value *func = NULL; + value *p = (value *) user; + value *for_app = *for_app_registration_update; - /* If for_app == NULL, then something is very wrong */ - assert(for_app); + /* If for_app == NULL, then something is very wrong */ + assert(for_app); - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_fd_modify"); - } + if (func == NULL) { + /* First time around, lookup by name */ + func = caml_named_value("libxl_fd_modify"); + } - args[0] = *p; - args[1] = Val_int(fd); - args[2] = *for_app; - args[3] = Val_poll_events(events); + args[0] = *p; + args[1] = Val_int(fd); + args[2] = *for_app; + args[3] = Val_poll_events(events); - *for_app = caml_callbackN_exn(*func, 4, args); - if (Is_exception_result(*for_app)) { - /* If an exception is caught, *for_app_registration_update is not - * changed. It remains a valid pointer to a value that is registered - * with the GC. */ - ret = ERROR_OSEVENT_REG_FAIL; - goto err; - } + *for_app = caml_callbackN_exn(*func, 4, args); + if (Is_exception_result(*for_app)) { + /* If an exception is caught, *for_app_registration_update is not + * changed. It remains a valid pointer to a value that is registered + * with the GC. */ + ret = ERROR_OSEVENT_REG_FAIL; + goto err; + } - *for_app_registration_update = for_app; + *for_app_registration_update = for_app; err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + CAMLdone; + caml_enter_blocking_section(); + return ret; } void fd_deregister(void *user, int fd, void *for_app_registration) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 3); - static const value *func = NULL; - value *p = (value *) user; - value *for_app = for_app_registration; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 3); + static const value *func = NULL; + value *p = (value *) user; + value *for_app = for_app_registration; - /* If for_app == NULL, then something is very wrong */ - assert(for_app); + /* If for_app == NULL, then something is very wrong */ + assert(for_app); - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_fd_deregister"); - } + if (func == NULL) { + /* First time around, lookup by name */ + func = caml_named_value("libxl_fd_deregister"); + } - args[0] = *p; - args[1] = Val_int(fd); - args[2] = *for_app; + args[0] = *p; + args[1] = Val_int(fd); + args[2] = *for_app; - caml_callbackN_exn(*func, 3, args); - /* This hook does not return error codes, so the best thing we can do - * to avoid trouble, if we catch an exception from the app, is abort. */ - if (Is_exception_result(*for_app)) - abort(); + caml_callbackN_exn(*func, 3, args); + /* This hook does not return error codes, so the best thing we can do + * to avoid trouble, if we catch an exception from the app, is abort. */ + if (Is_exception_result(*for_app)) + abort(); - caml_remove_global_root(for_app); - free(for_app); + caml_remove_global_root(for_app); + free(for_app); - CAMLdone; - caml_enter_blocking_section(); + CAMLdone; + caml_enter_blocking_section(); } struct timeout_handles { - void *for_libxl; - value for_app; + void *for_libxl; + value for_app; }; int timeout_register(void *user, void **for_app_registration_out, struct timeval abs, void *for_libxl) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocal2(sec, usec); - CAMLlocalN(args, 4); - int ret = 0; - static const value *func = NULL; - value *p = (value *) user; - struct timeout_handles *handles; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocal2(sec, usec); + CAMLlocalN(args, 4); + int ret = 0; + static const value *func = NULL; + value *p = (value *) user; + struct timeout_handles *handles; - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_timeout_register"); - } + if (func == NULL) { + /* First time around, lookup by name */ + func = caml_named_value("libxl_timeout_register"); + } - sec = caml_copy_int64(abs.tv_sec); - usec = caml_copy_int64(abs.tv_usec); + sec = caml_copy_int64(abs.tv_sec); + usec = caml_copy_int64(abs.tv_usec); - /* This struct of "handles" will contain "for_libxl" as well as "for_app". - * We'll give a pointer to the struct to the app, and get it back in - * occurred_timeout, where we can clean it all up. */ - handles = malloc(sizeof(*handles)); - if (!handles) { - ret = ERROR_OSEVENT_REG_FAIL; - goto err; - } + /* This struct of "handles" will contain "for_libxl" as well as "for_app". + * We'll give a pointer to the struct to the app, and get it back in + * occurred_timeout, where we can clean it all up. */ + handles = malloc(sizeof(*handles)); + if (!handles) { + ret = ERROR_OSEVENT_REG_FAIL; + goto err; + } - handles->for_libxl = for_libxl; + handles->for_libxl = for_libxl; - args[0] = *p; - args[1] = sec; - args[2] = usec; - args[3] = (value) handles; + args[0] = *p; + args[1] = sec; + args[2] = usec; + args[3] = (value) handles; - handles->for_app = caml_callbackN_exn(*func, 4, args); - if (Is_exception_result(handles->for_app)) { - ret = ERROR_OSEVENT_REG_FAIL; - free(handles); - goto err; - } + handles->for_app = caml_callbackN_exn(*func, 4, args); + if (Is_exception_result(handles->for_app)) { + ret = ERROR_OSEVENT_REG_FAIL; + free(handles); + goto err; + } - caml_register_global_root(&handles->for_app); - *for_app_registration_out = handles; + caml_register_global_root(&handles->for_app); + *for_app_registration_out = handles; err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + CAMLdone; + caml_enter_blocking_section(); + return ret; } int timeout_modify(void *user, void **for_app_registration_update, struct timeval abs) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocal1(for_app_update); - CAMLlocalN(args, 2); - int ret = 0; - static const value *func = NULL; - value *p = (value *) user; - struct timeout_handles *handles = *for_app_registration_update; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocal1(for_app_update); + CAMLlocalN(args, 2); + int ret = 0; + static const value *func = NULL; + value *p = (value *) user; + struct timeout_handles *handles = *for_app_registration_update; - /* If for_app == NULL, then something is very wrong */ - assert(handles->for_app); + /* If for_app == NULL, then something is very wrong */ + assert(handles->for_app); - /* Libxl currently promises that timeout_modify is only ever called with - * abs={0,0}, meaning "right away". We cannot deal with other values. */ - assert(abs.tv_sec == 0 && abs.tv_usec == 0); + /* Libxl currently promises that timeout_modify is only ever called with + * abs={0,0}, meaning "right away". We cannot deal with other values. */ + assert(abs.tv_sec == 0 && abs.tv_usec == 0); - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_timeout_fire_now"); - } + if (func == NULL) { + /* First time around, lookup by name */ + func = caml_named_value("libxl_timeout_fire_now"); + } - args[0] = *p; - args[1] = handles->for_app; + args[0] = *p; + args[1] = handles->for_app; - for_app_update = caml_callbackN_exn(*func, 2, args); - if (Is_exception_result(for_app_update)) { - /* If an exception is caught, *for_app_registration_update is not - * changed. It remains a valid pointer to a value that is registered - * with the GC. */ - ret = ERROR_OSEVENT_REG_FAIL; - goto err; - } + for_app_update = caml_callbackN_exn(*func, 2, args); + if (Is_exception_result(for_app_update)) { + /* If an exception is caught, *for_app_registration_update is not + * changed. It remains a valid pointer to a value that is registered + * with the GC. */ + ret = ERROR_OSEVENT_REG_FAIL; + goto err; + } - handles->for_app = for_app_update; + handles->for_app = for_app_update; err: - CAMLdone; - caml_enter_blocking_section(); - return ret; + CAMLdone; + caml_enter_blocking_section(); + return ret; } void timeout_deregister(void *user, void *for_app_registration) { - /* This hook will never be called by libxl. */ - abort(); + /* This hook will never be called by libxl. */ + abort(); } value stub_libxl_osevent_register_hooks(value ctx, value user) { - CAMLparam2(ctx, user); - CAMLlocal1(result); - libxl_osevent_hooks *hooks; - value *p; + CAMLparam2(ctx, user); + CAMLlocal1(result); + libxl_osevent_hooks *hooks; + value *p; - hooks = malloc(sizeof(*hooks)); - if (!hooks) - failwith_xl(ERROR_NOMEM, "cannot allocate osevent hooks"); - hooks->fd_register = fd_register; - hooks->fd_modify = fd_modify; - hooks->fd_deregister = fd_deregister; - hooks->timeout_register = timeout_register; - hooks->timeout_modify = timeout_modify; - hooks->timeout_deregister = timeout_deregister; + hooks = malloc(sizeof(*hooks)); + if (!hooks) + failwith_xl(ERROR_NOMEM, "cannot allocate osevent hooks"); + hooks->fd_register = fd_register; + hooks->fd_modify = fd_modify; + hooks->fd_deregister = fd_deregister; + hooks->timeout_register = timeout_register; + hooks->timeout_modify = timeout_modify; + hooks->timeout_deregister = timeout_deregister; - p = malloc(sizeof(value)); - if (!p) - failwith_xl(ERROR_NOMEM, "cannot allocate value"); - *p = user; - caml_register_global_root(p); + p = malloc(sizeof(value)); + if (!p) + failwith_xl(ERROR_NOMEM, "cannot allocate value"); + *p = user; + caml_register_global_root(p); - caml_enter_blocking_section(); - libxl_osevent_register_hooks(CTX, hooks, (void *) p); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_osevent_register_hooks(CTX, hooks, (void *) p); + caml_leave_blocking_section(); - result = caml_alloc(1, Abstract_tag); - *((libxl_osevent_hooks **) result) = hooks; + result = caml_alloc(1, Abstract_tag); + *((libxl_osevent_hooks **) result) = hooks; - CAMLreturn(result); + CAMLreturn(result); } value stub_libxl_osevent_occurred_fd(value ctx, value for_libxl, value fd, - value events, value revents) + value events, value revents) { - CAMLparam5(ctx, for_libxl, fd, events, revents); - int c_fd = Int_val(fd); - short c_events = Poll_events_val(events); - short c_revents = Poll_events_val(revents); + CAMLparam5(ctx, for_libxl, fd, events, revents); + int c_fd = Int_val(fd); + short c_events = Poll_events_val(events); + short c_revents = Poll_events_val(revents); - caml_enter_blocking_section(); - libxl_osevent_occurred_fd(CTX, (void *) for_libxl, c_fd, c_events, c_revents); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_osevent_occurred_fd(CTX, (void *) for_libxl, c_fd, c_events, c_revents); + caml_leave_blocking_section(); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } value stub_libxl_osevent_occurred_timeout(value ctx, value handles) { - CAMLparam1(ctx); - struct timeout_handles *c_handles = (struct timeout_handles *) handles; + CAMLparam1(ctx); + struct timeout_handles *c_handles = (struct timeout_handles *) handles; - caml_enter_blocking_section(); - libxl_osevent_occurred_timeout(CTX, (void *) c_handles->for_libxl); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_osevent_occurred_timeout(CTX, (void *) c_handles->for_libxl); + caml_leave_blocking_section(); - caml_remove_global_root(&c_handles->for_app); - free(c_handles); + caml_remove_global_root(&c_handles->for_app); + free(c_handles); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } struct user_with_ctx { - libxl_ctx *ctx; - value user; + libxl_ctx *ctx; + value user; }; void event_occurs(void *user, libxl_event *event) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 2); - struct user_with_ctx *c_user = (struct user_with_ctx *) user; - static const value *func = NULL; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 2); + struct user_with_ctx *c_user = (struct user_with_ctx *) user; + static const value *func = NULL; - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_event_occurs_callback"); - } + if (func == NULL) { + /* First time around, lookup by name */ + func = caml_named_value("libxl_event_occurs_callback"); + } - args[0] = c_user->user; - args[1] = Val_event(event); - libxl_event_free(c_user->ctx, event); + args[0] = c_user->user; + args[1] = Val_event(event); + libxl_event_free(c_user->ctx, event); - caml_callbackN(*func, 2, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 2, args); + CAMLdone; + caml_enter_blocking_section(); } void disaster(void *user, libxl_event_type type, const char *msg, int errnoval) { - caml_leave_blocking_section(); - CAMLparam0(); - CAMLlocalN(args, 4); - struct user_with_ctx *c_user = (struct user_with_ctx *) user; - static const value *func = NULL; + caml_leave_blocking_section(); + CAMLparam0(); + CAMLlocalN(args, 4); + struct user_with_ctx *c_user = (struct user_with_ctx *) user; + static const value *func = NULL; - if (func == NULL) { - /* First time around, lookup by name */ - func = caml_named_value("libxl_event_disaster_callback"); - } + if (func == NULL) { + /* First time around, lookup by name */ + func = caml_named_value("libxl_event_disaster_callback"); + } - args[0] = c_user->user; - args[1] = Val_event_type(type); - args[2] = caml_copy_string(msg); - args[3] = Val_int(errnoval); + args[0] = c_user->user; + args[1] = Val_event_type(type); + args[2] = caml_copy_string(msg); + args[3] = Val_int(errnoval); - caml_callbackN(*func, 4, args); - CAMLdone; - caml_enter_blocking_section(); + caml_callbackN(*func, 4, args); + CAMLdone; + caml_enter_blocking_section(); } value stub_libxl_event_register_callbacks(value ctx, value user) { - CAMLparam2(ctx, user); - CAMLlocal1(result); - struct user_with_ctx *c_user = NULL; - libxl_event_hooks *hooks; + CAMLparam2(ctx, user); + CAMLlocal1(result); + struct user_with_ctx *c_user = NULL; + libxl_event_hooks *hooks; - c_user = malloc(sizeof(*c_user)); - if (!c_user) - failwith_xl(ERROR_NOMEM, "cannot allocate user value"); - c_user->user = user; - c_user->ctx = CTX; - caml_register_global_root(&c_user->user); + c_user = malloc(sizeof(*c_user)); + if (!c_user) + failwith_xl(ERROR_NOMEM, "cannot allocate user value"); + c_user->user = user; + c_user->ctx = CTX; + caml_register_global_root(&c_user->user); - hooks = malloc(sizeof(*hooks)); - if (!hooks) - failwith_xl(ERROR_NOMEM, "cannot allocate event hooks"); - hooks->event_occurs_mask = LIBXL_EVENTMASK_ALL; - hooks->event_occurs = event_occurs; - hooks->disaster = disaster; + hooks = malloc(sizeof(*hooks)); + if (!hooks) + failwith_xl(ERROR_NOMEM, "cannot allocate event hooks"); + hooks->event_occurs_mask = LIBXL_EVENTMASK_ALL; + hooks->event_occurs = event_occurs; + hooks->disaster = disaster; - caml_enter_blocking_section(); - libxl_event_register_callbacks(CTX, hooks, (void *) c_user); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_event_register_callbacks(CTX, hooks, (void *) c_user); + caml_leave_blocking_section(); - result = caml_alloc(1, Abstract_tag); - *((libxl_event_hooks **) result) = hooks; + result = caml_alloc(1, Abstract_tag); + *((libxl_event_hooks **) result) = hooks; - CAMLreturn(result); + CAMLreturn(result); } value stub_libxl_evenable_domain_death(value ctx, value domid, value user) { - CAMLparam3(ctx, domid, user); - uint32_t c_domid = Int_val(domid); - int c_user = Int_val(user); - libxl_evgen_domain_death *evgen_out; + CAMLparam3(ctx, domid, user); + uint32_t c_domid = Int_val(domid); + int c_user = Int_val(user); + libxl_evgen_domain_death *evgen_out; - caml_enter_blocking_section(); - libxl_evenable_domain_death(CTX, c_domid, c_user, &evgen_out); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + libxl_evenable_domain_death(CTX, c_domid, c_user, &evgen_out); + caml_leave_blocking_section(); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } /* diff --git a/tools/ocaml/libs/xs/queueop.ml b/tools/ocaml/libs/xs/queueop.ml index 4e532cdaea..e069ab7a9c 100644 --- a/tools/ocaml/libs/xs/queueop.ml +++ b/tools/ocaml/libs/xs/queueop.ml @@ -18,8 +18,8 @@ open Xenbus let data_concat ls = (String.concat "\000" ls) ^ "\000" let queue con pkt = let r = Xb.queue con pkt in assert (r <> None) let queue_path ty (tid: int) (path: string) con = - let data = data_concat [ path; ] in - queue con (Xb.Packet.create tid 0 ty data) + let data = data_concat [ path; ] in + queue con (Xb.Packet.create tid 0 ty data) (* operations *) let directory tid path con = queue_path Xb.Op.Directory tid path con @@ -28,48 +28,48 @@ let read tid path con = queue_path Xb.Op.Read tid path con let getperms tid path con = queue_path Xb.Op.Getperms tid path con let debug commands con = - queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands)) + queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands)) let watch path data con = - let data = data_concat [ path; data; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) + let data = data_concat [ path; data; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) let unwatch path data con = - let data = data_concat [ path; data; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) + let data = data_concat [ path; data; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) let transaction_start con = - queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat [])) + queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat [])) let transaction_end tid commit con = - let data = data_concat [ (if commit then "T" else "F"); ] in - queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data) + let data = data_concat [ (if commit then "T" else "F"); ] in + queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data) let introduce domid mfn port con = - let data = data_concat [ Printf.sprintf "%u" domid; - Printf.sprintf "%nu" mfn; - string_of_int port; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data) + let data = data_concat [ Printf.sprintf "%u" domid; + Printf.sprintf "%nu" mfn; + string_of_int port; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data) let release domid con = - let data = data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Release data) + let data = data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Release data) let resume domid con = - let data = data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) + let data = data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) let getdomainpath domid con = - let data = data_concat [ Printf.sprintf "%u" domid; ] in - queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data) + let data = data_concat [ Printf.sprintf "%u" domid; ] in + queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data) let write tid path value con = - let data = path ^ "\000" ^ value (* no NULL at the end *) in - queue con (Xb.Packet.create tid 0 Xb.Op.Write data) + let data = path ^ "\000" ^ value (* no NULL at the end *) in + queue con (Xb.Packet.create tid 0 Xb.Op.Write data) let mkdir tid path con = queue_path Xb.Op.Mkdir tid path con let rm tid path con = queue_path Xb.Op.Rm tid path con let setperms tid path perms con = - let data = data_concat [ path; perms ] in - queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data) + let data = data_concat [ path; perms ] in + queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data) diff --git a/tools/ocaml/libs/xs/xs.ml b/tools/ocaml/libs/xs/xs.ml index 90bd68d73d..55d4f010b6 100644 --- a/tools/ocaml/libs/xs/xs.ml +++ b/tools/ocaml/libs/xs/xs.ml @@ -19,46 +19,46 @@ type con = Xsraw.con type domid = int type xsh = -{ - con: con; - debug: string list -> string; - directory: string -> string list; - read: string -> string; - readv: string -> string list -> string list; - write: string -> string -> unit; - writev: string -> (string * string) list -> unit; - mkdir: string -> unit; - rm: string -> unit; - getperms: string -> perms; - setperms: string -> perms -> unit; - setpermsv: string -> string list -> perms -> unit; - introduce: domid -> nativeint -> int -> unit; - release: domid -> unit; - resume: domid -> unit; - getdomainpath: domid -> string; - watch: string -> string -> unit; - unwatch: string -> string -> unit; -} + { + con: con; + debug: string list -> string; + directory: string -> string list; + read: string -> string; + readv: string -> string list -> string list; + write: string -> string -> unit; + writev: string -> (string * string) list -> unit; + mkdir: string -> unit; + rm: string -> unit; + getperms: string -> perms; + setperms: string -> perms -> unit; + setpermsv: string -> string list -> perms -> unit; + introduce: domid -> nativeint -> int -> unit; + release: domid -> unit; + resume: domid -> unit; + getdomainpath: domid -> string; + watch: string -> string -> unit; + unwatch: string -> string -> unit; + } let get_operations con = { - con = con; - debug = (fun commands -> Xsraw.debug commands con); - directory = (fun path -> Xsraw.directory 0 path con); - read = (fun path -> Xsraw.read 0 path con); - readv = (fun dir vec -> Xsraw.readv 0 dir vec con); - write = (fun path value -> Xsraw.write 0 path value con); - writev = (fun dir vec -> Xsraw.writev 0 dir vec con); - mkdir = (fun path -> Xsraw.mkdir 0 path con); - rm = (fun path -> Xsraw.rm 0 path con); - getperms = (fun path -> Xsraw.getperms 0 path con); - setperms = (fun path perms -> Xsraw.setperms 0 path perms con); - setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con); - introduce = (fun id mfn port -> Xsraw.introduce id mfn port con); - release = (fun id -> Xsraw.release id con); - resume = (fun id -> Xsraw.resume id con); - getdomainpath = (fun id -> Xsraw.getdomainpath id con); - watch = (fun path data -> Xsraw.watch path data con); - unwatch = (fun path data -> Xsraw.unwatch path data con); + con = con; + debug = (fun commands -> Xsraw.debug commands con); + directory = (fun path -> Xsraw.directory 0 path con); + read = (fun path -> Xsraw.read 0 path con); + readv = (fun dir vec -> Xsraw.readv 0 dir vec con); + write = (fun path value -> Xsraw.write 0 path value con); + writev = (fun dir vec -> Xsraw.writev 0 dir vec con); + mkdir = (fun path -> Xsraw.mkdir 0 path con); + rm = (fun path -> Xsraw.rm 0 path con); + getperms = (fun path -> Xsraw.getperms 0 path con); + setperms = (fun path perms -> Xsraw.setperms 0 path perms con); + setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con); + introduce = (fun id mfn port -> Xsraw.introduce id mfn port con); + release = (fun id -> Xsraw.release id con); + resume = (fun id -> Xsraw.resume id con); + getdomainpath = (fun id -> Xsraw.getdomainpath id con); + watch = (fun path data -> Xsraw.watch path data con); + unwatch = (fun path data -> Xsraw.unwatch path data con); } let transaction xsh = Xst.transaction xsh.con @@ -81,71 +81,71 @@ exception Timeout_with_nonempty_queue let max_blocking_time = 5. (* seconds *) let read_watchevent_timeout xsh timeout callback = - let start_time = Unix.gettimeofday () in - let end_time = start_time +. timeout in + let start_time = Unix.gettimeofday () in + let end_time = start_time +. timeout in - let left = ref timeout in + let left = ref timeout in - (* Returns true if a watch event in the queue satisfied us *) - let process_queued_events () = - let success = ref false in - while Xsraw.has_watchevents xsh.con && not(!success) - do - success := callback (Xsraw.get_watchevent xsh.con) - done; - !success in - (* Returns true if a watch event read from the socket satisfied us *) - let process_incoming_event () = - let fd = get_fd xsh in - let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in + (* Returns true if a watch event in the queue satisfied us *) + let process_queued_events () = + let success = ref false in + while Xsraw.has_watchevents xsh.con && not(!success) + do + success := callback (Xsraw.get_watchevent xsh.con) + done; + !success in + (* Returns true if a watch event read from the socket satisfied us *) + let process_incoming_event () = + let fd = get_fd xsh in + let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in - (* If data is available for reading then read it *) - if r = [] - then false (* timeout, either a max_blocking_time or global *) - else callback (Xsraw.read_watchevent xsh.con) in + (* If data is available for reading then read it *) + if r = [] + then false (* timeout, either a max_blocking_time or global *) + else callback (Xsraw.read_watchevent xsh.con) in - let success = ref false in - while !left > 0. && not(!success) - do - (* NB the 'callback' might call back into Xs functions - and as a side-effect, watches might be queued. Hence - we must process the queue on every loop iteration *) + let success = ref false in + while !left > 0. && not(!success) + do + (* NB the 'callback' might call back into Xs functions + and as a side-effect, watches might be queued. Hence + we must process the queue on every loop iteration *) - (* First process all queued watch events *) - if not(!success) - then success := process_queued_events (); - (* Then block for one more watch event *) - if not(!success) - then success := process_incoming_event (); - (* Just in case our callback caused events to be queued - and this is our last time round the loop: this prevents - us throwing the Timeout_with_nonempty_queue spuriously *) - if not(!success) - then success := process_queued_events (); + (* First process all queued watch events *) + if not(!success) + then success := process_queued_events (); + (* Then block for one more watch event *) + if not(!success) + then success := process_incoming_event (); + (* Just in case our callback caused events to be queued + and this is our last time round the loop: this prevents + us throwing the Timeout_with_nonempty_queue spuriously *) + if not(!success) + then success := process_queued_events (); - (* Update the time left *) - let current_time = Unix.gettimeofday () in - left := end_time -. current_time - done; - if not(!success) then begin - (* Sanity check: it should be impossible for any - events to be queued here *) - if Xsraw.has_watchevents xsh.con - then raise Timeout_with_nonempty_queue - else raise Timeout - end + (* Update the time left *) + let current_time = Unix.gettimeofday () in + left := end_time -. current_time + done; + if not(!success) then begin + (* Sanity check: it should be impossible for any + events to be queued here *) + if Xsraw.has_watchevents xsh.con + then raise Timeout_with_nonempty_queue + else raise Timeout + end let monitor_paths xsh l time callback = - let unwatch () = - List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in - List.iter (fun (w,v) -> xsh.watch w v) l; - begin try - read_watchevent_timeout xsh time callback; - with - exn -> unwatch (); raise exn; - end; - unwatch () + let unwatch () = + List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in + List.iter (fun (w,v) -> xsh.watch w v) l; + begin try + read_watchevent_timeout xsh time callback; + with + exn -> unwatch (); raise exn; + end; + unwatch () let daemon_socket = Paths.xen_run_stored ^ "/socket" @@ -153,24 +153,24 @@ let daemon_socket = Paths.xen_run_stored ^ "/socket" exception Failed_to_connect let daemon_open () = - try - let sockaddr = Unix.ADDR_UNIX(daemon_socket) in - let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unix.connect sock sockaddr; - Unix.set_close_on_exec sock; - make sock - with _ -> raise Failed_to_connect + try + let sockaddr = Unix.ADDR_UNIX(daemon_socket) in + let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.connect sock sockaddr; + Unix.set_close_on_exec sock; + make sock + with _ -> raise Failed_to_connect let domain_open () = - let path = try - let devpath = "/dev/xen/xenbus" in - Unix.access devpath [ Unix.F_OK ]; - devpath - with Unix.Unix_error(_, _, _) -> - "/proc/xen/xenbus" in + let path = try + let devpath = "/dev/xen/xenbus" in + Unix.access devpath [ Unix.F_OK ]; + devpath + with Unix.Unix_error(_, _, _) -> + "/proc/xen/xenbus" in - let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in - Unix.set_close_on_exec fd; - make fd + let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in + Unix.set_close_on_exec fd; + make fd let close xsh = Xsraw.close xsh.con diff --git a/tools/ocaml/libs/xs/xs.mli b/tools/ocaml/libs/xs/xs.mli index ce505b659b..cf8855c7d8 100644 --- a/tools/ocaml/libs/xs/xs.mli +++ b/tools/ocaml/libs/xs/xs.mli @@ -23,31 +23,31 @@ exception Failed_to_connect - owner domid. - other perm: applied to domain that is not owner or in ACL. - ACL: list of per-domain permission - *) +*) type perms = Xsraw.perms type domid = int type con type xsh = { - con : con; - debug: string list -> string; - directory : string -> string list; - read : string -> string; - readv : string -> string list -> string list; - write : string -> string -> unit; - writev : string -> (string * string) list -> unit; - mkdir : string -> unit; - rm : string -> unit; - getperms : string -> perms; - setperms : string -> perms -> unit; - setpermsv : string -> string list -> perms -> unit; - introduce : domid -> nativeint -> int -> unit; - release : domid -> unit; - resume : domid -> unit; - getdomainpath : domid -> string; - watch : string -> string -> unit; - unwatch : string -> string -> unit; + con : con; + debug: string list -> string; + directory : string -> string list; + read : string -> string; + readv : string -> string list -> string list; + write : string -> string -> unit; + writev : string -> (string * string) list -> unit; + mkdir : string -> unit; + rm : string -> unit; + getperms : string -> perms; + setperms : string -> perms -> unit; + setpermsv : string -> string list -> perms -> unit; + introduce : domid -> nativeint -> int -> unit; + release : domid -> unit; + resume : domid -> unit; + getdomainpath : domid -> string; + watch : string -> string -> unit; + unwatch : string -> string -> unit; } (** get operations provide a vector of xenstore function that apply to one @@ -75,10 +75,10 @@ val read_watchevent_timeout : xsh -> float -> (string * string -> bool) -> unit (** register a set of watches, then wait for watchevent. remove all watches previously set before giving back the hand. *) val monitor_paths : xsh - -> (string * string) list - -> float - -> (string * string -> bool) - -> unit + -> (string * string) list + -> float + -> (string * string -> bool) + -> unit (** open a socket-based xenstored connection *) val daemon_open : unit -> xsh diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml index cbd1728060..d51e40eed3 100644 --- a/tools/ocaml/libs/xs/xsraw.ml +++ b/tools/ocaml/libs/xs/xsraw.ml @@ -23,239 +23,239 @@ exception Unexpected_packet of string exception Invalid_path of string let unexpected_packet expected received = - let s = Printf.sprintf "expecting %s received %s" - (Xb.Op.to_string expected) - (Xb.Op.to_string received) in - raise (Unexpected_packet s) + let s = Printf.sprintf "expecting %s received %s" + (Xb.Op.to_string expected) + (Xb.Op.to_string received) in + raise (Unexpected_packet s) type con = { - xb: Xenbus.Xb.t; - watchevents: (string * string) Queue.t; + xb: Xenbus.Xb.t; + watchevents: (string * string) Queue.t; } let close con = - Xb.close con.xb + Xb.close con.xb let capacity = { Xb.maxoutstanding = 1; maxwatchevents = 0; } let open_fd fd = { - xb = Xb.open_fd ~capacity fd; - watchevents = Queue.create (); + xb = Xb.open_fd ~capacity fd; + watchevents = Queue.create (); } let rec split_string ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split_string ~limit: nlimit c b) + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split_string ~limit: nlimit c b) type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR type perms = int * perm * (int * perm) list let string_of_perms perms = - let owner, other, acl = perms in - let char_of_perm perm = - match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' - | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in - let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in - String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) + let owner, other, acl = perms in + let char_of_perm perm = + match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' + | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in + let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in + String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) let perms_of_string s = - let perm_of_char c = - match c with 'n' -> PERM_NONE | 'r' -> PERM_READ - | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR - | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in - let perm_of_string s = - if String.length s < 2 - then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s) - else - begin - int_of_string (String.sub s 1 (String.length s - 1)), - perm_of_char s.[0] - end in - let rec split s = - try let i = String.index s '\000' in - String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i)) - with Not_found -> if s = "" then [] else [ s ] in - let l = List.map perm_of_string (split s) in - match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, []) + let perm_of_char c = + match c with 'n' -> PERM_NONE | 'r' -> PERM_READ + | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR + | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in + let perm_of_string s = + if String.length s < 2 + then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s) + else + begin + int_of_string (String.sub s 1 (String.length s - 1)), + perm_of_char s.[0] + end in + let rec split s = + try let i = String.index s '\000' in + String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i)) + with Not_found -> if s = "" then [] else [ s ] in + let l = List.map perm_of_string (split s) in + match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, []) (* send one packet - can sleep *) let pkt_send con = - if Xb.has_old_output con.xb then - raise Partial_not_empty; - let workdone = ref false in - while not !workdone - do - workdone := Xb.output con.xb - done + if Xb.has_old_output con.xb then + raise Partial_not_empty; + let workdone = ref false in + while not !workdone + do + workdone := Xb.output con.xb + done (* receive one packet - can sleep *) let rec pkt_recv con = - match Xb.input con.xb with - | Some packet -> packet - | None -> pkt_recv con + match Xb.input con.xb with + | Some packet -> packet + | None -> pkt_recv con let pkt_recv_timeout con timeout = - let fd = Xb.get_fd con.xb in - let r, _, _ = Unix.select [ fd ] [] [] timeout in - if r = [] then - true, None - else - false, Xb.input con.xb + let fd = Xb.get_fd con.xb in + let r, _, _ = Unix.select [ fd ] [] [] timeout in + if r = [] then + true, None + else + false, Xb.input con.xb let queue_watchevent con data = - let ls = split_string ~limit:2 '\000' data in - if List.length ls != 2 then - raise (Xb.Packet.DataError "arguments number mismatch"); - let event = List.nth ls 0 - and event_data = List.nth ls 1 in - Queue.push (event, event_data) con.watchevents + let ls = split_string ~limit:2 '\000' data in + if List.length ls != 2 then + raise (Xb.Packet.DataError "arguments number mismatch"); + let event = List.nth ls 0 + and event_data = List.nth ls 1 in + Queue.push (event, event_data) con.watchevents let has_watchevents con = Queue.length con.watchevents > 0 let get_watchevent con = Queue.pop con.watchevents let read_watchevent con = - let pkt = pkt_recv con in - match Xb.Packet.get_ty pkt with - | Xb.Op.Watchevent -> - queue_watchevent con (Xb.Packet.get_data pkt); - Queue.pop con.watchevents - | ty -> unexpected_packet Xb.Op.Watchevent ty + let pkt = pkt_recv con in + match Xb.Packet.get_ty pkt with + | Xb.Op.Watchevent -> + queue_watchevent con (Xb.Packet.get_data pkt); + Queue.pop con.watchevents + | ty -> unexpected_packet Xb.Op.Watchevent ty (* send one packet in the queue, and wait for reply *) let rec sync_recv ty con = - let pkt = pkt_recv con in - match Xb.Packet.get_ty pkt with - | Xb.Op.Error -> ( - match Xb.Packet.get_data pkt with - | "ENOENT" -> raise Xb.Noent - | "EAGAIN" -> raise Xb.Eagain - | "EINVAL" -> raise Xb.Invalid - | s -> raise (Xb.Packet.Error s)) - | Xb.Op.Watchevent -> - queue_watchevent con (Xb.Packet.get_data pkt); - sync_recv ty con - | rty when rty = ty -> Xb.Packet.get_data pkt - | rty -> unexpected_packet ty rty + let pkt = pkt_recv con in + match Xb.Packet.get_ty pkt with + | Xb.Op.Error -> ( + match Xb.Packet.get_data pkt with + | "ENOENT" -> raise Xb.Noent + | "EAGAIN" -> raise Xb.Eagain + | "EINVAL" -> raise Xb.Invalid + | s -> raise (Xb.Packet.Error s)) + | Xb.Op.Watchevent -> + queue_watchevent con (Xb.Packet.get_data pkt); + sync_recv ty con + | rty when rty = ty -> Xb.Packet.get_data pkt + | rty -> unexpected_packet ty rty let sync f con = - (* queue a query using function f *) - f con.xb; - if Xb.output_len con.xb = 0 then - Printf.printf "output len = 0\n%!"; - let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in - pkt_send con; - sync_recv ty con + (* queue a query using function f *) + f con.xb; + if Xb.output_len con.xb = 0 then + Printf.printf "output len = 0\n%!"; + let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in + pkt_send con; + sync_recv ty con let ack s = - if s = "OK" then () else raise (Xb.Packet.DataError s) + if s = "OK" then () else raise (Xb.Packet.DataError s) (** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches) *) let validate_path path = - (* Paths shouldn't have a "//" in the middle *) - let bad = "//" in - for offset = 0 to String.length path - (String.length bad) do - if String.sub path offset (String.length bad) = bad then - raise (Invalid_path path) - done; - (* Paths shouldn't have a "/" at the end, except for the root *) - if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then - raise (Invalid_path path) + (* Paths shouldn't have a "//" in the middle *) + let bad = "//" in + for offset = 0 to String.length path - (String.length bad) do + if String.sub path offset (String.length bad) = bad then + raise (Invalid_path path) + done; + (* Paths shouldn't have a "/" at the end, except for the root *) + if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then + raise (Invalid_path path) (** Check to see if a path is suitable for watches *) let validate_watch_path path = - (* Check for stuff like @releaseDomain etc first *) - if path <> "" && path.[0] = '@' then () - else validate_path path + (* Check for stuff like @releaseDomain etc first *) + if path <> "" && path.[0] = '@' then () + else validate_path path let debug command con = - sync (Queueop.debug command) con + sync (Queueop.debug command) con let directory tid path con = - validate_path path; - let data = sync (Queueop.directory tid path) con in - split_string '\000' data + validate_path path; + let data = sync (Queueop.directory tid path) con in + split_string '\000' data let read tid path con = - validate_path path; - sync (Queueop.read tid path) con + validate_path path; + sync (Queueop.read tid path) con let readv tid dir vec con = - List.map (fun path -> validate_path path; read tid path con) - (if dir <> "" then - (List.map (fun v -> dir ^ "/" ^ v) vec) else vec) + List.map (fun path -> validate_path path; read tid path con) + (if dir <> "" then + (List.map (fun v -> dir ^ "/" ^ v) vec) else vec) let getperms tid path con = - validate_path path; - perms_of_string (sync (Queueop.getperms tid path) con) + validate_path path; + perms_of_string (sync (Queueop.getperms tid path) con) let watch path data con = - validate_watch_path path; - ack (sync (Queueop.watch path data) con) + validate_watch_path path; + ack (sync (Queueop.watch path data) con) let unwatch path data con = - validate_watch_path path; - ack (sync (Queueop.unwatch path data) con) + validate_watch_path path; + ack (sync (Queueop.unwatch path data) con) let transaction_start con = - let data = sync (Queueop.transaction_start) con in - try - int_of_string data - with - _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data)) + let data = sync (Queueop.transaction_start) con in + try + int_of_string data + with + _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data)) let transaction_end tid commit con = - try - ack (sync (Queueop.transaction_end tid commit) con); - true - with - Xb.Eagain -> false + try + ack (sync (Queueop.transaction_end tid commit) con); + true + with + Xb.Eagain -> false let introduce domid mfn port con = - ack (sync (Queueop.introduce domid mfn port) con) + ack (sync (Queueop.introduce domid mfn port) con) let release domid con = - ack (sync (Queueop.release domid) con) + ack (sync (Queueop.release domid) con) let resume domid con = - ack (sync (Queueop.resume domid) con) + ack (sync (Queueop.resume domid) con) let getdomainpath domid con = - sync (Queueop.getdomainpath domid) con + sync (Queueop.getdomainpath domid) con let write tid path value con = - validate_path path; - ack (sync (Queueop.write tid path value) con) + validate_path path; + ack (sync (Queueop.write tid path value) con) let writev tid dir vec con = - List.iter (fun (entry, value) -> - let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in - validate_path path; - write tid path value con) vec + List.iter (fun (entry, value) -> + let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + write tid path value con) vec let mkdir tid path con = - validate_path path; - ack (sync (Queueop.mkdir tid path) con) + validate_path path; + ack (sync (Queueop.mkdir tid path) con) let rm tid path con = - validate_path path; - try - ack (sync (Queueop.rm tid path) con) - with - Xb.Noent -> () + validate_path path; + try + ack (sync (Queueop.rm tid path) con) + with + Xb.Noent -> () let setperms tid path perms con = - validate_path path; - ack (sync (Queueop.setperms tid path (string_of_perms perms)) con) + validate_path path; + ack (sync (Queueop.setperms tid path (string_of_perms perms)) con) let setpermsv tid dir vec perms con = - List.iter (fun entry -> - let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in - validate_path path; - setperms tid path perms con) vec + List.iter (fun entry -> + let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + setperms tid path perms con) vec diff --git a/tools/ocaml/libs/xs/xst.ml b/tools/ocaml/libs/xs/xst.ml index 16affd2e07..50a980b915 100644 --- a/tools/ocaml/libs/xs/xst.ml +++ b/tools/ocaml/libs/xs/xst.ml @@ -15,47 +15,47 @@ *) type ops = -{ - directory: string -> string list; - read: string -> string; - readv: string -> string list -> string list; - write: string -> string -> unit; - writev: string -> (string * string) list -> unit; - mkdir: string -> unit; - rm: string -> unit; - getperms: string -> Xsraw.perms; - setperms: string -> Xsraw.perms -> unit; - setpermsv: string -> string list -> Xsraw.perms -> unit; -} + { + directory: string -> string list; + read: string -> string; + readv: string -> string list -> string list; + write: string -> string -> unit; + writev: string -> (string * string) list -> unit; + mkdir: string -> unit; + rm: string -> unit; + getperms: string -> Xsraw.perms; + setperms: string -> Xsraw.perms -> unit; + setpermsv: string -> string list -> Xsraw.perms -> unit; + } let get_operations tid xsh = { - directory = (fun path -> Xsraw.directory tid path xsh); - read = (fun path -> Xsraw.read tid path xsh); - readv = (fun dir vec -> Xsraw.readv tid dir vec xsh); - write = (fun path value -> Xsraw.write tid path value xsh); - writev = (fun dir vec -> Xsraw.writev tid dir vec xsh); - mkdir = (fun path -> Xsraw.mkdir tid path xsh); - rm = (fun path -> Xsraw.rm tid path xsh); - getperms = (fun path -> Xsraw.getperms tid path xsh); - setperms = (fun path perms -> Xsraw.setperms tid path perms xsh); - setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh); + directory = (fun path -> Xsraw.directory tid path xsh); + read = (fun path -> Xsraw.read tid path xsh); + readv = (fun dir vec -> Xsraw.readv tid dir vec xsh); + write = (fun path value -> Xsraw.write tid path value xsh); + writev = (fun dir vec -> Xsraw.writev tid dir vec xsh); + mkdir = (fun path -> Xsraw.mkdir tid path xsh); + rm = (fun path -> Xsraw.rm tid path xsh); + getperms = (fun path -> Xsraw.getperms tid path xsh); + setperms = (fun path perms -> Xsraw.setperms tid path perms xsh); + setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh); } let transaction xsh (f: ops -> 'a) : 'a = - let commited = ref false and result = ref None in - while not !commited - do - let tid = Xsraw.transaction_start xsh in - let t = get_operations tid xsh in + let commited = ref false and result = ref None in + while not !commited + do + let tid = Xsraw.transaction_start xsh in + let t = get_operations tid xsh in - begin try - result := Some (f t) - with exn -> - ignore (Xsraw.transaction_end tid false xsh); - raise exn - end; - commited := Xsraw.transaction_end tid true xsh - done; - match !result with - | None -> failwith "internal error in transaction" - | Some result -> result + begin try + result := Some (f t) + with exn -> + ignore (Xsraw.transaction_end tid false xsh); + raise exn + end; + commited := Xsraw.transaction_end tid true xsh + done; + match !result with + | None -> failwith "internal error in transaction" + | Some result -> result diff --git a/tools/ocaml/libs/xs/xst.mli b/tools/ocaml/libs/xs/xst.mli index 5ae560424c..08d737bc36 100644 --- a/tools/ocaml/libs/xs/xst.mli +++ b/tools/ocaml/libs/xs/xst.mli @@ -14,16 +14,16 @@ * GNU Lesser General Public License for more details. *) type ops = { - directory : string -> string list; - read : string -> string; - readv : string -> string list -> string list; - write : string -> string -> unit; - writev : string -> (string * string) list -> unit; - mkdir : string -> unit; - rm : string -> unit; - getperms : string -> Xsraw.perms; - setperms : string -> Xsraw.perms -> unit; - setpermsv : string -> string list -> Xsraw.perms -> unit; + directory : string -> string list; + read : string -> string; + readv : string -> string list -> string list; + write : string -> string -> unit; + writev : string -> (string * string) list -> unit; + mkdir : string -> unit; + rm : string -> unit; + getperms : string -> Xsraw.perms; + setperms : string -> Xsraw.perms -> unit; + setpermsv : string -> string list -> Xsraw.perms -> unit; } val get_operations : int -> Xsraw.con -> ops diff --git a/tools/ocaml/test/dmesg.ml b/tools/ocaml/test/dmesg.ml index c868024c52..f9efe5dc30 100644 --- a/tools/ocaml/test/dmesg.ml +++ b/tools/ocaml/test/dmesg.ml @@ -1,17 +1,17 @@ let _ = - Xenlight.register_exceptions (); - let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in - let ctx = Xenlight.ctx_alloc logger in + Xenlight.register_exceptions (); + let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in + let ctx = Xenlight.ctx_alloc logger in - let open Xenlight.Host in - let reader = xen_console_read_start ctx 0 in - (try - while true do - let line = xen_console_read_line ctx reader in - print_string line - done - with End_of_file -> ()); - let _ = xen_console_read_finish ctx reader in - () + let open Xenlight.Host in + let reader = xen_console_read_start ctx 0 in + (try + while true do + let line = xen_console_read_line ctx reader in + print_string line + done + with End_of_file -> ()); + let _ = xen_console_read_finish ctx reader in + () diff --git a/tools/ocaml/test/list_domains.ml b/tools/ocaml/test/list_domains.ml index c8974957fd..94f1cec050 100644 --- a/tools/ocaml/test/list_domains.ml +++ b/tools/ocaml/test/list_domains.ml @@ -20,7 +20,7 @@ let _ = let domains = Xenlight.Dominfo.list ctx in List.iter (fun d -> print_dominfo d) domains with Xenlight.Error(err, fn) -> begin - printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn; - end + printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn; + end diff --git a/tools/ocaml/test/raise_exception.ml b/tools/ocaml/test/raise_exception.ml index 5ef7fc0f13..8c24c3555b 100644 --- a/tools/ocaml/test/raise_exception.ml +++ b/tools/ocaml/test/raise_exception.ml @@ -4,6 +4,6 @@ let _ = try Xenlight.test_raise_exception () with Xenlight.Error(err, fn) -> begin - printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn; - end + printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn; + end diff --git a/tools/ocaml/test/xtl.ml b/tools/ocaml/test/xtl.ml index 5f94a76a82..458b11bbaa 100644 --- a/tools/ocaml/test/xtl.ml +++ b/tools/ocaml/test/xtl.ml @@ -2,24 +2,24 @@ open Printf open Xentoollog let stdio_vmessage min_level level errno ctx msg = - let level_str = level_to_string level - and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d" s - and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in - if compare min_level level <= 0 then begin - printf "%s%s%s: %s\n" level_str ctx_str errno_str msg; - flush stdout; - end + let level_str = level_to_string level + and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d" s + and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in + if compare min_level level <= 0 then begin + printf "%s%s%s: %s\n" level_str ctx_str errno_str msg; + flush stdout; + end let stdio_progress _ctx what percent dne total = - let nl = if dne = total then "\n" else "" in - printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl; - flush stdout + let nl = if dne = total then "\n" else "" in + printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl; + flush stdout let create_stdio_logger ?(level=Info) () = - let cbs = { - vmessage = stdio_vmessage level; - progress = stdio_progress; } in - create "Xentoollog.stdio_logger" cbs + let cbs = { + vmessage = stdio_vmessage level; + progress = stdio_progress; } in + create "Xentoollog.stdio_logger" cbs let do_test level = let lgr = create_stdio_logger ~level:level () in diff --git a/tools/ocaml/xenstored/config.ml b/tools/ocaml/xenstored/config.ml index 0ee7bc32ff..95ef745a54 100644 --- a/tools/ocaml/xenstored/config.ml +++ b/tools/ocaml/xenstored/config.ml @@ -15,98 +15,98 @@ *) type ty = - | Set_bool of bool ref - | Set_int of int ref - | Set_string of string ref - | Set_float of float ref - | Unit of (unit -> unit) - | Bool of (bool -> unit) - | Int of (int -> unit) - | String of (string -> unit) - | Float of (float -> unit) + | Set_bool of bool ref + | Set_int of int ref + | Set_string of string ref + | Set_float of float ref + | Unit of (unit -> unit) + | Bool of (bool -> unit) + | Int of (int -> unit) + | String of (string -> unit) + | Float of (float -> unit) exception Error of (string * string) list let trim_start lc s = - let len = String.length s and i = ref 0 in - while !i < len && (List.mem s.[!i] lc) - do - incr i - done; - if !i < len then String.sub s !i (len - !i) else "" + let len = String.length s and i = ref 0 in + while !i < len && (List.mem s.[!i] lc) + do + incr i + done; + if !i < len then String.sub s !i (len - !i) else "" let trim_end lc s = - let i = ref (String.length s - 1) in - while !i > 0 && (List.mem s.[!i] lc) - do - decr i - done; - if !i >= 0 then String.sub s 0 (!i + 1) else "" + let i = ref (String.length s - 1) in + while !i > 0 && (List.mem s.[!i] lc) + do + decr i + done; + if !i >= 0 then String.sub s 0 (!i + 1) else "" let rec split ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) let parse_line stream = - let lc = [ ' '; '\t' ] in - let trim_spaces s = trim_end lc (trim_start lc s) in - let to_config s = - match split ~limit:2 '=' s with - | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) - | _ -> None in - let rec read_filter_line () = - try - let line = trim_spaces (input_line stream) in - if String.length line > 0 && line.[0] <> '#' then - match to_config line with - | None -> read_filter_line () - | Some x -> x :: read_filter_line () - else - read_filter_line () - with - End_of_file -> [] in - read_filter_line () + let lc = [ ' '; '\t' ] in + let trim_spaces s = trim_end lc (trim_start lc s) in + let to_config s = + match split ~limit:2 '=' s with + | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) + | _ -> None in + let rec read_filter_line () = + try + let line = trim_spaces (input_line stream) in + if String.length line > 0 && line.[0] <> '#' then + match to_config line with + | None -> read_filter_line () + | Some x -> x :: read_filter_line () + else + read_filter_line () + with + End_of_file -> [] in + read_filter_line () let parse filename = - let stream = open_in filename in - let cf = parse_line stream in - close_in stream; - cf + let stream = open_in filename in + let cf = parse_line stream in + close_in stream; + cf let validate cf expected other = - let err = ref [] in - let append x = err := x :: !err in - List.iter (fun (k, v) -> - try - if not (List.mem_assoc k expected) then - other k v - else let ty = List.assoc k expected in - match ty with - | Unit f -> f () - | Bool f -> f (bool_of_string v) - | String f -> f v - | Int f -> f (int_of_string v) - | Float f -> f (float_of_string v) - | Set_bool r -> r := (bool_of_string v) - | Set_string r -> r := v - | Set_int r -> r := int_of_string v - | Set_float r -> r := (float_of_string v) - with - | Not_found -> append (k, "unknown key") - | Failure "int_of_string" -> append (k, "expect int arg") - | Failure "bool_of_string" -> append (k, "expect bool arg") - | Failure "float_of_string" -> append (k, "expect float arg") - | exn -> append (k, Printexc.to_string exn) - ) cf; - if !err != [] then raise (Error !err) + let err = ref [] in + let append x = err := x :: !err in + List.iter (fun (k, v) -> + try + if not (List.mem_assoc k expected) then + other k v + else let ty = List.assoc k expected in + match ty with + | Unit f -> f () + | Bool f -> f (bool_of_string v) + | String f -> f v + | Int f -> f (int_of_string v) + | Float f -> f (float_of_string v) + | Set_bool r -> r := (bool_of_string v) + | Set_string r -> r := v + | Set_int r -> r := int_of_string v + | Set_float r -> r := (float_of_string v) + with + | Not_found -> append (k, "unknown key") + | Failure "int_of_string" -> append (k, "expect int arg") + | Failure "bool_of_string" -> append (k, "expect bool arg") + | Failure "float_of_string" -> append (k, "expect float arg") + | exn -> append (k, Printexc.to_string exn) + ) cf; + if !err != [] then raise (Error !err) (** read a filename, parse and validate, and return the errors if any *) let read filename expected other = - let cf = parse filename in - validate cf expected other + let cf = parse filename in + validate cf expected other diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml index 54f7f76516..fcff0f332e 100644 --- a/tools/ocaml/xenstored/connection.ml +++ b/tools/ocaml/xenstored/connection.ml @@ -24,281 +24,281 @@ type 'a bounded_sender = 'a -> unit option (** a bounded sender accepts an ['a] item and returns: None - if there is no room to accept the item Some () - if it has successfully accepted/sent the item - *) +*) module BoundedPipe : sig - type 'a t + type 'a t - (** [create ~capacity ~destination] creates a bounded pipe with a - local buffer holding at most [capacity] items. Once the buffer is - full it will not accept further items. items from the pipe are - flushed into [destination] as long as it accepts items. The - destination could be another pipe. - *) - val create: capacity:int -> destination:'a bounded_sender -> 'a t + (** [create ~capacity ~destination] creates a bounded pipe with a + local buffer holding at most [capacity] items. Once the buffer is + full it will not accept further items. items from the pipe are + flushed into [destination] as long as it accepts items. The + destination could be another pipe. + *) + val create: capacity:int -> destination:'a bounded_sender -> 'a t - (** [is_empty t] returns whether the local buffer of [t] is empty. *) - val is_empty : _ t -> bool + (** [is_empty t] returns whether the local buffer of [t] is empty. *) + val is_empty : _ t -> bool - (** [length t] the number of items in the internal buffer *) - val length: _ t -> int + (** [length t] the number of items in the internal buffer *) + val length: _ t -> int - (** [flush_pipe t] sends as many items from the local buffer as possible, - which could be none. *) - val flush_pipe: _ t -> unit + (** [flush_pipe t] sends as many items from the local buffer as possible, + which could be none. *) + val flush_pipe: _ t -> unit - (** [push t item] tries to [flush_pipe] and then push [item] - into the pipe if its [capacity] allows. - Returns [None] if there is no more room - *) - val push : 'a t -> 'a bounded_sender + (** [push t item] tries to [flush_pipe] and then push [item] + into the pipe if its [capacity] allows. + Returns [None] if there is no more room + *) + val push : 'a t -> 'a bounded_sender end = struct - (* items are enqueued in [q], and then flushed to [connect_to] *) - type 'a t = - { q: 'a Queue.t - ; destination: 'a bounded_sender - ; capacity: int - } + (* items are enqueued in [q], and then flushed to [connect_to] *) + type 'a t = + { q: 'a Queue.t + ; destination: 'a bounded_sender + ; capacity: int + } - let create ~capacity ~destination = - { q = Queue.create (); capacity; destination } + let create ~capacity ~destination = + { q = Queue.create (); capacity; destination } - let rec flush_pipe t = - if not Queue.(is_empty t.q) then - let item = Queue.peek t.q in - match t.destination item with - | None -> () (* no room *) - | Some () -> - (* successfully sent item to next stage *) - let _ = Queue.pop t.q in - (* continue trying to send more items *) - flush_pipe t + let rec flush_pipe t = + if not Queue.(is_empty t.q) then + let item = Queue.peek t.q in + match t.destination item with + | None -> () (* no room *) + | Some () -> + (* successfully sent item to next stage *) + let _ = Queue.pop t.q in + (* continue trying to send more items *) + flush_pipe t - let push t item = - (* first try to flush as many items from this pipe as possible to make room, - it is important to do this first to preserve the order of the items - *) - flush_pipe t; - if Queue.length t.q < t.capacity then begin - (* enqueue, instead of sending directly. - this ensures that [out] sees the items in the same order as we receive them - *) - Queue.push item t.q; - Some (flush_pipe t) - end else None + let push t item = + (* first try to flush as many items from this pipe as possible to make room, + it is important to do this first to preserve the order of the items + *) + flush_pipe t; + if Queue.length t.q < t.capacity then begin + (* enqueue, instead of sending directly. + this ensures that [out] sees the items in the same order as we receive them + *) + Queue.push item t.q; + Some (flush_pipe t) + end else None - let is_empty t = Queue.is_empty t.q - let length t = Queue.length t.q + let is_empty t = Queue.is_empty t.q + let length t = Queue.length t.q end type watch = { - con: t; - token: string; - path: string; - base: string; - is_relative: bool; - pending_watchevents: Xenbus.Xb.Packet.t BoundedPipe.t; + con: t; + token: string; + path: string; + base: string; + is_relative: bool; + pending_watchevents: Xenbus.Xb.Packet.t BoundedPipe.t; } and t = { - xb: Xenbus.Xb.t; - dom: Domain.t option; - transactions: (int, Transaction.t) Hashtbl.t; - mutable next_tid: int; - watches: (string, watch list) Hashtbl.t; - mutable nb_watches: int; - anonid: int; - mutable stat_nb_ops: int; - mutable perm: Perms.Connection.t; - pending_source_watchevents: (watch * Xenbus.Xb.Packet.t) BoundedPipe.t + xb: Xenbus.Xb.t; + dom: Domain.t option; + transactions: (int, Transaction.t) Hashtbl.t; + mutable next_tid: int; + watches: (string, watch list) Hashtbl.t; + mutable nb_watches: int; + anonid: int; + mutable stat_nb_ops: int; + mutable perm: Perms.Connection.t; + pending_source_watchevents: (watch * Xenbus.Xb.Packet.t) BoundedPipe.t } module Watch = struct - module T = struct - type t = watch + module T = struct + type t = watch - let compare w1 w2 = - (* cannot compare watches from different connections *) - assert (w1.con == w2.con); - match String.compare w1.token w2.token with - | 0 -> String.compare w1.path w2.path - | n -> n - end - module Set = Set.Make(T) + let compare w1 w2 = + (* cannot compare watches from different connections *) + assert (w1.con == w2.con); + match String.compare w1.token w2.token with + | 0 -> String.compare w1.path w2.path + | n -> n + end + module Set = Set.Make(T) - let flush_events t = - BoundedPipe.flush_pipe t.pending_watchevents; - not (BoundedPipe.is_empty t.pending_watchevents) + let flush_events t = + BoundedPipe.flush_pipe t.pending_watchevents; + not (BoundedPipe.is_empty t.pending_watchevents) - let pending_watchevents t = - BoundedPipe.length t.pending_watchevents + let pending_watchevents t = + BoundedPipe.length t.pending_watchevents end let source_flush_watchevents t = - BoundedPipe.flush_pipe t.pending_source_watchevents + BoundedPipe.flush_pipe t.pending_source_watchevents let source_pending_watchevents t = - BoundedPipe.length t.pending_source_watchevents + BoundedPipe.length t.pending_source_watchevents let mark_as_bad con = - match con.dom with - |None -> () - | Some domain -> Domain.mark_as_bad domain + match con.dom with + |None -> () + | Some domain -> Domain.mark_as_bad domain let initial_next_tid = 1 let do_reconnect con = - Xenbus.Xb.reconnect con.xb; - (* dom is the same *) - Hashtbl.clear con.transactions; - con.next_tid <- initial_next_tid; - Hashtbl.clear con.watches; - (* anonid is the same *) - con.nb_watches <- 0; - con.stat_nb_ops <- 0; - (* perm is the same *) - () + Xenbus.Xb.reconnect con.xb; + (* dom is the same *) + Hashtbl.clear con.transactions; + con.next_tid <- initial_next_tid; + Hashtbl.clear con.watches; + (* anonid is the same *) + con.nb_watches <- 0; + con.stat_nb_ops <- 0; + (* perm is the same *) + () let get_path con = -Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d) + Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d) let watch_create ~con ~path ~token = { - con = con; - token = token; - path = path; - base = get_path con; - is_relative = path.[0] <> '/' && path.[0] <> '@'; - pending_watchevents = BoundedPipe.create ~capacity:!Define.maxwatchevents ~destination:(Xenbus.Xb.queue con.xb) + con = con; + token = token; + path = path; + base = get_path con; + is_relative = path.[0] <> '/' && path.[0] <> '@'; + pending_watchevents = BoundedPipe.create ~capacity:!Define.maxwatchevents ~destination:(Xenbus.Xb.queue con.xb) } let get_con w = w.con let number_of_transactions con = - Hashtbl.length con.transactions + Hashtbl.length con.transactions let get_domain con = con.dom let anon_id_next = ref 1 let get_domstr con = - match con.dom with - | None -> "A" ^ (string_of_int con.anonid) - | Some dom -> "D" ^ (string_of_int (Domain.get_id dom)) + match con.dom with + | None -> "A" ^ (string_of_int con.anonid) + | Some dom -> "D" ^ (string_of_int (Domain.get_id dom)) let make_perm dom = - let domid = - match dom with - | None -> 0 - | Some d -> Domain.get_id d - in - Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid + let domid = + match dom with + | None -> 0 + | Some d -> Domain.get_id d + in + Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid let create xbcon dom = - let destination (watch, pkt) = - BoundedPipe.push watch.pending_watchevents pkt - in - let id = - match dom with - | None -> let old = !anon_id_next in incr anon_id_next; old - | Some _ -> 0 - in - let con = - { - xb = xbcon; - dom = dom; - transactions = Hashtbl.create 5; - next_tid = initial_next_tid; - watches = Hashtbl.create 8; - nb_watches = 0; - anonid = id; - stat_nb_ops = 0; - perm = make_perm dom; + let destination (watch, pkt) = + BoundedPipe.push watch.pending_watchevents pkt + in + let id = + match dom with + | None -> let old = !anon_id_next in incr anon_id_next; old + | Some _ -> 0 + in + let con = + { + xb = xbcon; + dom = dom; + transactions = Hashtbl.create 5; + next_tid = initial_next_tid; + watches = Hashtbl.create 8; + nb_watches = 0; + anonid = id; + stat_nb_ops = 0; + perm = make_perm dom; - (* the actual capacity will be lower, this is used as an overflow - buffer: anything that doesn't fit elsewhere gets put here, only - limited by the amount of watches that you can generate with a - single xenstore command (which is finite, although possibly very - large in theory for Dom0). Once the pipe here has any contents the - domain is blocked from sending more commands until it is empty - again though. - *) - pending_source_watchevents = BoundedPipe.create ~capacity:Sys.max_array_length ~destination - } - in - Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con); - con + (* the actual capacity will be lower, this is used as an overflow + buffer: anything that doesn't fit elsewhere gets put here, only + limited by the amount of watches that you can generate with a + single xenstore command (which is finite, although possibly very + large in theory for Dom0). Once the pipe here has any contents the + domain is blocked from sending more commands until it is empty + again though. + *) + pending_source_watchevents = BoundedPipe.create ~capacity:Sys.max_array_length ~destination + } + in + Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con); + con let get_fd con = Xenbus.Xb.get_fd con.xb let close con = - Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con); - Xenbus.Xb.close con.xb + Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con); + Xenbus.Xb.close con.xb let get_perm con = - con.perm + con.perm let set_target con target_domid = - con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid + con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid let is_backend_mmap con = Xenbus.Xb.is_mmap con.xb let packet_of con tid rid ty data = - if (String.length data) > xenstore_payload_max && (is_backend_mmap con) then - Xenbus.Xb.Packet.create tid rid Xenbus.Xb.Op.Error "E2BIG\000" - else - Xenbus.Xb.Packet.create tid rid ty data + if (String.length data) > xenstore_payload_max && (is_backend_mmap con) then + Xenbus.Xb.Packet.create tid rid Xenbus.Xb.Op.Error "E2BIG\000" + else + Xenbus.Xb.Packet.create tid rid ty data let send_reply con tid rid ty data = - let result = Xenbus.Xb.queue con.xb (packet_of con tid rid ty data) in - (* should never happen: we only process an input packet when there is room for an output packet *) - (* and the limit for replies is different from the limit for watch events *) - assert (result <> None) + let result = Xenbus.Xb.queue con.xb (packet_of con tid rid ty data) in + (* should never happen: we only process an input packet when there is room for an output packet *) + (* and the limit for replies is different from the limit for watch events *) + assert (result <> None) let send_error con tid rid err = send_reply con tid rid Xenbus.Xb.Op.Error (err ^ "\000") let send_ack con tid rid ty = send_reply con tid rid ty "OK\000" let get_watch_path con path = - if path.[0] = '@' || path.[0] = '/' then - path - else - let rpath = get_path con in - rpath ^ path + if path.[0] = '@' || path.[0] = '/' then + path + else + let rpath = get_path con in + rpath ^ path let get_watches (con: t) path = - if Hashtbl.mem con.watches path - then Hashtbl.find con.watches path - else [] + if Hashtbl.mem con.watches path + then Hashtbl.find con.watches path + else [] let get_children_watches con path = - let path = path ^ "/" in - List.concat (Hashtbl.fold (fun p w l -> - if String.startswith path p then w :: l else l) con.watches []) + let path = path ^ "/" in + List.concat (Hashtbl.fold (fun p w l -> + if String.startswith path p then w :: l else l) con.watches []) let is_dom0 con = - Perms.Connection.is_dom0 (get_perm con) + Perms.Connection.is_dom0 (get_perm con) let add_watch con (path, apath) token = - if !Quota.activate && !Define.maxwatch > 0 && - not (is_dom0 con) && con.nb_watches > !Define.maxwatch then - raise Quota.Limit_reached; - let l = get_watches con apath in - if List.exists (fun w -> w.token = token) l then - raise Define.Already_exist; - let watch = watch_create ~con ~token ~path in - Hashtbl.replace con.watches apath (watch :: l); - con.nb_watches <- con.nb_watches + 1; - watch + if !Quota.activate && !Define.maxwatch > 0 && + not (is_dom0 con) && con.nb_watches > !Define.maxwatch then + raise Quota.Limit_reached; + let l = get_watches con apath in + if List.exists (fun w -> w.token = token) l then + raise Define.Already_exist; + let watch = watch_create ~con ~token ~path in + Hashtbl.replace con.watches apath (watch :: l); + con.nb_watches <- con.nb_watches + 1; + watch let del_watch con path token = - let apath = get_watch_path con path in - let ws = Hashtbl.find con.watches apath in - let w = List.find (fun w -> w.token = token) ws in - let filtered = Utils.list_remove w ws in - if List.length filtered > 0 then - Hashtbl.replace con.watches apath filtered - else - Hashtbl.remove con.watches apath; - con.nb_watches <- con.nb_watches - 1; - apath, w + let apath = get_watch_path con path in + let ws = Hashtbl.find con.watches apath in + let w = List.find (fun w -> w.token = token) ws in + let filtered = Utils.list_remove w ws in + if List.length filtered > 0 then + Hashtbl.replace con.watches apath filtered + else + Hashtbl.remove con.watches apath; + con.nb_watches <- con.nb_watches - 1; + apath, w let del_watches con = Hashtbl.reset con.watches; @@ -308,101 +308,101 @@ let del_transactions con = Hashtbl.reset con.transactions let list_watches con = - let ll = Hashtbl.fold - (fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc) - con.watches [] in - List.concat ll + let ll = Hashtbl.fold + (fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc) + con.watches [] in + List.concat ll let dbg fmt = Logging.debug "connection" fmt let info fmt = Logging.info "connection" fmt let lookup_watch_perm path = function -| None -> [] -| Some root -> - try Store.Path.apply root path @@ fun parent name -> - Store.Node.get_perms parent :: - try [Store.Node.get_perms (Store.Node.find parent name)] - with Not_found -> [] - with Define.Invalid_path | Not_found -> [] + | None -> [] + | Some root -> + try Store.Path.apply root path @@ fun parent name -> + Store.Node.get_perms parent :: + try [Store.Node.get_perms (Store.Node.find parent name)] + with Not_found -> [] + with Define.Invalid_path | Not_found -> [] let lookup_watch_perms oldroot root path = - lookup_watch_perm path oldroot @ lookup_watch_perm path (Some root) + lookup_watch_perm path oldroot @ lookup_watch_perm path (Some root) let fire_single_watch_unchecked source watch = - let data = Utils.join_by_null [watch.path; watch.token; ""] in - let pkt = packet_of watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data in + let data = Utils.join_by_null [watch.path; watch.token; ""] in + let pkt = packet_of watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data in - match BoundedPipe.push source.pending_source_watchevents (watch, pkt) with - | Some () -> () (* packet queued *) - | None -> - (* a well behaved Dom0 shouldn't be able to trigger this, - if it happens it is likely a Dom0 bug causing runaway memory usage - *) - failwith "watch event overflow, cannot happen" + match BoundedPipe.push source.pending_source_watchevents (watch, pkt) with + | Some () -> () (* packet queued *) + | None -> + (* a well behaved Dom0 shouldn't be able to trigger this, + if it happens it is likely a Dom0 bug causing runaway memory usage + *) + failwith "watch event overflow, cannot happen" let fire_single_watch source (oldroot, root) watch = - let abspath = get_watch_path watch.con watch.path |> Store.Path.of_string in - let perms = lookup_watch_perms oldroot root abspath in - if Perms.can_fire_watch watch.con.perm perms then - fire_single_watch_unchecked source watch - else - let perms = perms |> List.map (Perms.Node.to_string ~sep:" ") |> String.concat ", " in - let con = get_domstr watch.con in - Logging.watch_not_fired ~con perms (Store.Path.to_string abspath) + let abspath = get_watch_path watch.con watch.path |> Store.Path.of_string in + let perms = lookup_watch_perms oldroot root abspath in + if Perms.can_fire_watch watch.con.perm perms then + fire_single_watch_unchecked source watch + else + let perms = perms |> List.map (Perms.Node.to_string ~sep:" ") |> String.concat ", " in + let con = get_domstr watch.con in + Logging.watch_not_fired ~con perms (Store.Path.to_string abspath) let fire_watch source roots watch path = - let new_path = - if watch.is_relative && path.[0] = '/' - then begin - let n = String.length watch.base - and m = String.length path in - String.sub path n (m - n) - end else - path - in - fire_single_watch source roots { watch with path = new_path } + let new_path = + if watch.is_relative && path.[0] = '/' + then begin + let n = String.length watch.base + and m = String.length path in + String.sub path n (m - n) + end else + path + in + fire_single_watch source roots { watch with path = new_path } (* Search for a valid unused transaction id. *) let rec valid_transaction_id con proposed_id = - (* - * Clip proposed_id to the range [1, 0x3ffffffe] - * - * The chosen id must not trucate when written into the uint32_t tx_id - * field, and needs to fit within the positive range of a 31 bit ocaml - * integer to function when compiled as 32bit. - * - * Oxenstored therefore supports only 1 billion open transactions. - *) - let id = if proposed_id <= 0 || proposed_id >= 0x3fffffff then 1 else proposed_id in + (* + * Clip proposed_id to the range [1, 0x3ffffffe] + * + * The chosen id must not trucate when written into the uint32_t tx_id + * field, and needs to fit within the positive range of a 31 bit ocaml + * integer to function when compiled as 32bit. + * + * Oxenstored therefore supports only 1 billion open transactions. + *) + let id = if proposed_id <= 0 || proposed_id >= 0x3fffffff then 1 else proposed_id in - if Hashtbl.mem con.transactions id then ( - (* Outstanding transaction with this id. Try the next. *) - valid_transaction_id con (id + 1) - ) else - id + if Hashtbl.mem con.transactions id then ( + (* Outstanding transaction with this id. Try the next. *) + valid_transaction_id con (id + 1) + ) else + id let start_transaction con store = - if !Define.maxtransaction > 0 && not (is_dom0 con) - && Hashtbl.length con.transactions > !Define.maxtransaction then - raise Quota.Transaction_opened; - let id = valid_transaction_id con con.next_tid in - con.next_tid <- id + 1; - let ntrans = Transaction.make id store in - Hashtbl.add con.transactions id ntrans; - Logging.start_transaction ~tid:id ~con:(get_domstr con); - id + if !Define.maxtransaction > 0 && not (is_dom0 con) + && Hashtbl.length con.transactions > !Define.maxtransaction then + raise Quota.Transaction_opened; + let id = valid_transaction_id con con.next_tid in + con.next_tid <- id + 1; + let ntrans = Transaction.make id store in + Hashtbl.add con.transactions id ntrans; + Logging.start_transaction ~tid:id ~con:(get_domstr con); + id let end_transaction con tid commit = - let trans = Hashtbl.find con.transactions tid in - Hashtbl.remove con.transactions tid; - Logging.end_transaction ~tid ~con:(get_domstr con); - match commit with - | None -> true - | Some transaction_replay_f -> - Transaction.commit ~con:(get_domstr con) trans || transaction_replay_f con trans + let trans = Hashtbl.find con.transactions tid in + Hashtbl.remove con.transactions tid; + Logging.end_transaction ~tid ~con:(get_domstr con); + match commit with + | None -> true + | Some transaction_replay_f -> + Transaction.commit ~con:(get_domstr con) trans || transaction_replay_f con trans let get_transaction con tid = - Hashtbl.find con.transactions tid + Hashtbl.find con.transactions tid let do_input con = Xenbus.Xb.input con.xb let has_partial_input con = Xenbus.Xb.has_partial_input con.xb @@ -434,53 +434,53 @@ let is_bad con = match con.dom with None -> false | Some dom -> Domain.is_bad_do Restrictions below can be relaxed once xenstored learns to dump more of its live state in a safe way *) let has_extra_connection_data con = - let has_in = has_partial_input con in - let has_out = has_output con in - let has_nondefault_perms = make_perm con.dom <> con.perm in - has_in || has_out - (* TODO: what about SIGTERM, should use systemd to store FDS - || has_socket (* dom0 sockets not * dumped yet *) *) - || has_nondefault_perms (* set_target not dumped yet *) + let has_in = has_partial_input con in + let has_out = has_output con in + let has_nondefault_perms = make_perm con.dom <> con.perm in + has_in || has_out + (* TODO: what about SIGTERM, should use systemd to store FDS + || has_socket (* dom0 sockets not * dumped yet *) *) + || has_nondefault_perms (* set_target not dumped yet *) let has_transaction_data con = - let n = number_of_transactions con in - dbg "%s: number of transactions = %d" (get_domstr con) n; - n > 0 + let n = number_of_transactions con in + dbg "%s: number of transactions = %d" (get_domstr con) n; + n > 0 let prevents_live_update con = not (is_bad con) - && (has_extra_connection_data con || has_transaction_data con) + && (has_extra_connection_data con || has_transaction_data con) let has_more_work con = - (has_more_input con && can_input con) || not (has_old_output con) && has_new_output con + (has_more_input con && can_input con) || not (has_old_output con) && has_new_output con let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1 let stats con = - Hashtbl.length con.watches, con.stat_nb_ops + Hashtbl.length con.watches, con.stat_nb_ops let dump con chan = - let id = match con.dom with - | Some dom -> - let domid = Domain.get_id dom in - (* dump domain *) - Domain.dump dom chan; - domid - | None -> - let fd = con |> get_fd |> Utils.FD.to_int in - Printf.fprintf chan "socket,%d\n" fd; - -fd - in - (* dump watches *) - List.iter (fun (path, token) -> - Printf.fprintf chan "watch,%d,%s,%s\n" id (Utils.hexify path) (Utils.hexify token) - ) (list_watches con) + let id = match con.dom with + | Some dom -> + let domid = Domain.get_id dom in + (* dump domain *) + Domain.dump dom chan; + domid + | None -> + let fd = con |> get_fd |> Utils.FD.to_int in + Printf.fprintf chan "socket,%d\n" fd; + -fd + in + (* dump watches *) + List.iter (fun (path, token) -> + Printf.fprintf chan "watch,%d,%s,%s\n" id (Utils.hexify path) (Utils.hexify token) + ) (list_watches con) let debug con = - let domid = get_domstr con in - let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in - String.concat "" watches + let domid = get_domstr con in + let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in + String.concat "" watches let decr_conflict_credit doms con = - match con.dom with - | None -> () (* It's a socket connection. We don't know which domain we're in, so treat it as if it's free to conflict *) - | Some dom -> Domains.decr_conflict_credit doms dom + match con.dom with + | None -> () (* It's a socket connection. We don't know which domain we're in, so treat it as if it's free to conflict *) + | Some dom -> Domains.decr_conflict_credit doms dom diff --git a/tools/ocaml/xenstored/connections.ml b/tools/ocaml/xenstored/connections.ml index 7d68c583b4..682e1b493c 100644 --- a/tools/ocaml/xenstored/connections.ml +++ b/tools/ocaml/xenstored/connections.ml @@ -18,218 +18,218 @@ let debug fmt = Logging.debug "connections" fmt type t = { - anonymous: (Unix.file_descr, Connection.t) Hashtbl.t; - domains: (int, Connection.t) Hashtbl.t; - ports: (Xeneventchn.t, Connection.t) Hashtbl.t; - mutable watches: Connection.watch list Trie.t; - mutable has_pending_watchevents: Connection.Watch.Set.t + anonymous: (Unix.file_descr, Connection.t) Hashtbl.t; + domains: (int, Connection.t) Hashtbl.t; + ports: (Xeneventchn.t, Connection.t) Hashtbl.t; + mutable watches: Connection.watch list Trie.t; + mutable has_pending_watchevents: Connection.Watch.Set.t } let create () = { - anonymous = Hashtbl.create 37; - domains = Hashtbl.create 37; - ports = Hashtbl.create 37; - watches = Trie.create (); - has_pending_watchevents = Connection.Watch.Set.empty; + anonymous = Hashtbl.create 37; + domains = Hashtbl.create 37; + ports = Hashtbl.create 37; + watches = Trie.create (); + has_pending_watchevents = Connection.Watch.Set.empty; } let get_capacity () = - (* not multiplied by maxwatch on purpose: 2nd queue in watch itself! *) - { Xenbus.Xb.maxoutstanding = !Define.maxoutstanding; maxwatchevents = !Define.maxwatchevents } + (* not multiplied by maxwatch on purpose: 2nd queue in watch itself! *) + { Xenbus.Xb.maxoutstanding = !Define.maxoutstanding; maxwatchevents = !Define.maxwatchevents } let add_anonymous cons fd = - let capacity = get_capacity () in - let xbcon = Xenbus.Xb.open_fd fd ~capacity in - let con = Connection.create xbcon None in - Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con + let capacity = get_capacity () in + let xbcon = Xenbus.Xb.open_fd fd ~capacity in + let con = Connection.create xbcon None in + Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con let add_domain cons dom = - let capacity = get_capacity () in - let xbcon = Xenbus.Xb.open_mmap ~capacity (Domain.get_interface dom) (fun () -> Domain.notify dom) in - let con = Connection.create xbcon (Some dom) in - Hashtbl.add cons.domains (Domain.get_id dom) con; - match Domain.get_port dom with - | Some p -> Hashtbl.add cons.ports p con; - | None -> () + let capacity = get_capacity () in + let xbcon = Xenbus.Xb.open_mmap ~capacity (Domain.get_interface dom) (fun () -> Domain.notify dom) in + let con = Connection.create xbcon (Some dom) in + Hashtbl.add cons.domains (Domain.get_id dom) con; + match Domain.get_port dom with + | Some p -> Hashtbl.add cons.ports p con; + | None -> () let select ?(only_if = (fun _ -> true)) cons = - Hashtbl.fold (fun _ con (ins, outs) -> - if (only_if con) then ( - let fd = Connection.get_fd con in - let in_fds = if Connection.can_input con then fd :: ins else ins in - let out_fds = if Connection.has_output con then fd :: outs else outs in - in_fds, out_fds - ) else (ins, outs) - ) - cons.anonymous ([], []) + Hashtbl.fold (fun _ con (ins, outs) -> + if (only_if con) then ( + let fd = Connection.get_fd con in + let in_fds = if Connection.can_input con then fd :: ins else ins in + let out_fds = if Connection.has_output con then fd :: outs else outs in + in_fds, out_fds + ) else (ins, outs) + ) + cons.anonymous ([], []) let find cons = - Hashtbl.find cons.anonymous + Hashtbl.find cons.anonymous let find_domain cons = - Hashtbl.find cons.domains + Hashtbl.find cons.domains let find_domain_by_port cons port = - Hashtbl.find cons.ports port + Hashtbl.find cons.ports port let del_watches_of_con con watches = - match List.filter (fun w -> Connection.get_con w != con) watches with - | [] -> None - | ws -> Some ws + match List.filter (fun w -> Connection.get_con w != con) watches with + | [] -> None + | ws -> Some ws let del_watches cons con = - Connection.del_watches con; - cons.watches <- Trie.map (del_watches_of_con con) cons.watches; - cons.has_pending_watchevents <- - cons.has_pending_watchevents |> Connection.Watch.Set.filter @@ fun w -> - Connection.get_con w != con + Connection.del_watches con; + cons.watches <- Trie.map (del_watches_of_con con) cons.watches; + cons.has_pending_watchevents <- + cons.has_pending_watchevents |> Connection.Watch.Set.filter @@ fun w -> + Connection.get_con w != con let del_anonymous cons con = - try - Hashtbl.remove cons.anonymous (Connection.get_fd con); - del_watches cons con; - Connection.close con - with exn -> - debug "del anonymous %s" (Printexc.to_string exn) + try + Hashtbl.remove cons.anonymous (Connection.get_fd con); + del_watches cons con; + Connection.close con + with exn -> + debug "del anonymous %s" (Printexc.to_string exn) let del_domain cons id = - try - let con = find_domain cons id in - Hashtbl.remove cons.domains id; - (match Connection.get_domain con with - | Some d -> - (match Domain.get_port d with - | Some p -> Hashtbl.remove cons.ports p - | None -> ()) - | None -> ()); - del_watches cons con; - Connection.close con - with exn -> - debug "del domain %u: %s" id (Printexc.to_string exn) + try + let con = find_domain cons id in + Hashtbl.remove cons.domains id; + (match Connection.get_domain con with + | Some d -> + (match Domain.get_port d with + | Some p -> Hashtbl.remove cons.ports p + | None -> ()) + | None -> ()); + del_watches cons con; + Connection.close con + with exn -> + debug "del domain %u: %s" id (Printexc.to_string exn) let iter_domains cons fct = - Hashtbl.iter (fun _ c -> fct c) cons.domains + Hashtbl.iter (fun _ c -> fct c) cons.domains let iter_anonymous cons fct = - Hashtbl.iter (fun _ c -> fct c) cons.anonymous + Hashtbl.iter (fun _ c -> fct c) cons.anonymous let iter cons fct = - iter_domains cons fct; iter_anonymous cons fct + iter_domains cons fct; iter_anonymous cons fct let has_more_work cons = - Hashtbl.fold - (fun _id con acc -> - if Connection.has_more_work con then con :: acc else acc) - cons.domains [] + Hashtbl.fold + (fun _id con acc -> + if Connection.has_more_work con then con :: acc else acc) + cons.domains [] let key_of_str path = - if path.[0] = '@' - then [path] - else "" :: Store.Path.to_string_list (Store.Path.of_string path) + if path.[0] = '@' + then [path] + else "" :: Store.Path.to_string_list (Store.Path.of_string path) let key_of_path path = - "" :: Store.Path.to_string_list path + "" :: Store.Path.to_string_list path let add_watch cons con path token = - let apath = Connection.get_watch_path con path in - (* fail on invalid paths early by calling key_of_str before adding watch *) - let key = key_of_str apath in - let watch = Connection.add_watch con (path, apath) token in - let watches = - if Trie.mem cons.watches key - then Trie.find cons.watches key - else [] - in - cons.watches <- Trie.set cons.watches key (watch :: watches); - watch + let apath = Connection.get_watch_path con path in + (* fail on invalid paths early by calling key_of_str before adding watch *) + let key = key_of_str apath in + let watch = Connection.add_watch con (path, apath) token in + let watches = + if Trie.mem cons.watches key + then Trie.find cons.watches key + else [] + in + cons.watches <- Trie.set cons.watches key (watch :: watches); + watch let del_watch cons con path token = - let apath, watch = Connection.del_watch con path token in - let key = key_of_str apath in - let watches = Utils.list_remove watch (Trie.find cons.watches key) in - if watches = [] then - cons.watches <- Trie.unset cons.watches key - else - cons.watches <- Trie.set cons.watches key watches; - watch + let apath, watch = Connection.del_watch con path token in + let key = key_of_str apath in + let watches = Utils.list_remove watch (Trie.find cons.watches key) in + if watches = [] then + cons.watches <- Trie.unset cons.watches key + else + cons.watches <- Trie.set cons.watches key watches; + watch (* path is absolute *) let fire_watches ?oldroot source root cons path recurse = - let key = key_of_path path in - let path = Store.Path.to_string path in - let roots = oldroot, root in - let fire_watch _ = function - | None -> () - | Some watches -> List.iter (fun w -> Connection.fire_watch source roots w path) watches - in - let fire_rec _x = function - | None -> () - | Some watches -> - List.iter (Connection.fire_single_watch source roots) watches - in - Trie.iter_path fire_watch cons.watches key; - if recurse then - Trie.iter fire_rec (Trie.sub cons.watches key) + let key = key_of_path path in + let path = Store.Path.to_string path in + let roots = oldroot, root in + let fire_watch _ = function + | None -> () + | Some watches -> List.iter (fun w -> Connection.fire_watch source roots w path) watches + in + let fire_rec _x = function + | None -> () + | Some watches -> + List.iter (Connection.fire_single_watch source roots) watches + in + Trie.iter_path fire_watch cons.watches key; + if recurse then + Trie.iter fire_rec (Trie.sub cons.watches key) let send_watchevents cons con = - cons.has_pending_watchevents <- - cons.has_pending_watchevents |> Connection.Watch.Set.filter Connection.Watch.flush_events; - Connection.source_flush_watchevents con + cons.has_pending_watchevents <- + cons.has_pending_watchevents |> Connection.Watch.Set.filter Connection.Watch.flush_events; + Connection.source_flush_watchevents con let fire_spec_watches root cons specpath = - let source = find_domain cons 0 in - iter cons (fun con -> - List.iter (Connection.fire_single_watch source (None, root)) (Connection.get_watches con specpath)) + let source = find_domain cons 0 in + iter cons (fun con -> + List.iter (Connection.fire_single_watch source (None, root)) (Connection.get_watches con specpath)) let set_target cons domain target_domain = - let con = find_domain cons domain in - Connection.set_target con target_domain + let con = find_domain cons domain in + Connection.set_target con target_domain let number_of_transactions cons = - let res = ref 0 in - let aux con = - res := Connection.number_of_transactions con + !res - in - iter cons aux; - !res + let res = ref 0 in + let aux con = + res := Connection.number_of_transactions con + !res + in + iter cons aux; + !res let stats cons = - let nb_ops_anon = ref 0 - and nb_watchs_anon = ref 0 - and nb_ops_dom = ref 0 - and nb_watchs_dom = ref 0 in - iter_anonymous cons (fun con -> - let con_watchs, con_ops = Connection.stats con in - nb_ops_anon := !nb_ops_anon + con_ops; - nb_watchs_anon := !nb_watchs_anon + con_watchs; - ); - iter_domains cons (fun con -> - let con_watchs, con_ops = Connection.stats con in - nb_ops_dom := !nb_ops_dom + con_ops; - nb_watchs_dom := !nb_watchs_dom + con_watchs; - ); - (Hashtbl.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon, - Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom) + let nb_ops_anon = ref 0 + and nb_watchs_anon = ref 0 + and nb_ops_dom = ref 0 + and nb_watchs_dom = ref 0 in + iter_anonymous cons (fun con -> + let con_watchs, con_ops = Connection.stats con in + nb_ops_anon := !nb_ops_anon + con_ops; + nb_watchs_anon := !nb_watchs_anon + con_watchs; + ); + iter_domains cons (fun con -> + let con_watchs, con_ops = Connection.stats con in + nb_ops_dom := !nb_ops_dom + con_ops; + nb_watchs_dom := !nb_watchs_dom + con_watchs; + ); + (Hashtbl.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon, + Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom) let debug cons = - let anonymous = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.anonymous [] in - let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in - String.concat "" (domains @ anonymous) + let anonymous = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.anonymous [] in + let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in + String.concat "" (domains @ anonymous) let debug_watchevents cons con = - (* == (physical equality) - has to be used here because w.con.xb.backend might contain a [unit->unit] value causing regular - comparison to fail due to having a 'functional value' which cannot be compared. - *) - let s = cons.has_pending_watchevents |> Connection.Watch.Set.filter (fun w -> w.con == con) in - let pending = s |> Connection.Watch.Set.elements - |> List.map (fun w -> Connection.Watch.pending_watchevents w) |> List.fold_left (+) 0 in - Printf.sprintf "Watches with pending events: %d, pending events total: %d" (Connection.Watch.Set.cardinal s) pending + (* == (physical equality) + has to be used here because w.con.xb.backend might contain a [unit->unit] value causing regular + comparison to fail due to having a 'functional value' which cannot be compared. + *) + let s = cons.has_pending_watchevents |> Connection.Watch.Set.filter (fun w -> w.con == con) in + let pending = s |> Connection.Watch.Set.elements + |> List.map (fun w -> Connection.Watch.pending_watchevents w) |> List.fold_left (+) 0 in + Printf.sprintf "Watches with pending events: %d, pending events total: %d" (Connection.Watch.Set.cardinal s) pending let filter ~f cons = - let fold _ v acc = if f v then v :: acc else acc in - [] - |> Hashtbl.fold fold cons.anonymous - |> Hashtbl.fold fold cons.domains + let fold _ v acc = if f v then v :: acc else acc in + [] + |> Hashtbl.fold fold cons.anonymous + |> Hashtbl.fold fold cons.domains let prevents_quit cons = filter ~f:Connection.prevents_live_update cons diff --git a/tools/ocaml/xenstored/define.ml b/tools/ocaml/xenstored/define.ml index 327b6d795e..f4f5295930 100644 --- a/tools/ocaml/xenstored/define.ml +++ b/tools/ocaml/xenstored/define.ml @@ -27,9 +27,9 @@ let maxrequests = ref (1024) (* maximum requests per transaction *) let maxoutstanding = ref (1024) (* maximum outstanding requests, i.e. in-flight requests / domain *) let maxwatchevents = ref (1024) (* - maximum outstanding watch events per watch, - recommended >= maxoutstanding to avoid blocking backend transactions due to - malicious frontends + maximum outstanding watch events per watch, + recommended >= maxoutstanding to avoid blocking backend transactions due to + malicious frontends *) let gc_max_overhead = ref 120 (* 120% see comment in xenstored.ml *) diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml index 4739967b61..91f945f2bd 100644 --- a/tools/ocaml/xenstored/disk.ml +++ b/tools/ocaml/xenstored/disk.ml @@ -25,133 +25,133 @@ exception Bad_escape let is_digit c = match c with '0' .. '9' -> true | _ -> false let undec c = - match c with - | '0' .. '9' -> (Char.code c) - (Char.code '0') - | _ -> raise (Failure "undecify") + match c with + | '0' .. '9' -> (Char.code c) - (Char.code '0') + | _ -> raise (Failure "undecify") let unhex c = - let c = Char.lowercase c in - match c with - | '0' .. '9' -> (Char.code c) - (Char.code '0') - | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10 - | _ -> raise (Failure "unhexify") + let c = Char.lowercase c in + match c with + | '0' .. '9' -> (Char.code c) - (Char.code '0') + | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10 + | _ -> raise (Failure "unhexify") let string_unescaped s = - let len = String.length s - and i = ref 0 in - let d = Buffer.create len in + let len = String.length s + and i = ref 0 in + let d = Buffer.create len in - let read_escape () = - incr i; - match s.[!i] with - | 'n' -> '\n' - | 'r' -> '\r' - | '\\' -> '\\' - | '\'' -> '\'' - | '"' -> '"' - | 't' -> '\t' - | 'b' -> '\b' - | 'x' -> - let v = (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in - i := !i + 2; - Char.chr v - | c -> - if is_digit c then ( - let v = (undec s.[!i]) * 100 + - (undec s.[!i + 1]) * 10 + - (undec s.[!i + 2]) in - i := !i + 2; - Char.chr v - ) else - raise Bad_escape - in + let read_escape () = + incr i; + match s.[!i] with + | 'n' -> '\n' + | 'r' -> '\r' + | '\\' -> '\\' + | '\'' -> '\'' + | '"' -> '"' + | 't' -> '\t' + | 'b' -> '\b' + | 'x' -> + let v = (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in + i := !i + 2; + Char.chr v + | c -> + if is_digit c then ( + let v = (undec s.[!i]) * 100 + + (undec s.[!i + 1]) * 10 + + (undec s.[!i + 2]) in + i := !i + 2; + Char.chr v + ) else + raise Bad_escape + in - while !i < len - do - let c = match s.[!i] with - | '\\' -> read_escape () - | c -> c in - Buffer.add_char d c; - incr i - done; - Buffer.contents d + while !i < len + do + let c = match s.[!i] with + | '\\' -> read_escape () + | c -> c in + Buffer.add_char d c; + incr i + done; + Buffer.contents d (* file -> lines_of_file *) let file_readlines file = - let channel = open_in file in - let rec input_line_list channel = - let line = try input_line channel with End_of_file -> "" in - if String.length line > 0 then - line :: input_line_list channel - else ( - close_in channel; - [] - ) in - input_line_list channel + let channel = open_in file in + let rec input_line_list channel = + let line = try input_line channel with End_of_file -> "" in + if String.length line > 0 then + line :: input_line_list channel + else ( + close_in channel; + [] + ) in + input_line_list channel let rec map_string_list_range l s = - match l with - | [] -> [] - | (a,b) :: l -> String.sub s a (b - a) :: map_string_list_range l s + match l with + | [] -> [] + | (a,b) :: l -> String.sub s a (b - a) :: map_string_list_range l s let is_digit c = - try ignore (int_of_char c); true with _ -> false + try ignore (int_of_char c); true with _ -> false let rec parse_perm s = - let len = String.length s in - if len = 0 then - [] - else - let i = ref 1 in - while !i < len && is_digit s.[!i] do incr i done; - let x = String.sub s 0 !i - and lx = String.sub s !i len in - x :: parse_perm lx + let len = String.length s in + if len = 0 then + [] + else + let i = ref 1 in + while !i < len && is_digit s.[!i] do incr i done; + let x = String.sub s 0 !i + and lx = String.sub s !i len in + x :: parse_perm lx let read store = - (* don't let the permission get on our way, full perm ! *) - let v = Store.get_ops store Perms.Connection.full_rights in + (* don't let the permission get on our way, full perm ! *) + let v = Store.get_ops store Perms.Connection.full_rights in - (* a line is : path{perm} or path{perm} = value *) - let parse_line s = - let path, perm, value = - let len = String.length s in - let si = if String.contains s '=' then - String.index s '=' - else - len - 1 in - let pi = String.rindex_from s si '{' in - let epi = String.index_from s pi '}' in + (* a line is : path{perm} or path{perm} = value *) + let parse_line s = + let path, perm, value = + let len = String.length s in + let si = if String.contains s '=' then + String.index s '=' + else + len - 1 in + let pi = String.rindex_from s si '{' in + let epi = String.index_from s pi '}' in - if String.contains s '=' then - let ss = map_string_list_range [ (0, pi); - (pi + 1, epi); - (si + 2, len); ] s in - (List.nth ss 0, List.nth ss 1, List.nth ss 2) - else - let ss = map_string_list_range [ (0, pi); - (pi + 1, epi); - ] s in - (List.nth ss 0, List.nth ss 1, "") - in - let path = Store.Path.of_string path in - v.Store.write path (string_unescaped value); - v.Store.setperms path (Perms.Node.of_strings (parse_perm perm)) in - try - let lines = file_readlines xs_daemon_database in - List.iter (fun s -> parse_line s) lines - with exc -> - error "caught exn %s" (Printexc.to_string exc) + if String.contains s '=' then + let ss = map_string_list_range [ (0, pi); + (pi + 1, epi); + (si + 2, len); ] s in + (List.nth ss 0, List.nth ss 1, List.nth ss 2) + else + let ss = map_string_list_range [ (0, pi); + (pi + 1, epi); + ] s in + (List.nth ss 0, List.nth ss 1, "") + in + let path = Store.Path.of_string path in + v.Store.write path (string_unescaped value); + v.Store.setperms path (Perms.Node.of_strings (parse_perm perm)) in + try + let lines = file_readlines xs_daemon_database in + List.iter (fun s -> parse_line s) lines + with exc -> + error "caught exn %s" (Printexc.to_string exc) let write store = - if !enable then - try - let tfile = Printf.sprintf "%s#" xs_daemon_database in - let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] - 0o600 tfile in - Store.dump store channel; - flush channel; - close_out channel; - Unix.rename tfile xs_daemon_database - with exc -> - error "caught exn %s" (Printexc.to_string exc) + if !enable then + try + let tfile = Printf.sprintf "%s#" xs_daemon_database in + let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] + 0o600 tfile in + Store.dump store channel; + flush channel; + close_out channel; + Unix.rename tfile xs_daemon_database + with exc -> + error "caught exn %s" (Printexc.to_string exc) diff --git a/tools/ocaml/xenstored/domain.ml b/tools/ocaml/xenstored/domain.ml index 81cb59b8f1..4e62a48e8e 100644 --- a/tools/ocaml/xenstored/domain.ml +++ b/tools/ocaml/xenstored/domain.ml @@ -20,22 +20,22 @@ let debug fmt = Logging.debug "domain" fmt let warn fmt = Logging.warn "domain" fmt type t = -{ - id: Xenctrl.domid; - mfn: nativeint; - interface: Xenmmap.mmap_interface; - eventchn: Event.t; - mutable remote_port: int; - mutable port: Xeneventchn.t option; - mutable bad_client: bool; - mutable io_credit: int; (* the rounds of ring process left to do, default is 0, - usually set to 1 when there is work detected, could - also set to n to give "lazy" clients extra credit *) - mutable conflict_credit: float; (* Must be positive to perform writes; a commit - that later causes conflict with another - domain's transaction costs credit. *) - mutable caused_conflicts: int64; -} + { + id: Xenctrl.domid; + mfn: nativeint; + interface: Xenmmap.mmap_interface; + eventchn: Event.t; + mutable remote_port: int; + mutable port: Xeneventchn.t option; + mutable bad_client: bool; + mutable io_credit: int; (* the rounds of ring process left to do, default is 0, + usually set to 1 when there is work detected, could + also set to n to give "lazy" clients extra credit *) + mutable conflict_credit: float; (* Must be positive to perform writes; a commit + that later causes conflict with another + domain's transaction costs credit. *) + mutable caused_conflicts: int64; + } let is_dom0 d = d.id = 0 let get_id domain = domain.id @@ -57,51 +57,51 @@ let is_paused_for_conflict dom = dom.conflict_credit <= 0.0 let is_free_to_conflict = is_dom0 let string_of_port = function -| None -> "None" -| Some x -> string_of_int (Xeneventchn.to_int x) + | None -> "None" + | Some x -> string_of_int (Xeneventchn.to_int x) let dump d chan = - fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.remote_port + fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.remote_port let notify dom = match dom.port with -| None -> - warn "domain %d: attempt to notify on unknown port" dom.id -| Some port -> - Event.notify dom.eventchn port + | None -> + warn "domain %d: attempt to notify on unknown port" dom.id + | Some port -> + Event.notify dom.eventchn port let bind_interdomain dom = - begin match dom.port with - | None -> () - | Some port -> Event.unbind dom.eventchn port - end; - dom.port <- Some (Event.bind_interdomain dom.eventchn dom.id dom.remote_port); - debug "bound domain %d remote port %d to local port %s" dom.id dom.remote_port (string_of_port dom.port) + begin match dom.port with + | None -> () + | Some port -> Event.unbind dom.eventchn port + end; + dom.port <- Some (Event.bind_interdomain dom.eventchn dom.id dom.remote_port); + debug "bound domain %d remote port %d to local port %s" dom.id dom.remote_port (string_of_port dom.port) let close dom = - debug "domain %d unbound port %s" dom.id (string_of_port dom.port); - begin match dom.port with - | None -> () - | Some port -> Event.unbind dom.eventchn port - end; - Xenmmap.unmap dom.interface; - () + debug "domain %d unbound port %s" dom.id (string_of_port dom.port); + begin match dom.port with + | None -> () + | Some port -> Event.unbind dom.eventchn port + end; + Xenmmap.unmap dom.interface; + () let make id mfn remote_port interface eventchn = { - id = id; - mfn = mfn; - remote_port = remote_port; - interface = interface; - eventchn = eventchn; - port = None; - bad_client = false; - io_credit = 0; - conflict_credit = !Define.conflict_burst_limit; - caused_conflicts = 0L; + id = id; + mfn = mfn; + remote_port = remote_port; + interface = interface; + eventchn = eventchn; + port = None; + bad_client = false; + io_credit = 0; + conflict_credit = !Define.conflict_burst_limit; + caused_conflicts = 0L; } let log_and_reset_conflict_stats logfn dom = - if dom.caused_conflicts > 0L then ( - logfn dom.id dom.caused_conflicts; - dom.caused_conflicts <- 0L - ) + if dom.caused_conflicts > 0L then ( + logfn dom.id dom.caused_conflicts; + dom.caused_conflicts <- 0L + ) diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domains.ml index 17fe2fa257..a36b531663 100644 --- a/tools/ocaml/xenstored/domains.ml +++ b/tools/ocaml/xenstored/domains.ml @@ -21,35 +21,35 @@ let warn fmt = Logging.warn "domains" fmt let xc = Xenctrl.interface_open () type domains = { - eventchn: Event.t; - table: (Xenctrl.domid, Domain.t) Hashtbl.t; + eventchn: Event.t; + table: (Xenctrl.domid, Domain.t) Hashtbl.t; - (* N.B. the Queue module is not thread-safe but oxenstored is single-threaded. *) - (* Domains queue up to regain conflict-credit; we have a queue for - domains that are carrying some penalty and so are below the - maximum credit, and another queue for domains that have run out of - credit and so have had their access paused. *) - doms_conflict_paused: (Domain.t option ref) Queue.t; - doms_with_conflict_penalty: (Domain.t option ref) Queue.t; + (* N.B. the Queue module is not thread-safe but oxenstored is single-threaded. *) + (* Domains queue up to regain conflict-credit; we have a queue for + domains that are carrying some penalty and so are below the + maximum credit, and another queue for domains that have run out of + credit and so have had their access paused. *) + doms_conflict_paused: (Domain.t option ref) Queue.t; + doms_with_conflict_penalty: (Domain.t option ref) Queue.t; - (* A callback function to be called when we go from zero to one paused domain. - This will be to reset the countdown until the next unit of credit is issued. *) - on_first_conflict_pause: unit -> unit; + (* A callback function to be called when we go from zero to one paused domain. + This will be to reset the countdown until the next unit of credit is issued. *) + on_first_conflict_pause: unit -> unit; - (* If config is set to use individual instead of aggregate conflict-rate-limiting, - we use these counts instead of the queues. The second one includes the first. *) - mutable n_paused: int; (* Number of domains with zero or negative credit *) - mutable n_penalised: int; (* Number of domains with less than maximum credit *) + (* If config is set to use individual instead of aggregate conflict-rate-limiting, + we use these counts instead of the queues. The second one includes the first. *) + mutable n_paused: int; (* Number of domains with zero or negative credit *) + mutable n_penalised: int; (* Number of domains with less than maximum credit *) } let init eventchn on_first_conflict_pause = { - eventchn = eventchn; - table = Hashtbl.create 10; - doms_conflict_paused = Queue.create (); - doms_with_conflict_penalty = Queue.create (); - on_first_conflict_pause = on_first_conflict_pause; - n_paused = 0; - n_penalised = 0; + eventchn = eventchn; + table = Hashtbl.create 10; + doms_conflict_paused = Queue.create (); + doms_with_conflict_penalty = Queue.create (); + on_first_conflict_pause = on_first_conflict_pause; + n_paused = 0; + n_penalised = 0; } let del doms id = Hashtbl.remove doms.table id let exist doms id = Hashtbl.mem doms.table id @@ -58,165 +58,165 @@ let number doms = Hashtbl.length doms.table let iter doms fct = Hashtbl.iter (fun _ b -> fct b) doms.table let rec is_empty_queue q = - Queue.is_empty q || - if !(Queue.peek q) = None - then ( - ignore (Queue.pop q); - is_empty_queue q - ) else false + Queue.is_empty q || + if !(Queue.peek q) = None + then ( + ignore (Queue.pop q); + is_empty_queue q + ) else false let all_at_max_credit doms = - if !Define.conflict_rate_limit_is_aggregate - then - (* Check both becuase if burst limit is 1.0 then a domain can go straight - * from max-credit to paused without getting into the penalty queue. *) - is_empty_queue doms.doms_with_conflict_penalty - && is_empty_queue doms.doms_conflict_paused - else doms.n_penalised = 0 + if !Define.conflict_rate_limit_is_aggregate + then + (* Check both becuase if burst limit is 1.0 then a domain can go straight + * from max-credit to paused without getting into the penalty queue. *) + is_empty_queue doms.doms_with_conflict_penalty + && is_empty_queue doms.doms_conflict_paused + else doms.n_penalised = 0 (* Functions to handle queues of domains given that the domain might be deleted while in a queue. *) let push dom queue = - Queue.push (ref (Some dom)) queue + Queue.push (ref (Some dom)) queue let rec pop queue = - match !(Queue.pop queue) with - | None -> pop queue - | Some x -> x + match !(Queue.pop queue) with + | None -> pop queue + | Some x -> x let remove_from_queue dom queue = - Queue.iter (fun d -> match !d with - | None -> () - | Some x -> if x=dom then d := None) queue + Queue.iter (fun d -> match !d with + | None -> () + | Some x -> if x=dom then d := None) queue let cleanup doms = - let notify = ref false in - let dead_dom = ref [] in + let notify = ref false in + let dead_dom = ref [] in - Hashtbl.iter (fun id _ -> if id <> 0 then - try - let info = Xenctrl.domain_getinfo xc id in - if info.Xenctrl.shutdown || info.Xenctrl.dying then ( - debug "Domain %u died (dying=%b, shutdown %b -- code %d)" - id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code; - if info.Xenctrl.dying then - dead_dom := id :: !dead_dom - else - notify := true; - ) - with Xenctrl.Error _ -> - debug "Domain %u died -- no domain info" id; - dead_dom := id :: !dead_dom; - ) doms.table; - List.iter (fun id -> - let dom = Hashtbl.find doms.table id in - Domain.close dom; - Hashtbl.remove doms.table id; - if dom.Domain.conflict_credit <= !Define.conflict_burst_limit - then ( - remove_from_queue dom doms.doms_with_conflict_penalty; - if (dom.Domain.conflict_credit <= 0.) then remove_from_queue dom doms.doms_conflict_paused - ) - ) !dead_dom; - !notify, !dead_dom + Hashtbl.iter (fun id _ -> if id <> 0 then + try + let info = Xenctrl.domain_getinfo xc id in + if info.Xenctrl.shutdown || info.Xenctrl.dying then ( + debug "Domain %u died (dying=%b, shutdown %b -- code %d)" + id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code; + if info.Xenctrl.dying then + dead_dom := id :: !dead_dom + else + notify := true; + ) + with Xenctrl.Error _ -> + debug "Domain %u died -- no domain info" id; + dead_dom := id :: !dead_dom; + ) doms.table; + List.iter (fun id -> + let dom = Hashtbl.find doms.table id in + Domain.close dom; + Hashtbl.remove doms.table id; + if dom.Domain.conflict_credit <= !Define.conflict_burst_limit + then ( + remove_from_queue dom doms.doms_with_conflict_penalty; + if (dom.Domain.conflict_credit <= 0.) then remove_from_queue dom doms.doms_conflict_paused + ) + ) !dead_dom; + !notify, !dead_dom let resume _doms _domid = - () + () let create doms domid mfn port = - let interface = Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize()) mfn in - let dom = Domain.make domid mfn port interface doms.eventchn in - Hashtbl.add doms.table domid dom; - Domain.bind_interdomain dom; - dom + let interface = Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize()) mfn in + let dom = Domain.make domid mfn port interface doms.eventchn in + Hashtbl.add doms.table domid dom; + Domain.bind_interdomain dom; + dom let xenstored_kva = ref "" let xenstored_port = ref "" let create0 doms = - let port, interface = - ( - let port = Utils.read_file_single_integer !xenstored_port - and fd = Unix.openfile !xenstored_kva - [ Unix.O_RDWR ] 0o600 in - let interface = Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED - (Xenmmap.getpagesize()) 0 in - Unix.close fd; - port, interface - ) - in - let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in - Hashtbl.add doms.table 0 dom; - Domain.bind_interdomain dom; - Domain.notify dom; - dom + let port, interface = + ( + let port = Utils.read_file_single_integer !xenstored_port + and fd = Unix.openfile !xenstored_kva + [ Unix.O_RDWR ] 0o600 in + let interface = Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED + (Xenmmap.getpagesize()) 0 in + Unix.close fd; + port, interface + ) + in + let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in + Hashtbl.add doms.table 0 dom; + Domain.bind_interdomain dom; + Domain.notify dom; + dom let decr_conflict_credit doms dom = - dom.Domain.caused_conflicts <- Int64.add 1L dom.Domain.caused_conflicts; - let before = dom.Domain.conflict_credit in - let after = max (-1.0) (before -. 1.0) in - debug "decr_conflict_credit dom%d %F -> %F" (Domain.get_id dom) before after; - dom.Domain.conflict_credit <- after; - let newly_penalised = - before >= !Define.conflict_burst_limit - && after < !Define.conflict_burst_limit in - let newly_paused = before > 0.0 && after <= 0.0 in - if !Define.conflict_rate_limit_is_aggregate then ( - if newly_penalised - && after > 0.0 - then ( - push dom doms.doms_with_conflict_penalty - ) else if newly_paused - then ( - let first_pause = Queue.is_empty doms.doms_conflict_paused in - push dom doms.doms_conflict_paused; - if first_pause then doms.on_first_conflict_pause () - ) else ( - (* The queues are correct already: no further action needed. *) - ) - ) else ( - if newly_penalised then doms.n_penalised <- doms.n_penalised + 1; - if newly_paused then ( - doms.n_paused <- doms.n_paused + 1; - if doms.n_paused = 1 then doms.on_first_conflict_pause () - ) - ) + dom.Domain.caused_conflicts <- Int64.add 1L dom.Domain.caused_conflicts; + let before = dom.Domain.conflict_credit in + let after = max (-1.0) (before -. 1.0) in + debug "decr_conflict_credit dom%d %F -> %F" (Domain.get_id dom) before after; + dom.Domain.conflict_credit <- after; + let newly_penalised = + before >= !Define.conflict_burst_limit + && after < !Define.conflict_burst_limit in + let newly_paused = before > 0.0 && after <= 0.0 in + if !Define.conflict_rate_limit_is_aggregate then ( + if newly_penalised + && after > 0.0 + then ( + push dom doms.doms_with_conflict_penalty + ) else if newly_paused + then ( + let first_pause = Queue.is_empty doms.doms_conflict_paused in + push dom doms.doms_conflict_paused; + if first_pause then doms.on_first_conflict_pause () + ) else ( + (* The queues are correct already: no further action needed. *) + ) + ) else ( + if newly_penalised then doms.n_penalised <- doms.n_penalised + 1; + if newly_paused then ( + doms.n_paused <- doms.n_paused + 1; + if doms.n_paused = 1 then doms.on_first_conflict_pause () + ) + ) (* Give one point of credit to one domain, and update the queues appropriately. *) let incr_conflict_credit_from_queue doms = - let process_queue q requeue_test = - let d = pop q in - let before = d.Domain.conflict_credit in (* just for debug-logging *) - d.Domain.conflict_credit <- min (d.Domain.conflict_credit +. 1.0) !Define.conflict_burst_limit; - debug "incr_conflict_credit_from_queue: dom%d: %F -> %F" (Domain.get_id d) before d.Domain.conflict_credit; - if requeue_test d.Domain.conflict_credit then ( - push d q (* Make it queue up again for its next point of credit. *) - ) - in - let paused_queue_test cred = cred <= 0.0 in - let penalty_queue_test cred = cred < !Define.conflict_burst_limit in - try process_queue doms.doms_conflict_paused paused_queue_test - with Queue.Empty -> ( - try process_queue doms.doms_with_conflict_penalty penalty_queue_test - with Queue.Empty -> () (* Both queues are empty: nothing to do here. *) - ) + let process_queue q requeue_test = + let d = pop q in + let before = d.Domain.conflict_credit in (* just for debug-logging *) + d.Domain.conflict_credit <- min (d.Domain.conflict_credit +. 1.0) !Define.conflict_burst_limit; + debug "incr_conflict_credit_from_queue: dom%d: %F -> %F" (Domain.get_id d) before d.Domain.conflict_credit; + if requeue_test d.Domain.conflict_credit then ( + push d q (* Make it queue up again for its next point of credit. *) + ) + in + let paused_queue_test cred = cred <= 0.0 in + let penalty_queue_test cred = cred < !Define.conflict_burst_limit in + try process_queue doms.doms_conflict_paused paused_queue_test + with Queue.Empty -> ( + try process_queue doms.doms_with_conflict_penalty penalty_queue_test + with Queue.Empty -> () (* Both queues are empty: nothing to do here. *) + ) let incr_conflict_credit doms = - if !Define.conflict_rate_limit_is_aggregate - then incr_conflict_credit_from_queue doms - else ( - (* Give a point of credit to every domain, subject only to the cap. *) - let inc dom = - let before = dom.Domain.conflict_credit in - let after = min (before +. 1.0) !Define.conflict_burst_limit in - dom.Domain.conflict_credit <- after; - debug "incr_conflict_credit dom%d: %F -> %F" (Domain.get_id dom) before after; + if !Define.conflict_rate_limit_is_aggregate + then incr_conflict_credit_from_queue doms + else ( + (* Give a point of credit to every domain, subject only to the cap. *) + let inc dom = + let before = dom.Domain.conflict_credit in + let after = min (before +. 1.0) !Define.conflict_burst_limit in + dom.Domain.conflict_credit <- after; + debug "incr_conflict_credit dom%d: %F -> %F" (Domain.get_id dom) before after; - if before <= 0.0 && after > 0.0 - then doms.n_paused <- doms.n_paused - 1; + if before <= 0.0 && after > 0.0 + then doms.n_paused <- doms.n_paused - 1; - if before < !Define.conflict_burst_limit - && after >= !Define.conflict_burst_limit - then doms.n_penalised <- doms.n_penalised - 1 - in - if doms.n_penalised > 0 then iter doms inc - ) + if before < !Define.conflict_burst_limit + && after >= !Define.conflict_burst_limit + then doms.n_penalised <- doms.n_penalised - 1 + in + if doms.n_penalised > 0 then iter doms inc + ) diff --git a/tools/ocaml/xenstored/event.ml b/tools/ocaml/xenstored/event.ml index ccca90b6fc..b10027f004 100644 --- a/tools/ocaml/xenstored/event.ml +++ b/tools/ocaml/xenstored/event.ml @@ -16,8 +16,8 @@ (**************** high level binding ****************) type t = { - handle: Xeneventchn.handle; - mutable virq_port: Xeneventchn.t option; + handle: Xeneventchn.handle; + mutable virq_port: Xeneventchn.t option; } let init () = { handle = Xeneventchn.init (); virq_port = None; } diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/history.ml index ba5c9cb571..f03fb18329 100644 --- a/tools/ocaml/xenstored/history.ml +++ b/tools/ocaml/xenstored/history.ml @@ -13,11 +13,11 @@ *) type history_record = { - con: Connection.t; (* connection that made a change *) - tid: int; (* transaction id of the change (may be Transaction.none) *) - before: Store.t; (* the store before the change *) - after: Store.t; (* the store after the change *) - finish_count: int64; (* the commit-count at which the transaction finished *) + con: Connection.t; (* connection that made a change *) + tid: int; (* transaction id of the change (may be Transaction.none) *) + before: Store.t; (* the store before the change *) + after: Store.t; (* the store after the change *) + finish_count: int64; (* the commit-count at which the transaction finished *) } let history : history_record list ref = ref [] @@ -26,38 +26,38 @@ let history : history_record list ref = ref [] (* There is scope for optimisation here, replacing List.filter with something more efficient, * probably on a different list-like structure. *) let trim ?txn () = - Transaction.trim_short_running_transactions txn; - history := match Transaction.oldest_short_running_transaction () with - | None -> [] (* We have no open transaction, so no history is needed *) - | Some (_, txn) -> ( - (* keep records with finish_count recent enough to be relevant *) - List.filter (fun r -> r.finish_count > txn.Transaction.start_count) !history - ) + Transaction.trim_short_running_transactions txn; + history := match Transaction.oldest_short_running_transaction () with + | None -> [] (* We have no open transaction, so no history is needed *) + | Some (_, txn) -> ( + (* keep records with finish_count recent enough to be relevant *) + List.filter (fun r -> r.finish_count > txn.Transaction.start_count) !history + ) let end_transaction txn con tid commit = - let success = Connection.end_transaction con tid commit in - trim ~txn (); - success + let success = Connection.end_transaction con tid commit in + trim ~txn (); + success let reconnect con = - trim (); - Connection.do_reconnect con + trim (); + Connection.do_reconnect con let push (x: history_record) = - let dom = x.con.Connection.dom in - match dom with - | None -> () (* treat socket connections as always free to conflict *) - | Some d -> if not (Domain.is_free_to_conflict d) then history := x :: !history + let dom = x.con.Connection.dom in + match dom with + | None -> () (* treat socket connections as always free to conflict *) + | Some d -> if not (Domain.is_free_to_conflict d) then history := x :: !history (* Find the connections from records since commit-count [since] for which [f record] returns [true] *) let filter_connections ~ignore ~since ~f = - (* The "mem" call is an optimisation, to avoid calling f if we have picked con already. *) - (* Using a hash table rather than a list is to optimise the "mem" call. *) - List.fold_left (fun acc hist_rec -> - if hist_rec.finish_count > since - && not (hist_rec.con == ignore) - && not (Hashtbl.mem acc hist_rec.con) - && f hist_rec - then Hashtbl.replace acc hist_rec.con (); - acc - ) (Hashtbl.create 1023) !history + (* The "mem" call is an optimisation, to avoid calling f if we have picked con already. *) + (* Using a hash table rather than a list is to optimise the "mem" call. *) + List.fold_left (fun acc hist_rec -> + if hist_rec.finish_count > since + && not (hist_rec.con == ignore) + && not (Hashtbl.mem acc hist_rec.con) + && f hist_rec + then Hashtbl.replace acc hist_rec.con (); + acc + ) (Hashtbl.create 1023) !history diff --git a/tools/ocaml/xenstored/logging.ml b/tools/ocaml/xenstored/logging.ml index 39c3036155..021ebc465b 100644 --- a/tools/ocaml/xenstored/logging.ml +++ b/tools/ocaml/xenstored/logging.ml @@ -21,138 +21,138 @@ open Printf (* Logger common *) type log_destination = - | File of string - | Syslog of Syslog.facility + | File of string + | Syslog of Syslog.facility let log_destination_of_string s = - let prefix = "syslog:" in - let len_prefix = String.length prefix in - let len = String.length s in - if String.startswith prefix s - then Syslog(Syslog.facility_of_string (String.sub s len_prefix (len - len_prefix))) - else File s + let prefix = "syslog:" in + let len_prefix = String.length prefix in + let len = String.length s in + if String.startswith prefix s + then Syslog(Syslog.facility_of_string (String.sub s len_prefix (len - len_prefix))) + else File s (* The prefix of a log line depends on the log destination *) let prefix log_destination ?level ?key date = match log_destination with - | File _ -> - let level = match level with - | Some x -> Printf.sprintf "|%5s" x - | None -> "" in - let key = match key with - | Some x -> "|" ^ x - | None -> "" in - Printf.sprintf "[%s%s%s] " date level key - | Syslog _ -> - let key = match key with - | Some x -> "[" ^ x ^ "] " - | None -> "" in - (* Syslog handles the date and level internally *) - key + | File _ -> + let level = match level with + | Some x -> Printf.sprintf "|%5s" x + | None -> "" in + let key = match key with + | Some x -> "|" ^ x + | None -> "" in + Printf.sprintf "[%s%s%s] " date level key + | Syslog _ -> + let key = match key with + | Some x -> "[" ^ x ^ "] " + | None -> "" in + (* Syslog handles the date and level internally *) + key type level = Debug | Info | Warn | Error | Null type logger = - { stop: unit -> unit; - restart: unit -> unit; - rotate: unit -> unit; - write: ?level:level -> string -> unit } + { stop: unit -> unit; + restart: unit -> unit; + rotate: unit -> unit; + write: ?level:level -> string -> unit } let truncate_line nb_chars line = - if String.length line > nb_chars - 1 then - let len = max (nb_chars - 1) 2 in - let dst_line = Bytes.create len in - Bytes.blit_string line 0 dst_line 0 (len - 2); - Bytes.set dst_line (len-2) '.'; - Bytes.set dst_line (len-1) '.'; - Bytes.unsafe_to_string dst_line - else line + if String.length line > nb_chars - 1 then + let len = max (nb_chars - 1) 2 in + let dst_line = Bytes.create len in + Bytes.blit_string line 0 dst_line 0 (len - 2); + Bytes.set dst_line (len-2) '.'; + Bytes.set dst_line (len-1) '.'; + Bytes.unsafe_to_string dst_line + else line let log_rotate ref_ch log_file log_nb_files = - let file n = sprintf "%s.%i" log_file n in - let log_files = - let rec aux accu n = - if n >= log_nb_files then accu - else - if n = 1 && Sys.file_exists log_file - then aux [log_file,1] 2 - else - let file = file (n-1) in - if Sys.file_exists file then - aux ((file, n) :: accu) (n+1) - else accu in - aux [] 1 in - List.iter (fun (f, n) -> Unix.rename f (file n)) log_files; - close_out !ref_ch; - ref_ch := open_out log_file + let file n = sprintf "%s.%i" log_file n in + let log_files = + let rec aux accu n = + if n >= log_nb_files then accu + else + if n = 1 && Sys.file_exists log_file + then aux [log_file,1] 2 + else + let file = file (n-1) in + if Sys.file_exists file then + aux ((file, n) :: accu) (n+1) + else accu in + aux [] 1 in + List.iter (fun (f, n) -> Unix.rename f (file n)) log_files; + close_out !ref_ch; + ref_ch := open_out log_file let make_file_logger log_file log_nb_files log_nb_lines log_nb_chars post_rotate = - let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in - let counter = ref 0 in - let stop() = - try flush !channel; close_out !channel - with _ -> () in - let restart() = - stop(); - channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in - let rotate() = - log_rotate channel log_file log_nb_files; - (post_rotate (): unit); - counter := 0 in - let write ?level:_ s = - let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in - let s = s ^ "\n" in - output_string !channel s; - flush !channel; - incr counter; - if !counter > log_nb_lines then rotate() in - { stop=stop; restart=restart; rotate=rotate; write=write } + let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in + let counter = ref 0 in + let stop() = + try flush !channel; close_out !channel + with _ -> () in + let restart() = + stop(); + channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in + let rotate() = + log_rotate channel log_file log_nb_files; + (post_rotate (): unit); + counter := 0 in + let write ?level:_ s = + let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in + let s = s ^ "\n" in + output_string !channel s; + flush !channel; + incr counter; + if !counter > log_nb_lines then rotate() in + { stop=stop; restart=restart; rotate=rotate; write=write } exception Unknown_level of string let int_of_level = function - | Debug -> 0 | Info -> 1 | Warn -> 2 - | Error -> 3 | Null -> max_int + | Debug -> 0 | Info -> 1 | Warn -> 2 + | Error -> 3 | Null -> max_int let string_of_level = function - | Debug -> "debug" | Info -> "info" | Warn -> "warn" - | Error -> "error" | Null -> "null" + | Debug -> "debug" | Info -> "info" | Warn -> "warn" + | Error -> "error" | Null -> "null" let level_of_string = function - | "debug" -> Debug | "info" -> Info | "warn" -> Warn - | "error" -> Error | "null" -> Null | s -> raise (Unknown_level s) + | "debug" -> Debug | "info" -> Info | "warn" -> Warn + | "error" -> Error | "null" -> Null | s -> raise (Unknown_level s) let string_of_date () = - let time = Unix.gettimeofday () in - let tm = Unix.gmtime time in - let msec = time -. (floor time) in - sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ" - (1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday - tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec - (int_of_float (1000.0 *. msec)) + let time = Unix.gettimeofday () in + let tm = Unix.gmtime time in + let msec = time -. (floor time) in + sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ" + (1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday + tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + (int_of_float (1000.0 *. msec)) (* We can defer to syslog for log management *) let make_syslog_logger facility = - (* When TZ is unset in the environment, each syslog call will stat the - /etc/localtime file at least three times during the process. We'd like to - avoid this cost given that we are not a mobile environment and we log - almost every xenstore entry update/watch. *) - let () = - let tz_is_set = - try String.length (Unix.getenv "TZ") > 0 - with Not_found -> false in - if not tz_is_set then Unix.putenv "TZ" "/etc/localtime" in - let nothing () = () in - let write ?level s = - let level = match level with - | Some Error -> Syslog.Err - | Some Warn -> Syslog.Warning - | Some Info -> Syslog.Info - | Some Debug -> Syslog.Debug - | Some Null -> Syslog.Debug - | None -> Syslog.Debug in - (* Syslog handles the date and level internally *) - Syslog.log facility level s in - { stop = nothing; restart = nothing; rotate = nothing; write=write } + (* When TZ is unset in the environment, each syslog call will stat the + /etc/localtime file at least three times during the process. We'd like to + avoid this cost given that we are not a mobile environment and we log + almost every xenstore entry update/watch. *) + let () = + let tz_is_set = + try String.length (Unix.getenv "TZ") > 0 + with Not_found -> false in + if not tz_is_set then Unix.putenv "TZ" "/etc/localtime" in + let nothing () = () in + let write ?level s = + let level = match level with + | Some Error -> Syslog.Err + | Some Warn -> Syslog.Warning + | Some Info -> Syslog.Info + | Some Debug -> Syslog.Debug + | Some Null -> Syslog.Debug + | None -> Syslog.Debug in + (* Syslog handles the date and level internally *) + Syslog.log facility level s in + { stop = nothing; restart = nothing; rotate = nothing; write=write } let xenstored_log_destination = ref (File (Paths.xen_log_dir ^ "/xenstored.log")) let xenstored_log_level = ref Warn @@ -164,34 +164,34 @@ let xenstored_logger = ref (None: logger option) let debug_enabled () = !xenstored_log_level = Debug let set_xenstored_log_destination s = - xenstored_log_destination := log_destination_of_string s + xenstored_log_destination := log_destination_of_string s let set_xenstored_logger logger = - xenstored_logger := Some logger; - logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d.%d" - Define.xenstored_major Define.xenstored_minor) + xenstored_logger := Some logger; + logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d.%d" + Define.xenstored_major Define.xenstored_minor) let init_xenstored_log () = match !xenstored_log_destination with - | File file -> - if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then - let logger = - make_file_logger - file !xenstored_log_nb_files !xenstored_log_nb_lines - !xenstored_log_nb_chars ignore in - set_xenstored_logger logger - | Syslog facility -> - set_xenstored_logger (make_syslog_logger facility) + | File file -> + if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then + let logger = + make_file_logger + file !xenstored_log_nb_files !xenstored_log_nb_lines + !xenstored_log_nb_chars ignore in + set_xenstored_logger logger + | Syslog facility -> + set_xenstored_logger (make_syslog_logger facility) let xenstored_logging level key (fmt: (_,_,_,_) format4) = - match !xenstored_logger with - | Some logger when int_of_level level >= int_of_level !xenstored_log_level -> - let date = string_of_date() in - let level' = string_of_level level in - let prefix = prefix !xenstored_log_destination ~level:level' ~key date in - Printf.ksprintf (fun s -> logger.write ~level (prefix ^ s)) fmt - | _ -> Printf.ksprintf ignore fmt + match !xenstored_logger with + | Some logger when int_of_level level >= int_of_level !xenstored_log_level -> + let date = string_of_date() in + let level' = string_of_level level in + let prefix = prefix !xenstored_log_destination ~level:level' ~key date in + Printf.ksprintf (fun s -> logger.write ~level (prefix ^ s)) fmt + | _ -> Printf.ksprintf ignore fmt let debug key = xenstored_logging Debug key let info key = xenstored_logging Info key @@ -201,66 +201,66 @@ let error key = xenstored_logging Error key (* Access logger *) type access_type = - | Coalesce - | Conflict - | Commit - | Newconn - | Endconn - | Watch_not_fired - | XbOp of Xenbus.Xb.Op.operation + | Coalesce + | Conflict + | Commit + | Newconn + | Endconn + | Watch_not_fired + | XbOp of Xenbus.Xb.Op.operation let string_of_tid ~con tid = - if tid = 0 - then sprintf "%-12s" con - else sprintf "%-12s" (sprintf "%s.%i" con tid) + if tid = 0 + then sprintf "%-12s" con + else sprintf "%-12s" (sprintf "%s.%i" con tid) let string_of_access_type = function - | Coalesce -> "coalesce " - | Conflict -> "conflict " - | Commit -> "commit " - | Newconn -> "newconn " - | Endconn -> "endconn " - | Watch_not_fired -> "w notfired" + | Coalesce -> "coalesce " + | Conflict -> "conflict " + | Commit -> "commit " + | Newconn -> "newconn " + | Endconn -> "endconn " + | Watch_not_fired -> "w notfired" - | XbOp op -> match op with - | Xenbus.Xb.Op.Debug -> "debug " + | XbOp op -> match op with + | Xenbus.Xb.Op.Debug -> "debug " - | Xenbus.Xb.Op.Directory -> "directory" - | Xenbus.Xb.Op.Read -> "read " - | Xenbus.Xb.Op.Getperms -> "getperms " + | Xenbus.Xb.Op.Directory -> "directory" + | Xenbus.Xb.Op.Read -> "read " + | Xenbus.Xb.Op.Getperms -> "getperms " - | Xenbus.Xb.Op.Watch -> "watch " - | Xenbus.Xb.Op.Unwatch -> "unwatch " + | Xenbus.Xb.Op.Watch -> "watch " + | Xenbus.Xb.Op.Unwatch -> "unwatch " - | Xenbus.Xb.Op.Transaction_start -> "t start " - | Xenbus.Xb.Op.Transaction_end -> "t end " + | Xenbus.Xb.Op.Transaction_start -> "t start " + | Xenbus.Xb.Op.Transaction_end -> "t end " - | Xenbus.Xb.Op.Introduce -> "introduce" - | Xenbus.Xb.Op.Release -> "release " - | Xenbus.Xb.Op.Getdomainpath -> "getdomain" - | Xenbus.Xb.Op.Isintroduced -> "is introduced" - | Xenbus.Xb.Op.Resume -> "resume " + | Xenbus.Xb.Op.Introduce -> "introduce" + | Xenbus.Xb.Op.Release -> "release " + | Xenbus.Xb.Op.Getdomainpath -> "getdomain" + | Xenbus.Xb.Op.Isintroduced -> "is introduced" + | Xenbus.Xb.Op.Resume -> "resume " - | Xenbus.Xb.Op.Write -> "write " - | Xenbus.Xb.Op.Mkdir -> "mkdir " - | Xenbus.Xb.Op.Rm -> "rm " - | Xenbus.Xb.Op.Setperms -> "setperms " - | Xenbus.Xb.Op.Reset_watches -> "reset watches" - | Xenbus.Xb.Op.Set_target -> "settarget" + | Xenbus.Xb.Op.Write -> "write " + | Xenbus.Xb.Op.Mkdir -> "mkdir " + | Xenbus.Xb.Op.Rm -> "rm " + | Xenbus.Xb.Op.Setperms -> "setperms " + | Xenbus.Xb.Op.Reset_watches -> "reset watches" + | Xenbus.Xb.Op.Set_target -> "settarget" - | Xenbus.Xb.Op.Error -> "error " - | Xenbus.Xb.Op.Watchevent -> "w event " - | Xenbus.Xb.Op.Invalid -> "invalid " - (* - | x -> Xenbus.Xb.Op.to_string x - *) + | Xenbus.Xb.Op.Error -> "error " + | Xenbus.Xb.Op.Watchevent -> "w event " + | Xenbus.Xb.Op.Invalid -> "invalid " + (* + | x -> Xenbus.Xb.Op.to_string x + *) let sanitize_data data = - let data = String.init - (String.length data) - (fun i -> let c = data.[i] in if c = '\000' then ' ' else c) - in - String.escaped data + let data = String.init + (String.length data) + (fun i -> let c = data.[i] in if c = '\000' then ' ' else c) + in + String.escaped data let activate_access_log = ref true let access_log_destination = ref (File (Paths.xen_log_dir ^ "/xenstored-access.log")) @@ -273,72 +273,72 @@ let access_log_special_ops = ref false let access_logger = ref None let set_access_log_destination s = - access_log_destination := log_destination_of_string s + access_log_destination := log_destination_of_string s let init_access_log post_rotate = match !access_log_destination with - | File file -> - if !access_log_nb_files > 0 then - let logger = - make_file_logger - file !access_log_nb_files !access_log_nb_lines - !access_log_nb_chars post_rotate in - access_logger := Some logger - | Syslog facility -> - access_logger := Some (make_syslog_logger facility) + | File file -> + if !access_log_nb_files > 0 then + let logger = + make_file_logger + file !access_log_nb_files !access_log_nb_lines + !access_log_nb_chars post_rotate in + access_logger := Some logger + | Syslog facility -> + access_logger := Some (make_syslog_logger facility) let access_logging ~con ~tid ?(data="") ~level access_type = - try - maybe - (fun logger -> - let date = string_of_date() in - let tid = string_of_tid ~con tid in - let access_type = string_of_access_type access_type in - let data = sanitize_data data in - let prefix = prefix !access_log_destination date in - let msg = Printf.sprintf "%s %s %s %s" prefix tid access_type data in - logger.write ~level msg) - !access_logger - with _ -> () + try + maybe + (fun logger -> + let date = string_of_date() in + let tid = string_of_tid ~con tid in + let access_type = string_of_access_type access_type in + let data = sanitize_data data in + let prefix = prefix !access_log_destination date in + let msg = Printf.sprintf "%s %s %s %s" prefix tid access_type data in + logger.write ~level msg) + !access_logger + with _ -> () let new_connection = access_logging ~level:Debug Newconn let end_connection = access_logging ~level:Debug Endconn let read_coalesce ~tid ~con data = - if !access_log_read_ops - then access_logging Coalesce ~tid ~con ~data:("read "^data) ~level:Debug + if !access_log_read_ops + then access_logging Coalesce ~tid ~con ~data:("read "^data) ~level:Debug let write_coalesce data = access_logging Coalesce ~data:("write "^data) ~level:Debug let conflict = access_logging Conflict ~level:Debug let commit = access_logging Commit ~level:Debug let xb_op ~tid ~con ~ty data = - let print = match ty with - | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops - | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end -> - false (* transactions are managed below *) - | Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume -> - !access_log_special_ops - | _ -> true in - if print then access_logging ~tid ~con ~data (XbOp ty) ~level:Info + let print = match ty with + | Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops + | Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end -> + false (* transactions are managed below *) + | Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume -> + !access_log_special_ops + | _ -> true in + if print then access_logging ~tid ~con ~data (XbOp ty) ~level:Info let start_transaction ~tid ~con = - if !access_log_transaction_ops && tid <> 0 - then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~level:Debug + if !access_log_transaction_ops && tid <> 0 + then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~level:Debug let end_transaction ~tid ~con = - if !access_log_transaction_ops && tid <> 0 - then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) ~level:Debug + if !access_log_transaction_ops && tid <> 0 + then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) ~level:Debug let live_update () = - xb_op ~tid:0 ~con:"" ~ty:Xenbus.Xb.Op.Debug "Live update begin" + xb_op ~tid:0 ~con:"" ~ty:Xenbus.Xb.Op.Debug "Live update begin" let xb_answer ~tid ~con ~ty data = - let print, level = match ty with - | Xenbus.Xb.Op.Error when String.startswith "ENOENT" data -> !access_log_read_ops , Warn - | Xenbus.Xb.Op.Error -> true , Warn - | Xenbus.Xb.Op.Watchevent -> true , Info - | _ -> false, Debug - in - if print then access_logging ~tid ~con ~data (XbOp ty) ~level + let print, level = match ty with + | Xenbus.Xb.Op.Error when String.startswith "ENOENT" data -> !access_log_read_ops , Warn + | Xenbus.Xb.Op.Error -> true , Warn + | Xenbus.Xb.Op.Watchevent -> true , Info + | _ -> false, Debug + in + if print then access_logging ~tid ~con ~data (XbOp ty) ~level let watch_not_fired ~con perms path = - let data = Printf.sprintf "EPERM perms=[%s] path=%s" perms path in - access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info + let data = Printf.sprintf "EPERM perms=[%s] path=%s" perms path in + access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info diff --git a/tools/ocaml/xenstored/packet.ml b/tools/ocaml/xenstored/packet.ml index aeae0a4f57..7c25117937 100644 --- a/tools/ocaml/xenstored/packet.ml +++ b/tools/ocaml/xenstored/packet.ml @@ -1,16 +1,16 @@ type request = { - tid: int; - rid: int; - ty: Xenbus.Xb.Op.operation; - data: string; + tid: int; + rid: int; + ty: Xenbus.Xb.Op.operation; + data: string; } type response = - | Ack of (unit -> unit) (* function is the action to execute after sending the ack *) - | Reply of string - | Error of string + | Ack of (unit -> unit) (* function is the action to execute after sending the ack *) + | Reply of string + | Error of string let response_equal a b = - match (a, b) with - | (Ack _, Ack _) -> true (* just consider the response, not the post-response action *) - | (x, y) -> x = y + match (a, b) with + | (Ack _, Ack _) -> true (* just consider the response, not the post-response action *) + | (x, y) -> x = y diff --git a/tools/ocaml/xenstored/parse_arg.ml b/tools/ocaml/xenstored/parse_arg.ml index 7c0478e76a..1a85b14ef5 100644 --- a/tools/ocaml/xenstored/parse_arg.ml +++ b/tools/ocaml/xenstored/parse_arg.ml @@ -15,59 +15,59 @@ *) type config = -{ - domain_init: bool; - activate_access_log: bool; - daemonize: bool; - reraise_top_level: bool; - config_file: string option; - pidfile: string option; (* old xenstored compatibility *) - tracefile: string option; (* old xenstored compatibility *) - restart: bool; - live_reload: bool; - disable_socket: bool; -} + { + domain_init: bool; + activate_access_log: bool; + daemonize: bool; + reraise_top_level: bool; + config_file: string option; + pidfile: string option; (* old xenstored compatibility *) + tracefile: string option; (* old xenstored compatibility *) + restart: bool; + live_reload: bool; + disable_socket: bool; + } let do_argv = - let pidfile = ref "" and tracefile = ref "" (* old xenstored compatibility *) - and domain_init = ref true - and activate_access_log = ref true - and daemonize = ref true - and reraise_top_level = ref false - and config_file = ref "" - and restart = ref false - and live_reload = ref false - and disable_socket = ref false - in + let pidfile = ref "" and tracefile = ref "" (* old xenstored compatibility *) + and domain_init = ref true + and activate_access_log = ref true + and daemonize = ref true + and reraise_top_level = ref false + and config_file = ref "" + and restart = ref false + and live_reload = ref false + and disable_socket = ref false + in - let speclist = - [ ("--no-domain-init", Arg.Unit (fun () -> domain_init := false), - "to state that xenstored should not initialise dom0"); - ("--config-file", Arg.Set_string config_file, - "set an alternative location for the configuration file"); - ("--no-fork", Arg.Unit (fun () -> daemonize := false), - "to request that the daemon does not fork"); - ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level := true), - "reraise exceptions caught at the top level"); - ("--no-access-log", Arg.Unit (fun () -> activate_access_log := false), - "do not create a xenstore-access.log file"); - ("--pid-file", Arg.Set_string pidfile, ""); (* for compatibility *) - ("-T", Arg.Set_string tracefile, ""); (* for compatibility *) - ("--restart", Arg.Set restart, "Read database on starting"); - ("--live", Arg.Set live_reload, "Read live dump on startup"); - ("--disable-socket", Arg.Unit (fun () -> disable_socket := true), "Disable socket"); - ] in - let usage_msg = "usage : xenstored [--config-file ] [--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable-socket]" in - Arg.parse speclist (fun _ -> ()) usage_msg; - { - domain_init = !domain_init; - activate_access_log = !activate_access_log; - daemonize = !daemonize; - reraise_top_level = !reraise_top_level; - config_file = if !config_file <> "" then Some !config_file else None; - pidfile = if !pidfile <> "" then Some !pidfile else None; - tracefile = if !tracefile <> "" then Some !tracefile else None; - restart = !restart; - live_reload = !live_reload; - disable_socket = !disable_socket; - } + let speclist = + [ ("--no-domain-init", Arg.Unit (fun () -> domain_init := false), + "to state that xenstored should not initialise dom0"); + ("--config-file", Arg.Set_string config_file, + "set an alternative location for the configuration file"); + ("--no-fork", Arg.Unit (fun () -> daemonize := false), + "to request that the daemon does not fork"); + ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level := true), + "reraise exceptions caught at the top level"); + ("--no-access-log", Arg.Unit (fun () -> activate_access_log := false), + "do not create a xenstore-access.log file"); + ("--pid-file", Arg.Set_string pidfile, ""); (* for compatibility *) + ("-T", Arg.Set_string tracefile, ""); (* for compatibility *) + ("--restart", Arg.Set restart, "Read database on starting"); + ("--live", Arg.Set live_reload, "Read live dump on startup"); + ("--disable-socket", Arg.Unit (fun () -> disable_socket := true), "Disable socket"); + ] in + let usage_msg = "usage : xenstored [--config-file ] [--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable-socket]" in + Arg.parse speclist (fun _ -> ()) usage_msg; + { + domain_init = !domain_init; + activate_access_log = !activate_access_log; + daemonize = !daemonize; + reraise_top_level = !reraise_top_level; + config_file = if !config_file <> "" then Some !config_file else None; + pidfile = if !pidfile <> "" then Some !pidfile else None; + tracefile = if !tracefile <> "" then Some !tracefile else None; + restart = !restart; + live_reload = !live_reload; + disable_socket = !disable_socket; + } diff --git a/tools/ocaml/xenstored/perms.ml b/tools/ocaml/xenstored/perms.ml index 84f2503e8e..14f8e334fe 100644 --- a/tools/ocaml/xenstored/perms.ml +++ b/tools/ocaml/xenstored/perms.ml @@ -25,72 +25,72 @@ let watch_activate = ref true type permty = READ | WRITE | RDWR | NONE let char_of_permty perm = - match perm with - | READ -> 'r' - | WRITE -> 'w' - | RDWR -> 'b' - | NONE -> 'n' + match perm with + | READ -> 'r' + | WRITE -> 'w' + | RDWR -> 'b' + | NONE -> 'n' let permty_of_char c = - match c with - | 'r' -> READ - | 'w' -> WRITE - | 'b' -> RDWR - | 'n' -> NONE - | _ -> invalid_arg "unknown permission type" + match c with + | 'r' -> READ + | 'w' -> WRITE + | 'b' -> RDWR + | 'n' -> NONE + | _ -> invalid_arg "unknown permission type" (* node permissions *) module Node = struct -type t = -{ - owner: Xenctrl.domid; - other: permty; - acl: (Xenctrl.domid * permty) list; -} + type t = + { + owner: Xenctrl.domid; + other: permty; + acl: (Xenctrl.domid * permty) list; + } -let create owner other acl = - { owner = owner; other = other; acl = acl } + let create owner other acl = + { owner = owner; other = other; acl = acl } -let get_other perms = perms.other -let get_acl perms = perms.acl -let get_owner perm = perm.owner + let get_other perms = perms.other + let get_acl perms = perms.acl + let get_owner perm = perm.owner -(** [remote_domid ~domid perm] removes all ACLs for [domid] from perm. -* If [domid] was the owner then it is changed to Dom0. -* This is used for cleaning up after dead domains. -* *) -let remove_domid ~domid perm = - let acl = List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.acl in - if perm.owner = domid then None else Some { perm with acl; owner = perm.owner } + (** [remote_domid ~domid perm] removes all ACLs for [domid] from perm. + * If [domid] was the owner then it is changed to Dom0. + * This is used for cleaning up after dead domains. + * *) + let remove_domid ~domid perm = + let acl = List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.acl in + if perm.owner = domid then None else Some { perm with acl; owner = perm.owner } -let default0 = create 0 NONE [] + let default0 = create 0 NONE [] -let perm_of_string s = - let ty = permty_of_char s.[0] - and id = int_of_string (String.sub s 1 (String.length s - 1)) in - (id, ty) + let perm_of_string s = + let ty = permty_of_char s.[0] + and id = int_of_string (String.sub s 1 (String.length s - 1)) in + (id, ty) -let of_strings ls = - let vect = List.map (perm_of_string) ls in - match vect with - | [] -> invalid_arg "permvec empty" - | h :: l -> create (fst h) (snd h) l + let of_strings ls = + let vect = List.map (perm_of_string) ls in + match vect with + | [] -> invalid_arg "permvec empty" + | h :: l -> create (fst h) (snd h) l -(* [s] must end with '\000' *) -let of_string s = - let ls = String.split '\000' s in - let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in - of_strings ls + (* [s] must end with '\000' *) + let of_string s = + let ls = String.split '\000' s in + let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in + of_strings ls -let string_of_perm perm = - Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm) + let string_of_perm perm = + Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm) -let to_string ?(sep="\000") permvec = - let l = ((permvec.owner, permvec.other) :: permvec.acl) in - String.concat sep (List.map string_of_perm l) + let to_string ?(sep="\000") permvec = + let l = ((permvec.owner, permvec.other) :: permvec.acl) in + String.concat sep (List.map string_of_perm l) end @@ -99,87 +99,87 @@ end module Connection = struct -type elt = Xenctrl.domid * (permty list) -type t = - { main: elt; - target: elt option; } + type elt = Xenctrl.domid * (permty list) + type t = + { main: elt; + target: elt option; } -let full_rights : t = - { main = 0, [READ; WRITE]; - target = None } + let full_rights : t = + { main = 0, [READ; WRITE]; + target = None } -let create ?(perms=[NONE]) domid : t = - { main = (domid, perms); - target = None } + let create ?(perms=[NONE]) domid : t = + { main = (domid, perms); + target = None } -let set_target (connection:t) ?(perms=[NONE]) domid = - { connection with target = Some (domid, perms) } + let set_target (connection:t) ?(perms=[NONE]) domid = + { connection with target = Some (domid, perms) } -let get_owners (connection:t) = - match connection.main, connection.target with - | c1, Some c2 -> [ fst c1; fst c2 ] - | c1, None -> [ fst c1 ] + let get_owners (connection:t) = + match connection.main, connection.target with + | c1, Some c2 -> [ fst c1; fst c2 ] + | c1, None -> [ fst c1 ] -let is_owner (connection:t) id = - match connection.target with - | Some target -> fst connection.main = id || fst target = id - | None -> fst connection.main = id + let is_owner (connection:t) id = + match connection.target with + | Some target -> fst connection.main = id || fst target = id + | None -> fst connection.main = id -let is_dom0 (connection:t) = - is_owner connection 0 + let is_dom0 (connection:t) = + is_owner connection 0 -let elt_to_string (i,p) = - Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p))) + let elt_to_string (i,p) = + Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p))) -let to_string connection = - Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target)) + let to_string connection = + Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target)) end (* check if owner of the current connection and of the current node are the same *) let check_owner (connection:Connection.t) (node:Node.t) = - if !activate && not (Connection.is_dom0 connection) - then Connection.is_owner connection (Node.get_owner node) - else true + if !activate && not (Connection.is_dom0 connection) + then Connection.is_owner connection (Node.get_owner node) + else true (* check if the current connection lacks the requested perm on the current node *) let lacks (connection:Connection.t) request (node:Node.t) = - let check_acl domainid = - let perm = - if List.mem_assoc domainid (Node.get_acl node) - then List.assoc domainid (Node.get_acl node) - else Node.get_other node - in - match perm, request with - | NONE, _ -> - info "Permission denied: Domain %d has no permission" domainid; - false - | RDWR, _ -> true - | READ, READ -> true - | WRITE, WRITE -> true - | READ, _ -> - info "Permission denied: Domain %d has read only access" domainid; - false - | WRITE, _ -> - info "Permission denied: Domain %d has write only access" domainid; - false - in - !activate - && not (Connection.is_dom0 connection) - && not (check_owner connection node) - && not (List.exists check_acl (Connection.get_owners connection)) + let check_acl domainid = + let perm = + if List.mem_assoc domainid (Node.get_acl node) + then List.assoc domainid (Node.get_acl node) + else Node.get_other node + in + match perm, request with + | NONE, _ -> + info "Permission denied: Domain %d has no permission" domainid; + false + | RDWR, _ -> true + | READ, READ -> true + | WRITE, WRITE -> true + | READ, _ -> + info "Permission denied: Domain %d has read only access" domainid; + false + | WRITE, _ -> + info "Permission denied: Domain %d has write only access" domainid; + false + in + !activate + && not (Connection.is_dom0 connection) + && not (check_owner connection node) + && not (List.exists check_acl (Connection.get_owners connection)) (* check if the current connection has the requested perm on the current node. -* Raises an exception if it doesn't. *) + * Raises an exception if it doesn't. *) let check connection request node = - if lacks connection request node - then raise Define.Permission_denied + if lacks connection request node + then raise Define.Permission_denied (* check if the current connection has the requested perm on the current node *) let has connection request node = not (lacks connection request node) let can_fire_watch connection perms = - not !watch_activate - || List.exists (has connection READ) perms + not !watch_activate + || List.exists (has connection READ) perms let equiv perm1 perm2 = - (Node.to_string perm1) = (Node.to_string perm2) + (Node.to_string perm1) = (Node.to_string perm2) diff --git a/tools/ocaml/xenstored/poll.ml b/tools/ocaml/xenstored/poll.ml index 26f8620dfc..80951c7d36 100644 --- a/tools/ocaml/xenstored/poll.ml +++ b/tools/ocaml/xenstored/poll.ml @@ -17,9 +17,9 @@ subscription flags used by poll, which have a correspondence to the readfds, writefds, exceptfds concept as in select. *) type event = { - mutable read: bool; - mutable write: bool; - mutable except: bool; + mutable read: bool; + mutable write: bool; + mutable except: bool; } external select_on_poll: (Unix.file_descr * event) array -> int -> int = "stub_select_on_poll" @@ -28,40 +28,40 @@ external set_fd_limit: int -> unit = "stub_set_fd_limit" (* The rlim_max given to setrlimit must not go above the system level nr_open, which we can read from /proc/sys. *) let get_sys_fs_nr_open () = - try - let ch = open_in "/proc/sys/fs/nr_open" in - let v = int_of_string (input_line ch) in - close_in_noerr ch; v - with _ -> 1024 * 1024 + try + let ch = open_in "/proc/sys/fs/nr_open" in + let v = int_of_string (input_line ch) in + close_in_noerr ch; v + with _ -> 1024 * 1024 let init_event () = {read = false; write = false; except = false} let poll_select in_fds out_fds exc_fds timeout = - let h = Hashtbl.create 57 in - let add_event event_set fd = - let e = - try Hashtbl.find h fd - with Not_found -> - let e = init_event () in - Hashtbl.add h fd e; e in - event_set e in - List.iter (add_event (fun x -> x.read <- true)) in_fds; - List.iter (add_event (fun x -> x.write <- true)) out_fds; - List.iter (add_event (fun x -> x.except <- true)) exc_fds; - (* Unix.stdin and init_event are dummy input as stubs, which will - always be overwritten later on. *) - let a = Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in - let i = ref (-1) in - Hashtbl.iter (fun fd event -> incr i; Array.set a !i (fd, event)) h; - let n = select_on_poll a (int_of_float (timeout *. 1000.)) in - let r = [], [], [] in - if n = 0 then r else - Array.fold_right - (fun (fd, event) (r, w, x) -> - (if event.read then fd :: r else r), - (if event.write then fd :: w else w), - (if event.except then fd :: x else x)) - a r + let h = Hashtbl.create 57 in + let add_event event_set fd = + let e = + try Hashtbl.find h fd + with Not_found -> + let e = init_event () in + Hashtbl.add h fd e; e in + event_set e in + List.iter (add_event (fun x -> x.read <- true)) in_fds; + List.iter (add_event (fun x -> x.write <- true)) out_fds; + List.iter (add_event (fun x -> x.except <- true)) exc_fds; + (* Unix.stdin and init_event are dummy input as stubs, which will + always be overwritten later on. *) + let a = Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in + let i = ref (-1) in + Hashtbl.iter (fun fd event -> incr i; Array.set a !i (fd, event)) h; + let n = select_on_poll a (int_of_float (timeout *. 1000.)) in + let r = [], [], [] in + if n = 0 then r else + Array.fold_right + (fun (fd, event) (r, w, x) -> + (if event.read then fd :: r else r), + (if event.write then fd :: w else w), + (if event.except then fd :: x else x)) + a r let () = - set_fd_limit (get_sys_fs_nr_open ()) + set_fd_limit (get_sys_fs_nr_open ()) diff --git a/tools/ocaml/xenstored/poll.mli b/tools/ocaml/xenstored/poll.mli index f73465b99f..e759608b1a 100644 --- a/tools/ocaml/xenstored/poll.mli +++ b/tools/ocaml/xenstored/poll.mli @@ -15,5 +15,5 @@ (** Same interface and semantics as [Unix.select], implemented using poll(3). *) val poll_select: - Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float - -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list + Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float + -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml index 72a79e9328..30e62377ce 100644 --- a/tools/ocaml/xenstored/process.ml +++ b/tools/ocaml/xenstored/process.ml @@ -31,302 +31,302 @@ exception Invalid_Cmd_Args let allow_debug = ref false let c_int_of_string s = - let v = ref 0 in - let is_digit c = c >= '0' && c <= '9' in - let len = String.length s in - let i = ref 0 in - while !i < len && not (is_digit s.[!i]) do incr i done; - while !i < len && is_digit s.[!i] - do - let x = (Char.code s.[!i]) - (Char.code '0') in - v := !v * 10 + x; - incr i - done; - !v + let v = ref 0 in + let is_digit c = c >= '0' && c <= '9' in + let len = String.length s in + let i = ref 0 in + while !i < len && not (is_digit s.[!i]) do incr i done; + while !i < len && is_digit s.[!i] + do + let x = (Char.code s.[!i]) - (Char.code '0') in + v := !v * 10 + x; + incr i + done; + !v (* when we don't want a limit, apply a max limit of 8 arguments. no arguments take more than 3 currently, which is pointless to split more than needed. *) let split limit c s = - let limit = match limit with None -> 8 | Some x -> x in - String.split ~limit c s + let limit = match limit with None -> 8 | Some x -> x in + String.split ~limit c s let split_one_path data con = - let args = split (Some 2) '\000' data in - match args with - | path :: "" :: [] -> Store.Path.create path (Connection.get_path con) - | _ -> raise Invalid_Cmd_Args + let args = split (Some 2) '\000' data in + match args with + | path :: "" :: [] -> Store.Path.create path (Connection.get_path con) + | _ -> raise Invalid_Cmd_Args let process_watch source t cons = - let oldroot = t.Transaction.oldroot in - let newroot = Store.get_root t.Transaction.store in - let ops = Transaction.get_paths t |> List.rev in - let do_op_watch op cons = - let recurse, oldroot, root = match (fst op) with - | Xenbus.Xb.Op.Write|Xenbus.Xb.Op.Mkdir -> false, None, newroot - | Xenbus.Xb.Op.Rm -> true, None, oldroot - | Xenbus.Xb.Op.Setperms -> false, Some oldroot, newroot - | _ -> raise (Failure "huh ?") in - Connections.fire_watches ?oldroot source root cons (snd op) recurse in - List.iter (fun op -> do_op_watch op cons) ops; - Connections.send_watchevents cons source + let oldroot = t.Transaction.oldroot in + let newroot = Store.get_root t.Transaction.store in + let ops = Transaction.get_paths t |> List.rev in + let do_op_watch op cons = + let recurse, oldroot, root = match (fst op) with + | Xenbus.Xb.Op.Write|Xenbus.Xb.Op.Mkdir -> false, None, newroot + | Xenbus.Xb.Op.Rm -> true, None, oldroot + | Xenbus.Xb.Op.Setperms -> false, Some oldroot, newroot + | _ -> raise (Failure "huh ?") in + Connections.fire_watches ?oldroot source root cons (snd op) recurse in + List.iter (fun op -> do_op_watch op cons) ops; + Connections.send_watchevents cons source let create_implicit_path t perm path = - let dirname = Store.Path.get_parent path in - if not (Transaction.path_exists t dirname) then ( - let rec check_path p = - match p with - | [] -> [] - | h :: l -> - if Transaction.path_exists t h then - check_path l - else - p in - let ret = check_path (List.tl (Store.Path.get_hierarchy dirname)) in - List.iter (fun s -> Transaction.mkdir ~with_watch:false t perm s) ret - ) + let dirname = Store.Path.get_parent path in + if not (Transaction.path_exists t dirname) then ( + let rec check_path p = + match p with + | [] -> [] + | h :: l -> + if Transaction.path_exists t h then + check_path l + else + p in + let ret = check_path (List.tl (Store.Path.get_hierarchy dirname)) in + List.iter (fun s -> Transaction.mkdir ~with_watch:false t perm s) ret + ) module LiveUpdate = struct -type t = - { binary: string - ; cmdline: string list - ; deadline: float - ; force: bool - ; result: string list - ; pending: bool } + type t = + { binary: string + ; cmdline: string list + ; deadline: float + ; force: bool + ; result: string list + ; pending: bool } -let state = ref - { binary= Sys.executable_name - ; cmdline= (Sys.argv |> Array.to_list |> List.tl) - ; deadline= 0. - ; force= false - ; result = [] - ; pending= false } + let state = ref + { binary= Sys.executable_name + ; cmdline= (Sys.argv |> Array.to_list |> List.tl) + ; deadline= 0. + ; force= false + ; result = [] + ; pending= false } -let debug = Printf.eprintf + let debug = Printf.eprintf -let forced_args = ["--live"; "--restart"] -let args_of_t t = - let filtered = List.filter (fun x -> not @@ List.mem x forced_args) t.cmdline in - (t.binary, forced_args @ filtered) + let forced_args = ["--live"; "--restart"] + let args_of_t t = + let filtered = List.filter (fun x -> not @@ List.mem x forced_args) t.cmdline in + (t.binary, forced_args @ filtered) -let string_of_t t = - let executable, rest = args_of_t t in - Filename.quote_command executable rest + let string_of_t t = + let executable, rest = args_of_t t in + Filename.quote_command executable rest -let launch_exn t = - let executable, rest = args_of_t t in - let args = Array.of_list (executable :: rest) in - info "Launching %s, args: %s" executable (String.concat " " rest); - Unix.execv args.(0) args + let launch_exn t = + let executable, rest = args_of_t t in + let args = Array.of_list (executable :: rest) in + info "Launching %s, args: %s" executable (String.concat " " rest); + Unix.execv args.(0) args -let validate_exn t = - (* --help must be last to check validity of earlier arguments *) - let t' = {t with cmdline= t.cmdline @ ["--help"]} in - let cmd = string_of_t t' in - debug "Executing %s" cmd ; - match Unix.fork () with - | 0 -> ( try launch_exn t' with _ -> exit 2 ) - | pid -> ( - match Unix.waitpid [] pid with - | _, Unix.WEXITED 0 -> - debug "Live update validated cmdline %s" cmd; - t - | _, Unix.WEXITED n -> - invalid_arg (Printf.sprintf "Command %s exited with code %d" cmd n) - | _, Unix.WSIGNALED n -> - invalid_arg (Printf.sprintf "Command %s killed by ocaml signal number %d" cmd n) - | _, Unix.WSTOPPED n -> - invalid_arg (Printf.sprintf "Command %s stopped by ocaml signal number %d" cmd n) - ) + let validate_exn t = + (* --help must be last to check validity of earlier arguments *) + let t' = {t with cmdline= t.cmdline @ ["--help"]} in + let cmd = string_of_t t' in + debug "Executing %s" cmd ; + match Unix.fork () with + | 0 -> ( try launch_exn t' with _ -> exit 2 ) + | pid -> ( + match Unix.waitpid [] pid with + | _, Unix.WEXITED 0 -> + debug "Live update validated cmdline %s" cmd; + t + | _, Unix.WEXITED n -> + invalid_arg (Printf.sprintf "Command %s exited with code %d" cmd n) + | _, Unix.WSIGNALED n -> + invalid_arg (Printf.sprintf "Command %s killed by ocaml signal number %d" cmd n) + | _, Unix.WSTOPPED n -> + invalid_arg (Printf.sprintf "Command %s stopped by ocaml signal number %d" cmd n) + ) -let parse_live_update args = - try - (state := - match args with - | ["-f"; file] -> - validate_exn {!state with binary= file} - | ["-a"] -> - debug "Live update aborted" ; - {!state with pending= false; result = []} - | "-c" :: cmdline -> - validate_exn {!state with cmdline = !state.cmdline @ cmdline} - | "-s" :: _ -> - (match !state.pending, !state.result with - | true, _ -> !state (* no change to state, avoid resetting timeout *) - | false, _ :: _ -> !state (* we got a pending result to deliver *) - | false, [] -> - let timeout = ref 60 in - let force = ref false in - Arg.parse_argv ~current:(ref 0) (Array.of_list args) - [ ( "-t" - , Arg.Set_int timeout - , "timeout in seconds to wait for active transactions to finish" - ) - ; ( "-F" - , Arg.Set force - , "force live update to happen even with running transactions after timeout elapsed" - ) - ] - (fun x -> raise (Arg.Bad x)) - "live-update -s" ; - debug "Live update process queued" ; - {!state with deadline = Unix.gettimeofday () +. float !timeout - ; force= !force; pending= true}) - | _ -> - invalid_arg ("Unknown arguments: " ^ String.concat "," args)) ; - match !state.pending, !state.result with - | true, _ -> Some "BUSY" - | false, (_ :: _ as result) -> - (* xenstore-control has read the result, clear it *) - state := { !state with result = [] }; - Some (String.concat "\n" result) - | false, [] -> None - with - | Arg.Bad s | Arg.Help s | Invalid_argument s -> - Some s - | Unix.Unix_error (e, fn, args) -> - Some (Printf.sprintf "%s(%s): %s" fn args (Unix.error_message e)) + let parse_live_update args = + try + (state := + match args with + | ["-f"; file] -> + validate_exn {!state with binary= file} + | ["-a"] -> + debug "Live update aborted" ; + {!state with pending= false; result = []} + | "-c" :: cmdline -> + validate_exn {!state with cmdline = !state.cmdline @ cmdline} + | "-s" :: _ -> + (match !state.pending, !state.result with + | true, _ -> !state (* no change to state, avoid resetting timeout *) + | false, _ :: _ -> !state (* we got a pending result to deliver *) + | false, [] -> + let timeout = ref 60 in + let force = ref false in + Arg.parse_argv ~current:(ref 0) (Array.of_list args) + [ ( "-t" + , Arg.Set_int timeout + , "timeout in seconds to wait for active transactions to finish" + ) + ; ( "-F" + , Arg.Set force + , "force live update to happen even with running transactions after timeout elapsed" + ) + ] + (fun x -> raise (Arg.Bad x)) + "live-update -s" ; + debug "Live update process queued" ; + {!state with deadline = Unix.gettimeofday () +. float !timeout + ; force= !force; pending= true}) + | _ -> + invalid_arg ("Unknown arguments: " ^ String.concat "," args)) ; + match !state.pending, !state.result with + | true, _ -> Some "BUSY" + | false, (_ :: _ as result) -> + (* xenstore-control has read the result, clear it *) + state := { !state with result = [] }; + Some (String.concat "\n" result) + | false, [] -> None + with + | Arg.Bad s | Arg.Help s | Invalid_argument s -> + Some s + | Unix.Unix_error (e, fn, args) -> + Some (Printf.sprintf "%s(%s): %s" fn args (Unix.error_message e)) - let should_run cons = - let t = !state in - if t.pending then begin - match Connections.prevents_quit cons with - | [] -> true - | _ when Unix.gettimeofday () < t.deadline -> false - | l -> - warn "timeout reached: have to wait, migrate or shutdown %d domains:" (List.length l); - let msgs = List.rev_map (fun con -> Printf.sprintf "%s: %d tx, out: %b, perm: %s" - (Connection.get_domstr con) - (Connection.number_of_transactions con) - (Connection.has_output con) - (Connection.get_perm con |> Perms.Connection.to_string) - ) l in - List.iter (warn "Live-update: %s") msgs; - if t.force then begin - warn "Live update forced, some domain connections may break!"; - true - end else begin - warn "Live update aborted (see above for domains preventing it)"; - state := { t with pending = false; result = msgs}; - false - end - end else false + let should_run cons = + let t = !state in + if t.pending then begin + match Connections.prevents_quit cons with + | [] -> true + | _ when Unix.gettimeofday () < t.deadline -> false + | l -> + warn "timeout reached: have to wait, migrate or shutdown %d domains:" (List.length l); + let msgs = List.rev_map (fun con -> Printf.sprintf "%s: %d tx, out: %b, perm: %s" + (Connection.get_domstr con) + (Connection.number_of_transactions con) + (Connection.has_output con) + (Connection.get_perm con |> Perms.Connection.to_string) + ) l in + List.iter (warn "Live-update: %s") msgs; + if t.force then begin + warn "Live update forced, some domain connections may break!"; + true + end else begin + warn "Live update aborted (see above for domains preventing it)"; + state := { t with pending = false; result = msgs}; + false + end + end else false - let completed () = - state := { !state with result = ["OK"] } + let completed () = + state := { !state with result = ["OK"] } end (* packets *) let do_debug con t _domains cons data = - if not (Connection.is_dom0 con) && not !allow_debug - then None - else try match split None '\000' data with - | "live-update" :: params -> - let dropped_trailing_nul = params |> List.rev |> List.tl |> List.rev in - LiveUpdate.parse_live_update dropped_trailing_nul - | "print" :: msg :: _ -> - Logging.xb_op ~tid:0 ~ty:Xenbus.Xb.Op.Debug ~con:"=======>" msg; - None - | "quota" :: domid :: _ -> - let domid = int_of_string domid in - let quota = (Store.get_quota t.Transaction.store) in - Some (Quota.to_string quota domid ^ "\000") - | "watches" :: _ -> - let watches = Connections.debug cons in - Some (watches ^ "\000") - | "xenbus" :: domid :: _ -> - let domid = int_of_string domid in - let con = Connections.find_domain cons domid in - let s = Printf.sprintf "xenbus: %s; overflow queue length: %d, can_input: %b, has_more_input: %b, has_old_output: %b, has_new_output: %b, has_more_work: %b. pending: %s" - (Xenbus.Xb.debug con.xb) - (Connection.source_pending_watchevents con) - (Connection.can_input con) - (Connection.has_more_input con) - (Connection.has_old_output con) - (Connection.has_new_output con) - (Connection.has_more_work con) - (Connections.debug_watchevents cons con) - in - Some s - | "mfn" :: domid :: _ -> - let domid = int_of_string domid in - let con = Connections.find_domain cons domid in - may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connection.get_domain con) - | _ -> None - with _ -> None + if not (Connection.is_dom0 con) && not !allow_debug + then None + else try match split None '\000' data with + | "live-update" :: params -> + let dropped_trailing_nul = params |> List.rev |> List.tl |> List.rev in + LiveUpdate.parse_live_update dropped_trailing_nul + | "print" :: msg :: _ -> + Logging.xb_op ~tid:0 ~ty:Xenbus.Xb.Op.Debug ~con:"=======>" msg; + None + | "quota" :: domid :: _ -> + let domid = int_of_string domid in + let quota = (Store.get_quota t.Transaction.store) in + Some (Quota.to_string quota domid ^ "\000") + | "watches" :: _ -> + let watches = Connections.debug cons in + Some (watches ^ "\000") + | "xenbus" :: domid :: _ -> + let domid = int_of_string domid in + let con = Connections.find_domain cons domid in + let s = Printf.sprintf "xenbus: %s; overflow queue length: %d, can_input: %b, has_more_input: %b, has_old_output: %b, has_new_output: %b, has_more_work: %b. pending: %s" + (Xenbus.Xb.debug con.xb) + (Connection.source_pending_watchevents con) + (Connection.can_input con) + (Connection.has_more_input con) + (Connection.has_old_output con) + (Connection.has_new_output con) + (Connection.has_more_work con) + (Connections.debug_watchevents cons con) + in + Some s + | "mfn" :: domid :: _ -> + let domid = int_of_string domid in + let con = Connections.find_domain cons domid in + may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connection.get_domain con) + | _ -> None + with _ -> None let do_directory con t _domains _cons data = - let path = split_one_path data con in - let entries = Transaction.ls t (Connection.get_perm con) path in - if List.length entries > 0 then - (Utils.join_by_null entries) ^ "\000" - else - "" + let path = split_one_path data con in + let entries = Transaction.ls t (Connection.get_perm con) path in + if List.length entries > 0 then + (Utils.join_by_null entries) ^ "\000" + else + "" let do_read con t _domains _cons data = - let path = split_one_path data con in - Transaction.read t (Connection.get_perm con) path + let path = split_one_path data con in + Transaction.read t (Connection.get_perm con) path let do_getperms con t _domains _cons data = - let path = split_one_path data con in - let perms = Transaction.getperms t (Connection.get_perm con) path in - Perms.Node.to_string perms ^ "\000" + let path = split_one_path data con in + let perms = Transaction.getperms t (Connection.get_perm con) path in + Perms.Node.to_string perms ^ "\000" let do_getdomainpath _con _t _domains _cons data = - let domid = - match (split None '\000' data) with - | domid :: "" :: [] -> c_int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - sprintf "/local/domain/%u\000" domid + let domid = + match (split None '\000' data) with + | domid :: "" :: [] -> c_int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + sprintf "/local/domain/%u\000" domid let do_write con t _domains _cons data = - let path, value = - match (split (Some 2) '\000' data) with - | path :: value :: [] -> Store.Path.create path (Connection.get_path con), value - | _ -> raise Invalid_Cmd_Args - in - create_implicit_path t (Connection.get_perm con) path; - Transaction.write t (Connection.get_perm con) path value + let path, value = + match (split (Some 2) '\000' data) with + | path :: value :: [] -> Store.Path.create path (Connection.get_path con), value + | _ -> raise Invalid_Cmd_Args + in + create_implicit_path t (Connection.get_perm con) path; + Transaction.write t (Connection.get_perm con) path value let do_mkdir con t _domains _cons data = - let path = split_one_path data con in - create_implicit_path t (Connection.get_perm con) path; - try - Transaction.mkdir t (Connection.get_perm con) path - with - Define.Already_exist -> () + let path = split_one_path data con in + create_implicit_path t (Connection.get_perm con) path; + try + Transaction.mkdir t (Connection.get_perm con) path + with + Define.Already_exist -> () let do_rm con t _domains _cons data = - let path = split_one_path data con in - try - Transaction.rm t (Connection.get_perm con) path - with - Define.Doesnt_exist -> () + let path = split_one_path data con in + try + Transaction.rm t (Connection.get_perm con) path + with + Define.Doesnt_exist -> () let do_setperms con t _domains _cons data = - let path, perms = - match (split (Some 2) '\000' data) with - | path :: perms :: _ -> - Store.Path.create path (Connection.get_path con), - (Perms.Node.of_string perms) - | _ -> raise Invalid_Cmd_Args - in - Transaction.setperms t (Connection.get_perm con) path perms + let path, perms = + match (split (Some 2) '\000' data) with + | path :: perms :: _ -> + Store.Path.create path (Connection.get_path con), + (Perms.Node.of_string perms) + | _ -> raise Invalid_Cmd_Args + in + Transaction.setperms t (Connection.get_perm con) path perms let do_error _con _t _domains _cons _data = - raise Define.Unknown_operation + raise Define.Unknown_operation let do_isintroduced con _t domains _cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid = - match (split None '\000' data) with - | domid :: _ -> int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - if domid = Define.domid_self || Domains.exist domains domid then "T\000" else "F\000" + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let domid = + match (split None '\000' data) with + | domid :: _ -> int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + if domid = Define.domid_self || Domains.exist domains domid then "T\000" else "F\000" (* only in xen >= 4.2 *) let do_reset_watches con _t _domains cons _data = @@ -335,432 +335,432 @@ let do_reset_watches con _t _domains cons _data = (* only in >= xen3.3 *) let do_set_target con _t _domains cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - match split None '\000' data with - | [ domid; target_domid; "" ] -> Connections.set_target cons (c_int_of_string domid) (c_int_of_string target_domid) - | _ -> raise Invalid_Cmd_Args + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + match split None '\000' data with + | [ domid; target_domid; "" ] -> Connections.set_target cons (c_int_of_string domid) (c_int_of_string target_domid) + | _ -> raise Invalid_Cmd_Args (*------------- Generic handling of ty ------------------*) let send_response ty con t rid response = - match response with - | Packet.Ack f -> - Connection.send_ack con (Transaction.get_id t) rid ty; - (* Now do any necessary follow-up actions *) - f () - | Packet.Reply ret -> - Connection.send_reply con (Transaction.get_id t) rid ty ret - | Packet.Error e -> - Connection.send_error con (Transaction.get_id t) rid e + match response with + | Packet.Ack f -> + Connection.send_ack con (Transaction.get_id t) rid ty; + (* Now do any necessary follow-up actions *) + f () + | Packet.Reply ret -> + Connection.send_reply con (Transaction.get_id t) rid ty ret + | Packet.Error e -> + Connection.send_error con (Transaction.get_id t) rid e let reply_ack fct con t doms cons data = - fct con t doms cons data; - Packet.Ack (fun () -> - if Transaction.get_id t = Transaction.none then - process_watch con t cons - ) + fct con t doms cons data; + Packet.Ack (fun () -> + if Transaction.get_id t = Transaction.none then + process_watch con t cons + ) let reply_data fct con t doms cons data = - let ret = fct con t doms cons data in - Packet.Reply ret + let ret = fct con t doms cons data in + Packet.Reply ret let reply_data_or_ack fct con t doms cons data = - match fct con t doms cons data with - | Some ret -> Packet.Reply ret - | None -> Packet.Ack (fun () -> ()) + match fct con t doms cons data with + | Some ret -> Packet.Reply ret + | None -> Packet.Ack (fun () -> ()) let reply_none fct con t doms cons data = - (* let the function reply *) - fct con t doms cons data + (* let the function reply *) + fct con t doms cons data (* Functions for 'simple' operations that cannot be part of a transaction *) let function_of_type_simple_op ty = - match ty with - | Xenbus.Xb.Op.Debug - | Xenbus.Xb.Op.Watch - | Xenbus.Xb.Op.Unwatch - | Xenbus.Xb.Op.Transaction_start - | Xenbus.Xb.Op.Transaction_end - | Xenbus.Xb.Op.Introduce - | Xenbus.Xb.Op.Release - | Xenbus.Xb.Op.Isintroduced - | Xenbus.Xb.Op.Resume - | Xenbus.Xb.Op.Set_target - | Xenbus.Xb.Op.Reset_watches - | Xenbus.Xb.Op.Invalid -> error "called function_of_type_simple_op on operation %s" (Xenbus.Xb.Op.to_string ty); - raise (Invalid_argument (Xenbus.Xb.Op.to_string ty)) - | Xenbus.Xb.Op.Directory -> reply_data do_directory - | Xenbus.Xb.Op.Read -> reply_data do_read - | Xenbus.Xb.Op.Getperms -> reply_data do_getperms - | Xenbus.Xb.Op.Getdomainpath -> reply_data do_getdomainpath - | Xenbus.Xb.Op.Write -> reply_ack do_write - | Xenbus.Xb.Op.Mkdir -> reply_ack do_mkdir - | Xenbus.Xb.Op.Rm -> reply_ack do_rm - | Xenbus.Xb.Op.Setperms -> reply_ack do_setperms - | _ -> reply_ack do_error + match ty with + | Xenbus.Xb.Op.Debug + | Xenbus.Xb.Op.Watch + | Xenbus.Xb.Op.Unwatch + | Xenbus.Xb.Op.Transaction_start + | Xenbus.Xb.Op.Transaction_end + | Xenbus.Xb.Op.Introduce + | Xenbus.Xb.Op.Release + | Xenbus.Xb.Op.Isintroduced + | Xenbus.Xb.Op.Resume + | Xenbus.Xb.Op.Set_target + | Xenbus.Xb.Op.Reset_watches + | Xenbus.Xb.Op.Invalid -> error "called function_of_type_simple_op on operation %s" (Xenbus.Xb.Op.to_string ty); + raise (Invalid_argument (Xenbus.Xb.Op.to_string ty)) + | Xenbus.Xb.Op.Directory -> reply_data do_directory + | Xenbus.Xb.Op.Read -> reply_data do_read + | Xenbus.Xb.Op.Getperms -> reply_data do_getperms + | Xenbus.Xb.Op.Getdomainpath -> reply_data do_getdomainpath + | Xenbus.Xb.Op.Write -> reply_ack do_write + | Xenbus.Xb.Op.Mkdir -> reply_ack do_mkdir + | Xenbus.Xb.Op.Rm -> reply_ack do_rm + | Xenbus.Xb.Op.Setperms -> reply_ack do_setperms + | _ -> reply_ack do_error let input_handle_error ~cons ~doms ~fct ~con ~t ~req = - let reply_error e = - Packet.Error e in - try - Transaction.check_quota_exn ~perm:(Connection.get_perm con) t; - fct con t doms cons req.Packet.data - with - | Define.Invalid_path -> reply_error "EINVAL" - | Define.Already_exist -> reply_error "EEXIST" - | Define.Doesnt_exist -> reply_error "ENOENT" - | Define.Lookup_Doesnt_exist _ -> reply_error "ENOENT" - | Define.Permission_denied -> reply_error "EACCES" - | Not_found -> reply_error "ENOENT" - | Invalid_Cmd_Args -> reply_error "EINVAL" - | Invalid_argument _ -> reply_error "EINVAL" - | Transaction_again -> reply_error "EAGAIN" - | Transaction_nested -> reply_error "EBUSY" - | Domain_not_match -> reply_error "EINVAL" - | Quota.Limit_reached -> reply_error "EQUOTA" - | Quota.Data_too_big -> reply_error "E2BIG" - | Quota.Transaction_opened -> reply_error "EQUOTA" - | (Failure "int_of_string") -> reply_error "EINVAL" - | Define.Unknown_operation -> reply_error "ENOSYS" + let reply_error e = + Packet.Error e in + try + Transaction.check_quota_exn ~perm:(Connection.get_perm con) t; + fct con t doms cons req.Packet.data + with + | Define.Invalid_path -> reply_error "EINVAL" + | Define.Already_exist -> reply_error "EEXIST" + | Define.Doesnt_exist -> reply_error "ENOENT" + | Define.Lookup_Doesnt_exist _ -> reply_error "ENOENT" + | Define.Permission_denied -> reply_error "EACCES" + | Not_found -> reply_error "ENOENT" + | Invalid_Cmd_Args -> reply_error "EINVAL" + | Invalid_argument _ -> reply_error "EINVAL" + | Transaction_again -> reply_error "EAGAIN" + | Transaction_nested -> reply_error "EBUSY" + | Domain_not_match -> reply_error "EINVAL" + | Quota.Limit_reached -> reply_error "EQUOTA" + | Quota.Data_too_big -> reply_error "E2BIG" + | Quota.Transaction_opened -> reply_error "EQUOTA" + | (Failure "int_of_string") -> reply_error "EINVAL" + | Define.Unknown_operation -> reply_error "ENOSYS" let write_access_log ~ty ~tid ~con ~data = - Logging.xb_op ~ty ~tid ~con data + Logging.xb_op ~ty ~tid ~con data let write_answer_log ~ty ~tid ~con ~data = - Logging.xb_answer ~ty ~tid ~con data + Logging.xb_answer ~ty ~tid ~con data let write_response_log ~ty ~tid ~con ~response = - match response with - | Packet.Ack _ -> write_answer_log ~ty ~tid ~con ~data:"" - | Packet.Reply x -> write_answer_log ~ty ~tid ~con ~data:x - | Packet.Error e -> write_answer_log ~ty:(Xenbus.Xb.Op.Error) ~tid ~con ~data:e + match response with + | Packet.Ack _ -> write_answer_log ~ty ~tid ~con ~data:"" + | Packet.Reply x -> write_answer_log ~ty ~tid ~con ~data:x + | Packet.Error e -> write_answer_log ~ty:(Xenbus.Xb.Op.Error) ~tid ~con ~data:e let record_commit ~con ~tid ~before ~after = - let inc r = r := Int64.add 1L !r in - let finish_count = inc Transaction.counter; !Transaction.counter in - History.push {History.con=con; tid=tid; before=before; after=after; finish_count=finish_count} + let inc r = r := Int64.add 1L !r in + let finish_count = inc Transaction.counter; !Transaction.counter in + History.push {History.con=con; tid=tid; before=before; after=after; finish_count=finish_count} (* Replay a stored transaction against a fresh store, check the responses are all equivalent: if so, commit the transaction. Otherwise send the abort to the client. *) let transaction_replay c t doms cons = - match t.Transaction.ty with - | Transaction.No -> - error "attempted to replay a non-full transaction"; - false - | Transaction.Full(id, _oldstore, cstore) -> - let tid = Connection.start_transaction c cstore in - let replay_t = Transaction.make ~internal:true tid cstore in - let con = sprintf "r(%d):%s" id (Connection.get_domstr c) in + match t.Transaction.ty with + | Transaction.No -> + error "attempted to replay a non-full transaction"; + false + | Transaction.Full(id, _oldstore, cstore) -> + let tid = Connection.start_transaction c cstore in + let replay_t = Transaction.make ~internal:true tid cstore in + let con = sprintf "r(%d):%s" id (Connection.get_domstr c) in - let perform_exn ~wlog txn (request, response) = - if wlog then write_access_log ~ty:request.Packet.ty ~tid ~con ~data:request.Packet.data; - let fct = function_of_type_simple_op request.Packet.ty in - let response' = input_handle_error ~cons ~doms ~fct ~con:c ~t:txn ~req:request in - if wlog then write_response_log ~ty:request.Packet.ty ~tid ~con ~response:response'; - if not(Packet.response_equal response response') then raise Transaction_again - in - finally - (fun () -> - try - Logging.start_transaction ~con ~tid; - List.iter (perform_exn ~wlog:true replay_t) (Transaction.get_operations t); (* May throw EAGAIN *) + let perform_exn ~wlog txn (request, response) = + if wlog then write_access_log ~ty:request.Packet.ty ~tid ~con ~data:request.Packet.data; + let fct = function_of_type_simple_op request.Packet.ty in + let response' = input_handle_error ~cons ~doms ~fct ~con:c ~t:txn ~req:request in + if wlog then write_response_log ~ty:request.Packet.ty ~tid ~con ~response:response'; + if not(Packet.response_equal response response') then raise Transaction_again + in + finally + (fun () -> + try + Logging.start_transaction ~con ~tid; + List.iter (perform_exn ~wlog:true replay_t) (Transaction.get_operations t); (* May throw EAGAIN *) - Logging.end_transaction ~con ~tid; - Transaction.commit ~con replay_t - with - | Transaction_again -> ( - Transaction.failed_commits := Int64.add !Transaction.failed_commits 1L; - let victim_domstr = Connection.get_domstr c in - debug "Apportioning blame for EAGAIN in txn %d, domain=%s" id victim_domstr; - let punish guilty_con = - debug "Blaming domain %s for conflict with domain %s txn %d" - (Connection.get_domstr guilty_con) victim_domstr id; - Connection.decr_conflict_credit doms guilty_con - in - let judge_and_sentence hist_rec = ( - let can_apply_on store = ( - let store = Store.copy store in - let trial_t = Transaction.make ~internal:true Transaction.none store in - try List.iter (perform_exn ~wlog:false trial_t) (Transaction.get_operations t); - true - with Transaction_again -> false - ) in - if can_apply_on hist_rec.History.before - && not (can_apply_on hist_rec.History.after) - then (punish hist_rec.History.con; true) - else false - ) in - let guilty_cons = History.filter_connections ~ignore:c ~since:t.Transaction.start_count ~f:judge_and_sentence in - if Hashtbl.length guilty_cons = 0 then ( - debug "Found no culprit for conflict in %s: must be self or not in history." con; - Transaction.failed_commits_no_culprit := Int64.add !Transaction.failed_commits_no_culprit 1L - ); - false - ) - | e -> - info "transaction_replay %d caught: %s" tid (Printexc.to_string e); - false - ) - (fun () -> - ignore @@ Connection.end_transaction c tid None - ) + Logging.end_transaction ~con ~tid; + Transaction.commit ~con replay_t + with + | Transaction_again -> ( + Transaction.failed_commits := Int64.add !Transaction.failed_commits 1L; + let victim_domstr = Connection.get_domstr c in + debug "Apportioning blame for EAGAIN in txn %d, domain=%s" id victim_domstr; + let punish guilty_con = + debug "Blaming domain %s for conflict with domain %s txn %d" + (Connection.get_domstr guilty_con) victim_domstr id; + Connection.decr_conflict_credit doms guilty_con + in + let judge_and_sentence hist_rec = ( + let can_apply_on store = ( + let store = Store.copy store in + let trial_t = Transaction.make ~internal:true Transaction.none store in + try List.iter (perform_exn ~wlog:false trial_t) (Transaction.get_operations t); + true + with Transaction_again -> false + ) in + if can_apply_on hist_rec.History.before + && not (can_apply_on hist_rec.History.after) + then (punish hist_rec.History.con; true) + else false + ) in + let guilty_cons = History.filter_connections ~ignore:c ~since:t.Transaction.start_count ~f:judge_and_sentence in + if Hashtbl.length guilty_cons = 0 then ( + debug "Found no culprit for conflict in %s: must be self or not in history." con; + Transaction.failed_commits_no_culprit := Int64.add !Transaction.failed_commits_no_culprit 1L + ); + false + ) + | e -> + info "transaction_replay %d caught: %s" tid (Printexc.to_string e); + false + ) + (fun () -> + ignore @@ Connection.end_transaction c tid None + ) let do_watch con _t _domains cons data = - let (node, token) = - match (split None '\000' data) with - | [node; token; ""] -> node, token - | _ -> raise Invalid_Cmd_Args - in - let watch = Connections.add_watch cons con node token in - Packet.Ack (fun () -> - (* xenstore.txt says this watch is fired immediately, - implying even if path doesn't exist or is unreadable *) - Connection.fire_single_watch_unchecked con watch) + let (node, token) = + match (split None '\000' data) with + | [node; token; ""] -> node, token + | _ -> raise Invalid_Cmd_Args + in + let watch = Connections.add_watch cons con node token in + Packet.Ack (fun () -> + (* xenstore.txt says this watch is fired immediately, + implying even if path doesn't exist or is unreadable *) + Connection.fire_single_watch_unchecked con watch) let do_unwatch con _t _domains cons data = - let (node, token) = - match (split None '\000' data) with - | [node; token; ""] -> node, token - | _ -> raise Invalid_Cmd_Args - in - ignore @@ Connections.del_watch cons con node token + let (node, token) = + match (split None '\000' data) with + | [node; token; ""] -> node, token + | _ -> raise Invalid_Cmd_Args + in + ignore @@ Connections.del_watch cons con node token let do_transaction_start con t _domains _cons _data = - if Transaction.get_id t <> Transaction.none then - raise Transaction_nested; - let store = Transaction.get_store t in - string_of_int (Connection.start_transaction con store) ^ "\000" + if Transaction.get_id t <> Transaction.none then + raise Transaction_nested; + let store = Transaction.get_store t in + string_of_int (Connection.start_transaction con store) ^ "\000" let do_transaction_end con t domains cons data = - let commit = - match (split None '\000' data) with - | "T" :: _ -> true - | "F" :: _ -> false - | x :: _ -> raise (Invalid_argument x) - | _ -> raise Invalid_Cmd_Args - in - let commit = commit && not (Transaction.is_read_only t) in - let success = - let commit = if commit then Some (fun con trans -> transaction_replay con trans domains cons) else None in - History.end_transaction t con (Transaction.get_id t) commit in - if not success then - raise Transaction_again; - if commit then begin - process_watch con t cons; - match t.Transaction.ty with - | Transaction.No -> - () (* no need to record anything *) - | Transaction.Full(id, oldstore, cstore) -> - record_commit ~con ~tid:id ~before:oldstore ~after:cstore - end + let commit = + match (split None '\000' data) with + | "T" :: _ -> true + | "F" :: _ -> false + | x :: _ -> raise (Invalid_argument x) + | _ -> raise Invalid_Cmd_Args + in + let commit = commit && not (Transaction.is_read_only t) in + let success = + let commit = if commit then Some (fun con trans -> transaction_replay con trans domains cons) else None in + History.end_transaction t con (Transaction.get_id t) commit in + if not success then + raise Transaction_again; + if commit then begin + process_watch con t cons; + match t.Transaction.ty with + | Transaction.No -> + () (* no need to record anything *) + | Transaction.Full(id, oldstore, cstore) -> + record_commit ~con ~tid:id ~before:oldstore ~after:cstore + end let do_introduce con t domains cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let (domid, mfn, port) = - match (split None '\000' data) with - | domid :: mfn :: port :: _ -> - int_of_string domid, Nativeint.of_string mfn, int_of_string port - | _ -> raise Invalid_Cmd_Args; - in - let dom = - if Domains.exist domains domid then - let edom = Domains.find domains domid in - if (Domain.get_mfn edom) = mfn && (Connections.find_domain cons domid) != con then begin - (* Use XS_INTRODUCE for recreating the xenbus event-channel. *) - edom.remote_port <- port; - Domain.bind_interdomain edom; - end; - edom - else try - let ndom = Domains.create domains domid mfn port in - Connections.add_domain cons ndom; - Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.introduce_domain; - ndom - with _ -> raise Invalid_Cmd_Args - in - if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn then - raise Domain_not_match + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let (domid, mfn, port) = + match (split None '\000' data) with + | domid :: mfn :: port :: _ -> + int_of_string domid, Nativeint.of_string mfn, int_of_string port + | _ -> raise Invalid_Cmd_Args; + in + let dom = + if Domains.exist domains domid then + let edom = Domains.find domains domid in + if (Domain.get_mfn edom) = mfn && (Connections.find_domain cons domid) != con then begin + (* Use XS_INTRODUCE for recreating the xenbus event-channel. *) + edom.remote_port <- port; + Domain.bind_interdomain edom; + end; + edom + else try + let ndom = Domains.create domains domid mfn port in + Connections.add_domain cons ndom; + Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.introduce_domain; + ndom + with _ -> raise Invalid_Cmd_Args + in + if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn then + raise Domain_not_match let do_release con t domains cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid = - match (split None '\000' data) with - | [domid;""] -> int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - let fire_spec_watches = Domains.exist domains domid in - Domains.del domains domid; - Connections.del_domain cons domid; - Store.reset_permissions (Transaction.get_store t) domid; - if fire_spec_watches - then Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.release_domain - else raise Invalid_Cmd_Args + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let domid = + match (split None '\000' data) with + | [domid;""] -> int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + let fire_spec_watches = Domains.exist domains domid in + Domains.del domains domid; + Connections.del_domain cons domid; + Store.reset_permissions (Transaction.get_store t) domid; + if fire_spec_watches + then Connections.fire_spec_watches (Transaction.get_root t) cons Store.Path.release_domain + else raise Invalid_Cmd_Args let do_resume con _t domains _cons data = - if not (Connection.is_dom0 con) - then raise Define.Permission_denied; - let domid = - match (split None '\000' data) with - | domid :: _ -> int_of_string domid - | _ -> raise Invalid_Cmd_Args - in - if Domains.exist domains domid - then Domains.resume domains domid - else raise Invalid_Cmd_Args + if not (Connection.is_dom0 con) + then raise Define.Permission_denied; + let domid = + match (split None '\000' data) with + | domid :: _ -> int_of_string domid + | _ -> raise Invalid_Cmd_Args + in + if Domains.exist domains domid + then Domains.resume domains domid + else raise Invalid_Cmd_Args let function_of_type ty = - match ty with - | Xenbus.Xb.Op.Debug -> reply_data_or_ack do_debug - | Xenbus.Xb.Op.Watch -> reply_none do_watch - | Xenbus.Xb.Op.Unwatch -> reply_ack do_unwatch - | Xenbus.Xb.Op.Transaction_start -> reply_data do_transaction_start - | Xenbus.Xb.Op.Transaction_end -> reply_ack do_transaction_end - | Xenbus.Xb.Op.Introduce -> reply_ack do_introduce - | Xenbus.Xb.Op.Release -> reply_ack do_release - | Xenbus.Xb.Op.Isintroduced -> reply_data do_isintroduced - | Xenbus.Xb.Op.Resume -> reply_ack do_resume - | Xenbus.Xb.Op.Set_target -> reply_ack do_set_target - | Xenbus.Xb.Op.Reset_watches -> reply_ack do_reset_watches - | Xenbus.Xb.Op.Invalid -> reply_ack do_error - | _ -> function_of_type_simple_op ty + match ty with + | Xenbus.Xb.Op.Debug -> reply_data_or_ack do_debug + | Xenbus.Xb.Op.Watch -> reply_none do_watch + | Xenbus.Xb.Op.Unwatch -> reply_ack do_unwatch + | Xenbus.Xb.Op.Transaction_start -> reply_data do_transaction_start + | Xenbus.Xb.Op.Transaction_end -> reply_ack do_transaction_end + | Xenbus.Xb.Op.Introduce -> reply_ack do_introduce + | Xenbus.Xb.Op.Release -> reply_ack do_release + | Xenbus.Xb.Op.Isintroduced -> reply_data do_isintroduced + | Xenbus.Xb.Op.Resume -> reply_ack do_resume + | Xenbus.Xb.Op.Set_target -> reply_ack do_set_target + | Xenbus.Xb.Op.Reset_watches -> reply_ack do_reset_watches + | Xenbus.Xb.Op.Invalid -> reply_ack do_error + | _ -> function_of_type_simple_op ty (** * Determines which individual (non-transactional) operations we want to retain. * We only want to retain operations that have side-effects in the store since * these can be the cause of transactions failing. - *) +*) let retain_op_in_history ty = - match ty with - | Xenbus.Xb.Op.Write - | Xenbus.Xb.Op.Mkdir - | Xenbus.Xb.Op.Rm - | Xenbus.Xb.Op.Setperms -> true - | Xenbus.Xb.Op.Debug - | Xenbus.Xb.Op.Directory - | Xenbus.Xb.Op.Read - | Xenbus.Xb.Op.Getperms - | Xenbus.Xb.Op.Watch - | Xenbus.Xb.Op.Unwatch - | Xenbus.Xb.Op.Transaction_start - | Xenbus.Xb.Op.Transaction_end - | Xenbus.Xb.Op.Introduce - | Xenbus.Xb.Op.Release - | Xenbus.Xb.Op.Getdomainpath - | Xenbus.Xb.Op.Watchevent - | Xenbus.Xb.Op.Error - | Xenbus.Xb.Op.Isintroduced - | Xenbus.Xb.Op.Resume - | Xenbus.Xb.Op.Set_target - | Xenbus.Xb.Op.Reset_watches - | Xenbus.Xb.Op.Invalid -> false + match ty with + | Xenbus.Xb.Op.Write + | Xenbus.Xb.Op.Mkdir + | Xenbus.Xb.Op.Rm + | Xenbus.Xb.Op.Setperms -> true + | Xenbus.Xb.Op.Debug + | Xenbus.Xb.Op.Directory + | Xenbus.Xb.Op.Read + | Xenbus.Xb.Op.Getperms + | Xenbus.Xb.Op.Watch + | Xenbus.Xb.Op.Unwatch + | Xenbus.Xb.Op.Transaction_start + | Xenbus.Xb.Op.Transaction_end + | Xenbus.Xb.Op.Introduce + | Xenbus.Xb.Op.Release + | Xenbus.Xb.Op.Getdomainpath + | Xenbus.Xb.Op.Watchevent + | Xenbus.Xb.Op.Error + | Xenbus.Xb.Op.Isintroduced + | Xenbus.Xb.Op.Resume + | Xenbus.Xb.Op.Set_target + | Xenbus.Xb.Op.Reset_watches + | Xenbus.Xb.Op.Invalid -> false let maybe_ignore_transaction = function - | Xenbus.Xb.Op.Watch | Xenbus.Xb.Op.Unwatch -> fun tid -> - if tid <> Transaction.none then - debug "Ignoring transaction ID %d for watch/unwatch" tid; - Transaction.none - | _ -> fun x -> x + | Xenbus.Xb.Op.Watch | Xenbus.Xb.Op.Unwatch -> fun tid -> + if tid <> Transaction.none then + debug "Ignoring transaction ID %d for watch/unwatch" tid; + Transaction.none + | _ -> fun x -> x let () = Printexc.record_backtrace true (** * Nothrow guarantee. - *) +*) let process_packet ~store ~cons ~doms ~con ~req = - let ty = req.Packet.ty in - let tid = maybe_ignore_transaction ty req.Packet.tid in - let rid = req.Packet.rid in - try - let fct = function_of_type ty in - let t = - if tid = Transaction.none then - Transaction.make tid store - else - Connection.get_transaction con tid - in + let ty = req.Packet.ty in + let tid = maybe_ignore_transaction ty req.Packet.tid in + let rid = req.Packet.rid in + try + let fct = function_of_type ty in + let t = + if tid = Transaction.none then + Transaction.make tid store + else + Connection.get_transaction con tid + in - let execute () = input_handle_error ~cons ~doms ~fct ~con ~t ~req in + let execute () = input_handle_error ~cons ~doms ~fct ~con ~t ~req in - let response = - (* Note that transactions are recorded in history separately. *) - if tid = Transaction.none && retain_op_in_history ty then begin - let before = Store.copy store in - let response = execute () in - let after = Store.copy store in - record_commit ~con ~tid ~before ~after; - response - end else execute () - in + let response = + (* Note that transactions are recorded in history separately. *) + if tid = Transaction.none && retain_op_in_history ty then begin + let before = Store.copy store in + let response = execute () in + let after = Store.copy store in + record_commit ~con ~tid ~before ~after; + response + end else execute () + in - let response = try - Transaction.check_quota_exn ~perm:(Connection.get_perm con) t; - if tid <> Transaction.none then - (* Remember the request and response for this operation in case we need to replay the transaction *) - Transaction.add_operation t req response; - response - with Quota.Limit_reached -> - Packet.Error "EQUOTA" - in + let response = try + Transaction.check_quota_exn ~perm:(Connection.get_perm con) t; + if tid <> Transaction.none then + (* Remember the request and response for this operation in case we need to replay the transaction *) + Transaction.add_operation t req response; + response + with Quota.Limit_reached -> + Packet.Error "EQUOTA" + in - (* Put the response on the wire *) - send_response ty con t rid response - with exn -> - let bt = Printexc.get_backtrace () in - error "process packet: %s. %s" (Printexc.to_string exn) bt; - Connection.send_error con tid rid "EIO" + (* Put the response on the wire *) + send_response ty con t rid response + with exn -> + let bt = Printexc.get_backtrace () in + error "process packet: %s. %s" (Printexc.to_string exn) bt; + Connection.send_error con tid rid "EIO" let do_input store cons doms con = - let newpacket = - try - if Connection.can_input con then Connection.do_input con - else None - with Xenbus.Xb.Reconnect -> - info "%s requests a reconnect" (Connection.get_domstr con); - History.reconnect con; - info "%s reconnection complete" (Connection.get_domstr con); - None - | Invalid_argument exp | Failure exp -> - error "caught exception %s" exp; - error "got a bad client %s" (sprintf "%-8s" (Connection.get_domstr con)); - Connection.mark_as_bad con; - None - in + let newpacket = + try + if Connection.can_input con then Connection.do_input con + else None + with Xenbus.Xb.Reconnect -> + info "%s requests a reconnect" (Connection.get_domstr con); + History.reconnect con; + info "%s reconnection complete" (Connection.get_domstr con); + None + | Invalid_argument exp | Failure exp -> + error "caught exception %s" exp; + error "got a bad client %s" (sprintf "%-8s" (Connection.get_domstr con)); + Connection.mark_as_bad con; + None + in - match newpacket with - | None -> () - | Some packet -> - let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in - let req = {Packet.tid=tid; Packet.rid=rid; Packet.ty=ty; Packet.data=data} in + match newpacket with + | None -> () + | Some packet -> + let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in + let req = {Packet.tid=tid; Packet.rid=rid; Packet.ty=ty; Packet.data=data} in - (* As we don't log IO, do not call an unnecessary sanitize_data - info "[%s] -> [%d] %s \"%s\"" - (Connection.get_domstr con) tid - (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *) - process_packet ~store ~cons ~doms ~con ~req; - write_access_log ~ty ~tid ~con:(Connection.get_domstr con) ~data; - Connection.incr_ops con + (* As we don't log IO, do not call an unnecessary sanitize_data + info "[%s] -> [%d] %s \"%s\"" + (Connection.get_domstr con) tid + (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *) + process_packet ~store ~cons ~doms ~con ~req; + write_access_log ~ty ~tid ~con:(Connection.get_domstr con) ~data; + Connection.incr_ops con let do_output _store _cons _doms con = - Connection.source_flush_watchevents con; - if Connection.has_output con then ( - if Connection.has_new_output con then ( - let packet = Connection.peek_output con in - let tid, _rid, ty, data = Xenbus.Xb.Packet.unpack packet in - (* As we don't log IO, do not call an unnecessary sanitize_data - info "[%s] <- %s \"%s\"" - (Connection.get_domstr con) - (Xenbus.Xb.Op.to_string ty) (sanitize_data data);*) - write_answer_log ~ty ~tid ~con:(Connection.get_domstr con) ~data; - ); - try - ignore (Connection.do_output con) - with Xenbus.Xb.Reconnect -> - info "%s requests a reconnect" (Connection.get_domstr con); - History.reconnect con; - info "%s reconnection complete" (Connection.get_domstr con) - ) + Connection.source_flush_watchevents con; + if Connection.has_output con then ( + if Connection.has_new_output con then ( + let packet = Connection.peek_output con in + let tid, _rid, ty, data = Xenbus.Xb.Packet.unpack packet in + (* As we don't log IO, do not call an unnecessary sanitize_data + info "[%s] <- %s \"%s\"" + (Connection.get_domstr con) + (Xenbus.Xb.Op.to_string ty) (sanitize_data data);*) + write_answer_log ~ty ~tid ~con:(Connection.get_domstr con) ~data; + ); + try + ignore (Connection.do_output con) + with Xenbus.Xb.Reconnect -> + info "%s requests a reconnect" (Connection.get_domstr con); + History.reconnect con; + info "%s reconnection complete" (Connection.get_domstr con) + ) diff --git a/tools/ocaml/xenstored/quota.ml b/tools/ocaml/xenstored/quota.ml index 6e3d6401ae..300d78a50b 100644 --- a/tools/ocaml/xenstored/quota.ml +++ b/tools/ocaml/xenstored/quota.ml @@ -24,65 +24,65 @@ let maxent = ref (1000) let maxsize = ref (2048) type t = { - maxent: int; (* max entities per domU *) - maxsize: int; (* max size of data store in one node *) - cur: (Xenctrl.domid, int) Hashtbl.t; (* current domains quota *) + maxent: int; (* max entities per domU *) + maxsize: int; (* max size of data store in one node *) + cur: (Xenctrl.domid, int) Hashtbl.t; (* current domains quota *) } let to_string quota domid = - if Hashtbl.mem quota.cur domid - then Printf.sprintf "dom%i quota: %i/%i" domid (Hashtbl.find quota.cur domid) quota.maxent - else Printf.sprintf "dom%i quota: not set" domid + if Hashtbl.mem quota.cur domid + then Printf.sprintf "dom%i quota: %i/%i" domid (Hashtbl.find quota.cur domid) quota.maxent + else Printf.sprintf "dom%i quota: not set" domid let create () = - { maxent = !maxent; maxsize = !maxsize; cur = Hashtbl.create 100; } + { maxent = !maxent; maxsize = !maxsize; cur = Hashtbl.create 100; } let copy quota = { quota with cur = (Hashtbl.copy quota.cur) } let del quota id = Hashtbl.remove quota.cur id let _check quota id size = - if size > quota.maxsize then ( - warn "domain %u err create entry: data too big %d" id size; - raise Data_too_big - ); - if id > 0 && Hashtbl.mem quota.cur id then - let entry = Hashtbl.find quota.cur id in - if entry >= quota.maxent then ( - warn "domain %u cannot create entry: quota reached" id; - raise Limit_reached - ) + if size > quota.maxsize then ( + warn "domain %u err create entry: data too big %d" id size; + raise Data_too_big + ); + if id > 0 && Hashtbl.mem quota.cur id then + let entry = Hashtbl.find quota.cur id in + if entry >= quota.maxent then ( + warn "domain %u cannot create entry: quota reached" id; + raise Limit_reached + ) let check quota id size = - if !activate then - _check quota id size + if !activate then + _check quota id size let get_entry quota id = Hashtbl.find quota.cur id let set_entry quota id nb = - if nb = 0 - then Hashtbl.remove quota.cur id - else begin - if Hashtbl.mem quota.cur id then - Hashtbl.replace quota.cur id nb - else - Hashtbl.add quota.cur id nb - end + if nb = 0 + then Hashtbl.remove quota.cur id + else begin + if Hashtbl.mem quota.cur id then + Hashtbl.replace quota.cur id nb + else + Hashtbl.add quota.cur id nb + end let del_entry quota id = - try - let nb = get_entry quota id in - set_entry quota id (nb - 1) - with Not_found -> () + try + let nb = get_entry quota id in + set_entry quota id (nb - 1) + with Not_found -> () let add_entry quota id = - let nb = try get_entry quota id with Not_found -> 0 in - set_entry quota id (nb + 1) + let nb = try get_entry quota id with Not_found -> 0 in + set_entry quota id (nb + 1) let add quota diff = - Hashtbl.iter (fun id nb -> set_entry quota id (get_entry quota id + nb)) diff.cur + Hashtbl.iter (fun id nb -> set_entry quota id (get_entry quota id + nb)) diff.cur let merge orig_quota mod_quota dest_quota = - Hashtbl.iter (fun id nb -> let diff = nb - (try get_entry orig_quota id with Not_found -> 0) in - if diff <> 0 then - set_entry dest_quota id ((try get_entry dest_quota id with Not_found -> 0) + diff)) mod_quota.cur + Hashtbl.iter (fun id nb -> let diff = nb - (try get_entry orig_quota id with Not_found -> 0) in + if diff <> 0 then + set_entry dest_quota id ((try get_entry dest_quota id with Not_found -> 0) + diff)) mod_quota.cur diff --git a/tools/ocaml/xenstored/select_stubs.c b/tools/ocaml/xenstored/select_stubs.c index af72b84fa2..f2ef1ec3de 100644 --- a/tools/ocaml/xenstored/select_stubs.c +++ b/tools/ocaml/xenstored/select_stubs.c @@ -25,56 +25,56 @@ CAMLprim value stub_select_on_poll(value fd_events, value timeo) { - CAMLparam2(fd_events, timeo); - CAMLlocal1(events); - int i, rc, c_len = Wosize_val(fd_events), c_timeo = Int_val(timeo); - struct pollfd c_fds[c_len]; + CAMLparam2(fd_events, timeo); + CAMLlocal1(events); + int i, rc, c_len = Wosize_val(fd_events), c_timeo = Int_val(timeo); + struct pollfd c_fds[c_len]; - for (i = 0; i < c_len; i++) { + for (i = 0; i < c_len; i++) { - events = Field(Field(fd_events, i), 1); + events = Field(Field(fd_events, i), 1); - c_fds[i].fd = Int_val(Field(Field(fd_events, i), 0)); - c_fds[i].events = c_fds[i].revents = 0; - c_fds[i].events |= Bool_val(Field(events, 0)) ? POLLIN : 0; - c_fds[i].events |= Bool_val(Field(events, 1)) ? POLLOUT: 0; - c_fds[i].events |= Bool_val(Field(events, 2)) ? POLLPRI: 0; + c_fds[i].fd = Int_val(Field(Field(fd_events, i), 0)); + c_fds[i].events = c_fds[i].revents = 0; + c_fds[i].events |= Bool_val(Field(events, 0)) ? POLLIN : 0; + c_fds[i].events |= Bool_val(Field(events, 1)) ? POLLOUT: 0; + c_fds[i].events |= Bool_val(Field(events, 2)) ? POLLPRI: 0; - }; + }; - caml_enter_blocking_section(); - rc = poll(c_fds, c_len, c_timeo); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + rc = poll(c_fds, c_len, c_timeo); + caml_leave_blocking_section(); - if (rc < 0) uerror("poll", Nothing); + if (rc < 0) uerror("poll", Nothing); - if (rc > 0) { + if (rc > 0) { - for (i = 0; i < c_len; i++) { + for (i = 0; i < c_len; i++) { - events = Field(Field(fd_events, i), 1); + events = Field(Field(fd_events, i), 1); - if (c_fds[i].revents & POLLNVAL) unix_error(EBADF, "select", Nothing); - Field(events, 0) = Val_bool(c_fds[i].events & POLLIN && c_fds[i].revents & (POLLIN |POLLHUP|POLLERR)); - Field(events, 1) = Val_bool(c_fds[i].events & POLLOUT && c_fds[i].revents & (POLLOUT|POLLHUP|POLLERR)); - Field(events, 2) = Val_bool(c_fds[i].revents & POLLPRI); + if (c_fds[i].revents & POLLNVAL) unix_error(EBADF, "select", Nothing); + Field(events, 0) = Val_bool(c_fds[i].events & POLLIN && c_fds[i].revents & (POLLIN |POLLHUP|POLLERR)); + Field(events, 1) = Val_bool(c_fds[i].events & POLLOUT && c_fds[i].revents & (POLLOUT|POLLHUP|POLLERR)); + Field(events, 2) = Val_bool(c_fds[i].revents & POLLPRI); - } + } - } + } - CAMLreturn(Val_int(rc)); + CAMLreturn(Val_int(rc)); } CAMLprim value stub_set_fd_limit(value limit) { - CAMLparam1(limit); - struct rlimit rl; + CAMLparam1(limit); + struct rlimit rl; - rl.rlim_cur = rl.rlim_max = Int_val(limit); - if (setrlimit(RLIMIT_NOFILE, &rl) != 0) uerror("setrlimit", Nothing); - CAMLreturn(Val_unit); + rl.rlim_cur = rl.rlim_max = Int_val(limit); + if (setrlimit(RLIMIT_NOFILE, &rl) != 0) uerror("setrlimit", Nothing); + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/xenstored/stdext.ml b/tools/ocaml/xenstored/stdext.ml index 116920917a..0ee4a5ab9c 100644 --- a/tools/ocaml/xenstored/stdext.ml +++ b/tools/ocaml/xenstored/stdext.ml @@ -19,137 +19,137 @@ type ('a, 'b) either = Right of 'a | Left of 'b (** apply the clean_f function after fct function has been called. * Even if fct raises an exception, clean_f is applied - *) +*) let exnhook = ref None let finally fct clean_f = - let result = try - fct (); - with - exn -> - (match !exnhook with None -> () | Some f -> f exn); - clean_f (); raise exn in - clean_f (); - result + let result = try + fct (); + with + exn -> + (match !exnhook with None -> () | Some f -> f exn); + clean_f (); raise exn in + clean_f (); + result (** if v is not none, apply f on it and return some value else return none. *) let may f v = - match v with Some x -> Some (f x) | None -> None + match v with Some x -> Some (f x) | None -> None (** default value to d if v is none. *) let default d v = - match v with Some x -> x | None -> d + match v with Some x -> x | None -> d (** apply f on v if not none *) let maybe f v = - match v with None -> () | Some x -> f x + match v with None -> () | Some x -> f x module Filename = struct - include Filename - let quote_command cmd args = - cmd :: args |> List.map quote |> String.concat " " + include Filename + let quote_command cmd args = + cmd :: args |> List.map quote |> String.concat " " end module Map = struct - module Make(Ord: Map.OrderedType) = struct + module Make(Ord: Map.OrderedType) = struct - include Map.Make(Ord) + include Map.Make(Ord) - let find_opt k t = try Some (find k t) with Not_found -> None + let find_opt k t = try Some (find k t) with Not_found -> None - let update k f t = - let r = find_opt k t in - let r' = f r in - match r, r' with - | None, None -> t - | Some _, None -> remove k t - | Some r, Some r' when r == r' -> t - | _, Some r' -> add k r' t + let update k f t = + let r = find_opt k t in + let r' = f r in + match r, r' with + | None, None -> t + | Some _, None -> remove k t + | Some r, Some r' when r == r' -> t + | _, Some r' -> add k r' t - end + end end module String = struct include String -let of_char c = String.make 1 c + let of_char c = String.make 1 c -let rec split ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) + let rec split ?limit:(limit=(-1)) c s = + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) -let fold_left f accu string = - let accu = ref accu in - for i = 0 to length string - 1 do - accu := f !accu string.[i] - done; - !accu + let fold_left f accu string = + let accu = ref accu in + for i = 0 to length string - 1 do + accu := f !accu string.[i] + done; + !accu -(** True if string 'x' starts with prefix 'prefix' *) -let startswith prefix x = - let x_l = String.length x and prefix_l = String.length prefix in - prefix_l <= x_l && String.sub x 0 prefix_l = prefix + (** True if string 'x' starts with prefix 'prefix' *) + let startswith prefix x = + let x_l = String.length x and prefix_l = String.length prefix in + prefix_l <= x_l && String.sub x 0 prefix_l = prefix end module Unixext = struct -(** remove a file, but doesn't raise an exception if the file is already removed *) -let unlink_safe file = - try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () + (** remove a file, but doesn't raise an exception if the file is already removed *) + let unlink_safe file = + try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () -(** create a directory but doesn't raise an exception if the directory already exist *) -let mkdir_safe dir perm = - try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + (** create a directory but doesn't raise an exception if the directory already exist *) + let mkdir_safe dir perm = + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () -(** create a directory, and create parent if doesn't exist *) -let mkdir_rec dir perm = - let rec p_mkdir dir = - let p_name = Filename.dirname dir in - if p_name <> "/" && p_name <> "." - then p_mkdir p_name; - mkdir_safe dir perm in - p_mkdir dir + (** create a directory, and create parent if doesn't exist *) + let mkdir_rec dir perm = + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name <> "/" && p_name <> "." + then p_mkdir p_name; + mkdir_safe dir perm in + p_mkdir dir -(** daemonize a process *) -(* !! Must call this before spawning any threads !! *) -let daemonize () = - match Unix.fork () with - | 0 -> - if Unix.setsid () == -1 then - failwith "Unix.setsid failed"; + (** daemonize a process *) + (* !! Must call this before spawning any threads !! *) + let daemonize () = + match Unix.fork () with + | 0 -> + if Unix.setsid () == -1 then + failwith "Unix.setsid failed"; - begin match Unix.fork () with - | 0 -> - let nullfd = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0 in - begin try - Unix.dup2 nullfd Unix.stdin; - Unix.dup2 nullfd Unix.stdout; - Unix.dup2 nullfd Unix.stderr; - with exn -> Unix.close nullfd; raise exn - end; - Unix.close nullfd - | _ -> exit 0 - end - | _ -> exit 0 + begin match Unix.fork () with + | 0 -> + let nullfd = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0 in + begin try + Unix.dup2 nullfd Unix.stdin; + Unix.dup2 nullfd Unix.stdout; + Unix.dup2 nullfd Unix.stderr; + with exn -> Unix.close nullfd; raise exn + end; + Unix.close nullfd + | _ -> exit 0 + end + | _ -> exit 0 -(** write a pidfile file *) -let pidfile_write filename = - let fd = Unix.openfile filename - [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] - 0o640 in - finally - (fun () -> - let pid = Unix.getpid () in - let buf = string_of_int pid ^ "\n" in - let len = String.length buf in - if Unix.write_substring fd buf 0 len <> len - then failwith "pidfile_write failed"; - ) - (fun () -> Unix.close fd) + (** write a pidfile file *) + let pidfile_write filename = + let fd = Unix.openfile filename + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] + 0o640 in + finally + (fun () -> + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" in + let len = String.length buf in + if Unix.write_substring fd buf 0 len <> len + then failwith "pidfile_write failed"; + ) + (fun () -> Unix.close fd) end diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml index 70f0c83de4..14ec404988 100644 --- a/tools/ocaml/xenstored/store.ml +++ b/tools/ocaml/xenstored/store.ml @@ -20,231 +20,231 @@ module SymbolMap = Map.Make(Symbol) module Node = struct -type t = { - name: Symbol.t; - perms: Perms.Node.t; - value: string; - children: t SymbolMap.t; -} + type t = { + name: Symbol.t; + perms: Perms.Node.t; + value: string; + children: t SymbolMap.t; + } -let create _name _perms _value = - { name = Symbol.of_string _name; perms = _perms; value = _value; children = SymbolMap.empty; } + let create _name _perms _value = + { name = Symbol.of_string _name; perms = _perms; value = _value; children = SymbolMap.empty; } -let get_owner node = Perms.Node.get_owner node.perms -let get_children node = node.children -let get_value node = node.value -let get_perms node = node.perms -let get_name node = Symbol.to_string node.name + let get_owner node = Perms.Node.get_owner node.perms + let get_children node = node.children + let get_value node = node.value + let get_perms node = node.perms + let get_name node = Symbol.to_string node.name -let set_value node nvalue = - if node.value = nvalue - then node - else { node with value = nvalue } + let set_value node nvalue = + if node.value = nvalue + then node + else { node with value = nvalue } -let set_perms node nperms = { node with perms = nperms } + let set_perms node nperms = { node with perms = nperms } -let add_child node child = - let children = SymbolMap.add child.name child node.children in - { node with children } + let add_child node child = + let children = SymbolMap.add child.name child node.children in + { node with children } -let exists node childname = - let childname = Symbol.of_string childname in - SymbolMap.mem childname node.children + let exists node childname = + let childname = Symbol.of_string childname in + SymbolMap.mem childname node.children -let find node childname = - let childname = Symbol.of_string childname in - SymbolMap.find childname node.children + let find node childname = + let childname = Symbol.of_string childname in + SymbolMap.find childname node.children -let replace_child node child nchild = - { node with - children = SymbolMap.update child.name - (function None -> None | Some _ -> Some nchild) - node.children - } + let replace_child node child nchild = + { node with + children = SymbolMap.update child.name + (function None -> None | Some _ -> Some nchild) + node.children + } -let del_childname node childname = - let sym = Symbol.of_string childname in - { node with children = - SymbolMap.update sym - (function None -> raise Not_found | Some _ -> None) - node.children - } + let del_childname node childname = + let sym = Symbol.of_string childname in + { node with children = + SymbolMap.update sym + (function None -> raise Not_found | Some _ -> None) + node.children + } -let del_all_children node = - { node with children = SymbolMap.empty } + let del_all_children node = + { node with children = SymbolMap.empty } -(* check if the current node can be accessed by the current connection with rperm permissions *) -let check_perm node connection request = - Perms.check connection request node.perms + (* check if the current node can be accessed by the current connection with rperm permissions *) + let check_perm node connection request = + Perms.check connection request node.perms -(* check if the current node is owned by the current connection *) -let check_owner node connection = - if not (Perms.check_owner connection node.perms) - then begin - Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node); - raise Define.Permission_denied; - end + (* check if the current node is owned by the current connection *) + let check_owner node connection = + if not (Perms.check_owner connection node.perms) + then begin + Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node); + raise Define.Permission_denied; + end -let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct) node.children + let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct) node.children -(** [recurse_filter_map f tree] applies [f] on each node in the tree recursively, - possibly removing some nodes. - Note that the nodes removed this way won't generate watch events. -*) -let recurse_filter_map f = - let invalid = -1 in - let is_valid _ node = node.perms.owner <> invalid in - let rec walk node = - (* Map.filter_map is Ocaml 4.11+ only *) - let node = - { node with children = - SymbolMap.map walk node.children |> SymbolMap.filter is_valid } in - match f node with - | Some keep -> keep - | None -> { node with perms = {node.perms with owner = invalid } } - in - walk + (** [recurse_filter_map f tree] applies [f] on each node in the tree recursively, + possibly removing some nodes. + Note that the nodes removed this way won't generate watch events. + *) + let recurse_filter_map f = + let invalid = -1 in + let is_valid _ node = node.perms.owner <> invalid in + let rec walk node = + (* Map.filter_map is Ocaml 4.11+ only *) + let node = + { node with children = + SymbolMap.map walk node.children |> SymbolMap.filter is_valid } in + match f node with + | Some keep -> keep + | None -> { node with perms = {node.perms with owner = invalid } } + in + walk -let unpack node = (Symbol.to_string node.name, node.perms, node.value) + let unpack node = (Symbol.to_string node.name, node.perms, node.value) end module Path = struct -(* represent a path in a store. - * [] -> "/" - * [ "local"; "domain"; "1" ] -> "/local/domain/1" - *) -type t = string list + (* represent a path in a store. + * [] -> "/" + * [ "local"; "domain"; "1" ] -> "/local/domain/1" + *) + type t = string list -let char_is_valid c = - (c >= 'a' && c <= 'z') || - (c >= 'A' && c <= 'Z') || - (c >= '0' && c <= '9') || - c = '_' || c = '-' || c = '@' + let char_is_valid c = + (c >= 'a' && c <= 'z') || + (c >= 'A' && c <= 'Z') || + (c >= '0' && c <= '9') || + c = '_' || c = '-' || c = '@' -let name_is_valid name = - name <> "" && String.fold_left (fun accu c -> accu && char_is_valid c) true name + let name_is_valid name = + name <> "" && String.fold_left (fun accu c -> accu && char_is_valid c) true name -let is_valid path = - List.for_all name_is_valid path + let is_valid path = + List.for_all name_is_valid path -let of_string s = - if s.[0] = '@' - then [s] - else if s = "/" - then [] - else match String.split '/' s with - | "" :: path when is_valid path -> path - | _ -> raise Define.Invalid_path + let of_string s = + if s.[0] = '@' + then [s] + else if s = "/" + then [] + else match String.split '/' s with + | "" :: path when is_valid path -> path + | _ -> raise Define.Invalid_path -let of_path_and_name path name = - match path, name with - | [], "" -> [] - | _ -> path @ [name] + let of_path_and_name path name = + match path, name with + | [], "" -> [] + | _ -> path @ [name] -let create path connection_path = - of_string (Utils.path_validate path connection_path) + let create path connection_path = + of_string (Utils.path_validate path connection_path) -let to_string t = - "/" ^ (String.concat "/" t) + let to_string t = + "/" ^ (String.concat "/" t) -let to_string_list x = x + let to_string_list x = x -let get_parent t = - if t = [] then [] else List.rev (List.tl (List.rev t)) + let get_parent t = + if t = [] then [] else List.rev (List.tl (List.rev t)) -let get_hierarchy path = - Utils.get_hierarchy path + let get_hierarchy path = + Utils.get_hierarchy path -let get_common_prefix p1 p2 = - let rec compare l1 l2 = - match l1, l2 with - | h1 :: tl1, h2 :: tl2 -> - if h1 = h2 then h1 :: (compare tl1 tl2) else [] - | _, [] | [], _ -> - (* if l1 or l2 is empty, we found the equal part already *) - [] - in - compare p1 p2 + let get_common_prefix p1 p2 = + let rec compare l1 l2 = + match l1, l2 with + | h1 :: tl1, h2 :: tl2 -> + if h1 = h2 then h1 :: (compare tl1 tl2) else [] + | _, [] | [], _ -> + (* if l1 or l2 is empty, we found the equal part already *) + [] + in + compare p1 p2 -let rec lookup_modify node path fct = - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> fct node h - | h :: l -> - let (n, c) = - if not (Node.exists node h) then - raise (Define.Lookup_Doesnt_exist h) - else - (node, Node.find node h) in - let nc = lookup_modify c l fct in - Node.replace_child n c nc + let rec lookup_modify node path fct = + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> fct node h + | h :: l -> + let (n, c) = + if not (Node.exists node h) then + raise (Define.Lookup_Doesnt_exist h) + else + (node, Node.find node h) in + let nc = lookup_modify c l fct in + Node.replace_child n c nc -let apply_modify rnode path fct = - lookup_modify rnode path fct + let apply_modify rnode path fct = + lookup_modify rnode path fct -let rec lookup_get node path = - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> - (try - Node.find node h - with Not_found -> - raise Define.Doesnt_exist) - | h :: l -> let cnode = Node.find node h in lookup_get cnode l + let rec lookup_get node path = + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> + (try + Node.find node h + with Not_found -> + raise Define.Doesnt_exist) + | h :: l -> let cnode = Node.find node h in lookup_get cnode l -let get_node rnode path = - if path = [] then - Some rnode - else ( - try Some (lookup_get rnode path) with Define.Doesnt_exist -> None - ) + let get_node rnode path = + if path = [] then + Some rnode + else ( + try Some (lookup_get rnode path) with Define.Doesnt_exist -> None + ) -(* get the deepest existing node for this path, return the node and a flag on the existence of the full path *) -let rec get_deepest_existing_node node = function - | [] -> node, true - | h :: t -> - try get_deepest_existing_node (Node.find node h) t - with Not_found -> node, false + (* get the deepest existing node for this path, return the node and a flag on the existence of the full path *) + let rec get_deepest_existing_node node = function + | [] -> node, true + | h :: t -> + try get_deepest_existing_node (Node.find node h) t + with Not_found -> node, false -let set_node rnode path nnode = - if path = [] then - nnode - else - let set_node node name = - try - let ent = Node.find node name in - Node.replace_child node ent nnode - with Not_found -> - Node.add_child node nnode - in - apply_modify rnode path set_node + let set_node rnode path nnode = + if path = [] then + nnode + else + let set_node node name = + try + let ent = Node.find node name in + Node.replace_child node ent nnode + with Not_found -> + Node.add_child node nnode + in + apply_modify rnode path set_node -(* read | ls | getperms use this *) -let rec lookup node path fct = - match path with - | [] -> raise (Define.Invalid_path) - | h :: [] -> fct node h - | h :: l -> let cnode = Node.find node h in lookup cnode l fct + (* read | ls | getperms use this *) + let rec lookup node path fct = + match path with + | [] -> raise (Define.Invalid_path) + | h :: [] -> fct node h + | h :: l -> let cnode = Node.find node h in lookup cnode l fct -let apply rnode path fct = - lookup rnode path fct + let apply rnode path fct = + lookup rnode path fct -let introduce_domain = "@introduceDomain" -let release_domain = "@releaseDomain" -let specials = List.map of_string [ introduce_domain; release_domain ] + let introduce_domain = "@introduceDomain" + let release_domain = "@releaseDomain" + let specials = List.map of_string [ introduce_domain; release_domain ] end (* The Store.t type *) type t = -{ - mutable stat_transaction_coalesce: int; - mutable stat_transaction_abort: int; - mutable root: Node.t; - mutable quota: Quota.t; -} + { + mutable stat_transaction_coalesce: int; + mutable stat_transaction_abort: int; + mutable root: Node.t; + mutable quota: Quota.t; + } let get_root store = store.root let set_root store root = store.root <- root @@ -254,149 +254,149 @@ let set_quota store quota = store.quota <- quota (* modifying functions *) let path_mkdir store perm path = - let do_mkdir node name = - try - let ent = Node.find node name in - Node.check_perm ent perm Perms.WRITE; - raise Define.Already_exist - with Not_found -> - Node.check_perm node perm Perms.WRITE; - Node.add_child node (Node.create name node.Node.perms "") in - if path = [] then - store.root - else - Path.apply_modify store.root path do_mkdir + let do_mkdir node name = + try + let ent = Node.find node name in + Node.check_perm ent perm Perms.WRITE; + raise Define.Already_exist + with Not_found -> + Node.check_perm node perm Perms.WRITE; + Node.add_child node (Node.create name node.Node.perms "") in + if path = [] then + store.root + else + Path.apply_modify store.root path do_mkdir let path_write store perm path value = - let node_created = ref false in - let do_write node name = - try - let ent = Node.find node name in - Node.check_perm ent perm Perms.WRITE; - let nent = Node.set_value ent value in - Node.replace_child node ent nent - with Not_found -> - node_created := true; - Node.check_perm node perm Perms.WRITE; - Node.add_child node (Node.create name node.Node.perms value) in - if path = [] then ( - Node.check_perm store.root perm Perms.WRITE; - Node.set_value store.root value, false - ) else - let root = Path.apply_modify store.root path do_write in - root, !node_created + let node_created = ref false in + let do_write node name = + try + let ent = Node.find node name in + Node.check_perm ent perm Perms.WRITE; + let nent = Node.set_value ent value in + Node.replace_child node ent nent + with Not_found -> + node_created := true; + Node.check_perm node perm Perms.WRITE; + Node.add_child node (Node.create name node.Node.perms value) in + if path = [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.set_value store.root value, false + ) else + let root = Path.apply_modify store.root path do_write in + root, !node_created let path_rm store perm path = - let do_rm node name = - try - let ent = Node.find node name in - Node.check_perm ent perm Perms.WRITE; - Node.del_childname node name - with Not_found -> - raise Define.Doesnt_exist in - if path = [] then ( - Node.check_perm store.root perm Perms.WRITE; - Node.del_all_children store.root - ) else - Path.apply_modify store.root path do_rm + let do_rm node name = + try + let ent = Node.find node name in + Node.check_perm ent perm Perms.WRITE; + Node.del_childname node name + with Not_found -> + raise Define.Doesnt_exist in + if path = [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.del_all_children store.root + ) else + Path.apply_modify store.root path do_rm let path_setperms store perm path perms = - if path = [] then ( - Node.check_perm store.root perm Perms.WRITE; - Node.set_perms store.root perms - ) else - let do_setperms node name = - let c = Node.find node name in - Node.check_owner c perm; - Node.check_perm c perm Perms.WRITE; - let nc = Node.set_perms c perms in - Node.replace_child node c nc - in - Path.apply_modify store.root path do_setperms + if path = [] then ( + Node.check_perm store.root perm Perms.WRITE; + Node.set_perms store.root perms + ) else + let do_setperms node name = + let c = Node.find node name in + Node.check_owner c perm; + Node.check_perm c perm Perms.WRITE; + let nc = Node.set_perms c perms in + Node.replace_child node c nc + in + Path.apply_modify store.root path do_setperms (* accessing functions *) let get_node store path = - Path.get_node store.root path + Path.get_node store.root path let get_deepest_existing_node store path = - Path.get_deepest_existing_node store.root path + Path.get_deepest_existing_node store.root path let read store perm path = - let do_read node name = - let ent = Node.find node name in - Node.check_perm ent perm Perms.READ; - ent.Node.value - in - if path = [] then ( - let ent = store.root in - Node.check_perm ent perm Perms.READ; - ent.Node.value - ) else - Path.apply store.root path do_read + let do_read node name = + let ent = Node.find node name in + Node.check_perm ent perm Perms.READ; + ent.Node.value + in + if path = [] then ( + let ent = store.root in + Node.check_perm ent perm Perms.READ; + ent.Node.value + ) else + Path.apply store.root path do_read let ls store perm path = - let children = - if path = [] then ( - Node.check_perm store.root perm Perms.READ; - Node.get_children store.root - ) else - let do_ls node name = - let cnode = Node.find node name in - Node.check_perm cnode perm Perms.READ; - cnode.Node.children in - Path.apply store.root path do_ls in - SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children [] + let children = + if path = [] then ( + Node.check_perm store.root perm Perms.READ; + Node.get_children store.root + ) else + let do_ls node name = + let cnode = Node.find node name in + Node.check_perm cnode perm Perms.READ; + cnode.Node.children in + Path.apply store.root path do_ls in + SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children [] let getperms store perm path = - if path = [] then ( - Node.check_perm store.root perm Perms.READ; - Node.get_perms store.root - ) else - let fct n name = - let c = Node.find n name in - Node.check_perm c perm Perms.READ; - c.Node.perms in - Path.apply store.root path fct + if path = [] then ( + Node.check_perm store.root perm Perms.READ; + Node.get_perms store.root + ) else + let fct n name = + let c = Node.find n name in + Node.check_perm c perm Perms.READ; + c.Node.perms in + Path.apply store.root path fct let path_exists store path = - if path = [] then - true - else - try - let check_exist node name = - ignore(Node.find node name); - true in - Path.apply store.root path check_exist - with Not_found -> false + if path = [] then + true + else + try + let check_exist node name = + ignore(Node.find node name); + true in + Path.apply store.root path check_exist + with Not_found -> false (* others utils *) let traversal root_node f = - let rec _traversal path node = - f path node; - let node_path = Path.of_path_and_name path (Symbol.to_string node.Node.name) in - SymbolMap.iter (fun _ -> _traversal node_path) node.Node.children - in - _traversal [] root_node + let rec _traversal path node = + f path node; + let node_path = Path.of_path_and_name path (Symbol.to_string node.Node.name) in + SymbolMap.iter (fun _ -> _traversal node_path) node.Node.children + in + _traversal [] root_node let dump_store_buf root_node = - let buf = Buffer.create 8192 in - let dump_node path node = - let pathstr = String.concat "/" path in - Printf.bprintf buf "%s/%s{%s}" pathstr (Symbol.to_string node.Node.name) - (String.escaped (Perms.Node.to_string (Node.get_perms node))); - if String.length node.Node.value > 0 then - Printf.bprintf buf " = %s\n" (String.escaped node.Node.value) - else - Printf.bprintf buf "\n"; - in - traversal root_node dump_node; - buf + let buf = Buffer.create 8192 in + let dump_node path node = + let pathstr = String.concat "/" path in + Printf.bprintf buf "%s/%s{%s}" pathstr (Symbol.to_string node.Node.name) + (String.escaped (Perms.Node.to_string (Node.get_perms node))); + if String.length node.Node.value > 0 then + Printf.bprintf buf " = %s\n" (String.escaped node.Node.value) + else + Printf.bprintf buf "\n"; + in + traversal root_node dump_node; + buf let dump_store chan root_node = - let buf = dump_store_buf root_node in - output_string chan (Buffer.contents buf); - Buffer.reset buf + let buf = dump_store_buf root_node in + output_string chan (Buffer.contents buf); + Buffer.reset buf let dump_fct store f = traversal store.root f let dump store out_chan = dump_store out_chan store.root @@ -406,109 +406,109 @@ let dump_buffer store = dump_store_buf store.root (* modifying functions with quota udpate *) let set_node store path node orig_quota mod_quota = - let root = Path.set_node store.root path node in - store.root <- root; - Quota.merge orig_quota mod_quota store.quota + let root = Path.set_node store.root path node in + store.root <- root; + Quota.merge orig_quota mod_quota store.quota let write store perm path value = - let node, existing = get_deepest_existing_node store path in - let owner = Node.get_owner node in - if existing || (Perms.Connection.is_dom0 perm) then - (* Only check the string length limit *) - Quota.check store.quota (-1) (String.length value) - else - (* Check the domain entries limit too *) - Quota.check store.quota owner (String.length value); - let root, node_created = path_write store perm path value in - store.root <- root; - if node_created - then Quota.add_entry store.quota owner + let node, existing = get_deepest_existing_node store path in + let owner = Node.get_owner node in + if existing || (Perms.Connection.is_dom0 perm) then + (* Only check the string length limit *) + Quota.check store.quota (-1) (String.length value) + else + (* Check the domain entries limit too *) + Quota.check store.quota owner (String.length value); + let root, node_created = path_write store perm path value in + store.root <- root; + if node_created + then Quota.add_entry store.quota owner let mkdir store perm path = - let node, existing = get_deepest_existing_node store path in - let owner = Node.get_owner node in - (* It's upt to the mkdir logic to decide what to do with existing path *) - if not (existing || (Perms.Connection.is_dom0 perm)) then Quota.check store.quota owner 0; - store.root <- path_mkdir store perm path; - if not existing then - Quota.add_entry store.quota owner + let node, existing = get_deepest_existing_node store path in + let owner = Node.get_owner node in + (* It's upt to the mkdir logic to decide what to do with existing path *) + if not (existing || (Perms.Connection.is_dom0 perm)) then Quota.check store.quota owner 0; + store.root <- path_mkdir store perm path; + if not existing then + Quota.add_entry store.quota owner let rm store perm path = - let rmed_node = Path.get_node store.root path in - match rmed_node with - | None -> raise Define.Doesnt_exist - | Some rmed_node -> - store.root <- path_rm store perm path; - Node.recurse (fun node -> Quota.del_entry store.quota (Node.get_owner node)) rmed_node + let rmed_node = Path.get_node store.root path in + match rmed_node with + | None -> raise Define.Doesnt_exist + | Some rmed_node -> + store.root <- path_rm store perm path; + Node.recurse (fun node -> Quota.del_entry store.quota (Node.get_owner node)) rmed_node let setperms store perm path nperms = - match Path.get_node store.root path with - | None -> raise Define.Doesnt_exist - | Some node -> - let old_owner = Node.get_owner node in - let new_owner = Perms.Node.get_owner nperms in - if not ((old_owner = new_owner) || (Perms.Connection.is_dom0 perm)) then - raise Define.Permission_denied; - store.root <- path_setperms store perm path nperms; - Quota.del_entry store.quota old_owner; - Quota.add_entry store.quota new_owner + match Path.get_node store.root path with + | None -> raise Define.Doesnt_exist + | Some node -> + let old_owner = Node.get_owner node in + let new_owner = Perms.Node.get_owner nperms in + if not ((old_owner = new_owner) || (Perms.Connection.is_dom0 perm)) then + raise Define.Permission_denied; + store.root <- path_setperms store perm path nperms; + Quota.del_entry store.quota old_owner; + Quota.add_entry store.quota new_owner let reset_permissions store domid = - Logging.info "store|node" "Cleaning up xenstore ACLs for domid %d" domid; - store.root <- Node.recurse_filter_map (fun node -> - match Perms.Node.remove_domid ~domid node.perms with - | None -> None - | Some perms -> - if perms <> node.perms then - Logging.debug "store|node" "Changed permissions for node %s" (Node.get_name node); - Some { node with perms } - ) store.root + Logging.info "store|node" "Cleaning up xenstore ACLs for domid %d" domid; + store.root <- Node.recurse_filter_map (fun node -> + match Perms.Node.remove_domid ~domid node.perms with + | None -> None + | Some perms -> + if perms <> node.perms then + Logging.debug "store|node" "Changed permissions for node %s" (Node.get_name node); + Some { node with perms } + ) store.root type ops = { - store: t; - write: Path.t -> string -> unit; - mkdir: Path.t -> unit; - rm: Path.t -> unit; - setperms: Path.t -> Perms.Node.t -> unit; - ls: Path.t -> string list; - read: Path.t -> string; - getperms: Path.t -> Perms.Node.t; - path_exists: Path.t -> bool; + store: t; + write: Path.t -> string -> unit; + mkdir: Path.t -> unit; + rm: Path.t -> unit; + setperms: Path.t -> Perms.Node.t -> unit; + ls: Path.t -> string list; + read: Path.t -> string; + getperms: Path.t -> Perms.Node.t; + path_exists: Path.t -> bool; } let get_ops store perms = { - store = store; - write = write store perms; - mkdir = mkdir store perms; - rm = rm store perms; - setperms = setperms store perms; - ls = ls store perms; - read = read store perms; - getperms = getperms store perms; - path_exists = path_exists store; + store = store; + write = write store perms; + mkdir = mkdir store perms; + rm = rm store perms; + setperms = setperms store perms; + ls = ls store perms; + read = read store perms; + getperms = getperms store perms; + path_exists = path_exists store; } let create () = { - stat_transaction_coalesce = 0; - stat_transaction_abort = 0; - root = Node.create "" Perms.Node.default0 ""; - quota = Quota.create (); + stat_transaction_coalesce = 0; + stat_transaction_abort = 0; + root = Node.create "" Perms.Node.default0 ""; + quota = Quota.create (); } let copy store = { - stat_transaction_coalesce = store.stat_transaction_coalesce; - stat_transaction_abort = store.stat_transaction_abort; - root = store.root; - quota = Quota.copy store.quota; + stat_transaction_coalesce = store.stat_transaction_coalesce; + stat_transaction_abort = store.stat_transaction_abort; + root = store.root; + quota = Quota.copy store.quota; } let incr_transaction_coalesce store = - store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1 + store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1 let incr_transaction_abort store = - store.stat_transaction_abort <- store.stat_transaction_abort + 1 + store.stat_transaction_abort <- store.stat_transaction_abort + 1 let stats store = - let nb_nodes = ref 0 in - traversal store.root (fun _path _node -> - incr nb_nodes - ); - !nb_nodes, store.stat_transaction_abort, store.stat_transaction_coalesce + let nb_nodes = ref 0 in + traversal store.root (fun _path _node -> + incr nb_nodes + ); + !nb_nodes, store.stat_transaction_abort, store.stat_transaction_coalesce diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml index 72a84ebf80..02298a04ca 100644 --- a/tools/ocaml/xenstored/symbol.ml +++ b/tools/ocaml/xenstored/symbol.ml @@ -18,7 +18,7 @@ module WeakTable = Weak.Make(struct type t = string let equal (x:string) (y:string) = (x = y) let hash = Hashtbl.hash -end) + end) type t = string diff --git a/tools/ocaml/xenstored/syslog.ml b/tools/ocaml/xenstored/syslog.ml index a95da2fd7b..cc5816a868 100644 --- a/tools/ocaml/xenstored/syslog.ml +++ b/tools/ocaml/xenstored/syslog.ml @@ -15,32 +15,32 @@ type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern | Local0 | Local1 | Local2 | Local3 - | Local4 | Local5 | Local6 | Local7 - | Lpr | Mail | News | Syslog | User | Uucp + | Local4 | Local5 | Local6 | Local7 + | Lpr | Mail | News | Syslog | User | Uucp external log : facility -> level -> string -> unit = "stub_syslog" exception Unknown_facility of string let facility_of_string s = - match s with - |"auth"->Auth - |"authpriv"->Authpriv - |"cron"->Cron - |"daemon"->Daemon - |"ftp"->Ftp - |"kern"->Kern - |"local0"->Local0 - |"local1"->Local1 - |"local2"->Local2 - |"local3"->Local3 - |"local4"->Local4 - |"local5"->Local5 - |"local6"->Local6 - |"local7"->Local7 - |"lpr"->Lpr - |"mail"->Mail - |"news"->News - |"syslog"->Syslog - |"user"->User - |"uucp"->Uucp - |_-> raise (Unknown_facility s) + match s with + |"auth"->Auth + |"authpriv"->Authpriv + |"cron"->Cron + |"daemon"->Daemon + |"ftp"->Ftp + |"kern"->Kern + |"local0"->Local0 + |"local1"->Local1 + |"local2"->Local2 + |"local3"->Local3 + |"local4"->Local4 + |"local5"->Local5 + |"local6"->Local6 + |"local7"->Local7 + |"lpr"->Lpr + |"mail"->Mail + |"news"->News + |"syslog"->Syslog + |"user"->User + |"uucp"->Uucp + |_-> raise (Unknown_facility s) diff --git a/tools/ocaml/xenstored/syslog_stubs.c b/tools/ocaml/xenstored/syslog_stubs.c index 875d48ad57..4e5e49b557 100644 --- a/tools/ocaml/xenstored/syslog_stubs.c +++ b/tools/ocaml/xenstored/syslog_stubs.c @@ -21,28 +21,28 @@ #include static int __syslog_level_table[] = { - LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, - LOG_NOTICE, LOG_INFO, LOG_DEBUG + LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, + LOG_NOTICE, LOG_INFO, LOG_DEBUG }; static int __syslog_facility_table[] = { - LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN, - LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, - LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7, - LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP + LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN, + LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, + LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7, + LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP }; value stub_syslog(value facility, value level, value msg) { - CAMLparam3(facility, level, msg); - const char *c_msg = strdup(String_val(msg)); - int c_facility = __syslog_facility_table[Int_val(facility)] - | __syslog_level_table[Int_val(level)]; + CAMLparam3(facility, level, msg); + const char *c_msg = strdup(String_val(msg)); + int c_facility = __syslog_facility_table[Int_val(facility)] + | __syslog_level_table[Int_val(level)]; - caml_enter_blocking_section(); - syslog(c_facility, "%s", c_msg); - caml_leave_blocking_section(); + caml_enter_blocking_section(); + syslog(c_facility, "%s", c_msg); + caml_leave_blocking_section(); - free((void*)c_msg); - CAMLreturn(Val_unit); + free((void*)c_msg); + CAMLreturn(Val_unit); } diff --git a/tools/ocaml/xenstored/systemd_stubs.c b/tools/ocaml/xenstored/systemd_stubs.c index f4c875075a..f36f7300cf 100644 --- a/tools/ocaml/xenstored/systemd_stubs.c +++ b/tools/ocaml/xenstored/systemd_stubs.c @@ -29,19 +29,19 @@ CAMLprim value ocaml_sd_notify_ready(value ignore) { - CAMLparam1(ignore); + CAMLparam1(ignore); - sd_notify(1, "READY=1"); + sd_notify(1, "READY=1"); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } #else CAMLprim value ocaml_sd_notify_ready(value ignore) { - CAMLparam1(ignore); + CAMLparam1(ignore); - CAMLreturn(Val_unit); + CAMLreturn(Val_unit); } #endif diff --git a/tools/ocaml/xenstored/transaction.ml b/tools/ocaml/xenstored/transaction.ml index 294143e233..9ce0e61e03 100644 --- a/tools/ocaml/xenstored/transaction.ml +++ b/tools/ocaml/xenstored/transaction.ml @@ -23,71 +23,71 @@ let test_eagain = ref false let do_coalesce = ref true let check_parents_perms_identical root1 root2 path = - let hierarch = Store.Path.get_hierarchy path in - let permdiff = List.fold_left (fun acc path -> - let n1 = Store.Path.get_node root1 path - and n2 = Store.Path.get_node root2 path in - match n1, n2 with - | Some n1, Some n2 -> - not (Perms.equiv (Store.Node.get_perms n1) (Store.Node.get_perms n2)) || acc - | _ -> - true || acc - ) false hierarch in - (not permdiff) + let hierarch = Store.Path.get_hierarchy path in + let permdiff = List.fold_left (fun acc path -> + let n1 = Store.Path.get_node root1 path + and n2 = Store.Path.get_node root2 path in + match n1, n2 with + | Some n1, Some n2 -> + not (Perms.equiv (Store.Node.get_perms n1) (Store.Node.get_perms n2)) || acc + | _ -> + true || acc + ) false hierarch in + (not permdiff) let get_lowest path1 path2 = - match path2 with - | None -> Some path1 - | Some path2 -> Some (Store.Path.get_common_prefix path1 path2) + match path2 with + | None -> Some path1 + | Some path2 -> Some (Store.Path.get_common_prefix path1 path2) let test_coalesce oldroot currentroot optpath = - match optpath with - | None -> true - | Some path -> - let oldnode = Store.Path.get_node oldroot path - and currentnode = Store.Path.get_node currentroot path in + match optpath with + | None -> true + | Some path -> + let oldnode = Store.Path.get_node oldroot path + and currentnode = Store.Path.get_node currentroot path in - match oldnode, currentnode with - | (Some oldnode), (Some currentnode) -> - if oldnode == currentnode then ( - check_parents_perms_identical oldroot currentroot path - ) else ( - false - ) - | None, None -> ( - (* ok then it doesn't exists in the old version and the current version, - just sneak it in as a child of the parent node if it exists, or else fail *) - let pnode = Store.Path.get_node currentroot (Store.Path.get_parent path) in - match pnode with - | None -> false (* ok it doesn't exists, just bail out. *) - | Some _ -> true - ) - | _ -> - false + match oldnode, currentnode with + | (Some oldnode), (Some currentnode) -> + if oldnode == currentnode then ( + check_parents_perms_identical oldroot currentroot path + ) else ( + false + ) + | None, None -> ( + (* ok then it doesn't exists in the old version and the current version, + just sneak it in as a child of the parent node if it exists, or else fail *) + let pnode = Store.Path.get_node currentroot (Store.Path.get_parent path) in + match pnode with + | None -> false (* ok it doesn't exists, just bail out. *) + | Some _ -> true + ) + | _ -> + false let can_coalesce oldroot currentroot path = - if !do_coalesce then - try test_coalesce oldroot currentroot path with _ -> false - else - false + if !do_coalesce then + try test_coalesce oldroot currentroot path with _ -> false + else + false type ty = No | Full of ( - int * (* Transaction id *) - Store.t * (* Original store *) - Store.t (* A pointer to the canonical store: its root changes on each transaction-commit *) -) + int * (* Transaction id *) + Store.t * (* Original store *) + Store.t (* A pointer to the canonical store: its root changes on each transaction-commit *) + ) type t = { - ty: ty; - start_count: int64; - store: Store.t; (* This is the store that we change in write operations. *) - quota: Quota.t; - oldroot: Store.Node.t; - mutable paths: (Xenbus.Xb.Op.operation * Store.Path.t) list; - mutable operations: (Packet.request * Packet.response) list; - mutable quota_reached: bool; - mutable read_lowpath: Store.Path.t option; - mutable write_lowpath: Store.Path.t option; + ty: ty; + start_count: int64; + store: Store.t; (* This is the store that we change in write operations. *) + quota: Quota.t; + oldroot: Store.Node.t; + mutable paths: (Xenbus.Xb.Op.operation * Store.Path.t) list; + mutable operations: (Packet.request * Packet.response) list; + mutable quota_reached: bool; + mutable read_lowpath: Store.Path.t option; + mutable write_lowpath: Store.Path.t option; } let get_id t = match t.ty with No -> none | Full (id, _, _) -> id @@ -95,48 +95,48 @@ let counter = ref 0L let failed_commits = ref 0L let failed_commits_no_culprit = ref 0L let reset_conflict_stats () = - failed_commits := 0L; - failed_commits_no_culprit := 0L + failed_commits := 0L; + failed_commits_no_culprit := 0L (* Scope for optimisation: different data-structure and functions to search/filter it *) let short_running_txns = ref [] let oldest_short_running_transaction () = - let rec last = function - | [] -> None - | [x] -> Some x - | _ :: xs -> last xs - in last !short_running_txns + let rec last = function + | [] -> None + | [x] -> Some x + | _ :: xs -> last xs + in last !short_running_txns let trim_short_running_transactions txn = - let cutoff = Unix.gettimeofday () -. !Define.conflict_max_history_seconds in - let keep = match txn with - | None -> (function (start_time, _) -> start_time >= cutoff) - | Some t -> (function (start_time, tx) -> start_time >= cutoff && tx != t) - in - short_running_txns := List.filter - keep - !short_running_txns + let cutoff = Unix.gettimeofday () -. !Define.conflict_max_history_seconds in + let keep = match txn with + | None -> (function (start_time, _) -> start_time >= cutoff) + | Some t -> (function (start_time, tx) -> start_time >= cutoff && tx != t) + in + short_running_txns := List.filter + keep + !short_running_txns let make ?(internal=false) id store = - let ty = if id = none then No else Full(id, Store.copy store, store) in - let txn = { - ty = ty; - start_count = !counter; - store = if id = none then store else Store.copy store; - quota = Quota.copy store.Store.quota; - oldroot = Store.get_root store; - paths = []; - operations = []; - quota_reached = false; - read_lowpath = None; - write_lowpath = None; - } in - if id <> none && not internal then ( - let now = Unix.gettimeofday () in - short_running_txns := (now, txn) :: !short_running_txns - ); - txn + let ty = if id = none then No else Full(id, Store.copy store, store) in + let txn = { + ty = ty; + start_count = !counter; + store = if id = none then store else Store.copy store; + quota = Quota.copy store.Store.quota; + oldroot = Store.get_root store; + paths = []; + operations = []; + quota_reached = false; + read_lowpath = None; + write_lowpath = None; + } in + if id <> none && not internal then ( + let now = Unix.gettimeofday () in + short_running_txns := (now, txn) :: !short_running_txns + ); + txn let get_store t = t.store let get_paths t = t.paths @@ -148,115 +148,115 @@ let add_wop t ty path = t.paths <- (ty, path) :: t.paths let get_operations t = List.rev t.operations let check_quota_exn ~perm t = - if !Define.maxrequests >= 0 - && not (Perms.Connection.is_dom0 perm) - && (t.quota_reached || List.length t.operations >= !Define.maxrequests) - then begin - t.quota_reached <- true; - raise Quota.Limit_reached; - end + if !Define.maxrequests >= 0 + && not (Perms.Connection.is_dom0 perm) + && (t.quota_reached || List.length t.operations >= !Define.maxrequests) + then begin + t.quota_reached <- true; + raise Quota.Limit_reached; + end let add_operation t request response = - t.operations <- (request, response) :: t.operations + t.operations <- (request, response) :: t.operations let set_read_lowpath t path = t.read_lowpath <- get_lowest path t.read_lowpath let set_write_lowpath t path = t.write_lowpath <- get_lowest path t.write_lowpath let path_exists t path = Store.path_exists t.store path let write t perm path value = - let path_exists = path_exists t path in - Store.write t.store perm path value; - if path_exists - then set_write_lowpath t path - else set_write_lowpath t (Store.Path.get_parent path); - add_wop t Xenbus.Xb.Op.Write path + let path_exists = path_exists t path in + Store.write t.store perm path value; + if path_exists + then set_write_lowpath t path + else set_write_lowpath t (Store.Path.get_parent path); + add_wop t Xenbus.Xb.Op.Write path let mkdir ?(with_watch=true) t perm path = - Store.mkdir t.store perm path; - set_write_lowpath t (Store.Path.get_parent path); - if with_watch then - add_wop t Xenbus.Xb.Op.Mkdir path + Store.mkdir t.store perm path; + set_write_lowpath t (Store.Path.get_parent path); + if with_watch then + add_wop t Xenbus.Xb.Op.Mkdir path let setperms t perm path perms = - Store.setperms t.store perm path perms; - set_write_lowpath t path; - add_wop t Xenbus.Xb.Op.Setperms path + Store.setperms t.store perm path perms; + set_write_lowpath t path; + add_wop t Xenbus.Xb.Op.Setperms path let rm t perm path = - Store.rm t.store perm path; - set_write_lowpath t (Store.Path.get_parent path); - add_wop t Xenbus.Xb.Op.Rm path + Store.rm t.store perm path; + set_write_lowpath t (Store.Path.get_parent path); + add_wop t Xenbus.Xb.Op.Rm path let ls t perm path = - let r = Store.ls t.store perm path in - set_read_lowpath t path; - r + let r = Store.ls t.store perm path in + set_read_lowpath t path; + r let read t perm path = - let r = Store.read t.store perm path in - set_read_lowpath t path; - r + let r = Store.read t.store perm path in + set_read_lowpath t path; + r let getperms t perm path = - let r = Store.getperms t.store perm path in - set_read_lowpath t path; - r + let r = Store.getperms t.store perm path in + set_read_lowpath t path; + r let commit ~con t = - let has_write_ops = List.length t.paths > 0 in - let has_coalesced = ref false in - let has_commited = - match t.ty with - | No -> true - | Full (_id, oldstore, cstore) -> (* "cstore" meaning current canonical store *) - let commit_partial oldroot cstore store = - (* get the lowest path of the query and verify that it hasn't - been modified by others transactions. *) - if can_coalesce oldroot (Store.get_root cstore) t.read_lowpath - && can_coalesce oldroot (Store.get_root cstore) t.write_lowpath then ( - maybe (fun p -> - let n = Store.get_node store p in + let has_write_ops = List.length t.paths > 0 in + let has_coalesced = ref false in + let has_commited = + match t.ty with + | No -> true + | Full (_id, oldstore, cstore) -> (* "cstore" meaning current canonical store *) + let commit_partial oldroot cstore store = + (* get the lowest path of the query and verify that it hasn't + been modified by others transactions. *) + if can_coalesce oldroot (Store.get_root cstore) t.read_lowpath + && can_coalesce oldroot (Store.get_root cstore) t.write_lowpath then ( + maybe (fun p -> + let n = Store.get_node store p in - (* it has to be in the store, otherwise it means bugs - in the lowpath registration. we don't need to handle none. *) - maybe (fun n -> Store.set_node cstore p n t.quota store.Store.quota) n; - Logging.write_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p); - ) t.write_lowpath; - maybe (fun p -> - Logging.read_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p) - ) t.read_lowpath; - has_coalesced := true; - Store.incr_transaction_coalesce cstore; - true - ) else ( - (* cannot do anything simple, just discard the queries, - and the client need to redo it later *) - Store.incr_transaction_abort cstore; - false - ) - in - let try_commit oldroot cstore store = - if oldroot == Store.get_root cstore then ( - (* move the new root to the current store, if the oldroot - has not been modified *) - if has_write_ops then ( - Store.set_root cstore (Store.get_root store); - Store.set_quota cstore (Store.get_quota store) - ); - true - ) else - (* we try a partial commit if possible *) - commit_partial oldroot cstore store - in - if !test_eagain && Random.int 3 = 0 then - false - else - try_commit (Store.get_root oldstore) cstore t.store - in - if has_commited && has_write_ops then - Disk.write t.store; - if not has_commited - then Logging.conflict ~tid:(get_id t) ~con - else if not !has_coalesced - then Logging.commit ~tid:(get_id t) ~con; - has_commited + (* it has to be in the store, otherwise it means bugs + in the lowpath registration. we don't need to handle none. *) + maybe (fun n -> Store.set_node cstore p n t.quota store.Store.quota) n; + Logging.write_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p); + ) t.write_lowpath; + maybe (fun p -> + Logging.read_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p) + ) t.read_lowpath; + has_coalesced := true; + Store.incr_transaction_coalesce cstore; + true + ) else ( + (* cannot do anything simple, just discard the queries, + and the client need to redo it later *) + Store.incr_transaction_abort cstore; + false + ) + in + let try_commit oldroot cstore store = + if oldroot == Store.get_root cstore then ( + (* move the new root to the current store, if the oldroot + has not been modified *) + if has_write_ops then ( + Store.set_root cstore (Store.get_root store); + Store.set_quota cstore (Store.get_quota store) + ); + true + ) else + (* we try a partial commit if possible *) + commit_partial oldroot cstore store + in + if !test_eagain && Random.int 3 = 0 then + false + else + try_commit (Store.get_root oldstore) cstore t.store + in + if has_commited && has_write_ops then + Disk.write t.store; + if not has_commited + then Logging.conflict ~tid:(get_id t) ~con + else if not !has_coalesced + then Logging.commit ~tid:(get_id t) ~con; + has_commited diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml index ca38b26632..bef97cdbdb 100644 --- a/tools/ocaml/xenstored/trie.ml +++ b/tools/ocaml/xenstored/trie.ml @@ -19,159 +19,159 @@ module StringMap = Map.Make(String) module Node = struct - type 'a t = { - key: string; - value: 'a option; - children: 'a t StringMap.t; - } + type 'a t = { + key: string; + value: 'a option; + children: 'a t StringMap.t; + } - let _create key value = { - key = key; - value = Some value; - children = StringMap.empty; - } + let _create key value = { + key = key; + value = Some value; + children = StringMap.empty; + } - let empty key = { - key = key; - value = None; - children = StringMap.empty; - } + let empty key = { + key = key; + value = None; + children = StringMap.empty; + } - let _get_key node = node.key - let get_value node = - match node.value with - | None -> raise Not_found - | Some value -> value + let _get_key node = node.key + let get_value node = + match node.value with + | None -> raise Not_found + | Some value -> value - let _get_children node = node.children + let _get_children node = node.children - let set_value node value = - { node with value = Some value } - let set_children node children = - { node with children = children } + let set_value node value = + { node with value = Some value } + let set_children node children = + { node with children = children } - let _add_child node child = - { node with children = StringMap.add child.key child node.children } + let _add_child node child = + { node with children = StringMap.add child.key child node.children } end type 'a t = 'a Node.t StringMap.t let mem_node nodes key = - StringMap.mem key nodes + StringMap.mem key nodes let find_node nodes key = - StringMap.find key nodes + StringMap.find key nodes let replace_node nodes key node = - StringMap.update key (function None -> None | Some _ -> Some node) nodes + StringMap.update key (function None -> None | Some _ -> Some node) nodes let remove_node nodes key = - StringMap.update key (function None -> raise Not_found | Some _ -> None) nodes + StringMap.update key (function None -> raise Not_found | Some _ -> None) nodes let create () = StringMap.empty let rec iter f tree = - let aux key node = - f key node.Node.value; - iter f node.Node.children - in - StringMap.iter aux tree + let aux key node = + f key node.Node.value; + iter f node.Node.children + in + StringMap.iter aux tree let rec map f tree = - let aux node = - let value = - match node.Node.value with - | None -> None - | Some value -> f value - in - { node with Node.value = value; Node.children = map f node.Node.children } - in - tree |> StringMap.map aux - |> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.is_empty n.Node.children)) + let aux node = + let value = + match node.Node.value with + | None -> None + | Some value -> f value + in + { node with Node.value = value; Node.children = map f node.Node.children } + in + tree |> StringMap.map aux + |> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.is_empty n.Node.children)) let rec fold f tree acc = - let aux key node accu = - fold f node.Node.children (f key node.Node.value accu) - in - StringMap.fold aux tree acc + let aux key node accu = + fold f node.Node.children (f key node.Node.value accu) + in + StringMap.fold aux tree acc (* return a sub-trie *) let rec sub_node tree = function - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - if t = [] - then node - else sub_node node.Node.children t - end else - raise Not_found + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + if t = [] + then node + else sub_node node.Node.children t + end else + raise Not_found let sub tree path = - try (sub_node tree path).Node.children - with Not_found -> StringMap.empty + try (sub_node tree path).Node.children + with Not_found -> StringMap.empty let find tree path = - Node.get_value (sub_node tree path) + Node.get_value (sub_node tree path) (* return false if the node doesn't exists or if it is not associated to any value *) let rec mem tree = function - | [] -> false - | h::t -> - mem_node tree h - && (let node = find_node tree h in - if t = [] - then node.Node.value <> None - else mem node.Node.children t) + | [] -> false + | h::t -> + mem_node tree h + && (let node = find_node tree h in + if t = [] + then node.Node.value <> None + else mem node.Node.children t) (* Iterate over the longest valid prefix *) let rec iter_path f tree = function - | [] -> () - | h::l -> - if mem_node tree h - then begin - let node = find_node tree h in - f node.Node.key node.Node.value; - iter_path f node.Node.children l - end + | [] -> () + | h::l -> + if mem_node tree h + then begin + let node = find_node tree h in + f node.Node.key node.Node.value; + iter_path f node.Node.children l + end let rec set_node node path value = - if path = [] - then Node.set_value node value - else begin - let children = set node.Node.children path value in - Node.set_children node children - end + if path = [] + then Node.set_value node value + else begin + let children = set node.Node.children path value in + Node.set_children node children + end and set tree path value = - match path with - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - replace_node tree h (set_node node t value) - end else begin - let node = Node.empty h in - StringMap.add node.Node.key (set_node node t value) tree - end + match path with + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + replace_node tree h (set_node node t value) + end else begin + let node = Node.empty h in + StringMap.add node.Node.key (set_node node t value) tree + end let rec unset tree = function - | [] -> tree - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - let children = unset node.Node.children t in - let new_node = - if t = [] - then Node.set_children (Node.empty h) children - else Node.set_children node children - in - if StringMap.is_empty children && new_node.Node.value = None - then remove_node tree h - else replace_node tree h new_node - end else - raise Not_found + | [] -> tree + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + let children = unset node.Node.children t in + let new_node = + if t = [] + then Node.set_children (Node.empty h) children + else Node.set_children node children + in + if StringMap.is_empty children && new_node.Node.value = None + then remove_node tree h + else replace_node tree h new_node + end else + raise Not_found diff --git a/tools/ocaml/xenstored/trie.mli b/tools/ocaml/xenstored/trie.mli index 27785154f5..9e7afff788 100644 --- a/tools/ocaml/xenstored/trie.mli +++ b/tools/ocaml/xenstored/trie.mli @@ -17,44 +17,44 @@ type 'a t (** The type of tries. ['a] the type of values. - Internally, a trie is represented as a labeled tree, where node contains values - of type [string * 'a option]. *) + Internally, a trie is represented as a labeled tree, where node contains values + of type [string * 'a option]. *) val create : unit -> 'a t (** Creates an empty trie. *) val mem : 'a t -> string list -> bool (** [mem t k] returns true if a value is associated with the key [k] in the trie [t]. - Otherwise, it returns false. *) + Otherwise, it returns false. *) val find : 'a t -> string list -> 'a (** [find t k] returns the value associated with the key [k] in the trie [t]. - Returns [Not_found] if no values are associated with [k] in [t]. *) + Returns [Not_found] if no values are associated with [k] in [t]. *) val set : 'a t -> string list -> 'a -> 'a t (** [set t k v] associates the value [v] with the key [k] in the trie [t]. *) val unset : 'a t -> string list -> 'a t (** [unset k v] removes the association of value [v] with the key [k] in the trie [t]. - Moreover, it automatically clean the trie, ie. it removes recursively - every nodes of [t] containing no values and having no chil. *) + Moreover, it automatically clean the trie, ie. it removes recursively + every nodes of [t] containing no values and having no chil. *) val iter : (string -> 'a option -> unit) -> 'a t -> unit (** [iter f t] applies the function [f] to every node of the trie [t]. - As nodes of the trie [t] do not necessary contains a value, the second argument of - [f] is an option type. *) + As nodes of the trie [t] do not necessary contains a value, the second argument of + [f] is an option type. *) val iter_path : (string -> 'a option -> unit) -> 'a t -> string list -> unit (** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t]. - If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) + If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) val fold : (string -> 'a option -> 'c -> 'c) -> 'a t -> 'c -> 'c (** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *) val map : ('a -> 'b option) -> 'a t -> 'b t (** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option - as one may wants to remove value associated to a key. This function is not tail-recursive. *) + as one may wants to remove value associated to a key. This function is not tail-recursive. *) val sub : 'a t -> string list -> 'a t (** [sub t p] returns the sub-trie associated with the path [p] in the trie [t]. - If [p] is not a valid path of [t], it returns an empty trie. *) + If [p] is not a valid path of [t], it returns an empty trie. *) diff --git a/tools/ocaml/xenstored/utils.ml b/tools/ocaml/xenstored/utils.ml index dd03b2b5bc..eac56ec5d6 100644 --- a/tools/ocaml/xenstored/utils.ml +++ b/tools/ocaml/xenstored/utils.ml @@ -19,111 +19,111 @@ open Stdext (* lists utils *) let filter_out filter l = - List.filter (fun x -> not (List.mem x filter)) l + List.filter (fun x -> not (List.mem x filter)) l let filter_in filter l = - List.filter (fun x -> List.mem x filter) l + List.filter (fun x -> List.mem x filter) l let list_remove element l = - List.filter (fun e -> e != element) l + List.filter (fun e -> e != element) l let list_tl_multi n l = - let rec do_tl i x = - if i = 0 then x else do_tl (i - 1) (List.tl x) - in - do_tl n l + let rec do_tl i x = + if i = 0 then x else do_tl (i - 1) (List.tl x) + in + do_tl n l (* string utils *) let get_hierarchy path = - let l = List.length path in - let revpath = List.rev path in - let rec sub i = - let x = List.rev (list_tl_multi (l - i) revpath) in - if i = l then [ x ] else x :: sub (i + 1) - in - sub 0 + let l = List.length path in + let revpath = List.rev path in + let rec sub i = + let x = List.rev (list_tl_multi (l - i) revpath) in + if i = l then [ x ] else x :: sub (i + 1) + in + sub 0 let hexify s = - let hexseq_of_char c = sprintf "%02x" (Char.code c) in - let hs = Bytes.create (String.length s * 2) in - String.iteri (fun i c -> - let seq = hexseq_of_char c in - Bytes.set hs (i * 2) seq.[0]; - Bytes.set hs (i * 2 + 1) seq.[1]; - ) s; - Bytes.unsafe_to_string hs + let hexseq_of_char c = sprintf "%02x" (Char.code c) in + let hs = Bytes.create (String.length s * 2) in + String.iteri (fun i c -> + let seq = hexseq_of_char c in + Bytes.set hs (i * 2) seq.[0]; + Bytes.set hs (i * 2 + 1) seq.[1]; + ) s; + Bytes.unsafe_to_string hs let unhexify hs = - let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in - let b = Bytes.create (String.length hs / 2) in - for i = 0 to Bytes.length b - 1 - do - Bytes.set b i (char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]) - done; - Bytes.unsafe_to_string b + let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in + let b = Bytes.create (String.length hs / 2) in + for i = 0 to Bytes.length b - 1 + do + Bytes.set b i (char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]) + done; + Bytes.unsafe_to_string b let trim_path path = - try - let rindex = String.rindex path '/' in - String.sub path 0 rindex - with - Not_found -> "" + try + let rindex = String.rindex path '/' in + String.sub path 0 rindex + with + Not_found -> "" let join_by_null ls = String.concat "\000" ls (* unix utils *) let create_unix_socket name = - Unixext.unlink_safe name; - Unixext.mkdir_rec (Filename.dirname name) 0o700; - let sockaddr = Unix.ADDR_UNIX(name) in - let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unix.bind sock sockaddr; - Unix.listen sock 1; - sock + Unixext.unlink_safe name; + Unixext.mkdir_rec (Filename.dirname name) 0o700; + let sockaddr = Unix.ADDR_UNIX(name) in + let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.bind sock sockaddr; + Unix.listen sock 1; + sock let read_file_single_integer filename = - let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in - let buf = Bytes.make 20 '\000' in - let sz = Unix.read fd buf 0 20 in - Unix.close fd; - int_of_string (Bytes.sub_string buf 0 sz) + let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in + let buf = Bytes.make 20 '\000' in + let sz = Unix.read fd buf 0 20 in + Unix.close fd; + int_of_string (Bytes.sub_string buf 0 sz) (* @path may be guest data and needs its length validating. @connection_path * is generated locally in xenstored and always of the form "/local/domain/$N/" *) let path_validate path connection_path = - let len = String.length path in + let len = String.length path in - if len = 0 then raise Define.Invalid_path; + if len = 0 then raise Define.Invalid_path; - let abs_path = - match String.get path 0 with - | '/' | '@' -> path - | _ -> connection_path ^ path - in + let abs_path = + match String.get path 0 with + | '/' | '@' -> path + | _ -> connection_path ^ path + in - (* Regardless whether client specified absolute or relative path, - canonicalize it (above) and, for domain-relative paths, check the - length of the relative part. + (* Regardless whether client specified absolute or relative path, + canonicalize it (above) and, for domain-relative paths, check the + length of the relative part. - This prevents paths becoming invalid across migrate when the length - of the domid changes in @param connection_path. - *) - let len = String.length abs_path in - let on_absolute _ _ = len in - let on_relative _ offset = len - offset in - let len = Scanf.ksscanf abs_path on_absolute "/local/domain/%d/%n" on_relative in - if len > !Define.path_max then raise Define.Invalid_path; + This prevents paths becoming invalid across migrate when the length + of the domid changes in @param connection_path. + *) + let len = String.length abs_path in + let on_absolute _ _ = len in + let on_relative _ offset = len - offset in + let len = Scanf.ksscanf abs_path on_absolute "/local/domain/%d/%n" on_relative in + if len > !Define.path_max then raise Define.Invalid_path; - abs_path + abs_path module FD : sig - type t = Unix.file_descr - val of_int: int -> t - val to_int : t -> int + type t = Unix.file_descr + val of_int: int -> t + val to_int : t -> int end = struct - type t = Unix.file_descr - (* This is like Obj.magic but just for these types, - and relies on Unix.file_descr = int *) - external to_int : t -> int = "%identity" - external of_int : int -> t = "%identity" + type t = Unix.file_descr + (* This is like Obj.magic but just for these types, + and relies on Unix.file_descr = int *) + external to_int : t -> int = "%identity" + external of_int : int -> t = "%identity" end diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml index ffd43a4eee..34612814e1 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -26,589 +26,589 @@ let info fmt = Logging.info "xenstored" fmt (*------------ event klass processors --------------*) let process_connection_fds store cons domains rset wset = - let try_fct fct c = - try - fct store cons domains c - with - | Unix.Unix_error(err, "write", _) -> - Connections.del_anonymous cons c; - error "closing socket connection: write error: %s" - (Unix.error_message err) - | Unix.Unix_error(err, "read", _) -> - Connections.del_anonymous cons c; - if err <> Unix.ECONNRESET then - error "closing socket connection: read error: %s" - (Unix.error_message err) - | Xenbus.Xb.End_of_file -> - Connections.del_anonymous cons c; - debug "closing socket connection" - in - let process_fdset_with fds fct = - List.iter - (fun fd -> - try try_fct fct (Connections.find cons fd) - with Not_found -> () - ) fds in - process_fdset_with rset Process.do_input; - process_fdset_with wset Process.do_output + let try_fct fct c = + try + fct store cons domains c + with + | Unix.Unix_error(err, "write", _) -> + Connections.del_anonymous cons c; + error "closing socket connection: write error: %s" + (Unix.error_message err) + | Unix.Unix_error(err, "read", _) -> + Connections.del_anonymous cons c; + if err <> Unix.ECONNRESET then + error "closing socket connection: read error: %s" + (Unix.error_message err) + | Xenbus.Xb.End_of_file -> + Connections.del_anonymous cons c; + debug "closing socket connection" + in + let process_fdset_with fds fct = + List.iter + (fun fd -> + try try_fct fct (Connections.find cons fd) + with Not_found -> () + ) fds in + process_fdset_with rset Process.do_input; + process_fdset_with wset Process.do_output let process_domains store cons domains = - let do_io_domain domain = - if Domain.is_bad_domain domain - || Domain.get_io_credit domain <= 0 - || Domain.is_paused_for_conflict domain - then () (* nothing to do *) - else ( - let con = Connections.find_domain cons (Domain.get_id domain) in - Process.do_input store cons domains con; - Process.do_output store cons domains con; - Domain.decr_io_credit domain - ) in - Domains.iter domains do_io_domain + let do_io_domain domain = + if Domain.is_bad_domain domain + || Domain.get_io_credit domain <= 0 + || Domain.is_paused_for_conflict domain + then () (* nothing to do *) + else ( + let con = Connections.find_domain cons (Domain.get_id domain) in + Process.do_input store cons domains con; + Process.do_output store cons domains con; + Domain.decr_io_credit domain + ) in + Domains.iter domains do_io_domain let sigusr1_handler store = - try - let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] - 0o600 (Paths.xen_run_stored ^ "/db.debug") in - finally (fun () -> Store.dump store channel) - (fun () -> close_out channel) - with _ -> - () + try + let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] + 0o600 (Paths.xen_run_stored ^ "/db.debug") in + finally (fun () -> Store.dump store channel) + (fun () -> close_out channel) + with _ -> + () let sighup_handler _ = - maybe (fun logger -> logger.Logging.restart()) !Logging.xenstored_logger; - maybe (fun logger -> logger.Logging.restart()) !Logging.access_logger + maybe (fun logger -> logger.Logging.restart()) !Logging.xenstored_logger; + maybe (fun logger -> logger.Logging.restart()) !Logging.access_logger let config_filename cf = - match cf.config_file with - | Some name -> name - | None -> Define.default_config_dir ^ "/oxenstored.conf" + match cf.config_file with + | Some name -> name + | None -> Define.default_config_dir ^ "/oxenstored.conf" let default_pidfile = Paths.xen_run_dir ^ "/xenstored.pid" let ring_scan_interval = ref 20 let parse_config filename = - let pidfile = ref default_pidfile in - let options = [ - ("merge-activate", Config.Set_bool Transaction.do_coalesce); - ("conflict-burst-limit", Config.Set_float Define.conflict_burst_limit); - ("conflict-max-history-seconds", Config.Set_float Define.conflict_max_history_seconds); - ("conflict-rate-limit-is-aggregate", Config.Set_bool Define.conflict_rate_limit_is_aggregate); - ("perms-activate", Config.Set_bool Perms.activate); - ("perms-watch-activate", Config.Set_bool Perms.watch_activate); - ("quota-activate", Config.Set_bool Quota.activate); - ("quota-maxwatch", Config.Set_int Define.maxwatch); - ("quota-transaction", Config.Set_int Define.maxtransaction); - ("quota-maxentity", Config.Set_int Quota.maxent); - ("quota-maxsize", Config.Set_int Quota.maxsize); - ("quota-maxrequests", Config.Set_int Define.maxrequests); - ("quota-maxoutstanding", Config.Set_int Define.maxoutstanding); - ("quota-maxwatchevents", Config.Set_int Define.maxwatchevents); - ("quota-path-max", Config.Set_int Define.path_max); - ("gc-max-overhead", Config.Set_int Define.gc_max_overhead); - ("test-eagain", Config.Set_bool Transaction.test_eagain); - ("persistent", Config.Set_bool Disk.enable); - ("xenstored-log-file", Config.String Logging.set_xenstored_log_destination); - ("xenstored-log-level", Config.String - (fun s -> Logging.xenstored_log_level := Logging.level_of_string s)); - ("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_files); - ("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lines); - ("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_chars); - ("access-log-file", Config.String Logging.set_access_log_destination); - ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files); - ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines); - ("access-log-nb-chars", Config.Set_int Logging.access_log_nb_chars); - ("access-log-read-ops", Config.Set_bool Logging.access_log_read_ops); - ("access-log-transactions-ops", Config.Set_bool Logging.access_log_transaction_ops); - ("access-log-special-ops", Config.Set_bool Logging.access_log_special_ops); - ("allow-debug", Config.Set_bool Process.allow_debug); - ("ring-scan-interval", Config.Set_int ring_scan_interval); - ("pid-file", Config.Set_string pidfile); - ("xenstored-kva", Config.Set_string Domains.xenstored_kva); - ("xenstored-port", Config.Set_string Domains.xenstored_port); ] in - begin try Config.read filename options (fun _ _ -> raise Not_found) - with - | Config.Error err -> List.iter (fun (k, e) -> - match e with - | "unknown key" -> eprintf "config: unknown key %s\n" k - | _ -> eprintf "config: %s: %s\n" k e - ) err; - | Sys_error m -> eprintf "error: config: %s\n" m; - end; - !pidfile + let pidfile = ref default_pidfile in + let options = [ + ("merge-activate", Config.Set_bool Transaction.do_coalesce); + ("conflict-burst-limit", Config.Set_float Define.conflict_burst_limit); + ("conflict-max-history-seconds", Config.Set_float Define.conflict_max_history_seconds); + ("conflict-rate-limit-is-aggregate", Config.Set_bool Define.conflict_rate_limit_is_aggregate); + ("perms-activate", Config.Set_bool Perms.activate); + ("perms-watch-activate", Config.Set_bool Perms.watch_activate); + ("quota-activate", Config.Set_bool Quota.activate); + ("quota-maxwatch", Config.Set_int Define.maxwatch); + ("quota-transaction", Config.Set_int Define.maxtransaction); + ("quota-maxentity", Config.Set_int Quota.maxent); + ("quota-maxsize", Config.Set_int Quota.maxsize); + ("quota-maxrequests", Config.Set_int Define.maxrequests); + ("quota-maxoutstanding", Config.Set_int Define.maxoutstanding); + ("quota-maxwatchevents", Config.Set_int Define.maxwatchevents); + ("quota-path-max", Config.Set_int Define.path_max); + ("gc-max-overhead", Config.Set_int Define.gc_max_overhead); + ("test-eagain", Config.Set_bool Transaction.test_eagain); + ("persistent", Config.Set_bool Disk.enable); + ("xenstored-log-file", Config.String Logging.set_xenstored_log_destination); + ("xenstored-log-level", Config.String + (fun s -> Logging.xenstored_log_level := Logging.level_of_string s)); + ("xenstored-log-nb-files", Config.Set_int Logging.xenstored_log_nb_files); + ("xenstored-log-nb-lines", Config.Set_int Logging.xenstored_log_nb_lines); + ("xenstored-log-nb-chars", Config.Set_int Logging.xenstored_log_nb_chars); + ("access-log-file", Config.String Logging.set_access_log_destination); + ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files); + ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines); + ("access-log-nb-chars", Config.Set_int Logging.access_log_nb_chars); + ("access-log-read-ops", Config.Set_bool Logging.access_log_read_ops); + ("access-log-transactions-ops", Config.Set_bool Logging.access_log_transaction_ops); + ("access-log-special-ops", Config.Set_bool Logging.access_log_special_ops); + ("allow-debug", Config.Set_bool Process.allow_debug); + ("ring-scan-interval", Config.Set_int ring_scan_interval); + ("pid-file", Config.Set_string pidfile); + ("xenstored-kva", Config.Set_string Domains.xenstored_kva); + ("xenstored-port", Config.Set_string Domains.xenstored_port); ] in + begin try Config.read filename options (fun _ _ -> raise Not_found) + with + | Config.Error err -> List.iter (fun (k, e) -> + match e with + | "unknown key" -> eprintf "config: unknown key %s\n" k + | _ -> eprintf "config: %s: %s\n" k e + ) err; + | Sys_error m -> eprintf "error: config: %s\n" m; + end; + !pidfile module DB = struct -exception Bad_format of string + exception Bad_format of string -let dump_format_header = "$xenstored-dump-format" + let dump_format_header = "$xenstored-dump-format" -let from_channel_f chan global_f socket_f domain_f watch_f store_f = - let unhexify s = Utils.unhexify s in - let getpath s = - let u = Utils.unhexify s in - debug "Path: %s" u; - Store.Path.of_string u in - let header = input_line chan in - if header <> dump_format_header then - raise (Bad_format "header"); - let quit = ref false in - while not !quit - do - try - let line = input_line chan in - let l = String.split ',' line in - try - match l with - | "global" :: rw :: _ -> - (* there might be more parameters here, - e.g. a RO socket from a previous version: ignore it *) - global_f ~rw - | "socket" :: fd :: [] -> - socket_f ~fd:(int_of_string fd) - | "dom" :: domid :: mfn :: port :: []-> - domain_f (int_of_string domid) - (Nativeint.of_string mfn) - (int_of_string port) - | "watch" :: domid :: path :: token :: [] -> - watch_f (int_of_string domid) - (unhexify path) (unhexify token) - | "store" :: path :: perms :: value :: [] -> - store_f (getpath path) - (Perms.Node.of_string (unhexify perms ^ "\000")) - (unhexify value) - | _ -> - info "restoring: ignoring unknown line: %s" line - with exn -> - info "restoring: ignoring unknown line: %s (exception: %s)" - line (Printexc.to_string exn); - () - with End_of_file -> - quit := true - done; - info "Completed loading xenstore dump" + let from_channel_f chan global_f socket_f domain_f watch_f store_f = + let unhexify s = Utils.unhexify s in + let getpath s = + let u = Utils.unhexify s in + debug "Path: %s" u; + Store.Path.of_string u in + let header = input_line chan in + if header <> dump_format_header then + raise (Bad_format "header"); + let quit = ref false in + while not !quit + do + try + let line = input_line chan in + let l = String.split ',' line in + try + match l with + | "global" :: rw :: _ -> + (* there might be more parameters here, + e.g. a RO socket from a previous version: ignore it *) + global_f ~rw + | "socket" :: fd :: [] -> + socket_f ~fd:(int_of_string fd) + | "dom" :: domid :: mfn :: port :: []-> + domain_f (int_of_string domid) + (Nativeint.of_string mfn) + (int_of_string port) + | "watch" :: domid :: path :: token :: [] -> + watch_f (int_of_string domid) + (unhexify path) (unhexify token) + | "store" :: path :: perms :: value :: [] -> + store_f (getpath path) + (Perms.Node.of_string (unhexify perms ^ "\000")) + (unhexify value) + | _ -> + info "restoring: ignoring unknown line: %s" line + with exn -> + info "restoring: ignoring unknown line: %s (exception: %s)" + line (Printexc.to_string exn); + () + with End_of_file -> + quit := true + done; + info "Completed loading xenstore dump" -let from_channel store cons doms chan = - (* don't let the permission get on our way, full perm ! *) - let op = Store.get_ops store Perms.Connection.full_rights in - let rwro = ref (None) in - let global_f ~rw = - let get_listen_sock sockfd = - let fd = sockfd |> int_of_string |> Utils.FD.of_int in - Unix.listen fd 1; - Some fd - in - rwro := get_listen_sock rw - in - let socket_f ~fd = - let ufd = Utils.FD.of_int fd in - let is_valid = try (Unix.fstat ufd).Unix.st_kind = Unix.S_SOCK with _ -> false in - if is_valid then - Connections.add_anonymous cons ufd - else - warn "Ignoring invalid socket FD %d" fd - in - let domain_f domid mfn port = - let ndom = - if domid > 0 then - Domains.create doms domid mfn port - else - Domains.create0 doms - in - Connections.add_domain cons ndom; - in - let get_con id = - if id < 0 then Connections.find cons (Utils.FD.of_int (-id)) - else Connections.find_domain cons id - in - let watch_f id path token = - ignore (Connections.add_watch cons (get_con id) path token) - in - let store_f path perms value = - op.Store.write path value; - op.Store.setperms path perms - in - from_channel_f chan global_f socket_f domain_f watch_f store_f; - !rwro + let from_channel store cons doms chan = + (* don't let the permission get on our way, full perm ! *) + let op = Store.get_ops store Perms.Connection.full_rights in + let rwro = ref (None) in + let global_f ~rw = + let get_listen_sock sockfd = + let fd = sockfd |> int_of_string |> Utils.FD.of_int in + Unix.listen fd 1; + Some fd + in + rwro := get_listen_sock rw + in + let socket_f ~fd = + let ufd = Utils.FD.of_int fd in + let is_valid = try (Unix.fstat ufd).Unix.st_kind = Unix.S_SOCK with _ -> false in + if is_valid then + Connections.add_anonymous cons ufd + else + warn "Ignoring invalid socket FD %d" fd + in + let domain_f domid mfn port = + let ndom = + if domid > 0 then + Domains.create doms domid mfn port + else + Domains.create0 doms + in + Connections.add_domain cons ndom; + in + let get_con id = + if id < 0 then Connections.find cons (Utils.FD.of_int (-id)) + else Connections.find_domain cons id + in + let watch_f id path token = + ignore (Connections.add_watch cons (get_con id) path token) + in + let store_f path perms value = + op.Store.write path value; + op.Store.setperms path perms + in + from_channel_f chan global_f socket_f domain_f watch_f store_f; + !rwro -let from_file store cons doms file = - info "Loading xenstore dump from %s" file; - let channel = open_in file in - finally (fun () -> from_channel store doms cons channel) - (fun () -> close_in channel) + let from_file store cons doms file = + info "Loading xenstore dump from %s" file; + let channel = open_in file in + finally (fun () -> from_channel store doms cons channel) + (fun () -> close_in channel) -let to_channel store cons rw chan = - let hexify s = Utils.hexify s in + let to_channel store cons rw chan = + let hexify s = Utils.hexify s in - fprintf chan "%s\n" dump_format_header; - let fdopt = function None -> -1 | Some fd -> - (* systemd and utils.ml sets it close on exec *) - Unix.clear_close_on_exec fd; - Utils.FD.to_int fd in - fprintf chan "global,%d\n" (fdopt rw); + fprintf chan "%s\n" dump_format_header; + let fdopt = function None -> -1 | Some fd -> + (* systemd and utils.ml sets it close on exec *) + Unix.clear_close_on_exec fd; + Utils.FD.to_int fd in + fprintf chan "global,%d\n" (fdopt rw); - (* dump connections related to domains: domid, mfn, eventchn port/ sockets, and watches *) - Connections.iter cons (fun con -> Connection.dump con chan); + (* dump connections related to domains: domid, mfn, eventchn port/ sockets, and watches *) + Connections.iter cons (fun con -> Connection.dump con chan); - (* dump the store *) - Store.dump_fct store (fun path node -> - let name, perms, value = Store.Node.unpack node in - let fullpath = Store.Path.to_string (Store.Path.of_path_and_name path name) in - let permstr = Perms.Node.to_string perms in - fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexify value) - ); - flush chan; - () + (* dump the store *) + Store.dump_fct store (fun path node -> + let name, perms, value = Store.Node.unpack node in + let fullpath = Store.Path.to_string (Store.Path.of_path_and_name path name) in + let permstr = Perms.Node.to_string perms in + fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexify value) + ); + flush chan; + () -let to_file store cons fds file = - let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o600 file in - finally (fun () -> to_channel store cons fds channel) - (fun () -> close_out channel) + let to_file store cons fds file = + let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o600 file in + finally (fun () -> to_channel store cons fds channel) + (fun () -> close_out channel) end (* - By default OCaml's GC only returns memory to the OS when it exceeds a - configurable 'max overhead' setting. - The default is 500%, that is 5/6th of the OCaml heap needs to be free - and only 1/6th live for a compaction to be triggerred that would - release memory back to the OS. - If the limit is not hit then the OCaml process can reuse that memory - for its own purposes, but other processes won't be able to use it. + By default OCaml's GC only returns memory to the OS when it exceeds a + configurable 'max overhead' setting. + The default is 500%, that is 5/6th of the OCaml heap needs to be free + and only 1/6th live for a compaction to be triggerred that would + release memory back to the OS. + If the limit is not hit then the OCaml process can reuse that memory + for its own purposes, but other processes won't be able to use it. - There is also a 'space overhead' setting that controls how much work - each major GC slice does, and by default aims at having no more than - 80% or 120% (depending on version) garbage values compared to live - values. - This doesn't have as much relevance to memory returned to the OS as - long as space_overhead <= max_overhead, because compaction is only - triggerred at the end of major GC cycles. + There is also a 'space overhead' setting that controls how much work + each major GC slice does, and by default aims at having no more than + 80% or 120% (depending on version) garbage values compared to live + values. + This doesn't have as much relevance to memory returned to the OS as + long as space_overhead <= max_overhead, because compaction is only + triggerred at the end of major GC cycles. - The defaults are too large once the program starts using ~100MiB of - memory, at which point ~500MiB would be unavailable to other processes - (which would be fine if this was the main process in this VM, but it is - not). + The defaults are too large once the program starts using ~100MiB of + memory, at which point ~500MiB would be unavailable to other processes + (which would be fine if this was the main process in this VM, but it is + not). - Max overhead can also be set to 0, however this is for testing purposes - only (setting it lower than 'space overhead' wouldn't help because the - major GC wouldn't run fast enough, and compaction does have a - performance cost: we can only compact contiguous regions, so memory has - to be moved around). + Max overhead can also be set to 0, however this is for testing purposes + only (setting it lower than 'space overhead' wouldn't help because the + major GC wouldn't run fast enough, and compaction does have a + performance cost: we can only compact contiguous regions, so memory has + to be moved around). - Max overhead controls how often the heap is compacted, which is useful - if there are burst of activity followed by long periods of idle state, - or if a domain quits, etc. Compaction returns memory to the OS. + Max overhead controls how often the heap is compacted, which is useful + if there are burst of activity followed by long periods of idle state, + or if a domain quits, etc. Compaction returns memory to the OS. - wasted = live * space_overhead / 100 + wasted = live * space_overhead / 100 - For globally overriding the GC settings one can use OCAMLRUNPARAM, - however we provide a config file override to be consistent with other - oxenstored settings. + For globally overriding the GC settings one can use OCAMLRUNPARAM, + however we provide a config file override to be consistent with other + oxenstored settings. - One might want to dynamically adjust the overhead setting based on used - memory, i.e. to use a fixed upper bound in bytes, not percentage. However - measurements show that such adjustments increase GC overhead massively, - while still not guaranteeing that memory is returned any more quickly - than with a percentage based setting. + One might want to dynamically adjust the overhead setting based on used + memory, i.e. to use a fixed upper bound in bytes, not percentage. However + measurements show that such adjustments increase GC overhead massively, + while still not guaranteeing that memory is returned any more quickly + than with a percentage based setting. - The allocation policy could also be tweaked, e.g. first fit would reduce - fragmentation and thus memory usage, but the documentation warns that it - can be sensibly slower, and indeed one of our own testcases can trigger - such a corner case where it is multiple times slower, so it is best to keep - the default allocation policy (next-fit/best-fit depending on version). + The allocation policy could also be tweaked, e.g. first fit would reduce + fragmentation and thus memory usage, but the documentation warns that it + can be sensibly slower, and indeed one of our own testcases can trigger + such a corner case where it is multiple times slower, so it is best to keep + the default allocation policy (next-fit/best-fit depending on version). - There are other tweaks that can be attempted in the future, e.g. setting - 'ulimit -v' to 75% of RAM, however getting the kernel to actually return - NULL from allocations is difficult even with that setting, and without a - NULL the emergency GC won't be triggerred. - Perhaps cgroup limits could help, but for now tweak the safest only. + There are other tweaks that can be attempted in the future, e.g. setting + 'ulimit -v' to 75% of RAM, however getting the kernel to actually return + NULL from allocations is difficult even with that setting, and without a + NULL the emergency GC won't be triggerred. + Perhaps cgroup limits could help, but for now tweak the safest only. *) let tweak_gc () = - Gc.set { (Gc.get ()) with Gc.max_overhead = !Define.gc_max_overhead } + Gc.set { (Gc.get ()) with Gc.max_overhead = !Define.gc_max_overhead } let _ = - let cf = do_argv in - let pidfile = - if Sys.file_exists (config_filename cf) then - parse_config (config_filename cf) - else - default_pidfile - in + let cf = do_argv in + let pidfile = + if Sys.file_exists (config_filename cf) then + parse_config (config_filename cf) + else + default_pidfile + in - tweak_gc (); + tweak_gc (); - (try - Unixext.mkdir_rec (Filename.dirname pidfile) 0o755 - with _ -> - () - ); + (try + Unixext.mkdir_rec (Filename.dirname pidfile) 0o755 + with _ -> + () + ); - let rw_sock = - if cf.disable_socket || cf.live_reload then - None - else - Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket) - in + let rw_sock = + if cf.disable_socket || cf.live_reload then + None + else + Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket) + in - if cf.daemonize && not cf.live_reload then - Unixext.daemonize () - else - printf "Xen Storage Daemon, version %d.%d\n%!" - Define.xenstored_major Define.xenstored_minor; + if cf.daemonize && not cf.live_reload then + Unixext.daemonize () + else + printf "Xen Storage Daemon, version %d.%d\n%!" + Define.xenstored_major Define.xenstored_minor; - (try Unixext.pidfile_write pidfile with _ -> ()); + (try Unixext.pidfile_write pidfile with _ -> ()); - (* for compatilibity with old xenstored *) - begin match cf.pidfile with - | Some pidfile -> Unixext.pidfile_write pidfile - | None -> () end; + (* for compatilibity with old xenstored *) + begin match cf.pidfile with + | Some pidfile -> Unixext.pidfile_write pidfile + | None -> () end; - let store = Store.create () in - let eventchn = Event.init () in - let next_frequent_ops = ref 0. in - let advance_next_frequent_ops () = - next_frequent_ops := (Unix.gettimeofday () +. !Define.conflict_max_history_seconds) - in - let delay_next_frequent_ops_by duration = - next_frequent_ops := !next_frequent_ops +. duration - in - let domains = Domains.init eventchn advance_next_frequent_ops in + let store = Store.create () in + let eventchn = Event.init () in + let next_frequent_ops = ref 0. in + let advance_next_frequent_ops () = + next_frequent_ops := (Unix.gettimeofday () +. !Define.conflict_max_history_seconds) + in + let delay_next_frequent_ops_by duration = + next_frequent_ops := !next_frequent_ops +. duration + in + let domains = Domains.init eventchn advance_next_frequent_ops in - (* For things that need to be done periodically but more often - * than the periodic_ops function *) - let frequent_ops () = - if Unix.gettimeofday () > !next_frequent_ops then ( - History.trim (); - Domains.incr_conflict_credit domains; - advance_next_frequent_ops () - ) in - let cons = Connections.create () in + (* For things that need to be done periodically but more often + * than the periodic_ops function *) + let frequent_ops () = + if Unix.gettimeofday () > !next_frequent_ops then ( + History.trim (); + Domains.incr_conflict_credit domains; + advance_next_frequent_ops () + ) in + let cons = Connections.create () in - let quit = ref false in + let quit = ref false in - Logging.init_xenstored_log(); - List.iter (fun path -> - Store.write store Perms.Connection.full_rights path "") Store.Path.specials; + Logging.init_xenstored_log(); + List.iter (fun path -> + Store.write store Perms.Connection.full_rights path "") Store.Path.specials; - let rw_sock = - if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( - let rwro = DB.from_file store domains cons Disk.xs_daemon_database in - info "Live reload: database loaded"; - Event.bind_dom_exc_virq eventchn; - Process.LiveUpdate.completed (); - rwro - ) else ( - info "No live reload: regular startup"; - if !Disk.enable then ( - info "reading store from disk"; - Disk.read store - ); + let rw_sock = + if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( + let rwro = DB.from_file store domains cons Disk.xs_daemon_database in + info "Live reload: database loaded"; + Event.bind_dom_exc_virq eventchn; + Process.LiveUpdate.completed (); + rwro + ) else ( + info "No live reload: regular startup"; + if !Disk.enable then ( + info "reading store from disk"; + Disk.read store + ); - let localpath = Store.Path.of_string "/local" in - if not (Store.path_exists store localpath) then - Store.mkdir store (Perms.Connection.create 0) localpath; + let localpath = Store.Path.of_string "/local" in + if not (Store.path_exists store localpath) then + Store.mkdir store (Perms.Connection.create 0) localpath; - if cf.domain_init then ( - Connections.add_domain cons (Domains.create0 domains); - Event.bind_dom_exc_virq eventchn - ); - rw_sock - ) in + if cf.domain_init then ( + Connections.add_domain cons (Domains.create0 domains); + Event.bind_dom_exc_virq eventchn + ); + rw_sock + ) in - (* required for xenstore-control to detect availability of live-update *) - let tool_path = Store.Path.of_string "/tool" in - if not (Store.path_exists store tool_path) then - Store.mkdir store Perms.Connection.full_rights tool_path; - Store.write store Perms.Connection.full_rights - (Store.Path.of_string "/tool/xenstored") Sys.executable_name; + (* required for xenstore-control to detect availability of live-update *) + let tool_path = Store.Path.of_string "/tool" in + if not (Store.path_exists store tool_path) then + Store.mkdir store Perms.Connection.full_rights tool_path; + Store.write store Perms.Connection.full_rights + (Store.Path.of_string "/tool/xenstored") Sys.executable_name; - Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler); - Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun _ -> - info "Received SIGTERM"; - quit := true)); - Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun _ -> sigusr1_handler store)); - Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler); + Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun _ -> + info "Received SIGTERM"; + quit := true)); + Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun _ -> sigusr1_handler store)); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; - if cf.activate_access_log then begin - let post_rotate () = DB.to_file store cons (None) Disk.xs_daemon_database in - Logging.init_access_log post_rotate - end; + if cf.activate_access_log then begin + let post_rotate () = DB.to_file store cons (None) Disk.xs_daemon_database in + Logging.init_access_log post_rotate + end; - let spec_fds = - (match rw_sock with None -> [] | Some x -> [ x ]) @ - (if cf.domain_init then [ Event.fd eventchn ] else []) - in + let spec_fds = + (match rw_sock with None -> [] | Some x -> [ x ]) @ + (if cf.domain_init then [ Event.fd eventchn ] else []) + in - let process_special_fds rset = - let accept_connection fd = - let (cfd, _addr) = Unix.accept fd in - debug "new connection through socket"; - Connections.add_anonymous cons cfd - and handle_eventchn _fd = - let port = Event.pending eventchn in - debug "pending port %d" (Xeneventchn.to_int port); - finally (fun () -> - if Some port = eventchn.Event.virq_port then ( - let (notify, deaddom) = Domains.cleanup domains in - List.iter (Store.reset_permissions store) deaddom; - List.iter (Connections.del_domain cons) deaddom; - if deaddom <> [] || notify then - Connections.fire_spec_watches - (Store.get_root store) - cons Store.Path.release_domain - ) - else - let c = Connections.find_domain_by_port cons port in - match Connection.get_domain c with - | Some dom -> Domain.incr_io_credit dom | None -> () - ) (fun () -> Event.unmask eventchn port) - and do_if_set fd set fct = - if List.mem fd set then - fct fd in + let process_special_fds rset = + let accept_connection fd = + let (cfd, _addr) = Unix.accept fd in + debug "new connection through socket"; + Connections.add_anonymous cons cfd + and handle_eventchn _fd = + let port = Event.pending eventchn in + debug "pending port %d" (Xeneventchn.to_int port); + finally (fun () -> + if Some port = eventchn.Event.virq_port then ( + let (notify, deaddom) = Domains.cleanup domains in + List.iter (Store.reset_permissions store) deaddom; + List.iter (Connections.del_domain cons) deaddom; + if deaddom <> [] || notify then + Connections.fire_spec_watches + (Store.get_root store) + cons Store.Path.release_domain + ) + else + let c = Connections.find_domain_by_port cons port in + match Connection.get_domain c with + | Some dom -> Domain.incr_io_credit dom | None -> () + ) (fun () -> Event.unmask eventchn port) + and do_if_set fd set fct = + if List.mem fd set then + fct fd in - maybe (fun fd -> do_if_set fd rset accept_connection) rw_sock; - do_if_set (Event.fd eventchn) rset (handle_eventchn) - in + maybe (fun fd -> do_if_set fd rset accept_connection) rw_sock; + do_if_set (Event.fd eventchn) rset (handle_eventchn) + in - let ring_scan_checker dom = - (* no need to scan domains already marked as for processing *) - if not (Domain.get_io_credit dom > 0) then - debug "Looking up domid %d" (Domain.get_id dom); - let con = Connections.find_domain cons (Domain.get_id dom) in - if not (Connection.has_more_work con) then ( - Process.do_output store cons domains con; - Process.do_input store cons domains con; - if Connection.has_more_work con then - (* Previously thought as no work, but detect some after scan (as - processing a new message involves multiple steps.) It's very - likely to be a "lazy" client, bump its credit. It could be false - positive though (due to time window), but it's no harm to give a - domain extra credit. *) - let n = 32 + 2 * (Domains.number domains) in - info "found lazy domain %d, credit %d" (Domain.get_id dom) n; - Domain.set_io_credit ~n dom - ) in + let ring_scan_checker dom = + (* no need to scan domains already marked as for processing *) + if not (Domain.get_io_credit dom > 0) then + debug "Looking up domid %d" (Domain.get_id dom); + let con = Connections.find_domain cons (Domain.get_id dom) in + if not (Connection.has_more_work con) then ( + Process.do_output store cons domains con; + Process.do_input store cons domains con; + if Connection.has_more_work con then + (* Previously thought as no work, but detect some after scan (as + processing a new message involves multiple steps.) It's very + likely to be a "lazy" client, bump its credit. It could be false + positive though (due to time window), but it's no harm to give a + domain extra credit. *) + let n = 32 + 2 * (Domains.number domains) in + info "found lazy domain %d, credit %d" (Domain.get_id dom) n; + Domain.set_io_credit ~n dom + ) in - let last_stat_time = ref 0. in - let last_scan_time = ref 0. in + let last_stat_time = ref 0. in + let last_scan_time = ref 0. in - let periodic_ops now = - debug "periodic_ops starting"; + let periodic_ops now = + debug "periodic_ops starting"; - (* scan all the xs rings as a safenet for ill-behaved clients *) - if !ring_scan_interval >= 0 && now > (!last_scan_time +. float !ring_scan_interval) then - (last_scan_time := now; Domains.iter domains ring_scan_checker); + (* scan all the xs rings as a safenet for ill-behaved clients *) + if !ring_scan_interval >= 0 && now > (!last_scan_time +. float !ring_scan_interval) then + (last_scan_time := now; Domains.iter domains ring_scan_checker); - (* make sure we don't print general stats faster than 2 min *) - if now > (!last_stat_time +. 120.) then ( - info "Transaction conflict statistics for last %F seconds:" (now -. !last_stat_time); - last_stat_time := now; - Domains.iter domains (Domain.log_and_reset_conflict_stats (info "Dom%d caused %Ld conflicts")); - info "%Ld failed transactions; of these no culprit was found for %Ld" !Transaction.failed_commits !Transaction.failed_commits_no_culprit; - Transaction.reset_conflict_stats (); + (* make sure we don't print general stats faster than 2 min *) + if now > (!last_stat_time +. 120.) then ( + info "Transaction conflict statistics for last %F seconds:" (now -. !last_stat_time); + last_stat_time := now; + Domains.iter domains (Domain.log_and_reset_conflict_stats (info "Dom%d caused %Ld conflicts")); + info "%Ld failed transactions; of these no culprit was found for %Ld" !Transaction.failed_commits !Transaction.failed_commits_no_culprit; + Transaction.reset_conflict_stats (); - let gc = Gc.stat () in - let (lanon, lanon_ops, lanon_watchs, - ldom, ldom_ops, ldom_watchs) = Connections.stats cons in - let store_nodes, store_abort, store_coalesce = Store.stats store in - let symtbl_len, symtbl_entries = Symbol.stats () in + let gc = Gc.stat () in + let (lanon, lanon_ops, lanon_watchs, + ldom, ldom_ops, ldom_watchs) = Connections.stats cons in + let store_nodes, store_abort, store_coalesce = Store.stats store in + let symtbl_len, symtbl_entries = Symbol.stats () in - info "store stat: nodes(%d) t-abort(%d) t-coalesce(%d)" - store_nodes store_abort store_coalesce; - info "sytbl stat: length(%d) entries(%d)" symtbl_len symtbl_entries; - info " con stat: anonymous(%d, %d o, %d w) domains(%d, %d o, %d w)" - lanon lanon_ops lanon_watchs ldom ldom_ops ldom_watchs; - info " mem stat: minor(%.0f) promoted(%.0f) major(%.0f) heap(%d w, %d c) live(%d w, %d b) free(%d w, %d b)" - gc.Gc.minor_words gc.Gc.promoted_words gc.Gc.major_words - gc.Gc.heap_words gc.Gc.heap_chunks - gc.Gc.live_words gc.Gc.live_blocks - gc.Gc.free_words gc.Gc.free_blocks - ); - let elapsed = Unix.gettimeofday () -. now in - debug "periodic_ops took %F seconds." elapsed; - if !quit then ( - match Connections.prevents_quit cons with - | [] -> () - | domains -> List.iter (fun con -> warn "%s prevents live update" - (Connection.get_domstr con)) domains - ); - delay_next_frequent_ops_by elapsed - in + info "store stat: nodes(%d) t-abort(%d) t-coalesce(%d)" + store_nodes store_abort store_coalesce; + info "sytbl stat: length(%d) entries(%d)" symtbl_len symtbl_entries; + info " con stat: anonymous(%d, %d o, %d w) domains(%d, %d o, %d w)" + lanon lanon_ops lanon_watchs ldom ldom_ops ldom_watchs; + info " mem stat: minor(%.0f) promoted(%.0f) major(%.0f) heap(%d w, %d c) live(%d w, %d b) free(%d w, %d b)" + gc.Gc.minor_words gc.Gc.promoted_words gc.Gc.major_words + gc.Gc.heap_words gc.Gc.heap_chunks + gc.Gc.live_words gc.Gc.live_blocks + gc.Gc.free_words gc.Gc.free_blocks + ); + let elapsed = Unix.gettimeofday () -. now in + debug "periodic_ops took %F seconds." elapsed; + if !quit then ( + match Connections.prevents_quit cons with + | [] -> () + | domains -> List.iter (fun con -> warn "%s prevents live update" + (Connection.get_domstr con)) domains + ); + delay_next_frequent_ops_by elapsed + in - let period_ops_interval = 15. in - let period_start = ref 0. in + let period_ops_interval = 15. in + let period_start = ref 0. in - let main_loop () = - let is_peaceful c = - match Connection.get_domain c with - | None -> true (* Treat socket-connections as exempt, and free to conflict. *) - | Some dom -> not (Domain.is_paused_for_conflict dom) - in - frequent_ops (); - let mw = Connections.has_more_work cons in - let peaceful_mw = List.filter is_peaceful mw in - List.iter - (fun c -> - match Connection.get_domain c with - | None -> () | Some d -> Domain.incr_io_credit d) - peaceful_mw; - let start_time = Unix.gettimeofday () in - let timeout = - let until_next_activity = - if Domains.all_at_max_credit domains - then period_ops_interval - else min (max 0. (!next_frequent_ops -. start_time)) period_ops_interval in - if peaceful_mw <> [] then 0. else until_next_activity - in - let inset, outset = Connections.select ~only_if:is_peaceful cons in - let rset, wset, _ = - try - Poll.poll_select (spec_fds @ inset) outset [] timeout - with Unix.Unix_error(Unix.EINTR, _, _) -> - [], [], [] in - let sfds, cfds = - List.partition (fun fd -> List.mem fd spec_fds) rset in - if List.length sfds > 0 then - process_special_fds sfds; + let main_loop () = + let is_peaceful c = + match Connection.get_domain c with + | None -> true (* Treat socket-connections as exempt, and free to conflict. *) + | Some dom -> not (Domain.is_paused_for_conflict dom) + in + frequent_ops (); + let mw = Connections.has_more_work cons in + let peaceful_mw = List.filter is_peaceful mw in + List.iter + (fun c -> + match Connection.get_domain c with + | None -> () | Some d -> Domain.incr_io_credit d) + peaceful_mw; + let start_time = Unix.gettimeofday () in + let timeout = + let until_next_activity = + if Domains.all_at_max_credit domains + then period_ops_interval + else min (max 0. (!next_frequent_ops -. start_time)) period_ops_interval in + if peaceful_mw <> [] then 0. else until_next_activity + in + let inset, outset = Connections.select ~only_if:is_peaceful cons in + let rset, wset, _ = + try + Poll.poll_select (spec_fds @ inset) outset [] timeout + with Unix.Unix_error(Unix.EINTR, _, _) -> + [], [], [] in + let sfds, cfds = + List.partition (fun fd -> List.mem fd spec_fds) rset in + if List.length sfds > 0 then + process_special_fds sfds; - if List.length cfds > 0 || List.length wset > 0 then - process_connection_fds store cons domains cfds wset; - if timeout <> 0. then ( - let now = Unix.gettimeofday () in - if now > !period_start +. period_ops_interval then - (period_start := now; periodic_ops now) - ); + if List.length cfds > 0 || List.length wset > 0 then + process_connection_fds store cons domains cfds wset; + if timeout <> 0. then ( + let now = Unix.gettimeofday () in + if now > !period_start +. period_ops_interval then + (period_start := now; periodic_ops now) + ); - process_domains store cons domains - in + process_domains store cons domains + in - Systemd.sd_notify_ready (); - let live_update = ref false in - while not (!quit && Connections.prevents_quit cons = []) - do - try - main_loop (); - live_update := Process.LiveUpdate.should_run cons; - if !live_update || !quit then begin - (* don't initiate live update if saving state fails *) - DB.to_file store cons (rw_sock) Disk.xs_daemon_database; - quit := true; - end - with exc -> - let bt = Printexc.get_backtrace () in - error "caught exception %s: %s" (Printexc.to_string exc) bt; - if cf.reraise_top_level then - raise exc - done; - info "stopping xenstored"; - (* unlink pidfile so that launch-xenstore works again *) - Unixext.unlink_safe pidfile; - (match cf.pidfile with Some pidfile -> Unixext.unlink_safe pidfile | None -> ()); + Systemd.sd_notify_ready (); + let live_update = ref false in + while not (!quit && Connections.prevents_quit cons = []) + do + try + main_loop (); + live_update := Process.LiveUpdate.should_run cons; + if !live_update || !quit then begin + (* don't initiate live update if saving state fails *) + DB.to_file store cons (rw_sock) Disk.xs_daemon_database; + quit := true; + end + with exc -> + let bt = Printexc.get_backtrace () in + error "caught exception %s: %s" (Printexc.to_string exc) bt; + if cf.reraise_top_level then + raise exc + done; + info "stopping xenstored"; + (* unlink pidfile so that launch-xenstore works again *) + Unixext.unlink_safe pidfile; + (match cf.pidfile with Some pidfile -> Unixext.unlink_safe pidfile | None -> ()); - if !live_update then begin - Logging.live_update (); - Process.LiveUpdate.launch_exn !Process.LiveUpdate.state - end + if !live_update then begin + Logging.live_update (); + Process.LiveUpdate.launch_exn !Process.LiveUpdate.state + end From patchwork Tue Nov 8 15:34:00 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036478 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 6DE96C433FE for ; Tue, 8 Nov 2022 15:35:01 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440126.694252 (Exim 4.92) (envelope-from ) id 1osQcn-0003Yw-GV; Tue, 08 Nov 2022 15:34:53 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440126.694252; Tue, 08 Nov 2022 15:34:53 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQcn-0003Xi-8e; Tue, 08 Nov 2022 15:34:53 +0000 Received: by outflank-mailman (input) for mailman id 440126; Tue, 08 Nov 2022 15:34:51 +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 1osQcl-0001RY-Gs for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:51 +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 e0ef84aa-5f7a-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:34:49 +0100 (CET) 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: e0ef84aa-5f7a-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921689; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=8ZXiX9ItGs2cbrZyrTgiP7zufiQzcqMjhU4Bz6aA7bo=; b=QCdChhoGm43hsmE+1+edlUuHhyNoKL7Rgghp7jpV/rATFoOk4ckvePYu j/unOBHLxXr/ghnpIGfOggmcS4yATolVulgSSn7URVVn+ASJCeZyGs5RR 9X37WRB1dsz6feCU76wItMEcuU247pmf0pU0s2ml7RUIE0ZFB8st28F9O s=; Authentication-Results: esa2.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 84416530 X-Ironport-Server: esa2.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:QJrAg68xziy/qLbiSl7tDrUDjH6TJUtcMsCJ2f8bNWPcYEJGY0x3y mtKWG6HPa6KajCjeYx0PYq28E5X6pWDytdrS1Nuq388E34SpcT7XtnIdU2Y0wF+jCHgZBk+s 5hBMImowOQcFCK0SsKFa+C5xZVE/fjUAOG6UKucYHsZqTZMEE8JkQhkl/MynrlmiN24BxLlk d7pqojUNUTNNwRcawr40Ire7kIx1BjOkGlA5AZnPKgb5AW2e0Q9V/rzG4ngdxMUfaEMdgKKb 76r5K20+Grf4yAsBruN+losWhRXKlJ6FVHmZkt+A8BOsDAbzsAB+v9T2M4nQVVWk120c+VZk 72hg3ASpTABZcUgkMxFO/VR/roX0aduoNcrKlDn2SCfItGvn9IBDJyCAWlvVbD09NqbDklRq dkbdBsWfiu8iuSU7p2nUPs1uO08eZyD0IM34hmMzBncBPciB5vCX7/L9ZlT2zJYasJmRKiEI ZBDMHw2MUqGM0Yn1lQ/UfrSmM+limf+dXtEr0iSpoI84nTJzRw327/oWDbQUozWGZwLwx3Az o7A12vHJD8/bP+89WuMzVaLhM/KpXzxZJ1HQdVU8dY12QbOlwT/EiY+Sl+TsfS/zEmkVLp3O 0ESvyYjs6U23EiqVcXmGQ21pmaeuRwRUMYWFPc1gCmtx6zO8kCmD24LZjdbbZots8pebTAjy FKhhd7iAj1r9rqPRhqgGqy89G3of3JPdClbOHFCHVBtD8TfTJ8bkU7qTYpIC76OsdDzOx/f3 yqY9RYXmOBG5SIU7JmT8VfCijOqg5HGSA8p+wnaNl6YAhNFiJ2NPNLxtwWChRpUBMPAFwTa4 iBY8ySLxLpWZaxhghBhVwnk8FuBw/+eeAPRjld0d3XK32T8oiXzFWy8DdwXGauIDirmUWW3C KMwkVkLjHO2AJdNRf4fXm5JI552pZUM7Py8Ph0UB/IXCnSLSCeJ/Tt1eWmb1H33nU4nnMkXY MnFLpbwUy9CUf45nFJaotvxNpdymEgDKZ77H8inn3xLL5LCDJJqdVv1GATXNb1ohE91iA7U7 8xeJ6O3J+Z3CYXDj+i+2dB7EG3m2lBiVM2p8ZcMLr7aSuekcUl4Y8LsLXoaU9QNt8xoei3gp xlRhmcwJILDuED6 IronPort-HdrOrdr: A9a23:H+TIP6HUiUxyFGElpLqE0MeALOsnbusQ8zAXP0AYc3Jom6uj5r mTdZUgpHnJYVkqOE3I9ertBEDEewK4yXcX2/h3AV7BZniEhILAFugLhuGO/9SjIVybygc079 YZT0EUMrzN5DZB4voSmDPIceod/A== X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="84416530" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 08/15] tools/ocaml/libs/evtchn: add xenevtchn_fdopen bindings Date: Tue, 8 Nov 2022 15:34:00 +0000 Message-ID: <3e7f15778ffb5d5d7adde8567c4d50197607f7b2.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 Signed-off-by: Edwin Török Signed-off-by: Edwin Török > Acked-by: Christian Lindig > --- Reason for inclusion in 4.17: - needed for a bugfix in a followup commit Changes since v2: - new in v3 --- tools/ocaml/libs/eventchn/xeneventchn.ml | 6 +++- tools/ocaml/libs/eventchn/xeneventchn.mli | 9 +++++- tools/ocaml/libs/eventchn/xeneventchn_stubs.c | 28 +++++++++++++++++-- 3 files changed, 38 insertions(+), 5 deletions(-) diff --git a/tools/ocaml/libs/eventchn/xeneventchn.ml b/tools/ocaml/libs/eventchn/xeneventchn.ml index dd00a1f0ea..34f7391f5e 100644 --- a/tools/ocaml/libs/eventchn/xeneventchn.ml +++ b/tools/ocaml/libs/eventchn/xeneventchn.ml @@ -16,7 +16,11 @@ type handle -external init: unit -> handle = "stub_eventchn_init" +external init_cloexec: bool -> handle = "stub_eventchn_init" + +let init ?(cloexec=true) () = init_cloexec cloexec + +external fdopen: Unix.file_descr -> handle = "stub_eventchn_fdopen" external fd: handle -> Unix.file_descr = "stub_eventchn_fd" type t = int diff --git a/tools/ocaml/libs/eventchn/xeneventchn.mli b/tools/ocaml/libs/eventchn/xeneventchn.mli index 08c7337643..3965b29621 100644 --- a/tools/ocaml/libs/eventchn/xeneventchn.mli +++ b/tools/ocaml/libs/eventchn/xeneventchn.mli @@ -43,7 +43,14 @@ val to_int: t -> int val of_int: int -> t -val init: unit -> handle +val init: ?cloexec:bool -> unit -> handle +(** [init ?cloexec ()] + Return an initialised event channel interface. + The default is to close the underlying file descriptor + on [execve], which can be overriden with [~cloexec:false]. + On error it will throw a Failure exception. *) + +val fdopen: Unix.file_descr -> handle (** Return an initialised event channel interface. On error it will throw a Failure exception. *) diff --git a/tools/ocaml/libs/eventchn/xeneventchn_stubs.c b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c index 2263c4caa1..92092ca31e 100644 --- a/tools/ocaml/libs/eventchn/xeneventchn_stubs.c +++ b/tools/ocaml/libs/eventchn/xeneventchn_stubs.c @@ -58,14 +58,36 @@ static struct custom_operations xenevtchn_ops = { custom_compare_ext_default /* raises Failure */ }; -CAMLprim value stub_eventchn_init(void) +CAMLprim value stub_eventchn_init(value cloexec) { - CAMLparam0(); + CAMLparam1(cloexec); CAMLlocal1(result); xenevtchn_handle *xce; caml_enter_blocking_section(); - xce = xenevtchn_open(NULL, 0); + xce = xenevtchn_open(NULL, Bool_val(cloexec) ? 0 : XENEVTCHN_NO_CLOEXEC); + caml_leave_blocking_section(); + + if ( xce == NULL ) + caml_failwith("open failed"); + + /* contains file descriptors, trigger full GC at least every 128 + * allocations + */ + result = caml_alloc_custom(&xenevtchn_ops, sizeof(xce), 0, 1); + _H(result) = xce; + CAMLreturn(result); +} + +CAMLprim value stub_eventchn_fdopen(value fdval) +{ + CAMLparam1(fdval); + CAMLlocal1(result); + xenevtchn_handle *xce; + + caml_enter_blocking_section(); + /* having any flags here would raise EINVAL */ + xce = xenevtchn_fdopen(NULL, Int_val(fdval), 0); caml_leave_blocking_section(); if (xce == NULL) From patchwork Tue Nov 8 15:34:01 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036479 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 36166C4332F for ; Tue, 8 Nov 2022 15:35:02 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440125.694246 (Exim 4.92) (envelope-from ) id 1osQcm-0003Tk-UK; Tue, 08 Nov 2022 15:34:52 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440125.694246; Tue, 08 Nov 2022 15:34:52 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQcm-0003TY-Ql; Tue, 08 Nov 2022 15:34:52 +0000 Received: by outflank-mailman (input) for mailman id 440125; Tue, 08 Nov 2022 15:34:51 +0000 Received: from se1-gles-flk1-in.inumbo.com ([94.247.172.50] helo=se1-gles-flk1.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQcl-0003Q1-Gs for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:34:51 +0000 Received: from esa3.hc3370-68.iphmx.com (esa3.hc3370-68.iphmx.com [216.71.145.155]) by se1-gles-flk1.inumbo.com (Halon) with ESMTPS id e0a8562e-5f7a-11ed-8fd1-01056ac49cbb; Tue, 08 Nov 2022 16:34:49 +0100 (CET) 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: e0a8562e-5f7a-11ed-8fd1-01056ac49cbb DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921689; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=MEdqPuuz28JG9GUY0dslF3e+ZAUQoxJNc/yTLkjgR6E=; b=Rfne7eT985xPq10+c1Qb7a3QG19ihq9dOcXIFChprs6W5jgvv8ljqePs TLAqbi54kvfgxJBQAMew6zVTYLPNVwW95AEWg0rOX4clrrOpg7+DMZ5vV EYBi5zV/3T1voRSwmyumoim4IUrad/bEPV9PybeIPo+0/2PPtju3cVyMs 8=; Authentication-Results: esa3.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 84398280 X-Ironport-Server: esa3.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:vKRODK1dnOG9ENnkuPbD5d9xkn2cJEfYwER7XKvMYLTBsI5bpz0Bz TFMXjyBa/3ZYjP9fY8iOt+woEsHu8XUy9YyHVRvpC1hF35El5HIVI+TRqvS04F+DeWYFR46s J9OAjXkBJppJpMJjk71atANlVEliefTAOK5ULSfUsxIbVcMYD87jh5+kPIOjIdtgNyoayuAo tq3qMDEULOf82cc3lk8tuTS9nuDgNyo4GlC5wVmNagR1LPjvyJ94Kw3dPnZw0TQGuG4LsbiL 87fwbew+H/u/htFIrtJRZ6iLyXm6paLVeS/oiI+t5qK23CulQRrukoPD9IOaF8/ttm8t4sZJ OOhF3CHYVxB0qXkwIzxWvTDes10FfUuFLTveRBTvSEPpqFvnrSFL/hGVSkL0YMkFulfWzpM/ uUfCGk3SR252O+3/aCcd/JIr5F2RCXrFNt3VnBIyDjYCbAtQIzZQrWM7thdtNsyrpkQR7CEP ZNfMGcxKkSbC/FMEg5/5JYWkeu2h3+5bzpCr1G9rqsr+WnDigd21dABNfKFJofbFZ8Fxi50o Erm2nrDBjghEOCTiiOK6lj0q9XWxyP0Ddd6+LqQqacx3Qz7KnYoIBEfS1aTu/SyjU+6HdVFJ CQ85S4GvaU0skuxQbHVTxC+5XKJoBMYc95RCPEhrhGAzLLO5ASUDXRCSSROAPQGucksVHoV3 1mGt9rzAHpkt7j9dJ6G3u7K93XoY3FTdDJcI39fJecY3zX9iNtojBnWSfY6Kom4tIL4GAzi5 A2RiAFr0t3/kvU3/6m8+FnGhRelqZ7IUhM5623rY4610u9qTNX7PtL1sDA3+d4Fdd/EFQfZ4 BDojuDEtIgz4YexeDthqQnnNJWg/L67PTLVmjaD9LFxpm32qxZPkW29iQySxXuF0O5eJ1cFg 2eJ42u9AaO/21P7BZKbm6rrV6wXIVHITLwIlpn8N7KimKRZeg6d5z1JbkWNxW3rm0VEufhhZ 8jLLZj1VS5AV/QPIN+KqwA1iOFD+8zD7TmLGcCTI+qPjdJym0J5uZ9aaQDTP4jVHYuPoRnP8 sY3Cid540w3bQA/CwGJmbMuwacidClmWsqt8JQHL4Zu4GNOQQkcNhMY+pt5E6QNokifvr2gE q2VMqOA9GfCuA== IronPort-HdrOrdr: A9a23:KH2ZaqiFfTwXU2d031bvkwKXM3BQXuIji2hC6mlwRA09TySZ// rBoB19726MtN9xYgBHpTnuAsm9qB/nmaKdpLNhWItKPzOW31dATrsSjrcKqgeIc0aVm9K1l5 0QF5SWYOeAdWSS5vya3ODXKbkdKaG8gcKVuds= X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="84398280" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 09/15] tools/ocaml/xenstored/store.ml: fix build error Date: Tue, 8 Nov 2022 15:34:01 +0000 Message-ID: <09afc07ba0ba65afc02028bd6b4950d8e51af69b.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 Building with Dune in release mode fails with: ``` File "ocaml/xenstored/store.ml", line 464, characters 13-32: Warning 18: this type-based record disambiguation is not principal. File "ocaml/xenstored/store.ml", line 1: Error: Some fatal warnings were triggered (1 occurrences) ``` This is a warning to help keep the code futureproof, quoting from its documentation: > Check information path during type-checking, to make sure that all types are > derived in a principal way. When using labelled arguments and/or polymorphic > methods, this flag is required to ensure future versions of the compiler will > be able to infer types correctly, even if internal algorithms change. All > programs accepted in -principal mode are also accepted in the default mode with > equivalent types, but different binary signatures, and this may slow down type > checking; yet it is a good idea to use it once before publishing source code. Fixes: db471408edd46 "tools/ocaml/xenstored: Fix quota bypass on domain shutdown" Signed-off-by: Edwin Török Signed-off-by: Edwin Török > Acked-by: Christian Lindig > --- Reason for inclusion in 4.17: - fixes a build error in a previous commit that is already in master Changes since v2: - new in v3 --- tools/ocaml/xenstored/store.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml index 14ec404988..38a4945372 100644 --- a/tools/ocaml/xenstored/store.ml +++ b/tools/ocaml/xenstored/store.ml @@ -461,7 +461,7 @@ let reset_permissions store domid = | Some perms -> if perms <> node.perms then Logging.debug "store|node" "Changed permissions for node %s" (Node.get_name node); - Some { node with perms } + Some { node with Node.perms } ) store.root type ops = { From patchwork Tue Nov 8 15:34:02 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036484 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id EDDB0C433FE for ; Tue, 8 Nov 2022 15:39:59 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440166.694323 (Exim 4.92) (envelope-from ) id 1osQhb-000098-V1; Tue, 08 Nov 2022 15:39:51 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440166.694323; Tue, 08 Nov 2022 15:39:51 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQhb-00008s-Qs; Tue, 08 Nov 2022 15:39:51 +0000 Received: by outflank-mailman (input) for mailman id 440166; Tue, 08 Nov 2022 15:39:50 +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 1osQhZ-0007Fx-Tg for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:39:50 +0000 Received: from esa4.hc3370-68.iphmx.com (esa4.hc3370-68.iphmx.com [216.71.155.144]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id 93b83a42-5f7b-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:39:48 +0100 (CET) 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: 93b83a42-5f7b-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921988; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=buzE9ePYEDLC+F92TEeWnEnqUW11FTaxYumtDUDu/aE=; b=UYS14wTsgvW/RfheV6UQLyr3NozmQ6b2CO/VPrcR6eEoikZaK0nDs13+ cRpGSt5Fcrd6BK9L1jgWSL1oD7nQIVkqo7oOi9t/uSMKmiFntpa/6PZcy BJ3yCFOiF4ljbtN0PxS5/pWR0vROD326FmMPmjfDLJPZIN2givlltQXyl 4=; Authentication-Results: esa4.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 86935397 X-Ironport-Server: esa4.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:ozS7OKi+0ZyiXbU8r9SIKVtVX161bBAKZh0ujC45NGQN5FlHY01je htvUTiAPKuCY2D3f94gYdmy90wBucfXndMxSFdqqC82Rigb9cadCdqndUqhZCn6wu8v7q5Ex 55HNoSfdpBcolv0/ErF3m3J9CEkvU2wbuOgTrWCYmUpH1QMpB4J0XpLg/Q+jpNjne+3CgaMv cKai8DEMRqu1iUc3lg8sspvkzsy+qWs0N8klgZmP6oS5QeOzyN94K83fsldEVOpGuG4IcbiL wrz5OnR1n/U+R4rFuSknt7TGqHdauePVeQmoiM+t5mK2nCulARrukoIHKN0hXNsoyeIh7hMJ OBl7vRcf+uL0prkw4zxWzEAe8130DYvFLXveRBTuuTLp6HKnueFL1yDwyjaMKVBktubD12i+ tQyDCofTD+Fo9m1g72UVvNTuuIyI5fkadZ3VnFIlVk1DN4jSJHHBa7L+cVZzHE7gcUm8fT2P pRDL2A1NVKZPkMJagx/5JEWxY9EglHyfyNZrhSJorAw4EDYzRBr0airO93QEjCPbZULzx3F/ TOZl4j/KiEZa/zP+TC9yHm1rPXkvXnGRtMbG7Lto5aGh3XMnzdOWXX6T2CTrfCnh2akVtlYK khS/TAhxYAt8GS7Q9+7WAe3yFaUsxhZV9dOHukS7ACW1rGS8wufHnIDTDNKdJohrsBebRwn0 EWY2ezgAzNHuaeQD3ma89+pQSiaYHZPazVYPGldEFVDs4KLTJwPYgznZPJ5AoyaiPnOGnL/7 CyQkxQYlrpNgptev0mkxmzvjzWpr5nPawc64ATLQ26ohj9EiJ6Zi5+AsgaCs6sZRGqNZhzY5 SVfxZDChAwbJcvV/BFhVtnhC11ACxytFDTHyWBiEJA6n9hG0y7yJNsAiN2SyaoADyrlRdMLS BWN0e+yzMUJVJdPUUOQS9PZNijS5fK8fekJr9iNBjeOC7AoHON9wAlgZFSLw0fmm1U2nKc0N P+zKJjyUiZGV/0/lGDoF4/xNIPHIQhnmwvuqW3TlUz7gdJymlbJIVv6DLd+Rr9gt/7VyOkk2 91eK9GL231ivB7WO0HqHE96BQ5iEEXX8riv+pEILLXYelo/cIzjYteIqY4cl0Vet/w9vo/1E ruVASe0FHKXaaX7FDi3 IronPort-HdrOrdr: A9a23:LLMWWKp+zp4ZbGFS6aj+SJIaV5oReYIsimQD101hICG8cqSj9v xG+85rrSMc6QxhIU3I9urwW5VoLUmyyXcx2/h0AV7AZniBhILLFvAB0WKK+VSJcEeSmtK1l5 0QFJSWYOeAdmSS5vyb3ODXKbgdKaG8gcWVuds= X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="86935397" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 10/15] tools/ocaml/xenstored: keep eventchn FD open across live update Date: Tue, 8 Nov 2022 15:34:02 +0000 Message-ID: <17575704fceda409bd5bb0056a94664ddc3ac2e1.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 It has been discovered that the Windows PV drivers rebind their local port of the xenstore evtchn post migrate, which changes the eventchn port from e.g. the default of 3 (nVCPUs+1) to 1 without oxenstored knowing about it. And oxenstored goes and tries to rebind port 3, which is already in use by something else. The guest also writes to HVMPARAM, however there is a race condition between it resetting the eventchn port and writing to HVMPARAM, thus it is not possible to atomically obtain the guest's eventchn port for xenstore. It is possible to recover such a guest manually from a failed live update by running introduceDomain from Dom0 with the correct port number obtain using 'xen-vmdebug hvmparam'. There is also a small race condition window between closing the evtchn FD and reopening it where guest drivers would get an unbound evtchn port error from Xen when trying to talk to xenstore during live update. Avoid this by trying to keep the eventchn file descriptor open across live updates, using the new xenevtchn_fdopen API, similar to how C xenstored works. However an old enough oxenstored won't have kept the evtchn fd open and won't have saved it in the update stream, so handle that case by reopening the evtchn as a fallback. A followup commit will avoid rebind the guest remote port (we cannot rely on the remote port staying the same, e.g. the windows PV drivers change it) Signed-off-by: Edwin Török Acked-by: Christian Lindig --- Reason for inclusion in 4.17: - fixes live update in oxenstored, making future security updates easier if the base code already has this patch Changes since v2: - new in v3 --- tools/ocaml/xenstored/domains.ml | 1 + tools/ocaml/xenstored/event.ml | 7 ++- tools/ocaml/xenstored/xenstored.ml | 71 +++++++++++++++++++++--------- 3 files changed, 56 insertions(+), 23 deletions(-) diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domains.ml index a36b531663..d5c452d26c 100644 --- a/tools/ocaml/xenstored/domains.ml +++ b/tools/ocaml/xenstored/domains.ml @@ -56,6 +56,7 @@ let exist doms id = Hashtbl.mem doms.table id let find doms id = Hashtbl.find doms.table id let number doms = Hashtbl.length doms.table let iter doms fct = Hashtbl.iter (fun _ b -> fct b) doms.table +let eventchn doms = doms.eventchn let rec is_empty_queue q = Queue.is_empty q || diff --git a/tools/ocaml/xenstored/event.ml b/tools/ocaml/xenstored/event.ml index b10027f004..190ca6fcbf 100644 --- a/tools/ocaml/xenstored/event.ml +++ b/tools/ocaml/xenstored/event.ml @@ -20,7 +20,12 @@ type t = { mutable virq_port: Xeneventchn.t option; } -let init () = { handle = Xeneventchn.init (); virq_port = None; } +let init ?fd () = + let handle = match fd with + | None -> Xeneventchn.init ~cloexec:false () + | Some fd -> Xeneventchn.fdopen fd + in + { handle; virq_port = None } let fd eventchn = Xeneventchn.fd eventchn.handle let bind_dom_exc_virq eventchn = eventchn.virq_port <- Some (Xeneventchn.bind_dom_exc_virq eventchn.handle) let bind_interdomain eventchn domid port = Xeneventchn.bind_interdomain eventchn.handle domid port diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml index 34612814e1..cdd5b5ac67 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -144,7 +144,7 @@ module DB = struct let dump_format_header = "$xenstored-dump-format" - let from_channel_f chan global_f socket_f domain_f watch_f store_f = + let from_channel_f chan global_f event_f socket_f domain_f watch_f store_f = let unhexify s = Utils.unhexify s in let getpath s = let u = Utils.unhexify s in @@ -165,6 +165,8 @@ module DB = struct (* there might be more parameters here, e.g. a RO socket from a previous version: ignore it *) global_f ~rw + | "eventchnfd" :: eventfd :: [] -> + event_f ~eventfd | "socket" :: fd :: [] -> socket_f ~fd:(int_of_string fd) | "dom" :: domid :: mfn :: port :: []-> @@ -189,10 +191,27 @@ module DB = struct done; info "Completed loading xenstore dump" - let from_channel store cons doms chan = + let from_channel store cons createdoms chan = (* don't let the permission get on our way, full perm ! *) let op = Store.get_ops store Perms.Connection.full_rights in let rwro = ref (None) in + let eventchnfd = ref (None) in + let doms = ref (None) in + + let require_doms () = + match !doms with + | None -> + let missing_eventchnfd = !eventchnfd = None in + if missing_eventchnfd then + warn "No event channel file descriptor available in dump!"; + let eventchn = Event.init ?fd:!eventchnfd () in + let domains = createdoms eventchn in + if missing_eventchnfd then + Event.bind_dom_exc_virq eventchn; + doms := Some domains; + domains + | Some d -> d + in let global_f ~rw = let get_listen_sock sockfd = let fd = sockfd |> int_of_string |> Utils.FD.of_int in @@ -201,6 +220,10 @@ module DB = struct in rwro := get_listen_sock rw in + let event_f ~eventfd = + let fd = eventfd |> int_of_string |> Utils.FD.of_int in + eventchnfd := Some fd + in let socket_f ~fd = let ufd = Utils.FD.of_int fd in let is_valid = try (Unix.fstat ufd).Unix.st_kind = Unix.S_SOCK with _ -> false in @@ -210,6 +233,7 @@ module DB = struct warn "Ignoring invalid socket FD %d" fd in let domain_f domid mfn port = + let doms = require_doms () in let ndom = if domid > 0 then Domains.create doms domid mfn port @@ -229,8 +253,8 @@ module DB = struct 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 + from_channel_f chan global_f event_f socket_f domain_f watch_f store_f; + !rwro, require_doms () let from_file store cons doms file = info "Loading xenstore dump from %s" file; @@ -238,7 +262,7 @@ module DB = struct finally (fun () -> from_channel store doms cons channel) (fun () -> close_in channel) - let to_channel store cons rw chan = + let to_channel store cons (rw, eventchn) chan = let hexify s = Utils.hexify s in fprintf chan "%s\n" dump_format_header; @@ -247,6 +271,7 @@ module DB = struct Unix.clear_close_on_exec fd; Utils.FD.to_int fd in fprintf chan "global,%d\n" (fdopt rw); + fprintf chan "eventchnfd,%d\n" (Utils.FD.to_int @@ Event.fd eventchn); (* dump connections related to domains: domid, mfn, eventchn port/ sockets, and watches *) Connections.iter cons (fun con -> Connection.dump con chan); @@ -367,7 +392,6 @@ let _ = | None -> () end; let store = Store.create () in - let eventchn = Event.init () in let next_frequent_ops = ref 0. in let advance_next_frequent_ops () = next_frequent_ops := (Unix.gettimeofday () +. !Define.conflict_max_history_seconds) @@ -375,16 +399,8 @@ let _ = let delay_next_frequent_ops_by duration = next_frequent_ops := !next_frequent_ops +. duration in - let domains = Domains.init eventchn advance_next_frequent_ops in + let domains eventchn = Domains.init eventchn advance_next_frequent_ops in - (* For things that need to be done periodically but more often - * than the periodic_ops function *) - let frequent_ops () = - if Unix.gettimeofday () > !next_frequent_ops then ( - History.trim (); - Domains.incr_conflict_credit domains; - advance_next_frequent_ops () - ) in let cons = Connections.create () in let quit = ref false in @@ -393,15 +409,15 @@ let _ = List.iter (fun path -> Store.write store Perms.Connection.full_rights path "") Store.Path.specials; - let rw_sock = + let rw_sock, domains = if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( - let rwro = DB.from_file store domains cons Disk.xs_daemon_database in + let rw, domains = 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 + rw, domains ) else ( info "No live reload: regular startup"; + let domains = domains @@ Event.init () in if !Disk.enable then ( info "reading store from disk"; Disk.read store @@ -411,11 +427,21 @@ let _ = if not (Store.path_exists store localpath) then Store.mkdir store (Perms.Connection.create 0) localpath; + let eventchn = Event.init () in if cf.domain_init then ( Connections.add_domain cons (Domains.create0 domains); Event.bind_dom_exc_virq eventchn ); - rw_sock + rw_sock, domains + ) in + + (* For things that need to be done periodically but more often + * than the periodic_ops function *) + let frequent_ops () = + if Unix.gettimeofday () > !next_frequent_ops then ( + History.trim (); + Domains.incr_conflict_credit domains; + advance_next_frequent_ops () ) in (* required for xenstore-control to detect availability of live-update *) @@ -433,10 +459,11 @@ let _ = Sys.set_signal Sys.sigpipe Sys.Signal_ignore; if cf.activate_access_log then begin - let post_rotate () = DB.to_file store cons (None) Disk.xs_daemon_database in + let post_rotate () = DB.to_file store cons (None, Domains.eventchn domains) Disk.xs_daemon_database in Logging.init_access_log post_rotate end; + let eventchn = Domains.eventchn domains in let spec_fds = (match rw_sock with None -> [] | Some x -> [ x ]) @ (if cf.domain_init then [ Event.fd eventchn ] else []) @@ -594,7 +621,7 @@ let _ = live_update := Process.LiveUpdate.should_run cons; if !live_update || !quit then begin (* don't initiate live update if saving state fails *) - DB.to_file store cons (rw_sock) Disk.xs_daemon_database; + DB.to_file store cons (rw_sock, eventchn) Disk.xs_daemon_database; quit := true; end with exc -> From patchwork Tue Nov 8 15:34:03 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036482 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 9B16EC433FE for ; Tue, 8 Nov 2022 15:39:52 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440163.694290 (Exim 4.92) (envelope-from ) id 1osQhS-0007Xr-VO; Tue, 08 Nov 2022 15:39:42 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440163.694290; Tue, 08 Nov 2022 15:39:42 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQhS-0007Xg-Rg; Tue, 08 Nov 2022 15:39:42 +0000 Received: by outflank-mailman (input) for mailman id 440163; Tue, 08 Nov 2022 15:39:41 +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 1osQhR-0007Fx-Kr for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:39:41 +0000 Received: from esa3.hc3370-68.iphmx.com (esa3.hc3370-68.iphmx.com [216.71.145.155]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id 8dd69aaf-5f7b-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:39:40 +0100 (CET) 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: 8dd69aaf-5f7b-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921980; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=MmumC61ho15DndrHDcqanqMqkMI1LHqlie4LwBB5is0=; b=EK2C/i+u0+btJIOV2JQqFc7r35+r3X58Hjvapob6+gGoQd6QkQxKAgJV /oWGOL7/HGt4Pcovpy2fTmj00ykH2Jf55PrF66F2MYAABS90KtAj4+SMf rSWT60/cCXg6C3BIfLlLT3tNcxypl80W7ZMBLXAA/1VfttjPOtYlpgb6i E=; Authentication-Results: esa3.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 84398664 X-Ironport-Server: esa3.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:tas1CaIGkPgQGR05FE+R3ZUlxSXFcZb7ZxGr2PjKsXjdYENShmEBy TRMDTrQP/3cZGr3ct5xPd7loB8OsJ+Am9RrTQBlqX01Q3x08seUXt7xwmUcnc+xBpaaEB84t ZV2hv3odp1coqr0/0/1WlTZhSAgk/rOHv+kUrWs1hlZHWdMUD0mhQ9oh9k3i4tphcnRKw6Ws Jb5rta31GWNglaYCUpJrfPdwP9TlK6q4mlB5wRuPaojUGL2zBH5MrpOfcldEFOgKmVkNrbSb /rOyri/4lTY838FYj9yuu+mGqGiaue60Tmm0hK6aYD76vRxjnVaPpIAHOgdcS9qZwChxLid/ jnvWauYEm/FNoWU8AgUvoIx/ytWZcWq85efSZSzXFD6I+QrvBIAzt03ZHzaM7H09c52OWty9 +QELwwBbyvSi7yo75Cie+xj05FLwMnDZOvzu1llxDDdS/0nXYrCU+PB4towMDUY354UW6yEP oxANGQpPE+ojx5nYz/7DLozkPmpgD/jdCdfq3qepLYt4niVxwt0uFToGIqJIY3aG5sJ9qqej jyYuHbTXy03DYa01SSq4G2mm92VpCyuDer+E5Xnr6U30TV/3Fc7BBQIWHOhrPK+i0r4XMhQQ 2QL/gI+oK5081akJvHtUhv9rHOasxo0X9tLD/Z8+AyL0rDT4QuSGi4DVDEpQPwrstUnAwMj0 FChlsnsQzdotdWopWm1r+nO62noYG5McDFENXRsoRY5D8fLobk5shDXUtFfHK+O39GrBx7S2 gGPo31r71kMtvIj26K+9FHBpjujoJnVUwI4jjnqsnKZAhBRP9D8OdHxgbTPxbMZddvCEAHd1 JQRs5LGhN3iG61hg8BkrA8lOLiyr8iIPzTH6bKEN8lwrm/9k5JPkG053d2fGKuLGpxaEdMKS BWJ0e+02HO0FCrCUEOPS9jtY/nGNIC5fTklP9iNBja0XrB/dRWc4AZlblOK0mbmnSAEyP9hZ sfHL5/0VSxEWcyLKQZaoM9Ej9cWKt0WnzuPFfgXMTz7uVZhWJJlYehcawbfBgzIxKiFvB/U4 75i2ziikn1ivSyXSne/zLP/2nhTfCVkX8ut85wOHgNBSyI/cFwc5zbq6etJU+RYc259zI8kI lnVtpdk9WfC IronPort-HdrOrdr: A9a23:6bKEcKqAQOq+VSc39qigHrIaV5oReYIsimQD101hICG8cqSj9v xG+85rrSMc6QxhIU3I9urwW5VoLUmyyXcx2/h0AV7AZniBhILLFvAB0WKK+VSJcEeSmtK1l5 0QFJSWYOeAdmSS5vyb3ODXKbgdKaG8gcWVuds= X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="84398664" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 11/15] tools/ocaml/xenstored: do not rebind event channels after live update Date: Tue, 8 Nov 2022 15:34:03 +0000 Message-ID: <003537c5db4682b9a5f632d61cb15b332e0778bf.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 See explanation in previous commit. This introduces a new field into the live update stream to retain both ports, and handles the missing value in a backward compatible way. Signed-off-by: Edwin Török --- Reason for inclusion 4.17: - fixes a bug in oxenstored live update, needed to make live updates with future 4.17 security fixes possible/more reliable Changes since v2: - new in v3 --- tools/ocaml/libs/eventchn/xeneventchn.ml | 5 +++++ tools/ocaml/libs/eventchn/xeneventchn.mli | 5 +++++ tools/ocaml/xenstored/domain.ml | 6 +++++- tools/ocaml/xenstored/domains.ml | 13 +++++++++---- tools/ocaml/xenstored/event.ml | 1 + tools/ocaml/xenstored/xenstored.ml | 11 +++++++---- 6 files changed, 32 insertions(+), 9 deletions(-) diff --git a/tools/ocaml/libs/eventchn/xeneventchn.ml b/tools/ocaml/libs/eventchn/xeneventchn.ml index 34f7391f5e..7ccf7a99f0 100644 --- a/tools/ocaml/libs/eventchn/xeneventchn.ml +++ b/tools/ocaml/libs/eventchn/xeneventchn.ml @@ -43,6 +43,11 @@ type virq_t = external notify: handle -> int -> unit = "stub_eventchn_notify" external bind_interdomain: handle -> int -> int -> int = "stub_eventchn_bind_interdomain" + +let restore_interdomain handle _domid _remote_port local_port = + notify handle local_port; + local_port + external bind_virq: handle -> virq_t -> int = "stub_eventchn_bind_virq" let bind_dom_exc_virq handle = bind_virq handle Dom_exc external unbind: handle -> int -> unit = "stub_eventchn_unbind" diff --git a/tools/ocaml/libs/eventchn/xeneventchn.mli b/tools/ocaml/libs/eventchn/xeneventchn.mli index 3965b29621..7407031b9e 100644 --- a/tools/ocaml/libs/eventchn/xeneventchn.mli +++ b/tools/ocaml/libs/eventchn/xeneventchn.mli @@ -68,6 +68,11 @@ val bind_interdomain : handle -> int -> int -> t channel connected to domid:remote_port. On error it will throw a Failure exception. *) +val restore_interdomain : handle -> int -> int -> int -> t +(** [restore_interdomain h domid remote_port local_port] returns a local event + channel connected to domid:remote_port. On error it will + throw a Failure exception. *) + val bind_dom_exc_virq : handle -> t (** Binds a local event channel to the VIRQ_DOM_EXC (domain exception VIRQ). On error it will throw a Failure diff --git a/tools/ocaml/xenstored/domain.ml b/tools/ocaml/xenstored/domain.ml index 4e62a48e8e..5dad298614 100644 --- a/tools/ocaml/xenstored/domain.ml +++ b/tools/ocaml/xenstored/domain.ml @@ -61,7 +61,7 @@ let string_of_port = function | Some x -> string_of_int (Xeneventchn.to_int x) let dump d chan = - fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.remote_port + fprintf chan "dom,%d,%nd,%d,%s\n" d.id d.mfn d.remote_port (string_of_port d.port) let notify dom = match dom.port with | None -> @@ -77,6 +77,10 @@ let bind_interdomain dom = dom.port <- Some (Event.bind_interdomain dom.eventchn dom.id dom.remote_port); debug "bound domain %d remote port %d to local port %s" dom.id dom.remote_port (string_of_port dom.port) +let restore_interdomain dom localport = + assert (dom.port = None); + dom.port <- Some (Event.restore_interdomain dom.eventchn dom.id dom.remote_port localport); + debug "restored interdomain %d remote port %d to local port %s" dom.id dom.remote_port (string_of_port dom.port) let close dom = debug "domain %d unbound port %s" dom.id (string_of_port dom.port); diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domains.ml index d5c452d26c..af9fecf2f7 100644 --- a/tools/ocaml/xenstored/domains.ml +++ b/tools/ocaml/xenstored/domains.ml @@ -123,17 +123,22 @@ let cleanup doms = let resume _doms _domid = () -let create doms domid mfn port = +let maybe_bind_interdomain restore_localport dom = + match restore_localport with + | None -> Domain.bind_interdomain dom + | Some p -> Domain.restore_interdomain dom p + +let create doms domid mfn ?restore_localport port = let interface = Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize()) mfn in let dom = Domain.make domid mfn port interface doms.eventchn in Hashtbl.add doms.table domid dom; - Domain.bind_interdomain dom; + maybe_bind_interdomain restore_localport dom; dom let xenstored_kva = ref "" let xenstored_port = ref "" -let create0 doms = +let create0 ?restore_localport doms = let port, interface = ( let port = Utils.read_file_single_integer !xenstored_port @@ -147,7 +152,7 @@ let create0 doms = in let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in Hashtbl.add doms.table 0 dom; - Domain.bind_interdomain dom; + maybe_bind_interdomain restore_localport dom; Domain.notify dom; dom diff --git a/tools/ocaml/xenstored/event.ml b/tools/ocaml/xenstored/event.ml index 190ca6fcbf..3debe8731d 100644 --- a/tools/ocaml/xenstored/event.ml +++ b/tools/ocaml/xenstored/event.ml @@ -29,6 +29,7 @@ let init ?fd () = let fd eventchn = Xeneventchn.fd eventchn.handle let bind_dom_exc_virq eventchn = eventchn.virq_port <- Some (Xeneventchn.bind_dom_exc_virq eventchn.handle) let bind_interdomain eventchn domid port = Xeneventchn.bind_interdomain eventchn.handle domid port +let restore_interdomain eventchn domid port local_port = Xeneventchn.restore_interdomain eventchn.handle domid port local_port let unbind eventchn port = Xeneventchn.unbind eventchn.handle port let notify eventchn port = Xeneventchn.notify eventchn.handle port let pending eventchn = Xeneventchn.pending eventchn.handle diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml index cdd5b5ac67..d4ff24b440 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -169,10 +169,13 @@ module DB = struct event_f ~eventfd | "socket" :: fd :: [] -> socket_f ~fd:(int_of_string fd) - | "dom" :: domid :: mfn :: port :: []-> + | "dom" :: domid :: mfn :: port :: rest -> domain_f (int_of_string domid) (Nativeint.of_string mfn) (int_of_string port) + (match rest with + | [] -> None (* backward compat: old version didn't have it *) + | localport :: _ -> Some (int_of_string localport)) | "watch" :: domid :: path :: token :: [] -> watch_f (int_of_string domid) (unhexify path) (unhexify token) @@ -232,13 +235,13 @@ module DB = struct else warn "Ignoring invalid socket FD %d" fd in - let domain_f domid mfn port = + let domain_f domid mfn port restore_localport = let doms = require_doms () in let ndom = if domid > 0 then - Domains.create doms domid mfn port + Domains.create doms domid mfn ?restore_localport port else - Domains.create0 doms + Domains.create0 ?restore_localport doms in Connections.add_domain cons ndom; in From patchwork Tue Nov 8 15:34:04 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036483 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id E0990C4332F for ; Tue, 8 Nov 2022 15:39:59 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440164.694301 (Exim 4.92) (envelope-from ) id 1osQhZ-0007xM-7f; Tue, 08 Nov 2022 15:39:49 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440164.694301; Tue, 08 Nov 2022 15:39:49 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQhZ-0007x5-4Q; Tue, 08 Nov 2022 15:39:49 +0000 Received: by outflank-mailman (input) for mailman id 440164; Tue, 08 Nov 2022 15:39:47 +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 1osQhX-0007Fx-E5 for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:39:47 +0000 Received: from esa4.hc3370-68.iphmx.com (esa4.hc3370-68.iphmx.com [216.71.155.144]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id 91702d13-5f7b-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:39:46 +0100 (CET) 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: 91702d13-5f7b-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921986; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=UQCDfSuDGc6oIDdjMFWDCU+FRf1yoH/+ae5j3IlKjWg=; b=cb4uysJXM8hmUWa/EZCf780aMSck0hGU4QeoO8cv1+/62sCKXtLILboG L6IYUWvFW5eWCa4DpClXvG6q/HKdqxesLJFiNGNT8PtdDWPjBFKbnPBOG ib7kPQHvHbGfPLtvjcX+zdnMrOlWdAEASbA8fa3XuC8/MfmDYCEZcfmMu 8=; Authentication-Results: esa4.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 86935395 X-Ironport-Server: esa4.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:34ZUBK2BNTwjMjyOovbD5d9xkn2cJEfYwER7XKvMYLTBsI5bpz0Hz zMdXWqGMqvbamPweYp2bIrn/UpXvsfRzoBiTQtkpC1hF35El5HIVI+TRqvS04F+DeWYFR46s J9OAjXkBJppJpMJjk71atANlVEliefTAOK5ULSfUsxIbVcMYD87jh5+kPIOjIdtgNyoayuAo tq3qMDEULOf82cc3lk8tuTS9nuDgNyo4GlC5wVmNagR1LPjvyJ94Kw3dPnZw0TQGuG4LsbiL 87fwbew+H/u/htFIrtJRZ6iLyXm6paLVeS/oiI+t5qK23CulQRrukoPD9IOaF8/ttm8t4sZJ OOhF3CHYVxB0qXkwIzxWvTDes10FfUuFLTveRBTvSEPpqFvnrSFL/hGVSkL0YMkFulfPDpu0 dsbI2g3V1PS16W6n7XiDbFCiZF2RCXrFNt3VnBIyDjYCbAtQIzZQrWM7thdtNsyrpkQR7CEP ZNfMGcxKkSbC/FMEg5/5JYWkeu2h3+5bzpCr1G9rqsr+WnDigd21dABNfKFJI3RGJ4Ewy50o ErIvF7/LR1BOeXYihTY23mM3N7tpDL0Ddd6+LqQqacx3Qz7KnYoIAISfUu2p7++kEHWc8JSL QkY9zQjqYA29Ve3VZ/tUhugunmGsxUAHd1KHIUSyAyL0LuS3A+fCUANVDsHY9sj3Oc6TCIn/ kWElNToAXpoqrL9dJ6G3u7K93XoY3FTdDJcI39fJecY3zX9iLxorjboTd07Kpf2342yFW73m nfSgidr0t3/kvU3/6m8+FnGhRelqZ7IUhM5623rY4610u9qTNX7PtL1sDA3+d4Fdd/EFQfZ4 BDojuDEtIgz4YexeDthqQnnNJWg/L67PTLVmjaD9LFxpm32qxZPkW29iQySxXuF0O5eJ1cFg 2eJ42u9AaO/21P7BZKbm6rrV6wXIVHITLwIlpn8N7KimKRZeg6d5z1JbkWNxW3rm0VEufhhZ 8jLLZj1VS5AV/QPIN+KqwA1iOFD+8zD7TmLGcCTI+qPjdJym0J5uZ9aaQDTP4jVHYuPoRnP8 sY3Cid540w3bQA/CwGJmbMuwacidClmWsqt8JQHL4Zu4GNOQQkcNhMY+pt5E6QNokifvr2gE q2VMqOA9GfCuA== IronPort-HdrOrdr: A9a23:7SkhmKg8emYRfWRr/q9ESkII+nBQXgoji2hC6mlwRA09TyX4rb HMoB1173XJYVoqNU3I+urhBEDjex3hHPdOiOF7AV7FZmXbUQCTTb2KmrGSoQEIdReQysdtkY 99bqlzD8DxB1Bmgcu/3BO1CL8bsb66GGTCv5am85+rJjsaDZ1I3kNBBgiSLEtsRk1mDZ01EZ b03Lsjm9PaQwVyUviG X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="86935395" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 12/15] tools/ocaml/xenstored: log live update issues at warning level Date: Tue, 8 Nov 2022 15:34:04 +0000 Message-ID: <550a0bc27c19a6d64d43cdee1f8cc3230d6ff55e.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 During live update oxenstored tries a best effort approach to recover as many domains and information as possible even if it encounters errors restoring some domains. This defensive approach has already proven useful to recover domains after a bug in oxenstored. However the default log level is warning, which means that problems during live update were not logged at all, unless you've changes oxenstored.conf prior to live-update. Signed-off-by: Edwin Török Signed-off-by: Edwin Török > Acked-by: Christian Lindig > --- Reason for inclusion in 4.17: - makes live update issues debuggable (live update can be used to apply security updates to 4.17) Changes since v2: - new in v3 --- tools/ocaml/xenstored/xenstored.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml index d4ff24b440..78177b116f 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -184,9 +184,9 @@ module DB = struct (Perms.Node.of_string (unhexify perms ^ "\000")) (unhexify value) | _ -> - info "restoring: ignoring unknown line: %s" line + warn "restoring: ignoring unknown line: %s" line with exn -> - info "restoring: ignoring unknown line: %s (exception: %s)" + warn "restoring: ignoring unknown line: %s (exception: %s)" line (Printexc.to_string exn); () with End_of_file -> From patchwork Tue Nov 8 15:34:05 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036481 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 5A4F4C4332F for ; Tue, 8 Nov 2022 15:39:49 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440162.694279 (Exim 4.92) (envelope-from ) id 1osQhR-0007Gu-M6; Tue, 08 Nov 2022 15:39:41 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440162.694279; Tue, 08 Nov 2022 15:39:41 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQhR-0007Gn-JC; Tue, 08 Nov 2022 15:39:41 +0000 Received: by outflank-mailman (input) for mailman id 440162; Tue, 08 Nov 2022 15:39:40 +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 1osQhQ-0007Fx-Dg for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:39:40 +0000 Received: from esa5.hc3370-68.iphmx.com (esa5.hc3370-68.iphmx.com [216.71.155.168]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id 8d4e3290-5f7b-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:39:39 +0100 (CET) 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: 8d4e3290-5f7b-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921978; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=hQno2BG9QzWV381/kBdkjocEF/Hky2yAxo4hwyxhbW8=; b=JiG3Z1Flq52+kfeCl1udaItI2Lijp/awhDhrsN6iQfsZ03wLHs/mvsYi EupEGgSRKMiz/iMr9hCRP9AUFTQtRQPGVgp/ZYMmEYJ1ExLlJN3+HgUd6 LaMY4hw8vVArcV2hipHLPuLMOeTTdqWeGp/kM1nR3v/n5Awb8Ohm1b6sr c=; Authentication-Results: esa5.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 83478170 X-Ironport-Server: esa5.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:sesTT64v/yz9bk3iZOQfzgxRtDTHchMFZxGqfqrLsTDasY5as4F+v mdLUTrQOPyMN2LxKI1+bIiwp0sE6p6Byd8ySQZkpSo8Hi5G8cbLO4+Ufxz6V8+wwm8vb2o8t plDNYOQRCwQZiWBzvt4GuG59RGQ7YnRGvynTraBYnoqLeNdYH9JoQp5nOIkiZJfj9G8Agec0 fv/uMSaM1K+s9JOGjt8B5mr9VU+4pwehBtC5gZkPKkT7AeE/5UoJMl3yZ+ZfiOQrrZ8RoZWd 86bpJml82XQ+QsaC9/Nut4XpWVTH9Y+lSDX4pZnc/DKbipq/0Te4Y5iXBYoUm9Fii3hojxE4 I4lWapc6+seFvakdOw1C3G0GszlVEFM0OevzXOX6aR/w6BaGpdFLjoH4EweZOUlFuhL7W5my NY0JmA3NBO5nvuRw7eZQcMxhZhkBZy+VG8fkikIITDxCP8nRdbIQrnQ5M8e1zA17ixMNa+AP YxDM2MpNUmeJU0UUrsUIMtWcOOAi3XhcjsetFWPoqkf6GnP1g1hlrPqNbI5f/TaHpkKzh/H/ goq+Uz5KUsVaeetywGl0W3zmebPmwrqd40rQejQGvlC3wTImz175ActfVeyv/SRkEO1XNNbb UsO9UIGsqwa5EGtCN7nUHWQsHOC+xIRRddUO+k78x2WjLrZ5R6DAWoJRSIHb8Yp3OcWSDowx xm2ltXmLTV1tfueTnf1y1uPhWrsY25PdzZEPHJaC1teizX+nG0tpi/lYtgzKvS2tMTsPjL14 Tug8StiwJxG2KbnyJ6H1VzAhjutoL3AQQg0+hjbUwqZ0+9pWGK2T9f2sAaGtJ6sOK7cFwDc5 yZcx6By+chUVfmweDqxrPLh9V1Dz9KMK3XijFFmBPHNHBz9qif4Lei8DNyTTXqF0/romxezP ic/WisLvve/2UdGiocmC79d8+xwkcDd+S3ND5g5rrNmO/CdjjOv8iB0flK31GvwikUqmqxXE c7FL5n8UShDUfw9kmreqwIhPVgDn35W+I8ubcqjk0TPPUS2OBZ5tovpwHPRN7tkvctoUS3e8 spFNtvi9vmseLSWX8QWmKZNRW03wY8TXMGr9JYMLbbTe2KL2ggJUpfs/F/oQKQ994w9qwsC1 ijVtpNwoLYnuUD6FA== IronPort-HdrOrdr: A9a23:aepYbK7oWaexfs/5UgPXwPLXdLJyesId70hD6qhwISY1TiX+rb HXoB17726MtN9/YgBCpTntAsa9qDbnhPpICOoqTNGftWvdyQmVxehZhOOIqVCNJ8S9zJ876U 4JSdkENDSaNzhHZKjBjjVQa+xQpeW6zA== X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="83478170" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 13/15] tools/ocaml/xenstored: set uncaught exception handler Date: Tue, 8 Nov 2022 15:34:05 +0000 Message-ID: X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 Helps debug fatal errors during live update Previously this would've just gone to /dev/null, because: * daemonize reopens stderr as /dev/null * systemd redirects stderr to /dev/null too Previously the only way to debug this was to manually run oxenstored with --no-fork, but when you have a fatal error and oxenstored just disappears you'd want to know why. There has been at least one observed instance of a bug where oxenstored just disappeared inexplicably (it was believed due to an OOM exception). Signed-off-by: Edwin Török Acked-by: Christian Lindig --- Reason for inclusion in 4.17: - avoids losing crucial information during a fatal error (e.g. during live update) Changes since v2: - new in v3 --- tools/ocaml/xenstored/logging.ml | 33 ++++++++++++++++++++++++++++++ tools/ocaml/xenstored/xenstored.ml | 3 ++- 2 files changed, 35 insertions(+), 1 deletion(-) diff --git a/tools/ocaml/xenstored/logging.ml b/tools/ocaml/xenstored/logging.ml index 021ebc465b..cced038c48 100644 --- a/tools/ocaml/xenstored/logging.ml +++ b/tools/ocaml/xenstored/logging.ml @@ -342,3 +342,36 @@ let xb_answer ~tid ~con ~ty data = let watch_not_fired ~con perms path = let data = Printf.sprintf "EPERM perms=[%s] path=%s" perms path in access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info + +let print_flush msg = + prerr_endline msg; + flush stderr + +let msg_of exn bt = + Printf.sprintf "Fatal exception: %s\n%s\n" (Printexc.to_string exn) + (Printexc.raw_backtrace_to_string bt) + +let fallback_exception_handler exn bt = + (* stderr goes to /dev/null, so use the logger where possible, + but always print to stderr too, in case everything else fails, + e.g. this can be used to debug with --no-fork + + this function should try not to raise exceptions, but if it does + the ocaml runtime should still print the exception, both the original, + and the one from this function, but to stderr this time + *) + let msg = msg_of exn bt in + print_flush msg; + (* See Printexc.set_uncaught_exception_handler, need to flush, + so has to call stop and flush *) + match !xenstored_logger with + | Some l -> error "xenstored-fallback" "%s" msg; l.stop () + | None -> + (* Too early, no logger set yet. + We normally try to use the configured logger so we don't flood syslog + during development for example, or if the user has a file set + *) + try Syslog.log Syslog.Daemon Syslog.Err msg + with e -> + let bt = Printexc.get_raw_backtrace () in + print_flush @@ msg_of e bt diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml index 78177b116f..6828764f92 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -357,7 +357,8 @@ let tweak_gc () = Gc.set { (Gc.get ()) with Gc.max_overhead = !Define.gc_max_overhead } -let _ = +let () = + Printexc.set_uncaught_exception_handler Logging.fallback_exception_handler; let cf = do_argv in let pidfile = if Sys.file_exists (config_filename cf) then From patchwork Tue Nov 8 15:34:06 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036485 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 6784CC43219 for ; Tue, 8 Nov 2022 15:40:00 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440165.694308 (Exim 4.92) (envelope-from ) id 1osQhZ-00080r-Lt; Tue, 08 Nov 2022 15:39:49 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440165.694308; Tue, 08 Nov 2022 15:39:49 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQhZ-000807-DL; Tue, 08 Nov 2022 15:39:49 +0000 Received: by outflank-mailman (input) for mailman id 440165; Tue, 08 Nov 2022 15:39:48 +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 1osQhY-0007Fx-FQ for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:39:48 +0000 Received: from esa4.hc3370-68.iphmx.com (esa4.hc3370-68.iphmx.com [216.71.155.144]) by se1-gles-sth1.inumbo.com (Halon) with ESMTPS id 93141a4b-5f7b-11ed-91b5-6bf2151ebd3b; Tue, 08 Nov 2022 16:39:47 +0100 (CET) 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: 93141a4b-5f7b-11ed-91b5-6bf2151ebd3b DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921987; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=xndQpxaUgOTkOg9lUcdLHyryykFdZHp3J5lKgw8D8NA=; b=e/dWQRTj0pAPwmOhf9yva6MXLJgkWhiKlrlZDDRxyEI6+KRi3uRI+OoN 0lw1KoBTrzUFdSb1X9A39IiwCgpp29WfvWNcuXhN2+XcUa18/dV2qZuMf H74++M+lEtrpqr7kXwYWsQMzLk3bLQN3dWM3cp5sISxxZ4F67jZODxoRr 4=; Authentication-Results: esa4.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 86935398 X-Ironport-Server: esa4.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:jPjP+630aAVB3id3FPbD5d9xkn2cJEfYwER7XKvMYLTBsI5bp2AHx zEbXDuHOPzeamf9ftwnaoq0oxgGuZfRx9Q2TQs/pC1hF35El5HIVI+TRqvS04F+DeWYFR46s J9OAjXkBJppJpMJjk71atANlVEliefTAOK5ULSfUsxIbVcMYD87jh5+kPIOjIdtgNyoayuAo tq3qMDEULOf82cc3lk8tuTS9nuDgNyo4GlC5wVmNagR1LPjvyJ94Kw3dPnZw0TQGuG4LsbiL 87fwbew+H/u/htFIrtJRZ6iLyXm6paLVeS/oiI+t5qK23CulQRrukoPD9IOaF8/ttm8t4sZJ OOhF3CHYVxB0qXkwIzxWvTDes10FfUuFLTveRBTvSEPpqFvnrSFL/hGVSkL0YMkFulfK0VU5 943LhQ2bVOMqP6s/46dW+YyiZF2RCXrFNt3VnBIyDjYCbAtQIzZQrWM7thdtNsyrpkQR7CEP ZNfMGcxKkSbC/FMEg5/5JYWkeu2h3+5bzpCr1G9rqsr+WnDigd21dABNfKFJI3RGJ4Ezi50o ErAp1/AHxsqL+am9iap6GmLv/bGuRL0Ddd6+LqQqacx3Qz7KnYoIAISfUu2p7++kEHWc8JSL QkY9zQjqYA29Ve3VZ/tUhugunmGsxUAHd1KHIUSyAyL0LuS3A+fCUANVDsHY9sj3Oc6TCIn/ kWElNToAXpoqrL9dJ6G3u7K93XoY3FTdDJcI39fJecY3zX9iKsXlADtYdBHK632gfLpAw7M5 SGF8idr0t3/kvU3/6m8+FnGhRelqZ7IUhM5623rY4610u9qTNX7PtL1sDA3+d4Fdd/EFQfZ4 BDojuDEtIgz4YexeDthqQnnNJWg/L67PTLVmjaD9LFxpm32qxZPkW29iQySxXuF0O5eJ1cFg 2eJ42u9AaO/21P7BZKbm6rrV6wXIVHITLwIlpn8N7KimKRZeg6d5z1JbkWNxW3rm0VEufhhZ 8jLLZj1VS5AV/QPIN+KqwA1iOFD+8zD7TmLGcCTI+qPjdJym0J5uZ9aaQDTP4jVHYuPoRnP8 sY3Cid540w3bQA/CwGJmbMuwacidClmWsqt8JQHL4Zu4GNOQQkcNhMY+pt5E6QNokifvrygE q2VMqOA9GfCuA== IronPort-HdrOrdr: A9a23:r3pXR6C4zmoqEFXlHemU55DYdb4zR+YMi2TC1yhKJyC9Ffbo7v xG/c5rsyMc5wxwZJhNo7y90ey7MBbhHP1OkO4s1NWZLWrbUQKTRekIh+bfKn/baknDH4ZmpN 9dmsNFaeEYY2IUsS+D2njbL+od X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="86935398" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 14/15] tools/ocaml/xenstored/syslog_stubs.c: avoid potential NULL dereference Date: Tue, 8 Nov 2022 15:34:06 +0000 Message-ID: <5da5b63bd6a0f8d0f6ad0281773eefb32de8164d.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 If we are out of memory then strdup may return NULL, and passing NULL to syslog may cause a crash. Avoid this by using `caml_stat_strdup` which will raise an OCaml out of memory exception instead. This then needs to be paired with caml_stat_free. Signed-off-by: Edwin Török Signed-off-by: Edwin Török > Acked-by: Christian Lindig > --- Reason for inclusion in 4.17: - fixes a bug in out of memory situations Changes since v2: - new in v3 --- tools/ocaml/xenstored/syslog_stubs.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/tools/ocaml/xenstored/syslog_stubs.c b/tools/ocaml/xenstored/syslog_stubs.c index 4e5e49b557..4ad85c8eb5 100644 --- a/tools/ocaml/xenstored/syslog_stubs.c +++ b/tools/ocaml/xenstored/syslog_stubs.c @@ -14,6 +14,7 @@ #include #include +#include #include #include #include @@ -35,14 +36,16 @@ static int __syslog_facility_table[] = { value stub_syslog(value facility, value level, value msg) { CAMLparam3(facility, level, msg); - const char *c_msg = strdup(String_val(msg)); + char *c_msg = strdup(String_val(msg)); int c_facility = __syslog_facility_table[Int_val(facility)] | __syslog_level_table[Int_val(level)]; + if ( !c_msg ) + caml_raise_out_of_memory(); caml_enter_blocking_section(); syslog(c_facility, "%s", c_msg); caml_leave_blocking_section(); - free((void*)c_msg); + free(c_msg); CAMLreturn(Val_unit); } From patchwork Tue Nov 8 15:34:07 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= X-Patchwork-Id: 13036480 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on aws-us-west-2-korg-lkml-1.web.codeaurora.org Received: from lists.xenproject.org (lists.xenproject.org [192.237.175.120]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.lore.kernel.org (Postfix) with ESMTPS id 2C418C4332F for ; Tue, 8 Nov 2022 15:39:46 +0000 (UTC) Received: from list by lists.xenproject.org with outflank-mailman.440161.694268 (Exim 4.92) (envelope-from ) id 1osQhN-0006zR-BE; Tue, 08 Nov 2022 15:39:37 +0000 X-Outflank-Mailman: Message body and most headers restored to incoming version Received: by outflank-mailman (output) from mailman id 440161.694268; Tue, 08 Nov 2022 15:39:37 +0000 Received: from localhost ([127.0.0.1] helo=lists.xenproject.org) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQhN-0006zK-8X; Tue, 08 Nov 2022 15:39:37 +0000 Received: by outflank-mailman (input) for mailman id 440161; Tue, 08 Nov 2022 15:39:36 +0000 Received: from se1-gles-flk1-in.inumbo.com ([94.247.172.50] helo=se1-gles-flk1.inumbo.com) by lists.xenproject.org with esmtp (Exim 4.92) (envelope-from ) id 1osQhM-0006zE-C1 for xen-devel@lists.xenproject.org; Tue, 08 Nov 2022 15:39:36 +0000 Received: from esa2.hc3370-68.iphmx.com (esa2.hc3370-68.iphmx.com [216.71.145.153]) by se1-gles-flk1.inumbo.com (Halon) with ESMTPS id 8a6a5574-5f7b-11ed-8fd1-01056ac49cbb; Tue, 08 Nov 2022 16:39:34 +0100 (CET) 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: 8a6a5574-5f7b-11ed-8fd1-01056ac49cbb DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=citrix.com; s=securemail; t=1667921974; h=from:to:cc:subject:date:message-id:in-reply-to: references:mime-version:content-transfer-encoding; bh=8ePR03hmluMvOGGTEiWLD/HCh/fqyWBWHQzlfAz9mW4=; b=Qlcd397j3Ty8M+5IqATEqYp0rPtYrPoe8MZJdlElZuxS230FIAnLReTo 7gnD4aujZiNUxzGJqFa5hD5B8NOQ5OP/Msg5IZ9sz0K6Mo3Q9N4KCL6qu IDsbV4q1NkwnOvte+7GEdvwT87lZhkznBURNu6M5YlfoVbKuY/sCNMB3d 8=; Authentication-Results: esa2.hc3370-68.iphmx.com; dkim=none (message not signed) header.i=none X-SBRS: None X-MesageID: 84417005 X-Ironport-Server: esa2.hc3370-68.iphmx.com X-Remote-IP: 162.221.156.83 X-Policy: $RELAYED IronPort-Data: A9a23:9knbNquqGW13lrMKgnEn17uSP+fnVFpeMUV32f8akzHdYApBsoF/q tZmKTvUM/3YNGvwcox3bYq+8UkFsMPTzN5lTwVkqS01FCwT+JbJXdiXEBz9bniYRiHhoOCLz O1FM4Wdc5pkJpP4jk3wWlQ0hSAkjclkfpKlVKiffHg0HVU/IMsYoUoLs/YjhYJ1isSODQqIu Nfjy+XSI1bg0DNvWo4uw/vrRChH4bKj5lv0gnRkPaoR5QaGxyFPZH4iDfrZw0XQE9E88tGSH 44v/JnhlkvF8hEkDM+Sk7qTWiXmlZaLYGBiIlIPM0STqkAqSh4ai87XB9JFAatjsB2bnsgZ9 Tl4ncfYpTHFnEH7sL91vxFwS0mSNEDdkVPNCSDXXce7lyUqf5ZwqhnH4Y5f0YAwo45K7W9yG fMwEyoUQQijp8uMmpmhU9lzl50hI/KzI9ZK0p1g5Wmx4fcORJnCR+PB5MNC3Sd2jcdLdRrcT 5NHM3w1Nk2GOkARfAdMYH49tL7Aan3XfjFGqVTTua0t5Gv7xw1tyrn9dtHSf7RmQO0FwhrB+ TqeogwVBDk+LdbAkhSP8UiNxcbQwHnpBIUwLLqBo6sCbFq7mTVIVUx+uUGAiea9ol6zXZRYM UN80jojq+0++VKmSvH5XgakuziUsxgEQd1SHuYmrgaXxcL8wwufHHlCcTdHZ/QvrspwTjsvv neFls3kLSZiu7qUTTSa7Lj8kN+pEXFLdylYP3ZCFFZbpYm4yG0usv7RZu15CYGtrv3cI2vb2 Sm6szlnhboo1dFegs1X4mv7qz6ro5HISCs86QPWQn+p42tFWWK1W2C7wQOFtKgdde51WnHE5 SFZwJbGsIjiGLnXzESwrPMx8KZFDhpvGBnVmhZREpYo7FxBEFbzLNkLsFmSyKqEW/vomAMFg meJ52u9B7cJZhNGiJObhKrgY/nGNYC6SbzYugn8N7KjovFZLWdrBh1Ga0+KxHzKm0Mxi6w5M przWZ/yUylKVfo+lGLsGbd1PVoXKscWnD27eHwG507/jer2iIC9Fd/pz2dinshmtfjZ8W05A v5UNteQygU3bQENSnC/zGPSRHhURUUG6Wfe8p0KKbTYeVI2QQnMyZb5mNscRmCspIwN/s+gw 513chMwJIbX7ZEfFTi3Vw== IronPort-HdrOrdr: A9a23:wVwiwa5FANW47TynjwPXwPDXdLJyesId70hD6qhwISY6TiX+rb HWoB17726TtN9/YhEdcLy7VJVoBEmskKKdgrNhWotKPjOW21dARbsKheCJrgEIWReOktK1vZ 0QC5SWY+eQMbEVt6nHCXGDYrQd/OU= X-IronPort-AV: E=Sophos;i="5.96,148,1665460800"; d="scan'208";a="84417005" From: =?utf-8?b?RWR3aW4gVMO2csO2aw==?= To: CC: Henry Wang , =?utf-8?b?RWR3aW4gVMO2csO2aw==?= , Christian Lindig , David Scott , Wei Liu , Anthony PERARD Subject: [PATCH for-4.17 v3 15/15] tools/ocaml/libs/xc: fix use of uninitialized memory in shadow_allocation_get Date: Tue, 8 Nov 2022 15:34:07 +0000 Message-ID: <94f93ee61a4d0bd2fac3f5a753cb935962be20bb.1667920496.git.edvin.torok@citrix.com> X-Mailer: git-send-email 2.34.1 In-Reply-To: References: MIME-Version: 1.0 It has been noticed in 2013 that shadow allocation sometimes returns the wrong value, which got worked around by adding a limit to the shadow multiplier of 1000 and ignoring the value from Xen in that case to avoid a shadow multiplier causing a VM to request 6PB of memory for example: https://github.com/xapi-project/xen-api/pull/1215/commits/be55a8c30b41d1cd7596fc100ab1cfd3539f74eb However that is just a workaround, and I've just reproduced this by killing a VM mid migration, which resulted in a shadow multiplier of 629.42, rendering the VM unbootable even after a host reboot. The real bug is in Xen: when a VM is dying it will return '0' for paging op domctls and log a message at info level 'Ignoring paging op on dying domain', which leaves the 'mb' parameter uninitialized upon return from the domctl. The binding also doesn't initialize the 'c->mb' parameter (it is meant to be used only when setting, not when querying the allocation), which results in the VM getting a shadow allocation (and thus multiplier) set based on what value happened to be currently on the stack. Explicitly initialize the value passed to the domctl, and detect the uninitialized case (shadow allocation of 0), and raise an exception in that case. The exception will cause xenopsd to skip setting the shadow multiplier. Note that the behaviour of Xen here is inconsistent between x86 and ARM: ARM would return EINVAL when it gets a paging op on a dying domain, and X86-64 would return 0 with possibly uninitialized data. It might be desirable to change the x86 path in the hypervisor to return EINVAL, although that would require more testing in case it breaks somethig. But the bindings should be defensive anyway against bugs like this. Signed-off-by: Edwin Török --- Reason for inclusion in 4.17: - fixes a long-standing (>9y old) bug that is still happening today Changes since v2: - new in v3 --- tools/ocaml/libs/xc/xenctrl_stubs.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c b/tools/ocaml/libs/xc/xenctrl_stubs.c index e2d897581f..9681a74e40 100644 --- a/tools/ocaml/libs/xc/xenctrl_stubs.c +++ b/tools/ocaml/libs/xc/xenctrl_stubs.c @@ -1019,7 +1019,7 @@ CAMLprim value stub_shadow_allocation_get(value xch, value domid) { CAMLparam2(xch, domid); CAMLlocal1(mb); - unsigned int c_mb; + unsigned int c_mb = 0; int ret; caml_enter_blocking_section(); @@ -1029,6 +1029,9 @@ CAMLprim value stub_shadow_allocation_get(value xch, value domid) caml_leave_blocking_section(); if (ret != 0) failwith_xc(_H(xch)); + if ( !c_mb ) + caml_failwith("domctl returned uninitialized data for shadow " + "allocation, dying domain?"); mb = Val_int(c_mb); CAMLreturn(mb);