Record location that mask parents are nulled at for dangling parent ref

src/lib/block_producer/block_producer.ml

@@ -153,7 +153,7 @@ let generate_next_state ~constraint_constants ~previous_protocol_state
         ->
           (*staged_ledger remains unchanged and transitioned_staged_ledger is discarded because the external transtion created out of this diff will be applied in Transition_frontier*)
           ignore
-          @@ Ledger.unregister_mask_exn
+          @@ Ledger.unregister_mask_exn ~loc:__LOC__
                (Staged_ledger.ledger transitioned_staged_ledger) ;
           Some
             ( diff

src/lib/bootstrap_controller/bootstrap_controller.ml

@@ -331,7 +331,8 @@ let run ~logger ~trust_system ~verifier ~network ~consensus_local_state
                     ~snarked_ledger:temp_mask ~expected_merkle_root
                     ~pending_coinbases ~get_state
                 in
-                ignore (Ledger.Maskable.unregister_mask_exn temp_mask) ;
+                ignore
+                  (Ledger.Maskable.unregister_mask_exn ~loc:__LOC__ temp_mask) ;
                 Result.map result
                   ~f:
                     (const
@@ -702,7 +703,9 @@ let%test_module "Bootstrap_controller tests" =
         Transition_frontier.(
           Breadcrumb.validated_transition (root my_net.state.frontier))
       in
-      let%bind () = Transition_frontier.close my_net.state.frontier in
+      let%bind () =
+        Transition_frontier.close ~loc:__LOC__ my_net.state.frontier
+      in
       [%log info] "bootstrap begin" ;
       Block_time.Timeout.await_exn time_controller ~timeout_duration
         (run ~logger ~trust_system ~verifier ~network:my_net.network

src/lib/coda_base/ledger.ml

@@ -212,20 +212,22 @@ module Ledger_inner = struct
     try
       let result = f masked_ledger in
       let (_ : Mask.t) =
-        Maskable.unregister_mask_exn ~grandchildren:`Recursive masked_ledger
+        Maskable.unregister_mask_exn ~loc:__LOC__ ~grandchildren:`Recursive
+          masked_ledger
       in
       result
     with exn ->
       let (_ : Mask.t) =
-        Maskable.unregister_mask_exn ~grandchildren:`Recursive masked_ledger
+        Maskable.unregister_mask_exn ~loc:__LOC__ ~grandchildren:`Recursive
+          masked_ledger
       in
       raise exn
 
   let packed t = Any_ledger.cast (module Mask.Attached) t
 
   let register_mask t mask = Maskable.register_mask (packed t) mask
 
-  let unregister_mask_exn mask = Maskable.unregister_mask_exn mask
+  let unregister_mask_exn ~loc mask = Maskable.unregister_mask_exn ~loc mask
 
   let remove_and_reparent_exn t t_as_mask =
     Maskable.remove_and_reparent_exn (packed t) t_as_mask

src/lib/coda_base/ledger.mli

@@ -77,7 +77,7 @@ include
    Merkle_mask.Maskable_merkle_tree_intf.S because at this level callers aren't
    doing reparenting and shouldn't be able to turn off the check parameter.
 *)
-val unregister_mask_exn : Mask.Attached.t -> Mask.t
+val unregister_mask_exn : loc:string -> Mask.Attached.t -> Mask.t
 
 (* The maskable ledger is t = Mask.Attached.t because register/unregister
  * work off of this type *)

src/lib/coda_lib/coda_lib.ml

@@ -834,7 +834,7 @@ let create ?wallets (config : Config.t) =
               | None ->
                   Deferred.unit
               | Some frontier ->
-                  Transition_frontier.close frontier ) ;
+                  Transition_frontier.close ~loc:__LOC__ frontier ) ;
           let handle_request name ~f query_env =
             trace_recurring name (fun () ->
                 let input = Envelope.Incoming.data query_env in

src/lib/merkle_ledger_tests/test_mask.ml

@@ -254,7 +254,7 @@ module Make (Test : Test_intf) = struct
         in
         try
           let (_unattached_mask : Mask.t) =
-            Maskable.unregister_mask_exn attached_mask
+            Maskable.unregister_mask_exn ~loc:__LOC__ attached_mask
           in
           true
         with Failure _ -> false )

