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

Alpha, Michelson: gas in typechecking

Browse Source
This commit is contained in:
Milo Davis 2018-02-09 22:28:32 -05:00 committed by Grégoire Henry
parent 77eaca79e5
commit 8a49bf5509
16 changed files with 968 additions and 508 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
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 39991
assert_output $contract_dir/steps_to_quota.tz Unit Unit 39973
# Get the current balance of the contract
assert_output $contract_dir/balance.tz Unit Unit '"4,000,000"'
@ -416,7 +416,7 @@ assert_fails $client typecheck data '{ "A" ; "B" ; "B" }' against type '(set str
# Test hash consistency between Michelson and the CLI
hash_result=`$client hash data '(Pair "22220.00" (Pair "2017-12-13T04:49:00Z" 034))' \
of type '(pair tez (pair timestamp int))'`
of type '(pair tez (pair timestamp int))' | grep expr`
assert_output $contract_dir/hash_consistency_checker.tz Unit \
'(Pair "22220.00" (Pair "2017-12-13T04:49:00Z" 034))' "$hash_result"

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

@ -117,33 +117,34 @@ let trace
Alpha_services.Helpers.trace_code cctxt
block program.expanded (storage.expanded, input.expanded, amount, contract)
let hash_and_sign (data : Michelson_v1_parser.parsed) (typ : Michelson_v1_parser.parsed) sk block cctxt =
Alpha_services.Helpers.hash_data cctxt block (data.expanded, typ.expanded) >>=? fun hash ->
let hash_and_sign ?gas (data : Michelson_v1_parser.parsed) (typ : Michelson_v1_parser.parsed) sk block cctxt =
Alpha_services.Helpers.hash_data cctxt block (data.expanded, typ.expanded, gas) >>=? fun (hash, gas) ->
Client_keys.sign sk (MBytes.of_string hash) >>=? fun signature ->
let `Hex signature = Signature.to_hex signature in
return (hash, signature)
return (hash, signature, gas)
let typecheck_data
?gas
~(data : Michelson_v1_parser.parsed)
~(ty : Michelson_v1_parser.parsed)
block cctxt =
Alpha_services.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded)
Alpha_services.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded, gas)
let typecheck_program (program : Michelson_v1_parser.parsed) block cctxt =
Alpha_services.Helpers.typecheck_code cctxt block program.expanded
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
~emacs ~show_types ~print_source_on_error ~original_gas
program res (cctxt : #Client_context.printer) =
if emacs then
let type_map, errs = match res with
| Ok type_map -> type_map, []
let type_map, errs, _gas = match res with
| Ok (type_map, gas) -> (type_map, [], Some gas)
| Error (Alpha_environment.Ecoproto_error
(Script_tc_errors.Ill_typed_contract (_, type_map ))
:: _ as errs) ->
type_map, errs
(type_map, errs, None)
| Error errs ->
[], errs in
([], errs, None) in
cctxt#message
"(@[<v 0>(types . %a)@ (errors . %a)@])"
Michelson_v1_emacs.print_type_map (program, type_map)
@ -151,9 +152,11 @@ let print_typecheck_result
return ()
else
match res with
| Ok type_map ->
| Ok (type_map, gas) ->
let program = Michelson_v1_printer.inject_types type_map program in
cctxt#message "Well typed" >>= fun () ->
cctxt#message "@[<v 0>Well typed@,Gas used: %a@,Gas remaining: %a@]"
Gas.pp (Gas.used ~original:original_gas ~current:gas)
Gas.pp gas >>= fun () ->
if show_types then
cctxt#message "%a" Micheline_printer.print_expr program >>= fun () ->
return ()

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

@ -51,31 +51,35 @@ val print_trace_result :
tzresult -> unit tzresult Lwt.t
val hash_and_sign :
?gas:Gas.t ->
Michelson_v1_parser.parsed ->
Michelson_v1_parser.parsed ->
Client_keys.sk_uri ->
Block_services.block ->
#Proto_alpha.full ->
(string * string) tzresult Lwt.t
(string * string * Gas.t) tzresult Lwt.t
val typecheck_data :
?gas:Proto_alpha.Gas.t ->
data:Michelson_v1_parser.parsed ->
ty:Michelson_v1_parser.parsed ->
Block_services.block ->
#Proto_alpha.rpc_context ->
unit tzresult Lwt.t
'a ->
'a #Proto_alpha.Alpha_environment.RPC_context.simple ->
Gas.t tzresult Lwt.t
val typecheck_program :
?gas:Gas.t ->
Michelson_v1_parser.parsed ->
Block_services.block ->
#Proto_alpha.rpc_context ->
Script_tc_errors.type_map tzresult Lwt.t
(Script_tc_errors.type_map * Gas.t) tzresult Lwt.t
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, error list) result ->
(Script_tc_errors.type_map * Gas.t) tzresult ->
#Client_context.printer ->
unit tzresult Lwt.t

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

@ -206,6 +206,11 @@ let report_errors ~details ~show_source ?parsed ppf errs =
print_source (parsed, hilights) ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Alpha_environment.Ecoproto_error Gas.Quota_exceeded :: rest ->
Format.fprintf ppf
"@[<v 0>Gas limit exceeded during typechecking or execution. Try again with a higher gas limit.@]" ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Alpha_environment.Ecoproto_error err :: rest ->
begin match err with
| Apply.Bad_contract_parameter (c, None, _) ->

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

@ -41,6 +41,22 @@ let commands () =
~parameter:"amount"
~doc:"amount of the transfer in \xEA\x9C\xA9"
~default:"0.05" in
let custom_gas_flag =
arg
~long:"gas"
~short:'G'
~doc:"Initial quantity of gas for typechecking and execution"
~placeholder:"gas"
(parameter
(fun _ctx str ->
try
return @@ Proto_alpha.Gas.of_int @@ 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
| Some gas -> return gas in
let data_parameter =
Clic.parameter (fun _ data ->
Lwt.return (Micheline_parser.no_parsing_error
@ -102,17 +118,18 @@ let commands () =
else
run ~amount ~program ~storage ~input cctxt#block cctxt >>= fun res ->
print_run_result cctxt ~show_source ~parsed:program res)) ;
command ~group ~desc: "Ask the node to typecheck a program."
(args3 show_types_switch emacs_mode_switch no_print_source_flag)
(args4 show_types_switch emacs_mode_switch no_print_source_flag custom_gas_flag)
(prefixes [ "typecheck" ; "program" ]
@@ Program.source_param
@@ stop)
(fun (show_types, emacs_mode, no_print_source) program cctxt ->
(fun (show_types, emacs_mode, no_print_source, original_gas) program cctxt ->
match program with
| program, [] ->
typecheck_program program cctxt#block cctxt >>= fun res ->
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)
@ -135,7 +152,7 @@ let commands () =
) ;
command ~group ~desc: "Ask the node to typecheck a data expression."
(args1 no_print_source_flag)
(args2 no_print_source_flag custom_gas_flag)
(prefixes [ "typecheck" ; "data" ]
@@ Clic.param ~name:"data" ~desc:"the data to typecheck"
data_parameter
@ -143,10 +160,13 @@ let commands () =
@@ Clic.param ~name:"type" ~desc:"the expected type"
data_parameter
@@ stop)
(fun no_print_source data ty cctxt ->
Client_proto_programs.typecheck_data ~data ~ty cctxt#block cctxt >>= function
| Ok () ->
cctxt#message "Well typed" >>= fun () ->
(fun (no_print_source, custom_gas) data ty cctxt ->
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 () ->
return ()
| Error errs ->
cctxt#warning "%a"
@ -160,7 +180,7 @@ let commands () =
~desc: "Ask the node to hash a data expression.\n\
The returned hash is the same as what Michelson \
instruction `H` would have produced."
no_options
(args1 custom_gas_flag)
(prefixes [ "hash" ; "data" ]
@@ Clic.param ~name:"data" ~desc:"the data to hash"
data_parameter
@ -168,14 +188,21 @@ let commands () =
@@ Clic.param ~name:"type" ~desc:"type of the data"
data_parameter
@@ stop)
(fun () data typ cctxt ->
(fun custom_gas data typ cctxt ->
resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas ->
Alpha_services.Helpers.hash_data cctxt
cctxt#block (data.expanded, typ.expanded) >>= function
| Ok hash ->
cctxt#message "%S" hash >>= fun () ->
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 () ->
return ()
| Error errs ->
cctxt#warning "%a" pp_print_error errs >>= fun () ->
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:false
?parsed:None)
errs >>= fun () ->
cctxt#error "ill-formed data") ;
command ~group
@ -184,7 +211,7 @@ let commands () =
produce the hash, signs it using a given secret key, and \
displays it using the format expected by Michelson \
instruction `CHECK_SIGNATURE`."
no_options
(args1 custom_gas_flag)
(prefixes [ "hash" ; "and" ; "sign" ; "data" ]
@@ Clic.param ~name:"data" ~desc:"the data to hash"
data_parameter
@ -194,12 +221,21 @@ let commands () =
@@ prefixes [ "for" ]
@@ Client_keys.Secret_key.source_param
@@ stop)
(fun () data typ sk cctxt ->
Client_proto_programs.hash_and_sign data typ sk cctxt#block cctxt >>= begin function
| Ok (hash, signature) ->
cctxt#message "@[<v 0>Hash: %S@,Signature: %S@]" hash signature
(fun gas data typ sk cctxt ->
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@]"
hash signature
Proto_alpha.Gas.pp (Proto_alpha.Gas.used ~original:gas ~current:current_gas)
Proto_alpha.Gas.pp current_gas
| Error errs ->
cctxt#warning "%a" pp_print_error errs >>= fun () ->
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:false
?parsed:None)
errs >>= fun () ->
cctxt#error "ill-formed data"
end >>= return) ;

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

@ -386,35 +386,35 @@ let apply_manager_operation_content
| _ -> fail (Bad_contract_parameter (destination, None, parameters))
end
| Some script ->
let call_contract argument =
let gas = Gas.of_int (Constants.max_gas ctxt) in
let call_contract argument gas =
Script_interpreter.execute
origination_nonce
source destination ctxt script amount argument
(Gas.of_int (Constants.max_gas ctxt))
gas
>>= function
| Ok (storage_res, _res, _steps, ctxt, origination_nonce, maybe_big_map_diff) ->
(* TODO: pay for the steps and the storage diff:
update_script_storage checks the storage cost *)
| Ok (storage_res, _res, gas, ctxt, origination_nonce, maybe_big_map_diff) ->
begin match maybe_big_map_diff with
| None -> return (None, gas)
| Some map ->
Script_ir_translator.to_serializable_big_map gas map >>=? fun (diff, gas) ->
return (Some diff, gas) end >>=? fun (diff, _gas) ->
Contract.update_script_storage
ctxt destination
storage_res
(match maybe_big_map_diff with
| None -> None
| Some map ->
Some (Script_ir_translator.to_serializable_big_map map)) >>=? fun ctxt ->
storage_res diff >>=? fun ctxt ->
Fees.update_script_storage ctxt ~source
destination Script_interpreter.dummy_storage_fee >>=? fun ctxt ->
return (ctxt, origination_nonce, None)
| Error err ->
return (ctxt, origination_nonce, Some err) in
Lwt.return (Script_ir_translator.parse_toplevel script.code) >>=? fun (arg_type, _, _, _) ->
Lwt.return @@ Script_ir_translator.parse_toplevel gas script.code >>=? fun ((arg_type, _, _, _), gas) ->
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)))
call_contract (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))) gas
| Some parameters, _ -> begin
Script_ir_translator.typecheck_data ctxt (parameters, arg_type) >>= function
| Ok () -> call_contract parameters
Script_ir_translator.typecheck_data ctxt gas (parameters, arg_type) >>= function
| Ok gas -> call_contract parameters gas
| Error errs ->
let err = Bad_contract_parameter (destination, Some arg_type, Some parameters) in
return (ctxt, origination_nonce, Some ((err :: errs)))
@ -423,14 +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
begin match script with
| None -> return (None, None)
| None -> return (None, None, gas)
| Some script ->
Script_ir_translator.parse_script ctxt script >>=? fun _ ->
Script_ir_translator.erase_big_map_initialization ctxt script >>=? fun (script, big_map_diff) ->
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) ->
return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee)),
big_map_diff)
end >>=? fun (script, big_map) ->
big_map_diff, gas)
end >>=? fun (script, big_map, _gas) ->
Contract.spend ctxt source credit >>=? fun ctxt ->
Contract.originate ctxt
origination_nonce

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

