balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Alpha, Michelson: separate gas operations from costs

Browse Source
This commit is contained in:
Benjamin Canou 2018-03-04 18:04:30 +01:00 committed by Grégoire Henry
parent 8a49bf5509
commit 04415ff6a8
7 changed files with 669 additions and 644 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL
View File

@ -56,9 +56,10 @@
"Script_typed_ir",
"Fees",
"Gas",
"Script_tc_errors",
"Script_tc_errors",
"Michelson_v1_gas",
"Script_ir_translator",
"Script_tc_errors_registration",
"Script_tc_errors_registration",
"Script_interpreter",
"Baking",

303
src/proto_alpha/lib_protocol/src/gas.ml
View File

@ -7,11 +7,6 @@
(* *)
(**************************************************************************)
open Alpha_context
(* FIXME: this really is a preliminary estimation of costs,
everything in this file needs to be tweaked and proofread. *)
type t = { remaining : int } [@@unboxed]
type cost =
@ -32,6 +27,8 @@ let pp ppf { remaining } =
let of_int remaining = { remaining }
let remaining { remaining } = remaining
(* Maximum gas representable on a 64 bit system *)
let max_gas = of_int 4611686018427387903
@ -53,13 +50,6 @@ let pp_cost ppf { allocations ; steps } =
type error += Quota_exceeded
let bytes_per_word = 8
let bits_per_word = 8 * bytes_per_word
let words_of_bits n =
n / bits_per_word
let check_error gas =
if Compare.Int.(gas.remaining <= 0)
then error Quota_exceeded
@ -68,17 +58,14 @@ let check_error gas =
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 }
- 2 * cost.allocations
- 1 * cost.steps }
let consume_check gas cost =
let gas = consume gas cost in
@ -95,6 +82,12 @@ let alloc_cost n =
{ allocations = n + 1 ;
steps = 0 }
let alloc_bytes_cost n =
alloc_cost (n / 8)
let alloc_bits_cost n =
alloc_cost (n / 64)
(* Cost for one computation step. *)
let step_cost n =
{ allocations = 0 ;
@ -104,303 +97,47 @@ let free =
{ allocations = 0 ;
steps = 0 }
let ( + ) x y =
let ( +@ ) x y =
{ allocations = x.allocations + y.allocations ;
steps = x.steps + y.steps }
let ( * ) x y =
let ( *@ ) x y =
{ allocations = x * y.allocations ;
steps = x * y.steps }
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
let bool_binop _ _ = step_cost 1
let bool_unop _ = step_cost 1
let pair = alloc_cost 2
let pair_access = step_cost 1
let cons = alloc_cost 2
let variant_no_data = alloc_cost 1
let branch = step_cost 2
let string length =
alloc_cost (length / bytes_per_word)
let concat s1 s2 =
let (+) = Pervasives.(+) in
string ((String.length s1 + String.length s2) / bytes_per_word)
(* Cost per cycle of a loop, fold, etc *)
let loop_cycle = step_cost 2
let list_size = step_cost 1
let log2 =
let (+) = Pervasives.(+) in
let rec help acc = function
| 0 -> acc
| n -> help (acc + 1) (n / 2)
in help 1
let module_cost = alloc_cost 10
let map_access : type key value. (key, value) Script_typed_ir.map -> int
= fun (module Box) ->
log2 (snd Box.boxed)
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
= fun (module Box) ->
let size = snd Box.boxed in
2 * (alloc_cost @@ Pervasives.(size * 2))
let map_mem _key map = step_cost (map_access map)
let map_get = map_mem
let map_update _ _ map =
map_access map * alloc_cost 3
let map_size = step_cost 2
let big_map_mem _key _map = step_cost 200
let big_map_get _key _map = step_cost 200
let big_map_update _key _value _map = step_cost 200
let set_access : type elt. elt -> elt Script_typed_ir.set -> int
= fun _key (module Box) ->
log2 @@ Box.size
let set_mem key set = step_cost (set_access key set)
let set_update key _presence set =
set_access key set * alloc_cost 3
(* for LEFT, RIGHT, SOME *)
let wrap = alloc_cost 1
let mul n1 n2 =
let words =
let ( * ) = Pervasives.( * ) in
words_of_bits
((Z.numbits (Script_int.to_zint n1))
* (Z.numbits (Script_int.to_zint n2))) in
step_cost words + alloc_cost words
let div n1 n2 =
mul n1 n2 + alloc_cost 2
let add_sub_z n1 n2 =
let words = words_of_bits
(max (Z.numbits n1) (Z.numbits n2)) in
step_cost (words_of_bits words) + alloc_cost words
let add n1 n2 =
add_sub_z (Script_int.to_zint n1) (Script_int.to_zint n2)
let sub = add
let abs n =
alloc_cost (words_of_bits @@ Z.numbits @@ Script_int.to_zint n)
let neg = abs
let int _ = step_cost 1
let add_timestamp t n =
add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n)
let sub_timestamp t n =
add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n)
let diff_timestamps t1 t2 =
add_sub_z (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2)
let empty_set = module_cost
let set_size = step_cost 2
let set_to_list : type item. item Script_typed_ir.set -> cost
= fun (module Box) ->
alloc_cost @@ Pervasives.(Box.size * 2)
let empty_map = module_cost
let int64_op = step_cost 1 + alloc_cost 1
let z_to_int64 = step_cost 2 + alloc_cost 1
let int64_to_z = step_cost 2 + alloc_cost 1
let bitwise_binop n1 n2 =
let words = words_of_bits (max (Z.numbits (Script_int.to_zint n1)) (Z.numbits (Script_int.to_zint n2))) in
step_cost words + alloc_cost words
let logor = bitwise_binop
let logand = bitwise_binop
let logxor = bitwise_binop
let lognot n =
let words = words_of_bits @@ Z.numbits @@ Script_int.to_zint n in
step_cost words + alloc_cost words
let unopt ~default = function
| None -> default
| Some x -> x
let max_int = 1073741823
let shift_left x y =
(alloc_cost @@ words_of_bits @@
let (+) = Pervasives.(+) in
Z.numbits (Script_int.to_zint x) +
(unopt (Script_int.to_int y) ~default:max_int))
let shift_right x y =
(alloc_cost @@ words_of_bits @@
max 1 @@
let (-) = Pervasives.(-) in
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
let compare_res = step_cost 1
(* TODO: protocol operations *)
let manager = step_cost 3
let transfer = step_cost 50
let create_account = step_cost 20
let create_contract = step_cost 70
let implicit_account = step_cost 10
let balance = step_cost 5
let now = step_cost 3
let check_signature = step_cost 3
let hash_key = step_cost 3
(* TODO: This needs to be a function of the data being hashed *)
let hash _data = step_cost 3
let steps_to_quota = step_cost 1
let get_steps_to_quota gas = Script_int.abs @@ Script_int.of_int gas.remaining
let source = step_cost 3
let self = step_cost 3
let amount = step_cost 1
let compare_bool _ _ = step_cost 1
let compare_string s1 s2 =
step_cost (max (String.length s1) (String.length s2) / 8) + step_cost 1
let compare_tez _ _ = step_cost 1
let compare_zint n1 n2 = step_cost (max (Z.numbits n1) (Z.numbits n2) / 8) + step_cost 1
let compare_int n1 n2 = compare_zint (Script_int.to_zint n1) (Script_int.to_zint n2)
let compare_nat = compare_int
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 =
let rec fold_left ~cycle_cost gas f acc l =
consume_check gas cycle_cost >>=? fun gas ->
match l with
| [] -> return (acc, gas)
| hd :: tl -> f gas hd acc >>=? fun (acc, gas) ->
fold_left gas f acc tl
fold_left ~cycle_cost 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 =
let rec fold_right ~cycle_cost gas f base l =
consume_check gas cycle_cost >>=? fun gas ->
match l with
| [] -> return (base, gas)
| hd :: tl ->
fold_right gas f base tl >>=? fun (acc, gas) ->
fold_right ~cycle_cost gas f base tl >>=? fun (acc, gas) ->
f gas hd acc
(* f should fail if it does not receive sufficient gas *)
let rec fold_right_error ?(cycle_cost = Cost_of.loop_cycle) gas f base l =
let rec fold_right_error ~cycle_cost gas f base l =
consume_check_error gas cycle_cost >>? fun gas ->
match l with
| [] -> ok (base, gas)
| hd :: tl ->
fold_right_error gas f base tl >>? fun (acc, gas) ->
fold_right_error ~cycle_cost gas f base tl >>? fun (acc, gas) ->
f gas hd acc
(* f should fail if it does not receive sufficient gas *)
let rec fold_left_error ?(cycle_cost = Cost_of.loop_cycle) gas f acc l =
let rec fold_left_error ~cycle_cost gas f acc l =
consume_check_error gas cycle_cost >>? fun gas ->
match l with
| [] -> ok (acc, gas)
| hd :: tl -> f gas hd acc >>? fun (acc, gas) ->
fold_left_error gas f acc tl
fold_left_error ~cycle_cost gas f acc tl
let () =
let open Data_encoding in

174
src/proto_alpha/lib_protocol/src/gas.mli
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Alpha_context
type t
type cost
@ -27,181 +25,37 @@ val consume_check_error : t -> cost -> t tzresult
type error += Quota_exceeded
val of_int : int -> t
val remaining : t -> int
val ( *@ ) : int -> cost -> cost
val ( +@ ) : cost -> cost -> cost
val used : original:t -> current:t -> t
val free : cost
val step_cost : int -> cost
val alloc_cost : int -> cost
val alloc_bytes_cost : int -> cost
val alloc_bits_cost : int -> cost
val 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
val stack_op : cost
val bool_binop : 'a -> 'b -> cost
val bool_unop : 'a -> cost
val pair : cost
val pair_access : cost
val cons : cost
val variant_no_data : cost
val branch : cost
val concat : string -> string -> cost
val map_mem :
'a -> ('b, 'c) Script_typed_ir.map -> cost
val map_to_list :
('b, 'c) Script_typed_ir.map -> cost
val map_get :
'a -> ('b, 'c) Script_typed_ir.map -> cost
val map_update :
'a -> 'b -> ('c, 'd) Script_typed_ir.map -> cost
val map_size : cost
val big_map_mem : 'key -> ('key, 'value) Script_typed_ir.big_map -> cost
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 -> 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
val add : 'a Script_int.num -> 'b Script_int.num -> cost
val sub : 'a Script_int.num -> 'b Script_int.num -> cost
val abs : 'a Script_int.num -> cost
val neg : 'a Script_int.num -> cost
val int : 'a -> cost
val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> cost
val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> cost
val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> cost
val empty_set : cost
val set_size : cost
val empty_map : cost
val int64_op : cost
val z_to_int64 : cost
val int64_to_z : cost
val bitwise_binop : 'a Script_int.num -> 'b Script_int.num -> cost
val logor : 'a Script_int.num -> 'b Script_int.num -> cost
val logand : 'a Script_int.num -> 'b Script_int.num -> cost
val logxor : 'a Script_int.num -> 'b Script_int.num -> cost
val lognot : 'a Script_int.num -> cost
val shift_left : 'a Script_int.num -> 'b Script_int.num -> cost
val shift_right : 'a Script_int.num -> 'b Script_int.num -> cost
val exec : cost
val push : cost
val compare_res : cost
val manager : cost
val transfer : cost
val create_account : cost
val create_contract : cost
val implicit_account : cost
val balance : cost
val now : cost
val check_signature : cost
val hash_key : cost
val hash : 'a -> cost
val get_steps_to_quota : t -> Script_int.n Script_int.num
val steps_to_quota : cost
val source : cost
val self : cost
val amount : cost
val wrap : cost
val compare_bool : 'a -> 'b -> cost
val compare_string : string -> string -> cost
val compare_tez : 'a -> 'b -> cost
val compare_int : 'a Script_int.num -> 'b Script_int.num -> cost
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 ->
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 ->
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 ->
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 ->
val fold_left_error : cycle_cost:cost ->
t ->
(t -> 'a -> 'b -> ('b * t) tzresult) ->
'b -> 'a list -> ('b * t) tzresult

261
src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml Normal file
View File

@ -0,0 +1,261 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
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
let stack_op = step_cost 1
let bool_binop _ _ = step_cost 1
let bool_unop _ = step_cost 1
let pair = alloc_cost 2
let pair_access = step_cost 1
let cons = alloc_cost 2
let variant_no_data = alloc_cost 1
let branch = step_cost 2
let string length =
alloc_bytes_cost length
let concat s1 s2 =
string (String.length s1 + String.length s2)
(* Cost per cycle of a loop, fold, etc *)
let loop_cycle = step_cost 2
let list_size = step_cost 1
let log2 =
let rec help acc = function
| 0 -> acc
| n -> help (acc + 1) (n / 2)
in help 1
let module_cost = alloc_cost 10
let map_access : type key value. (key, value) Script_typed_ir.map -> int
= fun (module Box) ->
log2 (snd Box.boxed)
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
= fun (module Box) ->
let size = snd Box.boxed in
2 *@ (alloc_cost (size * 2))
let map_mem _key map = step_cost (map_access map)
let map_get = map_mem
let map_update _ _ map =
map_access map *@ alloc_cost 3
let map_size = step_cost 2
let big_map_mem _key _map = step_cost 200
let big_map_get _key _map = step_cost 200
let big_map_update _key _value _map = step_cost 200
let set_access : type elt. elt -> elt Script_typed_ir.set -> int
= fun _key (module Box) ->
log2 @@ Box.size
let set_mem key set = step_cost (set_access key set)
let set_update key _presence set =
set_access key set *@ alloc_cost 3
(* for LEFT, RIGHT, SOME *)
let wrap = alloc_cost 1
let mul n1 n2 =
let bits =
(Z.numbits (Script_int.to_zint n1))
* (Z.numbits (Script_int.to_zint n2)) in
step_cost bits +@ alloc_bits_cost bits
let div n1 n2 =
mul n1 n2 +@ alloc_cost 2
let add_sub_z n1 n2 =
let bits =
Compare.Int.max (Z.numbits n1) (Z.numbits n2) in
step_cost bits +@ alloc_cost bits
let add n1 n2 =
add_sub_z (Script_int.to_zint n1) (Script_int.to_zint n2)
let sub = add
let abs n =
alloc_bits_cost (Z.numbits @@ Script_int.to_zint n)
let neg = abs
let int _ = step_cost 1
let add_timestamp t n =
add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n)
let sub_timestamp t n =
add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n)
let diff_timestamps t1 t2 =
add_sub_z (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2)
let empty_set = module_cost
let set_size = step_cost 2
let set_to_list : type item. item Script_typed_ir.set -> cost
= fun (module Box) ->
alloc_cost @@ Pervasives.(Box.size * 2)
let empty_map = module_cost
let int64_op = step_cost 1 +@ alloc_cost 1
let z_to_int64 = step_cost 2 +@ alloc_cost 1
let int64_to_z = step_cost 2 +@ alloc_cost 1
let bitwise_binop n1 n2 =
let bits = Compare.Int.max (Z.numbits (Script_int.to_zint n1)) (Z.numbits (Script_int.to_zint n2)) in
step_cost bits +@ alloc_bits_cost bits
let logor = bitwise_binop
let logand = bitwise_binop
let logxor = bitwise_binop
let lognot n =
let bits = Z.numbits @@ Script_int.to_zint n in
step_cost bits +@ alloc_cost bits
let unopt ~default = function
| None -> default
| Some x -> x
let max_int = 1073741823
let shift_left x y =
alloc_bits_cost
(Z.numbits (Script_int.to_zint x) +
(unopt (Script_int.to_int y) ~default:max_int))
let shift_right x y =
alloc_bits_cost
(Compare.Int.max 1
(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
let compare_res = step_cost 1
(* TODO: protocol operations *)
let manager = step_cost 3
let transfer = step_cost 50
let create_account = step_cost 20
let create_contract = step_cost 70
let implicit_account = step_cost 10
let balance = step_cost 5
let now = step_cost 3
let check_signature = step_cost 3
let hash_key = step_cost 3
(* TODO: This needs to be a function of the data being hashed *)
let hash _data = step_cost 3
let steps_to_quota = step_cost 1
let get_steps_to_quota gas = Script_int.abs (Script_int.of_int (remaining gas))
let source = step_cost 3
let self = step_cost 3
let amount = step_cost 1
let compare_bool _ _ = step_cost 1
let compare_string s1 s2 =
step_cost (Compare.Int.max (String.length s1) (String.length s2) / 8) +@ step_cost 1
let compare_tez _ _ = step_cost 1
let compare_zint n1 n2 = step_cost (Compare.Int.max (Z.numbits n1) (Z.numbits n2) / 8) +@ step_cost 1
let compare_int n1 n2 = compare_zint (Script_int.to_zint n1) (Script_int.to_zint n2)
let compare_nat = compare_int
let compare_key_hash _ _ = alloc_bytes_cost 36
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_bytes_cost length
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_bytes_cost decimal_digits)
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

163
src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli Normal file
View File

@ -0,0 +1,163 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Alpha_context
module Cost_of : sig
val cycle : Gas.cost
val loop_cycle : Gas.cost
val list_size : Gas.cost
val nop : Gas.cost
val stack_op : Gas.cost
val bool_binop : 'a -> 'b -> Gas.cost
val bool_unop : 'a -> Gas.cost
val pair : Gas.cost
val pair_access : Gas.cost
val cons : Gas.cost
val variant_no_data : Gas.cost
val branch : Gas.cost
val concat : string -> string -> Gas.cost
val map_mem :
'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost
val map_to_list :
('b, 'c) Script_typed_ir.map -> Gas.cost
val map_get :
'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost
val map_update :
'a -> 'b -> ('c, 'd) Script_typed_ir.map -> Gas.cost
val map_size : Gas.cost
val big_map_mem : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost
val big_map_get : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost
val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost
val set_to_list : 'a Script_typed_ir.set -> Gas.cost
val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost
val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost
val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val abs : 'a Script_int.num -> Gas.cost
val neg : 'a Script_int.num -> Gas.cost
val int : 'a -> Gas.cost
val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost
val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost
val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost
val empty_set : Gas.cost
val set_size : Gas.cost
val empty_map : Gas.cost
val int64_op : Gas.cost
val z_to_int64 : Gas.cost
val int64_to_z : Gas.cost
val bitwise_binop : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val lognot : 'a Script_int.num -> Gas.cost
val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val exec : Gas.cost
val push : Gas.cost
val compare_res : Gas.cost
val manager : Gas.cost
val transfer : Gas.cost
val create_account : Gas.cost
val create_contract : Gas.cost
val implicit_account : Gas.cost
val balance : Gas.cost
val now : Gas.cost
val check_signature : Gas.cost
val hash_key : Gas.cost
val hash : 'a -> Gas.cost
val get_steps_to_quota : Gas.t -> Script_int.n Script_int.num
val steps_to_quota : Gas.cost
val source : Gas.cost
val self : Gas.cost
val amount : Gas.cost
val wrap : Gas.cost
val compare_bool : 'a -> 'b -> Gas.cost
val compare_string : string -> string -> Gas.cost
val compare_tez : 'a -> 'b -> Gas.cost
val compare_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val compare_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
val compare_key_hash : 'a -> 'b -> Gas.cost
val compare_timestamp : Script_timestamp.t -> Script_timestamp.t -> Gas.cost
module Typechecking : sig
val cycle : Gas.cost
val unit : Gas.cost
val bool : Gas.cost
val tez : Gas.cost
val string : int -> Gas.cost
val int_of_string : string -> Gas.cost
val string_timestamp : Gas.cost
val key : Gas.cost
val key_hash : Gas.cost
val signature : Gas.cost
val contract : Gas.cost
(** Gas.Cost of getting the code for a contract *)
val get_script : Gas.cost
val contract_exists : Gas.cost
(** Additional Gas.cost of parsing a pair over the Gas.cost of parsing each type *)
val pair : Gas.cost
val union : Gas.cost
val lambda : Gas.cost
val some : Gas.cost
val none : Gas.cost
val list_element : Gas.cost
val set_element : Gas.cost
val map_element : Gas.cost
val primitive_type : Gas.cost
val one_arg_type : Gas.cost
val two_arg_type : Gas.cost
end
module Unparse : sig
val cycle : Gas.cost
val unit : Gas.cost
val bool : Gas.cost
val int : 'a Script_int.num -> Gas.cost
val tez : Gas.cost
val string : string -> Gas.cost
val timestamp : Script_timestamp.t -> Gas.cost
val key : Gas.cost
val key_hash : Gas.cost
val signature : Gas.cost
val contract : Gas.cost
(** Additional Gas.cost of parsing a pair over the Gas.cost of parsing each type *)
val pair : Gas.cost
val union : Gas.cost
val lambda : Gas.cost
val some : Gas.cost
val none : Gas.cost
val list_element : Gas.cost
val set_element : Gas.cost
val map_element : Gas.cost
val primitive_type : Gas.cost
val one_arg_type : Gas.cost
val two_arg_type : 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
end

267
src/proto_alpha/lib_protocol/src/script_interpreter.ml
View File

@ -74,6 +74,8 @@ let rec unparse_stack
| Ok (data, _) -> (Micheline.strip_locations data) :: (unparse_stack (rest, rest_ty))
| Error _ -> Pervasives.failwith "Internal error: raise gas limit for unparse_stack"
module Interp_costs = Michelson_v1_gas.Cost_of
let rec interp
: type p r.
?log: (Script.location * Gas.t * Script.expr list) list ref ->
@ -86,7 +88,7 @@ let rec interp
Contract.origination_nonce -> Gas.t -> context -> (b, a) descr -> b stack ->
(a stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t =
fun origination gas ctxt ({ instr ; loc ; _ } as descr) stack ->
let gas = Gas.consume gas Gas.Cost_of.cycle in
let gas = Gas.consume gas Interp_costs.cycle in
Gas.check gas >>=? fun () ->
let logged_return : type a b.
(b, a) descr ->
@ -163,7 +165,7 @@ let rec interp
(((param, return) typed_contract * rest) stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t =
fun descr ~manager ~delegate ~spendable ~delegatable
~credit ~code ~init ~param_type ~storage_type ~return_type ~rest ->
let gas = Gas.consume gas Gas.Cost_of.create_contract in
let gas = Gas.consume gas Interp_costs.create_contract in
Gas.check gas >>=? fun () ->
let code =
Micheline.strip_locations
@ -189,83 +191,84 @@ let rec interp
match instr, stack with
(* stack ops *)
| Drop, Item (_, rest) ->
let gas = Gas.consume gas Gas.Cost_of.stack_op in
let gas = Gas.consume gas Interp_costs.stack_op in
Gas.check gas >>=? fun () ->
logged_return (rest, gas, ctxt)
| Dup, Item (v, rest) ->
let gas = Gas.consume gas Gas.Cost_of.stack_op in
let gas = Gas.consume gas Interp_costs.stack_op in
Gas.check gas >>=? fun () ->
logged_return (Item (v, Item (v, rest)), gas, ctxt)
| Swap, Item (vi, Item (vo, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.stack_op in
let gas = Gas.consume gas Interp_costs.stack_op in
Gas.check gas >>=? fun () ->
logged_return (Item (vo, Item (vi, rest)), gas, ctxt)
| Const v, rest ->
let gas = Gas.consume gas Gas.Cost_of.push in
let gas = Gas.consume gas Interp_costs.push in
Gas.check gas >>=? fun () ->
logged_return (Item (v, rest), gas, ctxt)
(* options *)
| Cons_some, Item (v, rest) ->
let gas = Gas.consume gas Gas.Cost_of.wrap in
let gas = Gas.consume gas Interp_costs.wrap in
Gas.check gas >>=? fun () ->
logged_return (Item (Some v, rest), gas, ctxt)
| Cons_none _, rest ->
let gas = Gas.consume gas Gas.Cost_of.variant_no_data in
let gas = Gas.consume gas Interp_costs.variant_no_data in
Gas.check gas >>=? fun () ->
logged_return (Item (None, rest), gas, ctxt)
| If_none (bt, _), Item (None, rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bt rest
step origination (Gas.consume gas Interp_costs.branch) ctxt bt rest
| If_none (_, bf), Item (Some v, rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bf (Item (v, rest))
step origination (Gas.consume gas Interp_costs.branch) ctxt bf (Item (v, rest))
(* pairs *)
| Cons_pair, Item (a, Item (b, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.pair in
let gas = Gas.consume gas Interp_costs.pair in
Gas.check gas >>=? fun () ->
logged_return (Item ((a, b), rest), gas, ctxt)
| Car, Item ((a, _), rest) ->
let gas = Gas.consume gas Gas.Cost_of.pair_access in
let gas = Gas.consume gas Interp_costs.pair_access in
Gas.check gas >>=? fun () ->
logged_return (Item (a, rest), gas, ctxt)
| Cdr, Item ((_, b), rest) ->
let gas = Gas.consume gas Gas.Cost_of.pair_access in
let gas = Gas.consume gas Interp_costs.pair_access in
Gas.check gas >>=? fun () ->
logged_return (Item (b, rest), gas, ctxt)
(* unions *)
| Left, Item (v, rest) ->
let gas = Gas.consume gas Gas.Cost_of.wrap in
let gas = Gas.consume gas Interp_costs.wrap in
Gas.check gas >>=? fun () ->
logged_return (Item (L v, rest), gas, ctxt)
| Right, Item (v, rest) ->
let gas = Gas.consume gas Gas.Cost_of.wrap in
let gas = Gas.consume gas Interp_costs.wrap in
Gas.check gas >>=? fun () ->
logged_return (Item (R v, rest), gas, ctxt)
| If_left (bt, _), Item (L v, rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bt (Item (v, rest))
step origination (Gas.consume gas Interp_costs.branch) ctxt bt (Item (v, rest))
| If_left (_, bf), Item (R v, rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bf (Item (v, rest))
step origination (Gas.consume gas Interp_costs.branch) ctxt bf (Item (v, rest))
(* lists *)
| Cons_list, Item (hd, Item (tl, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.cons in
let gas = Gas.consume gas Interp_costs.cons in
Gas.check gas >>=? fun () ->
logged_return (Item (hd :: tl, rest), gas, ctxt)
| Nil, rest ->
let gas = Gas.consume gas Gas.Cost_of.variant_no_data in
let gas = Gas.consume gas Interp_costs.variant_no_data in
Gas.check gas >>=? fun () ->
logged_return (Item ([], rest), gas, ctxt)
| If_cons (_, bf), Item ([], rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bf rest
step origination (Gas.consume gas Interp_costs.branch) ctxt bf rest
| If_cons (bt, _), Item (hd :: tl, rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bt (Item (hd, Item (tl, rest)))
step origination (Gas.consume gas Interp_costs.branch) ctxt bt (Item (hd, Item (tl, rest)))
| List_map, Item (lam, Item (l, rest)) ->
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))
Gas.fold_right ~cycle_cost:Interp_costs.cycle gas
(fun gas arg (tail, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam arg
>>=? fun (ret, gas, ctxt, origination) ->
return ((ret :: tail, ctxt, origination), gas))
([], ctxt, origination) l >>=? fun ((res, ctxt, origination), gas) ->
logged_return ~origination (Item (res, rest), gas, ctxt)
| List_map_body body, Item (l, rest) ->
let rec help rest gas l =
let gas = Gas.consume gas Gas.Cost_of.loop_cycle in
let gas = Gas.consume gas Interp_costs.loop_cycle in
Gas.check gas >>=? fun () ->
match l with
| [] -> logged_return ~origination (Item ([], rest), gas, ctxt)
@ -278,7 +281,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))) ->
Gas.fold_left gas
Gas.fold_left ~cycle_cost:Interp_costs.cycle gas
(fun gas arg (partial, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam (arg, partial)
>>=? fun (partial, gas, ctxt, origination) ->
@ -286,14 +289,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) ->
Gas.fold_left ~cycle_cost:Gas.Cost_of.list_size gas
Gas.fold_left ~cycle_cost:Interp_costs.list_size gas
(fun gas _ len ->
return (len + 1, gas))
0
list >>=? fun (len, gas) ->
logged_return (Item (Script_int.(abs (of_int len)), rest), gas, ctxt)
| List_iter body, Item (l, init_stack) ->
Gas.fold_left gas
Gas.fold_left ~cycle_cost:Interp_costs.list_size gas
(fun gas arg (stack, ctxt, origination) ->
step origination gas ctxt body (Item (arg, stack))
>>=? fun (stack, gas, ctxt, origination) ->
@ -302,13 +305,13 @@ let rec interp
logged_return ~origination (stack, gas, ctxt)
(* sets *)
| Empty_set t, rest ->
logged_return (Item (empty_set t, rest), Gas.consume gas Gas.Cost_of.empty_set, ctxt)
logged_return (Item (empty_set t, rest), Gas.consume gas Interp_costs.empty_set, ctxt)
| Set_reduce, Item (lam, Item (set, Item (init, rest))) ->
let gas = Gas.consume gas (Gas.Cost_of.set_to_list set) in
let gas = Gas.consume gas (Interp_costs.set_to_list set) in
Gas.check gas >>=? fun () ->
let items =
List.rev (set_fold (fun e acc -> e :: acc) set []) in
Gas.fold_left gas
Gas.fold_left ~cycle_cost:Interp_costs.list_size gas
(fun gas arg (partial, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam (arg, partial)
>>=? fun (partial, gas, ctxt, origination) ->
@ -316,7 +319,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) ->
Gas.fold_left gas
Gas.fold_left ~cycle_cost:Interp_costs.list_size gas
(fun gas arg (stack, ctxt, origination) ->
step origination gas ctxt body (Item (arg, stack))
>>=? fun (stack, gas, ctxt, origination) ->
@ -325,20 +328,20 @@ let rec interp
(set_fold (fun e acc -> e :: acc) set []) >>=? fun ((stack, ctxt, origination), gas) ->
logged_return ~origination (stack, gas, ctxt)
| Set_mem, Item (v, Item (set, rest)) ->
gas_check_binop descr (set_mem, v, set) Gas.Cost_of.set_mem rest ctxt
gas_check_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt
| Set_update, Item (v, Item (presence, Item (set, rest))) ->
gas_check_terop descr (set_update, v, presence, set) Gas.Cost_of.set_update rest
gas_check_terop descr (set_update, v, presence, set) Interp_costs.set_update rest
| Set_size, Item (set, rest) ->
gas_check_unop descr (set_size, set) (fun _ -> Gas.Cost_of.set_size) rest ctxt
gas_check_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt
(* maps *)
| Empty_map (t, _), rest ->
logged_return (Item (empty_map t, rest), Gas.consume gas Gas.Cost_of.empty_map, ctxt)
logged_return (Item (empty_map t, rest), Gas.consume gas Interp_costs.empty_map, ctxt)
| Map_map, Item (lam, Item (map, rest)) ->
let gas = Gas.consume gas (Gas.Cost_of.map_to_list map) in
let gas = Gas.consume gas (Interp_costs.map_to_list map) in
Gas.check gas >>=? fun () ->
let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
Gas.fold_left gas
Gas.fold_left ~cycle_cost:Interp_costs.list_size gas
(fun gas (k, v) (acc, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam (k, v)
>>=? fun (ret, gas, ctxt, origination) ->
@ -346,11 +349,11 @@ let rec interp
(empty_map (map_key_ty map), ctxt, origination) items >>=? fun ((res, ctxt, origination), gas) ->
logged_return ~origination (Item (res, rest), gas, ctxt)
| Map_reduce, Item (lam, Item (map, Item (init, rest))) ->
let gas = Gas.consume gas (Gas.Cost_of.map_to_list map) in
let gas = Gas.consume gas (Interp_costs.map_to_list map) in
Gas.check gas >>=? fun () ->
let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
Gas.fold_left gas
Gas.fold_left ~cycle_cost:Interp_costs.list_size gas
(fun gas arg (partial, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam (arg, partial)
>>=? fun (partial, gas, ctxt, origination) ->
@ -358,11 +361,11 @@ let rec interp
(init, ctxt, origination) items >>=? fun ((res, ctxt, origination), gas) ->
logged_return ~origination (Item (res, rest), gas, ctxt)
| Map_iter body, Item (map, init_stack) ->
let gas = Gas.consume gas (Gas.Cost_of.map_to_list map) in
let gas = Gas.consume gas (Interp_costs.map_to_list map) in
Gas.check gas >>=? fun () ->
let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
Gas.fold_left gas
Gas.fold_left ~cycle_cost:Interp_costs.list_size gas
(fun gas arg (stack, ctxt, origination) ->
step origination gas ctxt body (Item (arg, stack))
>>=? fun (stack, gas, ctxt, origination) ->
@ -370,59 +373,59 @@ let rec interp
(init_stack, ctxt, origination) items >>=? fun ((stack, ctxt, origination), gas) ->
logged_return ~origination (stack, gas, ctxt)
| Map_mem, Item (v, Item (map, rest)) ->
gas_check_binop descr (map_mem, v, map) Gas.Cost_of.map_mem rest ctxt
gas_check_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt
| Map_get, Item (v, Item (map, rest)) ->
gas_check_binop descr (map_get, v, map) Gas.Cost_of.map_get rest ctxt
gas_check_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt
| Map_update, Item (k, Item (v, Item (map, rest))) ->
gas_check_terop descr (map_update, k, v, map) Gas.Cost_of.map_update rest
gas_check_terop descr (map_update, k, v, map) Interp_costs.map_update rest
| Map_size, Item (map, rest) ->
gas_check_unop descr (map_size, map) (fun _ -> Gas.Cost_of.map_size) rest ctxt
gas_check_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt
(* Big map operations *)
| Big_map_mem, Item (key, Item (map, rest)) ->
let gas = Gas.consume gas (Gas.Cost_of.big_map_mem key map) in
let gas = Gas.consume gas (Interp_costs.big_map_mem key map) in
Gas.check gas >>=? fun () ->
Script_ir_translator.big_map_mem ctxt gas source key map >>=? fun (res, gas) ->
logged_return (Item (res, rest), gas, ctxt)
| Big_map_get, Item (key, Item (map, rest)) ->
let gas = Gas.consume gas (Gas.Cost_of.big_map_get key map) in
let gas = Gas.consume gas (Interp_costs.big_map_get key map) in
Gas.check gas >>=? fun () ->
Script_ir_translator.big_map_get ctxt gas source key map >>=? fun (res, gas) ->
logged_return (Item (res, rest), gas, ctxt)
| Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) ->
gas_check_terop descr
(Script_ir_translator.big_map_update, key, maybe_value, map)
Gas.Cost_of.big_map_update rest
Interp_costs.big_map_update rest
(* timestamp operations *)
| Add_seconds_to_timestamp, Item (n, Item (t, rest)) ->
gas_check_binop descr
(Script_timestamp.add_delta, t, n)
Gas.Cost_of.add_timestamp rest ctxt
Interp_costs.add_timestamp rest ctxt
| Add_timestamp_to_seconds, Item (t, Item (n, rest)) ->
gas_check_binop descr (Script_timestamp.add_delta, t, n)
Gas.Cost_of.add_timestamp rest ctxt
Interp_costs.add_timestamp rest ctxt
| Sub_timestamp_seconds, Item (t, Item (s, rest)) ->
gas_check_binop descr (Script_timestamp.sub_delta, t, s)
Gas.Cost_of.sub_timestamp rest ctxt
Interp_costs.sub_timestamp rest ctxt
| Diff_timestamps, Item (t1, Item (t2, rest)) ->
gas_check_binop descr (Script_timestamp.diff, t1, t2)
Gas.Cost_of.diff_timestamps rest ctxt
Interp_costs.diff_timestamps rest ctxt
(* string operations *)
| Concat, Item (x, Item (y, rest)) ->
gas_check_binop descr ((^), x, y) Gas.Cost_of.concat rest ctxt
gas_check_binop descr ((^), x, y) Interp_costs.concat rest ctxt
(* currency operations *)
| Add_tez, Item (x, Item (y, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.int64_op in
let gas = Gas.consume gas Interp_costs.int64_op in
Gas.check gas >>=? fun () ->
Lwt.return Tez.(x +? y) >>=? fun res ->
logged_return (Item (res, rest), gas, ctxt)
| Sub_tez, Item (x, Item (y, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.int64_op in
let gas = Gas.consume gas Interp_costs.int64_op in
Gas.check gas >>=? fun () ->
Lwt.return Tez.(x -? y) >>=? fun res ->
logged_return (Item (res, rest), gas, ctxt)
| Mul_teznat, Item (x, Item (y, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.int64_op in
let gas = Gas.consume gas Gas.Cost_of.z_to_int64 in
let gas = Gas.consume gas Interp_costs.int64_op in
let gas = Gas.consume gas Interp_costs.z_to_int64 in
Gas.check gas >>=? fun () ->
begin
match Script_int.to_int64 y with
@ -432,8 +435,8 @@ let rec interp
logged_return (Item (res, rest), gas, ctxt)
end
| Mul_nattez, Item (y, Item (x, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.int64_op in
let gas = Gas.consume gas Gas.Cost_of.z_to_int64 in
let gas = Gas.consume gas Interp_costs.int64_op in
let gas = Gas.consume gas Interp_costs.z_to_int64 in
Gas.check gas >>=? fun () ->
begin
match Script_int.to_int64 y with
@ -444,42 +447,42 @@ let rec interp
end
(* boolean operations *)
| Or, Item (x, Item (y, rest)) ->
gas_check_binop descr ((||), x, y) Gas.Cost_of.bool_binop rest ctxt
gas_check_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt
| And, Item (x, Item (y, rest)) ->
gas_check_binop descr ((&&), x, y) Gas.Cost_of.bool_binop rest ctxt
gas_check_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt
| Xor, Item (x, Item (y, rest)) ->
gas_check_binop descr (Compare.Bool.(<>), x, y) Gas.Cost_of.bool_binop rest ctxt
gas_check_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt
| Not, Item (x, rest) ->
gas_check_unop descr (not, x) Gas.Cost_of.bool_unop rest ctxt
gas_check_unop descr (not, x) Interp_costs.bool_unop rest ctxt
(* integer operations *)
| Abs_int, Item (x, rest) ->
gas_check_unop descr (Script_int.abs, x) Gas.Cost_of.abs rest ctxt
gas_check_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
| Int_nat, Item (x, rest) ->
gas_check_unop descr (Script_int.int, x) Gas.Cost_of.int rest ctxt
gas_check_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
| Neg_int, Item (x, rest) ->
gas_check_unop descr (Script_int.neg, x) Gas.Cost_of.neg rest ctxt
gas_check_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
| Neg_nat, Item (x, rest) ->
gas_check_unop descr (Script_int.neg, x) Gas.Cost_of.neg rest ctxt
gas_check_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
| Add_intint, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.add, x, y) Gas.Cost_of.add rest ctxt
gas_check_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| Add_intnat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.add, x, y) Gas.Cost_of.add rest ctxt
gas_check_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| Add_natint, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.add, x, y) Gas.Cost_of.add rest ctxt
gas_check_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| Add_natnat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.add_n, x, y) Gas.Cost_of.add rest ctxt
gas_check_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt
| Sub_int, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.sub, x, y) Gas.Cost_of.sub rest ctxt
gas_check_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt
| Mul_intint, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.mul, x, y) Gas.Cost_of.mul rest ctxt
gas_check_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| Mul_intnat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.mul, x, y) Gas.Cost_of.mul rest ctxt
gas_check_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| Mul_natint, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.mul, x, y) Gas.Cost_of.mul rest ctxt
gas_check_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| Mul_natnat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.mul_n, x, y) Gas.Cost_of.mul rest ctxt
gas_check_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt
| Ediv_teznat, Item (x, Item (y, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.int64_to_z in
let gas = Gas.consume gas Interp_costs.int64_to_z in
Gas.check gas >>=? fun () ->
let x = Script_int.of_int64 (Tez.to_mutez x) in
gas_check_binop ~gas descr
@ -499,12 +502,12 @@ let rec interp
(* Cannot overflow *)
| _ -> assert false),
x, y)
Gas.Cost_of.div
Interp_costs.div
rest
ctxt
| Ediv_tez, Item (x, Item (y, rest)) ->
let gas = Gas.consume gas Gas.Cost_of.int64_to_z in
let gas = Gas.consume gas Gas.Cost_of.int64_to_z in
let gas = Gas.consume gas Interp_costs.int64_to_z in
let gas = Gas.consume gas Interp_costs.int64_to_z in
let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
gas_check_binop ~gas descr
@ -518,123 +521,123 @@ let rec interp
| None -> assert false (* Cannot overflow *)
| Some r -> Some (q, r)),
x, y)
Gas.Cost_of.div
Interp_costs.div
rest
ctxt
| Ediv_intint, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.ediv, x, y) Gas.Cost_of.div rest ctxt
gas_check_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
| Ediv_intnat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.ediv, x, y) Gas.Cost_of.div rest ctxt
gas_check_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
| Ediv_natint, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.ediv, x, y) Gas.Cost_of.div rest ctxt
gas_check_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
| Ediv_natnat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.ediv_n, x, y) Gas.Cost_of.div rest ctxt
gas_check_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt
| Lsl_nat, Item (x, Item (y, rest)) ->
let gas = Gas.consume gas (Gas.Cost_of.shift_left x y) in
let gas = Gas.consume gas (Interp_costs.shift_left x y) in
Gas.check gas >>=? fun () -> begin
match Script_int.shift_left_n x y with
| None -> fail (Overflow loc)
| Some x -> logged_return (Item (x, rest), gas, ctxt)
end
| Lsr_nat, Item (x, Item (y, rest)) ->
let gas = Gas.consume gas (Gas.Cost_of.shift_right x y) in
let gas = Gas.consume gas (Interp_costs.shift_right x y) in
Gas.check gas >>=? fun () -> begin
match Script_int.shift_right_n x y with
| None -> fail (Overflow loc)
| Some r -> logged_return (Item (r, rest), gas, ctxt)
end
| Or_nat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.logor, x, y) Gas.Cost_of.logor rest ctxt
gas_check_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt
| And_nat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.logand, x, y) Gas.Cost_of.logand rest ctxt
gas_check_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt
| Xor_nat, Item (x, Item (y, rest)) ->
gas_check_binop descr (Script_int.logxor, x, y) Gas.Cost_of.logxor rest ctxt
gas_check_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt
| Not_int, Item (x, rest) ->
gas_check_unop descr (Script_int.lognot, x) Gas.Cost_of.lognot rest ctxt
gas_check_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt
| Not_nat, Item (x, rest) ->
gas_check_unop descr (Script_int.lognot, x) Gas.Cost_of.lognot rest ctxt
gas_check_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt
(* control *)
| Seq (hd, tl), stack ->
step origination gas ctxt hd stack >>=? fun (trans, gas, ctxt, origination) ->
step origination gas ctxt tl trans
| If (bt, _), Item (true, rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bt rest
step origination (Gas.consume gas Interp_costs.branch) ctxt bt rest
| If (_, bf), Item (false, rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bf rest
step origination (Gas.consume gas Interp_costs.branch) ctxt bf rest
| Loop body, Item (true, rest) ->
step origination (Gas.consume gas Gas.Cost_of.loop_cycle) ctxt body rest >>=? fun (trans, gas, ctxt, origination) ->
step origination (Gas.consume gas Gas.Cost_of.loop_cycle) ctxt descr trans
step origination (Gas.consume gas Interp_costs.loop_cycle) ctxt body rest >>=? fun (trans, gas, ctxt, origination) ->
step origination (Gas.consume gas Interp_costs.loop_cycle) ctxt descr trans
| Loop _, Item (false, rest) ->
logged_return (rest, gas, ctxt)
| Loop_left body, Item (L v, rest) ->
step origination (Gas.consume gas Gas.Cost_of.loop_cycle) ctxt body (Item (v, rest)) >>=? fun (trans, gas, ctxt, origination) ->
step origination (Gas.consume gas Gas.Cost_of.loop_cycle) ctxt descr trans
step origination (Gas.consume gas Interp_costs.loop_cycle) ctxt body (Item (v, rest)) >>=? fun (trans, gas, ctxt, origination) ->
step origination (Gas.consume gas Interp_costs.loop_cycle) ctxt descr trans
| Loop_left _, Item (R v, rest) ->
let gas = Gas.consume gas Gas.Cost_of.loop_cycle in
let gas = Gas.consume gas Interp_costs.loop_cycle in
Gas.check gas >>=? fun () ->
logged_return (Item (v, rest), gas, ctxt)
| Dip b, Item (ign, rest) ->
step origination (Gas.consume gas Gas.Cost_of.stack_op) ctxt b rest >>=? fun (res, gas, ctxt, origination) ->
step origination (Gas.consume gas Interp_costs.stack_op) ctxt b rest >>=? fun (res, gas, ctxt, origination) ->
logged_return ~origination (Item (ign, res), gas, ctxt)
| Exec, Item (arg, Item (lam, rest)) ->
interp ?log origination (Gas.consume gas Gas.Cost_of.exec) orig source amount ctxt lam arg >>=? fun (res, gas, ctxt, origination) ->
interp ?log origination (Gas.consume gas Interp_costs.exec) orig source amount ctxt lam arg >>=? fun (res, gas, ctxt, origination) ->
logged_return ~origination (Item (res, rest), gas, ctxt)
| Lambda lam, rest ->
logged_return ~origination (Item (lam, rest), Gas.consume gas Gas.Cost_of.push, ctxt)
logged_return ~origination (Item (lam, rest), Gas.consume gas Interp_costs.push, ctxt)
| Fail, _ ->
fail (Reject loc)
| Nop, stack ->
logged_return (stack, gas, ctxt)
(* comparison *)
| Compare Bool_key, Item (a, Item (b, rest)) ->
gas_compare descr Compare.Bool.compare Gas.Cost_of.compare_bool a b rest
gas_compare descr Compare.Bool.compare Interp_costs.compare_bool a b rest
| Compare String_key, Item (a, Item (b, rest)) ->
gas_compare descr Compare.String.compare Gas.Cost_of.compare_string a b rest
gas_compare descr Compare.String.compare Interp_costs.compare_string a b rest
| Compare Tez_key, Item (a, Item (b, rest)) ->
gas_compare descr Tez.compare Gas.Cost_of.compare_tez a b rest
gas_compare descr Tez.compare Interp_costs.compare_tez a b rest
| Compare Int_key, Item (a, Item (b, rest)) ->
gas_compare descr Script_int.compare Gas.Cost_of.compare_int a b rest
gas_compare descr Script_int.compare Interp_costs.compare_int a b rest
| Compare Nat_key, Item (a, Item (b, rest)) ->
gas_compare descr Script_int.compare Gas.Cost_of.compare_nat a b rest
gas_compare descr Script_int.compare Interp_costs.compare_nat a b rest
| Compare Key_hash_key, Item (a, Item (b, rest)) ->
gas_compare descr Signature.Public_key_hash.compare
Gas.Cost_of.compare_key_hash a b rest
Interp_costs.compare_key_hash a b rest
| Compare Timestamp_key, Item (a, Item (b, rest)) ->
gas_compare descr Script_timestamp.compare Gas.Cost_of.compare_timestamp a b rest
gas_compare descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest
(* comparators *)
| Eq, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres = 0) in
logged_return (Item (cmpres, rest), Gas.consume gas Gas.Cost_of.compare_res, ctxt)
logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt)
| Neq, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres <> 0) in
logged_return (Item (cmpres, rest), Gas.consume gas Gas.Cost_of.compare_res, ctxt)
logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt)
| Lt, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres < 0) in
logged_return (Item (cmpres, rest), Gas.consume gas Gas.Cost_of.compare_res, ctxt)
logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt)
| Le, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres <= 0) in
logged_return (Item (cmpres, rest), Gas.consume gas Gas.Cost_of.compare_res, ctxt)
logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt)
| Gt, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres > 0) in
logged_return (Item (cmpres, rest), Gas.consume gas Gas.Cost_of.compare_res, ctxt)
logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt)
| Ge, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres >= 0) in
logged_return (Item (cmpres, rest), Gas.consume gas Gas.Cost_of.compare_res, ctxt)
logged_return (Item (cmpres, rest), Gas.consume gas Interp_costs.compare_res, ctxt)
(* protocol *)
| Manager, Item ((_, _, contract), rest) ->
let gas = Gas.consume gas Gas.Cost_of.manager in
let gas = Gas.consume gas Interp_costs.manager in
Gas.check gas >>=? fun () ->
Contract.get_manager ctxt contract >>=? fun manager ->
logged_return (Item (manager, rest), gas, ctxt)
| Transfer_tokens storage_type,
Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (storage, Empty)))) -> begin
let gas = Gas.consume gas Gas.Cost_of.transfer in
let gas = Gas.consume gas Interp_costs.transfer in
Gas.check gas >>=? fun () ->
Contract.spend_from_script ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
@ -683,7 +686,7 @@ let rec interp
end
| Transfer_tokens storage_type,
Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin
let gas = Gas.consume gas Gas.Cost_of.transfer in
let gas = Gas.consume gas Interp_costs.transfer in
Gas.check gas >>=? fun () ->
Contract.spend_from_script ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
@ -726,7 +729,7 @@ let rec interp
end
| Create_account,
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
let gas = Gas.consume gas Gas.Cost_of.create_account in
let gas = Gas.consume gas Interp_costs.create_account in
Gas.check gas >>=? fun () ->
Contract.spend_from_script ctxt source credit >>=? fun ctxt ->
Lwt.return Tez.(credit -? Constants.origination_burn ctxt) >>=? fun balance ->
@ -737,7 +740,7 @@ let rec interp
Fees.origination_burn ctxt ~source contract >>=? fun ctxt ->
logged_return ~origination (Item ((Unit_t, Unit_t, contract), rest), gas, ctxt)
| Default_account, Item (key, rest) ->
let gas = Gas.consume gas Gas.Cost_of.implicit_account in
let gas = Gas.consume gas Interp_costs.implicit_account in
Gas.check gas >>=? fun () ->
let contract = Contract.implicit_contract key in
logged_return (Item ((Unit_t, Unit_t, contract), rest), gas, ctxt)
@ -761,40 +764,40 @@ let rec interp
create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init
~param_type ~return_type ~storage_type ~rest
| Balance, rest ->
let gas = Gas.consume gas Gas.Cost_of.balance in
let gas = Gas.consume gas Interp_costs.balance in
Gas.check gas >>=? fun () ->
Contract.get_balance ctxt source >>=? fun balance ->
logged_return (Item (balance, rest), gas, ctxt)
| Now, rest ->
let gas = Gas.consume gas Gas.Cost_of.now in
let gas = Gas.consume gas Interp_costs.now in
Gas.check gas >>=? fun () ->
let now = Script_timestamp.now ctxt in
logged_return (Item (now, rest), gas, ctxt)
| Check_signature, Item (key, Item ((signature, message), rest)) ->
let gas = Gas.consume gas Gas.Cost_of.check_signature in
let gas = Gas.consume gas Interp_costs.check_signature in
Gas.check gas >>=? fun () ->
let message = MBytes.of_string message in
let res = Signature.check key signature message in
logged_return (Item (res, rest), gas, ctxt)
| Hash_key, Item (key, rest) ->
logged_return (Item (Signature.Public_key.hash key, rest), Gas.consume gas Gas.Cost_of.hash_key, ctxt)
logged_return (Item (Signature.Public_key.hash key, rest), Gas.consume gas Interp_costs.hash_key, ctxt)
| H ty, Item (v, rest) ->
Gas.consume_check gas (Gas.Cost_of.hash v) >>=? fun gas ->
Gas.consume_check gas (Interp_costs.hash v) >>=? fun gas ->
Lwt.return @@ hash_data gas ty v >>=? fun (hash, gas) ->
logged_return (Item (hash, rest), gas, ctxt)
| Steps_to_quota, rest ->
let gas = Gas.consume gas Gas.Cost_of.steps_to_quota in
logged_return (Item (Gas.Cost_of.get_steps_to_quota gas, rest), gas, ctxt)
let gas = Gas.consume gas Interp_costs.steps_to_quota in
logged_return (Item (Interp_costs.get_steps_to_quota gas, rest), gas, ctxt)
| Source (ta, tb), rest ->
let gas = Gas.consume gas Gas.Cost_of.source in
let gas = Gas.consume gas Interp_costs.source in
Gas.check gas >>=? fun () ->
logged_return (Item ((ta, tb, orig), rest), gas, ctxt)
| Self (ta, tb), rest ->
let gas = Gas.consume gas Gas.Cost_of.self in
let gas = Gas.consume gas Interp_costs.self in
Gas.check gas >>=? fun () ->
logged_return (Item ((ta, tb, source), rest), gas, ctxt)
| Amount, rest ->
let gas = Gas.consume gas Gas.Cost_of.amount in
let gas = Gas.consume gas Interp_costs.amount in
Gas.check gas >>=? fun () ->
logged_return (Item (amount, rest), gas, ctxt) in
let stack = (Item (arg, Empty)) in

