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

Alpha: IO gas accounting

Browse Source
This commit is contained in:
Benjamin Canou 2018-04-07 18:28:37 +02:00 committed by Grégoire Henry
parent 4a0b30d968
commit 6f3be375e8
15 changed files with 155 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/proto_alpha/lib_protocol/src/alpha_context.mli
View File

@ -502,9 +502,9 @@ module Contract : sig
val is_spendable:
context -> contract -> bool tzresult Lwt.t
val get_script:
context -> contract -> (Script.t option) tzresult Lwt.t
context -> contract -> (context * Script.t option) tzresult Lwt.t
val get_storage:
context -> contract -> (Script.expr option) tzresult Lwt.t
context -> contract -> (context * Script.expr option) tzresult Lwt.t
val get_counter: context -> contract -> int32 tzresult Lwt.t
val get_balance:
@ -546,13 +546,13 @@ module Contract : sig
module Big_map : sig
val set:
context -> contract ->
string -> Script.expr -> context tzresult Lwt.t
context -> contract -> string -> Script.expr -> context tzresult Lwt.t
val remove:
context -> contract -> string -> context tzresult Lwt.t
val mem: context -> contract -> string -> bool Lwt.t
val mem:
context -> contract -> string -> (context * bool) tzresult Lwt.t
val get_opt:
context -> contract -> string -> Script_repr.expr option tzresult Lwt.t
context -> contract -> string -> (context * Script_repr.expr option) tzresult Lwt.t
end
end

2
src/proto_alpha/lib_protocol/src/apply.ml
View File

@ -376,7 +376,7 @@ let apply_manager_operation_content
begin
Contract.spend ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? function
Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with
| None -> begin
match parameters with
| None ->

10
src/proto_alpha/lib_protocol/src/contract_services.ml
View File

