Merge pull request #5215 from Vincent-lau/bar

XSI-1457: Limit number of sectors to coalesce

ocaml/libs/vhd/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 =
@@ -2633,7 +2641,11 @@ functor
       | 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
@@ -2653,11 +2665,16 @@ functor
           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')) ->
+      | 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 (Some (`Copy (h, ofs, len ++ len'))) (next ())
+            coalesce_request ~coalesced_sectors:(coalesced_sectors ++ 1L)
+              (Some (`Copy (h, ofs, len ++ len')))
+              (next ())
           else if ofs' ++ len' = ofs && h == h' then
-            coalesce_request (Some (`Copy (h, ofs', len ++ len'))) (next ())
+            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))