Merge pull request #10121 from MinaProtocol/lk86/simpler-optimized-st…

…aged-ledger-compatible

Lk86/simpler optimized staged ledger compatible

src/app/cli/src/init/transaction_snark_profiler.ml

@@ -153,10 +153,9 @@ let profile (module T : Transaction_snark.S) sparse_ledger0
  let next_available_token_before =
  Sparse_ledger.next_available_token sparse_ledger
  in
- let sparse_ledger', _ =
- Sparse_ledger.apply_transaction ~constraint_constants ~txn_state_view
- sparse_ledger (Transaction.forget t)
- |> Or_error.ok_exn
+ let sparse_ledger' =
+ Sparse_ledger.apply_transaction_exn ~constraint_constants
+ ~txn_state_view sparse_ledger (Transaction.forget t)
  in
  let next_available_token_after =
  Sparse_ledger.next_available_token sparse_ledger'
@@ -221,10 +220,9 @@ let check_base_snarks sparse_ledger0 (transitions : Transaction.Valid.t list)
  let next_available_token_before =
  Sparse_ledger.next_available_token sparse_ledger
  in
- let sparse_ledger', _ =
- Sparse_ledger.apply_transaction ~constraint_constants
+ let sparse_ledger' =
+ Sparse_ledger.apply_transaction_exn ~constraint_constants
  ~txn_state_view sparse_ledger (Transaction.forget t)
- |> Or_error.ok_exn
  in
  let next_available_token_after =
  Sparse_ledger.next_available_token sparse_ledger'
@@ -269,10 +267,9 @@ let generate_base_snarks_witness sparse_ledger0
  let next_available_token_before =
  Sparse_ledger.next_available_token sparse_ledger
  in
- let sparse_ledger', _ =
- Sparse_ledger.apply_transaction ~constraint_constants
+ let sparse_ledger' =
+ Sparse_ledger.apply_transaction_exn ~constraint_constants
  ~txn_state_view sparse_ledger (Transaction.forget t)
- |> Or_error.ok_exn
  in
  let next_available_token_after =
  Sparse_ledger.next_available_token sparse_ledger'

src/lib/merkle_ledger/any_ledger.ml

@@ -120,8 +120,6 @@ module Make_base (Inputs : Inputs_intf) :
 
  let merkle_path (T ((module Base), t)) = Base.merkle_path t
 
- let merkle_path_batch (T ((module Base), t)) = Base.merkle_path_batch t
-
  let merkle_root (T ((module Base), t)) = Base.merkle_root t
 
  let index_of_account_exn (T ((module Base), t)) =

src/lib/merkle_ledger/base_ledger_intf.ml

@@ -139,8 +139,6 @@ module type S = sig
 
  val merkle_path : t -> Location.t -> Path.t
 
- val merkle_path_batch : t -> Location.t list -> (Location.t * Path.t) list
-
  val merkle_path_at_index_exn : t -> int -> Path.t
 
  val remove_accounts_exn : t -> account_id list -> unit

src/lib/merkle_ledger/database.ml

@@ -154,17 +154,6 @@ module Make (Inputs : Inputs_intf) :
  | None ->
  empty_hash (Location.height ~ledger_depth:mdb.depth location)
 
- let get_hash_batch mdb locs =
- assert (List.for_all locs ~f:Location.is_hash) ;
- get_bin_batch mdb locs Hash.bin_read_t
- |> List.zip_exn locs
- |> List.map ~f:(fun (loc, result) ->
- match result with
- | Some hashes ->
- hashes
- | None ->
- empty_hash (Location.height ~ledger_depth:mdb.depth loc))
-
  let account_list_bin { kvdb; _ } account_bin_read : Account.t list =
  let all_keys_values = Kvdb.to_alist kvdb in
  (* see comment at top of location.ml about encoding of locations *)
@@ -755,38 +744,6 @@ module Make (Inputs : Inputs_intf) :
  in
  loop location
 
