Alpha, Michelson: gas in typechecking

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 39991
+assert_output $contract_dir/steps_to_quota.tz Unit Unit 39973
 
 # Get the current balance of the contract
 assert_output $contract_dir/balance.tz Unit Unit '"4,000,000"'
@@ -416,7 +416,7 @@ assert_fails $client typecheck data '{ "A" ; "B" ; "B" }' against type '(set str
 
 # Test hash consistency between Michelson and the CLI
 hash_result=`$client hash data '(Pair "22220.00" (Pair "2017-12-13T04:49:00Z" 034))' \
-                     of type '(pair tez (pair timestamp int))'`
+                     of type '(pair tez (pair timestamp int))' | grep expr`
 
 assert_output $contract_dir/hash_consistency_checker.tz Unit \
               '(Pair "22220.00" (Pair "2017-12-13T04:49:00Z" 034))' "$hash_result"

src/proto_alpha/lib_client/client_proto_programs.ml

@@ -117,33 +117,34 @@ let trace
   Alpha_services.Helpers.trace_code cctxt
     block program.expanded (storage.expanded, input.expanded, amount, contract)
 
-let hash_and_sign (data : Michelson_v1_parser.parsed) (typ : Michelson_v1_parser.parsed) sk block cctxt =
+let hash_and_sign ?gas (data : Michelson_v1_parser.parsed) (typ : Michelson_v1_parser.parsed) sk block cctxt =
-  Alpha_services.Helpers.hash_data cctxt block (data.expanded, typ.expanded) >>=? fun hash ->
+  Alpha_services.Helpers.hash_data cctxt block (data.expanded, typ.expanded, gas) >>=? fun (hash, gas) ->
   Client_keys.sign sk (MBytes.of_string hash) >>=? fun signature ->
   let `Hex signature = Signature.to_hex signature in
-  return (hash, signature)
+  return (hash, signature, gas)
 
 let typecheck_data
+    ?gas
     ~(data : Michelson_v1_parser.parsed)
     ~(ty : Michelson_v1_parser.parsed)
     block cctxt =
-  Alpha_services.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded)
+  Alpha_services.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded, gas)
 
-let typecheck_program (program : Michelson_v1_parser.parsed) block cctxt =
+let typecheck_program ?gas (program : Michelson_v1_parser.parsed) block cctxt =
-  Alpha_services.Helpers.typecheck_code cctxt block program.expanded
+  Alpha_services.Helpers.typecheck_code cctxt block (program.expanded, gas)
 
 let print_typecheck_result
-    ~emacs ~show_types ~print_source_on_error
+    ~emacs ~show_types ~print_source_on_error ~original_gas
     program res (cctxt : #Client_context.printer) =
   if emacs then
-    let type_map, errs = match res with
+    let type_map, errs, _gas = match res with
-      | Ok type_map -> type_map, []
+      | Ok (type_map, gas) -> (type_map, [], Some gas)
       | Error (Alpha_environment.Ecoproto_error
                  (Script_tc_errors.Ill_typed_contract (_, type_map ))
                :: _ as errs) ->
-          type_map, errs
+          (type_map, errs, None)
       | Error errs ->
-          [], errs in
+          ([], errs, None) in
     cctxt#message
       "(@[<v 0>(types . %a)@ (errors . %a)@])"
       Michelson_v1_emacs.print_type_map (program, type_map)
@@ -151,9 +152,11 @@ let print_typecheck_result
     return ()
   else
     match res with
-    | Ok type_map ->
+    | Ok (type_map, gas) ->
         let program = Michelson_v1_printer.inject_types type_map program in
-        cctxt#message "Well typed" >>= fun () ->
+        cctxt#message "@[<v 0>Well typed@,Gas used: %a@,Gas remaining: %a@]"
+          Gas.pp (Gas.used ~original:original_gas ~current:gas)
+          Gas.pp gas >>= fun () ->
         if show_types then
           cctxt#message "%a" Micheline_printer.print_expr program >>= fun () ->
           return ()

src/proto_alpha/lib_client/client_proto_programs.mli

@@ -51,31 +51,35 @@ val print_trace_result :
     tzresult -> unit tzresult Lwt.t
 
 val hash_and_sign :
+  ?gas:Gas.t ->
   Michelson_v1_parser.parsed ->
   Michelson_v1_parser.parsed ->
   Client_keys.sk_uri ->
   Block_services.block ->
   #Proto_alpha.full ->
-  (string * string) tzresult Lwt.t
+  (string * string * Gas.t) tzresult Lwt.t
 
 val typecheck_data :
+  ?gas:Proto_alpha.Gas.t ->
   data:Michelson_v1_parser.parsed ->
   ty:Michelson_v1_parser.parsed ->
-  Block_services.block ->
+  'a ->
-  #Proto_alpha.rpc_context ->
+  'a #Proto_alpha.Alpha_environment.RPC_context.simple ->
-  unit tzresult Lwt.t
+  Gas.t tzresult Lwt.t
 
 val typecheck_program :
+  ?gas:Gas.t ->
   Michelson_v1_parser.parsed ->
   Block_services.block ->
   #Proto_alpha.rpc_context ->
-  Script_tc_errors.type_map tzresult Lwt.t
+  (Script_tc_errors.type_map * Gas.t) tzresult Lwt.t
 
 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, error list) result ->
+  (Script_tc_errors.type_map * Gas.t) tzresult ->
   #Client_context.printer ->
   unit tzresult Lwt.t

src/proto_alpha/lib_client/michelson_v1_error_reporter.ml

@@ -206,6 +206,11 @@ let report_errors ~details ~show_source ?parsed ppf errs =
           print_source (parsed, hilights) ;
         if rest <> [] then Format.fprintf ppf "@," ;
         print_trace (parsed_locations parsed) rest
+    | Alpha_environment.Ecoproto_error Gas.Quota_exceeded :: rest ->
+        Format.fprintf ppf
+          "@[<v 0>Gas limit exceeded during typechecking or execution. Try again with a higher gas limit.@]" ;
+        if rest <> [] then Format.fprintf ppf "@," ;
+        print_trace locations rest
     | Alpha_environment.Ecoproto_error err :: rest ->
         begin match err with
           | Apply.Bad_contract_parameter (c, None, _) ->

src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml

@@ -41,6 +41,22 @@ let commands () =
       ~parameter:"amount"
       ~doc:"amount of the transfer in \xEA\x9C\xA9"
       ~default:"0.05" in
+  let custom_gas_flag =
+    arg
+      ~long:"gas"
+      ~short:'G'
+      ~doc:"Initial quantity of gas for typechecking and execution"
+      ~placeholder:"gas"
+      (parameter
+         (fun _ctx str ->
+            try
+              return @@ Proto_alpha.Gas.of_int @@ 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
+    | Some gas -> return gas in
   let data_parameter =
     Clic.parameter (fun _ data ->
         Lwt.return (Micheline_parser.no_parsing_error
@@ -102,17 +118,18 @@ let commands () =
           else
             run ~amount ~program ~storage ~input cctxt#block cctxt >>= fun res ->
             print_run_result cctxt ~show_source ~parsed:program res)) ;
-
     command ~group ~desc: "Ask the node to typecheck a program."
-      (args3 show_types_switch emacs_mode_switch no_print_source_flag)
+      (args4 show_types_switch emacs_mode_switch no_print_source_flag custom_gas_flag)
       (prefixes [ "typecheck" ; "program" ]
        @@ Program.source_param
        @@ stop)
-      (fun (show_types, emacs_mode, no_print_source) program cctxt ->
+      (fun (show_types, emacs_mode, no_print_source, original_gas) program cctxt ->
          match program with
          | program, [] ->
-             typecheck_program program cctxt#block cctxt >>= fun res ->
+             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)
@@ -135,7 +152,7 @@ let commands () =
       ) ;
 
     command ~group ~desc: "Ask the node to typecheck a data expression."
-      (args1 no_print_source_flag)
+      (args2 no_print_source_flag custom_gas_flag)
       (prefixes [ "typecheck" ; "data" ]
        @@ Clic.param ~name:"data" ~desc:"the data to typecheck"
          data_parameter
@@ -143,10 +160,13 @@ let commands () =
        @@ Clic.param ~name:"type" ~desc:"the expected type"
          data_parameter
        @@ stop)
-      (fun no_print_source data ty cctxt ->
+      (fun (no_print_source, custom_gas) data ty cctxt ->
-         Client_proto_programs.typecheck_data ~data ~ty cctxt#block cctxt >>= function
+         resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas ->
-         | Ok () ->
+         Client_proto_programs.typecheck_data ~gas:original_gas ~data ~ty cctxt#block cctxt >>= function
-             cctxt#message "Well typed" >>= fun () ->
+         | Ok gas ->
+             cctxt#message "@[<v 0>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 () ->
              return ()
          | Error errs ->
              cctxt#warning "%a"
@@ -160,7 +180,7 @@ let commands () =
       ~desc: "Ask the node to hash a data expression.\n\
               The returned hash is the same as what Michelson \
               instruction `H` would have produced."
-      no_options
+      (args1 custom_gas_flag)
       (prefixes [ "hash" ; "data" ]
        @@ Clic.param ~name:"data" ~desc:"the data to hash"
          data_parameter
@@ -168,14 +188,21 @@ let commands () =
        @@ Clic.param ~name:"type" ~desc:"type of the data"
          data_parameter
        @@ stop)
-      (fun () data typ cctxt ->
+      (fun custom_gas data typ cctxt ->
+         resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas ->
          Alpha_services.Helpers.hash_data cctxt
-           cctxt#block (data.expanded, typ.expanded) >>= function
+           cctxt#block (data.expanded, typ.expanded, Some original_gas) >>= function
-         | Ok hash ->
+         | Ok (hash, remaining_gas) ->
-             cctxt#message "%S" hash >>= fun () ->
+             cctxt#message "%S@,Gas used: %a" hash
+               Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:original_gas ~current:remaining_gas) >>= fun () ->
              return ()
          | Error errs ->
-             cctxt#warning "%a" pp_print_error errs  >>= fun () ->
+             cctxt#warning "%a"
+               (Michelson_v1_error_reporter.report_errors
+                  ~details:false
+                  ~show_source:false
+                  ?parsed:None)
+               errs  >>= fun () ->
              cctxt#error "ill-formed data") ;
 
     command ~group
@@ -184,7 +211,7 @@ let commands () =
               produce the hash, signs it using a given secret key, and \
               displays it using the format expected by Michelson \
               instruction `CHECK_SIGNATURE`."
-      no_options
+      (args1 custom_gas_flag)
       (prefixes [ "hash" ; "and" ; "sign" ; "data" ]
        @@ Clic.param ~name:"data" ~desc:"the data to hash"
          data_parameter
@@ -194,12 +221,21 @@ let commands () =
        @@ prefixes [ "for" ]
        @@ Client_keys.Secret_key.source_param
        @@ stop)
-      (fun () data typ sk cctxt ->
+      (fun gas data typ sk cctxt ->
-         Client_proto_programs.hash_and_sign data typ sk cctxt#block cctxt >>= begin function
+         resolve_max_gas cctxt cctxt#block gas >>=? fun gas ->
-           | Ok (hash, signature) ->
+         Client_proto_programs.hash_and_sign ~gas data typ sk cctxt#block cctxt >>= begin function
-               cctxt#message "@[<v 0>Hash: %S@,Signature: %S@]" hash signature
+           | Ok (hash, signature, current_gas) ->
+               cctxt#message "@[<v 0>Hash: %S@,Signature: %S@,Gas used: %a@,Remaining gas: %a@]"
+                 hash signature
+                 Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:gas ~current:current_gas)
+                 Proto_alpha.Gas.pp current_gas
            | Error errs ->
-               cctxt#warning "%a" pp_print_error errs >>= fun () ->
+               cctxt#warning "%a"
+                 (Michelson_v1_error_reporter.report_errors
+                    ~details:false
+                    ~show_source:false
+                    ?parsed:None)
+                 errs >>= fun () ->
                cctxt#error "ill-formed data"
          end >>= return) ;
 

src/proto_alpha/lib_protocol/src/apply.ml

@@ -386,35 +386,35 @@ let apply_manager_operation_content
               | _ -> fail (Bad_contract_parameter (destination, None, parameters))
         end
       | Some script ->
-          let call_contract argument =
+          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.of_int (Constants.max_gas ctxt))
+              gas
             >>= function
-            | Ok (storage_res, _res, _steps, ctxt, origination_nonce, maybe_big_map_diff) ->
+            | Ok (storage_res, _res, gas, ctxt, origination_nonce, maybe_big_map_diff) ->
-                (* TODO: pay for the steps and the storage diff:
+                begin match maybe_big_map_diff with
-                   update_script_storage checks the storage cost *)
+                  | 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
+                  storage_res diff >>=? fun ctxt ->
-                  (match maybe_big_map_diff with
-                   | None -> None
-                   | Some map ->
-                       Some (Script_ir_translator.to_serializable_big_map map)) >>=? 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 script.code) >>=? fun (arg_type, _, _, _) ->
+          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)))
+              call_contract (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))) gas
           | Some parameters, _ -> begin
-              Script_ir_translator.typecheck_data ctxt (parameters, arg_type) >>= function
+              Script_ir_translator.typecheck_data ctxt gas (parameters, arg_type) >>= function
-              | Ok () -> call_contract parameters
+              | 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)))
@@ -423,14 +423,15 @@ let apply_manager_operation_content
     end
   | Origination { manager ; delegate ; script ;
                   spendable ; delegatable ; credit } ->
+      let gas = Gas.of_int (Constants.max_gas ctxt) in
       begin match script with
-        | None -> return (None, None)
+        | None -> return (None, None, gas)
         | Some script ->
-            Script_ir_translator.parse_script ctxt script >>=? fun _ ->
+            Script_ir_translator.parse_script ctxt gas script >>=? fun (_, gas) ->
-            Script_ir_translator.erase_big_map_initialization ctxt script >>=? fun (script, big_map_diff) ->
+            Script_ir_translator.erase_big_map_initialization ctxt gas script >>=? fun (script, big_map_diff, gas) ->
             return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee)),
-                    big_map_diff)
+                    big_map_diff, gas)
-      end >>=? fun (script, big_map) ->
+      end >>=? fun (script, big_map, _gas) ->
       Contract.spend ctxt source credit >>=? fun ctxt ->
       Contract.originate ctxt
         origination_nonce

src/proto_alpha/lib_protocol/src/gas.ml

@@ -32,6 +32,9 @@ let pp ppf { remaining } =
 
 let of_int 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
@@ -57,20 +60,36 @@ let bits_per_word = 8 * bytes_per_word
 let words_of_bits n =
   n / bits_per_word
 
-let check gas =
+let check_error gas =
   if Compare.Int.(gas.remaining <= 0)
-  then fail Quota_exceeded
+  then error Quota_exceeded
-  else return ()
+  else ok ()
+
+let check gas =
+  Lwt.return @@ check_error gas
 
 let word_cost = 2
 let step_cost = 1
 
+let used ~original ~current =
+  { remaining = original.remaining - current.remaining }
+
 let consume t cost =
   { remaining =
       t.remaining
       - word_cost * cost.allocations
       - step_cost * 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 ;
@@ -97,6 +116,7 @@ let max = Compare.Int.max
 
 module Cost_of = struct
   let cycle = step_cost 1
+  let typechecking_cycle = cycle
   let nop = free
 
   let stack_op = step_cost 1
@@ -113,9 +133,12 @@ module Cost_of = struct
 
   let branch = step_cost 2
 
+  let string length =
+    alloc_cost (length / bytes_per_word)
+
   let concat s1 s2 =
     let (+) = Pervasives.(+) in
-    alloc_cost ((String.length s1 + String.length s2) / bytes_per_word)
+    string ((String.length s1 + String.length s2) / bytes_per_word)
 
   (* Cost per cycle of a loop, fold, etc *)
   let loop_cycle = step_cost 2
@@ -159,7 +182,7 @@ module Cost_of = struct
 
   let set_mem key set = step_cost (set_access key set)
 
-  let set_update key _value set =
+  let set_update key _presence set =
     set_access key set * alloc_cost 3
 
   (* for LEFT, RIGHT, SOME *)
@@ -247,7 +270,6 @@ module Cost_of = struct
      Z.numbits (Script_int.to_zint x) -
      unopt (Script_int.to_int y) ~default:max_int)
 
-
   let exec = step_cost 1
 
   let push = step_cost 1
@@ -281,8 +303,105 @@ module Cost_of = struct
   let compare_key_hash _ _ = alloc_cost (36 / bytes_per_word)
   let compare_timestamp t1 t2 = compare_zint (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2)
 
