Alpha: minor improvements and fixes in gas

src/lib_data_encoding/data_encoding.ml

@@ -100,7 +100,7 @@ struct
     splitted ~json ~binary
   let make_lazy encoding value =
     { encoding ; state = Value value }
-  let fold_lazy fun_value fun_bytes fun_combine le =
+  let apply_lazy ~fun_value ~fun_bytes ~fun_combine le =
     match le.state with
     | Value value -> fun_value value
     | Bytes bytes -> fun_bytes bytes

src/lib_data_encoding/data_encoding.mli

@@ -510,9 +510,9 @@ module Encoding: sig
   (** Make a lazy value from an immediate one. *)
   val make_lazy : 'a encoding -> 'a -> 'a lazy_t
 
-  (** Fold on structure of lazy value, and combine results *)
+  (** Apply on structure of lazy value, and combine results *)
-  val fold_lazy :
+  val apply_lazy :
-    ('a -> 'b) -> (MBytes.t -> 'b) -> ('b -> 'b -> 'b) ->
+    fun_value:('a -> 'b) -> fun_bytes:(MBytes.t -> 'b) -> fun_combine:('b -> 'b -> 'b) ->
     'a lazy_t -> 'b
 
 end

src/lib_error_monad/error_monad.ml

@@ -557,6 +557,20 @@ module Make(Prefix : sig val id : string end) = struct
     | Error errs -> Lwt.return (Error (err :: errs))
     | ok -> Lwt.return ok
 
+  let record_trace_eval mk_err result =
+    match result with
+    | Ok _ as res -> res
+    | Error errs ->
+        mk_err () >>? fun err ->
+        Error (err :: errs)
+
+  let trace_eval mk_err f =
+    f >>= function
+    | Error errs ->
+        mk_err () >>=? fun err ->
+        Lwt.return (Error (err :: errs))
+    | ok -> Lwt.return ok
+
   let fail_unless cond exn =
     if cond then return_unit else fail exn
 

src/lib_error_monad/error_monad_sig.ml

@@ -127,6 +127,12 @@ module type S = sig
   (** Automatically enrich error reporting on stack rewind *)
   val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
 