@ -32,6 +32,9 @@ let pp ppf { remaining } =
let of_int 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
@ -57,20 +60,36 @@ let bits_per_word = 8 * bytes_per_word
let words_of_bits n =
n / bits_per_word
let check gas =
let check_error gas =
if Compare.Int.(gas.remaining <= 0)
then fail Quota_exceeded
else return ()
then error Quota_exceeded
else ok ()
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 }
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 ;
@ -97,6 +116,7 @@ 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
@ -113,9 +133,12 @@ module Cost_of = struct
let branch = step_cost 2
let string length =
alloc_cost (length / bytes_per_word)
let concat s1 s2 =
let (+) = Pervasives.(+) in
alloc_cost ((String.length s1 + String.length s2) / bytes_per_word)
string ((String.length s1 + String.length s2) / bytes_per_word)
(* Cost per cycle of a loop, fold, etc *)
let loop_cycle = step_cost 2
@ -159,7 +182,7 @@ module Cost_of = struct
let set_mem key set = step_cost (set_access key set)
let set_update key _value set =
let set_update key _presence set =
set_access key set * alloc_cost 3
(* for LEFT, RIGHT, SOME *)
@ -247,7 +270,6 @@ module Cost_of = struct
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
@ -281,8 +303,105 @@ module Cost_of = struct
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 =
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
(* f should fail if it does not receive sufficient gas *)
let rec fold_right ?(cycle_cost = Cost_of.loop_cycle) 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) ->
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 =
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) ->
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 =
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
let () =
let open Data_encoding in
register_error_kind

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