+  module Typechecking = struct
+    let cycle = step_cost 1
+    let bool = free
+    let unit = free
+    let string = string
+    let int_of_string str =
+      alloc_cost @@ (Pervasives.(/) (String.length str) 5)
+    let tez = step_cost 1 + alloc_cost 1
+    let string_timestamp = step_cost 3 + alloc_cost 3
+    let key = step_cost 3 + alloc_cost 3
+    let key_hash = step_cost 1 + alloc_cost 1
+    let signature = step_cost 1 + alloc_cost 1
+    let contract = step_cost 5
+    let get_script = step_cost 20 + alloc_cost 5
+    let contract_exists = step_cost 15 + alloc_cost 5
+    let pair = alloc_cost 2
+    let union = alloc_cost 1
+    let lambda = alloc_cost 5 + step_cost 3
+    let some = alloc_cost 1
+    let none = alloc_cost 0
+    let list_element = alloc_cost 2 + step_cost 1
+    let set_element = alloc_cost 3 + step_cost 2
+    let map_element = alloc_cost 4 + step_cost 2
+    let primitive_type = alloc_cost 1
+    let one_arg_type = alloc_cost 2
+    let two_arg_type = alloc_cost 3
+  end
+
+  module Unparse = struct
+    let prim_cost = alloc_cost 4 (* location, primitive name, list, annotation *)
+    let string_cost length =
+      alloc_cost 3 + alloc_cost (length / bytes_per_word)
+
+    let cycle = step_cost 1
+    let bool = prim_cost
+    let unit = prim_cost
+    let string s = string_cost (String.length s)
+    (* Approximates log10(x) *)
+    let int i =
+      let decimal_digits = (Z.numbits (Z.abs (Script_int.to_zint i))) / 4 in
+      prim_cost + (alloc_cost @@ decimal_digits / bytes_per_word)
+    let tez = string_cost 19 (* max length of 64 bit int *)
+    let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int
+    let key = string_cost 54
+    let key_hash = string_cost 36
+    let signature = string_cost 128
+    let contract = string_cost 36
+    let pair = prim_cost + alloc_cost 4
+    let union = prim_cost + alloc_cost 2
+    let lambda = prim_cost + alloc_cost 3
+    let some = prim_cost + alloc_cost 2
+    let none = prim_cost
+    let list_element = prim_cost + alloc_cost 2
+    let set_element = alloc_cost 2
+    let map_element = alloc_cost 2
+    let primitive_type = prim_cost
+    let one_arg_type = prim_cost + alloc_cost 2
+    let two_arg_type = prim_cost + alloc_cost 4
+
+    let set_to_list = set_to_list
+    let map_to_list = map_to_list
+  end
+
 end
 
+(* f should fail if it does not receive sufficient gas *)
+let rec fold_left ?(cycle_cost = Cost_of.loop_cycle) 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 gas f acc tl
+
+(* f should fail if it does not receive sufficient gas *)
+let rec fold_right ?(cycle_cost = Cost_of.loop_cycle) gas f base l =
+  consume_check gas cycle_cost >>=? fun gas ->
+  match l with
+  | [] -> return (base, gas)
+  | hd :: tl ->
+      fold_right 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 = Cost_of.loop_cycle) gas f base l =
+  consume_check_error gas cycle_cost >>? fun gas ->
+  match l with
+  | [] -> ok (base, gas)
+  | hd :: tl ->
+      fold_right_error 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 = Cost_of.loop_cycle) 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 gas f acc tl
+
 let () =
   let open Data_encoding in
   register_error_kind

src/proto_alpha/lib_protocol/src/gas.mli

@@ -21,12 +21,20 @@ val encoding_cost : 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 used : original:t -> current:t -> t
+
+val max_gas : t
+
 module Cost_of : sig
   val cycle : cost
+  val typechecking_cycle : cost
   val loop_cycle : cost
   val list_size : cost
   val nop : cost
@@ -52,7 +60,7 @@ module Cost_of : sig
   val big_map_get : 'key -> ('key, 'value) Script_typed_ir.big_map -> cost
   val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> cost
   val set_to_list : 'a Script_typed_ir.set -> cost
-  val set_update : 'a -> 'b -> 'a Script_typed_ir.set -> cost
+  val set_update : 'a -> bool -> 'a Script_typed_ir.set -> cost
   val set_mem : 'a -> 'a Script_typed_ir.set -> cost
   val mul : 'a Script_int.num -> 'b Script_int.num -> cost
   val div : 'a Script_int.num -> 'b Script_int.num -> cost
@@ -103,5 +111,97 @@ module Cost_of : sig
   val compare_nat : 'a Script_int.num -> 'b Script_int.num -> cost
   val compare_key_hash : 'a -> 'b -> cost
   val compare_timestamp : Script_timestamp.t -> Script_timestamp.t -> cost
+
+  module Typechecking : sig
+    val cycle : cost
+    val unit : cost
+    val bool : cost
+    val tez : cost
+    val string : int -> cost
+    val int_of_string : string -> cost
+    val string_timestamp : cost
+    val key : cost
+    val key_hash : cost
+    val signature : cost
+
+    val contract : cost
+
+    (** Cost of getting the code for a contract *)
+    val get_script : cost
+
+    val contract_exists : cost
+
+    (** Additional cost of parsing a pair over the cost of parsing each type  *)
+    val pair : cost
+
+    val union : cost
+
+    val lambda : cost
+
+    val some : cost
+    val none : cost
+
+    val list_element : cost
+    val set_element : cost
+    val map_element : cost
+
+    val primitive_type : cost
+    val one_arg_type : cost
+    val two_arg_type : cost
+  end
+
+  module Unparse : sig
+    val cycle : cost
+    val unit : cost
+    val bool : cost
+    val int : 'a Script_int.num -> cost
+    val tez : cost
+    val string : string -> cost
+    val timestamp : Script_timestamp.t -> cost
+    val key : cost
+    val key_hash : cost
+    val signature : cost
+
+    val contract : cost
+
+    (** Additional cost of parsing a pair over the cost of parsing each type  *)
+    val pair : cost
+
+    val union : cost
+
+    val lambda : cost
+
+    val some : cost
+    val none : cost
+
+    val list_element : cost
+    val set_element : cost
+    val map_element : cost
+
+    val primitive_type : cost
+    val one_arg_type : cost
+    val two_arg_type : cost
+    val set_to_list : 'a Script_typed_ir.set -> cost
+    val map_to_list : ('a, 'b) Script_typed_ir.map -> cost
+  end
 end
 
