Add patch for XSI-1457 to ocaml-vhd

Signed-off-by: Christian Lindig <[email protected]>

packages/upstream/vhd-format-lwt.0.12.0/files/0001-XSI-1457-Limit-number-of-sectors-to-coalesce.patch

@@ -0,0 +1,99 @@
+From e2de1b257ecad00173672411870695f7b362b2fe Mon Sep 17 00:00:00 2001
+From: Christian Lindig <[email protected]>
+Date: Tue, 27 Feb 2024 15:19:07 +0000
+Subject: [PATCH 1/1] XSI-1457: Limit number of sectors to coalesce
+
+We limit the number of sectors to coalesce when generating a list of
+elements to be copied. The limit is currently set to 4 MiB. This allows
+the progress bar to be displayed at a finer granularity rather than
+going from 0 to 100 in one go due to one big sector being generated.
+
+Backport of xen-api.git db4d465f16745892b4d4ff37d44f8dbd72182314
+
+Signed-off-by: Vincent Liu <[email protected]>
+Signed-off-by: Christian Lindig <[email protected]>
+---
+ vhd_format/f.ml | 58 +++++++++++++++++++++++++++++++++++--------------
+ 1 file changed, 42 insertions(+), 16 deletions(-)
+
+diff --git a/vhd_format/f.ml b/vhd_format/f.ml
+index de1d521..e6f953f 100644
+--- a/vhd_format/f.ml
++++ b/vhd_format/f.ml
+@@ -18,6 +18,14 @@
+ let sector_size = 512
+ let sector_shift = 9
+
++let mib n =
++  let ( ** ) = Int64.mul in
++  Int64.(1024L ** 1024L ** of_int n)
++
++(** This is defined to be the same as sync_limit in channels.ml due to circular
++    dependencies.  *)
++let sync_limit = mib 4
++
+ exception Cstruct_differ
+
+ let cstruct_equal a b =
+@@ -2000,24 +2008,42 @@ module From_file = functor(F: S.FILE) -> struct
+     | false, Some parent -> in_any_bat parent i
+     | false, None -> false
+
+-  let rec coalesce_request acc s =
++  (* The coalesced_sectors variable accumulates the number of bytes that have
++     been coalesced so far. It is made optional because we only use it when we
++     continuously match with one pattern, i.e. the pattern where we coalesce
++     consecutive sectors, and default it to 1 when we are not coalescing. *)
++  let rec coalesce_request ?(coalesced_sectors = 1L) acc s =
+     let open Int64 in
+-    s >>= fun next -> match next, acc with
++    s >>= fun next ->
++    match (next, acc) with
+     | End, None -> return End
+-    | End, Some x -> return (Cons(x, fun () -> return End))
+-    | Cons(`Sectors s, next), None -> return(Cons(`Sectors s, fun () -> coalesce_request None (next ())))
+-    | Cons(`Sectors _, _next), Some x -> return(Cons(x, fun () -> coalesce_request None s))
+-    | Cons(`Empty n, next), None -> coalesce_request (Some(`Empty n)) (next ())
+-    | Cons(`Empty n, next), Some(`Empty m) -> coalesce_request (Some(`Empty (n ++ m))) (next ())
+-    | Cons(`Empty _n, _next), Some x -> return (Cons(x, fun () -> coalesce_request None s))
+-    | Cons(`Copy(h, ofs, len), next), None -> coalesce_request (Some (`Copy(h, ofs, len))) (next ())
+-    | Cons(`Copy(h, ofs, len), next), Some(`Copy(h', ofs', len')) ->
+-      if ofs ++ len = ofs' && h == h'
+-      then coalesce_request (Some(`Copy(h, ofs, len ++ len'))) (next ())
+-      else if ofs' ++ len' = ofs && h == h'
+-      then coalesce_request (Some(`Copy(h, ofs', len ++ len'))) (next ())
+-      else return (Cons(`Copy(h', ofs', len'), fun () -> coalesce_request None s))
+-    | Cons(`Copy(_h, _ofs, _len), _next), Some x -> return(Cons(x, fun () -> coalesce_request None s))
++    | End, Some x -> return (Cons (x, fun () -> return End))
++    | Cons (`Sectors s, next), None ->
++        return (Cons (`Sectors s, fun () -> coalesce_request None (next ())))
++    | Cons (`Sectors _, _next), Some x ->
++        return (Cons (x, fun () -> coalesce_request None s))
++    | Cons (`Empty n, next), None -> coalesce_request (Some (`Empty n)) (next ())
++    | Cons (`Empty n, next), Some (`Empty m) ->
++        coalesce_request (Some (`Empty (n ++ m))) (next ())
++    | Cons (`Empty _n, _next), Some x ->
++        return (Cons (x, fun () -> coalesce_request None s))
++    | Cons (`Copy (h, ofs, len), next), None ->
++        coalesce_request (Some (`Copy (h, ofs, len))) (next ())
++    | Cons (`Copy (h, ofs, len), next), Some (`Copy (h', ofs', len'))
++      when coalesced_sectors ** Int64.of_int sector_size <= sync_limit ->
++        if ofs ++ len = ofs' && h == h' then
++          coalesce_request ~coalesced_sectors:(coalesced_sectors ++ 1L)
++            (Some (`Copy (h, ofs, len ++ len')))
++            (next ())
++        else if ofs' ++ len' = ofs && h == h' then
++          coalesce_request ~coalesced_sectors:(coalesced_sectors ++ 1L)
++            (Some (`Copy (h, ofs', len ++ len')))
++            (next ())
++        else
++          return
++            (Cons (`Copy (h', ofs', len'), fun () -> coalesce_request None s))
++    | Cons (`Copy (_h, _ofs, _len), _next), Some x ->
++        return (Cons (x, fun () -> coalesce_request None s))
+
+   let twomib_bytes = 2 * 1024 * 1024
+   let twomib_sectors = twomib_bytes / 512
+-- 
+2.34.1
+

packages/upstream/vhd-format-lwt.0.12.0/opam

@@ -29,6 +29,9 @@ depends: [
   "dune" {>= "1.0"}
 ]
 available: os = "linux" | os = "macos"
+patches: [
+  "0001-XSI-1457-Limit-number-of-sectors-to-coalesce.patch"
+]
 build: [
   ["dune" "build" "-p" name "-j" jobs]
   ["dune" "runtest" "-p" name "-j" jobs] {with-test}

packages/upstream/vhd-format.0.12.0/files/0001-XSI-1457-Limit-number-of-sectors-to-coalesce.patch

@@ -0,0 +1,99 @@
+From e2de1b257ecad00173672411870695f7b362b2fe Mon Sep 17 00:00:00 2001
+From: Christian Lindig <[email protected]>
+Date: Tue, 27 Feb 2024 15:19:07 +0000
+Subject: [PATCH 1/1] XSI-1457: Limit number of sectors to coalesce
+
+We limit the number of sectors to coalesce when generating a list of
+elements to be copied. The limit is currently set to 4 MiB. This allows
+the progress bar to be displayed at a finer granularity rather than
+going from 0 to 100 in one go due to one big sector being generated.
+
+Backport of xen-api.git db4d465f16745892b4d4ff37d44f8dbd72182314
+
+Signed-off-by: Vincent Liu <[email protected]>
+Signed-off-by: Christian Lindig <[email protected]>
+---
+ vhd_format/f.ml | 58 +++++++++++++++++++++++++++++++++++--------------
+ 1 file changed, 42 insertions(+), 16 deletions(-)
+
+diff --git a/vhd_format/f.ml b/vhd_format/f.ml
+index de1d521..e6f953f 100644
+--- a/vhd_format/f.ml
++++ b/vhd_format/f.ml
+@@ -18,6 +18,14 @@
+ let sector_size = 512
+ let sector_shift = 9
+
++let mib n =
++  let ( ** ) = Int64.mul in
++  Int64.(1024L ** 1024L ** of_int n)
++
++(** This is defined to be the same as sync_limit in channels.ml due to circular
++    dependencies.  *)
++let sync_limit = mib 4
++
+ exception Cstruct_differ
+
+ let cstruct_equal a b =
+@@ -2000,24 +2008,42 @@ module From_file = functor(F: S.FILE) -> struct
+     | false, Some parent -> in_any_bat parent i
+     | false, None -> false
+
+-  let rec coalesce_request acc s =
++  (* The coalesced_sectors variable accumulates the number of bytes that have
++     been coalesced so far. It is made optional because we only use it when we
++     continuously match with one pattern, i.e. the pattern where we coalesce
++     consecutive sectors, and default it to 1 when we are not coalescing. *)
++  let rec coalesce_request ?(coalesced_sectors = 1L) acc s =
+     let open Int64 in
+-    s >>= fun next -> match next, acc with
++    s >>= fun next ->
++    match (next, acc) with
+     | End, None -> return End
+-    | End, Some x -> return (Cons(x, fun () -> return End))
+-    | Cons(`Sectors s, next), None -> return(Cons(`Sectors s, fun () -> coalesce_request None (next ())))
+-    | Cons(`Sectors _, _next), Some x -> return(Cons(x, fun () -> coalesce_request None s))
+-    | Cons(`Empty n, next), None -> coalesce_request (Some(`Empty n)) (next ())
+-    | Cons(`Empty n, next), Some(`Empty m) -> coalesce_request (Some(`Empty (n ++ m))) (next ())
+-    | Cons(`Empty _n, _next), Some x -> return (Cons(x, fun () -> coalesce_request None s))
+-    | Cons(`Copy(h, ofs, len), next), None -> coalesce_request (Some (`Copy(h, ofs, len))) (next ())
+-    | Cons(`Copy(h, ofs, len), next), Some(`Copy(h', ofs', len')) ->
+-      if ofs ++ len = ofs' && h == h'
+-      then coalesce_request (Some(`Copy(h, ofs, len ++ len'))) (next ())
+-      else if ofs' ++ len' = ofs && h == h'
+-      then coalesce_request (Some(`Copy(h, ofs', len ++ len'))) (next ())
+-      else return (Cons(`Copy(h', ofs', len'), fun () -> coalesce_request None s))
+-    | Cons(`Copy(_h, _ofs, _len), _next), Some x -> return(Cons(x, fun () -> coalesce_request None s))
++    | End, Some x -> return (Cons (x, fun () -> return End))
++    | Cons (`Sectors s, next), None ->
++        return (Cons (`Sectors s, fun () -> coalesce_request None (next ())))
++    | Cons (`Sectors _, _next), Some x ->
++        return (Cons (x, fun () -> coalesce_request None s))
++    | Cons (`Empty n, next), None -> coalesce_request (Some (`Empty n)) (next ())
++    | Cons (`Empty n, next), Some (`Empty m) ->
++        coalesce_request (Some (`Empty (n ++ m))) (next ())
++    | Cons (`Empty _n, _next), Some x ->
++        return (Cons (x, fun () -> coalesce_request None s))
++    | Cons (`Copy (h, ofs, len), next), None ->
++        coalesce_request (Some (`Copy (h, ofs, len))) (next ())
++    | Cons (`Copy (h, ofs, len), next), Some (`Copy (h', ofs', len'))
++      when coalesced_sectors ** Int64.of_int sector_size <= sync_limit ->
++        if ofs ++ len = ofs' && h == h' then
++          coalesce_request ~coalesced_sectors:(coalesced_sectors ++ 1L)
++            (Some (`Copy (h, ofs, len ++ len')))
++            (next ())
++        else if ofs' ++ len' = ofs && h == h' then
++          coalesce_request ~coalesced_sectors:(coalesced_sectors ++ 1L)
++            (Some (`Copy (h, ofs', len ++ len')))
++            (next ())
++        else
++          return
++            (Cons (`Copy (h', ofs', len'), fun () -> coalesce_request None s))
++    | Cons (`Copy (_h, _ofs, _len), _next), Some x ->
++        return (Cons (x, fun () -> coalesce_request None s))
+
+   let twomib_bytes = 2 * 1024 * 1024
+   let twomib_sectors = twomib_bytes / 512
+-- 
+2.34.1
+

packages/upstream/vhd-format.0.12.0/opam

@@ -28,6 +28,9 @@ available: os = "linux" | os = "macos"
 build: ["dune" "build" "-p" name "-j" jobs]
 depexts: ["linux-headers"] {os-distribution = "alpine"}
 dev-repo: "git+https://github.com/mirage/ocaml-vhd.git"
+patches: [
+  "0001-XSI-1457-Limit-number-of-sectors-to-coalesce.patch"
+]
 url {
   src:
     "https://github.com/mirage/ocaml-vhd/releases/download/v0.12.0/vhd-format-v0.12.0.tbz"