src/lib/merkle_mask/maskable_merkle_tree.ml

@@ -36,7 +36,7 @@ module Make (Inputs : Inputs_intf) = struct
       {hash: string; uuid: string; total_currency: int; num_accounts: int}
     [@@deriving yojson]
 
-    type dangling = {uuid: string} [@@deriving yojson]
+    type dangling = {uuid: string; nulled_at: string} [@@deriving yojson]
 
     type display = [`Attached of attached | `Dangling_parent of dangling]
     [@@deriving yojson]
@@ -65,8 +65,8 @@ module Make (Inputs : Inputs_intf) = struct
 
     let display mask =
       try `Attached (display_attached_mask mask)
-      with Mask.Attached.Dangling_parent_reference _ ->
-        `Dangling_parent {uuid= format_uuid mask}
+      with Mask.Attached.Dangling_parent_reference (_, nulled_at) ->
+        `Dangling_parent {uuid= format_uuid mask; nulled_at}
 
     let equal mask1 mask2 =
       let open Mask.Attached in
@@ -151,7 +151,7 @@ module Make (Inputs : Inputs_intf) = struct
     Uuid.Table.add_multi registered_masks ~key:(get_uuid t) ~data:attached_mask ;
     attached_mask
 
-  let rec unregister_mask_exn ?(grandchildren = `Check)
+  let rec unregister_mask_exn ?(grandchildren = `Check) ~loc
       (mask : Mask.Attached.t) : Mask.unattached =
     let parent_uuid = Mask.Attached.get_parent mask |> get_uuid in
     let error_msg suffix =
@@ -181,8 +181,9 @@ module Make (Inputs : Inputs_intf) = struct
           ( Hashtbl.find registered_masks (Mask.Attached.get_uuid mask)
           |> Option.value ~default:[] )
           ~f:(fun child_mask ->
-            ignore @@ unregister_mask_exn ~grandchildren:`Recursive child_mask
-            ) ) ;
+            ignore
+            @@ unregister_mask_exn ~loc ~grandchildren:`Recursive child_mask )
+    ) ;
     match Uuid.Table.find registered_masks parent_uuid with
     | None ->
         failwith @@ error_msg "parent not in registered_masks"
@@ -202,7 +203,7 @@ module Make (Inputs : Inputs_intf) = struct
             | other_masks ->
                 Uuid.Table.set registered_masks ~key:parent_uuid
                   ~data:other_masks ) ) ;
-        Mask.Attached.unset_parent mask
+        Mask.Attached.unset_parent ~loc mask
 
   (** a set calls the Base implementation set, notifies registered mask childen *)
   let set t location account =
@@ -224,10 +225,10 @@ module Make (Inputs : Inputs_intf) = struct
     in
     let dangling_masks =
       List.map children ~f:(fun c ->
-          unregister_mask_exn
+          unregister_mask_exn ~loc:__LOC__
             ~grandchildren:`I_promise_I_am_reparenting_this_mask c )
     in
-    ignore (unregister_mask_exn t_as_mask) ;
+    ignore (unregister_mask_exn ~loc:__LOC__ t_as_mask) ;
     List.iter dangling_masks ~f:(fun m -> ignore (register_mask parent m))
 
   let batch_notify_mask_children t accounts =

src/lib/merkle_mask/maskable_merkle_tree_intf.ml

@@ -20,6 +20,7 @@ module type S = sig
        ?grandchildren:[ `Check
                       | `Recursive
                       | `I_promise_I_am_reparenting_this_mask ]
+    -> loc:string
     -> attached_mask
     -> unattached_mask
 

src/lib/merkle_mask/masking_merkle_tree.ml

@@ -25,7 +25,8 @@ module Make (Inputs : Inputs_intf.S) = struct
       attached one. We can capture this with a GADT but there's some annoying
       issues with bin_io to do so *)
   module Parent = struct
-    type t = Base.t option [@@deriving sexp]
+    type t = (Base.t, string (* Location where null was set *)) Result.t
+    [@@deriving sexp]
   end
 
   type t =
@@ -44,7 +45,7 @@ module Make (Inputs : Inputs_intf.S) = struct
 
   let create ~depth () =
     { uuid= Uuid_unix.create ()
-    ; parent= None
+    ; parent= Error __LOC__
     ; account_tbl= Location_binable.Table.create ()
     ; token_owners= Token_id.Table.create ()
     ; next_available_token= None
@@ -78,7 +79,9 @@ module Make (Inputs : Inputs_intf.S) = struct
 
     exception Location_is_not_account of Location.t
 
-    exception Dangling_parent_reference of Uuid.t
+    exception
+      Dangling_parent_reference of
+        Uuid.t * (* Location where null was set*) string
 
     let create () =
       failwith
@@ -90,26 +93,26 @@ module Make (Inputs : Inputs_intf.S) = struct
         "Mask.Attached.with_ledger: cannot create an attached mask; use \
          Mask.create and Mask.set_parent"
 
-    let unset_parent t =
-      assert (Option.is_some t.parent) ;
-      t.parent <- None ;
+    let unset_parent ~loc t =
+      assert (Result.is_ok t.parent) ;
+      t.parent <- Error loc ;
       t
 
     let assert_is_attached t =
       match t.parent with
-      | None ->
-          raise (Dangling_parent_reference t.uuid)
-      | Some _ ->
+      | Error loc ->
+          raise (Dangling_parent_reference (t.uuid, loc))
+      | Ok _ ->
           ()
 
     let get_parent ({parent= opt; _} as t) =
-      assert_is_attached t ; Option.value_exn opt
+      assert_is_attached t ; Result.ok_or_failwith opt
 
     let get_uuid t = assert_is_attached t ; t.uuid
 
     let get_directory t =
       assert_is_attached t ;
-      Option.bind ~f:Base.get_directory t.parent
+      Base.get_directory (Result.ok_or_failwith t.parent)
 
     let depth t = assert_is_attached t ; t.depth
 
@@ -382,7 +385,7 @@ module Make (Inputs : Inputs_intf.S) = struct
     (* copy tables in t; use same parent *)
     let copy t =
       { uuid= Uuid_unix.create ()
-      ; parent= Some (get_parent t)
+      ; parent= Ok (get_parent t)
       ; account_tbl= Location_binable.Table.copy t.account_tbl
       ; token_owners= Token_id.Table.copy t.token_owners
       ; next_available_token= t.next_available_token
@@ -744,9 +747,9 @@ module Make (Inputs : Inputs_intf.S) = struct
   end
 
   let set_parent t parent =
-    assert (Option.is_none t.parent) ;
+    assert (Result.is_error t.parent) ;
     assert (Int.equal t.depth (Base.depth parent)) ;
-    t.parent <- Some parent ;
+    t.parent <- Ok parent ;
     t.current_location <- Attached.last_filled t ;
     t
 

src/lib/merkle_mask/masking_merkle_tree_intf.ml

@@ -46,7 +46,9 @@ module type S = sig
        and type account_id := account_id
        and type account_id_set := account_id_set
 
-    exception Dangling_parent_reference of Uuid.t
+    exception
+      Dangling_parent_reference of
+        Uuid.t * (* Location where null was set*) string
 
     (** get hash from mask, if present, else from its parent *)
     val get_hash : t -> Addr.t -> hash option
@@ -55,7 +57,7 @@ module type S = sig
     val commit : t -> unit
 
     (** remove parent *)
-    val unset_parent : t -> unattached
+    val unset_parent : loc:string -> t -> unattached
 
     (** get mask parent *)
     val get_parent : t -> parent

src/lib/staged_ledger/staged_ledger.ml

@@ -1926,7 +1926,8 @@ let%test_module "test" =
           in
           let sl = ref @@ Sl.create_exn ~constraint_constants ~ledger in
           Async.Thread_safe.block_on_async_exn (fun () -> f sl test_mask) ;
-          ignore @@ Ledger.Maskable.unregister_mask_exn test_mask )
+          ignore @@ Ledger.Maskable.unregister_mask_exn ~loc:__LOC__ test_mask
+      )
 
     (* Assert the given staged ledger is in the correct state after applying
          the first n user commands passed to the given base ledger. Checks the

src/lib/transition_frontier/full_frontier/full_frontier.ml

@@ -96,10 +96,10 @@ let protocol_states_for_root_scan_state t =
 
 let best_tip t = find_exn t t.best_tip
 
-let close t =
+let close ~loc t =
   Coda_metrics.(Gauge.set Transition_frontier.active_breadcrumbs 0.0) ;
   ignore
-    (Ledger.Maskable.unregister_mask_exn ~grandchildren:`Recursive
+    (Ledger.Maskable.unregister_mask_exn ~loc ~grandchildren:`Recursive
        (Breadcrumb.mask (root t)))
 
 let create ~logger ~root_data ~root_ledger ~consensus_local_state ~max_length
@@ -385,7 +385,7 @@ let move_root t ~new_root_hash ~new_root_protocol_states ~garbage
         let breadcrumb = find_exn t hash in
         let mask = Breadcrumb.mask breadcrumb in
         (* this should get garbage collected and should not require additional destruction *)
-        ignore (Ledger.Maskable.unregister_mask_exn mask) ;
+        ignore (Ledger.Maskable.unregister_mask_exn ~loc:__LOC__ mask) ;
         Hashtbl.remove t.table hash ) ;
     (* STEP 2 *)
     (* go ahead and remove the old root from the frontier *)
@@ -440,7 +440,7 @@ let move_root t ~new_root_hash ~new_root_protocol_states ~garbage
       (* STEP 6 *)
       Ledger.commit mt ;
       (* STEP 7 *)
-      ignore (Ledger.Maskable.unregister_mask_exn mt) ) ;
+      ignore (Ledger.Maskable.unregister_mask_exn ~loc:__LOC__ mt) ) ;
     new_staged_ledger
   in
   (* rewrite the new root breadcrumb to contain the new root mask *)

src/lib/transition_frontier/full_frontier/full_frontier.mli

@@ -34,7 +34,7 @@ val create :
   -> precomputed_values:Precomputed_values.t
   -> t
 
-val close : t -> unit
+val close : loc:string -> t -> unit
 
 val root_data : t -> Root_data.t
 

src/lib/transition_frontier/transition_frontier.ml

@@ -249,7 +249,7 @@ let load ?(retry_with_fresh_db = true) ~logger ~verifier ~consensus_local_state
 
 (* The persistent root and persistent frontier as safe to ignore here
  * because their lifecycle is longer than the transition frontier's *)
-let close
+let close ~loc
     { logger
     ; verifier= _
     ; consensus_local_state= _
@@ -261,7 +261,7 @@ let close
     ; extensions
     ; genesis_state_hash= _ } =
   [%log trace] "Closing transition frontier" ;
-  Full_frontier.close full_frontier ;
+  Full_frontier.close ~loc full_frontier ;
   Extensions.close extensions ;
   let%map () =
     Persistent_frontier.Instance.destroy persistent_frontier_instance

src/lib/transition_frontier/transition_frontier.mli

@@ -45,7 +45,7 @@ val load :
        | `Persistent_frontier_malformed ] )
      Deferred.Result.t
 
