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

Alpha, Michelson: thread the gas directly in the context

Browse Source
This commit is contained in:
Benjamin Canou 2018-03-24 02:03:03 +01:00 committed by Grégoire Henry
parent 04415ff6a8
commit 4fd2b03832
26 changed files with 1274 additions and 1230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/bin_client/test/test_contracts.sh
View File

@ -208,7 +208,7 @@ assert_output $contract_dir/exec_concat.tz Unit '""' '"_abc"'
assert_output $contract_dir/exec_concat.tz Unit '"test"' '"test_abc"'
# Get current steps to quota
assert_output $contract_dir/steps_to_quota.tz Unit Unit 39973
assert_output $contract_dir/steps_to_quota.tz Unit Unit 39968
# Get the current balance of the contract
assert_output $contract_dir/balance.tz Unit Unit '"4,000,000"'

5
src/proto_alpha/lib_client/client_proto_programs.ml
View File

@ -134,7 +134,7 @@ let typecheck_program ?gas (program : Michelson_v1_parser.parsed) block cctxt =
Alpha_services.Helpers.typecheck_code cctxt block (program.expanded, gas)
let print_typecheck_result
~emacs ~show_types ~print_source_on_error ~original_gas
~emacs ~show_types ~print_source_on_error
program res (cctxt : #Client_context.printer) =
if emacs then
let type_map, errs, _gas = match res with
@ -154,8 +154,7 @@ let print_typecheck_result
match res with
| Ok (type_map, gas) ->
let program = Michelson_v1_printer.inject_types type_map program in
cctxt#message "@[<v 0>Well typed@,Gas used: %a@,Gas remaining: %a@]"
Gas.pp (Gas.used ~original:original_gas ~current:gas)
cctxt#message "@[<v 0>Well typed@,Gas remaining: %a@]"
Gas.pp gas >>= fun () ->
if show_types then
cctxt#message "%a" Micheline_printer.print_expr program >>= fun () ->

7
src/proto_alpha/lib_client/client_proto_programs.mli
View File

@ -51,7 +51,7 @@ val print_trace_result :
tzresult -> unit tzresult Lwt.t
val hash_and_sign :
?gas:Gas.t ->
?gas:int ->
Michelson_v1_parser.parsed ->
Michelson_v1_parser.parsed ->
Client_keys.sk_uri ->
@ -60,7 +60,7 @@ val hash_and_sign :
(string * string * Gas.t) tzresult Lwt.t
val typecheck_data :
?gas:Proto_alpha.Gas.t ->
?gas:int ->
data:Michelson_v1_parser.parsed ->
ty:Michelson_v1_parser.parsed ->
'a ->
@ -68,7 +68,7 @@ val typecheck_data :
Gas.t tzresult Lwt.t
val typecheck_program :
?gas:Gas.t ->
?gas:int ->
Michelson_v1_parser.parsed ->
Block_services.block ->
#Proto_alpha.rpc_context ->
@ -78,7 +78,6 @@ val print_typecheck_result :
emacs:bool ->
show_types:bool ->
print_source_on_error:bool ->
original_gas:Gas.t ->
Michelson_v1_parser.parsed ->
(Script_tc_errors.type_map * Gas.t) tzresult ->
#Client_context.printer ->

19
src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml
View File

@ -50,12 +50,12 @@ let commands () =
(parameter
(fun _ctx str ->
try
return @@ Proto_alpha.Gas.of_int @@ int_of_string str
return (int_of_string str)
with _ ->
failwith "Invalid gas literal: '%s'" str)) in
let resolve_max_gas ctxt block = function
| None -> Alpha_services.Constants.max_gas ctxt block >>=? fun gas ->
return @@ Proto_alpha.Gas.of_int gas
return gas
| Some gas -> return gas in
let data_parameter =
Clic.parameter (fun _ data ->
@ -129,7 +129,6 @@ let commands () =
resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas ->
typecheck_program ~gas:original_gas program cctxt#block cctxt >>= fun res ->
print_typecheck_result
~original_gas
~emacs:emacs_mode
~show_types
~print_source_on_error:(not no_print_source)
@ -164,9 +163,8 @@ let commands () =
resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas ->
Client_proto_programs.typecheck_data ~gas:original_gas ~data ~ty cctxt#block cctxt >>= function
| Ok gas ->
cctxt#message "@[<v 0>Well typed@,Gas used: %a@,Gas remaining: %a@]"
Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:original_gas ~current:gas)
Proto_alpha.Gas.pp gas >>= fun () ->
cctxt#message "@[<v 0>Well typed@,Gas remaining: %a@]"
Proto_alpha.Alpha_context.Gas.pp gas >>= fun () ->
return ()
| Error errs ->
cctxt#warning "%a"
@ -193,8 +191,8 @@ let commands () =
Alpha_services.Helpers.hash_data cctxt
cctxt#block (data.expanded, typ.expanded, Some original_gas) >>= function
| Ok (hash, remaining_gas) ->
cctxt#message "%S@,Gas used: %a" hash
Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:original_gas ~current:remaining_gas) >>= fun () ->
cctxt#message "%S@,Gas remaining: %a" hash
Proto_alpha.Alpha_context.Gas.pp remaining_gas >>= fun () ->
return ()
| Error errs ->
cctxt#warning "%a"
@ -225,10 +223,9 @@ let commands () =
resolve_max_gas cctxt cctxt#block gas >>=? fun gas ->
Client_proto_programs.hash_and_sign ~gas data typ sk cctxt#block cctxt >>= begin function
| Ok (hash, signature, current_gas) ->
cctxt#message "@[<v 0>Hash: %S@,Signature: %S@,Gas used: %a@,Remaining gas: %a@]"
cctxt#message "@[<v 0>Hash: %S@,Signature: %S@,Remaining gas: %a@]"
hash signature
Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:gas ~current:current_gas)
Proto_alpha.Gas.pp current_gas
Proto_alpha.Alpha_context.Gas.pp current_gas
| Error errs ->
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors

2
src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL
View File

@ -20,6 +20,7 @@
"Cycle_repr",
"Level_repr",
"Seed_repr",
"Gas_repr",
"Script_int_repr",
"Script_timestamp_repr",
"Michelson_v1_primitives",
@ -55,7 +56,6 @@
"Script_typed_ir",
"Fees",
"Gas",
"Script_tc_errors",
"Michelson_v1_gas",
"Script_ir_translator",

7
src/proto_alpha/lib_protocol/src/alpha_context.ml
View File

@ -61,6 +61,13 @@ end
module Voting_period = Voting_period_repr
module Gas = struct
include Gas_repr
let set_limit = Raw_context.set_gas_limit
let set_unlimited = Raw_context.set_gas_unlimited
let consume = Raw_context.consume_gas
let level = Raw_context.gas_level
end
module Level = struct
include Level_repr
include Level_storage

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

@ -106,6 +106,36 @@ module Cycle : sig
end
module Gas : sig
type t = private
| Unaccounted
| Limited of { remaining : int }
val encoding : t Data_encoding.encoding
val pp : Format.formatter -> t -> unit
type cost
val cost_encoding : cost Data_encoding.encoding
val pp_cost : Format.formatter -> cost -> unit
type error += Quota_exceeded
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 ( *@ ) : int -> cost -> cost
val ( +@ ) : cost -> cost -> cost
val set_limit: context -> int -> context
val set_unlimited: context -> context
val consume: context -> cost -> context tzresult
val level: context -> t
end
module Script_int : module type of Script_int_repr
module Script_timestamp : sig

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

