Michelson: fix gas cost for CONTRACT

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -303,6 +303,8 @@ module Script : sig
   val lazy_expr_encoding: lazy_expr Data_encoding.t
   val deserialized_cost : expr -> Gas.cost
   val serialized_cost : MBytes.t -> Gas.cost
+  val traversal_cost : node -> Gas.cost
+  val node_cost : node -> Gas.cost
   val int_node_cost : Z.t -> Gas.cost
   val int_node_cost_of_numbits : int -> Gas.cost
   val string_node_cost : string -> Gas.cost

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -660,12 +660,8 @@ let rec interp
             logged_return (Item (contract, rest), ctxt)
         | Contract t, Item (contract, rest) ->
             Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt ->
-            Contract.exists ctxt contract >>=? fun exists ->
-            if exists then
-              Script_ir_translator.parse_contract ctxt loc t contract >>=? fun (ctxt, contract) ->
-              logged_return (Item (Some contract, rest), ctxt)
-            else
-              logged_return (Item (None, rest), ctxt)
+            Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) ->
+            logged_return (Item (maybe_contract, rest), ctxt)
         | Transfer_tokens,
           Item (p, Item (amount, Item ((tp, destination), rest))) ->
             Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -2702,6 +2702,55 @@ and parse_contract
                let contract : arg typed_contract = (arg, contract) in
                ok (ctxt, contract))
 
+(* Same as the one above, but does not fail when the contact is missing or
+   if the expected type doesn't match the actual one. In that case None is
+   returned and some overapproximation of the typechecking gas is consumed.
+   This can still fail on gas exhaustion. *)
+and parse_contract_for_script
+  : type arg. context -> Script.location -> arg ty -> Contract.t ->
+    (context * arg typed_contract option) tzresult Lwt.t
+  = fun ctxt loc arg contract ->
+    Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt ->
+    Contract.exists ctxt contract >>=? function
+    | false -> return (ctxt, None)
+    | true ->
+        Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt ->
+        trace
+          (Invalid_contract (loc, contract)) @@
+        Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with (* can only fail because of gas *)
+        | None ->
+            Lwt.return
+              (match ty_eq ctxt arg (Unit_t None) with
+               | Ok (Eq, ctxt) ->
+                   let contract : arg typed_contract = (arg, contract) in
+                   ok (ctxt, Some contract)
+               | Error _ ->
+                   Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt ->
+                   ok (ctxt, None))
+        | Some { code ; _ } ->
+            Script.force_decode ctxt code >>=? fun (code, ctxt) -> (* can only fail because of gas *)
+            Lwt.return
+              (match parse_toplevel code with
+               | Error _ -> error (Invalid_contract (loc, contract))
+               | Ok (arg_type, _, _) ->
+                   match parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type with
+                   | Error _ ->
+                       error (Invalid_contract (loc, contract))
+                   | Ok (Ex_ty targ, ctxt) ->
+                       match
+                         (ty_eq ctxt targ arg >>? fun (Eq, ctxt) ->
+                          merge_types ctxt loc targ arg >>? fun (arg, ctxt) ->
+                          let contract : arg typed_contract = (arg, contract) in
+                          ok (ctxt, Some contract))
+                       with
+                       | Ok res -> ok res
+                       | Error _ ->
+                           (* overapproximation by checking if targ = targ,
+                              can only fail because of gas *)
+                           ty_eq ctxt targ targ >>? fun (Eq, ctxt) ->
+                           merge_types ctxt loc targ targ >>? fun (_, ctxt) ->
+                           ok (ctxt, None))
+
 and parse_toplevel
   : Script.expr -> (Script.node * Script.node * Script.node) tzresult
   = fun toplevel ->

src/proto_alpha/lib_protocol/src/script_ir_translator.mli

@@ -101,6 +101,10 @@ val parse_contract :
   context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
   (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t
 
+val parse_contract_for_script :
+  context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
+  (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t
+
 val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t
 val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t
 

src/proto_alpha/lib_protocol/src/script_repr.ml

@@ -109,29 +109,32 @@ let rec node_size node =
 let expr_size expr =
   node_size (Micheline.root expr)
 
-let traversal_cost expr =
-  let blocks, _words = expr_size expr in
+let traversal_cost node =
+  let blocks, _words = node_size node in
   Gas_limit_repr.step_cost blocks
 
-let node_cost (blocks, words) =
+let cost_of_size (blocks, words) =
   let open Gas_limit_repr in
   ((Compare.Int.max 0 (blocks - 1)) *@ alloc_cost 0) +@
   alloc_cost words +@
   step_cost blocks
 
-let int_node_cost n = node_cost (int_node_size n)
-let int_node_cost_of_numbits n = node_cost (int_node_size_of_numbits n)
-let string_node_cost s = node_cost (string_node_size s)
-let string_node_cost_of_length s = node_cost (string_node_size_of_length s)
-let bytes_node_cost s = node_cost (bytes_node_size s)
-let bytes_node_cost_of_length s = node_cost (bytes_node_size_of_length s)
-let prim_node_cost_nonrec args annot = node_cost (prim_node_size_nonrec args annot)
-let prim_node_cost_nonrec_of_length n_args annot = node_cost (prim_node_size_nonrec_of_lengths n_args annot)
-let seq_node_cost_nonrec args = node_cost (seq_node_size_nonrec args)
-let seq_node_cost_nonrec_of_length n_args = node_cost (seq_node_size_nonrec_of_length n_args)
+let node_cost node =
+  cost_of_size (node_size node)
+
+let int_node_cost n = cost_of_size (int_node_size n)
+let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n)
+let string_node_cost s = cost_of_size (string_node_size s)
+let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s)
+let bytes_node_cost s = cost_of_size (bytes_node_size s)
+let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s)
+let prim_node_cost_nonrec args annot = cost_of_size (prim_node_size_nonrec args annot)
+let prim_node_cost_nonrec_of_length n_args annot = cost_of_size (prim_node_size_nonrec_of_lengths n_args annot)
+let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args)
+let seq_node_cost_nonrec_of_length n_args = cost_of_size (seq_node_size_nonrec_of_length n_args)
 
 let deserialized_cost expr =
-  node_cost (expr_size expr)
+  cost_of_size (expr_size expr)
 
 let serialized_cost bytes =
   let open Gas_limit_repr in
@@ -163,7 +166,7 @@ let force_bytes expr =
   match Data_encoding.force_bytes expr with
   | bytes ->
       begin match account_serialization_cost with
-        | Some v -> ok (bytes, traversal_cost v +@ serialized_cost bytes)
+        | Some v -> ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes)
         | None -> ok (bytes, Gas_limit_repr.free)
       end
   | exception _ -> error Lazy_script_decode

src/proto_alpha/lib_protocol/src/script_repr.mli

@@ -34,6 +34,8 @@ val encoding : t Data_encoding.encoding
 val deserialized_cost : expr -> Gas_limit_repr.cost
 
 val serialized_cost : MBytes.t -> Gas_limit_repr.cost
+val traversal_cost : node -> Gas_limit_repr.cost
+val node_cost : node -> Gas_limit_repr.cost
 
 val int_node_cost : Z.t -> Gas_limit_repr.cost
 val int_node_cost_of_numbits : int -> Gas_limit_repr.cost