@ -170,8 +170,10 @@ let () =
register_field S.counter Contract.get_counter ;
register_field S.spendable Contract.is_spendable ;
register_field S.delegatable Contract.is_delegatable ;
register_opt_field S.script Contract.get_script ;
register_opt_field S.storage Contract.get_storage ;
register_opt_field S.script
(fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ;
register_opt_field S.storage
(fun c v -> Contract.get_storage c v >>=? fun (_, v) -> return v) ;
register_field S.info (fun ctxt contract ->
Contract.get_balance ctxt contract >>=? fun balance ->
Contract.get_manager ctxt contract >>=? fun manager ->
@ -179,8 +181,8 @@ let () =
Contract.get_counter ctxt contract >>=? fun counter ->
Contract.is_delegatable ctxt contract >>=? fun delegatable ->
Contract.is_spendable ctxt contract >>=? fun spendable ->
Contract.get_script ctxt contract >>=? fun script ->
Contract.get_storage ctxt contract >>=? fun storage ->
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
Contract.get_storage ctxt contract >>=? fun (_ctxt, storage) ->
return { manager ; balance ;
spendable ; delegate = (delegatable, delegate) ;
script ; counter ; storage})

54
src/proto_alpha/lib_protocol/src/contract_storage.ml
View File

@ -200,8 +200,8 @@ let create_base c contract
Storage.Contract.Counter.init c contract counter >>=? fun c ->
(match script with
| Some ({ Script_repr.code ; storage }, (code_fees, storage_fees)) ->
Storage.Contract.Code.init c contract code >>=? fun c ->
Storage.Contract.Storage.init c contract storage >>=? fun c ->
Storage.Contract.Code.init c contract code >>=? fun (c, _) ->
Storage.Contract.Storage.init c contract storage >>=? fun (c, _) ->
Storage.Contract.Code_fees.init c contract code_fees >>=? fun c ->
Storage.Contract.Storage_fees.init c contract storage_fees
| None ->
@ -225,11 +225,11 @@ let delete c contract =
Storage.Contract.Spendable.del c contract >>= fun c ->
Storage.Contract.Delegatable.del c contract >>= fun c ->
Storage.Contract.Counter.delete c contract >>=? fun c ->
Storage.Contract.Code.remove c contract >>= fun c ->
Storage.Contract.Storage.remove c contract >>= fun c ->
Storage.Contract.Code.remove c contract >>=? fun (c, _) ->
Storage.Contract.Storage.remove c contract >>=? fun (c, _) ->
Storage.Contract.Code_fees.remove c contract >>= fun c ->
Storage.Contract.Storage_fees.remove c contract >>= fun c ->
Storage.Contract.Big_map.clear (c, contract) >>= fun c ->
Storage.Contract.Big_map.clear (c, contract) >>=? fun c ->
return c
let allocated c contract =
@ -274,11 +274,11 @@ let increment_counter c contract =
Storage.Contract.Counter.set c contract (Int32.succ contract_counter)
let get_script c contract =
Storage.Contract.Code.get_option c contract >>=? fun code ->
Storage.Contract.Storage.get_option c contract >>=? fun storage ->
Storage.Contract.Code.get_option c contract >>=? fun (c, code) ->
Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) ->
match code, storage with
| None, None -> return None
| Some code, Some storage -> return (Some { Script_repr.code ; storage })
| None, None -> return (c, None)
| Some code, Some storage -> return (c, Some { Script_repr.code ; storage })
| None, Some _ | Some _, None -> failwith "get_script"
let get_storage = Storage.Contract.Storage.get_option
@ -364,14 +364,15 @@ let update_script_storage c contract storage big_map =
fold_left_s (fun c (key, value) ->
match value with
| None ->
Storage.Contract.Big_map.remove (c, contract) key >>=
return
Storage.Contract.Big_map.remove (c, contract) key >>=? fun (c, _) ->
return c
| Some v ->
Storage.Contract.Big_map.init_set (c, contract) key v >>=
return)
Storage.Contract.Big_map.init_set (c, contract) key v >>=? fun (c, _) ->
return c)
c diff
end >>=? fun c ->
Storage.Contract.Storage.set c contract storage
Storage.Contract.Storage.set c contract storage >>=? fun (c, _) ->
return c
let spend_from_script c contract amount =
Storage.Contract.Balance.get c contract >>=? fun balance ->
@ -393,16 +394,18 @@ let spend_from_script c contract amount =
return c
| None ->
(* Delete empty implicit contract *)
delete c contract
delete c contract >>=? fun (c, _) ->
return c
let credit c contract amount =
begin
if Tez_repr.(amount <> Tez_repr.zero) then
return ()
return c
else
Storage.Contract.Code.mem c contract >>= fun target_has_code ->
fail_unless target_has_code (Empty_transaction contract)
end >>=? fun () ->
Storage.Contract.Code.mem c contract >>=? fun (c, target_has_code) ->
fail_unless target_has_code (Empty_transaction contract) >>=? fun () ->
return c
end >>=? fun c ->
Storage.Contract.Balance.get_option c contract >>=? function
| None -> begin
match Contract_repr.is_implicit contract with
@ -440,8 +443,13 @@ let init c =
module Big_map = struct
let set ctxt contract key value =
Storage.Contract.Big_map.init_set (ctxt, contract) key value >>= return
let remove ctxt contract = Storage.Contract.Big_map.delete (ctxt, contract)
let mem ctxt contract = Storage.Contract.Big_map.mem (ctxt, contract)
let get_opt ctxt contract = Storage.Contract.Big_map.get_option (ctxt, contract)
Storage.Contract.Big_map.init_set (ctxt, contract) key value >>=? fun (c, _) ->
return c
let remove ctxt contract key =
Storage.Contract.Big_map.delete (ctxt, contract) key >>=? fun (c, _) ->
return c
let mem ctxt contract key =
Storage.Contract.Big_map.mem (ctxt, contract) key
let get_opt ctxt contract key =
Storage.Contract.Big_map.get_option (ctxt, contract) key
end

12
src/proto_alpha/lib_protocol/src/contract_storage.mli
View File

@ -56,9 +56,9 @@ val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t
val get_counter: Raw_context.t -> Contract_repr.t -> int32 tzresult Lwt.t
val get_script:
Raw_context.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t
val get_storage:
Raw_context.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t
type big_map_diff = (string * Script_repr.expr option) list
@ -103,11 +103,11 @@ val init:
module Big_map : sig
val set :
Raw_context.t -> Contract_repr.t ->
string -> Script_repr.expr -> Raw_context.t tzresult Lwt.t
Raw_context.t -> Contract_repr.t -> string -> Script_repr.expr -> Raw_context.t tzresult Lwt.t
val remove :
Raw_context.t -> Contract_repr.t -> string -> Raw_context.t tzresult Lwt.t
val mem : Raw_context.t -> Contract_repr.t -> string -> bool Lwt.t
val mem :
Raw_context.t -> Contract_repr.t -> string -> (Raw_context.t * bool) tzresult Lwt.t
val get_opt :
Raw_context.t -> Contract_repr.t -> string -> Script_repr.expr option tzresult Lwt.t
Raw_context.t -> Contract_repr.t -> string -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t
end

