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

Alpha: minor improvements and fixes in gas

Browse Source
This commit is contained in:
Alain Mebsout 2018-06-28 20:54:39 +02:00 committed by Benjamin Canou
parent 7159b92cbd
commit 34d9f7e649
22 changed files with 176 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/lib_data_encoding/data_encoding.ml
View File

@ -100,7 +100,7 @@ struct
splitted ~json ~binary
let make_lazy encoding value =
{ encoding ; state = Value value }
let fold_lazy fun_value fun_bytes fun_combine le =
let apply_lazy ~fun_value ~fun_bytes ~fun_combine le =
match le.state with
| Value value -> fun_value value
| Bytes bytes -> fun_bytes bytes

6
src/lib_data_encoding/data_encoding.mli
View File

@ -510,9 +510,9 @@ module Encoding: sig
(** Make a lazy value from an immediate one. *)
val make_lazy : 'a encoding -> 'a -> 'a lazy_t
(** Fold on structure of lazy value, and combine results *)
val fold_lazy :
('a -> 'b) -> (MBytes.t -> 'b) -> ('b -> 'b -> 'b) ->
(** Apply on structure of lazy value, and combine results *)
val apply_lazy :
fun_value:('a -> 'b) -> fun_bytes:(MBytes.t -> 'b) -> fun_combine:('b -> 'b -> 'b) ->
'a lazy_t -> 'b
end

14
src/lib_error_monad/error_monad.ml
View File

@ -557,6 +557,20 @@ module Make(Prefix : sig val id : string end) = struct
| Error errs -> Lwt.return (Error (err :: errs))
| ok -> Lwt.return ok
let record_trace_eval mk_err result =
match result with
| Ok _ as res -> res
| Error errs ->
mk_err () >>? fun err ->
Error (err :: errs)
let trace_eval mk_err f =
f >>= function
| Error errs ->
mk_err () >>=? fun err ->
Lwt.return (Error (err :: errs))
| ok -> Lwt.return ok
let fail_unless cond exn =
if cond then return_unit else fail exn

6
src/lib_error_monad/error_monad_sig.ml
View File