+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

src/proto_alpha/lib_protocol/src/helpers_services.ml

@@ -77,8 +77,12 @@ module S = struct
     RPC_service.post_service
       ~description: "Typecheck a piece of code in the current context"
       ~query: RPC_query.empty
-      ~input: Script.expr_encoding
+      ~input: (obj2
-      ~output: Script_tc_errors_registration.type_map_enc
+                 (req "program" Script.expr_encoding)
+                 (opt "gas" Gas.encoding))
+      ~output: (obj2
+                  (req "type_map" Script_tc_errors_registration.type_map_enc)
+                  (req "gas" Gas.encoding))
       RPC_path.(custom_root / "typecheck_code")
 
   let typecheck_data =
@@ -86,19 +90,25 @@ module S = struct
       ~description: "Check that some data expression is well formed \
                      and of a given type in the current context"
       ~query: RPC_query.empty
-      ~input: (obj2
+      ~input: (obj3
                  (req "data" Script.expr_encoding)
-                 (req "type" Script.expr_encoding))
+                 (req "type" Script.expr_encoding)
-      ~output: empty
+                 (opt "gas" Gas.encoding))
+      ~output: (obj1 (req "gas" Gas.encoding))
       RPC_path.(custom_root / "typecheck_data")
 
   let hash_data =
     RPC_service.post_service
       ~description: "Computes the hash of some data expression \
                      using the same algorithm as script instruction H"
-      ~input: (obj2 (req "data" Script.expr_encoding)
+
-                 (req "type" Script.expr_encoding))
+      ~input: (obj3
-      ~output: (obj1 (req "hash" string))
+                 (req "data" Script.expr_encoding)
+                 (req "type" Script.expr_encoding)
+                 (opt "gas" Gas.encoding))
+      ~output: (obj2
+                  (req "hash" string)
+                  (req "gas" Gas.encoding))
       ~query: RPC_query.empty
       RPC_path.(custom_root / "hash_data")
 
@@ -191,17 +201,30 @@ let () =
             Option.map maybe_big_map_diff
               ~f:Script_ir_translator.to_printable_big_map)
   end ;
-  register0 S.typecheck_code begin fun ctxt () ->
+  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
   end ;
-  register0 S.typecheck_data begin fun ctxt () ->
+  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)
   end ;
-  register0 S.hash_data begin fun ctxt () (expr, typ) ->
+  register0 S.hash_data begin fun ctxt () (expr, typ, maybe_gas) ->
     let open Script_ir_translator in