@ -21,12 +21,20 @@ val encoding_cost : 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 used : original:t -> current:t -> t
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
@ -52,7 +60,7 @@ module Cost_of : sig
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 -> 'b -> '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
@ -103,5 +111,97 @@ module Cost_of : sig
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 ->
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

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

@ -77,8 +77,12 @@ module S = struct
RPC_service.post_service
~description: "Typecheck a piece of code in the current context"
~query: RPC_query.empty
~input: Script.expr_encoding
~output: Script_tc_errors_registration.type_map_enc
~input: (obj2
(req "program" Script.expr_encoding)
(opt "gas" Gas.encoding))
~output: (obj2
(req "type_map" Script_tc_errors_registration.type_map_enc)
(req "gas" Gas.encoding))
RPC_path.(custom_root / "typecheck_code")
let typecheck_data =
@ -86,19 +90,25 @@ module S = struct
~description: "Check that some data expression is well formed \
and of a given type in the current context"
~query: RPC_query.empty
~input: (obj2
~input: (obj3
(req "data" Script.expr_encoding)
(req "type" Script.expr_encoding))
~output: empty
(req "type" Script.expr_encoding)
(opt "gas" Gas.encoding))
~output: (obj1 (req "gas" Gas.encoding))
RPC_path.(custom_root / "typecheck_data")
let hash_data =
RPC_service.post_service
~description: "Computes the hash of some data expression \
using the same algorithm as script instruction H"
~input: (obj2 (req "data" Script.expr_encoding)
(req "type" Script.expr_encoding))
~output: (obj1 (req "hash" string))
~input: (obj3
(req "data" Script.expr_encoding)
(req "type" Script.expr_encoding)
(opt "gas" Gas.encoding))
~output: (obj2
(req "hash" string)
(req "gas" Gas.encoding))
~query: RPC_query.empty
RPC_path.(custom_root / "hash_data")
@ -191,17 +201,30 @@ let () =
Option.map maybe_big_map_diff
~f:Script_ir_translator.to_printable_big_map)
end ;
register0 S.typecheck_code begin fun ctxt () ->
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
end ;
register0 S.typecheck_data begin fun ctxt () ->
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)
end ;
register0 S.hash_data begin fun ctxt () (expr, typ) ->
register0 S.hash_data begin fun ctxt () (expr, typ, maybe_gas) ->
let open Script_ir_translator in
Lwt.return @@ parse_ty false (Micheline.root typ) >>=? fun (Ex_ty typ, _) ->
parse_data ctxt typ (Micheline.root expr) >>=? fun data ->
return (Script_ir_translator.hash_data typ data)
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
end ;
register1 S.level begin fun ctxt raw () offset ->
return (Level.from_raw ctxt ?offset raw)

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

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

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

@ -69,26 +69,10 @@ let rec unparse_stack
= function
| Empty, Empty_t -> []
| Item (v, rest), Item_t (ty, rest_ty, _) ->
Micheline.strip_locations (unparse_data ty v) :: unparse_stack (rest, rest_ty)
(* f should fail if it does not receive sufficient gas *)
let rec fold_left_gas ?(cycle_cost = Gas.Cost_of.loop_cycle) gas f acc l =
let gas = Gas.consume gas cycle_cost in
Gas.check gas >>=? fun () ->
match l with
| [] -> return (acc, gas)
| hd :: tl -> f gas hd acc >>=? fun (acc, gas) ->
fold_left_gas gas f acc tl
(* f should fail if it does not receive sufficient gas *)
let rec fold_right_gas ?(cycle_cost = Gas.Cost_of.loop_cycle) gas f base l =
let gas = Gas.consume gas cycle_cost in
Gas.check gas >>=? fun () ->
match l with
| [] -> return (base, gas)
| hd :: tl ->
fold_right_gas gas f base tl >>=? fun (acc, gas) ->
f gas hd acc
(* Meant to be more gas than you can consume as this function is only used for debugging/errors *)
match unparse_data (Gas.of_int 1000000000) ty v with
| Ok (data, _) -> (Micheline.strip_locations data) :: (unparse_stack (rest, rest_ty))
| Error _ -> Pervasives.failwith "Internal error: raise gas limit for unparse_stack"
let rec interp
: type p r.
@ -101,7 +85,7 @@ let rec interp
: type b a.
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 ->
fun origination gas ctxt ({ instr ; loc ; _ } as descr) stack ->
let gas = Gas.consume gas Gas.Cost_of.cycle in
Gas.check gas >>=? fun () ->
let logged_return : type a b.
@ -187,7 +171,8 @@ let rec interp
Prim (0, K_return, [ unparse_ty None return_type ], None) ;
Prim (0, K_storage, [ unparse_ty None storage_type ], None) ;
Prim (0, K_code, [ Micheline.root code ], None) ], None)) in
let storage = Micheline.strip_locations (unparse_data storage_type init) in
Lwt.return @@ unparse_data gas storage_type init >>=? fun (storage, gas) ->
let storage = Micheline.strip_locations storage in
Contract.spend_from_script ctxt source credit >>=? fun ctxt ->
Contract.originate ctxt
origination
@ -272,7 +257,7 @@ let rec interp
| If_cons (bt, _), Item (hd :: tl, rest) ->
step origination (Gas.consume gas Gas.Cost_of.branch) ctxt bt (Item (hd, Item (tl, rest)))
| List_map, Item (lam, Item (l, rest)) ->
fold_right_gas gas (fun gas arg (tail, ctxt, origination) ->
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))
@ -293,7 +278,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))) ->
fold_left_gas gas
Gas.fold_left gas
(fun gas arg (partial, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam (arg, partial)
>>=? fun (partial, gas, ctxt, origination) ->
@ -301,14 +286,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) ->
fold_left_gas ~cycle_cost:Gas.Cost_of.list_size gas
Gas.fold_left ~cycle_cost:Gas.Cost_of.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) ->
fold_left_gas gas
Gas.fold_left gas
(fun gas arg (stack, ctxt, origination) ->
step origination gas ctxt body (Item (arg, stack))
>>=? fun (stack, gas, ctxt, origination) ->
@ -323,7 +308,7 @@ let rec interp
Gas.check gas >>=? fun () ->
let items =
List.rev (set_fold (fun e acc -> e :: acc) set []) in
fold_left_gas gas
Gas.fold_left gas
(fun gas arg (partial, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam (arg, partial)
>>=? fun (partial, gas, ctxt, origination) ->
@ -331,7 +316,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) ->
fold_left_gas gas
Gas.fold_left gas
(fun gas arg (stack, ctxt, origination) ->
step origination gas ctxt body (Item (arg, stack))
>>=? fun (stack, gas, ctxt, origination) ->
@ -353,7 +338,7 @@ let rec interp
Gas.check gas >>=? fun () ->
let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
fold_left_gas gas
Gas.fold_left gas
(fun gas (k, v) (acc, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam (k, v)
>>=? fun (ret, gas, ctxt, origination) ->
@ -365,7 +350,7 @@ let rec interp
Gas.check gas >>=? fun () ->
let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
fold_left_gas gas
Gas.fold_left gas
(fun gas arg (partial, ctxt, origination) ->
interp ?log origination gas orig source amount ctxt lam (arg, partial)
>>=? fun (partial, gas, ctxt, origination) ->
@ -377,7 +362,7 @@ let rec interp
Gas.check gas >>=? fun () ->
let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
fold_left_gas gas
Gas.fold_left gas
(fun gas arg (stack, ctxt, origination) ->
step origination gas ctxt body (Item (arg, stack))
>>=? fun (stack, gas, ctxt, origination) ->
@ -396,12 +381,12 @@ let rec interp
| Big_map_mem, Item (key, Item (map, rest)) ->
let gas = Gas.consume gas (Gas.Cost_of.big_map_mem key map) in
Gas.check gas >>=? fun () ->
Script_ir_translator.big_map_mem ctxt source key map >>= fun res ->
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
Gas.check gas >>=? fun () ->
Script_ir_translator.big_map_get ctxt source key map >>=? fun res ->
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
@ -654,10 +639,16 @@ let rec interp
Contract.spend_from_script ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? fun destination_script ->
let sto = Micheline.strip_locations (unparse_data storage_type storage) in
Contract.update_script_storage ctxt source sto
(Option.map ~f:Script_ir_translator.to_serializable_big_map
(Script_ir_translator.extract_big_map storage_type storage)) >>=? fun ctxt ->
Lwt.return (unparse_data gas storage_type storage) >>=? fun (sto, gas) ->
let sto = Micheline.strip_locations sto in
begin match Script_ir_translator.extract_big_map storage_type storage with
| None ->
return (None, gas)
| Some diff ->
Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) ->
return (Some diff, gas)
end >>=? fun (diff, gas) ->
Contract.update_script_storage ctxt source sto diff >>=? fun ctxt ->
Fees.update_script_storage ctxt ~source:orig source dummy_storage_fee >>=? fun ctxt ->
begin match destination_script with
| None ->
@ -666,22 +657,28 @@ let rec interp
record_trace (Invalid_contract (loc, destination))) >>=? fun Eq ->
return (ctxt, gas, origination)
| Some script ->
let p = unparse_data tp p in
Lwt.return @@ unparse_data gas tp p >>=? fun (p, gas) ->
execute origination source destination ctxt script amount p gas
>>=? fun (csto, ret, gas, ctxt, origination, maybe_diff) ->
Contract.update_script_storage ctxt destination csto
(Option.map ~f:Script_ir_translator.to_serializable_big_map maybe_diff) >>=? fun ctxt ->
begin match maybe_diff with
| None ->
return (None, gas)
| Some diff ->
Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) ->
return (Some diff, gas)
end >>=? fun (maybe_diff, gas) ->
Contract.update_script_storage ctxt destination csto maybe_diff >>=? fun ctxt ->
trace
(Invalid_contract (loc, destination))
(parse_data ctxt Unit_t ret) >>=? fun () ->
(parse_data ctxt gas Unit_t ret) >>=? fun ((), gas) ->
Fees.update_script_storage ctxt ~source:orig
destination dummy_storage_fee >>=? fun ctxt ->
return (ctxt, gas, origination)
end >>=? fun (ctxt, gas, origination) ->
Contract.get_script ctxt source >>=? (function
| None -> assert false
| Some { storage } ->
parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto ->
| Some { storage; _ } ->
parse_data ctxt gas storage_type (Micheline.root storage) >>=? fun (sto, gas) ->
logged_return ~origination (Item ((), Item (sto, Empty)), gas, ctxt))
end
| Transfer_tokens storage_type,
@ -693,27 +690,38 @@ let rec interp
Contract.get_script ctxt destination >>=? function
| None -> fail (Invalid_contract (loc, destination))
| Some script ->
let maybe_diff = Script_ir_translator.(
Option.map ~f:to_serializable_big_map
@@ extract_big_map storage_type sto) in
let sto = Micheline.strip_locations (unparse_data storage_type sto) in
begin match extract_big_map storage_type sto with
| None ->
return (None, gas)
| Some diff ->
to_serializable_big_map gas diff >>=? fun (diff, gas) ->
return (Some diff, gas)
end >>=? fun (maybe_diff, gas) ->
Lwt.return (unparse_data gas storage_type sto) >>=? fun (sto, gas) ->
let sto = Micheline.strip_locations sto in
Contract.update_script_storage ctxt source sto maybe_diff >>=? fun ctxt ->
Fees.update_script_storage ctxt ~source:orig
source dummy_storage_fee >>=? fun ctxt ->
let p = unparse_data tp p in
Lwt.return (unparse_data gas tp p) >>=? fun (p, gas) ->
execute origination source destination ctxt script amount p gas
>>=? fun (sto, ret, gas, ctxt, origination, maybe_diff) ->
Contract.update_script_storage ctxt destination sto
(Option.map ~f:Script_ir_translator.to_serializable_big_map maybe_diff) >>=? fun ctxt ->
begin match maybe_diff with
| None ->
return (None, gas)
| Some diff ->
Script_ir_translator.to_serializable_big_map gas diff >>=? fun (diff, gas) ->
return (Some diff, gas)
end >>=? fun (diff, gas) ->
Contract.update_script_storage ctxt destination sto diff >>=? fun ctxt ->
Fees.update_script_storage ctxt ~source:orig
destination dummy_storage_fee >>=? fun ctxt ->
trace
(Invalid_contract (loc, destination))
(parse_data ctxt tr ret) >>=? fun v ->
(parse_data ctxt gas tr ret) >>=? fun (v, gas) ->
Contract.get_script ctxt source >>=? (function
| None -> assert false
| Some { storage } ->
parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto ->
| Some { storage ; _ } ->
parse_data ctxt gas storage_type (Micheline.root storage) >>=? fun (sto, gas) ->
logged_return ~origination (Item (v, Item (sto, Empty)), gas, ctxt))
end
| Create_account,
@ -771,9 +779,8 @@ let rec interp
| Hash_key, Item (key, rest) ->
logged_return (Item (Signature.Public_key.hash key, rest), Gas.consume gas Gas.Cost_of.hash_key, ctxt)
| H ty, Item (v, rest) ->
let gas = Gas.consume gas (Gas.Cost_of.hash v) in
Gas.check gas >>=? fun () ->
let hash = hash_data ty v in
Gas.consume_check gas (Gas.Cost_of.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
@ -804,17 +811,17 @@ let rec interp
and execute ?log origination orig source ctxt script amount arg gas :
(Script.expr * Script.node * Gas.t * context * Contract.origination_nonce *
Script_typed_ir.ex_big_map option) tzresult Lwt.t =
parse_script ctxt script
>>=? fun (Ex_script { code; arg_type; ret_type; storage; storage_type }) ->
parse_data ctxt arg_type arg >>=? fun arg ->
parse_script ctxt gas script
>>=? fun ((Ex_script { code; arg_type; ret_type; storage; storage_type }), gas) ->
parse_data ctxt gas arg_type arg >>=? fun (arg, gas) ->
trace
(Runtime_contract_error (source, script.code))
(interp ?log origination gas orig source amount ctxt code (arg, storage))
>>=? fun ((ret, storage), gas, ctxt, origination) ->
return (Micheline.strip_locations (unparse_data storage_type storage),
unparse_data ret_type ret,
gas, ctxt, origination,
Script_ir_translator.extract_big_map storage_type storage)
>>=? fun ((ret, sto), gas, ctxt, origination) ->
Lwt.return @@ unparse_data gas storage_type sto >>=? fun (storage, gas) ->
Lwt.return @@ unparse_data gas ret_type ret >>=? fun (ret, gas) ->
return (Micheline.strip_locations storage, ret, gas, ctxt, origination,
Script_ir_translator.extract_big_map storage_type sto)
let trace origination orig source ctxt script amount arg gas =
let log = ref [] in

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

File diff suppressed because it is too large Load Diff

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

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

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

@ -30,8 +30,8 @@ let ex_ty_enc =
Data_encoding.conv
(fun (Ex_ty ty) -> strip_locations (unparse_ty None ty))
(fun expr ->
match parse_ty true (root expr) with
| Ok (Ex_ty ty, _) -> Ex_ty ty
match parse_ty (Gas.of_int 10000000000) true (root expr) with
| Ok ((Ex_ty ty, _), _) -> Ex_ty ty
| _ -> Ex_ty Unit_t (* FIXME: ? *))
Script.expr_encoding

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 key_type print_data data_type contents =
let expect_big_map tc contract print_key ?(gas=Proto_alpha.Gas.max_gas) key_type print_data data_type contents =
let open Proto_alpha.Error_monad in
iter_p
(fun (n, exp) ->
let key = Proto_alpha.Script_ir_translator.hash_data key_type n in
Lwt.return @@ Proto_alpha.Script_ir_translator.hash_data gas key_type n >>=? fun (key, gas) ->
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 key_type print_data data_type contents
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 data_type (Micheline.root data) >>=? fun data ->
Proto_alpha.Script_ir_translator.parse_data tc gas data_type (Micheline.root data) >>=? fun (data, _gas) ->
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 data_type (Micheline.root data) >>=? fun data ->
Proto_alpha.Script_ir_translator.parse_data tc gas data_type (Micheline.root data) >>=? fun (data, _gas) ->
debug " - big_map[%a] = %a (expected %a)" print_key n print_data data print_data exp ;
Helpers_assert.equal data exp ;
return ())

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

@ -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" "39991" >>=? fun _ ->
test_output ~location: __LOC__ "steps_to_quota" "Unit" "Unit" "39973" >>=? fun _ ->
let bootstrap_0 = List.nth Account.bootstrap_accounts 0 in
get_balance_res bootstrap_0 sb >>=?? fun _balance ->