@ -127,6 +127,12 @@ module type S = sig
(** Automatically enrich error reporting on stack rewind *)
val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
(** Same as record_trace, for unevaluated error *)
val record_trace_eval : (unit -> error tzresult) -> 'a tzresult -> 'a tzresult
(** Same as trace, for unevaluated Lwt error *)
val trace_eval : (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
(** Erroneous return on failed assertion *)
val fail_unless : bool -> error -> unit tzresult Lwt.t
val fail_when : bool -> error -> unit tzresult Lwt.t

4
src/lib_protocol_environment/sigs/v1/data_encoding.mli
View File

@ -198,8 +198,8 @@ val lazy_encoding : 'a encoding -> 'a lazy_t encoding
val force_decode : 'a lazy_t -> 'a option
val force_bytes : 'a lazy_t -> MBytes.t
val make_lazy : 'a encoding -> 'a -> 'a lazy_t
val fold_lazy :
('a -> 'b) -> (MBytes.t -> 'b) -> ('b -> 'b -> 'b) ->
val apply_lazy :
fun_value:('a -> 'b) -> fun_bytes:(MBytes.t -> 'b) -> fun_combine:('b -> 'b -> 'b) ->
'a lazy_t -> 'b
module Json : sig

6
src/lib_protocol_environment/sigs/v1/error_monad.mli
View File

@ -118,6 +118,12 @@ val record_trace : error -> 'a tzresult -> 'a tzresult
(** Automatically enrich error reporting on stack rewind *)
val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
(** Same as record_trace, for unevaluated error *)
val record_trace_eval : (unit -> error tzresult) -> 'a tzresult -> 'a tzresult
(** Same as trace, for unevaluated Lwt error *)
val trace_eval : (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
(** Erroneous return on failed assertion *)
val fail_unless : bool -> error -> unit tzresult Lwt.t

2
src/proto_alpha/lib_client_commands/client_proto_context_commands.ml
View File

@ -129,7 +129,7 @@ let commands () =
| None ->
cctxt#error "This is not a smart contract."
| Some { code ; storage = _ } ->
match Script.force_decode code with
match Script_repr.force_decode code with
| Error errs -> cctxt#error "%a" (Format.pp_print_list ~pp_sep:Format.pp_print_newline Alpha_environment.Error_monad.pp) errs
| Ok (code, _) ->
begin cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped code >>= fun () ->

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

@ -53,6 +53,16 @@ end
module Script = struct
include Michelson_v1_primitives
include Script_repr
let force_decode ctxt lexpr =
Lwt.return
(Script_repr.force_decode lexpr >>? fun (v, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt ->
(v, ctxt))
let force_bytes ctxt lexpr =
Lwt.return
(Script_repr.force_bytes lexpr >>? fun (b, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt ->
(b, ctxt))
end
module Fees = Fees_storage
@ -74,6 +84,7 @@ module Gas = struct
let set_limit = Raw_context.set_gas_limit
let set_unlimited = Raw_context.set_gas_unlimited
let consume = Raw_context.consume_gas
let check_enough = Raw_context.check_enough_gas
let level = Raw_context.gas_level
let consumed = Raw_context.gas_consumed
let block_level = Raw_context.block_gas_level

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

@ -140,6 +140,7 @@ module Gas : sig
val set_limit: context -> Z.t -> context
val set_unlimited: context -> context
val consume: context -> cost -> context tzresult
val check_enough: context -> cost -> unit tzresult
val level: context -> t
val consumed: since: context -> until: context -> Z.t
val block_level: context -> Z.t
@ -311,9 +312,9 @@ module Script : sig
val prim_node_cost_nonrec_of_length : int -> annot -> Gas.cost
val seq_node_cost_nonrec : expr list -> Gas.cost
val seq_node_cost_nonrec_of_length : int -> Gas.cost
val force_decode : lazy_expr -> (expr * Gas.cost) tzresult
val force_bytes : lazy_expr -> (MBytes.t * Gas.cost) tzresult
val minimal_deserialize_cost : lazy_expr -> Gas.cost
val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t
val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t
end
module Constants : sig

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

@ -364,8 +364,8 @@ let apply_manager_operation_content :
match parameters with
| None -> return ctxt
| Some arg ->
Lwt.return (Script.force_decode arg) >>=? fun (arg, _cost_arg (* see [note] *)) ->
(* [note]: for toplevel ops, _cost_* is nil since the
Script.force_decode ctxt arg >>=? fun (arg, ctxt) -> (* see [note] *)
(* [note]: for toplevel ops, cost is nil since the
lazy value has already been forced at precheck, so
we compute and consume the full cost again *)
let cost_arg = Script.deserialized_cost arg in
@ -396,7 +396,7 @@ let apply_manager_operation_content :
let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in
return (ctxt, unit)
| Some parameters ->
Lwt.return (Script.force_decode parameters) >>=? fun (arg, _cost_arg (* see [note] *)) ->
Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *)
let cost_arg = Script.deserialized_cost arg in
Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt ->
return (ctxt, arg)
@ -431,10 +431,10 @@ let apply_manager_operation_content :
begin match script with
| None -> return (None, ctxt)
| Some script ->
Lwt.return (Script.force_decode script.storage) >>=? fun (ustorage, _cost (* see [note] *)) ->
Lwt.return (Gas.consume ctxt (Script.deserialized_cost ustorage)) >>=? fun ctxt ->
Lwt.return (Script.force_decode script.storage) >>=? fun (ucode, _cost (* see [note] *)) ->
Lwt.return (Gas.consume ctxt (Script.deserialized_cost ucode)) >>=? fun ctxt ->
Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *)
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt ->
Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *)
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt ->
Script_ir_translator.parse_script ctxt script >>=? fun (_, ctxt) ->
Script_ir_translator.erase_big_map_initialization ctxt Optimized script >>=? fun (script, big_map_diff, ctxt) ->
return (Some (script, big_map_diff), ctxt)
@ -518,23 +518,21 @@ let precheck_manager_contents
| Transaction { parameters = Some arg ; _ } ->
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
Gas.consume ctxt (Script.minimal_deserialize_cost arg) >>=? fun _ ->
Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
Lwt.return @@ Script.force_decode arg >>=? fun (_arg, cost_arg) ->
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
Gas.consume ctxt cost_arg
trace Gas_quota_exceeded_init_deserialize @@
Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt
| Origination { script = Some script ; _ } ->
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
(Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt ->
Gas.consume ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun _ ->
Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
Lwt.return @@ Script.force_decode script.code >>=? fun (_code, cost_code) ->
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
Gas.consume ctxt cost_code >>=? fun ctxt ->
Lwt.return @@ Script.force_decode script.storage >>=? fun (_storage, cost_storage) ->
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
Gas.consume ctxt cost_storage
trace Gas_quota_exceeded_init_deserialize @@
Script.force_decode ctxt script.code >>=? fun (_code, ctxt) ->
trace Gas_quota_exceeded_init_deserialize @@
Script.force_decode ctxt script.storage >>|? fun (_storage, ctxt) ->
ctxt
| _ -> return ctxt
end >>=? fun ctxt ->
Contract.get_manager_key ctxt source >>=? fun public_key ->

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

@ -168,9 +168,8 @@ let register () =
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
Lwt.return @@ Script.force_decode script.storage >>=? fun (storage, cost_storage) ->
Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun _ctxt ->
unparse_script ctxt Readable script >>=? fun script ->
Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) ->
return_some storage) ;
register_field S.info (fun ctxt contract ->
Contract.get_balance ctxt contract >>=? fun balance ->
@ -186,7 +185,7 @@ let register () =
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
unparse_script ctxt Readable script >>=? fun script ->
return (Some script, ctxt)
end >>=? fun (script, _ctxt) ->
return { manager ; balance ;

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

@ -99,6 +99,10 @@ let consume block_gas operation_gas cost = match operation_gas with
then error Block_quota_exceeded
else ok (block_remaining, Limited { remaining })
let check_enough block_gas operation_gas cost =
consume block_gas operation_gas cost
>|? fun (_block_remainig, _remaining) -> ()
let alloc_cost n =
{ allocations = Z.of_int (n + 1) ;
steps = Z.zero ;

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

@ -23,6 +23,7 @@ type error += Block_quota_exceeded (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
val consume : Z.t -> t -> cost -> (Z.t * t) tzresult
val check_enough : Z.t -> t -> cost -> unit tzresult
val free : cost
val step_cost : int -> cost

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

@ -233,11 +233,14 @@ module Cost_of = struct
let operation b = bytes b
let type_ nb_args = alloc_cost (nb_args + 1)
(* Cost of parsing instruction, is cost of allocation of
constructor + cost of contructor parameters + cost of
allocation on the stack type *)
let instr
: type b a. (b, a) Script_typed_ir.instr -> cost
= fun i ->
let open Script_typed_ir in
alloc_cost 1 +@
alloc_cost 1 +@ (* cost of allocation of constructor *)
match i with
| Drop -> alloc_cost 0
| Dup -> alloc_cost 1

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

@ -173,6 +173,8 @@ let set_gas_unlimited ctxt =
let consume_gas ctxt cost =
Gas_limit_repr.consume ctxt.block_gas ctxt.operation_gas cost >>? fun (block_gas, operation_gas) ->
ok { ctxt with block_gas ; operation_gas }
let check_enough_gas ctxt cost =
Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas cost
let gas_level ctxt = ctxt.operation_gas
let block_gas_level ctxt = ctxt.block_gas
let gas_consumed ~since ~until =
@ -523,6 +525,8 @@ module type T = sig
val consume_gas: context -> Gas_limit_repr.cost -> context tzresult
val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult
val description: context Storage_description.t
end

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

@ -192,6 +192,9 @@ module type T = sig
within a view. *)
val consume_gas: context -> Gas_limit_repr.cost -> context tzresult
(** Check if consume_gas will fail *)
val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult
val description: context Storage_description.t
end

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

@ -694,12 +694,12 @@ let rec interp
(credit, Item
(init, rest)))))) ->
Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt ->
unparse_ty ctxt param_type >>=? fun (u_param_type, ctxt) ->
unparse_ty ctxt storage_type >>=? fun (u_storage_type, ctxt) ->
unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) ->
unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) ->
let code =
Micheline.strip_locations
(Seq (0, [ Prim (0, K_parameter, [ u_param_type ], []) ;
Prim (0, K_storage, [ u_storage_type ], []) ;
(Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ;
Prim (0, K_storage, [ unparsed_storage_type ], []) ;
Prim (0, K_code, [ Micheline.root code ], []) ])) in
unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
let storage = Micheline.strip_locations storage in
@ -788,8 +788,7 @@ and execute ?log ctxt mode ~source ~payer ~self script amount arg :
trace
(Bad_contract_parameter self)
(parse_data ctxt arg_type arg) >>=? fun (arg, ctxt) ->
Lwt.return @@ Script.force_decode script.code >>=? fun (script_code, cost_script_code) ->
Lwt.return @@ Gas.consume ctxt cost_script_code >>=? fun ctxt ->
Script.force_decode ctxt script.code >>=? fun (script_code, ctxt) ->
trace
(Runtime_contract_error (self, script_code))
(interp ?log ctxt ~source ~payer ~self amount code (arg, storage))

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

@ -680,30 +680,14 @@ let comparable_ty_eq
serialize_ty_for_error ctxt (ty_of_comparable_ty tb) >>? fun (tb, _ctxt) ->
error (Inconsistent_types (ta, tb))
let record_trace mk_err result =
match result with
| Ok _ as res -> res
| Error errs ->
mk_err () >>? fun err ->
Error (err :: errs)
let trace mk_err f =
f >>= function
| Error errs ->
mk_err () >>=? fun err ->
Lwt.return (Error (err :: errs))
| ok -> Lwt.return ok
let record_inconsistent ctxt ta tb =
record_trace (fun () ->
record_trace_eval (fun () ->
serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) ->
Inconsistent_types (ta, tb))
let record_inconsistent_type_annotations ctxt loc ta tb =
record_trace (fun () ->
record_trace_eval (fun () ->
serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) ->
Inconsistent_type_annotations (loc, ta, tb))
@ -784,7 +768,7 @@ let rec stack_ty_eq
match ta, tb with
| Item_t (tva, ra, _), Item_t (tvb, rb, _) ->
ty_eq ctxt tva tvb |>
record_trace (fun () -> ok (Bad_stack_item lvl)) >>? fun (Eq, ctxt) ->
record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) ->
stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) ->
(Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
| Empty_t, Empty_t -> Ok (Eq, ctxt)
@ -972,7 +956,7 @@ let merge_branches
serialize_stack_for_error ctxt aftbt >>=? fun (aftbt, ctxt) ->
serialize_stack_for_error ctxt aftbf >>|? fun (aftbf, _ctxt) ->
Unmatched_branches (loc, aftbt, aftbf) in
trace unmatched_branches
trace_eval unmatched_branches
(Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) >>=? fun (Eq, ctxt) ->
Lwt.return (merge_stacks loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) ->
return (
@ -1023,10 +1007,8 @@ let rec parse_comparable_ty
error (Invalid_arity (loc, prim, 0, List.length l))
| Prim (loc, (T_pair | T_or | T_set | T_map
| T_list | T_option | T_lambda
| T_unit | T_signature | T_contract), _, _) as expr ->
parse_ty ctxt ~allow_big_map:false ~allow_operation:false expr >>? fun (Ex_ty ty, ctxt) ->
serialize_ty_for_error ctxt ty >>? fun (ty, _ctxt) ->
error (Comparable_type_expected (loc, ty))
| T_unit | T_signature | T_contract), _, _) ->
error (Comparable_type_expected (loc, Micheline.strip_locations ty))
| expr ->
error @@ unexpected expr [] Type_namespace
[ T_int ; T_nat ;
@ -1055,7 +1037,7 @@ and parse_ty :
parse_type_annot big_map_loc map_annot >>? fun map_name ->
parse_composed_type_annot loc storage_annot
>>? fun (ty_name, map_field, storage_field) ->
Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt ->
Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt ->
let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in
Ex_ty (Pair_t ((big_map_ty, map_field, None),
(remaining_storage, storage_field, None),
@ -1241,7 +1223,7 @@ let rec parse_data
Lwt.return (serialize_ty_for_error ctxt ty) >>|? fun (ty, _ctxt) ->
Invalid_constant (location script_data, strip_locations script_data, ty) in
let traced body =
trace error body in
trace_eval error body in
let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper =
let length = List.length items in
fold_left_s
@ -1315,8 +1297,10 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ Bytes_kind ], kind expr)))
(* Integers *)
| Int_t _, Int (_, v) ->
(* TODO gas *)
return (Script_int.of_zint v, ctxt)
| Nat_t _, Int (_, v) ->
(* TODO gas *)
let v = Script_int.of_zint v in
if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then
return (Script_int.abs v, ctxt)
@ -1340,6 +1324,7 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr)))
(* Timestamps *)
| Timestamp_t _, (Int (_, v)) (* As unparsed with [Optimized] or out of bounds [Readable]. *) ->
(* TODO gas *)
return (Script_timestamp.of_zint v, ctxt)
| Timestamp_t _, String (_, s) (* As unparsed with [Redable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt ->
@ -1488,6 +1473,7 @@ let rec parse_data
traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ]))
(* Lists *)
| List_t (t, _ty_name), Seq (_loc, items) ->
(* TODO gas *)
traced @@
fold_right_s
(fun v (rest, ctxt) ->
@ -1499,6 +1485,7 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Sets *)
| Set_t (t, _ty_name), (Seq (loc, vs) as expr) ->
(* TODO gas *)
let length = List.length vs in
traced @@
fold_left_s
@ -1523,10 +1510,12 @@ let rec parse_data
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Maps *)
| Map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) ->
(* TODO gas *)
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
| Map_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
| Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) ->
(* TODO gas *)
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) ->
({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt)
| Big_map_t (_tk, _tv, _), expr ->
@ -1549,7 +1538,7 @@ and parse_returning
parse_instr ?type_logger tc_context ctxt
script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function
| (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), ctxt) ->
trace
trace_eval
(fun () ->
Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) ->
serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) ->
@ -1572,10 +1561,10 @@ and parse_instr
Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t =
fun ?type_logger tc_context ctxt script_instr stack_ty ->
let check_item check loc name n m =
trace (fun () ->
trace_eval (fun () ->
serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) ->
Bad_stack (loc, name, m, stack_ty)) @@
trace (fun () -> return (Bad_stack_item n)) @@
trace (Bad_stack_item n) @@
Lwt.return check in
let check_item_ty ctxt exp got loc n =
check_item (ty_eq ctxt exp got) loc n in
@ -1765,7 +1754,7 @@ and parse_instr
let invalid_map_body () =
serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) ->
Invalid_map_body (loc, aft) in
trace invalid_map_body
trace_eval invalid_map_body
(Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) ->
typed ctxt loc (List_map ibody)
@ -1788,7 +1777,7 @@ and parse_instr
serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) ->
Invalid_iter_body (loc, rest, aft) in
trace invalid_iter_body
trace_eval invalid_iter_body
(Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) ->
typed ctxt loc (List_iter ibody) rest)
@ -1815,7 +1804,7 @@ and parse_instr
serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) ->
Invalid_iter_body (loc, rest, aft) in
trace invalid_iter_body
trace_eval invalid_iter_body
(Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) ->
typed ctxt loc (Set_iter ibody) rest)
@ -1860,7 +1849,7 @@ and parse_instr
let invalid_map_body () =
serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) ->
Invalid_map_body (loc, aft) in
trace invalid_map_body
trace_eval invalid_map_body
(Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) ->
typed ctxt loc (Map_map ibody)
@ -1886,7 +1875,7 @@ and parse_instr
serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) ->
Invalid_iter_body (loc, rest, aft) in
trace invalid_iter_body
trace_eval invalid_iter_body
(Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) ->
typed ctxt loc (Map_iter ibody) rest)
@ -2000,7 +1989,7 @@ and parse_instr
serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) ->
Unmatched_branches (loc, aft, stack) in
trace unmatched_branches
trace_eval unmatched_branches
(Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) ->
typed ctxt loc (Loop ibody) rest)
@ -2020,7 +2009,7 @@ and parse_instr
serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) ->
Unmatched_branches (loc, aft, stack) in
trace unmatched_branches
trace_eval unmatched_branches
(Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) ->
typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)))
@ -2492,13 +2481,11 @@ and parse_instr
let cannonical_code = fst @@ Micheline.extract_locations code in
Lwt.return @@ parse_toplevel cannonical_code >>=? fun (arg_type, storage_type, code_field) ->
trace
(fun () -> Error_monad.return
(Ill_formed_type (Some "parameter", cannonical_code, location arg_type)))
(Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
(Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)
>>=? fun (Ex_ty arg_type, ctxt) ->
trace
(fun () -> Error_monad.return
(Ill_formed_type (Some "storage", cannonical_code, location storage_type)))
(Ill_formed_type (Some "storage", cannonical_code, location storage_type))
(Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type)
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
@ -2511,7 +2498,7 @@ and parse_instr
Pair_t ((List_t (Operation_t None, None), None, None),
(storage_type, None, None), None) in
trace
(fun () -> Error_monad.return (Ill_typed_contract (cannonical_code, [])))
(Ill_typed_contract (cannonical_code, []))
(parse_returning (Toplevel { storage_type ; param_type = arg_type })
ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=?
fun (Lam ({ bef = Item_t (arg, Empty_t, _) ;
@ -2699,7 +2686,7 @@ and parse_contract
| true ->
Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt ->
trace
(fun () -> return (Invalid_contract (loc, contract))) @@
(Invalid_contract (loc, contract)) @@
Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with
| None ->
Lwt.return
@ -2707,10 +2694,9 @@ and parse_contract
let contract : arg typed_contract = (arg, contract) in
ok (ctxt, contract))
| Some { code ; _ } ->
Script.force_decode ctxt code >>=? fun (code, ctxt) ->
Lwt.return
(Script.force_decode code >>? fun (code, cost_code) ->
Gas.consume ctxt cost_code >>? fun ctxt ->
parse_toplevel code >>? fun (arg_type, _, _) ->
(parse_toplevel code >>? fun (arg_type, _, _) ->
parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ, ctxt) ->
ty_eq ctxt targ arg >>? fun (Eq, ctxt) ->
merge_types ctxt loc targ arg >>? fun (arg, ctxt) ->
@ -2720,7 +2706,7 @@ and parse_contract
and parse_toplevel
: Script.expr -> (Script.node * Script.node * Script.node) tzresult
= fun toplevel ->
record_trace (fun () -> ok (Ill_typed_contract (toplevel, []))) @@
record_trace (Ill_typed_contract (toplevel, [])) @@
match root toplevel with
| Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind))
| String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind))
@ -2765,17 +2751,15 @@ let parse_script
: ?type_logger: type_logger ->
context -> Script.t -> (ex_script * context) tzresult Lwt.t
= fun ?type_logger ctxt { code ; storage } ->
Lwt.return @@ Script.force_decode code >>=? fun (code, cost_code) ->
Lwt.return @@ Gas.consume ctxt cost_code >>=? fun ctxt ->
Lwt.return @@ Script.force_decode storage >>=? fun (storage, cost_storage) ->
Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun ctxt ->
Script.force_decode ctxt code >>=? fun (code, ctxt) ->
Script.force_decode ctxt storage >>=? fun (storage, ctxt) ->
Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) ->
trace
(fun () -> return (Ill_formed_type (Some "parameter", code, location arg_type)))
(Ill_formed_type (Some "parameter", code, location arg_type))
(Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type))
>>=? fun (Ex_ty arg_type, ctxt) ->
trace
(fun () -> return (Ill_formed_type (Some "storage", code, location storage_type)))
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type))
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
@ -2787,13 +2771,13 @@ let parse_script
let ret_type_full =
Pair_t ((List_t (Operation_t None, None), None, None),
(storage_type, None, None), None) in
trace
trace_eval
(fun () ->
Lwt.return @@ serialize_ty_for_error ctxt storage_type >>|? fun (storage_type, _ctxt) ->
Ill_typed_data (None, storage, storage_type))
(parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) ->
trace
(fun () -> return (Ill_typed_contract (code, [])))
(Ill_typed_contract (code, []))
(parse_returning (Toplevel { storage_type ; param_type = arg_type })
ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) ->
return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt)
@ -2805,11 +2789,11 @@ let typecheck_code
let type_map = ref [] in
(* TODO: annotation checking *)
trace
(fun () -> return (Ill_formed_type (Some "parameter", code, location arg_type)))
(Ill_formed_type (Some "parameter", code, location arg_type))
(Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type))
>>=? fun (Ex_ty arg_type, ctxt) ->
trace
(fun () -> return (Ill_formed_type (Some "storage", code, location storage_type)))
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type))
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
@ -2828,7 +2812,7 @@ let typecheck_code
~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map)
(arg_type_full, None) ret_type_full code_field in
trace
(fun () -> return (Ill_typed_contract (code, !type_map)))
(Ill_typed_contract (code, !type_map))
result >>=? fun (Lam _, ctxt) ->
return (!type_map, ctxt)
@ -2837,10 +2821,10 @@ let typecheck_data
context -> Script.expr * Script.expr -> context tzresult Lwt.t
= fun ?type_logger ctxt (data, exp_ty) ->
trace
(fun () -> return (Ill_formed_type (None, exp_ty, 0)))
(Ill_formed_type (None, exp_ty, 0))
(Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false (root exp_ty))
>>=? fun (Ex_ty exp_ty, ctxt) ->
trace
trace_eval
(fun () ->
Lwt.return @@ serialize_ty_for_error ctxt exp_ty >>|? fun (exp_ty, _ctxt) ->
Ill_typed_data (None, data, exp_ty))
@ -2995,6 +2979,7 @@ let rec unparse_data
| Lambda_t _, Lam (_, original_code) ->
unparse_code ctxt mode (root original_code)
(* only used in client, don't account for gas *)
and unparse_code ctxt mode = function
| Prim (loc, I_PUSH, [ ty ; data ], annot) ->
Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) ->
@ -3017,31 +3002,34 @@ and unparse_code ctxt mode = function
return (Prim (loc, prim, List.rev items, annot), ctxt)
| Int _ | String _ | Bytes _ as atom -> return (atom, ctxt)
(* only used in client, don't account for gas *)
let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } =
let Lam (_, original_code) = code in
unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) ->
unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) ->
unparse_ty ctxt arg_type >>=? fun (arg_type, ctxt) ->
unparse_ty ctxt storage_type >>=? fun (storage_type, ctxt) ->
unparse_ty ctxt storage_type >>=? fun (storage_type, _ctxt) ->
let open Micheline in
let code =
Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ;
Prim (-1, K_storage, [ storage_type ], []) ;
Prim (-1, K_code, [ code ], []) ]) in
return ({ code = lazy_expr (strip_locations code) ;
storage = lazy_expr (strip_locations storage) }, ctxt)
storage = lazy_expr (strip_locations storage) })
let pack_data ctxt typ data =
unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) ->
let unparsed = strip_annotations @@ data in
let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in
Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt ->
let bytes = MBytes.concat "" [ MBytes.of_string "\005" ; bytes ] in
Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt ->
return (bytes, ctxt)
let hash_data ctxt typ data =
pack_data ctxt typ data >>=? fun (bytes, ctxt) ->
Lwt.return @@ Gas.consume ctxt (Michelson_v1_gas.Cost_of.hash bytes 32) >>=? fun ctxt ->
Lwt.return @@ Gas.consume ctxt
(Michelson_v1_gas.Cost_of.hash bytes Script_expr_hash.size) >>=? fun ctxt ->
return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt)
(* ---------------- Big map -------------------------------------------------*)
@ -3097,10 +3085,8 @@ let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x ->
| _, _ -> None
let erase_big_map_initialization ctxt mode ({ code ; storage } : Script.t) =
Lwt.return @@ Script.force_decode code >>=? fun (code, cost_code) ->
Lwt.return @@ Gas.consume ctxt cost_code >>=? fun ctxt ->
Lwt.return @@ Script.force_decode storage >>=? fun (storage, cost_storage) ->
Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun ctxt ->
Script.force_decode ctxt code >>=? fun (code, ctxt) ->
Script.force_decode ctxt storage >>=? fun (storage, ctxt) ->
Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) ->
Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type >>=? fun (Ex_ty ty, ctxt) ->
parse_data ctxt ty

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

@ -91,9 +91,11 @@ val typecheck_data :
val parse_script :
?type_logger: type_logger ->
context -> Script.t -> (ex_script * context) tzresult Lwt.t
(* only used in client, don't account for gas *)
val unparse_script :
context -> unparsing_mode ->
('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t
('a, 'b) Script_typed_ir.script -> Script.t tzresult Lwt.t
val parse_contract :
context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->

27
src/proto_alpha/lib_protocol/src/script_repr.ml
View File

@ -135,16 +135,16 @@ let deserialized_cost expr =
let serialized_cost bytes =
let open Gas_limit_repr in
alloc_bytes_cost (MBytes.length bytes)
alloc_cost 12 +@ alloc_bytes_cost (MBytes.length bytes)
let force_decode lexpr =
match Data_encoding.force_decode lexpr with
| Some v ->
let deserialize_cost =
Data_encoding.fold_lazy
(fun _ -> Gas_limit_repr.free)
(fun _ -> deserialized_cost v)
(fun c_free _ -> c_free)
Data_encoding.apply_lazy
~fun_value:(fun _ -> Gas_limit_repr.free)
~fun_bytes:(fun _ -> deserialized_cost v)
~fun_combine:(fun c_free _ -> c_free)
lexpr in
ok (v, deserialize_cost)
| None -> error Lazy_script_decode
@ -154,18 +154,17 @@ let force_bytes expr =
match Data_encoding.force_bytes expr with
| bytes ->
let serialize_cost =
Data_encoding.fold_lazy
(fun v -> traversal_cost v +@ serialized_cost bytes)
(fun _ -> Gas_limit_repr.free)
(fun _ c_free -> c_free)
Data_encoding.apply_lazy
~fun_value:(fun v -> traversal_cost v +@ serialized_cost bytes)
~fun_bytes:(fun _ -> Gas_limit_repr.free)
~fun_combine:(fun _ c_free -> c_free)
expr in
ok (bytes, serialize_cost)
| exception _ -> error Lazy_script_decode
let minimal_deserialize_cost lexpr =
let open Gas_limit_repr in
Data_encoding.fold_lazy
(fun _ -> Gas_limit_repr.free)
(fun b -> alloc_bytes_cost (MBytes.length b))
(fun c_free _ -> c_free)
Data_encoding.apply_lazy
~fun_value:(fun _ -> Gas_limit_repr.free)
~fun_bytes:(fun b -> serialized_cost b)
~fun_combine:(fun c_free _ -> c_free)
lexpr

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

@ -144,16 +144,24 @@ module Contract = struct
(Z)
module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct
include Indexed_context.Make_carbonated_map
module I = Indexed_context.Make_carbonated_map
(N)
(struct
type t = Script_repr.lazy_expr
let encoding = Script_repr.lazy_expr_encoding
end)
type context = I.context
type key = I.key
type value = I.value
let mem = I.mem
let delete = I.delete
let remove = I.remove
let consume_deserialize_gas ctxt value =
Lwt.return @@
(Raw_context.consume_gas ctxt (Script_repr.minimal_deserialize_cost value) >>? fun _ ->
(Raw_context.check_enough_gas ctxt (Script_repr.minimal_deserialize_cost value) >>? fun () ->
Script_repr.force_decode value >>? fun (_value, value_cost) ->
Raw_context.consume_gas ctxt value_cost)
@ -163,12 +171,12 @@ module Contract = struct
Raw_context.consume_gas ctxt value_cost)
let get ctxt contract =
get ctxt contract >>=? fun (ctxt, value) ->
I.get ctxt contract >>=? fun (ctxt, value) ->
consume_deserialize_gas ctxt value >>|? fun ctxt ->
(ctxt, value)
let get_option ctxt contract =
get_option ctxt contract >>=? fun (ctxt, value_opt) ->
I.get_option ctxt contract >>=? fun (ctxt, value_opt) ->
match value_opt with
| None -> return (ctxt, None)
| Some value ->
@ -177,22 +185,22 @@ module Contract = struct
let set ctxt contract value =
consume_serialize_gas ctxt value >>=? fun ctxt ->
set ctxt contract value
I.set ctxt contract value
let set_option ctxt contract value_opt =
match value_opt with
| None -> set_option ctxt contract None
| None -> I.set_option ctxt contract None
| Some value ->
consume_serialize_gas ctxt value >>=? fun ctxt ->
set_option ctxt contract value_opt
I.set_option ctxt contract value_opt
let init ctxt contract value =
consume_serialize_gas ctxt value >>=? fun ctxt ->
init ctxt contract value
I.init ctxt contract value
let init_set ctxt contract value =
consume_serialize_gas ctxt value >>=? fun ctxt ->
init_set ctxt contract value
I.init_set ctxt contract value
end
module Code =

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

@ -66,6 +66,7 @@ module Make_subcontext (C : Raw_context.T) (N : NAME)
let project = C.project
let absolute_key c k = C.absolute_key c (to_key k)
let consume_gas = C.consume_gas
let check_enough_gas = C.check_enough_gas
let description =
Storage_description.register_named_subcontext C.description N.name
end
@ -555,6 +556,9 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
let consume_gas c g =
let (t, i) = unpack c in
C.consume_gas t g >>? fun t -> ok (pack t i)
let check_enough_gas c g =
let (t, _i) = unpack c in
C.check_enough_gas t g
let description = description
end