From 4fd2b038323e6e726253ec1713daed3e2b960bb0 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Sat, 24 Mar 2018 02:03:03 +0100 Subject: [PATCH] Alpha, Michelson: thread the gas directly in the context --- src/bin_client/test/test_contracts.sh | 2 +- .../lib_client/client_proto_programs.ml | 5 +- .../lib_client/client_proto_programs.mli | 7 +- .../client_proto_programs_commands.ml | 19 +- .../lib_protocol/src/TEZOS_PROTOCOL | 2 +- .../lib_protocol/src/alpha_context.ml | 7 + .../lib_protocol/src/alpha_context.mli | 30 + src/proto_alpha/lib_protocol/src/apply.ml | 112 +- src/proto_alpha/lib_protocol/src/gas.ml | 153 --- src/proto_alpha/lib_protocol/src/gas_repr.ml | 100 ++ .../src/{gas.mli => gas_repr.mli} | 46 +- .../lib_protocol/src/helpers_services.ml | 52 +- .../lib_protocol/src/helpers_services.mli | 6 +- .../lib_protocol/src/michelson_v1_gas.ml | 1 - .../lib_protocol/src/michelson_v1_gas.mli | 1 - .../lib_protocol/src/raw_context.ml | 11 + .../lib_protocol/src/raw_context.mli | 5 + .../lib_protocol/src/script_interpreter.ml | 786 ++++++------ .../lib_protocol/src/script_interpreter.mli | 8 +- .../lib_protocol/src/script_ir_translator.ml | 1080 +++++++++-------- .../lib_protocol/src/script_ir_translator.mli | 36 +- .../src/script_tc_errors_registration.ml | 10 +- .../test/helpers/helpers_script.ml | 5 +- .../test/helpers/helpers_script.mli | 2 +- .../lib_protocol/test/test_big_maps.ml | 8 +- .../lib_protocol/test/test_michelson.ml | 10 +- 26 files changed, 1274 insertions(+), 1230 deletions(-) delete mode 100644 src/proto_alpha/lib_protocol/src/gas.ml create mode 100644 src/proto_alpha/lib_protocol/src/gas_repr.ml rename src/proto_alpha/lib_protocol/src/{gas.mli => gas_repr.mli} (52%) diff --git a/src/bin_client/test/test_contracts.sh b/src/bin_client/test/test_contracts.sh index 5b0b68089..ef87464bf 100755 --- a/src/bin_client/test/test_contracts.sh +++ b/src/bin_client/test/test_contracts.sh @@ -208,7 +208,7 @@ assert_output $contract_dir/exec_concat.tz Unit '""' '"_abc"' assert_output $contract_dir/exec_concat.tz Unit '"test"' '"test_abc"' # Get current steps to quota -assert_output $contract_dir/steps_to_quota.tz Unit Unit 39973 +assert_output $contract_dir/steps_to_quota.tz Unit Unit 39968 # Get the current balance of the contract assert_output $contract_dir/balance.tz Unit Unit '"4,000,000"' diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 871b0eafe..f0ff024dd 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -134,7 +134,7 @@ let typecheck_program ?gas (program : Michelson_v1_parser.parsed) block cctxt = Alpha_services.Helpers.typecheck_code cctxt block (program.expanded, gas) let print_typecheck_result - ~emacs ~show_types ~print_source_on_error ~original_gas + ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then let type_map, errs, _gas = match res with @@ -154,8 +154,7 @@ let print_typecheck_result match res with | Ok (type_map, gas) -> let program = Michelson_v1_printer.inject_types type_map program in - cctxt#message "@[Well typed@,Gas used: %a@,Gas remaining: %a@]" - Gas.pp (Gas.used ~original:original_gas ~current:gas) + cctxt#message "@[Well typed@,Gas remaining: %a@]" Gas.pp gas >>= fun () -> if show_types then cctxt#message "%a" Micheline_printer.print_expr program >>= fun () -> diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index 5867cc4df..1afa7e93d 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -51,7 +51,7 @@ val print_trace_result : tzresult -> unit tzresult Lwt.t val hash_and_sign : - ?gas:Gas.t -> + ?gas:int -> Michelson_v1_parser.parsed -> Michelson_v1_parser.parsed -> Client_keys.sk_uri -> @@ -60,7 +60,7 @@ val hash_and_sign : (string * string * Gas.t) tzresult Lwt.t val typecheck_data : - ?gas:Proto_alpha.Gas.t -> + ?gas:int -> data:Michelson_v1_parser.parsed -> ty:Michelson_v1_parser.parsed -> 'a -> @@ -68,7 +68,7 @@ val typecheck_data : Gas.t tzresult Lwt.t val typecheck_program : - ?gas:Gas.t -> + ?gas:int -> Michelson_v1_parser.parsed -> Block_services.block -> #Proto_alpha.rpc_context -> @@ -78,7 +78,6 @@ val print_typecheck_result : emacs:bool -> show_types:bool -> print_source_on_error:bool -> - original_gas:Gas.t -> Michelson_v1_parser.parsed -> (Script_tc_errors.type_map * Gas.t) tzresult -> #Client_context.printer -> diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index 647c593bb..5c6a1bb43 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -50,12 +50,12 @@ let commands () = (parameter (fun _ctx str -> try - return @@ Proto_alpha.Gas.of_int @@ int_of_string str + return (int_of_string str) with _ -> failwith "Invalid gas literal: '%s'" str)) in let resolve_max_gas ctxt block = function | None -> Alpha_services.Constants.max_gas ctxt block >>=? fun gas -> - return @@ Proto_alpha.Gas.of_int gas + return gas | Some gas -> return gas in let data_parameter = Clic.parameter (fun _ data -> @@ -129,7 +129,6 @@ let commands () = resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program ~gas:original_gas program cctxt#block cctxt >>= fun res -> print_typecheck_result - ~original_gas ~emacs:emacs_mode ~show_types ~print_source_on_error:(not no_print_source) @@ -164,9 +163,8 @@ let commands () = resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas -> Client_proto_programs.typecheck_data ~gas:original_gas ~data ~ty cctxt#block cctxt >>= function | Ok gas -> - cctxt#message "@[Well typed@,Gas used: %a@,Gas remaining: %a@]" - Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:original_gas ~current:gas) - Proto_alpha.Gas.pp gas >>= fun () -> + cctxt#message "@[Well typed@,Gas remaining: %a@]" + Proto_alpha.Alpha_context.Gas.pp gas >>= fun () -> return () | Error errs -> cctxt#warning "%a" @@ -193,8 +191,8 @@ let commands () = Alpha_services.Helpers.hash_data cctxt cctxt#block (data.expanded, typ.expanded, Some original_gas) >>= function | Ok (hash, remaining_gas) -> - cctxt#message "%S@,Gas used: %a" hash - Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:original_gas ~current:remaining_gas) >>= fun () -> + cctxt#message "%S@,Gas remaining: %a" hash + Proto_alpha.Alpha_context.Gas.pp remaining_gas >>= fun () -> return () | Error errs -> cctxt#warning "%a" @@ -225,10 +223,9 @@ let commands () = resolve_max_gas cctxt cctxt#block gas >>=? fun gas -> Client_proto_programs.hash_and_sign ~gas data typ sk cctxt#block cctxt >>= begin function | Ok (hash, signature, current_gas) -> - cctxt#message "@[Hash: %S@,Signature: %S@,Gas used: %a@,Remaining gas: %a@]" + cctxt#message "@[Hash: %S@,Signature: %S@,Remaining gas: %a@]" hash signature - Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:gas ~current:current_gas) - Proto_alpha.Gas.pp current_gas + Proto_alpha.Alpha_context.Gas.pp current_gas | Error errs -> cctxt#warning "%a" (Michelson_v1_error_reporter.report_errors diff --git a/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL index 1bd186fa2..6d2f2d40f 100644 --- a/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL @@ -20,6 +20,7 @@ "Cycle_repr", "Level_repr", "Seed_repr", + "Gas_repr", "Script_int_repr", "Script_timestamp_repr", "Michelson_v1_primitives", @@ -55,7 +56,6 @@ "Script_typed_ir", "Fees", - "Gas", "Script_tc_errors", "Michelson_v1_gas", "Script_ir_translator", diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.ml b/src/proto_alpha/lib_protocol/src/alpha_context.ml index 1248e4aed..010805b41 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/src/alpha_context.ml @@ -61,6 +61,13 @@ end module Voting_period = Voting_period_repr +module Gas = struct + include Gas_repr + let set_limit = Raw_context.set_gas_limit + let set_unlimited = Raw_context.set_gas_unlimited + let consume = Raw_context.consume_gas + let level = Raw_context.gas_level +end module Level = struct include Level_repr include Level_storage diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index 1b268b2a7..2aa0c0eaa 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -106,6 +106,36 @@ module Cycle : sig end +module Gas : sig + type t = private + | Unaccounted + | Limited of { remaining : int } + + val encoding : t Data_encoding.encoding + val pp : Format.formatter -> t -> unit + + type cost + + val cost_encoding : cost Data_encoding.encoding + val pp_cost : Format.formatter -> cost -> unit + + type error += Quota_exceeded + + val free : cost + val step_cost : int -> cost + val alloc_cost : int -> cost + val alloc_bytes_cost : int -> cost + val alloc_bits_cost : int -> cost + + val ( *@ ) : int -> cost -> cost + val ( +@ ) : cost -> cost -> cost + + val set_limit: context -> int -> context + val set_unlimited: context -> context + val consume: context -> cost -> context tzresult + val level: context -> t +end + module Script_int : module type of Script_int_repr module Script_timestamp : sig diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index 73bf10464..3c9c68f5c 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -371,67 +371,67 @@ let apply_amendment_operation_content ctxt delegate = function let apply_manager_operation_content ctxt origination_nonce source = function | Reveal _ -> return (ctxt, origination_nonce, None) - | Transaction { amount ; parameters ; destination } -> begin - Contract.spend ctxt source amount >>=? fun ctxt -> - Contract.credit ctxt destination amount >>=? fun ctxt -> - Contract.get_script ctxt destination >>=? function - | None -> begin - match parameters with - | None -> - return (ctxt, origination_nonce, None) - | Some arg -> - match Micheline.root arg with - | Prim (_, D_Unit, [], _) -> - return (ctxt, origination_nonce, None) - | _ -> fail (Bad_contract_parameter (destination, None, parameters)) - end - | Some script -> - let gas = Gas.of_int (Constants.max_gas ctxt) in - let call_contract argument gas = - Script_interpreter.execute - origination_nonce - source destination ctxt script amount argument - gas - >>= function - | Ok (storage_res, _res, gas, ctxt, origination_nonce, maybe_big_map_diff) -> - begin match maybe_big_map_diff with - | None -> return (None, gas) - | Some map -> - Script_ir_translator.to_serializable_big_map gas map >>=? fun (diff, gas) -> - return (Some diff, gas) end >>=? fun (diff, _gas) -> - Contract.update_script_storage - ctxt destination - storage_res diff >>=? fun ctxt -> - Fees.update_script_storage ctxt ~source - destination Script_interpreter.dummy_storage_fee >>=? fun ctxt -> + | Transaction { amount ; parameters ; destination } -> + let ctxt = Gas.set_limit ctxt (Constants.max_gas ctxt) in + begin + Contract.spend ctxt source amount >>=? fun ctxt -> + Contract.credit ctxt destination amount >>=? fun ctxt -> + Contract.get_script ctxt destination >>=? function + | None -> begin + match parameters with + | None -> return (ctxt, origination_nonce, None) - | Error err -> - return (ctxt, origination_nonce, Some err) in - Lwt.return @@ Script_ir_translator.parse_toplevel gas script.code >>=? fun ((arg_type, _, _, _), gas) -> - let arg_type = Micheline.strip_locations arg_type in - match parameters, Micheline.root arg_type with - | None, Prim (_, T_unit, _, _) -> - call_contract (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))) gas - | Some parameters, _ -> begin - Script_ir_translator.typecheck_data ctxt gas (parameters, arg_type) >>= function - | Ok gas -> call_contract parameters gas - | Error errs -> - let err = Bad_contract_parameter (destination, Some arg_type, Some parameters) in - return (ctxt, origination_nonce, Some ((err :: errs))) - end - | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None)) - end + | Some arg -> + match Micheline.root arg with + | Prim (_, D_Unit, [], _) -> + return (ctxt, origination_nonce, None) + | _ -> fail (Bad_contract_parameter (destination, None, parameters)) + end + | Some script -> + let call_contract ctxt argument = + Script_interpreter.execute + origination_nonce + source destination ctxt script amount argument + >>= 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) -> + Contract.update_script_storage + ctxt destination + storage_res diff >>=? fun ctxt -> + Fees.update_script_storage ctxt ~source + destination Script_interpreter.dummy_storage_fee >>=? fun ctxt -> + return (ctxt, origination_nonce, None) + | Error err -> + return (ctxt, origination_nonce, Some err) in + Lwt.return @@ Script_ir_translator.parse_toplevel ctxt script.code >>=? fun ((arg_type, _, _, _), ctxt) -> + let arg_type = Micheline.strip_locations arg_type in + match parameters, Micheline.root arg_type with + | None, Prim (_, T_unit, _, _) -> + call_contract ctxt (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))) + | Some parameters, _ -> begin + Script_ir_translator.typecheck_data ctxt (parameters, arg_type) >>= function + | Ok ctxt -> call_contract ctxt parameters + | Error errs -> + let err = Bad_contract_parameter (destination, Some arg_type, Some parameters) in + return (ctxt, origination_nonce, Some ((err :: errs))) + end + | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None)) + end | Origination { manager ; delegate ; script ; spendable ; delegatable ; credit } -> - let gas = Gas.of_int (Constants.max_gas ctxt) in + let ctxt = Gas.set_limit ctxt (Constants.max_gas ctxt) in begin match script with - | None -> return (None, None, gas) + | None -> return (None, None, ctxt) | Some script -> - Script_ir_translator.parse_script ctxt gas script >>=? fun (_, gas) -> - Script_ir_translator.erase_big_map_initialization ctxt gas script >>=? fun (script, big_map_diff, gas) -> + Script_ir_translator.parse_script ctxt script >>=? fun (_, ctxt) -> + Script_ir_translator.erase_big_map_initialization ctxt script >>=? fun (script, big_map_diff, ctxt) -> return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee)), - big_map_diff, gas) - end >>=? fun (script, big_map, _gas) -> + big_map_diff, ctxt) + end >>=? fun (script, big_map, ctxt) -> Contract.spend ctxt source credit >>=? fun ctxt -> Contract.originate ctxt origination_nonce @@ -488,6 +488,7 @@ let apply_sourced_operation ctxt origination_nonce source content) (ctxt, origination_nonce, None) contents >>=? fun (ctxt, origination_nonce, err) -> + let ctxt = Gas.set_unlimited ctxt in return (ctxt, origination_nonce, err) | Consensus_operation content -> apply_consensus_operation_content ctxt @@ -615,6 +616,7 @@ let apply_anonymous_operation ctxt _delegate origination_nonce kind = let apply_operation ctxt delegate pred_block block_prio hash operation = + let ctxt = Gas.set_unlimited ctxt in match operation.contents with | Anonymous_operations ops -> let origination_nonce = Contract.initial_origination_nonce hash in diff --git a/src/proto_alpha/lib_protocol/src/gas.ml b/src/proto_alpha/lib_protocol/src/gas.ml deleted file mode 100644 index a68c2de77..000000000 --- a/src/proto_alpha/lib_protocol/src/gas.ml +++ /dev/null @@ -1,153 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2016. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -type t = { remaining : int } [@@unboxed] - -type cost = - { allocations : int ; - steps : int } - -let encoding = - let open Data_encoding in - conv - (fun { remaining } -> - (remaining)) - (fun (remaining) -> - { remaining }) - int31 - -let pp ppf { remaining } = - Format.pp_print_int ppf remaining - -let of_int remaining = { remaining } - -let remaining { remaining } = remaining - -(* Maximum gas representable on a 64 bit system *) -let max_gas = of_int 4611686018427387903 - -let encoding_cost = - let open Data_encoding in - conv - (fun { allocations ; steps } -> - (allocations, steps)) - (fun (allocations, steps) -> - { allocations ; steps }) - (obj2 - (req "allocations" int31) - (req "steps" int31)) - -let pp_cost ppf { allocations ; steps } = - Format.fprintf ppf - "(steps: %d, allocs: %d)" - steps allocations - -type error += Quota_exceeded - -let check_error gas = - if Compare.Int.(gas.remaining <= 0) - then error Quota_exceeded - else ok () - -let check gas = - Lwt.return @@ check_error gas - -let used ~original ~current = - { remaining = original.remaining - current.remaining } - -let consume t cost = - { remaining = - t.remaining - - 2 * cost.allocations - - 1 * cost.steps } - -let consume_check gas cost = - let gas = consume gas cost in - check gas >>|? fun () -> - gas - -let consume_check_error gas cost = - let gas = consume gas cost in - check_error gas >|? fun () -> - gas - -(* Cost for heap allocating n words of data. *) -let alloc_cost n = - { allocations = n + 1 ; - steps = 0 } - -let alloc_bytes_cost n = - alloc_cost (n / 8) - -let alloc_bits_cost n = - alloc_cost (n / 64) - -(* Cost for one computation step. *) -let step_cost n = - { allocations = 0 ; - steps = n } - -let free = - { allocations = 0 ; - steps = 0 } - -let ( +@ ) x y = - { allocations = x.allocations + y.allocations ; - steps = x.steps + y.steps } - -let ( *@ ) x y = - { allocations = x * y.allocations ; - steps = x * y.steps } - -(* f should fail if it does not receive sufficient gas *) -let rec fold_left ~cycle_cost gas f acc l = - consume_check gas cycle_cost >>=? fun gas -> - match l with - | [] -> return (acc, gas) - | hd :: tl -> f gas hd acc >>=? fun (acc, gas) -> - fold_left ~cycle_cost gas f acc tl - -(* f should fail if it does not receive sufficient gas *) -let rec fold_right ~cycle_cost gas f base l = - consume_check gas cycle_cost >>=? fun gas -> - match l with - | [] -> return (base, gas) - | hd :: tl -> - fold_right ~cycle_cost gas f base tl >>=? fun (acc, gas) -> - f gas hd acc - -(* f should fail if it does not receive sufficient gas *) -let rec fold_right_error ~cycle_cost gas f base l = - consume_check_error gas cycle_cost >>? fun gas -> - match l with - | [] -> ok (base, gas) - | hd :: tl -> - fold_right_error ~cycle_cost gas f base tl >>? fun (acc, gas) -> - f gas hd acc - -(* f should fail if it does not receive sufficient gas *) -let rec fold_left_error ~cycle_cost gas f acc l = - consume_check_error gas cycle_cost >>? fun gas -> - match l with - | [] -> ok (acc, gas) - | hd :: tl -> f gas hd acc >>? fun (acc, gas) -> - fold_left_error ~cycle_cost gas f acc tl - -let () = - let open Data_encoding in - register_error_kind - `Permanent - ~id:"quotaExceededRuntimeError" - ~title: "Quota exceeded (runtime script error)" - ~description: - "A script or one of its callee took too much \ - time or storage space" - empty - (function Quota_exceeded -> Some () | _ -> None) - (fun () -> Quota_exceeded) ; diff --git a/src/proto_alpha/lib_protocol/src/gas_repr.ml b/src/proto_alpha/lib_protocol/src/gas_repr.ml new file mode 100644 index 000000000..c41268571 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/gas_repr.ml @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = + | Unaccounted + | Limited of { remaining : int } + +type cost = + { allocations : int ; + steps : int } + +let encoding = + let open Data_encoding in + union + [ case (Tag 0) int31 + (function Limited { remaining } -> Some remaining | _ -> None) + (fun remaining -> Limited { remaining }) ; + case (Tag 1) (constant "unaccounted") + (function Unaccounted -> Some () | _ -> None) + (fun () -> Unaccounted) ] + +let pp ppf = function + | Unaccounted -> + Format.fprintf ppf "unaccounted" + | Limited { remaining } -> + Format.fprintf ppf "%d units remaining" remaining + +let cost_encoding = + let open Data_encoding in + conv + (fun { allocations ; steps } -> + (allocations, steps)) + (fun (allocations, steps) -> + { allocations ; steps }) + (obj2 + (req "allocations" int31) + (req "steps" int31)) + +let pp_cost ppf { allocations ; steps } = + Format.fprintf ppf + "(steps: %d, allocs: %d)" + steps allocations + +type error += Quota_exceeded + +let consume t cost = match t with + | Unaccounted -> ok Unaccounted + | Limited { remaining } -> + let remaining = + remaining + - 2 * cost.allocations + - 1 * cost.steps in + if Compare.Int.(remaining <= 0) + then error Quota_exceeded + else ok (Limited { remaining }) + +let alloc_cost n = + { allocations = n + 1 ; + steps = 0 } + +let alloc_bytes_cost n = + alloc_cost (n / 8) + +let alloc_bits_cost n = + alloc_cost (n / 64) + +let step_cost n = + { allocations = 0 ; + steps = n } + +let free = + { allocations = 0 ; + steps = 0 } + +let ( +@ ) x y = + { allocations = x.allocations + y.allocations ; + steps = x.steps + y.steps } + +let ( *@ ) x y = + { allocations = x * y.allocations ; + steps = x * y.steps } + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"quotaExceededRuntimeError" + ~title: "Quota exceeded (runtime script error)" + ~description: + "A script or one of its callee took too much \ + time or storage space" + empty + (function Quota_exceeded -> Some () | _ -> None) + (fun () -> Quota_exceeded) ; diff --git a/src/proto_alpha/lib_protocol/src/gas.mli b/src/proto_alpha/lib_protocol/src/gas_repr.mli similarity index 52% rename from src/proto_alpha/lib_protocol/src/gas.mli rename to src/proto_alpha/lib_protocol/src/gas_repr.mli index 4e9ab8e7b..01a3b9dcf 100644 --- a/src/proto_alpha/lib_protocol/src/gas.mli +++ b/src/proto_alpha/lib_protocol/src/gas_repr.mli @@ -7,30 +7,21 @@ (* *) (**************************************************************************) -type t -type cost - -val consume : t -> cost -> t +type t = + | Unaccounted + | Limited of { remaining : int } val encoding : t Data_encoding.encoding val pp : Format.formatter -> t -> unit -val encoding_cost : cost Data_encoding.encoding +type cost + +val cost_encoding : cost Data_encoding.encoding val pp_cost : Format.formatter -> cost -> unit -val check : t -> unit tzresult Lwt.t -val consume_check : t -> cost -> t tzresult Lwt.t -val check_error : t -> unit tzresult -val consume_check_error : t -> cost -> t tzresult type error += Quota_exceeded -val of_int : int -> t -val remaining : t -> int - -val ( *@ ) : int -> cost -> cost -val ( +@ ) : cost -> cost -> cost - -val used : original:t -> current:t -> t +val consume : t -> cost -> t tzresult val free : cost val step_cost : int -> cost @@ -38,24 +29,5 @@ val alloc_cost : int -> cost val alloc_bytes_cost : int -> cost val alloc_bits_cost : int -> cost -val max_gas : t - -val fold_left : cycle_cost:cost -> - t -> - (t -> 'a -> 'b -> ('b * t) tzresult Lwt.t) -> - 'b -> 'a list -> ('b * t) tzresult Lwt.t - -val fold_right : cycle_cost:cost -> - t -> - (t -> 'a -> 'b -> ('b * t) tzresult Lwt.t) -> - 'b -> 'a list -> ('b * t) tzresult Lwt.t - -val fold_right_error : cycle_cost:cost -> - t -> - (t -> 'a -> 'b -> ('b * t) tzresult) -> - 'b -> 'a list -> ('b * t) tzresult - -val fold_left_error : cycle_cost:cost -> - t -> - (t -> 'a -> 'b -> ('b * t) tzresult) -> - 'b -> 'a list -> ('b * t) tzresult +val ( *@ ) : int -> cost -> cost +val ( +@ ) : cost -> cost -> cost diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml index 37dcb5299..ca96dfdf1 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -79,7 +79,7 @@ module S = struct ~query: RPC_query.empty ~input: (obj2 (req "program" Script.expr_encoding) - (opt "gas" Gas.encoding)) + (opt "gas" int31)) ~output: (obj2 (req "type_map" Script_tc_errors_registration.type_map_enc) (req "gas" Gas.encoding)) @@ -93,7 +93,7 @@ module S = struct ~input: (obj3 (req "data" Script.expr_encoding) (req "type" Script.expr_encoding) - (opt "gas" Gas.encoding)) + (opt "gas" int31)) ~output: (obj1 (req "gas" Gas.encoding)) RPC_path.(custom_root / "typecheck_data") @@ -105,7 +105,7 @@ module S = struct ~input: (obj3 (req "data" Script.expr_encoding) (req "type" Script.expr_encoding) - (opt "gas" Gas.encoding)) + (opt "gas" int31)) ~output: (obj2 (req "hash" string) (req "gas" Gas.encoding)) @@ -178,53 +178,53 @@ let () = register0 S.run_code begin fun ctxt () parameters -> let (code, storage, input, amount, contract, gas, origination_nonce) = I.run_parameters ctxt parameters in + let ctxt = if Compare.Int.(gas > 0) then Gas.set_limit ctxt gas else Gas.set_unlimited ctxt in Script_interpreter.execute origination_nonce contract (* transaction initiator *) contract (* script owner *) - ctxt { storage ; code } amount input - (Gas.of_int gas) >>=? fun (sto, ret, _gas, _ctxt, _, maybe_big_map_diff) -> + 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) + ~f:(Script_ir_translator.to_printable_big_map ctxt)) end ; register0 S.trace_code begin fun ctxt () parameters -> let (code, storage, input, amount, contract, gas, origination_nonce) = I.run_parameters ctxt parameters in + let ctxt = if Compare.Int.(gas > 0) then Gas.set_limit ctxt gas else Gas.set_unlimited ctxt in Script_interpreter.trace origination_nonce contract (* transaction initiator *) contract (* script owner *) ctxt { storage ; code } amount input - (Gas.of_int gas) >>=? fun ((sto, ret, _gas, _ctxt, _, maybe_big_map_diff), trace) -> + >>=? 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) + ~f:(Script_ir_translator.to_printable_big_map ctxt)) end ; register0 S.typecheck_code begin fun ctxt () (expr, maybe_gas) -> - Script_ir_translator.typecheck_code ctxt - (match maybe_gas with - | None -> Gas.of_int (Constants.max_gas ctxt) - | Some gas -> gas) - expr + let ctxt = match maybe_gas with + | None -> Gas.set_unlimited ctxt + | Some gas -> Gas.set_limit ctxt gas in + Script_ir_translator.typecheck_code ctxt expr >>=? fun (res, ctxt) -> + return (res, Gas.level ctxt) end ; register0 S.typecheck_data begin fun ctxt () (data, ty, maybe_gas) -> - Script_ir_translator.typecheck_data ctxt - (match maybe_gas with - | None -> Gas.of_int (Constants.max_gas ctxt) - | Some gas -> gas) - (data, ty) + let ctxt = match maybe_gas with + | None -> Gas.set_unlimited ctxt + | Some gas -> Gas.set_limit ctxt gas in + Script_ir_translator.typecheck_data ctxt (data, ty) >>=? fun ctxt -> + return (Gas.level ctxt) end ; register0 S.hash_data begin fun ctxt () (expr, typ, maybe_gas) -> let open Script_ir_translator in - Lwt.return @@ - parse_ty - (match maybe_gas with - | None -> Gas.of_int (Constants.max_gas ctxt) - | Some gas -> gas) - false (Micheline.root typ) >>=? fun ((Ex_ty typ, _), gas) -> - parse_data ctxt gas typ (Micheline.root expr) >>=? fun (data, gas) -> - Lwt.return @@ Script_ir_translator.hash_data gas typ data + let ctxt = match maybe_gas with + | None -> Gas.set_unlimited ctxt + | Some gas -> Gas.set_limit ctxt gas in + Lwt.return (parse_ty ctxt false (Micheline.root typ)) >>=? fun ((Ex_ty typ, _), ctxt) -> + parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) -> + Lwt.return (Script_ir_translator.hash_data ctxt typ data) >>=? fun (hash, ctxt) -> + return (hash, Gas.level ctxt) end ; register1 S.level begin fun ctxt raw () offset -> return (Level.from_raw ctxt ?offset raw) diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.mli b/src/proto_alpha/lib_protocol/src/helpers_services.mli index 57784c405..0d8ff93d5 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.mli +++ b/src/proto_alpha/lib_protocol/src/helpers_services.mli @@ -37,16 +37,16 @@ val trace_code: val typecheck_code: 'a #RPC_context.simple -> - 'a -> (Script.expr * Gas.t option) -> + 'a -> (Script.expr * int option) -> (Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t val typecheck_data: 'a #RPC_context.simple -> - 'a -> Script.expr * Script.expr * (Gas.t option) -> Gas.t shell_tzresult Lwt.t + 'a -> Script.expr * Script.expr * int option -> Gas.t shell_tzresult Lwt.t val hash_data: 'a #RPC_context.simple -> - 'a -> Script.expr * Script.expr * (Gas.t option) -> (string * Gas.t) shell_tzresult Lwt.t + 'a -> Script.expr * Script.expr * int option -> (string * Gas.t) shell_tzresult Lwt.t val level: 'a #RPC_context.simple -> diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml index 5b709a03e..e862cfd7e 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml @@ -181,7 +181,6 @@ module Cost_of = struct (* TODO: This needs to be a function of the data being hashed *) let hash _data = step_cost 3 let steps_to_quota = step_cost 1 - let get_steps_to_quota gas = Script_int.abs (Script_int.of_int (remaining gas)) let source = step_cost 3 let self = step_cost 3 let amount = step_cost 1 diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli index c5be549d0..3d8be9f50 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli @@ -74,7 +74,6 @@ module Cost_of : sig val check_signature : Gas.cost val hash_key : Gas.cost val hash : 'a -> Gas.cost - val get_steps_to_quota : Gas.t -> Script_int.n Script_int.num val steps_to_quota : Gas.cost val source : Gas.cost val self : Gas.cost diff --git a/src/proto_alpha/lib_protocol/src/raw_context.ml b/src/proto_alpha/lib_protocol/src/raw_context.ml index 0c86d46e5..3b1156de7 100644 --- a/src/proto_alpha/lib_protocol/src/raw_context.ml +++ b/src/proto_alpha/lib_protocol/src/raw_context.ml @@ -19,6 +19,7 @@ type t = { endorsements_received: Int_set.t; fees: Tez_repr.t ; rewards: Tez_repr.t ; + gas: Gas_repr.t; } type context = t @@ -47,6 +48,14 @@ let add_rewards ctxt rewards = let get_rewards ctxt = ctxt.rewards let get_fees ctxt = ctxt.fees +let set_gas_limit ctxt remaining = { ctxt with gas = Limited { remaining } } +let set_gas_unlimited ctxt = { ctxt with gas = Unaccounted } +let consume_gas ctxt cost = + Gas_repr.consume ctxt.gas cost >>? fun gas -> + ok { ctxt with gas } +let gas_level ctxt = ctxt.gas + + type storage_error = | Incompatible_protocol_version of string | Missing_key of string list * [`Get | `Set | `Del | `Copy] @@ -263,6 +272,7 @@ let prepare ~level ~timestamp ~fitness ctxt = endorsements_received = Int_set.empty ; fees = Tez_repr.zero ; rewards = Tez_repr.zero ; + gas = Unaccounted ; } let check_first_block ctxt = @@ -307,6 +317,7 @@ let register_resolvers enc resolve = endorsements_received = Int_set.empty ; fees = Tez_repr.zero ; rewards = Tez_repr.zero ; + gas = Unaccounted ; } in resolve faked_context str in Context.register_resolver enc resolve diff --git a/src/proto_alpha/lib_protocol/src/raw_context.mli b/src/proto_alpha/lib_protocol/src/raw_context.mli index f6f716c0d..2ef8df1ab 100644 --- a/src/proto_alpha/lib_protocol/src/raw_context.mli +++ b/src/proto_alpha/lib_protocol/src/raw_context.mli @@ -73,6 +73,11 @@ val add_rewards: context -> Tez_repr.t -> context tzresult Lwt.t val get_fees: context -> Tez_repr.t val get_rewards: context -> Tez_repr.t +val set_gas_limit: t -> int -> t +val set_gas_unlimited: t -> t +val consume_gas: t -> Gas_repr.cost -> t tzresult +val gas_level: t -> Gas_repr.t + (** {1 Generic accessors} *************************************************) type key = string list diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index f6b34e319..8d816ed41 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -64,82 +64,78 @@ type 'tys stack = | Item : 'ty * 'rest stack -> ('ty * 'rest) stack | Empty : end_of_stack stack -let rec unparse_stack - : type a. a stack * a stack_ty -> Script.expr list - = function - | Empty, Empty_t -> [] - | Item (v, rest), Item_t (ty, rest_ty, _) -> - (* Meant to be more gas than you can consume as this function is only used for debugging/errors *) - match unparse_data (Gas.of_int 1000000000) ty v with - | Ok (data, _) -> (Micheline.strip_locations data) :: (unparse_stack (rest, rest_ty)) - | Error _ -> Pervasives.failwith "Internal error: raise gas limit for unparse_stack" +let unparse_stack ctxt (stack, stack_ty) = + (* We drop the gas limit as this function is only used for debugging/errors. *) + let ctxt = Gas.set_unlimited ctxt in + let rec unparse_stack + : type a. a stack * a stack_ty -> Script.expr list + = function + | Empty, Empty_t -> [] + | Item (v, rest), Item_t (ty, rest_ty, _) -> + match unparse_data ctxt ty v with + | Ok (data, _ctxt) -> Micheline.strip_locations data :: unparse_stack (rest, rest_ty) + | Error _ -> assert false in + unparse_stack (stack, stack_ty) module Interp_costs = Michelson_v1_gas.Cost_of let rec interp : type p r. ?log: (Script.location * Gas.t * Script.expr list) list ref -> - Contract.origination_nonce -> Gas.t -> Contract.t -> Contract.t -> Tez.t -> + Contract.origination_nonce -> Contract.t -> Contract.t -> Tez.t -> context -> (p, r) lambda -> p -> - (r * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t - = fun ?log origination gas orig source amount ctxt (Lam (code, _)) arg -> + (r * context * Contract.origination_nonce) tzresult Lwt.t + = fun ?log origination orig source amount ctxt (Lam (code, _)) arg -> let rec step : type b a. - Contract.origination_nonce -> Gas.t -> context -> (b, a) descr -> b stack -> - (a stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = - fun origination gas ctxt ({ instr ; loc ; _ } as descr) stack -> - let gas = Gas.consume gas Interp_costs.cycle in - Gas.check gas >>=? fun () -> + Contract.origination_nonce -> context -> (b, a) descr -> b stack -> + (a stack * context * Contract.origination_nonce) tzresult Lwt.t = + fun origination ctxt ({ instr ; loc ; _ } as descr) stack -> + Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> let logged_return : type a b. (b, a) descr -> ?origination:Contract.origination_nonce -> - a stack * Gas.t * context -> - (a stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = - fun descr ?(origination = origination) (ret, gas, ctxt) -> + a stack * context -> + (a stack * context * Contract.origination_nonce) tzresult Lwt.t = + fun descr ?(origination = origination) (ret, ctxt) -> match log with - | None -> return (ret, gas, ctxt, origination) + | None -> return (ret, ctxt, origination) | Some log -> - log := (descr.loc, gas, unparse_stack (ret, descr.aft)) :: !log ; - return (ret, gas, ctxt, origination) in - let gas_check_terop : type ret arg1 arg2 arg3 rest. - ?gas:Gas.t -> + log := (descr.loc, Gas.level ctxt, unparse_stack ctxt (ret, descr.aft)) :: !log ; + return (ret, ctxt, origination) in + let consume_gas_terop : type ret arg1 arg2 arg3 rest. ?origination:Contract.origination_nonce -> (_ * (_ * (_ * rest)), ret * rest) descr -> ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> (arg1 -> arg2 -> arg3 -> Gas.cost) -> rest stack -> - ((ret * rest) stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = - fun ?(gas=gas) ?(origination = origination) descr (op, x1, x2, x3) cost_func rest -> - let gas = Gas.consume gas (cost_func x1 x2 x3) in - Gas.check gas >>=? fun () -> - logged_return descr ~origination (Item (op x1 x2 x3, rest), gas, ctxt) in - let gas_check_binop : type ret arg1 arg2 rest. - ?gas:Gas.t -> + ((ret * rest) stack * context * Contract.origination_nonce) tzresult Lwt.t = + fun ?(origination = origination) descr (op, x1, x2, x3) cost_func rest -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> + logged_return descr ~origination (Item (op x1 x2 x3, rest), ctxt) in + let consume_gas_binop : type ret arg1 arg2 rest. ?origination:Contract.origination_nonce -> (_ * (_ * rest), ret * rest) descr -> ((arg1 -> arg2 -> ret) * arg1 * arg2) -> (arg1 -> arg2 -> Gas.cost) -> rest stack -> context -> - ((ret * rest) stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = - fun ?(gas=gas) ?(origination = origination) descr (op, x1, x2) cost_func rest ctxt -> - let gas = Gas.consume gas (cost_func x1 x2) in - Gas.check gas >>=? fun () -> - logged_return descr ~origination (Item (op x1 x2, rest), gas, ctxt) in - let gas_check_unop : type ret arg rest. - ?gas:Gas.t -> + ((ret * rest) stack * context * Contract.origination_nonce) tzresult Lwt.t = + fun ?(origination = origination) descr (op, x1, x2) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> + logged_return descr ~origination (Item (op x1 x2, rest), ctxt) in + let consume_gas_unop : type ret arg rest. ?origination:Contract.origination_nonce -> (_ * rest, ret * rest) descr -> ((arg -> ret) * arg) -> (arg -> Gas.cost) -> rest stack -> context -> - ((ret * rest) stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = - fun ?(gas=gas) ?(origination = origination) descr (op, arg) cost_func rest ctxt -> - let gas = Gas.consume gas (cost_func arg) in - Gas.check gas >>=? fun () -> - logged_return descr ~origination (Item (op arg, rest), gas, ctxt) in - let gas_compare : + ((ret * rest) stack * context * Contract.origination_nonce) tzresult Lwt.t = + fun ?(origination = origination) descr (op, arg) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> + logged_return descr ~origination (Item (op arg, rest), ctxt) in + let consume_gaz_comparison : type t rest. (t * (t * rest), Script_int.z Script_int.num * rest) descr -> (t -> t -> int) -> @@ -147,13 +143,11 @@ let rec interp t -> t -> rest stack -> ((Script_int.z Script_int.num * rest) stack - * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = fun descr op cost x1 x2 rest -> - let gas = Gas.consume gas (cost x1 x2) in - Gas.check gas >>=? fun () -> - logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), gas, ctxt) in + Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in let create_contract : type param return rest storage. (_, (param, return) typed_contract * rest) descr -> @@ -162,18 +156,17 @@ let rec interp init:storage -> param_type:param ty -> storage_type:storage ty -> return_type:return ty -> rest:rest stack -> - (((param, return) typed_contract * rest) stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = + (((param, return) typed_contract * rest) stack * context * Contract.origination_nonce) tzresult Lwt.t = fun descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init ~param_type ~storage_type ~return_type ~rest -> - let gas = Gas.consume gas Interp_costs.create_contract in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> let code = Micheline.strip_locations (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ; Prim (0, K_return, [ unparse_ty None return_type ], None) ; Prim (0, K_storage, [ unparse_ty None storage_type ], None) ; Prim (0, K_code, [ Micheline.root code ], None) ], None)) in - Lwt.return @@ unparse_data gas storage_type init >>=? fun (storage, gas) -> + 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.originate ctxt @@ -183,309 +176,313 @@ let rec interp ~spendable ~delegatable >>=? fun (ctxt, contract, origination) -> Fees.origination_burn ctxt ~source:orig contract >>=? fun ctxt -> - logged_return descr ~origination (Item ((param_type, return_type, contract), rest), gas, ctxt) in + logged_return descr ~origination (Item ((param_type, return_type, contract), rest), ctxt) in let logged_return : ?origination:Contract.origination_nonce -> - a stack * Gas.t * context -> - (a stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = + a stack * context -> + (a stack * context * Contract.origination_nonce) tzresult Lwt.t = logged_return descr in match instr, stack with (* stack ops *) | Drop, Item (_, rest) -> - let gas = Gas.consume gas Interp_costs.stack_op in - Gas.check gas >>=? fun () -> - logged_return (rest, gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (rest, ctxt) | Dup, Item (v, rest) -> - let gas = Gas.consume gas Interp_costs.stack_op in - Gas.check gas >>=? fun () -> - logged_return (Item (v, Item (v, rest)), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (v, Item (v, rest)), ctxt) | Swap, Item (vi, Item (vo, rest)) -> - let gas = Gas.consume gas Interp_costs.stack_op in - Gas.check gas >>=? fun () -> - logged_return (Item (vo, Item (vi, rest)), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (vo, Item (vi, rest)), ctxt) | Const v, rest -> - let gas = Gas.consume gas Interp_costs.push in - Gas.check gas >>=? fun () -> - logged_return (Item (v, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) (* options *) | Cons_some, Item (v, rest) -> - let gas = Gas.consume gas Interp_costs.wrap in - Gas.check gas >>=? fun () -> - logged_return (Item (Some v, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (Some v, rest), ctxt) | Cons_none _, rest -> - let gas = Gas.consume gas Interp_costs.variant_no_data in - Gas.check gas >>=? fun () -> - logged_return (Item (None, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) | If_none (bt, _), Item (None, rest) -> - step origination (Gas.consume gas Interp_costs.branch) ctxt bt rest + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step origination ctxt bt rest | If_none (_, bf), Item (Some v, rest) -> - step origination (Gas.consume gas Interp_costs.branch) ctxt bf (Item (v, rest)) + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step origination ctxt bf (Item (v, rest)) (* pairs *) | Cons_pair, Item (a, Item (b, rest)) -> - let gas = Gas.consume gas Interp_costs.pair in - Gas.check gas >>=? fun () -> - logged_return (Item ((a, b), rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> + logged_return (Item ((a, b), rest), ctxt) | Car, Item ((a, _), rest) -> - let gas = Gas.consume gas Interp_costs.pair_access in - Gas.check gas >>=? fun () -> - logged_return (Item (a, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (a, rest), ctxt) | Cdr, Item ((_, b), rest) -> - let gas = Gas.consume gas Interp_costs.pair_access in - Gas.check gas >>=? fun () -> - logged_return (Item (b, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (b, rest), ctxt) (* unions *) | Left, Item (v, rest) -> - let gas = Gas.consume gas Interp_costs.wrap in - Gas.check gas >>=? fun () -> - logged_return (Item (L v, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (L v, rest), ctxt) | Right, Item (v, rest) -> - let gas = Gas.consume gas Interp_costs.wrap in - Gas.check gas >>=? fun () -> - logged_return (Item (R v, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (R v, rest), ctxt) | If_left (bt, _), Item (L v, rest) -> - step origination (Gas.consume gas Interp_costs.branch) ctxt bt (Item (v, rest)) + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step origination ctxt bt (Item (v, rest)) | If_left (_, bf), Item (R v, rest) -> - step origination (Gas.consume gas Interp_costs.branch) ctxt bf (Item (v, rest)) + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step origination ctxt bf (Item (v, rest)) (* lists *) | Cons_list, Item (hd, Item (tl, rest)) -> - let gas = Gas.consume gas Interp_costs.cons in - Gas.check gas >>=? fun () -> - logged_return (Item (hd :: tl, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> + logged_return (Item (hd :: tl, rest), ctxt) | Nil, rest -> - let gas = Gas.consume gas Interp_costs.variant_no_data in - Gas.check gas >>=? fun () -> - logged_return (Item ([], rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item ([], rest), ctxt) | If_cons (_, bf), Item ([], rest) -> - step origination (Gas.consume gas Interp_costs.branch) ctxt bf rest + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step origination ctxt bf rest | If_cons (bt, _), Item (hd :: tl, rest) -> - step origination (Gas.consume gas Interp_costs.branch) ctxt bt (Item (hd, Item (tl, rest))) + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step origination ctxt bt (Item (hd, Item (tl, rest))) | List_map, Item (lam, Item (l, rest)) -> - Gas.fold_right ~cycle_cost:Interp_costs.cycle gas - (fun gas arg (tail, ctxt, origination) -> - interp ?log origination gas orig source amount ctxt lam arg - >>=? fun (ret, gas, ctxt, origination) -> - return ((ret :: tail, ctxt, origination), gas)) - ([], ctxt, origination) l >>=? fun ((res, ctxt, origination), gas) -> - logged_return ~origination (Item (res, rest), gas, ctxt) - | List_map_body body, Item (l, rest) -> - let rec help rest gas l = - let gas = Gas.consume gas Interp_costs.loop_cycle in - Gas.check gas >>=? fun () -> + let rec loop rest ctxt origination l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> match l with - | [] -> logged_return ~origination (Item ([], rest), gas, ctxt) + | [] -> return (List.rev acc, ctxt, origination) | hd :: tl -> - step origination gas ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), gas, _, _) -> - help rest gas tl - >>=? fun (Item (tl, rest), gas, ctxt, origination) -> - logged_return ~origination (Item (hd :: tl, rest), gas, ctxt) - in help rest gas l >>=? fun (res, gas, ctxt, origination) -> - logged_return ~origination (res, gas, ctxt) + interp ?log origination orig source amount ctxt lam hd + >>=? fun (hd, ctxt, origination) -> + loop rest ctxt origination tl (hd :: acc) + in loop rest ctxt origination l [] >>=? fun (res, ctxt, origination) -> + logged_return ~origination (Item (res, rest), ctxt) + | List_map_body body, Item (l, rest) -> + let rec loop rest ctxt origination l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (Item (List.rev acc, rest), ctxt, origination) + | hd :: tl -> + step origination ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt, origination) -> + loop rest ctxt origination tl (hd :: acc) + in loop rest ctxt origination l [] >>=? fun (res, ctxt, origination) -> + logged_return ~origination (res, ctxt) | List_reduce, Item (lam, Item (l, Item (init, rest))) -> - Gas.fold_left ~cycle_cost:Interp_costs.cycle gas - (fun gas arg (partial, ctxt, origination) -> - interp ?log origination gas orig source amount ctxt lam (arg, partial) - >>=? fun (partial, gas, ctxt, origination) -> - return ((partial, ctxt, origination), gas)) - (init, ctxt, origination) l >>=? fun ((res, ctxt, origination), gas) -> - logged_return ~origination (Item (res, rest), gas, ctxt) + let rec loop rest ctxt origination l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt, origination) + | hd :: tl -> + interp ?log origination orig source amount ctxt lam (hd, acc) + >>=? fun (acc, ctxt, origination) -> + loop rest ctxt origination tl acc + in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> + logged_return ~origination (Item (res, rest), ctxt) | List_size, Item (list, rest) -> - Gas.fold_left ~cycle_cost:Interp_costs.list_size gas - (fun gas _ len -> - return (len + 1, gas)) - 0 - list >>=? fun (len, gas) -> - logged_return (Item (Script_int.(abs (of_int len)), rest), gas, ctxt) - | List_iter body, Item (l, init_stack) -> - Gas.fold_left ~cycle_cost:Interp_costs.list_size gas - (fun gas arg (stack, ctxt, origination) -> - step origination gas ctxt body (Item (arg, stack)) - >>=? fun (stack, gas, ctxt, origination) -> - return ((stack, ctxt, origination), gas)) - (init_stack, ctxt, origination) l >>=? fun ((stack, ctxt, origination), gas) -> - logged_return ~origination (stack, gas, ctxt) + Lwt.return + (List.fold_left + (fun acc _ -> + acc >>? fun (size, ctxt) -> + Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> + ok (size + 1 (* FIXME: overflow *), ctxt)) + (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> + logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) + | List_iter body, Item (l, init) -> + let rec loop ctxt origination l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt, origination) + | hd :: tl -> + step origination ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt, origination) -> + loop ctxt origination tl stack + in loop ctxt origination l init >>=? fun (res, ctxt, origination) -> + logged_return ~origination (res, ctxt) (* sets *) | Empty_set t, rest -> - logged_return (Item (empty_set t, rest), Gas.consume gas Interp_costs.empty_set, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> + logged_return (Item (empty_set t, rest), ctxt) | Set_reduce, Item (lam, Item (set, Item (init, rest))) -> - let gas = Gas.consume gas (Interp_costs.set_to_list set) in - Gas.check gas >>=? fun () -> - let items = - List.rev (set_fold (fun e acc -> e :: acc) set []) in - Gas.fold_left ~cycle_cost:Interp_costs.list_size gas - (fun gas arg (partial, ctxt, origination) -> - interp ?log origination gas orig source amount ctxt lam (arg, partial) - >>=? fun (partial, gas, ctxt, origination) -> - return ((partial, ctxt, origination), gas)) - (init, ctxt, origination) items >>=? fun ((res, ctxt, origination), gas) -> - logged_return ~origination (Item (res, rest), gas, ctxt) - | Set_iter body, Item (set, init_stack) -> - Gas.fold_left ~cycle_cost:Interp_costs.list_size gas - (fun gas arg (stack, ctxt, origination) -> - step origination gas ctxt body (Item (arg, stack)) - >>=? fun (stack, gas, ctxt, origination) -> - return ((stack, ctxt, origination), gas)) - (init_stack, ctxt, origination) - (set_fold (fun e acc -> e :: acc) set []) >>=? fun ((stack, ctxt, origination), gas) -> - logged_return ~origination (stack, gas, ctxt) + Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop rest ctxt origination l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt, origination) + | hd :: tl -> + interp ?log origination orig source amount ctxt lam (hd, acc) + >>=? fun (acc, ctxt, origination) -> + loop rest ctxt origination tl acc + in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> + logged_return ~origination (Item (res, rest), ctxt) + | Set_iter body, Item (set, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop ctxt origination l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt, origination) + | hd :: tl -> + step origination ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt, origination) -> + loop ctxt origination tl stack + in loop ctxt origination l init >>=? fun (res, ctxt, origination) -> + logged_return ~origination (res, ctxt) | Set_mem, Item (v, Item (set, rest)) -> - gas_check_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt + consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt | Set_update, Item (v, Item (presence, Item (set, rest))) -> - gas_check_terop descr (set_update, v, presence, set) Interp_costs.set_update rest + consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest | Set_size, Item (set, rest) -> - gas_check_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt + consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt (* maps *) | Empty_map (t, _), rest -> - logged_return (Item (empty_map t, rest), Gas.consume gas Interp_costs.empty_map, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + logged_return (Item (empty_map t, rest), ctxt) | Map_map, Item (lam, Item (map, rest)) -> - let gas = Gas.consume gas (Interp_costs.map_to_list map) in - Gas.check gas >>=? fun () -> - let items = - List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - Gas.fold_left ~cycle_cost:Interp_costs.list_size gas - (fun gas (k, v) (acc, ctxt, origination) -> - interp ?log origination gas orig source amount ctxt lam (k, v) - >>=? fun (ret, gas, ctxt, origination) -> - return ((map_update k (Some ret) acc, ctxt, origination), gas)) - (empty_map (map_key_ty map), ctxt, origination) items >>=? fun ((res, ctxt, origination), gas) -> - logged_return ~origination (Item (res, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt origination l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt, origination) + | (k, _) as hd :: tl -> + interp ?log origination orig source amount ctxt 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) -> + logged_return ~origination (Item (res, rest), ctxt) | Map_reduce, Item (lam, Item (map, Item (init, rest))) -> - let gas = Gas.consume gas (Interp_costs.map_to_list map) in - Gas.check gas >>=? fun () -> - let items = - List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - Gas.fold_left ~cycle_cost:Interp_costs.list_size gas - (fun gas arg (partial, ctxt, origination) -> - interp ?log origination gas orig source amount ctxt lam (arg, partial) - >>=? fun (partial, gas, ctxt, origination) -> - return ((partial, ctxt, origination), gas)) - (init, ctxt, origination) items >>=? fun ((res, ctxt, origination), gas) -> - logged_return ~origination (Item (res, rest), gas, ctxt) - | Map_iter body, Item (map, init_stack) -> - let gas = Gas.consume gas (Interp_costs.map_to_list map) in - Gas.check gas >>=? fun () -> - let items = - List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - Gas.fold_left ~cycle_cost:Interp_costs.list_size gas - (fun gas arg (stack, ctxt, origination) -> - step origination gas ctxt body (Item (arg, stack)) - >>=? fun (stack, gas, ctxt, origination) -> - return ((stack, ctxt, origination), gas)) - (init_stack, ctxt, origination) items >>=? fun ((stack, ctxt, origination), gas) -> - logged_return ~origination (stack, gas, ctxt) + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt origination l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt, origination) + | hd :: tl -> + interp ?log origination orig source amount ctxt lam (hd, acc) + >>=? fun (acc, ctxt, origination) -> + loop rest ctxt origination tl acc + in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> + logged_return ~origination (Item (res, rest), ctxt) + | Map_iter body, Item (map, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop ctxt origination l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt, origination) + | hd :: tl -> + step origination ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt, origination) -> + loop ctxt origination tl stack + in loop ctxt origination l init >>=? fun (res, ctxt, origination) -> + logged_return ~origination (res, ctxt) | Map_mem, Item (v, Item (map, rest)) -> - gas_check_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt + consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt | Map_get, Item (v, Item (map, rest)) -> - gas_check_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt + consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt | Map_update, Item (k, Item (v, Item (map, rest))) -> - gas_check_terop descr (map_update, k, v, map) Interp_costs.map_update rest + consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest | Map_size, Item (map, rest) -> - gas_check_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt + consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt (* Big map operations *) | Big_map_mem, Item (key, Item (map, rest)) -> - let gas = Gas.consume gas (Interp_costs.big_map_mem key map) in - Gas.check gas >>=? fun () -> - Script_ir_translator.big_map_mem ctxt gas source key map >>=? fun (res, gas) -> - logged_return (Item (res, rest), gas, ctxt) + 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) -> + logged_return (Item (res, rest), ctxt) | Big_map_get, Item (key, Item (map, rest)) -> - let gas = Gas.consume gas (Interp_costs.big_map_get key map) in - Gas.check gas >>=? fun () -> - Script_ir_translator.big_map_get ctxt gas source key map >>=? fun (res, gas) -> - logged_return (Item (res, rest), gas, ctxt) + 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) -> + logged_return (Item (res, rest), ctxt) | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> - gas_check_terop descr + consume_gas_terop descr (Script_ir_translator.big_map_update, key, maybe_value, map) Interp_costs.big_map_update rest (* timestamp operations *) | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> - gas_check_binop descr + consume_gas_binop descr (Script_timestamp.add_delta, t, n) Interp_costs.add_timestamp rest ctxt | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> - gas_check_binop descr (Script_timestamp.add_delta, t, n) + consume_gas_binop descr (Script_timestamp.add_delta, t, n) Interp_costs.add_timestamp rest ctxt | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> - gas_check_binop descr (Script_timestamp.sub_delta, t, s) + consume_gas_binop descr (Script_timestamp.sub_delta, t, s) Interp_costs.sub_timestamp rest ctxt | Diff_timestamps, Item (t1, Item (t2, rest)) -> - gas_check_binop descr (Script_timestamp.diff, t1, t2) + consume_gas_binop descr (Script_timestamp.diff, t1, t2) Interp_costs.diff_timestamps rest ctxt (* string operations *) | Concat, Item (x, Item (y, rest)) -> - gas_check_binop descr ((^), x, y) Interp_costs.concat rest ctxt + consume_gas_binop descr ((^), x, y) Interp_costs.concat rest ctxt (* currency operations *) | Add_tez, Item (x, Item (y, rest)) -> - let gas = Gas.consume gas Interp_costs.int64_op in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> Lwt.return Tez.(x +? y) >>=? fun res -> - logged_return (Item (res, rest), gas, ctxt) + logged_return (Item (res, rest), ctxt) | Sub_tez, Item (x, Item (y, rest)) -> - let gas = Gas.consume gas Interp_costs.int64_op in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> Lwt.return Tez.(x -? y) >>=? fun res -> - logged_return (Item (res, rest), gas, ctxt) + logged_return (Item (res, rest), ctxt) | Mul_teznat, Item (x, Item (y, rest)) -> - let gas = Gas.consume gas Interp_costs.int64_op in - let gas = Gas.consume gas Interp_costs.z_to_int64 in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> begin match Script_int.to_int64 y with | None -> fail (Overflow loc) | Some y -> Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), gas, ctxt) + logged_return (Item (res, rest), ctxt) end | Mul_nattez, Item (y, Item (x, rest)) -> - let gas = Gas.consume gas Interp_costs.int64_op in - let gas = Gas.consume gas Interp_costs.z_to_int64 in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> begin match Script_int.to_int64 y with | None -> fail (Overflow loc) | Some y -> Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), gas, ctxt) + logged_return (Item (res, rest), ctxt) end (* boolean operations *) | Or, Item (x, Item (y, rest)) -> - gas_check_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt + consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt | And, Item (x, Item (y, rest)) -> - gas_check_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt + consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt | Xor, Item (x, Item (y, rest)) -> - gas_check_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt + consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt | Not, Item (x, rest) -> - gas_check_unop descr (not, x) Interp_costs.bool_unop rest ctxt + consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt (* integer operations *) | Abs_int, Item (x, rest) -> - gas_check_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt + consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt | Int_nat, Item (x, rest) -> - gas_check_unop descr (Script_int.int, x) Interp_costs.int rest ctxt + consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt | Neg_int, Item (x, rest) -> - gas_check_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt | Neg_nat, Item (x, rest) -> - gas_check_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt | Add_intint, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt | Add_intnat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt | Add_natint, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt | Add_natnat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt + consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt | Sub_int, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt + consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt | Mul_intint, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt | Mul_intnat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt | Mul_natint, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt | Mul_natnat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt + consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt | Ediv_teznat, Item (x, Item (y, rest)) -> - let gas = Gas.consume gas Interp_costs.int64_to_z in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> let x = Script_int.of_int64 (Tez.to_mutez x) in - gas_check_binop ~gas descr + consume_gas_binop descr ((fun x y -> match Script_int.ediv x y with | None -> None @@ -506,11 +503,11 @@ let rec interp rest ctxt | Ediv_tez, Item (x, Item (y, rest)) -> - let gas = Gas.consume gas Interp_costs.int64_to_z in - let gas = Gas.consume gas Interp_costs.int64_to_z in + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in - gas_check_binop ~gas descr + consume_gas_binop descr ((fun x y -> match Script_int.ediv_n x y with | None -> None | Some (q, r) -> @@ -525,132 +522,142 @@ let rec interp rest ctxt | Ediv_intint, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt | Ediv_intnat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt | Ediv_natint, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt | Ediv_natnat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt + consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt | Lsl_nat, Item (x, Item (y, rest)) -> - let gas = Gas.consume gas (Interp_costs.shift_left x y) in - Gas.check gas >>=? fun () -> begin + Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> + begin match Script_int.shift_left_n x y with | None -> fail (Overflow loc) - | Some x -> logged_return (Item (x, rest), gas, ctxt) + | Some x -> logged_return (Item (x, rest), ctxt) end | Lsr_nat, Item (x, Item (y, rest)) -> - let gas = Gas.consume gas (Interp_costs.shift_right x y) in - Gas.check gas >>=? fun () -> begin + Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> + begin match Script_int.shift_right_n x y with | None -> fail (Overflow loc) - | Some r -> logged_return (Item (r, rest), gas, ctxt) + | Some r -> logged_return (Item (r, rest), ctxt) end | Or_nat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt + consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt | And_nat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt | Xor_nat, Item (x, Item (y, rest)) -> - gas_check_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt + consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt | Not_int, Item (x, rest) -> - gas_check_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt | Not_nat, Item (x, rest) -> - gas_check_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt (* control *) | Seq (hd, tl), stack -> - step origination gas ctxt hd stack >>=? fun (trans, gas, ctxt, origination) -> - step origination gas ctxt tl trans + step origination ctxt hd stack >>=? fun (trans, ctxt, origination) -> + step origination ctxt tl trans | If (bt, _), Item (true, rest) -> - step origination (Gas.consume gas Interp_costs.branch) ctxt bt rest + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step origination ctxt bt rest | If (_, bf), Item (false, rest) -> - step origination (Gas.consume gas Interp_costs.branch) ctxt bf rest + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step origination ctxt bf rest | Loop body, Item (true, rest) -> - step origination (Gas.consume gas Interp_costs.loop_cycle) ctxt body rest >>=? fun (trans, gas, ctxt, origination) -> - step origination (Gas.consume gas Interp_costs.loop_cycle) ctxt descr trans + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step origination ctxt body rest >>=? fun (trans, ctxt, origination) -> + step origination ctxt descr trans | Loop _, Item (false, rest) -> - logged_return (rest, gas, ctxt) + logged_return (rest, ctxt) | Loop_left body, Item (L v, rest) -> - step origination (Gas.consume gas Interp_costs.loop_cycle) ctxt body (Item (v, rest)) >>=? fun (trans, gas, ctxt, origination) -> - step origination (Gas.consume gas Interp_costs.loop_cycle) ctxt descr trans + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step origination ctxt body (Item (v, rest)) >>=? fun (trans, ctxt, origination) -> + step origination ctxt descr trans | Loop_left _, Item (R v, rest) -> - let gas = Gas.consume gas Interp_costs.loop_cycle in - Gas.check gas >>=? fun () -> - logged_return (Item (v, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) | Dip b, Item (ign, rest) -> - step origination (Gas.consume gas Interp_costs.stack_op) ctxt b rest >>=? fun (res, gas, ctxt, origination) -> - logged_return ~origination (Item (ign, res), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + step origination ctxt b rest >>=? fun (res, ctxt, origination) -> + logged_return ~origination (Item (ign, res), ctxt) | Exec, Item (arg, Item (lam, rest)) -> - interp ?log origination (Gas.consume gas Interp_costs.exec) orig source amount ctxt lam arg >>=? fun (res, gas, ctxt, origination) -> - logged_return ~origination (Item (res, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> + interp ?log origination orig source amount ctxt lam arg >>=? fun (res, ctxt, origination) -> + logged_return ~origination (Item (res, rest), ctxt) | Lambda lam, rest -> - logged_return ~origination (Item (lam, rest), Gas.consume gas Interp_costs.push, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return ~origination (Item (lam, rest), ctxt) | Fail, _ -> fail (Reject loc) | Nop, stack -> - logged_return (stack, gas, ctxt) + logged_return (stack, ctxt) (* comparison *) | Compare Bool_key, Item (a, Item (b, rest)) -> - gas_compare descr Compare.Bool.compare Interp_costs.compare_bool a b rest + consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest | Compare String_key, Item (a, Item (b, rest)) -> - gas_compare descr Compare.String.compare Interp_costs.compare_string a b rest + consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest | Compare Tez_key, Item (a, Item (b, rest)) -> - gas_compare descr Tez.compare Interp_costs.compare_tez a b rest + consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest | Compare Int_key, Item (a, Item (b, rest)) -> - gas_compare descr Script_int.compare Interp_costs.compare_int a b rest + consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest | Compare Nat_key, Item (a, Item (b, rest)) -> - gas_compare descr Script_int.compare Interp_costs.compare_nat a b rest + consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest | Compare Key_hash_key, Item (a, Item (b, rest)) -> - gas_compare descr Signature.Public_key_hash.compare + consume_gaz_comparison descr Signature.Public_key_hash.compare Interp_costs.compare_key_hash a b rest | Compare Timestamp_key, Item (a, Item (b, rest)) -> - gas_compare descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest + consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest (* comparators *) | Eq, Item (cmpres, rest) -> let cmpres = Script_int.compare cmpres Script_int.zero in let cmpres = Compare.Int.(cmpres = 0) in - logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) | Neq, Item (cmpres, rest) -> let cmpres = Script_int.compare cmpres Script_int.zero in let cmpres = Compare.Int.(cmpres <> 0) in - logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) | Lt, Item (cmpres, rest) -> let cmpres = Script_int.compare cmpres Script_int.zero in let cmpres = Compare.Int.(cmpres < 0) in - logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) | Le, Item (cmpres, rest) -> let cmpres = Script_int.compare cmpres Script_int.zero in let cmpres = Compare.Int.(cmpres <= 0) in - logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) | Gt, Item (cmpres, rest) -> let cmpres = Script_int.compare cmpres Script_int.zero in let cmpres = Compare.Int.(cmpres > 0) in - logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) | Ge, Item (cmpres, rest) -> let cmpres = Script_int.compare cmpres Script_int.zero in let cmpres = Compare.Int.(cmpres >= 0) in - logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) (* protocol *) | Manager, Item ((_, _, contract), rest) -> - let gas = Gas.consume gas Interp_costs.manager in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.manager) >>=? fun ctxt -> Contract.get_manager ctxt contract >>=? fun manager -> - logged_return (Item (manager, rest), gas, ctxt) + logged_return (Item (manager, rest), ctxt) | Transfer_tokens storage_type, Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (storage, Empty)))) -> begin - let gas = Gas.consume gas Interp_costs.transfer in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> Contract.spend_from_script ctxt source amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.get_script ctxt destination >>=? fun destination_script -> - Lwt.return (unparse_data gas storage_type storage) >>=? fun (sto, gas) -> + Lwt.return (unparse_data ctxt storage_type storage) >>=? fun (sto, ctxt) -> let sto = Micheline.strip_locations sto in begin match Script_ir_translator.extract_big_map storage_type storage with | None -> - return (None, gas) + return (None, ctxt) | Some diff -> - Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) -> - return (Some diff, gas) - end >>=? fun (diff, gas) -> + 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 dummy_storage_fee >>=? fun ctxt -> begin match destination_script with @@ -658,36 +665,35 @@ let rec interp (* we see non scripted contracts as (unit, unit) contract *) Lwt.return (ty_eq tp Unit_t |> record_trace (Invalid_contract (loc, destination))) >>=? fun Eq -> - return (ctxt, gas, origination) + return (ctxt, origination) | Some script -> - Lwt.return @@ unparse_data gas tp p >>=? fun (p, gas) -> - execute origination source destination ctxt script amount p gas - >>=? fun (csto, ret, gas, ctxt, origination, maybe_diff) -> + Lwt.return @@ unparse_data ctxt tp p >>=? fun (p, ctxt) -> + execute origination source destination ctxt script amount p + >>=? fun (csto, ret, ctxt, origination, maybe_diff) -> begin match maybe_diff with | None -> - return (None, gas) + return (None, ctxt) | Some diff -> - Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) -> - return (Some diff, gas) - end >>=? fun (maybe_diff, gas) -> + Script_ir_translator.to_serializable_big_map ctxt diff >>=? fun (diff, ctxt) -> + return (Some diff, ctxt) + end >>=? fun (maybe_diff, ctxt) -> Contract.update_script_storage ctxt destination csto maybe_diff >>=? fun ctxt -> trace (Invalid_contract (loc, destination)) - (parse_data ctxt gas Unit_t ret) >>=? fun ((), gas) -> + (parse_data ctxt Unit_t ret) >>=? fun ((), ctxt) -> Fees.update_script_storage ctxt ~source:orig destination dummy_storage_fee >>=? fun ctxt -> - return (ctxt, gas, origination) - end >>=? fun (ctxt, gas, origination) -> + return (ctxt, origination) + end >>=? fun (ctxt, origination) -> Contract.get_script ctxt source >>=? (function | None -> assert false | Some { storage; _ } -> - parse_data ctxt gas storage_type (Micheline.root storage) >>=? fun (sto, gas) -> - logged_return ~origination (Item ((), Item (sto, Empty)), gas, ctxt)) + parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) -> + logged_return ~origination (Item ((), Item (sto, Empty)), ctxt)) end | Transfer_tokens storage_type, Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin - let gas = Gas.consume gas Interp_costs.transfer in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> Contract.spend_from_script ctxt source amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.get_script ctxt destination >>=? function @@ -695,42 +701,41 @@ let rec interp | Some script -> begin match extract_big_map storage_type sto with | None -> - return (None, gas) + return (None, ctxt) | Some diff -> - to_serializable_big_map gas diff >>=? fun (diff, gas) -> - return (Some diff, gas) - end >>=? fun (maybe_diff, gas) -> - Lwt.return (unparse_data gas storage_type sto) >>=? fun (sto, gas) -> + to_serializable_big_map ctxt diff >>=? fun (diff, ctxt) -> + return (Some diff, ctxt) + 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 dummy_storage_fee >>=? fun ctxt -> - Lwt.return (unparse_data gas tp p) >>=? fun (p, gas) -> - execute origination source destination ctxt script amount p gas - >>=? fun (sto, ret, gas, ctxt, origination, maybe_diff) -> + Lwt.return (unparse_data ctxt tp p) >>=? fun (p, ctxt) -> + execute origination source destination ctxt script amount p + >>=? fun (sto, ret, ctxt, origination, maybe_diff) -> begin match maybe_diff with | None -> - return (None, gas) + return (None, ctxt) | Some diff -> - Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) -> - return (Some diff, gas) - end >>=? fun (diff, gas) -> + 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 destination sto diff >>=? fun ctxt -> Fees.update_script_storage ctxt ~source:orig destination dummy_storage_fee >>=? fun ctxt -> trace (Invalid_contract (loc, destination)) - (parse_data ctxt gas tr ret) >>=? fun (v, gas) -> + (parse_data ctxt tr ret) >>=? fun (v, ctxt) -> Contract.get_script ctxt source >>=? (function | None -> assert false | Some { storage ; _ } -> - parse_data ctxt gas storage_type (Micheline.root storage) >>=? fun (sto, gas) -> - logged_return ~origination (Item (v, Item (sto, Empty)), gas, ctxt)) + parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) -> + logged_return ~origination (Item (v, Item (sto, Empty)), ctxt)) end | Create_account, Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> - let gas = Gas.consume gas Interp_costs.create_account in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> Contract.spend_from_script ctxt source credit >>=? fun ctxt -> Lwt.return Tez.(credit -? Constants.origination_burn ctxt) >>=? fun balance -> Contract.originate ctxt @@ -738,12 +743,11 @@ let rec interp ~manager ~delegate ~balance ?script:None ~spendable:true ~delegatable >>=? fun (ctxt, contract, origination) -> Fees.origination_burn ctxt ~source contract >>=? fun ctxt -> - logged_return ~origination (Item ((Unit_t, Unit_t, contract), rest), gas, ctxt) + logged_return ~origination (Item ((Unit_t, Unit_t, contract), rest), ctxt) | Default_account, Item (key, rest) -> - let gas = Gas.consume gas Interp_costs.implicit_account in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> let contract = Contract.implicit_contract key in - logged_return (Item ((Unit_t, Unit_t, contract), rest), gas, ctxt) + logged_return (Item ((Unit_t, Unit_t, contract), rest), ctxt) | Create_contract (storage_type, param_type, return_type), Item (manager, Item (delegate, Item @@ -764,75 +768,73 @@ let rec interp create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init ~param_type ~return_type ~storage_type ~rest | Balance, rest -> - let gas = Gas.consume gas Interp_costs.balance in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> Contract.get_balance ctxt source >>=? fun balance -> - logged_return (Item (balance, rest), gas, ctxt) + logged_return (Item (balance, rest), ctxt) | Now, rest -> - let gas = Gas.consume gas Interp_costs.now in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> let now = Script_timestamp.now ctxt in - logged_return (Item (now, rest), gas, ctxt) + logged_return (Item (now, rest), ctxt) | Check_signature, Item (key, Item ((signature, message), rest)) -> - let gas = Gas.consume gas Interp_costs.check_signature in - Gas.check gas >>=? fun () -> + Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> let message = MBytes.of_string message in let res = Signature.check key signature message in - logged_return (Item (res, rest), gas, ctxt) + logged_return (Item (res, rest), ctxt) | Hash_key, Item (key, rest) -> - logged_return (Item (Signature.Public_key.hash key, rest), Gas.consume gas Interp_costs.hash_key, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> + logged_return (Item (Signature.Public_key.hash key, rest), ctxt) | H ty, Item (v, rest) -> - Gas.consume_check gas (Interp_costs.hash v) >>=? fun gas -> - Lwt.return @@ hash_data gas ty v >>=? fun (hash, gas) -> - logged_return (Item (hash, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt (Interp_costs.hash v)) >>=? fun ctxt -> + Lwt.return @@ hash_data ctxt ty v >>=? fun (hash, ctxt) -> + logged_return (Item (hash, rest), ctxt) | Steps_to_quota, rest -> - let gas = Gas.consume gas Interp_costs.steps_to_quota in - logged_return (Item (Interp_costs.get_steps_to_quota gas, rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> + let steps = match Gas.level ctxt with + | Limited { remaining } -> remaining + | Unaccounted -> max_int in + logged_return (Item (Script_int.(abs (of_int steps)), rest), ctxt) | Source (ta, tb), rest -> - let gas = Gas.consume gas Interp_costs.source in - Gas.check gas >>=? fun () -> - logged_return (Item ((ta, tb, orig), rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item ((ta, tb, orig), rest), ctxt) | Self (ta, tb), rest -> - let gas = Gas.consume gas Interp_costs.self in - Gas.check gas >>=? fun () -> - logged_return (Item ((ta, tb, source), rest), gas, ctxt) + Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> + logged_return (Item ((ta, tb, source), rest), ctxt) | Amount, rest -> - let gas = Gas.consume gas Interp_costs.amount in - Gas.check gas >>=? fun () -> - logged_return (Item (amount, rest), gas, ctxt) in + Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> + logged_return (Item (amount, rest), ctxt) in let stack = (Item (arg, Empty)) in begin match log with | None -> () | Some log -> - log := (code.loc, gas, unparse_stack (stack, code.bef)) :: !log + log := (code.loc, Gas.level ctxt, unparse_stack ctxt (stack, code.bef)) :: !log end ; - step origination gas ctxt code stack >>=? fun (Item (ret, Empty), gas, ctxt, origination) -> - return (ret, gas, ctxt, origination) + step origination ctxt code stack >>=? fun (Item (ret, Empty), ctxt, origination) -> + return (ret, ctxt, origination) (* ---- contract handling ---------------------------------------------------*) -and execute ?log origination orig source ctxt script amount arg gas : - (Script.expr * Script.node * Gas.t * context * Contract.origination_nonce * +and execute ?log origination orig source ctxt script amount arg : + (Script.expr * Script.node * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) tzresult Lwt.t = - parse_script ctxt gas script - >>=? fun ((Ex_script { code; arg_type; ret_type; storage; storage_type }), gas) -> - parse_data ctxt gas arg_type arg >>=? fun (arg, gas) -> + 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 gas orig source amount ctxt code (arg, storage)) - >>=? fun ((ret, sto), gas, ctxt, origination) -> - Lwt.return @@ unparse_data gas storage_type sto >>=? fun (storage, gas) -> - Lwt.return @@ unparse_data gas ret_type ret >>=? fun (ret, gas) -> - return (Micheline.strip_locations storage, ret, gas, ctxt, origination, + (interp ?log origination orig source amount ctxt 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 gas = +let trace origination orig source ctxt script amount arg = let log = ref [] in - execute ~log origination orig source ctxt script amount (Micheline.root arg) gas - >>=? fun (sto, res, gas, ctxt, origination, maybe_big_map) -> - return ((sto, Micheline.strip_locations res, gas, ctxt, origination, maybe_big_map), List.rev !log) + 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) -let execute origination orig source ctxt script amount arg gas = - execute origination orig source ctxt script amount (Micheline.root arg) gas - >>=? fun (sto, res, gas, ctxt, origination, maybe_big_map) -> - return (sto, Micheline.strip_locations res, gas, ctxt, origination, maybe_big_map) +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) diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.mli b/src/proto_alpha/lib_protocol/src/script_interpreter.mli index 45e9f416e..9e20235b1 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.mli @@ -20,14 +20,14 @@ val execute: Contract.origination_nonce -> Contract.t -> Contract.t -> Alpha_context.t -> Script.t -> Tez.t -> - Script.expr -> Gas.t -> - (Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * + Script.expr -> + (Script.expr * Script.expr * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) tzresult Lwt.t val trace: Contract.origination_nonce -> Contract.t -> Contract.t -> Alpha_context.t -> Script.t -> Tez.t -> - Script.expr -> Gas.t -> - ((Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) * + 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 diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml index a05415039..d8e63e72f 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -553,108 +553,104 @@ let rec unparse_ty module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse let rec unparse_data - : type a. Gas.t -> a ty -> a -> (Script.node * Gas.t) tzresult - = fun gas ty a -> - Gas.consume_check_error gas Unparse_costs.cycle >>? fun gas -> + : type a. context -> a ty -> a -> (Script.node * context) tzresult + = fun ctxt ty a -> + Gas.consume ctxt Unparse_costs.cycle >>? fun gas -> match ty, a with | Unit_t, () -> - Gas.consume_check_error gas Unparse_costs.unit >|? fun gas -> + Gas.consume ctxt Unparse_costs.unit >|? fun gas -> (Prim (-1, D_Unit, [], None), gas) | Int_t, v -> - Gas.consume_check_error gas (Unparse_costs.int v) >|? fun gas -> + Gas.consume ctxt (Unparse_costs.int v) >|? fun gas -> (Int (-1, Script_int.to_string v), gas) | Nat_t, v -> - Gas.consume_check_error gas (Unparse_costs.int v) >|? fun gas -> + Gas.consume ctxt (Unparse_costs.int v) >|? fun gas -> (Int (-1, Script_int.to_string v), gas) | String_t, s -> - Gas.consume_check_error gas (Unparse_costs.string s) >|? fun gas -> + Gas.consume ctxt (Unparse_costs.string s) >|? fun gas -> (String (-1, s), gas) | Bool_t, true -> - Gas.consume_check_error gas Unparse_costs.bool >|? fun gas -> + Gas.consume ctxt Unparse_costs.bool >|? fun gas -> (Prim (-1, D_True, [], None), gas) | Bool_t, false -> - Gas.consume_check_error gas Unparse_costs.bool >|? fun gas -> + Gas.consume ctxt Unparse_costs.bool >|? fun gas -> (Prim (-1, D_False, [], None), gas) | Timestamp_t, t -> - Gas.consume_check_error gas (Unparse_costs.timestamp t) >>? fun gas -> + Gas.consume ctxt (Unparse_costs.timestamp t) >>? fun gas -> begin match Script_timestamp.to_notation t with | None -> ok @@ (Int (-1, Script_timestamp.to_num_str t), gas) | Some s -> ok @@ (String (-1, s), gas) end | Contract_t _, (_, _, c) -> - Gas.consume_check_error gas Unparse_costs.contract >|? fun gas -> + Gas.consume ctxt Unparse_costs.contract >|? fun gas -> (String (-1, Contract.to_b58check c), gas) | Signature_t, s -> - Gas.consume_check_error gas Unparse_costs.signature >|? fun gas -> + Gas.consume ctxt Unparse_costs.signature >|? fun gas -> let `Hex text = MBytes.to_hex (Data_encoding.Binary.to_bytes_exn Signature.encoding s) in (String (-1, text), gas) | Tez_t, v -> - Gas.consume_check_error gas Unparse_costs.tez >|? fun gas -> + Gas.consume ctxt Unparse_costs.tez >|? fun gas -> (String (-1, Tez.to_string v), gas) | Key_t, k -> - Gas.consume_check_error gas Unparse_costs.key >|? fun gas -> + Gas.consume ctxt Unparse_costs.key >|? fun gas -> (String (-1, Signature.Public_key.to_b58check k), gas) | Key_hash_t, k -> - Gas.consume_check_error gas Unparse_costs.key_hash >|? fun gas -> + Gas.consume ctxt Unparse_costs.key_hash >|? fun gas -> (String (-1, Signature.Public_key_hash.to_b58check k), gas) | Pair_t ((tl, _), (tr, _)), (l, r) -> - Gas.consume_check_error gas Unparse_costs.pair >>? fun gas -> + Gas.consume ctxt Unparse_costs.pair >>? fun gas -> unparse_data gas tl l >>? fun (l, gas) -> unparse_data gas tr r >|? fun (r, gas) -> (Prim (-1, D_Pair, [ l; r ], None), gas) | Union_t ((tl, _), _), L l -> - Gas.consume_check_error gas Unparse_costs.union >>? fun gas -> + Gas.consume ctxt Unparse_costs.union >>? fun gas -> unparse_data gas tl l >|? fun (l, gas) -> (Prim (-1, D_Left, [ l ], None), gas) | Union_t (_, (tr, _)), R r -> - Gas.consume_check_error gas Unparse_costs.union >>? fun gas -> + Gas.consume ctxt Unparse_costs.union >>? fun gas -> unparse_data gas tr r >|? fun (r, gas) -> (Prim (-1, D_Right, [ r ], None), gas) | Option_t t, Some v -> - Gas.consume_check_error gas Unparse_costs.some >>? fun gas -> + Gas.consume ctxt Unparse_costs.some >>? fun gas -> unparse_data gas t v >|? fun (v, gas) -> (Prim (-1, D_Some, [ v ], None), gas) | Option_t _, None -> - Gas.consume_check_error gas Unparse_costs.none >|? fun gas -> + Gas.consume ctxt Unparse_costs.none >|? fun gas -> (Prim (-1, D_None, [], None), gas) | List_t t, items -> - Gas.fold_right_error - ~cycle_cost:Unparse_costs.list_element - gas - (fun gas element l -> - unparse_data gas t element >|? fun (unparsed, gas) -> - (unparsed :: l, gas)) - [] - items >|? fun (items, gas) -> + List.fold_right + (fun element acc -> + acc >>? fun (l, ctxt) -> + Gas.consume ctxt Unparse_costs.list_element >>? fun ctxt -> + unparse_data ctxt t element >>? fun (unparsed, ctxt) -> + ok (unparsed :: l, ctxt)) + items + (ok ([], ctxt)) >|? fun (items, gas) -> (Micheline.Seq (-1, items, None), gas) | Set_t t, set -> let t = ty_of_comparable_ty t in - Gas.consume_check_error gas - (Unparse_costs.set_to_list set) >>? fun gas -> - let items = set_fold (fun e acc -> e :: acc) set [] in - Gas.fold_left_error - gas - ~cycle_cost:Unparse_costs.set_element - (fun gas item l -> - unparse_data gas t item >|? fun (item, gas) -> - (item :: l, gas)) - [] items >|? fun (items, gas) -> - (Micheline.Seq (-1, items, None), gas) + set_fold + (fun item acc -> + acc >>? fun (l, ctxt) -> + Gas.consume ctxt Unparse_costs.set_element >>? fun ctxt -> + unparse_data ctxt t item >>? fun (item, ctxt) -> + ok (item :: l, ctxt)) + set (ok ([], ctxt)) >|? fun (items, gas) -> + (Micheline.Seq (-1, List.rev items, None), gas) | Map_t (kt, vt), map -> let kt = ty_of_comparable_ty kt in - Gas.consume_check_error gas (Unparse_costs.map_to_list map) >>? fun gas -> - let elements = map_fold (fun k v acc -> (k, v) :: acc) map [] in - Gas.fold_left_error gas - ~cycle_cost:Unparse_costs.map_element - (fun gas (k, v) acc -> - unparse_data gas kt k >>? fun (key, gas) -> - unparse_data gas vt v >>? fun (value, gas) -> - ok (Prim (-1, D_Elt, [ key ; value ], None) :: acc, gas)) - [] elements >|? fun (items, gas) -> - (Micheline.Seq (-1, items, None), gas) + map_fold + (fun k v acc -> + acc >>? fun (l, ctxt) -> + Gas.consume ctxt Unparse_costs.map_element >>? fun ctxt -> + unparse_data ctxt kt k >>? fun (key, ctxt) -> + unparse_data ctxt vt v >>? fun (value, ctxt) -> + ok (Prim (-1, D_Elt, [ key ; value ], None) :: l, ctxt)) + map (ok ([], ctxt)) >|? fun (items, gas) -> + (Micheline.Seq (-1, List.rev items, None), gas) | Big_map_t (_kt, _kv), _map -> ok (Micheline.Seq (-1, [], None), gas) | Lambda_t _, Lam (_, original_code) -> @@ -897,16 +893,16 @@ let merge_branches module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking -let rec parse_comparable_ty : Gas.t -> Script.node -> (ex_comparable_ty * Gas.t) tzresult = fun gas node -> - Gas.consume_check_error gas Typecheck_costs.cycle >>? fun gas -> +let rec parse_comparable_ty : context -> Script.node -> (ex_comparable_ty * context) tzresult = fun ctxt node -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> match node with - | Prim (_, T_int, [], _) -> ok ((Ex_comparable_ty Int_key), gas) - | Prim (_, T_nat, [], _) -> ok ((Ex_comparable_ty Nat_key), gas) - | Prim (_, T_string, [], _) -> ok ((Ex_comparable_ty String_key), gas) - | Prim (_, T_tez, [], _) -> ok ((Ex_comparable_ty Tez_key), gas) - | Prim (_, T_bool, [], _) -> ok ((Ex_comparable_ty Bool_key), gas) - | Prim (_, T_key_hash, [], _) -> ok ((Ex_comparable_ty Key_hash_key), gas) - | Prim (_, T_timestamp, [], _) -> ok ((Ex_comparable_ty Timestamp_key), gas) + | Prim (_, T_int, [], _) -> ok ((Ex_comparable_ty Int_key), ctxt) + | Prim (_, T_nat, [], _) -> ok ((Ex_comparable_ty Nat_key), ctxt) + | Prim (_, T_string, [], _) -> ok ((Ex_comparable_ty String_key), ctxt) + | Prim (_, T_tez, [], _) -> ok ((Ex_comparable_ty Tez_key), ctxt) + | Prim (_, T_bool, [], _) -> ok ((Ex_comparable_ty Bool_key), ctxt) + | Prim (_, T_key_hash, [], _) -> ok ((Ex_comparable_ty Key_hash_key), ctxt) + | Prim (_, T_timestamp, [], _) -> ok ((Ex_comparable_ty Timestamp_key), ctxt) | Prim (loc, (T_int | T_nat | T_string | T_tez | T_bool | T_key | T_timestamp as prim), l, _) -> @@ -914,7 +910,7 @@ let rec parse_comparable_ty : Gas.t -> Script.node -> (ex_comparable_ty * Gas.t) | Prim (loc, (T_pair | T_or | T_set | T_map | T_list | T_option | T_lambda | T_unit | T_signature | T_contract), _, _) as expr -> - parse_ty gas false expr >>? fun ((Ex_ty ty, _), _gas) -> + parse_ty ctxt false expr >>? fun ((Ex_ty ty, _), _ctxt) -> error (Comparable_type_expected (loc, ty)) | expr -> error @@ unexpected expr [] Type_namespace @@ -923,9 +919,9 @@ let rec parse_comparable_ty : Gas.t -> Script.node -> (ex_comparable_ty * Gas.t) T_key ; T_key_hash ; T_timestamp ] and parse_ty : - Gas.t -> bool -> Script.node -> - ((ex_ty * annot) * Gas.t) tzresult = fun gas big_map_possible node -> - Gas.consume_check_error gas Typecheck_costs.cycle >>? fun gas -> + context -> bool -> Script.node -> + ((ex_ty * annot) * context) tzresult = fun ctxt big_map_possible node -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> match node with | Prim (_, T_pair, [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], @@ -933,7 +929,7 @@ and parse_ty : when big_map_possible -> begin match args with | [ key_ty ; value_ty ] -> - parse_comparable_ty gas key_ty >>? fun ((Ex_comparable_ty key_ty), gas) -> + parse_comparable_ty ctxt key_ty >>? fun ((Ex_comparable_ty key_ty), gas) -> parse_ty gas false value_ty >>? fun ((Ex_ty value_ty, right_annot), gas) -> error_unexpected_annot big_map_loc right_annot >>? fun () -> parse_ty gas false remaining_storage >>? fun ((Ex_ty remaining_storage, remaining_annot), gas) -> @@ -944,72 +940,72 @@ and parse_ty : | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) end | Prim (_, T_unit, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Unit_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Unit_t, annot), ctxt) | Prim (_, T_int, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Int_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Int_t, annot), ctxt) | Prim (_, T_nat, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Nat_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Nat_t, annot), ctxt) | Prim (_, T_string, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty String_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty String_t, annot), ctxt) | Prim (_, T_tez, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Tez_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Tez_t, annot), ctxt) | Prim (_, T_bool, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Bool_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Bool_t, annot), ctxt) | Prim (_, T_key, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Key_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Key_t, annot), ctxt) | Prim (_, T_key_hash, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Key_hash_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Key_hash_t, annot), ctxt) | Prim (_, T_timestamp, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Timestamp_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Timestamp_t, annot), ctxt) | Prim (_, T_signature, [], annot) -> - Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas -> - ok ((Ex_ty Signature_t, annot), gas) + Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> + ok ((Ex_ty Signature_t, annot), ctxt) | Prim (loc, T_contract, [ utl; utr ], annot) -> - Gas.consume_check_error gas Typecheck_costs.two_arg_type >>? fun gas -> - parse_ty gas false utl >>? fun ((Ex_ty tl, left_annot), gas) -> - parse_ty gas false utr >>? fun ((Ex_ty tr, right_annot), gas) -> + Gas.consume ctxt Typecheck_costs.two_arg_type >>? fun ctxt -> + parse_ty ctxt false utl >>? fun ((Ex_ty tl, left_annot), ctxt) -> + parse_ty ctxt false utr >>? fun ((Ex_ty tr, right_annot), ctxt) -> error_unexpected_annot loc left_annot >>? fun () -> error_unexpected_annot loc right_annot >|? fun () -> - ((Ex_ty (Contract_t (tl, tr)), annot), gas) + ((Ex_ty (Contract_t (tl, tr)), annot), ctxt) | Prim (_, T_pair, [ utl; utr ], annot) -> - parse_ty gas false utl >>? fun ((Ex_ty tl, left_annot), gas) -> - parse_ty gas false utr >|? fun ((Ex_ty tr, right_annot), gas) -> - ((Ex_ty (Pair_t ((tl, left_annot), (tr, right_annot))), annot), gas) + parse_ty ctxt false utl >>? fun ((Ex_ty tl, left_annot), ctxt) -> + parse_ty ctxt false utr >|? fun ((Ex_ty tr, right_annot), ctxt) -> + ((Ex_ty (Pair_t ((tl, left_annot), (tr, right_annot))), annot), ctxt) | Prim (_, T_or, [ utl; utr ], annot) -> - parse_ty gas false utl >>? fun ((Ex_ty tl, left_annot), gas) -> - parse_ty gas false utr >|? fun ((Ex_ty tr, right_annot), gas) -> - ((Ex_ty (Union_t ((tl, left_annot), (tr, right_annot))), annot), gas) + parse_ty ctxt false utl >>? fun ((Ex_ty tl, left_annot), ctxt) -> + parse_ty ctxt false utr >|? fun ((Ex_ty tr, right_annot), ctxt) -> + ((Ex_ty (Union_t ((tl, left_annot), (tr, right_annot))), annot), ctxt) | Prim (_, T_lambda, [ uta; utr ], annot) -> - parse_ty gas false uta >>? fun ((Ex_ty ta, _), gas) -> - parse_ty gas false utr >|? fun ((Ex_ty tr, _), gas) -> - ((Ex_ty (Lambda_t (ta, tr)), annot), gas) + parse_ty ctxt false uta >>? fun ((Ex_ty ta, _), ctxt) -> + parse_ty ctxt false utr >|? fun ((Ex_ty tr, _), ctxt) -> + ((Ex_ty (Lambda_t (ta, tr)), annot), ctxt) | Prim (loc, T_option, [ ut ], annot) -> - parse_ty gas false ut >>? fun ((Ex_ty t, opt_annot), gas) -> + parse_ty ctxt false ut >>? fun ((Ex_ty t, opt_annot), ctxt) -> error_unexpected_annot loc annot >|? fun () -> - ((Ex_ty (Option_t t), opt_annot), gas) + ((Ex_ty (Option_t t), opt_annot), ctxt) | Prim (loc, T_list, [ ut ], annot) -> - Gas.consume_check_error gas Typecheck_costs.one_arg_type >>? fun gas -> - parse_ty gas false ut >>? fun ((Ex_ty t, list_annot), gas) -> + Gas.consume ctxt Typecheck_costs.one_arg_type >>? fun ctxt -> + parse_ty ctxt false ut >>? fun ((Ex_ty t, list_annot), ctxt) -> error_unexpected_annot loc list_annot >>? fun () -> - ok ((Ex_ty (List_t t), annot), gas) + ok ((Ex_ty (List_t t), annot), ctxt) | Prim (_, T_set, [ ut ], annot) -> - Gas.consume_check_error gas Typecheck_costs.one_arg_type >>? fun gas -> - parse_comparable_ty gas ut >>? fun ((Ex_comparable_ty t), gas) -> - ok ((Ex_ty (Set_t t), annot), gas) + Gas.consume ctxt Typecheck_costs.one_arg_type >>? fun ctxt -> + parse_comparable_ty ctxt ut >>? fun ((Ex_comparable_ty t), ctxt) -> + ok ((Ex_ty (Set_t t), annot), ctxt) | Prim (_, T_map, [ uta; utr ], annot) -> - Gas.consume_check_error gas Typecheck_costs.one_arg_type >>? fun gas -> - parse_comparable_ty gas uta >>? fun ((Ex_comparable_ty ta), gas) -> - parse_ty gas false utr >>? fun ((Ex_ty tr, _), gas) -> - ok ((Ex_ty (Map_t (ta, tr)), annot), gas) + Gas.consume ctxt Typecheck_costs.one_arg_type >>? fun ctxt -> + parse_comparable_ty ctxt uta >>? fun ((Ex_comparable_ty ta), ctxt) -> + parse_ty ctxt false utr >>? fun ((Ex_ty tr, _), ctxt) -> + ok ((Ex_ty (Map_t (ta, tr)), annot), ctxt) | Prim (loc, T_big_map, _, _) -> error (Unexpected_big_map loc) | Prim (loc, (T_unit | T_signature @@ -1041,81 +1037,80 @@ type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script let rec parse_data : type a. ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> Gas.t -> a ty -> Script.node -> (a * Gas.t) tzresult Lwt.t - = fun ?type_logger ctxt gas ty script_data -> - Gas.consume_check gas Typecheck_costs.cycle >>=? fun gas -> + context -> a ty -> Script.node -> (a * context) tzresult Lwt.t + = fun ?type_logger ctxt ty script_data -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> let error () = Invalid_constant (location script_data, strip_locations script_data, ty) in let traced body = trace (error ()) body in - let parse_items ?type_logger loc ctxt gas expr key_type value_type items item_wrapper = - (Gas.fold_left - ~cycle_cost:Typecheck_costs.cycle - gas - (fun gas item (last_value, map) -> - match item with - | Prim (_, D_Elt, [ k; v ], _) -> - parse_comparable_data ?type_logger ctxt gas key_type k >>=? fun (k, gas) -> - parse_data ?type_logger ctxt gas value_type v >>=? fun (v, gas) -> - begin match last_value with - | Some value -> - if Compare.Int.(0 <= (compare_comparable key_type value k)) - then - if Compare.Int.(0 = (compare_comparable key_type value k)) - then fail (Duplicate_map_keys (loc, strip_locations expr)) - else fail (Unordered_map_keys (loc, strip_locations expr)) - else return () - | None -> return () - end >>=? fun () -> - return ((Some k, map_update k (Some (item_wrapper v)) map), gas) - | Prim (loc, D_Elt, l, _) -> - fail @@ Invalid_arity (loc, D_Elt, 2, List.length l) - | Prim (loc, name, _, _) -> - fail @@ Invalid_primitive (loc, [ D_Elt ], name) - | Int _ | String _ | Seq _ -> - fail (error ())) - (None, empty_map key_type) items) |> traced >>|? fun ((_prev, items), gas) -> - (items, gas) in + let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper = + fold_left_s + (fun (last_value, map, ctxt) item -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + match item with + | Prim (_, D_Elt, [ k; v ], _) -> + parse_comparable_data ?type_logger ctxt key_type k >>=? fun (k, ctxt) -> + parse_data ?type_logger ctxt value_type v >>=? fun (v, ctxt) -> + begin match last_value with + | Some value -> + if Compare.Int.(0 <= (compare_comparable key_type value k)) + then + if Compare.Int.(0 = (compare_comparable key_type value k)) + then fail (Duplicate_map_keys (loc, strip_locations expr)) + else fail (Unordered_map_keys (loc, strip_locations expr)) + else return () + | None -> return () + end >>=? fun () -> + return (Some k, map_update k (Some (item_wrapper v)) map, ctxt) + | Prim (loc, D_Elt, l, _) -> + fail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + fail @@ Invalid_primitive (loc, [ D_Elt ], name) + | Int _ | String _ | Seq _ -> + fail (error ())) + (None, empty_map key_type, ctxt) items |> traced >>|? fun (_, items, ctxt) -> + (items, ctxt) in match ty, script_data with (* Unit *) | Unit_t, Prim (_, D_Unit, [], _) -> - Gas.consume_check gas Typecheck_costs.unit >>|? fun gas -> - ((() : a), gas) + Lwt.return (Gas.consume ctxt Typecheck_costs.unit) >>|? fun ctxt -> + ((() : a), ctxt) | Unit_t, Prim (loc, D_Unit, l, _) -> traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l))) | Unit_t, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Unit ])) (* Booleans *) | Bool_t, Prim (_, D_True, [], _) -> - Gas.consume_check gas Typecheck_costs.bool >>|? fun gas -> - (true, gas) + Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> + (true, ctxt) | Bool_t, Prim (_, D_False, [], _) -> - Gas.consume_check gas Typecheck_costs.bool >>|? fun gas -> - (false, gas) + Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> + (false, ctxt) | Bool_t, Prim (loc, (D_True | D_False as c), l, _) -> traced (fail (Invalid_arity (loc, c, 0, List.length l))) | Bool_t, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_True ; D_False ])) (* Strings *) | String_t, String (_, v) -> - Gas.consume_check gas (Typecheck_costs.string (String.length v)) >>|? fun gas -> - (v, gas) + Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v))) >>|? fun ctxt -> + (v, ctxt) | String_t, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Integers *) | Int_t, Int (_, v) -> - Gas.consume_check gas (Typecheck_costs.int_of_string v) >>=? fun gas -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.int_of_string v)) >>=? fun ctxt -> begin match Script_int.of_string v with | None -> fail (error ()) - | Some v -> return (v, gas) + | Some v -> return (v, ctxt) end | Nat_t, Int (_, v) -> - Gas.consume_check gas (Typecheck_costs.int_of_string v) >>=? fun gas -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.int_of_string v)) >>=? fun ctxt -> begin match Script_int.of_string v with | None -> fail (error ()) | Some v -> if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then - return (Script_int.abs v, gas) + return (Script_int.abs v, ctxt) else fail (error ()) end | Int_t, expr -> @@ -1124,11 +1119,11 @@ let rec parse_data traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) (* Tez amounts *) | Tez_t, String (_, v) -> - Gas.consume_check gas Typecheck_costs.tez >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.tez) >>=? fun ctxt -> begin try match Tez.of_string v with | None -> raise Exit - | Some tez -> return (tez, gas) + | Some tez -> return (tez, ctxt) with _ -> fail @@ error () end @@ -1136,17 +1131,17 @@ let rec parse_data traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Timestamps *) | Timestamp_t, (Int (_, v)) -> - Gas.consume_check gas (Typecheck_costs.int_of_string v) >>=? fun gas -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.int_of_string v)) >>=? fun ctxt -> begin match Script_timestamp.of_string v with - | Some v -> return (v, gas) + | Some v -> return (v, ctxt) | None -> fail (error ()) end | Timestamp_t, String (_, s) -> - Gas.consume_check gas Typecheck_costs.string_timestamp >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt -> begin try match Script_timestamp.of_string s with - | Some v -> return (v, gas) + | Some v -> return (v, ctxt) | None -> fail (error ()) with _ -> fail (error ()) end @@ -1154,29 +1149,29 @@ let rec parse_data traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr))) (* IDs *) | Key_t, String (_, s) -> - Gas.consume_check gas Typecheck_costs.key >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt -> begin try - return (Signature.Public_key.of_b58check_exn s, gas) + return (Signature.Public_key.of_b58check_exn s, ctxt) with _ -> fail (error ()) end | Key_t, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) | Key_hash_t, String (_, s) -> - Gas.consume_check gas Typecheck_costs.key_hash >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt -> begin try - return (Signature.Public_key_hash.of_b58check_exn s, gas) + return (Signature.Public_key_hash.of_b58check_exn s, ctxt) with _ -> fail (error ()) end | Key_hash_t, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Signatures *) | Signature_t, String (_, s) -> begin try - Gas.consume_check gas Typecheck_costs.signature >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt -> match Data_encoding.Binary.of_bytes Signature.encoding (MBytes.of_hex (`Hex s)) with - | Some s -> return (s, gas) + | Some s -> return (s, ctxt) | None -> raise Not_found with _ -> fail (error ()) @@ -1185,59 +1180,59 @@ let rec parse_data traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Contracts *) | Contract_t (ty1, ty2), String (loc, s) -> - Gas.consume_check gas Typecheck_costs.contract >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> traced @@ (Lwt.return (Contract.of_b58check s)) >>=? fun c -> - parse_contract ctxt gas ty1 ty2 loc c >>=? fun _ -> - return ((ty1, ty2, c), gas) + parse_contract ctxt ty1 ty2 loc c >>=? fun _ -> + return ((ty1, ty2, c), ctxt) | Contract_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Pairs *) | Pair_t ((ta, _), (tb, _)), Prim (_, D_Pair, [ va; vb ], _) -> - Gas.consume_check gas Typecheck_costs.pair >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.pair) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt gas ta va >>=? fun (va, gas) -> - parse_data ?type_logger ctxt gas tb vb >>=? fun (vb, gas) -> - return ((va, vb), gas) + parse_data ?type_logger ctxt ta va >>=? fun (va, ctxt) -> + parse_data ?type_logger ctxt tb vb >>=? fun (vb, ctxt) -> + return ((va, vb), ctxt) | Pair_t _, Prim (loc, D_Pair, l, _) -> fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) | Pair_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Pair ])) (* Unions *) | Union_t ((tl, _), _), Prim (_, D_Left, [ v ], _) -> - Gas.consume_check gas Typecheck_costs.union >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt gas tl v >>=? fun (v, gas) -> - return (L v, gas) + parse_data ?type_logger ctxt tl v >>=? fun (v, ctxt) -> + return (L v, ctxt) | Union_t _, Prim (loc, D_Left, l, _) -> fail @@ Invalid_arity (loc, D_Left, 1, List.length l) | Union_t (_, (tr, _)), Prim (_, D_Right, [ v ], _) -> - Gas.consume_check gas Typecheck_costs.union >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt gas tr v >>=? fun (v, gas) -> - return (R v, gas) + parse_data ?type_logger ctxt tr v >>=? fun (v, ctxt) -> + return (R v, ctxt) | Union_t _, Prim (loc, D_Right, l, _) -> fail @@ Invalid_arity (loc, D_Right, 1, List.length l) | Union_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Left ; D_Right ])) (* Lambdas *) | Lambda_t (ta, tr), (Seq _ as script_instr) -> - Gas.consume_check gas Typecheck_costs.lambda >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt -> traced @@ - parse_returning Lambda ?type_logger ctxt gas (ta, Some "@arg") tr script_instr + parse_returning Lambda ?type_logger ctxt (ta, Some "@arg") tr script_instr | Lambda_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Options *) | Option_t t, Prim (_, D_Some, [ v ], _) -> - Gas.consume_check gas Typecheck_costs.some >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.some) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt gas t v >>=? fun (v, gas) -> - return (Some v, gas) + parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + return (Some v, ctxt) | Option_t _, Prim (loc, D_Some, l, _) -> fail @@ Invalid_arity (loc, D_Some, 1, List.length l) | Option_t _, Prim (_, D_None, [], _) -> - Gas.consume_check gas Typecheck_costs.none >>=? fun gas -> - return (None, gas) + Lwt.return (Gas.consume ctxt Typecheck_costs.none) >>=? fun ctxt -> + return (None, ctxt) | Option_t _, Prim (loc, D_None, l, _) -> fail @@ Invalid_arity (loc, D_None, 0, List.length l) | Option_t _, expr -> @@ -1246,22 +1241,22 @@ let rec parse_data | List_t t, Seq (loc, items, annot) -> fail_unexpected_annot loc annot >>=? fun () -> traced @@ - (Gas.fold_right ~cycle_cost:Typecheck_costs.list_element - gas - (fun gas v rest -> - parse_data ?type_logger ctxt gas t v >>=? fun (v, gas) -> - return ((v :: rest), gas)) - [] items) + fold_right_s + (fun v (rest, ctxt) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.list_element) >>=? fun ctxt -> + parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + return ((v :: rest), ctxt)) + items ([], ctxt) | List_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Sets *) | Set_t t, (Seq (loc, vs, annot) as expr) -> fail_unexpected_annot loc annot >>=? fun () -> traced @@ - Gas.fold_left ~cycle_cost:Typecheck_costs.set_element - gas - (fun gas v (last_value, set) -> - parse_comparable_data ?type_logger ctxt gas t v >>=? fun (v, gas) -> + fold_left_s + (fun (last_value, set, ctxt) v -> + Lwt.return (Gas.consume ctxt Typecheck_costs.set_element) >>=? fun ctxt -> + parse_comparable_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> begin match last_value with | Some value -> if Compare.Int.(0 <= (compare_comparable t value v)) @@ -1272,37 +1267,37 @@ let rec parse_data else return () | None -> return () end >>=? fun () -> - Gas.consume_check gas (Michelson_v1_gas.Cost_of.set_update v false set) >>=? fun gas -> - return ((Some v, set_update v true set), gas)) - (None, empty_set t) vs >>|? fun ((_, set), gas) -> - (set, gas) + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.set_update v false set)) >>=? fun ctxt -> + return (Some v, set_update v true set, ctxt)) + (None, empty_set t, ctxt) vs >>|? fun (_, set, ctxt) -> + (set, ctxt) | Set_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Maps *) | Map_t (tk, tv), (Seq (loc, vs, annot) as expr) -> fail_unexpected_annot loc annot >>=? fun () -> - parse_items ?type_logger loc ctxt gas expr tk tv vs (fun x -> x) + parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) | Map_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) | Big_map_t (tk, tv), (Seq (loc, vs, annot) as expr) -> fail_unexpected_annot loc annot >>=? fun () -> - parse_items ?type_logger loc ctxt gas expr tk tv vs (fun x -> Some x) >>|? fun (diff, gas) -> - ({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, gas) + parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) -> + ({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) | Big_map_t (_tk, _tv), expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) and parse_comparable_data : type a. ?type_logger:(int -> Script.expr list -> Script.expr list -> unit) -> - context -> Gas.t -> a comparable_ty -> Script.node -> (a * Gas.t) tzresult Lwt.t - = fun ?type_logger ctxt gas ty script_data -> - parse_data ?type_logger ctxt gas (ty_of_comparable_ty ty) script_data + context -> a comparable_ty -> Script.node -> (a * context) tzresult Lwt.t + = fun ?type_logger ctxt ty script_data -> + parse_data ?type_logger ctxt (ty_of_comparable_ty ty) script_data and parse_returning : type arg ret. tc_context -> context -> ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - Gas.t -> arg ty * annot -> ret ty -> Script.node -> ((arg, ret) lambda * Gas.t) tzresult Lwt.t = - fun tc_context ctxt ?type_logger gas (arg, arg_annot) ret script_instr -> - parse_instr tc_context ctxt ?type_logger gas + arg ty * annot -> ret ty -> Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = + fun tc_context ctxt ?type_logger (arg, arg_annot) ret script_instr -> + parse_instr tc_context ctxt ?type_logger script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), gas) -> trace @@ -1320,11 +1315,10 @@ and parse_instr tc_context -> context -> ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - Gas.t -> - Script.node -> bef stack_ty -> (bef judgement * Gas.t) tzresult Lwt.t = - fun tc_context ctxt ?type_logger gas script_instr stack_ty -> + Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = + fun tc_context ctxt ?type_logger script_instr stack_ty -> let return : - bef judgement * Gas.t -> (bef judgement * Gas.t) tzresult Lwt.t = fun (judgement, gas) -> + context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = fun ctxt judgement -> match judgement with | Typed { instr ; loc ; aft ; _ } -> let maximum_type_size = Constants.michelson_maximum_type_size ctxt in @@ -1334,9 +1328,9 @@ and parse_instr if Compare.Int.(type_size > maximum_type_size) then fail (Type_too_large (loc, type_size, maximum_type_size)) else - return (judgement, gas) + return (judgement, ctxt) | Failed _ -> - return (judgement, gas) in + return (judgement, ctxt) in let keep_or_rewrite_annot value_annot instr_annot = match value_annot, instr_annot with | annot, None -> annot @@ -1347,122 +1341,139 @@ and parse_instr Lwt.return check in let check_item_ty exp got loc n = check_item (ty_eq exp got) loc n in - let typed ?(gas = gas) loc (instr, aft) = + let typed ctxt loc instr aft = begin match type_logger, script_instr with | None, _ | Some _, (Seq (-1, _, _) | Int _ | String _) -> () | Some log, (Prim _ | Seq _) -> log loc (unparse_stack stack_ty) (unparse_stack aft) end ; - (Typed { loc ; instr ; bef = stack_ty ; aft }, gas) in + return ctxt (Typed { loc ; instr ; bef = stack_ty ; aft }) in match script_instr, stack_ty with (* stack ops *) | Prim (loc, I_DROP, [], _), Item_t (_, rest, _) -> - return (typed loc (Drop, rest)) + typed ctxt loc Drop + rest | Prim (loc, I_DUP, [], instr_annot), Item_t (v, rest, stack_annot) -> let annot = keep_or_rewrite_annot stack_annot instr_annot in - return (typed loc (Dup, Item_t (v, Item_t (v, rest, stack_annot), annot))) + typed ctxt loc Dup + (Item_t (v, Item_t (v, rest, stack_annot), annot)) | Prim (loc, I_SWAP, [], instr_annot), Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) -> let annot = keep_or_rewrite_annot stack_annot instr_annot in - return (typed loc (Swap, Item_t (w, Item_t (v, rest, cur_top_annot), annot))) + typed ctxt loc Swap + (Item_t (w, Item_t (v, rest, cur_top_annot), annot)) | Prim (loc, I_PUSH, [ t ; d ], instr_annot), stack -> - (Lwt.return (parse_ty gas false t)) >>=? fun ((Ex_ty t, _), gas) -> - parse_data ?type_logger ctxt gas t d >>=? fun (v, gas) -> - return (typed ~gas loc (Const v, Item_t (t, stack, instr_annot))) + (Lwt.return (parse_ty ctxt false t)) >>=? fun ((Ex_ty t, _), ctxt) -> + parse_data ?type_logger ctxt t d >>=? fun (v, ctxt) -> + typed ctxt loc (Const v) + (Item_t (t, stack, instr_annot)) | Prim (loc, I_UNIT, [], instr_annot), stack -> - return (typed loc (Const (), Item_t (Unit_t, stack, instr_annot))) + typed ctxt loc (Const ()) + (Item_t (Unit_t, stack, instr_annot)) (* options *) | Prim (loc, I_SOME, [], instr_annot), Item_t (t, rest, _) -> - return (typed loc (Cons_some, Item_t (Option_t t, rest, instr_annot))) + typed ctxt loc Cons_some + (Item_t (Option_t t, rest, instr_annot)) | Prim (loc, I_NONE, [ t ], instr_annot), stack -> - (Lwt.return (parse_ty gas false t)) >>=? fun ((Ex_ty t, _), gas) -> - return (typed ~gas loc (Cons_none t, Item_t (Option_t t, stack, instr_annot))) + (Lwt.return (parse_ty ctxt false t)) >>=? fun ((Ex_ty t, _), ctxt) -> + typed ctxt loc (Cons_none t) + (Item_t (Option_t t, stack, instr_annot)) | Prim (loc, I_IF_NONE, [ bt ; bf ], instr_annot), (Item_t (Option_t t, rest, _) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas bt rest >>=? fun (btr, gas) -> - parse_instr ?type_logger tc_context ctxt gas bf (Item_t (t, rest, instr_annot)) >>=? fun (bfr, gas) -> + parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf (Item_t (t, rest, instr_annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches loc btr bfr { branch } >>|? fun judgement -> - (judgement, gas) + merge_branches loc btr bfr { branch } >>=? fun judgement -> + return ctxt judgement (* pairs *) | Prim (loc, I_PAIR, [], instr_annot), Item_t (a, Item_t (b, rest, snd_annot), fst_annot) -> - return (typed loc (Cons_pair, Item_t (Pair_t((a, fst_annot), (b, snd_annot)), rest, instr_annot))) + typed ctxt loc Cons_pair + (Item_t (Pair_t((a, fst_annot), (b, snd_annot)), rest, instr_annot)) | Prim (loc, I_CAR, [], instr_annot), Item_t (Pair_t ((a, value_annot), _), rest, _) -> let annot = keep_or_rewrite_annot value_annot instr_annot in - return (typed loc (Car, Item_t (a, rest, annot))) + typed ctxt loc Car + (Item_t (a, rest, annot)) | Prim (loc, I_CDR, [], instr_annot), Item_t (Pair_t (_, (b, value_annot)), rest, _) -> let annot = keep_or_rewrite_annot value_annot instr_annot in - return (typed loc (Cdr, Item_t (b, rest, annot))) + typed ctxt loc Cdr + (Item_t (b, rest, annot)) (* unions *) | Prim (loc, I_LEFT, [ tr ], instr_annot), Item_t (tl, rest, stack_annot) -> - (Lwt.return (parse_ty gas false tr)) >>=? fun ((Ex_ty tr, _), gas) -> - return (typed ~gas loc (Left, Item_t (Union_t ((tl, stack_annot), (tr, None)), rest, instr_annot))) + (Lwt.return (parse_ty ctxt false tr)) >>=? fun ((Ex_ty tr, _), ctxt) -> + typed ctxt loc Left + (Item_t (Union_t ((tl, stack_annot), (tr, None)), rest, instr_annot)) | Prim (loc, I_RIGHT, [ tl ], instr_annot), Item_t (tr, rest, stack_annot) -> - (Lwt.return (parse_ty gas false tl)) >>=? fun ((Ex_ty tl, _), gas) -> - return (typed ~gas loc (Right, Item_t (Union_t ((tl, None), (tr, stack_annot)), rest, instr_annot))) + (Lwt.return (parse_ty ctxt false tl)) >>=? fun ((Ex_ty tl, _), ctxt) -> + typed ctxt loc Right + (Item_t (Union_t ((tl, None), (tr, stack_annot)), rest, instr_annot)) | Prim (loc, I_IF_LEFT, [ bt ; bf ], instr_annot), (Item_t (Union_t ((tl, left_annot), (tr, right_annot)), rest, _) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, gas) -> - parse_instr ?type_logger tc_context ctxt gas bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, gas) -> + parse_instr ?type_logger tc_context ctxt bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches loc btr bfr { branch } >>|? fun judgement -> - (judgement, gas) + merge_branches loc btr bfr { branch } >>=? fun judgement -> + return ctxt judgement (* lists *) | Prim (loc, I_NIL, [ t ], instr_annot), stack -> - (Lwt.return (parse_ty gas false t)) >>=? fun ((Ex_ty t, _), gas) -> - return (typed ~gas loc (Nil, Item_t (List_t t, stack, instr_annot))) + (Lwt.return (parse_ty ctxt false t)) >>=? fun ((Ex_ty t, _), ctxt) -> + typed ctxt loc Nil + (Item_t (List_t t, stack, instr_annot)) | Prim (loc, I_CONS, [], instr_annot), Item_t (tv, Item_t (List_t t, rest, _), _) -> check_item_ty tv t loc I_CONS 1 2 >>=? fun Eq -> - return (typed loc (Cons_list, Item_t (List_t t, rest, instr_annot))) + typed ctxt loc Cons_list + (Item_t (List_t t, rest, instr_annot)) | Prim (loc, I_IF_CONS, [ bt ; bf ], instr_annot), (Item_t (List_t t, rest, stack_annot) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas bt - (Item_t (t, Item_t (List_t t, rest, stack_annot), instr_annot)) >>=? fun (btr, gas) -> - parse_instr ?type_logger tc_context ctxt gas bf rest >>=? fun (bfr, gas) -> + parse_instr ?type_logger tc_context ctxt bt + (Item_t (t, Item_t (List_t t, rest, stack_annot), instr_annot)) >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches loc btr bfr { branch } >>|? fun judgement -> - (judgement, gas) + merge_branches loc btr bfr { branch } >>=? fun judgement -> + return ctxt judgement | Prim (loc, I_SIZE, [], instr_annot), Item_t (List_t _, rest, _) -> - return (typed loc (List_size, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc List_size + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_MAP, [], instr_annot), Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest, _), _) -> check_item_ty elt param loc I_MAP 2 2 >>=? fun Eq -> - return (typed loc (List_map, Item_t (List_t ret, rest, instr_annot))) + typed ctxt loc List_map + (Item_t (List_t ret, rest, instr_annot)) | Prim (loc, I_MAP, [ body ], instr_annot), (Item_t (List_t elt, starting_rest, _)) -> check_kind [ Seq_kind ] body >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas body (Item_t (elt, starting_rest, None)) >>=? begin fun (judgement, gas) -> + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, starting_rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> trace (Invalid_map_body (loc, ibody.aft)) (Lwt.return (stack_ty_eq 1 rest starting_rest)) >>=? fun Eq -> - return (typed ~gas loc (List_map_body ibody, Item_t (List_t ret, rest, instr_annot))) + typed ctxt loc (List_map_body ibody) + (Item_t (List_t ret, rest, instr_annot)) | Typed { aft ; _ } -> fail (Invalid_map_body (loc, aft)) | Failed _ -> fail (Invalid_map_block_fail loc) end @@ -1472,27 +1483,28 @@ and parse_instr check_item_ty r pr loc I_REDUCE 1 3 >>=? fun Eq -> check_item_ty elt pelt loc I_REDUCE 2 3 >>=? fun Eq -> check_item_ty init r loc I_REDUCE 3 3 >>=? fun Eq -> - return (typed loc (List_reduce, Item_t (r, rest, instr_annot))) + typed ctxt loc List_reduce + (Item_t (r, rest, instr_annot)) | Prim (loc, I_ITER, [ body ], instr_annot), Item_t (List_t elt, rest, _) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas body (Item_t (elt, rest, None)) >>=? begin fun (judgement, gas) -> + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> trace (Invalid_iter_body (loc, rest, ibody.aft)) (Lwt.return (stack_ty_eq 1 aft rest)) >>=? fun Eq -> - return (typed ~gas loc (List_iter ibody, rest)) + typed ctxt loc (List_iter ibody) rest | Failed { descr } -> - let ibody = descr rest in - return (typed ~gas loc (List_iter ibody, rest)) + typed ctxt loc (List_iter (descr rest)) rest end (* sets *) | Prim (loc, I_EMPTY_SET, [ t ], instr_annot), rest -> - (Lwt.return (parse_comparable_ty gas t)) >>=? fun ((Ex_comparable_ty t), gas) -> - return (typed ~gas loc (Empty_set t, Item_t (Set_t t, rest, instr_annot))) + (Lwt.return (parse_comparable_ty ctxt t)) >>=? fun ((Ex_comparable_ty t), ctxt) -> + typed ctxt loc (Empty_set t) + (Item_t (Set_t t, rest, instr_annot)) | Prim (loc, I_REDUCE, [], instr_annot), Item_t (Lambda_t (Pair_t ((pelt, _), (pr, _)), r), Item_t (Set_t elt, Item_t (init, rest, _), _), _) -> @@ -1500,49 +1512,54 @@ and parse_instr check_item_ty r pr loc I_REDUCE 1 3 >>=? fun Eq -> check_item_ty elt pelt loc I_REDUCE 2 3 >>=? fun Eq -> check_item_ty init r loc I_REDUCE 3 3 >>=? fun Eq -> - return (typed loc (Set_reduce, Item_t (r, rest, instr_annot))) + typed ctxt loc Set_reduce + (Item_t (r, rest, instr_annot)) | Prim (loc, I_ITER, [ body ], annot), Item_t (Set_t comp_elt, rest, _) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let elt = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt gas body (Item_t (elt, rest, None)) >>=? begin fun (judgement, gas) -> + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> trace (Invalid_iter_body (loc, rest, ibody.aft)) (Lwt.return (stack_ty_eq 1 aft rest)) >>=? fun Eq -> - return (typed ~gas loc (Set_iter ibody, rest)) + typed ctxt loc (Set_iter ibody) rest | Failed { descr } -> - let ibody = descr rest in - return (typed ~gas loc (Set_iter ibody, rest)) + typed ctxt loc (Set_iter (descr rest)) rest end | Prim (loc, I_MEM, [], instr_annot), Item_t (v, Item_t (Set_t elt, rest, _), _) -> let elt = ty_of_comparable_ty elt in check_item_ty elt v loc I_MEM 1 2 >>=? fun Eq -> - return (typed loc (Set_mem, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Set_mem + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_UPDATE, [], instr_annot), Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest, _), _), _) -> let ty = ty_of_comparable_ty elt in check_item_ty ty v loc I_UPDATE 1 3 >>=? fun Eq -> - return (typed loc (Set_update, Item_t (Set_t elt, rest, instr_annot))) + typed ctxt loc Set_update + (Item_t (Set_t elt, rest, instr_annot)) | Prim (loc, I_SIZE, [], instr_annot), Item_t (Set_t _, rest, _) -> - return (typed loc (Set_size, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Set_size + (Item_t (Nat_t, rest, instr_annot)) (* maps *) | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], instr_annot), stack -> - (Lwt.return (parse_comparable_ty gas tk)) >>=? fun ((Ex_comparable_ty tk), gas) -> - (Lwt.return (parse_ty gas false tv)) >>=? fun ((Ex_ty tv, _), gas) -> - return (typed ~gas loc (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack, instr_annot))) + (Lwt.return (parse_comparable_ty ctxt tk)) >>=? fun ((Ex_comparable_ty tk), ctxt) -> + (Lwt.return (parse_ty ctxt false tv)) >>=? fun ((Ex_ty tv, _), ctxt) -> + typed ctxt loc (Empty_map (tk, tv)) + (Item_t (Map_t (tk, tv), stack, instr_annot)) | Prim (loc, I_MAP, [], instr_annot), Item_t (Lambda_t (Pair_t ((pk, _), (pv, _)), ret), Item_t (Map_t (ck, v), rest, _), _) -> let k = ty_of_comparable_ty ck in check_item_ty pk k loc I_MAP 1 2 >>=? fun Eq -> check_item_ty pv v loc I_MAP 1 2 >>=? fun Eq -> - return (typed loc (Map_map, Item_t (Map_t (ck, ret), rest, instr_annot))) + typed ctxt loc Map_map + (Item_t (Map_t (ck, ret), rest, instr_annot)) | Prim (loc, I_REDUCE, [], instr_annot), Item_t (Lambda_t (Pair_t ((Pair_t ((pk, _), (pv, _)), _), (pr, _)), r), Item_t (Map_t (ck, v), @@ -1552,158 +1569,167 @@ and parse_instr check_item_ty pv v loc I_REDUCE 2 3 >>=? fun Eq -> check_item_ty r pr loc I_REDUCE 1 3 >>=? fun Eq -> check_item_ty init r loc I_REDUCE 3 3 >>=? fun Eq -> - return (typed loc (Map_reduce, Item_t (r, rest, instr_annot))) + typed ctxt loc Map_reduce + (Item_t (r, rest, instr_annot)) | Prim (loc, I_ITER, [ body ], instr_annot), Item_t (Map_t (comp_elt, element_ty), rest, _) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> let key = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt gas body + parse_instr ?type_logger tc_context ctxt body (Item_t (Pair_t ((key, None), (element_ty, None)), rest, None)) - >>=? begin fun (judgement, gas) -> match judgement with + >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> trace (Invalid_iter_body (loc, rest, ibody.aft)) (Lwt.return (stack_ty_eq 1 aft rest)) >>=? fun Eq -> - return (typed ~gas loc (Map_iter ibody, rest)) + typed ctxt loc (Map_iter ibody) rest | Failed { descr } -> - let ibody = descr rest in - return (typed loc (Map_iter ibody, rest)) + typed ctxt loc (Map_iter (descr rest)) rest end | Prim (loc, I_MEM, [], instr_annot), Item_t (vk, Item_t (Map_t (ck, _), rest, _), _) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc I_MEM 1 2 >>=? fun Eq -> - return (typed loc (Map_mem, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Map_mem + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_GET, [], instr_annot), Item_t (vk, Item_t (Map_t (ck, elt), rest, _), _) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc I_GET 1 2 >>=? fun Eq -> - return (typed loc (Map_get, Item_t (Option_t elt, rest, instr_annot))) + typed ctxt loc Map_get + (Item_t (Option_t elt, rest, instr_annot)) | Prim (loc, I_UPDATE, [], instr_annot), Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest, _), _), _) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc I_UPDATE 1 3 >>=? fun Eq -> check_item_ty vv v loc I_UPDATE 2 3 >>=? fun Eq -> - return (typed loc (Map_update, Item_t (Map_t (ck, v), rest, instr_annot))) + typed ctxt loc Map_update + (Item_t (Map_t (ck, v), rest, instr_annot)) | Prim (loc, I_SIZE, [], instr_annot), Item_t (Map_t (_, _), rest, _) -> - return (typed loc (Map_size, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Map_size + (Item_t (Nat_t, rest, instr_annot)) (* big_map *) | Prim (loc, I_MEM, [], instr_annot), Item_t (set_key, Item_t (Big_map_t (map_key, _), rest, _), _) -> let k = ty_of_comparable_ty map_key in check_item_ty set_key k loc I_MEM 1 2 >>=? fun Eq -> - return (typed loc (Big_map_mem, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Big_map_mem + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_GET, [], instr_annot), Item_t (vk, Item_t (Big_map_t (ck, elt), rest, _), _) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc I_GET 1 2 >>=? fun Eq -> - return (typed loc (Big_map_get, Item_t (Option_t elt, rest, instr_annot))) + typed ctxt loc Big_map_get + (Item_t (Option_t elt, rest, instr_annot)) | Prim (loc, I_UPDATE, [], instr_annot), Item_t (set_key, Item_t (Option_t set_value, Item_t (Big_map_t (map_key, map_value), rest, _), _), _) -> let k = ty_of_comparable_ty map_key in check_item_ty set_key k loc I_UPDATE 1 3 >>=? fun Eq -> check_item_ty set_value map_value loc I_UPDATE 2 3 >>=? fun Eq -> - return (typed loc (Big_map_update, Item_t (Big_map_t (map_key, map_value), rest, instr_annot))) + typed ctxt loc Big_map_update + (Item_t (Big_map_t (map_key, map_value), rest, instr_annot)) (* control *) | Seq (loc, [], annot), stack -> fail_unexpected_annot loc annot >>=? fun () -> - return (typed loc (Nop, stack)) + typed ctxt loc Nop stack | Seq (loc, [ single ], annot), stack -> fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas single stack >>=? begin fun (judgement, gas) -> + parse_instr ?type_logger tc_context ctxt single stack >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as instr) -> let nop = { bef = aft ; loc = loc ; aft ; instr = Nop } in - return (typed ~gas loc (Seq (instr, nop), aft)) + typed ctxt loc (Seq (instr, nop)) aft | Failed { descr ; _ } -> let descr aft = let nop = { bef = aft ; loc = loc ; aft ; instr = Nop } in let descr = descr aft in { descr with instr = Seq (descr, nop) } in - return (Failed { descr }, gas) + return ctxt (Failed { descr }) end | Seq (loc, hd :: tl, annot), stack -> fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas hd stack >>=? begin fun (judgement, gas) -> + parse_instr ?type_logger tc_context ctxt hd stack >>=? begin fun (judgement, ctxt) -> match judgement with | Failed _ -> fail (Fail_not_in_tail_position (Micheline.location hd)) | Typed ({ aft = middle ; _ } as ihd) -> - parse_instr ?type_logger tc_context ctxt gas (Seq (-1, tl, None)) middle >>=? fun (judgement, gas) -> + parse_instr ?type_logger tc_context ctxt (Seq (-1, tl, None)) middle >>=? fun (judgement, ctxt) -> match judgement with | Failed { descr } -> let descr ret = { loc ; instr = Seq (ihd, descr ret) ; bef = stack ; aft = ret } in - return (Failed { descr }, gas) + return ctxt (Failed { descr }) | Typed itl -> - return (typed ~gas loc (Seq (ihd, itl), itl.aft)) + typed ctxt loc (Seq (ihd, itl)) itl.aft end | Prim (loc, I_IF, [ bt ; bf ], _), (Item_t (Bool_t, rest, _) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas bt rest >>=? fun (btr, gas) -> - parse_instr ?type_logger tc_context ctxt gas bf rest >>=? fun (bfr, gas) -> + parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches loc btr bfr { branch } >>|? fun judgement -> - (judgement, gas) + merge_branches loc btr bfr { branch } >>=? fun judgement -> + return ctxt judgement | Prim (loc, I_LOOP, [ body ], _), (Item_t (Bool_t, rest, stack_annot) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas body rest >>=? begin fun (judgement, gas) -> + parse_instr ?type_logger tc_context ctxt body rest >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> trace (Unmatched_branches (loc, ibody.aft, stack)) (Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun Eq -> - return (typed ~gas loc (Loop ibody, rest)) + typed ctxt loc (Loop ibody) rest | Failed { descr } -> let ibody = descr (Item_t (Bool_t, rest, stack_annot)) in - return (typed ~gas loc (Loop ibody, rest)) + typed ctxt loc (Loop ibody) rest end | Prim (loc, I_LOOP_LEFT, [ body ], instr_annot), (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, _) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt gas body (Item_t (tl, rest, tl_annot)) - >>=? begin fun (judgement, gas) -> match judgement with + parse_instr ?type_logger tc_context ctxt body (Item_t (tl, rest, tl_annot)) + >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> trace (Unmatched_branches (loc, ibody.aft, stack)) (Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun Eq -> - return (typed ~gas loc (Loop_left ibody, (Item_t (tr, rest, tr_annot)))) + typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot)) | Failed { descr } -> let ibody = descr (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, None)) in - return (typed ~gas loc (Loop_left ibody, Item_t (tr, rest, tr_annot))) + typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot)) end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot), stack -> - (Lwt.return (parse_ty gas false arg)) >>=? fun ((Ex_ty arg, arg_annot), gas) -> - (Lwt.return (parse_ty gas false ret)) >>=? fun ((Ex_ty ret, _), gas) -> + (Lwt.return (parse_ty ctxt false arg)) >>=? fun ((Ex_ty arg, arg_annot), ctxt) -> + (Lwt.return (parse_ty ctxt false ret)) >>=? fun ((Ex_ty ret, _), ctxt) -> check_kind [ Seq_kind ] code >>=? fun () -> - parse_returning Lambda ?type_logger ctxt gas + parse_returning Lambda ?type_logger ctxt (arg, default_annot ~default:default_arg_annot arg_annot) - ret code >>=? fun (lambda, gas) -> - return (typed ~gas loc (Lambda lambda, Item_t (Lambda_t (arg, ret), stack, instr_annot))) + ret code >>=? fun (lambda, ctxt) -> + typed ctxt loc (Lambda lambda) + (Item_t (Lambda_t (arg, ret), stack, instr_annot)) | Prim (loc, I_EXEC, [], instr_annot), Item_t (arg, Item_t (Lambda_t (param, ret), rest, _), _) -> check_item_ty arg param loc I_EXEC 1 2 >>=? fun Eq -> - return (typed loc (Exec, Item_t (ret, rest, instr_annot))) + typed ctxt loc Exec + (Item_t (ret, rest, instr_annot)) | Prim (loc, I_DIP, [ code ], instr_annot), Item_t (v, rest, stack_annot) -> fail_unexpected_annot loc instr_annot >>=? fun () -> check_kind [ Seq_kind ] code >>=? fun () -> - parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt gas code rest - >>=? begin fun (judgement, gas) -> match judgement with + parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt code rest + >>=? begin fun (judgement, ctxt) -> match judgement with | Typed descr -> - return (typed ~gas loc (Dip descr, Item_t (v, descr.aft, stack_annot))) + typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot)) | Failed _ -> fail (Fail_not_in_tail_position loc) end @@ -1711,199 +1737,239 @@ and parse_instr bef -> fail_unexpected_annot loc annot >>=? fun () -> let descr aft = { loc ; instr = Fail ; bef ; aft } in - return (Failed { descr }, gas) + return ctxt (Failed { descr }) (* timestamp operations *) | Prim (loc, I_ADD, [], instr_annot), Item_t (Timestamp_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Add_timestamp_to_seconds, Item_t (Timestamp_t, rest, instr_annot))) + typed ctxt loc Add_timestamp_to_seconds + (Item_t (Timestamp_t, rest, instr_annot)) | Prim (loc, I_ADD, [], instr_annot), Item_t (Int_t, Item_t (Timestamp_t, rest, _), _) -> - return (typed loc (Add_seconds_to_timestamp, Item_t (Timestamp_t, rest, instr_annot))) + typed ctxt loc Add_seconds_to_timestamp + (Item_t (Timestamp_t, rest, instr_annot)) | Prim (loc, I_SUB, [], instr_annot), Item_t (Timestamp_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Sub_timestamp_seconds, Item_t (Timestamp_t, rest, instr_annot))) + typed ctxt loc Sub_timestamp_seconds + (Item_t (Timestamp_t, rest, instr_annot)) | Prim (loc, I_SUB, [], instr_annot), Item_t (Timestamp_t, Item_t (Timestamp_t, rest, _), _) -> - return (typed loc (Diff_timestamps, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Diff_timestamps + (Item_t (Int_t, rest, instr_annot)) (* string operations *) | Prim (loc, I_CONCAT, [], instr_annot), Item_t (String_t, Item_t (String_t, rest, _), _) -> - return (typed loc (Concat, Item_t (String_t, rest, instr_annot))) + typed ctxt loc Concat + (Item_t (String_t, rest, instr_annot)) (* currency operations *) | Prim (loc, I_ADD, [], instr_annot), Item_t (Tez_t, Item_t (Tez_t, rest, _), _) -> - return (typed loc (Add_tez, Item_t (Tez_t, rest, instr_annot))) + typed ctxt loc Add_tez + (Item_t (Tez_t, rest, instr_annot)) | Prim (loc, I_SUB, [], instr_annot), Item_t (Tez_t, Item_t (Tez_t, rest, _), _) -> - return (typed loc (Sub_tez, Item_t (Tez_t, rest, instr_annot))) + typed ctxt loc Sub_tez + (Item_t (Tez_t, rest, instr_annot)) | Prim (loc, I_MUL, [], instr_annot), Item_t (Tez_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Mul_teznat, Item_t (Tez_t, rest, instr_annot))) + typed ctxt loc Mul_teznat + (Item_t (Tez_t, rest, instr_annot)) | Prim (loc, I_MUL, [], instr_annot), Item_t (Nat_t, Item_t (Tez_t, rest, _), _) -> - return (typed loc (Mul_nattez, Item_t (Tez_t, rest, instr_annot))) + typed ctxt loc Mul_nattez + (Item_t (Tez_t, rest, instr_annot)) (* boolean operations *) | Prim (loc, I_OR, [], instr_annot), Item_t (Bool_t, Item_t (Bool_t, rest, _), _) -> - return (typed loc (Or, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Or + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_AND, [], instr_annot), Item_t (Bool_t, Item_t (Bool_t, rest, _), _) -> - return (typed loc (And, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc And + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_XOR, [], instr_annot), Item_t (Bool_t, Item_t (Bool_t, rest, _), _) -> - return (typed loc (Xor, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Xor + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_NOT, [], instr_annot), Item_t (Bool_t, rest, _) -> - return (typed loc (Not, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Not + (Item_t (Bool_t, rest, instr_annot)) (* integer operations *) | Prim (loc, I_ABS, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Abs_int, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Abs_int + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_INT, [], instr_annot), Item_t (Nat_t, rest, _) -> - return (typed loc (Int_nat, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Int_nat + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_NEG, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Neg_int, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Neg_int + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_NEG, [], instr_annot), Item_t (Nat_t, rest, _) -> - return (typed loc (Neg_nat, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Neg_nat + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_ADD, [], instr_annot), Item_t (Int_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Add_intint, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Add_intint + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_ADD, [], instr_annot), Item_t (Int_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Add_intnat, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Add_intnat + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_ADD, [], instr_annot), Item_t (Nat_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Add_natint, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Add_natint + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_ADD, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Add_natnat, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Add_natnat + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_SUB, [], instr_annot), Item_t (Int_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Sub_int, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Sub_int + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_SUB, [], instr_annot), Item_t (Int_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Sub_int, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Sub_int + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_SUB, [], instr_annot), Item_t (Nat_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Sub_int, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Sub_int + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_SUB, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Sub_int, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Sub_int + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_MUL, [], instr_annot), Item_t (Int_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Mul_intint, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Mul_intint + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_MUL, [], instr_annot), Item_t (Int_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Mul_intnat, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Mul_intnat + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_MUL, [], instr_annot), Item_t (Nat_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Mul_natint, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Mul_natint + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_MUL, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Mul_natnat, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Mul_natnat + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Tez_t, Item_t (Nat_t, rest, _), _) -> - return - (typed loc - (Ediv_teznat, - Item_t (Option_t (Pair_t ((Tez_t, None), (Tez_t, None))), rest, instr_annot))) + typed ctxt loc Ediv_teznat + (Item_t (Option_t (Pair_t ((Tez_t, None), (Tez_t, None))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Tez_t, Item_t (Tez_t, rest, _), _) -> - return (typed loc (Ediv_tez, - Item_t (Option_t (Pair_t ((Nat_t, None), (Tez_t, None))), rest, instr_annot))) + typed ctxt loc Ediv_tez + (Item_t (Option_t (Pair_t ((Nat_t, None), (Tez_t, None))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Int_t, Item_t (Int_t, rest, _), _) -> - return - (typed loc - (Ediv_intint, - Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot))) + typed ctxt loc Ediv_intint + (Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Int_t, Item_t (Nat_t, rest, _), _) -> - return - (typed loc - (Ediv_intnat, - Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot))) + typed ctxt loc Ediv_intnat + (Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Nat_t, Item_t (Int_t, rest, _), _) -> - return - (typed loc - (Ediv_natint, - Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot))) + typed ctxt loc Ediv_natint + (Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return - (typed loc - (Ediv_natnat, - Item_t (Option_t (Pair_t ((Nat_t, None), (Nat_t, None))), rest, instr_annot))) + typed ctxt loc Ediv_natnat + (Item_t (Option_t (Pair_t ((Nat_t, None), (Nat_t, None))), rest, instr_annot)) | Prim (loc, I_LSL, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Lsl_nat, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Lsl_nat + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_LSR, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Lsr_nat, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Lsr_nat + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_OR, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Or_nat, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Or_nat + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_AND, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (And_nat, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc And_nat + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_XOR, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Xor_nat, Item_t (Nat_t, rest, instr_annot))) + typed ctxt loc Xor_nat + (Item_t (Nat_t, rest, instr_annot)) | Prim (loc, I_NOT, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Not_int, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Not_int + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_NOT, [], instr_annot), Item_t (Nat_t, rest, _) -> - return (typed loc (Not_nat, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc Not_nat + (Item_t (Int_t, rest, instr_annot)) (* comparison *) | Prim (loc, I_COMPARE, [], instr_annot), Item_t (Int_t, Item_t (Int_t, rest, _), _) -> - return (typed loc (Compare Int_key, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc (Compare Int_key) + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_COMPARE, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> - return (typed loc (Compare Nat_key, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc (Compare Nat_key) + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_COMPARE, [], instr_annot), Item_t (Bool_t, Item_t (Bool_t, rest, _), _) -> - return (typed loc (Compare Bool_key, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc (Compare Bool_key) + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_COMPARE, [], instr_annot), Item_t (String_t, Item_t (String_t, rest, _), _) -> - return (typed loc (Compare String_key, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc (Compare String_key) + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_COMPARE, [], instr_annot), Item_t (Tez_t, Item_t (Tez_t, rest, _), _) -> - return (typed loc (Compare Tez_key, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc (Compare Tez_key) + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_COMPARE, [], instr_annot), Item_t (Key_hash_t, Item_t (Key_hash_t, rest, _), _) -> - return (typed loc (Compare Key_hash_key, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc (Compare Key_hash_key) + (Item_t (Int_t, rest, instr_annot)) | Prim (loc, I_COMPARE, [], instr_annot), Item_t (Timestamp_t, Item_t (Timestamp_t, rest, _), _) -> - return (typed loc (Compare Timestamp_key, Item_t (Int_t, rest, instr_annot))) + typed ctxt loc (Compare Timestamp_key) + (Item_t (Int_t, rest, instr_annot)) (* comparators *) | Prim (loc, I_EQ, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Eq, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Eq + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_NEQ, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Neq, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Neq + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_LT, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Lt, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Lt + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_GT, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Gt, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Gt + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_LE, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Le, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Le + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_GE, [], instr_annot), Item_t (Int_t, rest, _) -> - return (typed loc (Ge, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Ge + (Item_t (Bool_t, rest, instr_annot)) (* protocol *) | Prim (loc, I_MANAGER, [], instr_annot), Item_t (Contract_t _, rest, _) -> - return (typed loc (Manager, Item_t (Key_hash_t, rest, instr_annot))) + typed ctxt loc Manager + (Item_t (Key_hash_t, rest, instr_annot)) | Prim (loc, I_TRANSFER_TOKENS, [], instr_annot), Item_t (p, Item_t (Tez_t, Item_t @@ -1915,9 +1981,8 @@ and parse_instr | Lambda -> fail (Transfer_in_lambda loc) | Toplevel { storage_type ; _ } -> check_item_ty storage storage_type loc I_TRANSFER_TOKENS 3 4 >>=? fun Eq -> - return (typed loc (Transfer_tokens storage, - Item_t (cr, Item_t (storage, Empty_t, storage_annot), - instr_annot))) + typed ctxt loc (Transfer_tokens storage) + (Item_t (cr, Item_t (storage, Empty_t, storage_annot), instr_annot)) end | Prim (loc, I_CREATE_ACCOUNT, [], instr_annot), Item_t @@ -1925,12 +1990,12 @@ and parse_instr (Option_t Key_hash_t, Item_t (Bool_t, Item_t (Tez_t, rest, _), _), _), _) -> - return (typed loc (Create_account, - Item_t (Contract_t (Unit_t, Unit_t), rest, instr_annot))) + typed ctxt loc Create_account + (Item_t (Contract_t (Unit_t, Unit_t), rest, instr_annot)) | Prim (loc, I_DEFAULT_ACCOUNT, [], instr_annot), Item_t (Key_hash_t, rest, _) -> - return - (typed loc (Default_account, Item_t (Contract_t (Unit_t, Unit_t), rest, instr_annot))) + typed ctxt loc Default_account + (Item_t (Contract_t (Unit_t, Unit_t), rest, instr_annot)) | Prim (loc, I_CREATE_CONTRACT, [], instr_annot), Item_t (Key_hash_t, Item_t @@ -1943,8 +2008,8 @@ and parse_instr (ginit, rest, _), _), _), _), _), _), _) -> check_item_ty gp gr loc I_CREATE_CONTRACT 5 7 >>=? fun Eq -> check_item_ty ginit gp loc I_CREATE_CONTRACT 6 7 >>=? fun Eq -> - return (typed loc (Create_contract (gp, p, r), - Item_t (Contract_t (p, r), rest, instr_annot))) + typed ctxt loc (Create_contract (gp, p, r)) + (Item_t (Contract_t (p, r), rest, instr_annot)) | Prim (loc, I_CREATE_CONTRACT, [ (Seq (seq_loc, _, annot) as code)], instr_annot), Item_t (Key_hash_t, Item_t @@ -1955,64 +2020,72 @@ and parse_instr (ginit, rest, _), _), _), _), _), _) -> fail_unexpected_annot seq_loc annot >>=? fun () -> let cannonical_code = fst @@ Micheline.extract_locations code in - Lwt.return (parse_toplevel gas cannonical_code) >>=? fun ((arg_type, ret_type, storage_type, code_field), gas) -> + Lwt.return (parse_toplevel ctxt cannonical_code) >>=? fun ((arg_type, ret_type, storage_type, code_field), ctxt) -> trace (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) - (Lwt.return (parse_ty gas false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), gas) -> + (Lwt.return (parse_ty ctxt false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), ctxt) -> trace (Ill_formed_type (Some "return", cannonical_code, location ret_type)) - (Lwt.return (parse_ty gas false ret_type)) >>=? fun ((Ex_ty ret_type, _), gas) -> + (Lwt.return (parse_ty ctxt false ret_type)) >>=? fun ((Ex_ty ret_type, _), ctxt) -> trace (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) - (Lwt.return (parse_ty gas true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), gas) -> + (Lwt.return (parse_ty ctxt true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), ctxt) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in trace (Ill_typed_contract (cannonical_code, [])) (parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type }) - ctxt ?type_logger gas (arg_type_full, None) ret_type_full code_field) >>=? + ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; - aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, gas) -> + aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq -> Lwt.return @@ ty_eq ret ret_type_full >>=? fun Eq -> Lwt.return @@ ty_eq storage_type ginit >>=? fun Eq -> - return (typed ~gas loc (Create_contract_literal (storage_type, arg_type, ret_type, lambda), - Item_t (Contract_t (arg_type, ret_type), rest, instr_annot))) + typed ctxt loc (Create_contract_literal (storage_type, arg_type, ret_type, lambda)) + (Item_t (Contract_t (arg_type, ret_type), rest, instr_annot)) | Prim (loc, I_NOW, [], instr_annot), stack -> - return (typed loc (Now, Item_t (Timestamp_t, stack, instr_annot))) + typed ctxt loc Now + (Item_t (Timestamp_t, stack, instr_annot)) | Prim (loc, I_AMOUNT, [], instr_annot), stack -> - return (typed loc (Amount, Item_t (Tez_t, stack, instr_annot))) + typed ctxt loc Amount + (Item_t (Tez_t, stack, instr_annot)) | Prim (loc, I_BALANCE, [], instr_annot), stack -> - return (typed loc (Balance, Item_t (Tez_t, stack, instr_annot))) + typed ctxt loc Balance + (Item_t (Tez_t, stack, instr_annot)) | Prim (loc, I_HASH_KEY, [], instr_annot), Item_t (Key_t, rest, _) -> - return (typed loc (Hash_key, Item_t (Key_hash_t, rest, instr_annot))) + typed ctxt loc Hash_key + (Item_t (Key_hash_t, rest, instr_annot)) | Prim (loc, I_CHECK_SIGNATURE, [], instr_annot), Item_t (Key_t, Item_t (Pair_t ((Signature_t, _), (String_t, _)), rest, _), _) -> - return (typed loc (Check_signature, Item_t (Bool_t, rest, instr_annot))) + typed ctxt loc Check_signature + (Item_t (Bool_t, rest, instr_annot)) | Prim (loc, I_H, [], instr_annot), Item_t (t, rest, _) -> - return (typed loc (H t, Item_t (String_t, rest, instr_annot))) + typed ctxt loc (H t) + (Item_t (String_t, rest, instr_annot)) | Prim (loc, I_STEPS_TO_QUOTA, [], instr_annot), stack -> - return (typed loc (Steps_to_quota, Item_t (Nat_t, stack, instr_annot))) + typed ctxt loc Steps_to_quota + (Item_t (Nat_t, stack, instr_annot)) | Prim (loc, I_SOURCE, [ ta; tb ], instr_annot), stack -> - (Lwt.return (parse_ty gas false ta)) >>=? fun ((Ex_ty ta, _), gas) -> - (Lwt.return (parse_ty gas false tb)) >>=? fun ((Ex_ty tb, _), gas) -> - return (typed ~gas loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack, instr_annot))) + (Lwt.return (parse_ty ctxt false ta)) >>=? fun ((Ex_ty ta, _), ctxt) -> + (Lwt.return (parse_ty ctxt false tb)) >>=? fun ((Ex_ty tb, _), ctxt) -> + typed ctxt loc (Source (ta, tb)) + (Item_t (Contract_t (ta, tb), stack, instr_annot)) | Prim (loc, I_SELF, [], instr_annot), stack -> - let rec get_toplevel_type : tc_context -> (bef judgement * Gas.t) tzresult Lwt.t = function + let rec get_toplevel_type : tc_context -> (bef judgement * context) tzresult Lwt.t = function | Lambda -> fail (Self_in_lambda loc) | Dip (_, prev) -> get_toplevel_type prev | Toplevel { param_type ; ret_type ; _ } -> - return (typed ~gas loc (Self (param_type, ret_type), - Item_t (Contract_t (param_type, ret_type), stack, instr_annot))) in + typed ctxt loc (Self (param_type, ret_type)) + (Item_t (Contract_t (param_type, ret_type), stack, instr_annot)) in get_toplevel_type tc_context (* Primitive parsing errors *) | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT @@ -2105,14 +2178,14 @@ and parse_instr I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SELF ; I_LAMBDA ] and parse_contract - : type arg ret. context -> Gas.t -> arg ty -> ret ty -> Script.location -> Contract.t -> - ((arg, ret) typed_contract * Gas.t) tzresult Lwt.t - = fun ctxt gas arg ret loc contract -> - Gas.consume_check gas Typecheck_costs.contract_exists >>=? fun gas -> + : type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t -> + ((arg, ret) typed_contract * context) tzresult Lwt.t + = fun ctxt arg ret loc contract -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract_exists) >>=? fun ctxt -> Contract.exists ctxt contract >>=? function | false -> fail (Invalid_contract (loc, contract)) | true -> - Gas.consume_check gas Typecheck_costs.get_script >>=? fun gas -> + Lwt.return (Gas.consume ctxt Typecheck_costs.get_script) >>=? fun ctxt -> trace (Invalid_contract (loc, contract)) @@ Contract.get_script ctxt contract >>=? function @@ -2122,52 +2195,52 @@ and parse_contract ty_eq ret Unit_t >>? fun Eq -> let contract : (arg, ret) typed_contract = (arg, ret, contract) in - ok (contract, gas)) + ok (contract, ctxt)) | Some { code ; _ } -> Lwt.return - (parse_toplevel gas code >>? fun ((arg_type, ret_type, _, _), gas) -> - parse_ty gas false arg_type >>? fun ((Ex_ty targ, _), gas) -> - parse_ty gas false ret_type >>? fun ((Ex_ty tret, _), gas) -> + (parse_toplevel ctxt code >>? fun ((arg_type, ret_type, _, _), ctxt) -> + parse_ty ctxt false arg_type >>? fun ((Ex_ty targ, _), ctxt) -> + parse_ty ctxt false ret_type >>? fun ((Ex_ty tret, _), ctxt) -> ty_eq targ arg >>? fun Eq -> ty_eq tret ret >>? fun Eq -> let contract : (arg, ret) typed_contract = (arg, ret, contract) in - ok (contract, gas)) + ok (contract, ctxt)) and parse_toplevel - : Gas.t -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * Gas.t) tzresult - = fun gas toplevel -> - Gas.consume_check_error gas Typecheck_costs.cycle >>? fun gas -> + : context -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * context) tzresult + = fun ctxt toplevel -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> match root toplevel with | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind)) | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind)) | Seq (_, fields, _) -> - let rec find_fields gas p r s c fields = - Gas.consume_check_error gas Typecheck_costs.cycle >>? fun gas -> + let rec find_fields ctxt p r s c fields = + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> match fields with - | [] -> ok ((p, r, s, c), gas) + | [] -> ok ((p, r, s, c), ctxt) | Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind)) | String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind)) | Seq (loc, _, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) | Prim (loc, K_parameter, [ arg ], _) :: rest -> begin match p with - | None -> find_fields gas (Some arg) r s c rest + | None -> find_fields ctxt (Some arg) r s c rest | Some _ -> error (Duplicate_field (loc, K_parameter)) end | Prim (loc, K_return, [ arg ], _) :: rest -> begin match r with - | None -> find_fields gas p (Some arg) s c rest + | None -> find_fields ctxt p (Some arg) s c rest | Some _ -> error (Duplicate_field (loc, K_return)) end | Prim (loc, K_storage, [ arg ], _) :: rest -> begin match s with - | None -> find_fields gas p r (Some arg) c rest + | None -> find_fields ctxt p r (Some arg) c rest | Some _ -> error (Duplicate_field (loc, K_storage)) end | Prim (loc, K_code, [ arg ], _) :: rest -> begin match c with - | None -> find_fields gas p r s (Some arg) rest + | None -> find_fields ctxt p r s (Some arg) rest | Some _ -> error (Duplicate_field (loc, K_code)) end | Prim (loc, (K_parameter | K_return | K_storage | K_code as name), args, _) :: _ -> @@ -2176,54 +2249,54 @@ and parse_toplevel let allowed = [ K_parameter ; K_return ; K_storage ; K_code ] in error (Invalid_primitive (loc, allowed, name)) in - find_fields gas None None None None fields >>? function - | ((None, _, _, _), _gas) -> error (Missing_field K_parameter) - | ((Some _, None, _, _), _gas) -> error (Missing_field K_return) - | ((Some _, Some _, None, _), _gas) -> error (Missing_field K_storage) - | ((Some _, Some _, Some _, None), _gas) -> error (Missing_field K_code) - | ((Some p, Some r, Some s, Some c), _gas) -> ok ((p, r, s, c), gas) + find_fields ctxt None None None None fields >>? function + | ((None, _, _, _), _ctxt) -> error (Missing_field K_parameter) + | ((Some _, None, _, _), _ctxt) -> error (Missing_field K_return) + | ((Some _, Some _, None, _), _ctxt) -> error (Missing_field K_storage) + | ((Some _, Some _, Some _, None), _ctxt) -> error (Missing_field K_code) + | ((Some p, Some r, Some s, Some c), ctxt) -> ok ((p, r, s, c), ctxt) let parse_script : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> Gas.t -> Script.t -> (ex_script * Gas.t) tzresult Lwt.t - = fun ?type_logger ctxt gas { code ; storage } -> - Lwt.return (parse_toplevel gas code) >>=? fun ((arg_type, ret_type, storage_type, code_field), gas) -> + context -> Script.t -> (ex_script * context) tzresult Lwt.t + = fun ?type_logger ctxt { code ; storage } -> + Lwt.return (parse_toplevel ctxt code) >>=? fun ((arg_type, ret_type, storage_type, code_field), ctxt) -> trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty gas false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), gas) -> + (Lwt.return (parse_ty ctxt false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), ctxt) -> trace (Ill_formed_type (Some "return", code, location ret_type)) - (Lwt.return (parse_ty gas false ret_type)) >>=? fun ((Ex_ty ret_type, _), gas) -> + (Lwt.return (parse_ty ctxt false ret_type)) >>=? fun ((Ex_ty ret_type, _), ctxt) -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty gas true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), gas) -> + (Lwt.return (parse_ty ctxt true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), ctxt) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in trace (Ill_typed_data (None, storage, storage_type)) - (parse_data ?type_logger ctxt gas storage_type (root storage)) >>=? fun (storage, gas) -> + (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> trace (Ill_typed_contract (code, [])) (parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type }) - ctxt gas ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, gas) -> - return (Ex_script { code ; arg_type; ret_type; storage; storage_type }, gas) + ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> + return (Ex_script { code ; arg_type; ret_type; storage; storage_type }, ctxt) let typecheck_code - : context -> Gas.t -> Script.expr -> (type_map * Gas.t) tzresult Lwt.t - = fun ctxt gas code -> - Lwt.return (parse_toplevel gas code) >>=? fun ((arg_type, ret_type, storage_type, code_field), gas) -> + : context -> Script.expr -> (type_map * context) tzresult Lwt.t + = fun ctxt code -> + Lwt.return (parse_toplevel ctxt code) >>=? fun ((arg_type, ret_type, storage_type, code_field), ctxt) -> let type_map = ref [] in (* TODO: annotation checking *) trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty gas false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), gas) -> + (Lwt.return (parse_ty ctxt false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), ctxt) -> trace (Ill_formed_type (Some "return", code, location ret_type)) - (Lwt.return (parse_ty gas false ret_type)) >>=? fun ((Ex_ty ret_type, _), gas) -> + (Lwt.return (parse_ty ctxt false ret_type)) >>=? fun ((Ex_ty ret_type, _), ctxt) -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty gas true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), gas) -> + (Lwt.return (parse_ty ctxt true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), ctxt) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in @@ -2231,76 +2304,75 @@ let typecheck_code parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type }) ctxt - gas ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) (arg_type_full, None) ret_type_full code_field in trace (Ill_typed_contract (code, !type_map)) - result >>=? fun (Lam _, gas) -> - return (!type_map, gas) + result >>=? fun (Lam _, ctxt) -> + return (!type_map, ctxt) let typecheck_data : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> Gas.t -> Script.expr * Script.expr -> Gas.t tzresult Lwt.t - = fun ?type_logger ctxt gas (data, exp_ty) -> + context -> Script.expr * Script.expr -> context tzresult Lwt.t + = fun ?type_logger ctxt (data, exp_ty) -> trace (Ill_formed_type (None, exp_ty, 0)) - (Lwt.return (parse_ty gas true (root exp_ty))) >>=? fun ((Ex_ty exp_ty, _), gas) -> + (Lwt.return (parse_ty ctxt true (root exp_ty))) >>=? fun ((Ex_ty exp_ty, _), ctxt) -> trace (Ill_typed_data (None, data, exp_ty)) - (parse_data ?type_logger ctxt gas exp_ty (root data)) >>=? fun (_, gas) -> - return gas + (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) -> + return ctxt -let hash_data gas typ data = - unparse_data gas typ data >|? fun (data, gas) -> +let hash_data ctxt typ data = + unparse_data ctxt typ data >|? fun (data, ctxt) -> let unparsed = strip_annotations @@ data in let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in - (Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check), gas) + (Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check), ctxt) (* ---------------- Big map -------------------------------------------------*) -let big_map_mem ctx gas contract key { diff ; key_type ; _ } = +let big_map_mem ctxt contract key { diff ; key_type ; _ } = match map_get key diff with - | None -> Lwt.return @@ hash_data gas key_type key >>=? fun (hash, gas) -> - Alpha_context.Contract.Big_map.mem ctx contract hash >>= fun res -> - return (res, gas) - | Some None -> return (false, gas) - | Some (Some _) -> return (true, gas) + | None -> Lwt.return @@ hash_data ctxt key_type key >>=? fun (hash, ctxt) -> + Alpha_context.Contract.Big_map.mem ctxt contract hash >>= fun res -> + return (res, ctxt) + | Some None -> return (false, ctxt) + | Some (Some _) -> return (true, ctxt) -let big_map_get ctx gas contract key { diff ; key_type ; value_type } = +let big_map_get ctxt contract key { diff ; key_type ; value_type } = match map_get key diff with - | Some x -> return (x, gas) + | Some x -> return (x, ctxt) | None -> - Lwt.return @@ hash_data gas key_type key >>=? fun (hash, gas) -> + Lwt.return @@ hash_data ctxt key_type key >>=? fun (hash, ctxt) -> Alpha_context.Contract.Big_map.get_opt - ctx contract hash >>=? begin function - | None -> return (None, gas) + ctxt contract hash >>=? begin function + | None -> return (None, ctxt) | Some value -> - parse_data ctx gas value_type (Micheline.root value) >>|? fun (x, gas) -> - (Some x, gas) + parse_data ctxt value_type (Micheline.root value) >>|? fun (x, ctxt) -> + (Some x, ctxt) end let big_map_update key value ({ diff ; _ } as map) = { map with diff = map_set key value diff } -let to_big_map_diff_list gas { key_type ; value_type ; diff } = - Gas.consume_check gas (Michelson_v1_gas.Cost_of.map_to_list diff) >>=? fun gas -> +let to_big_map_diff_list ctxt { key_type ; value_type ; diff } = + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.map_to_list diff)) >>=? fun ctxt -> let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in - Gas.fold_left gas - ~cycle_cost:Typecheck_costs.cycle - (fun gas (key, value) acc -> - Lwt.return @@ hash_data gas key_type key >>=? fun (hash, gas) -> + fold_left_s + (fun (acc, ctxt) (key, value) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + Lwt.return @@ hash_data ctxt key_type key >>=? fun (hash, ctxt) -> begin match value with - | None -> return (None, gas) + | None -> return (None, ctxt) | Some x -> begin - Lwt.return @@ unparse_data gas value_type x >>=? fun (node, gas) -> - return (Some (Micheline.strip_locations node), gas) + Lwt.return @@ unparse_data ctxt value_type x >>=? fun (node, ctxt) -> + return (Some (Micheline.strip_locations node), ctxt) end - end >>=? fun (value, gas) -> - return ((hash, value) :: acc, gas)) - [] pairs + end >>=? fun (value, ctxt) -> + return ((hash, value) :: acc, ctxt)) + ([], ctxt) pairs (* Get the big map from a contract's storage if one exists *) let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x -> @@ -2311,28 +2383,28 @@ let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x -> let to_serializable_big_map gas (Ex_bm bm) = to_big_map_diff_list gas bm -(* Only used for debugging/user reporting, so no gas checking *) -let to_printable_big_map (Ex_bm { diff ; key_type ; value_type }) = +let to_printable_big_map ctxt (Ex_bm { diff ; key_type ; value_type }) = let un_error = function | Ok x -> x | Error _ -> Pervasives.failwith "Raise to_printiable_big_map gas limit" in + let ctxt = Gas.set_unlimited ctxt in let unparse ty value = - fst @@ un_error @@ unparse_data Gas.max_gas ty value in + fst @@ un_error @@ unparse_data ctxt ty value in let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in List.fold_left (fun acc (key, value) -> ((Micheline.strip_locations @@ unparse key_type key, Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse value_type x) value) :: acc)) [] pairs -let erase_big_map_initialization ctxt gas ({ code ; storage } : Script.t) = - Lwt.return @@ parse_toplevel gas code >>=? fun ((_, _, storage_type, _), gas) -> - Lwt.return @@ parse_ty gas true storage_type >>=? fun ((Ex_ty ty, _), gas) -> - parse_data ctxt gas ty (Micheline.root storage) >>=? fun (storage, gas) -> +let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) = + Lwt.return @@ parse_toplevel ctxt code >>=? fun ((_, _, storage_type, _), ctxt) -> + Lwt.return @@ parse_ty ctxt true storage_type >>=? fun ((Ex_ty ty, _), ctxt) -> + parse_data ctxt ty (Micheline.root storage) >>=? fun (storage, ctxt) -> begin match extract_big_map ty storage with - | None -> return (None, gas) - | Some bm -> to_serializable_big_map gas bm >>=? fun (bm, gas) -> - return (Some bm, gas) - end >>=? fun (bm, gas) -> - Lwt.return @@ unparse_data gas ty storage >>=? fun (storage, gas) -> - return ({ code ; storage = Micheline.strip_locations storage }, bm, gas) + | None -> return (None, ctxt) + | Some bm -> to_serializable_big_map ctxt bm >>=? fun (bm, ctxt) -> + return (Some bm, ctxt) + end >>=? fun (bm, ctxt) -> + Lwt.return @@ unparse_data ctxt ty storage >>=? fun (storage, ctxt) -> + return ({ code ; storage = Micheline.strip_locations storage }, bm, ctxt) diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli index 5ba465225..863035ba8 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -39,14 +39,14 @@ val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_t val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num val big_map_mem : - context -> Gas.t -> Contract.t -> 'key -> + context -> Contract.t -> 'key -> ('key, 'value) Script_typed_ir.big_map -> - (bool * Gas.t) tzresult Lwt.t + (bool * context) tzresult Lwt.t val big_map_get : - context -> Gas.t -> + context -> Contract.t -> 'key -> ('key, 'value) Script_typed_ir.big_map -> - ('value option * Gas.t) tzresult Lwt.t + ('value option * context) tzresult Lwt.t val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> ('key, 'value) Script_typed_ir.big_map @@ -57,42 +57,42 @@ val ty_eq : val parse_data : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> Gas.t -> 'a Script_typed_ir.ty -> Script.node -> ('a * Gas.t) tzresult Lwt.t + context -> 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t val unparse_data : - Gas.t -> 'a Script_typed_ir.ty -> 'a -> (Script.node * Gas.t) tzresult + context -> 'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult val parse_ty : - Gas.t -> bool -> Script.node -> - ((ex_ty * Script_typed_ir.annot) * Gas.t) tzresult + context -> bool -> Script.node -> + ((ex_ty * Script_typed_ir.annot) * context) tzresult val unparse_ty : string option -> 'a Script_typed_ir.ty -> Script.node val parse_toplevel - : Gas.t -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * Gas.t) tzresult + : context -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * context) tzresult val typecheck_code : - context -> Gas.t -> Script.expr -> (type_map * Gas.t) tzresult Lwt.t + context -> Script.expr -> (type_map * context) tzresult Lwt.t val typecheck_data : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> Gas.t -> Script.expr * Script.expr -> Gas.t tzresult Lwt.t + context -> Script.expr * Script.expr -> context tzresult Lwt.t val parse_script : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> Gas.t -> Script.t -> (ex_script * Gas.t) tzresult Lwt.t + context -> Script.t -> (ex_script * context) tzresult Lwt.t -val hash_data : Gas.t -> 'a Script_typed_ir.ty -> 'a -> (string * Gas.t) tzresult +val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (string * context) tzresult val extract_big_map : 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option val to_serializable_big_map : - Gas.t -> Script_typed_ir.ex_big_map -> - (Contract_storage.big_map_diff * Gas.t) tzresult Lwt.t + context -> Script_typed_ir.ex_big_map -> + (Contract_storage.big_map_diff * context) tzresult Lwt.t val to_printable_big_map : - Script_typed_ir.ex_big_map -> + context -> Script_typed_ir.ex_big_map -> (Script.expr * Script.expr option) list val erase_big_map_initialization : - context -> Gas.t -> Script.t -> - (Script.t * Contract_storage.big_map_diff option * Gas.t) tzresult Lwt.t + context -> Script.t -> + (Script.t * Contract_storage.big_map_diff option * context) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml index 6ead71110..a6ccc4acf 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml @@ -29,10 +29,12 @@ let type_map_enc = let ex_ty_enc = Data_encoding.conv (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) - (fun expr -> - match parse_ty (Gas.of_int 10000000000) true (root expr) with - | Ok ((Ex_ty ty, _), _) -> Ex_ty ty - | _ -> Ex_ty Unit_t (* FIXME: ? *)) + (fun _expr -> + (* (* code temporarily deactivated *) + match parse_ty (Gas.of_int 10000000000) true (root expr) with + | Ok ((Ex_ty ty, _), _) -> Ex_ty ty + | _ -> *) + Ex_ty Unit_t (* FIXME: ? *)) Script.expr_encoding (* main registration *) 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 ec39e7adb..9c4e6983c 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml @@ -29,10 +29,11 @@ let execute_code_pred let hash = Operation.hash apply_op in let dummy_nonce = Contract.initial_origination_nonce hash in let amount = Tez.zero in - let gaz = Gas.of_int (Alpha_context.Constants.max_gas tc) in + let gas = Proto_alpha.Alpha_context.Constants.max_gas tc in + let tc = Proto_alpha.Alpha_context.Gas.set_limit tc gas in let return = Script_interpreter.execute dummy_nonce op.contract dst - tc script amount argument gaz in + tc script amount argument 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 1fde532d8..b5d03573e 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,6 @@ 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 * Gas.t * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) + (Script.expr * Script.expr * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) proto_tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/test_big_maps.ml b/src/proto_alpha/lib_protocol/test/test_big_maps.ml index 82bac0ea2..ce8870515 100644 --- a/src/proto_alpha/lib_protocol/test/test_big_maps.ml +++ b/src/proto_alpha/lib_protocol/test/test_big_maps.ml @@ -42,11 +42,11 @@ let code = {| let storage = {| Pair { Elt "A" 1 ; Elt "B" 2 } Unit |} -let expect_big_map tc contract print_key ?(gas=Proto_alpha.Gas.max_gas) key_type print_data data_type contents = +let expect_big_map tc contract print_key key_type print_data data_type contents = let open Proto_alpha.Error_monad in iter_p (fun (n, exp) -> - Lwt.return @@ Proto_alpha.Script_ir_translator.hash_data gas key_type n >>=? fun (key, gas) -> + Lwt.return @@ Proto_alpha.Script_ir_translator.hash_data tc key_type n >>=? fun (key, _tc) -> Proto_alpha.Alpha_context.Contract.Big_map.get_opt tc contract key >>=? fun data -> match data, exp with | None, None -> @@ -56,11 +56,11 @@ let expect_big_map tc contract print_key ?(gas=Proto_alpha.Gas.max_gas) key_type debug " - big_map[%a] is not defined (error)" print_key n ; Helpers_assert.fail_msg "Wrong big map contents" | Some data, None -> - Proto_alpha.Script_ir_translator.parse_data tc gas data_type (Micheline.root data) >>=? fun (data, _gas) -> + Proto_alpha.Script_ir_translator.parse_data tc data_type (Micheline.root data) >>=? fun (data, _tc) -> debug " - big_map[%a] = %a (error)" print_key n print_data data ; Helpers_assert.fail_msg "Wrong big map contents" | Some data, Some exp -> - Proto_alpha.Script_ir_translator.parse_data tc gas data_type (Micheline.root data) >>=? fun (data, _gas) -> + Proto_alpha.Script_ir_translator.parse_data tc data_type (Micheline.root data) >>=? fun (data, _tc) -> debug " - big_map[%a] = %a (expected %a)" print_key n print_data data print_data exp ; Helpers_assert.equal data exp ; return ()) diff --git a/src/proto_alpha/lib_protocol/test/test_michelson.ml b/src/proto_alpha/lib_protocol/test/test_michelson.ml index 255d222fc..e298306ac 100644 --- a/src/proto_alpha/lib_protocol/test/test_michelson.ml +++ b/src/proto_alpha/lib_protocol/test/test_michelson.ml @@ -48,7 +48,7 @@ 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 (ret, st, tc, nonce, bgm) -> let contracts = Contract.originated_contracts nonce in return (ret, st, tc, contracts, bgm) @@ -85,8 +85,8 @@ let test_print ctxt fn s i = return () -let test_output ctxt ?location (file_name: string) (storage: string) (input: string) (expected_output: string) = - test ctxt file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts, _bgm) -> +let test_output ctxt ?tc ?location (file_name: string) (storage: string) (input: string) (expected_output: string) = + test ?tc ctxt file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts, _bgm) -> let output = string_of_canon output_prim in let msg = Option.unopt ~default:"strings aren't equal" location in Assert.equal_string ~msg expected_output output ; @@ -287,7 +287,7 @@ let test_example () = test_output ~location: __LOC__ "exec_concat" "Unit" "\"test\"" "\"test_abc\"" >>=? fun _ -> (* Get current steps to quota *) - test_output ~location: __LOC__ "steps_to_quota" "Unit" "Unit" "39973" >>=? fun _ -> + test_output ~location: __LOC__ "steps_to_quota" "Unit" "Unit" "39968" >>=? fun _ -> let bootstrap_0 = List.nth Account.bootstrap_accounts 0 in get_balance_res bootstrap_0 sb >>=?? fun _balance -> @@ -436,7 +436,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 (_, ret, _, _, _) -> Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ; (* Test DEFAULT_ACCOUNT *)