diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index 25f510c21e5ae138e344d5ce5f492f8c354349ee..5667ddf5a8332c9b08ec2cb6b06ddad14be3f490 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -2176,26 +2176,6 @@ module Registration_section = struct () let () = - let lambda = - let open Script_typed_ir in - let (Ty_ex_c pair_list_operation_unit) = pair (list operation) unit in - let descr = - { - kloc = 0; - kbef = cpair unit unit @$ bot; - kaft = pair_list_operation_unit @$ bot; - kinstr = - ICdr - ( kinfo (cpair unit unit @$ bot), - INil - ( kinfo (unit @$ bot), - ICons_pair - ( kinfo (list operation @$ unit @$ bot), - IHalt (kinfo (pair_list_operation_unit @$ bot)) ) ) ); - } - in - Lam (descr, Micheline.Int (0, Z.zero)) - in simple_benchmark ~name:Interpreter_workload.N_ICreate_contract ~kinstr: @@ -2203,10 +2183,7 @@ module Registration_section = struct { kinfo = kinfo (option key_hash @$ mutez @$ unit @$ bot); storage_type = unit; - arg_type = unit; - lambda; - views = Script_map.empty string_key; - entrypoints = no_entrypoints; + code = Micheline.(strip_locations @@ Seq (0, [])); k = halt (operation @$ address @$ bot); }) () diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index cca31ebb0c65a4d641575cd0afa85e067cf14db6..a6527475ca07c04627b0373a3e54761978be372e 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1047,57 +1047,21 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~amount return (ctxt, result, []) else fail (Script_tc_errors.No_such_entrypoint entrypoint) -let apply_origination ~consume_deserialization_gas ~ctxt ~parsed_script ~script - ~internal ~contract ~delegate ~source ~credit ~before_operation = - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - script.Script.storage - >>?= fun (_unparsed_storage, ctxt) -> - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - script.Script.code - >>?= fun (unparsed_code, ctxt) -> - (match parsed_script with - | None -> - Script_ir_translator.parse_script - ctxt - ~legacy:false - ~allow_forged_in_storage:internal - script - | Some parsed_script -> - return (Script_ir_translator.Ex_script parsed_script, ctxt)) - >>=? fun (Ex_script (Script parsed_script), ctxt) -> - let views_result = - Script_ir_translator.typecheck_views - ctxt - ~legacy:false - parsed_script.storage_type - parsed_script.views - in - trace (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) views_result - >>=? fun ctxt -> - Script_ir_translator.collect_lazy_storage - ctxt - parsed_script.storage_type - parsed_script.storage +let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code ~contract + ~delegate ~source ~credit ~before_operation = + Script_ir_translator.collect_lazy_storage ctxt storage_type storage >>?= fun (to_duplicate, ctxt) -> let to_update = Script_ir_translator.no_lazy_storage_id in Script_ir_translator.extract_lazy_storage_diff ctxt Optimized - parsed_script.storage_type - parsed_script.storage + storage_type + storage ~to_duplicate ~to_update ~temporary:false >>=? fun (storage, lazy_storage_diff, ctxt) -> - Script_ir_translator.unparse_data - ctxt - Optimized - parsed_script.storage_type - storage + Script_ir_translator.unparse_data ctxt Optimized storage_type storage >>=? fun (storage, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost storage) >>?= fun ctxt -> let storage = Script.lazy_expr (Micheline.strip_locations storage) in @@ -1233,14 +1197,19 @@ let apply_internal_manager_operation_content : { origination = {delegate; script; credit}; preorigination = contract; - script = parsed_script; + storage_type; + storage; } -> - apply_origination + Script.force_decode_in_context ~consume_deserialization_gas + ctxt + script.Script.code + >>?= fun (unparsed_code, ctxt) -> + apply_origination ~ctxt - ~parsed_script:(Some parsed_script) - ~script - ~internal:true + ~storage_type + ~storage + ~unparsed_code ~contract ~delegate ~source @@ -1452,17 +1421,44 @@ let apply_external_manager_operation_content : in return (ctxt, result, [op]) | Origination {delegate; script; credit} -> - (* The contract is only used to early return the address of an originated - contract in Michelson. - It cannot come from the outside. *) + (* Internal originations have their address generated in the interpreter + so that the script can use it immediately. + The address of external originations is generated here. *) Contract.fresh_contract_from_current_nonce ctxt >>?= fun (ctxt, contract) -> - apply_origination + Script.force_decode_in_context + ~consume_deserialization_gas + ctxt + script.Script.storage + >>?= fun (_unparsed_storage, ctxt) -> + Script_ir_translator.parse_script + ctxt + ~legacy:false + ~allow_forged_in_storage:false + script + >>=? fun (Ex_script parsed_script, ctxt) -> + Script.force_decode_in_context ~consume_deserialization_gas + ctxt + script.Script.code + >>?= fun (unparsed_code, ctxt) -> + let (Script {storage_type; views; storage; _}) = parsed_script in + let views_result = + Script_ir_translator.typecheck_views + ctxt + ~legacy:false + storage_type + views + in + trace + (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) + views_result + >>=? fun ctxt -> + apply_origination ~ctxt - ~parsed_script:None - ~script - ~internal:false + ~storage_type + ~storage + ~unparsed_code ~contract ~delegate ~source:source_contract diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 9fdafa8e945343b3067d489bad498f3a88ada506..3111b9d4cf29f82c540aa3feecd6074147c86d4f 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1137,22 +1137,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (input, storage) (EmptyCell, EmptyCell)))))) | Tx_rollup _ -> (return_none [@ocaml.tailcall]) ctxt) - | ICreate_contract - {storage_type; arg_type; lambda; views; entrypoints; k; _} -> + | ICreate_contract {storage_type; code; k; kinfo = _} -> (* Removed the instruction's arguments manager, spendable and delegatable *) let delegate = accu in let (credit, (init, stack)) = stack in - create_contract - g - gas - storage_type - arg_type - lambda - views - entrypoints - delegate - credit - init + create_contract g gas storage_type code delegate credit init >>=? fun (res, contract, ctxt, gas) -> let stack = ( {destination = Contract contract; entrypoint = Entrypoint.default}, diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 6a19b414337926ac63cf5122cb7805c5d6af885e..d50a1b9e15adcff23da44de20b4ab7366674932c 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -591,40 +591,8 @@ let transfer (ctxt, sc) gas amount location parameters_ty parameters destination (* TODO: https://gitlab.com/tezos/tezos/-/issues/1688 Refactor the sharing part of unparse_script and create_contract *) -let create_contract (ctxt, sc) gas storage_type param_type lambda views - entrypoints delegate credit init = +let create_contract (ctxt, sc) gas storage_type code delegate credit init = let ctxt = update_context gas ctxt in - let loc = Micheline.dummy_location in - unparse_parameter_ty ~loc ctxt param_type ~entrypoints - >>?= fun (unparsed_param_type, ctxt) -> - unparse_ty ~loc ctxt storage_type >>?= fun (unparsed_storage_type, ctxt) -> - let open Micheline in - let view name {input_ty; output_ty; view_code} views = - Prim - ( loc, - K_view, - [ - String (loc, Script_string.to_string name); - input_ty; - output_ty; - view_code; - ], - [] ) - :: views - in - let view_list = Script_map.fold view views [] |> List.rev in - let (Lam (_, code)) = lambda in - let code = - strip_locations - (Seq - ( loc, - [ - Prim (loc, K_parameter, [unparsed_param_type], []); - Prim (loc, K_storage, [unparsed_storage_type], []); - Prim (loc, K_code, [code], []); - ] - @ view_list )) - in collect_lazy_storage ctxt storage_type init >>?= fun (to_duplicate, ctxt) -> let to_update = no_lazy_storage_id in extract_lazy_storage_diff @@ -638,7 +606,7 @@ let create_contract (ctxt, sc) gas storage_type param_type lambda views >>=? fun (init, lazy_storage_diff, ctxt) -> unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost storage) >>?= fun ctxt -> - let storage = strip_locations storage in + let storage = Micheline.strip_locations storage in Contract.fresh_contract_from_current_nonce ctxt >>?= fun (ctxt, contract) -> let origination = { @@ -648,21 +616,9 @@ let create_contract (ctxt, sc) gas storage_type param_type lambda views {code = Script.lazy_expr code; storage = Script.lazy_expr storage}; } in - Script_ir_translator.code_size ctxt lambda views >>?= fun (code_size, ctxt) -> - let script = - Script - { - code = lambda; - arg_type = param_type; - storage = init; - storage_type; - views; - entrypoints; - code_size; - } - in let operation = - Origination {origination; preorigination = contract; script} + Origination + {origination; preorigination = contract; storage_type; storage = init} in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 84689e7eb084a6f8d20befdd47b6f441568afcd9..65b9f6bd1d23fd59bd4cc4cdfdcb82441058da5c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4549,6 +4549,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : -> Tc_context.check_not_in_view ~legacy loc tc_context prim >>?= fun () -> check_two_var_annot loc annot >>?= fun () -> + (* We typecheck the script to make sure we will originate only well-typed + contracts but then we throw away the typed version, except for the + storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in parse_toplevel ctxt ~legacy canonical_code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> @@ -4583,9 +4586,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : arg_type_full ret_type_full code_field) - >>=? fun ( (Lam - ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, - _ ) as lambda), + >>=? fun ( Lam + ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, + _ ), ctxt ) -> let views_result = typecheck_views ctxt ?type_logger ~legacy storage_type views @@ -4604,8 +4607,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : { apply = (fun kinfo k -> - ICreate_contract - {kinfo; storage_type; arg_type; lambda; views; entrypoints; k}); + ICreate_contract {kinfo; storage_type; code = canonical_code; k}); } in let stack = Item_t (operation_t, Item_t (address_t, rest)) in diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 7d344c3dd308e23cf47cd854c8e16a6fc979e92c..1ef7eaf3759cab36f5a2c2e34252da8ba78c4e1e 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -898,10 +898,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | ICreate_contract : { kinfo : (public_key_hash option, Tez.t * ('a * 's)) kinfo; storage_type : ('a, _) ty; - arg_type : ('b, _) ty; - lambda : ('b * 'a, operation boxed_list * 'a) lambda; - views : view_map; - entrypoints : 'b entrypoints; + code : Script.expr; k : (operation, address * 's, 'r, 'f) kinstr; } -> (public_key_hash option, Tez.t * ('a * 's), 'r, 'f) kinstr @@ -1368,7 +1365,8 @@ and 'kind manager_operation = | Origination : { origination : Alpha_context.origination; preorigination : Contract.t; - script : ('arg, 'storage) script; + storage_type : ('storage, _) ty; + storage : 'storage; } -> Kind.origination manager_operation | Delegation : @@ -1705,11 +1703,9 @@ let kinstr_rewritek : | ITransfer_tokens (kinfo, k) -> ITransfer_tokens (kinfo, f.apply k) | IView (kinfo, view_signature, k) -> IView (kinfo, view_signature, f.apply k) | IImplicit_account (kinfo, k) -> IImplicit_account (kinfo, f.apply k) - | ICreate_contract - {kinfo; storage_type; arg_type; lambda; views; entrypoints; k} -> + | ICreate_contract {kinfo; storage_type; code; k} -> let k = f.apply k in - ICreate_contract - {kinfo; storage_type; arg_type; lambda; views; entrypoints; k} + ICreate_contract {kinfo; storage_type; code; k} | ISet_delegate (kinfo, k) -> ISet_delegate (kinfo, f.apply k) | INow (kinfo, k) -> INow (kinfo, f.apply k) | IMin_block_time (kinfo, k) -> IMin_block_time (kinfo, f.apply k) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 94d13289a90664af9cf354b6cd5778beae0986db..80ef6bcda3d6b408c46755c70df84450375843d2 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -856,10 +856,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | ICreate_contract : { kinfo : (public_key_hash option, Tez.t * ('a * 's)) kinfo; storage_type : ('a, _) ty; - arg_type : ('b, _) ty; - lambda : ('b * 'a, operation boxed_list * 'a) lambda; - views : view_map; - entrypoints : 'b entrypoints; + code : Script.expr; k : (operation, address * 's, 'r, 'f) kinstr; } -> (public_key_hash option, Tez.t * ('a * 's), 'r, 'f) kinstr @@ -1506,7 +1503,8 @@ and 'kind manager_operation = | Origination : { origination : Alpha_context.origination; preorigination : Contract.t; - script : ('arg, 'storage) script; + storage_type : ('storage, _) ty; + storage : 'storage; } -> Kind.origination manager_operation | Delegation : diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 44174014b62498b2e777886cbbfeddbacdbe0e64..c9c336381960e8ab097a6f2539624f0ca8fc83a9 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -232,29 +232,6 @@ let chest_key_size _ = let proof_size = 256 in h2w +? (unlocked_value_size + proof_size) -let view_size {input_ty; output_ty; view_code} = - ret_adding - (node_size input_ty ++ node_size output_ty ++ node_size view_code) - h3w - -let views_size views = - Script_map.fold - (fun k view accu -> - ret_adding (accu ++ view_size view) (script_string_size k +! h4w)) - views - zero - -let rec entrypoints_size : type arg. arg entrypoints -> nodes_and_size = - fun {name; nested} -> - let name_size = option_size Entrypoint.in_memory_size name in - let nested_size = - match nested with - | Entrypoints_None -> zero - | Entrypoints_Union {left; right} -> - ret_adding (entrypoints_size left ++ entrypoints_size right) h2w - in - ret_succ_adding nested_size name_size - let kinfo_size {iloc = _; kstack_ty = _} = h2w (* The following mutually recursive functions are mostly @@ -553,16 +530,10 @@ and kinstr_size : ret_succ_adding (accu ++ view_signature_size s) (base kinfo +! word_size) | ITransfer_tokens (kinfo, _) -> ret_succ_adding accu (base kinfo) | IImplicit_account (kinfo, _) -> ret_succ_adding accu (base kinfo) - | ICreate_contract - {kinfo; storage_type; arg_type; lambda; entrypoints; views; k = _} -> - let accu = - ret_succ_adding - (accu ++ ty_size storage_type ++ ty_size arg_type - ++ views_size views - ++ entrypoints_size entrypoints) - (base kinfo +! (word_size *? 4)) - in - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes accu lambda + | ICreate_contract {kinfo; storage_type; code; k = _} -> + ret_succ_adding + (accu ++ ty_size storage_type ++ expr_size code) + (base kinfo +! (word_size *? 2)) | ISet_delegate (kinfo, _) -> ret_succ_adding accu (base kinfo) | INow (kinfo, _) -> ret_succ_adding accu (base kinfo) | IMin_block_time (kinfo, _) -> ret_succ_adding accu (base kinfo) @@ -705,7 +676,6 @@ let rec kinstr_extra_size : type a s r f. (a, s, r, f) kinstr -> nodes_and_size let kinfo = Script_typed_ir.kinfo_of_kinstr body in match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) | ILambda (_, lambda, _) -> lambda_extra_size lambda - | ICreate_contract {lambda; _} -> lambda_extra_size lambda | _ -> zero in ret_succ (accu ++ self_size) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/main.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/main.ml index 69d5ea568d404ada736263fef613efa380f7bfc5..f9a7743e8b4e0b30485ef2abd6ba8011a6d8b980 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/main.ml @@ -53,5 +53,6 @@ let () = ("script cache", Test_script_cache.tests); ("block time instructions", Test_block_time_instructions.tests); ("patched contracts", Test_patched_contracts.tests); + ("annotations", Test_annotations.tests); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml new file mode 100644 index 0000000000000000000000000000000000000000..83eda41acd50b2be39966675297697c7834dd4f0 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml @@ -0,0 +1,130 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (Michelson annotations) + Invocation: dune exec src/proto_alpha/lib_protocol/test/integration/michelson/main.exe \ + -- test "^annotations$" + Subject: This module tests that Michelson annotations are properly handled. +*) + +open Protocol +open Alpha_context + +let type_with_annotations = + "(option :a (or :b (pair %c :d (int %e :f) (nat :g %h)) (bool %i :j)))" + +let contract_with_annotations = + Printf.sprintf + "{ parameter %s ;\n storage %s ;\n code { FAILWITH } }" + type_with_annotations + type_with_annotations + +let contract_factory_with_annotations = + Printf.sprintf + "{ parameter %s ;\n\ + \ storage (option address) ;\n\ + \ code { CAR ;\n\ + \ AMOUNT ;\n\ + \ NONE key_hash ;\n\ + \ CREATE_CONTRACT %s ;\n\ + \ DIP { SOME ;\n\ + \ NIL operation } ;\n\ + \ CONS ;\n\ + \ PAIR } }" + type_with_annotations + contract_with_annotations + +let lazy_none = Script.lazy_expr (Expr.from_string "None") + +let init_and_originate contract_code_string = + Context.init ~consensus_threshold:0 1 >>=? fun (b, contracts) -> + Incremental.begin_construction b >>=? fun inc -> + let source = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd contracts in + let code = Expr.toplevel_from_string contract_code_string in + let script = Script.{code = lazy_expr code; storage = lazy_none} in + Op.contract_origination (I inc) source ~script >>=? fun (operation, addr) -> + Incremental.add_operation inc operation >|=? fun inc -> (inc, source, addr) + +let assert_stored_script_equal inc addr expected_code_string = + Context.Contract.script (I inc) addr >>=? fun stored_script -> + Assert.equal_string + ~loc:__LOC__ + expected_code_string + (Expr.to_string stored_script) + +let get_address_from_storage inc factory_addr = + Context.Contract.storage (I inc) factory_addr >>=? fun factory_storage -> + let ctxt = Incremental.alpha_ctxt inc in + Environment.wrap_tzresult Script_typed_ir.(option_t 0 address_t) + >>?= fun option_address_t -> + Script_ir_translator.parse_data + ctxt + ~legacy:false + ~allow_forged:false + option_address_t + (Micheline.root factory_storage) + >>= fun res -> + Environment.wrap_tzresult res >>?= fun (factory_storage, _ctxt) -> + match factory_storage with + | Some {entrypoint; _} when not (Entrypoint.is_default entrypoint) -> + failwith "Did not expect non-default entrypoint" + | Some {destination = Tx_rollup _; _} -> + failwith "Did not expect non-contract address" + | Some {destination = Contract addr; entrypoint = _it_is_default} -> + return addr + | _ -> + failwith + "The factory contract should have stored the address of the originated \ + contract" + +(* Checks that [contract_with_annotations] once originated is stored as is. *) +let test_external_origination () = + init_and_originate contract_with_annotations >>=? fun (inc, _source, addr) -> + assert_stored_script_equal inc addr contract_with_annotations + +(* Checks that [contract_with_annotations] originated from + [contract_factory_with_annotations] is stored as is. *) +let test_internal_origination () = + init_and_originate contract_factory_with_annotations + >>=? fun (inc, source, factory) -> + Op.transaction (I inc) source factory ~parameters:lazy_none Tez.zero + >>=? fun operation -> + Incremental.add_operation inc operation >>=? fun inc -> + get_address_from_storage inc factory >>=? fun addr -> + assert_stored_script_equal inc addr contract_with_annotations + +let tests = + [ + Tztest.tztest + "External origination preserves annotations" + `Quick + test_external_origination; + Tztest.tztest + "Internal origination preserves annotations" + `Quick + test_internal_origination; + ] diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index dd0c4884842c604cd1f22cd3801224e0a1c18976..18025e9d0590f8ad98bc0aa3b3e1cfc56178e8aa 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -332,7 +332,18 @@ let originate_script block ~script ~storage ~src ~baker ~forges_tickets = let origination_operation ctxt ~src ~script ~orig_contract = let open Lwt_tzresult_syntax in - let* (Script_ir_translator.Ex_script parsed_script, ctxt) = + let* ( Script_ir_translator.Ex_script + (Script + { + storage_type; + storage; + code = _; + arg_type = _; + views = _; + entrypoints = _; + code_size = _; + }), + ctxt ) = wrap @@ Script_ir_translator.parse_script ctxt @@ -349,7 +360,8 @@ let origination_operation ctxt ~src ~script ~orig_contract = { origination = {delegate = None; script; credit = Tez.one}; preorigination = orig_contract; - script = parsed_script; + storage_type; + storage; }; nonce = 1; } diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index ccab86761563d9e0ef5cdacb0c4fe2bc219cf804..183c07137406caebf571d1881ac17ae44a596d6b 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -232,7 +232,18 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = Incremental.begin_construction ~policy:Block.(By_account baker) block in let ctxt = Incremental.alpha_ctxt incr in - let* (Script_ir_translator.Ex_script parsed_script, ctxt) = + let* ( Script_ir_translator.Ex_script + (Script + { + storage_type; + storage; + code = _; + arg_type = _; + views = _; + entrypoints = _; + code_size = _; + }), + ctxt ) = wrap @@ Script_ir_translator.parse_script ctxt @@ -249,7 +260,8 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = { origination = {delegate = None; script; credit = Tez.one}; preorigination = orig_contract; - script = parsed_script; + storage_type; + storage; }; nonce = 1; } diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index 8109390b6e30107c1c74f31fce96bc6c103aa7b2..225e2a8eda8d77ab61a22df4d67acbb2db497f3a 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -220,17 +220,7 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location return (Some {destination = Contract destination; tickets}, ctxt) (** Extract tickets of an origination operation by scanning the storage. *) -let tickets_of_origination ctxt ~preorigination - (Script_typed_ir.Script - { - storage_type; - storage; - code = _; - arg_type = _; - views = _; - entrypoints = _; - code_size = _; - }) = +let tickets_of_origination ctxt ~preorigination ~storage_type ~storage = (* Extract any tickets from the storage. Note that if the type of the contract storage does not contain tickets, storage is not scanned. *) Ticket_scanner.type_has_tickets ctxt storage_type @@ -290,9 +280,10 @@ let tickets_of_operation ctxt { origination = {delegate = _; script = _; credit = _}; preorigination; - script; + storage_type; + storage; } -> - tickets_of_origination ctxt ~preorigination script + tickets_of_origination ctxt ~preorigination ~storage_type ~storage | Delegation _ -> return (None, ctxt) let add_transfer_to_token_map ctxt token_map {destination; tickets} = diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestOriginateContractFromContract::test_originate_contract_from_contract_origination.out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestOriginateContractFromContract::test_originate_contract_from_contract_origination.out index a7636f76f7db42c22cbc7cded04394315bfa2ab4..c90bd64b8f822cacc74099dcfbe61ab6d7ffaa50 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestOriginateContractFromContract::test_originate_contract_from_contract_origination.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestOriginateContractFromContract::test_originate_contract_from_contract_origination.out @@ -1,7 +1,7 @@ tests_alpha/test_contract.py::TestOriginateContractFromContract::test_originate_contract_from_contract_origination Node is bootstrapped. -Estimated gas: 1428.712 units (will add 100 for safety) +Estimated gas: 1428.262 units (will add 100 for safety) Estimated storage: 350 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -41,7 +41,7 @@ This sequence of operations was run: [CONTRACT_HASH] Storage size: 93 bytes Paid storage size diff: 93 bytes - Consumed gas: 1428.712 + Consumed gas: 1428.262 Balance updates: [CONTRACT_HASH] ... -ꜩ0.02325 storage fees ........................... +ꜩ0.02325 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestOriginateContractFromContract::test_originate_contract_from_contract_transfer.out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestOriginateContractFromContract::test_originate_contract_from_contract_transfer.out index 42bff6c96faa27bd6ceebff0ec561301aa19e202..4de97de5291d1b272343108c71f0d171f68ffaf6 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestOriginateContractFromContract::test_originate_contract_from_contract_transfer.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestOriginateContractFromContract::test_originate_contract_from_contract_transfer.out @@ -1,7 +1,7 @@ tests_alpha/test_contract.py::TestOriginateContractFromContract::test_originate_contract_from_contract_transfer Node is bootstrapped. -Estimated gas: 3470.319 units (will add 100 for safety) +Estimated gas: 3468.749 units (will add 100 for safety) Estimated storage: 295 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.000607 + Fee to the baker: ꜩ0.000606 Expected counter: [EXPECTED_COUNTER] - Gas limit: 3571 + Gas limit: 3569 Storage limit: 315 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.000607 - payload fees(the block proposer) ....... +ꜩ0.000607 + [CONTRACT_HASH] ... -ꜩ0.000606 + payload fees(the block proposer) ....... +ꜩ0.000606 Transaction: Amount: ꜩ0 From: [CONTRACT_HASH] @@ -26,7 +26,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 93 bytes - Consumed gas: 2066.252 + Consumed gas: 2064.682 Internal operations: Origination: From: [CONTRACT_HASH] diff --git "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" index edceebcd11243b01a973aa36c83e0fcd56b62e73..98ec1d692733e7649891fa4dd7a3a521f596f3d1 100644 --- "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" +++ "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" @@ -13,37 +13,37 @@ emitted operations big_map diff trace - - location: 8 (remaining gas: 1039984.204 units remaining) + - location: 8 (remaining gas: 1039984.654 units remaining) [ (Pair Unit None) ] - - location: 8 (remaining gas: 1039984.194 units remaining) + - location: 8 (remaining gas: 1039984.644 units remaining) [ ] - - location: 9 (remaining gas: 1039984.184 units remaining) + - location: 9 (remaining gas: 1039984.634 units remaining) [ Unit ] - - location: 10 (remaining gas: 1039984.169 units remaining) + - location: 10 (remaining gas: 1039984.619 units remaining) [ 50000 Unit ] - - location: 11 (remaining gas: 1039984.154 units remaining) + - location: 11 (remaining gas: 1039984.604 units remaining) [ None 50000 Unit ] - - location: 13 (remaining gas: 1039982.468 units remaining) + - location: 13 (remaining gas: 1039984.038 units remaining) [ 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm" ] - - location: 25 (remaining gas: 1039982.453 units remaining) + - location: 25 (remaining gas: 1039984.023 units remaining) [ "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm" ] - - location: 27 (remaining gas: 1039982.438 units remaining) + - location: 27 (remaining gas: 1039984.008 units remaining) [ (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 28 (remaining gas: 1039982.423 units remaining) + - location: 28 (remaining gas: 1039983.993 units remaining) [ {} (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 25 (remaining gas: 1039982.393 units remaining) + - location: 25 (remaining gas: 1039983.963 units remaining) [ 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b {} (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 30 (remaining gas: 1039982.378 units remaining) + - location: 30 (remaining gas: 1039983.948 units remaining) [ { 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b } (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 31 (remaining gas: 1039982.363 units remaining) + - location: 31 (remaining gas: 1039983.933 units remaining) [ (Pair { 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b } (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm")) ]