+  (** Same as record_trace, for unevaluated error *)
+  val record_trace_eval : (unit -> error tzresult) -> 'a tzresult -> 'a tzresult
+
+  (** Same as trace, for unevaluated Lwt error *)
+  val trace_eval : (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
+
   (** Erroneous return on failed assertion *)
   val fail_unless : bool -> error -> unit tzresult Lwt.t
   val fail_when : bool -> error -> unit tzresult Lwt.t

src/lib_protocol_environment/sigs/v1/data_encoding.mli

@@ -198,8 +198,8 @@ val lazy_encoding : 'a encoding -> 'a lazy_t encoding
 val force_decode : 'a lazy_t -> 'a option
 val force_bytes : 'a lazy_t -> MBytes.t
 val make_lazy : 'a encoding -> 'a -> 'a lazy_t
-val fold_lazy :
+val apply_lazy :
-  ('a -> 'b) -> (MBytes.t -> 'b) -> ('b -> 'b -> 'b) ->
+  fun_value:('a -> 'b) -> fun_bytes:(MBytes.t -> 'b) -> fun_combine:('b -> 'b -> 'b) ->
   'a lazy_t -> 'b
 
 module Json : sig

src/lib_protocol_environment/sigs/v1/error_monad.mli

@@ -118,6 +118,12 @@ val record_trace : error -> 'a tzresult -> 'a tzresult
 (** Automatically enrich error reporting on stack rewind *)
 val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
 
+(** Same as record_trace, for unevaluated error *)
+val record_trace_eval : (unit -> error tzresult) -> 'a tzresult -> 'a tzresult
+
+(** Same as trace, for unevaluated Lwt error *)
+val trace_eval : (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
+
 (** Erroneous return on failed assertion *)
 val fail_unless : bool -> error -> unit tzresult Lwt.t
 

src/proto_alpha/lib_client_commands/client_proto_context_commands.ml

@@ -129,7 +129,7 @@ let commands () =
         | None ->
             cctxt#error "This is not a smart contract."
         | Some { code ; storage = _ } ->
-            match Script.force_decode code with
+            match Script_repr.force_decode code with
             | Error errs -> cctxt#error "%a" (Format.pp_print_list ~pp_sep:Format.pp_print_newline Alpha_environment.Error_monad.pp) errs
             | Ok (code, _) ->
                 begin cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped code >>= fun () ->

src/proto_alpha/lib_protocol/src/alpha_context.ml

@@ -53,6 +53,16 @@ end
 module Script = struct
   include Michelson_v1_primitives
   include Script_repr
+  let force_decode ctxt lexpr =
+    Lwt.return
+      (Script_repr.force_decode lexpr >>? fun (v, cost) ->
+       Raw_context.consume_gas ctxt cost >|? fun ctxt ->
+       (v, ctxt))
+  let force_bytes ctxt lexpr =
+    Lwt.return
+      (Script_repr.force_bytes lexpr >>? fun (b, cost) ->
+       Raw_context.consume_gas ctxt cost >|? fun ctxt ->
+       (b, ctxt))
 end
 module Fees = Fees_storage
 
@@ -74,6 +84,7 @@ module Gas = struct
   let set_limit = Raw_context.set_gas_limit
   let set_unlimited = Raw_context.set_gas_unlimited
   let consume = Raw_context.consume_gas
+  let check_enough = Raw_context.check_enough_gas
   let level = Raw_context.gas_level
   let consumed = Raw_context.gas_consumed
   let block_level = Raw_context.block_gas_level

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -140,6 +140,7 @@ module Gas : sig
   val set_limit: context -> Z.t -> context
   val set_unlimited: context -> context
   val consume: context -> cost -> context tzresult
+  val check_enough: context -> cost -> unit tzresult
   val level: context -> t
   val consumed: since: context -> until: context -> Z.t
   val block_level: context -> Z.t
@@ -311,9 +312,9 @@ module Script : sig
   val prim_node_cost_nonrec_of_length : int -> annot -> Gas.cost
   val seq_node_cost_nonrec : expr list -> Gas.cost
   val seq_node_cost_nonrec_of_length : int -> Gas.cost
-  val force_decode : lazy_expr -> (expr * Gas.cost) tzresult
-  val force_bytes : lazy_expr -> (MBytes.t * Gas.cost) tzresult
   val minimal_deserialize_cost : lazy_expr -> Gas.cost
+  val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t
+  val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t
 end
 
 module Constants : sig

src/proto_alpha/lib_protocol/src/apply.ml

@@ -364,8 +364,8 @@ let apply_manager_operation_content :
             match parameters with
             | None -> return ctxt
             | Some arg ->
-                Lwt.return (Script.force_decode arg) >>=? fun (arg, _cost_arg (* see [note] *)) ->
+                Script.force_decode ctxt arg >>=? fun (arg, ctxt) -> (* see [note] *)
-                (* [note]: for toplevel ops, _cost_* is nil since the
+                (* [note]: for toplevel ops, cost is nil since the
                    lazy value has already been forced at precheck, so
                    we compute and consume the full cost again *)
                 let cost_arg = Script.deserialized_cost arg in
@@ -396,7 +396,7 @@ let apply_manager_operation_content :
                   let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in
                   return (ctxt, unit)
               | Some parameters ->
-                  Lwt.return (Script.force_decode parameters) >>=? fun (arg, _cost_arg (* see [note] *)) ->
+                  Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *)
                   let cost_arg = Script.deserialized_cost arg in
                   Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt ->
                   return (ctxt, arg)
@@ -431,10 +431,10 @@ let apply_manager_operation_content :
         begin match script with
           | None -> return (None, ctxt)
           | Some script ->
-              Lwt.return (Script.force_decode script.storage) >>=? fun (ustorage, _cost (* see [note] *)) ->
+              Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *)
-              Lwt.return (Gas.consume ctxt (Script.deserialized_cost ustorage)) >>=? fun ctxt ->
+              Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt ->
-              Lwt.return (Script.force_decode script.storage) >>=? fun (ucode, _cost (* see [note] *)) ->
+              Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *)
-              Lwt.return (Gas.consume ctxt (Script.deserialized_cost ucode)) >>=? fun ctxt ->
+              Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt ->
               Script_ir_translator.parse_script ctxt script >>=? fun (_, ctxt) ->
               Script_ir_translator.erase_big_map_initialization ctxt Optimized script >>=? fun (script, big_map_diff, ctxt) ->
               return (Some (script, big_map_diff), ctxt)
@@ -518,23 +518,21 @@ let precheck_manager_contents
     | Transaction { parameters = Some arg ; _ } ->
         (* Fail quickly if not enough gas for minimal deserialization cost *)
         Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
-        Gas.consume ctxt (Script.minimal_deserialize_cost arg) >>=? fun _ ->
+        Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () ->
         (* Fail if not enough gas for complete deserialization cost *)
-        Lwt.return @@ Script.force_decode arg >>=? fun (_arg, cost_arg) ->
+        trace Gas_quota_exceeded_init_deserialize @@
-        Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
+        Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt
-        Gas.consume ctxt cost_arg
     | Origination { script = Some script ; _ } ->
         (* Fail quickly if not enough gas for minimal deserialization cost *)
         Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
         (Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt ->
-         Gas.consume ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun _ ->
+         Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun () ->
         (* Fail if not enough gas for complete deserialization cost *)
-        Lwt.return @@ Script.force_decode script.code >>=? fun (_code, cost_code) ->
+        trace Gas_quota_exceeded_init_deserialize @@
-        Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
+        Script.force_decode ctxt script.code >>=? fun (_code, ctxt) ->
-        Gas.consume ctxt cost_code >>=? fun ctxt ->
+        trace Gas_quota_exceeded_init_deserialize @@
-        Lwt.return @@ Script.force_decode script.storage >>=? fun (_storage, cost_storage) ->
+        Script.force_decode ctxt script.storage >>|? fun (_storage, ctxt) ->
-        Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
+        ctxt
-        Gas.consume ctxt cost_storage
     | _ -> return ctxt
   end >>=? fun ctxt ->
   Contract.get_manager_key ctxt source >>=? fun public_key ->

src/proto_alpha/lib_protocol/src/contract_services.ml

@@ -168,9 +168,8 @@ let register () =
           let ctxt = Gas.set_unlimited ctxt in
           let open Script_ir_translator in
           parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
-          unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
+          unparse_script ctxt Readable script >>=? fun script ->
-          Lwt.return @@ Script.force_decode script.storage >>=? fun (storage, cost_storage) ->
+          Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) ->
-          Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun _ctxt ->
           return_some storage) ;
   register_field S.info (fun ctxt contract ->
       Contract.get_balance ctxt contract >>=? fun balance ->
@@ -186,7 +185,7 @@ let register () =
             let ctxt = Gas.set_unlimited ctxt in
             let open Script_ir_translator in
             parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
-            unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
+            unparse_script ctxt Readable script >>=? fun script ->
             return (Some script, ctxt)
       end >>=? fun (script, _ctxt) ->
       return { manager ; balance ;

src/proto_alpha/lib_protocol/src/gas_limit_repr.ml

@@ -99,6 +99,10 @@ let consume block_gas operation_gas cost = match operation_gas with
       then error Block_quota_exceeded
       else ok (block_remaining, Limited { remaining })
 
+let check_enough block_gas operation_gas cost =
+  consume block_gas operation_gas cost
+  >|? fun (_block_remainig, _remaining) -> ()
+
 let alloc_cost n =
   { allocations = Z.of_int (n + 1) ;
     steps = Z.zero ;

src/proto_alpha/lib_protocol/src/gas_limit_repr.mli

@@ -23,6 +23,7 @@ type error += Block_quota_exceeded (* `Temporary *)
 type error += Operation_quota_exceeded (* `Temporary *)
 
 val consume : Z.t -> t -> cost -> (Z.t * t) tzresult
+val check_enough : Z.t -> t -> cost -> unit tzresult
 
 val free : cost
 val step_cost : int -> cost

src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml

@@ -233,11 +233,14 @@ module Cost_of = struct
     let operation b = bytes b
     let type_ nb_args = alloc_cost (nb_args + 1)
 
+    (* Cost of parsing instruction, is cost of allocation of
+       constructor + cost of contructor parameters + cost of
+       allocation on the stack type *)
     let instr
       : type b a. (b, a) Script_typed_ir.instr -> cost
       = fun i ->
         let open Script_typed_ir in
-        alloc_cost 1 +@
+        alloc_cost 1 +@ (* cost of allocation of constructor *)
         match i with
         | Drop -> alloc_cost 0
         | Dup -> alloc_cost 1

src/proto_alpha/lib_protocol/src/raw_context.ml

@@ -173,6 +173,8 @@ let set_gas_unlimited ctxt =
 let consume_gas ctxt cost =
   Gas_limit_repr.consume ctxt.block_gas ctxt.operation_gas cost >>? fun (block_gas, operation_gas) ->
   ok { ctxt with block_gas ; operation_gas }
+let check_enough_gas ctxt cost =
+  Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas cost
 let gas_level ctxt = ctxt.operation_gas
 let block_gas_level ctxt = ctxt.block_gas
 let gas_consumed ~since ~until =
@@ -523,6 +525,8 @@ module type T = sig
 
   val consume_gas: context -> Gas_limit_repr.cost -> context tzresult
 
+  val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult
+
   val description: context Storage_description.t
 
 end

src/proto_alpha/lib_protocol/src/raw_context.mli

@@ -192,6 +192,9 @@ module type T = sig
       within a view. *)
   val consume_gas: context -> Gas_limit_repr.cost -> context tzresult
 
+  (** Check if consume_gas will fail *)
+  val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult
+
   val description: context Storage_description.t
 
 end

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -694,12 +694,12 @@ let rec interp
                            (credit, Item
                               (init, rest)))))) ->
             Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt ->
-            unparse_ty ctxt param_type >>=? fun (u_param_type, ctxt) ->
+            unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) ->
-            unparse_ty ctxt storage_type >>=? fun (u_storage_type, ctxt) ->
+            unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) ->
             let code =
               Micheline.strip_locations