99
src/proto_alpha/lib_protocol/src/gas_repr.ml
View File

@ -13,7 +13,11 @@ type t =
type cost =
{ allocations : Z.t ;
steps : Z.t }
steps : Z.t ;
reads : Z.t ;
writes : Z.t ;
bytes_read : Z.t ;
bytes_written : Z.t }
let encoding =
let open Data_encoding in
@ -34,32 +38,53 @@ let pp ppf = function
let cost_encoding =
let open Data_encoding in
conv
(fun { allocations ; steps } ->
(allocations, steps))
(fun (allocations, steps) ->
{ allocations ; steps })
(obj2
(fun { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } ->
(allocations, steps, reads, writes, bytes_read, bytes_written))
(fun (allocations, steps, reads, writes, bytes_read, bytes_written) ->
{ allocations ; steps ; reads ; writes ; bytes_read ; bytes_written })
(obj6
(req "allocations" z)
(req "steps" z))
(req "steps" z)
(req "reads" z)
(req "writes" z)
(req "bytes_read" z)
(req "bytes_written" z))
let pp_cost ppf { allocations ; steps } =
let pp_cost ppf { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } =
Format.fprintf ppf
"(steps: %s, allocs: %s)"
(Z.to_string steps) (Z.to_string allocations)
"(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))"
(Z.to_string steps)
(Z.to_string allocations)
(Z.to_string reads)
(Z.to_string bytes_read)
(Z.to_string writes)
(Z.to_string bytes_written)
type error += Block_quota_exceeded (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
let allocation_weight = Z.of_int 2
let step_weight = Z.of_int 1
let allocation_weight = Z.of_int 2 (* FIXME: placeholder *)
let step_weight = Z.of_int 1 (* FIXME: placeholder *)
let read_base_weight = Z.of_int 10 (* FIXME: placeholder *)
let write_base_weight = Z.of_int 20 (* FIXME: placeholder *)
let byte_read_weight = Z.of_int 10 (* FIXME: placeholder *)
let byte_written_weight = Z.of_int 20 (* FIXME: placeholder *)
let consume block_gas operation_gas cost = match operation_gas with
| Unaccounted -> ok (block_gas, Unaccounted)
| Limited { remaining } ->
let weighted_cost =
Z.add
(Z.mul allocation_weight cost.allocations)
(Z.mul step_weight cost.steps) in
(Z.add
(Z.mul allocation_weight cost.allocations)
(Z.mul step_weight cost.steps))
(Z.add
(Z.add
(Z.mul read_base_weight cost.reads)
(Z.mul write_base_weight cost.writes))
(Z.add
(Z.mul byte_read_weight cost.bytes_read)
(Z.mul byte_written_weight cost.bytes_written))) in
let remaining =
Z.sub remaining weighted_cost in
let block_remaining =
@ -72,7 +97,11 @@ let consume block_gas operation_gas cost = match operation_gas with
let alloc_cost n =
{ allocations = Z.of_int (n + 1) ;
steps = Z.zero }
steps = Z.zero ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
let alloc_bytes_cost n =
alloc_cost (n / 8)
@ -82,19 +111,51 @@ let alloc_bits_cost n =
let step_cost n =
{ allocations = Z.zero ;
steps = Z.of_int n }
steps = Z.of_int n ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
let free =
{ allocations = Z.zero ;
steps = Z.zero }
steps = Z.zero ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
let read_bytes_cost n =
{ allocations = Z.zero ;
steps = Z.zero ;
reads = Z.one ;
writes = Z.zero ;
bytes_read = n ;
bytes_written = Z.zero }
let write_bytes_cost n =
{ allocations = Z.zero ;
steps = Z.zero ;
reads = Z.zero ;
writes = Z.one ;
bytes_read = Z.zero ;
bytes_written = n }
let ( +@ ) x y =
{ allocations = Z.add x.allocations y.allocations ;
steps = Z.add x.steps y.steps }
steps = Z.add x.steps y.steps ;
reads = Z.add x.reads y.reads ;
writes = Z.add x.writes y.writes ;
bytes_read = Z.add x.bytes_read y.bytes_read ;
bytes_written = Z.add x.bytes_written y.bytes_written }
let ( *@ ) x y =
{ allocations = Z.mul (Z.of_int x) y.allocations ;
steps = Z.mul (Z.of_int x) y.steps }
steps = Z.mul (Z.of_int x) y.steps ;
reads = Z.mul (Z.of_int x) y.reads ;
writes = Z.mul (Z.of_int x) y.writes ;
bytes_read = Z.mul (Z.of_int x) y.bytes_read ;
bytes_written = Z.mul (Z.of_int x) y.bytes_written }
let () =
let open Data_encoding in

