From f5091bf5e6fbca3f315e083d85c5a409228cb4e4 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Sat, 30 Jun 2018 03:13:12 +0200 Subject: [PATCH] Michelson: fix gas cost for CONTRACT --- .../lib_protocol/src/alpha_context.mli | 2 + .../lib_protocol/src/script_interpreter.ml | 8 +-- .../lib_protocol/src/script_ir_translator.ml | 49 +++++++++++++++++++ .../lib_protocol/src/script_ir_translator.mli | 4 ++ .../lib_protocol/src/script_repr.ml | 33 +++++++------ .../lib_protocol/src/script_repr.mli | 2 + 6 files changed, 77 insertions(+), 21 deletions(-) diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index 22e0779fe..b0b49c5d6 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -303,6 +303,8 @@ module Script : sig val lazy_expr_encoding: lazy_expr Data_encoding.t val deserialized_cost : expr -> Gas.cost val serialized_cost : MBytes.t -> Gas.cost + val traversal_cost : node -> Gas.cost + val node_cost : node -> Gas.cost val int_node_cost : Z.t -> Gas.cost val int_node_cost_of_numbits : int -> Gas.cost val string_node_cost : string -> Gas.cost diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index 12e0da61a..4dfbcfe35 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -660,12 +660,8 @@ let rec interp logged_return (Item (contract, rest), ctxt) | Contract t, Item (contract, rest) -> Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> - Contract.exists ctxt contract >>=? fun exists -> - if exists then - Script_ir_translator.parse_contract ctxt loc t contract >>=? fun (ctxt, contract) -> - logged_return (Item (Some contract, rest), ctxt) - else - logged_return (Item (None, rest), ctxt) + Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> + logged_return (Item (maybe_contract, rest), ctxt) | Transfer_tokens, Item (p, Item (amount, Item ((tp, destination), rest))) -> Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> 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 cea4d5560..fa2b0d97c 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -2702,6 +2702,55 @@ and parse_contract let contract : arg typed_contract = (arg, contract) in ok (ctxt, contract)) +(* Same as the one above, but does not fail when the contact is missing or + if the expected type doesn't match the actual one. In that case None is + returned and some overapproximation of the typechecking gas is consumed. + This can still fail on gas exhaustion. *) +and parse_contract_for_script + : type arg. context -> Script.location -> arg ty -> Contract.t -> + (context * arg typed_contract option) tzresult Lwt.t + = fun ctxt loc arg contract -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> + Contract.exists ctxt contract >>=? function + | false -> return (ctxt, None) + | true -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> + trace + (Invalid_contract (loc, contract)) @@ + Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with (* can only fail because of gas *) + | None -> + Lwt.return + (match ty_eq ctxt arg (Unit_t None) with + | Ok (Eq, ctxt) -> + let contract : arg typed_contract = (arg, contract) in + ok (ctxt, Some contract) + | Error _ -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + ok (ctxt, None)) + | Some { code ; _ } -> + Script.force_decode ctxt code >>=? fun (code, ctxt) -> (* can only fail because of gas *) + Lwt.return + (match parse_toplevel code with + | Error _ -> error (Invalid_contract (loc, contract)) + | Ok (arg_type, _, _) -> + match parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type with + | Error _ -> + error (Invalid_contract (loc, contract)) + | Ok (Ex_ty targ, ctxt) -> + match + (ty_eq ctxt targ arg >>? fun (Eq, ctxt) -> + merge_types ctxt loc targ arg >>? fun (arg, ctxt) -> + let contract : arg typed_contract = (arg, contract) in + ok (ctxt, Some contract)) + with + | Ok res -> ok res + | Error _ -> + (* overapproximation by checking if targ = targ, + can only fail because of gas *) + ty_eq ctxt targ targ >>? fun (Eq, ctxt) -> + merge_types ctxt loc targ targ >>? fun (_, ctxt) -> + ok (ctxt, None)) + and parse_toplevel : Script.expr -> (Script.node * Script.node * Script.node) tzresult = fun toplevel -> 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 e1e8b1a1c..d5b218518 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -101,6 +101,10 @@ val parse_contract : context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t +val parse_contract_for_script : + context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t + val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/script_repr.ml b/src/proto_alpha/lib_protocol/src/script_repr.ml index 899d9cf80..1bf5030b4 100644 --- a/src/proto_alpha/lib_protocol/src/script_repr.ml +++ b/src/proto_alpha/lib_protocol/src/script_repr.ml @@ -109,29 +109,32 @@ let rec node_size node = let expr_size expr = node_size (Micheline.root expr) -let traversal_cost expr = - let blocks, _words = expr_size expr in +let traversal_cost node = + let blocks, _words = node_size node in Gas_limit_repr.step_cost blocks -let node_cost (blocks, words) = +let cost_of_size (blocks, words) = let open Gas_limit_repr in ((Compare.Int.max 0 (blocks - 1)) *@ alloc_cost 0) +@ alloc_cost words +@ step_cost blocks -let int_node_cost n = node_cost (int_node_size n) -let int_node_cost_of_numbits n = node_cost (int_node_size_of_numbits n) -let string_node_cost s = node_cost (string_node_size s) -let string_node_cost_of_length s = node_cost (string_node_size_of_length s) -let bytes_node_cost s = node_cost (bytes_node_size s) -let bytes_node_cost_of_length s = node_cost (bytes_node_size_of_length s) -let prim_node_cost_nonrec args annot = node_cost (prim_node_size_nonrec args annot) -let prim_node_cost_nonrec_of_length n_args annot = node_cost (prim_node_size_nonrec_of_lengths n_args annot) -let seq_node_cost_nonrec args = node_cost (seq_node_size_nonrec args) -let seq_node_cost_nonrec_of_length n_args = node_cost (seq_node_size_nonrec_of_length n_args) +let node_cost node = + cost_of_size (node_size node) + +let int_node_cost n = cost_of_size (int_node_size n) +let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n) +let string_node_cost s = cost_of_size (string_node_size s) +let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s) +let bytes_node_cost s = cost_of_size (bytes_node_size s) +let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s) +let prim_node_cost_nonrec args annot = cost_of_size (prim_node_size_nonrec args annot) +let prim_node_cost_nonrec_of_length n_args annot = cost_of_size (prim_node_size_nonrec_of_lengths n_args annot) +let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args) +let seq_node_cost_nonrec_of_length n_args = cost_of_size (seq_node_size_nonrec_of_length n_args) let deserialized_cost expr = - node_cost (expr_size expr) + cost_of_size (expr_size expr) let serialized_cost bytes = let open Gas_limit_repr in @@ -163,7 +166,7 @@ let force_bytes expr = match Data_encoding.force_bytes expr with | bytes -> begin match account_serialization_cost with - | Some v -> ok (bytes, traversal_cost v +@ serialized_cost bytes) + | Some v -> ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes) | None -> ok (bytes, Gas_limit_repr.free) end | exception _ -> error Lazy_script_decode diff --git a/src/proto_alpha/lib_protocol/src/script_repr.mli b/src/proto_alpha/lib_protocol/src/script_repr.mli index fc2badf50..b8f9d748d 100644 --- a/src/proto_alpha/lib_protocol/src/script_repr.mli +++ b/src/proto_alpha/lib_protocol/src/script_repr.mli @@ -34,6 +34,8 @@ val encoding : t Data_encoding.encoding val deserialized_cost : expr -> Gas_limit_repr.cost val serialized_cost : MBytes.t -> Gas_limit_repr.cost +val traversal_cost : node -> Gas_limit_repr.cost +val node_cost : node -> Gas_limit_repr.cost val int_node_cost : Z.t -> Gas_limit_repr.cost val int_node_cost_of_numbits : int -> Gas_limit_repr.cost