From 45b7917873e381070438c768fbfdf5810970643b Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Tue, 24 May 2022 10:55:08 +0200 Subject: [PATCH 01/11] Proto/Michelson: parse_view_name is not mutually recursive with the rest --- .../lib_protocol/script_ir_translator.ml | 44 +++++++++---------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b9e595f05087..639d1bb4ea9b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2183,6 +2183,28 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any +let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = + function + | String (loc, v) as expr -> + (* The limitation of length of string is same as entrypoint *) + if Compare.Int.(String.length v > 31) then error (View_name_too_long v) + else + let rec check_char i = + if Compare.Int.(i < 0) then ok v + else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1) + else error (Bad_view_name loc) + in + Gas.consume ctxt (Typecheck_costs.check_printable v) >>? fun ctxt -> + record_trace + (Invalid_syntactic_constant + ( loc, + strip_locations expr, + "string [a-zA-Z0-9_.%@] and the maximum string length of 31 \ + characters" )) + ( check_char (String.length v - 1) >>? fun v -> + Script_string.of_string v >|? fun s -> (s, ctxt) ) + | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) + (* -- parse data of any type -- *) (* @@ -4866,28 +4888,6 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra Implement typechecking of sc rollup deposits. *) fail (No_such_entrypoint entrypoint) -and parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = - function - | String (loc, v) as expr -> - (* The limitation of length of string is same as entrypoint *) - if Compare.Int.(String.length v > 31) then error (View_name_too_long v) - else - let rec check_char i = - if Compare.Int.(i < 0) then ok v - else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1) - else error (Bad_view_name loc) - in - Gas.consume ctxt (Typecheck_costs.check_printable v) >>? fun ctxt -> - record_trace - (Invalid_syntactic_constant - ( loc, - strip_locations expr, - "string [a-zA-Z0-9_.%@] and the maximum string length of 31 \ - characters" )) - ( check_char (String.length v - 1) >>? fun v -> - Script_string.of_string v >|? fun s -> (s, ctxt) ) - | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) - and parse_toplevel : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = fun ctxt ~legacy toplevel -> -- GitLab From 35648f4d9c10e14640f0bb7b273fa3b2ba2d3d84 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Tue, 24 May 2022 10:56:57 +0200 Subject: [PATCH 02/11] Proto/Michelson: parse_toplevel is not mutually recursive with the rest --- .../lib_protocol/script_ir_translator.ml | 184 +++++++++--------- 1 file changed, 92 insertions(+), 92 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 639d1bb4ea9b..8fb18c3e8387 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2205,6 +2205,98 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = Script_string.of_string v >|? fun s -> (s, ctxt) ) | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) +let parse_toplevel : + context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = + fun ctxt ~legacy 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)) + | Bytes (loc, _) -> error (Invalid_kind (loc, [Seq_kind], Bytes_kind)) + | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [Seq_kind], Prim_kind)) + | Seq (_, fields) -> ( + let rec find_fields ctxt p s c views fields = + match fields with + | [] -> ok (ctxt, (p, s, c, views)) + | Int (loc, _) :: _ -> error (Invalid_kind (loc, [Prim_kind], Int_kind)) + | String (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], String_kind)) + | Bytes (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], Bytes_kind)) + | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [Prim_kind], Seq_kind)) + | Prim (loc, K_parameter, [arg], annot) :: rest -> ( + match p with + | None -> find_fields ctxt (Some (arg, loc, annot)) s c views rest + | Some _ -> error (Duplicate_field (loc, K_parameter))) + | Prim (loc, K_storage, [arg], annot) :: rest -> ( + match s with + | None -> find_fields ctxt p (Some (arg, loc, annot)) c views rest + | Some _ -> error (Duplicate_field (loc, K_storage))) + | Prim (loc, K_code, [arg], annot) :: rest -> ( + match c with + | None -> find_fields ctxt p s (Some (arg, loc, annot)) views rest + | Some _ -> error (Duplicate_field (loc, K_code))) + | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _) :: _ + -> + error (Invalid_arity (loc, name, 1, List.length args)) + | Prim (loc, K_view, [name; input_ty; output_ty; view_code], _) :: rest + -> + parse_view_name ctxt name >>? fun (str, ctxt) -> + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.view_update str views) + >>? fun ctxt -> + if Script_map.mem str views then error (Duplicated_view_name loc) + else + let views' = + Script_map.update + str + (Some {input_ty; output_ty; view_code}) + views + in + find_fields ctxt p s c views' rest + | Prim (loc, K_view, args, _) :: _ -> + error (Invalid_arity (loc, K_view, 4, List.length args)) + | Prim (loc, name, _, _) :: _ -> + let allowed = [K_parameter; K_storage; K_code; K_view] in + error (Invalid_primitive (loc, allowed, name)) + in + find_fields ctxt None None None (Script_map.empty string_t) fields + >>? fun (ctxt, toplevel) -> + match toplevel with + | None, _, _, _ -> error (Missing_field K_parameter) + | Some _, None, _, _ -> error (Missing_field K_storage) + | Some _, Some _, None, _ -> error (Missing_field K_code) + | ( Some (p, ploc, pannot), + Some (s, sloc, sannot), + Some (c, cloc, cannot), + views ) -> + let p_pannot = + (* root name can be attached to either the parameter + primitive or the toplevel constructor (legacy only). + + In the latter case we move it to the parameter type. + *) + Script_ir_annot.has_field_annot p >>? function + | true -> ok (p, pannot) + | false -> ( + match pannot with + | [single] when legacy -> ( + is_field_annot ploc single >|? fun is_field_annot -> + match (is_field_annot, p) with + | true, Prim (loc, prim, args, annots) -> + (Prim (loc, prim, args, single :: annots), []) + | _ -> (p, [])) + | _ -> ok (p, pannot)) + in + (* only one field annot is allowed to set the root entrypoint name *) + p_pannot >>? fun (arg_type, pannot) -> + Script_ir_annot.error_unexpected_annot ploc pannot >>? fun () -> + Script_ir_annot.error_unexpected_annot cloc cannot >>? fun () -> + Script_ir_annot.error_unexpected_annot sloc sannot >|? fun () -> + ({code_field = c; arg_type; views; storage_type = s}, ctxt)) + (* -- parse data of any type -- *) (* @@ -4888,98 +4980,6 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra Implement typechecking of sc rollup deposits. *) fail (No_such_entrypoint entrypoint) -and parse_toplevel : - context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = - fun ctxt ~legacy 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)) - | Bytes (loc, _) -> error (Invalid_kind (loc, [Seq_kind], Bytes_kind)) - | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [Seq_kind], Prim_kind)) - | Seq (_, fields) -> ( - let rec find_fields ctxt p s c views fields = - match fields with - | [] -> ok (ctxt, (p, s, c, views)) - | Int (loc, _) :: _ -> error (Invalid_kind (loc, [Prim_kind], Int_kind)) - | String (loc, _) :: _ -> - error (Invalid_kind (loc, [Prim_kind], String_kind)) - | Bytes (loc, _) :: _ -> - error (Invalid_kind (loc, [Prim_kind], Bytes_kind)) - | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [Prim_kind], Seq_kind)) - | Prim (loc, K_parameter, [arg], annot) :: rest -> ( - match p with - | None -> find_fields ctxt (Some (arg, loc, annot)) s c views rest - | Some _ -> error (Duplicate_field (loc, K_parameter))) - | Prim (loc, K_storage, [arg], annot) :: rest -> ( - match s with - | None -> find_fields ctxt p (Some (arg, loc, annot)) c views rest - | Some _ -> error (Duplicate_field (loc, K_storage))) - | Prim (loc, K_code, [arg], annot) :: rest -> ( - match c with - | None -> find_fields ctxt p s (Some (arg, loc, annot)) views rest - | Some _ -> error (Duplicate_field (loc, K_code))) - | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _) :: _ - -> - error (Invalid_arity (loc, name, 1, List.length args)) - | Prim (loc, K_view, [name; input_ty; output_ty; view_code], _) :: rest - -> - parse_view_name ctxt name >>? fun (str, ctxt) -> - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.view_update str views) - >>? fun ctxt -> - if Script_map.mem str views then error (Duplicated_view_name loc) - else - let views' = - Script_map.update - str - (Some {input_ty; output_ty; view_code}) - views - in - find_fields ctxt p s c views' rest - | Prim (loc, K_view, args, _) :: _ -> - error (Invalid_arity (loc, K_view, 4, List.length args)) - | Prim (loc, name, _, _) :: _ -> - let allowed = [K_parameter; K_storage; K_code; K_view] in - error (Invalid_primitive (loc, allowed, name)) - in - find_fields ctxt None None None (Script_map.empty string_t) fields - >>? fun (ctxt, toplevel) -> - match toplevel with - | None, _, _, _ -> error (Missing_field K_parameter) - | Some _, None, _, _ -> error (Missing_field K_storage) - | Some _, Some _, None, _ -> error (Missing_field K_code) - | ( Some (p, ploc, pannot), - Some (s, sloc, sannot), - Some (c, cloc, cannot), - views ) -> - let p_pannot = - (* root name can be attached to either the parameter - primitive or the toplevel constructor (legacy only). - - In the latter case we move it to the parameter type. - *) - Script_ir_annot.has_field_annot p >>? function - | true -> ok (p, pannot) - | false -> ( - match pannot with - | [single] when legacy -> ( - is_field_annot ploc single >|? fun is_field_annot -> - match (is_field_annot, p) with - | true, Prim (loc, prim, args, annots) -> - (Prim (loc, prim, args, single :: annots), []) - | _ -> (p, [])) - | _ -> ok (p, pannot)) - in - (* only one field annot is allowed to set the root entrypoint name *) - p_pannot >>? fun (arg_type, pannot) -> - Script_ir_annot.error_unexpected_annot ploc pannot >>? fun () -> - Script_ir_annot.error_unexpected_annot cloc cannot >>? fun () -> - Script_ir_annot.error_unexpected_annot sloc sannot >|? fun () -> - ({code_field = c; arg_type; views; storage_type = s}, ctxt)) - (* Same as [parse_contract], 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. -- GitLab From 5d7e8db53f400fb800f2e736e25a9ba3ab35163b Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 16:26:44 +0200 Subject: [PATCH 03/11] Proto/Michelson: rename and duplicate parse_contract --- .../lib_protocol/script_ir_translator.ml | 24 ++++++++++++++++--- .../lib_protocol/script_ir_translator.mli | 4 ++-- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 8fb18c3e8387..e84b5ded286d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2484,7 +2484,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : traced ( parse_address ctxt expr >>?= fun (address, ctxt) -> let loc = location expr in - parse_contract + parse_contract_data ~stack_depth:(stack_depth + 1) ctxt loc @@ -4901,6 +4901,24 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : I_XOR; ] +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_data : + type arg argc. + stack_depth:int -> + context -> + Script.location -> + (arg, argc) ty -> + Destination.t -> + entrypoint:Entrypoint.t -> + (context * arg typed_contract) tzresult Lwt.t = + fun ~stack_depth ctxt loc arg destination ~entrypoint -> + (parse_contract [@ocaml.tailcall]) + ~stack_depth + ctxt + loc + arg + destination + ~entrypoint + and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract : type arg argc. stack_depth:int -> @@ -6077,8 +6095,8 @@ let unparse_code ctxt mode code = Global_constants_storage.expand ctxt (strip_locations code) >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code) -let parse_contract context loc arg_ty contract ~entrypoint = - parse_contract ~stack_depth:0 context loc arg_ty contract ~entrypoint +let parse_contract_data context loc arg_ty contract ~entrypoint = + parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint let parse_toplevel ctxt ~legacy toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index de9c6207a73e..e7a85579e8e5 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -56,7 +56,7 @@ consume gas, and thus are parameterized by an [Alpha_context.t]. The variety of functions reflects the variety of things one might want to parse, - from [parse_data] for arbitrary Micheline expressions to [parse_contract] for + from [parse_data] for arbitrary Micheline expressions to [parse_contract_data] for well-formed Michelson contracts. *) @@ -366,7 +366,7 @@ val parse_and_unparse_script_unaccounted : Script.t -> (Script.t * context) tzresult Lwt.t -val parse_contract : +val parse_contract_data : context -> Script.location -> ('a, _) Script_typed_ir.ty -> -- GitLab From d71892426092588d065aedf4e61145234842b1fc Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 16:48:17 +0200 Subject: [PATCH 04/11] Proto/Michelson: consume more gas for CONTRACT --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index e84b5ded286d..8bd969e54b19 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5011,6 +5011,7 @@ let parse_contract_for_script : entrypoint:Entrypoint.t -> (context * arg typed_contract option) tzresult Lwt.t = fun ctxt loc arg contract ~entrypoint -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> match contract with | Contract contract -> ( match contract with @@ -5028,11 +5029,10 @@ let parse_contract_for_script : (ctxt, Some contract) | Error Inconsistent_types_fast -> (ctxt, None) ) else - Lwt.return - ( Gas.consume ctxt Typecheck_costs.parse_instr_cycle - >|? fun ctxt -> - (* An implicit account on any other entrypoint is not a valid contract. *) - (ctxt, None) ) + return + ( (* An implicit account on any other entrypoint is not a valid contract. *) + ctxt, + None ) | Originated _ -> ( (* Originated account *) trace (Invalid_contract (loc, contract)) -- GitLab From dff30a980c9f9404734fcac76c7a76fd23207279 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 18:42:02 +0200 Subject: [PATCH 05/11] Tests/Python: update gas in regression traces --- ...1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-Unit].out" | 14 +++++++------- ...ddApproveTransferRemove::test_add_liquidity.out | 6 +++--- ...pproveTransferRemove::test_remove_liquidity.out | 12 ++++++------ ...idity_baking.TestTrades::test_add_liquidity.out | 6 +++--- ...t_liquidity_baking.TestTrades::test_buy_tok.out | 6 +++--- ..._liquidity_baking.TestTrades::test_sell_tok.out | 6 +++--- 6 files changed, 25 insertions(+), 25 deletions(-) diff --git "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[contract.tz-Unit-\"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-Unit].out" "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[contract.tz-Unit-\"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-Unit].out" index 70996020219a..882ff1a91ac6 100644 --- "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[contract.tz-Unit-\"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-Unit].out" +++ "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[contract.tz-Unit-\"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-Unit].out" @@ -11,19 +11,19 @@ trace [ (Pair "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" Unit) ] - location: 7 (remaining gas: 1039987.820 units remaining) [ "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" ] - - location: 8 (remaining gas: 1039987.730 units remaining) + - location: 8 (remaining gas: 1039987.510 units remaining) [ (Some "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5") ] - - location: 11 (remaining gas: 1039987.720 units remaining) + - location: 11 (remaining gas: 1039987.500 units remaining) [ "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" ] - - location: 11 (remaining gas: 1039987.710 units remaining) + - location: 11 (remaining gas: 1039987.490 units remaining) [ "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" ] - - location: 17 (remaining gas: 1039987.700 units remaining) + - location: 17 (remaining gas: 1039987.480 units remaining) [ ] - - location: 18 (remaining gas: 1039987.690 units remaining) + - location: 18 (remaining gas: 1039987.470 units remaining) [ Unit ] - - location: 19 (remaining gas: 1039987.680 units remaining) + - location: 19 (remaining gas: 1039987.460 units remaining) [ {} Unit ] - - location: 21 (remaining gas: 1039987.670 units remaining) + - location: 21 (remaining gas: 1039987.450 units remaining) [ (Pair {} Unit) ] diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out index 77ac452b4367..f29a346d8f8e 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestAddApproveTransferRemove::test_add_liquidity Node is bootstrapped. -Estimated gas: 8521.881 units (will add 100 for safety) +Estimated gas: 8522.321 units (will add 100 for safety) Estimated storage: 141 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -14,7 +14,7 @@ This sequence of operations was run: From: [CONTRACT_HASH] Fee to the baker: ꜩ0.001218 Expected counter: [EXPECTED_COUNTER] - Gas limit: 8622 + Gas limit: 8623 Storage limit: 161 bytes Balance updates: [CONTRACT_HASH] ... -ꜩ0.001218 @@ -34,7 +34,7 @@ This sequence of operations was run: 0x0115eb0104481a6d7921160bc982c5e0a561cd8a3a00 } Storage size: 4633 bytes Paid storage size diff: 3 bytes - Consumed gas: 3782.899 + Consumed gas: 3783.339 Balance updates: [CONTRACT_HASH] ... -ꜩ0.00075 storage fees ........................... +ꜩ0.00075 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out index b7e579836498..3759a9abf71f 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestAddApproveTransferRemove::test_remove_liquidity Node is bootstrapped. -Estimated gas: 7519.602 units (will add 100 for safety) +Estimated gas: 7520.262 units (will add 100 for safety) Estimated storage: 67 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001114 + Fee to the baker: ꜩ0.001115 Expected counter: [EXPECTED_COUNTER] - Gas limit: 7620 + Gas limit: 7621 Storage limit: 87 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001114 - payload fees(the block proposer) ....... +ꜩ0.001114 + [CONTRACT_HASH] ... -ꜩ0.001115 + payload fees(the block proposer) ....... +ꜩ0.001115 Transaction: Amount: ꜩ0 From: [CONTRACT_HASH] @@ -33,7 +33,7 @@ This sequence of operations was run: 0x01e927f00ef734dfc85919635e9afc9166c83ef9fc00 ; 0x0115eb0104481a6d7921160bc982c5e0a561cd8a3a00 } Storage size: 4633 bytes - Consumed gas: 2278.261 + Consumed gas: 2278.921 Internal operations: Internal Transaction: Amount: ꜩ0 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out index c6ced1b72a1b..b0f8fa476302 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_add_liquidity Node is bootstrapped. -Estimated gas: 8521.881 units (will add 100 for safety) +Estimated gas: 8522.321 units (will add 100 for safety) Estimated storage: 141 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -14,7 +14,7 @@ This sequence of operations was run: From: [CONTRACT_HASH] Fee to the baker: ꜩ0.001218 Expected counter: [EXPECTED_COUNTER] - Gas limit: 8622 + Gas limit: 8623 Storage limit: 161 bytes Balance updates: [CONTRACT_HASH] ... -ꜩ0.001218 @@ -34,7 +34,7 @@ This sequence of operations was run: 0x0115eb0104481a6d7921160bc982c5e0a561cd8a3a00 } Storage size: 4633 bytes Paid storage size diff: 3 bytes - Consumed gas: 3782.899 + Consumed gas: 3783.339 Balance updates: [CONTRACT_HASH] ... -ꜩ0.00075 storage fees ........................... +ꜩ0.00075 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out index c92472467b99..58d78a9381d4 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_buy_tok Node is bootstrapped. -Estimated gas: 5114.803 units (will add 100 for safety) +Estimated gas: 5115.243 units (will add 100 for safety) Estimated storage: 326 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -14,7 +14,7 @@ This sequence of operations was run: From: [CONTRACT_HASH] Fee to the baker: ꜩ0.000869 Expected counter: [EXPECTED_COUNTER] - Gas limit: 5215 + Gas limit: 5216 Storage limit: 346 bytes Balance updates: [CONTRACT_HASH] ... -ꜩ0.000869 @@ -34,7 +34,7 @@ This sequence of operations was run: 0x0115eb0104481a6d7921160bc982c5e0a561cd8a3a00 } Storage size: 4634 bytes Paid storage size diff: 1 bytes - Consumed gas: 1746.825 + Consumed gas: 1747.265 Balance updates: [CONTRACT_HASH] ... -ꜩ0.00025 storage fees ........................... +ꜩ0.00025 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out index 0d2a47c137c5..da9a8b0e15ef 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_sell_tok Node is bootstrapped. -Estimated gas: 7013.514 units (will add 100 for safety) +Estimated gas: 7014.174 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -14,7 +14,7 @@ This sequence of operations was run: From: [CONTRACT_HASH] Fee to the baker: ꜩ0.001057 Expected counter: [EXPECTED_COUNTER] - Gas limit: 7114 + Gas limit: 7115 Storage limit: 0 bytes Balance updates: [CONTRACT_HASH] ... -ꜩ0.001057 @@ -33,7 +33,7 @@ This sequence of operations was run: 0x01e927f00ef734dfc85919635e9afc9166c83ef9fc00 ; 0x0115eb0104481a6d7921160bc982c5e0a561cd8a3a00 } Storage size: 4633 bytes - Consumed gas: 1747.789 + Consumed gas: 1748.449 Internal operations: Internal Transaction: Amount: ꜩ0 -- GitLab From 08bc5f3074ae143dcd91cc39f22345dc9ad85d7a Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 16:49:10 +0200 Subject: [PATCH 06/11] Proto/Michelson: consume more gas for parsing contract data --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 8bd969e54b19..e4ba458ee798 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4929,6 +4929,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra entrypoint:Entrypoint.t -> (context * arg typed_contract) tzresult Lwt.t = fun ~stack_depth ctxt loc arg destination ~entrypoint -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> match destination with | Contract contract -> ( match contract with -- GitLab From 92ce6070294429acd0bc8fb01c85b42c2dcab1c5 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 19:05:26 +0200 Subject: [PATCH 07/11] Tests/Python: update gas in regression traces --- ...stSelfAddressTransfer::test_send_self_address.out | 4 ++-- ...codes.TestContractOnchainOpcodes::test_source.out | 4 ++-- ...tContractOnchainOpcodes::test_transfer_tokens.out | 8 ++++---- ...wwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-.f9045c3a04.out" | 12 ++++++------ 4 files changed, 14 insertions(+), 14 deletions(-) diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out index 50a8fdd290f6..f6612dd12883 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out @@ -1,7 +1,7 @@ tests_alpha/test_contract.py::TestSelfAddressTransfer::test_send_self_address Node is bootstrapped. -Estimated gas: 4693.442 units (will add 100 for safety) +Estimated gas: 4693.662 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -27,7 +27,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 82 bytes - Consumed gas: 3490.352 + Consumed gas: 3490.572 Internal operations: Internal Transaction: Amount: ꜩ0 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out index a21ec2e199b4..ddf5e0f5f28f 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out @@ -78,7 +78,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 3772.404 units (will add 100 for safety) +Estimated gas: 3772.624 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -104,7 +104,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 55 bytes - Consumed gas: 2569.202 + Consumed gas: 2569.422 Internal operations: Internal Transaction: Amount: ꜩ0 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out index 196f7f7c60b1..6fbadc4fd870 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out @@ -143,7 +143,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 4679.767 units (will add 100 for safety) +Estimated gas: 4679.987 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -169,7 +169,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 66 bytes - Consumed gas: 3476.965 + Consumed gas: 3477.185 Balance updates: [CONTRACT_HASH] ... -ꜩ100 [CONTRACT_HASH] ... +ꜩ100 @@ -191,7 +191,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 3767.700 units (will add 100 for safety) +Estimated gas: 3767.920 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -217,7 +217,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 66 bytes - Consumed gas: 2564.898 + Consumed gas: 2565.118 Balance updates: [CONTRACT_HASH] ... -ꜩ100 [CONTRACT_HASH] ... +ꜩ100 diff --git "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[address.tz-None-\"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-.f9045c3a04.out" "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[address.tz-None-\"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-.f9045c3a04.out" index c745e7361796..7760ae78c112 100644 --- "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[address.tz-None-\"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-.f9045c3a04.out" +++ "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[address.tz-None-\"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5\"-.f9045c3a04.out" @@ -7,17 +7,17 @@ emitted operations big_map diff trace - - location: 9 (remaining gas: 1039991.234 units remaining) + - location: 9 (remaining gas: 1039991.014 units remaining) [ (Pair "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" None) ] - - location: 9 (remaining gas: 1039991.224 units remaining) + - location: 9 (remaining gas: 1039991.004 units remaining) [ "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" ] - - location: 10 (remaining gas: 1039991.214 units remaining) + - location: 10 (remaining gas: 1039990.994 units remaining) [ "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" ] - - location: 11 (remaining gas: 1039991.204 units remaining) + - location: 11 (remaining gas: 1039990.984 units remaining) [ (Some "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5") ] - - location: 12 (remaining gas: 1039991.194 units remaining) + - location: 12 (remaining gas: 1039990.974 units remaining) [ {} (Some "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5") ] - - location: 14 (remaining gas: 1039991.184 units remaining) + - location: 14 (remaining gas: 1039990.964 units remaining) [ (Pair {} (Some "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5")) ] -- GitLab From 7fb36f736246aef068910046a60e1ba841798867 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 17:09:51 +0200 Subject: [PATCH 08/11] Proto/Michelson: do not translate errors in CONTRACT --- .../lib_protocol/script_ir_translator.ml | 85 +++++++++---------- 1 file changed, 40 insertions(+), 45 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index e4ba458ee798..bdc6e840d627 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5034,52 +5034,47 @@ let parse_contract_for_script : ( (* An implicit account on any other entrypoint is not a valid contract. *) ctxt, None ) - | Originated _ -> ( + | Originated _ -> (* Originated account *) - trace (Invalid_contract (loc, contract)) - @@ Contract.get_script_code ctxt contract - >>=? fun (ctxt, code) -> - match code with - | None -> return (ctxt, None) - | Some code -> - Lwt.return - ( Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - code - >>? fun (code, ctxt) -> - (* can only fail because of gas *) - match parse_toplevel ctxt ~legacy:true code with - | Error _ -> error (Invalid_contract (loc, contract)) - | Ok ({arg_type; _}, ctxt) -> ( - match - parse_parameter_ty_and_entrypoints - ctxt - ~stack_depth:0 - ~legacy:true - arg_type - with - | Error _ -> error (Invalid_contract (loc, contract)) - | Ok - ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> ( - (* we don't check targ size here because it's a legacy contract code *) - Gas_monad.run ctxt - @@ find_entrypoint_for_type - ~error_details:Fast - ~full:targ - ~expected:arg - entrypoints - entrypoint - >|? fun (entrypoint_arg, ctxt) -> - match entrypoint_arg with - | Ok (entrypoint, arg_ty) -> - let destination = Destination.Contract contract in - let address = {destination; entrypoint} in - let contract = Typed_contract {arg_ty; address} in - (ctxt, Some contract) - | Error Inconsistent_types_fast -> (ctxt, None))) ))) + trace + (Invalid_contract (loc, contract)) + ( Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> + match code with + | None -> return (ctxt, None) + | Some code -> + Lwt.return + ( Script.force_decode_in_context + ~consume_deserialization_gas:When_needed + ctxt + code + >>? fun (code, ctxt) -> + (* can only fail because of gas *) + parse_toplevel ctxt ~legacy:true code + >>? fun ({arg_type; _}, ctxt) -> + parse_parameter_ty_and_entrypoints + ctxt + ~stack_depth:0 + ~legacy:true + arg_type + >>? fun ( Ex_parameter_ty_and_entrypoints + {arg_type = targ; entrypoints}, + ctxt ) -> + (* we don't check targ size here because it's a legacy contract code *) + Gas_monad.run ctxt + @@ find_entrypoint_for_type + ~error_details:Fast + ~full:targ + ~expected:arg + entrypoints + entrypoint + >|? fun (entrypoint_arg, ctxt) -> + match entrypoint_arg with + | Ok (entrypoint, arg_ty) -> + let destination = Destination.Contract contract in + let address = {destination; entrypoint} in + let contract = Typed_contract {arg_ty; address} in + (ctxt, Some contract) + | Error Inconsistent_types_fast -> (ctxt, None) ) )) | Tx_rollup tx_rollup -> ( (* /!\ This pattern matching needs to remain in sync with [parse_contract_for_script] and -- GitLab From b539eced0dd8dd1bbdd72fe18d08d708fad1f234 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 17:11:50 +0200 Subject: [PATCH 09/11] Proto/Michelson: simplify parse_contract --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index bdc6e840d627..caa7019c0dc7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4941,7 +4941,6 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra @@ ty_eq ~error_details:(Informative loc) arg unit_t >>? fun (eq, ctxt) -> eq >|? fun Eq -> - let destination : Destination.t = Contract contract in let address = {destination; entrypoint} in (ctxt, Typed_contract {arg_ty = arg; address}) ) else fail (No_such_entrypoint entrypoint) @@ -5011,9 +5010,9 @@ let parse_contract_for_script : Destination.t -> entrypoint:Entrypoint.t -> (context * arg typed_contract option) tzresult Lwt.t = - fun ctxt loc arg contract ~entrypoint -> + fun ctxt loc arg destination ~entrypoint -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match contract with + match destination with | Contract contract -> ( match contract with | Implicit _ -> @@ -5024,7 +5023,6 @@ let parse_contract_for_script : >|? fun (eq, ctxt) -> match eq with | Ok Eq -> - let destination : Destination.t = Contract contract in let address = {destination; entrypoint} in let contract = Typed_contract {arg_ty = arg; address} in (ctxt, Some contract) @@ -5070,7 +5068,6 @@ let parse_contract_for_script : >|? fun (entrypoint_arg, ctxt) -> match entrypoint_arg with | Ok (entrypoint, arg_ty) -> - let destination = Destination.Contract contract in let address = {destination; entrypoint} in let contract = Typed_contract {arg_ty; address} in (ctxt, Some contract) @@ -5085,7 +5082,7 @@ let parse_contract_for_script : entrypoint = Alpha_context.Tx_rollup.deposit_entrypoint) -> ( Tx_rollup_state.find ctxt tx_rollup >|=? function | ctxt, Some _ -> - let address = {destination = contract; entrypoint} in + let address = {destination; entrypoint} in (ctxt, Some (Typed_contract {arg_ty = arg; address})) | ctxt, None -> (ctxt, None)) | _ -> return (ctxt, None)) -- GitLab From e05c863891d27c1d97bb992da72564a418fb07cd Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 17:40:12 +0200 Subject: [PATCH 10/11] Proto/Michelson: generalize parse_contract --- .../lib_protocol/script_ir_translator.ml | 138 +++++++++++------- 1 file changed, 82 insertions(+), 56 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index caa7019c0dc7..08f1c44f8800 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4911,92 +4911,118 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra entrypoint:Entrypoint.t -> (context * arg typed_contract) tzresult Lwt.t = fun ~stack_depth ctxt loc arg destination ~entrypoint -> - (parse_contract [@ocaml.tailcall]) - ~stack_depth + let error_details = Informative loc in + parse_contract + ~stack_depth:(stack_depth + 1) ctxt + ~error_details loc arg destination ~entrypoint + >>=? fun (ctxt, res) -> Lwt.return (res >|? fun res -> (ctxt, res)) + +(* [parse_contract] is used both to: + - parse contract data by [parse_data] ([parse_contract_data]) + - to execute the [CONTRACT] instruction ([parse_contract_for_script]). + The return type resembles the [Gas_monad]: + - the outer [tzresult] is for gas exhaustion and internal errors + - the inner [result] is for other legitimate cases of failure. + + The inner [result] is turned into an [option] by [parse_contract_for_script]. + Both [tzresult] are merged by [parse_contract_data]. +*) and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract : - type arg argc. + type arg argc err. stack_depth:int -> context -> + error_details:(location, err) error_details -> Script.location -> (arg, argc) ty -> Destination.t -> entrypoint:Entrypoint.t -> - (context * arg typed_contract) tzresult Lwt.t = - fun ~stack_depth ctxt loc arg destination ~entrypoint -> + (context * (arg typed_contract, err) result) tzresult Lwt.t = + fun ~stack_depth ctxt ~error_details loc arg destination ~entrypoint -> + let error ctxt f_err : context * (_, err) result = + ( ctxt, + Error + (match error_details with + | Fast -> (Inconsistent_types_fast : err) + | Informative loc -> trace_of_error @@ f_err loc) ) + in Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> match destination with | Contract contract -> ( match contract with | Implicit _ -> - if Entrypoint.is_default entrypoint then - (* An implicit account on the "default" entrypoint always exists and has type unit. *) - Lwt.return - ( Gas_monad.run ctxt - @@ ty_eq ~error_details:(Informative loc) arg unit_t - >>? fun (eq, ctxt) -> - eq >|? fun Eq -> - let address = {destination; entrypoint} in - (ctxt, Typed_contract {arg_ty = arg; address}) ) - else fail (No_such_entrypoint entrypoint) - | Originated _ -> ( - trace (Invalid_contract (loc, contract)) - @@ Contract.get_script_code ctxt contract - >>=? fun (ctxt, code) -> - match code with - | None -> fail (Invalid_contract (loc, contract)) - | Some code -> + Lwt.return + (if Entrypoint.is_default entrypoint then + (* An implicit account on the "default" entrypoint always exists and has type unit. *) + Gas_monad.run ctxt @@ ty_eq ~error_details arg unit_t + >|? fun (eq, ctxt) -> + ( ctxt, + eq >|? fun Eq -> + let address = {destination; entrypoint} in + Typed_contract {arg_ty = arg; address} ) + else + (* An implicit account on any other entrypoint is not a valid contract. *) + ok (error ctxt (fun _loc -> No_such_entrypoint entrypoint))) + | Originated _ -> + trace + (Invalid_contract (loc, contract)) + ( Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> Lwt.return - ( Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - code - >>? fun (code, ctxt) -> - (* can only fail because of gas *) - parse_toplevel ctxt ~legacy:true code - >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints - ctxt - ~stack_depth:(stack_depth + 1) - ~legacy:true - arg_type - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> - (* we don't check targ size here because it's a legacy contract code *) - Gas_monad.run ctxt - @@ find_entrypoint_for_type - ~error_details:(Informative loc) - ~full:targ - ~expected:arg - entrypoints - entrypoint - >>? fun (entrypoint_arg, ctxt) -> - entrypoint_arg >|? fun (entrypoint, arg_ty) -> - let address = {destination; entrypoint} in - (ctxt, Typed_contract {arg_ty; address}) ))) + (match code with + | None -> + ok + (error ctxt (fun loc -> Invalid_contract (loc, contract))) + | Some code -> + Script.force_decode_in_context + ~consume_deserialization_gas:When_needed + ctxt + code + >>? fun (code, ctxt) -> + (* can only fail because of gas *) + parse_toplevel ctxt ~legacy:true code + >>? fun ({arg_type; _}, ctxt) -> + parse_parameter_ty_and_entrypoints + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy:true + arg_type + >>? fun ( Ex_parameter_ty_and_entrypoints + {arg_type = targ; entrypoints}, + ctxt ) -> + Gas_monad.run ctxt + @@ find_entrypoint_for_type + ~error_details + ~full:targ + ~expected:arg + entrypoints + entrypoint + >|? fun (entrypoint_arg, ctxt) -> + ( ctxt, + entrypoint_arg >|? fun (entrypoint, arg_ty) -> + let address = {destination; entrypoint} in + Typed_contract {arg_ty; address} )) )) | Tx_rollup tx_rollup -> - Tx_rollup_state.assert_exist ctxt tx_rollup >>=? fun ctxt -> + Tx_rollup_state.assert_exist ctxt tx_rollup >|=? fun ctxt -> if Entrypoint.(entrypoint = Tx_rollup.deposit_entrypoint) then (* /!\ This pattern matching needs to remain in sync with [parse_contract] and [parse_tx_rollup_deposit_parameters]. *) match arg with | Pair_t (Ticket_t (_, _), Tx_rollup_l2_address_t, _, _) -> let address = {destination; entrypoint} in - return (ctxt, Typed_contract {arg_ty = arg; address}) + (ctxt, ok @@ Typed_contract {arg_ty = arg; address}) | _ -> - fail - @@ Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg) - else fail (No_such_entrypoint entrypoint) + error ctxt (fun loc -> + Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg)) + else error ctxt (fun _loc -> No_such_entrypoint entrypoint) | Sc_rollup _ -> (* TODO #2800 Implement typechecking of sc rollup deposits. *) - fail (No_such_entrypoint entrypoint) + return (error ctxt (fun _loc -> No_such_entrypoint entrypoint)) (* Same as [parse_contract], 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 -- GitLab From ef49fa6b7d4abaa55fc491c08e64e9c892837f9e Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 3 Jun 2022 17:52:50 +0200 Subject: [PATCH 11/11] Proto/Michelson: use parse_contract in parse_contract_for_script --- .../lib_protocol/script_ir_translator.ml | 89 +++---------------- 1 file changed, 12 insertions(+), 77 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 08f1c44f8800..ec4aecbc3fd1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5010,7 +5010,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra Tx_rollup_state.assert_exist ctxt tx_rollup >|=? fun ctxt -> if Entrypoint.(entrypoint = Tx_rollup.deposit_entrypoint) then (* /!\ This pattern matching needs to remain in sync with - [parse_contract] and [parse_tx_rollup_deposit_parameters]. *) + [parse_tx_rollup_deposit_parameters]. *) match arg with | Pair_t (Ticket_t (_, _), Tx_rollup_l2_address_t, _, _) -> let address = {destination; entrypoint} in @@ -5037,82 +5037,17 @@ let parse_contract_for_script : entrypoint:Entrypoint.t -> (context * arg typed_contract option) tzresult Lwt.t = fun ctxt loc arg destination ~entrypoint -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match destination with - | Contract contract -> ( - match contract with - | Implicit _ -> - if Entrypoint.is_default entrypoint then - (* An implicit account on the "default" entrypoint always exists and has type unit. *) - Lwt.return - ( Gas_monad.run ctxt @@ ty_eq ~error_details:Fast arg unit_t - >|? fun (eq, ctxt) -> - match eq with - | Ok Eq -> - let address = {destination; entrypoint} in - let contract = Typed_contract {arg_ty = arg; address} in - (ctxt, Some contract) - | Error Inconsistent_types_fast -> (ctxt, None) ) - else - return - ( (* An implicit account on any other entrypoint is not a valid contract. *) - ctxt, - None ) - | Originated _ -> - (* Originated account *) - trace - (Invalid_contract (loc, contract)) - ( Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> - match code with - | None -> return (ctxt, None) - | Some code -> - Lwt.return - ( Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - code - >>? fun (code, ctxt) -> - (* can only fail because of gas *) - parse_toplevel ctxt ~legacy:true code - >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints - ctxt - ~stack_depth:0 - ~legacy:true - arg_type - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> - (* we don't check targ size here because it's a legacy contract code *) - Gas_monad.run ctxt - @@ find_entrypoint_for_type - ~error_details:Fast - ~full:targ - ~expected:arg - entrypoints - entrypoint - >|? fun (entrypoint_arg, ctxt) -> - match entrypoint_arg with - | Ok (entrypoint, arg_ty) -> - let address = {destination; entrypoint} in - let contract = Typed_contract {arg_ty; address} in - (ctxt, Some contract) - | Error Inconsistent_types_fast -> (ctxt, None) ) )) - | Tx_rollup tx_rollup -> ( - (* /!\ This pattern matching needs to remain in sync with - [parse_contract_for_script] and - [parse_tx_rollup_deposit_parameters]. *) - match arg with - | Pair_t (Ticket_t (_, _), Tx_rollup_l2_address_t, _, _) - when Entrypoint.( - entrypoint = Alpha_context.Tx_rollup.deposit_entrypoint) -> ( - Tx_rollup_state.find ctxt tx_rollup >|=? function - | ctxt, Some _ -> - let address = {destination; entrypoint} in - (ctxt, Some (Typed_contract {arg_ty = arg; address})) - | ctxt, None -> (ctxt, None)) - | _ -> return (ctxt, None)) - | Sc_rollup _ -> return (ctxt, None) + parse_contract + ~stack_depth:0 + ctxt + ~error_details:Fast + loc + arg + destination + ~entrypoint + >|=? fun (ctxt, res) -> + ( ctxt, + match res with Ok res -> Some res | Error Inconsistent_types_fast -> None ) let view_size view = let open Script_typed_ir_size in -- GitLab