-                (Seq (0, [ Prim (0, K_parameter, [ u_param_type ], []) ;
+                (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ;
-                           Prim (0, K_storage, [ u_storage_type ], []) ;
+                           Prim (0, K_storage, [ unparsed_storage_type ], []) ;
                            Prim (0, K_code, [ Micheline.root code ], []) ])) in
             unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
             let storage = Micheline.strip_locations storage in
@@ -788,8 +788,7 @@ and execute ?log ctxt mode ~source ~payer ~self script amount arg :
   trace
     (Bad_contract_parameter self)
     (parse_data ctxt arg_type arg) >>=? fun (arg, ctxt) ->
-  Lwt.return @@ Script.force_decode script.code >>=? fun (script_code, cost_script_code) ->
+  Script.force_decode ctxt script.code >>=? fun (script_code, ctxt) ->
-  Lwt.return @@ Gas.consume ctxt cost_script_code >>=? fun ctxt ->
   trace
     (Runtime_contract_error (self, script_code))
     (interp ?log ctxt ~source ~payer ~self amount code (arg, storage))

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -680,30 +680,14 @@ let comparable_ty_eq
         serialize_ty_for_error ctxt (ty_of_comparable_ty tb) >>? fun (tb, _ctxt) ->
         error (Inconsistent_types (ta, tb))
 
-
-let record_trace mk_err result =
-  match result with
-  | Ok _ as res -> res
-  | Error errs ->
-      mk_err () >>? fun err ->
-      Error (err :: errs)
-
-let trace mk_err f =
-  f >>= function
-  | Error errs ->
-      mk_err () >>=? fun err ->
-      Lwt.return (Error (err :: errs))
-  | ok -> Lwt.return ok
-
-
 let record_inconsistent ctxt ta tb =
-  record_trace (fun () ->
+  record_trace_eval (fun () ->
       serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) ->
       serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) ->
       Inconsistent_types (ta, tb))
 
 let record_inconsistent_type_annotations ctxt loc ta tb =
-  record_trace (fun () ->
+  record_trace_eval (fun () ->
       serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) ->
       serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) ->
       Inconsistent_type_annotations (loc, ta, tb))
@@ -784,7 +768,7 @@ let rec stack_ty_eq
     match ta, tb with
     | Item_t (tva, ra, _), Item_t (tvb, rb, _) ->
         ty_eq ctxt tva tvb |>
-        record_trace (fun () -> ok (Bad_stack_item lvl)) >>? fun (Eq, ctxt) ->
+        record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) ->
         stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) ->
         (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
     | Empty_t, Empty_t -> Ok (Eq, ctxt)
@@ -972,7 +956,7 @@ let merge_branches
           serialize_stack_for_error ctxt aftbt >>=? fun (aftbt, ctxt) ->
           serialize_stack_for_error ctxt aftbf >>|? fun (aftbf, _ctxt) ->
           Unmatched_branches (loc, aftbt, aftbf) in
-        trace unmatched_branches
+        trace_eval unmatched_branches
           (Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) >>=? fun (Eq, ctxt) ->
            Lwt.return (merge_stacks loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) ->
            return (
@@ -1023,10 +1007,8 @@ let rec parse_comparable_ty
         error (Invalid_arity (loc, prim, 0, List.length l))
     | Prim (loc, (T_pair | T_or | T_set | T_map
                  | T_list | T_option  | T_lambda
-                 | T_unit | T_signature  | T_contract), _, _) as expr ->
+                 | T_unit | T_signature  | T_contract), _, _) ->
-        parse_ty ctxt ~allow_big_map:false ~allow_operation:false expr >>? fun (Ex_ty ty, ctxt) ->
+        error (Comparable_type_expected (loc, Micheline.strip_locations ty))
-        serialize_ty_for_error ctxt ty >>? fun (ty, _ctxt) ->
-        error (Comparable_type_expected (loc, ty))
     | expr ->
         error @@ unexpected expr [] Type_namespace
           [ T_int ; T_nat ;
@@ -1055,7 +1037,7 @@ and parse_ty :
               parse_type_annot big_map_loc map_annot >>? fun map_name ->
               parse_composed_type_annot loc storage_annot
               >>? fun (ty_name, map_field, storage_field) ->
-              Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt ->
+              Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt ->
               let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in
               Ex_ty (Pair_t ((big_map_ty, map_field, None),
                              (remaining_storage, storage_field, None),
@@ -1241,7 +1223,7 @@ let rec parse_data
       Lwt.return (serialize_ty_for_error ctxt ty) >>|? fun (ty, _ctxt) ->
       Invalid_constant (location script_data, strip_locations script_data, ty) in
     let traced body =
-      trace error body in
+      trace_eval error body in
     let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper =
       let length = List.length items in
       fold_left_s
@@ -1315,8 +1297,10 @@ let rec parse_data
         traced (fail (Invalid_kind (location expr, [ Bytes_kind ], kind expr)))
     (* Integers *)
     | Int_t _, Int (_, v) ->
+        (* TODO gas *)
         return (Script_int.of_zint v, ctxt)
     | Nat_t _, Int (_, v) ->
+        (* TODO gas *)
         let v = Script_int.of_zint v in
         if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then
           return (Script_int.abs v, ctxt)
@@ -1340,6 +1324,7 @@ let rec parse_data
         traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr)))
     (* Timestamps *)
     | Timestamp_t _, (Int (_, v)) (* As unparsed with [Optimized] or out of bounds [Readable]. *) ->
