From 3bbf3ebbe463772fca34079d621e695922f5377b Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Tue, 31 Mar 2026 11:15:23 +0200 Subject: [PATCH 01/28] Add a LRU cache to limit indexing memory usage. - Change the way small values are handled by storing them along their parent. - Make filenames relative to the current working directory of the indexer. - Disable related-uids compression Suggested-by: ArthurW Co-authored-by: Lucccyo Co-authored-by: Tim ats Co-authored-by: ArthurW --- src/analysis/occurrences.ml | 9 +- src/index-format/dbllist.ml | 145 +++++ src/index-format/dbllist.mli | 26 + src/index-format/dune | 2 +- src/index-format/granular_map.ml | 1 + src/index-format/granular_marshal.ml | 577 ++++++++++++++---- src/index-format/granular_marshal.mli | 24 +- src/index-format/index_format.ml | 49 +- src/index-format/index_format.mli | 11 +- src/index-format/union_find.ml | 124 ++-- src/index-format/union_find.mli | 15 + src/ocaml-index/bin/ocaml_index.ml | 13 +- src/ocaml-index/lib/index.ml | 43 +- src/ocaml-index/tests/tests-dirs/cmd.t | 3 +- .../tests/tests-dirs/index-project.t | 1 + .../tests/tests-dirs/transitive-deps.t | 4 +- src/ocaml/utils/config.ml | 2 +- .../occurrences/project-wide/union.t | 4 +- tests/test-units/union_find/dune | 4 + .../test-units/union_find/union_find_test.ml | 76 +++ 20 files changed, 943 insertions(+), 190 deletions(-) create mode 100644 src/index-format/dbllist.ml create mode 100644 src/index-format/dbllist.mli create mode 100644 src/index-format/union_find.mli create mode 100644 tests/test-units/union_find/dune create mode 100644 tests/test-units/union_find/union_find_test.ml diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 6d6a05e192..8839eddcfa 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -224,13 +224,18 @@ 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 store = ref (Uid_map.empty ()) in let related_uids = List.fold_left ~init:(Uid_map.empty ()) config.merlin.index_files ~f:(fun acc index_file -> try let index = Index_cache.read index_file in + store := Union_find.merge !store index.related_uids_store; Uid_map.union - (fun _ a b -> Some (Union_find.union a b)) + (fun _ a b -> + let store', v = Union_find.union !store a b in + store := store'; + Some v) index.related_uids acc with | Index_format.Not_an_index _ @@ -242,7 +247,7 @@ let lookup_related_uids_in_indexes ~(config : Mconfig.t) uid = 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.to_list) 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..0ee8bf847a 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -4,43 +4,148 @@ 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 * int * store * 'a schema option ref -> cached + +and value_status = + | Dirty_unknown_schema + (** Marks a value that has not been cleaned yet. Usually because its + schema was unknown when it was read from the disk for its smalls. *) + | Clean 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 } + (** {i on-disk} A pointer to a serialized value in the file. *) | Serialized_reused of { loc : int } + (** {i on-disk} A pointer to serialized value that is used multiple times. + Allow for better file compression and perofrmance. *) + | 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; pos : int option } + (** {i on-disk} A pointer to a serialized value in another file. The + optional `pos` field is used to target small values. *) + (* + * In-memory realm + *) | On_disk of { store : store; loc : int; schema : 'a schema } - | On_disk_ptr of { filename : string; loc : int; id : int } + (** {i in-memory} A value that can be read from the disk. *) + | On_disk_small of + { store : store; + loc : int; + 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 'a * value_status * cached Dbllist.cell * 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 + | Serialized_reused { loc } -> Printf.sprintf "Serialized_reused(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; pos; _ } -> + Printf.sprintf "On_disk_ptr(loc=%d%s)" loc + (match pos with + | Some pos -> Printf.sprintf ", pos=%d" pos + | None -> "") + | In_memory _ -> "In_memory" + | In_cache (_, status, { content = Cached (_, loc, _, _); _ }, _) -> + let clean_dirty = + match status with + | Clean -> "Clean" + | Dirty_unknown_schema -> "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 +166,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 +191,399 @@ let open_store store = force_open_store store | None -> force_open_store store -let read_loc store fd loc schema = - 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") - } +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 loc 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 + { store; + loc; + 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_ptr + { filename = store.filename; + loc; + id = store.id; + pos = None + }) + in + Cache.add store.cache loc (Link (lnk, None)); + PLink lnk + in + lnk := + On_disk_small + { store; + loc; + parent; + small_type_id = type_id; + small_schema = schema; + small_pos = pos + } + | Serialized { loc } -> lnk := On_disk { store; loc; schema } + | Serialized_reused { loc } -> ( + 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 _ -> + invalid_arg "Granular_marshal.read_loc: reuse of a different type" + | None -> + lnk := On_disk { store; loc; schema }; + Cache.add store.cache loc (Link (lnk, Some type_id))) + | On_disk_ptr { filename; loc; id; pos = None } -> ( + let filename = resolve_filename store ~filename in + let store = { filename; id; cache = Cache_cache.read filename } in + 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 + let () = + (* We might have reused a parent whose schema was initially unknown. + Let's update it. *) + match !lnk' with + | On_disk_ptr { loc; pos = 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 } + | In_cache (v, Dirty_unknown_schema, cell, smalls) -> + (* If we already have the value in cache we must clean it. *) + schema (disk_to_memory_iter store loc (PLink lnk')) v; + lnk' := In_cache (v, Clean, cell, smalls) + | Small _ + | Serialized _ + | Serialized_reused _ + | Serialized_small _ + | On_disk _ + | On_disk_small _ + | On_disk_ptr _ + | In_memory _ + | In_cache (_, _, _, _) + | In_memory_reused _ | Duplicate _ -> assert false + in + Cache.replace store.cache loc (Link (lnk', Some type_id)); + lnk := Duplicate (normalize lnk') + | _ -> lnk := On_disk { store; loc; schema }) + | On_disk_ptr { filename; loc; id; pos = Some 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_ptr { filename; loc; id; pos = None }) in + Cache.add store.cache loc (Link (lnk, None)); + PLink lnk + in + lnk := + On_disk_small + { store; + loc; + 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" *) ()) + } + +let on_cache_discard (Cached (link, loc, store, schema)) = + (* This also free the smalls that are stored in the link *) + match !schema with + | Some schema -> link := On_disk { store; loc; schema } + | None -> + link := + On_disk_ptr { filename = store.filename; id = store.id; loc; pos = None } + +let add_to_cache v lnk ~loc store ~size small_values schema = + let discarded = Dbllist.discard_size (get_lru ()) size in + let status = if Option.is_none schema then Dirty_unknown_schema else Clean in + let cell = + Dbllist.add_front (get_lru ()) (Cached (lnk, loc, store, ref schema), size) in + List.iter on_cache_discard discarded; + lnk := In_cache (v, status, cell, small_values) + +(** Read one value and its smalls from the disk. *) +let read_loc_dirty fd loc = + seek_in fd loc; + 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 loc parent_link in schema iter v; - v + (v, size_read, small_children) -let fetch_loc store loc schema = +(** 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 v = read_loc store fd loc schema in - v + 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 rec fetch lnk = - 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 +let fetch_on_disk_dirty lnk store loc = + let fd = open_store store in + let v, size, small_children = read_loc_dirty fd loc in + add_to_cache v lnk ~loc store ~size small_children None; + small_children + +(** 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 : parent_link -> any_value array = + fun (PLink parent_link) -> + match !parent_link with + | In_cache (_, _, _, smalls) -> smalls + | On_disk_ptr { filename; loc; id; pos = None } -> + let store = { filename; id; cache = Cache_cache.read filename } in + fetch_on_disk_dirty parent_link store loc | On_disk { store; loc; schema } -> - let v = fetch_loc store loc schema in - lnk := In_memory v; - v + snd (fetch_on_disk parent_link store loc schema) + | _ -> + invalid_arg + ("Granular_marshal.fetch_parent: Unexpected parent link " + ^ string_of_link parent_link) -let reuse lnk = +let rec fetch : type a. a link -> a = + fun lnk -> match !lnk with - | In_memory v -> lnk := In_memory_reused v + | In_cache (v, Clean, cell, _) -> + Dbllist.promote (get_lru ()) cell; + v + | In_cache (_v, Dirty_unknown_schema, _, _) -> + invalid_arg "Granular_marshal.fetch: accessing dirty cached value" + | Duplicate original_lnk -> fetch original_lnk + | On_disk { store; loc; schema } -> fst (fetch_on_disk lnk store loc schema) + | On_disk_small { store; loc; parent; small_pos; small_type_id; small_schema } + -> ( + let smalls = fetch_parent 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 loc parent) v; + smalls.(small_pos) <- Value (v, small_type_id); + v) + | In_memory v | In_memory_reused v -> v + | Serialized _ + | Serialized_reused _ + | Serialized_small _ + | Small _ + | On_disk_ptr _ -> + 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_reused _ + | Serialized_small _ + | Small _ + | On_disk_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_reused _ | 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 + ( _, + _, + { content = Cached (_, loc, { filename; id; _ }, _); _ }, + _ ) -> lnk := On_disk_ptr { filename; id; loc; pos = None } + | _ -> + 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 (_v, _, t, _children) -> + let (Cached (_, loc, { filename; id; _ }, _)) = t.content in + let filename = relativize filename in + lnk := On_disk_ptr { filename; id; loc; pos = None } | 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; pos = None } + | On_disk_small { store = { filename; id; _ }; loc; small_pos; _ } -> + let filename = relativize filename in + lnk := On_disk_ptr { filename; id; loc; pos = Some 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_ptr { pos = Some _; _ } -> + (* 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; + let _v_size, v_smalls = write_children schema v in lnk := Serialized_reused { loc = pos_out fd }; - Marshal.to_channel fd v flags + 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 = 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..9647dcdc8d 100644 --- a/src/index-format/index_format.ml +++ b/src/index-format/index_format.ml @@ -2,20 +2,30 @@ 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 Union_find = struct - type t = Uid_set.t Union_find.element Granular_marshal.link + type t = Uid_set.t Union_find.elt_handle Granular_marshal.link + type store = Uid_set.t Union_find.content Uid_map.t - let make v = Granular_marshal.link (Union_find.make v) + let empty () = Union_find.empty () - let get t = Union_find.get (Granular_marshal.fetch t) + let new_root store uid v = + let store, root = Union_find.new_root store uid v in + (store, Granular_marshal.link root) - let union a b = - Granular_marshal.( - link (Union_find.union ~f:Uid_set.union (fetch a) (fetch b))) + 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, link root) + + let merge = Union_find.merge ~f:Uid_set.union let type_id : t Type.Id.t = Type.Id.make () @@ -38,6 +48,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 } @@ -45,6 +56,7 @@ let lidset_schema iter lidset = Lid_set.schema iter Lid.schema 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 +67,10 @@ 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 _content -> ()) + index.related_uids_store let compress index = let cache = Lid.cache () in @@ -66,13 +81,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 +105,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.to_list in List.fold_left (fun acc key -> Uid_map.remove key acc) map group |> gather (group :: acc) | None -> acc @@ -123,7 +138,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 +152,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..5e8eaaea5e 100644 --- a/src/index-format/index_format.mli +++ b/src/index-format/index_format.mli @@ -14,10 +14,14 @@ module Uid_set = Shape.Uid.Set 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 end type stat = { mtime : float; size : int; source_digest : string option } @@ -28,6 +32,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..e15bae3607 100644 --- a/src/index-format/union_find.ml +++ b/src/index-format/union_find.ml @@ -1,40 +1,88 @@ -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 _ -> (store, uid) + | Link parent -> + let store, root = find_and_compress store parent in + let store = + (* Path compression: point [uid] to the root. *) + if Uid.equal parent root then store else Uid_map.add uid (Link root) store + in + (store, 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 = find_and_compress store x in + let store, y = find_and_compress store y in + if Uid.equal x y then (store, x) + else + match (Uid_map.find x store, Uid_map.find y store) 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 = + let s = Uid_map.add x (Link y) store in + if value <> value_y then + Uid_map.add y (Root { value; rank = rank_y }) s + else s + in + (store, y) + else if rank_x > rank_y then + let store = + let s = Uid_map.add y (Link x) store in + if value <> value_x then + Uid_map.add x (Root { value; rank = rank_x }) s + else s + 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) = + (* TODO there is similar logic in [index.ml] *) + let ensure store uid = + if Uid_map.mem uid store then store + else + match Uid_map.find (find s2 uid) s2 with + | Root { value; _ } -> fst (new_root store uid value) + | 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..3c6952aa9a --- /dev/null +++ b/src/index-format/union_find.mli @@ -0,0 +1,15 @@ +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 + +val merge : f:('a -> 'a -> 'a) -> 'a store -> 'a store -> 'a store +(** [f] must be idempotent, commutative and associative. *) diff --git a/src/ocaml-index/bin/ocaml_index.ml b/src/ocaml-index/bin/ocaml_index.ml index ab9dccfe3d..6fcde8e409 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 = 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,10 @@ 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, + "Set LRU cache size. Will bound memory usage in read-heavy scenarios." ) ] let set_log_level debug verbose = @@ -74,6 +81,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; try (match !command with | Some Aggregate -> @@ -114,6 +122,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..aabc96cd51 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,26 @@ 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 store = + ref (Union_find.merge index.related_uids_store into.related_uids_store) + in let related_uids = Uid_map.union - (fun _ a b -> Some (Union_find.union a b)) + (fun _ a b -> + let store', v = Union_find.union !store a b in + store := store'; + Some v) index.related_uids 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 = !store; + related_uids + } let from_files ~store_shapes ~output_file ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath files = @@ -177,6 +195,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..a0dff28cdb 100644 --- a/src/ocaml-index/tests/tests-dirs/cmd.t +++ b/src/ocaml-index/tests/tests-dirs/cmd.t @@ -6,12 +6,13 @@ ocaml-index [COMMAND] [-verbose] [] ... -o --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. Will bound memory usage in read-heavy scenarios. -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..037b370627 --- /dev/null +++ b/tests/test-units/union_find/union_find_test.ml @@ -0,0 +1,76 @@ +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)) + +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 + ] ) + +let () = Alcotest.run "merlin-lib.index_format.union_find" [ cases ] From f20f7722e86b2a35f701197698e9248fc77aa47e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 15 Jun 2026 15:51:53 +0200 Subject: [PATCH 02/28] Add changelog for #2079 --- CHANGES.md | 4 ++++ 1 file changed, 4 insertions(+) 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). From 5ae38c706f0c2edbd52d7b8c160ff089eb638907 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 15 Jun 2026 16:08:42 +0200 Subject: [PATCH 03/28] Promote test change --- src/ocaml-index/tests/tests-dirs/cmd.t | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/ocaml-index/tests/tests-dirs/cmd.t b/src/ocaml-index/tests/tests-dirs/cmd.t index a0dff28cdb..9f55870cce 100644 --- a/src/ocaml-index/tests/tests-dirs/cmd.t +++ b/src/ocaml-index/tests/tests-dirs/cmd.t @@ -1,6 +1,14 @@ $ ocaml-index aggregate $ ocaml-index aggregate --debug [debug] Debug log is enabled + total_cap : 1000000 + 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] [] ... -o From 70af090cd5cc32892ed5221caaee8128808cb647 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 15 Jun 2026 22:04:11 +0200 Subject: [PATCH 04/28] refmt --- src/index-format/index_format.mli | 2 +- src/index-format/union_find.mli | 14 +++++++++----- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/index-format/index_format.mli b/src/index-format/index_format.mli index 5e8eaaea5e..a519c88436 100644 --- a/src/index-format/index_format.mli +++ b/src/index-format/index_format.mli @@ -32,7 +32,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_store : Union_find.store; related_uids : Union_find.t Uid_map.t } diff --git a/src/index-format/union_find.mli b/src/index-format/union_find.mli index 3c6952aa9a..306704b822 100644 --- a/src/index-format/union_find.mli +++ b/src/index-format/union_find.mli @@ -1,15 +1,19 @@ module Uid = Shape.Uid -module Uid_map : Granular_map.S with type key = Uid.t - +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 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 +val union : + f:('a -> 'a -> 'a) -> + 'a store -> + 'a elt_handle -> + 'a elt_handle -> + 'a store * 'a elt_handle -val merge : f:('a -> 'a -> 'a) -> 'a store -> 'a store -> 'a store (** [f] must be idempotent, commutative and associative. *) +val merge : f:('a -> 'a -> 'a) -> 'a store -> 'a store -> 'a store From 88680e92e7a95dd2deaac6ebab6b35bea2f8fec7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Jun 2026 16:17:37 +0200 Subject: [PATCH 05/28] On_disk_small: Reuse store and loc from parents --- src/index-format/granular_marshal.ml | 49 ++++++++++++++-------------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 0ee8bf847a..3e8ebf276f 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -66,9 +66,7 @@ and 'a repr = | On_disk of { store : store; loc : int; schema : 'a schema } (** {i in-memory} A value that can be read from the disk. *) | On_disk_small of - { store : store; - loc : int; - parent : parent_link; (* Either the parent or an On_disk_ptr *) + { 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 @@ -198,7 +196,7 @@ let resolve_filename store ~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 loc parent_link = +let rec disk_to_memory_iter store parent_link = { yield = (fun (type a) (lnk : a link) @@ -209,9 +207,7 @@ let rec disk_to_memory_iter store loc parent_link = | Small pos -> lnk := On_disk_small - { store; - loc; - parent = parent_link; + { parent = parent_link; small_pos = pos; small_type_id = type_id; small_schema = schema @@ -235,9 +231,7 @@ let rec disk_to_memory_iter store loc parent_link = in lnk := On_disk_small - { store; - loc; - parent; + { parent; small_type_id = type_id; small_schema = schema; small_pos = pos @@ -281,7 +275,7 @@ let rec disk_to_memory_iter store loc parent_link = lnk' := On_disk { store; loc; schema } | In_cache (v, Dirty_unknown_schema, cell, smalls) -> (* If we already have the value in cache we must clean it. *) - schema (disk_to_memory_iter store loc (PLink lnk')) v; + schema (disk_to_memory_iter store (PLink lnk')) v; lnk' := In_cache (v, Clean, cell, smalls) | Small _ | Serialized _ @@ -310,9 +304,7 @@ let rec disk_to_memory_iter store loc parent_link = in lnk := On_disk_small - { store; - loc; - parent; + { parent; small_type_id = type_id; small_schema = schema; small_pos @@ -354,7 +346,7 @@ let read_loc_dirty fd loc = 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 loc parent_link in + let iter = disk_to_memory_iter store parent_link in schema iter v; (v, size_read, small_children) @@ -372,15 +364,23 @@ let fetch_on_disk_dirty lnk store loc = add_to_cache v lnk ~loc store ~size small_children None; small_children +(* 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 + | On_disk_ptr { filename; id; loc; pos = None; _ } -> + ({ filename; id; cache = Cache_cache.read filename }, loc) + | In_cache (_, _, { content = Cached (_, loc, store, _); _ }, _) + | On_disk { store; loc; _ } -> (store, loc) + | _ -> assert false + (** 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 : parent_link -> any_value array = - fun (PLink parent_link) -> +let fetch_parent : parent_link -> store -> any_value array = + fun (PLink parent_link) store -> match !parent_link with | In_cache (_, _, _, smalls) -> smalls - | On_disk_ptr { filename; loc; id; pos = None } -> - let store = { filename; id; cache = Cache_cache.read filename } in + | On_disk_ptr { loc; pos = None; _ } -> fetch_on_disk_dirty parent_link store loc | On_disk { store; loc; schema } -> snd (fetch_on_disk parent_link store loc schema) @@ -399,9 +399,9 @@ let rec fetch : type a. a link -> a = invalid_arg "Granular_marshal.fetch: accessing dirty cached value" | Duplicate original_lnk -> fetch original_lnk | On_disk { store; loc; schema } -> fst (fetch_on_disk lnk store loc schema) - | On_disk_small { store; loc; parent; small_pos; small_type_id; small_schema } - -> ( - let smalls = fetch_parent parent in + | On_disk_small { parent; small_pos; small_type_id; small_schema } -> ( + let store, _loc = store_and_loc_of_parent parent in + let smalls = fetch_parent parent store in match smalls.(small_pos) with | Value (type b) ((v, type_id') : b * _) -> ( match Type.Id.provably_equal small_type_id type_id' with @@ -409,7 +409,7 @@ let rec fetch : type a. a link -> a = | Some (Equal : (a link, b link) Type.eq) -> v) | Unknown v -> let v = Obj.magic v in - small_schema (disk_to_memory_iter store loc parent) v; + 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 @@ -504,7 +504,8 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = somewhere in the file. *) let filename = relativize filename in lnk := On_disk_ptr { filename; id; loc; pos = None } - | On_disk_small { store = { filename; id; _ }; loc; small_pos; _ } -> + | 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_ptr { filename; id; loc; pos = Some small_pos }) } From 8873a25203b980201e5be69d8c63bc44fc2adbed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Jun 2026 16:19:54 +0200 Subject: [PATCH 06/28] Promote parent in LRU when fetching a child --- src/index-format/granular_marshal.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 3e8ebf276f..8df4a0efe2 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -379,7 +379,9 @@ let store_and_loc_of_parent (PLink lnk : parent_link) = let fetch_parent : parent_link -> store -> any_value array = fun (PLink parent_link) store -> match !parent_link with - | In_cache (_, _, _, smalls) -> smalls + | In_cache (_, _, cell, smalls) -> + Dbllist.promote (get_lru ()) cell; + smalls | On_disk_ptr { loc; pos = None; _ } -> fetch_on_disk_dirty parent_link store loc | On_disk { store; loc; schema } -> From 6f1f871cd4bdf0a64d1d022ee69c85968afb69fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Jun 2026 16:20:32 +0200 Subject: [PATCH 07/28] Rename fetch_parent --- src/index-format/granular_marshal.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 8df4a0efe2..f8d4cfe365 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -376,7 +376,7 @@ let store_and_loc_of_parent (PLink lnk : parent_link) = (** 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 : parent_link -> store -> any_value array = +let fetch_parent_smalls : parent_link -> store -> any_value array = fun (PLink parent_link) store -> match !parent_link with | In_cache (_, _, cell, smalls) -> @@ -403,7 +403,7 @@ let rec fetch : type a. a link -> a = | On_disk { store; loc; schema } -> fst (fetch_on_disk lnk store loc schema) | On_disk_small { parent; small_pos; small_type_id; small_schema } -> ( let store, _loc = store_and_loc_of_parent parent in - let smalls = fetch_parent parent store in + let smalls = fetch_parent_smalls parent store in match smalls.(small_pos) with | Value (type b) ((v, type_id') : b * _) -> ( match Type.Id.provably_equal small_type_id type_id' with From 418a89090de201cd9d0a21c5f88d6e21bd708def Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Jun 2026 16:48:48 +0200 Subject: [PATCH 08/28] Make schema optional in `On_disk` to remove placeholder usages of `On_disk_ptr` --- src/index-format/granular_marshal.ml | 72 +++++++++++++--------------- 1 file changed, 32 insertions(+), 40 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index f8d4cfe365..5341e61cbc 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -63,7 +63,7 @@ and 'a repr = (* * In-memory realm *) - | On_disk of { store : store; loc : int; schema : 'a schema } + | 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 *) @@ -217,15 +217,7 @@ let rec disk_to_memory_iter store parent_link = match Cache.find_opt store.cache loc with | Some (Link (lnk, _)) -> PLink (normalize lnk) | None -> - let lnk = - ref - (On_disk_ptr - { filename = store.filename; - loc; - id = store.id; - pos = None - }) - in + let lnk = ref (On_disk { store; loc; schema = None }) in Cache.add store.cache loc (Link (lnk, None)); PLink lnk in @@ -236,7 +228,8 @@ let rec disk_to_memory_iter store parent_link = small_schema = schema; small_pos = pos } - | Serialized { loc } -> lnk := On_disk { store; loc; schema } + | Serialized { loc } -> + lnk := On_disk { store; loc; schema = Some schema } | Serialized_reused { loc } -> ( match Cache.find_opt store.cache loc with | Some (Link (type b) ((lnk', Some type_id') : b link * _)) -> ( @@ -249,7 +242,7 @@ let rec disk_to_memory_iter store parent_link = | Some _ -> invalid_arg "Granular_marshal.read_loc: reuse of a different type" | None -> - lnk := On_disk { store; loc; schema }; + lnk := On_disk { store; loc; schema = Some schema }; Cache.add store.cache loc (Link (lnk, Some type_id))) | On_disk_ptr { filename; loc; id; pos = None } -> ( let filename = resolve_filename store ~filename in @@ -268,11 +261,11 @@ let rec disk_to_memory_iter store parent_link = (* We might have reused a parent whose schema was initially unknown. Let's update it. *) match !lnk' with - | On_disk_ptr { loc; pos = None; _ } -> + | 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 } + lnk' := On_disk { store; loc; schema = Some schema } | In_cache (v, Dirty_unknown_schema, cell, smalls) -> (* If we already have the value in cache we must clean it. *) schema (disk_to_memory_iter store (PLink lnk')) v; @@ -290,7 +283,7 @@ let rec disk_to_memory_iter store parent_link = in Cache.replace store.cache loc (Link (lnk', Some type_id)); lnk := Duplicate (normalize lnk') - | _ -> lnk := On_disk { store; loc; schema }) + | _ -> lnk := On_disk { store; loc; schema = Some schema }) | On_disk_ptr { filename; loc; id; pos = Some small_pos } -> let filename = resolve_filename store ~filename in let store = { filename; id; cache = Cache_cache.read filename } in @@ -298,7 +291,7 @@ let rec disk_to_memory_iter store parent_link = match Cache.find_opt store.cache loc with | Some (Link (lnk, _)) -> PLink (normalize lnk) | None -> - let lnk = ref (On_disk_ptr { filename; loc; id; pos = None }) in + let lnk = ref (On_disk { store; loc; schema = None }) in Cache.add store.cache loc (Link (lnk, None)); PLink lnk in @@ -317,21 +310,17 @@ let rec disk_to_memory_iter store parent_link = | Duplicate _ -> (* These are already "clean" *) ()) } -let on_cache_discard (Cached (link, loc, store, schema)) = - (* This also free the smalls that are stored in the link *) - match !schema with - | Some schema -> link := On_disk { store; loc; schema } - | None -> - link := - On_disk_ptr { filename = store.filename; id = store.id; loc; pos = None } - let add_to_cache v lnk ~loc store ~size small_values schema = let discarded = Dbllist.discard_size (get_lru ()) size in let status = if Option.is_none schema then Dirty_unknown_schema else Clean in let cell = Dbllist.add_front (get_lru ()) (Cached (lnk, loc, store, ref schema), size) in - List.iter on_cache_discard discarded; + List.iter + (fun (Cached (link, loc, store, schema)) -> + (* This also free the smalls that are stored in the link *) + link := On_disk { store; loc; schema = !schema }) + discarded; lnk := In_cache (v, status, cell, small_values) (** Read one value and its smalls from the disk. *) @@ -367,25 +356,27 @@ let fetch_on_disk_dirty lnk store loc = (* 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 - | On_disk_ptr { filename; id; loc; pos = None; _ } -> - ({ filename; id; cache = Cache_cache.read filename }, loc) | In_cache (_, _, { content = Cached (_, loc, store, _); _ }, _) | On_disk { store; loc; _ } -> (store, loc) - | _ -> assert false + | _ -> + 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 -> store -> any_value array = - fun (PLink parent_link) store -> +let fetch_parent_smalls : parent_link -> any_value array * store = + fun (PLink parent_link) -> match !parent_link with | In_cache (_, _, cell, smalls) -> + let { content = Cached (_, _, store, _); _ } = cell in Dbllist.promote (get_lru ()) cell; - smalls - | On_disk_ptr { loc; pos = None; _ } -> - fetch_on_disk_dirty parent_link store loc - | On_disk { store; loc; schema } -> - snd (fetch_on_disk parent_link store loc schema) + (smalls, 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 " @@ -400,10 +391,10 @@ let rec fetch : type a. a link -> a = | In_cache (_v, Dirty_unknown_schema, _, _) -> invalid_arg "Granular_marshal.fetch: accessing dirty cached value" | Duplicate original_lnk -> fetch original_lnk - | On_disk { store; loc; schema } -> fst (fetch_on_disk lnk store loc schema) + | 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 store, _loc = store_and_loc_of_parent parent in - let smalls = fetch_parent_smalls parent store in + 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 @@ -419,7 +410,8 @@ let rec fetch : type a. a link -> a = | Serialized_reused _ | Serialized_small _ | Small _ - | On_disk_ptr _ -> + | On_disk_ptr _ + | On_disk { schema = None; _ } -> invalid_arg ("Granular_marshal.fetch: accesssing dirty link " ^ string_of_link lnk) @@ -578,7 +570,7 @@ let read filename fd root_schema = let store = { filename; id; cache = Cache_cache.read filename } in let root_loc = int_of_binstring (really_input_string fd 8) in let parent_link = - ref (On_disk { loc = root_loc; store; schema = root_schema }) + 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) From ba731793084efe73eec5e71a3028a33966f41c47 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Jun 2026 17:27:19 +0200 Subject: [PATCH 09/28] Factorize merge_union function --- src/analysis/occurrences.ml | 22 +++++++++------------- src/index-format/index_format.ml | 12 ++++++++++++ src/index-format/index_format.mli | 6 ++++++ src/ocaml-index/lib/index.ml | 21 ++++----------------- 4 files changed, 31 insertions(+), 30 deletions(-) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 8839eddcfa..ca120a8f36 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -224,30 +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 store = ref (Uid_map.empty ()) 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 - store := Union_find.merge !store index.related_uids_store; - Uid_map.union - (fun _ a b -> - let store', v = Union_find.union !store a b in - store := store'; - Some v) - 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 !store |> Uid_set.to_list) + x |> Union_find.get store |> Uid_set.to_list) let find_linked_uids ~config ~scope ~name uid = let title = "find_linked_uids" in diff --git a/src/index-format/index_format.ml b/src/index-format/index_format.ml index 9647dcdc8d..b7dca455b9 100644 --- a/src/index-format/index_format.ml +++ b/src/index-format/index_format.ml @@ -27,6 +27,18 @@ module Union_find = struct 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 () let schema { Granular_marshal.yield } t = diff --git a/src/index-format/index_format.mli b/src/index-format/index_format.mli index a519c88436..1e7cd53fa2 100644 --- a/src/index-format/index_format.mli +++ b/src/index-format/index_format.mli @@ -22,6 +22,12 @@ module Union_find : sig 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 } diff --git a/src/ocaml-index/lib/index.ml b/src/ocaml-index/lib/index.ml index aabc96cd51..2c70482457 100644 --- a/src/ocaml-index/lib/index.ml +++ b/src/ocaml-index/lib/index.ml @@ -165,26 +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 store = - ref (Union_find.merge index.related_uids_store into.related_uids_store) - in - let related_uids = - Uid_map.union - (fun _ a b -> - let store', v = Union_find.union !store a b in - store := store'; - Some v) - 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_store = !store; - 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 = From ebd1f00a42c98f741e0a9b15a8d54a1e30728a1a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Jun 2026 17:41:40 +0200 Subject: [PATCH 10/28] Always upgrade reused links schemas --- src/index-format/granular_marshal.ml | 57 +++++++++++++++------------- 1 file changed, 31 insertions(+), 26 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 5341e61cbc..36f9f3970f 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -239,8 +239,11 @@ let rec disk_to_memory_iter store parent_link = | None -> invalid_arg "Granular_marshal.read_loc: reuse of a different type" ) - | Some _ -> - 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))) @@ -257,30 +260,7 @@ let rec disk_to_memory_iter store parent_link = ) | Some (Link (lnk', None)) -> let lnk' = Obj.magic lnk' in - let () = - (* We might have reused a parent whose schema was initially unknown. - Let's update it. *) - 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 (v, Dirty_unknown_schema, cell, smalls) -> - (* If we already have the value in cache we must clean it. *) - schema (disk_to_memory_iter store (PLink lnk')) v; - lnk' := In_cache (v, Clean, cell, smalls) - | Small _ - | Serialized _ - | Serialized_reused _ - | Serialized_small _ - | On_disk _ - | On_disk_small _ - | On_disk_ptr _ - | In_memory _ - | In_cache (_, _, _, _) - | In_memory_reused _ | Duplicate _ -> assert false - in + upgrade_reused_link_schema lnk' store schema; Cache.replace store.cache loc (Link (lnk', Some type_id)); lnk := Duplicate (normalize lnk') | _ -> lnk := On_disk { store; loc; schema = Some schema }) @@ -310,6 +290,31 @@ let rec disk_to_memory_iter store parent_link = | Duplicate _ -> (* These are already "clean" *) ()) } +(* 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 (v, Dirty_unknown_schema, cell, smalls) -> + (* If we already have the value in cache we must clean it. *) + schema (disk_to_memory_iter store (PLink lnk)) v; + lnk := In_cache (v, Clean, cell, smalls) + | Small _ + | Serialized _ + | Serialized_reused _ + | Serialized_small _ + | On_disk _ + | On_disk_small _ + | On_disk_ptr _ + | In_memory _ + | In_cache (_, _, _, _) + | In_memory_reused _ | Duplicate _ -> assert false + let add_to_cache v lnk ~loc store ~size small_values schema = let discarded = Dbllist.discard_size (get_lru ()) size in let status = if Option.is_none schema then Dirty_unknown_schema else Clean in From a07ff2a345e31145259874f96a6be0cec8c80693 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Jun 2026 18:44:20 +0200 Subject: [PATCH 11/28] Serialized should use the same cache logic as Serialized_reused Before we could rely on deduplicate to flag links worth caching, but now we have both the LRU which could trigger multiple reads to the same loc and the smalls pointing to parents (which are potentially not marked as Serialized_reused) Suggested-by: ArthurW --- src/index-format/granular_marshal.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 36f9f3970f..4b8d50e9df 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -228,9 +228,7 @@ let rec disk_to_memory_iter store parent_link = small_schema = schema; small_pos = pos } - | Serialized { loc } -> - lnk := On_disk { store; loc; schema = Some schema } - | Serialized_reused { loc } -> ( + | Serialized { loc } | Serialized_reused { loc } -> ( 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 From 3b94badba05e26bc444df41bfefbf3e38ce9c8ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Jun 2026 20:11:46 +0200 Subject: [PATCH 12/28] Store info directly in `In_cache` instead of the LRU cell --- src/index-format/granular_marshal.ml | 66 +++++++++++++++------------- 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 4b8d50e9df..ce32599274 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -15,7 +15,7 @@ and any_value = and any_val = V : 'a -> any_val and any_val_link = Vlink : 'a * 'a link -> any_val_link -and cached = Cached : 'a link * int * store * 'a schema option ref -> cached +and cached = Cached : 'a link -> cached and value_status = | Dirty_unknown_schema @@ -77,7 +77,15 @@ and 'a repr = | In_memory_reused of 'a (** {i in-memory} A value that has been created in memory and is used multiple times. *) - | In_cache of 'a * value_status * cached Dbllist.cell * any_value array + | In_cache of + { value : 'a; + status : value_status; + store : store; + loc : int; + schema : 'a schema option ref; + 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. *) @@ -104,7 +112,7 @@ let string_of_link : type a. a link -> string = | Some pos -> Printf.sprintf ", pos=%d" pos | None -> "") | In_memory _ -> "In_memory" - | In_cache (_, status, { content = Cached (_, loc, _, _); _ }, _) -> + | In_cache { status; loc; _ } -> let clean_dirty = match status with | Clean -> "Clean" @@ -298,10 +306,10 @@ and upgrade_reused_link_schema : type a. a link -> store -> a schema -> unit = [On_disc_ptr { pos = Some_; _}] with a parent of unknown schema. *) lnk := On_disk { store; loc; schema = Some schema } - | In_cache (v, Dirty_unknown_schema, cell, smalls) -> + | In_cache ({ value; status = Dirty_unknown_schema; _ } as c) -> (* If we already have the value in cache we must clean it. *) - schema (disk_to_memory_iter store (PLink lnk)) v; - lnk := In_cache (v, Clean, cell, smalls) + schema (disk_to_memory_iter store (PLink lnk)) value; + lnk := In_cache { c with status = Clean } | Small _ | Serialized _ | Serialized_reused _ @@ -310,21 +318,25 @@ and upgrade_reused_link_schema : type a. a link -> store -> a schema -> unit = | On_disk_small _ | On_disk_ptr _ | In_memory _ - | In_cache (_, _, _, _) - | In_memory_reused _ | Duplicate _ -> assert false + | In_cache _ + | In_memory_reused _ + | Duplicate _ -> assert false -let add_to_cache v lnk ~loc store ~size small_values schema = +let add_to_cache value lnk ~loc store ~size small_values schema = let discarded = Dbllist.discard_size (get_lru ()) size in let status = if Option.is_none schema then Dirty_unknown_schema else Clean in - let cell = - Dbllist.add_front (get_lru ()) (Cached (lnk, loc, store, ref schema), size) - in + let cell = Dbllist.add_front (get_lru ()) (Cached lnk, size) in List.iter - (fun (Cached (link, loc, store, schema)) -> + (fun (Cached link) -> (* This also free the smalls that are stored in the link *) - link := On_disk { store; loc; schema = !schema }) + match !link with + | In_cache { loc; store; schema; _ } -> + link := On_disk { store; loc; schema = !schema } + | _ -> assert false) discarded; - lnk := In_cache (v, status, cell, small_values) + lnk := + In_cache + { value; status; loc; store; schema = ref schema; cell; small_values } (** Read one value and its smalls from the disk. *) let read_loc_dirty fd loc = @@ -359,8 +371,7 @@ let fetch_on_disk_dirty lnk store loc = (* 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_cache (_, _, { content = Cached (_, loc, store, _); _ }, _) - | On_disk { store; loc; _ } -> (store, loc) + | In_cache { store; loc; _ } | On_disk { store; loc; _ } -> (store, loc) | _ -> invalid_arg ("Granular_marshal.fetch_parent: Unexpected parent link " @@ -372,10 +383,9 @@ let store_and_loc_of_parent (PLink lnk : parent_link) = let fetch_parent_smalls : parent_link -> any_value array * store = fun (PLink parent_link) -> match !parent_link with - | In_cache (_, _, cell, smalls) -> - let { content = Cached (_, _, store, _); _ } = cell in + | In_cache { store; cell; small_values; _ } -> Dbllist.promote (get_lru ()) cell; - (smalls, store) + (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 } -> @@ -388,10 +398,10 @@ let fetch_parent_smalls : parent_link -> any_value array * store = let rec fetch : type a. a link -> a = fun lnk -> match !lnk with - | In_cache (v, Clean, cell, _) -> + | In_cache { value; status = Clean; cell; _ } -> Dbllist.promote (get_lru ()) cell; - v - | In_cache (_v, Dirty_unknown_schema, _, _) -> + value + | In_cache { status = Dirty_unknown_schema; _ } -> invalid_arg "Granular_marshal.fetch: accessing dirty cached value" | Duplicate original_lnk -> fetch original_lnk | On_disk { store; loc; schema = Some schema } -> @@ -481,19 +491,15 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = write_child_reused original_lnk schema v; lnk := !original_lnk | On_disk { store = { filename; id; _ }; loc; _ } - | In_cache - ( _, - _, - { content = Cached (_, loc, { filename; id; _ }, _); _ }, - _ ) -> lnk := On_disk_ptr { filename; id; loc; pos = None } + | In_cache { loc; store = { filename; id; _ }; _ } -> + lnk := On_disk_ptr { filename; id; loc; pos = None } | _ -> 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 (_v, _, t, _children) -> - let (Cached (_, loc, { filename; id; _ }, _)) = t.content in + | In_cache { loc; store = { filename; id; _ }; _ } -> let filename = relativize filename in lnk := On_disk_ptr { filename; id; loc; pos = None } | On_disk { store = { filename; id; _ }; loc; _ } -> From 5cbfbd0ac45aca1916e0b89cd54c7a72d2ce35ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 30 Jun 2026 14:20:21 +0200 Subject: [PATCH 13/28] Use kb for chache size flag, default to 1gb --- src/ocaml-index/bin/ocaml_index.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/ocaml-index/bin/ocaml_index.ml b/src/ocaml-index/bin/ocaml_index.ml index 6fcde8e409..85427db12f 100644 --- a/src/ocaml-index/bin/ocaml_index.ml +++ b/src/ocaml-index/bin/ocaml_index.ml @@ -14,7 +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 = ref 1_000_000 +let cache_size_kb = ref 1_000_000 type command = Aggregate | Dump | Stats @@ -69,8 +69,9 @@ let speclist = "Do not initialize the load path with the paths found in the first input \ cmt file" ); ( "--cache-size", - Arg.Set_int cache_size, - "Set LRU cache size. Will bound memory usage in read-heavy scenarios." ) + Arg.Set_int cache_size_kb, + "Set LRU cache size in kb. Will bound memory usage in read-heavy \ + scenarios." ) ] let set_log_level debug verbose = @@ -81,7 +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; + Granular_marshal.set_lru_size (!cache_size_kb * 1000); try (match !command with | Some Aggregate -> From d8c93313ff245de861fcf42f6d5d2aab3cd52f48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 14:55:32 +0200 Subject: [PATCH 14/28] Remove todo --- src/index-format/union_find.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/index-format/union_find.ml b/src/index-format/union_find.ml index e15bae3607..2dd2a49f8c 100644 --- a/src/index-format/union_find.ml +++ b/src/index-format/union_find.ml @@ -68,7 +68,6 @@ let union ~f store x y = | Link _, Root _ | Root _, Link _ | Link _, Link _ -> assert false let merge ~f (s1 : 'a store) (s2 : 'a store) = - (* TODO there is similar logic in [index.ml] *) let ensure store uid = if Uid_map.mem uid store then store else From bc9c08ef2d0091d1d01fff02d914da2e98b842fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 14:56:30 +0200 Subject: [PATCH 15/28] Document default cache size --- src/ocaml-index/bin/ocaml_index.ml | 2 +- src/ocaml-index/tests/tests-dirs/cmd.t | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ocaml-index/bin/ocaml_index.ml b/src/ocaml-index/bin/ocaml_index.ml index 85427db12f..4aca932bdd 100644 --- a/src/ocaml-index/bin/ocaml_index.ml +++ b/src/ocaml-index/bin/ocaml_index.ml @@ -71,7 +71,7 @@ let speclist = ( "--cache-size", Arg.Set_int cache_size_kb, "Set LRU cache size in kb. Will bound memory usage in read-heavy \ - scenarios." ) + scenarios. Defaults to 1_000_000 (1gb)" ) ] let set_log_level debug verbose = diff --git a/src/ocaml-index/tests/tests-dirs/cmd.t b/src/ocaml-index/tests/tests-dirs/cmd.t index 9f55870cce..935cb278e9 100644 --- a/src/ocaml-index/tests/tests-dirs/cmd.t +++ b/src/ocaml-index/tests/tests-dirs/cmd.t @@ -1,7 +1,7 @@ $ ocaml-index aggregate $ ocaml-index aggregate --debug [debug] Debug log is enabled - total_cap : 1000000 + total_cap : 1000000000 size : 0 promote_count : 0 add_count : 0 @@ -21,6 +21,6 @@ -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. Will bound memory usage in read-heavy scenarios. + --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 From ba39e1e9e89eb6cf0d65c0cddf2967aa69529df7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 15:04:44 +0200 Subject: [PATCH 16/28] find_and_wompress: directly return the root --- src/index-format/union_find.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/index-format/union_find.ml b/src/index-format/union_find.ml index 2dd2a49f8c..2af88c4b25 100644 --- a/src/index-format/union_find.ml +++ b/src/index-format/union_find.ml @@ -14,14 +14,15 @@ let new_root store uid value = let rec find_and_compress store uid = match Uid_map.find uid store with - | Root _ -> (store, uid) + | Root _ as root -> (store, uid, root) | Link parent -> - let store, root = find_and_compress store parent in + 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 then store else Uid_map.add uid (Link root) store + if Uid.equal parent root_uid then store + else Uid_map.add uid (Link root_uid) store in - (store, root) + (store, root_uid, root) let rec find store uid = match Uid_map.find uid store with @@ -35,11 +36,11 @@ let get store uid = | Link _ -> assert false let union ~f store x y = - let store, x = find_and_compress store x in - let store, y = find_and_compress store y in + 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 (Uid_map.find x store, Uid_map.find y store) with + 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 From daf5b2ab928e5292363254d590075ddc397f8549 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 15:09:47 +0200 Subject: [PATCH 17/28] Union_find.union, no need for a new link --- src/index-format/index_format.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/index-format/index_format.ml b/src/index-format/index_format.ml index b7dca455b9..d8903594a2 100644 --- a/src/index-format/index_format.ml +++ b/src/index-format/index_format.ml @@ -20,10 +20,10 @@ module Union_find = struct let union store a b = let open Granular_marshal in - let store, root = + let store, _root = Union_find.union store ~f:Uid_set.union (fetch a) (fetch b) in - (store, link root) + (store, a) let merge = Union_find.merge ~f:Uid_set.union From 50cd87a450acbad3ef7d1e9e939eb268f297deb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 15:35:13 +0200 Subject: [PATCH 18/28] Make the union find store more granular. This required removing a fast-path in Union_find.union that was relying on polymorphic comparison. I it turns out to be important we can add an equal function to granular set. --- src/index-format/index_format.ml | 10 +++++++--- src/index-format/index_format.mli | 2 +- src/index-format/union_find.ml | 12 ++++-------- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/index-format/index_format.ml b/src/index-format/index_format.ml index d8903594a2..ba3c49f6fe 100644 --- a/src/index-format/index_format.ml +++ b/src/index-format/index_format.ml @@ -4,7 +4,7 @@ module Lid = Lid module Lid_set = Granular_set.Make (Lid) 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.elt_handle Granular_marshal.link @@ -65,6 +65,8 @@ type index = } 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 () @@ -81,7 +83,9 @@ let index_schema (iter : Granular_marshal.iter) index = (fun iter _ v -> Union_find.schema iter v) index.related_uids; Uid_map.schema type_ufstore iter - (fun _iter _uid _content -> ()) + (fun iter _uid -> function + | Link _ -> () + | Root { value; _ } -> uidset_schema iter value) index.related_uids_store let compress index = @@ -122,7 +126,7 @@ let pp_related_uids (related_uids_store : Union_find.store) let rec gather acc map = match Uid_map.choose_opt map with | Some (_key, union) -> - let group = Union_find.get related_uids_store 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 diff --git a/src/index-format/index_format.mli b/src/index-format/index_format.mli index 1e7cd53fa2..1541f20619 100644 --- a/src/index-format/index_format.mli +++ b/src/index-format/index_format.mli @@ -10,7 +10,7 @@ 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 diff --git a/src/index-format/union_find.ml b/src/index-format/union_find.ml index 2af88c4b25..fc626f4a9d 100644 --- a/src/index-format/union_find.ml +++ b/src/index-format/union_find.ml @@ -46,18 +46,14 @@ let union ~f store x y = let value = f value_x value_y in if rank_x < rank_y then let store = - let s = Uid_map.add x (Link y) store in - if value <> value_y then - Uid_map.add y (Root { value; rank = rank_y }) s - else s + 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 = - let s = Uid_map.add y (Link x) store in - if value <> value_x then - Uid_map.add x (Root { value; rank = rank_x }) s - else s + Uid_map.add y (Link x) store + |> Uid_map.add x (Root { value; rank = rank_x }) in (store, x) else From 69afef57a81fa418e0a55eaca386701c11beccb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 15:54:13 +0200 Subject: [PATCH 19/28] Add missing cache use --- src/index-format/granular_marshal.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index ce32599274..2898f8d8df 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -269,7 +269,9 @@ let rec disk_to_memory_iter store parent_link = upgrade_reused_link_schema lnk' store schema; Cache.replace store.cache loc (Link (lnk', Some type_id)); lnk := Duplicate (normalize lnk') - | _ -> lnk := On_disk { store; loc; schema = Some schema }) + | None -> + lnk := On_disk { store; loc; schema = Some schema }; + Cache.add store.cache loc (Link (lnk, Some type_id))) | On_disk_ptr { filename; loc; id; pos = Some small_pos } -> let filename = resolve_filename store ~filename in let store = { filename; id; cache = Cache_cache.read filename } in From d9e1c02a2957a609a1eb0f4098a26e32d960d578 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 16:01:17 +0200 Subject: [PATCH 20/28] Factor out the cache logic --- src/index-format/granular_marshal.ml | 59 ++++++++++++---------------- 1 file changed, 25 insertions(+), 34 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 2898f8d8df..57632ca17a 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -236,42 +236,12 @@ let rec disk_to_memory_iter store parent_link = small_schema = schema; small_pos = pos } - | Serialized { loc } | Serialized_reused { loc } -> ( - 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))) - | On_disk_ptr { filename; loc; id; pos = None } -> ( + | Serialized { loc } | Serialized_reused { loc } -> + maybe_reuse_or_upgrade lnk store loc type_id schema + | On_disk_ptr { filename; loc; id; pos = None } -> let filename = resolve_filename store ~filename in let store = { filename; id; cache = Cache_cache.read filename } in - 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))) + maybe_reuse_or_upgrade lnk store loc type_id schema | On_disk_ptr { filename; loc; id; pos = Some small_pos } -> let filename = resolve_filename store ~filename in let store = { filename; id; cache = Cache_cache.read filename } in @@ -298,6 +268,27 @@ let rec disk_to_memory_iter store parent_link = | 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 = From b80cfc744a1d270c645a267266f2807ff2360329 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 16:13:49 +0200 Subject: [PATCH 21/28] Also skip smalls that have already been skipped --- src/index-format/granular_marshal.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 57632ca17a..95ebbfc1a4 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -511,7 +511,7 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = List.filter (fun (Vlink (_v, lnk)) -> match !lnk with - | On_disk_ptr { pos = Some _; _ } -> + | On_disk_ptr { pos = Some _; _ } | Serialized_small _ -> (* This small has already been serialized by another owner *) false | _ -> true) small_children From 5a288d99ec023bcfa102271bde946f827b8539af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 Jul 2026 16:30:52 +0200 Subject: [PATCH 22/28] Remove unused Serialized_reused --- src/index-format/granular_marshal.ml | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 95ebbfc1a4..3a73d473dd 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -49,9 +49,6 @@ and 'a repr = *) | Serialized of { loc : int } (** {i on-disk} A pointer to a serialized value in the file. *) - | Serialized_reused of { loc : int } - (** {i on-disk} A pointer to serialized value that is used multiple times. - Allow for better file compression and perofrmance. *) | 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. *) @@ -100,7 +97,6 @@ let string_of_link : type a. a link -> string = match !link with | Small _ -> Printf.sprintf "Small" | Serialized { loc } -> Printf.sprintf "Serialized(loc=%d)" loc - | Serialized_reused { loc } -> Printf.sprintf "Serialized_reused(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 @@ -236,7 +232,7 @@ let rec disk_to_memory_iter store parent_link = small_schema = schema; small_pos = pos } - | Serialized { loc } | Serialized_reused { loc } -> + | Serialized { loc } -> maybe_reuse_or_upgrade lnk store loc type_id schema | On_disk_ptr { filename; loc; id; pos = None } -> let filename = resolve_filename store ~filename in @@ -305,7 +301,6 @@ and upgrade_reused_link_schema : type a. a link -> store -> a schema -> unit = lnk := In_cache { c with status = Clean } | Small _ | Serialized _ - | Serialized_reused _ | Serialized_small _ | On_disk _ | On_disk_small _ @@ -413,7 +408,6 @@ let rec fetch : type a. a link -> a = v) | In_memory v | In_memory_reused v -> v | Serialized _ - | Serialized_reused _ | Serialized_small _ | Small _ | On_disk_ptr _ @@ -471,7 +465,6 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = (fun (type a) (lnk : a link) _type_id (schema : a schema) : unit -> match !lnk with | Serialized _ - | Serialized_reused _ | Serialized_small _ | Small _ | On_disk_ptr _ -> () @@ -553,7 +546,7 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = and write_child_reused : type a. a link -> a schema -> a -> unit = fun lnk schema v -> let _v_size, v_smalls = write_children schema v in - lnk := Serialized_reused { loc = pos_out fd }; + lnk := Serialized { loc = pos_out fd }; output_and_mark (V v) v_smalls in let _, root_value_smalls = write_children root_schema root_value in From 7b8bf4c17704a117371c37c56af86673d90ac53f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 7 Jul 2026 11:20:41 +0200 Subject: [PATCH 23/28] Remove remaining occurrence of Serialized_reused --- src/index-format/granular_marshal.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 3a73d473dd..9595ee779d 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -471,7 +471,7 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = | In_memory_reused v -> write_child_reused lnk schema v | Duplicate original_lnk -> ( match !original_lnk with - | Serialized_reused _ | Serialized_small _ | On_disk_ptr _ -> + | Serialized _ | Serialized_small _ | On_disk_ptr _ -> lnk := !original_lnk | In_memory_reused v -> write_child_reused original_lnk schema v; From 83029147bd5843a036965b57adba4ce861b7dc44 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 7 Jul 2026 11:21:09 +0200 Subject: [PATCH 24/28] Split On_disk_ptr in two to better distinguish smalls --- src/index-format/granular_marshal.ml | 30 +++++++++++++++------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 9595ee779d..457aa90ce0 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -54,9 +54,10 @@ and 'a repr = 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; pos : int option } + | 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 *) @@ -102,11 +103,9 @@ let string_of_link : type a. a link -> string = 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; pos; _ } -> - Printf.sprintf "On_disk_ptr(loc=%d%s)" loc - (match pos with - | Some pos -> Printf.sprintf ", pos=%d" pos - | None -> "") + | 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 { status; loc; _ } -> let clean_dirty = @@ -234,11 +233,11 @@ let rec disk_to_memory_iter store parent_link = } | Serialized { loc } -> maybe_reuse_or_upgrade lnk store loc type_id schema - | On_disk_ptr { filename; loc; id; pos = None } -> + | 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_ptr { filename; loc; id; pos = Some small_pos } -> + | 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 = @@ -305,6 +304,7 @@ and upgrade_reused_link_schema : type a. a link -> store -> a schema -> unit = | On_disk _ | On_disk_small _ | On_disk_ptr _ + | On_disk_small_ptr _ | In_memory _ | In_cache _ | In_memory_reused _ @@ -411,6 +411,7 @@ let rec fetch : type a. a link -> a = | 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) @@ -467,7 +468,8 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = | Serialized _ | Serialized_small _ | Small _ - | On_disk_ptr _ -> () + | On_disk_ptr _ + | On_disk_small_ptr _ -> () | In_memory_reused v -> write_child_reused lnk schema v | Duplicate original_lnk -> ( match !original_lnk with @@ -478,7 +480,7 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = lnk := !original_lnk | On_disk { store = { filename; id; _ }; loc; _ } | In_cache { loc; store = { filename; id; _ }; _ } -> - lnk := On_disk_ptr { filename; id; loc; pos = None } + lnk := On_disk_ptr { filename; id; loc } | _ -> failwith (Format.sprintf @@ -487,16 +489,16 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = | 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; pos = None } + lnk := On_disk_ptr { filename; id; loc } | On_disk { store = { 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; pos = None } + 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_ptr { filename; id; loc; pos = Some small_pos }) + 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 = @@ -504,7 +506,7 @@ let write ?(flags = []) fd ~filename ~id root_schema root_value = List.filter (fun (Vlink (_v, lnk)) -> match !lnk with - | On_disk_ptr { pos = Some _; _ } | Serialized_small _ -> + | On_disk_small_ptr _ | Serialized_small _ -> (* This small has already been serialized by another owner *) false | _ -> true) small_children From 50c0ad2325d73f484b7f2468dfcb09ca3d375939 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 9 Jul 2026 16:50:34 +0200 Subject: [PATCH 25/28] Push missing fix --- src/analysis/occurrences.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index ca120a8f36..55da99643c 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -243,7 +243,7 @@ let lookup_related_uids_in_indexes ~(config : Mconfig.t) uid = in Uid_map.find_opt uid related_uids |> Option.value_map ~default:[] ~f:(fun x -> - x |> Union_find.get store |> 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 From f5205a0350487067bd08277f5d161f478db13467 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 9 Jul 2026 16:51:01 +0200 Subject: [PATCH 26/28] Fix Union_find.merge in the general case --- src/index-format/union_find.ml | 9 ++++++--- .../test-units/union_find/union_find_test.ml | 19 ++++++++++++++++++- 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/src/index-format/union_find.ml b/src/index-format/union_find.ml index fc626f4a9d..717e0ca05a 100644 --- a/src/index-format/union_find.ml +++ b/src/index-format/union_find.ml @@ -66,10 +66,13 @@ let union ~f store x y = let merge ~f (s1 : 'a store) (s2 : 'a store) = let ensure store uid = - if Uid_map.mem uid store then store + let value = get s2 uid in + if not (Uid_map.mem uid store) then fst (new_root store uid value) else - match Uid_map.find (find s2 uid) s2 with - | Root { value; _ } -> fst (new_root store uid value) + let store, root, content = find_and_compress store uid in + match content with + | Root { value = v0; rank } -> + Uid_map.add root (Root { value = f v0 value; rank }) store | Link _ -> assert false in Uid_map.fold diff --git a/tests/test-units/union_find/union_find_test.ml b/tests/test-units/union_find/union_find_test.ml index 037b370627..6c381b0523 100644 --- a/tests/test-units/union_find/union_find_test.ml +++ b/tests/test-units/union_find/union_find_test.ml @@ -64,13 +64,30 @@ let disjoint_merge () = "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 "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 ] From 844955d6bc9e15d34a8a71e55d29bb941f597c59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 9 Jul 2026 16:59:26 +0200 Subject: [PATCH 27/28] In_cache: remove redundant status field --- src/index-format/granular_marshal.ml | 32 ++++++++++------------------ 1 file changed, 11 insertions(+), 21 deletions(-) diff --git a/src/index-format/granular_marshal.ml b/src/index-format/granular_marshal.ml index 457aa90ce0..aa1bffe1f4 100644 --- a/src/index-format/granular_marshal.ml +++ b/src/index-format/granular_marshal.ml @@ -17,12 +17,6 @@ and any_val_link = Vlink : 'a * 'a link -> any_val_link and cached = Cached : 'a link -> cached -and value_status = - | Dirty_unknown_schema - (** Marks a value that has not been cleaned yet. Usually because its - schema was unknown when it was read from the disk for its smalls. *) - | Clean - and 'a link = 'a repr ref (** Links descriptions. @@ -77,10 +71,9 @@ and 'a repr = multiple times. *) | In_cache of { value : 'a; - status : value_status; store : store; loc : int; - schema : 'a schema option ref; + mutable schema : 'a schema option; cell : cached Dbllist.cell; small_values : any_value array } @@ -107,11 +100,11 @@ let string_of_link : type a. a link -> string = | On_disk_small_ptr { loc; pos; _ } -> Printf.sprintf "On_disk_ptr(loc=%d, pos=%d)" loc pos | In_memory _ -> "In_memory" - | In_cache { status; loc; _ } -> + | In_cache { schema; loc; _ } -> let clean_dirty = - match status with - | Clean -> "Clean" - | Dirty_unknown_schema -> "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" @@ -294,10 +287,10 @@ and upgrade_reused_link_schema : type a. a link -> store -> a schema -> unit = [On_disc_ptr { pos = Some_; _}] with a parent of unknown schema. *) lnk := On_disk { store; loc; schema = Some schema } - | In_cache ({ value; status = Dirty_unknown_schema; _ } as c) -> + | 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; - lnk := In_cache { c with status = Clean } + c.schema <- Some schema | Small _ | Serialized _ | Serialized_small _ @@ -312,19 +305,16 @@ and upgrade_reused_link_schema : type a. a link -> store -> a schema -> unit = let add_to_cache value lnk ~loc store ~size small_values schema = let discarded = Dbllist.discard_size (get_lru ()) size in - let status = if Option.is_none schema then Dirty_unknown_schema else Clean 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 = !schema } + link := On_disk { store; loc; schema } | _ -> assert false) discarded; - lnk := - In_cache - { value; status; loc; store; schema = ref schema; cell; small_values } + 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 = @@ -386,10 +376,10 @@ let fetch_parent_smalls : parent_link -> any_value array * store = let rec fetch : type a. a link -> a = fun lnk -> match !lnk with - | In_cache { value; status = Clean; cell; _ } -> + | In_cache { value; schema = Some _; cell; _ } -> Dbllist.promote (get_lru ()) cell; value - | In_cache { status = Dirty_unknown_schema; _ } -> + | 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 } -> From ee42496b928be833b17554588f25ee4a9bb6aa37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 9 Jul 2026 17:03:31 +0200 Subject: [PATCH 28/28] Refactor Union_find.merge --- src/index-format/union_find.ml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/index-format/union_find.ml b/src/index-format/union_find.ml index 717e0ca05a..49dcdff4c0 100644 --- a/src/index-format/union_find.ml +++ b/src/index-format/union_find.ml @@ -67,13 +67,11 @@ let union ~f store x y = let merge ~f (s1 : 'a store) (s2 : 'a store) = let ensure store uid = let value = get s2 uid in - if not (Uid_map.mem uid store) then fst (new_root store uid value) - else - let store, root, content = find_and_compress store uid in - match content with - | Root { value = v0; rank } -> - Uid_map.add root (Root { value = f v0 value; rank }) store - | Link _ -> assert false + 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 ->