-    Lwt.return @@ parse_ty false (Micheline.root typ) >>=? fun (Ex_ty typ, _) ->
+    Lwt.return @@
-    parse_data ctxt typ (Micheline.root expr) >>=? fun data ->
+    parse_ty
-    return (Script_ir_translator.hash_data typ data)
+      (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
   end ;
   register1 S.level begin fun ctxt raw () offset ->
     return (Level.from_raw ctxt ?offset raw)

src/proto_alpha/lib_protocol/src/helpers_services.mli

@@ -37,15 +37,16 @@ val trace_code:
 
 val typecheck_code:
   'a #RPC_context.simple ->
-  'a -> Script.expr -> Script_tc_errors.type_map shell_tzresult Lwt.t
+  'a -> (Script.expr * Gas.t option) ->
+  (Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t
 
 val typecheck_data:
   'a #RPC_context.simple ->
-  'a -> Script.expr * Script.expr -> unit shell_tzresult Lwt.t
+  'a -> Script.expr * Script.expr * (Gas.t option) -> Gas.t shell_tzresult Lwt.t
 
 val hash_data:
   'a #RPC_context.simple ->
-  'a -> Script.expr * Script.expr -> string shell_tzresult Lwt.t
+  'a -> Script.expr * Script.expr * (Gas.t option) -> (string * Gas.t) shell_tzresult Lwt.t
 
 val level:
   'a #RPC_context.simple ->

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -69,26 +69,10 @@ let rec unparse_stack
   = function
     | Empty, Empty_t -> []
     | Item (v, rest), Item_t (ty, rest_ty, _) ->
-        Micheline.strip_locations (unparse_data ty v) :: unparse_stack (rest, 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
-(* f should fail if it does not receive sufficient gas *)
+        | Ok (data, _) -> (Micheline.strip_locations data) :: (unparse_stack (rest, rest_ty))
-let rec fold_left_gas ?(cycle_cost = Gas.Cost_of.loop_cycle) gas f acc l =
+        | Error _ -> Pervasives.failwith "Internal error: raise gas limit for unparse_stack"
-  let gas = Gas.consume gas cycle_cost in
-  Gas.check gas >>=? fun () ->
-  match l with
-  | [] -> return (acc, gas)
-  | hd :: tl -> f gas hd acc >>=? fun (acc, gas) ->
-      fold_left_gas gas f acc tl
-
-(* f should fail if it does not receive sufficient gas *)
-let rec fold_right_gas ?(cycle_cost = Gas.Cost_of.loop_cycle) gas f base l =
-  let gas = Gas.consume gas cycle_cost in
-  Gas.check gas >>=? fun () ->
-  match l with
-  | [] -> return (base, gas)
-  | hd :: tl ->
-      fold_right_gas gas f base tl >>=? fun (acc, gas) ->
-      f gas hd acc
 
 let rec interp
   : type p r.
@@ -101,7 +85,7 @@ let rec interp
       : 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 ->
+      fun origination gas ctxt ({ instr ; loc ; _ } as descr) stack ->
         let gas = Gas.consume gas Gas.Cost_of.cycle in
         Gas.check gas >>=? fun () ->
         let logged_return : type a b.
@@ -187,7 +171,8 @@ let rec interp
                            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
-            let storage = Micheline.strip_locations (unparse_data storage_type init) in
+            Lwt.return @@ unparse_data gas storage_type init >>=? fun (storage, gas) ->
+            let storage = Micheline.strip_locations storage in
             Contract.spend_from_script ctxt source credit >>=? fun ctxt ->
             Contract.originate ctxt
               origination
@@ -272,7 +257,7 @@ let rec interp
         | If_cons (bt, _), Item (hd :: tl, rest) ->
             step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bt (Item (hd, Item (tl, rest)))
         | List_map, Item (lam, Item (l, rest)) ->
-            fold_right_gas gas (fun gas arg (tail, ctxt, origination) ->
+            Gas.fold_right 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))
@@ -293,7 +278,7 @@ let rec interp
             in help rest gas l >>=? fun (res, gas, ctxt, origination) ->
             logged_return ~origination (res, gas, ctxt)
         | List_reduce, Item (lam, Item (l, Item (init, rest))) ->
-            fold_left_gas gas
+            Gas.fold_left gas
               (fun gas arg (partial, ctxt, origination) ->
                  interp ?log origination gas orig source amount ctxt lam (arg, partial)
                  >>=? fun (partial, gas, ctxt, origination) ->
@@ -301,14 +286,14 @@ let rec interp
               (init, ctxt, origination) l >>=? fun ((res, ctxt, origination), gas) ->
             logged_return ~origination (Item (res, rest), gas, ctxt)
         | List_size, Item (list, rest) ->
-            fold_left_gas ~cycle_cost:Gas.Cost_of.list_size gas
+            Gas.fold_left ~cycle_cost:Gas.Cost_of.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) ->
-            fold_left_gas gas
+            Gas.fold_left gas
               (fun gas arg (stack, ctxt, origination) ->
                  step origination gas ctxt body (Item (arg, stack))
                  >>=? fun (stack, gas, ctxt, origination) ->
@@ -323,7 +308,7 @@ let rec interp
             Gas.check gas >>=? fun () ->
             let items =
               List.rev (set_fold (fun e acc -> e :: acc) set []) in
-            fold_left_gas gas
+            Gas.fold_left gas
               (fun gas arg (partial, ctxt, origination) ->
                  interp ?log origination gas orig source amount ctxt lam (arg, partial)
                  >>=? fun (partial, gas, ctxt, origination) ->
@@ -331,7 +316,7 @@ let rec interp
               (init, ctxt, origination) items >>=? fun ((res, ctxt, origination), gas) ->
             logged_return ~origination (Item (res, rest), gas, ctxt)
         | Set_iter body, Item (set, init_stack) ->
-            fold_left_gas gas
+            Gas.fold_left gas
               (fun gas arg (stack, ctxt, origination) ->
                  step origination gas ctxt body (Item (arg, stack))
                  >>=? fun (stack, gas, ctxt, origination) ->
@@ -353,7 +338,7 @@ let rec interp
             Gas.check gas >>=? fun () ->
             let items =
               List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
-            fold_left_gas gas
+            Gas.fold_left gas
               (fun gas (k, v) (acc, ctxt, origination) ->
                  interp ?log origination gas orig source amount ctxt lam (k, v)
                  >>=? fun (ret, gas, ctxt, origination) ->
@@ -365,7 +350,7 @@ let rec interp
             Gas.check gas >>=? fun () ->
             let items =
               List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
-            fold_left_gas gas
+            Gas.fold_left gas
               (fun gas arg (partial, ctxt, origination) ->
                  interp ?log origination gas orig source amount ctxt lam (arg, partial)
                  >>=? fun (partial, gas, ctxt, origination) ->
@@ -377,7 +362,7 @@ let rec interp
             Gas.check gas >>=? fun () ->
             let items =
               List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
-            fold_left_gas gas
+            Gas.fold_left gas
               (fun gas arg (stack, ctxt, origination) ->
                  step origination gas ctxt body (Item (arg, stack))
                  >>=? fun (stack, gas, ctxt, origination) ->
@@ -396,12 +381,12 @@ let rec interp
         | Big_map_mem, Item (key, Item (map, rest)) ->
             let gas = Gas.consume gas (Gas.Cost_of.big_map_mem key map) in
             Gas.check gas >>=? fun () ->
-            Script_ir_translator.big_map_mem ctxt source key map >>= fun res ->
+            Script_ir_translator.big_map_mem ctxt gas source key map >>=? fun (res, gas) ->
             logged_return (Item (res, rest), gas, ctxt)
         | Big_map_get, Item (key, Item (map, rest)) ->
             let gas = Gas.consume gas (Gas.Cost_of.big_map_get key map) in
             Gas.check gas >>=? fun () ->
-            Script_ir_translator.big_map_get ctxt source key map >>=? fun res ->
+            Script_ir_translator.big_map_get ctxt gas source key map >>=? fun (res, gas) ->
             logged_return (Item (res, rest), gas, ctxt)
         | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) ->
             gas_check_terop descr
@@ -654,10 +639,16 @@ let rec interp
             Contract.spend_from_script ctxt source amount >>=? fun ctxt ->
             Contract.credit ctxt destination amount >>=? fun ctxt ->
             Contract.get_script ctxt destination >>=? fun destination_script ->
-            let sto = Micheline.strip_locations (unparse_data storage_type storage) in
+            Lwt.return (unparse_data gas storage_type storage) >>=? fun (sto, gas) ->
-            Contract.update_script_storage ctxt source sto
+            let sto = Micheline.strip_locations sto in
-              (Option.map ~f:Script_ir_translator.to_serializable_big_map
+            begin match Script_ir_translator.extract_big_map storage_type storage with
-                 (Script_ir_translator.extract_big_map storage_type storage)) >>=? fun ctxt ->
+              | None ->
+                  return (None, gas)
+              | Some diff ->
+                  Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) ->
+                  return (Some diff, gas)
+            end >>=? fun (diff, gas) ->
+            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
               | None ->
@@ -666,22 +657,28 @@ let rec interp
                               record_trace (Invalid_contract (loc, destination))) >>=? fun Eq ->
                   return (ctxt, gas, origination)
               | Some script ->
-                  let p = unparse_data tp p in
+                  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) ->
-                  Contract.update_script_storage ctxt destination csto
+                  begin match maybe_diff with
-                    (Option.map ~f:Script_ir_translator.to_serializable_big_map maybe_diff) >>=? fun ctxt ->
+                    | None ->
+                        return (None, gas)
+                    | Some diff ->
+                        Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) ->
+                        return (Some diff, gas)
+                  end >>=? fun (maybe_diff, gas) ->
+                  Contract.update_script_storage ctxt destination csto maybe_diff >>=? fun ctxt ->
                   trace
                     (Invalid_contract (loc, destination))
-                    (parse_data ctxt Unit_t ret) >>=? fun () ->
+                    (parse_data ctxt gas Unit_t ret) >>=? fun ((), gas) ->
                   Fees.update_script_storage ctxt ~source:orig
                     destination dummy_storage_fee >>=? fun ctxt ->
                   return (ctxt, gas, origination)
             end >>=? fun (ctxt, gas, origination) ->
             Contract.get_script ctxt source >>=? (function
                 | None -> assert false
-                | Some { storage } ->
+                | Some { storage; _ } ->
-                    parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto ->
+                    parse_data ctxt gas storage_type (Micheline.root storage) >>=? fun (sto, gas) ->
                     logged_return ~origination (Item ((), Item (sto, Empty)), gas, ctxt))
           end
         | Transfer_tokens storage_type,
@@ -693,27 +690,38 @@ let rec interp
             Contract.get_script ctxt destination >>=? function
             | None -> fail (Invalid_contract (loc, destination))
             | Some script ->
-                let maybe_diff = Script_ir_translator.(
+                begin match extract_big_map storage_type sto with
-                    Option.map ~f:to_serializable_big_map
+                  | None ->
-                    @@ extract_big_map storage_type sto) in
+                      return (None, gas)
-                let sto = Micheline.strip_locations (unparse_data storage_type sto) in
+                  | 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) ->
+                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 ->
-                let p = unparse_data tp p in
+                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) ->
-                Contract.update_script_storage ctxt destination sto
+                begin match maybe_diff with
-                  (Option.map ~f:Script_ir_translator.to_serializable_big_map maybe_diff) >>=? fun ctxt ->
+                  | None ->
+                      return (None, gas)
+                  | Some diff ->
+                      Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) ->
+                      return (Some diff, gas)
+                end >>=? fun (diff, gas) ->
+                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 tr ret) >>=? fun v ->
+                  (parse_data ctxt gas tr ret) >>=? fun (v, gas) ->
                 Contract.get_script ctxt source >>=? (function
                     | None -> assert false
-                    | Some { storage } ->
+                    | Some { storage ; _ } ->
-                        parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto ->
+                        parse_data ctxt gas storage_type (Micheline.root storage) >>=? fun (sto, gas) ->
                         logged_return ~origination (Item (v, Item (sto, Empty)), gas, ctxt))
           end
         | Create_account,
