From 5aa0b30e07a5e24e08ae48a89e55dff47c55c4ae Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Fri, 2 Oct 2026 09:48:26 -0700 Subject: [PATCH] feat: upsert modified stored nodes in place like cljs Match the cljs persistent-sorted-set storage semantics: a modified stored node keeps its previous address and is rewritten in place (IStorage.store with the node's _address), instead of allocating a fresh address and orphaning the superseded row. - storage.store_node takes ?address for the in-place rewrite - Leaf/Branch nodes carry a dirty flag; restored nodes start clean - 1->1 replacement inherits the node address; split keeps it on the first output; merge keeps the left operand's address; borrow keeps each slot's own address - store() on an unmodified stored set still writes nothing Verified against cljs persistent-sorted-set 0.1.2 (jar from org.clojars.tiensonqin) running the same add/remove/store scenarios: root address stays stable, merge keeps the left address and drops the right (we orphan the row instead of deleting it), split gives the first output the old address. --- bench/bench_pss.ml | 6 +- lib/persistent_sorted_set.ml | 266 +++++++++++++++++++--------- lib/persistent_sorted_set.mli | 5 +- test/js_memory_test.ml | 4 +- test/js_smoke.ml | 4 +- test/melange_storage_smoke.ml | 4 +- test/test_persistent_sorted_set.ml | 267 ++++++++++++++--------------- 7 files changed, 330 insertions(+), 226 deletions(-) diff --git a/bench/bench_pss.ml b/bench/bench_pss.ml index 37871a7..0badf83 100644 --- a/bench/bench_pss.ml +++ b/bench/bench_pss.ml @@ -116,9 +116,9 @@ let build_storage () = let next_address = ref 0 in { store_node = - (fun node -> + (fun ?address:given_address node -> incr next_address; - let address = "node-" ^ string_of_int !next_address in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !next_address in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -150,7 +150,7 @@ let restored_wide_4096 = let storage = { store_node = - (fun _ -> invalid_arg "wide benchmark storage is read-only"); + (fun ?address:_ _ -> invalid_arg "wide benchmark storage is read-only"); restore_node = (fun address -> Hashtbl.find_opt memory address); accessed = (fun _ -> ()); } diff --git a/lib/persistent_sorted_set.ml b/lib/persistent_sorted_set.ml index d238b80..c7180d6 100644 --- a/lib/persistent_sorted_set.ml +++ b/lib/persistent_sorted_set.ml @@ -4,7 +4,7 @@ type settings = { branching_factor : int; ref_type : ref_type } type 'a stored_node = Leaf of 'a array | Branch of 'a array * string array type 'a storage = { - store_node : 'a stored_node -> string; + store_node : ?address:string -> 'a stored_node -> string; restore_node : string -> 'a stored_node option; accessed : string -> unit; } @@ -12,11 +12,17 @@ type 'a storage = { module Node = struct type 'a t = | Ref of { max_key : 'a; address : string } - | Leaf of { values : 'a array; len : int; address : string option } + | Leaf of { + values : 'a array; + len : int; + address : string option; + dirty : bool; + } | Branch of { keys : 'a array; children : 'a t array; address : string option; + dirty : bool; } end @@ -74,8 +80,8 @@ let cache_storage settings storage = let cache = Hashtbl.create 128 in { store_node = - (fun node -> - let address = storage.store_node node in + (fun ?address node -> + let address = storage.store_node ?address node in Hashtbl.replace cache address node; address); restore_node = @@ -94,8 +100,8 @@ let cache_storage settings storage = let cache = Hashtbl.create 128 in { store_node = - (fun node -> - let address = storage.store_node node in + (fun ?address node -> + let address = storage.store_node ?address node in remember cache address node; address); restore_node = @@ -232,13 +238,13 @@ let show_node show_value root = add_line depth (Printf.sprintf "Ref(address=%s max_key=%s)" address (show_value max_key)) - | Node.Leaf { values; len; address } -> + | Node.Leaf { values; len; address; _ } -> add_line depth (Printf.sprintf "Leaf(address=%s len=%d values=%s)" (show_option_address address) len (show_list show_value (array_prefix_to_list values len))) - | Node.Branch { keys; children; address } -> + | Node.Branch { keys; children; address; _ } -> add_line depth (Printf.sprintf "Branch(address=%s keys=%s)" (show_option_address address) @@ -273,6 +279,7 @@ let node_branch_of_refs refs = keys = Array.of_list keys; children = Array.of_list children; address = None; + dirty = true; } let node_leaf_refs_of_chunks chunks = @@ -280,7 +287,13 @@ let node_leaf_refs_of_chunks chunks = |> List.map (fun chunk -> let values = Array.of_list chunk in ( values.(Array.length values - 1), - Node.Leaf { values; len = Array.length values; address = None } )) + Node.Leaf + { + values; + len = Array.length values; + address = None; + dirty = true; + } )) let rec node_of_refs settings = function | [] -> None @@ -333,25 +346,34 @@ let array_split values = Array.sub values left_length (length - left_length); ] -let tree_leaf_refs_of_arrays arrays = +(* cljs persistent-sorted-set keeps the previous storage address on a + modified node and re-stores it in place: the first replacement node + inherits [first_address], additional nodes get fresh addresses. *) +let tree_leaf_refs_of_arrays ?first_address arrays = arrays - |> List.map (fun values -> + |> List.mapi (fun index values -> + let address = if index = 0 then first_address else None in ( values.(Array.length values - 1), - Node.Leaf { values; len = Array.length values; address = None } )) + Node.Leaf + { values; len = Array.length values; address; dirty = true } )) -let tree_branch_refs_of_arrays settings keys children = +let tree_branch_refs_of_arrays ?first_address settings keys children = let length = Array.length keys in if length = 0 then [] else if length <= settings.branching_factor then - [ (keys.(length - 1), Node.Branch { keys; children; address = None }) ] + [ + ( keys.(length - 1), + Node.Branch { keys; children; address = first_address; dirty = true } ); + ] else let key_chunks = array_split keys in let child_chunks = array_split children in - List.map2 - (fun keys children -> + List.mapi + (fun index (keys, children) -> + let address = if index = 0 then first_address else None in ( keys.(Array.length keys - 1), - Node.Branch { keys; children; address = None } )) - key_chunks child_chunks + Node.Branch { keys; children; address; dirty = true } )) + (List.combine key_chunks child_chunks) let ref_arrays_of_list refs = let keys, children = List.split refs in @@ -388,12 +410,12 @@ let branch_splice_one keys children index replacement = (length - index - 1); (result_keys, result_children) -let branch_replace_one settings keys children index key child = +let branch_replace_one settings ?address keys children index key child = let keys = Array.copy keys in let children = Array.copy children in keys.(index) <- key; children.(index) <- child; - tree_branch_refs_of_arrays settings keys children + tree_branch_refs_of_arrays ?first_address:address settings keys children let min_child_occupancy settings = max 1 ((settings.branching_factor + 1) / 2) @@ -408,17 +430,21 @@ let array_append left right = Array.blit right 0 result left_length right_length; result -let leaf_ref values = +let leaf_ref ?address values = if Array.length values = 0 then invalid_arg "leaf ref requires values"; ( values.(Array.length values - 1), - Node.Leaf { values; len = Array.length values; address = None } ) + Node.Leaf { values; len = Array.length values; address; dirty = true } ) -let branch_ref keys children = +let branch_ref ?address keys children = let length = Array.length keys in if length = 0 then invalid_arg "branch ref requires keys"; if length <> Array.length children then invalid_arg "branch keys and children arity mismatch"; - (keys.(length - 1), Node.Branch { keys; children; address = None }) + (keys.(length - 1), Node.Branch { keys; children; address; dirty = true }) + +let node_address = function + | Node.Ref { address; _ } -> Some address + | Node.Leaf { address; _ } | Node.Branch { address; _ } -> address let total_cmp order_cmp equality_cmp left right = match order_cmp left right with 0 -> equality_cmp left right | n -> n @@ -499,12 +525,19 @@ let node_of_stored_branch keys child_addresses address = Node.Ref { max_key = key; address = child_address }) child_addresses in - Node.Branch { keys = Array.copy keys; children; address = Some address } + Node.Branch + { keys = Array.copy keys; children; address = Some address; dirty = false } let node_of_stored_node storage address = match restore_stored_node storage address with | Leaf values -> - Node.Leaf { values; len = Array.length values; address = Some address } + Node.Leaf + { + values; + len = Array.length values; + address = Some address; + dirty = false; + } | Branch (keys, child_addresses) -> node_of_stored_branch keys child_addresses address @@ -533,18 +566,18 @@ let node_branch_parts storage = function | Node.Ref _ | Node.Leaf _ -> None) | Node.Leaf _ -> None -let add_leaf_refs settings inserted = +let add_leaf_refs settings ?address inserted = let changed = if Array.length inserted <= settings.branching_factor then [ inserted ] else array_split inserted in - tree_leaf_refs_of_arrays changed + tree_leaf_refs_of_arrays ?first_address:address changed -let branch_refs_of_arrays settings keys children = - tree_branch_refs_of_arrays settings keys children +let branch_refs_of_arrays ?first_address settings keys children = + tree_branch_refs_of_arrays ?first_address settings keys children -let branch_replace_range settings keys children start remove_count replacements - = +let branch_replace_range settings ?first_address keys children start + remove_count replacements = let refs = ref [] in for index = Array.length children - 1 downto 0 do if index = start then refs := replacements @ !refs; @@ -552,9 +585,10 @@ let branch_replace_range settings keys children start remove_count replacements refs := (keys.(index), children.(index)) :: !refs done; let keys, children = ref_arrays_of_list !refs in - branch_refs_of_arrays settings keys children + branch_refs_of_arrays ?first_address settings keys children -let rebalance_leaf_child storage settings keys children index child = +let rebalance_leaf_child storage settings ?address keys children index child + = match node_leaf_values storage child with | None -> None | Some values -> ( @@ -573,8 +607,13 @@ let rebalance_leaf_child storage settings keys children index child = if combined_length <= settings.branching_factor then let merged = array_append values right in Some - (branch_replace_range settings keys children index 2 - [ leaf_ref merged ]) + (branch_replace_range settings ?first_address:address keys + children index 2 + [ + leaf_ref + ?address:(node_address children.(index)) + merged; + ]) else let needed = minimum - Array.length values in if needed <= 0 || Array.length right - needed < minimum then @@ -586,8 +625,16 @@ let rebalance_leaf_child storage settings keys children index child = Array.sub right needed (Array.length right - needed) in Some - (branch_replace_range settings keys children index 2 - [ leaf_ref left; leaf_ref right ]) + (branch_replace_range settings ?first_address:address + keys children index 2 + [ + leaf_ref + ?address:(node_address children.(index)) + left; + leaf_ref + ?address:(node_address children.(index + 1)) + right; + ]) in let rebalance_with_left () = if index = 0 then None @@ -599,8 +646,15 @@ let rebalance_leaf_child storage settings keys children index child = if combined_length <= settings.branching_factor then let merged = array_append left values in Some - (branch_replace_range settings keys children (index - 1) 2 - [ leaf_ref merged ]) + (branch_replace_range settings ?first_address:address keys + children + (index - 1) + 2 + [ + leaf_ref + ?address:(node_address children.(index - 1)) + merged; + ]) else let needed = minimum - Array.length values in if needed <= 0 || Array.length left - needed < minimum then @@ -611,14 +665,25 @@ let rebalance_leaf_child storage settings keys children index child = let left = Array.sub left 0 left_keep in let right = array_append borrowed values in Some - (branch_replace_range settings keys children (index - 1) 2 - [ leaf_ref left; leaf_ref right ]) + (branch_replace_range settings ?first_address:address + keys children + (index - 1) + 2 + [ + leaf_ref + ?address:(node_address children.(index - 1)) + left; + leaf_ref + ?address:(node_address children.(index)) + right; + ]) in match rebalance_with_right () with | Some changed -> Some changed | None -> rebalance_with_left ()) -let rebalance_branch_child storage settings keys children index child = +let rebalance_branch_child storage settings ?address keys children index + child = match node_branch_parts storage child with | None -> None | Some (child_keys, child_children) -> ( @@ -640,8 +705,13 @@ let rebalance_branch_child storage settings keys children index child = array_append child_children right_children in Some - (branch_replace_range settings keys children index 2 - [ branch_ref merged_keys merged_children ]) + (branch_replace_range settings ?first_address:address keys + children index 2 + [ + branch_ref + ?address:(node_address children.(index)) + merged_keys merged_children; + ]) else let needed = minimum - Array.length child_keys in if needed <= 0 || Array.length right_keys - needed < minimum @@ -662,10 +732,15 @@ let rebalance_branch_child storage settings keys children index child = (Array.length right_children - needed) in Some - (branch_replace_range settings keys children index 2 + (branch_replace_range settings ?first_address:address + keys children index 2 [ - branch_ref left_keys left_children; - branch_ref right_keys right_children; + branch_ref + ?address:(node_address children.(index)) + left_keys left_children; + branch_ref + ?address:(node_address children.(index + 1)) + right_keys right_children; ]) in let rebalance_with_left () = @@ -683,8 +758,15 @@ let rebalance_branch_child storage settings keys children index child = array_append left_children child_children in Some - (branch_replace_range settings keys children (index - 1) 2 - [ branch_ref merged_keys merged_children ]) + (branch_replace_range settings ?first_address:address keys + children + (index - 1) + 2 + [ + branch_ref + ?address:(node_address children.(index - 1)) + merged_keys merged_children; + ]) else let needed = minimum - Array.length child_keys in if needed <= 0 || Array.length left_keys - needed < minimum @@ -702,10 +784,17 @@ let rebalance_branch_child storage settings keys children index child = array_append borrowed_children child_children in Some - (branch_replace_range settings keys children (index - 1) 2 + (branch_replace_range settings ?first_address:address + keys children + (index - 1) + 2 [ - branch_ref left_keys left_children; - branch_ref right_keys right_children; + branch_ref + ?address:(node_address children.(index - 1)) + left_keys left_children; + branch_ref + ?address:(node_address children.(index)) + right_keys right_children; ]) in match rebalance_with_right () with @@ -722,6 +811,7 @@ let rec add_to_address storage settings order_cmp equality_cmp key_cmp value values; len = Array.length values; address = Some address; + dirty = false; }) | Branch (keys, child_addresses) -> add_to_node (Some storage) settings order_cmp equality_cmp key_cmp value @@ -731,13 +821,13 @@ and add_to_node storage settings order_cmp equality_cmp key_cmp value = function | Node.Ref _ as node -> add_to_node storage settings order_cmp equality_cmp key_cmp value (force_ref_node (storage_required storage) node) - | Node.Leaf { values; len; _ } -> ( + | Node.Leaf { values; len; address; _ } -> ( match find_insert_index_len order_cmp equality_cmp value values len with | `Found _ -> Tree_edit_unchanged | `Insert index -> let inserted = array_insert_len values len index value in - Tree_edit_changed (add_leaf_refs settings inserted)) - | Node.Branch { keys; children; _ } -> ( + Tree_edit_changed (add_leaf_refs settings ?address inserted)) + | Node.Branch { keys; children; address; _ } -> ( let index = find_child_index key_cmp value keys in match add_to_node storage settings order_cmp equality_cmp key_cmp value @@ -745,12 +835,12 @@ and add_to_node storage settings order_cmp equality_cmp key_cmp value = function with | Tree_edit_unchanged -> Tree_edit_unchanged | Tree_edit_changed [ (key, child) ] -> - branch_replace_one settings keys children index key child + branch_replace_one settings ?address keys children index key child |> fun changed -> Tree_edit_changed changed | Tree_edit_changed changed -> let keys, children = branch_splice_one keys children index changed in - branch_refs_of_arrays settings keys children |> fun changed -> - Tree_edit_changed changed) + branch_refs_of_arrays ?first_address:address settings keys children + |> fun changed -> Tree_edit_changed changed) let rec remove_from_address storage settings order_cmp equality_cmp key_cmp value address = @@ -763,6 +853,7 @@ let rec remove_from_address storage settings order_cmp equality_cmp key_cmp values; len = Array.length values; address = Some address; + dirty = false; }) | Branch (keys, child_addresses) -> remove_from_node (Some storage) settings order_cmp equality_cmp key_cmp @@ -774,7 +865,7 @@ and remove_from_node storage settings order_cmp equality_cmp key_cmp value = | Node.Ref _ as node -> remove_from_node storage settings order_cmp equality_cmp key_cmp value (force_ref_node (storage_required storage) node) - | Node.Leaf { values; len; _ } -> ( + | Node.Leaf { values; len; address; _ } -> ( match find_remove_index_len order_cmp equality_cmp value values len with | None -> Tree_edit_unchanged | Some index -> ( @@ -785,9 +876,14 @@ and remove_from_node storage settings order_cmp equality_cmp key_cmp value = [ ( values.(Array.length values - 1), Node.Leaf - { values; len = Array.length values; address = None } ); + { + values; + len = Array.length values; + address; + dirty = true; + } ); ])) - | Node.Branch { keys; children; _ } -> ( + | Node.Branch { keys; children; address; _ } -> ( let index = find_child_index key_cmp value keys in match remove_from_node storage settings order_cmp equality_cmp key_cmp value @@ -797,23 +893,25 @@ and remove_from_node storage settings order_cmp equality_cmp key_cmp value = | Tree_edit_changed [ (key, child) ] -> let changed = match - rebalance_leaf_child storage settings keys children index child + rebalance_leaf_child storage settings ?address keys children + index child with | Some changed -> changed | None -> ( match - rebalance_branch_child storage settings keys children index - child + rebalance_branch_child storage settings ?address keys + children index child with | Some changed -> changed | None -> - branch_replace_one settings keys children index key child) + branch_replace_one settings ?address keys children index + key child) in Tree_edit_changed changed | Tree_edit_changed changed -> let keys, children = branch_splice_one keys children index changed in - branch_refs_of_arrays settings keys children |> fun changed -> - Tree_edit_changed changed) + branch_refs_of_arrays ?first_address:address settings keys children + |> fun changed -> Tree_edit_changed changed) let add value set = let equality_cmp = set.cmp in @@ -1800,20 +1898,24 @@ let branch_key refs = | Some (key, _) -> key | None -> invalid_arg "branch requires at least one child" -let store_branch storage child_refs = +let store_branch ?address storage child_refs = let keys, child_addresses = split_branch_refs child_refs in - storage.store_node (Branch (keys, child_addresses)) + storage.store_node ?address (Branch (keys, child_addresses)) -let rec store_branch_tree storage settings child_refs = +let rec store_branch_tree ?address storage settings child_refs = if List.length child_refs <= settings.branching_factor then - let address = store_branch storage child_refs in + let address = store_branch ?address storage child_refs in (address, [ address ]) else let child_groups = chunks settings.branching_factor child_refs in let branch_addresses = child_groups - |> List.map (fun child_group -> - let address = store_branch storage child_group in + |> List.mapi (fun index child_group -> + let address = + store_branch + ?address:(if index = 0 then address else None) + storage child_group + in (branch_key child_group, address)) in let root, branch_tree_addresses = @@ -1823,12 +1925,16 @@ let rec store_branch_tree storage settings child_refs = let rec store_node_tree storage settings = function | Node.Ref { address; _ } -> (address, [ address ]) - | Node.Leaf { address = Some address; _ } -> (address, [ address ]) - | Node.Leaf { values; len; address = None; _ } -> - let address = storage.store_node (Leaf (Array.sub values 0 len)) in + | Node.Leaf { address = Some address; dirty = false; _ } -> + (address, [ address ]) + | Node.Leaf { values; len; address; _ } -> + let address = + storage.store_node ?address (Leaf (Array.sub values 0 len)) + in + (address, [ address ]) + | Node.Branch { address = Some address; dirty = false; _ } -> (address, [ address ]) - | Node.Branch { address = Some address; _ } -> (address, [ address ]) - | Node.Branch { keys; children; address = None; _ } -> + | Node.Branch { keys; children; address; _ } -> let child_refs = ref [] in let child_address_lists = ref [] in for index = 0 to Array.length children - 1 do @@ -1841,7 +1947,7 @@ let rec store_node_tree storage settings = function let child_refs = List.rev !child_refs in let child_address_lists = List.rev !child_address_lists in let address, branch_addresses = - store_branch_tree storage settings child_refs + store_branch_tree ?address storage settings child_refs in (address, branch_addresses @ List.concat child_address_lists) diff --git a/lib/persistent_sorted_set.mli b/lib/persistent_sorted_set.mli index 90e087a..dd086d1 100644 --- a/lib/persistent_sorted_set.mli +++ b/lib/persistent_sorted_set.mli @@ -4,7 +4,10 @@ type settings = { branching_factor : int; ref_type : ref_type } type 'a stored_node = Leaf of 'a array | Branch of 'a array * string array type 'a storage = { - store_node : 'a stored_node -> string; + store_node : ?address:string -> 'a stored_node -> string; + (** Write a node and return its address. When [address] is provided the + caller asks for the node to be stored at that existing address (the + cljs implementation's in-place rewrite of a modified stored node). *) restore_node : string -> 'a stored_node option; accessed : string -> unit; } diff --git a/test/js_memory_test.ml b/test/js_memory_test.ml index 48de3fc..c2c5566 100644 --- a/test/js_memory_test.ml +++ b/test/js_memory_test.ml @@ -55,9 +55,9 @@ let check ref_type label = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = diff --git a/test/js_smoke.ml b/test/js_smoke.ml index 00fe475..589de72 100644 --- a/test/js_smoke.ml +++ b/test/js_smoke.ml @@ -17,9 +17,9 @@ let () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr next; - let address = string_of_int !next in + let address = match given_address with Some a -> a | None -> string_of_int !next in Hashtbl.replace memory address node; address); restore_node = diff --git a/test/melange_storage_smoke.ml b/test/melange_storage_smoke.ml index 326289c..ae0a4dc 100644 --- a/test/melange_storage_smoke.ml +++ b/test/melange_storage_smoke.ml @@ -15,9 +15,9 @@ let () = let storage = { PSet.store_node = - (fun node -> + (fun ?address:given_address node -> incr next_id; - let address = "node-" ^ string_of_int !next_id in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !next_id in Hashtbl.replace memory address node; address); restore_node = diff --git a/test/test_persistent_sorted_set.ml b/test/test_persistent_sorted_set.ml index ddb1767..ff1e6e7 100644 --- a/test/test_persistent_sorted_set.ml +++ b/test/test_persistent_sorted_set.ml @@ -151,9 +151,9 @@ let roundtrip_set set = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -232,9 +232,9 @@ let test_show_node_tree_string () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -253,10 +253,10 @@ let test_show_node_tree_string () = let edited_root = root_node_exn "edited stored show_node" (add 10 stored) in assert_equal_string "show_node renders storage refs without materializing them" - "Branch(address=none keys=[3; 7; 10])\n\ + "Branch(address=node-4 keys=[3; 7; 10])\n\ \ Ref(address=node-1 max_key=3)\n\ \ Ref(address=node-2 max_key=7)\n\ - \ Leaf(address=none len=3 values=[8; 9; 10])" + \ Leaf(address=node-3 len=3 values=[8; 9; 10])" (show_node string_of_int edited_root) let test_store_preserves_memory_tree_shape () = @@ -265,9 +265,9 @@ let test_store_preserves_memory_tree_shape () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -314,9 +314,9 @@ let test_restored_add_uses_balanced_leaf_split () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -341,10 +341,10 @@ let test_restored_add_uses_balanced_leaf_split () = (Array.to_list keys); assert_equal_string_list "balanced restored add reuses unchanged left leaf" - [ "node-1"; "node-4"; "node-5" ] + [ "node-1"; "node-2"; "node-5" ] (Array.to_list child_addresses); match - (Hashtbl.find_opt memory "node-4", Hashtbl.find_opt memory "node-5") + (Hashtbl.find_opt memory "node-2", Hashtbl.find_opt memory "node-5") with | Some (Leaf left), Some (Leaf right) -> assert_equal_list "balanced restored add left split leaf" [ 4; 5 ] @@ -360,8 +360,8 @@ let test_storage_backed_pure_trees_do_not_rescan_before_edits () = let memory = Hashtbl.create 16 in { store_node = - (fun node -> - let address = "node-" ^ string_of_int (Hashtbl.length memory) in + (fun ?address:given_address node -> + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int (Hashtbl.length memory) in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -447,9 +447,9 @@ let test_settings_control_storage_branching_factor () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -498,9 +498,9 @@ let test_restore_preserves_settings_for_later_edits () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -542,12 +542,12 @@ let test_restore_preserves_settings_for_later_edits () = "custom restored add reuses unchanged leaves and stores split branch levels" [ added_root; - "node-6"; + "node-5"; "node-1"; "node-2"; "node-9"; "node-3"; - "node-7"; + "node-4"; "node-8"; ] (stored_addresses memory added_root); @@ -557,7 +557,7 @@ let test_restore_preserves_settings_for_later_edits () = [ 7; 16 ] (Array.to_list keys); assert_equal_list "custom restored add root addresses point at split branch nodes" - [ "node-6"; "node-9" ] (Array.to_list child_addresses) + [ "node-5"; "node-9" ] (Array.to_list child_addresses) | Some _ -> failwith "custom restored add root should be a branch" | None -> failwith "custom restored add root should be stored" @@ -568,9 +568,9 @@ let test_ref_type_controls_restored_node_cache () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address (Marshal.to_string node []); address); restore_node = @@ -631,9 +631,9 @@ let test_reclaimable_ref_types_release_restored_nodes_after_gc () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -685,7 +685,7 @@ let test_settings_validate_branching_factor () = let storage = { store_node = - (fun node -> + (fun ?address:_given_address node -> Hashtbl.replace memory "root" node; "root"); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -705,9 +705,9 @@ let test_of_sorted_array_uses_sorted_input_and_settings () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -838,9 +838,9 @@ let test_restored_equal_comparator_slice_ranges () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -1200,9 +1200,9 @@ let test_storage_round_trip_and_stable_addresses () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1235,10 +1235,10 @@ let test_storage_round_trip_and_stable_addresses () = [ root ] !accessed; let changed = add 101 stored_again in let changed_root, changed_stored = store changed in - if changed_root = root then - failwith "modified stored set should get a new root address"; - assert_equal_int "modified set writes a new root" 2 !writes; - assert_equal_list "stored_addresses reports the new root" [ changed_root ] + if changed_root <> root then + failwith "modified stored set should rewrite its root in place"; + assert_equal_int "modified set rewrites the root in place" 2 !writes; + assert_equal_list "stored_addresses reports the rewritten root" [ root ] (stored_addresses memory changed_root); let duplicate = add 101 changed_stored in let duplicate_root, _ = store duplicate in @@ -1254,9 +1254,9 @@ let test_stored_count_uses_cached_size () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1289,9 +1289,9 @@ let count_restore_fixture values = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = string_of_int !writes in + let address = match given_address with Some a -> a | None -> string_of_int !writes in Hashtbl.replace nodes address node; address); restore_node = @@ -1366,9 +1366,9 @@ let test_storage_uses_leaf_and_branch_nodes_for_large_sets () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1407,16 +1407,17 @@ let test_storage_uses_leaf_and_branch_nodes_for_large_sets () = !accessed; let appended = add 101 stored in let appended_root, _ = store appended in - if appended_root = root then - failwith "appending to a stored set should create a new root"; - assert_equal_int "append writes one changed leaf and one new branch" 7 !writes; + if appended_root <> root then + failwith "appending to a stored set should rewrite its root in place"; + assert_equal_int "append rewrites one leaf and the root branch in place" 7 + !writes; assert_equal_list "append reuses unchanged leaf addresses" - [ appended_root; "node-1"; "node-2"; "node-3"; "node-6" ] + [ root; "node-1"; "node-2"; "node-3"; "node-4" ] (stored_addresses memory appended_root); match Hashtbl.find_opt memory appended_root with | Some (Branch (_, child_addresses)) -> assert_equal_list "appended root reuses unchanged leaves" - [ "node-1"; "node-2"; "node-3"; "node-6" ] + [ "node-1"; "node-2"; "node-3"; "node-4" ] (Array.to_list child_addresses) | Some _ -> failwith "appended root should be a branch node" | None -> failwith "appended root address should be stored" @@ -1427,9 +1428,9 @@ let test_storage_remove_preserves_unchanged_leaf_addresses () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -1441,21 +1442,21 @@ let test_storage_remove_preserves_unchanged_leaf_addresses () = assert_equal_int "large store writes leaf nodes plus a root" 5 !writes; let removed = remove 50 stored in let removed_root, removed_stored = store removed in - if removed_root = root then - failwith "removing a value should create a new root address"; + if removed_root <> root then + failwith "removing a value should rewrite the root in place"; assert_equal_int "removing from one leaf rewrites one leaf and one root" 7 !writes; - assert_equal_list "remove reuses unaffected leaf addresses" - [ removed_root; "node-1"; "node-6"; "node-3"; "node-4" ] + assert_equal_list "remove reuses unchanged leaf addresses" + [ root; "node-1"; "node-2"; "node-3"; "node-4" ] (stored_addresses memory removed_root); (match Hashtbl.find_opt memory removed_root with | Some (Branch (_, child_addresses)) -> - assert_equal_list "removed root points at reused sibling leaves" - [ "node-1"; "node-6"; "node-3"; "node-4" ] + assert_equal_list "removed root points at unchanged sibling leaves" + [ "node-1"; "node-2"; "node-3"; "node-4" ] (Array.to_list child_addresses) | Some _ -> failwith "removed root should be a branch node" | None -> failwith "removed root address should be stored"); - (match Hashtbl.find_opt memory "node-6" with + (match Hashtbl.find_opt memory "node-2" with | Some (Leaf values) -> assert_equal_list "changed leaf only drops the removed value" (irange 32 49 @ irange 51 63) @@ -1472,9 +1473,9 @@ let test_storage_remove_borrows_from_right_sibling () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -1510,9 +1511,9 @@ let test_nested_storage_remove_borrows_branch_from_right_sibling () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -1554,9 +1555,9 @@ let test_storage_add_preserves_unchanged_leaf_addresses () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -1570,22 +1571,22 @@ let test_storage_add_preserves_unchanged_leaf_addresses () = assert_equal_int "large gapped store writes leaf nodes plus a root" 5 !writes; let added = add 50 stored in let added_root, added_stored = store added in - if added_root = root then - failwith "adding a value should create a new root address"; + if added_root <> root then + failwith "adding a value should rewrite the root in place"; assert_equal_int "adding into one full leaf rewrites split leaves and one root" 8 !writes; assert_equal_list "add reuses unaffected leaf addresses" - [ added_root; "node-1"; "node-6"; "node-7"; "node-3"; "node-4" ] + [ root; "node-1"; "node-2"; "node-7"; "node-3"; "node-4" ] (stored_addresses memory added_root); (match Hashtbl.find_opt memory added_root with | Some (Branch (_, child_addresses)) -> assert_equal_list "added root points at reused sibling leaves" - [ "node-1"; "node-6"; "node-7"; "node-3"; "node-4" ] + [ "node-1"; "node-2"; "node-7"; "node-3"; "node-4" ] (Array.to_list child_addresses) | Some _ -> failwith "added root should be a branch node" | None -> failwith "added root address should be stored"); (match - (Hashtbl.find_opt memory "node-6", Hashtbl.find_opt memory "node-7") + (Hashtbl.find_opt memory "node-2", Hashtbl.find_opt memory "node-7") with | Some (Leaf left), Some (Leaf right) -> assert_equal_list "split left leaf contains the lower local values" @@ -1604,9 +1605,9 @@ let test_restored_add_preserves_unchanged_leaf_addresses_lazily () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1630,11 +1631,12 @@ let test_restored_add_preserves_unchanged_leaf_addresses_lazily () = assert_equal_list "restored add should access only root and target leaf" [ "node-4"; root ] !accessed; let appended_root, appended_stored = store appended in - if appended_root = root then failwith "restored add should create a new root"; - assert_equal_int "restored add should write one changed leaf and one new root" - 7 !writes; + if appended_root <> root then + failwith "restored add should rewrite the root in place"; + assert_equal_int + "restored add should rewrite one changed leaf and the root" 7 !writes; assert_equal_list "restored add reuses unchanged leaf addresses" - [ appended_root; "node-1"; "node-2"; "node-3"; "node-6" ] + [ root; "node-1"; "node-2"; "node-3"; "node-4" ] (stored_addresses memory appended_root); assert_equal_list "restored add keeps sorted values" (irange 0 101) (to_list appended_stored) @@ -1647,9 +1649,9 @@ let test_chained_restored_adds_keep_edit_path_without_rebuilding () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1686,13 +1688,13 @@ let test_chained_restored_adds_keep_edit_path_without_rebuilding () = assert_equal_list "duplicate add should not access stored siblings" [] !accessed; let appended_root, appended_stored = store appended_duplicate in - if appended_root = root then - failwith "chained restored adds should create a new root"; + if appended_root <> root then + failwith "chained restored adds should rewrite the root in place"; assert_equal_int - "chained restored adds should write one final leaf and one new root" 7 + "chained restored adds should rewrite one final leaf and the root" 7 !writes; assert_equal_list "chained restored adds reuse unchanged leaf addresses" - [ appended_root; "node-1"; "node-2"; "node-3"; "node-6" ] + [ root; "node-1"; "node-2"; "node-3"; "node-4" ] (stored_addresses memory appended_root); assert_equal_list "chained restored adds keep sorted values" (irange 0 102) (to_list appended_stored) @@ -1705,9 +1707,9 @@ let test_restored_remove_preserves_unchanged_leaf_addresses_lazily () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1732,12 +1734,12 @@ let test_restored_remove_preserves_unchanged_leaf_addresses_lazily () = assert_equal_list "restored remove should access only root and target leaf" [ "node-2"; root ] !accessed; let removed_root, removed_stored = store removed in - if removed_root = root then - failwith "restored remove should create a new root"; + if removed_root <> root then + failwith "restored remove should rewrite the root in place"; assert_equal_int - "restored remove should write one changed leaf and one new root" 7 !writes; + "restored remove should rewrite one changed leaf and the root" 7 !writes; assert_equal_list "restored remove reuses unchanged leaf addresses" - [ removed_root; "node-1"; "node-6"; "node-3"; "node-4" ] + [ root; "node-1"; "node-2"; "node-3"; "node-4" ] (stored_addresses memory removed_root); assert_equal_list "restored remove keeps sorted values" (irange 0 49 @ irange 51 100) @@ -1751,9 +1753,9 @@ let test_restored_mem_reads_only_needed_leaves () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1805,9 +1807,9 @@ let test_restored_tree_refs_cache_repeated_access () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1851,9 +1853,9 @@ let test_restored_mem_uses_binary_search_inside_stored_nodes () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -1886,9 +1888,9 @@ let test_restored_slice_reads_only_overlapping_leaves () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1933,9 +1935,9 @@ let test_restored_reverse_slice_reads_only_overlapping_leaves () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -1989,7 +1991,7 @@ let test_restored_reverse_slice_avoids_branch_annotation_list () = Hashtbl.add memory "root" (Branch (Array.of_list keys, Array.of_list child_addresses)); let storage = { - store_node = (fun _ -> invalid_arg "test storage is read-only"); + store_node = (fun ?address:_ _ -> invalid_arg "test storage is read-only"); restore_node = (fun address -> Hashtbl.find_opt memory address); accessed = (fun _ -> ()); } @@ -2018,9 +2020,9 @@ let test_restored_seq_seek_is_lazy () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -2057,9 +2059,9 @@ let test_restored_rseq_seek_is_lazy () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -2096,9 +2098,9 @@ let test_restored_slice_seq_construction_is_lazy () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -2138,9 +2140,9 @@ let test_restored_rslice_seq_construction_is_lazy () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -2178,9 +2180,9 @@ let test_storage_uses_nested_branch_nodes_for_very_large_sets () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -2244,9 +2246,9 @@ let test_storage_addresses_visit_stored_descendants () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -2291,9 +2293,9 @@ let test_nested_storage_remove_reuses_unchanged_branch_addresses () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = (fun address -> Hashtbl.find_opt memory address); @@ -2305,27 +2307,24 @@ let test_nested_storage_remove_reuses_unchanged_branch_addresses () = if root <> "node-36" then failwith "initial nested root should be node-36"; let removed = remove 50 stored in let removed_root, removed_stored = store removed in - if removed_root = root then - failwith "nested remove should create a new root address"; + if removed_root <> root then + failwith "nested remove should rewrite the root in place"; assert_equal_int "nested remove rewrites changed leaf, one branch, and root" 39 !writes; - if removed_root <> "node-39" then - failwith "nested remove root should be the third new node"; (match Hashtbl.find_opt memory removed_root with | Some (Branch (keys, child_addresses)) -> assert_equal_list "nested remove root keeps old second branch max key" [ 1023; 1055 ] (Array.to_list keys); - assert_equal_list "nested remove root reuses unchanged second branch" - [ "node-38"; "node-35" ] (Array.to_list child_addresses) + assert_equal_string_list "nested remove root reuses both branch addresses" + [ "node-33"; "node-35" ] (Array.to_list child_addresses) | Some _ -> failwith "nested remove root should be a branch" | None -> failwith "nested remove root should be stored"); - (match Hashtbl.find_opt memory "node-38" with + (match Hashtbl.find_opt memory "node-33" with | Some (Branch (_, child_addresses)) -> let expected = - List.init 32 (fun index -> - if index = 1 then "node-37" else "node-" ^ string_of_int (index + 1)) + List.init 32 (fun index -> "node-" ^ string_of_int (index + 1)) in - assert_equal_list "nested remove rewrites only the changed leaf address" + assert_equal_list "nested remove rewrites the changed leaf in place" expected (Array.to_list child_addresses) | Some _ -> failwith "nested remove first branch should be a branch" | None -> failwith "nested remove changed branch should be stored"); @@ -2341,9 +2340,9 @@ let test_restored_nested_remove_reuses_unchanged_branch_addresses_lazily () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -2369,21 +2368,19 @@ let test_restored_nested_remove_reuses_unchanged_branch_addresses_lazily () = [ "node-2"; "node-33"; root ] !accessed; let removed_root, removed_stored = store removed in - if removed_root = root then - failwith "restored nested remove should create a new root address"; + if removed_root <> root then + failwith "restored nested remove should rewrite the root in place"; assert_equal_int "restored nested remove rewrites changed leaf, one branch, and root" 39 !writes; - if removed_root <> "node-39" then - failwith "restored nested remove root should be the third new node"; (match Hashtbl.find_opt memory removed_root with | Some (Branch (keys, child_addresses)) -> assert_equal_list "restored nested remove root keeps old second branch max key" [ 1023; 1055 ] (Array.to_list keys); assert_equal_list - "restored nested remove root reuses unchanged second branch" - [ "node-38"; "node-35" ] (Array.to_list child_addresses) + "restored nested remove root reuses both branch addresses" + [ "node-33"; "node-35" ] (Array.to_list child_addresses) | Some _ -> failwith "restored nested remove root should be a branch" | None -> failwith "restored nested remove root should be stored"); assert_equal_list "restored nested remove keeps sorted values" @@ -2398,9 +2395,9 @@ let test_restored_nested_add_reuses_unchanged_branch_addresses_lazily () = let storage = { store_node = - (fun node -> + (fun ?address:given_address node -> incr writes; - let address = "node-" ^ string_of_int !writes in + let address = match given_address with Some a -> a | None -> "node-" ^ string_of_int !writes in Hashtbl.replace memory address node; address); restore_node = @@ -2427,21 +2424,19 @@ let test_restored_nested_add_reuses_unchanged_branch_addresses_lazily () = [ "node-2"; "node-33"; root ] !accessed; let added_root, added_stored = store added in - if added_root = root then - failwith "restored nested add should create a new root address"; + if added_root <> root then + failwith "restored nested add should rewrite the root in place"; assert_equal_int "restored nested add rewrites split leaves, split branches, and root" 41 !writes; - if added_root <> "node-41" then - failwith "restored nested add root should be the fifth new node"; (match Hashtbl.find_opt memory added_root with | Some (Branch (keys, child_addresses)) -> assert_equal_list "restored nested add root updates split first branch max keys" [ 480; 1024; 1055 ] (Array.to_list keys); assert_equal_list - "restored nested add root reuses unchanged second branch" - [ "node-39"; "node-40"; "node-35" ] + "restored nested add root reuses first and second branch addresses" + [ "node-33"; "node-40"; "node-35" ] (Array.to_list child_addresses) | Some _ -> failwith "restored nested add root should be a branch" | None -> failwith "restored nested add root should be stored");