Proto/Contracts: start generalizing lazy storage

parent 159e45b9
......@@ -35,6 +35,7 @@
"Manager_repr",
"Commitment_repr",
"Parameters_repr",
"Lazy_storage_kind",
"Raw_context",
"Storage_sigs",
......@@ -47,6 +48,7 @@
"Seed_storage",
"Roll_storage",
"Delegate_storage",
"Lazy_storage_diff",
"Contract_storage",
"Bootstrap_storage",
"Fitness_storage",
......
......@@ -343,88 +343,71 @@ module Legacy_big_map_diff = struct
let encoding =
let open Data_encoding in
def "contract.big_map_diff" @@ list item_encoding
end
let big_map_key_cost = 65
let big_map_cost = 33
let to_lazy_storage_diff legacy_diffs =
let rev_last (diffs : (_ * (_, _) Lazy_storage_diff.diff) list) =
match diffs with
| [] ->
[]
| (_, Remove) :: _ ->
diffs
| (id, Update {init; updates}) :: rest ->
(id, Update {init; updates = List.rev updates}) :: rest
in
List.fold_left
(fun (new_diff : (_ * (_, _) Lazy_storage_diff.diff) list) item ->
match item with
| Clear id ->
(id, Lazy_storage_diff.Remove) :: rev_last new_diff
| Copy {src; dst} ->
(dst, Lazy_storage_diff.Update {init = Copy {src}; updates = []})
:: rev_last new_diff
| Alloc {big_map; key_type; value_type} ->
( big_map,
Lazy_storage_diff.(
Update
{init = Alloc Big_map.{key_type; value_type}; updates = []})
)
:: rev_last new_diff
| Update
{ big_map;
diff_key = key;
diff_key_hash = key_hash;
diff_value = value } -> (
match new_diff with
| (id, diff) :: rest when Compare.Z.(id = big_map) ->
let diff =
match diff with
| Remove ->
assert false
| Update {init; updates} ->
let updates =
Lazy_storage_diff.Big_map.{key; key_hash; value}
:: updates
in
Lazy_storage_diff.Update {init; updates}
in
(id, diff) :: rest
| new_diff ->
let updates =
[Lazy_storage_diff.Big_map.{key; key_hash; value}]
in
(big_map, Update {init = Existing; updates}) :: rev_last new_diff
))
[]
legacy_diffs
|> rev_last
|> List.rev_map (fun (id, diff) ->
Lazy_storage_diff.make Lazy_storage_kind.Big_map id diff)
end
let update_script_big_map c = function
| None ->
return (c, Z.zero)
| Some diff ->
let open Legacy_big_map_diff in
fold_left_s
(fun (c, total) -> function Clear id ->
Storage.Big_map.Total_bytes.get c id
>>=? fun size ->
Storage.Big_map.remove_rec c id
>>= fun c ->
if Compare.Z.(id < Z.zero) then return (c, total)
else return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost))
| Copy {src = from; dst = to_} ->
Storage.Big_map.copy c ~from ~to_
>>=? fun c ->
if Compare.Z.(to_ < Z.zero) then return (c, total)
else
Storage.Big_map.Total_bytes.get c from
>>=? fun size ->
return (c, Z.add (Z.add total size) (Z.of_int big_map_cost))
| Alloc {big_map; key_type; value_type} ->
Storage.Big_map.Total_bytes.init c big_map Z.zero
>>=? fun c ->
(* Annotations are erased to allow sharing on
[Copy]. The types from the contract code are used,
these ones are only used to make sure they are
compatible during transmissions between contracts,
and only need to be compatible, annotations
nonwhistanding. *)
let key_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root key_type))
in
let value_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root value_type))
in
Storage.Big_map.Key_type.init c big_map key_type
>>=? fun c ->
Storage.Big_map.Value_type.init c big_map value_type
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.add total (Z.of_int big_map_cost))
| Update {big_map; diff_key_hash; diff_value = None} ->
Storage.Big_map.Contents.remove (c, big_map) diff_key_hash
>>=? fun (c, freed, existed) ->
let freed =
if existed then freed + big_map_key_cost else freed
in
Storage.Big_map.Total_bytes.get c big_map
>>=? fun size ->
Storage.Big_map.Total_bytes.set
c
big_map
(Z.sub size (Z.of_int freed))
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.sub total (Z.of_int freed))
| Update {big_map; diff_key_hash; diff_value = Some v} ->
Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v
>>=? fun (c, size_diff, existed) ->
let size_diff =
if existed then size_diff else size_diff + big_map_key_cost
in
Storage.Big_map.Total_bytes.get c big_map
>>=? fun size ->
Storage.Big_map.Total_bytes.set
c
big_map
(Z.add size (Z.of_int size_diff))
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.add total (Z.of_int size_diff)))
(c, Z.zero)
diff
| Some legacy_diffs ->
Lazy_storage_diff.apply
c
(Legacy_big_map_diff.to_lazy_storage_diff legacy_diffs)
let create_base c ?(prepaid_bootstrap_storage = false)
(* Free space for bootstrap contracts *)
......
......@@ -51,6 +51,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
manager_repr.mli manager_repr.ml
commitment_repr.mli commitment_repr.ml
parameters_repr.mli parameters_repr.ml
lazy_storage_kind.ml
raw_context.mli raw_context.ml
storage_sigs.ml
storage_functors.mli storage_functors.ml
......@@ -61,6 +62,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
seed_storage.mli seed_storage.ml
roll_storage.mli roll_storage.ml
delegate_storage.mli delegate_storage.ml
lazy_storage_diff.mli lazy_storage_diff.ml
contract_storage.mli contract_storage.ml
bootstrap_storage.mli bootstrap_storage.ml
fitness_storage.ml
......@@ -128,6 +130,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
manager_repr.mli manager_repr.ml
commitment_repr.mli commitment_repr.ml
parameters_repr.mli parameters_repr.ml
lazy_storage_kind.ml
raw_context.mli raw_context.ml
storage_sigs.ml
storage_functors.mli storage_functors.ml
......@@ -138,6 +141,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
seed_storage.mli seed_storage.ml
roll_storage.mli roll_storage.ml
delegate_storage.mli delegate_storage.ml
lazy_storage_diff.mli lazy_storage_diff.ml
contract_storage.mli contract_storage.ml
bootstrap_storage.mli bootstrap_storage.ml
fitness_storage.ml
......@@ -205,6 +209,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
manager_repr.mli manager_repr.ml
commitment_repr.mli commitment_repr.ml
parameters_repr.mli parameters_repr.ml
lazy_storage_kind.ml
raw_context.mli raw_context.ml
storage_sigs.ml
storage_functors.mli storage_functors.ml
......@@ -215,6 +220,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
seed_storage.mli seed_storage.ml
roll_storage.mli roll_storage.ml
delegate_storage.mli delegate_storage.ml
lazy_storage_diff.mli lazy_storage_diff.ml
contract_storage.mli contract_storage.ml
bootstrap_storage.mli bootstrap_storage.ml
fitness_storage.ml
......@@ -302,6 +308,7 @@ include Tezos_raw_protocol_alpha.Main
Manager_repr
Commitment_repr
Parameters_repr
Lazy_storage_kind
Raw_context
Storage_sigs
Storage_functors
......@@ -312,6 +319,7 @@ include Tezos_raw_protocol_alpha.Main
Seed_storage
Roll_storage
Delegate_storage
Lazy_storage_diff
Contract_storage
Bootstrap_storage
Fitness_storage
......
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2020 Monadic Labs <[email protected]> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type OPS = sig
type alloc
type updates
val unit_cost : Z.t
val alloc : Raw_context.t -> Z.t -> alloc -> Raw_context.t tzresult Lwt.t
val apply_updates :
Raw_context.t -> Z.t -> updates -> (Raw_context.t * Z.t) tzresult Lwt.t
module Total_bytes : sig
val init : Raw_context.t -> Z.t -> Z.t -> Raw_context.t tzresult Lwt.t
val get : Raw_context.t -> Z.t -> Z.t tzresult Lwt.t
val set : Raw_context.t -> Z.t -> Z.t -> Raw_context.t tzresult Lwt.t
end
val copy :
Raw_context.t -> from:Z.t -> to_:Z.t -> Raw_context.t tzresult Lwt.t
val remove_rec : Raw_context.t -> Z.t -> Raw_context.t Lwt.t
end
module Big_map = struct
include Lazy_storage_kind.Big_map
let big_map_key_cost = 65
let unit_cost =
let big_map_cost = 33 in
Z.of_int big_map_cost
let alloc ctxt id {key_type; value_type} =
(* Annotations are erased to allow sharing on [Copy]. The types from the
contract code are used, these ones are only used to make sure they are
compatible during transmissions between contracts, and only need to be
compatible, annotations nonwhistanding. *)
let key_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root key_type))
in
let value_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root value_type))
in
Storage.Big_map.Key_type.init ctxt id key_type
>>=? fun ctxt -> Storage.Big_map.Value_type.init ctxt id value_type
let apply_update ctxt id {key = _; key_hash; value} =
match value with
| None ->
Storage.Big_map.Contents.remove (ctxt, id) key_hash
>>|? fun (ctxt, freed, existed) ->
let freed = if existed then freed + big_map_key_cost else freed in
(ctxt, Z.of_int ~-freed)
| Some v ->
Storage.Big_map.Contents.init_set (ctxt, id) key_hash v
>>|? fun (ctxt, size_diff, existed) ->
let size_diff =
if existed then size_diff else size_diff + big_map_key_cost
in
(ctxt, Z.of_int size_diff)
let apply_updates ctxt id updates =
fold_left_s
(fun (ctxt, size) update ->
apply_update ctxt id update
>>|? fun (ctxt, added_size) -> (ctxt, Z.add size added_size))
(ctxt, Z.zero)
updates
include Storage.Big_map
end
type ('alloc, 'updates) ops =
(module OPS with type alloc = 'alloc and type updates = 'updates)
let get_ops : type a u. (a, u) Lazy_storage_kind.t -> (a, u) ops = function
| Big_map ->
(module Big_map)
type 'alloc init = Existing | Copy of {src : Z.t} | Alloc of 'alloc
type ('alloc, 'updates) diff =
| Remove
| Update of {init : 'alloc init; updates : 'updates}
let apply_updates : type a u. _ -> (a, u) ops -> _ -> u -> _ =
fun ctxt (module OPS) id updates ->
OPS.apply_updates ctxt id updates
>>=? fun (ctxt, updates_size) ->
if Z.(equal updates_size zero) then return (ctxt, updates_size)
else
OPS.Total_bytes.get ctxt id
>>=? fun size ->
OPS.Total_bytes.set ctxt id (Z.add size updates_size)
>>|? fun ctxt -> (ctxt, updates_size)
let apply_init : type a u. _ -> (a, u) ops -> _ -> a init -> _ =
fun ctxt (module OPS) id init ->
match init with
| Existing ->
return (ctxt, Z.zero)
| Copy {src} ->
OPS.copy ctxt ~from:src ~to_:id
>>=? fun ctxt ->
OPS.Total_bytes.get ctxt src
>>=? fun copy_size -> return (ctxt, copy_size)
| Alloc alloc ->
OPS.Total_bytes.init ctxt id Z.zero
>>=? fun ctxt ->
OPS.alloc ctxt id alloc >>=? fun ctxt -> return (ctxt, OPS.unit_cost)
let apply_diff : type a u. _ -> (a, u) ops -> _ -> (a, u) diff -> _ =
fun ctxt ((module OPS) as ops) id diff ->
match diff with
| Remove ->
OPS.Total_bytes.get ctxt id
>>=? fun size ->
OPS.remove_rec ctxt id
>>= fun ctxt -> return (ctxt, Z.neg (Z.add size OPS.unit_cost))
| Update {init; updates} ->
apply_init ctxt ops id init
>>=? fun (ctxt, init_size) ->
apply_updates ctxt ops id updates
>>=? fun (ctxt, updates_size) ->
return (ctxt, Z.add init_size updates_size)
type diffs_item =
| E : ('a, 'u) Lazy_storage_kind.t * Z.t * ('a, 'u) diff -> diffs_item
let make :
type a u. (a, u) Lazy_storage_kind.t -> Z.t -> (a, u) diff -> diffs_item =
fun k id diff -> E (k, id, diff)
type diffs = diffs_item list
let apply ctxt diffs =
fold_left_s
(fun (ctxt, total_size) (E (k, id, diff)) ->
let ops = get_ops k in
apply_diff ctxt ops id diff
>>|? fun (ctxt, added_size) ->
( ctxt,
if Compare.Z.(id < Z.zero) then total_size
else Z.add total_size added_size ))
(ctxt, Z.zero)
diffs
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2020 Monadic Labs <[email protected]> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining 'a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Big_map : sig
type alloc = Lazy_storage_kind.Big_map.alloc = {
key_type : Script_repr.expr;
value_type : Script_repr.expr;
}
type update = Lazy_storage_kind.Big_map.update = {
key : Script_repr.expr;
key_hash : Script_expr_hash.t;
value : Script_repr.expr option;
}
type updates = Lazy_storage_kind.Big_map.updates
end
type 'alloc init = Existing | Copy of {src : Z.t} | Alloc of 'alloc
type ('alloc, 'updates) diff =
| Remove
| Update of {init : 'alloc init; updates : 'updates}
type diffs_item
val make : ('a, 'u) Lazy_storage_kind.t -> Z.t -> ('a, 'u) diff -> diffs_item
type diffs = diffs_item list
val apply : Raw_context.t -> diffs -> (Raw_context.t * Z.t) tzresult Lwt.t
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2020 Monadic Labs <[email protected]> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Big_map = struct
type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr}
type update = {
key : Script_repr.expr;
key_hash : Script_expr_hash.t;
value : Script_repr.expr option;
}
type updates = update list
end
type ('alloc, 'updates) t = Big_map : (Big_map.alloc, Big_map.updates) t
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment