diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 2cd5e55bd56aa8e4fb0ba3cce237a3b84c45b352..e78124e1a27dd89d303bd951a3de6feeff9e38bb 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -654,7 +654,7 @@ end) let result = Lwt_main.run ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let big_map = Script_ir_translator.empty_big_map key_ty elt_ty in + let big_map = Script_big_map.empty key_ty elt_ty in (* Cannot have big maps under big maps *) option_t (-1) elt_ty |> Environment.wrap_tzresult >>?= fun opt_elt_ty -> @@ -662,7 +662,7 @@ end) Script_map.fold (fun k v acc -> acc >>=? fun (bm, ctxt_acc) -> - Script_ir_translator.big_map_update ctxt_acc k v bm) + Script_big_map.update ctxt_acc k v bm) map (return (big_map, ctxt)) >|= Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index 81187791c5495229155aae2c07905c0195e4e35f..d934fca4a4aaa006bc28974629210cd83ad69bfc 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -1412,11 +1412,11 @@ module Registration_section = struct raise_if_error (Lwt_main.run ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let big_map = Script_ir_translator.empty_big_map int unit_t in + let big_map = Script_big_map.empty int unit_t in Script_map.fold (fun k v acc -> acc >>=? fun (bm, ctxt_acc) -> - Script_ir_translator.big_map_update ctxt_acc k v bm) + Script_big_map.update ctxt_acc k v bm) map (return (big_map, ctxt)) >|= Environment.wrap_tzresult @@ -1463,7 +1463,7 @@ module Registration_section = struct ( kinfo (int @$ big_map int unit @$ unit @$ bot), halt (option unit @$ unit @$ bot) )) ~intercept_stack: - (let map = Script_ir_translator.empty_big_map int unit in + (let map = Script_big_map.empty int unit in (Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> let key, map = generate_big_map_and_key_in_map cfg rng_state in @@ -1483,7 +1483,7 @@ module Registration_section = struct ( kinfo (int @$ option unit @$ big_map int unit @$ bot), halt (big_map int unit @$ bot) )) ~intercept_stack: - (let map = Script_ir_translator.empty_big_map int unit in + (let map = Script_big_map.empty int unit in (Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> let key, map = generate_big_map_and_key_in_map cfg rng_state in @@ -1504,7 +1504,7 @@ module Registration_section = struct ( kinfo (int @$ option unit @$ big_map int unit @$ bot), halt (option unit @$ big_map int unit @$ bot) )) ~intercept_stack: - (let map = Script_ir_translator.empty_big_map int unit in + (let map = Script_big_map.empty int unit in (Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> let key, map = generate_big_map_and_key_in_map cfg rng_state in diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 72597091ad41491601db20196737c5c9470b5a9f..e7a9039bfa71930afdcc24d78c8bb79a4fe023f6 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -164,6 +164,7 @@ "Script_tc_context", "Apply_results", "Script_ir_translator", + "Script_big_map", "Script_cache", "Script_tc_errors_registration", "Ticket_costs", diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 209816423928b5a09395f8cd21c2d2eabdba6f8d..9adad91359a23d8c02696c9d0e405c9973e986bc 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -185,6 +185,7 @@ Script_tc_context Apply_results Script_ir_translator + Script_big_map Script_cache Script_tc_errors_registration Ticket_costs @@ -391,6 +392,7 @@ script_tc_context.ml script_tc_context.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli + script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli script_tc_errors_registration.ml script_tc_errors_registration.mli ticket_costs.ml ticket_costs.mli @@ -583,6 +585,7 @@ script_tc_context.ml script_tc_context.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli + script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli script_tc_errors_registration.ml script_tc_errors_registration.mli ticket_costs.ml ticket_costs.mli @@ -796,6 +799,7 @@ script_tc_context.ml script_tc_context.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli + script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli script_tc_errors_registration.ml script_tc_errors_registration.mli ticket_costs.ml ticket_costs.mli @@ -1004,6 +1008,7 @@ script_tc_context.ml script_tc_context.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli + script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli script_tc_errors_registration.ml script_tc_errors_registration.mli ticket_costs.ml ticket_costs.mli diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml new file mode 100644 index 0000000000000000000000000000000000000000..44369f61a1fd532eb8b055c820335bdd3e5fa4e3 --- /dev/null +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -0,0 +1,92 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2021-2022 Nomadic Labs *) +(* Copyright (c) 2022 Trili Tech *) +(* Copyright (c) 2022 Marigold *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Script_typed_ir +open Script_ir_translator + +let empty key_type value_type = + Big_map + { + id = None; + diff = {map = Big_map_overlay.empty; size = 0}; + key_type; + value_type; + } + +let mem ctxt key (Big_map {id; diff; key_type; _}) = + hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> + match (Big_map_overlay.find key_hash diff.map, id) with + | None, None -> return (false, ctxt) + | None, Some id -> + Alpha_context.Big_map.mem ctxt id key_hash >|=? fun (ctxt, res) -> + (res, ctxt) + | Some (_, None), _ -> return (false, ctxt) + | Some (_, Some _), _ -> return (true, ctxt) + +let get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = + match (Big_map_overlay.find key diff.map, id) with + | Some (_, x), _ -> return (x, ctxt) + | None, None -> return (None, ctxt) + | None, Some id -> ( + Alpha_context.Big_map.get_opt ctxt id key >>=? function + | ctxt, None -> return (None, ctxt) + | ctxt, Some value -> + parse_data + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >|=? fun (x, ctxt) -> (Some x, ctxt)) + +let get ctxt key (Big_map {key_type; _} as map) = + hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> + get_by_hash ctxt key_hash map + +let update_by_hash key_hash key value (Big_map map) = + let contains = Big_map_overlay.mem key_hash map.diff.map in + Big_map + { + map with + diff = + { + map = Big_map_overlay.add key_hash (key, value) map.diff.map; + size = (if contains then map.diff.size else map.diff.size + 1); + }; + } + +let update ctxt key value (Big_map {key_type; _} as map) = + hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> + let map = update_by_hash key_hash key value map in + return (map, ctxt) + +let get_and_update ctxt key value (Big_map {key_type; _} as map) = + hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> + let new_map = update_by_hash key_hash key value map in + get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) -> + return ((old_value, new_map), ctxt) diff --git a/src/proto_alpha/lib_protocol/script_big_map.mli b/src/proto_alpha/lib_protocol/script_big_map.mli new file mode 100644 index 0000000000000000000000000000000000000000..62fac92a1846642a74f466cfa2e2f62cf748bfb8 --- /dev/null +++ b/src/proto_alpha/lib_protocol/script_big_map.mli @@ -0,0 +1,83 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2021-2022 Nomadic Labs *) +(* Copyright (c) 2022 Trili Tech *) +(* Copyright (c) 2022 Marigold *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +(** [empty] is the big map with no bindings. *) +val empty : + 'a Script_typed_ir.comparable_ty -> + ('b, _) Script_typed_ir.ty -> + ('a, 'b) Script_typed_ir.big_map + +(** [mem ctxt key big_map] returns [true] iff [key] is bound in the + given [big_map]. + Consumes the cost of hashing the given key. + Consumes as [Storage.Big_map.Contents.mem] if the key is not bound + yet in the current overlay. *) +val mem : + context -> + 'key -> + ('key, 'value) Script_typed_ir.big_map -> + (bool * context) tzresult Lwt.t + +(** [get ctxt key big_map] returns the value bound by [key] in the + given [big_map]. If the [key] is not bound, [None] is returned instead. + Consumes cost of hashing the given key. + Consumes cost as [Storage.Big_map.Contents.find] in case of the given key + is absent in the current overlay. + Consumes cost of parsing data if the value is readed from storage. *) +val get : + context -> + 'key -> + ('key, 'value) Script_typed_ir.big_map -> + ('value option * context) tzresult Lwt.t + +(** [update ctxt key new_value big_map] updates the value bound by [key] + with [v] if the [new_value] is [Some v]. When the [new_value] is [None], + delete the entire entry bound by [key] in the [big_map]. + Consumes cost for hashing the given key. + See {!get_and_update} for details. *) +val update : + context -> + 'key -> + 'value option -> + ('key, 'value) Script_typed_ir.big_map -> + (('key, 'value) Script_typed_ir.big_map * context) tzresult Lwt.t + +(** [get_and_update ctxt key new_value big_map] works just like + [update ctxt key new_value big_map] except it also returns + the old value bound by [key]. + Consumes cost for hashing the given key. + This does {i not} modify the underlying storage, only the diff table. *) +val get_and_update : + context -> + 'key -> + 'value option -> + ('key, 'value) Script_typed_ir.big_map -> + (('value option * ('key, 'value) Script_typed_ir.big_map) * context) tzresult + Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 1efa10a6568ec4e9029598874e772abd04bfb1ca..26646df03f42e9ed59df07c1bd60ff5c7798741c 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -640,34 +640,34 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) g gas k ks res stack (* Big map operations *) | IEmpty_big_map (_, tk, tv, k) -> - let ebm = Script_ir_translator.empty_big_map tk tv in + let ebm = Script_big_map.empty tk tv in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) | IBig_map_mem (_, k) -> let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - Script_ir_translator.big_map_mem ctxt key map ) + Script_big_map.mem ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack | IBig_map_get (_, k) -> let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - Script_ir_translator.big_map_get ctxt key map ) + Script_big_map.get ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack | IBig_map_update (_, k) -> let key = accu in let maybe_value, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - Script_ir_translator.big_map_update ctxt key maybe_value map ) + Script_big_map.update ctxt key maybe_value map ) >>=? fun (big_map, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack | IBig_map_get_and_update (_, k) -> let key = accu in let v, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - Script_ir_translator.big_map_get_and_update ctxt key v map ) + Script_big_map.get_and_update ctxt key v map ) >>=? fun ((v', map'), ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack) (* timestamp operations *) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 11f7323a23dc399fa3cc116a40dcc166f374956c..78213e0b0ad20aafa4c83d92e1e0c51a3c635b34 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5665,71 +5665,6 @@ let hash_data ctxt ty data = let pack_data ctxt ty data = pack_data_with_mode ctxt ty data ~mode:Optimized_legacy -(* ---------------- Big map -------------------------------------------------*) - -let empty_big_map key_type value_type = - Big_map - { - id = None; - diff = {map = Big_map_overlay.empty; size = 0}; - key_type; - value_type; - } - -let big_map_mem ctxt key (Big_map {id; diff; key_type; _}) = - hash_comparable_data ctxt key_type key >>=? fun (key, ctxt) -> - match (Big_map_overlay.find key diff.map, id) with - | None, None -> return (false, ctxt) - | None, Some id -> - Alpha_context.Big_map.mem ctxt id key >|=? fun (ctxt, res) -> (res, ctxt) - | Some (_, None), _ -> return (false, ctxt) - | Some (_, Some _), _ -> return (true, ctxt) - -let big_map_get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = - match (Big_map_overlay.find key diff.map, id) with - | Some (_, x), _ -> return (x, ctxt) - | None, None -> return (None, ctxt) - | None, Some id -> ( - Alpha_context.Big_map.get_opt ctxt id key >>=? function - | ctxt, None -> return (None, ctxt) - | ctxt, Some value -> - parse_data - ~stack_depth:0 - ctxt - ~legacy:true - ~allow_forged:true - value_type - (Micheline.root value) - >|=? fun (x, ctxt) -> (Some x, ctxt)) - -let big_map_get ctxt key (Big_map {key_type; _} as map) = - hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - big_map_get_by_hash ctxt key_hash map - -let big_map_update_by_hash ctxt key_hash key value (Big_map map) = - let contains = Big_map_overlay.mem key_hash map.diff.map in - return - ( Big_map - { - map with - diff = - { - map = Big_map_overlay.add key_hash (key, value) map.diff.map; - size = (if contains then map.diff.size else map.diff.size + 1); - }; - }, - ctxt ) - -let big_map_update ctxt key value (Big_map {key_type; _} as map) = - hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - big_map_update_by_hash ctxt key_hash key value map - -let big_map_get_and_update ctxt key value (Big_map {key_type; _} as map) = - hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - big_map_update_by_hash ctxt key_hash key value map >>=? fun (map', ctxt) -> - big_map_get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) -> - return ((old_value, map'), ctxt) - (* ---------------- Lazy storage---------------------------------------------*) type lazy_storage_ids = Lazy_storage.IdSet.t diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 919e2e71ead8c943310a1695d86c951c451047a5..de9c6207a73ea1e2bbd2f62a00e768d24e359a6b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -175,44 +175,6 @@ type type_logger = stack_ty_after:Script.expr list -> unit -(** Create an empty big_map *) -val empty_big_map : - 'a Script_typed_ir.comparable_ty -> - ('b, _) Script_typed_ir.ty -> - ('a, 'b) Script_typed_ir.big_map - -val big_map_mem : - context -> - 'key -> - ('key, 'value) Script_typed_ir.big_map -> - (bool * context) tzresult Lwt.t - -val big_map_get : - context -> - 'key -> - ('key, 'value) Script_typed_ir.big_map -> - ('value option * context) tzresult Lwt.t - -(** Update a big map. See {!big_map_get_and_update} for details. *) -val big_map_update : - context -> - 'key -> - 'value option -> - ('key, 'value) Script_typed_ir.big_map -> - (('key, 'value) Script_typed_ir.big_map * context) tzresult Lwt.t - -(** Update a big map, returning the old value of the given key and the new map. - - This does {i not} modify the underlying storage, only the diff table. - *) -val big_map_get_and_update : - context -> - 'key -> - 'value option -> - ('key, 'value) Script_typed_ir.big_map -> - (('value option * ('key, 'value) Script_typed_ir.big_map) * context) tzresult - Lwt.t - val ty_eq : error_details:(Script.location, 'error_trace) error_details -> ('a, 'ac) Script_typed_ir.ty -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/script_big_map.ml b/src/proto_alpha/lib_protocol/test/helpers/script_big_map.ml index 8573cafd181800061836aec97a67742bdf5af88f..6a7745859af01c1c49a96880b7b16dbf92bd2405 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/script_big_map.ml @@ -21,10 +21,10 @@ (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) -let update k v m ctxt = Protocol.Script_ir_translator.big_map_update ctxt k v m +let update k v m ctxt = Protocol.Script_big_map.update ctxt k v m let of_list key_ty ty xs ctxt = List.fold_left_es (fun (bm, ctxt) (k, v) -> update k (Some v) bm ctxt) - (Protocol.Script_ir_translator.empty_big_map key_ty ty, ctxt) + (Protocol.Script_big_map.empty key_ty ty, ctxt) xs