diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 75ba10925c0a511a040899d598feeb22b753204f..bf6e08d7f09211973bab31e911e172f1ee52af4f 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -65,7 +65,7 @@ module Proto = struct module Translator = struct type toplevel = Script_ir_translator.toplevel - type ex_ty = Script_ir_translator.ex_ty + type ex_ty = Script_typed_ir.ex_ty type ex_code = Script_ir_translator.ex_code @@ -107,11 +107,11 @@ module Proto = struct in data - let unparse_ty (ctxt : Raw_context.t) (Script_ir_translator.Ex_ty ty) = + let unparse_ty (ctxt : Raw_context.t) (Script_typed_ir.Ex_ty ty) = let open Result_syntax in let+ expr, _ = wrap_tzresult - @@ Script_ir_translator.unparse_ty ~loc:0 (Obj.magic ctxt) ty + @@ Script_ir_unparser.unparse_ty ~loc:0 (Obj.magic ctxt) ty in expr @@ -207,7 +207,7 @@ module Proto = struct Box.OPS.fold (fun _k v acc -> g v @ acc) Box.boxed []) @@ find_lambda_tys tv - let collect_lambda_tys (Script_ir_translator.Ex_ty ty) = + let collect_lambda_tys (Script_typed_ir.Ex_ty ty) = match find_lambda_tys ty with | [] -> None | lams -> Some (Ex_ty_lambdas (ty, lams)) @@ -222,7 +222,7 @@ module Proto = struct match parse_result with | Error _ -> acc | Ok data -> ( - match Script_ir_translator.unparse_ty ~loc:0 (Obj.magic ctxt) ty with + match Script_ir_unparser.unparse_ty ~loc:0 (Obj.magic ctxt) ty with | Error _ -> assert false | Ok (ty_expr, _) -> List.fold_left (fun acc g -> f acc ty_expr @@ g data) acc getters) diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index f1b643175a664240a956449b33cc343a5932c412..f36ab8c661e02e3b5e117ca57a7cf415e63e8b62 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -244,7 +244,7 @@ module type S = sig module Michelson_base : Michelson_samplers_base.S module Random_type : sig - val m_type : size:int -> Script_ir_translator.ex_ty sampler + val m_type : size:int -> Script_typed_ir.ex_ty sampler val m_comparable_type : size:int -> Script_ir_translator.ex_comparable_ty sampler @@ -290,7 +290,7 @@ end) (* Random generation of Michelson types. *) module Random_type = struct let type_of_atomic_type_name (at_tn : atomic_type_name) : - Script_ir_translator.ex_ty = + Script_typed_ir.ex_ty = match at_tn with | `TString -> Ex_ty string_t | `TNat -> Ex_ty nat_t @@ -333,7 +333,7 @@ end) | `TKey -> Ex_comparable_ty key_t | `TChain_id -> Ex_comparable_ty chain_id_t - let rec m_type ~size : Script_ir_translator.ex_ty sampler = + let rec m_type ~size : Script_typed_ir.ex_ty sampler = let open Script_ir_translator in let open M in if size <= 0 then Stdlib.failwith "m_type: size <= 0" diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.mli b/src/proto_alpha/lib_benchmark/michelson_samplers.mli index c6730c7312ca33328a746a0e74263582482e8d4a..c333639b79a9b026e0acbcd15f1c12b090bc8ef4 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.mli +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.mli @@ -67,7 +67,7 @@ module type S = sig (** Samplers for random Michelson types. *) module Random_type : sig (** [m_type ~size] samples a type containing exactly [size] constructors. *) - val m_type : size:int -> Script_ir_translator.ex_ty sampler + val m_type : size:int -> Script_typed_ir.ex_ty sampler (** [m_comparable_type ~size] samples a comparable type containing exactly [size] constructors. *) diff --git a/src/proto_alpha/lib_benchmark/type_helpers.mli b/src/proto_alpha/lib_benchmark/type_helpers.mli index 1a041e001459ae90b7d493a6a14ab10c890d33a9..0cf310d3afcfead9e171aa0b5cb171527a7c07e1 100644 --- a/src/proto_alpha/lib_benchmark/type_helpers.mli +++ b/src/proto_alpha/lib_benchmark/type_helpers.mli @@ -44,7 +44,7 @@ val michelson_type_list_to_ex_stack_ty : @raise Type_helpers_error if an error arises during parsing. *) val michelson_type_to_ex_ty : - Alpha_context.Script.expr -> Alpha_context.t -> Script_ir_translator.ex_ty + Alpha_context.Script.expr -> Alpha_context.t -> Script_typed_ir.ex_ty (** [stack_type_to_michelson_type_list] converts a Mikhailsky stack type to a stack represented as a list of Micheline expressions, each @@ -54,5 +54,4 @@ val michelson_type_to_ex_ty : val stack_type_to_michelson_type_list : Type.Stack.t -> Script_repr.expr list (** [base_type_to_ex_ty] converts a Mikhailsky type to a Michelson one. *) -val base_type_to_ex_ty : - Type.Base.t -> Alpha_context.t -> Script_ir_translator.ex_ty +val base_type_to_ex_ty : Type.Base.t -> Alpha_context.t -> Script_typed_ir.ex_ty diff --git a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml index a686c668cd405ea9951fe8520f4c8b2c051c8171..a2c05ba2d8d91f2adce89ea17cccdadd47b90116 100644 --- a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml @@ -79,7 +79,7 @@ end = struct ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type ctxt in match ex_ty with - | Script_ir_translator.Ex_ty ty -> ( + | Script_typed_ir.Ex_ty ty -> ( match Lwt_main.run (Script_ir_translator.parse_data @@ -144,7 +144,7 @@ module Type_size_benchmark : Tezos_benchmark.Benchmark.S = struct let models = [(model_name, size_based_model name)] - let type_size_benchmark (Script_ir_translator.Ex_ty ty) = + let type_size_benchmark (Script_typed_ir.Ex_ty ty) = let open Script_typed_ir_size.Internal_for_tests in let open Cache_memory_helpers in let size = Nodes.(to_int (fst (ty_size ty))) in diff --git a/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml index 5a9813b17e33edc98318d7e62acb241cef8c58db..6b1e614378b1146a45068b5597e9803312d1958c 100644 --- a/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml @@ -183,7 +183,6 @@ let ticket_ty = This is a worst case type for [type_has_tickets], though nested unions, nested maps or nested lists would be just as bad. *) let rec dummy_type_generator ~rng_state size = - let open Script_ir_translator in let open Script_typed_ir in let ticket_or_int = if Base_samplers.uniform_bool rng_state then Ex_ty ticket_ty diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 9ec90ebfbf5861a766306060f333b4d791c04e3a..87b1186807e5057c15bb01fd6def3e7fc0ff58ad 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -206,7 +206,7 @@ module Typechecking_data : Benchmark.S = struct | Some workload -> workload in match ex_ty with - | Script_ir_translator.Ex_ty ty -> + | Script_typed_ir.Ex_ty ty -> let closure () = match Lwt_main.run @@ -278,7 +278,7 @@ module Unparsing_data : Benchmark.S = struct | Some workload -> workload in match ex_ty with - | Script_ir_translator.Ex_ty ty -> + | Script_typed_ir.Ex_ty ty -> Script_ir_translator.parse_data ctxt ~legacy:false @@ -292,7 +292,7 @@ module Unparsing_data : Benchmark.S = struct Lwt_main.run (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized + Script_ir_unparser.Optimized ty typed) with @@ -570,7 +570,7 @@ module Ty_eq : Benchmark.S = struct let models = [("size_translator_model", size_model); ("codegen", codegen_model)] - let ty_eq_benchmark rng_state nodes (ty : Script_ir_translator.ex_ty) = + let ty_eq_benchmark rng_state nodes (ty : Script_typed_ir.ex_ty) = Lwt_main.run ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> let ctxt = Gas_helpers.set_limit ctxt in @@ -630,7 +630,6 @@ let () = Registration_helpers.register (module Ty_eq) an extra test is performed to determine if the comb type needs to be folded. *) let rec dummy_type_generator size = - let open Script_ir_translator in let open Script_typed_ir in if size <= 1 then Ex_ty unit_t else @@ -694,7 +693,7 @@ let parse_ty ctxt node = ~allow_ticket:true node -let unparse_ty ctxt ty = Script_ir_translator.unparse_ty ~loc:(-1) ctxt ty +let unparse_ty ctxt ty = Script_ir_unparser.unparse_ty ~loc:(-1) ctxt ty module Parse_type_benchmark : Benchmark.S = struct include Parse_type_shared diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml index 065fd6007e710cd86b7fcbac2ce6fc60c1d499ae..0d7d92c73446f4b5d5b9a91670acd5e63e0d94e8 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml @@ -110,7 +110,7 @@ let workload_to_sparse_vec (trace : t) = let data_typechecker_workload ctxt t_kind micheline_node ex_ty = let open Protocol in match ex_ty with - | Script_ir_translator.Ex_ty ty -> + | Script_typed_ir.Ex_ty ty -> let ctxt = Gas_helpers.set_limit ctxt in Lwt_main.run ( Script_ir_translator.parse_data diff --git a/src/proto_alpha/lib_client/client_proto_args.ml b/src/proto_alpha/lib_client/client_proto_args.ml index 5a221a42371b635a8299200615f4b57202f6477c..1915b09fee683778355617773a945c852fc64c5c 100644 --- a/src/proto_alpha/lib_client/client_proto_args.ml +++ b/src/proto_alpha/lib_client/client_proto_args.ml @@ -559,9 +559,9 @@ let unparsing_mode_parameter = return ["Readable"; "Optimized"; "Optimized_legacy"]) (fun _cctxt s -> match s with - | "Readable" -> return Script_ir_translator.Readable - | "Optimized" -> return Script_ir_translator.Optimized - | "Optimized_legacy" -> return Script_ir_translator.Optimized_legacy + | "Readable" -> return Script_ir_unparser.Readable + | "Optimized" -> return Script_ir_unparser.Optimized + | "Optimized_legacy" -> return Script_ir_unparser.Optimized_legacy | _ -> failwith "Unknown unparsing mode %s" s) let unparsing_mode_arg ~default = diff --git a/src/proto_alpha/lib_client/client_proto_args.mli b/src/proto_alpha/lib_client/client_proto_args.mli index 180ec8580ccf4e4ab8f1cbbaa41f41ffff7d134e..c10aaaa08278c7c73eb89fbee438dd655b93c632 100644 --- a/src/proto_alpha/lib_client/client_proto_args.mli +++ b/src/proto_alpha/lib_client/client_proto_args.mli @@ -150,7 +150,7 @@ val data_parameter : (Michelson_v1_parser.parsed, full) Clic.parameter val raw_level_parameter : (Raw_level.t, full) Clic.parameter val unparsing_mode_arg : - default:string -> (Script_ir_translator.unparsing_mode, full) Clic.arg + default:string -> (Script_ir_unparser.unparsing_mode, full) Clic.arg val enforce_indentation_flag : (bool, full) Clic.arg diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index 8dca7a77749e1c958e81a4ee16f9537596f032ad..2b5f73c969f4b7ad05348c4dcca0bfbbda89d21d 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -38,7 +38,7 @@ val get_storage : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> - unparsing_mode:Script_ir_translator.unparsing_mode -> + unparsing_mode:Script_ir_unparser.unparsing_mode -> Contract_hash.t -> Script.expr option tzresult Lwt.t @@ -79,7 +79,7 @@ val get_big_map_value : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> - unparsing_mode:Script_ir_translator.unparsing_mode -> + unparsing_mode:Script_ir_unparser.unparsing_mode -> Big_map.Id.t -> Script_expr_hash.t -> Script.expr tzresult Lwt.t @@ -89,7 +89,7 @@ val get_script : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> - unparsing_mode:Script_ir_translator.unparsing_mode -> + unparsing_mode:Script_ir_unparser.unparsing_mode -> normalize_types:bool -> Contract_hash.t -> Script.t option tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_proto_fa12.mli b/src/proto_alpha/lib_client/client_proto_fa12.mli index 4817f9c68295ededefd170fb10fa918288f77be6..f3cafb56ef6419c7b67ce2e23aee0c205c484f03 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.mli +++ b/src/proto_alpha/lib_client/client_proto_fa12.mli @@ -157,6 +157,6 @@ val run_view_action : action:action -> ?payer:Signature.public_key_hash -> ?gas:Gas.Arith.integral -> - unparsing_mode:Script_ir_translator.unparsing_mode -> + unparsing_mode:Script_ir_unparser.unparsing_mode -> unit -> Script.expr tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 728e9ec1baaa1e6c2ab1add4c4726f99ac79b753..4412d16c001cfa50d1f5e337291dff3aec789fce 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -122,7 +122,7 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed = type simulation_params = { input : Michelson_v1_parser.parsed; - unparsing_mode : Script_ir_translator.unparsing_mode; + unparsing_mode : Script_ir_unparser.unparsing_mode; now : Script_timestamp.t option; level : Script_int.n Script_int.num option; source : Contract.t option; diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index 40d5acac1b4f50bc1df8a041a3a5c481f7c4a1dd..383d2116b10b99715efff23e87098ecd22c4b7cc 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -35,7 +35,7 @@ module Program : (* Parameters shared by both simulations (views, and contracts). *) type simulation_params = { input : Michelson_v1_parser.parsed; - unparsing_mode : Script_ir_translator.unparsing_mode; + unparsing_mode : Script_ir_unparser.unparsing_mode; now : Script_timestamp.t option; level : Script_int.n Script_int.num option; source : Contract.t option; diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 11a1fefef01b1cc47a5993db06e14138e983eda5..e6de2ed315eff3d32b7f94121e998b7920981309 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -123,7 +123,7 @@ module Registration = struct end let unparsing_mode_encoding = - let open Script_ir_translator in + let open Script_ir_unparser in let open Data_encoding in union ~tag_size:`Uint8 @@ -468,7 +468,7 @@ module Scripts = struct end module type UNPARSING_MODE = sig - val unparsing_mode : Script_ir_translator.unparsing_mode + val unparsing_mode : Script_ir_unparser.unparsing_mode end module Traced_interpreter (Unparsing_mode : UNPARSING_MODE) = struct @@ -556,7 +556,7 @@ module Scripts = struct >>?= fun (Ex_ty exp_ty, ctxt) -> trace_eval (fun () -> - let exp_ty = Script_ir_translator.serialize_ty_for_error exp_ty in + let exp_ty = Script_ir_unparser.serialize_ty_for_error exp_ty in Script_tc_errors.Ill_typed_data (None, data, exp_ty)) (let allow_forged = true @@ -1451,7 +1451,7 @@ module Scripts = struct (Micheline.root script) >|=? fun (normalized, _ctxt) -> Micheline.strip_locations normalized) ; Registration.register0 ~chunked:true S.normalize_type (fun ctxt () typ -> - let open Script_ir_translator in + let open Script_typed_ir in let ctxt = Gas.set_unlimited ctxt in (* Unfortunately, Script_ir_translator.parse_any_ty is not exported *) Script_ir_translator.parse_ty diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index f7729e81f1c9ba2ca1eb99ace07b931e3906d155..71c7e7b36aacc1cea5b1dc0f3a77ebe89cf36418 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -188,6 +188,7 @@ "Apply_operation_result", "Apply_internal_results", "Apply_results", + "Script_ir_unparser", "Script_ir_translator", "Script_big_map", "Script_cache", diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 7f9f086db701361869ca6010e4abcc6bcdf0e4ce..02f02c46665adb7c7acd5a998effd4f82923a2e6 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -931,7 +931,7 @@ let ex_ticket_size : fun ctxt (Ex_ticket (ty, ticket)) -> (* type *) Script_typed_ir.ticket_t Micheline.dummy_location ty >>?= fun ty -> - Script_ir_translator.unparse_ty ~loc:Micheline.dummy_location ctxt ty + Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt ty >>?= fun (ty', ctxt) -> let ty_nodes, ty_size = Script_typed_ir_size.node_size ty' in let ty_size = Saturation_repr.to_int ty_size in diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index f067f3b48e3b42dbb564059a1389e6a1550daff8..8804e19b0edc0f5131eb2be4c8cbc2bc7b392266 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -451,7 +451,8 @@ let register () = r |> function | Ok (Ex_ty_cstr {ty; original_type_expr; _}) -> if normalize_types then - unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _ctxt) -> + Script_ir_unparser.unparse_ty ~loc:() ctxt ty + >|? fun (ty_node, _ctxt) -> Some (Micheline.strip_locations ty_node) else ok (Some (Micheline.strip_locations original_type_expr)) @@ -486,9 +487,12 @@ let register () = entrypoints in Entrypoint.Map.fold_e - (fun entry (Ex_ty ty, original_type_expr) (acc, ctxt) -> + (fun entry + (Script_typed_ir.Ex_ty ty, original_type_expr) + (acc, ctxt) -> (if normalize_types then - unparse_ty ~loc:() ctxt ty >|? fun (ty_node, ctxt) -> + Script_ir_unparser.unparse_ty ~loc:() ctxt ty + >|? fun (ty_node, ctxt) -> (Micheline.strip_locations ty_node, ctxt) else ok (Micheline.strip_locations original_type_expr, ctxt)) diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index ec1225e2420fc8021c39c3b0dfc5f9f669fa3efb..07fb0c871a8656b4f35a4ba9de4f5be9aed97d84 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -204,6 +204,7 @@ Apply_operation_result Apply_internal_results Apply_results + Script_ir_unparser Script_ir_translator Script_big_map Script_cache @@ -447,6 +448,7 @@ apply_operation_result.ml apply_operation_result.mli apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli + script_ir_unparser.ml script_ir_unparser.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli @@ -670,6 +672,7 @@ apply_operation_result.ml apply_operation_result.mli apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli + script_ir_unparser.ml script_ir_unparser.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli @@ -898,6 +901,7 @@ apply_operation_result.ml apply_operation_result.mli apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli + script_ir_unparser.ml script_ir_unparser.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index 9237267ded7002048069bc48061d4bbaa15e6d2c..8c689361ed9da1e0d0d9b2e3d821ce1906dea679 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -59,7 +59,7 @@ let make_internal_inbox_message ctxt ty ~payload ~sender ~source = let+ payload, ctxt = Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized + Script_ir_unparser.Optimized ty payload in diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index bcca460b020ff01665b55914e43a266cd0a43a44..bfee647aff66d9d229ecf19ad002a4cdd80c11eb 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -96,7 +96,7 @@ val execute : ?logger:logger -> Alpha_context.t -> cached_script:Script_ir_translator.ex_script option -> - Script_ir_translator.unparsing_mode -> + Script_ir_unparser.unparsing_mode -> step_constants -> script:Script.t -> entrypoint:Entrypoint.t -> @@ -114,7 +114,7 @@ val execute_with_typed_parameter : ?logger:logger -> Alpha_context.context -> cached_script:Script_ir_translator.ex_script option -> - Script_ir_translator.unparsing_mode -> + Script_ir_unparser.unparsing_mode -> step_constants -> script:Script.t -> entrypoint:Entrypoint.t -> diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 67f8fa5791c623e34a8548b06dda11758524d6d1..eb09e705a2cf1220741bcf213c40796dd648b593 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -433,7 +433,7 @@ let apply ctxt gas capture_ty capture lam = let ctxt = update_context gas ctxt in unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> let loc = Micheline.dummy_location in - unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> + Script_ir_unparser.unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> match full_arg_ty with | Pair_t (capture_ty, arg_ty, _, _) -> let arg_stack_ty = Item_t (arg_ty, Bot_t) in @@ -483,7 +483,7 @@ let make_transaction_to_tx_rollup (type t) ctxt ~destination ~amount unparse_data ctxt Optimized parameters_ty parameters >>=? fun (unparsed_parameters, ctxt) -> Lwt.return - ( Script_ir_translator.unparse_ty ~loc:Micheline.dummy_location ctxt tp + ( Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt tp >>? fun (ty, ctxt) -> let unparsed_parameters = Micheline.Seq (Micheline.dummy_location, [unparsed_parameters; ty]) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index c224c3471340d60fa4464bd2a499032d3c11023a..ff050082abf0d956c86fc24306dc953313d0831b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -32,6 +32,7 @@ open Script open Script_tc_errors open Script_ir_annot open Script_typed_ir +open Script_ir_unparser module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking module Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing module Tc_context = Script_tc_context @@ -90,8 +91,6 @@ let compose_descr : type tc_context = Tc_context.t -type unparsing_mode = Optimized | Readable | Optimized_legacy - type type_logger = Script.location -> stack_ty_before:Script.expr list -> @@ -147,150 +146,6 @@ let check_kind kinds expr = let loc = location expr in error (Invalid_kind (loc, kinds, kind)) -(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*) - -(* This part contains the unparsing that does not depend on parsing - (everything that cannot contain a lambda). The rest is located at - the end of the file. *) - -let unparse_memo_size ~loc memo_size = - let z = Sapling.Memo_size.unparse_to_z memo_size in - Int (loc, z) - -let rec unparse_ty_and_entrypoints_uncarbonated : - type a ac loc. - loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node = - fun ~loc ty {nested = nested_entrypoints; at_node} -> - let name, args = - match ty with - | Unit_t -> (T_unit, []) - | Int_t -> (T_int, []) - | Nat_t -> (T_nat, []) - | Signature_t -> (T_signature, []) - | String_t -> (T_string, []) - | Bytes_t -> (T_bytes, []) - | Mutez_t -> (T_mutez, []) - | Bool_t -> (T_bool, []) - | Key_hash_t -> (T_key_hash, []) - | Key_t -> (T_key, []) - | Timestamp_t -> (T_timestamp, []) - | Address_t -> (T_address, []) - | Tx_rollup_l2_address_t -> (T_tx_rollup_l2_address, []) - | Operation_t -> (T_operation, []) - | Chain_id_t -> (T_chain_id, []) - | Never_t -> (T_never, []) - | Bls12_381_g1_t -> (T_bls12_381_g1, []) - | Bls12_381_g2_t -> (T_bls12_381_g2, []) - | Bls12_381_fr_t -> (T_bls12_381_fr, []) - | Contract_t (ut, _meta) -> - let t = - unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints - in - (T_contract, [t]) - | Pair_t (utl, utr, _meta, _) -> ( - let tl = - unparse_ty_and_entrypoints_uncarbonated ~loc utl no_entrypoints - in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints - in - (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) - (* Note that the folding does not happen if the pair on the right has an - annotation because this annotation would be lost *) - match tr with - | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts) - | _ -> (T_pair, [tl; tr])) - | Union_t (utl, utr, _meta, _) -> - let entrypoints_l, entrypoints_r = - match nested_entrypoints with - | Entrypoints_None -> (no_entrypoints, no_entrypoints) - | Entrypoints_Union {left; right} -> (left, right) - in - let tl = - unparse_ty_and_entrypoints_uncarbonated ~loc utl entrypoints_l - in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr entrypoints_r - in - (T_or, [tl; tr]) - | Lambda_t (uta, utr, _meta) -> - let ta = - unparse_ty_and_entrypoints_uncarbonated ~loc uta no_entrypoints - in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints - in - (T_lambda, [ta; tr]) - | Option_t (ut, _meta, _) -> - let ut = - unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints - in - (T_option, [ut]) - | List_t (ut, _meta) -> - let t = - unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints - in - (T_list, [t]) - | Ticket_t (ut, _meta) -> - let t = unparse_comparable_ty_uncarbonated ~loc ut in - (T_ticket, [t]) - | Set_t (ut, _meta) -> - let t = unparse_comparable_ty_uncarbonated ~loc ut in - (T_set, [t]) - | Map_t (uta, utr, _meta) -> - let ta = unparse_comparable_ty_uncarbonated ~loc uta in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints - in - (T_map, [ta; tr]) - | Big_map_t (uta, utr, _meta) -> - let ta = unparse_comparable_ty_uncarbonated ~loc uta in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints - in - (T_big_map, [ta; tr]) - | Sapling_transaction_t memo_size -> - (T_sapling_transaction, [unparse_memo_size ~loc memo_size]) - | Sapling_transaction_deprecated_t memo_size -> - (T_sapling_transaction_deprecated, [unparse_memo_size ~loc memo_size]) - | Sapling_state_t memo_size -> - (T_sapling_state, [unparse_memo_size ~loc memo_size]) - | Chest_key_t -> (T_chest_key, []) - | Chest_t -> (T_chest, []) - in - let annot = - match at_node with - | None -> [] - | Some {name; original_type_expr = _} -> - [Entrypoint.unparse_as_field_annot name] - in - Prim (loc, name, args, annot) - -and unparse_comparable_ty_uncarbonated : - type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = - fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints - -let unparse_ty_uncarbonated ~loc ty = - unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints - -let unparse_ty ~loc ctxt ty = - Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> - (unparse_ty_uncarbonated ~loc ty, ctxt) - -let unparse_parameter_ty ~loc ctxt ty ~entrypoints = - Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> - (unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root, ctxt) - -let serialize_ty_for_error ty = - (* - Types are bounded by [Constants.michelson_maximum_type_size], so - [unparse_ty_uncarbonated] and [strip_locations] are bounded in time. - - It is hence OK to use them in errors that are not caught in the validation - (only once in apply). - *) - unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations - let check_comparable : type a ac. Script.location -> (a, ac) ty -> (ac, Dependent_bool.yes) eq tzresult = @@ -298,281 +153,9 @@ let check_comparable : match is_comparable ty with | Yes -> ok Eq | No -> - let t = serialize_ty_for_error ty in + let t = Script_ir_unparser.serialize_ty_for_error ty in error (Comparable_type_expected (loc, t)) -let rec unparse_stack_uncarbonated : - type a s. (a, s) stack_ty -> Script.expr list = function - | Bot_t -> [] - | Item_t (ty, rest) -> - let uty = unparse_ty_uncarbonated ~loc:() ty in - let urest = unparse_stack_uncarbonated rest in - strip_locations uty :: urest - -let serialize_stack_for_error ctxt stack_ty = - match Gas.level ctxt with - | Unaccounted -> unparse_stack_uncarbonated stack_ty - | Limited _ -> [] - -let unparse_unit ~loc ctxt () = ok (Prim (loc, D_Unit, [], []), ctxt) - -let unparse_int ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) - -let unparse_nat ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) - -let unparse_string ~loc ctxt s = - ok (String (loc, Script_string.to_string s), ctxt) - -let unparse_bytes ~loc ctxt s = ok (Bytes (loc, s), ctxt) - -let unparse_bool ~loc ctxt b = - ok (Prim (loc, (if b then D_True else D_False), [], []), ctxt) - -let unparse_timestamp ~loc ctxt mode t = - match mode with - | Optimized | Optimized_legacy -> - ok (Int (loc, Script_timestamp.to_zint t), ctxt) - | Readable -> ( - Gas.consume ctxt Unparse_costs.timestamp_readable >>? fun ctxt -> - match Script_timestamp.to_notation t with - | None -> ok (Int (loc, Script_timestamp.to_zint t), ctxt) - | Some s -> ok (String (loc, s), ctxt)) - -let unparse_address ~loc ctxt mode {destination; entrypoint} = - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn - Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding) - (destination, entrypoint) - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt -> - let notation = - Destination.to_b58check destination - ^ Entrypoint.to_address_suffix entrypoint - in - (String (loc, notation), ctxt) - -let unparse_tx_rollup_l2_address ~loc ctxt mode - (tx_address : tx_rollup_l2_address) = - let tx_address = Indexable.to_value tx_address in - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn - Tx_rollup_l2_address.encoding - tx_address - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt -> - let b58check = Tx_rollup_l2_address.to_b58check tx_address in - (String (loc, b58check), ctxt) - -let unparse_contract ~loc ctxt mode typed_contract = - let destination = Typed_contract.destination typed_contract in - let entrypoint = Typed_contract.entrypoint typed_contract in - let address = {destination; entrypoint} in - unparse_address ~loc ctxt mode address - -let unparse_signature ~loc ctxt mode s = - let s = Script_signature.get s in - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.signature_optimized >|? fun ctxt -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.signature_readable >|? fun ctxt -> - (String (loc, Signature.to_b58check s), ctxt) - -let unparse_mutez ~loc ctxt v = ok (Int (loc, Z.of_int64 (Tez.to_mutez v)), ctxt) - -let unparse_key ~loc ctxt mode k = - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.public_key_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.public_key_readable >|? fun ctxt -> - (String (loc, Signature.Public_key.to_b58check k), ctxt) - -let unparse_key_hash ~loc ctxt mode k = - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.key_hash_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.key_hash_readable >|? fun ctxt -> - (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) - -(* Operations are only unparsed during the production of execution traces of - the interpreter. *) -let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = - let iop = Apply_internal_results.packed_internal_operation piop in - let bytes = - Data_encoding.Binary.to_bytes_exn - Apply_internal_results.internal_operation_encoding - iop - in - Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> - (Bytes (loc, bytes), ctxt) - -let unparse_chain_id ~loc ctxt mode chain_id = - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.chain_id_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn Script_chain_id.encoding chain_id - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.chain_id_readable >|? fun ctxt -> - (String (loc, Script_chain_id.to_b58check chain_id), ctxt) - -let unparse_bls12_381_g1 ~loc ctxt x = - Gas.consume ctxt Unparse_costs.bls12_381_g1 >|? fun ctxt -> - let bytes = Script_bls.G1.to_bytes x in - (Bytes (loc, bytes), ctxt) - -let unparse_bls12_381_g2 ~loc ctxt x = - Gas.consume ctxt Unparse_costs.bls12_381_g2 >|? fun ctxt -> - let bytes = Script_bls.G2.to_bytes x in - (Bytes (loc, bytes), ctxt) - -let unparse_bls12_381_fr ~loc ctxt x = - Gas.consume ctxt Unparse_costs.bls12_381_fr >|? fun ctxt -> - let bytes = Script_bls.Fr.to_bytes x in - (Bytes (loc, bytes), ctxt) - -let unparse_with_data_encoding ~loc ctxt s unparse_cost encoding = - Lwt.return - ( Gas.consume ctxt unparse_cost >|? fun ctxt -> - let bytes = Data_encoding.Binary.to_bytes_exn encoding s in - (Bytes (loc, bytes), ctxt) ) - -(* -- Unparsing data of complex types -- *) - -type ('ty, 'depth) comb_witness = - | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness - | Comb_Any : (_, _) comb_witness - -let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode - (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) = - unparse_l ctxt l >>=? fun (l, ctxt) -> - unparse_r ctxt r >|=? fun (r, ctxt) -> - (* Fold combs. - For combs, three notations are supported: - - a) [Pair x1 (Pair x2 ... (Pair xn-1 xn) ...)], - - b) [Pair x1 x2 ... xn-1 xn], and - - c) [{x1; x2; ...; xn-1; xn}]. - In readable mode, we always use b), - in optimized mode we use the shortest to serialize: - - for n=2, [Pair x1 x2], - - for n=3, [Pair x1 (Pair x2 x3)], - - for n>=4, [{x1; x2; ...; xn}]. - *) - let res = - match (mode, r_comb_witness, r) with - | Optimized, Comb_Pair _, Micheline.Seq (_, r) -> - (* Optimized case n > 4 *) - Micheline.Seq (loc, l :: r) - | ( Optimized, - Comb_Pair (Comb_Pair _), - Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> - (* Optimized case n = 4 *) - Micheline.Seq (loc, [l; x2; x3; x4]) - | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) -> - (* Readable case n > 2 *) - Prim (loc, D_Pair, l :: xs, []) - | _ -> - (* The remaining cases are: - - Optimized n = 2, - - Optimized n = 3, and - - Readable n = 2, - - Optimized_legacy, any n *) - Prim (loc, D_Pair, [l; r], []) - in - (res, ctxt) - -let unparse_union ~loc unparse_l unparse_r ctxt = function - | L l -> - unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (loc, D_Left, [l], []), ctxt) - | R r -> - unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (loc, D_Right, [r], []), ctxt) - -let unparse_option ~loc unparse_v ctxt = function - | Some v -> - unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (loc, D_Some, [v], []), ctxt) - | None -> return (Prim (loc, D_None, [], []), ctxt) - -(* -- Unparsing data of comparable types -- *) - -let comb_witness2 : - type t tc. (t, tc) ty -> (t, unit -> unit -> unit) comb_witness = function - | Pair_t (_, Pair_t _, _, _) -> Comb_Pair (Comb_Pair Comb_Any) - | Pair_t _ -> Comb_Pair Comb_Any - | _ -> Comb_Any - -let rec unparse_comparable_data : - type a loc. - loc:loc -> - context -> - unparsing_mode -> - a comparable_ty -> - a -> - (loc Script.michelson_node * context) tzresult Lwt.t = - fun ~loc ctxt mode ty a -> - (* No need for stack_depth here. Unlike [unparse_data], - [unparse_comparable_data] doesn't call [unparse_code]. - The stack depth is bounded by the type depth, currently bounded - by 1000 (michelson_maximum_type_size). *) - Gas.consume ctxt Unparse_costs.unparse_data_cycle - (* We could have a smaller cost but let's keep it consistent with - [unparse_data] for now. *) - >>?= - fun ctxt -> - match (ty, a) with - | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v - | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v - | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v - | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s - | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s - | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b - | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address - | Tx_rollup_l2_address_t, address -> - Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v - | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k - | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | Chain_id_t, chain_id -> - Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Pair_t (tl, tr, _, YesYes), pair -> - let r_witness = comb_witness2 tr in - let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in - let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in - unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, YesYes), v -> - let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in - let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in - unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, Yes), v -> - let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in - unparse_option ~loc unparse_v ctxt v - | Never_t, _ -> . - let pack_node unparsed ctxt = Gas.consume ctxt (Script.strip_locations_cost unparsed) >>? fun ctxt -> let bytes = @@ -944,8 +527,6 @@ let parse_memo_size (n : (location, _) Micheline.node) : type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty -type ex_ty = Ex_ty : ('a, _) ty -> ex_ty - type ex_parameter_ty_and_entrypoints_node = | Ex_parameter_ty_and_entrypoints_node : { arg_type : ('a, _) ty; @@ -5273,263 +4854,15 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) in fold_tree full entrypoints.root [] reachable ([], init) -(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) +include Data_unparser (struct + type nonrec type_logger = type_logger -(* -- Unparsing data of any type -- *) + let opened_ticket_type = opened_ticket_type -let rec unparse_data : - type a ac. - context -> - stack_depth:int -> - unparsing_mode -> - (a, ac) ty -> - a -> - (Script.node * context) tzresult Lwt.t = - fun ctxt ~stack_depth mode ty a -> - Gas.consume ctxt Unparse_costs.unparse_data_cycle >>?= fun ctxt -> - let non_terminal_recursion ctxt mode ty a = - if Compare.Int.(stack_depth > 10_000) then - fail Unparsing_too_many_recursive_calls - else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a - in - let loc = Micheline.dummy_location in - match (ty, a) with - | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v - | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v - | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v - | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s - | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s - | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b - | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address - | Tx_rollup_l2_address_t, address -> - Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Contract_t _, contract -> - Lwt.return @@ unparse_contract ~loc ctxt mode contract - | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v - | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k - | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | Operation_t, operation -> - Lwt.return @@ unparse_operation ~loc ctxt operation - | Chain_id_t, chain_id -> - Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x - | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x - | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x - | Pair_t (tl, tr, _, _), pair -> - let r_witness = comb_witness2 tr in - let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in - let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, _), v -> - let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in - let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, _), v -> - let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in - unparse_option ~loc unparse_v ctxt v - | List_t (t, _), items -> - List.fold_left_es - (fun (l, ctxt) element -> - non_terminal_recursion ctxt mode t element - >|=? fun (unparsed, ctxt) -> (unparsed :: l, ctxt)) - ([], ctxt) - items.elements - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) - | Ticket_t (t, _), {ticketer; contents; amount} -> - (* ideally we would like to allow a little overhead here because it is only used for unparsing *) - opened_ticket_type loc t >>?= fun t -> - let destination : Destination.t = Contract ticketer in - let addr = {destination; entrypoint = Entrypoint.default} in - (unparse_data [@tailcall]) - ctxt - ~stack_depth - mode - t - (addr, (contents, amount)) - | Set_t (t, _), set -> - List.fold_left_es - (fun (l, ctxt) item -> - unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> - (item :: l, ctxt)) - ([], ctxt) - (Script_set.fold (fun e acc -> e :: acc) set []) - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Map_t (kt, vt, _), map -> - let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _} - when Compare.Int.( = ) size 0 -> - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} -> - let items = - Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] - in - let items = - (* Sort the items in Michelson comparison order and not in key - hash order. This code path is only exercised for tracing, - so we don't bother carbonating this sort operation - precisely. Also, the sort uses a reverse compare because - [unparse_items] will reverse the result. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - (* this can't fail if the original type is well-formed - because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt >>?= fun vt -> - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) - | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} -> - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> - match v with None -> acc | Some v -> (k, v) :: acc) - map - [] - in - let items = - (* See note above. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Lambda_t _, Lam (_, original_code) -> - unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code - | Never_t, _ -> . - | Sapling_transaction_t _, s -> - Lwt.return - ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s - in - (Bytes (loc, bytes), ctxt) ) - | Sapling_transaction_deprecated_t _, s -> - Lwt.return - ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) - >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn - Sapling.Legacy.transaction_encoding - s - in - (Bytes (loc, bytes), ctxt) ) - | Sapling_state_t _, {id; diff; _} -> - Lwt.return - ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> - ( (match diff with - | {commitments_and_ciphertexts = []; nullifiers = []} -> ( - match id with - | None -> Micheline.Seq (loc, []) - | Some id -> - let id = Sapling.Id.unparse_to_z id in - Micheline.Int (loc, id)) - | diff -> ( - let diff_bytes = - Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff - in - let unparsed_diff = Bytes (loc, diff_bytes) in - match id with - | None -> unparsed_diff - | Some id -> - let id = Sapling.Id.unparse_to_z id in - Micheline.Prim - (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), - ctxt ) ) - | Chest_key_t, s -> - unparse_with_data_encoding - ~loc - ctxt - s - Unparse_costs.chest_key - Script_timelock.chest_key_encoding - | Chest_t, s -> - unparse_with_data_encoding - ~loc - ctxt - s - (Unparse_costs.chest - ~plaintext_size:(Script_timelock.get_plaintext_size s)) - Script_timelock.chest_encoding - -and unparse_items : - type k v vc. - context -> - stack_depth:int -> - unparsing_mode -> - k comparable_ty -> - (v, vc) ty -> - (k * v) list -> - (Script.node list * context) tzresult Lwt.t = - fun ctxt ~stack_depth mode kt vt items -> - List.fold_left_es - (fun (l, ctxt) (k, v) -> - let loc = Micheline.dummy_location in - unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v - >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) - ([], ctxt) - items + let parse_packable_ty = parse_packable_ty -and unparse_code ctxt ~stack_depth mode code = - let legacy = true in - Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> - let non_terminal_recursion ctxt mode code = - if Compare.Int.(stack_depth > 10_000) then - fail Unparsing_too_many_recursive_calls - else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code - in - match code with - | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty - >>?= fun (Ex_ty t, ctxt) -> - let allow_forged = - false - (* Forgeable in PUSH data are already forbidden at parsing, - the only case for which this matters is storing a lambda resulting - from APPLYing a non-forgeable but this cannot happen either as long - as all packable values are also forgeable. *) - in - parse_data - ctxt - ~stack_depth:(stack_depth + 1) - ~legacy - ~allow_forged - t - data - >>=? fun (data, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data - >>=? fun (data, ctxt) -> - return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) - | Seq (loc, items) -> - List.fold_left_es - (fun (l, ctxt) item -> - non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) -> - (item :: l, ctxt)) - ([], ctxt) - items - >>=? fun (items, ctxt) -> - return (Micheline.Seq (loc, List.rev items), ctxt) - | Prim (loc, prim, items, annot) -> - List.fold_left_es - (fun (l, ctxt) item -> - non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) -> - (item :: l, ctxt)) - ([], ctxt) - items - >>=? fun (items, ctxt) -> - return (Prim (loc, prim, List.rev items, annot), ctxt) - | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) + let parse_data = parse_data +end) let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage mode ~normalize_types {code; storage} = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index cd0e7a8e8bdd662643cc015844a84536835f72fa..5407b328d25c2a62adeb6b7264c59a292b16bd00 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -42,7 +42,7 @@ careful not to accidentally quantify 'a universally, that is "for all 'a, 'a ty exists", otherwise you'll get an annoying error about 'a trying to escape it's scope. We do this by hiding 'a in an existential type. This is what - ex_comparable_ty, ex_ty, ex_stack_ty, etc. do. + ex_comparable_ty, ex_ty, ex_stack_ty, etc. do. 2. A set of functions dealing with high-level Michelson types: This module also provides functions for interacting with the list, map, @@ -63,6 +63,7 @@ (** {1 Michelson Existential Witness types} *) open Alpha_context +open Script_typed_ir open Script_tc_errors type ('ta, 'tb) eq = Eq : ('same, 'same) eq @@ -70,8 +71,6 @@ type ('ta, 'tb) eq = Eq : ('same, 'same) eq type ex_comparable_ty = | Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty -type ex_ty = Ex_ty : ('a, _) Script_typed_ir.ty -> ex_ty - type ex_parameter_ty_and_entrypoints = | Ex_parameter_ty_and_entrypoints : { arg_type : ('a, _) Script_typed_ir.ty; @@ -158,14 +157,6 @@ type ('a, 's) judgement = val close_descr : ('a, 'b, 'c, 'd) descr -> ('a, 'b, 'c, 'd) Script_typed_ir.kdescr -(** Flag that drives unparsing of typed values to nodes. - - [Optimized_legacy] must be kept backward-compatible in order to compute - valid hashes (of big map keys). - - [Optimized] may be used as long as the result can be read by parse_data. - - [Readable] produces with [string] values instead of [bytes] when feasible. -*) -type unparsing_mode = Optimized | Readable | Optimized_legacy - (* ---- Lists, Sets and Maps ----------------------------------------------- *) (** {2 High-level Michelson Data Types} *) @@ -204,22 +195,14 @@ val parse_data : (* Unparsing an IR-typed data back into a Micheline node data *) val unparse_data : context -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> ('a, _) Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult Lwt.t -val unparse_comparable_data : - loc:'loc -> - context -> - unparsing_mode -> - 'a Script_typed_ir.comparable_ty -> - 'a -> - ('loc Script.michelson_node * context) tzresult Lwt.t - val unparse_code : context -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> Script.node -> (Script.node * context) tzresult Lwt.t @@ -303,22 +286,9 @@ val parse_ty : Script.node -> (ex_ty * context) tzresult -val unparse_ty : - loc:'loc -> - context -> - ('a, _) Script_typed_ir.ty -> - ('loc Script.michelson_node * context) tzresult - val parse_toplevel : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult Lwt.t -val unparse_parameter_ty : - loc:'loc -> - context -> - ('a, _) Script_typed_ir.ty -> - entrypoints:'a Script_typed_ir.entrypoints -> - ('loc Script.michelson_node * context) tzresult - (** High-level function to typecheck a Michelson script. This function is not used for validating operations but only for the [typecheck_code] RPC. @@ -331,8 +301,6 @@ val typecheck_code : Script.expr -> (type_map * context) tzresult Lwt.t -val serialize_ty_for_error : ('a, _) Script_typed_ir.ty -> Script.expr - val parse_code : ?type_logger:type_logger -> context -> @@ -363,7 +331,7 @@ val parse_and_unparse_script_unaccounted : context -> legacy:bool -> allow_forged_in_storage:bool -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> normalize_types:bool -> Script.t -> (Script.t * context) tzresult Lwt.t @@ -459,7 +427,7 @@ val list_of_big_map_ids : lazy_storage_ids -> Big_map.Id.t list *) val extract_lazy_storage_diff : context -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> temporary:bool -> to_duplicate:lazy_storage_ids -> to_update:lazy_storage_ids -> diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml new file mode 100644 index 0000000000000000000000000000000000000000..306f15962ab0b6961d127ae85d1df8f0151bc21f --- /dev/null +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -0,0 +1,733 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Micheline +open Script_typed_ir +open Michelson_v1_primitives +module Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing + +type unparsing_mode = Optimized | Readable | Optimized_legacy + +(* This part contains the unparsing that does not depend on parsing + (everything that cannot contain a lambda). The rest is located at + the end of the file. *) + +let unparse_memo_size ~loc memo_size = + let z = Sapling.Memo_size.unparse_to_z memo_size in + Int (loc, z) + +let rec unparse_ty_and_entrypoints_uncarbonated : + type a ac loc. + loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node = + fun ~loc ty {nested = nested_entrypoints; at_node} -> + let name, args = + match ty with + | Unit_t -> (T_unit, []) + | Int_t -> (T_int, []) + | Nat_t -> (T_nat, []) + | Signature_t -> (T_signature, []) + | String_t -> (T_string, []) + | Bytes_t -> (T_bytes, []) + | Mutez_t -> (T_mutez, []) + | Bool_t -> (T_bool, []) + | Key_hash_t -> (T_key_hash, []) + | Key_t -> (T_key, []) + | Timestamp_t -> (T_timestamp, []) + | Address_t -> (T_address, []) + | Tx_rollup_l2_address_t -> (T_tx_rollup_l2_address, []) + | Operation_t -> (T_operation, []) + | Chain_id_t -> (T_chain_id, []) + | Never_t -> (T_never, []) + | Bls12_381_g1_t -> (T_bls12_381_g1, []) + | Bls12_381_g2_t -> (T_bls12_381_g2, []) + | Bls12_381_fr_t -> (T_bls12_381_fr, []) + | Contract_t (ut, _meta) -> + let t = + unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints + in + (T_contract, [t]) + | Pair_t (utl, utr, _meta, _) -> ( + let tl = + unparse_ty_and_entrypoints_uncarbonated ~loc utl no_entrypoints + in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints + in + (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) + (* Note that the folding does not happen if the pair on the right has an + annotation because this annotation would be lost *) + match tr with + | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts) + | _ -> (T_pair, [tl; tr])) + | Union_t (utl, utr, _meta, _) -> + let entrypoints_l, entrypoints_r = + match nested_entrypoints with + | Entrypoints_None -> (no_entrypoints, no_entrypoints) + | Entrypoints_Union {left; right} -> (left, right) + in + let tl = + unparse_ty_and_entrypoints_uncarbonated ~loc utl entrypoints_l + in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr entrypoints_r + in + (T_or, [tl; tr]) + | Lambda_t (uta, utr, _meta) -> + let ta = + unparse_ty_and_entrypoints_uncarbonated ~loc uta no_entrypoints + in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints + in + (T_lambda, [ta; tr]) + | Option_t (ut, _meta, _) -> + let ut = + unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints + in + (T_option, [ut]) + | List_t (ut, _meta) -> + let t = + unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints + in + (T_list, [t]) + | Ticket_t (ut, _meta) -> + let t = unparse_comparable_ty_uncarbonated ~loc ut in + (T_ticket, [t]) + | Set_t (ut, _meta) -> + let t = unparse_comparable_ty_uncarbonated ~loc ut in + (T_set, [t]) + | Map_t (uta, utr, _meta) -> + let ta = unparse_comparable_ty_uncarbonated ~loc uta in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints + in + (T_map, [ta; tr]) + | Big_map_t (uta, utr, _meta) -> + let ta = unparse_comparable_ty_uncarbonated ~loc uta in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints + in + (T_big_map, [ta; tr]) + | Sapling_transaction_t memo_size -> + (T_sapling_transaction, [unparse_memo_size ~loc memo_size]) + | Sapling_transaction_deprecated_t memo_size -> + (T_sapling_transaction_deprecated, [unparse_memo_size ~loc memo_size]) + | Sapling_state_t memo_size -> + (T_sapling_state, [unparse_memo_size ~loc memo_size]) + | Chest_key_t -> (T_chest_key, []) + | Chest_t -> (T_chest, []) + in + let annot = + match at_node with + | None -> [] + | Some {name; original_type_expr = _} -> + [Entrypoint.unparse_as_field_annot name] + in + Prim (loc, name, args, annot) + +and unparse_comparable_ty_uncarbonated : + type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = + fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints + +let unparse_ty_uncarbonated ~loc ty = + unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints + +let unparse_ty ~loc ctxt ty = + Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> + (unparse_ty_uncarbonated ~loc ty, ctxt) + +let unparse_parameter_ty ~loc ctxt ty ~entrypoints = + Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> + (unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root, ctxt) + +let serialize_ty_for_error ty = + (* + Types are bounded by [Constants.michelson_maximum_type_size], so + [unparse_ty_uncarbonated] and [strip_locations] are bounded in time. + + It is hence OK to use them in errors that are not caught in the validation + (only once in apply). + *) + unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations + +let rec unparse_stack_uncarbonated : + type a s. (a, s) stack_ty -> Script.expr list = function + | Bot_t -> [] + | Item_t (ty, rest) -> + let uty = unparse_ty_uncarbonated ~loc:() ty in + let urest = unparse_stack_uncarbonated rest in + strip_locations uty :: urest + +let serialize_stack_for_error ctxt stack_ty = + match Gas.level ctxt with + | Unaccounted -> unparse_stack_uncarbonated stack_ty + | Limited _ -> [] + +let unparse_unit ~loc ctxt () = ok (Prim (loc, D_Unit, [], []), ctxt) + +let unparse_int ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) + +let unparse_nat ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) + +let unparse_string ~loc ctxt s = + ok (String (loc, Script_string.to_string s), ctxt) + +let unparse_bytes ~loc ctxt s = ok (Bytes (loc, s), ctxt) + +let unparse_bool ~loc ctxt b = + ok (Prim (loc, (if b then D_True else D_False), [], []), ctxt) + +let unparse_timestamp ~loc ctxt mode t = + match mode with + | Optimized | Optimized_legacy -> + ok (Int (loc, Script_timestamp.to_zint t), ctxt) + | Readable -> ( + Gas.consume ctxt Unparse_costs.timestamp_readable >>? fun ctxt -> + match Script_timestamp.to_notation t with + | None -> ok (Int (loc, Script_timestamp.to_zint t), ctxt) + | Some s -> ok (String (loc, s), ctxt)) + +let unparse_address ~loc ctxt mode {destination; entrypoint} = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding) + (destination, entrypoint) + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt -> + let notation = + Destination.to_b58check destination + ^ Entrypoint.to_address_suffix entrypoint + in + (String (loc, notation), ctxt) + +let unparse_tx_rollup_l2_address ~loc ctxt mode + (tx_address : tx_rollup_l2_address) = + let tx_address = Indexable.to_value tx_address in + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Tx_rollup_l2_address.encoding + tx_address + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt -> + let b58check = Tx_rollup_l2_address.to_b58check tx_address in + (String (loc, b58check), ctxt) + +let unparse_contract ~loc ctxt mode typed_contract = + let destination = Typed_contract.destination typed_contract in + let entrypoint = Typed_contract.entrypoint typed_contract in + let address = {destination; entrypoint} in + unparse_address ~loc ctxt mode address + +let unparse_signature ~loc ctxt mode s = + let s = Script_signature.get s in + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.signature_optimized >|? fun ctxt -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.signature_readable >|? fun ctxt -> + (String (loc, Signature.to_b58check s), ctxt) + +let unparse_mutez ~loc ctxt v = ok (Int (loc, Z.of_int64 (Tez.to_mutez v)), ctxt) + +let unparse_key ~loc ctxt mode k = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.public_key_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.public_key_readable >|? fun ctxt -> + (String (loc, Signature.Public_key.to_b58check k), ctxt) + +let unparse_key_hash ~loc ctxt mode k = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.key_hash_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.key_hash_readable >|? fun ctxt -> + (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) + +(* Operations are only unparsed during the production of execution traces of + the interpreter. *) +let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = + let iop = Apply_internal_results.packed_internal_operation piop in + let bytes = + Data_encoding.Binary.to_bytes_exn + Apply_internal_results.internal_operation_encoding + iop + in + Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> + (Bytes (loc, bytes), ctxt) + +let unparse_chain_id ~loc ctxt mode chain_id = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.chain_id_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Script_chain_id.encoding chain_id + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.chain_id_readable >|? fun ctxt -> + (String (loc, Script_chain_id.to_b58check chain_id), ctxt) + +let unparse_bls12_381_g1 ~loc ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_g1 >|? fun ctxt -> + let bytes = Script_bls.G1.to_bytes x in + (Bytes (loc, bytes), ctxt) + +let unparse_bls12_381_g2 ~loc ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_g2 >|? fun ctxt -> + let bytes = Script_bls.G2.to_bytes x in + (Bytes (loc, bytes), ctxt) + +let unparse_bls12_381_fr ~loc ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_fr >|? fun ctxt -> + let bytes = Script_bls.Fr.to_bytes x in + (Bytes (loc, bytes), ctxt) + +let unparse_with_data_encoding ~loc ctxt s unparse_cost encoding = + Lwt.return + ( Gas.consume ctxt unparse_cost >|? fun ctxt -> + let bytes = Data_encoding.Binary.to_bytes_exn encoding s in + (Bytes (loc, bytes), ctxt) ) + +(* -- Unparsing data of complex types -- *) + +type ('ty, 'depth) comb_witness = + | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness + | Comb_Any : (_, _) comb_witness + +let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode + (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) = + unparse_l ctxt l >>=? fun (l, ctxt) -> + unparse_r ctxt r >|=? fun (r, ctxt) -> + (* Fold combs. + For combs, three notations are supported: + - a) [Pair x1 (Pair x2 ... (Pair xn-1 xn) ...)], + - b) [Pair x1 x2 ... xn-1 xn], and + - c) [{x1; x2; ...; xn-1; xn}]. + In readable mode, we always use b), + in optimized mode we use the shortest to serialize: + - for n=2, [Pair x1 x2], + - for n=3, [Pair x1 (Pair x2 x3)], + - for n>=4, [{x1; x2; ...; xn}]. + *) + let res = + match (mode, r_comb_witness, r) with + | Optimized, Comb_Pair _, Micheline.Seq (_, r) -> + (* Optimized case n > 4 *) + Micheline.Seq (loc, l :: r) + | ( Optimized, + Comb_Pair (Comb_Pair _), + Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> + (* Optimized case n = 4 *) + Micheline.Seq (loc, [l; x2; x3; x4]) + | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) -> + (* Readable case n > 2 *) + Prim (loc, D_Pair, l :: xs, []) + | _ -> + (* The remaining cases are: + - Optimized n = 2, + - Optimized n = 3, and + - Readable n = 2, + - Optimized_legacy, any n *) + Prim (loc, D_Pair, [l; r], []) + in + (res, ctxt) + +let unparse_union ~loc unparse_l unparse_r ctxt = function + | L l -> + unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (loc, D_Left, [l], []), ctxt) + | R r -> + unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (loc, D_Right, [r], []), ctxt) + +let unparse_option ~loc unparse_v ctxt = function + | Some v -> + unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (loc, D_Some, [v], []), ctxt) + | None -> return (Prim (loc, D_None, [], []), ctxt) + +(* -- Unparsing data of comparable types -- *) + +let comb_witness2 : + type t tc. (t, tc) ty -> (t, unit -> unit -> unit) comb_witness = function + | Pair_t (_, Pair_t _, _, _) -> Comb_Pair (Comb_Pair Comb_Any) + | Pair_t _ -> Comb_Pair Comb_Any + | _ -> Comb_Any + +let rec unparse_comparable_data : + type a loc. + loc:loc -> + context -> + unparsing_mode -> + a comparable_ty -> + a -> + (loc Script.michelson_node * context) tzresult Lwt.t = + fun ~loc ctxt mode ty a -> + (* No need for stack_depth here. Unlike [unparse_data], + [unparse_comparable_data] doesn't call [unparse_code]. + The stack depth is bounded by the type depth, currently bounded + by 1000 (michelson_maximum_type_size). *) + Gas.consume ctxt Unparse_costs.unparse_data_cycle + (* We could have a smaller cost but let's keep it consistent with + [unparse_data] for now. *) + >>?= + fun ctxt -> + match (ty, a) with + | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, address -> + Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address + | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Chain_id_t, chain_id -> + Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id + | Pair_t (tl, tr, _, YesYes), pair -> + let r_witness = comb_witness2 tr in + let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in + let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in + unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair + | Union_t (tl, tr, _, YesYes), v -> + let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in + let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in + unparse_union ~loc unparse_l unparse_r ctxt v + | Option_t (t, _, Yes), v -> + let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in + unparse_option ~loc unparse_v ctxt v + | Never_t, _ -> . + +(* -- Unparsing data of any type -- *) + +module type MICHELSON_PARSER = sig + type type_logger + + val opened_ticket_type : + Script.location -> + 'a comparable_ty -> + (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty + tzresult + + val parse_packable_ty : + context -> + stack_depth:int -> + legacy:bool -> + Script.node -> + (ex_ty * context) tzresult + + val parse_data : + ?type_logger:type_logger -> + stack_depth:int -> + context -> + legacy:bool -> + allow_forged:bool -> + ('a, 'ac) ty -> + Script.node -> + ('a * t) tzresult Lwt.t +end + +module Data_unparser (P : MICHELSON_PARSER) = struct + let rec unparse_data : + type a ac. + context -> + stack_depth:int -> + unparsing_mode -> + (a, ac) ty -> + a -> + (Script.node * context) tzresult Lwt.t = + fun ctxt ~stack_depth mode ty a -> + Gas.consume ctxt Unparse_costs.unparse_data_cycle >>?= fun ctxt -> + let non_terminal_recursion ctxt mode ty a = + if Compare.Int.(stack_depth > 10_000) then + fail Script_tc_errors.Unparsing_too_many_recursive_calls + else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a + in + let loc = Micheline.dummy_location in + match (ty, a) with + | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, address -> + Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address + | Contract_t _, contract -> + Lwt.return @@ unparse_contract ~loc ctxt mode contract + | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Operation_t, operation -> + Lwt.return @@ unparse_operation ~loc ctxt operation + | Chain_id_t, chain_id -> + Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id + | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x + | Pair_t (tl, tr, _, _), pair -> + let r_witness = comb_witness2 tr in + let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in + let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in + unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair + | Union_t (tl, tr, _, _), v -> + let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in + let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in + unparse_union ~loc unparse_l unparse_r ctxt v + | Option_t (t, _, _), v -> + let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in + unparse_option ~loc unparse_v ctxt v + | List_t (t, _), items -> + List.fold_left_es + (fun (l, ctxt) element -> + non_terminal_recursion ctxt mode t element + >|=? fun (unparsed, ctxt) -> (unparsed :: l, ctxt)) + ([], ctxt) + items.elements + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) + | Ticket_t (t, _), {ticketer; contents; amount} -> + (* ideally we would like to allow a little overhead here because it is only used for unparsing *) + P.opened_ticket_type loc t >>?= fun t -> + let destination : Destination.t = Contract ticketer in + let addr = {destination; entrypoint = Entrypoint.default} in + (unparse_data [@tailcall]) + ctxt + ~stack_depth + mode + t + (addr, (contents, amount)) + | Set_t (t, _), set -> + List.fold_left_es + (fun (l, ctxt) item -> + unparse_comparable_data ~loc ctxt mode t item + >|=? fun (item, ctxt) -> (item :: l, ctxt)) + ([], ctxt) + (Script_set.fold (fun e acc -> e :: acc) set []) + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) + | Map_t (kt, vt, _), map -> + let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) + | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _} + when Compare.Int.( = ) size 0 -> + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) + | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} -> + let items = + Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] + in + let items = + (* Sort the items in Michelson comparison order and not in key + hash order. This code path is only exercised for tracing, + so we don't bother carbonating this sort operation + precisely. Also, the sort uses a reverse compare because + [unparse_items] will reverse the result. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + (* this can't fail if the original type is well-formed + because [option vt] is always strictly smaller than [big_map kt vt] *) + option_t loc vt >>?= fun vt -> + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> + ( Micheline.Prim + ( loc, + D_Pair, + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], + [] ), + ctxt ) + | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} -> + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> + match v with None -> acc | Some v -> (k, v) :: acc) + map + [] + in + let items = + (* See note above. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) + | Lambda_t _, Lam (_, original_code) -> + unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + | Never_t, _ -> . + | Sapling_transaction_t _, s -> + Lwt.return + ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) + >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s + in + (Bytes (loc, bytes), ctxt) ) + | Sapling_transaction_deprecated_t _, s -> + Lwt.return + ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) + >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Sapling.Legacy.transaction_encoding + s + in + (Bytes (loc, bytes), ctxt) ) + | Sapling_state_t _, {id; diff; _} -> + Lwt.return + ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> + ( (match diff with + | {commitments_and_ciphertexts = []; nullifiers = []} -> ( + match id with + | None -> Micheline.Seq (loc, []) + | Some id -> + let id = Sapling.Id.unparse_to_z id in + Micheline.Int (loc, id)) + | diff -> ( + let diff_bytes = + Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff + in + let unparsed_diff = Bytes (loc, diff_bytes) in + match id with + | None -> unparsed_diff + | Some id -> + let id = Sapling.Id.unparse_to_z id in + Micheline.Prim + (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), + ctxt ) ) + | Chest_key_t, s -> + unparse_with_data_encoding + ~loc + ctxt + s + Unparse_costs.chest_key + Script_timelock.chest_key_encoding + | Chest_t, s -> + unparse_with_data_encoding + ~loc + ctxt + s + (Unparse_costs.chest + ~plaintext_size:(Script_timelock.get_plaintext_size s)) + Script_timelock.chest_encoding + + and unparse_items : + type k v vc. + context -> + stack_depth:int -> + unparsing_mode -> + k comparable_ty -> + (v, vc) ty -> + (k * v) list -> + (Script.node list * context) tzresult Lwt.t = + fun ctxt ~stack_depth mode kt vt items -> + List.fold_left_es + (fun (l, ctxt) (k, v) -> + let loc = Micheline.dummy_location in + unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v + >|=? fun (value, ctxt) -> + (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) + ([], ctxt) + items + + and unparse_code ctxt ~stack_depth mode code = + let legacy = true in + Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> + let non_terminal_recursion ctxt mode code = + if Compare.Int.(stack_depth > 10_000) then + fail Script_tc_errors.Unparsing_too_many_recursive_calls + else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code + in + match code with + | Prim (loc, I_PUSH, [ty; data], annot) -> + P.parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + >>?= fun (Ex_ty t, ctxt) -> + let allow_forged = + false + (* Forgeable in PUSH data are already forbidden at parsing, + the only case for which this matters is storing a lambda resulting + from APPLYing a non-forgeable but this cannot happen either as long + as all packable values are also forgeable. *) + in + P.parse_data + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy + ~allow_forged + t + data + >>=? fun (data, ctxt) -> + unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data + >>=? fun (data, ctxt) -> + return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) + | Seq (loc, items) -> + List.fold_left_es + (fun (l, ctxt) item -> + non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) -> + (item :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + return (Micheline.Seq (loc, List.rev items), ctxt) + | Prim (loc, prim, items, annot) -> + List.fold_left_es + (fun (l, ctxt) item -> + non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) -> + (item :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + return (Prim (loc, prim, List.rev items, annot), ctxt) + | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) +end diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli new file mode 100644 index 0000000000000000000000000000000000000000..47ff8f3be5eb7c87decdae4c048122506ca474ad --- /dev/null +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -0,0 +1,212 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_typed_ir + +(** Flag that drives unparsing of typed values to nodes. + - [Optimized_legacy] must be kept backward-compatible in order to compute + valid hashes (of big map keys). + - [Optimized] may be used as long as the result can be read by {!Script_translator.parse_data}. + - [Readable] produces with [string] values instead of [bytes] when feasible. +*) +type unparsing_mode = Optimized | Readable | Optimized_legacy + +(** [('t, 'd) comb_witness] describes types of values belonging to a [comb] + of type ['t] and size ['d]. *) +type ('ty, 'depth) comb_witness = + | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness + | Comb_Any : (_, _) comb_witness + +(** [serialize_ty_for_error ty] returns the Micheline representation of [ty] + suitable for rendering in an error message. Does not consume gas, since + when this function is called, the operation must have already failed. *) +val serialize_ty_for_error : ('a, 'b) ty -> Script.expr + +(** [serialize_stack_for_error ctxt stack_ty] returns a Micheline representation of + [stack_ty] as a list of Micheline expressions ONLY IF gas is unlimited + in [ctxt]. Otherwise returns an empty list. *) +val serialize_stack_for_error : context -> ('a, 'b) stack_ty -> Script.expr list + +(** [unparse_ty ~loc ctxt ty] returns the Micheline representation of a given + type and an update context, where gas has been properly consumed. *) +val unparse_ty : + loc:'loc -> + context -> + ('b, 'c) ty -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_comparable_ty_uncarbonated ~loc ty] returns the Michelson + representation of comparable type [ty] without consuming gas. *) +val unparse_comparable_ty_uncarbonated : + loc:'loc -> 'a comparable_ty -> 'loc Script.michelson_node + +(** [unparse_stack_uncarbonated stack_ty] returns the Micheline representation + of [stack_ty]. Does not consume gas. *) +val unparse_stack_uncarbonated : ('a, 's) stack_ty -> Script.expr list + +(** [unparse_parameter_ty ~loc ctxt ty ~entrypoints] is a specialised version of + [unparse_ty], which also analyses [entrypoints] in order to annotate + the returned type with adequate annotations. *) +val unparse_parameter_ty : + loc:'loc -> + context -> + ('a, 'c) ty -> + entrypoints:'a entrypoints -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) +val unparse_bls12_381_g1 : + loc:'loc -> + context -> + Script_bls.G1.t -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) +val unparse_bls12_381_g2 : + loc:'loc -> + context -> + Script_bls.G2.t -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) +val unparse_bls12_381_fr : + loc:'loc -> + context -> + Script_bls.Fr.t -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_operation ~loc ctxt op] returns the Micheline representation of + [op] and consumes gas from [ctxt]. Useful only for producing execution + traces in the interpreter. *) +val unparse_operation : + loc:'loc -> + context -> + Script_typed_ir.operation -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_with_data_encoding ~loc ctxt v gas_cost enc] returns the bytes + representation of [v] wrapped in [Micheline.Bytes], consuming [gas_cost] + from [ctxt]. *) +val unparse_with_data_encoding : + loc:'loc -> + context -> + 'a -> + Gas.cost -> + 'a Data_encoding.t -> + ('loc Script.michelson_node * context, error trace) result Lwt.t + +(** [unparse_comparable_data ~loc ctxt unparsing_mode ty v] returns the + Micheline representation of [v] of type [ty], consuming gas from + [ctxt]. *) +val unparse_comparable_data : + loc:'loc -> + context -> + unparsing_mode -> + 'a comparable_ty -> + 'a -> + ('loc Script.michelson_node * context) tzresult Lwt.t + +(** [unparse_contract ~loc ctxt unparsin_mode contract] returns a Micheline + representation of a given contract in a given [unparsing_mode]. Consumes + gas [ctxt]. *) +val unparse_contract : + loc:'loc -> + context -> + unparsing_mode -> + 'b typed_contract -> + ('loc Script.michelson_node * context, error trace) result + +(** [MICHESLON_PARSER] signature describes a set of dependencies required to + unparse arbitrary values in the IR. Because some of those values contain + just a Michelson code that does not need to be parsed immediately, + unparsing them requires extracting information from that code – that's + why we depend on the parser here. *) +module type MICHELSON_PARSER = sig + type type_logger + + val opened_ticket_type : + Script.location -> + 'a comparable_ty -> + (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty + tzresult + + val parse_packable_ty : + context -> + stack_depth:int -> + legacy:bool -> + Script.node -> + (ex_ty * context) tzresult + + val parse_data : + ?type_logger:type_logger -> + stack_depth:int -> + context -> + legacy:bool -> + allow_forged:bool -> + ('a, 'ac) ty -> + Script.node -> + ('a * t) tzresult Lwt.t +end + +module Data_unparser : functor (P : MICHELSON_PARSER) -> sig + (** [unparse_data ctxt ~stack_depth unparsing_mode ty data] returns the + Micheline representation of [data] of type [ty], consuming an appropriate + amount of gas from [ctxt]. *) + val unparse_data : + context -> + stack_depth:int -> + unparsing_mode -> + ('a, 'ac) ty -> + 'a -> + (Script.node * context) tzresult Lwt.t + + (** [unparse_items ctxt ~stack_depth unparsing_mode kty vty assoc] returns the + Micheline representation of [assoc] (being an association list) with keys + of type [kty] and values of type [vty]. Gas is being consumed from + [ctxt]. *) + val unparse_items : + context -> + stack_depth:int -> + unparsing_mode -> + 'k comparable_ty -> + ('v, 'vc) ty -> + ('k * 'v) list -> + (Script.node list * context) tzresult Lwt.t + + (** [unparse_code ctxt ~stack_depth unparsing_mode code] returns [code] + with [I_PUSH] instructions parsed and unparsed back to make sure that + only forgeable values are being pushed. The gas is being consumed from + [ctxt]. *) + val unparse_code : + context -> + stack_depth:int -> + unparsing_mode -> + Script.node -> + (Script.node * context, error trace) result Lwt.t +end diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index e47943604c640e74284d6bd17af94cb3dce271ee..245dc02c3b80dbe32ad6d59a933a5381a94e3f86 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1416,6 +1416,8 @@ and operation = { lazy_storage_diff : Lazy_storage.diffs option; } +type ex_ty = Ex_ty : ('a, _) ty -> ex_ty + type ('arg, 'storage) script = | Script : { code : diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 0af068f38163302b9085be70d12101c17f00d0df..75191ba3e5863c333f6684945e1a7af548580086 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1565,6 +1565,8 @@ type ('arg, 'storage) script = } -> ('arg, 'storage) script +type ex_ty = Ex_ty : ('a, _) ty -> ex_ty + val manager_kind : 'kind internal_operation_contents -> 'kind Kind.manager val kinstr_location : (_, _, _, _) kinstr -> Script.location diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml index a9d66415bd8c2ca173ba42fade4bf6758d208600..d9a9d6af2b264af2bb8b36a2a5fcc5b8ec1db09a 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml @@ -34,7 +34,6 @@ open Protocol open Alpha_context -open Script_ir_translator open Script_typed_ir (* 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 61068795b30ad6e6f11aa392e0e3bcb492ab9a8a..d7ae5ff979e31f16be602a879e6789ce32ad5ec8 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 @@ -57,10 +57,10 @@ let string_list_of_ex_token_diffs ctxt token_diffs = (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = let* x, ctxt = wrap - @@ Script_ir_translator.unparse_comparable_data + @@ Script_ir_unparser.unparse_comparable_data ~loc:() ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable contents_type contents in @@ -124,10 +124,10 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = in let* key_node, ctxt = wrap - (Script_ir_translator.unparse_comparable_data + (Script_ir_unparser.unparse_comparable_data ~loc:Micheline.dummy_location ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable key_type key) in @@ -139,7 +139,7 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable value_type value) in @@ -200,14 +200,11 @@ let setup ctxt ~key_type ~value_type entries = in let*? key_type_node, ctxt = Environment.wrap_tzresult - @@ Script_ir_translator.unparse_ty - ~loc:Micheline.dummy_location - ctxt - key_type + @@ Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt key_type in let*? value_type_node, ctxt = Environment.wrap_tzresult - @@ Script_ir_translator.unparse_ty + @@ Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt value_type @@ -382,7 +379,7 @@ let transfer_operation ctxt ~src ~destination ~arg_type ~arg = wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable arg_type arg) in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml index d8c857b49f4263b7f7fc2f3ef46abc199fd0e46d..b5a020fb04569e6db829a86a5703717b7756622f 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml @@ -48,10 +48,10 @@ let string_list_of_ex_token_diffs ctxt token_diffs = (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = let* x, ctxt = wrap - @@ Script_ir_translator.unparse_comparable_data + @@ Script_ir_unparser.unparse_comparable_data ~loc:() ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable contents_type contents in 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 2080c05f9014a3a112e91cb3011f4af87b032b0d..5746fd1ee802794b782bc67eda7c71782ff1ff78 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 @@ -121,10 +121,10 @@ let string_of_ticket_token ctxt (Ticket_token.Ex_token {ticketer; contents_type; contents}) = let* x, _ = wrap - @@ Script_ir_translator.unparse_comparable_data + @@ Script_ir_unparser.unparse_comparable_data ctxt ~loc:() - Script_ir_translator.Readable + Script_ir_unparser.Readable contents_type contents in @@ -310,7 +310,7 @@ let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable parameters_ty parameters) in @@ -342,7 +342,7 @@ let transfer_operation_to_tx_rollup ~incr ~src ~parameters_ty ~parameters wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized_legacy + Script_ir_unparser.Optimized_legacy parameters_ty parameters) in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index 5a3ebfd37126803866b0744e4dc6fc80a72d8142..6f843eb7b1dad20afc8bfb34e38e0e3abb7163cc 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -76,7 +76,7 @@ let string_list_of_ex_tickets ctxt tickets = wrap @@ Script_ir_translator.unparse_data ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable cty contents in @@ -127,7 +127,7 @@ let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = let tickets_of_value ctxt ~include_lazy ~allow_zero_amount_tickets ~type_exp ~value_exp = - let Script_ir_translator.Ex_ty ty, ctxt = + let Script_typed_ir.Ex_ty ty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in Result.value_f ~default:(fun () -> Stdlib.failwith "Failed to parse") diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index 4c7d8f96e8458d472fca3280a6f0af715b0f1dcb..c241cdbac26ffe4458d5f8f4468e086acf063c5f 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -115,7 +115,7 @@ let test_context_with_nat_nat_big_map ?(sc_rollup_enable = false) () = wrap_error_lwt @@ Big_map.fresh ~temporary:false ctxt >>=? fun (ctxt, id) -> let nat_ty = Script_typed_ir.nat_t in wrap_error_lwt @@ Lwt.return - @@ Script_ir_translator.unparse_ty ~loc:() ctxt nat_ty + @@ Script_ir_unparser.unparse_ty ~loc:() ctxt nat_ty >>=? fun (nat_ty_node, ctxt) -> let nat_ty_expr = Micheline.strip_locations nat_ty_node in let alloc = Big_map.{key_type = nat_ty_expr; value_type = nat_ty_expr} in @@ -211,7 +211,7 @@ let test_parse_ty (type exp expc) ctxt node ~allow_contract ~allow_ticket node - >>? fun (Script_ir_translator.Ex_ty actual, ctxt) -> + >>? fun (Script_typed_ir.Ex_ty actual, ctxt) -> Gas_monad.run ctxt @@ Script_ir_translator.ty_eq ~error_details:(Informative (location node)) @@ -290,7 +290,7 @@ let test_parse_comb_type () = let test_unparse_ty loc ctxt expected ty = Environment.wrap_tzresult - ( Script_ir_translator.unparse_ty ~loc:() ctxt ty >>? fun (actual, ctxt) -> + ( Script_ir_unparser.unparse_ty ~loc:() ctxt ty >>? fun (actual, ctxt) -> if actual = expected then ok ctxt else Alcotest.failf "Unexpected error: %s" loc ) @@ -331,7 +331,7 @@ let test_unparse_comparable_ty loc ctxt expected ty = let open Script_typed_ir in Environment.wrap_tzresult ( set_t (-1) ty >>? fun set_ty_ty -> - Script_ir_translator.unparse_ty ~loc:() ctxt set_ty_ty + Script_ir_unparser.unparse_ty ~loc:() ctxt set_ty_ty >>? fun (actual, ctxt) -> if actual = Prim ((), T_set, [expected], []) then ok ctxt else Alcotest.failf "Unexpected error: %s" loc ) @@ -578,12 +578,12 @@ let test_parse_address () = let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = wrap_error_lwt - ( Script_ir_translator.unparse_data ctxt Script_ir_translator.Readable ty x + ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x >>=? fun (actual_readable, ctxt) -> (if actual_readable = expected_readable then return ctxt else Alcotest.failf "Error in readable unparsing: %s" loc) >>=? fun ctxt -> - Script_ir_translator.unparse_data ctxt Script_ir_translator.Optimized ty x + Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x >>=? fun (actual_optimized, ctxt) -> if actual_optimized = expected_optimized then return ctxt else Alcotest.failf "Error in optimized unparsing: %s" loc ) @@ -674,11 +674,7 @@ let test_optimal_comb () = in let check_optimal_comb loc ctxt ty v arity = wrap_error_lwt - ( Script_ir_translator.unparse_data - ctxt - Script_ir_translator.Optimized - ty - v + ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty v >>=? fun (unparsed, ctxt) -> let unparsed_canonical, unparsed_size = size_of_micheline unparsed in List.iter_es (fun other_repr -> diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index 24a0e83814b27aac61e5f422cf48ac51bd333bd0..bc14314945dfae5172428dddb17040d647940245 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -201,7 +201,7 @@ let verify_params ctxt ~parameters_ty ~parameters ~unparsed_parameters = wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized + Script_ir_unparser.Optimized parameters_ty parameters) in diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml index ce5313b7790479be6765956ed4b7e295ac03bcb7..aba4549d2fb66190997a09b3ef51f36f4888b97c 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml @@ -200,7 +200,7 @@ let ctxt = let unparse_comparable_ty ty = Micheline.strip_locations - (fst (assert_ok Script_ir_translator.(unparse_ty ~loc:() ctxt ty))) + (fst (assert_ok Script_ir_unparser.(unparse_ty ~loc:() ctxt ty))) let unparse_comparable_data ty x = Micheline.strip_locations diff --git a/src/proto_alpha/lib_protocol/test/regression/test_logging.ml b/src/proto_alpha/lib_protocol/test/regression/test_logging.ml index 37ed71abb6909ff09060094f1b4ce932d94967e7..b7a360e0684904d4318aee21bbe56a941fd0b23b 100644 --- a/src/proto_alpha/lib_protocol/test/regression/test_logging.ml +++ b/src/proto_alpha/lib_protocol/test/regression/test_logging.ml @@ -37,7 +37,7 @@ open Alpha_context open Tezt module Traced_interpreter = Plugin.RPC.Scripts.Traced_interpreter (struct - let unparsing_mode = Script_ir_translator.Readable + let unparsing_mode = Script_ir_unparser.Readable end) type contract = {filename : string; storage : string} diff --git a/src/proto_alpha/lib_protocol/ticket_balance_key.ml b/src/proto_alpha/lib_protocol/ticket_balance_key.ml index 81a6b28a702160f5356cb2088f7a29d49e71bc39..5251cbdb6bd2d49df0d8ff239e09f61408281071 100644 --- a/src/proto_alpha/lib_protocol/ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/ticket_balance_key.ml @@ -35,7 +35,7 @@ open Alpha_context let of_ex_token ctxt ~owner (Ticket_token.Ex_token {ticketer; contents_type; contents}) = let loc = Micheline.dummy_location in - Script_ir_translator.unparse_ty ~loc ctxt contents_type + Script_ir_unparser.unparse_ty ~loc ctxt contents_type >>?= fun (cont_ty_unstripped, ctxt) -> (* We strip the annotations from the content type in order to map tickets with the same content type, but with different annotations, to the @@ -43,10 +43,10 @@ let of_ex_token ctxt ~owner Gas.consume ctxt (Script.strip_annotations_cost cont_ty_unstripped) >>?= fun ctxt -> let ty = Script.strip_annotations cont_ty_unstripped in - Script_ir_translator.unparse_comparable_data + Script_ir_unparser.unparse_comparable_data ~loc ctxt - Script_ir_translator.Optimized_legacy + Script_ir_unparser.Optimized_legacy contents_type contents >>=? fun (contents, ctxt) -> @@ -59,13 +59,13 @@ let of_ex_token ctxt ~owner in Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized_legacy + Script_ir_unparser.Optimized_legacy Script_typed_ir.address_t ticketer_address >>=? fun (ticketer, ctxt) -> Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized_legacy + Script_ir_unparser.Optimized_legacy Script_typed_ir.address_t owner_address >>=? fun (owner, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index d2aaa66055fcd27af2d51f600dfb689d07c57279..b76f582767fe90f5f39cb3a5aa334aca9ebe569b 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -174,7 +174,7 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates We should have the non-serialized version of the value type. *) parse_value_type ctxt value_type - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun (Script_typed_ir.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> List.fold_left_es @@ -204,7 +204,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = type. It would be more efficient if the value preserved. *) parse_value_type ctxt value_ty - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun (Script_typed_ir.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> (* Iterate over big-map items. *)