+        (* TODO gas *)
         return (Script_timestamp.of_zint v, ctxt)
     | Timestamp_t _, String (_, s) (* As unparsed with [Redable]. *) ->
         Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt ->
@@ -1488,6 +1473,7 @@ let rec parse_data
         traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ]))
     (* Lists *)
     | List_t (t, _ty_name), Seq (_loc, items) ->
+        (* TODO gas *)
         traced @@
         fold_right_s
           (fun v (rest, ctxt) ->
@@ -1499,6 +1485,7 @@ let rec parse_data
         traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
     (* Sets *)
     | Set_t (t, _ty_name), (Seq (loc, vs) as expr) ->
+        (* TODO gas *)
         let length = List.length vs in
         traced @@
         fold_left_s
@@ -1523,10 +1510,12 @@ let rec parse_data
         traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
     (* Maps *)
     | Map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) ->
+        (* TODO gas *)
         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, _ty_name), (Seq (loc, vs) as expr) ->
+        (* TODO 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 ->
@@ -1549,7 +1538,7 @@ and parse_returning
     parse_instr ?type_logger tc_context ctxt
       script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function
     | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), ctxt) ->
-        trace
+        trace_eval
           (fun () ->
              Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) ->
              serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) ->
@@ -1572,10 +1561,10 @@ and parse_instr
     Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t =
   fun ?type_logger tc_context ctxt script_instr stack_ty ->
     let check_item check loc name n m =
-      trace (fun () ->
+      trace_eval (fun () ->
           serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) ->
           Bad_stack (loc, name, m, stack_ty)) @@
-      trace (fun () -> return (Bad_stack_item n)) @@
+      trace (Bad_stack_item n) @@
       Lwt.return check in
     let check_item_ty ctxt exp got loc n =
       check_item (ty_eq ctxt exp got) loc n in
@@ -1765,7 +1754,7 @@ and parse_instr
               let invalid_map_body () =
                 serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) ->
                 Invalid_map_body (loc, aft) in
-              trace invalid_map_body
+              trace_eval invalid_map_body
                 (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) ->
                  Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) ->
                  typed ctxt loc (List_map ibody)
@@ -1788,7 +1777,7 @@ and parse_instr
                 serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
                 serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) ->
                 Invalid_iter_body (loc, rest, aft) in
-              trace invalid_iter_body
+              trace_eval invalid_iter_body
                 (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) ->
                  Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) ->
                  typed ctxt loc (List_iter ibody) rest)
@@ -1815,7 +1804,7 @@ and parse_instr
                 serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
                 serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) ->
                 Invalid_iter_body (loc, rest, aft) in
-              trace invalid_iter_body
+              trace_eval invalid_iter_body
                 (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) ->
                  Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) ->
                  typed ctxt loc (Set_iter ibody) rest)
@@ -1860,7 +1849,7 @@ and parse_instr
               let invalid_map_body () =
                 serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) ->
                 Invalid_map_body (loc, aft) in
-              trace invalid_map_body
+              trace_eval invalid_map_body
                 (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) ->
                  Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) ->
                  typed ctxt loc (Map_map ibody)
@@ -1886,7 +1875,7 @@ and parse_instr
                 serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
                 serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) ->
                 Invalid_iter_body (loc, rest, aft) in
-              trace invalid_iter_body
+              trace_eval invalid_iter_body
                 (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) ->
                  Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) ->
                  typed ctxt loc (Map_iter ibody) rest)
@@ -2000,7 +1989,7 @@ and parse_instr
                 serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
                 serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) ->
                 Unmatched_branches (loc, aft, stack) in
-              trace unmatched_branches
+              trace_eval unmatched_branches
                 (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) ->
                  Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) ->
                  typed ctxt loc (Loop ibody) rest)
@@ -2020,7 +2009,7 @@ and parse_instr
                 serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
                 serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) ->
                 Unmatched_branches (loc, aft, stack) in
-              trace unmatched_branches
+              trace_eval unmatched_branches
                 (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) ->
                  Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) ->
                  typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)))
@@ -2492,13 +2481,11 @@ and parse_instr
         let cannonical_code = fst @@ Micheline.extract_locations code in
         Lwt.return @@ parse_toplevel cannonical_code >>=? fun (arg_type, storage_type, code_field) ->
         trace
-          (fun () -> Error_monad.return
+          (Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
-              (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)))
           (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)
         >>=? fun (Ex_ty arg_type, ctxt) ->
         trace
-          (fun () -> Error_monad.return
+          (Ill_formed_type (Some "storage", cannonical_code, location storage_type))
-              (Ill_formed_type (Some "storage", cannonical_code, location storage_type)))
           (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type)
         >>=? fun (Ex_ty storage_type, ctxt) ->
         let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
