diff --git a/src/lib/merkle_address/merkle_address.ml b/src/lib/merkle_address/merkle_address.ml
index f36dd5b2af0..d5030726733 100644
--- a/src/lib/merkle_address/merkle_address.ml
+++ b/src/lib/merkle_address/merkle_address.ml
@@ -97,9 +97,9 @@ let height ~ledger_depth path = ledger_depth - depth path
 
 let get = get
 
-[%%define_locally
-Stable.Latest.(t_of_sexp, sexp_of_t, to_yojson, compare, equal)]
+[%%define_locally Stable.Latest.(t_of_sexp, sexp_of_t, to_yojson)]
 
+include Comparable.Make_binable (Stable.Latest)
 include Hashable.Make_binable (Stable.Latest)
 
 let of_byte_string = bitstring_of_string
@@ -114,13 +114,13 @@ let copy (path : t) : t =
 (* returns a slice of the original path, so the returned key needs to be
        copied before mutating the path *)
 let parent (path : t) =
-  if bitstring_length path = 0 then
+  if Int.equal (bitstring_length path) 0 then
     Or_error.error_string "Address length should be nonzero"
   else Or_error.return (slice path 0 (bitstring_length path - 1))
 
 let parent_exn = Fn.compose Or_error.ok_exn parent
 
-let is_leaf ~ledger_depth path = bitstring_length path >= ledger_depth
+let is_leaf ~ledger_depth path = Int.(bitstring_length path >= ledger_depth)
 
 let child ~ledger_depth (path : t) dir : t Or_error.t =
   if is_leaf ~ledger_depth path then
@@ -137,10 +137,10 @@ let to_int (path : t) : int =
   Sequence.range 0 (depth path)
   |> Sequence.fold ~init:0 ~f:(fun acc i ->
          let index = depth path - 1 - i in
-         acc + ((if get path index <> 0 then 1 else 0) lsl i) )
+         acc + ((if Int.(get path index <> 0) then 1 else 0) lsl i) )
 
 let of_int_exn ~ledger_depth index =
-  if index >= 1 lsl ledger_depth then failwith "Index is too large"
+  if Int.(index >= 1 lsl ledger_depth) then failwith "Index is too large"
   else
     let buf = create_bitstring ledger_depth in
     ignore
@@ -160,7 +160,7 @@ let root () = create_bitstring 0
 let sibling (path : t) : t =
   let path = copy path in
   let last_bit_index = depth path - 1 in
-  let last_bit = if get path last_bit_index = 0 then 1 else 0 in
+  let last_bit = if Int.equal (get path last_bit_index) 0 then 1 else 0 in
   put path last_bit_index last_bit ;
   path
 
@@ -169,12 +169,12 @@ let next (path : t) : t Option.t =
   let path = copy path in
   let len = depth path in
   let rec find_rightmost_clear_bit i =
-    if i < 0 then None
+    if Int.(i < 0) then None
     else if is_clear path i then Some i
     else find_rightmost_clear_bit (i - 1)
   in
   let rec clear_bits i =
-    if i >= len then ()
+    if Int.(i >= len) then ()
     else (
       clear path i ;
       clear_bits (i + 1) )
@@ -189,12 +189,12 @@ let prev (path : t) : t Option.t =
   let path = copy path in
   let len = depth path in
   let rec find_rightmost_one_bit i =
-    if i < 0 then None
+    if Int.(i < 0) then None
     else if is_set path i then Some i
     else find_rightmost_one_bit (i - 1)
   in
   let rec set_bits i =
-    if i >= len then ()
+    if Int.(i >= len) then ()
     else (
       set path i ;
       set_bits (i + 1) )
@@ -208,28 +208,38 @@ let serialize ~ledger_depth path =
   let path = add_padding path in
   let path_len = depth path in
   let required_bits = 8 * byte_count_of_bits ledger_depth in
-  assert (path_len <= required_bits) ;
+  assert (Int.(path_len <= required_bits)) ;
   let required_padding = required_bits - path_len in
   Bigstring.of_string @@ string_of_bitstring
   @@ concat [ path; zeroes_bitstring required_padding ]
 
 let is_parent_of parent ~maybe_child = Bitstring.is_prefix maybe_child parent
 
+let same_height_ancestors x y =
+  let depth_x = depth x in
+  let depth_y = depth y in
+  if Int.(depth_x < depth_y) then (x, slice y 0 depth_x)
+  else (slice x 0 depth_y, y)
+
+let is_further_right ~than path =
+  let than, path = same_height_ancestors than path in
+  Int.( < ) (compare than path) 0
+
 module Range = struct
   type nonrec t = t * t
 
   let rec fold_exl (first, last) ~init ~f =
     let comparison = compare first last in
-    if comparison > 0 then
+    if Int.(comparison > 0) then
       raise (Invalid_argument "first address needs to precede last address")
-    else if comparison = 0 then init
+    else if Int.(comparison = 0) then init
     else fold_exl (next first |> Option.value_exn, last) ~init:(f first init) ~f
 
   let fold_incl (first, last) ~init ~f =
     f last @@ fold_exl (first, last) ~init ~f
 
   let fold ?(stop = `Inclusive) (first, last) ~init ~f =
-    assert (depth first = depth last) ;
+    assert (Int.(depth first = depth last)) ;
     match stop with
     | `Inclusive ->
         fold_incl (first, last) ~init ~f
@@ -253,7 +263,7 @@ module Range = struct
         | _, `Stop ->
             None
         | current_node, `Don't_stop ->
-            if compare current_node last_node = 0 then
+            if Int.equal (compare current_node last_node) 0 then
               Some (current_node, (current_node, `Stop))
             else
               Option.map (next current_node) ~f:(fun next_node ->
diff --git a/src/lib/merkle_address/merkle_address.mli b/src/lib/merkle_address/merkle_address.mli
index 767fc004961..af169723da8 100644
--- a/src/lib/merkle_address/merkle_address.mli
+++ b/src/lib/merkle_address/merkle_address.mli
@@ -11,6 +11,8 @@ module Stable : sig
   module Latest : module type of V1
 end
 
+include Comparable.S_binable with type t := t
+
 include Hashable.S_binable with type t := t
 
 val of_byte_string : string -> t
@@ -74,3 +76,7 @@ val height : ledger_depth:int -> t -> int
 val to_int : t -> int
 
 val of_int_exn : ledger_depth:int -> int -> t
+
+val same_height_ancestors : t -> t -> t * t
+
+val is_further_right : than:t -> t -> bool
diff --git a/src/lib/merkle_ledger/any_ledger.ml b/src/lib/merkle_ledger/any_ledger.ml
index 30f4da1c996..0541f47acbd 100644
--- a/src/lib/merkle_ledger/any_ledger.ml
+++ b/src/lib/merkle_ledger/any_ledger.ml
@@ -122,6 +122,9 @@ module Make_base (Inputs : Inputs_intf) :
 
     let merkle_path_batch (T ((module Base), t)) = Base.merkle_path_batch t
 
+    let wide_merkle_path_batch (T ((module Base), t)) =
+      Base.wide_merkle_path_batch t
+
     let merkle_root (T ((module Base), t)) = Base.merkle_root t
 
     let get_hash_batch_exn (T ((module Base), t)) = Base.get_hash_batch_exn t
diff --git a/src/lib/merkle_ledger/base_ledger_intf.ml b/src/lib/merkle_ledger/base_ledger_intf.ml
index c74408be04f..f85caa808b5 100644
--- a/src/lib/merkle_ledger/base_ledger_intf.ml
+++ b/src/lib/merkle_ledger/base_ledger_intf.ml
@@ -136,6 +136,11 @@ module type S = sig
 
   val merkle_path_batch : t -> Location.t list -> Path.t list
 
+  val wide_merkle_path_batch :
+       t
+    -> Location.t list
+    -> [ `Left of hash * hash | `Right of hash * hash ] list list
+
   val get_hash_batch_exn : t -> Location.t list -> hash list
 
   val remove_accounts_exn : t -> account_id list -> unit
diff --git a/src/lib/merkle_ledger/database.ml b/src/lib/merkle_ledger/database.ml
index 3f5689c4771..ec1e2c1e856 100644
--- a/src/lib/merkle_ledger/database.ml
+++ b/src/lib/merkle_ledger/database.ml
@@ -700,7 +700,7 @@ module Make (Inputs : Inputs_intf) :
     List.map2_exn dependency_dirs dependency_hashes ~f:(fun dir hash ->
         Direction.map dir ~left:(`Left hash) ~right:(`Right hash) )
 
-  let merkle_path_batch mdb locations =
+  let path_batch_impl ~expand_query ~compute_path mdb locations =
     let locations =
       List.map locations ~f:(fun location ->
           if Location.is_account location then
@@ -709,48 +709,44 @@ module Make (Inputs : Inputs_intf) :
             assert (Location.is_hash location) ;
             location ) )
     in
-    let rev_locations, rev_directions, rev_lengths =
-      let rec loop locations loc_acc dir_acc length_acc =
-        match (locations, length_acc) with
-        | [], _ :: length_acc ->
-            (loc_acc, dir_acc, length_acc)
-        | k :: locations, length :: length_acc ->
-            if Location.height ~ledger_depth:mdb.depth k >= mdb.depth then
-              loop locations loc_acc dir_acc (0 :: length :: length_acc)
-            else
-              let sibling = Location.sibling k in
-              let sibling_dir =
-                Location.last_direction (Location.to_path_exn k)
-              in
-              loop
-                (Location.parent k :: locations)
-                (sibling :: loc_acc) (sibling_dir :: dir_acc)
-                ((length + 1) :: length_acc)
-        | _ ->
-            assert false
-      in
-      loop locations [] [] [ 0 ]
+    let list_of_dependencies =
+      List.map locations ~f:Location.merkle_path_dependencies_exn
     in
-    let rev_hashes = get_hash_batch_exn mdb rev_locations in
-    let rec loop directions hashes lengths acc =
-      match (directions, hashes, lengths, acc) with
-      | [], [], [], _ (* actually [] *) :: acc_tl ->
-          acc_tl
-      | _, _, 0 :: lengths, _ ->
-          loop directions hashes lengths ([] :: acc)
-      | ( direction :: directions
-        , hash :: hashes
-        , length :: lengths
-        , acc_hd :: acc_tl ) ->
-          let dir =
-            Direction.map direction ~left:(`Left hash) ~right:(`Right hash)
-          in
-          loop directions hashes ((length - 1) :: lengths)
-            ((dir :: acc_hd) :: acc_tl)
-      | _ ->
-          failwith "Mismatched lengths"
+    let all_locs =
+      List.map list_of_dependencies ~f:(fun deps -> List.map ~f:fst deps |> expand_query) |> List.concat
     in
-    loop rev_directions rev_hashes rev_lengths [ [] ]
+    let hashes = get_hash_batch_exn mdb all_locs in
+    snd @@ List.fold_map ~init:hashes ~f:compute_path list_of_dependencies
+
+  let merkle_path_batch =
+    path_batch_impl ~expand_query:ident
+      ~compute_path:(fun all_hashes loc_and_dir_list ->
+        let len = List.length loc_and_dir_list in
+        let sibling_hashes, rest_hashes = List.split_n all_hashes len in
+        let res =
+          List.map2_exn loc_and_dir_list sibling_hashes
+            ~f:(fun (_, direction) sibling_hash ->
+              Direction.map direction ~left:(`Left sibling_hash)
+                ~right:(`Right sibling_hash) )
+        in
+        (rest_hashes, res) )
+
+  let wide_merkle_path_batch =
+    path_batch_impl
+      ~expand_query:(fun sib_locs ->
+        sib_locs @ List.map sib_locs ~f:Location.sibling )
+      ~compute_path:(fun all_hashes loc_and_dir_list ->
+        let len = List.length loc_and_dir_list in
+        let sibling_hashes, rest_hashes = List.split_n all_hashes len in
+        let self_hashes, rest_hashes' = List.split_n rest_hashes len in
+        let res =
+          List.map3_exn loc_and_dir_list sibling_hashes self_hashes
+            ~f:(fun (_, direction) sibling_hash self_hash ->
+              Direction.map direction
+                ~left:(`Left (self_hash, sibling_hash))
+                ~right:(`Right (sibling_hash, self_hash)) )
+        in
+        (rest_hashes', res) )
 
   let merkle_path_at_addr_exn t addr = merkle_path t (Location.Hash addr)
 
diff --git a/src/lib/merkle_ledger/null_ledger.ml b/src/lib/merkle_ledger/null_ledger.ml
index c756ee03a6a..644dbfc9a5c 100644
--- a/src/lib/merkle_ledger/null_ledger.ml
+++ b/src/lib/merkle_ledger/null_ledger.ml
@@ -57,15 +57,36 @@ end = struct
       let h = Location.height ~ledger_depth:t.depth k in
       if h >= t.depth then []
       else
-        let sibling_dir = Location.last_direction (Location.to_path_exn k) in
+        let dir = Location.last_direction (Location.to_path_exn k) in
         let hash = empty_hash_at_height h in
-        Direction.map sibling_dir ~left:(`Left hash) ~right:(`Right hash)
+        Direction.map dir ~left:(`Left hash) ~right:(`Right hash)
         :: loop (Location.parent k)
     in
     loop location
 
   let merkle_path_batch t locations = List.map ~f:(merkle_path t) locations
 
+  let wide_merkle_path t location =
+    let location =
+      if Location.is_account location then
+        Location.Hash (Location.to_path_exn location)
+      else location
+    in
+    assert (Location.is_hash location) ;
+    let rec loop k =
+      let h = Location.height ~ledger_depth:t.depth k in
+      if h >= t.depth then []
+      else
+        let dir = Location.last_direction (Location.to_path_exn k) in
+        let hash = empty_hash_at_height h in
+        Direction.map dir ~left:(`Left (hash, hash)) ~right:(`Right (hash, hash))
+        :: loop (Location.parent k)
+    in
+    loop location
+
+  let wide_merkle_path_batch t locations =
+    List.map ~f:(wide_merkle_path t) locations
+
   let merkle_root t = empty_hash_at_height t.depth
 
   let merkle_path_at_addr_exn t addr = merkle_path t (Location.Hash addr)
diff --git a/src/lib/merkle_ledger_tests/test_mask.ml b/src/lib/merkle_ledger_tests/test_mask.ml
index feed94a7a20..f273f52d798 100644
--- a/src/lib/merkle_ledger_tests/test_mask.ml
+++ b/src/lib/merkle_ledger_tests/test_mask.ml
@@ -188,17 +188,6 @@ module Make (Test : Test_intf) = struct
         (* verify all hashes to root are same in mask and parent *)
         compare_maskable_mask_hashes maskable attached_mask dummy_address )
 
-  let%test "mask delegates to parent" =
-    Test.with_instances (fun maskable mask ->
-        let attached_mask = Maskable.register_mask maskable mask in
-        (* set to parent, get from mask *)
-        Maskable.set maskable dummy_location dummy_account ;
-        let mask_result = Mask.Attached.get attached_mask dummy_location in
-        Option.is_some mask_result
-        &&
-        let mask_account = Option.value_exn mask_result in
-        Account.equal dummy_account mask_account )
-
   let%test "mask prune after parent notification" =
     Test.with_instances (fun maskable mask ->
         let attached_mask = Maskable.register_mask maskable mask in
@@ -763,8 +752,9 @@ module Make_maskable_and_mask_with_depth (Depth : Depth_S) = struct
       | Generic of Merkle_ledger.Location.Bigstring.t
       | Account of Location.Addr.t
       | Hash of Location.Addr.t
-    [@@deriving hash, sexp, compare]
+    [@@deriving hash, sexp]
 
+    include Comparable.Make_binable (Arg)
     include Hashable.Make_binable (Arg) [@@deriving sexp, compare, hash, yojson]
   end
 
diff --git a/src/lib/merkle_mask/dune b/src/lib/merkle_mask/dune
index 1c9070d0db2..02538f4c132 100644
--- a/src/lib/merkle_mask/dune
+++ b/src/lib/merkle_mask/dune
@@ -23,6 +23,7 @@
    visualization
    mina_stdlib
    direction
+   empty_hashes
  )
  (preprocess
   (pps
diff --git a/src/lib/merkle_mask/inputs_intf.ml b/src/lib/merkle_mask/inputs_intf.ml
index 761b5768ddb..48647cd4d61 100644
--- a/src/lib/merkle_mask/inputs_intf.ml
+++ b/src/lib/merkle_mask/inputs_intf.ml
@@ -20,8 +20,11 @@ module type S = sig
 
   module Location : Merkle_ledger.Location_intf.S
 
-  module Location_binable :
-    Core_kernel.Hashable.S_binable with type t := Location.t
+  module Location_binable : sig
+    include Core_kernel.Hashable.S_binable with type t := Location.t
+
+    include Core_kernel.Comparable.S_binable with type t := Location.t
+  end
 
   module Base :
     Base_merkle_tree_intf.S
diff --git a/src/lib/merkle_mask/masking_merkle_tree.ml b/src/lib/merkle_mask/masking_merkle_tree.ml
index a5c88273009..b35ba1d6ad7 100644
--- a/src/lib/merkle_mask/masking_merkle_tree.ml
+++ b/src/lib/merkle_mask/masking_merkle_tree.ml
@@ -40,12 +40,12 @@ module Make (Inputs : Inputs_intf.S) = struct
 
   type t =
     { uuid : Uuid.Stable.V1.t
-    ; account_tbl : Account.t Location_binable.Table.t
-    ; token_owners : Account_id.t Token_id.Table.t
+    ; accounts : Account.t Location_binable.Map.t ref
+    ; token_owners : Account_id.t Token_id.Map.t ref
     ; mutable parent : Parent.t
     ; detached_parent_signal : Detached_parent_signal.t
-    ; hash_tbl : Hash.t Addr.Table.t
-    ; location_tbl : Location.t Account_id.Table.t
+    ; hashes : Hash.t Addr.Map.t ref
+    ; locations : Location.t Account_id.Map.t ref
     ; mutable current_location : Location.t option
     ; depth : int
     }
@@ -57,10 +57,10 @@ module Make (Inputs : Inputs_intf.S) = struct
     { uuid = Uuid_unix.create ()
     ; parent = Error __LOC__
     ; detached_parent_signal = Async.Ivar.create ()
-    ; account_tbl = Location_binable.Table.create ()
-    ; token_owners = Token_id.Table.create ()
-    ; hash_tbl = Addr.Table.create ()
-    ; location_tbl = Account_id.Table.create ()
+    ; accounts = ref Location_binable.Map.empty
+    ; token_owners = ref Token_id.Map.empty
+    ; hashes = ref Addr.Map.empty
+    ; locations = ref Account_id.Map.empty
     ; current_location = None
     ; depth
     }
@@ -134,11 +134,11 @@ module Make (Inputs : Inputs_intf.S) = struct
     (* don't rely on a particular implementation *)
     let self_find_hash t address =
       assert_is_attached t ;
-      Addr.Table.find t.hash_tbl address
+      Map.find !(t.hashes) address
 
     let self_set_hash t address hash =
       assert_is_attached t ;
-      Addr.Table.set t.hash_tbl ~key:address ~data:hash
+      t.hashes := Map.set !(t.hashes) ~key:address ~data:hash
 
     let set_inner_hash_at_addr_exn t address hash =
       assert_is_attached t ;
@@ -148,11 +148,11 @@ module Make (Inputs : Inputs_intf.S) = struct
     (* don't rely on a particular implementation *)
     let self_find_location t account_id =
       assert_is_attached t ;
-      Account_id.Table.find t.location_tbl account_id
+      Map.find !(t.locations) account_id
 
     let self_set_location t account_id location =
       assert_is_attached t ;
-      Account_id.Table.set t.location_tbl ~key:account_id ~data:location ;
+      t.locations := Map.set !(t.locations) ~key:account_id ~data:location ;
       (* if account is at a hitherto-unused location, that
          becomes the current location
       *)
@@ -166,11 +166,11 @@ module Make (Inputs : Inputs_intf.S) = struct
     (* don't rely on a particular implementation *)
     let self_find_account t location =
       assert_is_attached t ;
-      Location_binable.Table.find t.account_tbl location
+      Map.find !(t.accounts) location
 
     let self_set_account t location account =
       assert_is_attached t ;
-      Location_binable.Table.set t.account_tbl ~key:location ~data:account ;
+      t.accounts := Map.set !(t.accounts) ~key:location ~data:account ;
       self_set_location t (Account.identifier account) location
 
     (* a read does a lookup in the account_tbl; if that fails, delegate to
@@ -181,13 +181,20 @@ module Make (Inputs : Inputs_intf.S) = struct
       | Some account ->
           Some account
       | None ->
-          Base.get (get_parent t) location
+          let is_empty =
+            match t.current_location with
+            | None ->
+                true
+            | Some current_location ->
+                let address = Location.to_path_exn location in
+                let current_address = Location.to_path_exn current_location in
+                Addr.is_further_right ~than:current_address address
+          in
+          if is_empty then None else Base.get (get_parent t) location
 
     let self_find_or_batch_lookup self_find lookup_parent t ids =
       assert_is_attached t ;
-      let self_found_or_none =
-        List.map ids ~f:(fun id -> (id, self_find t id))
-      in
+      let self_found_or_none = List.map ids ~f:self_find in
       let not_found =
         List.filter_map self_found_or_none ~f:(function
           | id, None ->
@@ -196,84 +203,145 @@ module Make (Inputs : Inputs_intf.S) = struct
               None )
       in
       let from_parent = lookup_parent (get_parent t) not_found in
-      let _, res =
-        List.fold_map self_found_or_none ~init:from_parent
-          ~f:(fun from_parent (id, self_found) ->
-            match (self_found, from_parent) with
-            | None, r :: rest ->
-                (rest, r)
-            | Some _, _ ->
-                (from_parent, (id, self_found))
-            | _ ->
-                failwith "unexpected number of results from DB" )
+      List.fold_map self_found_or_none ~init:from_parent
+        ~f:(fun from_parent (id, self_found) ->
+          match (self_found, from_parent) with
+          | None, r :: rest ->
+              (rest, r)
+          | Some acc_found_locally, _ ->
+              (from_parent, (id, acc_found_locally))
+          | _ ->
+              failwith "unexpected number of results from DB" )
+      |> snd
+
+    let get_batch t =
+      let self_find id =
+        let res = self_find_account t id in
+        let res =
+          if Option.is_none res then
+            let is_empty =
+              Option.value_map ~default:true t.current_location
+                ~f:(fun current_location ->
+                  let address = Location.to_path_exn id in
+                  let current_address = Location.to_path_exn current_location in
+                  Addr.is_further_right ~than:current_address address )
+            in
+            Option.some_if is_empty None
+          else Some res
+        in
+        (id, res)
       in
-      res
-
-    let get_batch = self_find_or_batch_lookup self_find_account Base.get_batch
-
-    let self_merkle_path t address =
-      Option.try_with (fun () ->
-          let rec self_merkle_path address =
-            if Addr.height ~ledger_depth:t.depth address >= t.depth then []
-            else
-              let sibling = Addr.sibling address in
-              let sibling_dir = Location.last_direction address in
-              let hash =
-                match self_find_hash t sibling with
-                | Some hash ->
-                    hash
-                | None ->
-                    (* Caught by [try_with] above. *) assert false
-              in
-              let parent_address =
-                match Addr.parent address with
-                | Ok addr ->
-                    addr
-                | Error _ ->
-                    (* Caught by [try_with] above. *) assert false
-              in
-              Direction.map sibling_dir ~left:(`Left hash) ~right:(`Right hash)
-              :: self_merkle_path parent_address
+      self_find_or_batch_lookup self_find Base.get_batch t
+
+    let empty_hash =
+      Empty_hashes.extensible_cache (module Hash) ~init_hash:Hash.empty_account
+
+    let self_path_get_hash ~hashes ~current_location height address =
+      match Map.find hashes address with
+      | Some hash ->
+          Some hash
+      | None ->
+          let is_empty =
+            match current_location with
+            | None ->
+                true
+            | Some current_location ->
+                let current_address = Location.to_path_exn current_location in
+                Addr.is_further_right ~than:current_address address
           in
-          self_merkle_path address )
+          if is_empty then Some (empty_hash height) else None
+
+    let rec self_path_impl ~element ~depth address =
+      let height = Addr.height ~ledger_depth:depth address in
+      if height >= depth then Some []
+      else
+        let%bind.Option el = element height address in
+        let%bind.Option parent_address = Addr.parent address |> Or_error.ok in
+        let%map.Option rest = self_path_impl ~element ~depth parent_address in
+        el :: rest
+
+    let self_merkle_path ~hashes ~current_location =
+      let element height address =
+        let sibling = Addr.sibling address in
+        let dir = Location.last_direction address in
+        let%map.Option sibling_hash =
+          self_path_get_hash ~hashes ~current_location height sibling
+        in
+        Direction.map dir ~left:(`Left sibling_hash) ~right:(`Right sibling_hash)
+      in
+      self_path_impl ~element
+
+    let self_wide_merkle_path ~hashes ~current_location =
+      let element height address =
+        let sibling = Addr.sibling address in
+        let dir = Location.last_direction address in
+        let%bind.Option sibling_hash =
+          self_path_get_hash ~hashes ~current_location height sibling
+        in
+        let%map.Option self_hash =
+          self_path_get_hash ~hashes ~current_location height address
+        in
+        Direction.map dir
+          ~left:(`Left (self_hash, sibling_hash))
+          ~right:(`Right (sibling_hash, self_hash))
+      in
+      self_path_impl ~element
 
     (* fixup_merkle_path patches a Merkle path reported by the parent,
        overriding with hashes which are stored in the mask *)
-    let fixup_merkle_path t path address =
-      let rec build_fixed_path path address accum =
-        if List.is_empty path then List.rev accum
-        else
-          (* first element in the path contains hash at sibling of address *)
-          let curr_element = List.hd_exn path in
-          let merkle_node_address = Addr.sibling address in
-          let mask_hash = self_find_hash t merkle_node_address in
-          let parent_hash = match curr_element with `Left h | `Right h -> h in
-          let new_hash = Option.value mask_hash ~default:parent_hash in
-          let new_element =
-            match curr_element with
-            | `Left _ ->
-                `Left new_hash
-            | `Right _ ->
-                `Right new_hash
-          in
-          build_fixed_path (List.tl_exn path) (Addr.parent_exn address)
-            (new_element :: accum)
+    let fixup_merkle_path ~hashes ~address:init =
+      let f address =
+        (* first element in the path contains hash at sibling of address *)
+        let sibling_mask_hash = Map.find hashes (Addr.sibling address) in
+        let parent_addr = Addr.parent_exn address in
+        let open Option in
+        function
+        | `Left h ->
+            (parent_addr, `Left (value sibling_mask_hash ~default:h))
+        | `Right h ->
+            (parent_addr, `Right (value sibling_mask_hash ~default:h))
       in
-      build_fixed_path path address []
+      Fn.compose snd @@ List.fold_map ~init ~f
+
+    (* fixup_merkle_path patches a Merkle path reported by the parent,
+       overriding with hashes which are stored in the mask *)
+    let fixup_wide_merkle_path ~hashes ~address:init =
+      let f address =
+        (* element in the path contains hash at sibling of address *)
+        let sibling_mask_hash = Map.find hashes (Addr.sibling address) in
+        let self_mask_hash = Map.find hashes address in
+        let parent_addr = Addr.parent_exn address in
+        let open Option in
+        function
+        | `Left (h_l, h_r) ->
+            ( parent_addr
+            , `Left
+                ( value self_mask_hash ~default:h_l
+                , value sibling_mask_hash ~default:h_r ) )
+        | `Right (h_l, h_r) ->
+            ( parent_addr
+            , `Right
+                ( value sibling_mask_hash ~default:h_l
+                , value self_mask_hash ~default:h_r ) )
+      in
+      Fn.compose snd @@ List.fold_map ~init ~f
 
     (* the following merkle_path_* functions report the Merkle path for the
        mask *)
 
     let merkle_path_at_addr_exn t address =
       assert_is_attached t ;
-      match self_merkle_path t address with
+      match
+        self_merkle_path ~depth:t.depth ~hashes:!(t.hashes)
+          ~current_location:t.current_location address
+      with
       | Some path ->
           path
       | None ->
           let parent_merkle_path =
             Base.merkle_path_at_addr_exn (get_parent t) address
           in
-          fixup_merkle_path t parent_merkle_path address
+          fixup_merkle_path ~hashes:!(t.hashes) parent_merkle_path ~address
 
     let merkle_path_at_index_exn t index =
       merkle_path_at_addr_exn t (Addr.of_int_exn ~ledger_depth:t.depth index)
@@ -281,44 +349,46 @@ module Make (Inputs : Inputs_intf.S) = struct
     let merkle_path t location =
       merkle_path_at_addr_exn t (Location.to_path_exn location)
 
-    let merkle_path_batch t locations =
+    let path_batch_impl ~fixup_path ~self_lookup ~base_lookup t locations =
       assert_is_attached t ;
-      let self_merkle_paths_rev =
-        List.rev_map locations ~f:(fun location ->
+      let parent = get_parent t in
+      let self_paths =
+        List.map locations ~f:(fun location ->
             let address = Location.to_path_exn location in
-            match self_merkle_path t address with
-            | Some path ->
-                Either.First path
-            | None ->
-                Either.Second (location, address) )
+            self_lookup ~hashes:!(t.hashes) ~current_location:t.current_location
+              ~depth:t.depth address
+            |> Option.value_map
+                 ~default:(Either.Second (location, address))
+                 ~f:Either.first )
       in
-      let parent_merkle_paths_rev =
-        let parent_locations_rev =
-          List.filter_map self_merkle_paths_rev ~f:(function
+      let all_parent_paths =
+        let locs =
+          List.filter_map self_paths ~f:(function
             | Either.First _ ->
                 None
             | Either.Second (location, _) ->
                 Some location )
         in
-        if List.is_empty parent_locations_rev then []
-        else Base.merkle_path_batch (get_parent t) parent_locations_rev
+        if List.is_empty locs then [] else base_lookup parent locs
       in
-      let rec recombine self_merkle_paths_rev parent_merkle_paths_rev acc =
-        match (self_merkle_paths_rev, parent_merkle_paths_rev) with
-        | [], [] ->
-            acc
-        | Either.First path :: self_merkle_paths_rev, parent_merkle_paths_rev ->
-            recombine self_merkle_paths_rev parent_merkle_paths_rev (path :: acc)
-        | ( Either.Second (_, address) :: self_merkle_paths_rev
-          , path :: parent_merkle_paths_rev ) ->
-            let path = fixup_merkle_path t path address in
-            recombine self_merkle_paths_rev parent_merkle_paths_rev (path :: acc)
-        | _ :: _, [] ->
-            assert false
-        | [], _ :: _ ->
-            assert false
+      let f parent_paths = function
+        | Either.First path ->
+            (parent_paths, path)
+        | Either.Second (_, address) ->
+            let path =
+              fixup_path ~hashes:!(t.hashes) ~address (List.hd_exn parent_paths)
+            in
+            (List.tl_exn parent_paths, path)
       in
-      recombine self_merkle_paths_rev parent_merkle_paths_rev []
+      snd @@ List.fold_map ~init:all_parent_paths ~f self_paths
+
+    let merkle_path_batch =
+      path_batch_impl ~base_lookup:Base.merkle_path_batch
+        ~self_lookup:self_merkle_path ~fixup_path:fixup_merkle_path
+
+    let wide_merkle_path_batch =
+      path_batch_impl ~base_lookup:Base.wide_merkle_path_batch
+        ~self_lookup:self_wide_merkle_path ~fixup_path:fixup_wide_merkle_path
 
     (* given a Merkle path corresponding to a starting address, calculate
        addresses and hashes for each node affected by the starting hash; that is,
@@ -354,14 +424,15 @@ module Make (Inputs : Inputs_intf.S) = struct
       assert_is_attached t ;
       (* remove account and key from tables *)
       let account = Option.value_exn (self_find_account t location) in
-      Location_binable.Table.remove t.account_tbl location ;
+      t.accounts := Map.remove !(t.accounts) location ;
       (* Update token info. *)
       let account_id = Account.identifier account in
-      Token_id.Table.remove t.token_owners
-        (Account_id.derive_token_id ~owner:account_id) ;
+      t.token_owners :=
+        Token_id.Map.remove !(t.token_owners)
+          (Account_id.derive_token_id ~owner:account_id) ;
       (* TODO : use stack database to save unused location, which can be used
          when allocating a location *)
-      Account_id.Table.remove t.location_tbl account_id ;
+      t.locations := Map.remove !(t.locations) account_id ;
       (* reuse location if possible *)
       Option.iter t.current_location ~f:(fun curr_loc ->
           if Location.equal location curr_loc then
@@ -386,9 +457,10 @@ module Make (Inputs : Inputs_intf.S) = struct
       self_set_account t location account ;
       (* Update token info. *)
       let account_id = Account.identifier account in
-      Token_id.Table.set t.token_owners
-        ~key:(Account_id.derive_token_id ~owner:account_id)
-        ~data:account_id
+      t.token_owners :=
+        Map.set !(t.token_owners)
+          ~key:(Account_id.derive_token_id ~owner:account_id)
+          ~data:account_id
 
     (* a write writes only to the mask, parent is not involved need to update
        both account and hash pieces of the mask *)
@@ -471,10 +543,10 @@ module Make (Inputs : Inputs_intf.S) = struct
     let commit t =
       assert_is_attached t ;
       let old_root_hash = merkle_root t in
-      let account_data = Location_binable.Table.to_alist t.account_tbl in
+      let account_data = Map.to_alist !(t.accounts) in
       Base.set_batch (get_parent t) account_data ;
-      Location_binable.Table.clear t.account_tbl ;
-      Addr.Table.clear t.hash_tbl ;
+      t.accounts := Location_binable.Map.empty ;
+      t.hashes := Addr.Map.empty ;
       Debug_assert.debug_assert (fun () ->
           [%test_result: Hash.t]
             ~message:
@@ -492,10 +564,10 @@ module Make (Inputs : Inputs_intf.S) = struct
       { uuid = Uuid_unix.create ()
       ; parent = Ok (get_parent t)
       ; detached_parent_signal = Async.Ivar.create ()
-      ; account_tbl = Location_binable.Table.copy t.account_tbl
-      ; token_owners = Token_id.Table.copy t.token_owners
-      ; location_tbl = Account_id.Table.copy t.location_tbl
-      ; hash_tbl = Addr.Table.copy t.hash_tbl
+      ; accounts = ref !(t.accounts)
+      ; token_owners = ref !(t.token_owners)
+      ; locations = ref !(t.locations)
+      ; hashes = ref !(t.hashes)
       ; current_location = t.current_location
       ; depth = t.depth
       }
@@ -558,14 +630,15 @@ module Make (Inputs : Inputs_intf.S) = struct
         t.current_location <- Some last_location ;
         Mina_stdlib.Nonempty_list.iter account_to_location_list
           ~f:(fun (key, data) ->
-            Account_id.Table.set t.location_tbl ~key ~data )
+            t.locations := Map.set !(t.locations) ~key ~data )
 
       let set_raw_account_batch t locations_and_accounts =
         List.iter locations_and_accounts ~f:(fun (location, account) ->
             let account_id = Account.identifier account in
-            Token_id.Table.set t.token_owners
-              ~key:(Account_id.derive_token_id ~owner:account_id)
-              ~data:account_id ;
+            t.token_owners :=
+              Map.set !(t.token_owners)
+                ~key:(Account_id.derive_token_id ~owner:account_id)
+                ~data:account_id ;
             self_set_account t location account )
     end)
 
@@ -580,7 +653,7 @@ module Make (Inputs : Inputs_intf.S) = struct
 
     let token_owner t tid =
       assert_is_attached t ;
-      match Token_id.Table.find t.token_owners tid with
+      match Map.find !(t.token_owners) tid with
       | Some id ->
           Some id
       | None ->
@@ -589,7 +662,7 @@ module Make (Inputs : Inputs_intf.S) = struct
     let token_owners (t : t) : Account_id.Set.t =
       assert_is_attached t ;
       let mask_owners =
-        Hashtbl.fold t.token_owners ~init:Account_id.Set.empty
+        Map.fold !(t.token_owners) ~init:Account_id.Set.empty
           ~f:(fun ~key:_tid ~data:owner acc -> Set.add acc owner)
       in
       Set.union mask_owners (Base.token_owners (get_parent t))
@@ -597,7 +670,7 @@ module Make (Inputs : Inputs_intf.S) = struct
     let tokens t pk =
       assert_is_attached t ;
       let mask_tokens =
-        Account_id.Table.keys t.location_tbl
+        Map.keys !(t.locations)
         |> List.filter_map ~f:(fun aid ->
                if Key.equal pk (Account_id.public_key aid) then
                  Some (Account_id.token_id aid)
@@ -628,9 +701,10 @@ module Make (Inputs : Inputs_intf.S) = struct
       | None ->
           Base.location_of_account (get_parent t) account_id
 
-    let location_of_account_batch =
-      self_find_or_batch_lookup self_find_location
-        Base.location_of_account_batch
+    let location_of_account_batch t =
+      self_find_or_batch_lookup
+        (fun id -> (id, Option.map ~f:Option.some @@ self_find_location t id))
+        Base.location_of_account_batch t
 
     (* Adds specified accounts to the mask by laoding them from parent ledger.
 
@@ -641,13 +715,9 @@ module Make (Inputs : Inputs_intf.S) = struct
     *)
     let unsafe_preload_accounts_from_parent t account_ids =
       assert_is_attached t ;
-      let locations =
-        Base.location_of_account_batch (get_parent t) account_ids
-      in
-      let non_empty_locations =
-        List.filter_map locations ~f:(fun (_account_id, location) -> location)
-      in
-      let accounts = Base.get_batch (get_parent t) non_empty_locations in
+      let locations = location_of_account_batch t account_ids in
+      let non_empty_locations = List.filter_map locations ~f:snd in
+      let accounts = get_batch t non_empty_locations in
       let all_hash_locations =
         let rec generate_locations account_locations acc =
           match account_locations with
@@ -731,9 +801,9 @@ module Make (Inputs : Inputs_intf.S) = struct
        as sometimes this is desired behavior *)
     let close t =
       assert_is_attached t ;
-      Location_binable.Table.clear t.account_tbl ;
-      Addr.Table.clear t.hash_tbl ;
-      Account_id.Table.clear t.location_tbl ;
+      t.accounts := Location_binable.Map.empty ;
+      t.hashes := Addr.Map.empty ;
+      t.locations := Account_id.Map.empty ;
       Async.Ivar.fill_if_empty t.detached_parent_signal ()
 
     let index_of_account_exn t key =
@@ -777,9 +847,7 @@ module Make (Inputs : Inputs_intf.S) = struct
 
     let foldi_with_ignored_accounts t ignored_accounts ~init ~f =
       assert_is_attached t ;
-      let locations_and_accounts =
-        Location_binable.Table.to_alist t.account_tbl
-      in
+      let locations_and_accounts = Map.to_alist !(t.accounts) in
       (* parent should ignore accounts in this mask *)
       let mask_accounts =
         List.map locations_and_accounts ~f:(fun (_loc, acct) ->
diff --git a/src/lib/mina_base/sparse_ledger_base.ml b/src/lib/mina_base/sparse_ledger_base.ml
index 649cff6309c..d8fe3128431 100644
--- a/src/lib/mina_base/sparse_ledger_base.ml
+++ b/src/lib/mina_base/sparse_ledger_base.ml
@@ -153,6 +153,7 @@ M.
   , set_exn
   , find_index_exn
   , add_path
+  , add_wide_path_unsafe
   , merkle_root
   , iteri )]
 
diff --git a/src/lib/mina_base/sparse_ledger_base.mli b/src/lib/mina_base/sparse_ledger_base.mli
index 3c30e910a12..6bea8d7a034 100644
--- a/src/lib/mina_base/sparse_ledger_base.mli
+++ b/src/lib/mina_base/sparse_ledger_base.mli
@@ -59,6 +59,17 @@ val add_path :
   -> Account.t
   -> t
 
+(** Same as [add_path], but using the hashes provided in the wide merkle path
+    instead of recomputing them.
+    This is unsafe: the hashes are not checked or recomputed.
+*)
+val add_wide_path_unsafe :
+     t
+  -> [ `Left of Field.t * Field.t | `Right of Field.t * Field.t ] list
+  -> Account_id.t
+  -> Account.t
+  -> t
+
 val iteri : t -> f:(Account.Index.t -> Account.t -> unit) -> unit
 
 val handler : t -> Handler.t Staged.t
diff --git a/src/lib/mina_ledger/dune b/src/lib/mina_ledger/dune
index cb4afb03975..cb8a7dbaa9c 100644
--- a/src/lib/mina_ledger/dune
+++ b/src/lib/mina_ledger/dune
@@ -53,4 +53,5 @@
    unsigned_extended
    with_hash
    ppx_version.runtime
+   direction
 ))
diff --git a/src/lib/mina_ledger/ledger.ml b/src/lib/mina_ledger/ledger.ml
index 87fb51b7ae1..0272b13c8ca 100644
--- a/src/lib/mina_ledger/ledger.ml
+++ b/src/lib/mina_ledger/ledger.ml
@@ -22,6 +22,7 @@ module Ledger_inner = struct
       | Hash of Location_at_depth.Addr.t
     [@@deriving hash, sexp, compare]
 
+    include Comparable.Make_binable (Arg)
     include Hashable.Make_binable (Arg) [@@deriving sexp, compare, hash, yojson]
   end
 
diff --git a/src/lib/mina_ledger/sparse_ledger.ml b/src/lib/mina_ledger/sparse_ledger.ml
index 10e1f5a1e78..cd9ec670915 100644
--- a/src/lib/mina_ledger/sparse_ledger.ml
+++ b/src/lib/mina_ledger/sparse_ledger.ml
@@ -6,37 +6,72 @@ module GS = Global_state
 let of_ledger_root ledger =
   of_root ~depth:(Ledger.depth ledger) (Ledger.merkle_root ledger)
 
-let of_ledger_subset_exn (oledger : Ledger.t) keys =
-  let ledger = Ledger.copy oledger in
-  let locations = Ledger.location_of_account_batch ledger keys in
-  let non_empty_locations = List.filter_map ~f:snd locations in
-  let accounts = Ledger.get_batch ledger non_empty_locations in
-  let merkle_paths = Ledger.merkle_path_batch ledger non_empty_locations in
-  let sl, _, _ =
+(*** [iterate_n ~f init n] returns [[f init, f (f init), ..]] of size [n] *)
+let iterate_n ~f =
+  let rec impl prev = function
+    | 0 ->
+        []
+    | n ->
+        let r = f prev in
+        r :: impl r (n - 1)
+  in
+  impl
+
+let of_ledger_subset_exn_impl ~path_query ~path_add (oledger : Ledger.t) keys =
+  let locations = Ledger.location_of_account_batch oledger keys in
+  let non_empty_locations = List.filter_map locations ~f:snd in
+  let num_new_accounts =
+    List.length locations - List.length non_empty_locations
+  in
+  let accounts = Ledger.get_batch oledger non_empty_locations in
+  let empty_paths, non_empty_paths =
+    let next_location_exn loc = Option.value_exn (Ledger.Location.next loc) in
+    let empty_address =
+      Ledger.Addr.of_directions
+      @@ List.init (Ledger.depth oledger) ~f:(Fn.const Direction.Left)
+    in
+    let empty_locations =
+      if num_new_accounts = 0 then []
+      else
+        let first_loc =
+          Option.value_map ~f:next_location_exn
+            ~default:(Ledger.Location.Account empty_address)
+            (Ledger.last_filled oledger)
+        in
+        first_loc
+        :: iterate_n ~f:next_location_exn first_loc (num_new_accounts - 1)
+    in
+    let paths = path_query oledger (empty_locations @ non_empty_locations) in
+    List.split_n paths num_new_accounts
+  in
+  let process_location sl key = function
+    | Some _, (_, Some account) :: accs, path :: ne_paths, epaths ->
+        (path_add sl path key account, accs, ne_paths, epaths)
+    | None, accs, ne_paths, path :: epaths ->
+        (path_add sl path key Account.empty, accs, ne_paths, epaths)
+    | Some _, (_, None) :: _, _, _ ->
+        failwith
+          "of_ledger_subset_exn: account not found for location returned by \
+           location_of_account_batch"
+    | _ ->
+        failwith "of_ledger_subset_exn: mismatched lengths"
+  in
+  let sl, _, _, _ =
     List.fold locations
-      ~init:(of_ledger_root ledger, accounts, merkle_paths)
-      ~f:(fun (sl, accounts, merkle_paths) (key, location) ->
-        match location with
-        | Some _loc -> (
-            match (accounts, merkle_paths) with
-            | (_, account) :: rest, merkle_path :: rest_merkle_paths ->
-                let sl =
-                  add_path sl merkle_path key (Option.value_exn account)
-                in
-                (sl, rest, rest_merkle_paths)
-            | _ ->
-                failwith "unexpected number of non empty accounts" )
-        | None ->
-            let path, account = Ledger.create_empty_exn ledger key in
-            let sl = add_path sl path key account in
-            (sl, accounts, merkle_paths) )
+      ~init:(of_ledger_root oledger, accounts, non_empty_paths, empty_paths)
+      ~f:(fun (sl, accs, ne_paths, epaths) (key, mloc) ->
+        process_location sl key (mloc, accs, ne_paths, epaths) )
   in
   Debug_assert.debug_assert (fun () ->
       [%test_eq: Ledger_hash.t]
-        (Ledger.merkle_root ledger)
+        (Ledger.merkle_root oledger)
         ((merkle_root sl :> Random_oracle.Digest.t) |> Ledger_hash.of_hash) ) ;
   sl
 
+let of_ledger_subset_exn =
+  of_ledger_subset_exn_impl ~path_query:Ledger.wide_merkle_path_batch
+    ~path_add:add_wide_path_unsafe
+
 let of_ledger_index_subset_exn (ledger : Ledger.Any_ledger.witness) indexes =
   List.fold indexes
     ~init:
diff --git a/src/lib/sparse_ledger_lib/dune b/src/lib/sparse_ledger_lib/dune
index d4ceea27859..8eb2fd1f42a 100644
--- a/src/lib/sparse_ledger_lib/dune
+++ b/src/lib/sparse_ledger_lib/dune
@@ -13,6 +13,8 @@
    bin_prot.shape
    result
    ppx_version.runtime
+   ;; mina
+   mina_stdlib
  )
  (preprocess
   (pps ppx_jane ppx_compare ppx_deriving_yojson ppx_version))
diff --git a/src/lib/sparse_ledger_lib/sparse_ledger.ml b/src/lib/sparse_ledger_lib/sparse_ledger.ml
index 168d408b614..bef5f273932 100644
--- a/src/lib/sparse_ledger_lib/sparse_ledger.ml
+++ b/src/lib/sparse_ledger_lib/sparse_ledger.ml
@@ -74,6 +74,17 @@ module type S = sig
   val add_path :
     t -> [ `Left of hash | `Right of hash ] list -> account_id -> account -> t
 
+  (** Same as [add_path], but using the hashes provided in the wide merkle path
+      instead of recomputing them.
+      This is unsafe: the hashes are not checked or recomputed.
+  *)
+  val add_wide_path_unsafe :
+       t
+    -> [ `Left of hash * hash | `Right of hash * hash ] list
+    -> account_id
+    -> account
+    -> t
+
   val iteri : t -> f:(int -> account -> unit) -> unit
 
   val merkle_root : t -> hash
@@ -122,54 +133,85 @@ end = struct
 
   let merkle_root { T.tree; _ } = hash tree
 
-  let add_path depth0 tree0 path0 account =
-    let rec build_tree height p =
-      match p with
-      | `Left h_r :: path ->
-          let l = build_tree (height - 1) path in
-          Tree.Node (Hash.merge ~height (hash l) h_r, l, Hash h_r)
-      | `Right h_l :: path ->
-          let r = build_tree (height - 1) path in
-          Node (Hash.merge ~height h_l (hash r), Hash h_l, r)
-      | [] ->
-          assert (height = -1) ;
-          Account account
+  let add_path_impl ~replace_self tree0 path0 account =
+    (* Takes height, left and right children and builds a pair of sibling nodes
+       one level up *)
+    let build_tail_f height (prev_l, prev_r) =
+      replace_self ~f:(fun mself ->
+          let self =
+            match mself with
+            | Some self ->
+                self
+            | None ->
+                Hash.merge ~height (hash prev_l) (hash prev_r)
+          in
+          Tree.Node (self, prev_l, prev_r) )
+    in
+    (* Builds the tail of path, i.e. part of the path that is not present in
+       the current ledger and we just add it all the way down to account
+       using the path *)
+    let build_tail hash_node_to_bottom_path =
+      let bottom_el, bottom_to_hash_node_path =
+        Mina_stdlib.Nonempty_list.(rev hash_node_to_bottom_path |> uncons)
+      in
+      (* Left and right branches of a node that is parent of the bottom node *)
+      let init = replace_self ~f:(Fn.const (Tree.Account account)) bottom_el in
+      List.foldi ~init bottom_to_hash_node_path ~f:build_tail_f
     in
-    let rec union height tree path =
-      match (tree, path) with
-      | Tree.Hash h, path ->
-          let t = build_tree height path in
-          [%test_result: Hash.t]
-            ~message:
-              "Hashes in union are not equal, something is wrong with your \
-               ledger"
-            ~expect:h (hash t) ;
-          t
-      | Node (h, l, r), `Left h_r :: path ->
-          assert (Hash.equal h_r (hash r)) ;
-          let l = union (height - 1) l path in
-          Node (h, l, r)
-      | Node (h, l, r), `Right h_l :: path ->
-          assert (Hash.equal h_l (hash l)) ;
-          let r = union (height - 1) r path in
-          Node (h, l, r)
+    (* Traverses the tree along path, collecting nodes and untraversed sibling hashes
+        Stops when encounters `Hash` or `Account` node.
+
+       Returns the last visited node (`Hash` or `Account`), remainder of path and
+       collected node/sibling hashes in bottom-to-top order.
+    *)
+    let rec traverse_through_nodes = function
+      | Tree.Account _, _ :: _ ->
+          failwith "path is longer than a tree's branch"
+      | Account _, [] | Tree.Hash _, [] ->
+          Tree.Account account
+      | Tree.Hash h, fst_el :: rest ->
+          let tail_l, tail_r =
+            build_tail (Mina_stdlib.Nonempty_list.init fst_el rest)
+          in
+          Tree.Node (h, tail_l, tail_r)
+      | Node (h, l, r), `Left _ :: rest ->
+          Tree.Node (h, traverse_through_nodes (l, rest), r)
+      | Node (h, l, r), `Right _ :: rest ->
+          Tree.Node (h, l, traverse_through_nodes (r, rest))
       | Node _, [] ->
-          failwith "Path too short"
-      | Account _, _ :: _ ->
-          failwith "Path too long"
-      | Account a, [] ->
-          assert (Account.equal a account) ;
-          tree
+          failwith "path is shorter than a tree's branch"
     in
-    union (depth0 - 1) tree0 (List.rev path0)
+    traverse_through_nodes (tree0, List.rev path0)
 
   let add_path (t : t) path account_id account =
     let index =
       List.foldi path ~init:0 ~f:(fun i acc x ->
           match x with `Right _ -> acc + (1 lsl i) | `Left _ -> acc )
     in
+    let replace_self ~f = function
+      | `Left h_r ->
+          (f None, Tree.Hash h_r)
+      | `Right h_l ->
+          (Tree.Hash h_l, f None)
+    in
+    { t with
+      tree = add_path_impl ~replace_self t.tree path account
+    ; indexes = (account_id, index) :: t.indexes
+    }
+
+  let add_wide_path_unsafe (t : t) path account_id account =
+    let index =
+      List.foldi path ~init:0 ~f:(fun i acc x ->
+          match x with `Right _ -> acc + (1 lsl i) | `Left _ -> acc )
+    in
+    let replace_self ~f = function
+      | `Left (h_l, h_r) ->
+          (f (Some h_l), Tree.Hash h_r)
+      | `Right (h_l, h_r) ->
+          (Tree.Hash h_l, f (Some h_r))
+    in
     { t with
-      tree = add_path t.depth t.tree path account
+      tree = add_path_impl ~replace_self t.tree path account
     ; indexes = (account_id, index) :: t.indexes
     }