@@ -771,9 +779,8 @@ let rec interp
         | Hash_key, Item (key, rest) ->
             logged_return (Item (Signature.Public_key.hash key, rest), Gas.consume gas Gas.Cost_of.hash_key, ctxt)
         | H ty, Item (v, rest) ->
-            let gas = Gas.consume gas (Gas.Cost_of.hash v) in
+            Gas.consume_check gas (Gas.Cost_of.hash v) >>=? fun gas ->
-            Gas.check gas >>=? fun () ->
+            Lwt.return @@ hash_data gas ty v >>=? fun (hash, gas) ->
-            let hash = hash_data ty v in
             logged_return (Item (hash, rest), gas, ctxt)
         | Steps_to_quota, rest ->
             let gas = Gas.consume gas Gas.Cost_of.steps_to_quota in
@@ -804,17 +811,17 @@ let rec interp
 and execute ?log origination orig source ctxt script amount arg gas :
   (Script.expr * Script.node * Gas.t * context * Contract.origination_nonce *
    Script_typed_ir.ex_big_map option) tzresult Lwt.t =
-  parse_script ctxt script
+  parse_script ctxt gas script
-  >>=? fun (Ex_script { code; arg_type; ret_type; storage; storage_type }) ->
+  >>=? fun ((Ex_script { code; arg_type; ret_type; storage; storage_type }), gas) ->
-  parse_data ctxt arg_type arg >>=? fun arg ->
+  parse_data ctxt gas arg_type arg >>=? fun (arg, gas) ->
   trace
     (Runtime_contract_error (source, script.code))
     (interp ?log origination gas orig source amount ctxt code (arg, storage))
-  >>=? fun ((ret, storage), gas, ctxt, origination) ->
+  >>=? fun ((ret, sto), gas, ctxt, origination) ->
-  return (Micheline.strip_locations (unparse_data storage_type storage),
+  Lwt.return @@ unparse_data gas storage_type sto >>=? fun (storage, gas) ->
-          unparse_data ret_type ret,
+  Lwt.return @@ unparse_data gas ret_type ret >>=? fun (ret, gas) ->
-          gas, ctxt, origination,
+  return (Micheline.strip_locations storage, ret, gas, ctxt, origination,
-          Script_ir_translator.extract_big_map storage_type storage)
+          Script_ir_translator.extract_big_map storage_type sto)
 
 let trace origination orig source ctxt script amount arg gas =
   let log = ref [] in

