[Xen-devel] [PATCH 1/1] x86/arch: VM resume: avoid RDTSC emulation due to host clock drift
On a Intel(R) Xeon(R) CPU E5-2697 v3 @ 2.60GHz the host frequency drifts:
```
(XEN) [6.607693] Detected 2600.004 MHz processor.
(XEN) [ 2674.213081] dom1(hvm): mode=0,ofs=0xfffee6f70b7faa48,khz=2600018,inc=3
(XEN) [ 2674.213087] dom2(hvm): mode=0,ofs=0xfffee6fd499835c0,khz=2600018,inc=2
```
The 2 domains were suspended prior to rebooting the host and applying a
xen/microcode patch. After the reboot the frequency of the host was deemed to
be slightly different, and therefore switching on RDTSC emulation for the Linux
HVM guest, even though the difference was only 5 ppm. This CPU doesn't support
TSC scaling.
Therefore we should either measure the standard deviation of our calibration
and have a range of acceptable frequencies as "same", or have a static
tolerance value.
The platform timer's clock frequency accuracy is:
* IA-PC HPET Specification 1.0a sections 2.2 and 2.4.1: 500 ppm or better
* ACPI PM timer, and PIT timer do not have defined accuracies
* Intel 300 Series datasheet section 25.6: 24 MHz crystal 100 ppm or better
* NTP FAQ section 3.3 Clock Quality: 11 ppm drift due to temperature
* section 2.2.2 claims that PIT/ACPI PM timer share the same crystal as HPET and
thus 500 ppm as an upper bound, "the real drift is usually smaller than 30ppm"
For simplicity and determinism opted for a static tolerance value of 100 ppm
here, such that the any error would be well within the error you would get with
HPET/Linux's calibration. NTP can cope with a drift < 500 ppm.
Most importantly this should stop Xen from claiming that the clock frequency on
the same host is different across reboots. Specifications do not currently
mandate an accuracy higher than 100 ppm, therefore OSes should already be able
to cope with such drift on real hardware. Any improvements in accuracy from
future specifications/motherboards wouldn't be applicable, because they would
also come with newer CPUs that support TSC scaling.
If the CPU does support TSC scaling Xen will of course still attempt to match
the exact frequency value it thinks the guest had when it was suspended.
See below for `if ( hvm_tsc_scaling_supported && !d->arch.vtsc )` (not visible
in patch context).
llabs() doesn't appear to be available when building xen, hence the 2
comparisons.
After this patch when suspending a VM, and rebooting the host I get this output:
```
(XEN) [6.614703] Detected 2600.010 MHz processor.
(XEN) [ 138.924342] TSC marked as reliable, warp = 0 (count=2)
(XEN) [ 138.924346] dom1(hvm): mode=0,ofs=0xfffed01901016d18,khz=2600012,inc=2
```
Signed-off-by: Edwin Török
---
xen/arch/x86/time.c | 8 +++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/xen/arch/x86/time.c b/xen/arch/x86/time.c
index 9a6ea8ffcb..a0b99f5fff 100644
--- a/xen/arch/x86/time.c
+++ b/xen/arch/x86/time.c
@@ -2171,6 +2171,12 @@ void tsc_get_info(struct domain *d, uint32_t *tsc_mode,
*elapsed_nsec = 0;
}
+static inline int frequency_same_with_tolerance(int64_t khz1, int64_t khz2)
+{
+int64_t ppm = (khz2 - khz1) * 100 / khz2;
+return -100 < ppm && ppm < 100;
+}
+
/*
* This may be called as many as three times for a domain, once when the
* hypervisor creates the domain, once when the toolstack creates the
@@ -2207,7 +2213,7 @@ int tsc_set_info(struct domain *d,
* d->arch.tsc_khz == cpu_khz. Thus no need to check incarnation.
*/
if ( tsc_mode == TSC_MODE_DEFAULT && host_tsc_is_safe() &&
- (d->arch.tsc_khz == cpu_khz ||
+ (frequency_same_with_tolerance(d->arch.tsc_khz, cpu_khz) ||
(is_hvm_domain(d) &&
hvm_get_tsc_scaling_ratio(d->arch.tsc_khz))) )
{
--
2.20.1
___
Xen-devel mailing list
Xen-devel@lists.xenproject.org
https://lists.xenproject.org/mailman/listinfo/xen-devel
[Xen-devel] [PATCH 0/1] Avoiding RDTSC emulation due to host clock drift
I noticed that RDTSC emulation got turned on for a VM after a suspend/host-reboot/resume cycle. Xen currently expects an exact match between host CPU and saved guest CPU frequency in KHz, otherwise it turns on RDTSC emulation if the CPU doesn't support TSC scaling. An exact match would require ~0.4 ppm accuracy, and even on physical hardware the platform timer used for calibration is not that accurate. The best accuracy I could find that datasheets/specifications require is 100 ppm, so let Xen accept a 100 ppm difference in clock frequency as "the same" and do not turn on RDTSC emulation due to that. So far I have manually tested this on Intel(R) Xeon(R) CPU E5-2697 v3 and a Debian 9 guest, more tests pending. See the commit for more details. Edwin Török (1): x86/arch: VM resume: avoid RDTSC emulation due to host clock drift xen/arch/x86/time.c | 8 +++- 1 file changed, 7 insertions(+), 1 deletion(-) -- 2.20.1 ___ Xen-devel mailing list Xen-devel@lists.xenproject.org https://lists.xenproject.org/mailman/listinfo/xen-devel
Re: [Xen-devel] [PATCH 1/1] x86/arch: VM resume: avoid RDTSC emulation due to host clock drift
On 03/09/2019 08:54, Jan Beulich wrote:
> On 02.09.2019 20:27, Edwin Török wrote:
>> On a Intel(R) Xeon(R) CPU E5-2697 v3 @ 2.60GHz the host frequency drifts:
>> ```
>> (XEN) [6.607693] Detected 2600.004 MHz processor.
>> (XEN) [ 2674.213081] dom1(hvm):
>> mode=0,ofs=0xfffee6f70b7faa48,khz=2600018,inc=3
>> (XEN) [ 2674.213087] dom2(hvm):
>> mode=0,ofs=0xfffee6fd499835c0,khz=2600018,inc=2
>> ```
>>
>> The 2 domains were suspended prior to rebooting the host and applying a
>> xen/microcode patch. After the reboot the frequency of the host was deemed to
>> be slightly different, and therefore switching on RDTSC emulation for the
>> Linux
>> HVM guest, even though the difference was only 5 ppm. This CPU doesn't
>> support
>> TSC scaling.
>>
>> Therefore we should either measure the standard deviation of our calibration
>> and have a range of acceptable frequencies as "same", or have a static
>> tolerance value.
>>
>> The platform timer's clock frequency accuracy is:
>> * IA-PC HPET Specification 1.0a sections 2.2 and 2.4.1: 500 ppm or better
>> * ACPI PM timer, and PIT timer do not have defined accuracies
>> * Intel 300 Series datasheet section 25.6: 24 MHz crystal 100 ppm or better
>> * NTP FAQ section 3.3 Clock Quality: 11 ppm drift due to temperature
>> * section 2.2.2 claims that PIT/ACPI PM timer share the same crystal as HPET
>> and
>> thus 500 ppm as an upper bound, "the real drift is usually smaller than
>> 30ppm"
>>
>> For simplicity and determinism opted for a static tolerance value of 100 ppm
>> here, such that the any error would be well within the error you would get
>> with
>> HPET/Linux's calibration. NTP can cope with a drift < 500 ppm.
>> Most importantly this should stop Xen from claiming that the clock frequency
>> on
>> the same host is different across reboots. Specifications do not currently
>> mandate an accuracy higher than 100 ppm, therefore OSes should already be
>> able
>> to cope with such drift on real hardware. Any improvements in accuracy from
>> future specifications/motherboards wouldn't be applicable, because they would
>> also come with newer CPUs that support TSC scaling.
>>
>> If the CPU does support TSC scaling Xen will of course still attempt to match
>> the exact frequency value it thinks the guest had when it was suspended.
>> See below for `if ( hvm_tsc_scaling_supported && !d->arch.vtsc )` (not
>> visible
>> in patch context).
>>
>> llabs() doesn't appear to be available when building xen, hence the 2
>> comparisons.
>>
>> After this patch when suspending a VM, and rebooting the host I get this
>> output:
>> ```
>> (XEN) [6.614703] Detected 2600.010 MHz processor.
>> (XEN) [ 138.924342] TSC marked as reliable, warp = 0 (count=2)
>> (XEN) [ 138.924346] dom1(hvm):
>> mode=0,ofs=0xfffed01901016d18,khz=2600012,inc=2
>> ```
>>
>> Signed-off-by: Edwin Török
>
> First of all - are you aware that there had been multiple iterations
> of a patch (by Olaf Hering) making this a command line and/or guest
> config controllable setting?
No, I'll take a look at them and the associated discussion.
Found a '[PATCH v10] new config option vtsc_tolerance_khz to avoid TSC
emulation' in the archives from 9 months ago.
> If so, it would have been nice if at
> least the cover letter identified the correlation. If not, please
> take a look. After all it hasn't gone in so far because of objections
> by Andrew.
>
> Using a hardcoded tolerance value in any event raises the question
> of how you know whether a particular guest OS can actually cope.
>
>> --- a/xen/arch/x86/time.c
>> +++ b/xen/arch/x86/time.c
>> @@ -2171,6 +2171,12 @@ void tsc_get_info(struct domain *d, uint32_t
>> *tsc_mode,
>> *elapsed_nsec = 0;
>> }
>>
>> +static inline int frequency_same_with_tolerance(int64_t khz1, int64_t khz2)
>
> The return type wants to be bool. And there wants to be an explaining
> comment ahead of the function, (re-)stating some of what you have in
> the description.
>
>> +{
>> +int64_t ppm = (khz2 - khz1) * 100 / khz2;
>> +return -100 < ppm && ppm < 100;
>
> While we have no llabs(), you should imo use either ABS() or
> __builtin_labs() / __builtin_llabs().
>
> Furthermore, could we limit this behavior to the case of there not
> being TSC scaling available (due to running on old hardware, or due
> to it being a PV guest)?
Yes, that'd make sense.
Best regards,
--Edwin
___
Xen-devel mailing list
Xen-devel@lists.xenproject.org
https://lists.xenproject.org/mailman/listinfo/xen-devel
Re: [Xen-devel] [PATCH 3/3] xen-init-dom0: set Dom0 UUID if requested
On 14/11/2018 18:17, Wei Liu wrote:
> Read from XEN_CONFIG_DIR/dom0-uuid. If it contains a valid UUID, set
> it for Dom0.
>
> Signed-off-by: Wei Liu
[snip]
In general this looks good, however I am not familiar with libxl
conventions, so just some generic comments below.
> +static void get_dom0_uuid(libxl_uuid *uuid)
> +{
> +int fd = -1;
> +ssize_t r;
> +char uuid_buf[LIBXL_UUID_FMTLEN+1];
> +
> +libxl_uuid_clear(uuid);
> +
> +fd = open(DOM0_UUID_PATH, O_RDONLY);
> +if (fd < 0) {
> +fprintf(stderr, "failed to open %s\n", DOM0_UUID_PATH);
> +goto out;
> +}
> +
> +r = read(fd, uuid_buf, LIBXL_UUID_FMTLEN);
Could this be a short read? I'm not familiar with libxl conventions, but
would there be a utility function that repeats the read if it is short,
or would fread be better?
> +if (r == -1) {
> +fprintf(stderr, "failed to read %s, errno %d\n", DOM0_UUID_PATH,
> errno);
> +goto out;
> +}
> +
> +if (r != LIBXL_UUID_FMTLEN) {
> +fprintf(stderr, "file too short\n");
Would be nice to print which file is too short.
> +goto out;
> +}
> +
> +uuid_buf[LIBXL_UUID_FMTLEN] = 0;
> +
> +if (libxl_uuid_from_string(uuid, uuid_buf)) {
> +fprintf(stderr, "failed to parse UUID\n");
As above, would be nice to print which file this error is from.
> +libxl_uuid_clear(uuid);
> +}
> +
> +out:
> +if (fd >= 0) close(fd);
> +}
> +
> int main(int argc, char **argv)
> {
> int rc;
> -struct xs_handle *xsh;
> +struct xs_handle *xsh = NULL;
> +xc_interface *xch = NULL;
> char *domname_string = NULL, *domid_string = NULL;
> +libxl_uuid uuid;
>
> xsh = xs_open(0);
> if (!xsh) {
> fprintf(stderr, "cannot open xenstore connection\n");
> -exit(1);
> +rc = 1;
> +goto out;
> +}
> +
> +xch = xc_interface_open(NULL, NULL, 0);
> +if (!xch) {
> +fprintf(stderr, "xc_interface_open() failed\n");
> +rc = 1;
> }
>
> /* Sanity check: this program can only be run once. */
> @@ -31,7 +82,16 @@ int main(int argc, char **argv)
> goto out;
> }
>
> -rc = gen_stub_json_config(0, NULL);
> +get_dom0_uuid(&uuid);
> +
> +if (!libxl_uuid_is_nil(&uuid) &&
> +xc_domain_sethandle(xch, 0, libxl_uuid_bytearray(&uuid))) {
> +fprintf(stderr, "failed to set Dom0 UUID\n");
Can xc_domain_sethandle tell us why it failed?
> +rc = 1;
> +goto out;
> +}
> +
> +rc = gen_stub_json_config(0, &uuid);
> if (rc)
> goto out;
>
> @@ -55,6 +115,7 @@ out:
> free(domid_string);
> free(domname_string);
> xs_close(xsh);
> +xc_interface_close(xch);
I assume this function doesn't mind getting called with NULL, right?
Best regards,
--Edwin
___
Xen-devel mailing list
Xen-devel@lists.xenproject.org
https://lists.xenproject.org/mailman/listinfo/xen-devel
Re: [Xen-devel] [PATCH v2 3/3] xen-init-dom0: set Dom0 UUID if requested
On 15/11/2018 14:30, Wei Liu wrote: > Read from XEN_CONFIG_DIR/dom0-uuid. If it contains a valid UUID, set > it for Dom0. > > Signed-off-by: Wei Liu > --- > v2: > 1. add missing "goto out" > 2. print file names more > 3. also print errno in xc_interface_open error message > 4. take care of short-read > --- > tools/examples/Makefile | 1 + > tools/examples/README | 2 ++ > tools/examples/dom0-uuid | 0 > tools/helpers/Makefile| 3 +- > tools/helpers/xen-init-dom0.c | 65 > +-- > 5 files changed, 67 insertions(+), 4 deletions(-) > create mode 100644 tools/examples/dom0-uuid I can't spot anything wrong here. Acked-by: Edwin Török Best regards, --Edwin ___ Xen-devel mailing list Xen-devel@lists.xenproject.org https://lists.xenproject.org/mailman/listinfo/xen-devel
[PATCH v1 1/1] tools/ocaml/xenstored: drop the creation of the RO socket
The readonly flag was propagated but ignored, so this was essentially
equivalent to a RW socket.
C xenstored is dropping the RO socket too, so drop it from oxenstored too.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/define.ml | 1 -
tools/ocaml/xenstored/xenstored.ml | 15 ++-
3 files changed, 7 insertions(+), 11 deletions(-)
diff --git a/tools/ocaml/xenstored/connections.ml
b/tools/ocaml/xenstored/connections.ml
index f02ef6b526..f2c4318c88 100644
--- a/tools/ocaml/xenstored/connections.ml
+++ b/tools/ocaml/xenstored/connections.ml
@@ -31,7 +31,7 @@ let create () = {
watches = Trie.create ()
}
-let add_anonymous cons fd _can_write =
+let add_anonymous cons fd =
let xbcon = Xenbus.Xb.open_fd fd in
let con = Connection.create xbcon None in
Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con
diff --git a/tools/ocaml/xenstored/define.ml b/tools/ocaml/xenstored/define.ml
index 2965c08534..ea9e1b7620 100644
--- a/tools/ocaml/xenstored/define.ml
+++ b/tools/ocaml/xenstored/define.ml
@@ -18,7 +18,6 @@ let xenstored_major = 1
let xenstored_minor = 0
let xs_daemon_socket = Paths.xen_run_stored ^ "/socket"
-let xs_daemon_socket_ro = Paths.xen_run_stored ^ "/socket_ro"
let default_config_dir = Paths.xen_config_dir
diff --git a/tools/ocaml/xenstored/xenstored.ml
b/tools/ocaml/xenstored/xenstored.ml
index 5b96f1852a..7e7824761b 100644
--- a/tools/ocaml/xenstored/xenstored.ml
+++ b/tools/ocaml/xenstored/xenstored.ml
@@ -242,12 +242,11 @@ let _ =
()
);
- let rw_sock, ro_sock =
+ let rw_sock =
if cf.disable_socket then
- None, None
+ None
else
- Some (Unix.handle_unix_error Utils.create_unix_socket
Define.xs_daemon_socket),
- Some (Unix.handle_unix_error Utils.create_unix_socket
Define.xs_daemon_socket_ro)
+ Some (Unix.handle_unix_error Utils.create_unix_socket
Define.xs_daemon_socket)
in
if cf.daemonize then
@@ -320,15 +319,14 @@ let _ =
let spec_fds =
(match rw_sock with None -> [] | Some x -> [ x ]) @
- (match ro_sock with None -> [] | Some x -> [ x ]) @
(if cf.domain_init then [ Event.fd eventchn ] else [])
in
let process_special_fds rset =
- let accept_connection can_write fd =
+ let accept_connection fd =
let (cfd, _addr) = Unix.accept fd in
debug "new connection through socket";
- Connections.add_anonymous cons cfd can_write
+ Connections.add_anonymous cons cfd
and handle_eventchn _fd =
let port = Event.pending eventchn in
debug "pending port %d" (Xeneventchn.to_int port);
@@ -348,8 +346,7 @@ let _ =
if List.mem fd set then
fct fd in
- maybe (fun fd -> do_if_set fd rset (accept_connection true))
rw_sock;
- maybe (fun fd -> do_if_set fd rset (accept_connection false))
ro_sock;
+ maybe (fun fd -> do_if_set fd rset accept_connection) rw_sock;
do_if_set (Event.fd eventchn) rset (handle_eventchn)
in
--
2.25.1
[PATCH v1 0/1] drop RO socket from oxenstored
See https://lore.kernel.org/xen-devel/20201002154141.11677-6-jgr...@suse.com/T/#u Edwin Török (1): tools/ocaml/xenstored: drop the creation of the RO socket tools/ocaml/xenstored/connections.ml | 2 +- tools/ocaml/xenstored/define.ml | 1 - tools/ocaml/xenstored/xenstored.ml | 15 ++- 3 files changed, 7 insertions(+), 11 deletions(-) -- 2.25.1
[PATCH v1 2/4] automation/: add Ubuntu:focal container
Signed-off-by: Edwin Török
---
automation/build/ubuntu/focal.dockerfile | 50
automation/scripts/containerize | 1 +
2 files changed, 51 insertions(+)
create mode 100644 automation/build/ubuntu/focal.dockerfile
diff --git a/automation/build/ubuntu/focal.dockerfile
b/automation/build/ubuntu/focal.dockerfile
new file mode 100644
index 00..1f014b67bc
--- /dev/null
+++ b/automation/build/ubuntu/focal.dockerfile
@@ -0,0 +1,50 @@
+FROM ubuntu:20.04
+LABEL maintainer.name="The Xen Project " \
+ maintainer.email="xen-devel@lists.xenproject.org"
+
+ENV DEBIAN_FRONTEND=noninteractive
+ENV USER root
+
+RUN mkdir /build
+WORKDIR /build
+
+# build depends
+RUN apt-get update && \
+apt-get --quiet --yes install \
+build-essential \
+zlib1g-dev \
+libncurses5-dev \
+libssl-dev \
+python-dev \
+python3-dev \
+xorg-dev \
+uuid-dev \
+libyajl-dev \
+libaio-dev \
+libglib2.0-dev \
+clang \
+libpixman-1-dev \
+pkg-config \
+flex \
+bison \
+gettext \
+acpica-tools \
+bin86 \
+bcc \
+liblzma-dev \
+libc6-dev-i386 \
+libnl-3-dev \
+ocaml-nox \
+libfindlib-ocaml-dev \
+libsystemd-dev \
+markdown \
+transfig \
+pandoc \
+checkpolicy \
+wget \
+git \
+nasm \
+&& \
+apt-get autoremove -y && \
+apt-get clean && \
+rm -rf /var/lib/apt/lists* /tmp/* /var/tmp/*
diff --git a/automation/scripts/containerize b/automation/scripts/containerize
index ed991bb79c..94ff8b1ca8 100755
--- a/automation/scripts/containerize
+++ b/automation/scripts/containerize
@@ -29,6 +29,7 @@ case "_${CONTAINER}" in
_centos7) CONTAINER="${BASE}/centos:7" ;;
_centos72) CONTAINER="${BASE}/centos:7.2" ;;
_fedora) CONTAINER="${BASE}/fedora:29";;
+_focal) CONTAINER="${BASE}/ubuntu:focal" ;;
_jessie) CONTAINER="${BASE}/debian:jessie" ;;
_stretch|_) CONTAINER="${BASE}/debian:stretch" ;;
_unstable|_) CONTAINER="${BASE}/debian:unstable" ;;
--
2.18.4
[PATCH v1 1/4] automation/scripts/containerize: fix DOCKER_CMD=podman
On CentOS 8 with SELinux containerize doesn't work at all:
Make sure that the source code and SSH agent directories are passed on
with SELinux relabeling enabled.
(`-security-opt label=disabled` would be another option)
Signed-off-by: Edwin Török
---
automation/scripts/containerize | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/automation/scripts/containerize b/automation/scripts/containerize
index a75d54566c..ed991bb79c 100755
--- a/automation/scripts/containerize
+++ b/automation/scripts/containerize
@@ -7,7 +7,7 @@
# and /etc/subgid.
#
docker_cmd=${DOCKER_CMD:-"docker"}
-[ "$DOCKER_CMD" = "podman" ] && userns_podman="--userns=keep-id"
+[ "$DOCKER_CMD" = "podman" ] && userns_podman="--userns=keep-id" selinux=",z"
einfo() {
echo "$*" >&2
@@ -95,9 +95,9 @@ einfo "*** Launching container ..."
exec ${docker_cmd} run \
${userarg} \
${SSH_AUTH_SOCK:+-e SSH_AUTH_SOCK="/tmp/ssh-agent/${SSH_AUTH_NAME}"} \
--v "${CONTAINER_PATH}":/build:rw \
+-v "${CONTAINER_PATH}":/build:rw${selinux} \
-v "${HOME}/.ssh":/root/.ssh:ro \
-${SSH_AUTH_DIR:+-v "${SSH_AUTH_DIR}":/tmp/ssh-agent} \
+${SSH_AUTH_DIR:+-v "${SSH_AUTH_DIR}":/tmp/ssh-agent${selinux}} \
${XEN_CONFIG_EXPERT:+-e XEN_CONFIG_EXPERT=${XEN_CONFIG_EXPERT}} \
${CONTAINER_ARGS} \
-${termint}i --rm -- \
--
2.18.4
[PATCH v1 0/4] tools/ocaml/libs/xc: domid control at domain creation time
The xl toolstack allows some control over the domid at VM creation time, allow xenopsd similar control by exposing the appropriate domid field in the OCaml xenctrl bindings. A new API function is introduced to preserve backwards compatibility without merge ordering requirements between the Xen and xenopsd patches: Xen can merge the patch and xenopsd will keep building with the old function, and a new version of xenopsd will start using the new function. I've also included some build system fixes to allow me to test the build in an upstream build environment: ``` cd automation/build podman build -t registry.gitlab.com/xen-project/xen/ubuntu:focal -f ubuntu/focal.dockerfile ubuntu DOCKER_CMD=podman CONTAINER_NO_PULL=1 CONTAINER=registry.gitlab.com/xen-project/xen/ubuntu:focal automation/scripts/containerize make build-tools-oxenstored ``` It'd be good if someone could test whether containerize still works on non-SELinux systems now, or whether we need more detection logic in the script. This works around bugs in the OCaml makefiles that end up in "inconsistent assumptions" by doing a 'make clean' before building the OCaml files every time. This is inefficient, but works. Long term it would be beneficial to switch to Dune as build system, which can do correct incremental builds with minimal configuration. I'll send a separate patch series for that. Edwin Török (4): automation/scripts/containerize: fix DOCKER_CMD=podman automation/: add Ubuntu:focal container Makefile: add build-tools-oxenstored tools/ocaml/libs/xc: backward compatible domid control at domain creation time Makefile | 6 +++ automation/build/ubuntu/focal.dockerfile | 50 automation/scripts/containerize | 7 ++-- tools/ocaml/Makefile | 8 tools/ocaml/libs/xc/xenctrl.ml | 3 ++ tools/ocaml/libs/xc/xenctrl.mli | 2 + tools/ocaml/libs/xc/xenctrl_stubs.c | 9 - 7 files changed, 80 insertions(+), 5 deletions(-) create mode 100644 automation/build/ubuntu/focal.dockerfile -- 2.18.4
[PATCH v1 3/4] Makefile: add build-tools-oxenstored
As a convenience so that oxenstored patches can be compile-tested using upstream's build-system before submitting upstream. Signed-off-by: Edwin Török --- Makefile | 6 ++ tools/ocaml/Makefile | 8 2 files changed, 14 insertions(+) diff --git a/Makefile b/Makefile index 9ad2602f63..96d32cfd50 100644 --- a/Makefile +++ b/Makefile @@ -62,6 +62,12 @@ build-xen: build-tools: build-tools-public-headers $(MAKE) -C tools build +.PHONY: build-tools-oxenstored +build-tools-oxenstored: build-tools-public-headers + $(MAKE) -s -C tools/ocaml clean + $(MAKE) -s -C tools/libs + $(MAKE) -C tools/ocaml build-tools-oxenstored + .PHONY: build-stubdom build-stubdom: mini-os-dir build-tools-public-headers $(MAKE) -C stubdom build diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index 66f2d6b131..a7c04b6546 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -26,3 +26,11 @@ clean: subdirs-clean .PHONY: distclean distclean: subdirs-distclean + +.PHONY: build-tools-oxenstored +build-tools-oxenstored: + $(MAKE) -s -C libs/eventchn + $(MAKE) -s -C libs/mmap + $(MAKE) -s -C libs/xb + $(MAKE) -s -C libs/xc + $(MAKE) -C xenstored -- 2.18.4
[PATCH v1 4/4] tools/ocaml/libs/xc: backward compatible domid control at domain creation time
One can specify the domid to use when creating the domain, but this was
hardcoded to 0.
Keep the existing `domain_create` function (and the type of its parameters) as
is to make
backwards compatibility easier.
Introduce a new `domain_create_domid` OCaml API that allows specifying the
domid.
A new version of xenopsd can choose to start using this, while old versions of
xenopsd will keep
building and using the old API.
Controlling the domid can be useful during testing or migration.
Signed-off-by: Edwin Török
---
tools/ocaml/libs/xc/xenctrl.ml | 3 +++
tools/ocaml/libs/xc/xenctrl.mli | 2 ++
tools/ocaml/libs/xc/xenctrl_stubs.c | 9 +++--
3 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml
index e878699b0a..9d720886e9 100644
--- a/tools/ocaml/libs/xc/xenctrl.ml
+++ b/tools/ocaml/libs/xc/xenctrl.ml
@@ -182,6 +182,9 @@ let with_intf f =
external domain_create: handle -> domctl_create_config -> domid
= "stub_xc_domain_create"
+external domain_create_domid: handle -> domctl_create_config -> domid -> domid
+ = "stub_xc_domain_create_domid"
+
external domain_sethandle: handle -> domid -> string -> unit
= "stub_xc_domain_sethandle"
diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli
index e64907df8e..e629022901 100644
--- a/tools/ocaml/libs/xc/xenctrl.mli
+++ b/tools/ocaml/libs/xc/xenctrl.mli
@@ -145,6 +145,8 @@ val close_handle: unit -> unit
external domain_create : handle -> domctl_create_config -> domid
= "stub_xc_domain_create"
+external domain_create_domid : handle -> domctl_create_config -> domid -> domid
+ = "stub_xc_domain_create_domid"
external domain_sethandle : handle -> domid -> string -> unit =
"stub_xc_domain_sethandle"
external domain_max_vcpus : handle -> domid -> int -> unit
= "stub_xc_domain_max_vcpus"
diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c
b/tools/ocaml/libs/xc/xenctrl_stubs.c
index 94aba38a42..bb718fd164 100644
--- a/tools/ocaml/libs/xc/xenctrl_stubs.c
+++ b/tools/ocaml/libs/xc/xenctrl_stubs.c
@@ -175,7 +175,7 @@ static unsigned int ocaml_list_to_c_bitmap(value l)
return val;
}
-CAMLprim value stub_xc_domain_create(value xch, value config)
+CAMLprim value stub_xc_domain_create_domid(value xch, value config, value
want_domid)
{
CAMLparam2(xch, config);
CAMLlocal2(l, arch_domconfig);
@@ -191,7 +191,7 @@ CAMLprim value stub_xc_domain_create(value xch, value
config)
#define VAL_MAX_MAPTRACK_FRAMES Field(config, 7)
#define VAL_ARCHField(config, 8)
- uint32_t domid = 0;
+ uint32_t domid = Int_val(want_domid);
int result;
struct xen_domctl_createdomain cfg = {
.ssidref = Int32_val(VAL_SSIDREF),
@@ -262,6 +262,11 @@ CAMLprim value stub_xc_domain_create(value xch, value
config)
CAMLreturn(Val_int(domid));
}
+CAMLprim value stub_xc_domain_create(value xch, value config, value want_domid)
+{
+return stub_xc_domain_create_domid(xch, config, Val_int(0));
+}
+
CAMLprim value stub_xc_domain_max_vcpus(value xch, value domid,
value max_vcpus)
{
--
2.18.4
[PATCH v2 1/2] automation/: add Ubuntu:focal container
Signed-off-by: Edwin Török
Acked-by: Doug Goldstein
---
Changed since v1:
* dropped python-dev and markdown
---
automation/build/ubuntu/focal.dockerfile | 48
automation/scripts/containerize | 1 +
2 files changed, 49 insertions(+)
create mode 100644 automation/build/ubuntu/focal.dockerfile
diff --git a/automation/build/ubuntu/focal.dockerfile
b/automation/build/ubuntu/focal.dockerfile
new file mode 100644
index 00..c1c1f8d58f
--- /dev/null
+++ b/automation/build/ubuntu/focal.dockerfile
@@ -0,0 +1,48 @@
+FROM ubuntu:20.04
+LABEL maintainer.name="The Xen Project " \
+ maintainer.email="xen-devel@lists.xenproject.org"
+
+ENV DEBIAN_FRONTEND=noninteractive
+ENV USER root
+
+RUN mkdir /build
+WORKDIR /build
+
+# build depends
+RUN apt-get update && \
+apt-get --quiet --yes install \
+build-essential \
+zlib1g-dev \
+libncurses5-dev \
+libssl-dev \
+python3-dev \
+xorg-dev \
+uuid-dev \
+libyajl-dev \
+libaio-dev \
+libglib2.0-dev \
+clang \
+libpixman-1-dev \
+pkg-config \
+flex \
+bison \
+gettext \
+acpica-tools \
+bin86 \
+bcc \
+liblzma-dev \
+libc6-dev-i386 \
+libnl-3-dev \
+ocaml-nox \
+libfindlib-ocaml-dev \
+libsystemd-dev \
+transfig \
+pandoc \
+checkpolicy \
+wget \
+git \
+nasm \
+&& \
+apt-get autoremove -y && \
+apt-get clean && \
+rm -rf /var/lib/apt/lists* /tmp/* /var/tmp/*
diff --git a/automation/scripts/containerize b/automation/scripts/containerize
index c8c3c20fa2..da45baed4e 100755
--- a/automation/scripts/containerize
+++ b/automation/scripts/containerize
@@ -28,6 +28,7 @@ case "_${CONTAINER}" in
_centos7) CONTAINER="${BASE}/centos:7" ;;
_centos72) CONTAINER="${BASE}/centos:7.2" ;;
_fedora) CONTAINER="${BASE}/fedora:29";;
+_focal) CONTAINER="${BASE}/ubuntu:focal" ;;
_jessie) CONTAINER="${BASE}/debian:jessie" ;;
_stretch|_) CONTAINER="${BASE}/debian:stretch" ;;
_unstable|_) CONTAINER="${BASE}/debian:unstable" ;;
--
2.29.2
[PATCH v2 0/2] oxenstored build enhancements
The patches were posted previously, this is a repost after the XSA series. For convenience here is a tree with all patch series applied: https://github.com/edwintorok/xen/pull/1 Edwin Török (2): automation/: add Ubuntu:focal container Makefile: add build-tools-oxenstored Makefile | 6 +++ automation/build/ubuntu/focal.dockerfile | 48 automation/scripts/containerize | 1 + tools/ocaml/Makefile | 8 4 files changed, 63 insertions(+) create mode 100644 automation/build/ubuntu/focal.dockerfile -- 2.29.2
[PATCH v2 2/2] Makefile: add build-tools-oxenstored
As a convenience so that oxenstored patches can be compile-tested using upstream's build-system before submitting upstream. Signed-off-by: Edwin Török --- Changed since V1: * repost after XSA to avoid conflicts --- Makefile | 6 ++ tools/ocaml/Makefile | 8 2 files changed, 14 insertions(+) diff --git a/Makefile b/Makefile index 9ad2602f63..96d32cfd50 100644 --- a/Makefile +++ b/Makefile @@ -62,6 +62,12 @@ build-xen: build-tools: build-tools-public-headers $(MAKE) -C tools build +.PHONY: build-tools-oxenstored +build-tools-oxenstored: build-tools-public-headers + $(MAKE) -s -C tools/ocaml clean + $(MAKE) -s -C tools/libs + $(MAKE) -C tools/ocaml build-tools-oxenstored + .PHONY: build-stubdom build-stubdom: mini-os-dir build-tools-public-headers $(MAKE) -C stubdom build diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index 66f2d6b131..a7c04b6546 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -26,3 +26,11 @@ clean: subdirs-clean .PHONY: distclean distclean: subdirs-distclean + +.PHONY: build-tools-oxenstored +build-tools-oxenstored: + $(MAKE) -s -C libs/eventchn + $(MAKE) -s -C libs/mmap + $(MAKE) -s -C libs/xb + $(MAKE) -s -C libs/xc + $(MAKE) -C xenstored -- 2.29.2
[PATCH v2 3/8] docs/designs/xenstore-migration.md: clarify that deletes are recursive
Signed-off-by: Edwin Török --- Changed since V1: * post publicly now that the XSA is out --- docs/designs/xenstore-migration.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/docs/designs/xenstore-migration.md b/docs/designs/xenstore-migration.md index 2ce2c836f5..f44bc0c61d 100644 --- a/docs/designs/xenstore-migration.md +++ b/docs/designs/xenstore-migration.md @@ -365,7 +365,8 @@ record previously present). | | 0x0001: read | | | 0x0002: written| | || -| | The value will be zero for a deleted node | +| | The value will be zero for a recursively | +| | deleted node | | || | `perm-count` | The number (N) of node permission specifiers | | | (which will be 0 for a node deleted in a | -- 2.29.2
[PATCH v2 2/8] Add workaround for xenstore-control flood issues
There are alternative fixes for this, e.g. do the entire live update
inside oxenstored and reply OK from the next oxenstored or an error.
This requires some asynchronous handling there.
Once that code is available we can revert this one.
Signed-off-by: Edwin Török
Reviewed-by: Pau Ruiz Safont
Reviewed-by: Christian Lindig
---
Changed since V1:
* post publicly now that the XSA is out
---
tools/xenstore/xenstore_control.c | 13 +
1 file changed, 13 insertions(+)
diff --git a/tools/xenstore/xenstore_control.c
b/tools/xenstore/xenstore_control.c
index 5ca015a07d..611e8b4fdd 100644
--- a/tools/xenstore/xenstore_control.c
+++ b/tools/xenstore/xenstore_control.c
@@ -42,6 +42,10 @@ static int live_update_start(struct xs_handle *xsh, bool
force, unsigned int to)
len = add_to_buf(&buf, "-F", len);
if (len < 0)
return 1;
+/* +1 for rounding issues
+ * +1 to give oxenstored a chance to timeout and report back first
+ */
+to += 2;
for (time_start = time(NULL); time(NULL) - time_start < to;) {
ret = xs_control_command(xsh, "live-update", buf, len);
@@ -49,6 +53,15 @@ static int live_update_start(struct xs_handle *xsh, bool
force, unsigned int to)
goto err;
if (strcmp(ret, "BUSY"))
break;
+/* TODO: use task ID for commands, avoid busy loop polling
+here
+ * oxenstored checks BUSY condition internally on every main
+loop iteration anyway.
+ * Avoid flooding xenstored with live-update requests.
+ * The flooding can also cause the evtchn to overflow in
+xenstored which makes
+ * xenstored enter an infinite loop */
+sleep(1);
}
if (strcmp(ret, "OK"))
--
2.29.2
[PATCH v2 5/8] tools/ocaml/xenstored: Automatically resume when possible
When a `db` file exists use it to resume oxenstored. It will contains a xenstore tree, domain reconnection info, and watches. It is currently missing data about all active socket connections, so a toolstack should ideally be stopped and restarted too. Tell systemd about oxenstored's PID and allow it to restart on success. This should make updating oxenstored as easy as: `systemctl stop -s SIGTERM xenstored` on a suitable xenstored version. Signed-off-by: Edwin Török Reviewed-by: Pau Ruiz Safont Reviewed-by: Christian Lindig --- Changed since V1: * post publicly now that the XSA is out --- tools/ocaml/xenstored/xenstored.ml | 12 +++- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml index 6b5381962b..500d96753b 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -292,9 +292,8 @@ let _ = List.iter (fun path -> Store.write store Perms.Connection.full_rights path "") Store.Path.specials; - let filename = Paths.xen_run_stored ^ "/db" in - if cf.restart && Sys.file_exists filename then ( - DB.from_file store domains cons filename; + if cf.restart && Sys.file_exists Disk.xs_daemon_database then ( + DB.from_file store domains cons Disk.xs_daemon_database; Event.bind_dom_exc_virq eventchn ) else ( if !Disk.enable then ( @@ -320,7 +319,7 @@ let _ = Sys.set_signal Sys.sigpipe Sys.Signal_ignore; if cf.activate_access_log then begin - let post_rotate () = DB.to_file store cons (Paths.xen_run_stored ^ "/db") in + let post_rotate () = DB.to_file store cons Disk.xs_daemon_database in Logging.init_access_log post_rotate end; @@ -494,5 +493,8 @@ let _ = raise exc done; info "stopping xenstored"; - DB.to_file store cons (Paths.xen_run_stored ^ "/db"); + DB.to_file store cons Disk.xs_daemon_database; + (* unlink pidfile so that launch-xenstore works again *) + Unixext.unlink_safe pidfile; + (match cf.pidfile with Some pidfile -> Unixext.unlink_safe pidfile | None -> ()); () -- 2.29.2
[PATCH v2 1/8] tools/xenstore: add live update command to xenstore-control
From: Juergen Gross
Add the "live-update" command to xenstore-control enabling updating
xenstored to a new version in a running Xen system.
With -c it is possible to pass a different command line to the
new instance of xenstored. This will replace the command line used
for the invocation of the just running xenstored instance.
The running xenstored (or xenstore-stubdom) needs to support live
updating, of course.
For now just add a small dummy handler to C xenstore denying any
live update action.
Signed-off-by: Juergen Gross
Reviewed-by: Paul Durrant
Reviewed-by: Julien Grall
---
docs/misc/xenstore.txt| 21 ++
tools/xenstore/Makefile | 3 +-
tools/xenstore/xenstore_control.c | 332 --
3 files changed, 339 insertions(+), 17 deletions(-)
diff --git a/docs/misc/xenstore.txt b/docs/misc/xenstore.txt
index 2081f20f55..1480742330 100644
--- a/docs/misc/xenstore.txt
+++ b/docs/misc/xenstore.txt
@@ -317,6 +317,27 @@ CONTROL|[|]
Current commands are:
check
checks xenstored innards
+ live-update||+
+ perform a live-update of the Xenstore daemon, only to
+ be used via xenstore-control command.
+are implementation specific and are used for
+ different steps of the live-update processing. Currently
+ supported are:
+ -f specify new daemon binary
+ -b specify size of new stubdom binary
+ -dtransfer chunk of new
+ stubdom binary
+ -c specify new command line to use
+ -s [-t ] [-F] start live update process (-t specifies
+ timeout in seconds to wait for active transactions
+ to finish, default is 60 seconds; -F will force
+ live update to happen even with running transactions
+ after timeout elapsed)
+ -a abort live update handling
+ All sub-options will return "OK" in case of success or an
+ error string in case of failure. -s can return "BUSY" in case
+ of an active transaction, a retry of -s can be done in that
+ case.
log|on
turn xenstore logging on
log|off
diff --git a/tools/xenstore/Makefile b/tools/xenstore/Makefile
index 9a0f0d012d..ab89e22d3a 100644
--- a/tools/xenstore/Makefile
+++ b/tools/xenstore/Makefile
@@ -11,6 +11,7 @@ CFLAGS += -include $(XEN_ROOT)/tools/config.h
CFLAGS += -I./include
CFLAGS += $(CFLAGS_libxenevtchn)
CFLAGS += $(CFLAGS_libxenctrl)
+CFLAGS += $(CFLAGS_libxenguest)
CFLAGS += $(CFLAGS_libxentoolcore)
CFLAGS += -DXEN_LIB_STORED="\"$(XEN_LIB_STORED)\""
CFLAGS += -DXEN_RUN_STORED="\"$(XEN_RUN_STORED)\""
@@ -81,7 +82,7 @@ xenstore: xenstore_client.o
$(CC) $< $(LDFLAGS) $(LDLIBS_libxenstore) $(LDLIBS_libxentoolcore)
$(SOCKET_LIBS) -o $@ $(APPEND_LDFLAGS)
xenstore-control: xenstore_control.o
- $(CC) $< $(LDFLAGS) $(LDLIBS_libxenstore) $(LDLIBS_libxentoolcore)
$(SOCKET_LIBS) -o $@ $(APPEND_LDFLAGS)
+ $(CC) $< $(LDFLAGS) $(LDLIBS_libxenstore) $(LDLIBS_libxenctrl)
$(LDLIBS_libxenguest) $(LDLIBS_libxentoolcore) $(SOCKET_LIBS) -o $@
$(APPEND_LDFLAGS)
xs_tdb_dump: xs_tdb_dump.o utils.o tdb.o talloc.o
$(CC) $^ $(LDFLAGS) -o $@ $(APPEND_LDFLAGS)
diff --git a/tools/xenstore/xenstore_control.c
b/tools/xenstore/xenstore_control.c
index afa04495a7..5ca015a07d 100644
--- a/tools/xenstore/xenstore_control.c
+++ b/tools/xenstore/xenstore_control.c
@@ -1,9 +1,311 @@
+#define _GNU_SOURCE
+#include
#include
#include
#include
+#include
+#include
+#include
#include "xenstore.h"
+/* Add a string plus terminating 0 byte to buf, returning new len. */
+static int add_to_buf(char **buf, const char *val, int len)
+{
+int vallen = strlen(val) + 1;
+
+if (len < 0)
+return -1;
+
+*buf = realloc(*buf, len + vallen);
+if (!*buf)
+return -1;
+
+strcpy(*buf + len, val);
+
+return len + vallen;
+}
+
+static int live_update_start(struct xs_handle *xsh, bool force, unsigned int
to)
+{
+int len = 0;
+char *buf = NULL, *ret;
+time_t time_start;
+
+if (asprintf(&ret, "%u", to) < 0)
+return 1;
+len = add_to_buf(&buf, "-s", len);
+len = add_to_buf(&buf, "-t", len);
+len = add_to_buf(&buf, ret, len);
+free(ret);
+if (force)
+len = add_to_buf(&buf, "-F", len);
+if (len < 0)
+return 1;
+
+for (time_start = time(NULL); time(NULL) - time_start < to;) {
+ret = xs_control_command(xsh, "live-update", buf, len);
+if (!ret)
+goto err;
+if (strcmp(ret, "BUSY"))
+break;
+}
+
+if (strcmp(ret, "OK"))
+goto err;
+
+free(buf);
+free(ret);
+
+return 0;
+
+ err:
+fprintf(stderr, "Starting live update failed:\n%s\n",
+re
[PATCH v2 4/8] tools/ocaml/xenstored: only quit on SIGTERM when a reload is possible
Currently when oxenstored receives SIGTERM it dumps its state and quits. It is possible to then restart it if --restart is given, however that is not always safe: * domains could have active transactions, and after a restart they would either reuse transaction IDs of already open transactions, or get an error back that the transaction doesn't exist * there could be pending data to send to a VM still in oxenstored's queue which would be lost * there could be pending input to be processed from a VM in oxenstored's queue which would be lost Prevent shutting down oxenstored via SIGTERM in the above situations. Also ignore domains marked as bad because oxenstored would never talk to them again. Signed-off-by: Edwin Török Reviewed-by: Pau Ruiz Safont Reviewed-by: Christian Lindig --- Changed since V1: * post publicly now that the XSA is out --- tools/ocaml/xenstored/connection.ml | 35 tools/ocaml/xenstored/connections.ml | 8 +++ tools/ocaml/xenstored/xenstored.ml | 13 +-- tools/xenstore/xenstored_core.c | 7 +- 4 files changed, 60 insertions(+), 3 deletions(-) diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml index fa0d3c4d92..bd02060cd0 100644 --- a/tools/ocaml/xenstored/connection.ml +++ b/tools/ocaml/xenstored/connection.ml @@ -290,6 +290,41 @@ let has_new_output con = Xenbus.Xb.has_new_output con.xb let peek_output con = Xenbus.Xb.peek_output con.xb let do_output con = Xenbus.Xb.output con.xb +let is_bad con = match con.dom with None -> false | Some dom -> Domain.is_bad_domain dom + +(* oxenstored currently only dumps limited information about its state. + A live update is only possible if any of the state that is not dumped would be empty. + Compared to https://xenbits.xen.org/docs/unstable/designs/xenstore-migration.html: + * GLOBAL_DATA: not strictly needed, systemd is giving the socket FDs to us + * CONNECTION_DATA: PARTIAL + * for domains: PARTIAL, see Connection.dump -> Domain.dump, only if data and tdomid is empty + * for sockets (Dom0 toolstack): NO + * WATCH_DATA: OK, see Connection.dump + * TRANSACTION_DATA: NO + * NODE_DATA: OK (except for transactions), see Store.dump_fct and DB.to_channel + + Also xenstored will never talk to a Domain once it is marked as bad, + so treat it as idle for live-update. + + 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_input con in + let has_out = has_output con in + let has_socket = con.dom = None in + let has_nondefault_perms = make_perm con.dom <> con.perm in + has_in || has_out + || 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 prevents_live_update con = not (is_bad con) + && (has_extra_connection_data con || has_transaction_data con) + let has_more_work con = has_more_input con || not (has_old_output con) && has_new_output con diff --git a/tools/ocaml/xenstored/connections.ml b/tools/ocaml/xenstored/connections.ml index 6ee3552ec2..82988f7e8d 100644 --- a/tools/ocaml/xenstored/connections.ml +++ b/tools/ocaml/xenstored/connections.ml @@ -194,3 +194,11 @@ 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 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 prevents_quit cons = filter ~f:Connection.prevents_live_update cons diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml index 39d6d767e4..6b5381962b 100644 --- a/tools/ocaml/xenstored/xenstored.ml +++ b/tools/ocaml/xenstored/xenstored.ml @@ -20,6 +20,7 @@ open Parse_arg open Stdext let error fmt = Logging.error "xenstored" fmt +let warn fmt = Logging.warn "xenstored" fmt let debug fmt = Logging.debug "xenstored" fmt let info fmt = Logging.info "xenstored" fmt @@ -312,7 +313,9 @@ let _ = ); Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler); - Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun _ -> quit := true)); + Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun _ -> +info "Received SIGTERM"; +quit := true)); Sys.set_signal Sys.sigusr
[PATCH v2 6/8] tools/ocaml/xenstored: add cooperative live-update command
See docs/misc/xenstore.txt for documentation on live-update command.
Validate that the binary exists and that the cmdline is valid,
to prevent typos from taking down xenstore
(if live-update fails there is no way back due to the use of execve).
Live update only proceeds if there are no active transactions,
and no unprocess input or unflushed output.
It is not yet possible to force the live-update.
Signed-off-by: Edwin Török
Reviewed-by: Pau Ruiz Safont
Reviewed-by: Christian Lindig
---
Changed since V1:
* post publicly now that the XSA is out
---
tools/ocaml/xenstored/process.ml | 112 +++
tools/ocaml/xenstored/stdext.ml | 6 ++
2 files changed, 118 insertions(+)
diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml
index 437d2dcf9e..c3c5dc58c0 100644
--- a/tools/ocaml/xenstored/process.ml
+++ b/tools/ocaml/xenstored/process.ml
@@ -15,6 +15,7 @@
*)
let error fmt = Logging.error "process" fmt
+let warn fmt = Logging.warn "process" fmt
let info fmt = Logging.info "process" fmt
let debug fmt = Logging.debug "process" fmt
@@ -84,11 +85,122 @@ let create_implicit_path t perm path =
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
+ ; pending: bool }
+
+let state =
+ ref
+ { binary= Sys.executable_name
+ ; cmdline= []
+ ; deadline= 0.
+ ; force= false
+ ; pending= false }
+
+let debug = Printf.eprintf
+
+let args_of_t t = (t.binary, "--restart" :: t.cmdline)
+
+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
+ 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 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}
+ | "-c" :: cmdline ->
+ validate_exn {!state with cmdline}
+ | "-s" :: _ ->
+ let timeout = ref 60 in
+ let force = ref false in
+ Arg.parse_argv ~current:(ref 1) (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)) ;
+ 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 (U
[PATCH v2 1/2] tools/ocaml/xenstored: trim txhistory on xenbus reconnect
There is a global history, containing transactions from the past 0.05s, which get trimmed whenever any transaction commits or aborts. Destroying a domain will cause xenopsd to perform some transactions deleting the tree, so that is fine. But I think that a domain can abuse the xenbus reconnect facility to cause a large history to be recorded - provided that noone does any transactions on the system inbetween, which may be difficult to achieve given squeezed's constant pinging. The theoretical situation is like this: - a domain starts a transaction, creates as large a tree as it can, commits it. Then repeatedly: - start a transaction, do nothing with it, start a transaction, delete part of the large tree, write some new unique data there, don't commit - cause a xenbus reconnect (I think this can be done by writing something to the ring). This causes all transactions/watches for the connection to be cleared, but NOT the history, there were no commits, so nobody trimmed the history, i.e. it the history can contain transactions from more than just 0.05s - loop back and start more transactions, you can keep this up indefinitely without hitting quotas Now there is a periodic History.trim running every 0.05s, so I don't think you can do much damage with it. But lets be safe an trim the transaction history anyway on reconnect. Signed-off-by: Edwin Török --- Changed since V1: * post publicly now that the XSA is out (not a security issue) --- tools/ocaml/xenstored/connection.ml | 2 +- tools/ocaml/xenstored/history.ml| 4 tools/ocaml/xenstored/process.ml| 4 ++-- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml index eb23c3af7a..1cf24beafd 100644 --- a/tools/ocaml/xenstored/connection.ml +++ b/tools/ocaml/xenstored/connection.ml @@ -47,7 +47,7 @@ let mark_as_bad con = let initial_next_tid = 1 -let reconnect con = +let do_reconnect con = Xenbus.Xb.reconnect con.xb; (* dom is the same *) Hashtbl.clear con.transactions; diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/history.ml index f39565bff5..3899353da8 100644 --- a/tools/ocaml/xenstored/history.ml +++ b/tools/ocaml/xenstored/history.ml @@ -53,6 +53,10 @@ let end_transaction txn con tid commit = trim ~txn (); success +let reconnect con = + trim (); + Connection.do_reconnect con + let push (x: history_record) = let dom = x.con.Connection.dom in match dom with diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml index dd50456ad5..da8e9cdb26 100644 --- a/tools/ocaml/xenstored/process.ml +++ b/tools/ocaml/xenstored/process.ml @@ -705,7 +705,7 @@ let do_input store cons doms con = Connection.do_input con with Xenbus.Xb.Reconnect -> info "%s requests a reconnect" (Connection.get_domstr con); - Connection.reconnect con; + History.reconnect con; info "%s reconnection complete" (Connection.get_domstr con); false | Failure exp -> @@ -744,7 +744,7 @@ let do_output _store _cons _doms con = ignore (Connection.do_output con) with Xenbus.Xb.Reconnect -> info "%s requests a reconnect" (Connection.get_domstr con); - Connection.reconnect con; + History.reconnect con; info "%s reconnection complete" (Connection.get_domstr con) ) -- 2.29.2
[PATCH v1 2/5] tools/ocaml/xenstored: implement the live migration binary format
This is implemented by C xenstored as live update dump format. oxenstored already has its own (text-based) dump format, but for compatibility implement one compatible with C xenstored. This will also be useful in the future for non-cooperative guest live migration. docs/designs/xenstore-migration.md documents the format For now this always dumps integers in big endian order, because even old versions of OCaml have support for that. The binary format supports both little and big endian orders, so this should be compatible. To dump in little endian or native endian order we would require OCaml 4.08+. Signed-off-by: Edwin Török --- tools/ocaml/xenstored/disk.ml | 318 ++ 1 file changed, 318 insertions(+) diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml index 4739967b61..595fdab54a 100644 --- a/tools/ocaml/xenstored/disk.ml +++ b/tools/ocaml/xenstored/disk.ml @@ -155,3 +155,321 @@ let write store = Unix.rename tfile xs_daemon_database with exc -> error "caught exn %s" (Printexc.to_string exc) + + module BinaryOut = struct + let version = 0x1 + let endian = 1 + let padding = String.make 7 '\x00' + + let write_header ch = + (* for testing endian order *) + output_binary_int ch 0x78656e73; + output_binary_int ch 0x746f7265; + output_binary_int ch version; + output_binary_int ch endian; + ch + + let w8 = output_char + let w16 ch i = + assert (i >= 0 && i lsr 16 = 0); + output_byte ch (i lsr 8); + output_byte ch i + + let w32 ch v = + assert (v >= 0 && v <= 0x_); + output_binary_int ch v + + let pos = pos_out + let wpad ch = + let padto = 8 in + let padby = (padto - pos ch mod padto) mod padto in + if padby > 0 then + output_substring ch padding 0 padby + + let wstring = output_string + end + + module BinaryIn = struct + type t = in_channel + + let read_header t = + let h = Bytes.make 8 '\x00' in + really_input t h 0 (Bytes.length h); + let ver = input_binary_int t in + let endian = input_binary_int t in + if Bytes.to_string h <> "xenstore" then + failwith "Header doesn't begin with 'xenstore'"; + if ver <> BinaryOut.version then + failwith "Incompatible version"; + if endian <> BinaryOut.endian then + failwith "Incompatible endianness" + + let r8 = input_char + + let r16 t = + let r0 = input_byte t in + let r1 = input_byte t in + (r0 lsl 8) lor r1 + + let r32 t = + (* read unsigned 32-bit int *) + let r = input_binary_int t land 0x_ in + assert (r >= 0); + r + + let rstring = really_input_string + + let rpad t = + let padto = 8 in + let padby = (padto - pos_in t mod padto) mod padto in + if padby > 0 then + ignore (really_input_string t padby) + end + +module FD : sig + 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" +end + +module LiveRecord = struct + (* See docs/designs/xenstore-migration.md for binary format *) + module Type : sig + type t = private int + val end_ : t + val global_data : t + val connection_data : t + val watch_data : t + val transaction_data : t + val node_data: t + end = struct + type t = int + let end_ = 0x0 + let global_data = 0x01 + let connection_data = 0x02 + let watch_data = 0x03 + let transaction_data = 0x04 + let node_da
[PATCH v2 7/8] tools/ocaml/xenstored: start live update process
Signed-off-by: Edwin Török
Reviewed-by: Pau Ruiz Safont
Reviewed-by: Christian Lindig
---
Changed since V1:
* post publicly now that the XSA is out
---
tools/ocaml/xenstored/logging.ml | 3 +++
tools/ocaml/xenstored/process.ml | 8 +---
tools/ocaml/xenstored/xenstored.ml | 29 ++---
3 files changed, 30 insertions(+), 10 deletions(-)
diff --git a/tools/ocaml/xenstored/logging.ml b/tools/ocaml/xenstored/logging.ml
index 1ede131329..39c3036155 100644
--- a/tools/ocaml/xenstored/logging.ml
+++ b/tools/ocaml/xenstored/logging.ml
@@ -327,6 +327,9 @@ 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
+let live_update () =
+ 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
diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml
index c3c5dc58c0..3174d8ede5 100644
--- a/tools/ocaml/xenstored/process.ml
+++ b/tools/ocaml/xenstored/process.ml
@@ -112,6 +112,7 @@ let string_of_t t =
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 =
@@ -151,7 +152,7 @@ let parse_live_update args =
| "-s" :: _ ->
let timeout = ref 60 in
let force = ref false in
- Arg.parse_argv ~current:(ref 1) (Array.of_list args)
+ 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"
@@ -166,7 +167,7 @@ let parse_live_update args =
{!state with deadline = Unix.gettimeofday () +.
float !timeout
; force= !force; pending= true}
| _ ->
- invalid_arg ("Unknown arguments: " ^ String.concat " "
args)) ;
+ invalid_arg ("Unknown arguments: " ^ String.concat ","
args)) ;
None
with
| Arg.Bad s | Arg.Help s | Invalid_argument s ->
@@ -200,7 +201,8 @@ let do_debug con t _domains cons data =
then None
else try match split None '\000' data with
| "live-update" :: params ->
- LiveUpdate.parse_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
diff --git a/tools/ocaml/xenstored/xenstored.ml
b/tools/ocaml/xenstored/xenstored.ml
index 500d96753b..22413271fb 100644
--- a/tools/ocaml/xenstored/xenstored.ml
+++ b/tools/ocaml/xenstored/xenstored.ml
@@ -311,6 +311,11 @@ let _ =
);
);
+ (* required for xenstore-control to detect availability of live-update
*)
+ Store.mkdir store Perms.Connection.full_rights (Store.Path.of_string
"/tool");
+ 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";
@@ -483,18 +488,28 @@ let _ =
in
Systemd.sd_notify_ready ();
+ let live_update = ref false in
while not (!quit && Connections.prevents_quit cons = [])
do
try
- main_loop ()
+ 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 Disk.xs_daemon_database;
+ quit := true;
+ end
with exc ->
- error "caught exception %s" (Printexc.to_string exc);
+ let bt = Printexc.get_backtrace () in
+ error "caught exception %s: %s" (Printexc.to_string
[PATCH v1 1/4] tools/ocaml/libs/xb: do not crash after xenbus is unmapped
Xenmmap.unmap sets the address to MAP_FAILED in xenmmap_stubs.c.
If due to a bug there were still references to the Xenbus and we attempt
to use it then we crash.
Raise an exception instead of crashing.
(My initial version of fuzz testing had such a bug)
Signed-off-by: Edwin Török
---
tools/ocaml/libs/xb/xs_ring_stubs.c | 3 +++
1 file changed, 3 insertions(+)
diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c
b/tools/ocaml/libs/xb/xs_ring_stubs.c
index 7537a23949..7a91fdee75 100644
--- a/tools/ocaml/libs/xb/xs_ring_stubs.c
+++ b/tools/ocaml/libs/xb/xs_ring_stubs.c
@@ -32,6 +32,7 @@
#include
#include
+#include
#include "mmap_stubs.h"
#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
@@ -166,6 +167,8 @@ 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");
intf->server_features = Int_val(v);
--
2.29.2
[PATCH v1 3/4] tools/ocaml/xenstored: reject invalid watch paths early
Watches on invalid paths were accepted, but they would never trigger. The client also got no notification that its watch is bad and would never trigger. Found again by the structured fuzzer, due to an error on live update reload: the invalid watch paths would get rejected during live update and the list of watches would be different pre/post live update. This was found by an older version of the fuzzer: ``` Test live-update failed (507 shrink steps): [NEW; (0, None, WATCH ([""; ""], "")); (0, None, CONTROL live-update ())] ``` The testcase is watch on `//`, which is an invalid path. Signed-off-by: Edwin Török --- tools/ocaml/xenstored/connection.ml | 5 ++--- tools/ocaml/xenstored/connections.ml | 4 +++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml index 1f9fe9e3b2..c7f22e5ee9 100644 --- a/tools/ocaml/xenstored/connection.ml +++ b/tools/ocaml/xenstored/connection.ml @@ -163,18 +163,17 @@ let get_children_watches con path = let is_dom0 con = Perms.Connection.is_dom0 (get_perm con) -let add_watch con path token = +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 apath = get_watch_path con path in 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; - apath, watch + watch let del_watch con path token = let apath = get_watch_path con path in diff --git a/tools/ocaml/xenstored/connections.ml b/tools/ocaml/xenstored/connections.ml index 8a66eeec3a..3c7429fe7f 100644 --- a/tools/ocaml/xenstored/connections.ml +++ b/tools/ocaml/xenstored/connections.ml @@ -114,8 +114,10 @@ let key_of_path path = "" :: Store.Path.to_string_list path let add_watch cons con path token = - let apath, watch = Connection.add_watch con path token in + 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 -- 2.29.2
[PATCH v1 3/5] tools/ocaml/xenstored: add binary dump format support
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/connection.ml | 63 +
1 file changed, 47 insertions(+), 16 deletions(-)
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index 51041dde8e..1f9fe9e3b2 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -17,6 +17,7 @@
exception End_of_file
open Stdext
+module LR = Disk.LiveRecord
let xenstore_payload_max = 4096 (* xen/include/public/io/xs_wire.h *)
@@ -77,6 +78,10 @@ let number_of_transactions con =
let get_domain con = con.dom
+let get_id con = match con.dom with
+| None -> 2*LR.domid_invalid + con.anonid
+| Some dom -> 1 + Domain.get_id dom
+
let anon_id_next = ref 1
let get_domstr con =
@@ -279,6 +284,9 @@ let end_transaction con tid commit =
let get_transaction con tid =
Hashtbl.find con.transactions tid
+let iter_transactions con f =
+ Hashtbl.iter f con.transactions
+
let do_input con = Xenbus.Xb.input con.xb
let has_input con = Xenbus.Xb.has_in_packet con.xb
let has_partial_input con = match con.xb.Xenbus.Xb.partial_in with
@@ -337,22 +345,45 @@ let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
let stats con =
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 serialize_pkt_in buf xb =
+ let open Xenbus.Xb in
+ Queue.iter (fun p -> Buffer.add_string buf (Packet.to_string p))
xb.pkt_in;
+ match xb.partial_in with
+ | NoHdr (to_read, hdrb) ->
+ (* see Xb.input *)
+ let used = Xenbus.Partial.header_size () - to_read in
+ Buffer.add_subbytes buf hdrb 0 used
+ | HaveHdr p ->
+ p |> Packet.of_partialpkt |> Packet.to_string |>
Buffer.add_string buf
+
+let serialize_pkt_out buf xb =
+ let open Xenbus.Xb in
+ Buffer.add_string buf xb.partial_out;
+ Queue.iter (fun p -> Buffer.add_string buf (Packet.to_string p))
xb.pkt_out
+
+let dump con store chan =
+ let conid = get_id con in
+ let conn = match con.dom with
+ | None -> LR.Socket (get_fd con)
+ | Some dom -> LR.Domain {
+ id = Domain.get_id dom;
+ target = LR.domid_invalid; (* TODO: we do not store this info
*)
+ remote_port = Domain.get_remote_port dom
+ } in
+ let pkt_in = Buffer.create 4096 in
+ let pkt_out = Buffer.create 4096 in
+ serialize_pkt_in pkt_in con.xb;
+ serialize_pkt_out pkt_out con.xb;
+ LR.write_connection_data chan ~conid ~conn pkt_in con.xb.partial_out
pkt_out;
+
+ con |> list_watches
+ |> List.rev (* preserve order in dump/reload *)
+ |> List.iter (fun (wpath, token) ->
+ LR.write_watch_data chan ~conid ~wpath ~token
+ );
+ let conpath = get_path con in
+ iter_transactions con (fun _ txn ->
+Transaction.dump store conpath ~conid txn chan)
let debug con =
let domid = get_domstr con in
--
2.29.2
[PATCH v4 3/4] tools/ocaml/xenstored: use more efficient node trees
This changes the output of xenstore-ls to be sorted.
Previously the keys were listed in the order in which they were inserted
in.
docs/misc/xenstore.txt doesn't specify in what order keys are listed.
Map.update is used to retain semantics with replace_child:
only an existing child is replaced, if it wasn't part of the original
map we don't add it.
Similarly exception behaviour is retained for del_childname and related
functions.
Entries are stored in reverse sort order, so that upon Map.fold the
constructed list is sorted in ascending order and there is no need for a
List.rev.
This changes the semantics and is not suitable as is for a backport.
It reveals bugs in buggy clients that depend on xenstore entry order,
however those clients should be fixed.
(We found one such bug in our internal testsuite where the first
xenstore entry from a subtree was always dropped, and changing the
listing order changed what key got dropped making the test fail)
Signed-off-by: Edwin Török
Acked-by: Christian Lindig
---
Changed since V3:
* repost after XSA to avoid conflicts
---
tools/ocaml/xenstored/store.ml | 48 +++-
tools/ocaml/xenstored/symbol.ml | 4 +++
tools/ocaml/xenstored/symbol.mli | 3 ++
3 files changed, 30 insertions(+), 25 deletions(-)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index 9c226e4ef7..5f155f45eb 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -16,17 +16,19 @@
*)
open Stdext
+module SymbolMap = Map.Make(Symbol)
+
module Node = struct
type t = {
name: Symbol.t;
perms: Perms.Node.t;
value: string;
- children: t list;
+ children: t SymbolMap.t;
}
let create _name _perms _value =
- { name = Symbol.of_string _name; perms = _perms; value = _value;
children = []; }
+ { 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
@@ -42,38 +44,34 @@ let set_value node nvalue =
let set_perms node nperms = { node with perms = nperms }
let add_child node child =
- { node with children = child :: node.children }
+ let children = SymbolMap.add child.name child node.children in
+ { node with children }
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.mem childname node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.find childname node.children
let replace_child node child nchild =
- (* this is the on-steroid version of the filter one-replace one *)
- let rec replace_one_in_list l =
- match l with
- | [] -> []
- | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
- | h :: tl -> h :: replace_one_in_list
tl
- in
- { node with children = (replace_one_in_list node.children) }
+ { 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
- let rec delete_one_in_list l =
- match l with
- | []-> raise Not_found
- | h :: tl when Symbol.equal h.name sym -> tl
- | h :: tl -> h :: delete_one_in_list tl
- in
- { node with children = (delete_one_in_list node.children) }
+ { node with children =
+ SymbolMap.update sym
+ (function None -> raise Not_found | Some _ -> None)
+ node.children
+ }
let del_all_children node =
- { node with children = [] }
+ { 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 =
@@ -87,12 +85,12 @@ let check_owner node connection =
raise Define.Permission_denied;
end
-let rec recurse fct node = fct node; List.iter (recurse fct) node.children
+let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct)
node.children
(** [recurse_map f tree] applies [f] on each node in the tree recursively *)
let recurse_map f =
let rec walk node =
- f { node with children = List.rev_map walk node.children |>
List.rev }
+ f { node with children = SymbolMap.map walk node.children }
in
[PATCH v1 2/4] tools/ocaml/xenstored: fix quota calculation for mkdir EEXIST
We increment the domain's quota on mkdir even when the node already
exists.
This results in a quota inconsistency after live update, where
reconstructing the tree from scratch results in a different quota.
Not a security issue because the domain uses up quota faster,
so it will only get a Quota error sooner than it should.
Discovered by the structured fuzzing test:
```
live-update-agree: FAIL
When given the input:
[{ "domid" = 0;
"cmd" = { "tid" = 0;
"rid" = 0;
"op" = MKDIR;
"data" = "/" } }; { "domid" = 0;
"cmd" = { "tid" = 0;
"rid" = 0;
"op" = DEBUG;
"data" = "live-update\000-s" } }]
the test failed:
store agrement: diff --git 1/tmp/expected5b4372.txt 2/tmp/actual1c18b5.txt
index ac39964836..af318026ec 100644
--- 1/tmp/expected5b4372.txt
+++ 2/tmp/actual1c18b5.txt
@@ -1,9 +1,9 @@
{ "stat_transaction_coalesce" = 0;
"stat_transaction_abort" = 0;
"store" = /{n0}
/tool{n0}
/local{n0}
;
"quota" = { "maxent" = 8192;
"maxsize" = 2048;
"cur" = (hashtbl (0, +3+))-2-)) } }
Fatal error: exception Crowbar.TestFailure
```
This shows that the quota was 2 instead of 3 after a live update.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/store.ml | 1 +
1 file changed, 1 insertion(+)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index a9c079a417..1a9f71fa62 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -420,6 +420,7 @@ let mkdir store perm path =
(* 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 =
--
2.29.2
[PATCH v1 4/4] tools/ocaml/xenstored: mkdir conflicts were sometimes missed
Due to how set_write_lowpath was used here it didn't detect create/delete conflicts. When we create an entry we must mark our parent as modified (this is what creating a new node via write does). Otherwise we can have 2 transactions one creating, and another deleting a node both succeeding depending on timing. Or one transaction reading an entry, concluding it doesn't exist, do some other work based on that information and successfully commit even if another transaction creates the node via mkdir meanwhile. Signed-off-by: Edwin Török --- tools/ocaml/xenstored/transaction.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/ocaml/xenstored/transaction.ml b/tools/ocaml/xenstored/transaction.ml index 4ee77b6e14..0466b04ae3 100644 --- a/tools/ocaml/xenstored/transaction.ml +++ b/tools/ocaml/xenstored/transaction.ml @@ -172,7 +172,7 @@ let write t perm path value = let mkdir ?(with_watch=true) t perm path = Store.mkdir t.store perm path; - set_write_lowpath t path; + set_write_lowpath t (Store.Path.get_parent path); if with_watch then add_wop t Xenbus.Xb.Op.Mkdir path -- 2.29.2
[PATCH v1 5/5] Add structured fuzzing unit test
Based on ideas from qcstm, implemented using Crowbar. Quickcheck-style property tests that uses AFL for quickly exploring various values that trigger bugs in the code. This is structured/guided fuzzing: we read an arbitrary random number, and use it to generate some valid looking xenstore trees and commands. There are 2 instances of xenstored: one that runs the live update command, and one that ignores it. Live-update should be a no-op wrt to xenstored state: this is our quicheck property. When any mismatch is identified it prints the input (tree+xenstore commands), and a diff of the output: the internal xenstore tree state + quotas. afl-cmin can be used to further minimize the testcase. Crowbar (AFL persistent mode Quickcheck integration) is used due to speed: this very easily gets us a multi-core parallelizable test. Currently the Transaction tests fail, which is why live updates with active transactions are rejected. TODO: split out the non-working transaction code, and drop some obsolete code. There is also some incomplete code here that attempts to find functional bugs in xenstored by interpeting xenstore commands in a simpler way and comparing states. This will build the fuzzer and run it single core for sanity test: make container-fuzz-sanity-test This will run it multicore (requires all dependencies installed on the host, including ocaml-bun, the multi-core AFL runner): make dune-oxenstored-fuzz 'make check' will also run the fuzzer but with input supplied by OCaml's random number generator, and for a very small number of iterations (few thousand). This doesn't require any external tools (no AFL, bun). On failure it prints a base64 encoding of the fuzzer state that can be used to reproduce the failure instantly, which is very useful for debugging: one can iterate on the failed fuzzer state until it is fixed, and then run the fuzzer again to find next failure. The unit tests here require OCaml 4.06, but the rest of the codebase doesn't (yet). See https://lore.kernel.org/xen-devel/cbb2742191e9c1303fdfd95feef4d829ecf33a0d.ca...@citrix.com/ for previous discussion of OCaml version. Signed-off-by: Edwin Török --- tools/ocaml/Makefile | 19 + tools/ocaml/xenstored/process.ml | 12 +- tools/ocaml/xenstored/store.ml| 1 + tools/ocaml/xenstored/test/generator.ml | 189 + tools/ocaml/xenstored/test/model.ml | 253 ++ tools/ocaml/xenstored/test/old/arbitrary.ml | 261 +++ tools/ocaml/xenstored/test/old/gen_paths.ml | 66 ++ .../xenstored/test/old/xenstored_test.ml | 527 + tools/ocaml/xenstored/test/pathtree.ml| 40 + tools/ocaml/xenstored/test/testable.ml| 364 + tools/ocaml/xenstored/test/types.ml | 427 ++ tools/ocaml/xenstored/test/xenstored_test.ml | 149 +++- tools/ocaml/xenstored/test/xs_protocol.ml | 733 ++ tools/ocaml/xenstored/transaction.ml | 119 ++- 14 files changed, 3151 insertions(+), 9 deletions(-) create mode 100644 tools/ocaml/xenstored/test/generator.ml create mode 100644 tools/ocaml/xenstored/test/model.ml create mode 100644 tools/ocaml/xenstored/test/old/arbitrary.ml create mode 100644 tools/ocaml/xenstored/test/old/gen_paths.ml create mode 100644 tools/ocaml/xenstored/test/old/xenstored_test.ml create mode 100644 tools/ocaml/xenstored/test/pathtree.ml create mode 100644 tools/ocaml/xenstored/test/testable.ml create mode 100644 tools/ocaml/xenstored/test/types.ml create mode 100644 tools/ocaml/xenstored/test/xs_protocol.ml diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index 53dd0a0f0d..de375820a3 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -67,3 +67,22 @@ dune-syntax-check: dune-pre .PHONY: build-oxenstored-dune dune-build-oxenstored: dune-pre LD_LIBRARY_PATH=$(LIBRARY_PATH) LIBRARY_PATH=$(LIBRARY_PATH) C_INCLUDE_PATH=$(C_INCLUDE_PATH) dune build --profile=release @all + +.PHONY: oxenstored-fuzz1 oxenstored-fuzz +dune-oxenstored-fuzz: dune-pre + # --force is needed, otherwise it would cache a successful run + sh -c '. /etc/profile && C_INCLUDE_PATH=$(C_INCLUDE_PATH) dune build --profile=release --no-buffer --force @fuzz' + +dune-oxenstored-fuzz1: dune-pre + sh -c '. /etc/profile && C_INCLUDE_PATH=$(C_INCLUDE_PATH) dune build --profile=release --no-buffer --force @fuzz1' + +.PHONY: container-fuzz +container-fuzz-sanity-test: + dune clean + podman build -t oxenstored-fuzz . + # if UID is 0 then we get EPERM on setrlimit from inside the container + # use containerize script which ensures that uid is not 0 + # (podman/docker run would get us a uid of 0) + # Only do a sanity test with 1 core, actually doing fuzzing inside a container is a bad idea + # due to FUSE overlayfs overhead + CONTAINER=oxenstored-fuzz CO
[PATCH v4 2/4] tools/ocaml/xenstored: backport find_opt/update from 4.06
We are currently on OCaml 4.02 as minimum version.
To make the followup optimizations compile backport these functions from
OCaml 4.06.
This implementation is less efficient than the one in the 4.06 standard
library which has access to the internals of the Map.
Signed-off-by: Edwin Török
---
Changed since V3:
* repost after XSA to avoid conflicts
---
tools/ocaml/xenstored/stdext.ml | 19 +++
tools/ocaml/xenstored/trie.ml | 2 ++
2 files changed, 21 insertions(+)
diff --git a/tools/ocaml/xenstored/stdext.ml b/tools/ocaml/xenstored/stdext.ml
index e1567c4dfa..0640602449 100644
--- a/tools/ocaml/xenstored/stdext.ml
+++ b/tools/ocaml/xenstored/stdext.ml
@@ -50,6 +50,25 @@ module Filename = struct
cmd :: args |> List.map quote |> String.concat " "
end
+module Map = struct
+module Make(Ord: Map.OrderedType) = struct
+
+include Map.Make(Ord)
+
+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
+
+end
+end
+
module String = struct include String
let of_char c = String.make 1 c
diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
index dc42535092..f513f4e608 100644
--- a/tools/ocaml/xenstored/trie.ml
+++ b/tools/ocaml/xenstored/trie.ml
@@ -13,6 +13,8 @@
* GNU Lesser General Public License for more details.
*)
+open Stdext
+
module Node =
struct
type ('a,'b) t = {
--
2.29.2
[PATCH v2 2/2] tools/ocaml/libs/xc: backward compatible domid control at domain creation time
One can specify the domid to use when creating the domain, but this was
hardcoded to 0.
Keep the existing `domain_create` function, and make domid an optional argument.
When not specified default to 0.
A new version of xenopsd can choose to start using this, while old versions of
xenopsd will keep
building and using the old API.
(The ABI will change, but that changes every time a function is
introduced/removed or modified)
Controlling the domid can be useful during testing or migration.
Signed-off-by: Edwin Török
Acked-by: Christian Lindig
---
Changed since V1:
* introduced an optional ?domid for better backwards compatibility
* use CAMLparam3 because we have an additional parameter
---
tools/ocaml/libs/xc/xenctrl.ml | 5 -
tools/ocaml/libs/xc/xenctrl.mli | 4 ++--
tools/ocaml/libs/xc/xenctrl_stubs.c | 6 +++---
3 files changed, 9 insertions(+), 6 deletions(-)
diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml
index e878699b0a..e0a47c4769 100644
--- a/tools/ocaml/libs/xc/xenctrl.ml
+++ b/tools/ocaml/libs/xc/xenctrl.ml
@@ -179,9 +179,12 @@ let with_intf f =
handle := Some h;
f h
-external domain_create: handle -> domctl_create_config -> domid
+external domain_create_stub: handle -> domid -> domctl_create_config -> domid
= "stub_xc_domain_create"
+let domain_create handle ?(domid=0) config =
+ domain_create_stub handle domid config
+
external domain_sethandle: handle -> domid -> string -> unit
= "stub_xc_domain_sethandle"
diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli
index e64907df8e..84311fa33d 100644
--- a/tools/ocaml/libs/xc/xenctrl.mli
+++ b/tools/ocaml/libs/xc/xenctrl.mli
@@ -143,8 +143,8 @@ val get_handle: unit -> handle option
* would invalidate the handle that with_intf passes to its argument. *)
val close_handle: unit -> unit
-external domain_create : handle -> domctl_create_config -> domid
- = "stub_xc_domain_create"
+val domain_create: handle -> ?domid:int -> domctl_create_config -> domid
+
external domain_sethandle : handle -> domid -> string -> unit =
"stub_xc_domain_sethandle"
external domain_max_vcpus : handle -> domid -> int -> unit
= "stub_xc_domain_max_vcpus"
diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c
b/tools/ocaml/libs/xc/xenctrl_stubs.c
index 94aba38a42..9a8dbe5579 100644
--- a/tools/ocaml/libs/xc/xenctrl_stubs.c
+++ b/tools/ocaml/libs/xc/xenctrl_stubs.c
@@ -175,9 +175,9 @@ static unsigned int ocaml_list_to_c_bitmap(value l)
return val;
}
-CAMLprim value stub_xc_domain_create(value xch, value config)
+CAMLprim value stub_xc_domain_create(value xch, value wanted_domid, value
config)
{
- CAMLparam2(xch, config);
+ CAMLparam3(xch, wanted_domid, config);
CAMLlocal2(l, arch_domconfig);
/* Mnemonics for the named fields inside domctl_create_config */
@@ -191,7 +191,7 @@ CAMLprim value stub_xc_domain_create(value xch, value
config)
#define VAL_MAX_MAPTRACK_FRAMES Field(config, 7)
#define VAL_ARCHField(config, 8)
- uint32_t domid = 0;
+ uint32_t domid = Int_val(wanted_domid);
int result;
struct xen_domctl_createdomain cfg = {
.ssidref = Int32_val(VAL_SSIDREF),
--
2.29.2
[PATCH v1 4/5] tools/ocaml/xenstored: add support for binary format
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/perms.ml | 2 +
tools/ocaml/xenstored/xenstored.ml | 201 -
2 files changed, 173 insertions(+), 30 deletions(-)
diff --git a/tools/ocaml/xenstored/perms.ml b/tools/ocaml/xenstored/perms.ml
index e8a16221f8..61c1c60083 100644
--- a/tools/ocaml/xenstored/perms.ml
+++ b/tools/ocaml/xenstored/perms.ml
@@ -69,6 +69,8 @@ let remove_domid ~domid perm =
let default0 = create 0 NONE []
+let acls t = (t.owner, t.other) :: t.acl
+
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
diff --git a/tools/ocaml/xenstored/xenstored.ml
b/tools/ocaml/xenstored/xenstored.ml
index e25b407303..9338190804 100644
--- a/tools/ocaml/xenstored/xenstored.ml
+++ b/tools/ocaml/xenstored/xenstored.ml
@@ -141,7 +141,8 @@ exception Bad_format of string
let dump_format_header = "$xenstored-dump-format"
-let from_channel_f chan global_f socket_f domain_f watch_f store_f =
+(* for backwards compatibility with already released live-update *)
+let from_channel_f_compat 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
@@ -186,7 +187,7 @@ let from_channel_f chan global_f socket_f domain_f watch_f
store_f =
done;
info "Completed loading xenstore dump"
-let from_channel store cons doms chan =
+let from_channel_compat ~live 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
@@ -226,43 +227,183 @@ let from_channel store cons doms chan =
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;
+ from_channel_f_compat 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)
+module LR = Disk.LiveRecord
+
+let from_channel_f_bin chan on_global_data on_connection_data on_watch_data
on_transaction_data on_node_data =
+ Disk.BinaryIn.read_header chan;
+ let quit = ref false in
+ let on_end () = quit := true in
+ let errors = ref 0 in
+ while not !quit
+ do
+ try
+ LR.read_record chan ~on_end ~on_global_data
~on_connection_data ~on_watch_data ~on_transaction_data ~on_node_data
+ with exn ->
+ let bt = Printexc.get_backtrace () in
+ incr errors;
+ Logging.warn "xenstored" "restoring: ignoring faulty
record (exception: %s): %s" (Printexc.to_string exn) bt
+ done;
+info "Completed loading xenstore dump";
+ !errors
+
+
+let from_channel_bin ~live store cons doms chan =
+ (* don't let the permission get on our way, full perm ! *)
+ let maintx = Transaction.make ~internal:true Transaction.none store in
+ let fullperm = Perms.Connection.full_rights in
+ let fds = ref None in
+ let allcons = Hashtbl.create 1021 in
+ let contxid_to_op = Hashtbl.create 1021 in
+ let global_f ~rw_sock =
+ (* file descriptors are only valid on a live-reload, a cold
restart won't have them *)
+ if live then
+ fds := Some rw_sock
+ in
+ let domain_f ~conid ~conn ~in_data ~out_data ~out_resp_len =
+ let con = match conn with
+ | LR.Domain { LR.id = 0; _ } ->
+ (* Dom0 is precreated *)
+ Connections.find_domain cons 0
+ | LR.Domain d ->
+ debug "Recreating domain %d, port %d" d.id
d.remote_port;
+ (* FIXME: gnttab *)
+ Domains.create doms d.id 0n d.remote_port
+ |> Connections.add_domain cons;
+ Connections.find_domain cons d.id
+ | LR.Socket fd ->
+ debug "Recreating open socket";
+ (* TODO: rw/ro flag *)
+ Connections.add_anonymous cons fd;
+ Connections.find cons fd
+ in
+ Hashtbl.add allcons conid con
+ in
+ let watch_f ~conid ~wpath ~token =
+ let con = Hashtbl.find allcons conid in
+ ignore (Connections.add_watch cons con wpath token);
+ ()
+ in
+ let transaction_f ~conid ~txid =
+ let con = Hashtbl.find allcons co
[PATCH v4 1/4] tools/ocaml/xenstored: replace hand rolled GC with weak GC references
The code here is attempting to reduce memory usage by sharing common
substrings in the tree: it replaces strings with ints, and keeps a
string->int map that gets manually garbage collected using a hand-rolled
mark and sweep algorithm.
This is unnecessary: OCaml already has a mark-and-sweep Garbage
Collector runtime, and sharing of common strings in tree nodes
can be achieved through Weak references: if the string hasn't been seen
yet it gets added to the Weak reference table, and if it has we use the
entry from the table instead, thus storing a string only once.
When the string is no longer referenced OCaml's GC will drop it from the
weak table: there is no need to manually do a mark-and-sweep, or to tell
OCaml when to drop it.
Signed-off-by: Edwin Török
Acked-by: Christian Lindig
---
Changed since V3:
* repost after XSA to avoid conflicts
---
tools/ocaml/xenstored/connection.ml | 3 --
tools/ocaml/xenstored/history.ml| 14 --
tools/ocaml/xenstored/store.ml | 11 ++---
tools/ocaml/xenstored/symbol.ml | 68 ++---
tools/ocaml/xenstored/symbol.mli| 21 ++---
tools/ocaml/xenstored/xenstored.ml | 16 +--
6 files changed, 24 insertions(+), 109 deletions(-)
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index 1cf24beafd..51041dde8e 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -334,9 +334,6 @@ let has_more_work con =
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
-let mark_symbols con =
- Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t))
con.transactions
-
let stats con =
Hashtbl.length con.watches, con.stat_nb_ops
diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/history.ml
index 3899353da8..ba5c9cb571 100644
--- a/tools/ocaml/xenstored/history.ml
+++ b/tools/ocaml/xenstored/history.ml
@@ -22,20 +22,6 @@ type history_record = {
let history : history_record list ref = ref []
-(* Called from periodic_ops to ensure we don't discard symbols that are still
needed. *)
-(* There is scope for optimisation here, since in consecutive commits one
commit's `after`
- * is the same thing as the next commit's `before`, but not all commits in
history are
- * consecutive. *)
-let mark_symbols () =
- (* There are gaps where dom0's commits are missing. Otherwise we could
assume that
-* each element's `before` is the same thing as the next element's
`after`
-* since the next element is the previous commit *)
- List.iter (fun hist_rec ->
- Store.mark_symbols hist_rec.before;
- Store.mark_symbols hist_rec.after;
- )
- !history
-
(* Keep only enough commit-history to protect the running transactions that we
are still tracking *)
(* There is scope for optimisation here, replacing List.filter with something
more efficient,
* probably on a different list-like structure. *)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index a3be2e6bbe..9c226e4ef7 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -46,18 +46,18 @@ let add_child node child =
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> n.name = childname) node.children
+ List.exists (fun n -> Symbol.equal n.name childname) node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> n.name = childname) node.children
+ List.find (fun n -> Symbol.equal n.name childname) node.children
let replace_child node child nchild =
(* this is the on-steroid version of the filter one-replace one *)
let rec replace_one_in_list l =
match l with
| [] -> []
- | h :: tl when h.name = child.name -> nchild :: tl
+ | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
| h :: tl -> h :: replace_one_in_list
tl
in
{ node with children = (replace_one_in_list node.children) }
@@ -67,7 +67,7 @@ let del_childname node childname =
let rec delete_one_in_list l =
match l with
| []-> raise Not_found
- | h :: tl when h.name = sym -> tl
+ | h :: tl when Symbol.equal h.name sym -> tl
| h :: tl -> h :: delete_one_in_list tl
in
{ node with children = (delete_one_in_list node.children) }
@@ -489,9 +489,6 @@ let copy store = {
quota = Quota.copy store.quota;
}
-let mark_symbols store =
- Node.recurse (fun node -> Symbol.mark_as_used node.Node.name)
[PATCH v1 1/5] tools/ocaml: add unit test skeleton with Dune build system
Based on initial work by Christian Lindig Doing oxenstored development, especially fuzzing/unit tests requires an incremental and fast build system. Dune is the preferred upstream build system for OCaml, and has been in use by the XAPI project for years. Is is incremental and also generates editor integration files (.merlin). Usage: ./xs-reconfigure.sh cd tools/ocaml make clean make check There are some other convenience targets as well: make dune-clean make dune-syntax-check make dune-build-oxenstored There are some files that are generated by Make, these are created by a 'dune-pre' target, they are too closely tied to make and cannot yet be generated by Dune itself. The various Makefile targets are used as entrypoints into Dune that set the needed env vars (for C include files and libraries) and ensure that the generated files are available. The unit tests do not require Xen to be available, so add mock eventchn and xenctrl libraries for the unit test to use, and copy the non-system specific modules from xenstored/ to xenstored/test/. Xenstored had to be split into Xenstored and Xenstored_main, so that we can use the functions defined in Xenstored without actually starting up the daemon in a unit test. Similarly argument parsing had to be delayed until after daemon startup. Also had to disable setrlimit when running as non-root in poll.ml. Signed-off-by: Edwin Török --- tools/ocaml/.gitignore | 2 + tools/ocaml/Makefile | 33 + tools/ocaml/dune-project | 5 ++ tools/ocaml/libs/eventchn/dune | 8 tools/ocaml/libs/mmap/dune | 8 tools/ocaml/libs/xb/dune | 7 +++ tools/ocaml/libs/xc/dune | 9 tools/ocaml/libs/xs/dune | 4 ++ tools/ocaml/xen.opam | 0 tools/ocaml/xenstore.opam| 0 tools/ocaml/xenstored.opam | 18 +++ tools/ocaml/xenstored/Makefile | 3 +- tools/ocaml/xenstored/dune | 19 tools/ocaml/xenstored/parse_arg.ml | 2 +- tools/ocaml/xenstored/poll.ml| 3 +- tools/ocaml/xenstored/test/dune | 11 + tools/ocaml/xenstored/test/xenctrl.ml| 48 +++ tools/ocaml/xenstored/test/xeneventchn.ml| 50 tools/ocaml/xenstored/test/xenstored_test.ml | 2 + tools/ocaml/xenstored/xenstored.ml | 4 +- 20 files changed, 231 insertions(+), 5 deletions(-) create mode 100644 tools/ocaml/.gitignore create mode 100644 tools/ocaml/dune-project create mode 100644 tools/ocaml/libs/eventchn/dune create mode 100644 tools/ocaml/libs/mmap/dune create mode 100644 tools/ocaml/libs/xb/dune create mode 100644 tools/ocaml/libs/xc/dune create mode 100644 tools/ocaml/libs/xs/dune create mode 100644 tools/ocaml/xen.opam create mode 100644 tools/ocaml/xenstore.opam create mode 100644 tools/ocaml/xenstored.opam create mode 100644 tools/ocaml/xenstored/dune create mode 100644 tools/ocaml/xenstored/test/dune create mode 100644 tools/ocaml/xenstored/test/xenctrl.ml create mode 100644 tools/ocaml/xenstored/test/xeneventchn.ml create mode 100644 tools/ocaml/xenstored/test/xenstored_test.ml diff --git a/tools/ocaml/.gitignore b/tools/ocaml/.gitignore new file mode 100644 index 00..655e32b07c --- /dev/null +++ b/tools/ocaml/.gitignore @@ -0,0 +1,2 @@ +_build +.merlin diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index a7c04b6546..53dd0a0f0d 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -34,3 +34,36 @@ build-tools-oxenstored: $(MAKE) -s -C libs/xb $(MAKE) -s -C libs/xc $(MAKE) -C xenstored + +LIBRARY_PATH=$(XEN_libxenctrl):$(XEN_libxenguest):$(XEN_libxentoollog):$(XEN_libxencall):$(XEN_libxenevtchn):$(XEN_libxenforeignmemory):$(XEN_libxengnttab):$(XEN_libxendevicemodel):$(XEN_libxentoolcore) +C_INCLUDE_PATH=$(XEN_libxenctrl)/include:$(XEN_libxengnttab)/include:$(XEN_libxenevtchn)/include:$(XEN_libxentoollog)/include:$(XEN_INCLUDE) + +# Files generated by the Makefile +# These cannot be generated from dune, because dune cannot refer to files +# in the parent directory (so it couldn't copy/use Config.mk) +.PHONY: dune-pre +dune-pre: + $(MAKE) -s -C ../../ build-tools-public-headers + $(MAKE) -s -C libs/xs paths.ml + $(MAKE) -s -C libs/xc xenctrl_abi_check.h + $(MAKE) -s -C xenstored paths.ml _paths.h + +.PHONY: check +check: dune-pre + # --force isn't necessary here if the test is deterministic + OCAMLRUNPARAM=b C_INCLUDE_PATH=$(C_INCLUDE_PATH) dune runtest --profile=release --no-buffer --force + +# Convenience targets for development + +.PHONY: dune-clean +dune-clean: + $(MAKE) clean + dune clean + +.PHONY: dune-syntax-check +dune-syntax-check: dune-pre + LIBRARY_PATH=$(LIBRARY_
[PATCH v2 8/8] tools/ocaml/xenstored: Implement live update for socket connections
From: Edvin Torok
Signed-off-by: Edwin Török
Reviewed-by: Pau Ruiz Safont
Reviewed-by: Christian Lindig
---
Changed since V1
* post publicly now that the XSA is out
---
tools/ocaml/xenstored/connection.ml | 25 +---
tools/ocaml/xenstored/parse_arg.ml | 4 ++
tools/ocaml/xenstored/process.ml| 51 -
tools/ocaml/xenstored/store.ml | 2 +-
tools/ocaml/xenstored/utils.ml | 12
tools/ocaml/xenstored/xenstored.ml | 88 +
6 files changed, 138 insertions(+), 44 deletions(-)
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index bd02060cd0..eb23c3af7a 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -281,6 +281,9 @@ let get_transaction con tid =
let do_input con = Xenbus.Xb.input con.xb
let has_input con = Xenbus.Xb.has_in_packet con.xb
+let has_partial_input con = match con.xb.Xenbus.Xb.partial_in with
+ | HaveHdr _ -> true
+ | NoHdr (n, _) -> n < Xenbus.Partial.header_size ()
let pop_in con = Xenbus.Xb.get_in_packet con.xb
let has_more_input con = Xenbus.Xb.has_more_input con.xb
@@ -309,12 +312,13 @@ 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_input con in
+ let has_in = has_input con || has_partial_input con in
let has_out = has_output con in
let has_socket = con.dom = None in
let has_nondefault_perms = make_perm con.dom <> con.perm in
has_in || has_out
- || has_socket (* dom0 sockets not dumped yet *)
+ (* 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 =
@@ -337,16 +341,21 @@ let stats con =
Hashtbl.length con.watches, con.stat_nb_ops
let dump con chan =
- match con.dom with
+ let id = match con.dom with
| Some dom ->
let domid = Domain.get_id dom in
(* dump domain *)
Domain.dump dom chan;
- (* dump watches *)
- List.iter (fun (path, token) ->
- Printf.fprintf chan "watch,%d,%s,%s\n" domid
(Utils.hexify path) (Utils.hexify token)
- ) (list_watches con);
- | None -> ()
+ 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
diff --git a/tools/ocaml/xenstored/parse_arg.ml
b/tools/ocaml/xenstored/parse_arg.ml
index 2c4b5a8528..7c0478e76a 100644
--- a/tools/ocaml/xenstored/parse_arg.ml
+++ b/tools/ocaml/xenstored/parse_arg.ml
@@ -24,6 +24,7 @@ type config =
pidfile: string option; (* old xenstored compatibility *)
tracefile: string option; (* old xenstored compatibility *)
restart: bool;
+ live_reload: bool;
disable_socket: bool;
}
@@ -35,6 +36,7 @@ let do_argv =
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
@@ -52,6 +54,7 @@ let do_argv =
("--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
@@ -65,5 +68,6 @@ let do_argv =
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/process.ml b/tools/ocaml/xenstored/process.ml
index 3174d8ede5..dd50456ad
[PATCH v4 4/4] tools/ocaml/xenstored: use more efficient tries
No functional change, just an optimization.
Signed-off-by: Edwin Török
Acked-by: Christian Lindig
---
Changed since V3:
* repost after XSA to avoid conflicts
---
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/symbol.ml | 6 +--
tools/ocaml/xenstored/trie.ml| 59
tools/ocaml/xenstored/trie.mli | 26 ++--
4 files changed, 43 insertions(+), 50 deletions(-)
diff --git a/tools/ocaml/xenstored/connections.ml
b/tools/ocaml/xenstored/connections.ml
index 82988f7e8d..8a66eeec3a 100644
--- a/tools/ocaml/xenstored/connections.ml
+++ b/tools/ocaml/xenstored/connections.ml
@@ -21,7 +21,7 @@ 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: (string, Connection.watch list) Trie.t;
+ mutable watches: Connection.watch list Trie.t;
}
let create () = {
diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml
index 301639f16f..72a84ebf80 100644
--- a/tools/ocaml/xenstored/symbol.ml
+++ b/tools/ocaml/xenstored/symbol.ml
@@ -31,9 +31,9 @@ let equal a b =
(* compare using physical equality, both members have to be part of the
above weak table *)
a == b
-let compare a b =
- if equal a b then 0
- else -(String.compare a b)
+(* the sort order is reversed here, so that Map.fold constructs a list
+ in ascending order *)
+let compare a b = String.compare b a
let stats () =
let len, entries, _, _, _, _ = WeakTable.stats tbl in
diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
index f513f4e608..ad2aed5123 100644
--- a/tools/ocaml/xenstored/trie.ml
+++ b/tools/ocaml/xenstored/trie.ml
@@ -15,24 +15,26 @@
open Stdext
+module StringMap = Map.Make(String)
+
module Node =
struct
- type ('a,'b) t = {
- key: 'a;
- value: 'b option;
- children: ('a,'b) t list;
+ type 'a t = {
+ key: string;
+ value: 'a option;
+ children: 'a t StringMap.t;
}
let _create key value = {
key = key;
value = Some value;
- children = [];
+ children = StringMap.empty;
}
let empty key = {
key = key;
value = None;
- children = []
+ children = StringMap.empty;
}
let _get_key node = node.key
@@ -49,41 +51,31 @@ struct
{ node with children = children }
let _add_child node child =
- { node with children = child :: node.children }
+ { node with children = StringMap.add child.key child
node.children }
end
-type ('a,'b) t = ('a,'b) Node.t list
+type 'a t = 'a Node.t StringMap.t
let mem_node nodes key =
- List.exists (fun n -> n.Node.key = key) nodes
+ StringMap.mem key nodes
let find_node nodes key =
- List.find (fun n -> n.Node.key = key) nodes
+ StringMap.find key nodes
let replace_node nodes key node =
- let rec aux = function
- | []-> []
- | h :: tl when h.Node.key = key -> node :: tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> None | Some _ -> Some node) nodes
let remove_node nodes key =
- let rec aux = function
- | []-> raise Not_found
- | h :: tl when h.Node.key = key -> tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> raise Not_found | Some _ ->
None) nodes
-let create () = []
+let create () = StringMap.empty
let rec iter f tree =
- let aux node =
- f node.Node.key node.Node.value;
+ let aux key node =
+ f key node.Node.value;
iter f node.Node.children
in
- List.iter aux tree
+ StringMap.iter aux tree
let rec map f tree =
let aux node =
@@ -94,13 +86,14 @@ let rec map f tree =
in
{ node with Node.value = value; Node.children = map f
node.Node.children }
in
- List.filter (fun n -> n.Node.value <> None || n.Node.children <> [])
(List.map aux tree)
+ 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 accu node =
- fold f node.Node.children (f node.Node.key node.Node.value accu)
+ let aux key node accu =
+ fold f node.Node.children (f key node.Node.val
[PATCH v1 0/1] oxenstored: fix ABI breakage in reset watches
dbc84d2983969bb47d294131ed9e6bbbdc2aec49 (Xen >= 4.9.0) deleted XS_RESTRICT from oxenstored, which caused all the following opcodes to be shifted by 1, breaking the ABI compared to the C version and guests. The affected opcode is 'reset watches', e.g. Linux uses this during kexec if a suitable control/platform-feature-xs_reset_watches field is present in xenstore. Edwin Török (1): oxenstored: fix ABI breakage introduced in Xen 4.9.0 tools/ocaml/libs/xb/op.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) -- 2.25.1
[PATCH v1 1/1] oxenstored: fix ABI breakage introduced in Xen 4.9.0
dbc84d2983969bb47d294131ed9e6bbbdc2aec49 (Xen >= 4.9.0) deleted XS_RESTRICT from oxenstored, which caused all the following opcodes to be shifted by 1: reset_watches became off-by-one compared to the C version of xenstored. Looking at the C code the opcode for reset watches needs: XS_RESET_WATCHES = XS_SET_TARGET + 2 So add the placeholder `Invalid` in the OCaml<->C mapping list. (Note that the code here doesn't simply convert the OCaml constructor to an integer, so we don't need to introduce a dummy constructor). Igor says that with a suitably patched xenopsd to enable watch reset, we now see `reset watches` during kdump of a guest in xenstored-access.log. Signed-off-by: Edwin Török Tested-by: Igor Druzhinin --- tools/ocaml/libs/xb/op.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml index d4f1f08185..9bcab0f38c 100644 --- a/tools/ocaml/libs/xb/op.ml +++ b/tools/ocaml/libs/xb/op.ml @@ -28,7 +28,7 @@ let operation_c_mapping = Transaction_end; Introduce; Release; Getdomainpath; Write; Mkdir; Rm; Setperms; Watchevent; Error; Isintroduced; - Resume; Set_target; Reset_watches |] + Resume; Set_target; Invalid; Reset_watches |] let size = Array.length operation_c_mapping let array_search el a = -- 2.25.1
[PATCH v1 0/6] tools/ocaml/xenstored: simplify code
Fix warnings, and delete some obsolete code.
oxenstored contained a hand-rolled GC to perform hash-consing:
this can be done with a lot fewer lines of code by using the built-in Weak
module.
The choice of data structures for trees/tries is not very efficient: they are
just
lists. Using a map improves lookup and deletion complexity, and replaces
hand-rolled
recursion with higher-level library calls.
There is a lot more that could be done to optimize socket polling:
an epoll backend with a poll fallback,but API structured around event-based
polling
would be better. But first lets drop the legacy select based code: I think every
modern *nix should have a working poll(3) by now.
This is a draft series, in need of more testing.
Edwin Török (6):
tools/ocaml/libs/xc: Fix ambiguous documentation comment
tools/ocaml/xenstored: fix deprecation warning
tools/ocaml/xenstored: replace hand rolled GC with weak GC references
tools/ocaml/xenstored: drop select based
tools/ocaml/xenstored: use more efficient node trees
tools/ocaml/xenstored: use more efficient tries
tools/ocaml/libs/xc/xenctrl.mli | 2 +
tools/ocaml/xenstored/connection.ml | 3 -
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/disk.ml | 2 +-
tools/ocaml/xenstored/history.ml | 14
tools/ocaml/xenstored/parse_arg.ml| 7 +-
tools/ocaml/xenstored/{select.ml => poll.ml} | 14 +---
.../ocaml/xenstored/{select.mli => poll.mli} | 12 +---
tools/ocaml/xenstored/store.ml| 49 ++---
tools/ocaml/xenstored/symbol.ml | 70 +--
tools/ocaml/xenstored/symbol.mli | 22 ++
tools/ocaml/xenstored/trie.ml | 61 +++-
tools/ocaml/xenstored/trie.mli| 26 +++
tools/ocaml/xenstored/xenstored.ml| 20 +-
14 files changed, 98 insertions(+), 206 deletions(-)
rename tools/ocaml/xenstored/{select.ml => poll.ml} (85%)
rename tools/ocaml/xenstored/{select.mli => poll.mli} (58%)
--
2.25.1
[PATCH v1 2/6] tools/ocaml/xenstored: fix deprecation warning
``` File "xenstored/disk.ml", line 33, characters 9-23: 33 |let c = Char.lowercase c in ^^ (alert deprecated): Stdlib.Char.lowercase Use Char.lowercase_ascii instead. ``` Signed-off-by: Edwin Török --- tools/ocaml/xenstored/disk.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml index 4739967b61..1ca0e2a95e 100644 --- a/tools/ocaml/xenstored/disk.ml +++ b/tools/ocaml/xenstored/disk.ml @@ -30,7 +30,7 @@ let undec c = | _ -> raise (Failure "undecify") let unhex c = - let c = Char.lowercase c in + let c = Char.lowercase_ascii c in match c with | '0' .. '9' -> (Char.code c) - (Char.code '0') | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10 -- 2.25.1
[PATCH v1 3/6] tools/ocaml/xenstored: replace hand rolled GC with weak GC references
The code here is attempting to reduce memory usage by sharing common
substrings in the tree: it replaces strings with ints, and keeps a
string->int map that gets manually garbage collected using a hand-rolled
mark and sweep algorithm.
This is unnecessary: OCaml already has a mark-and-sweep Garbage
Collector runtime, and sharing of common strings in tree nodes
can be achieved through Weak references: if the string hasn't been seen
yet it gets added to the Weak reference table, and if it has we use the
entry from the table instead, thus storing a string only once.
When the string is no longer referenced OCaml's GC will drop it from the
weak table: there is no need to manually do a mark-and-sweep, or to tell
OCaml when to drop it.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/connection.ml | 3 --
tools/ocaml/xenstored/history.ml| 14 --
tools/ocaml/xenstored/store.ml | 11 ++---
tools/ocaml/xenstored/symbol.ml | 68 ++---
tools/ocaml/xenstored/symbol.mli| 21 ++---
tools/ocaml/xenstored/xenstored.ml | 16 +--
6 files changed, 24 insertions(+), 109 deletions(-)
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index 24750ada43..aa6dd95501 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -271,9 +271,6 @@ let has_more_work con =
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
-let mark_symbols con =
- Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t))
con.transactions
-
let stats con =
Hashtbl.length con.watches, con.stat_nb_ops
diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/history.ml
index f39565bff5..029802bd15 100644
--- a/tools/ocaml/xenstored/history.ml
+++ b/tools/ocaml/xenstored/history.ml
@@ -22,20 +22,6 @@ type history_record = {
let history : history_record list ref = ref []
-(* Called from periodic_ops to ensure we don't discard symbols that are still
needed. *)
-(* There is scope for optimisation here, since in consecutive commits one
commit's `after`
- * is the same thing as the next commit's `before`, but not all commits in
history are
- * consecutive. *)
-let mark_symbols () =
- (* There are gaps where dom0's commits are missing. Otherwise we could
assume that
-* each element's `before` is the same thing as the next element's
`after`
-* since the next element is the previous commit *)
- List.iter (fun hist_rec ->
- Store.mark_symbols hist_rec.before;
- Store.mark_symbols hist_rec.after;
- )
- !history
-
(* Keep only enough commit-history to protect the running transactions that we
are still tracking *)
(* There is scope for optimisation here, replacing List.filter with something
more efficient,
* probably on a different list-like structure. *)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index f299ec6461..45659a23ee 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -46,18 +46,18 @@ let add_child node child =
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> n.name = childname) node.children
+ List.exists (fun n -> Symbol.equal n.name childname) node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> n.name = childname) node.children
+ List.find (fun n -> Symbol.equal n.name childname) node.children
let replace_child node child nchild =
(* this is the on-steroid version of the filter one-replace one *)
let rec replace_one_in_list l =
match l with
| [] -> []
- | h :: tl when h.name = child.name -> nchild :: tl
+ | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
| h :: tl -> h :: replace_one_in_list
tl
in
{ node with children = (replace_one_in_list node.children) }
@@ -67,7 +67,7 @@ let del_childname node childname =
let rec delete_one_in_list l =
match l with
| []-> raise Not_found
- | h :: tl when h.name = sym -> tl
+ | h :: tl when Symbol.equal h.name sym -> tl
| h :: tl -> h :: delete_one_in_list tl
in
{ node with children = (delete_one_in_list node.children) }
@@ -463,9 +463,6 @@ let copy store = {
quota = Quota.copy store.quota;
}
-let mark_symbols store =
- Node.recurse (fun node -> Symbol.mark_as_used node.Node.name) store.root
-
let incr_transaction_coalesce store =
store.stat_transaction_coalesce &l
[PATCH v1 4/6] tools/ocaml/xenstored: drop select based
Poll has been the default since 2014, I think we can safely say by now
that poll() works and we don't need to fall back to select().
This will allow fixing up the way we call poll to be more efficient
(and pave the way for introducing epoll support):
currently poll wraps the select API, which is inefficient.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/Makefile | 12 ++--
tools/ocaml/xenstored/parse_arg.ml | 7 ++-
tools/ocaml/xenstored/{select.ml => poll.ml} | 14 ++
tools/ocaml/xenstored/{select.mli => poll.mli} | 12 ++--
tools/ocaml/xenstored/xenstored.ml | 4 +---
5 files changed, 13 insertions(+), 36 deletions(-)
rename tools/ocaml/xenstored/{select.ml => poll.ml} (85%)
rename tools/ocaml/xenstored/{select.mli => poll.mli} (58%)
diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile
index 68d35c483a..692a62584e 100644
--- a/tools/ocaml/xenstored/Makefile
+++ b/tools/ocaml/xenstored/Makefile
@@ -18,12 +18,12 @@ OCAMLINCLUDE += \
-I $(OCAML_TOPLEVEL)/libs/xc \
-I $(OCAML_TOPLEVEL)/libs/eventchn
-LIBS = syslog.cma syslog.cmxa select.cma select.cmxa
+LIBS = syslog.cma syslog.cmxa poll.cma poll.cmxa
syslog_OBJS = syslog
syslog_C_OBJS = syslog_stubs
-select_OBJS = select
-select_C_OBJS = select_stubs
-OCAML_LIBRARY = syslog select
+poll_OBJS = poll
+poll_C_OBJS = select_stubs
+OCAML_LIBRARY = syslog poll
LIBS += systemd.cma systemd.cmxa
systemd_OBJS = systemd
@@ -58,13 +58,13 @@ OBJS = paths \
process \
xenstored
-INTF = symbol.cmi trie.cmi syslog.cmi systemd.cmi select.cmi
+INTF = symbol.cmi trie.cmi syslog.cmi systemd.cmi poll.cmi
XENSTOREDLIBS = \
unix.cmxa \
-ccopt -L -ccopt . syslog.cmxa \
-ccopt -L -ccopt . systemd.cmxa \
- -ccopt -L -ccopt . select.cmxa \
+ -ccopt -L -ccopt . poll.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap
$(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn
$(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc
$(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \
diff --git a/tools/ocaml/xenstored/parse_arg.ml
b/tools/ocaml/xenstored/parse_arg.ml
index 1803c3eda0..2c4b5a8528 100644
--- a/tools/ocaml/xenstored/parse_arg.ml
+++ b/tools/ocaml/xenstored/parse_arg.ml
@@ -25,7 +25,6 @@ type config =
tracefile: string option; (* old xenstored compatibility *)
restart: bool;
disable_socket: bool;
- use_select: bool;
}
let do_argv =
@@ -37,7 +36,7 @@ let do_argv =
and config_file = ref ""
and restart = ref false
and disable_socket = ref false
- and use_select = ref false in
+ in
let speclist =
[ ("--no-domain-init", Arg.Unit (fun () -> domain_init :=
false),
@@ -54,9 +53,8 @@ let do_argv =
("-T", Arg.Set_string tracefile, ""); (* for compatibility *)
("--restart", Arg.Set restart, "Read database on starting");
("--disable-socket", Arg.Unit (fun () -> disable_socket :=
true), "Disable socket");
- ("--use-select", Arg.Unit (fun () -> use_select := true),
"Use select instead of poll"); (* for backward compatibility and testing *)
] in
- let usage_msg = "usage : xenstored [--config-file ]
[--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart]
[--disable-socket] [--use-select]" 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;
@@ -68,5 +66,4 @@ let do_argv =
tracefile = if !tracefile <> "" then Some !tracefile else None;
restart = !restart;
disable_socket = !disable_socket;
- use_select = !use_select;
}
diff --git a/tools/ocaml/xenstored/select.ml b/tools/ocaml/xenstored/poll.ml
similarity index 85%
rename from tools/ocaml/xenstored/select.ml
rename to tools/ocaml/xenstored/poll.ml
index 0455e163e3..26f8620dfc 100644
--- a/tools/ocaml/xenstored/select.ml
+++ b/tools/ocaml/xenstored/poll.ml
@@ -63,15 +63,5 @@ let poll_select in_fds out_fds exc_fds timeout =
(if event.except then fd :: x else x))
a r
-(* If the use_poll function is not called at all, we default to the original
Unix.select behavior *)
-let select_fun = ref Unix.select
-
-let use_poll yes =
- let sel_fun, max_fd =
- if yes then poll_select, get_sys_fs_nr_open ()
- else Unix.select, 1024 i
[PATCH v1 1/6] tools/ocaml/libs/xc: Fix ambiguous documentation comment
Signed-off-by: Edwin Török --- tools/ocaml/libs/xc/xenctrl.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli index 26ec7e59b1..f7f6ec570d 100644 --- a/tools/ocaml/libs/xc/xenctrl.mli +++ b/tools/ocaml/libs/xc/xenctrl.mli @@ -132,8 +132,10 @@ external interface_close : handle -> unit = "stub_xc_interface_close" * interface_open and interface_close or with_intf although mixing both * is possible *) val with_intf : (handle -> 'a) -> 'a + (** [get_handle] returns the global handle used by [with_intf] *) val get_handle: unit -> handle option + (** [close handle] closes the handle maintained by [with_intf]. This * should only be closed before process exit. It must not be called from * a function called directly or indirectly by with_intf as this -- 2.25.1
[PATCH v1 5/6] tools/ocaml/xenstored: use more efficient node trees
This changes the output of xenstore-ls to be sorted.
Previously the keys were listed in the order in which they were inserted
in.
docs/misc/xenstore.txt doesn't specify in what order keys are listed.
Map.update is used to retain semantics with replace_child:
only an existing child is replaced, if it wasn't part of the original
map we don't add it.
Similarly exception behaviour is retained for del_childname and related
functions.
Entries are stored in reverse sort order, so that upon Map.fold the
constructed list is sorted in ascending order and there is no need for a
List.rev.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/store.ml | 46 +++-
tools/ocaml/xenstored/symbol.ml | 4 +++
tools/ocaml/xenstored/symbol.mli | 3 +++
3 files changed, 29 insertions(+), 24 deletions(-)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index 45659a23ee..d9dfa36045 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -16,17 +16,19 @@
*)
open Stdext
+module SymbolMap = Map.Make(Symbol)
+
module Node = struct
type t = {
name: Symbol.t;
perms: Perms.Node.t;
value: string;
- children: t list;
+ children: t SymbolMap.t;
}
let create _name _perms _value =
- { name = Symbol.of_string _name; perms = _perms; value = _value;
children = []; }
+ { 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
@@ -42,38 +44,34 @@ let set_value node nvalue =
let set_perms node nperms = { node with perms = nperms }
let add_child node child =
- { node with children = child :: node.children }
+ let children = SymbolMap.add child.name child node.children in
+ { node with children }
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.mem childname node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.find childname node.children
let replace_child node child nchild =
- (* this is the on-steroid version of the filter one-replace one *)
- let rec replace_one_in_list l =
- match l with
- | [] -> []
- | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
- | h :: tl -> h :: replace_one_in_list
tl
- in
- { node with children = (replace_one_in_list node.children) }
+ { 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
- let rec delete_one_in_list l =
- match l with
- | []-> raise Not_found
- | h :: tl when Symbol.equal h.name sym -> tl
- | h :: tl -> h :: delete_one_in_list tl
- in
- { node with children = (delete_one_in_list node.children) }
+ { node with children =
+ SymbolMap.update sym
+ (function None -> raise Not_found | Some _ -> None)
+ node.children
+ }
let del_all_children node =
- { node with children = [] }
+ { 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 =
@@ -87,7 +85,7 @@ let check_owner node connection =
raise Define.Permission_denied;
end
-let rec recurse fct node = fct node; List.iter (recurse fct) node.children
+let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct)
node.children
let unpack node = (Symbol.to_string node.name, node.perms, node.value)
@@ -321,7 +319,7 @@ let ls store perm path =
Node.check_perm cnode perm Perms.READ;
cnode.Node.children in
Path.apply store.root path do_ls in
- List.rev (List.map (fun n -> Symbol.to_string n.Node.name) children)
+ SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children []
let getperms store perm path =
if path = [] then
@@ -350,7 +348,7 @@ 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
- List.iter (_traversal node_path) node.Node.children
+
[PATCH v1 6/6] tools/ocaml/xenstored: use more efficient tries
No functional change, just an optimization.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/trie.ml| 61
tools/ocaml/xenstored/trie.mli | 26 ++--
3 files changed, 41 insertions(+), 48 deletions(-)
diff --git a/tools/ocaml/xenstored/connections.ml
b/tools/ocaml/xenstored/connections.ml
index f02ef6b526..4983c7370b 100644
--- a/tools/ocaml/xenstored/connections.ml
+++ b/tools/ocaml/xenstored/connections.ml
@@ -21,7 +21,7 @@ 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: (string, Connection.watch list) Trie.t;
+ mutable watches: Connection.watch list Trie.t;
}
let create () = {
diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
index dc42535092..f4ef97742f 100644
--- a/tools/ocaml/xenstored/trie.ml
+++ b/tools/ocaml/xenstored/trie.ml
@@ -13,24 +13,26 @@
* GNU Lesser General Public License for more details.
*)
+module StringMap = Map.Make(String)
+
module Node =
struct
- type ('a,'b) t = {
- key: 'a;
- value: 'b option;
- children: ('a,'b) t list;
+ type 'a t = {
+ key: string;
+ value: 'a option;
+ children: 'a t StringMap.t;
}
let _create key value = {
key = key;
value = Some value;
- children = [];
+ children = StringMap.empty;
}
let empty key = {
key = key;
value = None;
- children = []
+ children = StringMap.empty;
}
let _get_key node = node.key
@@ -47,41 +49,31 @@ struct
{ node with children = children }
let _add_child node child =
- { node with children = child :: node.children }
+ { node with children = StringMap.add child.key child
node.children }
end
-type ('a,'b) t = ('a,'b) Node.t list
+type 'a t = 'a Node.t StringMap.t
let mem_node nodes key =
- List.exists (fun n -> n.Node.key = key) nodes
+ StringMap.mem key nodes
let find_node nodes key =
- List.find (fun n -> n.Node.key = key) nodes
+ StringMap.find key nodes
let replace_node nodes key node =
- let rec aux = function
- | []-> []
- | h :: tl when h.Node.key = key -> node :: tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> None | Some _ -> Some node) nodes
let remove_node nodes key =
- let rec aux = function
- | []-> raise Not_found
- | h :: tl when h.Node.key = key -> tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> raise Not_found | Some _ ->
None) nodes
-let create () = []
+let create () = StringMap.empty
let rec iter f tree =
- let aux node =
- f node.Node.key node.Node.value;
+ let aux key node =
+ f key node.Node.value;
iter f node.Node.children
in
- List.iter aux tree
+ StringMap.iter aux tree
let rec map f tree =
let aux node =
@@ -92,13 +84,14 @@ let rec map f tree =
in
{ node with Node.value = value; Node.children = map f
node.Node.children }
in
- List.filter (fun n -> n.Node.value <> None || n.Node.children <> [])
(List.map aux tree)
+ 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 accu node =
- fold f node.Node.children (f node.Node.key node.Node.value accu)
+ let aux key node accu =
+ fold f node.Node.children (f key node.Node.value accu)
in
- List.fold_left aux acc tree
+ StringMap.fold aux tree acc
(* return a sub-trie *)
let rec sub_node tree = function
@@ -115,7 +108,7 @@ let rec sub_node tree = function
let sub tree path =
try (sub_node tree path).Node.children
- with Not_found -> []
+ with Not_found -> StringMap.empty
let find tree path =
Node.get_value (sub_node tree path)
@@ -158,8 +151,8 @@ and set tree path value =
let node = find_node tree h in
replace_node tree h (set_node node t value)
end else begin
- let node = N
[PATCH v2 1/6] tools/ocaml/libs/xc: Fix ambiguous documentation comment
Signed-off-by: Edwin Török --- tools/ocaml/libs/xc/xenctrl.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli index 26ec7e59b1..f7f6ec570d 100644 --- a/tools/ocaml/libs/xc/xenctrl.mli +++ b/tools/ocaml/libs/xc/xenctrl.mli @@ -132,8 +132,10 @@ external interface_close : handle -> unit = "stub_xc_interface_close" * interface_open and interface_close or with_intf although mixing both * is possible *) val with_intf : (handle -> 'a) -> 'a + (** [get_handle] returns the global handle used by [with_intf] *) val get_handle: unit -> handle option + (** [close handle] closes the handle maintained by [with_intf]. This * should only be closed before process exit. It must not be called from * a function called directly or indirectly by with_intf as this -- 2.25.1
[PATCH v2 4/6] tools/ocaml/xenstored: drop select based socket watching
Poll has been the default since 2014, I think we can safely say by now
that poll() works and we don't need to fall back to select().
This will allow fixing up the way we call poll to be more efficient
(and pave the way for introducing epoll support):
currently poll wraps the select API, which is inefficient.
Signed-off-by: Edwin Török
---
Changed since v1:
* fix commit title
---
tools/ocaml/xenstored/Makefile | 12 ++--
tools/ocaml/xenstored/parse_arg.ml | 7 ++-
tools/ocaml/xenstored/{select.ml => poll.ml} | 14 ++
tools/ocaml/xenstored/{select.mli => poll.mli} | 12 ++--
tools/ocaml/xenstored/xenstored.ml | 4 +---
5 files changed, 13 insertions(+), 36 deletions(-)
rename tools/ocaml/xenstored/{select.ml => poll.ml} (85%)
rename tools/ocaml/xenstored/{select.mli => poll.mli} (58%)
diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile
index 68d35c483a..692a62584e 100644
--- a/tools/ocaml/xenstored/Makefile
+++ b/tools/ocaml/xenstored/Makefile
@@ -18,12 +18,12 @@ OCAMLINCLUDE += \
-I $(OCAML_TOPLEVEL)/libs/xc \
-I $(OCAML_TOPLEVEL)/libs/eventchn
-LIBS = syslog.cma syslog.cmxa select.cma select.cmxa
+LIBS = syslog.cma syslog.cmxa poll.cma poll.cmxa
syslog_OBJS = syslog
syslog_C_OBJS = syslog_stubs
-select_OBJS = select
-select_C_OBJS = select_stubs
-OCAML_LIBRARY = syslog select
+poll_OBJS = poll
+poll_C_OBJS = select_stubs
+OCAML_LIBRARY = syslog poll
LIBS += systemd.cma systemd.cmxa
systemd_OBJS = systemd
@@ -58,13 +58,13 @@ OBJS = paths \
process \
xenstored
-INTF = symbol.cmi trie.cmi syslog.cmi systemd.cmi select.cmi
+INTF = symbol.cmi trie.cmi syslog.cmi systemd.cmi poll.cmi
XENSTOREDLIBS = \
unix.cmxa \
-ccopt -L -ccopt . syslog.cmxa \
-ccopt -L -ccopt . systemd.cmxa \
- -ccopt -L -ccopt . select.cmxa \
+ -ccopt -L -ccopt . poll.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap
$(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn
$(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc
$(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \
diff --git a/tools/ocaml/xenstored/parse_arg.ml
b/tools/ocaml/xenstored/parse_arg.ml
index 1803c3eda0..2c4b5a8528 100644
--- a/tools/ocaml/xenstored/parse_arg.ml
+++ b/tools/ocaml/xenstored/parse_arg.ml
@@ -25,7 +25,6 @@ type config =
tracefile: string option; (* old xenstored compatibility *)
restart: bool;
disable_socket: bool;
- use_select: bool;
}
let do_argv =
@@ -37,7 +36,7 @@ let do_argv =
and config_file = ref ""
and restart = ref false
and disable_socket = ref false
- and use_select = ref false in
+ in
let speclist =
[ ("--no-domain-init", Arg.Unit (fun () -> domain_init :=
false),
@@ -54,9 +53,8 @@ let do_argv =
("-T", Arg.Set_string tracefile, ""); (* for compatibility *)
("--restart", Arg.Set restart, "Read database on starting");
("--disable-socket", Arg.Unit (fun () -> disable_socket :=
true), "Disable socket");
- ("--use-select", Arg.Unit (fun () -> use_select := true),
"Use select instead of poll"); (* for backward compatibility and testing *)
] in
- let usage_msg = "usage : xenstored [--config-file ]
[--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart]
[--disable-socket] [--use-select]" 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;
@@ -68,5 +66,4 @@ let do_argv =
tracefile = if !tracefile <> "" then Some !tracefile else None;
restart = !restart;
disable_socket = !disable_socket;
- use_select = !use_select;
}
diff --git a/tools/ocaml/xenstored/select.ml b/tools/ocaml/xenstored/poll.ml
similarity index 85%
rename from tools/ocaml/xenstored/select.ml
rename to tools/ocaml/xenstored/poll.ml
index 0455e163e3..26f8620dfc 100644
--- a/tools/ocaml/xenstored/select.ml
+++ b/tools/ocaml/xenstored/poll.ml
@@ -63,15 +63,5 @@ let poll_select in_fds out_fds exc_fds timeout =
(if event.except then fd :: x else x))
a r
-(* If the use_poll function is not called at all, we default to the original
Unix.select behavior *)
-let select_fun = ref Unix.select
-
-let use_poll yes =
- let sel_fun, max_fd =
- if yes then poll_select, get_sys_fs_nr_open ()
-
[PATCH v2 3/6] tools/ocaml/xenstored: replace hand rolled GC with weak GC references
The code here is attempting to reduce memory usage by sharing common
substrings in the tree: it replaces strings with ints, and keeps a
string->int map that gets manually garbage collected using a hand-rolled
mark and sweep algorithm.
This is unnecessary: OCaml already has a mark-and-sweep Garbage
Collector runtime, and sharing of common strings in tree nodes
can be achieved through Weak references: if the string hasn't been seen
yet it gets added to the Weak reference table, and if it has we use the
entry from the table instead, thus storing a string only once.
When the string is no longer referenced OCaml's GC will drop it from the
weak table: there is no need to manually do a mark-and-sweep, or to tell
OCaml when to drop it.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/connection.ml | 3 --
tools/ocaml/xenstored/history.ml| 14 --
tools/ocaml/xenstored/store.ml | 11 ++---
tools/ocaml/xenstored/symbol.ml | 68 ++---
tools/ocaml/xenstored/symbol.mli| 21 ++---
tools/ocaml/xenstored/xenstored.ml | 16 +--
6 files changed, 24 insertions(+), 109 deletions(-)
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index 24750ada43..aa6dd95501 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -271,9 +271,6 @@ let has_more_work con =
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
-let mark_symbols con =
- Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t))
con.transactions
-
let stats con =
Hashtbl.length con.watches, con.stat_nb_ops
diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/history.ml
index f39565bff5..029802bd15 100644
--- a/tools/ocaml/xenstored/history.ml
+++ b/tools/ocaml/xenstored/history.ml
@@ -22,20 +22,6 @@ type history_record = {
let history : history_record list ref = ref []
-(* Called from periodic_ops to ensure we don't discard symbols that are still
needed. *)
-(* There is scope for optimisation here, since in consecutive commits one
commit's `after`
- * is the same thing as the next commit's `before`, but not all commits in
history are
- * consecutive. *)
-let mark_symbols () =
- (* There are gaps where dom0's commits are missing. Otherwise we could
assume that
-* each element's `before` is the same thing as the next element's
`after`
-* since the next element is the previous commit *)
- List.iter (fun hist_rec ->
- Store.mark_symbols hist_rec.before;
- Store.mark_symbols hist_rec.after;
- )
- !history
-
(* Keep only enough commit-history to protect the running transactions that we
are still tracking *)
(* There is scope for optimisation here, replacing List.filter with something
more efficient,
* probably on a different list-like structure. *)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index f299ec6461..45659a23ee 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -46,18 +46,18 @@ let add_child node child =
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> n.name = childname) node.children
+ List.exists (fun n -> Symbol.equal n.name childname) node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> n.name = childname) node.children
+ List.find (fun n -> Symbol.equal n.name childname) node.children
let replace_child node child nchild =
(* this is the on-steroid version of the filter one-replace one *)
let rec replace_one_in_list l =
match l with
| [] -> []
- | h :: tl when h.name = child.name -> nchild :: tl
+ | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
| h :: tl -> h :: replace_one_in_list
tl
in
{ node with children = (replace_one_in_list node.children) }
@@ -67,7 +67,7 @@ let del_childname node childname =
let rec delete_one_in_list l =
match l with
| []-> raise Not_found
- | h :: tl when h.name = sym -> tl
+ | h :: tl when Symbol.equal h.name sym -> tl
| h :: tl -> h :: delete_one_in_list tl
in
{ node with children = (delete_one_in_list node.children) }
@@ -463,9 +463,6 @@ let copy store = {
quota = Quota.copy store.quota;
}
-let mark_symbols store =
- Node.recurse (fun node -> Symbol.mark_as_used node.Node.name) store.root
-
let incr_transaction_coalesce store =
store.stat_transaction_coalesce &l
[PATCH v2 6/6] tools/ocaml/xenstored: use more efficient tries
No functional change, just an optimization.
Signed-off-by: Edwin Török
---
Changed since v1:
* fix missing 'set_node' in 'set' that got lost in conversion to map
* simplify 'compare' function
---
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/symbol.ml | 6 +--
tools/ocaml/xenstored/trie.ml| 59
tools/ocaml/xenstored/trie.mli | 26 ++--
4 files changed, 43 insertions(+), 50 deletions(-)
diff --git a/tools/ocaml/xenstored/connections.ml
b/tools/ocaml/xenstored/connections.ml
index f02ef6b526..4983c7370b 100644
--- a/tools/ocaml/xenstored/connections.ml
+++ b/tools/ocaml/xenstored/connections.ml
@@ -21,7 +21,7 @@ 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: (string, Connection.watch list) Trie.t;
+ mutable watches: Connection.watch list Trie.t;
}
let create () = {
diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml
index 2697915623..85b3f265de 100644
--- a/tools/ocaml/xenstored/symbol.ml
+++ b/tools/ocaml/xenstored/symbol.ml
@@ -31,9 +31,9 @@ let equal a b =
(* compare using physical equality, both members have to be part of the
above weak table *)
a == b
-let compare a b =
- if equal a b then 0
- else -(String.compare a b)
+(* the sort order is reversed here, so that Map.fold constructs a list
+ in ascending order *)
+let compare a b = String.compare b a
let stats () =
let len, entries, _, _, _, _ = WeakTable.stats tbl in
diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
index dc42535092..5b4831cf02 100644
--- a/tools/ocaml/xenstored/trie.ml
+++ b/tools/ocaml/xenstored/trie.ml
@@ -13,24 +13,26 @@
* GNU Lesser General Public License for more details.
*)
+module StringMap = Map.Make(String)
+
module Node =
struct
- type ('a,'b) t = {
- key: 'a;
- value: 'b option;
- children: ('a,'b) t list;
+ type 'a t = {
+ key: string;
+ value: 'a option;
+ children: 'a t StringMap.t;
}
let _create key value = {
key = key;
value = Some value;
- children = [];
+ children = StringMap.empty;
}
let empty key = {
key = key;
value = None;
- children = []
+ children = StringMap.empty;
}
let _get_key node = node.key
@@ -47,41 +49,31 @@ struct
{ node with children = children }
let _add_child node child =
- { node with children = child :: node.children }
+ { node with children = StringMap.add child.key child
node.children }
end
-type ('a,'b) t = ('a,'b) Node.t list
+type 'a t = 'a Node.t StringMap.t
let mem_node nodes key =
- List.exists (fun n -> n.Node.key = key) nodes
+ StringMap.mem key nodes
let find_node nodes key =
- List.find (fun n -> n.Node.key = key) nodes
+ StringMap.find key nodes
let replace_node nodes key node =
- let rec aux = function
- | []-> []
- | h :: tl when h.Node.key = key -> node :: tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> None | Some _ -> Some node) nodes
let remove_node nodes key =
- let rec aux = function
- | []-> raise Not_found
- | h :: tl when h.Node.key = key -> tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> raise Not_found | Some _ ->
None) nodes
-let create () = []
+let create () = StringMap.empty
let rec iter f tree =
- let aux node =
- f node.Node.key node.Node.value;
+ let aux key node =
+ f key node.Node.value;
iter f node.Node.children
in
- List.iter aux tree
+ StringMap.iter aux tree
let rec map f tree =
let aux node =
@@ -92,13 +84,14 @@ let rec map f tree =
in
{ node with Node.value = value; Node.children = map f
node.Node.children }
in
- List.filter (fun n -> n.Node.value <> None || n.Node.children <> [])
(List.map aux tree)
+ 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 accu node =
- fold f node.Node.children (f node.Node.key
[PATCH v2 5/6] tools/ocaml/xenstored: use more efficient node trees
This changes the output of xenstore-ls to be sorted.
Previously the keys were listed in the order in which they were inserted
in.
docs/misc/xenstore.txt doesn't specify in what order keys are listed.
Map.update is used to retain semantics with replace_child:
only an existing child is replaced, if it wasn't part of the original
map we don't add it.
Similarly exception behaviour is retained for del_childname and related
functions.
Entries are stored in reverse sort order, so that upon Map.fold the
constructed list is sorted in ascending order and there is no need for a
List.rev.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/store.ml | 46 +++-
tools/ocaml/xenstored/symbol.ml | 4 +++
tools/ocaml/xenstored/symbol.mli | 3 +++
3 files changed, 29 insertions(+), 24 deletions(-)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index 45659a23ee..d9dfa36045 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -16,17 +16,19 @@
*)
open Stdext
+module SymbolMap = Map.Make(Symbol)
+
module Node = struct
type t = {
name: Symbol.t;
perms: Perms.Node.t;
value: string;
- children: t list;
+ children: t SymbolMap.t;
}
let create _name _perms _value =
- { name = Symbol.of_string _name; perms = _perms; value = _value;
children = []; }
+ { 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
@@ -42,38 +44,34 @@ let set_value node nvalue =
let set_perms node nperms = { node with perms = nperms }
let add_child node child =
- { node with children = child :: node.children }
+ let children = SymbolMap.add child.name child node.children in
+ { node with children }
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.mem childname node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.find childname node.children
let replace_child node child nchild =
- (* this is the on-steroid version of the filter one-replace one *)
- let rec replace_one_in_list l =
- match l with
- | [] -> []
- | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
- | h :: tl -> h :: replace_one_in_list
tl
- in
- { node with children = (replace_one_in_list node.children) }
+ { 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
- let rec delete_one_in_list l =
- match l with
- | []-> raise Not_found
- | h :: tl when Symbol.equal h.name sym -> tl
- | h :: tl -> h :: delete_one_in_list tl
- in
- { node with children = (delete_one_in_list node.children) }
+ { node with children =
+ SymbolMap.update sym
+ (function None -> raise Not_found | Some _ -> None)
+ node.children
+ }
let del_all_children node =
- { node with children = [] }
+ { 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 =
@@ -87,7 +85,7 @@ let check_owner node connection =
raise Define.Permission_denied;
end
-let rec recurse fct node = fct node; List.iter (recurse fct) node.children
+let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct)
node.children
let unpack node = (Symbol.to_string node.name, node.perms, node.value)
@@ -321,7 +319,7 @@ let ls store perm path =
Node.check_perm cnode perm Perms.READ;
cnode.Node.children in
Path.apply store.root path do_ls in
- List.rev (List.map (fun n -> Symbol.to_string n.Node.name) children)
+ SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children []
let getperms store perm path =
if path = [] then
@@ -350,7 +348,7 @@ 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
- List.iter (_traversal node_path) node.Node.children
+
[PATCH v2 0/6] tools/ocaml/xenstored: simplify code
Fix warnings, and delete some obsolete code.
oxenstored contained a hand-rolled GC to perform hash-consing:
this can be done with a lot fewer lines of code by using the built-in Weak
module.
The choice of data structures for trees/tries is not very efficient: they are
just
lists. Using a map improves lookup and deletion complexity, and replaces
hand-rolled
recursion with higher-level library calls.
There is a lot more that could be done to optimize socket polling:
an epoll backend with a poll fallback,but API structured around event-based
polling
would be better. But first lets drop the legacy select based code: I think every
modern *nix should have a working poll(3) by now.
Changes since v1:
* passed some testing
* fix commit title on 'drop select based'
* fix missing 'set_node' in 'set' that got lost in conversion to map
* simplify 'compare' function
Edwin Török (6):
tools/ocaml/libs/xc: Fix ambiguous documentation comment
tools/ocaml/xenstored: fix deprecation warning
tools/ocaml/xenstored: replace hand rolled GC with weak GC references
tools/ocaml/xenstored: drop select based socket watching
tools/ocaml/xenstored: use more efficient node trees
tools/ocaml/xenstored: use more efficient tries
tools/ocaml/libs/xc/xenctrl.mli | 2 +
tools/ocaml/xenstored/Makefile| 12 ++--
tools/ocaml/xenstored/connection.ml | 3 -
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/disk.ml | 2 +-
tools/ocaml/xenstored/history.ml | 14
tools/ocaml/xenstored/parse_arg.ml| 7 +-
tools/ocaml/xenstored/{select.ml => poll.ml} | 14 +---
.../ocaml/xenstored/{select.mli => poll.mli} | 12 +---
tools/ocaml/xenstored/store.ml| 49 ++---
tools/ocaml/xenstored/symbol.ml | 70 +--
tools/ocaml/xenstored/symbol.mli | 22 ++
tools/ocaml/xenstored/trie.ml | 59 +++-
tools/ocaml/xenstored/trie.mli| 26 +++
tools/ocaml/xenstored/xenstored.ml| 20 +-
15 files changed, 103 insertions(+), 211 deletions(-)
rename tools/ocaml/xenstored/{select.ml => poll.ml} (85%)
rename tools/ocaml/xenstored/{select.mli => poll.mli} (58%)
--
2.25.1
[PATCH v2 2/6] tools/ocaml/xenstored: fix deprecation warning
``` File "xenstored/disk.ml", line 33, characters 9-23: 33 |let c = Char.lowercase c in ^^ (alert deprecated): Stdlib.Char.lowercase Use Char.lowercase_ascii instead. ``` Signed-off-by: Edwin Török --- tools/ocaml/xenstored/disk.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml index 4739967b61..1ca0e2a95e 100644 --- a/tools/ocaml/xenstored/disk.ml +++ b/tools/ocaml/xenstored/disk.ml @@ -30,7 +30,7 @@ let undec c = | _ -> raise (Failure "undecify") let unhex c = - let c = Char.lowercase c in + let c = Char.lowercase_ascii c in match c with | '0' .. '9' -> (Char.code c) - (Char.code '0') | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10 -- 2.25.1
[PATCH v3 4/6] tools/ocaml/xenstored: drop select based socket watching
Poll has been the default since 2014, I think we can safely say by now
that poll() works and we don't need to fall back to select().
This will allow fixing up the way we call poll to be more efficient
(and pave the way for introducing epoll support):
currently poll wraps the select API, which is inefficient.
Signed-off-by: Edwin Török
---
Changed since v1:
* fix commit title
---
tools/ocaml/xenstored/Makefile | 12 ++--
tools/ocaml/xenstored/parse_arg.ml | 7 ++-
tools/ocaml/xenstored/{select.ml => poll.ml} | 14 ++
tools/ocaml/xenstored/{select.mli => poll.mli} | 12 ++--
tools/ocaml/xenstored/xenstored.ml | 4 +---
5 files changed, 13 insertions(+), 36 deletions(-)
rename tools/ocaml/xenstored/{select.ml => poll.ml} (85%)
rename tools/ocaml/xenstored/{select.mli => poll.mli} (58%)
diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile
index 68d35c483a..692a62584e 100644
--- a/tools/ocaml/xenstored/Makefile
+++ b/tools/ocaml/xenstored/Makefile
@@ -18,12 +18,12 @@ OCAMLINCLUDE += \
-I $(OCAML_TOPLEVEL)/libs/xc \
-I $(OCAML_TOPLEVEL)/libs/eventchn
-LIBS = syslog.cma syslog.cmxa select.cma select.cmxa
+LIBS = syslog.cma syslog.cmxa poll.cma poll.cmxa
syslog_OBJS = syslog
syslog_C_OBJS = syslog_stubs
-select_OBJS = select
-select_C_OBJS = select_stubs
-OCAML_LIBRARY = syslog select
+poll_OBJS = poll
+poll_C_OBJS = select_stubs
+OCAML_LIBRARY = syslog poll
LIBS += systemd.cma systemd.cmxa
systemd_OBJS = systemd
@@ -58,13 +58,13 @@ OBJS = paths \
process \
xenstored
-INTF = symbol.cmi trie.cmi syslog.cmi systemd.cmi select.cmi
+INTF = symbol.cmi trie.cmi syslog.cmi systemd.cmi poll.cmi
XENSTOREDLIBS = \
unix.cmxa \
-ccopt -L -ccopt . syslog.cmxa \
-ccopt -L -ccopt . systemd.cmxa \
- -ccopt -L -ccopt . select.cmxa \
+ -ccopt -L -ccopt . poll.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap
$(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn
$(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc
$(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \
diff --git a/tools/ocaml/xenstored/parse_arg.ml
b/tools/ocaml/xenstored/parse_arg.ml
index 1803c3eda0..2c4b5a8528 100644
--- a/tools/ocaml/xenstored/parse_arg.ml
+++ b/tools/ocaml/xenstored/parse_arg.ml
@@ -25,7 +25,6 @@ type config =
tracefile: string option; (* old xenstored compatibility *)
restart: bool;
disable_socket: bool;
- use_select: bool;
}
let do_argv =
@@ -37,7 +36,7 @@ let do_argv =
and config_file = ref ""
and restart = ref false
and disable_socket = ref false
- and use_select = ref false in
+ in
let speclist =
[ ("--no-domain-init", Arg.Unit (fun () -> domain_init :=
false),
@@ -54,9 +53,8 @@ let do_argv =
("-T", Arg.Set_string tracefile, ""); (* for compatibility *)
("--restart", Arg.Set restart, "Read database on starting");
("--disable-socket", Arg.Unit (fun () -> disable_socket :=
true), "Disable socket");
- ("--use-select", Arg.Unit (fun () -> use_select := true),
"Use select instead of poll"); (* for backward compatibility and testing *)
] in
- let usage_msg = "usage : xenstored [--config-file ]
[--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart]
[--disable-socket] [--use-select]" 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;
@@ -68,5 +66,4 @@ let do_argv =
tracefile = if !tracefile <> "" then Some !tracefile else None;
restart = !restart;
disable_socket = !disable_socket;
- use_select = !use_select;
}
diff --git a/tools/ocaml/xenstored/select.ml b/tools/ocaml/xenstored/poll.ml
similarity index 85%
rename from tools/ocaml/xenstored/select.ml
rename to tools/ocaml/xenstored/poll.ml
index 0455e163e3..26f8620dfc 100644
--- a/tools/ocaml/xenstored/select.ml
+++ b/tools/ocaml/xenstored/poll.ml
@@ -63,15 +63,5 @@ let poll_select in_fds out_fds exc_fds timeout =
(if event.except then fd :: x else x))
a r
-(* If the use_poll function is not called at all, we default to the original
Unix.select behavior *)
-let select_fun = ref Unix.select
-
-let use_poll yes =
- let sel_fun, max_fd =
- if yes then poll_select, get_sys_fs_nr_open ()
-
[PATCH v3 6/6] tools/ocaml/xenstored: use more efficient tries
No functional change, just an optimization.
Signed-off-by: Edwin Török
---
Changed since v1:
* fix missing 'set_node' in 'set' that got lost in conversion to map
* simplify 'compare' function
---
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/symbol.ml | 6 +--
tools/ocaml/xenstored/trie.ml| 59
tools/ocaml/xenstored/trie.mli | 26 ++--
4 files changed, 43 insertions(+), 50 deletions(-)
diff --git a/tools/ocaml/xenstored/connections.ml
b/tools/ocaml/xenstored/connections.ml
index f02ef6b526..4983c7370b 100644
--- a/tools/ocaml/xenstored/connections.ml
+++ b/tools/ocaml/xenstored/connections.ml
@@ -21,7 +21,7 @@ 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: (string, Connection.watch list) Trie.t;
+ mutable watches: Connection.watch list Trie.t;
}
let create () = {
diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml
index 2697915623..85b3f265de 100644
--- a/tools/ocaml/xenstored/symbol.ml
+++ b/tools/ocaml/xenstored/symbol.ml
@@ -31,9 +31,9 @@ let equal a b =
(* compare using physical equality, both members have to be part of the
above weak table *)
a == b
-let compare a b =
- if equal a b then 0
- else -(String.compare a b)
+(* the sort order is reversed here, so that Map.fold constructs a list
+ in ascending order *)
+let compare a b = String.compare b a
let stats () =
let len, entries, _, _, _, _ = WeakTable.stats tbl in
diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
index dc42535092..5b4831cf02 100644
--- a/tools/ocaml/xenstored/trie.ml
+++ b/tools/ocaml/xenstored/trie.ml
@@ -13,24 +13,26 @@
* GNU Lesser General Public License for more details.
*)
+module StringMap = Map.Make(String)
+
module Node =
struct
- type ('a,'b) t = {
- key: 'a;
- value: 'b option;
- children: ('a,'b) t list;
+ type 'a t = {
+ key: string;
+ value: 'a option;
+ children: 'a t StringMap.t;
}
let _create key value = {
key = key;
value = Some value;
- children = [];
+ children = StringMap.empty;
}
let empty key = {
key = key;
value = None;
- children = []
+ children = StringMap.empty;
}
let _get_key node = node.key
@@ -47,41 +49,31 @@ struct
{ node with children = children }
let _add_child node child =
- { node with children = child :: node.children }
+ { node with children = StringMap.add child.key child
node.children }
end
-type ('a,'b) t = ('a,'b) Node.t list
+type 'a t = 'a Node.t StringMap.t
let mem_node nodes key =
- List.exists (fun n -> n.Node.key = key) nodes
+ StringMap.mem key nodes
let find_node nodes key =
- List.find (fun n -> n.Node.key = key) nodes
+ StringMap.find key nodes
let replace_node nodes key node =
- let rec aux = function
- | []-> []
- | h :: tl when h.Node.key = key -> node :: tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> None | Some _ -> Some node) nodes
let remove_node nodes key =
- let rec aux = function
- | []-> raise Not_found
- | h :: tl when h.Node.key = key -> tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> raise Not_found | Some _ ->
None) nodes
-let create () = []
+let create () = StringMap.empty
let rec iter f tree =
- let aux node =
- f node.Node.key node.Node.value;
+ let aux key node =
+ f key node.Node.value;
iter f node.Node.children
in
- List.iter aux tree
+ StringMap.iter aux tree
let rec map f tree =
let aux node =
@@ -92,13 +84,14 @@ let rec map f tree =
in
{ node with Node.value = value; Node.children = map f
node.Node.children }
in
- List.filter (fun n -> n.Node.value <> None || n.Node.children <> [])
(List.map aux tree)
+ 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 accu node =
- fold f node.Node.children (f node.Node.key
[PATCH v3 0/6] tools/ocaml/xenstored: simplify code
Fix warnings, and delete some obsolete code.
oxenstored contained a hand-rolled GC to perform hash-consing:
this can be done with a lot fewer lines of code by using the built-in Weak
module.
The choice of data structures for trees/tries is not very efficient: they are
just
lists. Using a map improves lookup and deletion complexity, and replaces
hand-rolled
recursion with higher-level library calls.
There is a lot more that could be done to optimize socket polling:
an epoll backend with a poll fallback,but API structured around event-based
polling
would be better. But first lets drop the legacy select based code: I think every
modern *nix should have a working poll(3) by now.
This is a draft series, in need of more testing.
Changes since v1:
* fix bug where a 'set_node' call was missed
* simplify 'compare' code
* fix commit title for 'drop select based'
* passed some testing
Please ignore V2, something went wrong and V2 was nearly identical to V1,
not matching what I had in my git tree.
Edwin Török (6):
tools/ocaml/libs/xc: Fix ambiguous documentation comment
tools/ocaml/xenstored: fix deprecation warning
tools/ocaml/xenstored: replace hand rolled GC with weak GC references
tools/ocaml/xenstored: drop select based socket watching
tools/ocaml/xenstored: use more efficient node trees
tools/ocaml/xenstored: use more efficient tries
tools/ocaml/libs/xc/xenctrl.mli | 2 +
tools/ocaml/xenstored/Makefile| 12 ++--
tools/ocaml/xenstored/connection.ml | 3 -
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/disk.ml | 2 +-
tools/ocaml/xenstored/history.ml | 14
tools/ocaml/xenstored/parse_arg.ml| 7 +-
tools/ocaml/xenstored/{select.ml => poll.ml} | 14 +---
.../ocaml/xenstored/{select.mli => poll.mli} | 12 +---
tools/ocaml/xenstored/store.ml| 49 ++---
tools/ocaml/xenstored/symbol.ml | 70 +--
tools/ocaml/xenstored/symbol.mli | 22 ++
tools/ocaml/xenstored/trie.ml | 59 +++-
tools/ocaml/xenstored/trie.mli| 26 +++
tools/ocaml/xenstored/xenstored.ml| 20 +-
15 files changed, 103 insertions(+), 211 deletions(-)
rename tools/ocaml/xenstored/{select.ml => poll.ml} (85%)
rename tools/ocaml/xenstored/{select.mli => poll.mli} (58%)
--
2.25.1
[PATCH v3 2/6] tools/ocaml/xenstored: fix deprecation warning
``` File "xenstored/disk.ml", line 33, characters 9-23: 33 |let c = Char.lowercase c in ^^ (alert deprecated): Stdlib.Char.lowercase Use Char.lowercase_ascii instead. ``` Signed-off-by: Edwin Török --- tools/ocaml/xenstored/disk.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml index 4739967b61..1ca0e2a95e 100644 --- a/tools/ocaml/xenstored/disk.ml +++ b/tools/ocaml/xenstored/disk.ml @@ -30,7 +30,7 @@ let undec c = | _ -> raise (Failure "undecify") let unhex c = - let c = Char.lowercase c in + let c = Char.lowercase_ascii c in match c with | '0' .. '9' -> (Char.code c) - (Char.code '0') | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10 -- 2.25.1
[PATCH v3 1/6] tools/ocaml/libs/xc: Fix ambiguous documentation comment
Signed-off-by: Edwin Török --- tools/ocaml/libs/xc/xenctrl.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli index 26ec7e59b1..f7f6ec570d 100644 --- a/tools/ocaml/libs/xc/xenctrl.mli +++ b/tools/ocaml/libs/xc/xenctrl.mli @@ -132,8 +132,10 @@ external interface_close : handle -> unit = "stub_xc_interface_close" * interface_open and interface_close or with_intf although mixing both * is possible *) val with_intf : (handle -> 'a) -> 'a + (** [get_handle] returns the global handle used by [with_intf] *) val get_handle: unit -> handle option + (** [close handle] closes the handle maintained by [with_intf]. This * should only be closed before process exit. It must not be called from * a function called directly or indirectly by with_intf as this -- 2.25.1
[PATCH v3 5/6] tools/ocaml/xenstored: use more efficient node trees
This changes the output of xenstore-ls to be sorted.
Previously the keys were listed in the order in which they were inserted
in.
docs/misc/xenstore.txt doesn't specify in what order keys are listed.
Map.update is used to retain semantics with replace_child:
only an existing child is replaced, if it wasn't part of the original
map we don't add it.
Similarly exception behaviour is retained for del_childname and related
functions.
Entries are stored in reverse sort order, so that upon Map.fold the
constructed list is sorted in ascending order and there is no need for a
List.rev.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/store.ml | 46 +++-
tools/ocaml/xenstored/symbol.ml | 4 +++
tools/ocaml/xenstored/symbol.mli | 3 +++
3 files changed, 29 insertions(+), 24 deletions(-)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index 45659a23ee..d9dfa36045 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -16,17 +16,19 @@
*)
open Stdext
+module SymbolMap = Map.Make(Symbol)
+
module Node = struct
type t = {
name: Symbol.t;
perms: Perms.Node.t;
value: string;
- children: t list;
+ children: t SymbolMap.t;
}
let create _name _perms _value =
- { name = Symbol.of_string _name; perms = _perms; value = _value;
children = []; }
+ { 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
@@ -42,38 +44,34 @@ let set_value node nvalue =
let set_perms node nperms = { node with perms = nperms }
let add_child node child =
- { node with children = child :: node.children }
+ let children = SymbolMap.add child.name child node.children in
+ { node with children }
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.mem childname node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.find childname node.children
let replace_child node child nchild =
- (* this is the on-steroid version of the filter one-replace one *)
- let rec replace_one_in_list l =
- match l with
- | [] -> []
- | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
- | h :: tl -> h :: replace_one_in_list
tl
- in
- { node with children = (replace_one_in_list node.children) }
+ { 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
- let rec delete_one_in_list l =
- match l with
- | []-> raise Not_found
- | h :: tl when Symbol.equal h.name sym -> tl
- | h :: tl -> h :: delete_one_in_list tl
- in
- { node with children = (delete_one_in_list node.children) }
+ { node with children =
+ SymbolMap.update sym
+ (function None -> raise Not_found | Some _ -> None)
+ node.children
+ }
let del_all_children node =
- { node with children = [] }
+ { 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 =
@@ -87,7 +85,7 @@ let check_owner node connection =
raise Define.Permission_denied;
end
-let rec recurse fct node = fct node; List.iter (recurse fct) node.children
+let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct)
node.children
let unpack node = (Symbol.to_string node.name, node.perms, node.value)
@@ -321,7 +319,7 @@ let ls store perm path =
Node.check_perm cnode perm Perms.READ;
cnode.Node.children in
Path.apply store.root path do_ls in
- List.rev (List.map (fun n -> Symbol.to_string n.Node.name) children)
+ SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children []
let getperms store perm path =
if path = [] then
@@ -350,7 +348,7 @@ 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
- List.iter (_traversal node_path) node.Node.children
+
[PATCH v3 3/6] tools/ocaml/xenstored: replace hand rolled GC with weak GC references
The code here is attempting to reduce memory usage by sharing common
substrings in the tree: it replaces strings with ints, and keeps a
string->int map that gets manually garbage collected using a hand-rolled
mark and sweep algorithm.
This is unnecessary: OCaml already has a mark-and-sweep Garbage
Collector runtime, and sharing of common strings in tree nodes
can be achieved through Weak references: if the string hasn't been seen
yet it gets added to the Weak reference table, and if it has we use the
entry from the table instead, thus storing a string only once.
When the string is no longer referenced OCaml's GC will drop it from the
weak table: there is no need to manually do a mark-and-sweep, or to tell
OCaml when to drop it.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/connection.ml | 3 --
tools/ocaml/xenstored/history.ml| 14 --
tools/ocaml/xenstored/store.ml | 11 ++---
tools/ocaml/xenstored/symbol.ml | 68 ++---
tools/ocaml/xenstored/symbol.mli| 21 ++---
tools/ocaml/xenstored/xenstored.ml | 16 +--
6 files changed, 24 insertions(+), 109 deletions(-)
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index 24750ada43..aa6dd95501 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -271,9 +271,6 @@ let has_more_work con =
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
-let mark_symbols con =
- Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t))
con.transactions
-
let stats con =
Hashtbl.length con.watches, con.stat_nb_ops
diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/history.ml
index f39565bff5..029802bd15 100644
--- a/tools/ocaml/xenstored/history.ml
+++ b/tools/ocaml/xenstored/history.ml
@@ -22,20 +22,6 @@ type history_record = {
let history : history_record list ref = ref []
-(* Called from periodic_ops to ensure we don't discard symbols that are still
needed. *)
-(* There is scope for optimisation here, since in consecutive commits one
commit's `after`
- * is the same thing as the next commit's `before`, but not all commits in
history are
- * consecutive. *)
-let mark_symbols () =
- (* There are gaps where dom0's commits are missing. Otherwise we could
assume that
-* each element's `before` is the same thing as the next element's
`after`
-* since the next element is the previous commit *)
- List.iter (fun hist_rec ->
- Store.mark_symbols hist_rec.before;
- Store.mark_symbols hist_rec.after;
- )
- !history
-
(* Keep only enough commit-history to protect the running transactions that we
are still tracking *)
(* There is scope for optimisation here, replacing List.filter with something
more efficient,
* probably on a different list-like structure. *)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index f299ec6461..45659a23ee 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -46,18 +46,18 @@ let add_child node child =
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> n.name = childname) node.children
+ List.exists (fun n -> Symbol.equal n.name childname) node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> n.name = childname) node.children
+ List.find (fun n -> Symbol.equal n.name childname) node.children
let replace_child node child nchild =
(* this is the on-steroid version of the filter one-replace one *)
let rec replace_one_in_list l =
match l with
| [] -> []
- | h :: tl when h.name = child.name -> nchild :: tl
+ | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
| h :: tl -> h :: replace_one_in_list
tl
in
{ node with children = (replace_one_in_list node.children) }
@@ -67,7 +67,7 @@ let del_childname node childname =
let rec delete_one_in_list l =
match l with
| []-> raise Not_found
- | h :: tl when h.name = sym -> tl
+ | h :: tl when Symbol.equal h.name sym -> tl
| h :: tl -> h :: delete_one_in_list tl
in
{ node with children = (delete_one_in_list node.children) }
@@ -463,9 +463,6 @@ let copy store = {
quota = Quota.copy store.quota;
}
-let mark_symbols store =
- Node.recurse (fun node -> Symbol.mark_as_used node.Node.name) store.root
-
let incr_transaction_coalesce store =
store.stat_transaction_coalesce &l
[PATCH v4 3/4] tools/ocaml/xenstored: use more efficient node trees
This changes the output of xenstore-ls to be sorted.
Previously the keys were listed in the order in which they were inserted
in.
docs/misc/xenstore.txt doesn't specify in what order keys are listed.
Map.update is used to retain semantics with replace_child:
only an existing child is replaced, if it wasn't part of the original
map we don't add it.
Similarly exception behaviour is retained for del_childname and related
functions.
Entries are stored in reverse sort order, so that upon Map.fold the
constructed list is sorted in ascending order and there is no need for a
List.rev.
Signed-off-by: Edwin Török
Acked-by: Christian Lindig
---
Changes since V3:
* none, repost after preceding commits fix OCaml 4.02 compatibility
---
tools/ocaml/xenstored/store.ml | 46 +++-
tools/ocaml/xenstored/symbol.ml | 4 +++
tools/ocaml/xenstored/symbol.mli | 3 +++
3 files changed, 29 insertions(+), 24 deletions(-)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index 45659a23ee..d9dfa36045 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -16,17 +16,19 @@
*)
open Stdext
+module SymbolMap = Map.Make(Symbol)
+
module Node = struct
type t = {
name: Symbol.t;
perms: Perms.Node.t;
value: string;
- children: t list;
+ children: t SymbolMap.t;
}
let create _name _perms _value =
- { name = Symbol.of_string _name; perms = _perms; value = _value;
children = []; }
+ { 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
@@ -42,38 +44,34 @@ let set_value node nvalue =
let set_perms node nperms = { node with perms = nperms }
let add_child node child =
- { node with children = child :: node.children }
+ let children = SymbolMap.add child.name child node.children in
+ { node with children }
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.mem childname node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> Symbol.equal n.name childname) node.children
+ SymbolMap.find childname node.children
let replace_child node child nchild =
- (* this is the on-steroid version of the filter one-replace one *)
- let rec replace_one_in_list l =
- match l with
- | [] -> []
- | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
- | h :: tl -> h :: replace_one_in_list
tl
- in
- { node with children = (replace_one_in_list node.children) }
+ { 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
- let rec delete_one_in_list l =
- match l with
- | []-> raise Not_found
- | h :: tl when Symbol.equal h.name sym -> tl
- | h :: tl -> h :: delete_one_in_list tl
- in
- { node with children = (delete_one_in_list node.children) }
+ { node with children =
+ SymbolMap.update sym
+ (function None -> raise Not_found | Some _ -> None)
+ node.children
+ }
let del_all_children node =
- { node with children = [] }
+ { 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 =
@@ -87,7 +85,7 @@ let check_owner node connection =
raise Define.Permission_denied;
end
-let rec recurse fct node = fct node; List.iter (recurse fct) node.children
+let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct)
node.children
let unpack node = (Symbol.to_string node.name, node.perms, node.value)
@@ -321,7 +319,7 @@ let ls store perm path =
Node.check_perm cnode perm Perms.READ;
cnode.Node.children in
Path.apply store.root path do_ls in
- List.rev (List.map (fun n -> Symbol.to_string n.Node.name) children)
+ SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children []
let getperms store perm path =
if path = [] then
@@ -350,7 +348,7 @@ let traversal root_node f =
let rec _traversal path node =
f path node;
let node_path = Path
[PATCH v4 1/4] tools/ocaml/xenstored: replace hand rolled GC with weak GC references
The code here is attempting to reduce memory usage by sharing common
substrings in the tree: it replaces strings with ints, and keeps a
string->int map that gets manually garbage collected using a hand-rolled
mark and sweep algorithm.
This is unnecessary: OCaml already has a mark-and-sweep Garbage
Collector runtime, and sharing of common strings in tree nodes
can be achieved through Weak references: if the string hasn't been seen
yet it gets added to the Weak reference table, and if it has we use the
entry from the table instead, thus storing a string only once.
When the string is no longer referenced OCaml's GC will drop it from the
weak table: there is no need to manually do a mark-and-sweep, or to tell
OCaml when to drop it.
Signed-off-by: Edwin Török
Acked-by: Christian Lindig
---
Changes since V3:
* replace String.equal with (=) for compatibility with 4.02
---
tools/ocaml/xenstored/connection.ml | 3 --
tools/ocaml/xenstored/history.ml| 14 --
tools/ocaml/xenstored/store.ml | 11 ++---
tools/ocaml/xenstored/symbol.ml | 68 ++---
tools/ocaml/xenstored/symbol.mli| 21 ++---
tools/ocaml/xenstored/xenstored.ml | 16 +--
6 files changed, 24 insertions(+), 109 deletions(-)
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index 24750ada43..aa6dd95501 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -271,9 +271,6 @@ let has_more_work con =
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
-let mark_symbols con =
- Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t))
con.transactions
-
let stats con =
Hashtbl.length con.watches, con.stat_nb_ops
diff --git a/tools/ocaml/xenstored/history.ml b/tools/ocaml/xenstored/history.ml
index f39565bff5..029802bd15 100644
--- a/tools/ocaml/xenstored/history.ml
+++ b/tools/ocaml/xenstored/history.ml
@@ -22,20 +22,6 @@ type history_record = {
let history : history_record list ref = ref []
-(* Called from periodic_ops to ensure we don't discard symbols that are still
needed. *)
-(* There is scope for optimisation here, since in consecutive commits one
commit's `after`
- * is the same thing as the next commit's `before`, but not all commits in
history are
- * consecutive. *)
-let mark_symbols () =
- (* There are gaps where dom0's commits are missing. Otherwise we could
assume that
-* each element's `before` is the same thing as the next element's
`after`
-* since the next element is the previous commit *)
- List.iter (fun hist_rec ->
- Store.mark_symbols hist_rec.before;
- Store.mark_symbols hist_rec.after;
- )
- !history
-
(* Keep only enough commit-history to protect the running transactions that we
are still tracking *)
(* There is scope for optimisation here, replacing List.filter with something
more efficient,
* probably on a different list-like structure. *)
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
index f299ec6461..45659a23ee 100644
--- a/tools/ocaml/xenstored/store.ml
+++ b/tools/ocaml/xenstored/store.ml
@@ -46,18 +46,18 @@ let add_child node child =
let exists node childname =
let childname = Symbol.of_string childname in
- List.exists (fun n -> n.name = childname) node.children
+ List.exists (fun n -> Symbol.equal n.name childname) node.children
let find node childname =
let childname = Symbol.of_string childname in
- List.find (fun n -> n.name = childname) node.children
+ List.find (fun n -> Symbol.equal n.name childname) node.children
let replace_child node child nchild =
(* this is the on-steroid version of the filter one-replace one *)
let rec replace_one_in_list l =
match l with
| [] -> []
- | h :: tl when h.name = child.name -> nchild :: tl
+ | h :: tl when Symbol.equal h.name child.name -> nchild :: tl
| h :: tl -> h :: replace_one_in_list
tl
in
{ node with children = (replace_one_in_list node.children) }
@@ -67,7 +67,7 @@ let del_childname node childname =
let rec delete_one_in_list l =
match l with
| []-> raise Not_found
- | h :: tl when h.name = sym -> tl
+ | h :: tl when Symbol.equal h.name sym -> tl
| h :: tl -> h :: delete_one_in_list tl
in
{ node with children = (delete_one_in_list node.children) }
@@ -463,9 +463,6 @@ let copy store = {
quota = Quota.copy store.quota;
}
-let mark_symbols store =
- Node.recurse (fun node
[PATCH v4 2/4] Map: backport find_opt/update from 4.06
We are currently on OCaml 4.02 as minimum version.
To make the followup optimizations compile backport these functions from
OCaml 4.06.
This implementation is less efficient than the one in the 4.06 standard
library which has access to the internals of the Map.
Signed-off-by: Edwin Török
---
Changes since V3:
* this patch is new in V4
---
tools/ocaml/xenstored/stdext.ml | 21 +
tools/ocaml/xenstored/trie.ml | 2 ++
2 files changed, 23 insertions(+)
diff --git a/tools/ocaml/xenstored/stdext.ml b/tools/ocaml/xenstored/stdext.ml
index 4f2f3a2c8c..5bebe2aa27 100644
--- a/tools/ocaml/xenstored/stdext.ml
+++ b/tools/ocaml/xenstored/stdext.ml
@@ -44,6 +44,27 @@ let default d v =
let maybe f v =
match v with None -> () | Some x -> f x
+module Map = struct
+module Make(Ord: Map.OrderedType) = struct
+
+include Map.Make(Ord)
+
+let find_opt k t =
+ (* avoid raising exceptions, they can be expensive *)
+ if mem k t then Some (find k t) else 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
+
+end
+end
+
module String = struct include String
let of_char c = String.make 1 c
diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
index dc42535092..f513f4e608 100644
--- a/tools/ocaml/xenstored/trie.ml
+++ b/tools/ocaml/xenstored/trie.ml
@@ -13,6 +13,8 @@
* GNU Lesser General Public License for more details.
*)
+open Stdext
+
module Node =
struct
type ('a,'b) t = {
--
2.25.1
[PATCH v4 0/4] tools/ocaml/xenstored: simplify code
This refreshes the V3 patches to work with OCaml 4.02. Upgrading to 4.06 will come as a separate series. This patch is new in V4, the other patches were already acked in V3: [PATCH v4 2/4] Map: backport find_opt/update from 4.06 A git tree with this and other series is available at: https://gitlab.com/edwintorok/xen/-/compare/master...for-upstream Edwin Török (4): tools/ocaml/xenstored: replace hand rolled GC with weak GC references Map: backport find_opt/update from 4.06 tools/ocaml/xenstored: use more efficient node trees tools/ocaml/xenstored: use more efficient tries tools/ocaml/xenstored/connection.ml | 3 -- tools/ocaml/xenstored/connections.ml | 2 +- tools/ocaml/xenstored/history.ml | 14 -- tools/ocaml/xenstored/stdext.ml | 21 + tools/ocaml/xenstored/store.ml | 49 +-- tools/ocaml/xenstored/symbol.ml | 70 +++- tools/ocaml/xenstored/symbol.mli | 22 +++-- tools/ocaml/xenstored/trie.ml| 61 +++- tools/ocaml/xenstored/trie.mli | 26 +-- tools/ocaml/xenstored/xenstored.ml | 16 +-- 10 files changed, 110 insertions(+), 174 deletions(-) -- 2.25.1
[PATCH v4 4/4] tools/ocaml/xenstored: use more efficient tries
No functional change, just an optimization.
Signed-off-by: Edwin Török
Acked-by: Christian Lindig
---
Changes since V3:
* none, repost after previous commits fix compatibility with OCaml 4.02
---
tools/ocaml/xenstored/connections.ml | 2 +-
tools/ocaml/xenstored/symbol.ml | 6 +--
tools/ocaml/xenstored/trie.ml| 59
tools/ocaml/xenstored/trie.mli | 26 ++--
4 files changed, 43 insertions(+), 50 deletions(-)
diff --git a/tools/ocaml/xenstored/connections.ml
b/tools/ocaml/xenstored/connections.ml
index f02ef6b526..4983c7370b 100644
--- a/tools/ocaml/xenstored/connections.ml
+++ b/tools/ocaml/xenstored/connections.ml
@@ -21,7 +21,7 @@ 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: (string, Connection.watch list) Trie.t;
+ mutable watches: Connection.watch list Trie.t;
}
let create () = {
diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml
index 301639f16f..72a84ebf80 100644
--- a/tools/ocaml/xenstored/symbol.ml
+++ b/tools/ocaml/xenstored/symbol.ml
@@ -31,9 +31,9 @@ let equal a b =
(* compare using physical equality, both members have to be part of the
above weak table *)
a == b
-let compare a b =
- if equal a b then 0
- else -(String.compare a b)
+(* the sort order is reversed here, so that Map.fold constructs a list
+ in ascending order *)
+let compare a b = String.compare b a
let stats () =
let len, entries, _, _, _, _ = WeakTable.stats tbl in
diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
index f513f4e608..ad2aed5123 100644
--- a/tools/ocaml/xenstored/trie.ml
+++ b/tools/ocaml/xenstored/trie.ml
@@ -15,24 +15,26 @@
open Stdext
+module StringMap = Map.Make(String)
+
module Node =
struct
- type ('a,'b) t = {
- key: 'a;
- value: 'b option;
- children: ('a,'b) t list;
+ type 'a t = {
+ key: string;
+ value: 'a option;
+ children: 'a t StringMap.t;
}
let _create key value = {
key = key;
value = Some value;
- children = [];
+ children = StringMap.empty;
}
let empty key = {
key = key;
value = None;
- children = []
+ children = StringMap.empty;
}
let _get_key node = node.key
@@ -49,41 +51,31 @@ struct
{ node with children = children }
let _add_child node child =
- { node with children = child :: node.children }
+ { node with children = StringMap.add child.key child
node.children }
end
-type ('a,'b) t = ('a,'b) Node.t list
+type 'a t = 'a Node.t StringMap.t
let mem_node nodes key =
- List.exists (fun n -> n.Node.key = key) nodes
+ StringMap.mem key nodes
let find_node nodes key =
- List.find (fun n -> n.Node.key = key) nodes
+ StringMap.find key nodes
let replace_node nodes key node =
- let rec aux = function
- | []-> []
- | h :: tl when h.Node.key = key -> node :: tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> None | Some _ -> Some node) nodes
let remove_node nodes key =
- let rec aux = function
- | []-> raise Not_found
- | h :: tl when h.Node.key = key -> tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> raise Not_found | Some _ ->
None) nodes
-let create () = []
+let create () = StringMap.empty
let rec iter f tree =
- let aux node =
- f node.Node.key node.Node.value;
+ let aux key node =
+ f key node.Node.value;
iter f node.Node.children
in
- List.iter aux tree
+ StringMap.iter aux tree
let rec map f tree =
let aux node =
@@ -94,13 +86,14 @@ let rec map f tree =
in
{ node with Node.value = value; Node.children = map f
node.Node.children }
in
- List.filter (fun n -> n.Node.value <> None || n.Node.children <> [])
(List.map aux tree)
+ 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 accu node =
- fold f node.Node.children (f node.Node.key node.Node.value accu)
+ let aux key node accu =
+ fold f node.Nod
[PATCH v1 7/9] tools/ocaml/xenstored: don't store domU's mfn of ring page
This is a port of the following C xenstored commit
122b52230aa5b79d65e18b8b77094027faa2f8e2 tools/xenstore: don't store domU's mfn
of ring page in xenstored
Backwards compat: accept a domain dump both with and without MFN.
CC: Signed-off-by: Juergen Gross
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/domain.ml| 7 ++-
tools/ocaml/xenstored/domains.ml | 6 +++---
tools/ocaml/xenstored/process.ml | 16 +---
tools/ocaml/xenstored/xenstored.ml | 8
4 files changed, 14 insertions(+), 23 deletions(-)
diff --git a/tools/ocaml/xenstored/domain.ml b/tools/ocaml/xenstored/domain.ml
index 2d9c1f5d09..b11a2f39f5 100644
--- a/tools/ocaml/xenstored/domain.ml
+++ b/tools/ocaml/xenstored/domain.ml
@@ -22,7 +22,6 @@ let warn fmt = Logging.warn "domain" fmt
type t =
{
id: Xenctrl.domid;
- mfn: nativeint;
interface: Xenmmap.t;
eventchn: Event.t;
mutable remote_port: int;
@@ -41,7 +40,6 @@ let is_dom0 d = d.id = 0
let get_path dom = "/local/domain/" ^ (sprintf "%u" dom.id)
let get_id domain = domain.id
let get_interface d = d.interface
-let get_mfn d = d.mfn
let get_remote_port d = d.remote_port
let get_port d = d.port
@@ -62,7 +60,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,%d\n" d.id d.remote_port
let notify dom = match dom.port with
| None ->
@@ -88,9 +86,8 @@ let close dom =
Xenmmap.unmap dom.interface;
()
-let make id mfn remote_port interface eventchn = {
+let make id remote_port interface eventchn = {
id = id;
- mfn = mfn;
remote_port = remote_port;
interface = interface;
eventchn = eventchn;
diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domains.ml
index d9cb693751..0dfeed193a 100644
--- a/tools/ocaml/xenstored/domains.ml
+++ b/tools/ocaml/xenstored/domains.ml
@@ -124,10 +124,10 @@ let cleanup doms =
let resume _doms _domid =
()
-let create doms domid mfn port =
+let create doms domid port =
let mapping = Gnt.(Gnttab.map_exn doms.gnttab { domid; ref = xenstore}
true) in
let interface = Gnt.Gnttab.Local_mapping.to_pages doms.gnttab mapping in
- let dom = Domain.make domid mfn port interface doms.eventchn in
+ let dom = Domain.make domid port interface doms.eventchn in
Hashtbl.add doms.table domid dom;
Domain.bind_interdomain dom;
dom
@@ -147,7 +147,7 @@ let create0 doms =
port, interface
)
in
- let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in
+ let dom = Domain.make 0 port interface doms.eventchn in
Hashtbl.add doms.table 0 dom;
Domain.bind_interdomain dom;
Domain.notify dom;
diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml
index ff5c9484fc..73d7411e59 100644
--- a/tools/ocaml/xenstored/process.ml
+++ b/tools/ocaml/xenstored/process.ml
@@ -97,10 +97,6 @@ let do_debug con t _domains cons data =
| "watches" :: _ ->
let watches = Connections.debug cons in
Some (watches ^ "\000")
- | "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
@@ -409,20 +405,18 @@ let do_introduce con _t domains cons data =
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;
+ (* Use XS_INTRODUCE for recreating the xenbus
event-channel. *)
+ edom.remote_port <- port;
+ Domain.bind_interdomain edom;
edom
else try
- let ndom = Domains.create domains domid mfn port in
+ let ndom = Domains.create domains domid port in
Connections.add_domain cons ndom;
Connections.fire_spec_watches cons "@introduceDomain";
ndom
with _ -> raise Invalid_Cmd_Args
in
- if (Domain.get_remote_port dom) <> port || (Domain.g
[PATCH v1 5/9] tools/ocaml: safer Xenmmap interface
Xenmmap.mmap_interface is created from multiple places:
* via mmap(), which needs to be unmap()-ed
* xc_map_foreign_range
* xengnttab_map_grant_ref
Signed-off-by: Edwin Török
---
tools/ocaml/libs/mmap/xenmmap.ml | 14 --
tools/ocaml/libs/mmap/xenmmap.mli | 11 ---
tools/ocaml/libs/xb/xb.ml | 10 +-
tools/ocaml/libs/xb/xb.mli| 4 ++--
tools/ocaml/libs/xc/xenctrl.ml| 6 --
tools/ocaml/libs/xc/xenctrl.mli | 5 ++---
tools/ocaml/xenstored/domain.ml | 2 +-
tools/ocaml/xenstored/gnt.ml | 14 --
tools/ocaml/xenstored/gnt.mli | 3 ++-
9 files changed, 44 insertions(+), 25 deletions(-)
diff --git a/tools/ocaml/libs/mmap/xenmmap.ml b/tools/ocaml/libs/mmap/xenmmap.ml
index 44b67c89d2..af258942a0 100644
--- a/tools/ocaml/libs/mmap/xenmmap.ml
+++ b/tools/ocaml/libs/mmap/xenmmap.ml
@@ -15,17 +15,27 @@
*)
type mmap_interface
+type t = mmap_interface * (mmap_interface -> unit)
+
type mmap_prot_flag = RDONLY | WRONLY | RDWR
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
+external mmap': Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
-> 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"
(* write: interface -> data -> start -> length -> unit *)
external write: mmap_interface -> string -> int -> int -> unit =
"stub_mmap_write"
(* getpagesize: unit -> size of page *)
+external unmap': mmap_interface -> unit = "stub_mmap_final"
+(* getpagesize: unit -> size of page *)
+let make ?(unmap=unmap') interface = interface, unmap
external getpagesize: unit -> int = "stub_mmap_getpagesize"
+
+let to_interface (intf, _) = intf
+let mmap fd prot_flag map_flag length offset =
+ let map = mmap' fd prot_flag map_flag length offset in
+ make map ~unmap:unmap'
+let unmap (map, do_unmap) = do_unmap map
diff --git a/tools/ocaml/libs/mmap/xenmmap.mli
b/tools/ocaml/libs/mmap/xenmmap.mli
index 8f92ed6310..075b24eab4 100644
--- a/tools/ocaml/libs/mmap/xenmmap.mli
+++ b/tools/ocaml/libs/mmap/xenmmap.mli
@@ -14,15 +14,20 @@
* GNU Lesser General Public License for more details.
*)
+type t
type mmap_interface
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"
-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"
+val mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int ->
t
+val unmap : t -> unit
+
+val make: ?unmap:(mmap_interface -> unit) -> mmap_interface -> t
+
+val to_interface: t -> mmap_interface
+
external getpagesize : unit -> int = "stub_mmap_getpagesize"
diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml
index 104d319d77..4ddf741420 100644
--- a/tools/ocaml/libs/xb/xb.ml
+++ b/tools/ocaml/libs/xb/xb.ml
@@ -28,7 +28,7 @@ let _ =
type backend_mmap =
{
- mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *)
+ mmap: Xenmmap.t; (* mmaped interface = xs_ring *)
eventchn_notify: unit -> unit; (* function to notify through eventchn *)
mutable work_again: bool;
}
@@ -59,7 +59,7 @@ let reconnect t = match t.backend with
(* should never happen, so close the connection *)
raise End_of_file
| Xenmmap backend ->
- Xs_ring.close backend.mmap;
+ Xs_ring.close Xenmmap.(to_interface backend.mmap);
backend.eventchn_notify ();
(* Clear our old connection state *)
Queue.clear t.pkt_in;
@@ -77,7 +77,7 @@ let read_fd back _con b len =
let read_mmap back _con b len =
let s = Bytes.make len '\000' in
- let rd = Xs_ring.read back.mmap s len in
+ let rd = Xs_ring.read Xenmmap.(to_interface back.mmap) s len in
Bytes.blit s 0 b 0 rd;
back.work_again <- (rd > 0);
if rd > 0 then
@@ -93,7 +93,7 @@ let write_fd back _con b 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
+ let ws = Xs_ring.wri
[PATCH v1 6/9] tools/ocaml/xenstored: use gnttab instead of xenctrl's foreign_map_range
This is an oxenstored port of the following C xenstored commit:
38eeb3864de40aa568c48f9f26271c141c62b50b tools/xenstored: Drop mapping of the
ring via foreign map
Now only Xenctrl.domain_getinfo remains as the last use of unstable xenctrl
interface
in oxenstored.
Depends on: tools/ocaml: safer Xenmmap interface
(without it the code would build but the wrong unmap function would get
called on domain destruction)
CC: Andrew Cooper
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/domains.ml | 7 +--
tools/ocaml/xenstored/xenstored.ml | 3 ++-
2 files changed, 7 insertions(+), 3 deletions(-)
diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domains.ml
index 17fe2fa257..d9cb693751 100644
--- a/tools/ocaml/xenstored/domains.ml
+++ b/tools/ocaml/xenstored/domains.ml
@@ -22,6 +22,7 @@ let xc = Xenctrl.interface_open ()
type domains = {
eventchn: Event.t;
+ gnttab: Gnt.Gnttab.interface;
table: (Xenctrl.domid, Domain.t) Hashtbl.t;
(* N.B. the Queue module is not thread-safe but oxenstored is
single-threaded. *)
@@ -42,8 +43,9 @@ type domains = {
mutable n_penalised: int; (* Number of domains with less than maximum
credit *)
}
-let init eventchn on_first_conflict_pause = {
+let init eventchn gnttab on_first_conflict_pause = {
eventchn = eventchn;
+ gnttab;
table = Hashtbl.create 10;
doms_conflict_paused = Queue.create ();
doms_with_conflict_penalty = Queue.create ();
@@ -123,7 +125,8 @@ let resume _doms _domid =
()
let create doms domid mfn port =
- let interface = Xenctrl.map_foreign_range xc domid
(Xenmmap.getpagesize()) mfn in
+ let mapping = Gnt.(Gnttab.map_exn doms.gnttab { domid; ref = xenstore}
true) in
+ let interface = Gnt.Gnttab.Local_mapping.to_pages doms.gnttab mapping in
let dom = Domain.make domid mfn port interface doms.eventchn in
Hashtbl.add doms.table domid dom;
Domain.bind_interdomain dom;
diff --git a/tools/ocaml/xenstored/xenstored.ml
b/tools/ocaml/xenstored/xenstored.ml
index f3e4697dea..a232e4c616 100644
--- a/tools/ocaml/xenstored/xenstored.ml
+++ b/tools/ocaml/xenstored/xenstored.ml
@@ -265,6 +265,7 @@ let _ =
let store = Store.create () in
let eventchn = Event.init () in
+ let gnttab = Gnt.Gnttab.interface_open () in
let next_frequent_ops = ref 0. in
let advance_next_frequent_ops () =
next_frequent_ops := (Unix.gettimeofday () +.
!Define.conflict_max_history_seconds)
@@ -272,7 +273,7 @@ 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 = Domains.init eventchn gnttab advance_next_frequent_ops in
(* For things that need to be done periodically but more often
* than the periodic_ops function *)
--
2.25.1
[PATCH v1 2/9] tools/ocaml/libs/mmap: allocate correct number of bytes
OCaml memory allocation functions use words as units,
unless explicitly documented otherwise.
Thus we were allocating more memory than necessary,
caml_alloc should've been called with the parameter '2',
but was called with a lot more.
To account for future changes in the struct keep using sizeof,
but round up and convert to number of words.
For OCaml 1 word = sizeof(value)
The Wsize_bsize macro converts bytes to words.
Signed-off-by: Edwin Török
---
tools/ocaml/libs/mmap/xenmmap_stubs.c | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c
b/tools/ocaml/libs/mmap/xenmmap_stubs.c
index b811990a89..4d09c5a6e6 100644
--- a/tools/ocaml/libs/mmap/xenmmap_stubs.c
+++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c
@@ -28,6 +28,8 @@
#include
#include
+#define Wsize_bsize_round(n) (Wsize_bsize( (n) + sizeof(value) - 1 ))
+
static int mmap_interface_init(struct mmap_interface *intf,
int fd, int pflag, int mflag,
int len, int offset)
@@ -57,7 +59,7 @@ CAMLprim value stub_mmap_init(value fd, value pflag, value
mflag,
default: caml_invalid_argument("maptype");
}
- result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
+ result = caml_alloc(Wsize_bsize_round(sizeof(struct mmap_interface)),
Abstract_tag);
if (mmap_interface_init(Intf_val(result), Int_val(fd),
c_pflag, c_mflag,
--
2.25.1
[PATCH v1 3/9] tools/ocaml/libs/mmap: Expose stub_mmap_alloc
This also handles mmap errors better by using the `uerror` helper
to raise a proper exception using `errno`.
Changed type of `len` from `int` to `size_t`: at construction time we
ensure the length is >= 0, so we can reflect this by using an unsigned
type. The type is unsigned at the C API level, and a negative integer
would just get translated to a very large unsigned number otherwise.
mmap also takes off_t and size_t, so using int64 would be more generic
here, however we only ever use this interface to map rings, so keeping
the `int` sizes is fine.
OCaml itself only uses `ints` for mapping bigarrays, and int64 for just
the offset.
Signed-off-by: Edwin Török
---
tools/ocaml/libs/mmap/mmap_stubs.h| 4 +++-
tools/ocaml/libs/mmap/xenmmap_stubs.c | 31 +--
2 files changed, 23 insertions(+), 12 deletions(-)
diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h
b/tools/ocaml/libs/mmap/mmap_stubs.h
index 816ba6a724..3352594e38 100644
--- a/tools/ocaml/libs/mmap/mmap_stubs.h
+++ b/tools/ocaml/libs/mmap/mmap_stubs.h
@@ -27,7 +27,7 @@
struct mmap_interface
{
void *addr;
- int len;
+ size_t len;
};
#ifndef Data_abstract_val
@@ -37,4 +37,6 @@ struct mmap_interface
#define Intf_val(a) ((struct mmap_interface *) Data_abstract_val(a))
#define Intf_data_val(a) (Intf_val(a)->addr)
+value stub_mmap_alloc(void *addr, size_t len);
+
#endif
diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c
b/tools/ocaml/libs/mmap/xenmmap_stubs.c
index 4d09c5a6e6..9c1126c6a2 100644
--- a/tools/ocaml/libs/mmap/xenmmap_stubs.c
+++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c
@@ -27,16 +27,18 @@
#include
#include
#include
+#include
#define Wsize_bsize_round(n) (Wsize_bsize( (n) + sizeof(value) - 1 ))
-static int mmap_interface_init(struct mmap_interface *intf,
- int fd, int pflag, int mflag,
- int len, int offset)
+value stub_mmap_alloc(void *addr, size_t len)
{
- intf->len = len;
- intf->addr = mmap(NULL, len, pflag, mflag, fd, offset);
- return (intf->addr == MAP_FAILED) ? errno : 0;
+ CAMLparam0();
+ CAMLlocal1(result);
+ result = caml_alloc(Wsize_bsize_round(sizeof(struct mmap_interface)),
Abstract_tag);
+ Intf_val(result)->addr = addr;
+ Intf_val(result)->len = len;
+ CAMLreturn(result);
}
CAMLprim value stub_mmap_init(value fd, value pflag, value mflag,
@@ -45,6 +47,8 @@ CAMLprim value stub_mmap_init(value fd, value pflag, value
mflag,
CAMLparam5(fd, pflag, mflag, len, offset);
CAMLlocal1(result);
int c_pflag, c_mflag;
+ void* addr;
+ size_t length;
switch (Int_val(pflag)) {
case 0: c_pflag = PROT_READ; break;
@@ -59,12 +63,17 @@ CAMLprim value stub_mmap_init(value fd, value pflag, value
mflag,
default: caml_invalid_argument("maptype");
}
- result = caml_alloc(Wsize_bsize_round(sizeof(struct mmap_interface)),
Abstract_tag);
+ if (Int_val(len) < 0)
+ caml_invalid_argument("negative size");
+ if (Int_val(offset) < 0)
+ caml_invalid_argument("negative offset");
+ length = Int_val(len);
- if (mmap_interface_init(Intf_val(result), Int_val(fd),
- c_pflag, c_mflag,
- Int_val(len), Int_val(offset)))
- caml_failwith("mmap");
+ addr = mmap(NULL, length, c_pflag, c_mflag, fd, Int_val(offset));
+ if (MAP_FAILED == addr)
+ uerror("mmap", Nothing);
+
+ result = stub_mmap_alloc(addr, length);
CAMLreturn(result);
}
--
2.25.1
[PATCH v1 4/9] tools/ocaml/libs/xb: import gnttab stubs from mirage
Upstream URL: https://github.com/mirage/ocaml-gnt
Mirage is part of the Xen project and the license is compatible,
copyright headers are retained.
Changes from upstream:
* cut down dependencies: dropped Lwt, replaced Io_page with Xenmmap
* only import Gnttab and not Gntshr
This is for xenstored's use only which needs a way to grant map
the xenstore ring without using xenctrl.
Signed-off-by: Edwin Török
---
tools/ocaml/xenstored/Makefile | 11 ++-
tools/ocaml/xenstored/gnt.ml | 60 +++
tools/ocaml/xenstored/gnt.mli| 86 ++
tools/ocaml/xenstored/gnttab_stubs.c | 106 +++
4 files changed, 260 insertions(+), 3 deletions(-)
create mode 100644 tools/ocaml/xenstored/gnt.ml
create mode 100644 tools/ocaml/xenstored/gnt.mli
create mode 100644 tools/ocaml/xenstored/gnttab_stubs.c
diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile
index 692a62584e..3490c4ff4e 100644
--- a/tools/ocaml/xenstored/Makefile
+++ b/tools/ocaml/xenstored/Makefile
@@ -7,6 +7,7 @@ CFLAGS += -include $(XEN_ROOT)/tools/config.h
CFLAGS-$(CONFIG_SYSTEMD) += $(SYSTEMD_CFLAGS)
LDFLAGS-$(CONFIG_SYSTEMD) += $(SYSTEMD_LIBS)
+CFLAGS += $(CFLAGS_libxengnttab) -I../libs/mmap
CFLAGS += $(CFLAGS-y)
CFLAGS += $(APPEND_CFLAGS)
LDFLAGS += $(LDFLAGS-y)
@@ -18,12 +19,15 @@ OCAMLINCLUDE += \
-I $(OCAML_TOPLEVEL)/libs/xc \
-I $(OCAML_TOPLEVEL)/libs/eventchn
-LIBS = syslog.cma syslog.cmxa poll.cma poll.cmxa
+LIBS = syslog.cma syslog.cmxa poll.cma poll.cmxa gnt.cma gnt.cmxa
syslog_OBJS = syslog
syslog_C_OBJS = syslog_stubs
poll_OBJS = poll
poll_C_OBJS = select_stubs
-OCAML_LIBRARY = syslog poll
+gnt_OBJS = gnt
+gnt_C_OBJS = gnttab_stubs
+LIBS_gnt += $(LDLIBS_libxengnttab)
+OCAML_LIBRARY = syslog poll gnt
LIBS += systemd.cma systemd.cmxa
systemd_OBJS = systemd
@@ -58,7 +62,7 @@ OBJS = paths \
process \
xenstored
-INTF = symbol.cmi trie.cmi syslog.cmi systemd.cmi poll.cmi
+INTF = symbol.cmi trie.cmi syslog.cmi systemd.cmi poll.cmi gnt.cmi
XENSTOREDLIBS = \
unix.cmxa \
@@ -66,6 +70,7 @@ XENSTOREDLIBS = \
-ccopt -L -ccopt . systemd.cmxa \
-ccopt -L -ccopt . poll.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap
$(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \
+ -ccopt -L -ccopt . gnt.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn
$(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc
$(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \
-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb
$(OCAML_TOPLEVEL)/libs/xb/xenbus.cmxa \
diff --git a/tools/ocaml/xenstored/gnt.ml b/tools/ocaml/xenstored/gnt.ml
new file mode 100644
index 00..65f0334b7c
--- /dev/null
+++ b/tools/ocaml/xenstored/gnt.ml
@@ -0,0 +1,60 @@
+(*
+ * Copyright (c) 2010 Anil Madhavapeddy
+ * Copyright (C) 2012-2014 Citrix Inc
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+type gntref = int
+type domid = int
+
+let console = 0 (* public/grant_table.h:GNTTAB_RESERVED_CONSOLE *)
+let xenstore = 1 (* public/grant_table.h:GNTTAB_RESERVED_XENSTORE *)
+
+type grant_handle (* handle to a mapped grant *)
+
+module Gnttab = struct
+ type interface
+
+ external interface_open': unit -> interface = "stub_gnttab_interface_open"
+
+ let interface_open () =
+try
+ interface_open' ()
+with e ->
+ Printf.fprintf stderr "Failed to open grant table device: ENOENT\n";
+ Printf.fprintf stderr "Does this system have Xen userspace grant table
support?\n";
+ Printf.fprintf stderr "On linux try:\n";
+ Printf.fprintf stderr " sudo modprobe xen-gntdev\n%!";
+ raise e
+
+ external interface_close: interface -> unit = "stub_gnttab_interface_close"
+
+ type grant = {
+domid: domid;
+ref: gntref;
+ }
+
+ module Local_mapping = struct
+type t = Xenmmap.mmap_interface
+
+let to_pages t = t
+ end
+
+ external unmap_exn : interface -> Local_mapping.t -> unit =
"stub_gnttab_unmap"
+
+ external map_fresh_exn: interface -> gntref -> domid -> bool ->
Local_mapping.t = "stub_gnttab_map_fresh"
+
+
[PATCH v1 9/9] tools/ocaml/libs/mmap: Clean up unused read/write
Xenmmap is only modified by the ring functions,
these functions are unused.
Signed-off-by: Edwin Török
---
tools/ocaml/libs/mmap/xenmmap.ml | 5
tools/ocaml/libs/mmap/xenmmap.mli | 4 ---
tools/ocaml/libs/mmap/xenmmap_stubs.c | 41 ---
3 files changed, 50 deletions(-)
diff --git a/tools/ocaml/libs/mmap/xenmmap.ml b/tools/ocaml/libs/mmap/xenmmap.ml
index af258942a0..e17a62e607 100644
--- a/tools/ocaml/libs/mmap/xenmmap.ml
+++ b/tools/ocaml/libs/mmap/xenmmap.ml
@@ -24,11 +24,6 @@ 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"
-(* read: interface -> start -> length -> data *)
-external read: mmap_interface -> int -> int -> string = "stub_mmap_read"
-(* write: interface -> data -> start -> length -> unit *)
-external write: mmap_interface -> string -> int -> int -> unit =
"stub_mmap_write"
-(* getpagesize: unit -> size of page *)
external unmap': mmap_interface -> unit = "stub_mmap_final"
(* getpagesize: unit -> size of page *)
let make ?(unmap=unmap') interface = interface, unmap
diff --git a/tools/ocaml/libs/mmap/xenmmap.mli
b/tools/ocaml/libs/mmap/xenmmap.mli
index 075b24eab4..abf2a50131 100644
--- a/tools/ocaml/libs/mmap/xenmmap.mli
+++ b/tools/ocaml/libs/mmap/xenmmap.mli
@@ -19,10 +19,6 @@ type mmap_interface
type mmap_prot_flag = RDONLY | WRONLY | RDWR
type mmap_map_flag = SHARED | PRIVATE
-external read : mmap_interface -> int -> int -> string = "stub_mmap_read"
-external write : mmap_interface -> string -> int -> int -> unit
- = "stub_mmap_write"
-
val mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int ->
t
val unmap : t -> unit
diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c
b/tools/ocaml/libs/mmap/xenmmap_stubs.c
index 21feceea0e..ec0431efb5 100644
--- a/tools/ocaml/libs/mmap/xenmmap_stubs.c
+++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c
@@ -96,47 +96,6 @@ CAMLprim value stub_mmap_final(value intf)
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;
-
- 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");
-
- data = caml_alloc_string(c_len);
- memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len);
-
- 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;
-
- 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");
-
- memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len);
-
- CAMLreturn(Val_unit);
-}
-
CAMLprim value stub_mmap_getpagesize(value unit)
{
CAMLparam1(unit);
--
2.25.1
[PATCH v1 1/9] tools/ocaml: use common macros for manipulating mmap_interface
Signed-off-by: Edwin Török
---
tools/ocaml/libs/mmap/mmap_stubs.h| 7 +++
tools/ocaml/libs/mmap/xenmmap_stubs.c | 2 --
tools/ocaml/libs/xb/xs_ring_stubs.c | 14 +-
3 files changed, 12 insertions(+), 11 deletions(-)
diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h
b/tools/ocaml/libs/mmap/mmap_stubs.h
index 65e4239890..816ba6a724 100644
--- a/tools/ocaml/libs/mmap/mmap_stubs.h
+++ b/tools/ocaml/libs/mmap/mmap_stubs.h
@@ -30,4 +30,11 @@ struct mmap_interface
int len;
};
+#ifndef Data_abstract_val
+#define Data_abstract_val(v) ((void*) Op_val(v))
+#endif
+
+#define Intf_val(a) ((struct mmap_interface *) Data_abstract_val(a))
+#define Intf_data_val(a) (Intf_val(a)->addr)
+
#endif
diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c
b/tools/ocaml/libs/mmap/xenmmap_stubs.c
index e2ce088e25..b811990a89 100644
--- a/tools/ocaml/libs/mmap/xenmmap_stubs.c
+++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c
@@ -28,8 +28,6 @@
#include
#include
-#define Intf_val(a) ((struct mmap_interface *) a)
-
static int mmap_interface_init(struct mmap_interface *intf,
int fd, int pflag, int mflag,
int len, int offset)
diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c
b/tools/ocaml/libs/xb/xs_ring_stubs.c
index 7537a23949..9b6e3209fe 100644
--- a/tools/ocaml/libs/xb/xs_ring_stubs.c
+++ b/tools/ocaml/libs/xb/xs_ring_stubs.c
@@ -34,8 +34,6 @@
#include "mmap_stubs.h"
-#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
-
/*
* Bytes_val has been introduced by Ocaml 4.06.1. So define our own version
* if needed.
@@ -51,12 +49,11 @@ CAMLprim value ml_interface_read(value ml_interface,
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 xenstore_domain_interface *intf = interface->addr;
+ struct xenstore_domain_interface *intf = Intf_data_val(ml_interface);
XENSTORE_RING_IDX cons, prod; /* offsets only */
int total_data, data;
uint32_t connection;
@@ -110,12 +107,11 @@ CAMLprim value ml_interface_write(value ml_interface,
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 xenstore_domain_interface *intf = interface->addr;
+ struct xenstore_domain_interface *intf = Intf_data_val(ml_interface);
XENSTORE_RING_IDX cons, prod;
int total_space, space;
uint32_t connection;
@@ -165,7 +161,7 @@ exit:
CAMLprim value ml_interface_set_server_features(value interface, value v)
{
CAMLparam2(interface, v);
- struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr;
+ struct xenstore_domain_interface *intf = Intf_data_val(interface);
intf->server_features = Int_val(v);
@@ -175,7 +171,7 @@ CAMLprim value ml_interface_set_server_features(value
interface, value v)
CAMLprim value ml_interface_get_server_features(value interface)
{
CAMLparam1(interface);
- struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr;
+ struct xenstore_domain_interface *intf = Intf_data_val(interface);
CAMLreturn(Val_int (intf->server_features));
}
@@ -183,7 +179,7 @@ CAMLprim value ml_interface_get_server_features(value
interface)
CAMLprim value ml_interface_close(value interface)
{
CAMLparam1(interface);
- struct xenstore_domain_interface *intf = GET_C_STRUCT(interface)->addr;
+ struct xenstore_domain_interface *intf = Intf_data_val(interface);
int i;
intf->req_cons = intf->req_prod = intf->rsp_cons = intf->rsp_prod = 0;
--
2.25.1
[PATCH v1 0/9] tools/ocaml: use gnttab instead of map_foreign_range
oxenstored currently depends on 2 unstable interfaces from libxenctrl: * Xenctrl.map_foreign_range * Xenctrl.domain_getinfo It is desirable to reduce the use of unstable APIs in xenstored, so that an update to the hypervisor doesn't break xenstored. The C version of xenstored has dropped the usage of map_foreign_range in: 38eeb3864de40aa568c48f9f26271c141c62b50b tools/xenstored: Drop mapping of the ring via foreign map This also made the MFN in oxenstored redundant, which was dropped in: 122b52230aa5b79d65e18b8b77094027faa2f8e2 tools/xenstore: don't store domU's mfn of ring page in xenstored This series ports those commits and dependencies to oxenstored. First of all oxenstored currently doesn't have bindings to xengnttab. There are upstream bindings available at https://github.com/mirage/ocaml-gnt. A reduced form of that is imported into oxenstored that removes external dependencies such as Lwt and Io_page. This also requires changes to xenmmap interface to make it safer: there are now 2 ways to unmap a Xenmmap.mmap_interface, so we need to use the type system to ensure that we can't call the wrong one. Also cleaned up various minor issues in xenmmap bindings (e.g. allocating more bytes than necessary, due to a confusion between bytes and words in function parameters). I've tested that I can boot a Linux and Windows VM after these changes. Note: I thought about replacing Xenmmap.mmap_interface with Bigarray.Array1.t. However Bigarrays can't be unmapped at arbitrary point in time by design: they can only be GCed. We require more precise control in oxenstored, so I retained xenmmap as it is, I don't think it can be simplified further. A git tree with this and the other series is available at: https://gitlab.com/edwintorok/xen/-/compare/master...for-upstream Edwin Török (9): tools/ocaml: use common macros for manipulating mmap_interface tools/ocaml/libs/mmap: allocate correct number of bytes tools/ocaml/libs/mmap: Expose stub_mmap_alloc tools/ocaml/libs/xb: import gnttab stubs from mirage tools/ocaml: safer Xenmmap interface tools/ocaml/xenstored: use gnttab instead of xenctrl's foreign_map_range tools/ocaml/xenstored: don't store domU's mfn of ring page tools/ocaml/libs/mmap: mark mmap/munmap as blocking tools/ocaml/libs/mmap: Clean up unused read/write tools/ocaml/libs/mmap/mmap_stubs.h| 11 ++- tools/ocaml/libs/mmap/xenmmap.ml | 17 +++-- tools/ocaml/libs/mmap/xenmmap.mli | 13 ++-- tools/ocaml/libs/mmap/xenmmap_stubs.c | 86 - tools/ocaml/libs/xb/xb.ml | 10 +-- tools/ocaml/libs/xb/xb.mli| 4 +- tools/ocaml/libs/xb/xs_ring_stubs.c | 14 ++-- tools/ocaml/libs/xc/xenctrl.ml| 6 +- tools/ocaml/libs/xc/xenctrl.mli | 5 +- tools/ocaml/xenstored/Makefile| 11 ++- tools/ocaml/xenstored/domain.ml | 9 +-- tools/ocaml/xenstored/domains.ml | 13 ++-- tools/ocaml/xenstored/gnt.ml | 62 +++ tools/ocaml/xenstored/gnt.mli | 87 + tools/ocaml/xenstored/gnttab_stubs.c | 106 ++ tools/ocaml/xenstored/process.ml | 16 ++-- tools/ocaml/xenstored/xenstored.ml| 11 +-- 17 files changed, 362 insertions(+), 119 deletions(-) create mode 100644 tools/ocaml/xenstored/gnt.ml create mode 100644 tools/ocaml/xenstored/gnt.mli create mode 100644 tools/ocaml/xenstored/gnttab_stubs.c -- 2.25.1
[PATCH v1 8/9] tools/ocaml/libs/mmap: mark mmap/munmap as blocking
These functions can potentially take some time,
so allow other OCaml code to proceed meanwhile (if any).
Signed-off-by: Edwin Török
---
tools/ocaml/libs/mmap/xenmmap_stubs.c | 12 ++--
1 file changed, 10 insertions(+), 2 deletions(-)
diff --git a/tools/ocaml/libs/mmap/xenmmap_stubs.c
b/tools/ocaml/libs/mmap/xenmmap_stubs.c
index 9c1126c6a2..21feceea0e 100644
--- a/tools/ocaml/libs/mmap/xenmmap_stubs.c
+++ b/tools/ocaml/libs/mmap/xenmmap_stubs.c
@@ -28,6 +28,7 @@
#include
#include
#include
+#include
#define Wsize_bsize_round(n) (Wsize_bsize( (n) + sizeof(value) - 1 ))
@@ -69,7 +70,9 @@ CAMLprim value stub_mmap_init(value fd, value pflag, value
mflag,
caml_invalid_argument("negative offset");
length = Int_val(len);
+ caml_enter_blocking_section();
addr = mmap(NULL, length, c_pflag, c_mflag, fd, Int_val(offset));
+ caml_leave_blocking_section();
if (MAP_FAILED == addr)
uerror("mmap", Nothing);
@@ -80,10 +83,15 @@ CAMLprim value stub_mmap_init(value fd, value pflag, value
mflag,
CAMLprim value stub_mmap_final(value intf)
{
CAMLparam1(intf);
+ struct mmap_interface interface = *Intf_val(intf);
- if (Intf_val(intf)->addr != MAP_FAILED)
- munmap(Intf_val(intf)->addr, Intf_val(intf)->len);
+ /* mark it as freed, in case munmap below fails, so we don't retry it */
Intf_val(intf)->addr = MAP_FAILED;
+ if (interface.addr != MAP_FAILED) {
+ caml_enter_blocking_section();
+ munmap(interface.addr, interface.len);
+ caml_leave_blocking_section();
+ }
CAMLreturn(Val_unit);
}
--
2.25.1
[PATCH v1 2/2] backup_ptes: fix leak on realloc failure
From: Edwin Török
>From `man 2 realloc`:
`If realloc() fails, the original block is left untouched; it is not freed or
moved.`
Found using GCC -fanalyzer:
```
| 184 | backup->entries = realloc(backup->entries,
| | ~~
| | | | |
| | | | (91) when ‘realloc’ fails
| | | (92) ‘old_ptes.entries’ leaks here; was
allocated at (44)
| | (90) ...to here
```
Signed-off-by: Edwin Török
---
tools/libs/guest/xg_offline_page.c | 7 +--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/tools/libs/guest/xg_offline_page.c
b/tools/libs/guest/xg_offline_page.c
index c594fdba41..a8bcea768b 100644
--- a/tools/libs/guest/xg_offline_page.c
+++ b/tools/libs/guest/xg_offline_page.c
@@ -181,10 +181,13 @@ static int backup_ptes(xen_pfn_t table_mfn, int offset,
if (backup->max == backup->cur)
{
-backup->entries = realloc(backup->entries,
+void* orig = backup->entries;
+backup->entries = realloc(orig,
backup->max * 2 * sizeof(struct pte_backup_entry));
-if (backup->entries == NULL)
+if (backup->entries == NULL) {
+free(orig);
return -1;
+}
else
backup->max *= 2;
}
--
2.39.1
[PATCH v1 0/2] fix memory leaks reported by GCC -fanalyzer
From: Edwin Török Using GCC 12.2.1 with -fanalyzer it has shown some memory leaks: This is how I enabled -fanalyzer (adding it to CFLAGS for toplevel configure didn't seem to work): ``` CFLAGS += $(call cc-option,$(CC),-fanalyzer) ``` Note that there are more errors shown than fixed here, but they seem to be false positives (which is why this flag cannot, yet, be enabled by default). Edwin Török (2): xc_core_arch_map_p2m_tree_rw: fix memory leak backup_ptes: fix leak on realloc failure tools/libs/guest/xg_core_x86.c | 2 ++ tools/libs/guest/xg_offline_page.c | 7 +-- 2 files changed, 7 insertions(+), 2 deletions(-) -- 2.39.1
[PATCH v1 1/2] xc_core_arch_map_p2m_tree_rw: fix memory leak
From: Edwin Török Prior to bd7a29c3d0 'out' would've always been executed and memory freed, but that commit changed it such that it returns early and leaks. Found using gcc 12.2.1 `-fanalyzer`: ``` xg_core_x86.c: In function ‘xc_core_arch_map_p2m_tree_rw’: xg_core_x86.c:300:5: error: leak of ‘p2m_frame_list_list’ [CWE-401] [-Werror=analyzer-malloc-leak] 300 | return p2m_frame_list; | ^~ ‘xc_core_arch_map_p2m_writable’: events 1-2 | | 378 | xc_core_arch_map_p2m_writable(xc_interface *xch, struct domain_info_context *dinfo, xc_dominfo_t *info, | | ^ | | | | | (1) entry to ‘xc_core_arch_map_p2m_writable’ |.. | 381 | return xc_core_arch_map_p2m_rw(xch, dinfo, info, live_shinfo, live_p2m, 1); | | ~~~ | || | |(2) calling ‘xc_core_arch_map_p2m_rw’ from ‘xc_core_arch_map_p2m_writable’ | +--> ‘xc_core_arch_map_p2m_rw’: events 3-10 | | 319 | xc_core_arch_map_p2m_rw(xc_interface *xch, struct domain_info_context *dinfo, xc_dominfo_t *info, | | ^~~ | | | | | (3) entry to ‘xc_core_arch_map_p2m_rw’ |.. | 328 | if ( xc_domain_nr_gpfns(xch, info->domid, &dinfo->p2m_size) < 0 ) | |~ | || | |(4) following ‘false’ branch... |.. | 334 | if ( dinfo->p2m_size < info->nr_pages ) | | ~~ ~ | | | | | | | (6) following ‘false’ branch... | | (5) ...to here |.. | 340 | p2m_cr3 = GET_FIELD(live_shinfo, arch.p2m_cr3, dinfo->guest_width); | | ~~~ | | | | | (7) ...to here | 341 | | 342 | p2m_frame_list = p2m_cr3 ? xc_core_arch_map_p2m_list_rw(xch, dinfo, dom, live_shinfo, p2m_cr3) | | ~ | 343 | : xc_core_arch_map_p2m_tree_rw(xch, dinfo, dom, live_shinfo); | | | | | | | | | (9) ...to here | | | (10) calling ‘xc_core_arch_map_p2m_tree_rw’ from ‘xc_core_arch_map_p2m_rw’ | | (8) following ‘false’ branch... | +--> ‘xc_core_arch_map_p2m_tree_rw’: events 11-24 | | 228 | xc_core_arch_map_p2m_tree_rw(xc_interface *xch, struct domain_info_context *dinfo, | | ^~~~ | | | | | (11) entry to ‘xc_core_arch_map_p2m_tree_rw’ |.. | 245 | if ( !live_p2m_frame_list_list ) | |~ | || | |(12) following ‘false’ branch (when ‘live_p2m_frame_list_list’ is non-NULL)... |.. | 252 | if ( !(p2m_frame_list_list = malloc(PAGE_SIZE)) ) | | ~~ ~ ~ | | | | | | | | | (14) allocated here | | | (15) assuming ‘p2m_frame_list_list’ is non-NULL | | | (16) following ‘false’ branch (when ‘p2m_frame_list_list’ is non-NULL)... | | (13) ...to here |.. | 257 | memcpy(p2m_frame_list_list, live_p2m_frame_list_list, PAGE_SIZE); | | ~~ | | | | | (17) ...to here |.. | 266 | else if ( dinfo->guest_width < sizeof(unsigned long) ) | | ~ | | | | | (18) following ‘false’ branch... |.. | 270 | live_p2m_frame_list = | | ~~~ | | | | | (19) ...to here |.. | 275 | if ( !live_p2m_frame_list ) | |~ | || | |(20) foll
[PATCH] x86/msr: fix X2APIC_LAST
The latest Intel manual now says the X2APIC reserved range is only 0x800 to 0x8ff (NOT 0xbff). The AMD manual documents 0x800-0x8ff too. There are non-X2APIC MSRs in the 0x900-0xbff range now: e.g. 0x981 is IA32_TME_CAPABILITY, an architectural MSR. The new MSR in this range appears to have been introduced in Icelake, so this commit should be backported to Xen versions supporting Icelake. Backport: 4.13+ Signed-off-by: Edwin Török --- xen/arch/x86/include/asm/msr-index.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xen/arch/x86/include/asm/msr-index.h b/xen/arch/x86/include/asm/msr-index.h index 8cab8736d8..1a928ea6af 100644 --- a/xen/arch/x86/include/asm/msr-index.h +++ b/xen/arch/x86/include/asm/msr-index.h @@ -148,7 +148,7 @@ #define MSR_INTERRUPT_SSP_TABLE 0x06a8 #define MSR_X2APIC_FIRST0x0800 -#define MSR_X2APIC_LAST 0x0bff +#define MSR_X2APIC_LAST 0x08ff #define MSR_X2APIC_TPR 0x0808 #define MSR_X2APIC_PPR 0x080a -- 2.34.1
[PATCH v2] x86/msr: fix X2APIC_LAST
The latest Intel manual now says the X2APIC reserved range is only
0x800 to 0x8ff (NOT 0xbff).
This changed between SDM 68 (Nov 2018) and SDM 69 (Jan 2019).
The AMD manual documents 0x800-0x8ff too.
There are non-X2APIC MSRs in the 0x900-0xbff range now:
e.g. 0x981 is IA32_TME_CAPABILITY, an architectural MSR.
The new MSR in this range appears to have been introduced in Icelake,
so this commit should be backported to Xen versions supporting Icelake.
Backport: 4.13+
Signed-off-by: Edwin Török
---
Notes:
Changed since v1:
* include version of Intel SDM where the change occured
* remove opencoded MSR_X2APIC_FIRST + 0xff
xen/arch/x86/hvm/vmx/vmx.c | 4 ++--
xen/arch/x86/include/asm/msr-index.h | 2 +-
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/xen/arch/x86/hvm/vmx/vmx.c b/xen/arch/x86/hvm/vmx/vmx.c
index 47554cc004..17e103188a 100644
--- a/xen/arch/x86/hvm/vmx/vmx.c
+++ b/xen/arch/x86/hvm/vmx/vmx.c
@@ -3397,7 +3397,7 @@ void vmx_vlapic_msr_changed(struct vcpu *v)
if ( cpu_has_vmx_apic_reg_virt )
{
for ( msr = MSR_X2APIC_FIRST;
- msr <= MSR_X2APIC_FIRST + 0xff; msr++ )
+ msr <= MSR_X2APIC_LAST; msr++ )
vmx_clear_msr_intercept(v, msr, VMX_MSR_R);
vmx_set_msr_intercept(v, MSR_X2APIC_PPR, VMX_MSR_R);
@@ -3418,7 +3418,7 @@ void vmx_vlapic_msr_changed(struct vcpu *v)
if ( !(v->arch.hvm.vmx.secondary_exec_control &
SECONDARY_EXEC_VIRTUALIZE_X2APIC_MODE) )
for ( msr = MSR_X2APIC_FIRST;
- msr <= MSR_X2APIC_FIRST + 0xff; msr++ )
+ msr <= MSR_X2APIC_LAST; msr++ )
vmx_set_msr_intercept(v, msr, VMX_MSR_RW);
vmx_update_secondary_exec_control(v);
diff --git a/xen/arch/x86/include/asm/msr-index.h
b/xen/arch/x86/include/asm/msr-index.h
index 8cab8736d8..1a928ea6af 100644
--- a/xen/arch/x86/include/asm/msr-index.h
+++ b/xen/arch/x86/include/asm/msr-index.h
@@ -148,7 +148,7 @@
#define MSR_INTERRUPT_SSP_TABLE 0x06a8
#define MSR_X2APIC_FIRST0x0800
-#define MSR_X2APIC_LAST 0x0bff
+#define MSR_X2APIC_LAST 0x08ff
#define MSR_X2APIC_TPR 0x0808
#define MSR_X2APIC_PPR 0x080a
--
2.34.1
[PATCH v1 7/7] tools/ocaml/libs/eventchn: do not leak event channels and OCaml 5.0 compat
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
---
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..c0d57e2954 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), 1, 128);
+ _H(result) = xce;
CAMLreturn(result);
}
--
2.34.1
[PATCH v1 0/7] tools/ocaml code and build cleanups
Various OCaml code cleanups to make building and working on Oxenstored easier, including compatibility with newer language versions. This does not yet change the minimum version of OCaml. A version of this series in a git repository is publicly available at: https://github.com/edwintorok/xen.git https://github.com/edwintorok/xen/compare/private/edvint/public?expand=1 Edwin Török (7): tools/ocaml/Makefile: do not run ocamldep during make clean tools/ocaml/*/Makefile: generate paths.ml from configure tools/ocaml/*/dune: dune based build system tools/ocaml: Makefile to drive dune tools/ocaml: fix compiler warnings tools/ocaml/libs/xb: hide type of Xb.t tools/ocaml/libs/eventchn: do not leak event channels and OCaml 5.0 compat Makefile | 5 ++ tools/.gitignore | 7 ++ tools/configure | 4 +- tools/configure.ac| 2 + tools/dune| 5 ++ tools/dune-project| 1 + tools/ocaml/Makefile.dune | 88 +++ tools/ocaml/Makefile.rules| 2 + tools/ocaml/dune-project | 27 ++ tools/ocaml/dune-workspace.dev.in | 2 + tools/ocaml/dune-workspace.in | 18 tools/ocaml/libs/eventchn/dune| 11 +++ tools/ocaml/libs/eventchn/xeneventchn_stubs.c | 29 +- tools/ocaml/libs/mmap/dune| 9 ++ tools/ocaml/libs/xb/dune | 10 +++ tools/ocaml/libs/xb/xb.ml | 3 + tools/ocaml/libs/xb/xb.mli| 9 +- tools/ocaml/libs/xc/dune | 16 tools/ocaml/libs/xs/Makefile | 5 -- tools/ocaml/libs/xs/dune | 15 tools/ocaml/libs/xs/paths.ml.in | 1 + tools/ocaml/xenstored/Makefile| 5 -- tools/ocaml/xenstored/connection.ml | 10 +-- tools/ocaml/xenstored/dune| 51 +++ tools/ocaml/xenstored/paths.ml.in | 4 + tools/ocaml/xenstored/process.ml | 5 +- 26 files changed, 315 insertions(+), 29 deletions(-) create mode 100644 tools/.gitignore create mode 100644 tools/dune create mode 100644 tools/dune-project create mode 100644 tools/ocaml/Makefile.dune create mode 100644 tools/ocaml/dune-project create mode 100644 tools/ocaml/dune-workspace.dev.in create mode 100644 tools/ocaml/dune-workspace.in create mode 100644 tools/ocaml/libs/eventchn/dune create mode 100644 tools/ocaml/libs/mmap/dune create mode 100644 tools/ocaml/libs/xb/dune create mode 100644 tools/ocaml/libs/xc/dune create mode 100644 tools/ocaml/libs/xs/dune create mode 100644 tools/ocaml/libs/xs/paths.ml.in create mode 100644 tools/ocaml/xenstored/dune create mode 100644 tools/ocaml/xenstored/paths.ml.in -- 2.34.1
[PATCH v1 2/7] tools/ocaml/*/Makefile: generate paths.ml from configure
paths.ml contains various paths known to configure, and currently is generated via a Makefile rule. Simplify this and generate it through configure, similar to how oxenstored.conf is generated from oxenstored.conf.in. This will allow to reuse the generated file more easily with Dune. No functional change. Signed-off-by: Edwin Török --- tools/configure | 4 +++- tools/configure.ac| 2 ++ tools/ocaml/libs/xs/Makefile | 5 - tools/ocaml/libs/xs/paths.ml.in | 1 + tools/ocaml/xenstored/Makefile| 5 - tools/ocaml/xenstored/paths.ml.in | 4 6 files changed, 10 insertions(+), 11 deletions(-) create mode 100644 tools/ocaml/libs/xs/paths.ml.in create mode 100644 tools/ocaml/xenstored/paths.ml.in diff --git a/tools/configure b/tools/configure index a052c186a5..41deb7fb96 100755 --- a/tools/configure +++ b/tools/configure @@ -2453,7 +2453,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -ac_config_files="$ac_config_files ../config/Tools.mk hotplug/FreeBSD/rc.d/xencommons hotplug/FreeBSD/rc.d/xendriverdomain hotplug/Linux/init.d/sysconfig.xencommons hotplug/Linux/init.d/sysconfig.xendomains hotplug/Linux/init.d/xen-watchdog hotplug/Linux/init.d/xencommons hotplug/Linux/init.d/xendomains hotplug/Linux/init.d/xendriverdomain hotplug/Linux/launch-xenstore hotplug/Linux/vif-setup hotplug/Linux/xen-hotplug-common.sh hotplug/Linux/xendomains hotplug/NetBSD/rc.d/xencommons hotplug/NetBSD/rc.d/xendriverdomain ocaml/xenstored/oxenstored.conf" +ac_config_files="$ac_config_files ../config/Tools.mk hotplug/FreeBSD/rc.d/xencommons hotplug/FreeBSD/rc.d/xendriverdomain hotplug/Linux/init.d/sysconfig.xencommons hotplug/Linux/init.d/sysconfig.xendomains hotplug/Linux/init.d/xen-watchdog hotplug/Linux/init.d/xencommons hotplug/Linux/init.d/xendomains hotplug/Linux/init.d/xendriverdomain hotplug/Linux/launch-xenstore hotplug/Linux/vif-setup hotplug/Linux/xen-hotplug-common.sh hotplug/Linux/xendomains hotplug/NetBSD/rc.d/xencommons hotplug/NetBSD/rc.d/xendriverdomain ocaml/libs/xs/paths.ml ocaml/xenstored/paths.ml ocaml/xenstored/oxenstored.conf" ac_config_headers="$ac_config_headers config.h" @@ -10935,6 +10935,8 @@ do "hotplug/Linux/xendomains") CONFIG_FILES="$CONFIG_FILES hotplug/Linux/xendomains" ;; "hotplug/NetBSD/rc.d/xencommons") CONFIG_FILES="$CONFIG_FILES hotplug/NetBSD/rc.d/xencommons" ;; "hotplug/NetBSD/rc.d/xendriverdomain") CONFIG_FILES="$CONFIG_FILES hotplug/NetBSD/rc.d/xendriverdomain" ;; +"ocaml/libs/xs/paths.ml") CONFIG_FILES="$CONFIG_FILES ocaml/libs/xs/paths.ml" ;; +"ocaml/xenstored/paths.ml") CONFIG_FILES="$CONFIG_FILES ocaml/xenstored/paths.ml" ;; "ocaml/xenstored/oxenstored.conf") CONFIG_FILES="$CONFIG_FILES ocaml/xenstored/oxenstored.conf" ;; "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; "hotplug/Linux/systemd/proc-xen.mount") CONFIG_FILES="$CONFIG_FILES hotplug/Linux/systemd/proc-xen.mount" ;; diff --git a/tools/configure.ac b/tools/configure.ac index 1094d896fc..32cbe6bd3c 100644 --- a/tools/configure.ac +++ b/tools/configure.ac @@ -21,6 +21,8 @@ hotplug/Linux/xen-hotplug-common.sh hotplug/Linux/xendomains hotplug/NetBSD/rc.d/xencommons hotplug/NetBSD/rc.d/xendriverdomain +ocaml/libs/xs/paths.ml +ocaml/xenstored/paths.ml ocaml/xenstored/oxenstored.conf ]) AC_CONFIG_HEADERS([config.h]) diff --git a/tools/ocaml/libs/xs/Makefile b/tools/ocaml/libs/xs/Makefile index e934bbb550..e160e6a711 100644 --- a/tools/ocaml/libs/xs/Makefile +++ b/tools/ocaml/libs/xs/Makefile @@ -44,8 +44,3 @@ uninstall: $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xenstore include $(OCAML_TOPLEVEL)/Makefile.rules - -genpath-target = $(call buildmakevars2module,paths.ml) -$(eval $(genpath-target)) - -GENERATED_FILES += paths.ml diff --git a/tools/ocaml/libs/xs/paths.ml.in b/tools/ocaml/libs/xs/paths.ml.in new file mode 100644 index 00..c067f8d012 --- /dev/null +++ b/tools/ocaml/libs/xs/paths.ml.in @@ -0,0 +1 @@ +let xen_run_stored = "@XEN_RUN_STORED@" diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile index 0b5711b507..6f7333926e 100644 --- a/tools/ocaml/xenstored/Makefile +++ b/tools/ocaml/xenstored/Makefile @@ -93,8 +93,3 @@ uninstall: rm -f $(DESTDIR)$(sbindir)/oxenstored include $(OCAML_TOPLEVEL)/Makefile.rules - -genpath-target = $(call buildmakevars2module,paths.ml) -$(eval $(genpath-target)) - -GENERATED_FILES += paths.ml diff --git a/tools/ocaml/xenstored/paths.ml.in b/tools/ocaml/xenstored/paths.ml.in new file mode 100644 index 00..37949dc8f3 --- /dev/null +++ b/tools/ocaml/xenstored/paths.ml.in @@ -0,0 +1,4 @@ +let xen_log_dir = "@XEN_LOG_DIR@" +let xen_config_dir = "@XEN_CONFIG_DIR@" +let xen_run_dir = "@XEN_RUN_DIR@" +let xen_run_stored = "@XEN_RUN_STORED@" -- 2.34.1
[PATCH v1 6/7] tools/ocaml/libs/xb: hide type of Xb.t
The only user of 'xb' that I can find is in-tree oxenstored.
Other code (e.g. xenopsd) would use the mirage 'xenstore' implementation
instead, so changing the API here shouldn't require anyone to update
their code.
Hiding the type will make it easier to change the implementation
in the future without breaking code that relies on it.
No functional change.
Signed-off-by: Edwin Török
---
tools/ocaml/libs/xb/xb.ml | 3 +++
tools/ocaml/libs/xb/xb.mli | 9 ++---
tools/ocaml/xenstored/connection.ml | 8 ++--
3 files changed, 7 insertions(+), 13 deletions(-)
diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml
index 104d319d77..8404ddd8a6 100644
--- a/tools/ocaml/libs/xb/xb.ml
+++ b/tools/ocaml/libs/xb/xb.ml
@@ -196,6 +196,9 @@ let peek_output con = Queue.peek con.pkt_out
let input_len con = Queue.length con.pkt_in
let has_in_packet con = Queue.length con.pkt_in > 0
let get_in_packet con = Queue.pop con.pkt_in
+let has_partial_input con = match con.partial_in with
+ | HaveHdr _ -> true
+ | NoHdr (n, _) -> n < Partial.header_size ()
let has_more_input con =
match con.backend with
| Fd _ -> false
diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli
index 3a00da6cdd..794e35bb34 100644
--- a/tools/ocaml/libs/xb/xb.mli
+++ b/tools/ocaml/libs/xb/xb.mli
@@ -66,13 +66,7 @@ type backend_mmap = {
type backend_fd = { 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
-type t = {
- backend : backend;
- pkt_in : Packet.t Queue.t;
- pkt_out : Packet.t Queue.t;
- mutable partial_in : partial_buf;
- mutable partial_out : string;
-}
+type t
val init_partial_in : unit -> partial_buf
val reconnect : t -> unit
val queue : t -> Packet.t -> unit
@@ -97,6 +91,7 @@ val has_output : t -> bool
val peek_output : t -> Packet.t
val input_len : t -> int
val has_in_packet : t -> bool
+val has_partial_input : t -> bool
val get_in_packet : t -> Packet.t
val has_more_input : t -> bool
val is_selectable : t -> bool
diff --git a/tools/ocaml/xenstored/connection.ml
b/tools/ocaml/xenstored/connection.ml
index a94d47cdc2..0ce54cd7f9 100644
--- a/tools/ocaml/xenstored/connection.ml
+++ b/tools/ocaml/xenstored/connection.ml
@@ -125,9 +125,7 @@ let get_perm con =
let set_target con target_domid =
con.perm <- Perms.Connection.set_target (get_perm con)
~perms:[Perms.READ; Perms.WRITE] target_domid
-let is_backend_mmap con = match con.xb.Xenbus.Xb.backend with
- | Xenbus.Xb.Xenmmap _ -> true
- | _ -> false
+let is_backend_mmap con = Xenbus.Xb.is_mmap con.xb
let send_reply con tid rid ty data =
if (String.length data) > xenstore_payload_max && (is_backend_mmap con)
then
@@ -280,9 +278,7 @@ let get_transaction con tid =
let do_input con = Xenbus.Xb.input con.xb
let has_input con = Xenbus.Xb.has_in_packet con.xb
-let has_partial_input con = match con.xb.Xenbus.Xb.partial_in with
- | HaveHdr _ -> true
- | NoHdr (n, _) -> n < Xenbus.Partial.header_size ()
+let has_partial_input con = Xenbus.Xb.has_partial_input con.xb
let pop_in con = Xenbus.Xb.get_in_packet con.xb
let has_more_input con = Xenbus.Xb.has_more_input con.xb
--
2.34.1
[PATCH v1 3/7] tools/ocaml/*/dune: dune based build system
Based on Christian Lindig's work.
Initially this will be used to build unit tests, and to make development
easier.
Dune supports proper incremental builds and editor integration with
merlin/LSP.
For now the Makefile based build system is retained too: this is not a
hard dependency on Dune.
Using version 2.1 of Dune build language here, because that is the one
available in Ubuntu Focal (part of the CI here).
No functional change.
Signed-off-by: Edwin Török
---
tools/.gitignore | 7 +
tools/dune | 5
tools/dune-project | 1 +
tools/ocaml/dune-project | 27 ++
tools/ocaml/libs/eventchn/dune | 11
tools/ocaml/libs/mmap/dune | 9 ++
tools/ocaml/libs/xb/dune | 10 +++
tools/ocaml/libs/xc/dune | 16 +++
tools/ocaml/libs/xs/dune | 15 ++
tools/ocaml/xenstored/dune | 51 ++
10 files changed, 152 insertions(+)
create mode 100644 tools/.gitignore
create mode 100644 tools/dune
create mode 100644 tools/dune-project
create mode 100644 tools/ocaml/dune-project
create mode 100644 tools/ocaml/libs/eventchn/dune
create mode 100644 tools/ocaml/libs/mmap/dune
create mode 100644 tools/ocaml/libs/xb/dune
create mode 100644 tools/ocaml/libs/xc/dune
create mode 100644 tools/ocaml/libs/xs/dune
create mode 100644 tools/ocaml/xenstored/dune
diff --git a/tools/.gitignore b/tools/.gitignore
new file mode 100644
index 00..c211749a3b
--- /dev/null
+++ b/tools/.gitignore
@@ -0,0 +1,7 @@
+dune-workspace*
+_build/
+.merlin
+*.h.gch
+*.opam
+ocaml/*.install
+include/_xentoolcore_list.h
diff --git a/tools/dune b/tools/dune
new file mode 100644
index 00..febbd078f0
--- /dev/null
+++ b/tools/dune
@@ -0,0 +1,5 @@
+; only look inside ocaml and include subdirectory, speeds up the build
+; since dune doesn't need to copy/hash/monitor all the other files
+(dirs ocaml)
+
+(data_only_dirs include libs)
diff --git a/tools/dune-project b/tools/dune-project
new file mode 100644
index 00..cd8d4e3d86
--- /dev/null
+++ b/tools/dune-project
@@ -0,0 +1 @@
+(lang dune 2.1)
diff --git a/tools/ocaml/dune-project b/tools/ocaml/dune-project
new file mode 100644
index 00..1dae7b0acb
--- /dev/null
+++ b/tools/ocaml/dune-project
@@ -0,0 +1,27 @@
+(lang dune 2.1)
+
+(name xen)
+
+(formatting (enabled_for dune))
+(generate_opam_files true)
+
+(maintainers christian.lin...@citrix.com)
+(license LGPL)
+
+(package
+ (name xen)
+ (synopsis "Xen interfaces")
+ (depends
+ base-unix
+ (dune (>= 2.1))
+ )
+)
+
+(package
+ (name xenstored)
+ (synopsis "In-memory key-value store for the Xen hypervisor")
+ (depends
+ base-unix
+ (dune (>= 2.1))
+ )
+)
diff --git a/tools/ocaml/libs/eventchn/dune b/tools/ocaml/libs/eventchn/dune
new file mode 100644
index 00..4468f2e769
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/dune
@@ -0,0 +1,11 @@
+(library
+ (foreign_stubs
+ (language c)
+ (names xeneventchn_stubs)
+ (extra_deps ../../../include/xen/xen.h ../../../libs/evtchn/libxenevtchn.so)
+ (include_dirs ../../../include))
+ (name xeneventchn)
+ (public_name xen.eventchn)
+ (libraries unix)
+ (no_dynlink)
+ (c_library_flags -lxenevtchn))
diff --git a/tools/ocaml/libs/mmap/dune b/tools/ocaml/libs/mmap/dune
new file mode 100644
index 00..57a8ab5b9b
--- /dev/null
+++ b/tools/ocaml/libs/mmap/dune
@@ -0,0 +1,9 @@
+(library
+ (foreign_stubs
+ (language c)
+ (names xenmmap_stubs))
+ (name xenmmap)
+ (public_name xen.mmap)
+ (libraries unix)
+ (no_dynlink)
+ (install_c_headers mmap_stubs))
diff --git a/tools/ocaml/libs/xb/dune b/tools/ocaml/libs/xb/dune
new file mode 100644
index 00..13a507ea87
--- /dev/null
+++ b/tools/ocaml/libs/xb/dune
@@ -0,0 +1,10 @@
+(library
+ (foreign_stubs
+ (language c)
+ (extra_deps ../../../include/xen/xen.h)
+ (include_dirs ../../../include)
+ (names xenbus_stubs xs_ring_stubs))
+ (name xenbus)
+ (public_name xen.bus)
+ (no_dynlink)
+ (libraries unix xenmmap))
diff --git a/tools/ocaml/libs/xc/dune b/tools/ocaml/libs/xc/dune
new file mode 100644
index 00..6f9450cd27
--- /dev/null
+++ b/tools/ocaml/libs/xc/dune
@@ -0,0 +1,16 @@
+(rule
+ (with-stdout-to
+ xenctrl_abi_check.h
+ (run perl -w %{dep:abi-check} %{dep:xenctrl_stubs.c} %{dep:xenctrl.ml})))
+
+(library
+ (foreign_stubs
+ (language c)
+ (names xenctrl_stubs)
+ (extra_deps ../../../include/xen/xen.h ../../../libs/ctrl/libxenctrl.so)
+ (include_dirs ../../../include))
+ (name xenctrl)
+ (public_name xen.ctrl)
+ (libraries unix xenmmap)
+ (no_dynlink)
+ (c_library_flags -lxenctrl -lxenguest))
diff --git a/tools/ocaml/libs/xs/dune b/tools/ocaml/libs/xs/dune
new file mode 100644
index 00..086259f51d
--- /dev/null
+++ b/tools/ocaml/libs/xs/dune
@@ -0,0 +1,15 @@
+; fallback mode: the files may have been generated by configure already
+
+(rule
+ (targets paths.ml)
+ (deps paths.ml.in)
[PATCH v1 1/7] tools/ocaml/Makefile: do not run ocamldep during make clean
Trying to include .ocamldep.make will cause it to be generated if it doesn't exist. We do not want this during make clean: we would remove it anyway. Speeds up make clean. Before (measured on f732240fd3bac25116151db5ddeb7203b62e85ce, July 2022): ``` Parsing /home/edwin/xen2/tools/ocaml/libs/xl/../../../../tools/libs/light/libxl_types.idl Parsing /home/edwin/xen2/tools/ocaml/libs/xl/../../../../tools/libs/light/libxl_types.idl Parsing /home/edwin/xen2/tools/ocaml/libs/xl/../../../../tools/libs/light/libxl_types.idl Parsing /home/edwin/xen2/tools/ocaml/libs/xl/../../../../tools/libs/light/libxl_types.idl Parsing /home/edwin/xen2/tools/ocaml/libs/xl/../../../../tools/libs/light/libxl_types.idl Performance counter stats for 'make clean -j8 -s' (5 runs): 4.2233 +- 0.0208 seconds time elapsed ( +- 0.49% ) ``` After: ``` perf stat -r 5 --null make clean -j8 -s Performance counter stats for 'make clean -j8 -s' (5 runs): 2.7325 +- 0.0138 seconds time elapsed ( +- 0.51% ) ``` No functional change. Signed-off-by: Edwin Török --- tools/ocaml/Makefile.rules | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules index 7e4db457a1..d368308d9b 100644 --- a/tools/ocaml/Makefile.rules +++ b/tools/ocaml/Makefile.rules @@ -44,8 +44,10 @@ META: META.in ALL_OCAML_OBJ_SOURCES=$(addsuffix .ml, $(ALL_OCAML_OBJS)) +ifneq ($(MAKECMDGOALS),clean) .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 -- 2.34.1
[PATCH v1 4/7] tools/ocaml: Makefile to drive dune
create a separate Makefile that can be used to drive dune.
Usage:
`make -f Makefile.dune`
There are some files that need to be created by the Makefile based
build system (such as all the C code in $(XEN_ROOT)/tools/libs),
and those need to exist before dune runs.
Although it'd be possible to automatically call the necessary makefile
rules from dune, it wouldn't work reliably:
* dune uses sandboxing by default (only files declared or known as
dependencies are visible to individual build commands,
symlinks/hardlinks are used by dune to implement this)
* the dune builds always run in a _build subdir, and calling the
makefiles from there would get the wrong XEN_ROOT set
* running the make command in the source tree would work, but dune still
wouldn't immediately see the build dependencies since they wouldn't
have been copied/linked under _build
The approach here is to:
* use the Makefile to build C-only prerequisites (i.e. most of Xen)
* use Dune only to build the OCaml parts once the C prerequisites exist
* dune has dependencies declared on the C bits, so if they are missing
you will get an error about a missing rule to create them instead of a
cryptic compilation error
* dune is still optional - the old Makefile based buildsystem is still
there for now
* use dune exclusively for new code going forward (e.g. OCaml test-suites)
The workspace file needs to be generated by make because this currently
cannot be generated by dune, and it doesn't support including external
files. But could be generated by configure?
LD_LIBRARY_PATH needs to be set, because even with -Wl,-rpath
executables wouldn't be able to run using the just-built libraries,
unless we'd also link all the transitive dependencies of libs.
No functional change.
Signed-off-by: Edwin Török
---
Makefile | 5 ++
tools/ocaml/Makefile.dune | 88 +++
tools/ocaml/dune-workspace.dev.in | 2 +
tools/ocaml/dune-workspace.in | 18 +++
4 files changed, 113 insertions(+)
create mode 100644 tools/ocaml/Makefile.dune
create mode 100644 tools/ocaml/dune-workspace.dev.in
create mode 100644 tools/ocaml/dune-workspace.in
diff --git a/Makefile b/Makefile
index b93b22c752..ddb33c3555 100644
--- a/Makefile
+++ b/Makefile
@@ -68,6 +68,11 @@ build-tools-oxenstored: build-tools-public-headers
$(MAKE) -s -C tools/libs
$(MAKE) -C tools/ocaml build-tools-oxenstored
+.PHONY: build-tools-oxenstored-prepare
+build-tools-oxenstored-prepare: build-tools-public-headers
+ test -f tools/config.status || (cd tools && ./configure
--with-xenstored=oxenstored)
+ $(MAKE) -C tools/libs V=
+
.PHONY: build-stubdom
build-stubdom: mini-os-dir build-tools-public-headers
$(MAKE) -C stubdom build
diff --git a/tools/ocaml/Makefile.dune b/tools/ocaml/Makefile.dune
new file mode 100644
index 00..eca9cac0ca
--- /dev/null
+++ b/tools/ocaml/Makefile.dune
@@ -0,0 +1,88 @@
+XEN_ROOT = $(CURDIR)/../..
+all: dune-all-check
+
+# Dune by default uses all available CPUs. Make doesn't.
+# Query the available CPUs and use all available for any of the make rules we
call out to.
+# -O is also needed with parallel make such that the build error and the build
command causing
+# the error are close together and not interspersed with other output
+NPROC=$(shell getconf _NPROCESSORS_ONLN)
+MAKEN=$(MAKE) -j$(NPROC) -O
+
+# We want to link and use the Xen libraries built locally
+# without installing them system-wide
+# (the system-wide one installed from packages will likely be too old and not
match the locally
+# built one anyway).
+#
+# Set LIBRARY_PATH and LD_LIBRARY_PATH so that the linker
+# finds the proper libraries and the various dune commands
+# work (e.g. running tests, utop, etc.).
+#
+# The Makefile based buildsystem would use -Wl,-rpath-link= here,
+# but that only works during linking, not runtime.
+# There is a -Wl, -rpath= that can be used, but that only works
+# for libraries linked directly to the main executable:
+# the dependencies of those libraries won't get found on the rpath
+# (the rpath of the executable is apparently not used during that search).
+#
+# Use environment variables, because that way we don't make any permanent
alternations (rpath)
+# to the executable, so once installed system-wide it won't refer to build
paths anymore.
+#
+# Dune cannot be used to generate this file: the env-vars stanza doesn't
support %{read:}, :include,
+# and dune-workspace doesn't support (include) stanzas.
+# So for now generate it from this Makefile
+# Cannot start with comment, so add auto-generated comment at the end
+LIB_DIRS=$(abspath $(wildcard ../libs/*/.))
+LIBRARY_PATH=$(subst $(eval) ,:,$(LIB_DIRS))
+../dune-workspace ../dune-workspace.dev: dune-workspace.in
dune-workspace.dev.in Makefile.dune
+ @( sed -e "s|@LIBRARY_PATH@|$(LIBRARY_PATH)|" <$<
[PATCH v1 5/7] tools/ocaml: fix compiler warnings
Fix compiler warning about: * unused value * ambiguous documentation comment * non-principal type inference (compiler version dependent) No functional change. Signed-off-by: Edwin Török --- tools/ocaml/xenstored/connection.ml | 2 +- tools/ocaml/xenstored/process.ml| 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml index 65f99ea6f2..a94d47cdc2 100644 --- a/tools/ocaml/xenstored/connection.ml +++ b/tools/ocaml/xenstored/connection.ml @@ -313,7 +313,7 @@ let is_bad con = match con.dom with None -> false | Some dom -> Domain.is_bad_do let has_extra_connection_data con = let has_in = has_input con || has_partial_input con in let has_out = has_output con in - let has_socket = con.dom = None in + let _has_socket = con.dom = None 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 diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml index 27790d4a5c..86eed02413 100644 --- a/tools/ocaml/xenstored/process.ml +++ b/tools/ocaml/xenstored/process.ml @@ -59,7 +59,7 @@ let split_one_path data con = let process_watch t cons = let oldroot = t.Transaction.oldroot in - let newroot = Store.get_root t.store 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 @@ -491,7 +491,7 @@ let transaction_replay c t doms cons = ignore @@ Connection.end_transaction c tid None ) -let do_watch con t _domains cons data = +let do_watch con _t _domains cons data = let (node, token) = match (split None '\000' data) with | [node; token; ""] -> node, token @@ -651,6 +651,7 @@ let maybe_ignore_transaction = function let () = Printexc.record_backtrace true + (** * Nothrow guarantee. *) -- 2.34.1
[RFC PATCH] tools/configure: require OCaml >= 4.06.1 for oxenstored
OCaml 4.06.1 is widely available in distributions: https://repology.org/project/ocaml/versions oxenstored already includes some compatibility code to be able to run on versions older than 4.06, however this is slightly less efficient than just using the new features in 4.06 standard library: https://lore.kernel.org/xen-devel/b94cd2ad099486678609909e12b045c54abb2f27.ca...@citrix.com/ The OCaml version in stubdom/ is unchanged for now as it is unclear how this used. Typically to run OCaml code as a stubdom one would use the mirage tooling to build a unikernel, which handles cross-compilation using Dune. The unikernel itself also uses Solo5 instead of MiniOS, so the OCaml code in stubdom/ is probably stale. Signed-off-by: Edwin Török Cc: Christian Lindig --- tools/configure| 2 +- tools/configure.ac | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/configure b/tools/configure index 41deb7fb96..8f391e2da4 100755 --- a/tools/configure +++ b/tools/configure @@ -6765,7 +6765,7 @@ else -e 's/[^0-9]//g'` - ax_compare_version_B=`echo "4.02.0" | sed -e 's/\([0-9]*\)/Z\1Z/g' \ + ax_compare_version_B=`echo "4.06.1" | sed -e 's/\([0-9]*\)/Z\1Z/g' \ -e 's/Z\([0-9]\)Z/Z0\1Z/g' \ -e 's/Z\([0-9][0-9]\)Z/Z0\1Z/g' \ -e 's/Z\([0-9][0-9][0-9]\)Z/Z0\1Z/g' \ diff --git a/tools/configure.ac b/tools/configure.ac index 32cbe6bd3c..7518199ec8 100644 --- a/tools/configure.ac +++ b/tools/configure.ac @@ -310,7 +310,7 @@ AS_IF([test "x$ocamltools" = "xy"], [ AC_MSG_ERROR([Ocaml tools enabled, but missing ocamlopt or ocamlfind])]) ocamltools="n" ], [ -AX_COMPARE_VERSION([$OCAMLVERSION], [lt], [4.02.0], [ +AX_COMPARE_VERSION([$OCAMLVERSION], [lt], [4.06.1], [ AS_IF([test "x$enable_ocamltools" = "xyes"], [ AC_MSG_ERROR([Your version of OCaml: $OCAMLVERSION is not supported])]) ocamltools="n" -- 2.34.1
[PATCH v1 3/5] tools/ocaml/libs/xc: add hvm_param_get binding
Not to be confused which hvm_get_param, which also exists and has a different, more error-prone interface. This one always returns a 64-bit value, and that is retained in the OCaml binding as well, returning 'int64' (and not int, or nativeint which might have a different size). The integer here is unsigned in the C API, however OCaml only has signed integers. No bits are lost, it is just a matter of interpretation when printing and for certain arithmetic operations, however in the cases where the MSB is set it is very likely that the value is an address and no arithmetic should be performed on the OCaml side on it. (this is not a new problem with this binding, but worth mentioning given the difference in types) Signed-off-by: Edwin Török --- tools/ocaml/libs/xc/xenctrl.ml | 44 tools/ocaml/libs/xc/xenctrl.mli | 45 + tools/ocaml/libs/xc/xenctrl_stubs.c | 16 ++ 3 files changed, 105 insertions(+) diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml index c21e391f98..1f8d927b0c 100644 --- a/tools/ocaml/libs/xc/xenctrl.ml +++ b/tools/ocaml/libs/xc/xenctrl.ml @@ -298,6 +298,50 @@ external map_foreign_range: handle -> domid -> int -> nativeint -> Xenmmap.mmap_interface = "stub_map_foreign_range" +type hvm_param = + | HVM_PARAM_CALLBACK_IRQ + | HVM_PARAM_STORE_PFN + | HVM_PARAM_STORE_EVTCHN + | HVM_PARAM_UNDEFINED_3 + | HVM_PARAM_PAE_ENABLED + | HVM_PARAM_IOREQ_PFN + | HVM_PARAM_BUFIOREQ_PFN + | HVM_PARAM_UNDEFINED_7 + | HVM_PARAM_UNDEFINED_8 + | HVM_PARAM_VIRIDIAN + | HVM_PARAM_TIMER_MODE0 + | HVM_PARAM_HPET_ENABLED1 + | HVM_PARAM_IDENT_PT2 + | HVM_PARAM_UNDEFINED_13 + | HVM_PARAM_ACPI_S_STATE4 + | HVM_PARAM_VM86_TSS5 + | HVM_PARAM_VPT_ALIGN6 + | HVM_PARAM_CONSOLE_PFN7 + | HVM_PARAM_CONSOLE_EVTCHN8 + | HVM_PARAM_ACPI_IOPORTS_LOCATION9 + | HVM_PARAM_MEMORY_EVENT_CR00 + | HVM_PARAM_MEMORY_EVENT_CR31 + | HVM_PARAM_MEMORY_EVENT_CR42 + | HVM_PARAM_MEMORY_EVENT_INT33 + | HVM_PARAM_NESTEDHVM4 + | HVM_PARAM_MEMORY_EVENT_SINGLE_STEP5 + | HVM_PARAM_UNDEFINED_26 + | HVM_PARAM_PAGING_RING_PFN7 + | HVM_PARAM_MONITOR_RING_PFN8 + | HVM_PARAM_SHARING_RING_PFN9 + | HVM_PARAM_MEMORY_EVENT_MSR0 + | HVM_PARAM_TRIPLE_FAULT_REASON1 + | HVM_PARAM_IOREQ_SERVER_PFN2 + | HVM_PARAM_NR_IOREQ_SERVER_PAGES3 + | HVM_PARAM_VM_GENERATION_ID_ADDR4 + | HVM_PARAM_ALTP2M5 + | HVM_PARAM_X87_FIP_WIDTH6 + | HVM_PARAM_VM86_TSS_SIZED7 + | HVM_PARAM_MCA_CAP8 + +external hvm_param_get: handle -> domid -> hvm_param -> int64 + = "stub_xc_hvm_param_get" + external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit = "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli index 60e7902e66..f6c7e5b553 100644 --- a/tools/ocaml/libs/xc/xenctrl.mli +++ b/tools/ocaml/libs/xc/xenctrl.mli @@ -236,6 +236,51 @@ external map_foreign_range : handle -> domid -> int -> nativeint -> Xenmmap.mmap_interface = "stub_map_foreign_range" +(* needs to be sorted according to its numeric value, watch out for gaps! *) +type hvm_param = + | HVM_PARAM_CALLBACK_IRQ + | HVM_PARAM_STORE_PFN + | HVM_PARAM_STORE_EVTCHN + | HVM_PARAM_UNDEFINED_3 + | HVM_PARAM_PAE_ENABLED + | HVM_PARAM_IOREQ_PFN + | HVM_PARAM_BUFIOREQ_PFN + | HVM_PARAM_UNDEFINED_7 + | HVM_PARAM_UNDEFINED_8 + | HVM_PARAM_VIRIDIAN + | HVM_PARAM_TIMER_MODE0 + | HVM_PARAM_HPET_ENABLED1 + | HVM_PARAM_IDENT_PT2 + | HVM_PARAM_UNDEFINED_13 + | HVM_PARAM_ACPI_S_STATE4 + | HVM_PARAM_VM86_TSS5 + | HVM_PARAM_VPT_ALIGN6 + | HVM_PARAM_CONSOLE_PFN7 + | HVM_PARAM_CONSOLE_EVTCHN8 + | HVM_PARAM_ACPI_IOPORTS_LOCATION9 + | HVM_PARAM_MEMORY_EVENT_CR00 + | HVM_PARAM_MEMORY_EVENT_CR31 + | HVM_PARAM_MEMORY_EVENT_CR42 + | HVM_PARAM_MEMORY_EVENT_INT33 + | HVM_PARAM_NESTEDHVM4 + | HVM_PARAM_MEMORY_EVENT_SINGLE_STEP5 + | HVM_PARAM_UNDEFINED_26 + | HVM_PARAM_PAGING_RING_PFN7 + | HVM_PARAM_MONITOR_RING_PFN8 + | HVM_PARAM_SHARING_RING_PFN9 + | HVM_PARAM_MEMORY_EVENT_MSR0 + | HVM_PARAM_TRIPLE_FAULT_REASON1 + | HVM_PARAM_IOREQ_SERVER_PFN2 + | HVM_PARAM_NR_IOREQ_SERVER_PAGES3 + | HVM_PARAM_VM_GENERATION_ID_ADDR4 + | HVM_PARAM_ALTP2M5 + | HVM_PARAM_X87_FIP_WIDTH6 + | HVM_PARAM_VM86_TSS_SIZED7 + | HVM_PARAM_MCA_CAP8 + +external hvm_param_get: handle -> domid -> hvm_param -> int64 + = "stub_xc_hvm_param_get" + external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit = "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c b/tools/ocaml/libs/xc/xenctrl_stubs.c index 67f3648391..b2df93d4f8 100644 --- a/tools/o
[PATCH v1 5/5] CODING_STYLE: add .clang-format
Add a .clang-format configuration that tries to match CODING_STYLE where possible. I was not able to express the special casing of braces after 'do' though, this can only be controlled generally for all control statements. It is imperfect, but should be better than the existing bindings, which do not follow Xen coding style. Add this to tools/ocaml first because: * there are relatively few C files here, and it is a good place to start with * it'd be useful to make these follow Xen's CODING_STYLE (which they currently do not because they use tabs for example) * they change relatively infrequently, so shouldn't cause issues with backporting security fixes (could either backport the reindentation patch too, or use git cherry-pick with `-Xignore-space-change`) Once this is used it'll need inserting some '#include ', otherwise xs_wire.h fails to compile due to the missing uint32_t define. Does not yet reformat any code. No functional change. Signed-off-by: Edwin Török --- tools/ocaml/.clang-format | 9 + 1 file changed, 9 insertions(+) create mode 100644 tools/ocaml/.clang-format diff --git a/tools/ocaml/.clang-format b/tools/ocaml/.clang-format new file mode 100644 index 00..7ff88ee043 --- /dev/null +++ b/tools/ocaml/.clang-format @@ -0,0 +1,9 @@ +BasedOnStyle: GNU +IndentWidth: 4 + +# override GNU to match Xen ../../CODING_STYLE more closely +AlwaysBreakAfterDefinitionReturnType: None +AlwaysBreakAfterReturnType: None +SpacesInConditionalStatement: true +SpaceBeforeParens: ControlStatements +BreakBeforeBraces: Allman -- 2.34.1
[PATCH v1 1/5] CODING-STYLE: add .editorconfig to clarify indentation uses spaces
Add an .editorconfig to make it easier to keep patches compatible with
Xen's coding style, and to reemphasize what Xen's coding style is.
I thought that Xen demands tabs rather than spaces (which is more
difficult with OCaml because indentation tools use spaces,
and the use of tabs requires changing editor settings),
however CODING-STYLE says it is spaces.
Document this explicitly by adding a .editorconfig file (see editorconfig.org),
which is an editor agnostic format for specifying basic style properties like
indentation, either with native support in editors or via plugins.
It is safer than modelines because it only supports controlling a
restricted set of editor properties and not arbitrary commands as Vim
modelines would have, and works with editors other than Vim too.
(Vim has a deny list for modeline sandboxing, which is error-prone
because every time a new command gets added it needs to be added to the
deny list, which has been the source of a few CVEs in the past
and I disable Vim modelines everywhere as a precaution).
This file is added as a convenience for those who might have an editor
that supports it, and its presence should have no impact on those that
do not (want to) use it.
It also won't cause re-indentation of existing files when edited, only
newly added lines would follow the convention.
No functional change.
Signed-off-by: Edwin Török
---
.editorconfig | 20
1 file changed, 20 insertions(+)
create mode 100644 .editorconfig
diff --git a/.editorconfig b/.editorconfig
new file mode 100644
index 00..cb2f27c581
--- /dev/null
+++ b/.editorconfig
@@ -0,0 +1,20 @@
+# See ./CODING_STYLE
+root = true
+
+[*]
+end_of_line = lf
+indent_style = space
+charset = utf-8
+max_line_length = 79
+trim_trailing_whitespace = true
+insert_final_newline = true
+
+# Makefiles must use tabs, otherwise they don't work
+[{Makefile,*.mk,Makefile.rules}]
+indent_style = tabs
+
+[*.{c,h}]
+indent_size = 4
+
+[*.{ml,mli}]
+indent_size = 2
--
2.34.1
[PATCH v1 4/5] tools/ocaml/libs/xb: add missing stdint.h
xs_wire.h fails to compile without this, and a slight rearrangement of header includes (e.g. by clang-format) could cause the file to fail to compile. Be more robust and include the needed header file. --- tools/ocaml/libs/xb/xenbus_stubs.c | 1 + 1 file changed, 1 insertion(+) diff --git a/tools/ocaml/libs/xb/xenbus_stubs.c b/tools/ocaml/libs/xb/xenbus_stubs.c index e5206f64d4..ce6d33b23e 100644 --- a/tools/ocaml/libs/xb/xenbus_stubs.c +++ b/tools/ocaml/libs/xb/xenbus_stubs.c @@ -15,6 +15,7 @@ */ #include +#include #include #include #include -- 2.34.1
[PATCH v1 0/5] OCaml bindings for hvm_param_get and xc_evtchn_status
Add bindings to xc_evtchn_status and hvm_param_get, useful for xenopsd and for recovery from failed live updates. .editorconfig helps me format the source code with the desired Xen coding style (now that the reindent patch has switched it to spaces as desired by the Xen project). If you don't have an editor set up to use editorconfig this is a no-op. .clang-format is an experiment for the OCaml subtree in slowly moving its code to be closer to the Xen coding style. There is no Xen coding style as such in clang-format, this takes GNU as a base and tweaks it to be as close to CODING_STYLE as possible (there is just one different in handling of do/while as far as I can tell). It should be an improvement over the current situation where the OCaml C bindings do not follow Xen coding style, and further bindings added that follow the style of the code around them would not follow it either. It doesn't yet reformat anything with it, just allows someone that submits patches to use it if desired (e.g. on new code). Edwin Török (5): CODING-STYLE: add .editorconfig to clarify indentation uses spaces tools/ocaml/libs/xc: add binding to xc_evtchn_status tools/ocaml/libs/xc: add hvm_param_get binding tools/ocaml/libs/xb: add missing stdint.h CODING_STYLE: add .clang-format .editorconfig | 20 +++ tools/ocaml/.clang-format | 9 tools/ocaml/libs/xb/xenbus_stubs.c | 1 + tools/ocaml/libs/xc/xenctrl.ml | 58 + tools/ocaml/libs/xc/xenctrl.mli | 60 + tools/ocaml/libs/xc/xenctrl_stubs.c | 81 + 6 files changed, 229 insertions(+) create mode 100644 .editorconfig create mode 100644 tools/ocaml/.clang-format -- 2.34.1
[PATCH v1 2/5] tools/ocaml/libs/xc: add binding to xc_evtchn_status
There is no API or ioctl to query event channel status, it is only
present in xenctrl.h
The C union is mapped to an OCaml variant exposing just the value from the
correct union tag.
Querying event channel status is useful when analyzing Windows VMs that
may have reset and changed the xenstore event channel port number from
what it initially got booted with.
The information provided here is similar to 'lstevtchn', but rather than
parsing its output it queries the underlying API directly.
Signed-off-by: Edwin Török
---
tools/ocaml/libs/xc/xenctrl.ml | 14 +++
tools/ocaml/libs/xc/xenctrl.mli | 15 +++
tools/ocaml/libs/xc/xenctrl_stubs.c | 65 +
3 files changed, 94 insertions(+)
diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml
index 2ed7454b16..c21e391f98 100644
--- a/tools/ocaml/libs/xc/xenctrl.ml
+++ b/tools/ocaml/libs/xc/xenctrl.ml
@@ -267,6 +267,20 @@ external evtchn_alloc_unbound: handle -> domid -> domid ->
int
= "stub_xc_evtchn_alloc_unbound"
external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset"
+type evtchn_interdomain = { dom: domid; port: int}
+
+type evtchn_stat =
+ | EVTCHNSTAT_unbound of domid
+ | EVTCHNSTAT_interdomain of evtchn_interdomain
+ | EVTCHNSTAT_pirq of int
+ | EVTCHNSTAT_virq of int
+ | EVTCHNSTAT_ipi
+
+type evtchn_status = { vcpu: int; status: evtchn_stat }
+
+external evtchn_status: handle -> domid -> int -> evtchn_status option =
+ "stub_xc_evtchn_status"
+
external readconsolering: handle -> string = "stub_xc_readconsolering"
external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys"
diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli
index 0f80aafea0..60e7902e66 100644
--- a/tools/ocaml/libs/xc/xenctrl.mli
+++ b/tools/ocaml/libs/xc/xenctrl.mli
@@ -206,6 +206,21 @@ external shadow_allocation_get : handle -> domid -> int
external evtchn_alloc_unbound : handle -> domid -> domid -> int
= "stub_xc_evtchn_alloc_unbound"
external evtchn_reset : handle -> domid -> unit = "stub_xc_evtchn_reset"
+
+type evtchn_interdomain = { dom: domid; port: int}
+
+type evtchn_stat =
+ | EVTCHNSTAT_unbound of domid
+ | EVTCHNSTAT_interdomain of evtchn_interdomain
+ | EVTCHNSTAT_pirq of int
+ | EVTCHNSTAT_virq of int
+ | EVTCHNSTAT_ipi
+
+type evtchn_status = { vcpu: int; status: evtchn_stat }
+
+external evtchn_status: handle -> domid -> int -> evtchn_status option =
+ "stub_xc_evtchn_status"
+
external readconsolering : handle -> string = "stub_xc_readconsolering"
external send_debug_keys : handle -> string -> unit = "stub_xc_send_debug_keys"
external physinfo : handle -> physinfo = "stub_xc_physinfo"
diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c
b/tools/ocaml/libs/xc/xenctrl_stubs.c
index d30585f21c..67f3648391 100644
--- a/tools/ocaml/libs/xc/xenctrl_stubs.c
+++ b/tools/ocaml/libs/xc/xenctrl_stubs.c
@@ -641,6 +641,71 @@ CAMLprim value stub_xc_evtchn_reset(value xch, value domid)
CAMLreturn(Val_unit);
}
+CAMLprim value stub_xc_evtchn_status(value xch, value domid, value port)
+{
+CAMLparam3(xch, domid, port);
+CAMLlocal4(result, result_status, stat, interdomain);
+xc_evtchn_status_t status;
+int rc;
+
+memset(&status, 0, sizeof(status));
+status.dom = _D(domid);
+status.port = Int_val(port);
+
+caml_enter_blocking_section();
+rc = xc_evtchn_status(_H(xch), &status);
+caml_leave_blocking_section();
+
+if ( rc < 0 )
+failwith_xc(_H(xch));
+
+if ( status.status == EVTCHNSTAT_closed )
+result = Val_none;
+else
+{
+switch ( status.status )
+{
+case EVTCHNSTAT_unbound:
+stat = caml_alloc(1, 0); /* 1st non-constant constructor */
+Store_field(stat, 0, Val_int(status.u.unbound.dom));
+break;
+
+case EVTCHNSTAT_interdomain:
+interdomain = caml_alloc_tuple(2);
+Store_field(interdomain, 0, Val_int(status.u.interdomain.dom));
+Store_field(interdomain, 1, Val_int(status.u.interdomain.port));
+stat = caml_alloc(1, 1); /* 2nd non-constant constructor */
+Store_field(stat, 0, interdomain);
+break;
+case EVTCHNSTAT_pirq:
+stat = caml_alloc(1, 2); /* 3rd non-constant constructor */
+Store_field(stat, 0, Val_int(status.u.pirq));
+break;
+
+case EVTCHNSTAT_virq:
+stat = caml_alloc(1, 3); /* 4th non-constant constructor */
+Store_field(stat, 0, Val_int(status.u.virq));
+break;
+
+case EVTCHNSTAT_ipi:
+stat = Val_int(0); /* 1st constant constructor */
+break;
+
+default:
+
[PATCH v2 0/4] OCaml bindings for hvm_param_get and xc_evtchn_status
Changes since v1: * dropped stdint.h patch, still being discussed on where to best fix it * addressed review comments (see individual patches' changes section) Edwin Török (4): CODING-STYLE: add .editorconfig to clarify indentation uses spaces tools/ocaml/libs/xc: add binding to xc_evtchn_status tools/ocaml/libs/xc: add hvm_param_get binding tools/ocaml: add .clang-format .editorconfig | 20 ++ tools/ocaml/.clang-format | 9 +++ tools/ocaml/libs/Makefile | 2 +- tools/ocaml/libs/xc/META.in | 2 +- tools/ocaml/libs/xc/Makefile| 2 +- tools/ocaml/libs/xc/xenctrl.ml | 62 ++ tools/ocaml/libs/xc/xenctrl.mli | 63 ++ tools/ocaml/libs/xc/xenctrl_stubs.c | 99 + 8 files changed, 256 insertions(+), 3 deletions(-) create mode 100644 .editorconfig create mode 100644 tools/ocaml/.clang-format -- 2.34.1
[PATCH v2 3/4] tools/ocaml/libs/xc: add hvm_param_get binding
Not to be confused which hvm_get_param, which also exists and has a different, more error-prone interface. This one always returns a 64-bit value, and that is retained in the OCaml binding as well, returning 'int64' (and not int, or nativeint which might have a different size). The integer here is unsigned in the C API, however OCaml only has signed integers. No bits are lost, it is just a matter of interpretation when printing and for certain arithmetic operations, however in the cases where the MSB is set it is very likely that the value is an address and no arithmetic should be performed on the OCaml side on it. (this is not a new problem with this binding, but worth mentioning given the difference in types) Signed-off-by: Edwin Török --- Changes since v1: * drop accidental extra numbers in variant names * use 'val' instead of 'result' for local var * add binding for hvm_param_set --- tools/ocaml/libs/xc/xenctrl.ml | 47 tools/ocaml/libs/xc/xenctrl.mli | 48 + tools/ocaml/libs/xc/xenctrl_stubs.c | 32 +++ 3 files changed, 127 insertions(+) diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml index 5dac47991e..370dac3fc8 100644 --- a/tools/ocaml/libs/xc/xenctrl.ml +++ b/tools/ocaml/libs/xc/xenctrl.ml @@ -299,6 +299,53 @@ external map_foreign_range: handle -> domid -> int -> nativeint -> Xenmmap.mmap_interface = "stub_map_foreign_range" +type hvm_param = + | HVM_PARAM_CALLBACK_IRQ + | HVM_PARAM_STORE_PFN + | HVM_PARAM_STORE_EVTCHN + | HVM_PARAM_UNDEF_3 + | HVM_PARAM_PAE_ENABLED + | HVM_PARAM_IOREQ_PFN + | HVM_PARAM_BUFIOREQ_PFN + | HVM_PARAM_UNDEF_7 + | HVM_PARAM_UNDEF_8 + | HVM_PARAM_VIRIDIAN + | HVM_PARAM_TIMER_MODE0 + | HVM_PARAM_HPET_ENABLED1 + | HVM_PARAM_IDENT_PT2 + | HVM_PARAM_UNDEF_13 + | HVM_PARAM_ACPI_S_STATE + | HVM_PARAM_VM86_TSS + | HVM_PARAM_VPT_ALIGN + | HVM_PARAM_CONSOLE_PFN + | HVM_PARAM_CONSOLE_EVTCHN + | HVM_PARAM_ACPI_IOPORTS_LOCATION + | HVM_PARAM_MEMORY_EVENT_CR0 + | HVM_PARAM_MEMORY_EVENT_CR3 + | HVM_PARAM_MEMORY_EVENT_CR4 + | HVM_PARAM_MEMORY_EVENT_INT3 + | HVM_PARAM_NESTEDHVM + | HVM_PARAM_MEMORY_EVENT_SINGLE_STEP + | HVM_PARAM_UNDEF_26 + | HVM_PARAM_PAGING_RING_PFN + | HVM_PARAM_MONITOR_RING_PFN + | HVM_PARAM_SHARING_RING_PFN + | HVM_PARAM_MEMORY_EVENT_MSR + | HVM_PARAM_TRIPLE_FAULT_REASON + | HVM_PARAM_IOREQ_SERVER_PFN + | HVM_PARAM_NR_IOREQ_SERVER_PAGES + | HVM_PARAM_VM_GENERATION_ID_ADDR + | HVM_PARAM_ALTP2M + | HVM_PARAM_X87_FIP_WIDTH6 + | HVM_PARAM_VM86_TSS_SIZED + | HVM_PARAM_MCA_CAP + +external hvm_param_get: handle -> domid -> hvm_param -> int64 + = "stub_xc_hvm_param_get" + +external hvm_param_set: handle -> domid -> hvm_param -> int64 -> unit + = "stub_xc_hvm_param_set" + external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit = "stub_xc_domain_assign_device" external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli index 6c9206bc74..e18d5cddb7 100644 --- a/tools/ocaml/libs/xc/xenctrl.mli +++ b/tools/ocaml/libs/xc/xenctrl.mli @@ -236,6 +236,54 @@ external map_foreign_range : handle -> domid -> int -> nativeint -> Xenmmap.mmap_interface = "stub_map_foreign_range" +(* needs to be sorted according to its numeric value, watch out for gaps! *) +type hvm_param = + | HVM_PARAM_CALLBACK_IRQ + | HVM_PARAM_STORE_PFN + | HVM_PARAM_STORE_EVTCHN + | HVM_PARAM_UNDEF_3 + | HVM_PARAM_PAE_ENABLED + | HVM_PARAM_IOREQ_PFN + | HVM_PARAM_BUFIOREQ_PFN + | HVM_PARAM_UNDEF_7 + | HVM_PARAM_UNDEF_8 + | HVM_PARAM_VIRIDIAN + | HVM_PARAM_TIMER_MODE0 + | HVM_PARAM_HPET_ENABLED1 + | HVM_PARAM_IDENT_PT2 + | HVM_PARAM_UNDEF_13 + | HVM_PARAM_ACPI_S_STATE + | HVM_PARAM_VM86_TSS + | HVM_PARAM_VPT_ALIGN + | HVM_PARAM_CONSOLE_PFN + | HVM_PARAM_CONSOLE_EVTCHN + | HVM_PARAM_ACPI_IOPORTS_LOCATION + | HVM_PARAM_MEMORY_EVENT_CR0 + | HVM_PARAM_MEMORY_EVENT_CR3 + | HVM_PARAM_MEMORY_EVENT_CR4 + | HVM_PARAM_MEMORY_EVENT_INT3 + | HVM_PARAM_NESTEDHVM + | HVM_PARAM_MEMORY_EVENT_SINGLE_STEP + | HVM_PARAM_UNDEF_26 + | HVM_PARAM_PAGING_RING_PFN + | HVM_PARAM_MONITOR_RING_PFN + | HVM_PARAM_SHARING_RING_PFN + | HVM_PARAM_MEMORY_EVENT_MSR + | HVM_PARAM_TRIPLE_FAULT_REASON + | HVM_PARAM_IOREQ_SERVER_PFN + | HVM_PARAM_NR_IOREQ_SERVER_PAGES + | HVM_PARAM_VM_GENERATION_ID_ADDR + | HVM_PARAM_ALTP2M + | HVM_PARAM_X87_FIP_WIDTH6 + | HVM_PARAM_VM86_TSS_SIZED + | HVM_PARAM_MCA_CAP + +external hvm_param_get: handle -> domid -> hvm_param -> int64 + = "stub_xc_hvm_param_get" + +external hvm_param_set: handle -> domid -> hvm_param -> int64 -> unit + = "stub_xc_hvm_param_set" + external domain_assign_device: ha
[PATCH v2 1/4] CODING-STYLE: add .editorconfig to clarify indentation uses spaces
Add an .editorconfig to make it easier to keep patches compatible with
Xen's coding style, and to reemphasize what Xen's coding style is.
I thought that Xen demands tabs rather than spaces (which is more
difficult with OCaml because indentation tools use spaces,
and the use of tabs requires changing editor settings),
however CODING-STYLE says it is spaces.
Document this explicitly by adding a .editorconfig file (see editorconfig.org),
which is an editor agnostic format for specifying basic style properties like
indentation, either with native support in editors or via plugins.
It is safer than modelines because it only supports controlling a
restricted set of editor properties and not arbitrary commands as Vim
modelines would have, and works with editors other than Vim too.
(Vim has a deny list for modeline sandboxing, which is error-prone
because every time a new command gets added it needs to be added to the
deny list, which has been the source of a few CVEs in the past
and I disable Vim modelines everywhere as a precaution).
This file is added as a convenience for those who might have an editor
that supports it, and its presence should have no impact on those that
do not (want to) use it.
It also won't cause re-indentation of existing files when edited, only
newly added lines would follow the convention.
No functional change.
Signed-off-by: Edwin Török
---
.editorconfig | 20
1 file changed, 20 insertions(+)
create mode 100644 .editorconfig
diff --git a/.editorconfig b/.editorconfig
new file mode 100644
index 00..cb2f27c581
--- /dev/null
+++ b/.editorconfig
@@ -0,0 +1,20 @@
+# See ./CODING_STYLE
+root = true
+
+[*]
+end_of_line = lf
+indent_style = space
+charset = utf-8
+max_line_length = 79
+trim_trailing_whitespace = true
+insert_final_newline = true
+
+# Makefiles must use tabs, otherwise they don't work
+[{Makefile,*.mk,Makefile.rules}]
+indent_style = tabs
+
+[*.{c,h}]
+indent_size = 4
+
+[*.{ml,mli}]
+indent_size = 2
--
2.34.1
[PATCH v2 2/4] tools/ocaml/libs/xc: add binding to xc_evtchn_status
There is no API or ioctl to query event channel status, it is only
present in xenctrl.h
The C union is mapped to an OCaml variant exposing just the value from the
correct union tag.
The information provided here is similar to 'lsevtchn', but rather than
parsing its output it queries the underlying API directly.
Signed-off-by: Edwin Török
---
Changes since v1:
* drop paragraph about where this is used
* add comment about max port
* use Xeneventchn.virq_t instead of int, add a dependency: xc -> eventchn
* initialize struct without memset-ing first
* use 2 CAMLreturn, I found an example in the OCaml stdlib that does that so
should be future-proof
https://github.com/ocaml/ocaml/blob/663e8d219f566095e3a9497c5bae07b6a95cae39/otherlibs/unix/dup_win32.c#L52-L77
* use Tag_some, defining it if needed
* fix typo on failwith
---
tools/ocaml/libs/Makefile | 2 +-
tools/ocaml/libs/xc/META.in | 2 +-
tools/ocaml/libs/xc/Makefile| 2 +-
tools/ocaml/libs/xc/xenctrl.ml | 15 +++
tools/ocaml/libs/xc/xenctrl.mli | 15 +++
tools/ocaml/libs/xc/xenctrl_stubs.c | 67 +
6 files changed, 100 insertions(+), 3 deletions(-)
diff --git a/tools/ocaml/libs/Makefile b/tools/ocaml/libs/Makefile
index 7e7c27e2d5..15f45a6d66 100644
--- a/tools/ocaml/libs/Makefile
+++ b/tools/ocaml/libs/Makefile
@@ -4,7 +4,7 @@ include $(XEN_ROOT)/tools/Rules.mk
SUBDIRS= \
mmap \
xentoollog \
- xc eventchn \
+ eventchn xc\
xb xs xl
.PHONY: all
diff --git a/tools/ocaml/libs/xc/META.in b/tools/ocaml/libs/xc/META.in
index 2ff4dcb6bf..6a273936a3 100644
--- a/tools/ocaml/libs/xc/META.in
+++ b/tools/ocaml/libs/xc/META.in
@@ -1,5 +1,5 @@
version = "@VERSION@"
description = "Xen Control Interface"
-requires = "unix,xenmmap"
+requires = "unix,xenmmap,xeneventchn"
archive(byte) = "xenctrl.cma"
archive(native) = "xenctrl.cmxa"
diff --git a/tools/ocaml/libs/xc/Makefile b/tools/ocaml/libs/xc/Makefile
index 3b76e9ad7b..1d9fecb06e 100644
--- a/tools/ocaml/libs/xc/Makefile
+++ b/tools/ocaml/libs/xc/Makefile
@@ -4,7 +4,7 @@ include $(OCAML_TOPLEVEL)/common.make
CFLAGS += -I../mmap $(CFLAGS_libxenctrl) $(CFLAGS_libxenguest)
CFLAGS += $(APPEND_CFLAGS)
-OCAMLINCLUDE += -I ../mmap
+OCAMLINCLUDE += -I ../mmap -I ../eventchn
OBJS = xenctrl
INTF = xenctrl.cmi
diff --git a/tools/ocaml/libs/xc/xenctrl.ml b/tools/ocaml/libs/xc/xenctrl.ml
index 2ed7454b16..5dac47991e 100644
--- a/tools/ocaml/libs/xc/xenctrl.ml
+++ b/tools/ocaml/libs/xc/xenctrl.ml
@@ -267,6 +267,21 @@ external evtchn_alloc_unbound: handle -> domid -> domid ->
int
= "stub_xc_evtchn_alloc_unbound"
external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset"
+(* FIFO has theoretical maximum of 2^28 ports, fits in an int *)
+type evtchn_interdomain = { dom: domid; port: int}
+
+type evtchn_stat =
+ | EVTCHNSTAT_unbound of domid
+ | EVTCHNSTAT_interdomain of evtchn_interdomain
+ | EVTCHNSTAT_pirq of int
+ | EVTCHNSTAT_virq of Xeneventchn.virq_t
+ | EVTCHNSTAT_ipi
+
+type evtchn_status = { vcpu: int; status: evtchn_stat }
+
+external evtchn_status: handle -> domid -> int -> evtchn_status option =
+ "stub_xc_evtchn_status"
+
external readconsolering: handle -> string = "stub_xc_readconsolering"
external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys"
diff --git a/tools/ocaml/libs/xc/xenctrl.mli b/tools/ocaml/libs/xc/xenctrl.mli
index 0f80aafea0..6c9206bc74 100644
--- a/tools/ocaml/libs/xc/xenctrl.mli
+++ b/tools/ocaml/libs/xc/xenctrl.mli
@@ -206,6 +206,21 @@ external shadow_allocation_get : handle -> domid -> int
external evtchn_alloc_unbound : handle -> domid -> domid -> int
= "stub_xc_evtchn_alloc_unbound"
external evtchn_reset : handle -> domid -> unit = "stub_xc_evtchn_reset"
+
+type evtchn_interdomain = { dom: domid; port: int}
+
+type evtchn_stat =
+ | EVTCHNSTAT_unbound of domid
+ | EVTCHNSTAT_interdomain of evtchn_interdomain
+ | EVTCHNSTAT_pirq of int
+ | EVTCHNSTAT_virq of Xeneventchn.virq_t
+ | EVTCHNSTAT_ipi
+
+type evtchn_status = { vcpu: int; status: evtchn_stat }
+
+external evtchn_status: handle -> domid -> int -> evtchn_status option =
+ "stub_xc_evtchn_status"
+
external readconsolering : handle -> string = "stub_xc_readconsolering"
external send_debug_keys : handle -> string -> unit = "stub_xc_send_debug_keys"
external physinfo : handle -> physinfo = "stub_xc_physinfo"
diff --git a/tools/ocaml/libs/xc/xenctrl_stubs.c
b/tools/ocaml/libs/xc/xenctrl_stubs.c
index d30585f21c..a492ea17fd 100644
--- a/tools/ocaml/libs/xc/xenctrl_stubs.c
+++ b/tools/ocaml/libs/xc/xenctrl_stubs.c
@@ -44,6 +44,10 @@
#define Val_none (Val_int(0))
#endif
+#ifndef Tag_some
+#define Ta
