Reduce memory usage (#134)

Memory usage is reduced by:
* Dropping the `refs` map entirely, it is not essential for the functioning of `qcow_stream`
* Dropping cached clusters as soon as they've been read
* Using `Qcow_mapping` (implemented in C as a simple array) instead of `ClusterMap` to store physical-to-virtual mappings

Memory usage and runtime comparisons for before/after this PR:
```
image                 | memory peak    | runtime (> /dev/null) | runtime (> disk)
-----------------------------------------------------------------------------------
23G XO-produced image | 142mb -> 12mb  | 12.1 -> 10.5          | 17.9 -> 16.4
54G             image | 271mb -> 19mb  | 33.5 -> 26.2          | 49.8 -> 44.1
```
(a 200gb qcow2 image takes up 56mb of memory at peak after the PR, meaning for every additional terabyte in the image size, memory usage grows by ~120mb, and a 20tb image would take up around 2.5gb)

This required changing types in the interface, so I've bumped the version to 0.13.0 as a "breaking" change (nothing except one caller in xapi uses this)

Author: psafont

CHANGES.md

@@ -1,3 +1,8 @@
+## 0.13.0 (2026-02-06)
+- qcow_stream: Breaking changes to the interface, with the allocated data
+  clusters now returned in Qcow_mapping.t. Great reductions in memory usage,
+  various other optimizations (last-genius #134)
+
 ## 0.12.3 (2026-01-28)
 - qcow_cache: Fix skipped reads, which could lead to crashes
   and corruption (last-genius #133)

dune-project

@@ -24,10 +24,12 @@
     (diet (>= 0.3.0))
     logs
     lwt
+    lwt_ppx
     (mirage-block (>= 3.0.0))
     ppx_sexp_conv
     prometheus
     sexplib
+    (alcotest :with-test)
   )
 )
 

lib/dune

@@ -7,7 +7,8 @@
   (name qcow_types)
   (public_name qcow-types)
   (modules (:standard \ qcow qcow_debug qcow_block_cache qcow_cstructs
-                      qcow_padded qcow_recycler qcow_stream))
+                      qcow_padded qcow_recycler qcow_stream
+                      qcow_mapping qcow_mapping_test))
   (libraries
     astring
     (re_export cstruct)
@@ -27,19 +28,29 @@
 (library
   (name qcow_stream)
   (public_name qcow-stream)
-  (modules qcow_stream)
+  (modules qcow_stream qcow_mapping)
   (libraries
     cstruct-lwt
     io-page
     lwt.unix
     qcow_types
   )
+  (foreign_stubs
+    (language c)
+    (names qcow_mapping_stubs))
   (wrapped false)
   (preprocess
-    (pps ppx_sexp_conv)
+    (pps ppx_sexp_conv lwt_ppx)
   )
 )
 
+(test
+  (modes native)
+  (name qcow_mapping_test)
+  (modules qcow_mapping_test)
+  (libraries alcotest qcow_stream)
+  )
+
 (library
   (name qcow)
   (public_name qcow)

lib/qcow_cache.ml

@@ -89,8 +89,11 @@ let write t cluster data =
 
 let remove t cluster =
   if Cluster.Map.mem cluster t.clusters then
-    Printf.fprintf stderr "Dropping cache for cluster %s\n"
-      (Cluster.to_string cluster) ;
+    Log.err (fun f ->
+        f "Dropping cache for cluster %s (length is %d)\n"
+          (Cluster.to_string cluster)
+          (Cluster.Map.cardinal t.clusters)
+    ) ;
   t.clusters <- Cluster.Map.remove cluster t.clusters
 
 let resize t new_size_clusters =

lib/qcow_mapping.ml

@@ -0,0 +1,34 @@
+type t
+
+external create : int64 -> t = "stub_qcow_mapping_create"
+
+external extend : t -> int64 -> unit = "stub_qcow_mapping_extend"
+
+external get : t -> int64 -> int64 = "stub_qcow_mapping_get"
+
+external set : t -> int64 -> int64 -> unit = "stub_qcow_mapping_set"
+
+external length : t -> int64 = "stub_qcow_mapping_length"
+
+external get_sparse_interval_stub :
+  t -> int64 -> int64 -> (int64 * int64 * int64) option
+  = "stub_qcow_mapping_get_sparse_interval"
+
+let get_sparse_interval t ~index ~cluster_bits =
+  get_sparse_interval_stub t index cluster_bits
+
+let to_interval_seq arr cluster_bits =
+  let rec aux arr length index () =
+    if index = length then
+      Seq.Nil
+    else
+      match get_sparse_interval arr ~index ~cluster_bits with
+      | None ->
+          Seq.Nil
+      | Some (right_index, left_cluster, right_cluster) ->
+          Seq.Cons
+            ( (left_cluster, right_cluster)
+            , aux arr length (Int64.succ right_index)
+            )
+  in
+  aux arr (length arr) 0L

lib/qcow_mapping.mli

@@ -0,0 +1,23 @@
+type t
+
+val create : int64 -> t
+
+val extend : t -> int64 -> unit
+
+val get : t -> int64 -> int64
+
+val set : t -> int64 -> int64 -> unit
+
+val length : t -> int64
+
+(** [to_interval_seq t cluster_bits] returns a sequence of allocated virtual
+    data cluster intervals, intended to be used with sparse disks.
+
+    Thus, for a physical image represented by an array of physical clusters
+    and their corresponding virtual clusters:
+        [-1; 1; 2; 3; 7; -1; 4]
+
+    [to_interval_seq] will return:
+        (1,3); (7,7); (4,4)
+    *)
+val to_interval_seq : t -> int64 -> (int64 * int64) Seq.t

lib/qcow_mapping_stubs.c

@@ -0,0 +1,177 @@
+#include <stdint.h>
+#include <string.h>
+#include <errno.h>
+
+#define CAML_NAME_SPACE
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/threads.h>
+#include <caml/fail.h>
+#include <caml/custom.h>
+
+typedef struct array {
+    uint64_t length;
+    int64_t* a;
+} array;
+
+static inline array *
+qcow_mapping_arr_of_val (value v)
+{
+    array *arr = *(array **) Data_custom_val(v);
+
+    return arr;
+}
+
+static void
+qcow_mapping_finalize (value v)
+{
+    array *arr = qcow_mapping_arr_of_val (v);
+    free(arr->a);
+    free(arr);
+}
+
+static struct custom_operations qcow_mapping_ops = {
+    .identifier = "qcow_mapping_array",
+    .finalize = qcow_mapping_finalize,
+    .compare = custom_compare_default,      /* Can't compare     */
+    .hash = custom_hash_default,    /* Can't hash        */
+    .serialize = custom_serialize_default,  /* Can't serialize   */
+    .deserialize = custom_deserialize_default,      /* Can't deserialize */
+    .compare_ext = custom_compare_ext_default,      /* Can't compare     */
+};
+
+#define Arr_val(v) (*((array **) Data_custom_val(v)))
+
+CAMLprim value
+stub_qcow_mapping_create (value length_val)
+{
+    CAMLparam1(length_val);
+    CAMLlocal1(result);
+    array *arr = malloc(sizeof *arr);
+
+    arr->length = Int64_val(length_val);
+    result = caml_alloc_custom(&qcow_mapping_ops, sizeof(array *), 0, 1);
+
+    caml_release_runtime_system();
+    arr->a = malloc(sizeof(uint64_t) * arr->length);
+    caml_acquire_runtime_system();
+
+    if (!arr->a)
+        caml_failwith(strerror(errno));
+
+    caml_release_runtime_system();
+    // Initialize to -1, otherwise there's no way to distinguish data clusters
+    // from table clusters and empty clusters
+    for (size_t i = 0; i < arr->length; i++) {
+        arr->a[i] = -1;
+    }
+    caml_acquire_runtime_system();
+
+    Arr_val(result) = arr;
+
+    CAMLreturn(result);
+}
+
+CAMLprim value
+stub_qcow_mapping_extend (value t_val, value length_val)
+{
+    CAMLparam2(t_val, length_val);
+    CAMLlocal1(result);
+    array* arr = qcow_mapping_arr_of_val(t_val);
+
+    uint64_t new_length = Int64_val(length_val);
+
+    caml_release_runtime_system();
+    arr->a = realloc(arr->a, sizeof(uint64_t) * new_length);
+    caml_acquire_runtime_system();
+
+    if (!arr->a)
+        caml_failwith(strerror(errno));
+
+    caml_release_runtime_system();
+    // Initialize the newly allocated cells to -1, otherwise there's no way
+    // to distinguish data clusters from table clusters and empty clusters
+    for (size_t i = arr->length; i < new_length; i++) {
+        arr->a[i] = -1;
+    }
+    arr->length = new_length;
+    caml_acquire_runtime_system();
+
+    CAMLreturn(Val_unit);
+}
+
+CAMLprim value
+stub_qcow_mapping_get (value t_val, value index_val)
+{
+    CAMLparam2(t_val, index_val);
+    CAMLlocal1(result);
+    array* arr = qcow_mapping_arr_of_val(t_val);
+
+    uint64_t index = Int64_val(index_val);
+    result = caml_copy_int64(arr->a[index]);
+
+    CAMLreturn(result);
+}
+
+CAMLprim value
+stub_qcow_mapping_set (value t_val, value index_val, value new_val)
+{
+    CAMLparam3(t_val, index_val, new_val);
+    array* arr = qcow_mapping_arr_of_val(t_val);
+
+    uint64_t index = Int64_val(index_val);
+    int64_t new = Int64_val(new_val);
+    arr->a[index] = new;
+
+    CAMLreturn(Val_unit);
+}
+
+CAMLprim value
+stub_qcow_mapping_length (value t_val)
+{
+    CAMLparam1(t_val);
+    CAMLlocal1(result);
+
+    array *arr = qcow_mapping_arr_of_val(t_val);
+    result = caml_copy_int64(arr->length);
+
+    CAMLreturn(result);
+}
+
+
+CAMLprim value
+stub_qcow_mapping_get_sparse_interval (value t_val, value index_val, value cluster_bits_val)
+{
+    CAMLparam3(t_val, index_val, cluster_bits_val);
+    CAMLlocal1(result);
+    result = caml_alloc_tuple(3);
+
+    array* arr = qcow_mapping_arr_of_val(t_val);
+
+    uint64_t cluster_bits = Int64_val(cluster_bits_val);
+    uint64_t diff_bw_next_clusters = 1 << cluster_bits;
+    uint64_t left_index = Int64_val(index_val);
+    uint64_t right_index = left_index;
+
+    // Find the longest interval of subsequent allocated data clusters
+    // (data clusters are subsequent if they're located right next to each
+    // other on the virtual disk), return the index to be used in the next
+    // search iteration and the [interval_start, interval_end] pair of virtual
+    // clusters (both inclusive)
+    for (size_t i = left_index+1; i < arr->length; i++, right_index++) {
+        if (arr->a[i-1] == -1) {
+            if (arr->a[i] == -1 && i == (arr->length-1)) {
+                CAMLreturn(Val_none);
+            }
+            left_index++;
+        } else if (arr->a[i-1] + diff_bw_next_clusters != arr->a[i]) {
+            break;
+        }
+    }
+
+    Store_field(result, 0, caml_copy_int64(right_index));
+    Store_field(result, 1, caml_copy_int64((arr->a[left_index]) >> cluster_bits));
+    Store_field(result, 2, caml_copy_int64((arr->a[right_index]) >> cluster_bits));
+
+    CAMLreturn(caml_alloc_some(result));
+}

lib/qcow_mapping_test.ml

@@ -0,0 +1,80 @@
+module Arr = Qcow_mapping
+
+let ( ++ ) = Int64.add
+
+let basic_test () =
+  let arr = Arr.create 16L in
+
+  Alcotest.(check' int64)
+    ~msg:"wrong length" ~actual:(Arr.length arr) ~expected:16L ;
+
+  for i = 0 to Int64.to_int (Arr.length arr) - 1 do
+    let i = Int64.of_int i in
+    Arr.set arr i i
+  done ;
+  for i = 0 to Int64.to_int (Arr.length arr) - 1 do
+    let i = Int64.of_int i in
+    let v = Arr.get arr i in
+    Alcotest.(check' int64) ~msg:"wrong value" ~actual:v ~expected:i
+  done ;
+
+  Arr.extend arr 32L ;
+  Alcotest.(check' int64)
+    ~msg:"wrong length after .extend" ~actual:(Arr.length arr) ~expected:32L ;
+
+  (* Check values were copied properly *)
+  for i = 0 to 15 do
+    let i = Int64.of_int i in
+    let v = Arr.get arr i in
+    Alcotest.(check' int64)
+      ~msg:"wrong value after .extend" ~actual:v ~expected:i
+  done ;
+
+  for i = 0 to Int64.to_int (Arr.length arr) - 1 do
+    let i = Int64.of_int i in
+    Arr.set arr i (i ++ 1L)
+  done ;
+  for i = 0 to Int64.to_int (Arr.length arr) - 1 do
+    let i = Int64.of_int i in
+    let v = Arr.get arr i in
+    Alcotest.(check' int64) ~msg:"wrong value" ~actual:v ~expected:(i ++ 1L)
+  done ;
+
+  ()
+
+let interval_test () =
+  (* Set a few of the cells, representing a sparse disk *)
+  let arr = Arr.create 16L in
+  for i = 2 to 4 do
+    let i = Int64.of_int i in
+    Arr.set arr i i
+  done ;
+
+  (* Non-subsequent clusters next to each other *)
+  Arr.set arr 6L 0L ;
+  Arr.set arr 7L 6L ;
+  Arr.set arr 8L 8L ;
+
+  for i = 10 to 13 do
+    let i = Int64.of_int i in
+    Arr.set arr i i
+  done ;
+
+  (* Verify only the intervals filled with subsequent clusters
+     are reported as populated *)
+  let l = Arr.to_interval_seq arr 0L |> List.of_seq in
+  Alcotest.(check' @@ list @@ pair int64 int64)
+    ~msg:"wrong interval" ~actual:l
+    ~expected:[(2L, 4L); (0L, 0L); (6L, 6L); (8L, 8L); (10L, 13L)] ;
+  ()
+
+let () =
+  Alcotest.run "Test qcow_mapping library"
+    [
+      ( "Basic tests"
+      , [
+          ("basic_test", `Quick, basic_test)
+        ; ("interval_test", `Quick, interval_test)
+        ]
+      )
+    ]