- let merkle_path_batch mdb =
- let rec loop height locs =
- if height >= mdb.depth then List.init (List.length locs) ~f:(Fn.const [])
- else
- let siblings = List.map locs ~f:Location.sibling in
- let hashes = get_hash_batch mdb siblings in
- let this_layer =
- List.zip_exn locs hashes
- |> List.map ~f:(fun (loc, hash) ->
- loc |> Location.to_path_exn |> Location.last_direction
- |> Direction.map ~left:(`Left hash) ~right:(`Right hash))
- in
- let next_layer = loop (height + 1) (List.map locs ~f:Location.parent) in
- List.zip_exn this_layer next_layer |> List.map ~f:(fun (h, t) -> h :: t)
- in
- fun locs ->
- let locs =
- List.map locs ~f:(fun loc ->
- if Location.is_account loc then
- Location.Hash (Location.to_path_exn loc)
- else loc)
- in
- match locs with
- | [] ->
- []
- | first_loc :: _ ->
- let height = Location.height ~ledger_depth:mdb.depth first_loc in
- assert (
- List.for_all locs ~f:(fun loc ->
- Location.height ~ledger_depth:mdb.depth loc = height) ) ;
- List.zip_exn locs (loop height locs)
-
  let merkle_path_at_addr_exn t addr = merkle_path t (Location.Hash addr)
 
  let merkle_path_at_index_exn t index =

src/lib/merkle_ledger/null_ledger.ml

@@ -64,9 +64,6 @@ end = struct
  in
  loop location
 
- let merkle_path_batch t locs =
- List.zip_exn locs (List.map locs ~f:(merkle_path t))
-
  let merkle_root t = empty_hash_at_height t.depth
 
  let merkle_path_at_addr_exn t addr = merkle_path t (Location.Hash addr)

src/lib/merkle_mask/masking_merkle_tree.ml

@@ -240,14 +240,6 @@ module Make (Inputs : Inputs_intf.S) = struct
  let parent_merkle_path = Base.merkle_path (get_parent t) location in
  fixup_merkle_path t parent_merkle_path address
 
- (* TODO: we should be able to optimize this some with a little thought *)
- let merkle_path_batch t locations =
- assert_is_attached t ;
- locations
- |> Base.merkle_path_batch (get_parent t)
- |> List.map ~f:(fun (loc, path) ->
- (loc, fixup_merkle_path t path (Location.to_path_exn loc)))
-
  (* given a Merkle path corresponding to a starting address, calculate
  addresses and hashes for each node affected by the starting hash; that is,
  along the path from the account address to root *)
@@ -770,47 +762,37 @@ module Make (Inputs : Inputs_intf.S) = struct
  ( Addr.of_directions
  @@ List.init ledger_depth ~f:(fun _ -> Direction.Left) )
 
- let next_location t =
- let maybe_location =
- match last_filled t with
- | None ->
- Some (first_location ~ledger_depth:t.depth)
- | Some loc ->
- Location.next loc
- in
- match maybe_location with
- | None ->
- Or_error.error_string "Db_error.Out_of_leaves"
- | Some location ->
- Ok location
-
  let loc_max a b =
  let a' = Location.to_path_exn a in
  let b' = Location.to_path_exn b in
  if Location.Addr.compare a' b' > 0 then a else b
 
- (* NB: unsafe to call if account_id is already in ledger *)
- let unsafe_create_account t account_id account =
- let open Or_error.Let_syntax in
- let%map location = next_location t in
- set t location account ;
- self_set_location t account_id location ;
- t.current_location <- Some location ;
- location
-
  (* NB: updates the mutable current_location field in t *)
  let get_or_create_account t account_id account =
- let open Or_error.Let_syntax in
  assert_is_attached t ;
  match self_find_location t account_id with
  | None -> (
  (* not in mask, maybe in parent *)
  match Base.location_of_account (get_parent t) account_id with
  | Some location ->
  Ok (`Existed, location)
- | None ->
- let%map location = unsafe_create_account t account_id account in
- (`Added, location) )
+ | None -> (
+ (* not in parent, create new location *)
+ let maybe_location =
+ match last_filled t with
+ | None ->
+ Some (first_location ~ledger_depth:t.depth)
+ | Some loc ->
+ Location.next loc
+ in
+ match maybe_location with
+ | None ->
+ Or_error.error_string "Db_error.Out_of_leaves"
+ | Some location ->
+ set t location account ;
+ self_set_location t account_id location ;
+ t.current_location <- Some location ;
+ Ok (`Added, location) ) )
  | Some location ->
  Ok (`Existed, location)
 

src/lib/merkle_mask/masking_merkle_tree_intf.ml

@@ -1,6 +1,4 @@
 (* masking_merkle_tree_intf.ml *)
-open Core_kernel
-
 (* the type of a Merkle tree mask associated with a parent Merkle tree *)
 module type S = sig
  type t
@@ -55,10 +53,6 @@ module type S = sig
  (** get hash from mask, if present, else from its parent *)
  val get_hash : t -> Addr.t -> hash option
 
- (** registers a new account in the ledger; unsafe to call if account id already exists *)
- val unsafe_create_account :
- t -> account_id -> account -> Location.t Or_error.t
-
  (** commit all state to the parent, flush state locally *)
  val commit : t -> unit
 

src/lib/mina_base/dune

@@ -51,7 +51,7 @@
  (preprocessor_deps ../../config.mlh)
  (preprocess
  (pps ppx_snarky ppx_here ppx_coda ppx_version ppx_compare ppx_deriving.enum ppx_deriving.ord
- ppx_base ppx_bench ppx_let ppx_optcomp ppx_sexp_conv ppx_bin_prot ppx_fields_conv ppx_custom_printf ppx_pipebang ppx_assert ppx_deriving_yojson ppx_inline_test h_list.ppx
+ ppx_base ppx_bench ppx_let ppx_optcomp ppx_sexp_conv ppx_bin_prot ppx_fields_conv ppx_custom_printf ppx_assert ppx_deriving_yojson ppx_inline_test h_list.ppx
  ))
  (instrumentation (backend bisect_ppx))
  (synopsis "Snarks and friends necessary for keypair generation"))

src/lib/mina_base/ledger.mli

@@ -1,6 +1,5 @@
 open Core
 open Signature_lib
-open Transaction_logic
 
 module Location : Merkle_ledger.Location_intf.S
 
@@ -101,8 +100,88 @@ val register_mask : t -> Mask.t -> Mask.Attached.t
 
 val commit : Mask.Attached.t -> unit
 
-val unsafe_create_account :
- t -> Account_id.t -> Account.t -> Location.t Or_error.t
+module Transaction_applied : sig
+ open Transaction_logic
+
+ module Signed_command_applied : sig
+ module Common : sig
+ type t = Transaction_applied.Signed_command_applied.Common.t =
+ { user_command : Signed_command.t With_status.t
+ ; previous_receipt_chain_hash : Receipt.Chain_hash.t
+ ; fee_payer_timing : Account.Timing.t
+ ; source_timing : Account.Timing.t option
+ }
+ [@@deriving sexp]
+ end
+
+ module Body : sig
+ type t = Transaction_applied.Signed_command_applied.Body.t =
+ | Payment of { previous_empty_accounts : Account_id.t list }
+ | Stake_delegation of
+ { previous_delegate : Public_key.Compressed.t option }
+ | Create_new_token of { created_token : Token_id.t }
+ | Create_token_account
+ | Mint_tokens
+ | Failed
+ [@@deriving sexp]
+ end
+
+ type t = Transaction_applied.Signed_command_applied.t =
+ { common : Common.t; body : Body.t }
+ [@@deriving sexp]
+ end
+
+ module Snapp_command_applied : sig
+ type t = Transaction_applied.Snapp_command_applied.t =
+ { accounts : (Account_id.t * Account.t option) list
+ ; command : Snapp_command.t With_status.t
+ }
+ [@@deriving sexp]
+ end
+
+ module Command_applied : sig
+ type t = Transaction_applied.Command_applied.t =
+ | Signed_command of Signed_command_applied.t
+ | Snapp_command of Snapp_command_applied.t
+ [@@deriving sexp]
+ end
+
+ module Fee_transfer_applied : sig
+ type t = Transaction_applied.Fee_transfer_applied.t =
+ { fee_transfer : Fee_transfer.t
+ ; previous_empty_accounts : Account_id.t list
+ ; receiver_timing : Account.Timing.t
+ ; balances : Transaction_status.Fee_transfer_balance_data.t
+ }
+ [@@deriving sexp]
+ end
+
+ module Coinbase_applied : sig
+ type t = Transaction_applied.Coinbase_applied.t =
+ { coinbase : Coinbase.t
+ ; previous_empty_accounts : Account_id.t list
+ ; receiver_timing : Account.Timing.t
+ ; balances : Transaction_status.Coinbase_balance_data.t
+ }
+ [@@deriving sexp]
+ end
+
+ module Varying : sig
+ type t = Transaction_applied.Varying.t =
+ | Command of Command_applied.t
+ | Fee_transfer of Fee_transfer_applied.t
+ | Coinbase of Coinbase_applied.t
+ [@@deriving sexp]
+ end
+
+ type t = Transaction_applied.t =
+ { previous_hash : Ledger_hash.t; varying : Varying.t }
+ [@@deriving sexp]
+
+ val transaction : t -> Transaction.t With_status.t
+
+ val user_command_status : t -> Transaction_status.t
+end
 
 (** Raises if the ledger is full, or if an account already exists for the given
  [Account_id.t].