diff --git a/src/lib_protocol_environment/sigs/v5/fallbackArray.mli b/src/lib_protocol_environment/sigs/v5/fallbackArray.mli index 71dd14d3c3e794bdc5c255fdc00ef4fadb85e90a..5ad040732304ba0785661150e0c10ea18fcdf835 100644 --- a/src/lib_protocol_environment/sigs/v5/fallbackArray.mli +++ b/src/lib_protocol_environment/sigs/v5/fallbackArray.mli @@ -39,6 +39,11 @@ type 'a t [v]. The value [v] is the fallback value for [a]. *) val make : int -> 'a -> 'a t +(** [of_list ~fallback ~proj l] builds a fallback array [a] of length + [List.length l] where each cell [i] is initialized by [proj (List.nth l i)] + and the fallback value is [fallback]. *) +val of_list : fallback:'b -> proj:('a -> 'b) -> 'a list -> 'b t + (** [fallback a] returns the fallback value for [a]. *) val fallback : 'a t -> 'a diff --git a/src/lib_stdlib/fallbackArray.ml b/src/lib_stdlib/fallbackArray.ml index d23bc109104837b501c53da3c3ddfbfce6cd5e97..aba7facfd86f30895a5b6bd2f883406afbfc1111 100644 --- a/src/lib_stdlib/fallbackArray.ml +++ b/src/lib_stdlib/fallbackArray.ml @@ -28,3 +28,11 @@ include ReadOnlyArray let set array idx v = let len = length array in if idx >= 0 && idx < len then Array.unsafe_set array idx v else () + +let of_list ~fallback ~proj l = + let length = List.length l in + let arr = make length fallback in + (* the initial construction of the array guarantees that we can always use + unsafe_set since the condition check in set is always true. *) + List.iteri (fun i e -> Array.unsafe_set arr i (proj e)) l ; + arr diff --git a/src/lib_stdlib/fallbackArray.mli b/src/lib_stdlib/fallbackArray.mli index e0f66a99482b34c01843eb3b344f81159378b757..604bec65029e62cfbccf0d3ce91f28e8e7097a2a 100644 --- a/src/lib_stdlib/fallbackArray.mli +++ b/src/lib_stdlib/fallbackArray.mli @@ -39,6 +39,11 @@ type 'a t [v]. The value [v] is the fallback value for [a]. *) val make : int -> 'a -> 'a t +(** [of_list ~fallback ~proj l] builds a fallback array [a] of length + [List.length l] where each cell [i] is initialized by [proj (List.nth l i)] + and the fallback value is [fallback]. *) +val of_list : fallback:'b -> proj:('a -> 'b) -> 'a list -> 'b t + (** [fallback a] returns the fallback value for [a]. *) val fallback : 'a t -> 'a diff --git a/src/lib_stdlib/test/test_fallbackArray.ml b/src/lib_stdlib/test/test_fallbackArray.ml index d90b8f1d9beb51fa8af897d31aef376c6098d101..7000bbcf76b0dfa61e76909f1d1d56df35a40fcd 100644 --- a/src/lib_stdlib/test/test_fallbackArray.ml +++ b/src/lib_stdlib/test/test_fallbackArray.ml @@ -30,12 +30,42 @@ Subject: Fallback arrays *) -module Tests = Test_arrays.Make (struct - include FallbackArray +module Tests = struct + include Test_arrays.Make (struct + include FallbackArray - let set a i v = - set a i v ; - a -end) + let set a i v = + set a i v ; + a + end) + + open Alcotest + + let check_of_list () = + let l = Array.to_list (Array.init 100 (fun i -> i)) in + let open FallbackArray in + let fallback = -1 in + let farr = of_list ~fallback ~proj:(fun e -> e) l in + let farr_fallback = FallbackArray.fallback farr in + if not Compare.Int.(farr_fallback = fallback) then + fail + (Printf.sprintf "fallback should be %d (is %d)" fallback farr_fallback) ; + let i = ref 0 in + iter + (fun e -> + let expected = List.nth l !i in + if not Compare.Int.(expected = e) then + fail + (Printf.sprintf + "at index %d, fallback array (%d) disagrees with original list \ + (%d)" + !i + e + expected) + else incr i) + farr + + let tests = ("of_list", `Quick, check_of_list) :: tests +end let () = Alcotest.run "stdlib" [("FallbackArray", Tests.tests)] diff --git a/src/lib_store/test/alpha_utils.ml b/src/lib_store/test/alpha_utils.ml index 6664001c17b9f6db4d63a81030c45683bd865968..90d28cf786ada94110933e23def63bf9e7d9cbfc 100644 --- a/src/lib_store/test/alpha_utils.ml +++ b/src/lib_store/test/alpha_utils.ml @@ -369,7 +369,7 @@ let check_constants_consistency constants = (fun () -> failwith "Inconsistent constants : blocks per cycle must be superior than \ - blocks per roll snapshot") + blocks per stake snapshot") in return_unit diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index c38d048429f8fd0aa1cb02d01f52b5558731a9e7..a404b33372bf320bb6473476eb2e9ed3440a0b82 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -3572,7 +3572,7 @@ module RPC = struct Signature.Public_key_hash.Map.fold (fun delegate slots acc -> {level = level.level; delegate; slots} :: acc) - rights + (rights :> Slot.t list Signature.Public_key_hash.Map.t) [] let register () = diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index d0987bfc0ac0877e99452c2dd2a600a2bee5cb44..1e08e5c79ba082ffff059c160ff732d97438fa52 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -49,13 +49,7 @@ module Timestamp = struct let predecessor = Raw_context.predecessor_timestamp end -module Slot = struct - include Slot_repr - - type slot_range = List.t - - let slot_range ~min ~count = List.slot_range ~min ~count -end +module Slot = Slot_repr module Sc_rollup = struct include Sc_rollup_repr @@ -359,7 +353,8 @@ module Delegate = struct current_amount : Tez.t; } - let grace_period = Delegate_activation_storage.grace_period + let last_cycle_before_deactivation = + Delegate_activation_storage.last_cycle_before_deactivation let prepare_stake_distribution = Stake_storage.prepare_stake_distribution diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 743ad7fb79980405b90e46b8e0036dc605459a6e..f04d56aa7b575525b9e654bc015a72091e9fa662 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -67,6 +67,8 @@ type signature = Signature.t module Slot : sig type t + type slot = t + include Compare.S with type t := t val pp : Format.formatter -> t -> unit @@ -79,9 +81,19 @@ module Slot : sig val encoding : t Data_encoding.encoding - type slot_range = private t list + module Range : sig + type t + + val create : min:int -> count:int -> t tzresult - val slot_range : min:int -> count:int -> slot_range tzresult + val fold : ('a -> slot -> 'a) -> 'a -> t -> 'a + + val fold_es : + ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t + + val rev_fold_es : + ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t + end module Map : Map.S with type key = t @@ -1631,7 +1643,7 @@ module Delegate : sig val deactivated : context -> Signature.Public_key_hash.t -> bool tzresult Lwt.t - val grace_period : + val last_cycle_before_deactivation : context -> Signature.Public_key_hash.t -> Cycle.t tzresult Lwt.t val pubkey : context -> public_key_hash -> public_key tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/baking.ml b/src/proto_alpha/lib_protocol/baking.ml index 3c33ebda1d13bfe6722935d2dac6b86e426646d2..eb10613fe00df1b7a793a4ffa60d800654a68301 100644 --- a/src/proto_alpha/lib_protocol/baking.ml +++ b/src/proto_alpha/lib_protocol/baking.ml @@ -77,34 +77,30 @@ let baking_rights c level = in f c Round.zero +type ordered_slots = Slot.t list + +(* Slots returned by this function are assumed by consumers to be in increasing + order, hence the use of [Slot.Range.rev_fold_es]. *) let endorsing_rights (ctxt : t) level = let consensus_committee_size = Constants.consensus_committee_size ctxt in - Slot.slot_range ~min:0 ~count:consensus_committee_size >>?= fun slots -> - List.fold_left_es - (fun (ctxt, acc) slot -> + Slot.Range.create ~min:0 ~count:consensus_committee_size >>?= fun slots -> + Slot.Range.rev_fold_es + (fun (ctxt, map) slot -> Stake_distribution.slot_owner ctxt level slot >>=? fun (ctxt, (_, pkh)) -> - return (ctxt, (slot, pkh) :: acc)) - (ctxt, []) - (slots :> Slot.t list) - >>=? fun (ctxt, right_owners) -> - let rights = - List.fold_left - (fun acc (slot, pkh) -> - let slots = - match Signature.Public_key_hash.Map.find pkh acc with - | None -> [slot] - | Some slots -> slot :: slots - in - Signature.Public_key_hash.Map.add pkh slots acc) - Signature.Public_key_hash.Map.empty - right_owners - in - return (ctxt, rights) + let map = + Signature.Public_key_hash.Map.update + pkh + (function None -> Some [slot] | Some slots -> Some (slot :: slots)) + map + in + return (ctxt, map)) + (ctxt, Signature.Public_key_hash.Map.empty) + slots let endorsing_rights_by_first_slot ctxt level = - Slot.slot_range ~min:0 ~count:(Constants.consensus_committee_size ctxt) + Slot.Range.create ~min:0 ~count:(Constants.consensus_committee_size ctxt) >>?= fun slots -> - List.fold_left_es + Slot.Range.fold_es (fun (ctxt, (delegates_map, slots_map)) slot -> Stake_distribution.slot_owner ctxt level slot >|=? fun (ctxt, (pk, pkh)) -> @@ -126,5 +122,5 @@ let endorsing_rights_by_first_slot ctxt level = in (ctxt, (delegates_map, slots_map))) (ctxt, (Signature.Public_key_hash.Map.empty, Slot.Map.empty)) - (slots :> Slot.t list) + slots >>=? fun (ctxt, (_, slots_map)) -> return (ctxt, slots_map) diff --git a/src/proto_alpha/lib_protocol/baking.mli b/src/proto_alpha/lib_protocol/baking.mli index 6504712552ed6cbd1269602b38f15e9d412e0598..9d9281b735a3922496eb29ebff754b683cd13595 100644 --- a/src/proto_alpha/lib_protocol/baking.mli +++ b/src/proto_alpha/lib_protocol/baking.mli @@ -34,17 +34,23 @@ type error += consensus_threshold : int; } -(** For a given level computes who has the right to include an - endorsement in the next block. It returns a mapping from the - delegates with such rights to their endorsing slots. This function - is only used by the 'validators' RPC. *) +type ordered_slots = private Slot.t list + +(** For a given level computes who has the right to include an endorsement in + the next block. + + @return map from delegates with such rights to their endorsing slots, in + increasing order. + + This function is only used by the 'validators' RPC. *) val endorsing_rights : context -> Level.t -> - (context * Slot.t list Signature.Public_key_hash.Map.t) tzresult Lwt.t + (context * ordered_slots Signature.Public_key_hash.Map.t) tzresult Lwt.t + +(** Computes endorsing rights for a given level. -(** Computes the endorsing rights for a given level. Returns a map - from allocated first slots to their owner's public key, public key + @return map from allocated first slots to their owner's public key, public key hash, and endorsing power. *) val endorsing_rights_by_first_slot : context -> diff --git a/src/proto_alpha/lib_protocol/cache_repr.ml b/src/proto_alpha/lib_protocol/cache_repr.ml index 6f6929c6bae99c4221a27411cf828000611dbf5f..ed4590f99e2a6715c5aaa08bb620d7d36f7342e8 100644 --- a/src/proto_alpha/lib_protocol/cache_repr.ml +++ b/src/proto_alpha/lib_protocol/cache_repr.ml @@ -204,7 +204,7 @@ let register_exn (type cvalue) @@ Admin.cache_size ctxt ~cache_index:C.cache_index let size_limit ctxt = - Option.value ~default:max_int + Option.value ~default:0 @@ Admin.cache_size_limit ctxt ~cache_index:C.cache_index let update ctxt id v = diff --git a/src/proto_alpha/lib_protocol/cache_repr.mli b/src/proto_alpha/lib_protocol/cache_repr.mli index 6480a57786ac883e632e7e6efe99a61f43b66c94..72826e742a4550adca351b4e3e7a51bf29bf65f0 100644 --- a/src/proto_alpha/lib_protocol/cache_repr.mli +++ b/src/proto_alpha/lib_protocol/cache_repr.mli @@ -115,7 +115,11 @@ module Admin : sig val cache_size_limit : Raw_context.t -> cache_index:int -> size option (** [value_of_key ctxt k] interprets the functions introduced by - [register] to construct a cacheable value for a key [k]. *) + [register] to construct a cacheable value for a key [k]. + + [value_of_key] is a maintenance operation: it is typically run + when a node reboots. For this reason, this operation is not + carbonated. *) val value_of_key : Raw_context.t -> Context.Cache.key -> Context.Cache.value tzresult Lwt.t end diff --git a/src/proto_alpha/lib_protocol/constants_repr.ml b/src/proto_alpha/lib_protocol/constants_repr.ml index bc9112cff620d35f86ce6303a92fc77682e2d42d..52d15980645ec9f5e861568b915f7b4ea1ce1af5 100644 --- a/src/proto_alpha/lib_protocol/constants_repr.ml +++ b/src/proto_alpha/lib_protocol/constants_repr.ml @@ -456,6 +456,17 @@ let check_constants constants = Compare.Int32.(remainder = 0l)) (Invalid_protocol_constants "blocks_per_voting_period should be a multiple of blocks_per_cycle.") + >>? fun () -> + error_unless + (let snapshot_frequence = + Int32.div constants.blocks_per_cycle constants.blocks_per_stake_snapshot + in + Compare.Int32.( + snapshot_frequence > Int32.zero + && snapshot_frequence < Int32.of_int (1 lsl 16))) + (Invalid_protocol_constants + "The ratio blocks_per_cycle per blocks_per_stake_snapshot should be \ + between 1 and 65535") >>? fun () -> Result.return_unit module Generated = struct diff --git a/src/proto_alpha/lib_protocol/contract_delegate_storage.ml b/src/proto_alpha/lib_protocol/contract_delegate_storage.ml index ca295af19167bddc8a8d7254a616f238a73db680..006b00a31d2d040d34f07262c3aaa9e5e7e03479 100644 --- a/src/proto_alpha/lib_protocol/contract_delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/contract_delegate_storage.ml @@ -44,7 +44,7 @@ let registered c delegate = | None -> false let link c contract delegate = - Storage.Contract.Balance.get c contract >>=? fun balance -> + Storage.Contract.Spendable_balance.get c contract >>=? fun balance -> Stake_storage.add_stake c delegate balance >>=? fun c -> Storage.Contract.Delegated.add (c, Contract_repr.implicit_contract delegate) @@ -55,7 +55,7 @@ let unlink c contract = Storage.Contract.Delegate.find c contract >>=? function | None -> return c | Some delegate -> - Storage.Contract.Balance.get c contract >>=? fun balance -> + Storage.Contract.Spendable_balance.get c contract >>=? fun balance -> (* Removes the balance of the contract from the delegate *) Stake_storage.remove_stake c delegate balance >>=? fun c -> Storage.Contract.Delegated.remove @@ -71,8 +71,6 @@ let delete ctxt contract = unlink ctxt contract >>=? fun ctxt -> Storage.Contract.Delegate.remove ctxt contract >|= ok -let remove ctxt contract = unlink ctxt contract - let set ctxt contract delegate = unlink ctxt contract >>=? fun ctxt -> Storage.Contract.Delegate.add ctxt contract delegate >>= fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/contract_delegate_storage.mli b/src/proto_alpha/lib_protocol/contract_delegate_storage.mli index 1a62d96b6ade5d5d2a8629abd86f508cd2a1c774..85ba40fc46fffa046f6a5532e01a654607fd5a2f 100644 --- a/src/proto_alpha/lib_protocol/contract_delegate_storage.mli +++ b/src/proto_alpha/lib_protocol/contract_delegate_storage.mli @@ -45,17 +45,17 @@ val init : Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t -(** [remove ctxt contract] removes contract from the list of contracts that +(** [unlink ctxt contract] removes [contract] from the list of contracts that delegated to [find ctxt contract], i.e. the output of [delegated_contracts]. This function does not affect the value of the expression [find ctxt contract]. This function is undefined if [contract] is not allocated. *) -val remove : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t +val unlink : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t -(** [delete ctxt contract] behaves as [remove ctxt contract], but in addition +(** [delete ctxt contract] behaves as [unlink ctxt contract], but in addition removes the association of the [contract] to its current delegate, leaving - the former with no delegate. + the former without delegate. This function is undefined if [contract] is not allocated. *) val delete : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/contract_storage.ml b/src/proto_alpha/lib_protocol/contract_storage.ml index 5bce09cebc5038e0eb675d4e68aaea60cd74adee..97d6c4d925b56ed6ae91023f793e089f4d9c64c6 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.ml +++ b/src/proto_alpha/lib_protocol/contract_storage.ml @@ -386,7 +386,7 @@ let create_base c ~prepaid_bootstrap_storage Storage.Contract.Global_counter.get c >>=? fun counter -> Storage.Contract.Counter.init c contract counter) >>=? fun c -> - Storage.Contract.Balance.init c contract balance >>=? fun c -> + Storage.Contract.Spendable_balance.init c contract balance >>=? fun c -> (match manager with | Some manager -> Contract_manager_storage.init c contract (Manager_repr.Hash manager) @@ -442,8 +442,9 @@ let delete c contract = (* For non implicit contract Big_map should be cleared *) failwith "Non implicit contracts cannot be removed" | Some _ -> - Contract_delegate_storage.remove c contract >>=? fun c -> - Storage.Contract.Balance.remove_existing c contract >>=? fun c -> + Contract_delegate_storage.unlink c contract >>=? fun c -> + Storage.Contract.Spendable_balance.remove_existing c contract + >>=? fun c -> Contract_manager_storage.remove_existing c contract >>=? fun c -> Storage.Contract.Counter.remove_existing c contract >>=? fun c -> Storage.Contract.Code.remove c contract >>=? fun (c, _, _) -> @@ -452,7 +453,7 @@ let delete c contract = Storage.Contract.Used_storage_space.remove c contract >|= ok let allocated c contract = - Storage.Contract.Balance.find c contract >>=? function + Storage.Contract.Spendable_balance.find c contract >>=? function | None -> return_false | Some _ -> return_true @@ -532,7 +533,7 @@ let get_counter c manager = | Some v -> return v let get_balance c contract = - Storage.Contract.Balance.find c contract >>=? function + Storage.Contract.Spendable_balance.find c contract >>=? function | None -> ( match Contract_repr.is_implicit contract with | Some _ -> return Tez_repr.zero @@ -559,12 +560,13 @@ let update_script_storage c contract storage lazy_storage_diff = Storage.Contract.Used_storage_space.update c contract new_size let spend_only_call_from_token c contract amount = - Storage.Contract.Balance.find c contract >>=? fun balance -> + Storage.Contract.Spendable_balance.find c contract >>=? fun balance -> let balance = Option.value balance ~default:Tez_repr.zero in match Tez_repr.(balance -? amount) with | Error _ -> fail (Balance_too_low (contract, balance, amount)) | Ok new_balance -> ( - Storage.Contract.Balance.update c contract new_balance >>=? fun c -> + Storage.Contract.Spendable_balance.update c contract new_balance + >>=? fun c -> Contract_delegate_storage.remove_contract_stake c contract amount >>=? fun c -> if Tez_repr.(new_balance > Tez_repr.zero) then return c @@ -584,16 +586,16 @@ let spend_only_call_from_token c contract amount = (* [Tez_repr.(amount <> zero)] is a precondition of this function. It ensures that no entry associating a null balance to an implicit contract exists in the map - [Storage.Contract.Balance]. *) + [Storage.Contract.Spendable_balance]. *) let credit_only_call_from_token c contract amount = - Storage.Contract.Balance.find c contract >>=? function + Storage.Contract.Spendable_balance.find c contract >>=? function | None -> ( match Contract_repr.is_implicit contract with | None -> fail (Non_existing_contract contract) | Some manager -> create_implicit c manager ~balance:amount) | Some balance -> Tez_repr.(amount +? balance) >>?= fun balance -> - Storage.Contract.Balance.update c contract balance >>=? fun c -> + Storage.Contract.Spendable_balance.update c contract balance >>=? fun c -> Contract_delegate_storage.add_contract_stake c contract amount let init c = @@ -618,9 +620,9 @@ let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space = >|=? fun c -> (to_pay, c) let update_balance ctxt contract f amount = - Storage.Contract.Balance.get ctxt contract >>=? fun balance -> + Storage.Contract.Spendable_balance.get ctxt contract >>=? fun balance -> f balance amount >>?= fun new_balance -> - Storage.Contract.Balance.update ctxt contract new_balance + Storage.Contract.Spendable_balance.update ctxt contract new_balance let increase_balance_only_call_from_token ctxt contract amount = update_balance ctxt contract Tez_repr.( +? ) amount diff --git a/src/proto_alpha/lib_protocol/delegate_activation_storage.ml b/src/proto_alpha/lib_protocol/delegate_activation_storage.ml index 2d090108f20bdda7cb701c8e90fac956fedb47ae..296502f80389a3f983645b1a4b0ca20aae5f8865 100644 --- a/src/proto_alpha/lib_protocol/delegate_activation_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_activation_storage.ml @@ -30,7 +30,7 @@ let is_inactive ctxt delegate = >>= fun inactive -> if inactive then return inactive else - Storage.Contract.Delegate_desactivation.find + Storage.Contract.Delegate_last_cycle_before_deactivation.find ctxt (Contract_repr.implicit_contract delegate) >|=? function @@ -44,11 +44,14 @@ let is_inactive ctxt delegate = a contract. *) false -let grace_period ctxt delegate = +let last_cycle_before_deactivation ctxt delegate = let contract = Contract_repr.implicit_contract delegate in - Storage.Contract.Delegate_desactivation.get ctxt contract + Storage.Contract.Delegate_last_cycle_before_deactivation.get ctxt contract -let set_inactive = Storage.Contract.Inactive_delegate.add +let set_inactive ctxt delegate = + Storage.Contract.Inactive_delegate.add + ctxt + (Contract_repr.implicit_contract delegate) let set_active ctxt delegate = is_inactive ctxt delegate >>=? fun inactive -> @@ -60,9 +63,10 @@ let set_active ctxt delegate = - if the delegate is new or inactive, we give it additionally `preserved_cycles` because the delegate needs this number of cycles to receive rights, so `1 + 2 * preserved_cycles` in total. *) - Storage.Contract.Delegate_desactivation.find + let delegate_contract = Contract_repr.implicit_contract delegate in + Storage.Contract.Delegate_last_cycle_before_deactivation.find ctxt - (Contract_repr.implicit_contract delegate) + delegate_contract >>=? fun current_last_active_cycle -> let last_active_cycle = match current_last_active_cycle with @@ -74,14 +78,12 @@ let set_active ctxt delegate = let updated = Cycle_repr.add current_cycle delay in Cycle_repr.max current_last_active_cycle updated in - Storage.Contract.Delegate_desactivation.add + Storage.Contract.Delegate_last_cycle_before_deactivation.add ctxt - (Contract_repr.implicit_contract delegate) + delegate_contract last_active_cycle >>= fun ctxt -> if not inactive then return (ctxt, inactive) else - Storage.Contract.Inactive_delegate.remove - ctxt - (Contract_repr.implicit_contract delegate) + Storage.Contract.Inactive_delegate.remove ctxt delegate_contract >>= fun ctxt -> return (ctxt, inactive) diff --git a/src/proto_alpha/lib_protocol/delegate_activation_storage.mli b/src/proto_alpha/lib_protocol/delegate_activation_storage.mli index e18ca676079e9fda2111028ab2866381e5a47b3f..28f43fcf597aca9b9fb23374851ecc0d45526832 100644 --- a/src/proto_alpha/lib_protocol/delegate_activation_storage.mli +++ b/src/proto_alpha/lib_protocol/delegate_activation_storage.mli @@ -26,13 +26,21 @@ val is_inactive : Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t -(** [grace_period ctxt delegate] is the cycle at which the delegate is - scheduled to become inactive. *) -val grace_period : +(** [last_cycle_before_deactivation ctxt delegate] is the cycle at which + the delegate is scheduled to become inactive. *) +val last_cycle_before_deactivation : Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t tzresult Lwt.t -val set_inactive : Raw_context.t -> Contract_repr.t -> Raw_context.t Lwt.t +(** [set_inactive context delegate] adds [delegate] to the set of inactive + * contracts. *) +val set_inactive : + Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t Lwt.t +(** [set_active ctxt delegate] returns a pair [(new_ctxt, is_inactive)] where: + - [new_ctxt] is a new context, updated from [ctxt], where the [delegate]'s + last active cycle has been updated + - [is_inactive] represents the state of [delegate], prior to the update. + *) val set_active : Raw_context.t -> Signature.Public_key_hash.t -> diff --git a/src/proto_alpha/lib_protocol/delegate_services.ml b/src/proto_alpha/lib_protocol/delegate_services.ml index faf698116b1e94c890eb615322b0bf06bdd50c25..6363728961ce0d076ea6d36a7f558e559629affe 100644 --- a/src/proto_alpha/lib_protocol/delegate_services.ml +++ b/src/proto_alpha/lib_protocol/delegate_services.ml @@ -362,7 +362,7 @@ let register () = Delegate.delegated_contracts ctxt pkh >>= fun delegated_contracts -> Delegate.delegated_balance ctxt pkh >>=? fun delegated_balance -> Delegate.deactivated ctxt pkh >>=? fun deactivated -> - Delegate.grace_period ctxt pkh >>=? fun grace_period -> + Delegate.last_cycle_before_deactivation ctxt pkh >>=? fun grace_period -> Vote.get_voting_power_free ctxt pkh >|=? fun voting_power -> { full_balance; @@ -404,7 +404,7 @@ let register () = Delegate.deactivated ctxt pkh) ; register1 ~chunked:false S.grace_period (fun ctxt pkh () () -> Delegate.check_delegate ctxt pkh >>=? fun () -> - Delegate.grace_period ctxt pkh) ; + Delegate.last_cycle_before_deactivation ctxt pkh) ; register1 ~chunked:false S.voting_power (fun ctxt pkh () () -> Delegate.check_delegate ctxt pkh >>=? fun () -> Vote.get_voting_power_free ctxt pkh) ; diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index 2677d68150c99edba3654063addb6d4a071ea369..bbf20434a6333fdc55728a2a5fba06ab5ec5506b 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -171,9 +171,7 @@ let () = (fun pkh -> Not_registered pkh) let set_inactive ctxt delegate = - let delegate_contract = Contract_repr.implicit_contract delegate in - Delegate_activation_storage.set_inactive ctxt delegate_contract - >>= fun ctxt -> + Delegate_activation_storage.set_inactive ctxt delegate >>= fun ctxt -> Stake_storage.deactivate_only_call_from_delegate_storage ctxt delegate >|= ok let set_active ctxt delegate = @@ -244,7 +242,7 @@ let set c contract delegate = else return_unit | None -> return_unit) >>=? fun () -> - Storage.Contract.Balance.mem c contract >>= fun exists -> + Storage.Contract.Spendable_balance.mem c contract >>= fun exists -> error_when (self_delegation && not exists) (Empty_delegate_account delegate) @@ -276,7 +274,9 @@ let update_activity ctxt last_cycle = ~init:(Ok (ctxt, [])) ~f:(fun delegate () acc -> acc >>?= fun (ctxt, deactivated) -> - Delegate_activation_storage.grace_period ctxt delegate + Delegate_activation_storage.last_cycle_before_deactivation + ctxt + delegate >>=? fun cycle -> if Cycle_repr.(cycle <= last_cycle) then set_inactive ctxt delegate >|=? fun ctxt -> @@ -466,7 +466,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle else if Tez_repr.(current_amount < maximum_stake_to_be_deposited) then Tez_repr.(maximum_stake_to_be_deposited -? current_amount) >>?= fun desired_to_freeze -> - Storage.Contract.Balance.get ctxt delegate_contract >>=? fun balance -> + Storage.Contract.Spendable_balance.get ctxt delegate_contract + >>=? fun balance -> (* In case the delegate hasn't been slashed in this cycle, the following invariant holds: maximum_stake_to_be_deposited <= frozen_deposits + balance @@ -532,7 +533,7 @@ let cycle_end ctxt last_cycle unrevealed_nonces = let balance ctxt delegate = let contract = Contract_repr.implicit_contract delegate in - Storage.Contract.Balance.get ctxt contract + Storage.Contract.Spendable_balance.get ctxt contract let frozen_deposits ctxt delegate = Frozen_deposits_storage.get ctxt (Contract_repr.implicit_contract delegate) diff --git a/src/proto_alpha/lib_protocol/delegate_storage.mli b/src/proto_alpha/lib_protocol/delegate_storage.mli index ee784b4e98951266f9bc9cbd766e3a125fc6eefd..74066a6e6de2ec007e7a09a89b91e9ce82bffc84 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.mli +++ b/src/proto_alpha/lib_protocol/delegate_storage.mli @@ -100,6 +100,11 @@ type participation_info = { required minimum, then the rewards are zero. (dynamic) *) } +(** Only use this function for RPC: this is expensive. + + [delegate_participation_info] and [!val:check_delegate] forms the + implementation of RPC call "/context/delegates//participation". + *) val delegate_participation_info : Raw_context.t -> Signature.Public_key_hash.t -> diff --git a/src/proto_alpha/lib_protocol/frozen_deposits_storage.ml b/src/proto_alpha/lib_protocol/frozen_deposits_storage.ml index 6aa3b65aff55ab27c8e7ebefce6b7fe8d7ed9f26..99a9fb136390968abdeee8857c3e3906a125a46b 100644 --- a/src/proto_alpha/lib_protocol/frozen_deposits_storage.ml +++ b/src/proto_alpha/lib_protocol/frozen_deposits_storage.ml @@ -37,8 +37,7 @@ let find = Storage.Contract.Frozen_deposits.find let update_balance ctxt delegate f amount = let delegate_contract = Contract_repr.implicit_contract delegate in - Storage.Contract.Frozen_deposits.get ctxt delegate_contract - >>=? fun frozen_deposits -> + get ctxt delegate_contract >>=? fun frozen_deposits -> f frozen_deposits.current_amount amount >>?= fun new_amount -> Storage.Contract.Frozen_deposits.update ctxt @@ -52,8 +51,7 @@ let spend_only_call_from_token ctxt delegate amount = update_balance ctxt delegate Tez_repr.( -? ) amount let update_initial_amount ctxt delegate_contract deposits_cap = - Storage.Contract.Frozen_deposits.get ctxt delegate_contract - >>=? fun frozen_deposits -> + get ctxt delegate_contract >>=? fun frozen_deposits -> Storage.Contract.Frozen_deposits.update ctxt delegate_contract diff --git a/src/proto_alpha/lib_protocol/frozen_deposits_storage.mli b/src/proto_alpha/lib_protocol/frozen_deposits_storage.mli index 9371d11f61d23ccb9ccada43318704e5f983f655..f61954b9c2a5ffac6c0a0d63f069362e71a6c669 100644 --- a/src/proto_alpha/lib_protocol/frozen_deposits_storage.mli +++ b/src/proto_alpha/lib_protocol/frozen_deposits_storage.mli @@ -23,27 +23,46 @@ (* *) (*****************************************************************************) +(** Simple abstraction from low-level storage to handle frozen deposits *) + +(** [init ctxt delegate] returns a new context from [ctxt] where the frozen + deposits of the implicit contract represented by [delegate] have been initialized to + {!val:Tez_repr.zero}. *) val init : Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t +(** [allocated ctxt contract] checks whether [contract] has frozen deposits in + [ctxt]. *) val allocated : Raw_context.t -> Contract_repr.t -> bool Lwt.t +(** [get ctxt contract] retrieves the frozen deposits of [contract] in [ctxt]. *) val get : Raw_context.t -> Contract_repr.t -> Storage.deposits tzresult Lwt.t +(** [find ctxt contract] retrieves the frozen deposits of [contract] in + [ctxt], if any. *) val find : Raw_context.t -> Contract_repr.t -> Storage.deposits option tzresult Lwt.t +(** [credit_only_call_from_token ctxt delegate tez] returns a new context from + [ctxt] where the amount of frozen deposits for the implicit contract + represented by [delegate] increases by [tez]. *) val credit_only_call_from_token : Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t +(** [spend_only_call_from_token ctxt delegate tez] returns a new context from + [ctxt] where the amount of frozen deposits for the implicit contract + represented by [delegate] decreases by [tez].*) val spend_only_call_from_token : Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t +(** [update_initial_amount ctxt contract tez] returns a new context from [ctxt] + where the initial_amount of the frozen deposits for [contract] is set to + [tez]. *) val update_initial_amount : Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/main.mli b/src/proto_alpha/lib_protocol/main.mli index 4d5e885952178d7ad97270972deea487bc1a8eba..d90b5c1675c88ae42ccb5ee27af09ee5ed299970 100644 --- a/src/proto_alpha/lib_protocol/main.mli +++ b/src/proto_alpha/lib_protocol/main.mli @@ -27,7 +27,7 @@ This module is the entrypoint to the protocol for shells and other embedders. This signature is an instance of - {{!Tezos_protocol_environment_sigs.V3.T.Updater.PROTOCOL} the + {{!Tezos_protocol_environment_sigs.V5.T.Updater.PROTOCOL} the [Updater.PROTOCOL] signature} from the {{:https://tezos.gitlab.io/shell/the_big_picture.html#the-economic-protocol-environment-and-compiler} Protocol Environment}. @@ -40,6 +40,8 @@ {{:https://tezos.gitlab.io/shell/the_big_picture.html} this overview}. *) +(** [validation_mode] permits to differenciate [!type:validation_state] + values. *) type validation_mode = | Application of { block_header : Alpha_context.Block_header.t; @@ -49,6 +51,8 @@ type validation_mode = predecessor_round : Alpha_context.Round.t; predecessor_level : Alpha_context.Level.t; } + (** Full Validation of a block. See + {!val:Tezos_protocol_environment_sigs.V5.T.Updater.PROTOCOL.begin_application}**) | Partial_application of { block_header : Alpha_context.Block_header.t; fitness : Alpha_context.Fitness.t; @@ -57,14 +61,19 @@ type validation_mode = predecessor_level : Alpha_context.Level.t; predecessor_round : Alpha_context.Round.t; } - (* Mempool only *) + (** [Partial_application] is use in chain bootstrapping - not all checks + are done. Special case of [Application] to allow quick rejection of bad + blocks. See + {!val:Tezos_protocol_environment_sigs.V5.T.Updater.PROTOCOL.begin_partial_application} + *) | Partial_construction of { predecessor : Block_hash.t; predecessor_fitness : Fitness.t; predecessor_level : Alpha_context.Level.t; predecessor_round : Alpha_context.Round.t; } - (* Baker only *) + (** Shell/mempool-only construction of a virtual block. See + {!val:Tezos_protocol_environment_sigs.V5.T.Updater.PROTOCOL.begin_construction} *) | Full_construction of { predecessor : Block_hash.t; payload_producer : Alpha_context.public_key_hash; @@ -75,6 +84,9 @@ type validation_mode = predecessor_level : Alpha_context.Level.t; predecessor_round : Alpha_context.Round.t; } + (** Baker-only block construction for baking in. See + {!val:Tezos_protocol_environment_sigs.V5.T.Updater.PROTOCOL.begin_construction} + *) type validation_state = { mode : validation_mode; diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index d6f75bb1a9eeccdd1b048c17c4052351e764567e..98705d3724231e36e9b311c70816f3f296181a1f 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -658,7 +658,6 @@ module Encoding = struct Case { tag = 20; - (* Preendorsement where added after *) name = "preendorsement"; encoding = consensus_content_encoding; select = @@ -667,7 +666,6 @@ module Encoding = struct inj = (fun preendorsement -> Preendorsement preendorsement); } - (* Defined before endorsement encoding because this is used there *) let preendorsement_encoding = let make (Case {tag; name; encoding; select = _; proj; inj}) = case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) diff --git a/src/proto_alpha/lib_protocol/period_repr.ml b/src/proto_alpha/lib_protocol/period_repr.ml index 1f2de5752be8f7b2b1b8a571fff948620bbfec7b..4e928de82001966adf7097f9fc8958a74c3b6e30 100644 --- a/src/proto_alpha/lib_protocol/period_repr.ml +++ b/src/proto_alpha/lib_protocol/period_repr.ml @@ -118,12 +118,12 @@ module Internal : INTERNAL = struct let mult_ a b = if a <> zero then let res = Int64.mul a b in - if Int64.div res a <> b then None else Some res + if Compare.Int64.(Int64.div res a <> b) then None else Some res else Some zero let add_ a b = let res = Int64.add a b in - if res < a || res < b then None else Some res + if Compare.Int64.(res < a || res < b) then None else Some res end include Internal diff --git a/src/proto_alpha/lib_protocol/receipt_repr.ml b/src/proto_alpha/lib_protocol/receipt_repr.ml index d9e1cd6fe9a83f67c5d7e0445f9e7bd4e9912e44..8abe1a10b3ce33c60638aa98e556031ebec92dc0 100644 --- a/src/proto_alpha/lib_protocol/receipt_repr.ml +++ b/src/proto_alpha/lib_protocol/receipt_repr.ml @@ -246,6 +246,8 @@ let compare_balance ba bb = type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t +let is_zero_update = function Debited t | Credited t -> Tez_repr.(t = zero) + let balance_update_encoding = let open Data_encoding in def "operation_metadata.alpha.balance_update" @@ -331,33 +333,49 @@ let balance_updates_encoding = (merge_objs balance_encoding balance_update_encoding) update_origin_encoding)) -module BalanceMap = Map.Make (struct - type t = balance * update_origin +module BalanceMap = struct + include Map.Make (struct + type t = balance * update_origin + + let compare (ba, ua) (bb, ub) = + let c = compare_balance ba bb in + if is_not_zero c then c else compare_update_origin ua ub + end) - let compare (ba, ua) (bb, ub) = - let c = compare_balance ba bb in - if is_not_zero c then c else compare_update_origin ua ub -end) + let update_r key (f : 'a option -> 'b option tzresult) map = + f (find key map) >>? function + | Some v -> ok (add key v map) + | None -> ok (remove key map) +end let group_balance_updates balance_updates = List.fold_left_e (fun acc (b, update, o) -> - (match BalanceMap.find (b, o) acc with - | None -> ok update - | Some present -> ( - match (present, update) with - | (Credited a, Debited b) | (Debited b, Credited a) -> - if Tez_repr.(a >= b) then - Tez_repr.(a -? b) >>? fun update -> ok (Credited update) - else Tez_repr.(b -? a) >>? fun update -> ok (Debited update) - | (Credited a, Credited b) -> - Tez_repr.(a +? b) >>? fun update -> ok (Credited update) - | (Debited a, Debited b) -> - Tez_repr.(a +? b) >>? fun update -> ok (Debited update))) - >>? function - | Credited update when Tez_repr.(update = zero) -> - ok (BalanceMap.remove (b, o) acc) - | update -> ok (BalanceMap.add (b, o) update acc)) + (* Do not do anything if the update is zero *) + if is_zero_update update then ok acc + else + BalanceMap.update_r + (b, o) + (function + | None -> ok (Some update) + | Some balance -> ( + match (balance, update) with + | (Credited a, Debited b) | (Debited b, Credited a) -> + (* Remove the binding since it just fell down to zero *) + if Tez_repr.(a = b) then ok None + else if Tez_repr.(a > b) then + Tez_repr.(a -? b) >>? fun update -> + ok (Some (Credited update)) + else + Tez_repr.(b -? a) >>? fun update -> + ok (Some (Debited update)) + | (Credited a, Credited b) -> + Tez_repr.(a +? b) >>? fun update -> + ok (Some (Credited update)) + | (Debited a, Debited b) -> + Tez_repr.(a +? b) >>? fun update -> + ok (Some (Debited update)))) + acc) BalanceMap.empty balance_updates >>? fun map -> diff --git a/src/proto_alpha/lib_protocol/sampler.ml b/src/proto_alpha/lib_protocol/sampler.ml index 1802a612eafc6ec228bbe8d3d561e752bd204a32..b390b6dcf54be68771ca010e6518c6d21cb7b596 100644 --- a/src/proto_alpha/lib_protocol/sampler.ml +++ b/src/proto_alpha/lib_protocol/sampler.ml @@ -78,8 +78,8 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct match (small, large) with | ([], _) -> List.iter (fun (_, i) -> FallbackArray.set p i total) large | (_, []) -> - (* This can only happen because of numerical inaccuracies when using - eg [Mass.t = float] *) + (* This can only happen because of numerical inaccuracies e.g. when using + [Mass.t = float] *) List.iter (fun (_, i) -> FallbackArray.set p i total) small | ((qi, i) :: small', (qj, j) :: large') -> FallbackArray.set p i qi ; @@ -89,12 +89,8 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct init_loop total p alias ((qj', j) :: small') large' else init_loop total p alias small' ((qj', j) :: large') - let support : - fallback:'a -> length:int -> ('a * Mass.t) list -> 'a FallbackArray.t = - fun ~fallback ~length measure -> - let a = FallbackArray.make length fallback in - List.iteri (fun i (elt, _) -> FallbackArray.set a i elt) measure ; - a + let support : fallback:'a -> ('a * Mass.t) list -> 'a FallbackArray.t = + fun ~fallback measure -> FallbackArray.of_list ~fallback ~proj:fst measure let check_and_cleanup measure = let (total, measure) = @@ -126,8 +122,8 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct (0, [], []) measure in - let support = support ~fallback ~length measure in - let p = FallbackArray.make length total in + let support = support ~fallback measure in + let p = FallbackArray.make length Mass.zero in let alias = FallbackArray.make length (-1) in init_loop total p alias small large ; {total; support; p; alias} @@ -182,6 +178,8 @@ end module Internal_for_tests = struct module Make = Make + + module type SMass = SMass end module Mass : SMass with type t = int64 = struct @@ -206,4 +204,16 @@ module Mass : SMass with type t = int64 = struct let ( < ) = Compare.Int64.( < ) end +(* This is currently safe to do that since since at this point the values for + [total] is 8 * 10^8 * 10^6 and the delgates [n] = 400. + + Therefore [let q = Mass.mul p n ...] in [create] does not overflow since p < + total. + + Assuming the total active stake does not increase too much, which is the case + at the current 5% inflation rate, this implementation can thus support around + 10000 delegates without overflows. + + If/when this happens, the implementation should be revisited. + *) include Make (Mass) diff --git a/src/proto_alpha/lib_protocol/sampler.mli b/src/proto_alpha/lib_protocol/sampler.mli index 5f1eb8e2bf2379ab3ed613324862d55481f979ff..00cf20a7768c03d32273619b7d739a8107b47104 100644 --- a/src/proto_alpha/lib_protocol/sampler.mli +++ b/src/proto_alpha/lib_protocol/sampler.mli @@ -28,30 +28,6 @@ to the given measure. *) -(** [Mass] is the module type describing the measure associated to points. *) -module type SMass = sig - (** [t] is the type describing the measure associated to points. *) - type t - - val encoding : t Data_encoding.t - - val zero : t - - val of_int : int -> t - - val mul : t -> t -> t - - val add : t -> t -> t - - val sub : t -> t -> t - - val ( = ) : t -> t -> bool - - val ( <= ) : t -> t -> bool - - val ( < ) : t -> t -> bool -end - (** [S] is the module type of a module allowing to construct samplers based on the alias method. *) module type S = sig @@ -90,9 +66,46 @@ end (**/**) module Internal_for_tests : sig + (** [Mass] is the module type describing the measure associated to points. + + The current signature reflects the need for efficiency for the arithmetic + operators. As such, they do not error or add dynamic checks for + over-/under-flow. + + One must make sure that the implementation of its arithmetic operators + cannot over-/under-flow under the current usage. *) + module type SMass = sig + (** [t] is the type describing the measure associated to points. *) + type t + + val encoding : t Data_encoding.t + + val zero : t + + val of_int : int -> t + + val mul : t -> t -> t + + val add : t -> t -> t + + val sub : t -> t -> t + + val ( = ) : t -> t -> bool + + val ( <= ) : t -> t -> bool + + val ( < ) : t -> t -> bool + end + (** [Make(Mass)] instantiates a module allowing to creates samplers for [Mass]-valued finite measures. *) module Make : functor (Mass : SMass) -> S with type mass = Mass.t end +(** Sampler based on int64. In the current state of the protocol, this should + not ever over-/under-flow -- see the thought process in the .ml file. + + However, should the total stake increase a lot or the number of delegates get + close to 10k, this might not be true anymore and this module should be + revisited. *) include S with type mass = Int64.t diff --git a/src/proto_alpha/lib_protocol/slot_repr.ml b/src/proto_alpha/lib_protocol/slot_repr.ml index 45660159cea46cb607875336bd55e0ae3dfb5090..4cb7219bfedc206efcfaa00496e19e5a66369a29 100644 --- a/src/proto_alpha/lib_protocol/slot_repr.ml +++ b/src/proto_alpha/lib_protocol/slot_repr.ml @@ -38,6 +38,8 @@ let () = include Compare.Int +type slot = t + (* TODO? should there be some assertions to verify that slots are never too big ? Or do that in a storage module that depends on constants ? *) @@ -66,70 +68,39 @@ let succ slot = of_int (slot + 1) module Map = Map.Make (Compare.Int) module Set = Set.Make (Compare.Int) -module List = struct - (* Expected invariant: list of increasing values *) - type nonrec t = t list - - module Compressed = struct - type elt = {skip : int; take : int} - - type encoded = elt list - - let elt_encoding = - Data_encoding.( - conv - (fun {skip; take} -> (skip, take)) - (fun (skip, take) -> {skip; take}) - (obj2 (req "skip" uint16) (req "take" uint16))) - - let encoding = Data_encoding.list elt_encoding - - let encode l : encoded = - let rec loop_taking ~pos ~skipped ~taken l = - match l with - | [] -> if taken > 0 then [{skip = skipped; take = taken}] else [] - | h :: t -> - if h = pos then - loop_taking ~pos:(pos + 1) ~skipped ~taken:(taken + 1) t - else - let elt = {skip = skipped; take = taken} in - let skipped = h - pos in - let taken = 1 in - let elts = loop_taking ~pos:(h + 1) ~skipped ~taken t in - elt :: elts - in - loop_taking ~pos:0 ~skipped:0 ~taken:0 l - - let decode (elts : encoded) = - let rec loop ~pos elts = - match elts with - | [] -> Ok [] - | elt :: elts -> ( - let pos = pos + elt.skip in - match - List.init ~when_negative_length:() elt.take (fun i -> i + pos) - with - | Ok l -> ( - let pos = pos + elt.take in - match loop ~pos elts with Ok t -> Ok (l @ t) | e -> e) - | Error () -> - Error "A compressed element contains a negative list size") - in - loop ~pos:0 elts - end - - let encoding = - Data_encoding.conv_with_guard - Compressed.encode - Compressed.decode - Compressed.encoding - - let slot_range ~min ~count = +module Range = struct + (* For now, we only need full intervals. If we ever need sparse ones, we + could switch this representation to interval trees. [hi] and [lo] bounds + are included. *) + type t = Interval of {lo : int; hi : int} + + let create ~min ~count = error_when (min < 0) (Invalid_slot min) >>? fun () -> error_when (min > max_value) (Invalid_slot min) >>? fun () -> error_when (count < 1) (Invalid_slot count) >>? fun () -> error_when (count > max_value) (Invalid_slot count) >>? fun () -> let max = min + count - 1 in error_when (max > max_value) (Invalid_slot max) >>? fun () -> - ok Misc.(min --> max) + ok (Interval {lo = min; hi = max}) + + let fold f init (Interval {lo; hi}) = + let rec loop ~acc ~next = + if Compare.Int.(next > hi) then acc + else loop ~acc:(f acc next) ~next:(next + 1) + in + loop ~acc:(f init lo) ~next:(lo + 1) + + let fold_es f init (Interval {lo; hi}) = + let rec loop ~acc ~next = + if Compare.Int.(next > hi) then return acc + else f acc next >>=? fun acc -> loop ~acc ~next:(next + 1) + in + f init lo >>=? fun acc -> loop ~acc ~next:(lo + 1) + + let rev_fold_es f init (Interval {lo; hi}) = + let rec loop ~acc ~next = + if Compare.Int.(next < lo) then return acc + else f acc next >>=? fun acc -> loop ~acc ~next:(next - 1) + in + f init hi >>=? fun acc -> loop ~acc ~next:(hi - 1) end diff --git a/src/proto_alpha/lib_protocol/slot_repr.mli b/src/proto_alpha/lib_protocol/slot_repr.mli index 2d460e22e73fd49f17605e957b01c7dd1032be48..cccc2cf431304d2734e827d8130acb841c751498 100644 --- a/src/proto_alpha/lib_protocol/slot_repr.mli +++ b/src/proto_alpha/lib_protocol/slot_repr.mli @@ -32,6 +32,8 @@ max_value]. In this case it returns an [Invalid_slot] error.*) type t +type slot = t + val encoding : t Data_encoding.t (** {1 Constructors }*) @@ -41,19 +43,19 @@ val zero : t (** Upper bound on the value a slot index can take *) val max_value : t -(** [of_int i] creates a slot index from integer [i]. +(** [of_int i] creates a slot index from integer [i]. - @return [Error (Invalid_slot i)] if [i < 0 || i > max_value], and + @return [Error (Invalid_slot i)] if [i < 0 || i > max_value], and [Ok slot] otherwise *) val of_int : int -> t tzresult (** [of_int_do_not_use_except_for_parameters i] is an unchecked construction - function. + function. It may be used in cases where one knows [0 <= i <= max_value], e.g., when - creating protocol parameters. - + creating protocol parameters. + When in doubt, use [of_int] or [of_int_exn]. *) val of_int_do_not_use_except_for_parameters : int -> t @@ -80,12 +82,36 @@ module Set : Set.S with type elt = t include Compare.S with type t := t -module List : sig - (** A list of slot is an ordered list of increasing slot values *) - type nonrec t = private t list +(** {2 Slot ranges} *) +module Range : sig + (** An ordered range of slots, in increasing order. *) + type t + + (** {3 Constructor} *) + + (** [create ~min ~count] creates a full slot range starting at [min], of size + [count], i.e, [min, min + count - 1]. + + [create] errors if + - [min < 0] + - [count < 1] + - [min + count - 1 > max_value] + *) + val create : min:int -> count:int -> t tzresult + + (** {3 Iterators} *) + + (** [fold f acc range] folds [f] over the values of [range], in increasing + order. *) + val fold : ('a -> slot -> 'a) -> 'a -> t -> 'a - val encoding : t Data_encoding.t + (** [fold_es f acc range] folds [f] over the values of [range], in increasing + order. *) + val fold_es : + ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t - (** {3 Constructors} *) - val slot_range : min:int -> count:int -> t tzresult + (** [rev_fold_es f acc range] folds [f] over the values of [range], in decreasing + order. *) + val rev_fold_es : + ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t end diff --git a/src/proto_alpha/lib_protocol/stake_storage.ml b/src/proto_alpha/lib_protocol/stake_storage.ml index 34d68b4538f864a436857014c5186fdd2336a0c1..4a840e8759f3bd4008a4cb0c17f46c15478d5be4 100644 --- a/src/proto_alpha/lib_protocol/stake_storage.ml +++ b/src/proto_alpha/lib_protocol/stake_storage.ml @@ -57,10 +57,7 @@ module Selected_distribution_for_cycle = struct let remove_existing ctxt cycle = let id = identifier_of_cycle cycle in - (Cache.find ctxt id >>=? function - | None -> return ctxt - | Some _ -> Cache.update ctxt id None |> Lwt.return) - >>=? fun ctxt -> + Cache.update ctxt id None >>?= fun ctxt -> Storage.Stake.Selected_distribution_for_cycle.remove_existing ctxt cycle end @@ -98,28 +95,27 @@ module Delegate_sampler_state = struct let remove_existing ctxt cycle = let id = identifier_of_cycle cycle in - (Cache.find ctxt id >>=? function - | None -> return ctxt - | Some _ -> Cache.update ctxt id None |> Lwt.return) - >>=? fun ctxt -> Storage.Delegate_sampler_state.remove_existing ctxt cycle + Cache.update ctxt id None >>?= fun ctxt -> + Storage.Delegate_sampler_state.remove_existing ctxt cycle end let get_staking_balance = Storage.Stake.Staking_balance.get -let ensure_stake_inited ctxt delegate = - Storage.Stake.Staking_balance.mem ctxt delegate >>= function - | true -> return ctxt - | false -> +let get_initialized_stake ctxt delegate = + Storage.Stake.Staking_balance.find ctxt delegate >>=? function + | Some staking_balance -> return (staking_balance, ctxt) + | None -> Frozen_deposits_storage.init ctxt delegate >>=? fun ctxt -> - Storage.Stake.Staking_balance.init ctxt delegate Tez_repr.zero + let balance = Tez_repr.zero in + Storage.Stake.Staking_balance.init ctxt delegate balance >>=? fun ctxt -> + return (balance, ctxt) let remove_stake ctxt delegate amount = - ensure_stake_inited ctxt delegate >>=? fun ctxt -> - let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in - get_staking_balance ctxt delegate >>=? fun staking_balance_before -> + get_initialized_stake ctxt delegate >>=? fun (staking_balance_before, ctxt) -> Tez_repr.(staking_balance_before -? amount) >>?= fun staking_balance -> Storage.Stake.Staking_balance.update ctxt delegate staking_balance >>=? fun ctxt -> + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in if Tez_repr.(staking_balance_before >= tokens_per_roll) then Delegate_activation_storage.is_inactive ctxt delegate >>=? fun inactive -> if (not inactive) && Tez_repr.(staking_balance < tokens_per_roll) then @@ -133,12 +129,11 @@ let remove_stake ctxt delegate amount = return ctxt let add_stake ctxt delegate amount = - ensure_stake_inited ctxt delegate >>=? fun ctxt -> - let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in - get_staking_balance ctxt delegate >>=? fun staking_balance_before -> + get_initialized_stake ctxt delegate >>=? fun (staking_balance_before, ctxt) -> Tez_repr.(amount +? staking_balance_before) >>?= fun staking_balance -> Storage.Stake.Staking_balance.update ctxt delegate staking_balance >>=? fun ctxt -> + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in if Tez_repr.(staking_balance >= tokens_per_roll) then Delegate_activation_storage.is_inactive ctxt delegate >>=? fun inactive -> if inactive || Tez_repr.(staking_balance_before >= tokens_per_roll) then @@ -156,8 +151,7 @@ let deactivate_only_call_from_delegate_storage ctxt delegate = Storage.Stake.Active_delegate_with_one_roll.remove ctxt delegate let activate_only_call_from_delegate_storage ctxt delegate = - ensure_stake_inited ctxt delegate >>=? fun ctxt -> - get_staking_balance ctxt delegate >>=? fun staking_balance -> + get_initialized_stake ctxt delegate >>=? fun (staking_balance, ctxt) -> let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in if Tez_repr.(staking_balance >= tokens_per_roll) then Storage.Stake.Active_delegate_with_one_roll.add ctxt delegate () @@ -170,6 +164,58 @@ let snapshot ctxt = Storage.Stake.Staking_balance.snapshot ctxt index >>=? fun ctxt -> Storage.Stake.Active_delegate_with_one_roll.snapshot ctxt index +let get_stakes_for_selected_index ctxt index = + Storage.Stake.Active_delegate_with_one_roll.fold_snapshot + ctxt + index + ~order:`Sorted + ~init:([], Tez_repr.zero) + ~f:(fun delegate () (acc, total_stake) -> + Storage.Stake.Staking_balance.Snapshot.get ctxt (index, delegate) + >>=? fun staking_balance -> + let delegate_contract = Contract_repr.implicit_contract delegate in + Storage.Contract.Frozen_deposits_limit.find ctxt delegate_contract + >>=? fun frozen_deposits_limit -> + Storage.Contract.Spendable_balance.get ctxt delegate_contract + >>=? fun balance -> + Frozen_deposits_storage.get ctxt delegate_contract + >>=? fun frozen_deposits -> + Tez_repr.(balance +? frozen_deposits.current_amount) + >>?= fun total_balance -> + let frozen_deposits_percentage = + Constants_storage.frozen_deposits_percentage ctxt + in + let stake_to_consider = + match frozen_deposits_limit with + | Some frozen_deposits_limit -> ( + try + let open Tez_repr in + let max_mutez = of_mutez_exn Int64.max_int in + if frozen_deposits_limit > div_exn max_mutez 100 then + let frozen_deposits_limit_by_10 = + mul_exn frozen_deposits_limit 10 + in + if frozen_deposits_limit_by_10 < staking_balance then + frozen_deposits_limit_by_10 + else staking_balance + else + min + staking_balance + (div_exn + (mul_exn frozen_deposits_limit 100) + frozen_deposits_percentage) + with _ -> staking_balance) + | None -> staking_balance + in + Tez_repr.(total_balance *? 100L) >>?= fun expanded_balance -> + Tez_repr.(expanded_balance /? Int64.of_int frozen_deposits_percentage) + >>?= fun max_staking_capacity -> + let stake_for_cycle = + Tez_repr.min stake_to_consider max_staking_capacity + in + Tez_repr.(total_stake +? stake_for_cycle) >>?= fun total_stake -> + return ((delegate, stake_for_cycle) :: acc, total_stake)) + let select_distribution_for_cycle ctxt cycle pubkey = Storage.Stake.Last_snapshot.get ctxt >>=? fun max_index -> Storage.Seed.For_cycle.get ctxt cycle >>=? fun seed -> @@ -181,53 +227,7 @@ let select_distribution_for_cycle ctxt cycle pubkey = List.fold_left_es (fun ctxt index -> (if Compare.Int.(index = selected_index) then - Storage.Stake.Active_delegate_with_one_roll.fold_snapshot - ctxt - index - ~order:`Sorted - ~init:([], Tez_repr.zero) - ~f:(fun delegate () (acc, total_stake) -> - Storage.Stake.Staking_balance.Snapshot.get ctxt (index, delegate) - >>=? fun staking_balance -> - let delegate_contract = Contract_repr.implicit_contract delegate in - Storage.Contract.Frozen_deposits_limit.find ctxt delegate_contract - >>=? fun frozen_deposits_limit -> - Storage.Contract.Balance.get ctxt delegate_contract - >>=? fun balance -> - Frozen_deposits_storage.get ctxt delegate_contract - >>=? fun frozen_deposits -> - Tez_repr.(balance +? frozen_deposits.current_amount) - >>?= fun total_balance -> - let frozen_deposits_percentage = - Constants_storage.frozen_deposits_percentage ctxt - in - let stake_to_consider = - match frozen_deposits_limit with - | Some frozen_deposits_limit -> ( - try - let max_mutez = Tez_repr.of_mutez_exn Int64.max_int in - let frozen_stake_limit = - if Tez_repr.(frozen_deposits_limit > div_exn max_mutez 100) - then max_mutez - else - Tez_repr.( - div_exn - (mul_exn frozen_deposits_limit 100) - frozen_deposits_percentage) - in - Tez_repr.min staking_balance frozen_stake_limit - with _ -> staking_balance) - | None -> staking_balance - in - let max_staking_capacity = - Tez_repr.( - div_exn (mul_exn total_balance 100) frozen_deposits_percentage) - in - let stake_for_cycle = - Tez_repr.min stake_to_consider max_staking_capacity - in - Tez_repr.(total_stake +? stake_for_cycle) >>?= fun total_stake -> - return ((delegate, stake_for_cycle) :: acc, total_stake)) + get_stakes_for_selected_index ctxt index >>=? fun (stakes, total_stake) -> let stakes = List.sort (fun (_, x) (_, y) -> Tez_repr.compare y x) stakes diff --git a/src/proto_alpha/lib_protocol/stake_storage.mli b/src/proto_alpha/lib_protocol/stake_storage.mli index 66984a63211eb7090b5e500a7a7d5e97a587cb84..08f67604db6910ef3c928a04362e4d8d2d56358c 100644 --- a/src/proto_alpha/lib_protocol/stake_storage.mli +++ b/src/proto_alpha/lib_protocol/stake_storage.mli @@ -122,5 +122,7 @@ val find_selected_distribution : context. *) val prepare_stake_distribution : Raw_context.t -> Raw_context.t tzresult Lwt.t +(** [get_total_active_stake ctxt cycle] retrieves the amount in Tez of the + active stake at [cycle] from [ctxt]. *) val get_total_active_stake : Raw_context.t -> Cycle_repr.t -> Tez_repr.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 6eccb3d03f3bc11a62447eff75ce7b4376cbbafd..711bb49af20f1b54f635a2b2fbf4e1deed16e2ee 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -188,7 +188,7 @@ module Contract = struct let list = Indexed_context.keys - module Balance = + module Spendable_balance = Indexed_context.Make_map (struct let name = ["balance"] @@ -223,9 +223,10 @@ module Contract = struct let name = ["inactive_delegate"] end) - module Delegate_desactivation = + module Delegate_last_cycle_before_deactivation = Indexed_context.Make_map (struct + (* FIXME? Change the key name to reflect the functor's name *) let name = ["delegate_desactivation"] end) (Cycle_repr) @@ -1048,6 +1049,21 @@ module Stake = struct module Selected_distribution_for_cycle = Cycle.Selected_stake_distribution + (* This is an index that is set to 0 by calls to + Stake_storage.selected_new_distribution_at_cycle_end and incremented (by 1) + by calls to Stake_storage.snapshot. + + Stake_storage.snapshot is called in relation with constant + [Constants_storage.blocks_per_stake_snapshot] here in + [Level_storage.may_snapshot_rolls]. + + That is, the increment is effectively done every 512 blocks or so, and + reset at the end of cycles. So it goes up to around 16 (= 8192/512) for the + number of blocks per cycle is 8192, then comes back to 0, so that a UInt16 + is big enough. + + The ratio above (blocks_per_cycle / blocks_per_stake_snapshot) is checked + in {!val:Constants_repr.check_constants} to fit in a UInt16. *) module Last_snapshot = Make_single_data_storage (Registered) (Raw_context) (struct diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli index 8e94c44f89215d37809901baf0bd23235b54633e..a489e8bf40f861618acdb4a2da0f15aa81eec007 100644 --- a/src/proto_alpha/lib_protocol/storage.mli +++ b/src/proto_alpha/lib_protocol/storage.mli @@ -73,7 +73,7 @@ module Contract : sig may also possess tez in frozen deposits. Empty balances (of zero tez) are only allowed for originated contracts, not for implicit ones. *) - module Balance : + module Spendable_balance : Indexed_data_storage with type key = Contract_repr.t and type value = Tez_repr.t @@ -141,7 +141,7 @@ module Contract : sig (** The last cycle where the delegate is considered active; that is, at the next cycle it will be considered inactive. *) - module Delegate_desactivation : + module Delegate_last_cycle_before_deactivation : Indexed_data_storage with type key = Contract_repr.t and type value = Cycle_repr.t @@ -351,6 +351,7 @@ module Stake : sig and type snapshot = int and type t := Raw_context.t + (** Counter of stake storage snapshots taken since last cycle *) module Last_snapshot : Single_data_storage with type value = int and type t := Raw_context.t diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_sampler.ml b/src/proto_alpha/lib_protocol/test/pbt/test_sampler.ml index 326fe581d26fbce237ffb685004240d27e845094..b6cab498556760726af7fe8e68099edae5f68664 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_sampler.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_sampler.ml @@ -143,7 +143,7 @@ let state = |] module Make_test (Mass : sig - include SMass + include Internal_for_tests.SMass val to_float : t -> float end) (S : sig @@ -190,7 +190,8 @@ end (* Testing the alias sampler with float-valued measures *) -module Probability_mass_float : SMass with type t = float = struct +module Probability_mass_float : Internal_for_tests.SMass with type t = float = +struct type t = float let encoding = Data_encoding.float @@ -226,7 +227,7 @@ module Test_float = (* Testing the alias sampler with Z-valued measures *) -module Probability_mass_z : SMass with type t = Z.t = struct +module Probability_mass_z : Internal_for_tests.SMass with type t = Z.t = struct let encoding = Data_encoding.z include Z diff --git a/src/proto_alpha/lib_protocol/tez_repr.mli b/src/proto_alpha/lib_protocol/tez_repr.mli index 5a1231e2932cd2830aaba1f8a8931ae64190dc41..50b4c79e7f0f674d7d50147492bf691be68f565b 100644 --- a/src/proto_alpha/lib_protocol/tez_repr.mli +++ b/src/proto_alpha/lib_protocol/tez_repr.mli @@ -24,6 +24,14 @@ (* *) (*****************************************************************************) +(** Internal representation of the Tez currency. Behaves mostly like a natural + number where number 1 represents 1/1,000,000 Tez (1 micro-Tez or mutez). + It's protected from ever becoming negative and overflowing by special + arithmetic functions, which fail in case something undesired would happen. + When divided, it's always rounded down to 1 mutez. + + Internally encoded as [int64], which may be relevant to guard against + overflow errors. *) type repr (** [t] is made algebraic in order to distinguish it from the other type diff --git a/src/proto_alpha/lib_protocol/token.ml b/src/proto_alpha/lib_protocol/token.ml index beefc1a06382055fb69db86707342c93e44068fe..980d5a18c144b8328fc1bac756361cc3838c4a8a 100644 --- a/src/proto_alpha/lib_protocol/token.ml +++ b/src/proto_alpha/lib_protocol/token.ml @@ -30,7 +30,7 @@ type container = | `Frozen_deposits of Signature.Public_key_hash.t | `Block_fees ] -type source = +type infinite_source = [ `Invoice | `Bootstrap | `Initial_commitments @@ -40,15 +40,17 @@ type source = | `Baking_rewards | `Baking_bonuses | `Minted - | `Liquidity_baking_subsidies - | container ] + | `Liquidity_baking_subsidies ] -type sink = +type source = [infinite_source | container] + +type infinite_sink = [ `Storage_fees | `Double_signing_punishments | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Burned - | container ] + | `Burned ] + +type sink = [infinite_sink | container] let allocated ctxt stored = match stored with @@ -68,7 +70,7 @@ let balance ctxt stored = | `Collected_commitments bpkh -> Commitment_storage.committed_amount ctxt bpkh | `Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in - Storage.Contract.Balance.get ctxt contract + Storage.Contract.Spendable_balance.get ctxt contract | `Frozen_deposits delegate -> ( let contract = Contract_repr.implicit_contract delegate in Frozen_deposits_storage.find ctxt contract >|=? fun frozen_deposits -> @@ -80,77 +82,95 @@ let balance ctxt stored = let credit ctxt dest amount origin = let open Receipt_repr in (match dest with - | `Storage_fees -> return (ctxt, Storage_fees) - | `Double_signing_punishments -> return (ctxt, Double_signing_punishments) - | `Lost_endorsing_rewards (d, p, r) -> - return (ctxt, Lost_endorsing_rewards (d, p, r)) - | `Burned -> return (ctxt, Burned) - | `Contract dest -> - Contract_storage.credit_only_call_from_token ctxt dest amount - >|=? fun ctxt -> (ctxt, Contract dest) - | `Collected_commitments bpkh -> - Commitment_storage.increase_commitment_only_call_from_token - ctxt - bpkh - amount - >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> - let contract = Contract_repr.implicit_contract delegate in - Contract_storage.increase_balance_only_call_from_token - ctxt - contract - amount - >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate as dest -> - allocated ctxt dest >>=? fun allocated -> - (if not allocated then Frozen_deposits_storage.init ctxt delegate - else return ctxt) - >>=? fun ctxt -> - Frozen_deposits_storage.credit_only_call_from_token ctxt delegate amount - >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> - Raw_context.credit_collected_fees_only_call_from_token ctxt amount - >>?= fun ctxt -> return (ctxt, Block_fees)) + | #infinite_sink as infinite_sink -> + let sink = + match infinite_sink with + | `Storage_fees -> Storage_fees + | `Double_signing_punishments -> Double_signing_punishments + | `Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) + | `Burned -> Burned + in + return (ctxt, sink) + | #container as container -> ( + match container with + | `Contract dest -> + Contract_storage.credit_only_call_from_token ctxt dest amount + >|=? fun ctxt -> (ctxt, Contract dest) + | `Collected_commitments bpkh -> + Commitment_storage.increase_commitment_only_call_from_token + ctxt + bpkh + amount + >|=? fun ctxt -> (ctxt, Commitments bpkh) + | `Delegate_balance delegate -> + let contract = Contract_repr.implicit_contract delegate in + Contract_storage.increase_balance_only_call_from_token + ctxt + contract + amount + >|=? fun ctxt -> (ctxt, Contract contract) + | `Frozen_deposits delegate as dest -> + allocated ctxt dest >>=? fun allocated -> + (if not allocated then Frozen_deposits_storage.init ctxt delegate + else return ctxt) + >>=? fun ctxt -> + Frozen_deposits_storage.credit_only_call_from_token + ctxt + delegate + amount + >|=? fun ctxt -> (ctxt, Deposits delegate) + | `Block_fees -> + Raw_context.credit_collected_fees_only_call_from_token ctxt amount + >>?= fun ctxt -> return (ctxt, Block_fees))) >|=? fun (ctxt, balance) -> (ctxt, (balance, Credited amount, origin)) let spend ctxt src amount origin = let open Receipt_repr in (match src with - | `Bootstrap -> return (ctxt, Bootstrap) - | `Invoice -> return (ctxt, Invoice) - | `Initial_commitments -> return (ctxt, Initial_commitments) - | `Minted -> return (ctxt, Minted) - | `Liquidity_baking_subsidies -> return (ctxt, Liquidity_baking_subsidies) - | `Revelation_rewards -> return (ctxt, Nonce_revelation_rewards) - | `Double_signing_evidence_rewards -> - return (ctxt, Double_signing_evidence_rewards) - | `Endorsing_rewards -> return (ctxt, Endorsing_rewards) - | `Baking_rewards -> return (ctxt, Baking_rewards) - | `Baking_bonuses -> return (ctxt, Baking_bonuses) - | `Contract src -> - Contract_storage.spend_only_call_from_token ctxt src amount - >|=? fun ctxt -> (ctxt, Contract src) - | `Collected_commitments bpkh -> - Commitment_storage.decrease_commitment_only_call_from_token - ctxt - bpkh - amount - >>=? fun ctxt -> return (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> - let contract = Contract_repr.implicit_contract delegate in - Contract_storage.decrease_balance_only_call_from_token - ctxt - contract - amount - >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate -> - (if Tez_repr.(amount = zero) then return ctxt - else - Frozen_deposits_storage.spend_only_call_from_token ctxt delegate amount) - >>=? fun ctxt -> return (ctxt, Deposits delegate) - | `Block_fees -> - Raw_context.spend_collected_fees_only_call_from_token ctxt amount - >>?= fun ctxt -> return (ctxt, Block_fees)) + | #infinite_source as infinite_source -> + let src = + match infinite_source with + | `Bootstrap -> Bootstrap + | `Invoice -> Invoice + | `Initial_commitments -> Initial_commitments + | `Minted -> Minted + | `Liquidity_baking_subsidies -> Liquidity_baking_subsidies + | `Revelation_rewards -> Nonce_revelation_rewards + | `Double_signing_evidence_rewards -> Double_signing_evidence_rewards + | `Endorsing_rewards -> Endorsing_rewards + | `Baking_rewards -> Baking_rewards + | `Baking_bonuses -> Baking_bonuses + in + return (ctxt, src) + | #container as container -> ( + match container with + | `Contract src -> + Contract_storage.spend_only_call_from_token ctxt src amount + >|=? fun ctxt -> (ctxt, Contract src) + | `Collected_commitments bpkh -> + Commitment_storage.decrease_commitment_only_call_from_token + ctxt + bpkh + amount + >>=? fun ctxt -> return (ctxt, Commitments bpkh) + | `Delegate_balance delegate -> + let contract = Contract_repr.implicit_contract delegate in + Contract_storage.decrease_balance_only_call_from_token + ctxt + contract + amount + >|=? fun ctxt -> (ctxt, Contract contract) + | `Frozen_deposits delegate -> + (if Tez_repr.(amount = zero) then return ctxt + else + Frozen_deposits_storage.spend_only_call_from_token + ctxt + delegate + amount) + >>=? fun ctxt -> return (ctxt, Deposits delegate) + | `Block_fees -> + Raw_context.spend_collected_fees_only_call_from_token ctxt amount + >>?= fun ctxt -> return (ctxt, Block_fees))) >|=? fun (ctxt, balance) -> (ctxt, (balance, Debited amount, origin)) let transfer_n ?(origin = Receipt_repr.Block_application) ctxt src dest = diff --git a/src/proto_alpha/lib_protocol/token.mli b/src/proto_alpha/lib_protocol/token.mli index e872b872c34806331d6c7c4f53238d6955be9017..5dece551bbacd19a2d20090872424cb7cf93c149 100644 --- a/src/proto_alpha/lib_protocol/token.mli +++ b/src/proto_alpha/lib_protocol/token.mli @@ -48,9 +48,9 @@ type container = | `Frozen_deposits of Signature.Public_key_hash.t | `Block_fees ] -(** [source] is the type of token providers. Token providers that are not - containers are considered to have infinite capacity. *) -type source = +(** [infinite_source] defines types of tokens provides which are considered to be + ** of infinite capacity. *) +type infinite_source = [ `Invoice | `Bootstrap | `Initial_commitments @@ -60,17 +60,21 @@ type source = | `Baking_rewards | `Baking_bonuses | `Minted - | `Liquidity_baking_subsidies - | container ] + | `Liquidity_baking_subsidies ] -(** [sink] is the type of token receivers. Token receivers that are not +(** [source] is the type of token providers. Token providers that are not containers are considered to have infinite capacity. *) -type sink = +type source = [infinite_source | container] + +type infinite_sink = [ `Storage_fees | `Double_signing_punishments | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Burned - | container ] + | `Burned ] + +(** [sink] is the type of token receivers. Token receivers that are not + containers are considered to have infinite capacity. *) +type sink = [infinite_sink | container] (** [allocated ctxt container] returns true if [balance ctxt container] is guaranteed not to fail, and returns false when [balance ctxt container] may