From 34d9f7e6491880854c5464f752efab902ccb9a01 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 28 Jun 2018 20:54:39 +0200 Subject: [PATCH] Alpha: minor improvements and fixes in gas --- src/lib_data_encoding/data_encoding.ml | 2 +- src/lib_data_encoding/data_encoding.mli | 6 +- src/lib_error_monad/error_monad.ml | 14 +++ src/lib_error_monad/error_monad_sig.ml | 6 + .../sigs/v1/data_encoding.mli | 4 +- .../sigs/v1/error_monad.mli | 6 + .../client_proto_context_commands.ml | 2 +- .../lib_protocol/src/alpha_context.ml | 11 ++ .../lib_protocol/src/alpha_context.mli | 5 +- src/proto_alpha/lib_protocol/src/apply.ml | 34 +++-- .../lib_protocol/src/contract_services.ml | 7 +- .../lib_protocol/src/gas_limit_repr.ml | 4 + .../lib_protocol/src/gas_limit_repr.mli | 1 + .../lib_protocol/src/michelson_v1_gas.ml | 5 +- .../lib_protocol/src/raw_context.ml | 4 + .../lib_protocol/src/raw_context.mli | 3 + .../lib_protocol/src/script_interpreter.ml | 11 +- .../lib_protocol/src/script_ir_translator.ml | 118 ++++++++---------- .../lib_protocol/src/script_ir_translator.mli | 4 +- .../lib_protocol/src/script_repr.ml | 27 ++-- src/proto_alpha/lib_protocol/src/storage.ml | 26 ++-- .../lib_protocol/src/storage_functors.ml | 4 + 22 files changed, 176 insertions(+), 128 deletions(-) diff --git a/src/lib_data_encoding/data_encoding.ml b/src/lib_data_encoding/data_encoding.ml index 108077d9e..c16963904 100644 --- a/src/lib_data_encoding/data_encoding.ml +++ b/src/lib_data_encoding/data_encoding.ml @@ -100,7 +100,7 @@ struct splitted ~json ~binary let make_lazy encoding value = { encoding ; state = Value value } - let fold_lazy fun_value fun_bytes fun_combine le = + let apply_lazy ~fun_value ~fun_bytes ~fun_combine le = match le.state with | Value value -> fun_value value | Bytes bytes -> fun_bytes bytes diff --git a/src/lib_data_encoding/data_encoding.mli b/src/lib_data_encoding/data_encoding.mli index 5d73fbbcc..81ed8efb5 100644 --- a/src/lib_data_encoding/data_encoding.mli +++ b/src/lib_data_encoding/data_encoding.mli @@ -510,9 +510,9 @@ module Encoding: sig (** Make a lazy value from an immediate one. *) val make_lazy : 'a encoding -> 'a -> 'a lazy_t - (** Fold on structure of lazy value, and combine results *) - val fold_lazy : - ('a -> 'b) -> (MBytes.t -> 'b) -> ('b -> 'b -> 'b) -> + (** Apply on structure of lazy value, and combine results *) + val apply_lazy : + fun_value:('a -> 'b) -> fun_bytes:(MBytes.t -> 'b) -> fun_combine:('b -> 'b -> 'b) -> 'a lazy_t -> 'b end diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index bf9da9d99..94f542d3b 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -557,6 +557,20 @@ module Make(Prefix : sig val id : string end) = struct | Error errs -> Lwt.return (Error (err :: errs)) | ok -> Lwt.return ok + let record_trace_eval mk_err result = + match result with + | Ok _ as res -> res + | Error errs -> + mk_err () >>? fun err -> + Error (err :: errs) + + let trace_eval mk_err f = + f >>= function + | Error errs -> + mk_err () >>=? fun err -> + Lwt.return (Error (err :: errs)) + | ok -> Lwt.return ok + let fail_unless cond exn = if cond then return_unit else fail exn diff --git a/src/lib_error_monad/error_monad_sig.ml b/src/lib_error_monad/error_monad_sig.ml index 6c2846834..78f7b19dd 100644 --- a/src/lib_error_monad/error_monad_sig.ml +++ b/src/lib_error_monad/error_monad_sig.ml @@ -127,6 +127,12 @@ module type S = sig (** Automatically enrich error reporting on stack rewind *) val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t + (** Same as record_trace, for unevaluated error *) + val record_trace_eval : (unit -> error tzresult) -> 'a tzresult -> 'a tzresult + + (** Same as trace, for unevaluated Lwt error *) + val trace_eval : (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t + (** Erroneous return on failed assertion *) val fail_unless : bool -> error -> unit tzresult Lwt.t val fail_when : bool -> error -> unit tzresult Lwt.t diff --git a/src/lib_protocol_environment/sigs/v1/data_encoding.mli b/src/lib_protocol_environment/sigs/v1/data_encoding.mli index 28da335b7..b1330f15a 100644 --- a/src/lib_protocol_environment/sigs/v1/data_encoding.mli +++ b/src/lib_protocol_environment/sigs/v1/data_encoding.mli @@ -198,8 +198,8 @@ val lazy_encoding : 'a encoding -> 'a lazy_t encoding val force_decode : 'a lazy_t -> 'a option val force_bytes : 'a lazy_t -> MBytes.t val make_lazy : 'a encoding -> 'a -> 'a lazy_t -val fold_lazy : - ('a -> 'b) -> (MBytes.t -> 'b) -> ('b -> 'b -> 'b) -> +val apply_lazy : + fun_value:('a -> 'b) -> fun_bytes:(MBytes.t -> 'b) -> fun_combine:('b -> 'b -> 'b) -> 'a lazy_t -> 'b module Json : sig diff --git a/src/lib_protocol_environment/sigs/v1/error_monad.mli b/src/lib_protocol_environment/sigs/v1/error_monad.mli index 293383c0e..65ddeecdd 100644 --- a/src/lib_protocol_environment/sigs/v1/error_monad.mli +++ b/src/lib_protocol_environment/sigs/v1/error_monad.mli @@ -118,6 +118,12 @@ val record_trace : error -> 'a tzresult -> 'a tzresult (** Automatically enrich error reporting on stack rewind *) val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t +(** Same as record_trace, for unevaluated error *) +val record_trace_eval : (unit -> error tzresult) -> 'a tzresult -> 'a tzresult + +(** Same as trace, for unevaluated Lwt error *) +val trace_eval : (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t + (** Erroneous return on failed assertion *) val fail_unless : bool -> error -> unit tzresult Lwt.t diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 17d29f10b..65640542c 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -129,7 +129,7 @@ let commands () = | None -> cctxt#error "This is not a smart contract." | Some { code ; storage = _ } -> - match Script.force_decode code with + match Script_repr.force_decode code with | Error errs -> cctxt#error "%a" (Format.pp_print_list ~pp_sep:Format.pp_print_newline Alpha_environment.Error_monad.pp) errs | Ok (code, _) -> begin cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped code >>= fun () -> diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.ml b/src/proto_alpha/lib_protocol/src/alpha_context.ml index fd7aec34d..1acdff4f2 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/src/alpha_context.ml @@ -53,6 +53,16 @@ end module Script = struct include Michelson_v1_primitives include Script_repr + let force_decode ctxt lexpr = + Lwt.return + (Script_repr.force_decode lexpr >>? fun (v, cost) -> + Raw_context.consume_gas ctxt cost >|? fun ctxt -> + (v, ctxt)) + let force_bytes ctxt lexpr = + Lwt.return + (Script_repr.force_bytes lexpr >>? fun (b, cost) -> + Raw_context.consume_gas ctxt cost >|? fun ctxt -> + (b, ctxt)) end module Fees = Fees_storage @@ -74,6 +84,7 @@ module Gas = struct let set_limit = Raw_context.set_gas_limit let set_unlimited = Raw_context.set_gas_unlimited let consume = Raw_context.consume_gas + let check_enough = Raw_context.check_enough_gas let level = Raw_context.gas_level let consumed = Raw_context.gas_consumed let block_level = Raw_context.block_gas_level diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index 51f6332f2..f2d2e15c0 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -140,6 +140,7 @@ module Gas : sig val set_limit: context -> Z.t -> context val set_unlimited: context -> context val consume: context -> cost -> context tzresult + val check_enough: context -> cost -> unit tzresult val level: context -> t val consumed: since: context -> until: context -> Z.t val block_level: context -> Z.t @@ -311,9 +312,9 @@ module Script : sig val prim_node_cost_nonrec_of_length : int -> annot -> Gas.cost val seq_node_cost_nonrec : expr list -> Gas.cost val seq_node_cost_nonrec_of_length : int -> Gas.cost - val force_decode : lazy_expr -> (expr * Gas.cost) tzresult - val force_bytes : lazy_expr -> (MBytes.t * Gas.cost) tzresult val minimal_deserialize_cost : lazy_expr -> Gas.cost + val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t + val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t end module Constants : sig diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index 6eaac060b..290097fb3 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -364,8 +364,8 @@ let apply_manager_operation_content : match parameters with | None -> return ctxt | Some arg -> - Lwt.return (Script.force_decode arg) >>=? fun (arg, _cost_arg (* see [note] *)) -> - (* [note]: for toplevel ops, _cost_* is nil since the + Script.force_decode ctxt arg >>=? fun (arg, ctxt) -> (* see [note] *) + (* [note]: for toplevel ops, cost is nil since the lazy value has already been forced at precheck, so we compute and consume the full cost again *) let cost_arg = Script.deserialized_cost arg in @@ -396,7 +396,7 @@ let apply_manager_operation_content : let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in return (ctxt, unit) | Some parameters -> - Lwt.return (Script.force_decode parameters) >>=? fun (arg, _cost_arg (* see [note] *)) -> + Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *) let cost_arg = Script.deserialized_cost arg in Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> return (ctxt, arg) @@ -431,10 +431,10 @@ let apply_manager_operation_content : begin match script with | None -> return (None, ctxt) | Some script -> - Lwt.return (Script.force_decode script.storage) >>=? fun (ustorage, _cost (* see [note] *)) -> - Lwt.return (Gas.consume ctxt (Script.deserialized_cost ustorage)) >>=? fun ctxt -> - Lwt.return (Script.force_decode script.storage) >>=? fun (ucode, _cost (* see [note] *)) -> - Lwt.return (Gas.consume ctxt (Script.deserialized_cost ucode)) >>=? fun ctxt -> + Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt -> + Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt -> Script_ir_translator.parse_script ctxt script >>=? fun (_, ctxt) -> Script_ir_translator.erase_big_map_initialization ctxt Optimized script >>=? fun (script, big_map_diff, ctxt) -> return (Some (script, big_map_diff), ctxt) @@ -518,23 +518,21 @@ let precheck_manager_contents | Transaction { parameters = Some arg ; _ } -> (* Fail quickly if not enough gas for minimal deserialization cost *) Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ - Gas.consume ctxt (Script.minimal_deserialize_cost arg) >>=? fun _ -> + Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () -> (* Fail if not enough gas for complete deserialization cost *) - Lwt.return @@ Script.force_decode arg >>=? fun (_arg, cost_arg) -> - Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ - Gas.consume ctxt cost_arg + trace Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt | Origination { script = Some script ; _ } -> (* Fail quickly if not enough gas for minimal deserialization cost *) Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ (Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt -> - Gas.consume ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun _ -> + Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun () -> (* Fail if not enough gas for complete deserialization cost *) - Lwt.return @@ Script.force_decode script.code >>=? fun (_code, cost_code) -> - Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ - Gas.consume ctxt cost_code >>=? fun ctxt -> - Lwt.return @@ Script.force_decode script.storage >>=? fun (_storage, cost_storage) -> - Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ - Gas.consume ctxt cost_storage + trace Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt script.code >>=? fun (_code, ctxt) -> + trace Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt script.storage >>|? fun (_storage, ctxt) -> + ctxt | _ -> return ctxt end >>=? fun ctxt -> Contract.get_manager_key ctxt source >>=? fun public_key -> diff --git a/src/proto_alpha/lib_protocol/src/contract_services.ml b/src/proto_alpha/lib_protocol/src/contract_services.ml index d631452c2..d34241c3a 100644 --- a/src/proto_alpha/lib_protocol/src/contract_services.ml +++ b/src/proto_alpha/lib_protocol/src/contract_services.ml @@ -168,9 +168,8 @@ let register () = let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in parse_script ctxt script >>=? fun (Ex_script script, ctxt) -> - unparse_script ctxt Readable script >>=? fun (script, ctxt) -> - Lwt.return @@ Script.force_decode script.storage >>=? fun (storage, cost_storage) -> - Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun _ctxt -> + unparse_script ctxt Readable script >>=? fun script -> + Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) -> return_some storage) ; register_field S.info (fun ctxt contract -> Contract.get_balance ctxt contract >>=? fun balance -> @@ -186,7 +185,7 @@ let register () = let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in parse_script ctxt script >>=? fun (Ex_script script, ctxt) -> - unparse_script ctxt Readable script >>=? fun (script, ctxt) -> + unparse_script ctxt Readable script >>=? fun script -> return (Some script, ctxt) end >>=? fun (script, _ctxt) -> return { manager ; balance ; diff --git a/src/proto_alpha/lib_protocol/src/gas_limit_repr.ml b/src/proto_alpha/lib_protocol/src/gas_limit_repr.ml index 5da9e578a..d1f9114b8 100644 --- a/src/proto_alpha/lib_protocol/src/gas_limit_repr.ml +++ b/src/proto_alpha/lib_protocol/src/gas_limit_repr.ml @@ -99,6 +99,10 @@ let consume block_gas operation_gas cost = match operation_gas with then error Block_quota_exceeded else ok (block_remaining, Limited { remaining }) +let check_enough block_gas operation_gas cost = + consume block_gas operation_gas cost + >|? fun (_block_remainig, _remaining) -> () + let alloc_cost n = { allocations = Z.of_int (n + 1) ; steps = Z.zero ; diff --git a/src/proto_alpha/lib_protocol/src/gas_limit_repr.mli b/src/proto_alpha/lib_protocol/src/gas_limit_repr.mli index c07512f1d..64b3d65ee 100644 --- a/src/proto_alpha/lib_protocol/src/gas_limit_repr.mli +++ b/src/proto_alpha/lib_protocol/src/gas_limit_repr.mli @@ -23,6 +23,7 @@ type error += Block_quota_exceeded (* `Temporary *) type error += Operation_quota_exceeded (* `Temporary *) val consume : Z.t -> t -> cost -> (Z.t * t) tzresult +val check_enough : Z.t -> t -> cost -> unit tzresult val free : cost val step_cost : int -> cost diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml index 938b75c56..8af49c017 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml @@ -233,11 +233,14 @@ module Cost_of = struct let operation b = bytes b let type_ nb_args = alloc_cost (nb_args + 1) + (* Cost of parsing instruction, is cost of allocation of + constructor + cost of contructor parameters + cost of + allocation on the stack type *) let instr : type b a. (b, a) Script_typed_ir.instr -> cost = fun i -> let open Script_typed_ir in - alloc_cost 1 +@ + alloc_cost 1 +@ (* cost of allocation of constructor *) match i with | Drop -> alloc_cost 0 | Dup -> alloc_cost 1 diff --git a/src/proto_alpha/lib_protocol/src/raw_context.ml b/src/proto_alpha/lib_protocol/src/raw_context.ml index f2fe667a6..7028c723b 100644 --- a/src/proto_alpha/lib_protocol/src/raw_context.ml +++ b/src/proto_alpha/lib_protocol/src/raw_context.ml @@ -173,6 +173,8 @@ let set_gas_unlimited ctxt = let consume_gas ctxt cost = Gas_limit_repr.consume ctxt.block_gas ctxt.operation_gas cost >>? fun (block_gas, operation_gas) -> ok { ctxt with block_gas ; operation_gas } +let check_enough_gas ctxt cost = + Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas cost let gas_level ctxt = ctxt.operation_gas let block_gas_level ctxt = ctxt.block_gas let gas_consumed ~since ~until = @@ -523,6 +525,8 @@ module type T = sig val consume_gas: context -> Gas_limit_repr.cost -> context tzresult + val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult + val description: context Storage_description.t end diff --git a/src/proto_alpha/lib_protocol/src/raw_context.mli b/src/proto_alpha/lib_protocol/src/raw_context.mli index 105c93d99..cf43bd33d 100644 --- a/src/proto_alpha/lib_protocol/src/raw_context.mli +++ b/src/proto_alpha/lib_protocol/src/raw_context.mli @@ -192,6 +192,9 @@ module type T = sig within a view. *) val consume_gas: context -> Gas_limit_repr.cost -> context tzresult + (** Check if consume_gas will fail *) + val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult + val description: context Storage_description.t end diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index 6cbc6951f..904dfd6a4 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -694,12 +694,12 @@ let rec interp (credit, Item (init, rest)))))) -> Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> - unparse_ty ctxt param_type >>=? fun (u_param_type, ctxt) -> - unparse_ty ctxt storage_type >>=? fun (u_storage_type, ctxt) -> + unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> let code = Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ u_param_type ], []) ; - Prim (0, K_storage, [ u_storage_type ], []) ; + (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + Prim (0, K_storage, [ unparsed_storage_type ], []) ; Prim (0, K_code, [ Micheline.root code ], []) ])) in unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> let storage = Micheline.strip_locations storage in @@ -788,8 +788,7 @@ and execute ?log ctxt mode ~source ~payer ~self script amount arg : trace (Bad_contract_parameter self) (parse_data ctxt arg_type arg) >>=? fun (arg, ctxt) -> - Lwt.return @@ Script.force_decode script.code >>=? fun (script_code, cost_script_code) -> - Lwt.return @@ Gas.consume ctxt cost_script_code >>=? fun ctxt -> + Script.force_decode ctxt script.code >>=? fun (script_code, ctxt) -> trace (Runtime_contract_error (self, script_code)) (interp ?log ctxt ~source ~payer ~self amount code (arg, storage)) diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml index a6586e27f..ccf6c0c34 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -680,30 +680,14 @@ let comparable_ty_eq serialize_ty_for_error ctxt (ty_of_comparable_ty tb) >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb)) - -let record_trace mk_err result = - match result with - | Ok _ as res -> res - | Error errs -> - mk_err () >>? fun err -> - Error (err :: errs) - -let trace mk_err f = - f >>= function - | Error errs -> - mk_err () >>=? fun err -> - Lwt.return (Error (err :: errs)) - | ok -> Lwt.return ok - - let record_inconsistent ctxt ta tb = - record_trace (fun () -> + record_trace_eval (fun () -> serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) -> Inconsistent_types (ta, tb)) let record_inconsistent_type_annotations ctxt loc ta tb = - record_trace (fun () -> + record_trace_eval (fun () -> serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) -> Inconsistent_type_annotations (loc, ta, tb)) @@ -784,7 +768,7 @@ let rec stack_ty_eq match ta, tb with | Item_t (tva, ra, _), Item_t (tvb, rb, _) -> ty_eq ctxt tva tvb |> - record_trace (fun () -> ok (Bad_stack_item lvl)) >>? fun (Eq, ctxt) -> + record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) -> stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) -> (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult) | Empty_t, Empty_t -> Ok (Eq, ctxt) @@ -972,7 +956,7 @@ let merge_branches serialize_stack_for_error ctxt aftbt >>=? fun (aftbt, ctxt) -> serialize_stack_for_error ctxt aftbf >>|? fun (aftbf, _ctxt) -> Unmatched_branches (loc, aftbt, aftbf) in - trace unmatched_branches + trace_eval unmatched_branches (Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) >>=? fun (Eq, ctxt) -> Lwt.return (merge_stacks loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) -> return ( @@ -1023,10 +1007,8 @@ let rec parse_comparable_ty error (Invalid_arity (loc, prim, 0, List.length l)) | Prim (loc, (T_pair | T_or | T_set | T_map | T_list | T_option | T_lambda - | T_unit | T_signature | T_contract), _, _) as expr -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false expr >>? fun (Ex_ty ty, ctxt) -> - serialize_ty_for_error ctxt ty >>? fun (ty, _ctxt) -> - error (Comparable_type_expected (loc, ty)) + | T_unit | T_signature | T_contract), _, _) -> + error (Comparable_type_expected (loc, Micheline.strip_locations ty)) | expr -> error @@ unexpected expr [] Type_namespace [ T_int ; T_nat ; @@ -1055,7 +1037,7 @@ and parse_ty : parse_type_annot big_map_loc map_annot >>? fun map_name -> parse_composed_type_annot loc storage_annot >>? fun (ty_name, map_field, storage_field) -> - Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> + Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt -> let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in Ex_ty (Pair_t ((big_map_ty, map_field, None), (remaining_storage, storage_field, None), @@ -1241,7 +1223,7 @@ let rec parse_data Lwt.return (serialize_ty_for_error ctxt ty) >>|? fun (ty, _ctxt) -> Invalid_constant (location script_data, strip_locations script_data, ty) in let traced body = - trace error body in + trace_eval error body in let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper = let length = List.length items in fold_left_s @@ -1315,8 +1297,10 @@ let rec parse_data traced (fail (Invalid_kind (location expr, [ Bytes_kind ], kind expr))) (* Integers *) | Int_t _, Int (_, v) -> + (* TODO gas *) return (Script_int.of_zint v, ctxt) | Nat_t _, Int (_, v) -> + (* TODO gas *) let v = Script_int.of_zint v in if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then return (Script_int.abs v, ctxt) @@ -1340,6 +1324,7 @@ let rec parse_data traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) (* Timestamps *) | Timestamp_t _, (Int (_, v)) (* As unparsed with [Optimized] or out of bounds [Readable]. *) -> + (* TODO gas *) return (Script_timestamp.of_zint v, ctxt) | Timestamp_t _, String (_, s) (* As unparsed with [Redable]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt -> @@ -1488,6 +1473,7 @@ let rec parse_data traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ])) (* Lists *) | List_t (t, _ty_name), Seq (_loc, items) -> + (* TODO gas *) traced @@ fold_right_s (fun v (rest, ctxt) -> @@ -1499,6 +1485,7 @@ let rec parse_data traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Sets *) | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> + (* TODO gas *) let length = List.length vs in traced @@ fold_left_s @@ -1523,10 +1510,12 @@ let rec parse_data traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Maps *) | Map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> + (* TODO gas *) parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) | Map_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) | Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> + (* TODO gas *) parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) -> ({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) | Big_map_t (_tk, _tv, _), expr -> @@ -1549,7 +1538,7 @@ and parse_returning parse_instr ?type_logger tc_context ctxt script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), ctxt) -> - trace + trace_eval (fun () -> Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> @@ -1572,10 +1561,10 @@ and parse_instr Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = fun ?type_logger tc_context ctxt script_instr stack_ty -> let check_item check loc name n m = - trace (fun () -> + trace_eval (fun () -> serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty)) @@ - trace (fun () -> return (Bad_stack_item n)) @@ + trace (Bad_stack_item n) @@ Lwt.return check in let check_item_ty ctxt exp got loc n = check_item (ty_eq ctxt exp got) loc n in @@ -1765,7 +1754,7 @@ and parse_instr let invalid_map_body () = serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft) in - trace invalid_map_body + trace_eval invalid_map_body (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> typed ctxt loc (List_map ibody) @@ -1788,7 +1777,7 @@ and parse_instr serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) in - trace invalid_iter_body + trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest) @@ -1815,7 +1804,7 @@ and parse_instr serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) in - trace invalid_iter_body + trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest) @@ -1860,7 +1849,7 @@ and parse_instr let invalid_map_body () = serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft) in - trace invalid_map_body + trace_eval invalid_map_body (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> typed ctxt loc (Map_map ibody) @@ -1886,7 +1875,7 @@ and parse_instr serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) in - trace invalid_iter_body + trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest) @@ -2000,7 +1989,7 @@ and parse_instr serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack) in - trace unmatched_branches + trace_eval unmatched_branches (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest) @@ -2020,7 +2009,7 @@ and parse_instr serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack) in - trace unmatched_branches + trace_eval unmatched_branches (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot))) @@ -2492,13 +2481,11 @@ and parse_instr let cannonical_code = fst @@ Micheline.extract_locations code in Lwt.return @@ parse_toplevel cannonical_code >>=? fun (arg_type, storage_type, code_field) -> trace - (fun () -> Error_monad.return - (Ill_formed_type (Some "parameter", cannonical_code, location arg_type))) + (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type) >>=? fun (Ex_ty arg_type, ctxt) -> trace - (fun () -> Error_monad.return - (Ill_formed_type (Some "storage", cannonical_code, location storage_type))) + (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) @@ -2511,7 +2498,7 @@ and parse_instr Pair_t ((List_t (Operation_t None, None), None, None), (storage_type, None, None), None) in trace - (fun () -> Error_monad.return (Ill_typed_contract (cannonical_code, []))) + (Ill_typed_contract (cannonical_code, [])) (parse_returning (Toplevel { storage_type ; param_type = arg_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; @@ -2699,7 +2686,7 @@ and parse_contract | true -> Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> trace - (fun () -> return (Invalid_contract (loc, contract))) @@ + (Invalid_contract (loc, contract)) @@ Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with | None -> Lwt.return @@ -2707,10 +2694,9 @@ and parse_contract let contract : arg typed_contract = (arg, contract) in ok (ctxt, contract)) | Some { code ; _ } -> + Script.force_decode ctxt code >>=? fun (code, ctxt) -> Lwt.return - (Script.force_decode code >>? fun (code, cost_code) -> - Gas.consume ctxt cost_code >>? fun ctxt -> - parse_toplevel code >>? fun (arg_type, _, _) -> + (parse_toplevel code >>? fun (arg_type, _, _) -> parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ, ctxt) -> ty_eq ctxt targ arg >>? fun (Eq, ctxt) -> merge_types ctxt loc targ arg >>? fun (arg, ctxt) -> @@ -2720,7 +2706,7 @@ and parse_contract and parse_toplevel : Script.expr -> (Script.node * Script.node * Script.node) tzresult = fun toplevel -> - record_trace (fun () -> ok (Ill_typed_contract (toplevel, []))) @@ + record_trace (Ill_typed_contract (toplevel, [])) @@ match root toplevel with | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind)) @@ -2765,17 +2751,15 @@ let parse_script : ?type_logger: type_logger -> context -> Script.t -> (ex_script * context) tzresult Lwt.t = fun ?type_logger ctxt { code ; storage } -> - Lwt.return @@ Script.force_decode code >>=? fun (code, cost_code) -> - Lwt.return @@ Gas.consume ctxt cost_code >>=? fun ctxt -> - Lwt.return @@ Script.force_decode storage >>=? fun (storage, cost_storage) -> - Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun ctxt -> + Script.force_decode ctxt code >>=? fun (code, ctxt) -> + Script.force_decode ctxt storage >>=? fun (storage, ctxt) -> Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) -> trace - (fun () -> return (Ill_formed_type (Some "parameter", code, location arg_type))) + (Ill_formed_type (Some "parameter", code, location arg_type)) (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) >>=? fun (Ex_ty arg_type, ctxt) -> trace - (fun () -> return (Ill_formed_type (Some "storage", code, location storage_type))) + (Ill_formed_type (Some "storage", code, location storage_type)) (Lwt.return (parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type)) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) @@ -2787,13 +2771,13 @@ let parse_script let ret_type_full = Pair_t ((List_t (Operation_t None, None), None, None), (storage_type, None, None), None) in - trace + trace_eval (fun () -> Lwt.return @@ serialize_ty_for_error ctxt storage_type >>|? fun (storage_type, _ctxt) -> Ill_typed_data (None, storage, storage_type)) (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> trace - (fun () -> return (Ill_typed_contract (code, []))) + (Ill_typed_contract (code, [])) (parse_returning (Toplevel { storage_type ; param_type = arg_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt) @@ -2805,11 +2789,11 @@ let typecheck_code let type_map = ref [] in (* TODO: annotation checking *) trace - (fun () -> return (Ill_formed_type (Some "parameter", code, location arg_type))) + (Ill_formed_type (Some "parameter", code, location arg_type)) (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) >>=? fun (Ex_ty arg_type, ctxt) -> trace - (fun () -> return (Ill_formed_type (Some "storage", code, location storage_type))) + (Ill_formed_type (Some "storage", code, location storage_type)) (Lwt.return (parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type)) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) @@ -2828,7 +2812,7 @@ let typecheck_code ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) (arg_type_full, None) ret_type_full code_field in trace - (fun () -> return (Ill_typed_contract (code, !type_map))) + (Ill_typed_contract (code, !type_map)) result >>=? fun (Lam _, ctxt) -> return (!type_map, ctxt) @@ -2837,10 +2821,10 @@ let typecheck_data context -> Script.expr * Script.expr -> context tzresult Lwt.t = fun ?type_logger ctxt (data, exp_ty) -> trace - (fun () -> return (Ill_formed_type (None, exp_ty, 0))) + (Ill_formed_type (None, exp_ty, 0)) (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false (root exp_ty)) >>=? fun (Ex_ty exp_ty, ctxt) -> - trace + trace_eval (fun () -> Lwt.return @@ serialize_ty_for_error ctxt exp_ty >>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty)) @@ -2995,6 +2979,7 @@ let rec unparse_data | Lambda_t _, Lam (_, original_code) -> unparse_code ctxt mode (root original_code) +(* only used in client, don't account for gas *) and unparse_code ctxt mode = function | Prim (loc, I_PUSH, [ ty ; data ], annot) -> Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) -> @@ -3017,31 +3002,34 @@ and unparse_code ctxt mode = function return (Prim (loc, prim, List.rev items, annot), ctxt) | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) +(* only used in client, don't account for gas *) let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = let Lam (_, original_code) = code in unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) -> unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) -> unparse_ty ctxt arg_type >>=? fun (arg_type, ctxt) -> - unparse_ty ctxt storage_type >>=? fun (storage_type, ctxt) -> + unparse_ty ctxt storage_type >>=? fun (storage_type, _ctxt) -> let open Micheline in let code = Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ; Prim (-1, K_storage, [ storage_type ], []) ; Prim (-1, K_code, [ code ], []) ]) in return ({ code = lazy_expr (strip_locations code) ; - storage = lazy_expr (strip_locations storage) }, ctxt) + storage = lazy_expr (strip_locations storage) }) let pack_data ctxt typ data = unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) -> let unparsed = strip_annotations @@ data in let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in + Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> let bytes = MBytes.concat "" [ MBytes.of_string "\005" ; bytes ] in Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> return (bytes, ctxt) let hash_data ctxt typ data = pack_data ctxt typ data >>=? fun (bytes, ctxt) -> - Lwt.return @@ Gas.consume ctxt (Michelson_v1_gas.Cost_of.hash bytes 32) >>=? fun ctxt -> + Lwt.return @@ Gas.consume ctxt + (Michelson_v1_gas.Cost_of.hash bytes Script_expr_hash.size) >>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt) (* ---------------- Big map -------------------------------------------------*) @@ -3097,10 +3085,8 @@ let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x -> | _, _ -> None let erase_big_map_initialization ctxt mode ({ code ; storage } : Script.t) = - Lwt.return @@ Script.force_decode code >>=? fun (code, cost_code) -> - Lwt.return @@ Gas.consume ctxt cost_code >>=? fun ctxt -> - Lwt.return @@ Script.force_decode storage >>=? fun (storage, cost_storage) -> - Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun ctxt -> + Script.force_decode ctxt code >>=? fun (code, ctxt) -> + Script.force_decode ctxt storage >>=? fun (storage, ctxt) -> Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) -> Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type >>=? fun (Ex_ty ty, ctxt) -> parse_data ctxt ty diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli index e221a3774..d3e50a53b 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -91,9 +91,11 @@ val typecheck_data : val parse_script : ?type_logger: type_logger -> context -> Script.t -> (ex_script * context) tzresult Lwt.t + +(* only used in client, don't account for gas *) val unparse_script : context -> unparsing_mode -> - ('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t + ('a, 'b) Script_typed_ir.script -> Script.t tzresult Lwt.t val parse_contract : context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> diff --git a/src/proto_alpha/lib_protocol/src/script_repr.ml b/src/proto_alpha/lib_protocol/src/script_repr.ml index 2ea02302c..c3ad507a1 100644 --- a/src/proto_alpha/lib_protocol/src/script_repr.ml +++ b/src/proto_alpha/lib_protocol/src/script_repr.ml @@ -135,16 +135,16 @@ let deserialized_cost expr = let serialized_cost bytes = let open Gas_limit_repr in - alloc_bytes_cost (MBytes.length bytes) + alloc_cost 12 +@ alloc_bytes_cost (MBytes.length bytes) let force_decode lexpr = match Data_encoding.force_decode lexpr with | Some v -> let deserialize_cost = - Data_encoding.fold_lazy - (fun _ -> Gas_limit_repr.free) - (fun _ -> deserialized_cost v) - (fun c_free _ -> c_free) + Data_encoding.apply_lazy + ~fun_value:(fun _ -> Gas_limit_repr.free) + ~fun_bytes:(fun _ -> deserialized_cost v) + ~fun_combine:(fun c_free _ -> c_free) lexpr in ok (v, deserialize_cost) | None -> error Lazy_script_decode @@ -154,18 +154,17 @@ let force_bytes expr = match Data_encoding.force_bytes expr with | bytes -> let serialize_cost = - Data_encoding.fold_lazy - (fun v -> traversal_cost v +@ serialized_cost bytes) - (fun _ -> Gas_limit_repr.free) - (fun _ c_free -> c_free) + Data_encoding.apply_lazy + ~fun_value:(fun v -> traversal_cost v +@ serialized_cost bytes) + ~fun_bytes:(fun _ -> Gas_limit_repr.free) + ~fun_combine:(fun _ c_free -> c_free) expr in ok (bytes, serialize_cost) | exception _ -> error Lazy_script_decode let minimal_deserialize_cost lexpr = - let open Gas_limit_repr in - Data_encoding.fold_lazy - (fun _ -> Gas_limit_repr.free) - (fun b -> alloc_bytes_cost (MBytes.length b)) - (fun c_free _ -> c_free) + Data_encoding.apply_lazy + ~fun_value:(fun _ -> Gas_limit_repr.free) + ~fun_bytes:(fun b -> serialized_cost b) + ~fun_combine:(fun c_free _ -> c_free) lexpr diff --git a/src/proto_alpha/lib_protocol/src/storage.ml b/src/proto_alpha/lib_protocol/src/storage.ml index e34bbdeba..4697cc190 100644 --- a/src/proto_alpha/lib_protocol/src/storage.ml +++ b/src/proto_alpha/lib_protocol/src/storage.ml @@ -144,16 +144,24 @@ module Contract = struct (Z) module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct - include Indexed_context.Make_carbonated_map + module I = Indexed_context.Make_carbonated_map (N) (struct type t = Script_repr.lazy_expr let encoding = Script_repr.lazy_expr_encoding end) + type context = I.context + type key = I.key + type value = I.value + + let mem = I.mem + let delete = I.delete + let remove = I.remove + let consume_deserialize_gas ctxt value = Lwt.return @@ - (Raw_context.consume_gas ctxt (Script_repr.minimal_deserialize_cost value) >>? fun _ -> + (Raw_context.check_enough_gas ctxt (Script_repr.minimal_deserialize_cost value) >>? fun () -> Script_repr.force_decode value >>? fun (_value, value_cost) -> Raw_context.consume_gas ctxt value_cost) @@ -163,12 +171,12 @@ module Contract = struct Raw_context.consume_gas ctxt value_cost) let get ctxt contract = - get ctxt contract >>=? fun (ctxt, value) -> + I.get ctxt contract >>=? fun (ctxt, value) -> consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value) let get_option ctxt contract = - get_option ctxt contract >>=? fun (ctxt, value_opt) -> + I.get_option ctxt contract >>=? fun (ctxt, value_opt) -> match value_opt with | None -> return (ctxt, None) | Some value -> @@ -177,22 +185,22 @@ module Contract = struct let set ctxt contract value = consume_serialize_gas ctxt value >>=? fun ctxt -> - set ctxt contract value + I.set ctxt contract value let set_option ctxt contract value_opt = match value_opt with - | None -> set_option ctxt contract None + | None -> I.set_option ctxt contract None | Some value -> consume_serialize_gas ctxt value >>=? fun ctxt -> - set_option ctxt contract value_opt + I.set_option ctxt contract value_opt let init ctxt contract value = consume_serialize_gas ctxt value >>=? fun ctxt -> - init ctxt contract value + I.init ctxt contract value let init_set ctxt contract value = consume_serialize_gas ctxt value >>=? fun ctxt -> - init_set ctxt contract value + I.init_set ctxt contract value end module Code = diff --git a/src/proto_alpha/lib_protocol/src/storage_functors.ml b/src/proto_alpha/lib_protocol/src/storage_functors.ml index 3b5302bd3..c579e9775 100644 --- a/src/proto_alpha/lib_protocol/src/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/src/storage_functors.ml @@ -66,6 +66,7 @@ module Make_subcontext (C : Raw_context.T) (N : NAME) let project = C.project let absolute_key c k = C.absolute_key c (to_key k) let consume_gas = C.consume_gas + let check_enough_gas = C.check_enough_gas let description = Storage_description.register_named_subcontext C.description N.name end @@ -555,6 +556,9 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) let consume_gas c g = let (t, i) = unpack c in C.consume_gas t g >>? fun t -> ok (pack t i) + let check_enough_gas c g = + let (t, _i) = unpack c in + C.check_enough_gas t g let description = description end