-val close : t -> unit Deferred.t
+val close : loc:string -> t -> unit Deferred.t
 
 val add_breadcrumb_exn : t -> Breadcrumb.t -> unit Deferred.t
 

src/lib/transition_router/transition_router.ml

@@ -306,7 +306,7 @@ let initialize ~logger ~network ~is_seed ~is_demo_mode ~verifier ~trust_system
         let initial_root_transition =
           Transition_frontier.(Breadcrumb.validated_transition (root frontier))
         in
-        let%map () = Transition_frontier.close frontier in
+        let%map () = Transition_frontier.close ~loc:__LOC__ frontier in
         start_bootstrap_controller ~logger ~trust_system ~verifier ~network
           ~time_controller ~producer_transition_reader_ref
           ~producer_transition_writer_ref ~verified_transition_writer
@@ -501,7 +501,9 @@ let run ~logger ~trust_system ~verifier ~network ~is_seed ~is_demo_mode
                             let%bind () =
                               Strict_pipe.Writer.write clear_writer `Clear
                             in
-                            let%map () = Transition_frontier.close frontier in
+                            let%map () =
+                              Transition_frontier.close ~loc:__LOC__ frontier
+                            in
                             start_bootstrap_controller ~logger ~trust_system
                               ~verifier ~network ~time_controller
                               ~producer_transition_reader_ref