diff --git a/CHANGES.md b/CHANGES.md
index 7793da0666..c354fcf813 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -7,6 +7,10 @@ Tue Jun 23 12:15:42 CEST 2026
     - Fix signature-help with type aliases (#2067, fixes #1927)
     - Fix locate on punned let bindings, to use the common identifier as the
       expression (instead of the pattern) (#2066)
+  + index format
+    - Use a LRU to reduce memory usage when indexing. Change the way small
+      values are stored. Make sub-indexes paths relative to the working
+      directory of the indexer. (#2079)
   + test suite
     - Remove the FIXME line for #1404 as the issue was already fixed and add two tests (#2073).
 
diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 6d6a05e192..55da99643c 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -224,25 +224,26 @@ let get_external_locs ~(config : Mconfig.t) ~current_buffer_path uid :
 let lookup_related_uids_in_indexes ~(config : Mconfig.t) uid =
   let title = "lookup_related_uids_in_indexes" in
   let open Index_format in
-  let related_uids =
-    List.fold_left ~init:(Uid_map.empty ()) config.merlin.index_files
-      ~f:(fun acc index_file ->
+  let store, related_uids =
+    List.fold_left
+      ~init:(Uid_map.empty (), Uid_map.empty ())
+      config.merlin.index_files
+      ~f:(fun (store, acc) index_file ->
         try
           let index = Index_cache.read index_file in
-          Uid_map.union
-            (fun _ a b -> Some (Union_find.union a b))
-            index.related_uids acc
+          Union_find.merge_union store index.related_uids
+            index.related_uids_store acc
         with
         | Index_format.Not_an_index _
         | Sys_error _
         | Granular_marshal.Outdated_store _
         ->
           log ~title "Could not load index %s" index_file;
-          acc)
+          (store, acc))
   in
   Uid_map.find_opt uid related_uids
   |> Option.value_map ~default:[] ~f:(fun x ->
-      x |> Union_find.get |> Uid_set.to_list)
+      x |> Union_find.get store |> Uid_set.elements)
 
 let find_linked_uids ~config ~scope ~name uid =
   let title = "find_linked_uids" in
diff --git a/src/index-format/dbllist.ml b/src/index-format/dbllist.ml
new file mode 100644
index 0000000000..afbc44b153
--- /dev/null
+++ b/src/index-format/dbllist.ml
@@ -0,0 +1,145 @@
+type 'a cell =
+  { content : 'a; weight : int; mutable prev : 'a cell; mutable next : 'a cell }
+
+type stats =
+  { mutable total_cap : int;
+    mutable promote_count : int;
+    mutable add_count : int;
+    mutable discard_count : int;
+    mutable add_size : int;
+    mutable discarded_size : int
+  }
+
+type 'a dbll =
+  | Nil of int
+  | List of { first : 'a cell; last : 'a cell; size : int; cap : int }
+
+type 'a t = { mutable dbll : 'a dbll; stats : stats }
+
+exception Action_on_empty_list of string
+
+let pp_stats t =
+  let size =
+    match t.dbll with
+    | Nil _ -> 0
+    | List l -> l.size
+  in
+  Printf.eprintf
+    "total_cap \t\t: %d\n\
+     size \t\t: %d\n\
+     promote_count \t: %d\n\
+     add_count \t\t: %d\n\
+     discard_count \t: %d\n\
+     add_size \t\t: %d\n\
+     discard_size \t: %d\n\
+     volume_conservation \t: %d = %d + %d : %b\n\
+     %!"
+    t.stats.total_cap size t.stats.promote_count t.stats.add_count
+    t.stats.discard_count t.stats.add_size t.stats.discarded_size
+    t.stats.add_size t.stats.discarded_size size
+    (t.stats.add_size = t.stats.discarded_size + size)
+
+let create cap =
+  let stats =
+    { total_cap = cap;
+      promote_count = 0;
+      add_count = 0;
+      discard_count = 0;
+      add_size = 0;
+      discarded_size = 0
+    }
+  in
+  { dbll = Nil cap; stats }
+
+let add_front t (v, w) =
+  t.stats.add_count <- t.stats.add_count + 1;
+  t.stats.add_size <- t.stats.add_size + w;
+  match t.dbll with
+  | Nil cap ->
+    let rec c = { content = v; weight = w; prev = c; next = c } in
+    t.dbll <- List { first = c; last = c; size = w; cap };
+    c
+  | List l ->
+    let rec new_first =
+      { content = v; weight = w; prev = new_first; next = l.first }
+    in
+    l.first.prev <- new_first;
+    t.dbll <-
+      List { first = new_first; last = l.last; size = l.size + w; cap = l.cap };
+    new_first
+
+let discard t =
+  t.stats.discard_count <- t.stats.discard_count + 1;
+  match t.dbll with
+  | Nil _ ->
+    raise
+      (Action_on_empty_list
+         "Unable to discard the last element, the doubly linked list is empty.")
+  | List l ->
+    if l.first == l.last then (
+      t.dbll <- Nil l.cap;
+      t.stats.discarded_size <- t.stats.discarded_size + l.last.weight;
+      l.last.content)
+    else
+      let discarded_value = l.last.content in
+      let discarded_weight = l.last.weight in
+      t.stats.discarded_size <- t.stats.discarded_size + discarded_weight;
+      let new_last = l.last.prev in
+      (* TODO Should we explicitely disconnect last's pointers ? *)
+      new_last.next <- new_last;
+      (* TODO Int.max 0 (l.size - discarded_weight) does seems useless.
+         We could use an assert to check it. *)
+      (* Unlinking the discaded cell is not strictly necessary but not doing it
+         could lead to memory leaks if the user of the cache keeps a reference
+         to the cell. *)
+      l.last.next <- l.last;
+      l.last.prev <- l.last;
+      t.dbll <-
+        List
+          { first = l.first;
+            last = new_last;
+            size = Int.max 0 (l.size - discarded_weight);
+            cap = l.cap
+          };
+      discarded_value
+
+let discard_size t s =
+  (* this is fold not iter *)
+  let rec iter acc t =
+    match t.dbll with
+    | Nil _ -> acc
+    | List l -> if l.size + s <= l.cap then acc else iter (discard t :: acc) t
+  in
+  iter [] t
+
+let promote t c =
+  t.stats.promote_count <- t.stats.promote_count + 1;
+  match t.dbll with
+  | Nil _ ->
+    raise
+      (Action_on_empty_list
+         "Unable to promote a cell, the doubly linked list is empty.")
+  | List l ->
+    if l.first == c then ()
+    else if l.last == c then (
+      let new_last = l.last.prev in
+      new_last.next <- new_last;
+      let new_first = c in
+      new_first.next <- l.first;
+      new_first.prev <- new_first;
+      l.first.prev <- new_first;
+      t.dbll <-
+        List { first = new_first; last = new_last; size = l.size; cap = l.cap })
+    else
+      let voisin_prev = c.prev in
+      let voisin_next = c.next in
+      voisin_prev.next <- voisin_next;
+      voisin_next.prev <- voisin_prev;
+      let new_first = c in
+      new_first.prev <- new_first;
+      new_first.next <- l.first;
+      l.first.prev <- new_first;
+      t.dbll <-
+        List { first = new_first; last = l.last; size = l.size; cap = l.cap }
+
+let get c = c.content
diff --git a/src/index-format/dbllist.mli b/src/index-format/dbllist.mli
new file mode 100644
index 0000000000..446a5893b2
--- /dev/null
+++ b/src/index-format/dbllist.mli
@@ -0,0 +1,26 @@
+type 'a cell =
+  { content : 'a; weight : int; mutable prev : 'a cell; mutable next : 'a cell }
+
+type stats =
+  { mutable total_cap : int;
+    mutable promote_count : int;
+    mutable add_count : int;
+    mutable discard_count : int;
+    mutable add_size : int;
+    mutable discarded_size : int
+  }
+
+type 'a dbll =
+  | Nil of int
+  | List of { first : 'a cell; last : 'a cell; size : int; cap : int }
+
+type 'a t = { mutable dbll : 'a dbll; stats : stats }
+
+exception Action_on_empty_list of string
+
+val pp_stats : 'a t -> unit
+val create : int -> 'a t
+val add_front : 'a t -> 'a * int -> 'a cell
+val discard_size : 'a t -> int -> 'a list
+val promote : 'a t -> 'a cell -> unit
+val get : 'a cell -> 'a
diff --git a/src/index-format/dune b/src/index-format/dune
index 7cdf97ffd4..8afe8e3b81 100644
--- a/src/index-format/dune
+++ b/src/index-format/dune
@@ -7,4 +7,4 @@
   -open Ocaml_typing
   -open Ocaml_utils
   -open Merlin_utils)
- (libraries ocaml_parsing ocaml_typing ocaml_utils merlin_utils))
+ (libraries unix ocaml_parsing ocaml_typing ocaml_utils merlin_utils))
diff --git a/src/index-format/granular_map.ml b/src/index-format/granular_map.ml
index b09d9b0081..69e9c0277d 100644
--- a/src/index-format/granular_map.ml
+++ b/src/index-format/granular_map.ml
@@ -31,6 +31,7 @@ module type S = sig
   val choose_opt : 'a t -> (key * 'a) option
   val iter : (key -> 'a -> unit) -> 'a t -> unit
   val iter_in_memory : (key -> 'a -> unit) -> 'a t -> unit
+
   val fold : (key -> 'a -> 'acc -> 'acc) -> 'a t -> 'acc -> 'acc
   val map : ('a -> 'b) -> 'a t -> 'b t
   val is_empty : 'a t -> bool
diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml
index a401da062b..aa1bffe1f4 100644
--- a/src/index-format/granular_marshal.ml
+++ b/src/index-format/granular_marshal.ml
@@ -4,43 +4,142 @@ type store = { filename : string; id : int; cache : cache }
 
 and cache = any_link Cache.t
 
-and any_link = Link : 'a link * 'a link Type.Id.t -> any_link
+and any_link = Link : 'a link * 'a link Type.Id.t option -> any_link
+
+and parent_link = PLink : 'a link -> parent_link
+and any_value =
+  | Value : 'a * 'a link Type.Id.t -> any_value
+  | Unknown : 'a -> any_value
+      (** Marks a small that has not been cleaned yet. Usually because its
+          schema was unknown when it was read from the disk. *)
+and any_val = V : 'a -> any_val
+and any_val_link = Vlink : 'a * 'a link -> any_val_link
+
+and cached = Cached : 'a link -> cached
 
 and 'a link = 'a repr ref
 
+(** Links descriptions.
+  There are two different realms: on disk and in memory.
+  Things such as On_disk cannot live on disk since the contain a function, schema.
+  _ Type.Id.t cannot survive to marshalling either.
+
+  We call "cleaning a value" the process of translates links from the Disk Realm
+  to the Memory Realm.
+
+  A lot of the complexity stems from the "small values" optimization. It can be
+  seen as an inlining of small-enough values with their parent value. This is
+  important both for speed and file size. It removes the overhead of having many
+  links which is not worth for small values.
+
+  When reading a small value, its parent value might have an unknown schema,
+  resulting in a dirty cache entry. This is marked by [Dirty_unknown_schema].
+  Silimarly, small values are dirty until they are explicitely needed, and thus
+  their schema known.
+*)
 and 'a repr =
-  | Small of 'a
+  (*
+   * On-disk realm
+   *)
   | Serialized of { loc : int }
-  | Serialized_reused of { loc : int }
-  | On_disk of { store : store; loc : int; schema : 'a schema }
+      (** {i on-disk} A pointer to a serialized value in the file. *)
+  | Small of int
+      (** {i on-disk} A "small value" placeholder. Contains the index of this
+          small's actual value in the array stored by its parent value. *)
+  | Serialized_small of { loc : int; pos : int }
+      (** {i on-disk} A pointer to an already serialized small value. *)
   | On_disk_ptr of { filename : string; loc : int; id : int }
+      (** {i on-disk} A pointer to a serialized value in another file. The
+          optional `pos` field is used to target small values. *)
+  | On_disk_small_ptr of { filename : string; loc : int; id : int; pos : int }
+  (*
+   * In-memory realm
+   *)
+  | On_disk of { store : store; loc : int; schema : 'a schema option }
+      (** {i in-memory} A value that can be read from the disk. *)
+  | On_disk_small of
+      { parent : parent_link; (* Either the parent or an On_disk_ptr *)
+        small_type_id : 'a link Type.Id.t;
+        small_pos : int;
+        small_schema : 'a schema
+      }
+      (** {i in-memory} A small value whose parent can be read from the disk. *)
   | In_memory of 'a
+      (** {i in-memory} A value that has been created in memory. *)
   | In_memory_reused of 'a
+      (** {i in-memory} A value that has been created in memory and is used
+          multiple times. *)
+  | In_cache of
+      { value : 'a;
+        store : store;
+        loc : int;
+        mutable schema : 'a schema option;
+        cell : cached Dbllist.cell;
+        small_values : any_value array
+      }
+      (** {i in-memory} A value and its small that has been already read from
+          the disk. Both the values and the smalls might be "unclean". They will
+          be promoted to clean if read with their expected schema. *)
   | Duplicate of 'a link
-  | Placeholder
 
 and 'a schema = iter -> 'a -> unit
 
 and iter = { yield : 'a. 'a link -> 'a link Type.Id.t -> 'a schema -> unit }
 
+let string_of_link : type a. a link -> string =
+ fun link ->
+  match !link with
+  | Small _ -> Printf.sprintf "Small"
+  | Serialized { loc } -> Printf.sprintf "Serialized(loc=%d)" loc
+  | On_disk { loc; _ } -> Printf.sprintf "On_disk(loc=%d)" loc
+  | On_disk_small { small_pos; _ } ->
+    Printf.sprintf "On_disk_small(small_pos=%d)" small_pos
+  | Serialized_small { loc; pos } ->
+    Printf.sprintf "Serialized_small(loc=%d;small_pos=%d)" loc pos
+  | On_disk_ptr { loc; _ } -> Printf.sprintf "On_disk_ptr(loc=%d)" loc
+  | On_disk_small_ptr { loc; pos; _ } ->
+    Printf.sprintf "On_disk_ptr(loc=%d, pos=%d)" loc pos
+  | In_memory _ -> "In_memory"
+  | In_cache { schema; loc; _ } ->
+    let clean_dirty =
+      match schema with
+      | Some _ -> "Clean"
+      | None -> "Dirty"
+    in
+    Printf.sprintf "In_cache(%s; loc=%i)" clean_dirty loc
+  | In_memory_reused _ -> "In_memory_reused"
+  | Duplicate _ -> "Duplicate"
+
 exception
   Outdated_store of
     { filename : string; reason : [ `Missing_file | `Index_ids_do_not_match ] }
 
+let lru_dbllist : cached Dbllist.t option ref = ref None
+let lru_size = ref 1_000_000
+let set_lru_size i = lru_size := i
+
+let get_lru () =
+  match !lru_dbllist with
+  | Some lru -> lru
+  | None ->
+    let lru = Dbllist.create !lru_size in
+    lru_dbllist := Some lru;
+    lru
+
 let schema_no_sublinks : _ schema = fun _ _ -> ()
 
 let link v = ref (In_memory v)
 
-let is_on_disk lnk =
-  match !lnk with
-  | On_disk _ | On_disk_ptr _ -> true
-  | _ -> false
-
 let rec normalize lnk =
   match !lnk with
   | Duplicate lnk -> normalize lnk
   | _ -> lnk
 
+let is_on_disk lnk =
+  match !(normalize lnk) with
+  | On_disk _ | On_disk_ptr _ | On_disk_small _ | In_cache _ -> true
+  | _ -> false
+
 module Cache_cache = File_cache.Make (struct
   type t = cache
   let read _filename = Cache.create 0
@@ -61,12 +160,6 @@ let int_of_binstring s =
 
 let last_open_store = ref None
 
-let () =
-  at_exit (fun () ->
-      match !last_open_store with
-      | None -> ()
-      | Some (_, fd) -> close_in fd)
-
 let force_open_store store =
   try
     let fd = open_in_bin store.filename in
@@ -92,137 +185,387 @@ let open_store store =
     force_open_store store
   | None -> force_open_store store
 
-let read_loc store fd loc schema =
+let resolve_filename store ~filename =
+  if Filename.is_relative filename then
+    Filename.concat (Filename.dirname store.filename) filename
+  else filename
+
+(** This iterator translates links from the Disk Realm to the Memory Realm.
+    This is the process we refer too as "cleaning a value". *)
+let rec disk_to_memory_iter store parent_link =
+  { yield =
+      (fun (type a)
+        (lnk : a link)
+        (type_id : a link Type.Id.t)
+        (schema : a schema)
+      ->
+        match !lnk with
+        | Small pos ->
+          lnk :=
+            On_disk_small
+              { parent = parent_link;
+                small_pos = pos;
+                small_type_id = type_id;
+                small_schema = schema
+              }
+        | Serialized_small { loc; pos } ->
+          let parent =
+            match Cache.find_opt store.cache loc with
+            | Some (Link (lnk, _)) -> PLink (normalize lnk)
+            | None ->
+              let lnk = ref (On_disk { store; loc; schema = None }) in
+              Cache.add store.cache loc (Link (lnk, None));
+              PLink lnk
+          in
+          lnk :=
+            On_disk_small
+              { parent;
+                small_type_id = type_id;
+                small_schema = schema;
+                small_pos = pos
+              }
+        | Serialized { loc } ->
+          maybe_reuse_or_upgrade lnk store loc type_id schema
+        | On_disk_ptr { filename; loc; id } ->
+          let filename = resolve_filename store ~filename in
+          let store = { filename; id; cache = Cache_cache.read filename } in
+          maybe_reuse_or_upgrade lnk store loc type_id schema
+        | On_disk_small_ptr { filename; loc; id; pos = small_pos } ->
+          let filename = resolve_filename store ~filename in
+          let store = { filename; id; cache = Cache_cache.read filename } in
+          let parent =
+            match Cache.find_opt store.cache loc with
+            | Some (Link (lnk, _)) -> PLink (normalize lnk)
+            | None ->
+              let lnk = ref (On_disk { store; loc; schema = None }) in
+              Cache.add store.cache loc (Link (lnk, None));
+              PLink lnk
+          in
+          lnk :=
+            On_disk_small
+              { parent;
+                small_type_id = type_id;
+                small_schema = schema;
+                small_pos
+              }
+        | In_memory _
+        | In_cache _
+        | In_memory_reused _
+        | On_disk_small _
+        | On_disk _
+        | Duplicate _ -> (* These are already "clean" *) ())
+  }
+
+(* Checks if a loc has already been read, clean it if it was read without
+   schema, or store it in the cache if it was never read.*)
+and maybe_reuse_or_upgrade : type a.
+    a link -> store -> int -> a link Type.Id.t -> a schema -> unit =
+ fun lnk store loc type_id schema ->
+  match Cache.find_opt store.cache loc with
+  | Some (Link (type b) ((lnk', Some type_id') : b link * _)) -> (
+    match Type.Id.provably_equal type_id type_id' with
+    | Some (Equal : (a link, b link) Type.eq) ->
+      lnk := Duplicate (normalize lnk')
+    | None -> invalid_arg "Granular_marshal.read_loc: reuse of a different type"
+    )
+  | Some (Link (lnk', None)) ->
+    let lnk' = Obj.magic lnk' in
+    upgrade_reused_link_schema lnk' store schema;
+    Cache.replace store.cache loc (Link (lnk', Some type_id));
+    lnk := Duplicate (normalize lnk')
+  | None ->
+    lnk := On_disk { store; loc; schema = Some schema };
+    Cache.add store.cache loc (Link (lnk, Some type_id))
+
+(* Sometimes we reuse a parent whose schema was unknown so far.
+   This function updates this parent's schema. *)
+and upgrade_reused_link_schema : type a. a link -> store -> a schema -> unit =
+ fun lnk store schema ->
+  match !lnk with
+  | On_disk { store; loc; schema = None; _ } ->
+    (* This case only happens if the previous read was an
+                    [On_disc_ptr { pos = Some_; _}] with a parent of unknown
+                    schema. *)
+    lnk := On_disk { store; loc; schema = Some schema }
+  | In_cache ({ value; schema = None; _ } as c) ->
+    (* If we already have the value in cache we must clean it. *)
+    schema (disk_to_memory_iter store (PLink lnk)) value;
+    c.schema <- Some schema
+  | Small _
+  | Serialized _
+  | Serialized_small _
+  | On_disk _
+  | On_disk_small _
+  | On_disk_ptr _
+  | On_disk_small_ptr _
+  | In_memory _
+  | In_cache _
+  | In_memory_reused _
+  | Duplicate _ -> assert false
+
+let add_to_cache value lnk ~loc store ~size small_values schema =
+  let discarded = Dbllist.discard_size (get_lru ()) size in
+  let cell = Dbllist.add_front (get_lru ()) (Cached lnk, size) in
+  List.iter
+    (fun (Cached link) ->
+      (* This also free the smalls that are stored in the link *)
+      match !link with
+      | In_cache { loc; store; schema; _ } ->
+        link := On_disk { store; loc; schema }
+      | _ -> assert false)
+    discarded;
+  lnk := In_cache { value; loc; store; schema; cell; small_values }
+
+(** Read one value and its smalls from the disk.  *)
+let read_loc_dirty fd loc =
   seek_in fd loc;
-  let v = Marshal.from_channel fd in
-  let rec iter =
-    { yield =
-        (fun (type a) (lnk : a link) type_id schema ->
-          match !lnk with
-          | Small v ->
-            schema iter v;
-            lnk := In_memory v
-          | Serialized { loc } -> lnk := On_disk { store; loc; schema }
-          | Serialized_reused { loc } -> (
-            match Cache.find store.cache loc with
-            | Link (type b) ((lnk', type_id') : b link * _) -> (
-              match Type.Id.provably_equal type_id type_id' with
-              | Some (Equal : (a link, b link) Type.eq) ->
-                lnk := Duplicate (normalize lnk')
-              | None ->
-                invalid_arg
-                  "Granular_marshal.read_loc: reuse of a different type")
-            | exception Not_found ->
-              lnk := On_disk { store; loc; schema };
-              Cache.add store.cache loc (Link (lnk, type_id)))
-          | In_memory _ | In_memory_reused _ | On_disk _ | Duplicate _ -> ()
-          | On_disk_ptr { filename; loc; id } ->
-            let store = { filename; id; cache = Cache_cache.read filename } in
-            lnk := On_disk { store; loc; schema }
-          | Placeholder -> invalid_arg "Granular_marshal.read_loc: Placeholder")
-    }
-  in
+  let v, small_children = Marshal.from_channel fd in
+  let size_read = pos_in fd - loc in
+  let small_children = Array.map (fun (V v) -> Unknown v) small_children in
+  (v, size_read, small_children)
+
+(** Read one value and its smalls from the disk. Clean it. The smalls are not
+    cleaned yet because their schema is unknown at that point.  *)
+let read_loc store fd loc schema parent_link =
+  let v, size_read, small_children = read_loc_dirty fd loc in
+  let iter = disk_to_memory_iter store parent_link in
   schema iter v;
-  v
+  (v, size_read, small_children)
+
+(** Reads a value with its smalls, clean it and add it to the cache *)
+let fetch_on_disk lnk store loc schema =
+  let fd = open_store store in
+  let parent_link = PLink lnk in
+  let v, size, small_values = read_loc store fd loc schema parent_link in
+  add_to_cache v lnk ~loc store ~size small_values (Some schema);
+  (v, small_values)
 
-let fetch_loc store loc schema =
+let fetch_on_disk_dirty lnk store loc =
   let fd = open_store store in
-  let v = read_loc store fd loc schema in
-  v
+  let v, size, small_children = read_loc_dirty fd loc in
+  add_to_cache v lnk ~loc store ~size small_children None;
+  small_children
 
-let rec fetch lnk =
+(* Smalls are stored along their parents so they share the same loc *)
+let store_and_loc_of_parent (PLink lnk : parent_link) =
   match !lnk with
-  | In_memory v | In_memory_reused v -> v
-  | Serialized _ | Serialized_reused _ | Small _ | On_disk_ptr _ ->
-    invalid_arg "Granular_marshal.fetch: serialized"
-  | Placeholder -> invalid_arg "Granular_marshal.fetch: during a write"
-  | Duplicate original_lnk ->
-    let v = fetch original_lnk in
-    lnk := In_memory v;
-    v
-  | On_disk { store; loc; schema } ->
-    let v = fetch_loc store loc schema in
-    lnk := In_memory v;
-    v
-
-let reuse lnk =
+  | In_cache { store; loc; _ } | On_disk { store; loc; _ } -> (store, loc)
+  | _ ->
+    invalid_arg
+      ("Granular_marshal.fetch_parent: Unexpected parent link "
+     ^ string_of_link lnk)
+
+(** Fetch the parent of a small value in order to read its smalls. If the parent
+  has not yet been loaded in memory it will be read from the disk and kept dirty
+  because its schema is unknown.*)
+let fetch_parent_smalls : parent_link -> any_value array * store =
+ fun (PLink parent_link) ->
+  match !parent_link with
+  | In_cache { store; cell; small_values; _ } ->
+    Dbllist.promote (get_lru ()) cell;
+    (small_values, store)
+  | On_disk { store; loc; schema = None } ->
+    (fetch_on_disk_dirty parent_link store loc, store)
+  | On_disk { store; loc; schema = Some schema } ->
+    (snd (fetch_on_disk parent_link store loc schema), store)
+  | _ ->
+    invalid_arg
+      ("Granular_marshal.fetch_parent: Unexpected parent link "
+     ^ string_of_link parent_link)
+
+let rec fetch : type a. a link -> a =
+ fun lnk ->
   match !lnk with
-  | In_memory v -> lnk := In_memory_reused v
+  | In_cache { value; schema = Some _; cell; _ } ->
+    Dbllist.promote (get_lru ()) cell;
+    value
+  | In_cache { schema = None; _ } ->
+    invalid_arg "Granular_marshal.fetch: accessing dirty cached value"
+  | Duplicate original_lnk -> fetch original_lnk
+  | On_disk { store; loc; schema = Some schema } ->
+    fst (fetch_on_disk lnk store loc schema)
+  | On_disk_small { parent; small_pos; small_type_id; small_schema } -> (
+    let smalls, store = fetch_parent_smalls parent in
+    match smalls.(small_pos) with
+    | Value (type b) ((v, type_id') : b * _) -> (
+      match Type.Id.provably_equal small_type_id type_id' with
+      | None -> invalid_arg "Granular_marshal.read_loc: small has wrong type"
+      | Some (Equal : (a link, b link) Type.eq) -> v)
+    | Unknown v ->
+      let v = Obj.magic v in
+      small_schema (disk_to_memory_iter store parent) v;
+      smalls.(small_pos) <- Value (v, small_type_id);
+      v)
+  | In_memory v | In_memory_reused v -> v
+  | Serialized _
+  | Serialized_small _
+  | Small _
+  | On_disk_ptr _
+  | On_disk_small_ptr _
+  | On_disk { schema = None; _ } ->
+    invalid_arg
+      ("Granular_marshal.fetch: accesssing dirty link " ^ string_of_link lnk)
+
+let rec reuse original_lnk =
+  match !original_lnk with
+  | In_memory v -> original_lnk := In_memory_reused v
   | In_memory_reused _ -> ()
-  | _ -> invalid_arg "Granular_marshal.reuse: not in memory"
+  | On_disk _ -> ()
+  | Duplicate link -> reuse link
+  | _ ->
+    invalid_arg
+    @@ Printf.sprintf "Granular_marshal.reuse: not in memory, got %s"
+         (string_of_link original_lnk)
 
 let cache (type a) (module Key : Hashtbl.HashedType with type t = a) =
   let module H = Hashtbl.Make (Key) in
   let cache = H.create 16 in
   fun (lnk : a link) ->
-    let key = fetch lnk in
-    match H.find cache key with
-    | original_lnk ->
-      assert (original_lnk != lnk);
-      reuse original_lnk;
-      lnk := Duplicate original_lnk
-    | exception Not_found -> H.add cache key lnk
-
-let write ?(flags = []) fd ~id root_schema root_value =
-  let id = binstring_of_int id in
-  output_string fd id;
+    if not (is_on_disk lnk) then
+      let key = fetch lnk in
+      match H.find cache key with
+      | original_lnk ->
+        assert (original_lnk != lnk);
+        reuse original_lnk;
+        lnk := Duplicate original_lnk
+      | exception Not_found -> H.add cache key lnk
+
+let relativize ~wrt:path =
+  let path_segments = Misc.split_path path in
+  let rec aux path target =
+    match (path, target) with
+    | p :: tl, t :: tl_target when p = t -> aux tl tl_target
+    | [], target -> target
+    | _ :: _, [] -> List.map (Fun.const "..") path
+    | _ :: _, _ :: _ -> List.map (Fun.const "..") path @ target
+  in
+  fun target ->
+    let target_segments = Misc.split_path target in
+    List.fold_left Filename.concat "" (aux path_segments target_segments)
+
+let write ?(flags = []) fd ~filename ~id root_schema root_value =
+  let relativize =
+    relativize ~wrt:Filename.(dirname (concat (Unix.getcwd ()) filename))
+  in
+  let id' = binstring_of_int id in
+  output_string fd id';
   let pt_root = pos_out fd in
   output_string fd (String.make ptr_size '\000');
-  let rec iter size ~placeholders ~restore =
+  let rec iter size ~small_children =
     { yield =
         (fun (type a) (lnk : a link) _type_id (schema : a schema) : unit ->
           match !lnk with
-          | Serialized _ | Serialized_reused _ | Small _ | On_disk_ptr _ -> ()
-          | Placeholder -> failwith "big nono"
+          | Serialized _
+          | Serialized_small _
+          | Small _
+          | On_disk_ptr _
+          | On_disk_small_ptr _ -> ()
           | In_memory_reused v -> write_child_reused lnk schema v
-          | Duplicate original_lnk ->
-            (match !original_lnk with
-            | Serialized_reused _ -> ()
-            | In_memory_reused v -> write_child_reused original_lnk schema v
-            | _ -> failwith "Granular_marshal.write: duplicate not reused");
-            lnk := !original_lnk
-          | In_memory v -> write_child lnk schema v size ~placeholders ~restore
+          | Duplicate original_lnk -> (
+            match !original_lnk with
+            | Serialized _ | Serialized_small _ | On_disk_ptr _ ->
+              lnk := !original_lnk
+            | In_memory_reused v ->
+              write_child_reused original_lnk schema v;
+              lnk := !original_lnk
+            | On_disk { store = { filename; id; _ }; loc; _ }
+            | In_cache { loc; store = { filename; id; _ }; _ } ->
+              lnk := On_disk_ptr { filename; id; loc }
+            | _ ->
+              failwith
+                (Format.sprintf
+                   "Granular_marshal.write: duplicate not reused got %s"
+                   (string_of_link original_lnk)))
+          | In_memory v -> write_child lnk schema v size ~small_children
+          | In_cache { loc; store = { filename; id; _ }; _ } ->
+            let filename = relativize filename in
+            lnk := On_disk_ptr { filename; id; loc }
           | On_disk { store = { filename; id; _ }; loc; _ } ->
-            lnk := On_disk_ptr { filename; id; loc })
+            (* TODO we could have all the possible filenames wrote once
+               somewhere in the file. *)
+            let filename = relativize filename in
+            lnk := On_disk_ptr { filename; id; loc }
+          | On_disk_small { parent; small_pos; _ } ->
+            let { filename; id; _ }, loc = store_and_loc_of_parent parent in
+            let filename = relativize filename in
+            lnk := On_disk_small_ptr { filename; id; loc; pos = small_pos })
     }
+  and output_and_mark (V v) (small_children : any_val_link list) =
+    let new_smalls =
+      (* Some smalls might have been already serialized by another value *)
+      List.filter
+        (fun (Vlink (_v, lnk)) ->
+          match !lnk with
+          | On_disk_small_ptr _ | Serialized_small _ ->
+            (* This small has already been serialized by another owner *) false
+          | _ -> true)
+        small_children
+    in
+    let smalls =
+      (* We iter on the smalls to set their links with the position in the array and *)
+      List.mapi
+        (fun i (Vlink (v, lnk)) ->
+          lnk := Small i;
+          V v)
+        new_smalls
+      |> Array.of_list
+    in
+    let loc = pos_out fd in
+    Marshal.to_channel fd (v, smalls) flags;
+    (* Now we replace the links by an indirection in case they are reused *)
+    List.iteri
+      (fun i (Vlink (_v, lnk)) -> lnk := Serialized_small { loc; pos = i })
+      new_smalls
   and write_child : type a. a link -> a schema -> a -> _ =
-   fun lnk schema v size ~placeholders ~restore ->
-    let v_size = write_children schema v in
-    if v_size > 1024 then (
+   fun lnk schema v size ~small_children ->
+    let v_size, v_smalls = write_children schema v in
+    if v_size > 4096 then (
       lnk := Serialized { loc = pos_out fd };
-      Marshal.to_channel fd v flags)
+      output_and_mark (V v) v_smalls)
     else (
       size := !size + v_size;
-      placeholders := (fun () -> lnk := Placeholder) :: !placeholders;
-      restore := (fun () -> lnk := Small v) :: !restore)
-  and write_children : type a. a schema -> a -> int =
+      (* We don't care about the order since smalls are numbered right before
+         writing to the disk. *)
+      let smalls = List.rev_append v_smalls !small_children in
+      small_children := Vlink (v, lnk) :: smalls)
+  and write_children : type a. a schema -> a -> _ =
    fun schema v ->
     let children_size = ref 0 in
-    let placeholders = ref [] in
-    let restore = ref [] in
-    schema (iter children_size ~placeholders ~restore) v;
-    List.iter (fun placehold -> placehold ()) !placeholders;
+    let small_children = ref [] in
+    schema (iter children_size ~small_children) v;
     let v_size = Obj.(reachable_words (repr v)) in
-    List.iter (fun restore -> restore ()) !restore;
-    !children_size + v_size
-  and write_child_reused : type a. a link -> a schema -> a -> _ =
+    (!children_size + v_size, !small_children)
+  and write_child_reused : type a. a link -> a schema -> a -> unit =
    fun lnk schema v ->
-    let children_size = ref 0 in
-    let placeholders = ref [] in
-    let restore = ref [] in
-    schema (iter children_size ~placeholders ~restore) v;
-    lnk := Serialized_reused { loc = pos_out fd };
-    Marshal.to_channel fd v flags
+    let _v_size, v_smalls = write_children schema v in
+    lnk := Serialized { loc = pos_out fd };
+    output_and_mark (V v) v_smalls
   in
-  let _ : int = write_children root_schema root_value in
+  let _, root_value_smalls = write_children root_schema root_value in
   let root_loc = pos_out fd in
-  Marshal.to_channel fd root_value flags;
+  output_and_mark (V root_value) root_value_smalls;
   seek_out fd pt_root;
   output_string fd (binstring_of_int root_loc)
 
 let read filename fd root_schema =
   let id = int_of_binstring (really_input_string fd 8) in
+  let filename =
+    if Filename.is_relative filename then
+      Filename.concat (Unix.getcwd ()) filename
+    else filename
+  in
   let store = { filename; id; cache = Cache_cache.read filename } in
   let root_loc = int_of_binstring (really_input_string fd 8) in
-  let root_value = read_loc store fd root_loc root_schema in
+  let parent_link =
+    ref (On_disk { loc = root_loc; store; schema = Some root_schema })
+  in
+  let root_value, _, _ =
+    read_loc store fd root_loc root_schema (PLink parent_link)
+  in
   root_value
+
+let () =
+  at_exit (fun () ->
+      match !last_open_store with
+      | None -> ()
+      | Some (_, fd) -> close_in fd)
diff --git a/src/index-format/granular_marshal.mli b/src/index-format/granular_marshal.mli
index 1a577f3a42..545176073e 100644
--- a/src/index-format/granular_marshal.mli
+++ b/src/index-format/granular_marshal.mli
@@ -1,6 +1,21 @@
+(** Core module for reading and writing granular values.
+
+    Note on file paths: when writing a value that was read from an existing
+    granular file, only a pointer to the original file is present in the new
+    one. This means the original file should not be moved or deleted.
+
+    These pointers are relative to the working directory of the tool that wrote
+    the new file. *)
+
 (** A pointer to an ['a] value, either residing in memory or on disk. *)
 type 'a link
 
+type cached
+
+(* val create_lru : int -> unit *)
+val set_lru_size : int -> unit
+val get_lru : unit -> cached Dbllist.t
+
 (** [link v] returns a new link to the in-memory value [v]. *)
 val link : 'a -> 'a link
 
@@ -61,10 +76,14 @@ exception
   Outdated_store of
     { filename : string; reason : [ `Missing_file | `Index_ids_do_not_match ] }
 
-(** [write oc ~id schema value] writes the [value] in the output channel [oc], creating unmarshalling boundaries on every link in [value] specified by the [schema]. [id] is used as index UID. *)
+(** [write oc ~id schema value] writes the [value] in the output channel [oc],
+    creating unmarshalling boundaries on every link in [value] specified by the
+    [schema]. [id] is used as index UID. File pointers are made relative to the
+    current working directory. *)
 val write :
   ?flags:Marshal.extern_flags list ->
   out_channel ->
+  filename:string ->
   id:int ->
   'a schema ->
   'a ->
@@ -72,5 +91,6 @@ val write :
 
 (** [read ic schema] reads the value marshalled in the input channel [ic],
     stopping the unmarshalling on every link boundary indicated by the [schema].
-    It returns the root [value] read.  *)
+    It returns the root [value] read. File pointers are resolved relatively to
+    the current working directory.  *)
 val read : string -> in_channel -> 'a schema -> 'a
diff --git a/src/index-format/index_format.ml b/src/index-format/index_format.ml
index 3fb57b054b..ba3c49f6fe 100644
--- a/src/index-format/index_format.ml
+++ b/src/index-format/index_format.ml
@@ -2,20 +2,42 @@ exception Not_an_index of string
 
 module Lid = Lid
 module Lid_set = Granular_set.Make (Lid)
-module Uid_map = Granular_map.Make (Shape.Uid)
+module Uid_map = Union_find.Uid_map
 module Stats = Map.Make (String)
-module Uid_set = Shape.Uid.Set
+module Uid_set = Granular_set.Make (Shape.Uid)
 
 module Union_find = struct
-  type t = Uid_set.t Union_find.element Granular_marshal.link
-
-  let make v = Granular_marshal.link (Union_find.make v)
-
-  let get t = Union_find.get (Granular_marshal.fetch t)
-
-  let union a b =
-    Granular_marshal.(
-      link (Union_find.union ~f:Uid_set.union (fetch a) (fetch b)))
+  type t = Uid_set.t Union_find.elt_handle Granular_marshal.link
+  type store = Uid_set.t Union_find.content Uid_map.t
+
+  let empty () = Union_find.empty ()
+
+  let new_root store uid v =
+    let store, root = Union_find.new_root store uid v in
+    (store, Granular_marshal.link root)
+
+  let get store t = Union_find.get store (Granular_marshal.fetch t)
+
+  let union store a b =
+    let open Granular_marshal in
+    let store, _root =
+      Union_find.union store ~f:Uid_set.union (fetch a) (fetch b)
+    in
+    (store, a)
+
+  let merge = Union_find.merge ~f:Uid_set.union
+
+  let merge_union store map store' map' =
+    let store = ref (merge store store') in
+    let map =
+      Uid_map.union
+        (fun _ a b ->
+          let store', v = union !store a b in
+          store := store';
+          Some v)
+        map map'
+    in
+    (!store, map)
 
   let type_id : t Type.Id.t = Type.Id.make ()
 
@@ -38,13 +60,17 @@ type index =
     cu_shape : (string, Shape.t) Hashtbl.t;
     stats : stat Stats.t;
     root_directory : string option;
+    related_uids_store : Union_find.store;
     related_uids : Union_find.t Uid_map.t
   }
 
 let lidset_schema iter lidset = Lid_set.schema iter Lid.schema lidset
+let uidset_schema iter lidset =
+  Uid_set.schema iter Granular_marshal.schema_no_sublinks lidset
 
 let type_setmap : Lid_set.t Uid_map.t Type.Id.t = Type.Id.make ()
 let type_ufmap : Union_find.t Uid_map.t Type.Id.t = Type.Id.make ()
+let type_ufstore : Union_find.store Type.Id.t = Type.Id.make ()
 
 let index_schema (iter : Granular_marshal.iter) index =
   Uid_map.schema type_setmap iter
@@ -55,7 +81,12 @@ let index_schema (iter : Granular_marshal.iter) index =
     index.approximated;
   Uid_map.schema type_ufmap iter
     (fun iter _ v -> Union_find.schema iter v)
-    index.related_uids
+    index.related_uids;
+  Uid_map.schema type_ufstore iter
+    (fun iter _uid -> function
+      | Link _ -> ()
+      | Root { value; _ } -> uidset_schema iter value)
+    index.related_uids_store
 
 let compress index =
   let cache = Lid.cache () in
@@ -66,13 +97,13 @@ let compress index =
   compress_map_set index.defs;
   compress_map_set index.approximated;
   let related_uids =
-    Uid_map.map
+    (* Uid_map.map
       (fun set ->
         let uid = Uid_set.min_elt (Union_find.get set) in
         let reference_set = Uid_map.find uid index.related_uids in
         Granular_marshal.reuse reference_set;
-        reference_set)
-      index.related_uids
+        reference_set) *)
+    index.related_uids
   in
   { index with related_uids }
 
@@ -90,12 +121,12 @@ let pp_partials (fmt : Format.formatter) (partials : Lid_set.t Uid_map.t) =
     partials;
   Format.fprintf fmt "@]}"
 
-let pp_related_uids (fmt : Format.formatter)
-    (related_uids : Union_find.t Uid_map.t) =
+let pp_related_uids (related_uids_store : Union_find.store)
+    (fmt : Format.formatter) (related_uids : Union_find.t Uid_map.t) =
   let rec gather acc map =
     match Uid_map.choose_opt map with
     | Some (_key, union) ->
-      let group = Union_find.get union |> Uid_set.to_list in
+      let group = Union_find.get related_uids_store union |> Uid_set.elements in
       List.fold_left (fun acc key -> Uid_map.remove key acc) map group
       |> gather (group :: acc)
     | None -> acc
@@ -123,7 +154,9 @@ let pp (fmt : Format.formatter) pl =
     pp_partials pl.approximated;
   Format.fprintf fmt "and shapes for CUS %s.@ "
     (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq));
-  Format.fprintf fmt "and related uids:@[{%a}@]" pp_related_uids pl.related_uids
+  Format.fprintf fmt "and related uids:@[{%a}@]"
+    (pp_related_uids pl.related_uids_store)
+    pl.related_uids
 
 let ext = "ocaml-index"
 
@@ -135,7 +168,7 @@ let write ~file index =
     (fun _temp_file_name oc ->
       output_string oc magic_number;
       let id = Random.State.(full_int (make_self_init ()) max_int) in
-      Granular_marshal.write oc ~id index_schema (index : index))
+      Granular_marshal.write oc ~filename:file ~id index_schema (index : index))
 
 type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown
 
diff --git a/src/index-format/index_format.mli b/src/index-format/index_format.mli
index af1e4f380c..1541f20619 100644
--- a/src/index-format/index_format.mli
+++ b/src/index-format/index_format.mli
@@ -10,14 +10,24 @@ module Lid : sig
 end
 module Lid_set : Granular_set.S with type elt = Lid.t
 module Stats : Map.S with type key = String.t
-module Uid_set = Shape.Uid.Set
+module Uid_set : Granular_set.S with type elt = Shape.Uid.t
 module Uid_map : Granular_map.S with type key = Shape.Uid.t
 module Union_find : sig
   type t
+  type store = Uid_set.t Union_find.content Uid_map.t
+  val empty : unit -> store
 
-  val make : Uid_set.t -> t
-  val get : t -> Uid_set.t
-  val union : t -> t -> t
+  val new_root : store -> Shape.Uid.t -> Uid_set.t -> store * t
+  val get : store -> t -> Uid_set.t
+  val union : store -> t -> t -> store * t
+
+  val merge : store -> store -> store
+
+  (** [merge_union store map store' map'] combines two union-find structures,
+      each described by a [store] (mapping uids to their union-find content) and
+      a [map] (mapping uids to handles into that store). *)
+  val merge_union :
+    store -> t Uid_map.t -> store -> t Uid_map.t -> store * t Uid_map.t
 end
 
 type stat = { mtime : float; size : int; source_digest : string option }
@@ -28,6 +38,7 @@ type index =
     cu_shape : (string, Shape.t) Hashtbl.t;
     stats : stat Stats.t;
     root_directory : string option;
+    related_uids_store : Union_find.store;
     related_uids : Union_find.t Uid_map.t
   }
 
diff --git a/src/index-format/union_find.ml b/src/index-format/union_find.ml
index d59d1fed12..49dcdff4c0 100644
--- a/src/index-format/union_find.ml
+++ b/src/index-format/union_find.ml
@@ -1,40 +1,85 @@
-type 'a content =
-  | Root of { mutable value : 'a; mutable rank : int }
-  | Link of { mutable parent : 'a element }
-and 'a element = 'a content ref
-
-let make value = ref (Root { value; rank = 0 })
-
-let rec find x =
-  match !x with
-  | Root _ -> x
-  | Link ({ parent; _ } as link) ->
-    let root = find parent in
-    if root != parent then link.parent <- root;
-    root
-
-let union ~f x y =
-  let x = find x in
-  let y = find y in
-  if x == y then x
-  else
-    begin match (!x, !y) with
-    | ( Root ({ rank = rank_x; value = value_x } as root_x),
-        Root ({ rank = rank_y; value = value_y } as root_y) ) ->
-      let new_value = f value_x value_y in
-      if rank_x < rank_y then (
-        x := Link { parent = y };
-        root_y.value <- new_value;
-        y)
-      else (
-        y := Link { parent = x };
-        root_x.value <- new_value;
-        if rank_x = rank_y then root_x.rank <- root_x.rank + 1;
-        x)
-    | _ -> assert false
-    end
-
-let get elt =
-  match !(find elt) with
+module Uid = Shape.Uid
+module Uid_map = Granular_map.Make (Uid)
+
+type 'a elt_handle = Uid.t
+
+type 'a content = Root of { value : 'a; rank : int } | Link of 'a elt_handle
+
+type 'a store = 'a content Uid_map.t
+
+let empty () = Uid_map.empty ()
+
+let new_root store uid value =
+  (Uid_map.add uid (Root { value; rank = 0 }) store, uid)
+
+let rec find_and_compress store uid =
+  match Uid_map.find uid store with
+  | Root _ as root -> (store, uid, root)
+  | Link parent ->
+    let store, root_uid, root = find_and_compress store parent in
+    let store =
+      (* Path compression: point [uid] to the root. *)
+      if Uid.equal parent root_uid then store
+      else Uid_map.add uid (Link root_uid) store
+    in
+    (store, root_uid, root)
+
+let rec find store uid =
+  match Uid_map.find uid store with
+  | Root _ -> uid
+  | Link parent -> find store parent
+
+let get store uid =
+  let root = find store uid in
+  match Uid_map.find root store with
   | Root { value; _ } -> value
   | Link _ -> assert false
+
+let union ~f store x y =
+  let store, x, x_root = find_and_compress store x in
+  let store, y, y_root = find_and_compress store y in
+  if Uid.equal x y then (store, x)
+  else
+    match (x_root, y_root) with
+    | ( Root { value = value_x; rank = rank_x },
+        Root { value = value_y; rank = rank_y } ) ->
+      let value = f value_x value_y in
+      if rank_x < rank_y then
+        let store =
+          Uid_map.add x (Link y) store
+          |> Uid_map.add y (Root { value; rank = rank_y })
+        in
+        (store, y)
+      else if rank_x > rank_y then
+        let store =
+          Uid_map.add y (Link x) store
+          |> Uid_map.add x (Root { value; rank = rank_x })
+        in
+        (store, x)
+      else
+        let store =
+          Uid_map.add y (Link x) store
+          |> Uid_map.add x (Root { value; rank = rank_x + 1 })
+        in
+        (store, x)
+    | Link _, Root _ | Root _, Link _ | Link _, Link _ -> assert false
+
+let merge ~f (s1 : 'a store) (s2 : 'a store) =
+  let ensure store uid =
+    let value = get s2 uid in
+    match find_and_compress store uid with
+    | exception Not_found -> fst (new_root store uid value)
+    | store, root, Root { value = v0; rank } ->
+      Uid_map.add root (Root { value = f v0 value; rank }) store
+    | _, _, Link _ -> assert false
+  in
+  Uid_map.fold
+    (fun uid content store ->
+      match content with
+      | Root _ -> ensure store uid
+      | Link parent ->
+        let store = ensure store uid in
+        let store = ensure store parent in
+        let store, _ = union ~f store uid parent in
+        store)
+    s2 s1
diff --git a/src/index-format/union_find.mli b/src/index-format/union_find.mli
new file mode 100644
index 0000000000..306704b822
--- /dev/null
+++ b/src/index-format/union_find.mli
@@ -0,0 +1,19 @@
+module Uid = Shape.Uid
+
+module Uid_map : Granular_map.S with type key = Uid.t
+
+type 'a elt_handle = Uid.t
+type 'a content = Root of { value : 'a; rank : int } | Link of 'a elt_handle
+type 'a store = 'a content Uid_map.t
+val empty : unit -> 'a store
+val new_root : 'a store -> Uid.t -> 'a -> 'a store * 'a elt_handle
+val get : 'a store -> 'a elt_handle -> 'a
+val union :
+  f:('a -> 'a -> 'a) ->
+  'a store ->
+  'a elt_handle ->
+  'a elt_handle ->
+  'a store * 'a elt_handle
+
+(** [f] must be idempotent, commutative and associative. *)
+val merge : f:('a -> 'a -> 'a) -> 'a store -> 'a store -> 'a store
diff --git a/src/ocaml-index/bin/ocaml_index.ml b/src/ocaml-index/bin/ocaml_index.ml
index ab9dccfe3d..4aca932bdd 100644
--- a/src/ocaml-index/bin/ocaml_index.ml
+++ b/src/ocaml-index/bin/ocaml_index.ml
@@ -14,6 +14,7 @@ let root = ref ""
 let rewrite_root = ref false
 let store_shapes = ref false
 let do_not_use_cmt_loadpath = ref false
+let cache_size_kb = ref 1_000_000
 
 type command = Aggregate | Dump | Stats
 
@@ -38,7 +39,10 @@ let anon_fun arg =
 let speclist =
   [ ("--verbose", Arg.Set verbose, "Output more information");
     ("--debug", Arg.Set debug, "Output debugging information");
-    ("-o", Arg.Set_string output_file, "Set output file name");
+    ( "-o",
+      Arg.Set_string output_file,
+      "Set output file name. Note that sub-indexes paths remains relative to \
+       the current directory." );
     ( "--root",
       Arg.Set_string root,
       "Set the root path for all relative locations" );
@@ -63,7 +67,11 @@ let speclist =
     ( "--no-cmt-load-path",
       Arg.Set do_not_use_cmt_loadpath,
       "Do not initialize the load path with the paths found in the first input \
-       cmt file" )
+       cmt file" );
+    ( "--cache-size",
+      Arg.Set_int cache_size_kb,
+      "Set LRU cache size in kb. Will bound memory usage in read-heavy \
+       scenarios. Defaults to 1_000_000 (1gb)" )
   ]
 
 let set_log_level debug verbose =
@@ -74,6 +82,7 @@ let set_log_level debug verbose =
 let () =
   Arg.parse speclist anon_fun usage_msg;
   set_log_level !debug !verbose;
+  Granular_marshal.set_lru_size (!cache_size_kb * 1000);
   try
     (match !command with
     | Some Aggregate ->
@@ -114,6 +123,7 @@ let () =
             (Option.value ~default:"none" root_directory))
         !input_files
     | _ -> Printf.printf "Nothing to do.\n%!");
+    if !debug then Granular_marshal.get_lru () |> Dbllist.pp_stats;
     exit 0
   with Granular_marshal.Outdated_store { filename; reason } ->
     let msg =
diff --git a/src/ocaml-index/lib/index.ml b/src/ocaml-index/lib/index.ml
index abfebf8a00..2c70482457 100644
--- a/src/ocaml-index/lib/index.ml
+++ b/src/ocaml-index/lib/index.ml
@@ -135,22 +135,28 @@ let index_of_cmt ~into ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath
           into.stats
       with Unix.Unix_error _ -> into.stats)
   in
-  let related_uids =
+  let related_uids_store, related_uids =
+    let get_or_create store acc uid =
+      match Uid_map.find_opt uid acc with
+      | Some h -> (store, (acc, h))
+      | None ->
+        let store, h = Union_find.new_root store uid (Uid_set.singleton uid) in
+        (store, (Uid_map.add uid h acc, h))
+    in
     List.fold_left
-      (fun acc (_, uid1, uid2) ->
-        let union = Union_find.make (Uid_set.of_list [ uid1; uid2 ]) in
-        let map_update uid =
-          Uid_map.update uid (function
-            | None -> Some union
-            | Some union' -> Some (Union_find.union union' union))
-        in
-        acc |> map_update uid1 |> map_update uid2)
-      into.related_uids cmt_declaration_dependencies
+      (fun (store, acc) (_, uid1, uid2) ->
+        let store, (acc, h1) = get_or_create store acc uid1 in
+        let store, (acc, h2) = get_or_create store acc uid2 in
+        let store, _ = Union_find.union store h1 h2 in
+        (store, acc))
+      (into.related_uids_store, into.related_uids)
+      cmt_declaration_dependencies
   in
   { defs;
     approximated;
     cu_shape;
     stats;
+    related_uids_store;
     related_uids;
     root_directory = into.root_directory
   }
@@ -159,14 +165,13 @@ let merge_index ~store_shapes ~into index =
   let defs = merge index.defs into.defs in
   let approximated = merge index.approximated into.approximated in
   let stats = Stats.union (fun _ f1 _f2 -> Some f1) into.stats index.stats in
-  let related_uids =
-    Uid_map.union
-      (fun _ a b -> Some (Union_find.union a b))
-      index.related_uids into.related_uids
+  let related_uids_store, related_uids =
+    Union_find.merge_union index.related_uids_store index.related_uids
+      into.related_uids_store into.related_uids
   in
   if store_shapes then
     Hashtbl.add_seq index.cu_shape (Hashtbl.to_seq into.cu_shape);
-  { into with defs; approximated; stats; related_uids }
+  { into with defs; approximated; stats; related_uids_store; related_uids }
 
 let from_files ~store_shapes ~output_file ~root ~rewrite_root ~build_path
     ~do_not_use_cmt_loadpath files =
@@ -177,6 +182,7 @@ let from_files ~store_shapes ~output_file ~root ~rewrite_root ~build_path
       cu_shape = Hashtbl.create 64;
       stats = Stats.empty;
       root_directory = root;
+      related_uids_store = Uid_map.empty ();
       related_uids = Uid_map.empty ()
     }
   in
diff --git a/src/ocaml-index/tests/tests-dirs/cmd.t b/src/ocaml-index/tests/tests-dirs/cmd.t
index 885de8fca5..935cb278e9 100644
--- a/src/ocaml-index/tests/tests-dirs/cmd.t
+++ b/src/ocaml-index/tests/tests-dirs/cmd.t
@@ -1,17 +1,26 @@
   $ ocaml-index aggregate
   $ ocaml-index aggregate --debug
   [debug] Debug log is enabled
+  total_cap 		: 1000000000
+  size 		: 0
+  promote_count 	: 0
+  add_count 		: 0
+  discard_count 	: 0
+  add_size 		: 0
+  discard_size 	: 0
+  volume_conservation 	: 0 = 0 + 0 : true
 
   $ ocaml-index --help
   ocaml-index [COMMAND] [-verbose] <file1> [<file2>] ... -o <output>
     --verbose Output more information
     --debug Output debugging information
-    -o Set output file name
+    -o Set output file name. Note that sub-indexes paths remains relative to the current directory.
     --root Set the root path for all relative locations
     --rewrite-root Rewrite locations paths using the provided root
     --store-shapes Aggregate input-indexes shapes and store them in the new index
     -I An extra directory to add to the load path
     -H An extra hidden directory to add to the load path
     --no-cmt-load-path Do not initialize the load path with the paths found in the first input cmt file
+    --cache-size Set LRU cache size in kb. Will bound memory usage in read-heavy scenarios. Defaults to 1_000_000 (1gb)
     -help  Display this list of options
     --help  Display this list of options
diff --git a/src/ocaml-index/tests/tests-dirs/index-project.t b/src/ocaml-index/tests/tests-dirs/index-project.t
index fdd7a5dc51..9d7030e446 100644
--- a/src/ocaml-index/tests/tests-dirs/index-project.t
+++ b/src/ocaml-index/tests/tests-dirs/index-project.t
@@ -152,3 +152,4 @@
   - 0 compilation units shapes
   - root dir: none
   
+  $ ocaml-index aggregate -o project.uideps main.uideps foo.uideps bar.uideps 
diff --git a/src/ocaml-index/tests/tests-dirs/transitive-deps.t b/src/ocaml-index/tests/tests-dirs/transitive-deps.t
index 95f94aaedb..950c6ecb1b 100644
--- a/src/ocaml-index/tests/tests-dirs/transitive-deps.t
+++ b/src/ocaml-index/tests/tests-dirs/transitive-deps.t
@@ -20,8 +20,8 @@
 
 # We pass explicitely the implicit transitive dependency over lib2:
   $ ocaml-index aggregate -o main.uideps main.cmt -I lib2
-  $ ocaml-index aggregate -o lib1/foo.uideps lib1/foo.cmt
-  $ ocaml-index aggregate -o lib2/bar.uideps lib2/bar.cmt
+  $ (cd lib1 ; ocaml-index aggregate -o foo.uideps foo.cmt)
+  $ (cd lib2 ; ocaml-index aggregate -o bar.uideps bar.cmt)
 
   $ ocaml-index aggregate -o test.uideps main.uideps lib1/foo.uideps lib2/bar.uideps
 
diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml
index 75d7ab2744..d226383134 100644
--- a/src/ocaml/utils/config.ml
+++ b/src/ocaml/utils/config.ml
@@ -51,7 +51,7 @@ and ast_impl_magic_number = "Caml1999M037"
 and ast_intf_magic_number = "Caml1999N037"
 and cmxs_magic_number = "Caml1999D037"
 and cmt_magic_number = "Caml1999T037"
-and index_magic_number = "Merl2023I004"
+and index_magic_number = "Merl2023I005"
 
 let interface_suffix = ref ".mli"
 let flat_float_array = true
diff --git a/tests/test-dirs/occurrences/project-wide/union.t b/tests/test-dirs/occurrences/project-wide/union.t
index 6f78383c3d..c05da4207a 100644
--- a/tests/test-dirs/occurrences/project-wide/union.t
+++ b/tests/test-dirs/occurrences/project-wide/union.t
@@ -57,7 +57,7 @@ An error is expected, a pointer references an index file, but it doesn't exist a
 
   $ mv test_sig.ocaml-index index-files
   $ ocaml-index dump project.ocaml-index
-  Missing file "test_sig.ocaml-index".
+  Missing file "$TESTCASE_ROOT/test_sig.ocaml-index".
   Hint: try to rebuild indexes with dune build @ocaml-index.
   [1]
   $ mv index-files test_sig.ocaml-index
@@ -66,6 +66,6 @@ An error is expected, a pointer references an index file that is considered outd
 
   $ ocaml-index aggregate test.cmti test.cmt sig.cmti sig.cmt --root . --rewrite-root -o test_sig.ocaml-index
   $ ocaml-index dump project.ocaml-index
-  Index IDs doesn't match for "test_sig.ocaml-index".
+  Index IDs doesn't match for "$TESTCASE_ROOT/test_sig.ocaml-index".
   Hint: try to rebuild indexes with dune build @ocaml-index.
   [1]
diff --git a/tests/test-units/union_find/dune b/tests/test-units/union_find/dune
new file mode 100644
index 0000000000..8ed2ffd19e
--- /dev/null
+++ b/tests/test-units/union_find/dune
@@ -0,0 +1,4 @@
+(test
+ (name union_find_test)
+ (package merlin-lib)
+ (libraries fmt alcotest merlin-lib.ocaml_typing merlin-lib.index_format))
diff --git a/tests/test-units/union_find/union_find_test.ml b/tests/test-units/union_find/union_find_test.ml
new file mode 100644
index 0000000000..6c381b0523
--- /dev/null
+++ b/tests/test-units/union_find/union_find_test.ml
@@ -0,0 +1,93 @@
+module Uid = Ocaml_typing.Shape.Uid
+module Ident = Ocaml_typing.Ident
+module Uid_set = Ocaml_typing.Shape.Uid.Set
+module Union_find = Merlin_index_format.Union_find
+
+let f = Uid_set.union
+let uid name = Uid.of_compilation_unit_id (Ident.create_persistent name)
+let a = uid "A"
+let b = uid "B"
+let c = uid "C"
+let d = uid "D"
+
+(* Build a store: each uid starts as a singleton root, then the listed pairs
+   are unioned together. *)
+let store uids unions =
+  let store, handles =
+    List.fold_left
+      (fun (store, handles) u ->
+        let store, h = Union_find.new_root store u (Uid_set.singleton u) in
+        (store, (u, h) :: handles))
+      (Union_find.empty (), [])
+      uids
+  in
+  let handle u = List.assoc u handles in
+  List.fold_left
+    (fun store (x, y) ->
+      let store, _ = Union_find.union ~f store (handle x) (handle y) in
+      store)
+    store unions
+
+let uid_set = Alcotest.testable Uid_set.print Uid_set.equal
+
+(* Every member of [members] must resolve to exactly the set [members]. *)
+let check_class store ~msg members =
+  let expected = Uid_set.of_list members in
+  List.iter
+    (fun u ->
+      Alcotest.check uid_set
+        (Format.asprintf "%s: related set of %a" msg Uid.print u)
+        expected (Union_find.get store u))
+    members
+
+(* s1: {A,B,C}; s2: {A}, {B,D}. B is shared and only a link in s1, so the
+   relation A~B~C (s1) and B~D (s2) must close into a single class {A,B,C,D}.
+   The previous [merge] dropped D from A's and C's class. *)
+let transitive_merge () =
+  let s1 = store [ a; b; c ] [ (a, b); (a, c) ] in
+  let s2 = store [ a; b; d ] [ (b, d) ] in
+  let merged = Union_find.merge ~f s1 s2 in
+  check_class merged ~msg:"transitive" [ a; b; c; d ]
+
+let self_merge () =
+  let s = store [ a; b; c ] [ (a, b); (a, c) ] in
+  let merged = Union_find.merge ~f s s in
+  check_class merged ~msg:"self" [ a; b; c ]
+
+let disjoint_merge () =
+  let s1 = store [ a; b ] [ (a, b) ] in
+  let s2 = store [ c; d ] [ (c, d) ] in
+  let merged = Union_find.merge ~f s1 s2 in
+  check_class merged ~msg:"disjoint/left" [ a; b ];
+  check_class merged ~msg:"disjoint/right" [ c; d ];
+  Alcotest.(check bool)
+    "disjoint classes stay separate" false
+    (Uid_set.mem c (Union_find.get merged a))
+
+(* Both stores have A as a lone root but carry different related sets. The old
+   [merge] kept only s1's value and dropped s2's; the merged value must be the
+   union of both. *)
+let conflicting_root_values () =
+  let s1 =
+    fst (Union_find.new_root (Union_find.empty ()) a (Uid_set.of_list [ a; b ]))
+  in
+  let s2 =
+    fst (Union_find.new_root (Union_find.empty ()) a (Uid_set.of_list [ a; c ]))
+  in
+  let merged = Union_find.merge ~f s1 s2 in
+  Alcotest.check uid_set "merged root value is the union of both"
+    (Uid_set.of_list [ a; b; c ])
+    (Union_find.get merged a)
+
+let cases =
+  ( "union_find_merge",
+    Alcotest.
+      [ test_case "merges transitive classes across stores" `Quick
+          transitive_merge;
+        test_case "self-merge preserves classes" `Quick self_merge;
+        test_case "disjoint stores keep separate classes" `Quick disjoint_merge;
+        test_case "shared root combines conflicting values" `Quick
+          conflicting_root_values
+      ] )
+
+let () = Alcotest.run "merlin-lib.index_format.union_find" [ cases ]