@ -371,7 +371,9 @@ let apply_amendment_operation_content ctxt delegate = function
let apply_manager_operation_content
ctxt origination_nonce source = function
| Reveal _ -> return (ctxt, origination_nonce, None)
| Transaction { amount ; parameters ; destination } -> begin
| Transaction { amount ; parameters ; destination } ->
let ctxt = Gas.set_limit ctxt (Constants.max_gas ctxt) in
begin
Contract.spend ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? function
@ -386,19 +388,17 @@ let apply_manager_operation_content
| _ -> fail (Bad_contract_parameter (destination, None, parameters))
end
| Some script ->
let gas = Gas.of_int (Constants.max_gas ctxt) in
let call_contract argument gas =
let call_contract ctxt argument =
Script_interpreter.execute
origination_nonce
source destination ctxt script amount argument
gas
>>= function
| Ok (storage_res, _res, gas, ctxt, origination_nonce, maybe_big_map_diff) ->
| Ok (storage_res, _res, ctxt, origination_nonce, maybe_big_map_diff) ->
begin match maybe_big_map_diff with
| None -> return (None, gas)
| None -> return (None, ctxt)
| Some map ->
Script_ir_translator.to_serializable_big_map gas map >>=? fun (diff, gas) ->
return (Some diff, gas) end >>=? fun (diff, _gas) ->
Script_ir_translator.to_serializable_big_map ctxt map >>=? fun (diff, ctxt) ->
return (Some diff, ctxt) end >>=? fun (diff, ctxt) ->
Contract.update_script_storage
ctxt destination
storage_res diff >>=? fun ctxt ->
@ -407,14 +407,14 @@ let apply_manager_operation_content
return (ctxt, origination_nonce, None)
| Error err ->
return (ctxt, origination_nonce, Some err) in
Lwt.return @@ Script_ir_translator.parse_toplevel gas script.code >>=? fun ((arg_type, _, _, _), gas) ->
Lwt.return @@ Script_ir_translator.parse_toplevel ctxt script.code >>=? fun ((arg_type, _, _, _), ctxt) ->
let arg_type = Micheline.strip_locations arg_type in
match parameters, Micheline.root arg_type with
| None, Prim (_, T_unit, _, _) ->
call_contract (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))) gas
call_contract ctxt (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None)))
| Some parameters, _ -> begin
Script_ir_translator.typecheck_data ctxt gas (parameters, arg_type) >>= function
| Ok gas -> call_contract parameters gas
Script_ir_translator.typecheck_data ctxt (parameters, arg_type) >>= function
| Ok ctxt -> call_contract ctxt parameters
| Error errs ->
let err = Bad_contract_parameter (destination, Some arg_type, Some parameters) in
return (ctxt, origination_nonce, Some ((err :: errs)))
@ -423,15 +423,15 @@ let apply_manager_operation_content
end
| Origination { manager ; delegate ; script ;
spendable ; delegatable ; credit } ->
let gas = Gas.of_int (Constants.max_gas ctxt) in
let ctxt = Gas.set_limit ctxt (Constants.max_gas ctxt) in
begin match script with
| None -> return (None, None, gas)
| None -> return (None, None, ctxt)
| Some script ->
Script_ir_translator.parse_script ctxt gas script >>=? fun (_, gas) ->
Script_ir_translator.erase_big_map_initialization ctxt gas script >>=? fun (script, big_map_diff, gas) ->
Script_ir_translator.parse_script ctxt script >>=? fun (_, ctxt) ->
Script_ir_translator.erase_big_map_initialization ctxt script >>=? fun (script, big_map_diff, ctxt) ->
return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee)),
big_map_diff, gas)
end >>=? fun (script, big_map, _gas) ->
big_map_diff, ctxt)
end >>=? fun (script, big_map, ctxt) ->
Contract.spend ctxt source credit >>=? fun ctxt ->
Contract.originate ctxt
origination_nonce
@ -488,6 +488,7 @@ let apply_sourced_operation
ctxt origination_nonce source content)
(ctxt, origination_nonce, None) contents
>>=? fun (ctxt, origination_nonce, err) ->
let ctxt = Gas.set_unlimited ctxt in
return (ctxt, origination_nonce, err)
| Consensus_operation content ->
apply_consensus_operation_content ctxt
@ -615,6 +616,7 @@ let apply_anonymous_operation ctxt _delegate origination_nonce kind =
let apply_operation
ctxt delegate pred_block block_prio hash operation =
let ctxt = Gas.set_unlimited ctxt in
match operation.contents with
| Anonymous_operations ops ->
let origination_nonce = Contract.initial_origination_nonce hash in

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