2
src/proto_alpha/lib_protocol/src/gas_repr.mli
View File

@ -29,6 +29,8 @@ val step_cost : int -> cost
val alloc_cost : int -> cost
val alloc_bytes_cost : int -> cost
val alloc_bits_cost : int -> cost
val read_bytes_cost : Z.t -> cost
val write_bytes_cost : Z.t -> cost
val ( *@ ) : int -> cost -> cost
val ( +@ ) : cost -> cost -> cost

1
src/proto_alpha/lib_protocol/src/raw_context.mli
View File

@ -77,7 +77,6 @@ type error += Gas_limit_too_high (* `Permanent *)
val set_gas_limit: t -> Z.t -> t tzresult
val set_gas_unlimited: t -> t
val consume_gas: t -> Gas_repr.cost -> t tzresult
val gas_level: t -> Gas_repr.t
val block_gas_level: t -> Z.t

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

@ -648,7 +648,7 @@ let rec interp
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
Contract.spend_from_script ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? fun destination_script ->
Contract.get_script ctxt destination >>=? fun (ctxt, destination_script) ->
Lwt.return (unparse_data ctxt storage_type storage) >>=? fun (sto, ctxt) ->
let sto = Micheline.strip_locations sto in
begin match Script_ir_translator.extract_big_map storage_type storage with
@ -685,7 +685,7 @@ let rec interp
destination dummy_storage_fee >>=? fun ctxt ->
return (ctxt, origination)
end >>=? fun (ctxt, origination) ->
Contract.get_script ctxt source >>=? (function
Contract.get_script ctxt source >>=? (fun (ctxt, script) -> match script with
| None -> assert false
| Some { storage; _ } ->
parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) ->
@ -696,7 +696,7 @@ let rec interp
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
Contract.spend_from_script ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? function
Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with
| None -> fail (Invalid_contract (loc, destination))
| Some script ->
begin match extract_big_map storage_type sto with
@ -727,7 +727,7 @@ let rec interp
trace
(Invalid_contract (loc, destination))
(parse_data ctxt tr ret) >>=? fun (v, ctxt) ->
Contract.get_script ctxt source >>=? (function
Contract.get_script ctxt source >>=? (fun (ctxt, script) -> match script with
| None -> assert false
| Some { storage ; _ } ->
parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) ->

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

@ -2159,7 +2159,7 @@ and parse_contract
Lwt.return (Gas.consume ctxt Typecheck_costs.get_script) >>=? fun ctxt ->
trace
(Invalid_contract (loc, contract)) @@
Contract.get_script ctxt contract >>=? function
Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with
| None ->
Lwt.return
(ty_eq arg Unit_t >>? fun Eq ->
@ -2303,7 +2303,7 @@ let hash_data ctxt typ data =
let big_map_mem ctxt contract key { diff ; key_type ; _ } =
match map_get key diff with
| None -> Lwt.return @@ hash_data ctxt key_type key >>=? fun (hash, ctxt) ->
Alpha_context.Contract.Big_map.mem ctxt contract hash >>= fun res ->
Alpha_context.Contract.Big_map.mem ctxt contract hash >>=? fun (ctxt, res) ->
return (res, ctxt)
| Some None -> return (false, ctxt)
| Some (Some _) -> return (true, ctxt)
@ -2315,10 +2315,10 @@ let big_map_get ctxt contract key { diff ; key_type ; value_type } =
Lwt.return @@ hash_data ctxt key_type key >>=? fun (hash, ctxt) ->
Alpha_context.Contract.Big_map.get_opt
ctxt contract hash >>=? begin function
| None -> return (None, ctxt)
| Some value ->
parse_data ctxt value_type (Micheline.root value) >>|? fun (x, ctxt) ->
(Some x, ctxt)
| (ctxt, None) -> return (None, ctxt)
| (ctxt, Some value) ->
parse_data ctxt value_type (Micheline.root value) >>=? fun (x, ctxt) ->
return (Some x, ctxt)
end
let big_map_update key value ({ diff ; _ } as map) =

12
src/proto_alpha/lib_protocol/src/storage.ml
View File

@ -127,17 +127,17 @@ module Contract = struct
(Make_value(Int32))
module Code =
Indexed_context.Make_map
Indexed_context.Make_carbonated_map
(struct let name = ["code"] end)
(Make_value(struct
(Make_carbonated_value(struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
end))
module Storage =
Indexed_context.Make_map
Indexed_context.Make_carbonated_map
(struct let name = ["storage"] end)
(Make_value(struct
(Make_carbonated_value(struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
end))
@ -145,12 +145,12 @@ module Contract = struct
type bigmap_key = Raw_context.t * Contract_repr.t
module Big_map =
Storage_functors.Make_indexed_data_storage
Storage_functors.Make_indexed_carbonated_data_storage
(Make_subcontext
(Indexed_context.Raw_context)
(struct let name = ["big_map"] end))
(String_index)
(Make_value (struct
(Make_carbonated_value (struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
end))

6
src/proto_alpha/lib_protocol/src/storage.mli
View File

@ -156,12 +156,12 @@ module Contract : sig
and type value = int32
and type t := Raw_context.t
module Code : Indexed_data_storage
module Code : Indexed_carbonated_data_storage
with type key = Contract_repr.t
and type value = Script_repr.expr
and type t := Raw_context.t
module Storage : Indexed_data_storage
module Storage : Indexed_carbonated_data_storage
with type key = Contract_repr.t
and type value = Script_repr.expr
and type t := Raw_context.t
@ -178,7 +178,7 @@ module Contract : sig
type bigmap_key = Raw_context.t * Contract_repr.t
module Big_map : Indexed_data_storage
module Big_map : Indexed_carbonated_data_storage
with type key = string
and type value = Script_repr.expr
and type t := bigmap_key

2
src/proto_alpha/lib_protocol/src/storage_functors.ml
View File

@ -48,7 +48,7 @@ let rec len_name = function
let encode_len_value bytes =
let length = MBytes.length bytes in
Data_encoding.(Binary.to_bytes int31) length
Data_encoding.(Binary.to_bytes_exn int31) length
let decode_len_value key len =
match Data_encoding.(Binary.of_bytes int31) len with

4
src/proto_alpha/lib_protocol/test/test_big_maps.ml
View File

@ -46,8 +46,8 @@ let expect_big_map tc contract print_key key_type print_data data_type contents
let open Proto_alpha.Error_monad in
iter_p
(fun (n, exp) ->
Lwt.return @@ Proto_alpha.Script_ir_translator.hash_data tc key_type n >>=? fun (key, _tc) ->
Proto_alpha.Alpha_context.Contract.Big_map.get_opt tc contract key >>=? fun data ->
Lwt.return @@ Proto_alpha.Script_ir_translator.hash_data tc key_type n >>=? fun (key, tc) ->
Proto_alpha.Alpha_context.Contract.Big_map.get_opt tc contract key >>=? fun (_tc, data) ->
match data, exp with
| None, None ->
debug " - big_map[%a] is not defined (ok)" print_key n ;

2
src/proto_alpha/lib_protocol/test/test_michelson.ml
View File

@ -434,7 +434,7 @@ let test_example () =
test_contract ~tc "create_contract" account_str account_str >>=? fun (cs, tc) ->
Assert.equal_int 1 @@ List.length cs ;
let contract = List.hd cs in
Proto_alpha.Alpha_context.Contract.get_script tc contract >>=?? fun res ->
Proto_alpha.Alpha_context.Contract.get_script tc contract >>=?? fun (_, res) ->
let script = Option.unopt_exn (Failure "get_script") res in
Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun (_, ret, _, _, _) ->
Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ;