Create faster populate from genesis API

Instead of having a populate_root method to populate an existing, empty
root ledger from genesis, the genesis ledger now has a create_root
method. This method assumes the responsibility for creating the root
ledger itself. The create_root method can thus checkpoint the genesis
ledger directly when the genesis ledger is backed by a database.

Author: cjjdespres

src/lib/consensus/proof_of_stake.ml

@@ -2666,14 +2666,9 @@ module Make_str (A : Wire_types.Concrete) = struct
                       | Ledger_snapshot.Ledger_root ledger ->
                           Ok ledger
                       | Ledger_snapshot.Genesis_epoch_ledger packed ->
-                          let fresh_root_ledger =
-                            Mina_ledger.Ledger.Root.create ~logger
-                              ~config:snapshot_config
-                              ~depth:Context.constraint_constants.ledger_depth
-                              ()
-                          in
-                          Genesis_ledger.Packed.populate_root packed
-                            fresh_root_ledger )
+                          Genesis_ledger.Packed.create_root packed
+                            ~config:snapshot_config
+                            ~depth:Context.constraint_constants.ledger_depth () )
                 in
                 match snapshot_id with
                 | Staking_epoch_snapshot ->

src/lib/genesis_ledger/genesis_ledger.ml

@@ -66,18 +66,19 @@ module Balances (Balances : Intf.Named_balances_intf) = struct
 end
 
 module Utils = struct
-  let populate_root_with_backing_root genesis_mask ~src ~dest =
-    let open Or_error.Let_syntax in
+  (* Create a new [Ledger.Root.t] ledger with the components of a root
+     backing_ledger for a genesis ledger. These components are the underlying
+     root ledger and the stored mask on top of that root that is presented to
+     users of the genesis root. The mask is passed in to this function so we can
+     assert that there are no uncommitted changes to it, so we can simply
+     checkpoint the root instead of performing a much slower account transfer. *)
+  let create_root_from_backing_root genesis_mask root ~config ~depth () =
     assert (
       Ledger_hash.equal
         (Ledger.merkle_root genesis_mask)
-        (Ledger.Root.merkle_root src) ) ;
-    let%map _root =
-      Ledger_transfer_any.transfer_accounts
-        ~src:(Ledger.Root.as_unmasked src)
-        ~dest:(Ledger.Root.as_unmasked dest)
-    in
-    dest
+        (Ledger.Root.merkle_root root) ) ;
+    assert (Ledger.Root.depth root = depth) ;
+    Ledger.Root.create_checkpoint ~config root () |> Or_error.return
 
   let keypair_of_account_record_exn (private_key, account) =
     let open Account in
@@ -163,11 +164,12 @@ module Make (Inputs : Intf.Ledger_input_intf) : Intf.S = struct
 
   let t = Lazy.map ~f:snd backing_ledger
 
-  let populate_root root =
+  let create_root ~config ~depth () =
     let backing_ledger, mask = Lazy.force backing_ledger in
     match backing_ledger with
     | `Ephemeral ledger ->
         let open Or_error.Let_syntax in
+        let root = Ledger.Root.create ~logger ~config ~depth () in
         (* We are transferring to an unmasked view of the root, so this is
            used solely for the transfer side effect *)
         let%map _dest =
@@ -176,7 +178,7 @@ module Make (Inputs : Intf.Ledger_input_intf) : Intf.S = struct
         in
         root
     | `Root ledger ->
-        populate_root_with_backing_root mask ~src:ledger ~dest:root
+        create_root_from_backing_root mask ledger ~config ~depth ()
 
   include Utils
 
@@ -214,7 +216,7 @@ module Packed = struct
 
   let t ((module L) : t) = L.t
 
-  let populate_root ((module L) : t) ledger = L.populate_root ledger
+  let create_root ((module L) : t) = L.create_root
 
   let depth ((module L) : t) = L.depth
 
@@ -258,9 +260,9 @@ end) : Intf.S = struct
 
   include Utils
 
-  let populate_root dest =
+  let create_root ~config ~depth () =
     let genesis_root, mask = Lazy.force backing_ledger in
-    populate_root_with_backing_root mask ~src:genesis_root ~dest
+    create_root_from_backing_root mask genesis_root ~config ~depth ()
 
   let find_account_record_exn ~f =
     find_account_record_exn ~f (Lazy.force accounts)

src/lib/genesis_ledger/intf.ml

@@ -74,9 +74,12 @@ end
 module type S = sig
   val t : Mina_ledger.Ledger.t Lazy.t
 
-  (** Populate a root ledger with the content of the genesis ledger *)
-  val populate_root :
-    Mina_ledger.Ledger.Root.t -> Mina_ledger.Ledger.Root.t Or_error.t
+  (** Create a new root ledger that is equal in state to the genesis ledger *)
+  val create_root :
+       config:Mina_ledger.Ledger.Root.Config.t
+    -> depth:int
+    -> unit
+    -> Mina_ledger.Ledger.Root.t Or_error.t
 
   val depth : int
 

src/lib/genesis_proof/genesis_proof.ml

@@ -115,8 +115,8 @@ module T = struct
   let genesis_ledger { genesis_ledger; _ } =
     Genesis_ledger.Packed.t genesis_ledger
 
-  let populate_root { genesis_ledger; _ } =
-    Genesis_ledger.Packed.populate_root genesis_ledger
+  let create_root { genesis_ledger; _ } =
+    Genesis_ledger.Packed.create_root genesis_ledger
 
   let genesis_epoch_data { genesis_epoch_data; _ } = genesis_epoch_data
 

src/lib/transition_frontier/full_frontier/full_frontier.ml

@@ -1025,7 +1025,8 @@ module For_tests = struct
         ~directory:(Filename.temp_file "snarked_ledger" "")
         ~ledger_depth
     in
-    Persistent_root.reset_to_genesis_exn ~precomputed_values persistent_root ;
+    Async.Thread_safe.block_on_async_exn (fun () ->
+        Persistent_root.reset_to_genesis_exn persistent_root ~precomputed_values ) ;
     let persistent_root_instance =
       Persistent_root.create_instance_exn persistent_root
     in

src/lib/transition_frontier/persistent_root/persistent_root.ml

@@ -309,15 +309,27 @@ let with_instance_exn t ~f =
   let x = f instance in
   Instance.close instance ; x
 
-let reset_to_genesis_exn t ~precomputed_values =
+(** Clear the factory directory and recreate the snarked ledger instance for
+    this factory with [create_root] and [setup] *)
+let reset_factory_root_exn t ~create_root ~setup =
+  let open Async.Deferred.Let_syntax in
   assert (Option.is_none t.instance) ;
-  Mina_stdlib_unix.File_system.rmrf t.directory ;
-  with_instance_exn t ~f:(fun instance ->
-      ignore
-        ( Precomputed_values.populate_root precomputed_values
-            (Instance.snarked_ledger instance)
-          |> Or_error.map ~f:Ledger.Root.as_unmasked
-          : Ledger.Any_ledger.witness Or_error.t ) ;
+  let%map () =
+    Mina_stdlib_unix.File_system.create_dir ~clear_if_exists:true t.directory
+  in
+  let root =
+    create_root
+      ~config:(Instance.Config.snarked_ledger t)
+      ~depth:t.ledger_depth ()
+    |> Or_error.ok_exn
+  in
+  Ledger.Root.close root ;
+  with_instance_exn t ~f:setup
+
+let reset_to_genesis_exn t ~precomputed_values =
+  reset_factory_root_exn t
+    ~create_root:(Precomputed_values.create_root precomputed_values)
+    ~setup:(fun instance ->
       Instance.set_root_identifier instance
         (genesis_root_identifier
            ~genesis_state_hash:

src/lib/transition_frontier/persistent_root/persistent_root.mli

@@ -105,4 +105,11 @@ val load_from_disk_exn :
 
 val with_instance_exn : t -> f:(Instance_type.t -> 'a) -> 'a
 
-val reset_to_genesis_exn : t -> precomputed_values:Genesis_proof.t -> unit
+val reset_factory_root_exn :
+     t
+  -> create_root:(config:Root.Config.t -> depth:int -> unit -> Root.t Or_error.t)
+  -> setup:(Instance_type.t -> 'a)
+  -> 'a Async.Deferred.t
+
+val reset_to_genesis_exn :
+  t -> precomputed_values:Genesis_proof.t -> unit Async.Deferred.t

src/lib/transition_frontier/transition_frontier.ml

@@ -283,7 +283,9 @@ let rec load_with_max_length :
           (State_hash.With_state_hashes.state_hash
              precomputed_values.protocol_state_with_hashes )
     in
-    Persistent_root.reset_to_genesis_exn persistent_root ~precomputed_values ;
+    let%bind () =
+      Persistent_root.reset_to_genesis_exn persistent_root ~precomputed_values
+    in
     let genesis_ledger_hash =
       Precomputed_values.genesis_ledger precomputed_values
       |> Lazy.force |> Ledger.merkle_root |> Frozen_ledger_hash.of_ledger_hash
@@ -684,8 +686,8 @@ module For_tests = struct
 
   let gen ?(logger = Logger.null ()) ~verifier ?trust_system
       ?consensus_local_state ~precomputed_values
-      ?(populate_root_and_accounts =
-        ( Precomputed_values.populate_root precomputed_values
+      ?(create_root_and_accounts =
+        ( Precomputed_values.create_root precomputed_values
         , Lazy.force (Precomputed_values.accounts precomputed_values) ))
       ?(gen_root_breadcrumb =
         gen_genesis_breadcrumb_with_protocol_states ~logger ~verifier
@@ -724,7 +726,7 @@ module For_tests = struct
                   precomputed_values.protocol_state_with_hashes )
              ~epoch_ledger_backing_type:Stable_db )
     in
-    let populate_root, root_ledger_accounts = populate_root_and_accounts in
+    let create_root, root_ledger_accounts = create_root_and_accounts in
     (* TODO: ensure that rose_tree cannot be longer than k *)
     let%bind root, branches, protocol_states =
       let%bind root, protocol_states = gen_root_breadcrumb in
@@ -755,12 +757,12 @@ module For_tests = struct
           ~genesis_state_hash:
             (State_hash.With_state_hashes.state_hash
                precomputed_values.protocol_state_with_hashes ) ) ;
-    Persistent_root.with_instance_exn persistent_root ~f:(fun instance ->
-        let transition = Root_data.Limited.transition root_data in
-        Persistent_root.Instance.set_root_state_hash instance
-          (Mina_block.Validated.state_hash transition) ;
-        ignore
-        @@ populate_root (Persistent_root.Instance.snarked_ledger instance) ) ;
+    Async.Thread_safe.block_on_async_exn (fun () ->
+        Persistent_root.reset_factory_root_exn persistent_root ~create_root
+          ~setup:(fun instance ->
+            let transition = Root_data.Limited.transition root_data in
+            Persistent_root.Instance.set_root_state_hash instance
+              (Mina_block.Validated.state_hash transition) ) ) ;
     let frontier_result =
       Async.Thread_safe.block_on_async_exn (fun () ->
           load_with_max_length ~max_length ~retry_with_fresh_db:false
@@ -797,21 +799,21 @@ module For_tests = struct
 
   let gen_with_branch ?logger ~verifier ?trust_system ?consensus_local_state
       ~precomputed_values
-      ?(populate_root_and_accounts =
-        ( Precomputed_values.populate_root precomputed_values
+      ?(create_root_and_accounts =
+        ( Precomputed_values.create_root precomputed_values
         , Lazy.force (Precomputed_values.accounts precomputed_values) ))
       ?gen_root_breadcrumb ?(get_branch_root = root) ~max_length ~frontier_size
       ~branch_size () =
     let open Quickcheck.Generator.Let_syntax in
     let%bind frontier =
       gen ?logger ~verifier ?trust_system ?consensus_local_state
-        ~precomputed_values ?gen_root_breadcrumb ~populate_root_and_accounts
+        ~precomputed_values ?gen_root_breadcrumb ~create_root_and_accounts
         ~max_length ~size:frontier_size ()
     in
     let%map make_branch =
       Breadcrumb.For_tests.gen_seq ?logger ~precomputed_values ~verifier
         ?trust_system
-        ~accounts_with_secret_keys:(snd populate_root_and_accounts)
+        ~accounts_with_secret_keys:(snd create_root_and_accounts)
         branch_size
     in
     let branch =

src/lib/transition_frontier/transition_frontier.mli

@@ -152,8 +152,10 @@ module For_tests : sig
     -> ?trust_system:Trust_system.t
     -> ?consensus_local_state:Consensus.Data.Local_state.t
     -> precomputed_values:Precomputed_values.t
-    -> ?populate_root_and_accounts:
-         (   Mina_ledger.Ledger.Root.t
+    -> ?create_root_and_accounts:
+         (   config:Mina_ledger.Ledger.Root.Config.t
+          -> depth:int
+          -> unit
           -> Mina_ledger.Ledger.Root.t Core_kernel.Or_error.t )
          * (Private_key.t option * Account.t) list
     -> ?gen_root_breadcrumb:
@@ -173,8 +175,10 @@ module For_tests : sig
     -> ?trust_system:Trust_system.t
     -> ?consensus_local_state:Consensus.Data.Local_state.t
     -> precomputed_values:Precomputed_values.t
-    -> ?populate_root_and_accounts:
-         (   Mina_ledger.Ledger.Root.t
+    -> ?create_root_and_accounts:
+         (   config:Mina_ledger.Ledger.Root.Config.t
+          -> depth:int
+          -> unit
           -> Mina_ledger.Ledger.Root.t Core_kernel.Or_error.t )
          * (Private_key.t option * Account.t) list
     -> ?gen_root_breadcrumb: