ocaml/libs: Check if blocks are filled with zeros in vhd_format (#6720)

`find_data_blocks` is used to determine which blocks need to be copied
to the destination VHD file during export. It uses `lseek(SEEK_DATA)` to
skip "holes" in files. Raw files presented by the storage layer,
however, do not have holes, instead returning blocks filled with zeros.
This means that `vhd-tool` ends up allocating every single block (even
if all of them contain zeroes and no actual data).

In addition to using `lseek_data`, read the whole block and check if it
only contains zeros. This avoids allocating zero blocks and greatly
speeds up export from raw to vhd (which happens when exporting qcow2 to
vhd as well).

Before this fix, when exporting a QCOW2-backed VDI (which vhd-tool falls
back to treating as "raw"):

    $ xe vdi-export uuid=VDI_UUID filename=test.vhd format=vhd
    $ ll -h test.vhd
    2.1G test.vhd

Compared to the qcow2 backing file:

    $ ll -h /var/run/sr-mount/SR_UUID/VDI_UUID.qcow2
    165M /var/run/sr-mount/SR_UUID/VDI_UUID.qcow2

After this fix:

    $ ll -h test.vhd
    219M test.vhd

Author: last-genius

ocaml/libs/vhd/vhd_format/f.ml

@@ -3273,16 +3273,24 @@ functor
       open Raw
 
       let vhd t =
-        let include_block block_size index =
+        let include_block block_size index zero buffer =
           (* is the next data byte in the next block? *)
           let offset = Int64.(mul block_size (of_int index)) in
           F.lseek_data t.Raw.handle offset >>= fun data ->
-          return Int64.(add offset block_size > data)
+          if Int64.(add offset block_size > data) then
+            (* Check if the block is filled with zeros *)
+            really_read t.Raw.handle offset buffer >>= fun () ->
+            return (not (Cstruct.equal buffer zero))
+          else
+            return false
         in
         let find_data_blocks ~blocks ~block_size =
+          (* Cstruct.create fills the buffer with 0 bytes *)
+          let zero = Cstruct.create (Int64.to_int block_size) in
+          let buffer = Memory.alloc (Int64.to_int block_size) in
           let rec loop index acc =
             if index < blocks then
-              include_block block_size index >>= function
+              include_block block_size index zero buffer >>= function
               | true ->
                   loop (index + 1) (index :: acc)
               | false ->