@@ -2511,7 +2498,7 @@ and parse_instr
           Pair_t ((List_t (Operation_t None, None), None, None),
                   (storage_type, None, None), None) in
         trace
-          (fun () -> Error_monad.return (Ill_typed_contract (cannonical_code, [])))
+          (Ill_typed_contract (cannonical_code, []))
           (parse_returning (Toplevel { storage_type ; param_type = arg_type })
              ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=?
         fun (Lam ({ bef = Item_t (arg, Empty_t, _) ;
@@ -2699,7 +2686,7 @@ and parse_contract
     | true ->
         Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt ->
         trace
-          (fun () -> return (Invalid_contract (loc, contract))) @@
+          (Invalid_contract (loc, contract)) @@
         Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with
         | None ->
             Lwt.return
@@ -2707,10 +2694,9 @@ and parse_contract
                let contract : arg typed_contract = (arg, contract) in
                ok (ctxt, contract))
         | Some { code ; _ } ->
+            Script.force_decode ctxt code >>=? fun (code, ctxt) ->
             Lwt.return
-              (Script.force_decode code >>? fun (code, cost_code) ->
+              (parse_toplevel code >>? fun (arg_type, _, _) ->
-               Gas.consume ctxt cost_code >>? fun ctxt ->
-               parse_toplevel code >>? fun (arg_type, _, _) ->
                parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ, ctxt) ->
                ty_eq ctxt targ arg >>? fun (Eq, ctxt) ->
                merge_types ctxt loc targ arg >>? fun (arg, ctxt) ->
@@ -2720,7 +2706,7 @@ and parse_contract
 and parse_toplevel
   : Script.expr -> (Script.node * Script.node * Script.node) tzresult
   = fun toplevel ->
-    record_trace (fun () -> ok (Ill_typed_contract (toplevel, []))) @@
+    record_trace (Ill_typed_contract (toplevel, [])) @@
     match root toplevel with
     | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind))
     | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind))
@@ -2765,17 +2751,15 @@ let parse_script
   : ?type_logger: type_logger ->
     context -> Script.t -> (ex_script * context) tzresult Lwt.t
   = fun ?type_logger ctxt { code ; storage } ->
-    Lwt.return @@ Script.force_decode code >>=? fun (code, cost_code) ->
+    Script.force_decode ctxt code >>=? fun (code, ctxt) ->
-    Lwt.return @@ Gas.consume ctxt cost_code >>=? fun ctxt ->
+    Script.force_decode ctxt storage >>=? fun (storage, ctxt) ->
-    Lwt.return @@ Script.force_decode storage >>=? fun (storage, cost_storage) ->
-    Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun ctxt ->
     Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) ->
     trace
-      (fun () -> return (Ill_formed_type (Some "parameter", code, location arg_type)))
+      (Ill_formed_type (Some "parameter", code, location arg_type))
       (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type))
     >>=? fun (Ex_ty arg_type, ctxt) ->
     trace
-      (fun () -> return (Ill_formed_type (Some "storage", code, location storage_type)))
+      (Ill_formed_type (Some "storage", code, location storage_type))
       (Lwt.return (parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type))
     >>=? fun (Ex_ty storage_type, ctxt) ->
     let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
@@ -2787,13 +2771,13 @@ let parse_script
     let ret_type_full =
       Pair_t ((List_t (Operation_t None, None), None, None),
               (storage_type, None, None), None) in
-    trace
+    trace_eval
       (fun () ->
          Lwt.return @@ serialize_ty_for_error ctxt storage_type >>|? fun (storage_type, _ctxt) ->
          Ill_typed_data (None, storage, storage_type))
       (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) ->
     trace
-      (fun () -> return (Ill_typed_contract (code, [])))
+      (Ill_typed_contract (code, []))
       (parse_returning (Toplevel { storage_type ; param_type = arg_type })
          ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) ->
     return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt)
@@ -2805,11 +2789,11 @@ let typecheck_code
     let type_map = ref [] in
     (* TODO: annotation checking *)
     trace
-      (fun () -> return (Ill_formed_type (Some "parameter", code, location arg_type)))
+      (Ill_formed_type (Some "parameter", code, location arg_type))
       (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type))
     >>=? fun (Ex_ty arg_type, ctxt) ->
     trace
-      (fun () -> return (Ill_formed_type (Some "storage", code, location storage_type)))
+      (Ill_formed_type (Some "storage", code, location storage_type))
       (Lwt.return (parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type))
     >>=? fun (Ex_ty storage_type, ctxt) ->
     let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
@@ -2828,7 +2812,7 @@ let typecheck_code
         ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map)
         (arg_type_full, None) ret_type_full code_field in
     trace
-      (fun () -> return (Ill_typed_contract (code, !type_map)))
+      (Ill_typed_contract (code, !type_map))
       result >>=? fun (Lam _, ctxt) ->
     return (!type_map, ctxt)
 
@@ -2837,10 +2821,10 @@ let typecheck_data
     context -> Script.expr * Script.expr -> context tzresult Lwt.t
   = fun ?type_logger ctxt (data, exp_ty) ->
     trace
-      (fun () -> return (Ill_formed_type (None, exp_ty, 0)))
+      (Ill_formed_type (None, exp_ty, 0))
       (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false (root exp_ty))
     >>=? fun (Ex_ty exp_ty, ctxt) ->
-    trace
+    trace_eval
       (fun () ->
          Lwt.return @@ serialize_ty_for_error ctxt exp_ty >>|? fun (exp_ty, _ctxt) ->
          Ill_typed_data (None, data, exp_ty))
@@ -2995,6 +2979,7 @@ let rec unparse_data
     | Lambda_t _, Lam (_, original_code) ->
         unparse_code ctxt mode (root original_code)
 
+(* only used in client, don't account for gas *)
 and unparse_code ctxt mode = function
   | Prim (loc, I_PUSH, [ ty ; data ], annot) ->
       Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) ->
@@ -3017,31 +3002,34 @@ and unparse_code ctxt mode = function
       return (Prim (loc, prim, List.rev items, annot), ctxt)
   | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt)
 
+(* only used in client, don't account for gas *)
 let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } =
   let Lam (_, original_code) = code in
   unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) ->
   unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) ->
   unparse_ty ctxt arg_type >>=? fun (arg_type, ctxt) ->
-  unparse_ty ctxt storage_type >>=? fun (storage_type, ctxt) ->
+  unparse_ty ctxt storage_type >>=? fun (storage_type, _ctxt) ->
   let open Micheline in
   let code =
     Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ;
                Prim (-1, K_storage, [ storage_type ], []) ;
                Prim (-1, K_code, [ code ], []) ]) in
   return ({ code = lazy_expr (strip_locations code) ;
-            storage = lazy_expr (strip_locations storage) }, ctxt)
+            storage = lazy_expr (strip_locations storage) })
 
 let pack_data ctxt typ data =
   unparse_data ctxt Optimized 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
+  Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt ->
   let bytes = MBytes.concat "" [ MBytes.of_string "\005" ; bytes ] in
   Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt ->
   return (bytes, ctxt)
 
 let hash_data ctxt typ data =
   pack_data ctxt typ data >>=? fun (bytes, ctxt) ->
-  Lwt.return @@ Gas.consume ctxt (Michelson_v1_gas.Cost_of.hash bytes 32) >>=? fun ctxt ->
+  Lwt.return @@ Gas.consume ctxt
+    (Michelson_v1_gas.Cost_of.hash bytes Script_expr_hash.size) >>=? fun ctxt ->
   return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt)
 
 (* ---------------- Big map -------------------------------------------------*)
@@ -3097,10 +3085,8 @@ let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x ->
   | _, _ -> None
 
 let erase_big_map_initialization ctxt mode ({ code ; storage } : Script.t) =
-  Lwt.return @@ Script.force_decode code >>=? fun (code, cost_code) ->
+  Script.force_decode ctxt code >>=? fun (code, ctxt) ->
-  Lwt.return @@ Gas.consume ctxt cost_code >>=? fun ctxt ->
+  Script.force_decode ctxt storage >>=? fun (storage, ctxt) ->
-  Lwt.return @@ Script.force_decode storage >>=? fun (storage, cost_storage) ->
-  Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun ctxt ->
   Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) ->
   Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type >>=? fun (Ex_ty ty, ctxt) ->
   parse_data ctxt ty

src/proto_alpha/lib_protocol/src/script_ir_translator.mli

@@ -91,9 +91,11 @@ val typecheck_data :
 val parse_script :
   ?type_logger: type_logger ->
   context -> Script.t -> (ex_script * context) tzresult Lwt.t
+
+(* only used in client, don't account for gas *)
 val unparse_script :
   context -> unparsing_mode ->
-  ('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t
+  ('a, 'b) Script_typed_ir.script -> Script.t tzresult Lwt.t
 
 val parse_contract :
   context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->

src/proto_alpha/lib_protocol/src/script_repr.ml

@@ -135,16 +135,16 @@ let deserialized_cost expr =
 
 let serialized_cost bytes =
   let open Gas_limit_repr in
-  alloc_bytes_cost (MBytes.length bytes)
+  alloc_cost 12 +@ alloc_bytes_cost (MBytes.length bytes)
 
 let force_decode lexpr =
   match Data_encoding.force_decode lexpr with
   | Some v ->
       let deserialize_cost =
-        Data_encoding.fold_lazy
+        Data_encoding.apply_lazy
-          (fun _ -> Gas_limit_repr.free)
+          ~fun_value:(fun _ -> Gas_limit_repr.free)
-          (fun _ -> deserialized_cost v)
+          ~fun_bytes:(fun _ -> deserialized_cost v)
-          (fun c_free _ -> c_free)
+          ~fun_combine:(fun c_free _ -> c_free)
           lexpr in
       ok (v, deserialize_cost)
   | None -> error Lazy_script_decode
@@ -154,18 +154,17 @@ let force_bytes expr =
   match Data_encoding.force_bytes expr with
   | bytes ->
       let serialize_cost =
-        Data_encoding.fold_lazy
+        Data_encoding.apply_lazy
-          (fun v -> traversal_cost v +@ serialized_cost bytes)
+          ~fun_value:(fun v -> traversal_cost v +@ serialized_cost bytes)
-          (fun _ -> Gas_limit_repr.free)
+          ~fun_bytes:(fun _ -> Gas_limit_repr.free)
-          (fun _ c_free -> c_free)
+          ~fun_combine:(fun _ c_free -> c_free)
           expr in
       ok (bytes, serialize_cost)
   | exception _ -> error Lazy_script_decode
 
 let minimal_deserialize_cost lexpr =
-  let open Gas_limit_repr in
+  Data_encoding.apply_lazy
-  Data_encoding.fold_lazy
+    ~fun_value:(fun _ -> Gas_limit_repr.free)
-    (fun _ -> Gas_limit_repr.free)
+    ~fun_bytes:(fun b -> serialized_cost b)
-    (fun b -> alloc_bytes_cost (MBytes.length b))
+    ~fun_combine:(fun c_free _ -> c_free)
-    (fun c_free _ -> c_free)
     lexpr

src/proto_alpha/lib_protocol/src/storage.ml

@@ -144,16 +144,24 @@ module Contract = struct
       (Z)
 
   module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct
-    include Indexed_context.Make_carbonated_map
+    module I = Indexed_context.Make_carbonated_map
         (N)
         (struct
           type t = Script_repr.lazy_expr
           let encoding = Script_repr.lazy_expr_encoding
         end)
 
+    type context = I.context
+    type key = I.key
+    type value = I.value
+
+    let mem = I.mem
+    let delete = I.delete
+    let remove = I.remove
+
     let consume_deserialize_gas ctxt value =
       Lwt.return @@
-      (Raw_context.consume_gas ctxt (Script_repr.minimal_deserialize_cost value) >>? fun _ ->
+      (Raw_context.check_enough_gas ctxt (Script_repr.minimal_deserialize_cost value) >>? fun () ->
        Script_repr.force_decode value >>? fun (_value, value_cost) ->
        Raw_context.consume_gas ctxt value_cost)
 
@@ -163,12 +171,12 @@ module Contract = struct
        Raw_context.consume_gas ctxt value_cost)
 
     let get ctxt contract =
-      get ctxt contract >>=? fun (ctxt, value) ->
+      I.get ctxt contract >>=? fun (ctxt, value) ->
       consume_deserialize_gas ctxt value >>|? fun ctxt ->
       (ctxt, value)
 
     let get_option ctxt contract =
-      get_option ctxt contract >>=? fun (ctxt, value_opt) ->
+      I.get_option ctxt contract >>=? fun (ctxt, value_opt) ->
       match value_opt with
       | None -> return (ctxt, None)
       | Some value ->
@@ -177,22 +185,22 @@ module Contract = struct
 
     let set ctxt contract value =
       consume_serialize_gas ctxt value >>=? fun ctxt ->
-      set ctxt contract value
+      I.set ctxt contract value
 
     let set_option ctxt contract value_opt =
       match value_opt with
-      | None -> set_option ctxt contract None
+      | None -> I.set_option ctxt contract None
       | Some value ->
           consume_serialize_gas ctxt value >>=? fun ctxt ->
-          set_option ctxt contract value_opt
+          I.set_option ctxt contract value_opt
 
     let init ctxt contract value =
       consume_serialize_gas ctxt value >>=? fun ctxt ->
-      init ctxt contract value
+      I.init ctxt contract value
 
     let init_set ctxt contract value =
       consume_serialize_gas ctxt value >>=? fun ctxt ->
-      init_set ctxt contract value
+      I.init_set ctxt contract value
   end
 
   module Code =

src/proto_alpha/lib_protocol/src/storage_functors.ml

@@ -66,6 +66,7 @@ module Make_subcontext (C : Raw_context.T) (N : NAME)
   let project = C.project
   let absolute_key c k = C.absolute_key c (to_key k)
   let consume_gas = C.consume_gas
+  let check_enough_gas = C.check_enough_gas
   let description =
     Storage_description.register_named_subcontext C.description N.name
 end
@@ -555,6 +556,9 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
     let consume_gas c g =
       let (t, i) = unpack c in
       C.consume_gas t g >>? fun t -> ok (pack t i)
+    let check_enough_gas c g =
+      let (t, _i) = unpack c in
+      C.check_enough_gas t g
     let description = description
   end