From 59cccd53aa8a71136aab3489906e9090e2b197f1 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Sun, 8 Apr 2018 20:24:25 +0200 Subject: [PATCH] Michelson: cleaner naming in interpreter --- .../lib_client/client_proto_programs.ml | 4 +- .../lib_client/client_proto_programs.mli | 12 +- src/proto_alpha/lib_protocol/src/apply.ml | 19 ++- .../lib_protocol/src/helpers_services.ml | 35 +++--- .../lib_protocol/src/helpers_services.mli | 6 +- .../lib_protocol/src/script_interpreter.ml | 113 +++++++++++------- .../lib_protocol/src/script_interpreter.mli | 34 ++++-- .../test/helpers/helpers_script.ml | 8 +- .../test/helpers/helpers_script.mli | 3 +- .../lib_protocol/test/test_michelson.ml | 8 +- 10 files changed, 138 insertions(+), 104 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index f0ff024dd..f1030326b 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -43,11 +43,11 @@ let print_big_map_diff ppf = function (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf (key, value) -> - Format.fprintf ppf "%s %a%a" + Format.fprintf ppf "%s %s%a" (match value with | None -> "-" | Some _ -> "+") - print_expr key + key (fun ppf -> function | None -> () | Some x -> Format.fprintf ppf "-> %a" print_expr x) diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index 619499747..d50790e19 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -22,7 +22,7 @@ val run : input:Michelson_v1_parser.parsed -> Block_services.block -> #Proto_alpha.rpc_context -> - (Script.expr * Script.expr * (Script.expr * Script.expr option) list option) tzresult Lwt.t + (Script.expr * Script.expr * Contract.big_map_diff option) tzresult Lwt.t val trace : ?contract:Contract.t -> @@ -32,22 +32,24 @@ val trace : input:Michelson_v1_parser.parsed -> Block_services.block -> #Proto_alpha.rpc_context -> - (Script.expr * Script.expr * (int * Gas.t * Script.expr list) list * (Script.expr * Script.expr option) list option) tzresult Lwt.t + (Script.expr * Script.expr * + Script_interpreter.execution_trace * + Contract.big_map_diff option) tzresult Lwt.t val print_run_result : #Client_context.printer -> show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr * Script_repr.expr * - (Script_repr.expr * Script_repr.expr option) list option) tzresult -> unit tzresult Lwt.t + Contract.big_map_diff option) tzresult -> unit tzresult Lwt.t val print_trace_result : #Client_context.printer -> show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr * Script_repr.expr * - (int * Gas.t * Script_repr.expr list) list * - (Script_repr.expr * Script_repr.expr option) list option) + Script_interpreter.execution_trace * + Contract.big_map_diff option) tzresult -> unit tzresult Lwt.t val hash_and_sign : diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index b73ad5b2a..90443f218 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -388,21 +388,16 @@ let apply_manager_operation_content | _ -> fail (Bad_contract_parameter (destination, None, parameters)) end | Some script -> - let call_contract ctxt argument = + let call_contract ctxt parameter = Script_interpreter.execute - origination_nonce - source destination ctxt script amount argument + ctxt origination_nonce + ~source ~self:(destination, script) ~amount ~parameter >>= function - | Ok (storage_res, _res, ctxt, origination_nonce, maybe_big_map_diff) -> - begin match maybe_big_map_diff with - | None -> return (None, ctxt) - | Some map -> - Script_ir_translator.to_serializable_big_map ctxt map >>=? fun (diff, ctxt) -> - return (Some diff, ctxt) end >>=? fun (diff, ctxt) -> + | Ok { ctxt ; origination_nonce ; storage ; big_map_diff ; return_value = _ } -> Contract.update_script_storage - ctxt destination - storage_res diff >>=? fun ctxt -> - Fees.update_script_storage ctxt ~source destination >>=? fun (ctxt, fees) -> + ctxt destination storage big_map_diff >>=? fun ctxt -> + Fees.update_script_storage + ctxt ~source destination >>=? fun (ctxt, fees) -> return (ctxt, origination_nonce, None, fees) | Error err -> return (ctxt, origination_nonce, Some err, Tez.zero) in diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml index bd7232daf..7d4b64a5d 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -40,7 +40,7 @@ module S = struct ~output: (obj3 (req "storage" Script.expr_encoding) (req "output" Script.expr_encoding) - (opt "big_map_diff" (list (tup2 Script.expr_encoding (option Script.expr_encoding))))) + (opt "big_map_diff" (list (tup2 string (option Script.expr_encoding))))) RPC_path.(custom_root / "run_code") let apply_operation = @@ -71,7 +71,7 @@ module S = struct (req "location" Script.location_encoding) (req "gas" Gas.encoding) (req "stack" (list (Script.expr_encoding))))) - (opt "big_map_diff" (list (tup2 Script.expr_encoding (option Script.expr_encoding))))) + (opt "big_map_diff" (list (tup2 string (option Script.expr_encoding))))) RPC_path.(custom_root / "trace_code") let typecheck_code = @@ -179,37 +179,34 @@ let () = end ; register0 S.apply_operation I.apply_operation ; register0 S.run_code begin fun ctxt () parameters -> - let (code, storage, input, amount, contract, gas, origination_nonce) = + let (code, storage, parameter, amount, contract, gas, origination_nonce) = I.run_parameters ctxt parameters in begin if Compare.Z.(gas > Z.zero) then Lwt.return (Gas.set_limit ctxt gas) else return (Gas.set_unlimited ctxt) end >>=? fun ctxt -> Script_interpreter.execute - origination_nonce - contract (* transaction initiator *) - contract (* script owner *) - ctxt { storage ; code } amount input >>=? fun (sto, ret, _ctxt, _, maybe_big_map_diff) -> - return (sto, ret, - Option.map maybe_big_map_diff - ~f:(Script_ir_translator.to_printable_big_map ctxt)) + ctxt origination_nonce + ~source:contract (* transaction initiator *) + ~self:(contract, { storage ; code }) (* script owner *) + ~amount ~parameter + >>=? fun { Script_interpreter.storage ; return_value ; big_map_diff ; _ } -> + return (storage, return_value, big_map_diff) end ; register0 S.trace_code begin fun ctxt () parameters -> - let (code, storage, input, amount, contract, gas, origination_nonce) = + let (code, storage, parameter, amount, contract, gas, origination_nonce) = I.run_parameters ctxt parameters in begin if Compare.Z.(gas > Z.zero) then Lwt.return (Gas.set_limit ctxt gas) else return (Gas.set_unlimited ctxt) end >>=? fun ctxt -> Script_interpreter.trace - origination_nonce - contract (* transaction initiator *) - contract (* script owner *) - ctxt { storage ; code } amount input - >>=? fun ((sto, ret, _ctxt, _, maybe_big_map_diff), trace) -> - return (sto, ret, trace, - Option.map maybe_big_map_diff - ~f:(Script_ir_translator.to_printable_big_map ctxt)) + ctxt origination_nonce + ~source:contract (* transaction initiator *) + ~self:(contract, { storage ; code }) (* script owner *) + ~amount ~parameter + >>=? fun ({ Script_interpreter.storage ; return_value ; big_map_diff ; _ }, trace) -> + return (storage, return_value, trace, big_map_diff) end ; register0 S.typecheck_code begin fun ctxt () (expr, maybe_gas) -> begin match maybe_gas with diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.mli b/src/proto_alpha/lib_protocol/src/helpers_services.mli index ba21f05b0..1295d8a08 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.mli +++ b/src/proto_alpha/lib_protocol/src/helpers_services.mli @@ -25,15 +25,15 @@ val run_code: 'a #RPC_context.simple -> 'a -> Script.expr -> (Script.expr * Script.expr * Tez.t * Contract.t) -> - (Script.expr * Script.expr * (Script.expr * Script.expr option) list option) shell_tzresult Lwt.t + (Script.expr * Script.expr * Contract.big_map_diff option) shell_tzresult Lwt.t val trace_code: 'a #RPC_context.simple -> 'a -> Script.expr -> (Script.expr * Script.expr * Tez.t * Contract.t) -> (Script.expr * Script.expr * - (Script.location * Gas.t * Script.expr list) list * - (Script.expr * Script.expr option) list option) shell_tzresult Lwt.t + Script_interpreter.execution_trace * + Contract.big_map_diff option) shell_tzresult Lwt.t val typecheck_code: 'a #RPC_context.simple -> diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index fc02a22e9..b4251c878 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -76,13 +76,17 @@ let unparse_stack ctxt (stack, stack_ty) = module Interp_costs = Michelson_v1_gas.Cost_of +type execution_trace = + (Script.location * Gas.t * Script.expr list) list + let rec interp : type p r. - ?log: (Script.location * Gas.t * Script.expr list) list ref -> - Contract.origination_nonce -> Contract.t -> Contract.t -> Tez.t -> - context -> (p, r) lambda -> p -> - (r * context * Contract.origination_nonce) tzresult Lwt.t - = fun ?log origination orig source amount ctxt (Lam (code, _)) arg -> + (?log: execution_trace ref -> + context -> Contract.origination_nonce -> + source: Contract.t -> self: Contract.t -> Tez.t -> + (p, r) lambda -> p -> + (r * context * Contract.origination_nonce) tzresult Lwt.t) + = fun ?log ctxt origination ~source ~self amount (Lam (code, _)) arg -> let rec step : type b a. Contract.origination_nonce -> context -> (b, a) descr -> b stack -> @@ -165,14 +169,14 @@ let rec interp Prim (0, K_code, [ Micheline.root code ], None) ], None)) in Lwt.return @@ unparse_data ctxt storage_type init >>=? fun (storage, ctxt) -> let storage = Micheline.strip_locations storage in - Contract.spend_from_script ctxt source credit >>=? fun ctxt -> + Contract.spend_from_script ctxt self credit >>=? fun ctxt -> Contract.originate ctxt origination ~manager ~delegate ~balance:credit ~script:({ code ; storage }, None (* TODO: initialize a big map from a map *)) ~spendable ~delegatable >>=? fun (ctxt, contract, origination) -> - Fees.origination_burn ctxt ~source:orig contract >>=? fun ctxt -> + Fees.origination_burn ctxt ~source contract >>=? fun ctxt -> logged_return descr ~origination (Item ((param_type, return_type, contract), rest), ctxt) in let logged_return : ?origination:Contract.origination_nonce -> a stack * context -> @@ -247,7 +251,7 @@ let rec interp match l with | [] -> return (List.rev acc, ctxt, origination) | hd :: tl -> - interp ?log origination orig source amount ctxt lam hd + interp ?log ctxt origination ~source ~self amount lam hd >>=? fun (hd, ctxt, origination) -> loop rest ctxt origination tl (hd :: acc) in loop rest ctxt origination l [] >>=? fun (res, ctxt, origination) -> @@ -269,7 +273,7 @@ let rec interp match l with | [] -> return (acc, ctxt, origination) | hd :: tl -> - interp ?log origination orig source amount ctxt lam (hd, acc) + interp ?log ctxt origination ~source ~self amount lam (hd, acc) >>=? fun (acc, ctxt, origination) -> loop rest ctxt origination tl acc in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> @@ -306,7 +310,7 @@ let rec interp match l with | [] -> return (acc, ctxt, origination) | hd :: tl -> - interp ?log origination orig source amount ctxt lam (hd, acc) + interp ?log ctxt origination ~source ~self amount lam (hd, acc) >>=? fun (acc, ctxt, origination) -> loop rest ctxt origination tl acc in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> @@ -342,7 +346,7 @@ let rec interp match l with | [] -> return (acc, ctxt, origination) | (k, _) as hd :: tl -> - interp ?log origination orig source amount ctxt lam hd + interp ?log ctxt origination ~source ~self amount lam hd >>=? fun (hd, ctxt, origination) -> loop rest ctxt origination tl (map_update k (Some hd) acc) in loop rest ctxt origination l (empty_map (map_key_ty map)) >>=? fun (res, ctxt, origination) -> @@ -355,7 +359,7 @@ let rec interp match l with | [] -> return (acc, ctxt, origination) | hd :: tl -> - interp ?log origination orig source amount ctxt lam (hd, acc) + interp ?log ctxt origination ~source ~self amount lam (hd, acc) >>=? fun (acc, ctxt, origination) -> loop rest ctxt origination tl acc in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> @@ -384,11 +388,11 @@ let rec interp (* Big map operations *) | Big_map_mem, Item (key, Item (map, rest)) -> Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_mem ctxt source key map >>=? fun (res, ctxt) -> + Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt) | Big_map_get, Item (key, Item (map, rest)) -> Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_get ctxt source key map >>=? fun (res, ctxt) -> + Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt) | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> consume_gas_terop descr @@ -579,7 +583,7 @@ let rec interp logged_return ~origination (Item (ign, res), ctxt) | Exec, Item (arg, Item (lam, rest)) -> Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> - interp ?log origination orig source amount ctxt lam arg >>=? fun (res, ctxt, origination) -> + interp ?log ctxt origination ~source ~self amount lam arg >>=? fun (res, ctxt, origination) -> logged_return ~origination (Item (res, rest), ctxt) | Lambda lam, rest -> Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> @@ -643,7 +647,7 @@ let rec interp | Transfer_tokens storage_type, Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (storage, Empty)))) -> begin Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> - Contract.spend_from_script ctxt source amount >>=? fun ctxt -> + Contract.spend_from_script ctxt self amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.get_script ctxt destination >>=? fun (ctxt, destination_script) -> Lwt.return (unparse_data ctxt storage_type storage) >>=? fun (sto, ctxt) -> @@ -655,8 +659,8 @@ let rec interp Script_ir_translator.to_serializable_big_map ctxt diff >>=? fun (diff, ctxt) -> return (Some diff, ctxt) end >>=? fun (diff, ctxt) -> - Contract.update_script_storage ctxt source sto diff >>=? fun ctxt -> - Fees.update_script_storage ctxt ~source:orig source >>=? fun (ctxt, _) -> + Contract.update_script_storage ctxt self sto diff >>=? fun ctxt -> + Fees.update_script_storage ctxt ~source self >>=? fun (ctxt, _) -> begin match destination_script with | None -> (* we see non scripted contracts as (unit, unit) contract *) @@ -665,7 +669,8 @@ let rec interp return (ctxt, origination) | Some script -> Lwt.return @@ unparse_data ctxt tp p >>=? fun (p, ctxt) -> - execute origination source destination ctxt script amount p + (* FIXME: add a sender parameter *) + execute ctxt origination ~source ~self:destination script amount p >>=? fun (csto, ret, ctxt, origination, maybe_diff) -> begin match maybe_diff with | None -> @@ -678,10 +683,10 @@ let rec interp trace (Invalid_contract (loc, destination)) (parse_data ctxt Unit_t ret) >>=? fun ((), ctxt) -> - Fees.update_script_storage ctxt ~source:orig destination >>=? fun (ctxt, _) -> + Fees.update_script_storage ctxt ~source destination >>=? fun (ctxt, _) -> return (ctxt, origination) end >>=? fun (ctxt, origination) -> - Contract.get_script ctxt source >>=? (fun (ctxt, script) -> match script with + Contract.get_script ctxt self >>=? (fun (ctxt, script) -> match script with | None -> assert false | Some { storage; _ } -> parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) -> @@ -690,7 +695,7 @@ let rec interp | Transfer_tokens storage_type, Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> - Contract.spend_from_script ctxt source amount >>=? fun ctxt -> + Contract.spend_from_script ctxt self amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with | None -> fail (Invalid_contract (loc, destination)) @@ -704,10 +709,10 @@ let rec interp end >>=? fun (maybe_diff, ctxt) -> Lwt.return (unparse_data ctxt storage_type sto) >>=? fun (sto, ctxt) -> let sto = Micheline.strip_locations sto in - Contract.update_script_storage ctxt source sto maybe_diff >>=? fun ctxt -> - Fees.update_script_storage ctxt ~source:orig source >>=? fun (ctxt, _) -> + Contract.update_script_storage ctxt self sto maybe_diff >>=? fun ctxt -> + Fees.update_script_storage ctxt ~source self >>=? fun (ctxt, _) -> Lwt.return (unparse_data ctxt tp p) >>=? fun (p, ctxt) -> - execute origination source destination ctxt script amount p + execute ctxt origination ~source ~self:destination script amount p >>=? fun (sto, ret, ctxt, origination, maybe_diff) -> begin match maybe_diff with | None -> @@ -717,11 +722,11 @@ let rec interp return (Some diff, ctxt) end >>=? fun (diff, ctxt) -> Contract.update_script_storage ctxt destination sto diff >>=? fun ctxt -> - Fees.update_script_storage ctxt ~source:orig destination >>=? fun (ctxt, _) -> + Fees.update_script_storage ctxt ~source destination >>=? fun (ctxt, _) -> trace (Invalid_contract (loc, destination)) (parse_data ctxt tr ret) >>=? fun (v, ctxt) -> - Contract.get_script ctxt source >>=? (fun (ctxt, script) -> match script with + Contract.get_script ctxt self >>=? (fun (ctxt, script) -> match script with | None -> assert false | Some { storage ; _ } -> parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) -> @@ -730,7 +735,7 @@ let rec interp | Create_account, Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - Contract.spend_from_script ctxt source credit >>=? fun ctxt -> + Contract.spend_from_script ctxt self credit >>=? fun ctxt -> Lwt.return Tez.(credit -? Constants.origination_burn ctxt) >>=? fun balance -> Contract.originate ctxt origination @@ -763,7 +768,7 @@ let rec interp ~param_type ~return_type ~storage_type ~rest | Balance, rest -> Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> - Contract.get_balance ctxt source >>=? fun balance -> + Contract.get_balance ctxt self >>=? fun balance -> logged_return (Item (balance, rest), ctxt) | Now, rest -> Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> @@ -789,10 +794,10 @@ let rec interp logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) | Source (ta, tb), rest -> Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item ((ta, tb, orig), rest), ctxt) + logged_return (Item ((ta, tb, source), rest), ctxt) | Self (ta, tb), rest -> Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> - logged_return (Item ((ta, tb, source), rest), ctxt) + logged_return (Item ((ta, tb, self), rest), ctxt) | Amount, rest -> Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> logged_return (Item (amount, rest), ctxt) in @@ -807,28 +812,50 @@ let rec interp (* ---- contract handling ---------------------------------------------------*) -and execute ?log origination orig source ctxt script amount arg : +and execute ?log ctxt origination_nonce ~source ~self script amount arg : (Script.expr * Script.node * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) tzresult Lwt.t = parse_script ctxt script >>=? fun ((Ex_script { code; arg_type; ret_type; storage; storage_type }), ctxt) -> parse_data ctxt arg_type arg >>=? fun (arg, ctxt) -> trace - (Runtime_contract_error (source, script.code)) - (interp ?log origination orig source amount ctxt code (arg, storage)) + (Runtime_contract_error (self, script.code)) + (interp ?log ctxt origination_nonce ~source ~self amount code (arg, storage)) >>=? fun ((ret, sto), ctxt, origination) -> Lwt.return @@ unparse_data ctxt storage_type sto >>=? fun (storage, ctxt) -> Lwt.return @@ unparse_data ctxt ret_type ret >>=? fun (ret, ctxt) -> return (Micheline.strip_locations storage, ret, ctxt, origination, Script_ir_translator.extract_big_map storage_type sto) -let trace origination orig source ctxt script amount arg = - let log = ref [] in - execute ~log origination orig source ctxt script amount (Micheline.root arg) - >>=? fun (sto, res, ctxt, origination, maybe_big_map) -> - return ((sto, Micheline.strip_locations res, ctxt, origination, maybe_big_map), List.rev !log) +type execution_result = + { ctxt : context ; + origination_nonce : Contract.origination_nonce ; + storage : Script.expr ; + big_map_diff : Contract.big_map_diff option ; + return_value : Script.expr } -let execute origination orig source ctxt script amount arg = - execute origination orig source ctxt script amount (Micheline.root arg) - >>=? fun (sto, res, ctxt, origination, maybe_big_map) -> - return (sto, Micheline.strip_locations res, ctxt, origination, maybe_big_map) +let trace ctxt origination_nonce ~source ~self:(self, script) ~parameter ~amount = + let log = ref [] in + execute ~log ctxt origination_nonce ~source ~self script amount (Micheline.root parameter) + >>=? fun (storage, return_value, ctxt, origination_nonce, big_map_diff) -> + let return_value = Micheline.strip_locations return_value in + begin match big_map_diff with + | None -> return (None, ctxt) + | Some big_map_diff -> + Script_ir_translator.to_serializable_big_map ctxt big_map_diff >>=? fun (big_map_diff, ctxt) -> + return (Some big_map_diff, ctxt) + end >>=? fun (big_map_diff, ctxt) -> + let trace = List.rev !log in + return ({ ctxt ; origination_nonce ; storage ; big_map_diff ; return_value }, trace) + +let execute ctxt origination_nonce ~source ~self:(self, script) ~parameter ~amount = + execute ctxt origination_nonce ~source ~self script amount (Micheline.root parameter) + >>=? fun (storage, return_value, ctxt, origination_nonce, big_map_diff) -> + let return_value = Micheline.strip_locations return_value in + begin match big_map_diff with + | None -> return (None, ctxt) + | Some big_map_diff -> + Script_ir_translator.to_serializable_big_map ctxt big_map_diff >>=? fun (big_map_diff, ctxt) -> + return (Some big_map_diff, ctxt) + end >>=? fun (big_map_diff, ctxt) -> + return { ctxt ; origination_nonce ; storage ; big_map_diff ; return_value } diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.mli b/src/proto_alpha/lib_protocol/src/script_interpreter.mli index 6b515767c..fe563660d 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.mli @@ -13,18 +13,28 @@ type error += Overflow of Script.location type error += Reject of Script.location type error += Runtime_contract_error : Contract.t * Script.expr -> error +type execution_result = + { ctxt : context ; + origination_nonce : Contract.origination_nonce ; + storage : Script.expr ; + big_map_diff : Contract.big_map_diff option ; + return_value : Script.expr } + val execute: - Contract.origination_nonce -> - Contract.t -> Contract.t -> Alpha_context.t -> - Script.t -> Tez.t -> - Script.expr -> - (Script.expr * Script.expr * context * Contract.origination_nonce * - Script_typed_ir.ex_big_map option) tzresult Lwt.t + Alpha_context.t -> Contract.origination_nonce -> + source: Contract.t -> + self: (Contract.t * Script.t) -> + parameter: Script.expr -> + amount: Tez.t -> + execution_result tzresult Lwt.t + +type execution_trace = + (Script.location * Gas.t * Script.expr list) list val trace: - Contract.origination_nonce -> - Contract.t -> Contract.t -> Alpha_context.t -> - Script.t -> Tez.t -> - Script.expr -> - ((Script.expr * Script.expr * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) * - (Script.location * Gas.t * Script.expr list) list) tzresult Lwt.t + Alpha_context.t -> Contract.origination_nonce -> + source: Contract.t -> + self: (Contract.t * Script.t) -> + parameter: Script.expr -> + amount: Tez.t -> + (execution_result * execution_trace) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml index 0d98d734e..50ab3a118 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml @@ -14,7 +14,7 @@ open Alpha_context let init_amount = 20000 let execute_code_pred - ?tc (pred : Helpers_block.result) (script : Script.t) (argument : Script.expr) = + ?tc (pred : Helpers_block.result) (script : Script.t) (parameter : Script.expr) = let op = List.nth Helpers_account.bootstrap_accounts 0 in let tc = Option.unopt ~default:pred.tezos_context tc in Helpers_apply.script_origination_pred ~tc ~pred (script, op, init_amount) @@ -32,8 +32,10 @@ let execute_code_pred let amount = Tez.zero in Lwt.return (Proto_alpha.Alpha_context.Gas.set_limit tc gas) >>=? fun tc -> let return = Script_interpreter.execute - dummy_nonce op.contract dst - tc script amount argument in + tc dummy_nonce + ~source: op.contract + ~self: (dst, script) + ~amount ~parameter in return diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli index b5d03573e..0ca097eb5 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli @@ -13,6 +13,5 @@ open Alpha_context val init_amount : int val execute_code_pred : ?tc:Alpha_context.t -> Helpers_block.result -> Script.t -> Script.expr -> - (Script.expr * Script.expr * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) - proto_tzresult Lwt.t + Script_interpreter.execution_result proto_tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/test_michelson.ml b/src/proto_alpha/lib_protocol/test/test_michelson.ml index 030eeb242..8a0a7e81b 100644 --- a/src/proto_alpha/lib_protocol/test/test_michelson.ml +++ b/src/proto_alpha/lib_protocol/test/test_michelson.ml @@ -48,9 +48,11 @@ let quote s = "\"" ^ s ^ "\"" let parse_execute sb ?tc code_str param_str storage_str = let param = parse_param param_str in let script = parse_script code_str storage_str in - Script.execute_code_pred ?tc sb script param >>=?? fun (ret, st, tc, nonce, bgm) -> + Script.execute_code_pred ?tc sb script param + >>=?? fun { return_value = ret ; storage = st ; ctxt = tc ; + origination_nonce = nonce ; big_map_diff = bgm } -> let contracts = Contract.originated_contracts nonce in - return (ret, st, tc, contracts, bgm) + return (st, ret, tc, contracts, bgm) let test ctxt ?tc (file_name: string) (storage: string) (input: string) = let full_path = contract_path // file_name ^ ".tz" in @@ -436,7 +438,7 @@ let test_example () = let contract = List.hd cs in Proto_alpha.Alpha_context.Contract.get_script tc contract >>=?? fun (_, res) -> let script = Option.unopt_exn (Failure "get_script") res in - Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun (_, ret, _, _, _) -> + Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun { return_value = ret } -> Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ; (* Test IMPLICIT_ACCOUNT *)