Michelson: factor unparsing and deserialization cost computations

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -301,6 +301,16 @@ 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 int_node_cost : Z.t -> Gas.cost
+  val int_node_cost_of_numbits : int -> Gas.cost
+  val string_node_cost : string -> Gas.cost
+  val string_node_cost_of_length : int -> Gas.cost
+  val bytes_node_cost : MBytes.t -> Gas.cost
+  val bytes_node_cost_of_length : int -> Gas.cost
+  val prim_node_cost_nonrec : expr list -> annot  -> Gas.cost
+  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

src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml

@@ -10,9 +10,6 @@
 open Alpha_context
 open Gas
 
-(* FIXME: this really is a preliminary estimation of costs,
-   everything in this file needs to be tweaked and proofread. *)
-
 module Cost_of = struct
   let cycle = step_cost 1
   let nop = free
@@ -34,6 +31,9 @@ module Cost_of = struct
   let string length =
     alloc_bytes_cost length
 
+  let bytes length =
+    alloc_cost 12 +@ alloc_bytes_cost length
+
   let concat s1 s2 =
     string (String.length s1 + String.length s2)
 
@@ -208,6 +208,7 @@ module Cost_of = struct
     let bool = free
     let unit = free
     let string = string
+    let bytes = bytes
     let int_of_string str =
       alloc_cost @@ (Pervasives.(/) (String.length str) 5)
     let tez = step_cost 1 +@ alloc_cost 1
@@ -229,10 +230,7 @@ module Cost_of = struct
     let primitive_type = alloc_cost 1
     let one_arg_type = alloc_cost 2
     let two_arg_type = alloc_cost 3
-    let operation b =
+    let operation b = bytes b
-      (* TODO: proper handling of (de)serialization costs *)
-      let len = MBytes.length b in
-      alloc_cost len +@ step_cost (len * 10)
     let type_ nb_args = alloc_cost (nb_args + 1)
 
     let instr
@@ -356,41 +354,33 @@ module Cost_of = struct
   end
 
   module Unparse = struct
-    let prim_cost nb_args =
+    let prim_cost l annot = Script.prim_node_cost_nonrec_of_length l annot
-      alloc_cost 4 (* location, primitive name, list, annotation *) +@
+    let seq_cost = Script.seq_node_cost_nonrec_of_length
-      (nb_args *@ alloc_cost 2)
+    let string_cost length = Script.string_node_cost_of_length length
-    let seq_cost nb_args =
-      alloc_cost 2 (* location, list *) +@
-      (nb_args *@ alloc_cost 2)
-    let string_cost length =
-      alloc_cost 3 +@ alloc_bytes_cost length
 
     let cycle = step_cost 1
-    let bool = prim_cost 0
+    let bool = prim_cost 0 []
-    let unit = prim_cost 0
+    let unit = prim_cost 0 []
-    (* FIXME: not sure we should count the length of strings and bytes
+    (* We count the length of strings and bytes to prevent hidden
-       as they are shared *)
+       miscalculations due to non detectable expansion of sharing. *)
-    let string s = string_cost (String.length s)
+    let string s = Script.string_node_cost s
-    let bytes s = alloc_bytes_cost (MBytes.length s)
+    let bytes s = Script.bytes_node_cost s
-    (* Approximates log10(x) *)
+    let z i = Script.int_node_cost i
-    let z i =
+    let int i = Script.int_node_cost (Script_int.to_zint i)
-      let decimal_digits = (Z.numbits (Z.abs i)) / 4 in
+    let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *)
-      prim_cost 0 +@ (alloc_bytes_cost decimal_digits)
-    let int i = z (Script_int.to_zint i)
-    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 operation bytes = string_cost (MBytes.length bytes * 2)
+    let operation bytes = Script.bytes_node_cost bytes
     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 2
+    let pair = prim_cost 2 []
-    let union = prim_cost 1
+    let union = prim_cost 1 []
-    let some = prim_cost 1
+    let some = prim_cost 1 []
-    let none = prim_cost 0
+    let none = prim_cost 0 []
-    let list_element = prim_cost 1
+    let list_element = alloc_cost 2
-    let set_element = alloc_cost 2
+    let set_element = alloc_cost 2 (* FIXME: log(size) *)
-    let map_element = alloc_cost 2
+    let map_element = alloc_cost 2 (* FIXME: log(size) *)
     let one_arg_type = prim_cost 1
     let two_arg_type = prim_cost 2
 

src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli

@@ -100,6 +100,7 @@ module Cost_of : sig
     val bool : Gas.cost
     val tez : Gas.cost
     val string : int -> Gas.cost
+    val bytes : int -> Gas.cost
     val int_of_string : string -> Gas.cost
     val string_timestamp : Gas.cost
     val key : Gas.cost
@@ -131,7 +132,7 @@ module Cost_of : sig
     val one_arg_type : Gas.cost
     val two_arg_type : Gas.cost
 
-    val operation : MBytes.t -> Gas.cost
+    val operation : int -> Gas.cost
 
     (** Cost of parsing a type *)
     val type_ : int -> Gas.cost
@@ -141,7 +142,7 @@ module Cost_of : sig
   end
 
   module Unparse : sig
-    val prim_cost : int -> Gas.cost
+    val prim_cost : int -> Script.annot -> Gas.cost
     val seq_cost : int -> Gas.cost
     val cycle : Gas.cost
     val unit : Gas.cost
@@ -171,8 +172,8 @@ module Cost_of : sig
     val set_element : Gas.cost
     val map_element : Gas.cost
 
-    val one_arg_type : Gas.cost
+    val one_arg_type : Script.annot -> Gas.cost
-    val two_arg_type : Gas.cost
+    val two_arg_type : Script.annot -> Gas.cost
     val set_to_list : 'a Script_typed_ir.set -> Gas.cost
     val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost
   end

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -547,7 +547,7 @@ let rec unparse_ty_no_lwt
     Gas.consume ctxt Unparse_costs.cycle >>? fun ctxt ->
     let return ctxt (name, args, annot) =
       let result = Prim (-1, name, args, annot) in
-      Gas.consume ctxt (Unparse_costs.prim_cost (List.length args)) >>? fun ctxt ->
+      Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot) >>? fun ctxt ->
       ok (result, ctxt) in
     match ty with
     | Unit_t tname -> return ctxt (T_unit, [], unparse_type_annot tname)

src/proto_alpha/lib_protocol/src/script_repr.ml

@@ -57,29 +57,53 @@ let encoding =
        (req "code" lazy_expr_encoding)
        (req "storage" lazy_expr_encoding))
 
+let int_node_size_of_numbits n =
+  (1, 1 + (n + 63) / 64)
+let int_node_size n =
+  int_node_size_of_numbits (Z.numbits n)
+let string_node_size_of_length s =
+  (1, 1 + (s + 7) / 8)
+let string_node_size s =
+  string_node_size_of_length (String.length s)
+let bytes_node_size_of_length s =
+  (* approx cost of indirection to the C heap *)
+  (2, 1 + (s + 7) / 8 + 12)
+let bytes_node_size s =
+  bytes_node_size_of_length (MBytes.length s)
+let prim_node_size_nonrec_of_lengths n_args annots =
+  let annots_length = List.fold_left (fun acc s -> acc + String.length s) 0 annots in
+  if Compare.Int.(annots_length = 0) then
+    (1 + n_args, 2 + 2 * n_args)
+  else
+    (2 + n_args, 4 + 2 * n_args + (annots_length + 7) / 8)
+let prim_node_size_nonrec args annots =
+  let n_args = List.length args in
+  prim_node_size_nonrec_of_lengths n_args annots
+let seq_node_size_nonrec_of_length n_args =
+  (1 + n_args, 2 + 2 * n_args)
+let seq_node_size_nonrec args =
+  let n_args = List.length args in
+  seq_node_size_nonrec_of_length n_args
+
 let rec node_size node =
   let open Micheline in
   match node with
-  | Int (_, n) -> (1, 1 + (Z.numbits n + 63) / 64)
+  | Int (_, n) -> int_node_size n
-  | String (_, s) -> (1, 1 + (String.length s + 7) / 8)
+  | String (_, s) -> string_node_size s
-  | Bytes (_, s) -> (1, 1 + (MBytes.length s + 7) / 8)
+  | Bytes (_, s) -> bytes_node_size s
   | Prim (_, _, args, annot) ->
       List.fold_left
         (fun (blocks, words) node ->
            let (nblocks, nwords) = node_size node in
-           (blocks + 1 + nblocks, words + 2 + nwords))
+           (blocks + nblocks, words + nwords))
-        (match annot with
+        (prim_node_size_nonrec args annot)
-         | [] -> (1, 2)
-         | annots ->
-             let annots_length = List.fold_left (fun acc s -> acc + String.length s) 0 annots in
-             (1, 4 + (annots_length + 7) / 8))
         args
   | Seq (_, args) ->
       List.fold_left
         (fun (blocks, words) node ->
            let (nblocks, nwords) = node_size node in
-           (blocks + 1 + nblocks, words + 2 + nwords))
+           (blocks + nblocks, words + nwords))
-        (1, 2)
+        (seq_node_size_nonrec args)
         args
 
 let expr_size expr =
@@ -89,13 +113,26 @@ let traversal_cost expr =
   let blocks, _words = expr_size expr in
   Gas_limit_repr.step_cost blocks
 
-let deserialized_cost expr =
+let node_cost (blocks, words) =
   let open Gas_limit_repr in
-  let blocks, words = expr_size expr 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 deserialized_cost expr =
+  node_cost (expr_size expr)
+
 let serialized_cost bytes =
   let open Gas_limit_repr in
   alloc_bytes_cost (MBytes.length bytes)

src/proto_alpha/lib_protocol/src/script_repr.mli

@@ -35,6 +35,17 @@ val deserialized_cost : expr -> Gas_limit_repr.cost
 
 val serialized_cost : MBytes.t -> 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
+val string_node_cost : string -> Gas_limit_repr.cost
+val string_node_cost_of_length : int -> Gas_limit_repr.cost
+val bytes_node_cost : MBytes.t -> Gas_limit_repr.cost
+val bytes_node_cost_of_length : int -> Gas_limit_repr.cost
+val prim_node_cost_nonrec : expr list -> annot -> Gas_limit_repr.cost
+val prim_node_cost_nonrec_of_length : int -> annot -> Gas_limit_repr.cost
+val seq_node_cost_nonrec : expr list -> Gas_limit_repr.cost
+val seq_node_cost_nonrec_of_length : int -> Gas_limit_repr.cost
+
 val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult
 
 val force_bytes : lazy_expr -> (MBytes.t * Gas_limit_repr.cost) tzresult