src/proto_alpha/lib_protocol/src/script_ir_translator.mli

@@ -38,10 +38,15 @@ val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option
 val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty
 val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num
 
-val big_map_mem : context -> Alpha_context.Contract.t -> 'key -> ('key, 'value) Script_typed_ir.big_map -> bool Lwt.t
+val big_map_mem :
+  context -> Gas.t -> Contract.t -> 'key ->
+  ('key, 'value) Script_typed_ir.big_map ->
+  (bool * Gas.t) tzresult Lwt.t
 val big_map_get :
-  context -> Alpha_context.Contract.t -> 'key -> ('key, 'value) Script_typed_ir.big_map ->
+  context -> Gas.t ->
-  'value option tzresult Lwt.t
+  Contract.t -> 'key ->
+  ('key, 'value) Script_typed_ir.big_map ->
+  ('value option * Gas.t) tzresult Lwt.t
 val big_map_update :
   'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map ->
   ('key, 'value) Script_typed_ir.big_map
@@ -52,36 +57,42 @@ val ty_eq :
 
 val parse_data :
   ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
-  context -> 'a Script_typed_ir.ty -> Script.node -> 'a tzresult Lwt.t
+  context -> Gas.t -> 'a Script_typed_ir.ty -> Script.node -> ('a * Gas.t) tzresult Lwt.t
 val unparse_data :
-  'a Script_typed_ir.ty -> 'a -> Script.node
+  Gas.t -> 'a Script_typed_ir.ty -> 'a -> (Script.node * Gas.t) tzresult
 
-val parse_ty : bool ->
+val parse_ty :
-  Script.node -> (ex_ty * Script_typed_ir.annot) tzresult
+  Gas.t -> bool -> Script.node ->
+  ((ex_ty * Script_typed_ir.annot) * Gas.t) tzresult
 val unparse_ty :
   string option -> 'a Script_typed_ir.ty -> Script.node
 
 val parse_toplevel
-  : Script.expr -> (Script.node * Script.node * Script.node * Script.node) tzresult
+  : Gas.t -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * Gas.t) tzresult
 
 val typecheck_code :
-  context -> Script.expr -> type_map tzresult Lwt.t
+  context -> Gas.t -> Script.expr -> (type_map * Gas.t) tzresult Lwt.t
 
 val typecheck_data :
   ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
-  context -> Script.expr * Script.expr -> unit tzresult Lwt.t
+  context -> Gas.t -> Script.expr * Script.expr -> Gas.t tzresult Lwt.t
 
 val parse_script :
   ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
-  context -> Script.t -> ex_script tzresult Lwt.t
+  context -> Gas.t -> Script.t -> (ex_script * Gas.t) tzresult Lwt.t
 
-val hash_data : 'a Script_typed_ir.ty -> 'a -> string
+val hash_data : Gas.t -> 'a Script_typed_ir.ty -> 'a -> (string * Gas.t) tzresult
 
 val extract_big_map : 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option
 
-val to_serializable_big_map : Script_typed_ir.ex_big_map -> Contract_storage.big_map_diff
+val to_serializable_big_map :
+  Gas.t -> Script_typed_ir.ex_big_map ->
+  (Contract_storage.big_map_diff * Gas.t) tzresult Lwt.t
 
-val to_printable_big_map : Script_typed_ir.ex_big_map -> (Script.expr * Script.expr option) list
+val to_printable_big_map :
+  Script_typed_ir.ex_big_map ->
+  (Script.expr * Script.expr option) list
 
-val erase_big_map_initialization : context -> Script.t ->
+val erase_big_map_initialization :
-  (Script.t * Contract_storage.big_map_diff option) tzresult Lwt.t
+  context -> Gas.t -> Script.t ->
+  (Script.t * Contract_storage.big_map_diff option * Gas.t) tzresult Lwt.t

src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml

@@ -30,8 +30,8 @@ let ex_ty_enc =
   Data_encoding.conv
     (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty))
     (fun expr ->
-       match parse_ty true (root expr) with
+       match parse_ty (Gas.of_int 10000000000) true (root expr) with
-       | Ok (Ex_ty ty, _) -> Ex_ty ty
+       | Ok ((Ex_ty ty, _), _) -> Ex_ty ty
        | _ -> Ex_ty Unit_t (* FIXME: ? *))
     Script.expr_encoding
 

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 key_type print_data data_type contents =
+let expect_big_map tc contract print_key ?(gas=Proto_alpha.Gas.max_gas) key_type print_data data_type contents =
   let open Proto_alpha.Error_monad in
   iter_p
     (fun (n, exp) ->
-       let key = Proto_alpha.Script_ir_translator.hash_data key_type n in
+       Lwt.return @@ Proto_alpha.Script_ir_translator.hash_data gas key_type n >>=? fun (key, gas) ->
        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 key_type print_data data_type contents
            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 data_type (Micheline.root data) >>=? fun data ->
+           Proto_alpha.Script_ir_translator.parse_data tc gas data_type (Micheline.root data) >>=? fun (data, _gas) ->
            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 data_type (Micheline.root data) >>=? fun data ->
+           Proto_alpha.Script_ir_translator.parse_data tc gas data_type (Micheline.root data) >>=? fun (data, _gas) ->
            debug " - big_map[%a] = %a (expected %a)" print_key n print_data data print_data exp ;
            Helpers_assert.equal data exp ;
            return ())

src/proto_alpha/lib_protocol/test/test_michelson.ml

@@ -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" "39991" >>=? fun _ ->
+  test_output ~location: __LOC__ "steps_to_quota" "Unit" "Unit" "39973" >>=? fun _ ->
 
   let bootstrap_0 = List.nth Account.bootstrap_accounts 0 in
   get_balance_res bootstrap_0 sb >>=?? fun _balance ->