@ -1,153 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t = { remaining : int } [@@unboxed]
type cost =
{ allocations : int ;
steps : int }
let encoding =
let open Data_encoding in
conv
(fun { remaining } ->
(remaining))
(fun (remaining) ->
{ remaining })
int31
let pp ppf { remaining } =
Format.pp_print_int 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
let encoding_cost =
let open Data_encoding in
conv
(fun { allocations ; steps } ->
(allocations, steps))
(fun (allocations, steps) ->
{ allocations ; steps })
(obj2
(req "allocations" int31)
(req "steps" int31))
let pp_cost ppf { allocations ; steps } =
Format.fprintf ppf
"(steps: %d, allocs: %d)"
steps allocations
type error += Quota_exceeded
let check_error gas =
if Compare.Int.(gas.remaining <= 0)
then error Quota_exceeded
else ok ()
let check gas =
Lwt.return @@ check_error gas
let used ~original ~current =
{ remaining = original.remaining - current.remaining }
let consume t cost =
{ remaining =
t.remaining
- 2 * cost.allocations
- 1 * cost.steps }
let consume_check gas cost =
let gas = consume gas cost in
check gas >>|? fun () ->
gas
let consume_check_error gas cost =
let gas = consume gas cost in
check_error gas >|? fun () ->
gas
(* Cost for heap allocating n words of data. *)
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 ;
steps = n }
let free =
{ allocations = 0 ;
steps = 0 }
let ( +@ ) x y =
{ allocations = x.allocations + y.allocations ;
steps = x.steps + y.steps }
let ( *@ ) x y =
{ allocations = x * y.allocations ;
steps = x * y.steps }
(* f should fail if it does not receive sufficient gas *)
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 ~cycle_cost gas f acc tl
(* f should fail if it does not receive sufficient gas *)
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 ~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 gas f base l =
consume_check_error gas cycle_cost >>? fun gas ->
match l with
| [] -> ok (base, gas)
| hd :: tl ->
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 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 ~cycle_cost gas f acc tl
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"quotaExceededRuntimeError"
~title: "Quota exceeded (runtime script error)"
~description:
"A script or one of its callee took too much \
time or storage space"
empty
(function Quota_exceeded -> Some () | _ -> None)
(fun () -> Quota_exceeded) ;

100
src/proto_alpha/lib_protocol/src/gas_repr.ml Normal file
View File

@ -0,0 +1,100 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t =
| Unaccounted
| Limited of { remaining : int }
type cost =
{ allocations : int ;
steps : int }
let encoding =
let open Data_encoding in
union
[ case (Tag 0) int31
(function Limited { remaining } -> Some remaining | _ -> None)
(fun remaining -> Limited { remaining }) ;
case (Tag 1) (constant "unaccounted")
(function Unaccounted -> Some () | _ -> None)
(fun () -> Unaccounted) ]
let pp ppf = function
| Unaccounted ->
Format.fprintf ppf "unaccounted"
| Limited { remaining } ->
Format.fprintf ppf "%d units remaining" remaining
let cost_encoding =
let open Data_encoding in
conv
(fun { allocations ; steps } ->
(allocations, steps))
(fun (allocations, steps) ->
{ allocations ; steps })
(obj2
(req "allocations" int31)
(req "steps" int31))
let pp_cost ppf { allocations ; steps } =
Format.fprintf ppf
"(steps: %d, allocs: %d)"
steps allocations
type error += Quota_exceeded
let consume t cost = match t with
| Unaccounted -> ok Unaccounted
| Limited { remaining } ->
let remaining =
remaining
- 2 * cost.allocations
- 1 * cost.steps in
if Compare.Int.(remaining <= 0)
then error Quota_exceeded
else ok (Limited { remaining })
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)
let step_cost n =
{ allocations = 0 ;
steps = n }
let free =
{ allocations = 0 ;
steps = 0 }
let ( +@ ) x y =
{ allocations = x.allocations + y.allocations ;
steps = x.steps + y.steps }
let ( *@ ) x y =
{ allocations = x * y.allocations ;
steps = x * y.steps }
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"quotaExceededRuntimeError"
~title: "Quota exceeded (runtime script error)"
~description:
"A script or one of its callee took too much \
time or storage space"
empty
(function Quota_exceeded -> Some () | _ -> None)
(fun () -> Quota_exceeded) ;

46
src/proto_alpha/lib_protocol/src/gas.mli → src/proto_alpha/lib_protocol/src/gas_repr.mli
View File

@ -7,30 +7,21 @@
(* *)
(**************************************************************************)
type t
type cost
val consume : t -> cost -> t
type t =
| Unaccounted
| Limited of { remaining : int }
val encoding : t Data_encoding.encoding
val pp : Format.formatter -> t -> unit
val encoding_cost : cost Data_encoding.encoding
type cost
val cost_encoding : cost Data_encoding.encoding
val pp_cost : Format.formatter -> cost -> unit
val check : t -> unit tzresult Lwt.t
val consume_check : t -> cost -> t tzresult Lwt.t
val check_error : t -> unit tzresult
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 consume : t -> cost -> t tzresult
val free : cost
val step_cost : int -> cost
@ -38,24 +29,5 @@ val alloc_cost : int -> cost
val alloc_bytes_cost : int -> cost
val alloc_bits_cost : int -> cost
val max_gas : t
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 ->
t ->
(t -> 'a -> 'b -> ('b * t) tzresult Lwt.t) ->
'b -> 'a list -> ('b * t) tzresult Lwt.t
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 ->
t ->
(t -> 'a -> 'b -> ('b * t) tzresult) ->
'b -> 'a list -> ('b * t) tzresult
val ( *@ ) : int -> cost -> cost
val ( +@ ) : cost -> cost -> cost

52
src/proto_alpha/lib_protocol/src/helpers_services.ml
View File

@ -79,7 +79,7 @@ module S = struct
~query: RPC_query.empty
~input: (obj2
(req "program" Script.expr_encoding)
(opt "gas" Gas.encoding))
(opt "gas" int31))
~output: (obj2
(req "type_map" Script_tc_errors_registration.type_map_enc)
(req "gas" Gas.encoding))
@ -93,7 +93,7 @@ module S = struct
~input: (obj3
(req "data" Script.expr_encoding)
(req "type" Script.expr_encoding)
(opt "gas" Gas.encoding))
(opt "gas" int31))
~output: (obj1 (req "gas" Gas.encoding))
RPC_path.(custom_root / "typecheck_data")
@ -105,7 +105,7 @@ module S = struct
~input: (obj3
(req "data" Script.expr_encoding)
(req "type" Script.expr_encoding)
(opt "gas" Gas.encoding))
(opt "gas" int31))
~output: (obj2
(req "hash" string)
(req "gas" Gas.encoding))
@ -178,53 +178,53 @@ let () =
register0 S.run_code begin fun ctxt () parameters ->
let (code, storage, input, amount, contract, gas, origination_nonce) =
I.run_parameters ctxt parameters in
let ctxt = if Compare.Int.(gas > 0) then Gas.set_limit ctxt gas else Gas.set_unlimited ctxt in
Script_interpreter.execute
origination_nonce
contract (* transaction initiator *)
contract (* script owner *)
ctxt { storage ; code } amount input
(Gas.of_int gas) >>=? fun (sto, ret, _gas, _ctxt, _, maybe_big_map_diff) ->
ctxt { storage ; code } amount input >>=? fun (sto, ret, _ctxt, _, maybe_big_map_diff) ->
return (sto, ret,
Option.map maybe_big_map_diff
~f:Script_ir_translator.to_printable_big_map)
~f:(Script_ir_translator.to_printable_big_map ctxt))
end ;
register0 S.trace_code begin fun ctxt () parameters ->
let (code, storage, input, amount, contract, gas, origination_nonce) =
I.run_parameters ctxt parameters in
let ctxt = if Compare.Int.(gas > 0) then Gas.set_limit ctxt gas else Gas.set_unlimited ctxt in
Script_interpreter.trace
origination_nonce
contract (* transaction initiator *)
contract (* script owner *)
ctxt { storage ; code } amount input
(Gas.of_int gas) >>=? fun ((sto, ret, _gas, _ctxt, _, maybe_big_map_diff), trace) ->
>>=? fun ((sto, ret, _ctxt, _, maybe_big_map_diff), trace) ->
return (sto, ret, trace,
Option.map maybe_big_map_diff
~f:Script_ir_translator.to_printable_big_map)
~f:(Script_ir_translator.to_printable_big_map ctxt))
end ;
register0 S.typecheck_code begin fun ctxt () (expr, maybe_gas) ->
Script_ir_translator.typecheck_code ctxt
(match maybe_gas with
| None -> Gas.of_int (Constants.max_gas ctxt)
| Some gas -> gas)
expr
let ctxt = match maybe_gas with
| None -> Gas.set_unlimited ctxt
| Some gas -> Gas.set_limit ctxt gas in
Script_ir_translator.typecheck_code ctxt expr >>=? fun (res, ctxt) ->
return (res, Gas.level ctxt)
end ;
register0 S.typecheck_data begin fun ctxt () (data, ty, maybe_gas) ->
Script_ir_translator.typecheck_data ctxt
(match maybe_gas with
| None -> Gas.of_int (Constants.max_gas ctxt)
| Some gas -> gas)
(data, ty)
let ctxt = match maybe_gas with
| None -> Gas.set_unlimited ctxt
| Some gas -> Gas.set_limit ctxt gas in
Script_ir_translator.typecheck_data ctxt (data, ty) >>=? fun ctxt ->
return (Gas.level ctxt)
end ;
register0 S.hash_data begin fun ctxt () (expr, typ, maybe_gas) ->
let open Script_ir_translator in
Lwt.return @@
parse_ty
(match maybe_gas with
| None -> Gas.of_int (Constants.max_gas ctxt)
| Some gas -> gas)
false (Micheline.root typ) >>=? fun ((Ex_ty typ, _), gas) ->
parse_data ctxt gas typ (Micheline.root expr) >>=? fun (data, gas) ->
Lwt.return @@ Script_ir_translator.hash_data gas typ data
let ctxt = match maybe_gas with
| None -> Gas.set_unlimited ctxt
| Some gas -> Gas.set_limit ctxt gas in
Lwt.return (parse_ty ctxt false (Micheline.root typ)) >>=? fun ((Ex_ty typ, _), ctxt) ->
parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) ->
Lwt.return (Script_ir_translator.hash_data ctxt typ data) >>=? fun (hash, ctxt) ->
return (hash, Gas.level ctxt)
end ;
register1 S.level begin fun ctxt raw () offset ->
return (Level.from_raw ctxt ?offset raw)

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

@ -37,16 +37,16 @@ val trace_code:
val typecheck_code:
'a #RPC_context.simple ->
'a -> (Script.expr * Gas.t option) ->
'a -> (Script.expr * int option) ->
(Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t
val typecheck_data:
'a #RPC_context.simple ->
'a -> Script.expr * Script.expr * (Gas.t option) -> Gas.t shell_tzresult Lwt.t
'a -> Script.expr * Script.expr * int option -> Gas.t shell_tzresult Lwt.t
val hash_data:
'a #RPC_context.simple ->
'a -> Script.expr * Script.expr * (Gas.t option) -> (string * Gas.t) shell_tzresult Lwt.t
'a -> Script.expr * Script.expr * int option -> (string * Gas.t) shell_tzresult Lwt.t
val level:
'a #RPC_context.simple ->

1
src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml
View File

@ -181,7 +181,6 @@ module Cost_of = struct
(* 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

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

@ -74,7 +74,6 @@ module Cost_of : sig
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

11
src/proto_alpha/lib_protocol/src/raw_context.ml
View File

@ -19,6 +19,7 @@ type t = {
endorsements_received: Int_set.t;
fees: Tez_repr.t ;
rewards: Tez_repr.t ;
gas: Gas_repr.t;
}
type context = t
@ -47,6 +48,14 @@ let add_rewards ctxt rewards =
let get_rewards ctxt = ctxt.rewards
let get_fees ctxt = ctxt.fees
let set_gas_limit ctxt remaining = { ctxt with gas = Limited { remaining } }
let set_gas_unlimited ctxt = { ctxt with gas = Unaccounted }
let consume_gas ctxt cost =
Gas_repr.consume ctxt.gas cost >>? fun gas ->
ok { ctxt with gas }
let gas_level ctxt = ctxt.gas
type storage_error =
| Incompatible_protocol_version of string
| Missing_key of string list * [`Get | `Set | `Del | `Copy]
@ -263,6 +272,7 @@ let prepare ~level ~timestamp ~fitness ctxt =
endorsements_received = Int_set.empty ;
fees = Tez_repr.zero ;
rewards = Tez_repr.zero ;
gas = Unaccounted ;
}
let check_first_block ctxt =
@ -307,6 +317,7 @@ let register_resolvers enc resolve =
endorsements_received = Int_set.empty ;
fees = Tez_repr.zero ;
rewards = Tez_repr.zero ;
gas = Unaccounted ;
} in
resolve faked_context str in
Context.register_resolver enc resolve

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

@ -73,6 +73,11 @@ val add_rewards: context -> Tez_repr.t -> context tzresult Lwt.t
val get_fees: context -> Tez_repr.t
val get_rewards: context -> Tez_repr.t
val set_gas_limit: t -> int -> t
val set_gas_unlimited: t -> t
val consume_gas: t -> Gas_repr.cost -> t tzresult
val gas_level: t -> Gas_repr.t
(** {1 Generic accessors} *************************************************)
type key = string list

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

File diff suppressed because it is too large Load Diff

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

@ -20,14 +20,14 @@ val execute:
Contract.origination_nonce ->
Contract.t -> Contract.t -> Alpha_context.t ->
Script.t -> Tez.t ->
Script.expr -> Gas.t ->
(Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce *
Script.expr ->
(Script.expr * Script.expr * context * Contract.origination_nonce *
Script_typed_ir.ex_big_map option) tzresult Lwt.t
val trace:
Contract.origination_nonce ->
Contract.t -> Contract.t -> Alpha_context.t ->
Script.t -> Tez.t ->
Script.expr -> Gas.t ->
((Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) *
Script.expr ->
((Script.expr * Script.expr * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) *
(Script.location * Gas.t * Script.expr list) list) tzresult Lwt.t

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

File diff suppressed because it is too large Load Diff

36
src/proto_alpha/lib_protocol/src/script_ir_translator.mli
View File

@ -39,14 +39,14 @@ val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_t
val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num
val big_map_mem :
context -> Gas.t -> Contract.t -> 'key ->
context -> Contract.t -> 'key ->
('key, 'value) Script_typed_ir.big_map ->
(bool * Gas.t) tzresult Lwt.t
(bool * context) tzresult Lwt.t
val big_map_get :
context -> Gas.t ->
context ->
Contract.t -> 'key ->
('key, 'value) Script_typed_ir.big_map ->
('value option * Gas.t) tzresult Lwt.t
('value option * context) tzresult Lwt.t
val big_map_update :
'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map ->
('key, 'value) Script_typed_ir.big_map
@ -57,42 +57,42 @@ val ty_eq :
val parse_data :
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Gas.t -> 'a Script_typed_ir.ty -> Script.node -> ('a * Gas.t) tzresult Lwt.t
context -> 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t
val unparse_data :
Gas.t -> 'a Script_typed_ir.ty -> 'a -> (Script.node * Gas.t) tzresult
context -> 'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult
val parse_ty :
Gas.t -> bool -> Script.node ->
((ex_ty * Script_typed_ir.annot) * Gas.t) tzresult
context -> bool -> Script.node ->
((ex_ty * Script_typed_ir.annot) * context) tzresult
val unparse_ty :
string option -> 'a Script_typed_ir.ty -> Script.node
val parse_toplevel
: Gas.t -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * Gas.t) tzresult
: context -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * context) tzresult
val typecheck_code :
context -> Gas.t -> Script.expr -> (type_map * Gas.t) tzresult Lwt.t
context -> Script.expr -> (type_map * context) tzresult Lwt.t
val typecheck_data :
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Gas.t -> Script.expr * Script.expr -> Gas.t tzresult Lwt.t
context -> Script.expr * Script.expr -> context tzresult Lwt.t
val parse_script :
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Gas.t -> Script.t -> (ex_script * Gas.t) tzresult Lwt.t
context -> Script.t -> (ex_script * context) tzresult Lwt.t
val hash_data : Gas.t -> 'a Script_typed_ir.ty -> 'a -> (string * Gas.t) tzresult
val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (string * context) tzresult
val extract_big_map : 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option
val to_serializable_big_map :
Gas.t -> Script_typed_ir.ex_big_map ->
(Contract_storage.big_map_diff * Gas.t) tzresult Lwt.t
context -> Script_typed_ir.ex_big_map ->
(Contract_storage.big_map_diff * context) tzresult Lwt.t
val to_printable_big_map :
Script_typed_ir.ex_big_map ->
context -> Script_typed_ir.ex_big_map ->
(Script.expr * Script.expr option) list
val erase_big_map_initialization :
context -> Gas.t -> Script.t ->
(Script.t * Contract_storage.big_map_diff option * Gas.t) tzresult Lwt.t
context -> Script.t ->
(Script.t * Contract_storage.big_map_diff option * context) tzresult Lwt.t

6
src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml
View File

@ -29,10 +29,12 @@ let type_map_enc =
let ex_ty_enc =
Data_encoding.conv
(fun (Ex_ty ty) -> strip_locations (unparse_ty None ty))
(fun expr ->
(fun _expr ->
(* (* code temporarily deactivated *)
match parse_ty (Gas.of_int 10000000000) true (root expr) with
| Ok ((Ex_ty ty, _), _) -> Ex_ty ty
| _ -> Ex_ty Unit_t (* FIXME: ? *))
| _ -> *)
Ex_ty Unit_t (* FIXME: ? *))
Script.expr_encoding
(* main registration *)

5
src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml
View File

@ -29,10 +29,11 @@ let execute_code_pred
let hash = Operation.hash apply_op in
let dummy_nonce = Contract.initial_origination_nonce hash in
let amount = Tez.zero in
let gaz = Gas.of_int (Alpha_context.Constants.max_gas tc) in
let gas = Proto_alpha.Alpha_context.Constants.max_gas tc in
let tc = Proto_alpha.Alpha_context.Gas.set_limit tc gas in
let return = Script_interpreter.execute
dummy_nonce op.contract dst
tc script amount argument gaz in
tc script amount argument in
return

2
src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli
View File

@ -13,6 +13,6 @@ open Alpha_context
val init_amount : int
val execute_code_pred :
?tc:Alpha_context.t -> Helpers_block.result -> Script.t -> Script.expr ->
(Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option)
(Script.expr * Script.expr * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option)
proto_tzresult Lwt.t

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

@ -42,11 +42,11 @@ let code = {|
let storage = {| Pair { Elt "A" 1 ; Elt "B" 2 } Unit |}
let expect_big_map tc contract print_key ?(gas=Proto_alpha.Gas.max_gas) key_type print_data data_type contents =
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 gas key_type n >>=? fun (key, gas) ->
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 ->
match data, exp with
| None, None ->
@ -56,11 +56,11 @@ let expect_big_map tc contract print_key ?(gas=Proto_alpha.Gas.max_gas) key_type
debug " - big_map[%a] is not defined (error)" print_key n ;
Helpers_assert.fail_msg "Wrong big map contents"
| Some data, None ->
Proto_alpha.Script_ir_translator.parse_data tc gas data_type (Micheline.root data) >>=? fun (data, _gas) ->
Proto_alpha.Script_ir_translator.parse_data tc data_type (Micheline.root data) >>=? fun (data, _tc) ->
debug " - big_map[%a] = %a (error)" print_key n print_data data ;
Helpers_assert.fail_msg "Wrong big map contents"
| Some data, Some exp ->
Proto_alpha.Script_ir_translator.parse_data tc gas data_type (Micheline.root data) >>=? fun (data, _gas) ->
Proto_alpha.Script_ir_translator.parse_data tc data_type (Micheline.root data) >>=? fun (data, _tc) ->
debug " - big_map[%a] = %a (expected %a)" print_key n print_data data print_data exp ;
Helpers_assert.equal data exp ;
return ())

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

@ -48,7 +48,7 @@ let quote s = "\"" ^ s ^ "\""
let parse_execute sb ?tc code_str param_str storage_str =
let param = parse_param param_str in
let script = parse_script code_str storage_str in
Script.execute_code_pred ?tc sb script param >>=?? fun (ret, st, _, tc, nonce, bgm) ->
Script.execute_code_pred ?tc sb script param >>=?? fun (ret, st, tc, nonce, bgm) ->
let contracts = Contract.originated_contracts nonce in
return (ret, st, tc, contracts, bgm)
@ -85,8 +85,8 @@ let test_print ctxt fn s i =
return ()
let test_output ctxt ?location (file_name: string) (storage: string) (input: string) (expected_output: string) =
test ctxt file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts, _bgm) ->
let test_output ctxt ?tc ?location (file_name: string) (storage: string) (input: string) (expected_output: string) =
test ?tc ctxt file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts, _bgm) ->
let output = string_of_canon output_prim in
let msg = Option.unopt ~default:"strings aren't equal" location in
Assert.equal_string ~msg expected_output output ;
@ -287,7 +287,7 @@ let test_example () =
test_output ~location: __LOC__ "exec_concat" "Unit" "\"test\"" "\"test_abc\"" >>=? fun _ ->
(* Get current steps to quota *)
test_output ~location: __LOC__ "steps_to_quota" "Unit" "Unit" "39973" >>=? fun _ ->
test_output ~location: __LOC__ "steps_to_quota" "Unit" "Unit" "39968" >>=? fun _ ->
let bootstrap_0 = List.nth Account.bootstrap_accounts 0 in
get_balance_res bootstrap_0 sb >>=?? fun _balance ->
@ -436,7 +436,7 @@ let test_example () =
let contract = List.hd cs in
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, _, _, _, _) ->
Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun (_, ret, _, _, _) ->
Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ;
(* Test DEFAULT_ACCOUNT *)