140
src/proto_alpha/lib_protocol/src/script_ir_translator.ml
View File

@ -550,77 +550,79 @@ let rec unparse_ty
let tr = unparse_ty None utr in
Prim (-1, T_big_map, [ ta; tr ], None)
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
let rec unparse_data
: type a. Gas.t -> a ty -> a -> (Script.node * Gas.t) tzresult
= fun gas ty a ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.cycle >>? fun gas ->
Gas.consume_check_error gas Unparse_costs.cycle >>? fun gas ->
match ty, a with
| Unit_t, () ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.unit >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.unit >|? fun gas ->
(Prim (-1, D_Unit, [], None), gas)
| Int_t, v ->
Gas.consume_check_error gas (Gas.Cost_of.Unparse.int v) >|? fun gas ->
Gas.consume_check_error gas (Unparse_costs.int v) >|? fun gas ->
(Int (-1, Script_int.to_string v), gas)
| Nat_t, v ->
Gas.consume_check_error gas (Gas.Cost_of.Unparse.int v) >|? fun gas ->
Gas.consume_check_error gas (Unparse_costs.int v) >|? fun gas ->
(Int (-1, Script_int.to_string v), gas)
| String_t, s ->
Gas.consume_check_error gas (Gas.Cost_of.Unparse.string s) >|? fun gas ->
Gas.consume_check_error gas (Unparse_costs.string s) >|? fun gas ->
(String (-1, s), gas)
| Bool_t, true ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.bool >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.bool >|? fun gas ->
(Prim (-1, D_True, [], None), gas)
| Bool_t, false ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.bool >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.bool >|? fun gas ->
(Prim (-1, D_False, [], None), gas)
| Timestamp_t, t ->
Gas.consume_check_error gas (Gas.Cost_of.Unparse.timestamp t) >>? fun gas ->
Gas.consume_check_error gas (Unparse_costs.timestamp t) >>? fun gas ->
begin
match Script_timestamp.to_notation t with
| None -> ok @@ (Int (-1, Script_timestamp.to_num_str t), gas)
| Some s -> ok @@ (String (-1, s), gas)
end
| Contract_t _, (_, _, c) ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.contract >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.contract >|? fun gas ->
(String (-1, Contract.to_b58check c), gas)
| Signature_t, s ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.signature >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.signature >|? fun gas ->
let `Hex text =
MBytes.to_hex
(Data_encoding.Binary.to_bytes_exn Signature.encoding s) in
(String (-1, text), gas)
| Tez_t, v ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.tez >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.tez >|? fun gas ->
(String (-1, Tez.to_string v), gas)
| Key_t, k ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.key >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.key >|? fun gas ->
(String (-1, Signature.Public_key.to_b58check k), gas)
| Key_hash_t, k ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.key_hash >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.key_hash >|? fun gas ->
(String (-1, Signature.Public_key_hash.to_b58check k), gas)
| Pair_t ((tl, _), (tr, _)), (l, r) ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.pair >>? fun gas ->
Gas.consume_check_error gas Unparse_costs.pair >>? fun gas ->
unparse_data gas tl l >>? fun (l, gas) ->
unparse_data gas tr r >|? fun (r, gas) ->
(Prim (-1, D_Pair, [ l; r ], None), gas)
| Union_t ((tl, _), _), L l ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.union >>? fun gas ->
Gas.consume_check_error gas Unparse_costs.union >>? fun gas ->
unparse_data gas tl l >|? fun (l, gas) ->
(Prim (-1, D_Left, [ l ], None), gas)
| Union_t (_, (tr, _)), R r ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.union >>? fun gas ->
Gas.consume_check_error gas Unparse_costs.union >>? fun gas ->
unparse_data gas tr r >|? fun (r, gas) ->
(Prim (-1, D_Right, [ r ], None), gas)
| Option_t t, Some v ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.some >>? fun gas ->
Gas.consume_check_error gas Unparse_costs.some >>? fun gas ->
unparse_data gas t v >|? fun (v, gas) ->
(Prim (-1, D_Some, [ v ], None), gas)
| Option_t _, None ->
Gas.consume_check_error gas Gas.Cost_of.Unparse.none >|? fun gas ->
Gas.consume_check_error gas Unparse_costs.none >|? fun gas ->
(Prim (-1, D_None, [], None), gas)
| List_t t, items ->
Gas.fold_right_error
~cycle_cost:Gas.Cost_of.Unparse.list_element
~cycle_cost:Unparse_costs.list_element
gas
(fun gas element l ->
unparse_data gas t element >|? fun (unparsed, gas) ->
@ -631,11 +633,11 @@ let rec unparse_data
| Set_t t, set ->
let t = ty_of_comparable_ty t in
Gas.consume_check_error gas
(Gas.Cost_of.Unparse.set_to_list set) >>? fun gas ->
(Unparse_costs.set_to_list set) >>? fun gas ->
let items = set_fold (fun e acc -> e :: acc) set [] in
Gas.fold_left_error
gas
~cycle_cost:Gas.Cost_of.Unparse.set_element
~cycle_cost:Unparse_costs.set_element
(fun gas item l ->
unparse_data gas t item >|? fun (item, gas) ->
(item :: l, gas))
@ -643,10 +645,10 @@ let rec unparse_data
(Micheline.Seq (-1, items, None), gas)
| Map_t (kt, vt), map ->
let kt = ty_of_comparable_ty kt in
Gas.consume_check_error gas (Gas.Cost_of.Unparse.map_to_list map) >>? fun gas ->
Gas.consume_check_error gas (Unparse_costs.map_to_list map) >>? fun gas ->
let elements = map_fold (fun k v acc -> (k, v) :: acc) map [] in
Gas.fold_left_error gas
~cycle_cost:Gas.Cost_of.Unparse.map_element
~cycle_cost:Unparse_costs.map_element
(fun gas (k, v) acc ->
unparse_data gas kt k >>? fun (key, gas) ->
unparse_data gas vt v >>? fun (value, gas) ->
@ -893,8 +895,10 @@ let merge_branches
| Failed { descr = descrt }, Typed dbf ->
return (Typed (branch (descrt dbf.aft) dbf))
module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking
let rec parse_comparable_ty : Gas.t -> Script.node -> (ex_comparable_ty * Gas.t) tzresult = fun gas node ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.cycle >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.cycle >>? fun gas ->
match node with
| Prim (_, T_int, [], _) -> ok ((Ex_comparable_ty Int_key), gas)
| Prim (_, T_nat, [], _) -> ok ((Ex_comparable_ty Nat_key), gas)
@ -921,7 +925,7 @@ let rec parse_comparable_ty : Gas.t -> Script.node -> (ex_comparable_ty * Gas.t)
and parse_ty :
Gas.t -> bool -> Script.node ->
((ex_ty * annot) * Gas.t) tzresult = fun gas big_map_possible node ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.cycle >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.cycle >>? fun gas ->
match node with
| Prim (_, T_pair,
[ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ],
@ -940,37 +944,37 @@ and parse_ty :
| args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)
end
| Prim (_, T_unit, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Unit_t, annot), gas)
| Prim (_, T_int, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Int_t, annot), gas)
| Prim (_, T_nat, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Nat_t, annot), gas)
| Prim (_, T_string, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty String_t, annot), gas)
| Prim (_, T_tez, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Tez_t, annot), gas)
| Prim (_, T_bool, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Bool_t, annot), gas)
| Prim (_, T_key, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Key_t, annot), gas)
| Prim (_, T_key_hash, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Key_hash_t, annot), gas)
| Prim (_, T_timestamp, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Timestamp_t, annot), gas)
| Prim (_, T_signature, [], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.primitive_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.primitive_type >>? fun gas ->
ok ((Ex_ty Signature_t, annot), gas)
| Prim (loc, T_contract, [ utl; utr ], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.two_arg_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.two_arg_type >>? fun gas ->
parse_ty gas false utl >>? fun ((Ex_ty tl, left_annot), gas) ->
parse_ty gas false utr >>? fun ((Ex_ty tr, right_annot), gas) ->
error_unexpected_annot loc left_annot >>? fun () ->
@ -993,16 +997,16 @@ and parse_ty :
error_unexpected_annot loc annot >|? fun () ->
((Ex_ty (Option_t t), opt_annot), gas)
| Prim (loc, T_list, [ ut ], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.one_arg_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.one_arg_type >>? fun gas ->
parse_ty gas false ut >>? fun ((Ex_ty t, list_annot), gas) ->
error_unexpected_annot loc list_annot >>? fun () ->
ok ((Ex_ty (List_t t), annot), gas)
| Prim (_, T_set, [ ut ], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.one_arg_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.one_arg_type >>? fun gas ->
parse_comparable_ty gas ut >>? fun ((Ex_comparable_ty t), gas) ->
ok ((Ex_ty (Set_t t), annot), gas)
| Prim (_, T_map, [ uta; utr ], annot) ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.one_arg_type >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.one_arg_type >>? fun gas ->
parse_comparable_ty gas uta >>? fun ((Ex_comparable_ty ta), gas) ->
parse_ty gas false utr >>? fun ((Ex_ty tr, _), gas) ->
ok ((Ex_ty (Map_t (ta, tr)), annot), gas)
@ -1039,13 +1043,14 @@ let rec parse_data
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Gas.t -> a ty -> Script.node -> (a * Gas.t) tzresult Lwt.t
= fun ?type_logger ctxt gas ty script_data ->
Gas.consume_check gas Gas.Cost_of.typechecking_cycle >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.cycle >>=? fun gas ->
let error () =
Invalid_constant (location script_data, strip_locations script_data, ty) in
let traced body =
trace (error ()) body in
let parse_items ?type_logger loc ctxt gas expr key_type value_type items item_wrapper =
(Gas.fold_left
~cycle_cost:Typecheck_costs.cycle
gas
(fun gas item (last_value, map) ->
match item with
@ -1074,7 +1079,7 @@ let rec parse_data
match ty, script_data with
(* Unit *)
| Unit_t, Prim (_, D_Unit, [], _) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.unit >>|? fun gas ->
Gas.consume_check gas Typecheck_costs.unit >>|? fun gas ->
((() : a), gas)
| Unit_t, Prim (loc, D_Unit, l, _) ->
traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l)))
@ -1082,10 +1087,10 @@ let rec parse_data
traced (fail (unexpected expr [] Constant_namespace [ D_Unit ]))
(* Booleans *)
| Bool_t, Prim (_, D_True, [], _) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.bool >>|? fun gas ->
Gas.consume_check gas Typecheck_costs.bool >>|? fun gas ->
(true, gas)
| Bool_t, Prim (_, D_False, [], _) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.bool >>|? fun gas ->
Gas.consume_check gas Typecheck_costs.bool >>|? fun gas ->
(false, gas)
| Bool_t, Prim (loc, (D_True | D_False as c), l, _) ->
traced (fail (Invalid_arity (loc, c, 0, List.length l)))
@ -1093,19 +1098,19 @@ let rec parse_data
traced (fail (unexpected expr [] Constant_namespace [ D_True ; D_False ]))
(* Strings *)
| String_t, String (_, v) ->
Gas.consume_check gas (Gas.Cost_of.Typechecking.string (String.length v)) >>|? fun gas ->
Gas.consume_check gas (Typecheck_costs.string (String.length v)) >>|? fun gas ->
(v, gas)
| String_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Integers *)
| Int_t, Int (_, v) ->
Gas.consume_check gas (Gas.Cost_of.Typechecking.int_of_string v) >>=? fun gas ->
Gas.consume_check gas (Typecheck_costs.int_of_string v) >>=? fun gas ->
begin match Script_int.of_string v with
| None -> fail (error ())
| Some v -> return (v, gas)
end
| Nat_t, Int (_, v) ->
Gas.consume_check gas (Gas.Cost_of.Typechecking.int_of_string v) >>=? fun gas ->
Gas.consume_check gas (Typecheck_costs.int_of_string v) >>=? fun gas ->
begin match Script_int.of_string v with
| None -> fail (error ())
| Some v ->
@ -1119,7 +1124,7 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr)))
(* Tez amounts *)
| Tez_t, String (_, v) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.tez >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.tez >>=? fun gas ->
begin try
match Tez.of_string v with
| None -> raise Exit
@ -1131,14 +1136,14 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Timestamps *)
| Timestamp_t, (Int (_, v)) ->
Gas.consume_check gas (Gas.Cost_of.Typechecking.int_of_string v) >>=? fun gas ->
Gas.consume_check gas (Typecheck_costs.int_of_string v) >>=? fun gas ->
begin
match Script_timestamp.of_string v with
| Some v -> return (v, gas)
| None -> fail (error ())
end
| Timestamp_t, String (_, s) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.string_timestamp >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.string_timestamp >>=? fun gas ->
begin try
match Script_timestamp.of_string s with
| Some v -> return (v, gas)
@ -1149,7 +1154,7 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr)))
(* IDs *)
| Key_t, String (_, s) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.key >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.key >>=? fun gas ->
begin
try
return (Signature.Public_key.of_b58check_exn s, gas)
@ -1158,7 +1163,7 @@ let rec parse_data
| Key_t, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
| Key_hash_t, String (_, s) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.key_hash >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.key_hash >>=? fun gas ->
begin
try
return (Signature.Public_key_hash.of_b58check_exn s, gas)
@ -1167,7 +1172,7 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Signatures *)
| Signature_t, String (_, s) -> begin try
Gas.consume_check gas Gas.Cost_of.Typechecking.signature >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.signature >>=? fun gas ->
match Data_encoding.Binary.of_bytes
Signature.encoding
(MBytes.of_hex (`Hex s)) with
@ -1180,7 +1185,7 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Contracts *)
| Contract_t (ty1, ty2), String (loc, s) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.contract >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.contract >>=? fun gas ->
traced @@
(Lwt.return (Contract.of_b58check s)) >>=? fun c ->
parse_contract ctxt gas ty1 ty2 loc c >>=? fun _ ->
@ -1189,7 +1194,7 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Pairs *)
| Pair_t ((ta, _), (tb, _)), Prim (_, D_Pair, [ va; vb ], _) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.pair >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.pair >>=? fun gas ->
traced @@
parse_data ?type_logger ctxt gas ta va >>=? fun (va, gas) ->
parse_data ?type_logger ctxt gas tb vb >>=? fun (vb, gas) ->
@ -1200,14 +1205,14 @@ let rec parse_data
traced (fail (unexpected expr [] Constant_namespace [ D_Pair ]))
(* Unions *)
| Union_t ((tl, _), _), Prim (_, D_Left, [ v ], _) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.union >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.union >>=? fun gas ->
traced @@
parse_data ?type_logger ctxt gas tl v >>=? fun (v, gas) ->
return (L v, gas)
| Union_t _, Prim (loc, D_Left, l, _) ->
fail @@ Invalid_arity (loc, D_Left, 1, List.length l)
| Union_t (_, (tr, _)), Prim (_, D_Right, [ v ], _) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.union >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.union >>=? fun gas ->
traced @@
parse_data ?type_logger ctxt gas tr v >>=? fun (v, gas) ->
return (R v, gas)
@ -1217,21 +1222,21 @@ let rec parse_data
traced (fail (unexpected expr [] Constant_namespace [ D_Left ; D_Right ]))
(* Lambdas *)
| Lambda_t (ta, tr), (Seq _ as script_instr) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.lambda >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.lambda >>=? fun gas ->
traced @@
parse_returning Lambda ?type_logger ctxt gas (ta, Some "@arg") tr script_instr
| Lambda_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Options *)
| Option_t t, Prim (_, D_Some, [ v ], _) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.some >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.some >>=? fun gas ->
traced @@
parse_data ?type_logger ctxt gas t v >>=? fun (v, gas) ->
return (Some v, gas)
| Option_t _, Prim (loc, D_Some, l, _) ->
fail @@ Invalid_arity (loc, D_Some, 1, List.length l)
| Option_t _, Prim (_, D_None, [], _) ->
Gas.consume_check gas Gas.Cost_of.Typechecking.none >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.none >>=? fun gas ->
return (None, gas)
| Option_t _, Prim (loc, D_None, l, _) ->
fail @@ Invalid_arity (loc, D_None, 0, List.length l)
@ -1241,7 +1246,7 @@ let rec parse_data
| List_t t, Seq (loc, items, annot) ->
fail_unexpected_annot loc annot >>=? fun () ->
traced @@
(Gas.fold_right ~cycle_cost:Gas.Cost_of.Typechecking.list_element
(Gas.fold_right ~cycle_cost:Typecheck_costs.list_element
gas
(fun gas v rest ->
parse_data ?type_logger ctxt gas t v >>=? fun (v, gas) ->
@ -1253,7 +1258,7 @@ let rec parse_data
| Set_t t, (Seq (loc, vs, annot) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
traced @@
Gas.fold_left ~cycle_cost:Gas.Cost_of.Typechecking.set_element
Gas.fold_left ~cycle_cost:Typecheck_costs.set_element
gas
(fun gas v (last_value, set) ->
parse_comparable_data ?type_logger ctxt gas t v >>=? fun (v, gas) ->
@ -1267,7 +1272,7 @@ let rec parse_data
else return ()
| None -> return ()
end >>=? fun () ->
Gas.consume_check gas (Gas.Cost_of.set_update v false set) >>=? fun gas ->
Gas.consume_check gas (Michelson_v1_gas.Cost_of.set_update v false set) >>=? fun gas ->
return ((Some v, set_update v true set), gas))
(None, empty_set t) vs >>|? fun ((_, set), gas) ->
(set, gas)
@ -2103,11 +2108,11 @@ and parse_contract
: type arg ret. context -> Gas.t -> arg ty -> ret ty -> Script.location -> Contract.t ->
((arg, ret) typed_contract * Gas.t) tzresult Lwt.t
= fun ctxt gas arg ret loc contract ->
Gas.consume_check gas Gas.Cost_of.Typechecking.contract_exists >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.contract_exists >>=? fun gas ->
Contract.exists ctxt contract >>=? function
| false -> fail (Invalid_contract (loc, contract))
| true ->
Gas.consume_check gas Gas.Cost_of.Typechecking.get_script >>=? fun gas ->
Gas.consume_check gas Typecheck_costs.get_script >>=? fun gas ->
trace
(Invalid_contract (loc, contract)) @@
Contract.get_script ctxt contract >>=? function
@ -2132,14 +2137,14 @@ and parse_contract
and parse_toplevel
: Gas.t -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * Gas.t) tzresult
= fun gas toplevel ->
Gas.consume_check_error gas Gas.Cost_of.Typechecking.cycle >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.cycle >>? fun gas ->
match root toplevel with
| Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind))
| String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind))
| Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind))
| Seq (_, fields, _) ->
let rec find_fields gas p r s c fields =
Gas.consume_check_error gas Gas.Cost_of.Typechecking.cycle >>? fun gas ->
Gas.consume_check_error gas Typecheck_costs.cycle >>? fun gas ->
match fields with
| [] -> ok ((p, r, s, c), gas)
| Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind))
@ -2279,9 +2284,10 @@ let big_map_update key value ({ diff ; _ } as map) =
{ map with diff = map_set key value diff }
let to_big_map_diff_list gas { key_type ; value_type ; diff } =
Gas.consume_check gas (Gas.Cost_of.map_to_list diff) >>=? fun gas ->
Gas.consume_check gas (Michelson_v1_gas.Cost_of.map_to_list diff) >>=? fun gas ->
let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
Gas.fold_left gas
~cycle_cost:Typecheck_costs.cycle
(fun gas (key, value) acc ->
Lwt.return @@ hash_data gas key_type key >>=? fun (hash, gas) ->
begin