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

Alpha, Gas: gas accounting for serialization of data and types

Browse Source 
Also gas accounting in errors, failures and trace
This commit is contained in:
Alain Mebsout 2018-06-27 12:39:28 +02:00 committed by Benjamin Canou
parent fa4a3a9fe4
commit a69333d21f
10 changed files with 598 additions and 447 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -10,39 +10,32 @@
open Proto_alpha
open Alpha_context
open Tezos_micheline
open Script_typed_ir
open Script_tc_errors
open Script_ir_annot
open Script_ir_translator
open Script_interpreter
open Michelson_v1_printer
let print_ty (type t) ppf (ty : t ty) =
unparse_ty ty
|> Micheline.strip_locations
|> Michelson_v1_printer.print_expr_unwrapped ppf
let print_ty ppf ty =
Michelson_v1_printer.print_expr_unwrapped ppf ty
let print_var_annot ppf annot =
List.iter (Format.fprintf ppf "@ %s") (unparse_var_annot annot)
List.iter (Format.fprintf ppf "@ %s") annot
let print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) =
let rec loop
: type t. int -> Format.formatter -> t stack_ty -> unit
= fun depth ppf -> function
| Empty_t -> ()
| _ when depth <= 0 ->
Format.fprintf ppf "..."
| Item_t (last, Empty_t, annot) ->
Format.fprintf ppf "%a%a"
print_ty last
print_var_annot annot
| Item_t (last, rest, annot) ->
Format.fprintf ppf "%a%a@ :@ %a"
print_ty last
print_var_annot annot
(loop (depth - 1)) rest in
let print_stack_ty ?(depth = max_int) ppf s =
let rec loop depth ppf = function
| [] -> ()
| _ when depth <= 0 ->
Format.fprintf ppf "..."
| [last, annot] ->
Format.fprintf ppf "%a%a"
print_ty last
print_var_annot annot
| (last, annot) :: rest ->
Format.fprintf ppf "%a%a@ :@ %a"
print_ty last
print_var_annot annot
(loop (depth - 1)) rest in
match s with
| Empty_t ->
| [] ->
Format.fprintf ppf "[]"
| sty ->
Format.fprintf ppf "@[<hov 2>[ %a ]@]" (loop depth) sty
@ -338,7 +331,7 @@ let report_errors ~details ~show_source ?parsed ppf errs =
- @[<v 0>expected return stack type:@ %a,@]@,\
- @[<v 0>actual stack type:@ %a.@]@]"
print_loc loc
(fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t, None))
(fun ppf -> print_stack_ty ppf) [exp, []]
(fun ppf -> print_stack_ty ppf) got
| Bad_stack (loc, name, depth, sty) ->
Format.fprintf ppf

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

@ -200,7 +200,7 @@ module Scripts = struct
let ctxt = match maybe_gas with
| None -> Gas.set_unlimited ctxt
| Some gas -> Gas.set_limit ctxt gas in
Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ) ->
Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ) ->
parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) ->
Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) ->
return (bytes, Gas.level ctxt)

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

@ -236,21 +236,27 @@ module Cost_of = struct
end
module Unparse = struct
let prim_cost = alloc_cost 4 (* location, primitive name, list, annotation *)
let prim_cost nb_args =
alloc_cost 4 (* location, primitive name, list, annotation *) +@
(nb_args *@ alloc_cost 2)
let seq_cost nb_args =
alloc_cost 2 (* location, list *) +@
(nb_args *@ alloc_cost 2)
let string_cost length =
alloc_cost 3 +@ alloc_bytes_cost length
let cycle = step_cost 1
let bool = prim_cost
let unit = prim_cost
let bool = prim_cost 0
let unit = prim_cost 0
(* FIXME: not sure we should count the length of strings and bytes
as they are shared *)
let string s = string_cost (String.length s)
let bytes s = alloc_bytes_cost (MBytes.length s)
(* Approximates log10(x) *)
let int i =
let decimal_digits = (Z.numbits (Z.abs (Script_int.to_zint i))) / 4 in
prim_cost +@ (alloc_bytes_cost decimal_digits)
let z i =
let decimal_digits = (Z.numbits (Z.abs i)) / 4 in
prim_cost 0 +@ (alloc_bytes_cost decimal_digits)
let int i = z (Script_int.to_zint i)
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 operation bytes = string_cost (MBytes.length bytes * 2)
@ -258,17 +264,15 @@ module Cost_of = struct
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 pair = prim_cost 2
let union = prim_cost 1
let some = prim_cost 1
let none = prim_cost 0
let list_element = prim_cost 1
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 one_arg_type = prim_cost 1
let two_arg_type = prim_cost 2
let set_to_list = set_to_list
let map_to_list = map_to_list

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

@ -135,9 +135,12 @@ module Cost_of : sig
end
module Unparse : sig
val prim_cost : int -> Gas.cost
val seq_cost : int -> Gas.cost
val cycle : Gas.cost
val unit : Gas.cost
val bool : Gas.cost
val z : Z.t -> Gas.cost
val int : 'a Script_int.num -> Gas.cost
val tez : Gas.cost
val string : string -> Gas.cost
@ -155,8 +158,6 @@ module Cost_of : sig
val union : Gas.cost
val lambda : Gas.cost
val some : Gas.cost
val none : Gas.cost
@ -164,7 +165,6 @@ module Cost_of : sig
val set_element : Gas.cost
val map_element : Gas.cost
val primitive_type : Gas.cost
val one_arg_type : Gas.cost
val two_arg_type : Gas.cost
val set_to_list : 'a Script_typed_ir.set -> Gas.cost

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

@ -21,6 +21,9 @@ type error += Reject of Script.location * Script.expr * execution_trace option
type error += Overflow of Script.location * execution_trace option
type error += Runtime_contract_error : Contract.t * Script.expr -> error
type error += Bad_contract_parameter of Contract.t (* `Permanent *)
type error += Cannot_serialize_log
type error += Cannot_serialize_failure
type error += Cannot_serialize_storage
let () =
let open Data_encoding in
@ -82,7 +85,37 @@ let () =
the wrong type"
Data_encoding.(obj1 (req "contract" Contract.encoding))
(function Bad_contract_parameter c -> Some c | _ -> None)
(fun c -> Bad_contract_parameter c)
(fun c -> Bad_contract_parameter c) ;
(* Cannot serialize log *)
register_error_kind
`Temporary
~id:"cannotSerializeLog"
~title:"Not enough gas to serialize execution trace"
~description:"Execution trace with stacks was to big to be serialized with \
the provided gas"
Data_encoding.empty
(function Cannot_serialize_log -> Some () | _ -> None)
(fun () -> Cannot_serialize_log) ;
(* Cannot serialize failure *)
register_error_kind
`Temporary
~id:"cannotSerializeFailure"
~title:"Not enough gas to serialize argument of FAILWITH"
~description:"Argument of FAILWITH was too big to be serialized with \
the provided gas"
Data_encoding.empty
(function Cannot_serialize_failure -> Some () | _ -> None)
(fun () -> Cannot_serialize_failure) ;
(* Cannot serialize storage *)
register_error_kind
`Temporary
~id:"cannotSerializeStorage"
~title:"Not enough gas to serialize execution storage"
~description:"The returned storage was too big to be serialized with \
the provided gas"
Data_encoding.empty
(function Cannot_serialize_storage -> Some () | _ -> None)
(fun () -> Cannot_serialize_storage)
(* ---- interpreter ---------------------------------------------------------*)
@ -132,7 +165,9 @@ let rec interp
match log with
| None -> return (ret, ctxt)
| Some log ->
unparse_stack ctxt (ret, descr.aft) >>=? fun stack ->
trace
Cannot_serialize_log
(unparse_stack ctxt (ret, descr.aft)) >>=? fun stack ->
log := (descr.loc, Gas.level ctxt, stack) :: !log ;
return (ret, ctxt) in
let get_log (log : execution_trace ref option) =
@ -544,7 +579,8 @@ let rec interp
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
logged_return (Item (lam, rest), ctxt)
| Failwith tv, Item (v, _) ->
unparse_data ctxt Optimized tv v >>=? fun (v, _ctxt) ->
trace Cannot_serialize_failure
(unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) ->
let v = Micheline.strip_locations v in
fail (Reject (loc, v, get_log log))
| Nop, stack ->
@ -658,10 +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) ->
let code =
Micheline.strip_locations
(Seq (0, [ Prim (0, K_parameter, [ unparse_ty param_type ], []) ;
Prim (0, K_storage, [ unparse_ty storage_type ], []) ;
(Seq (0, [ Prim (0, K_parameter, [ u_param_type ], []) ;
Prim (0, K_storage, [ u_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
@ -732,7 +770,8 @@ let rec interp
begin match log with
| None -> return_unit
| Some log ->
unparse_stack ctxt (stack, code.bef) >>=? fun stack ->
trace Cannot_serialize_log
(unparse_stack ctxt (stack, code.bef)) >>=? fun stack ->
log := (code.loc, Gas.level ctxt, stack) :: !log ;
return_unit
end >>=? fun () ->
@ -755,7 +794,8 @@ and execute ?log ctxt mode ~source ~payer ~self script amount arg :
(Runtime_contract_error (self, script_code))
(interp ?log ctxt ~source ~payer ~self amount code (arg, storage))
>>=? fun ((ops, sto), ctxt) ->
unparse_data ctxt mode storage_type sto >>=? fun (storage, ctxt) ->
trace Cannot_serialize_storage
(unparse_data ctxt mode storage_type sto) >>=? fun (storage, ctxt) ->
return (Micheline.strip_locations storage, ops, ctxt,
Script_ir_translator.extract_big_map storage_type sto)

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

@ -16,6 +16,9 @@ type error += Reject of Script.location * Script.expr * execution_trace option
type error += Overflow of Script.location * execution_trace option
type error += Runtime_contract_error : Contract.t * Script.expr -> error
type error += Bad_contract_parameter of Contract.t (* `Permanent *)
type error += Cannot_serialize_log
type error += Cannot_serialize_failure
type error += Cannot_serialize_storage
type execution_result =
{ ctxt : context ;

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

File diff suppressed because it is too large Load Diff

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

@ -57,6 +57,7 @@ val big_map_update :
('key, 'value) Script_typed_ir.big_map
val ty_eq :
context ->
'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty ->
('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq tzresult
@ -69,13 +70,16 @@ val unparse_data :
(Script.node * context) tzresult Lwt.t
val parse_ty :
context ->
allow_big_map: bool ->
allow_operation: bool ->
Script.node -> ex_ty tzresult
val unparse_ty : 'a Script_typed_ir.ty -> Script.node
val parse_toplevel
: Script.expr -> (Script.node * Script.node * Script.node) tzresult
val unparse_ty :
context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t
val parse_toplevel :
Script.expr -> (Script.node * Script.node * Script.node) tzresult
val typecheck_code :
context -> Script.expr -> (type_map * context) tzresult Lwt.t

31
src/proto_alpha/lib_protocol/src/script_tc_errors.ml
View File

@ -9,7 +9,6 @@
open Alpha_context
open Script
open Script_typed_ir
(* ---- Error definitions ---------------------------------------------------*)
@ -17,7 +16,8 @@ open Script_typed_ir
(* Auxiliary types for error documentation *)
type namespace = Type_namespace | Constant_namespace | Instr_namespace | Keyword_namespace
type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind
type type_map = (int * ((Script.expr * Script.annot) list * (Script.expr * Script.annot) list)) list
type unparsed_stack_ty = (Script.expr * Script.annot) list
type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list
(* Structure errors *)
type error += Invalid_arity of Script.location * prim * int * int
@ -31,35 +31,38 @@ type error += Unexpected_operation of Script.location
(* Instruction typing errors *)
type error += Fail_not_in_tail_position of Script.location
type error += Undefined_binop : Script.location * prim * _ ty * _ ty -> error
type error += Undefined_unop : Script.location * prim * _ ty -> error
type error += Bad_return : Script.location * _ stack_ty * _ ty -> error
type error += Bad_stack : Script.location * prim * int * _ stack_ty -> error
type error += Unmatched_branches : Script.location * _ stack_ty * _ stack_ty -> error
type error += Undefined_binop : Script.location * prim * Script.expr * Script.expr -> error
type error += Undefined_unop : Script.location * prim * Script.expr -> error
type error += Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error
type error += Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error
type error += Unmatched_branches : Script.location * unparsed_stack_ty * unparsed_stack_ty -> error
type error += Self_in_lambda of Script.location
type error += Bad_stack_length
type error += Bad_stack_item of int
type error += Inconsistent_annotations of string * string
type error += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error
type error += Inconsistent_type_annotations : Script.location * Script.expr * Script.expr -> error
type error += Inconsistent_field_annotations of string * string
type error += Unexpected_annotation of Script.location
type error += Ungrouped_annotations of Script.location
type error += Invalid_map_body : Script.location * _ stack_ty -> error
type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error
type error += Invalid_map_block_fail of Script.location
type error += Invalid_iter_body : Script.location * _ stack_ty * _ stack_ty -> error
type error += Invalid_iter_body : Script.location * unparsed_stack_ty * unparsed_stack_ty -> error
type error += Type_too_large : Script.location * int * int -> error
(* Value typing errors *)
type error += Invalid_constant : Script.location * Script.expr * _ ty -> error
type error += Invalid_constant : Script.location * Script.expr * Script.expr -> error
type error += Invalid_contract of Script.location * Contract.t
type error += Comparable_type_expected : Script.location * _ ty -> error
type error += Inconsistent_types : _ ty * _ ty -> error
type error += Comparable_type_expected : Script.location * Script.expr -> error
type error += Inconsistent_types : Script.expr * Script.expr -> error
type error += Unordered_map_keys of Script.location * Script.expr
type error += Unordered_set_values of Script.location * Script.expr
type error += Duplicate_map_keys of Script.location * Script.expr
type error += Duplicate_set_values of Script.location * Script.expr
(* Toplevel errors *)
type error += Ill_typed_data : string option * Script.expr * _ ty -> error
type error += Ill_typed_data : string option * Script.expr * Script.expr -> error
type error += Ill_formed_type of string option * Script.expr * Script.location
type error += Ill_typed_contract : Script.expr * type_map -> error
(* Gas related errors *)
type error += Cannot_serialize_error

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

@ -8,11 +8,8 @@
(**************************************************************************)
open Alpha_context
open Micheline
open Script
open Script_typed_ir
open Script_tc_errors
open Script_ir_translator
(* Helpers for encoding *)
let type_map_enc =
@ -27,49 +24,12 @@ let type_map_enc =
(req "stackBefore" stack_enc)
(req "stackAfter" stack_enc)))
let rec strip_var_annots = function
| Int _ | String _ | Bytes _ as atom -> atom
| Seq (loc, args) -> Seq (loc, List.map strip_var_annots args)
| Prim (loc, name, args, annots) ->
let not_var_annot s = Compare.Char.(String.get s 0 <> '@') in
let annots = List.filter not_var_annot annots in
Prim (loc, name, List.map strip_var_annots args, annots)
let ex_ty_enc =
Data_encoding.conv
(fun (Ex_ty ty) ->
strip_locations (strip_var_annots (unparse_ty ty)))
(fun expr ->
match parse_ty ~allow_big_map:true ~allow_operation:true (root expr) with
| Ok ty -> ty
| _ -> assert false)
Script.expr_encoding
let var_annot_enc =
let stack_ty_enc =
let open Data_encoding in
conv
(function `Var_annot x -> "@" ^ x)
(function x ->
assert (Compare.Int.(String.length x > 0) && Compare.Char.(String.get x 0 = '@')) ;
`Var_annot (String.sub x 1 (String.length x - 1)))
string
let ex_stack_ty_enc =
let open Data_encoding in
let rec unfold = function
| Ex_stack_ty (Item_t (ty, rest, annot)) ->
(Ex_ty ty, annot) :: unfold (Ex_stack_ty rest)
| Ex_stack_ty Empty_t -> [] in
let rec fold = function
| (Ex_ty ty, annot) :: rest ->
let Ex_stack_ty rest = fold rest in
Ex_stack_ty (Item_t (ty, rest, annot))
| [] -> Ex_stack_ty Empty_t in
conv unfold fold
(list
(obj2
(req "type" ex_ty_enc)
(opt "annot" var_annot_enc)))
(list
(obj2
(req "type" Script.expr_encoding)
(dft "annots" (list string) [])))
(* main registration *)
let () =
@ -290,13 +250,13 @@ let () =
over which it is not defined."
(located (obj3
(req "operatorName" prim_encoding)
(req "wrongLeftOperandType" ex_ty_enc)
(req "wrongRightOperandType" ex_ty_enc)))
(req "wrongLeftOperandType" Script.expr_encoding)
(req "wrongRightOperandType" Script.expr_encoding)))
(function
| Undefined_binop (loc, n, tyl, tyr) ->
Some (loc, (n, Ex_ty tyl, Ex_ty tyr))
Some (loc, (n, tyl, tyr))
| _ -> None)
(fun (loc, (n, Ex_ty tyl, Ex_ty tyr)) ->
(fun (loc, (n, tyl, tyr)) ->
Undefined_binop (loc, n, tyl, tyr)) ;
(* Undefined unary operation *)
register_error_kind
@ -308,12 +268,12 @@ let () =
over which it is not defined."
(located (obj2
(req "operatorName" prim_encoding)
(req "wrongOperandType" ex_ty_enc)))
(req "wrongOperandType" Script.expr_encoding)))
(function
| Undefined_unop (loc, n, ty) ->
Some (loc, (n, Ex_ty ty))
Some (loc, (n, ty))
| _ -> None)
(fun (loc, (n, Ex_ty ty)) ->
(fun (loc, (n, ty)) ->
Undefined_unop (loc, n, ty)) ;
(* Bad return *)
register_error_kind
@ -323,12 +283,12 @@ let () =
~description:
"Unexpected stack at the end of a lambda or script."
(located (obj2
(req "expectedReturnType" ex_ty_enc)
(req "wrongStackType" ex_stack_ty_enc)))
(req "expectedReturnType" Script.expr_encoding)
(req "wrongStackType" stack_ty_enc)))
(function
| Bad_return (loc, sty, ty) -> Some (loc, (Ex_ty ty, Ex_stack_ty sty))
| Bad_return (loc, sty, ty) -> Some (loc, (ty, sty))
| _ -> None)
(fun (loc, (Ex_ty ty, Ex_stack_ty sty)) ->
(fun (loc, (ty, sty)) ->
Bad_return (loc, sty, ty)) ;
(* Bad stack *)
register_error_kind
@ -340,11 +300,11 @@ let () =
(located (obj3
(req "primitiveName" prim_encoding)
(req "relevantStackPortion" int16)
(req "wrongStackType" ex_stack_ty_enc)))
(req "wrongStackType" stack_ty_enc)))
(function
| Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, Ex_stack_ty sty))
| Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty))
| _ -> None)
(fun (loc, (name, s, Ex_stack_ty sty)) ->
(fun (loc, (name, s, sty)) ->
Bad_stack (loc, name, s, sty)) ;
(* Inconsistent annotations *)
register_error_kind
@ -377,12 +337,12 @@ let () =
~title:"Types contain inconsistent annotations"
~description:"The two types contain annotations that do not match"
(located (obj2
(req "type1" ex_ty_enc)
(req "type2" ex_ty_enc)))
(req "type1" Script.expr_encoding)
(req "type2" Script.expr_encoding)))
(function
| Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (Ex_ty ty1, Ex_ty ty2))
| Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (ty1, ty2))
| _ -> None)
(fun (loc, (Ex_ty ty1, Ex_ty ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ;
(fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ;
(* Unexpected annotation *)
register_error_kind
`Permanent
@ -412,13 +372,13 @@ let () =
"At the join point at the end of two code branches \
the stacks have inconsistent lengths or contents."
(located (obj2
(req "firstStackType" ex_stack_ty_enc)
(req "otherStackType" ex_stack_ty_enc)))
(req "firstStackType" stack_ty_enc)
(req "otherStackType" stack_ty_enc)))
(function
| Unmatched_branches (loc, stya, styb) ->
Some (loc, (Ex_stack_ty stya, Ex_stack_ty styb))
Some (loc, (stya, styb))
| _ -> None)
(fun (loc, (Ex_stack_ty stya, Ex_stack_ty styb)) ->
(fun (loc, (stya, styb)) ->
Unmatched_branches (loc, stya, styb)) ;
(* Bad stack item *)
register_error_kind
@ -470,13 +430,13 @@ let () =
~description:
"A data expression was invalid for its expected type."
(located (obj2
(req "expectedType" ex_ty_enc)
(req "expectedType" Script.expr_encoding)
(req "wrongExpression" Script.expr_encoding)))
(function
| Invalid_constant (loc, expr, ty) ->
Some (loc, (Ex_ty ty, expr))
Some (loc, (ty, expr))
| _ -> None)
(fun (loc, (Ex_ty ty, expr)) ->
(fun (loc, (ty, expr)) ->
Invalid_constant (loc, expr, ty)) ;
(* Invalid contract *)
register_error_kind
@ -501,11 +461,11 @@ let () =
~description:
"A non comparable type was used in a place where \
only comparable types are accepted."
(located (obj1 (req "wrongType" ex_ty_enc)))
(located (obj1 (req "wrongType" Script.expr_encoding)))
(function
| Comparable_type_expected (loc, ty) -> Some (loc, Ex_ty ty)
| Comparable_type_expected (loc, ty) -> Some (loc, ty)
| _ -> None)
(fun (loc, Ex_ty ty) ->
(fun (loc, ty) ->
Comparable_type_expected (loc, ty)) ;
(* Inconsistent types *)
register_error_kind
@ -518,14 +478,12 @@ let () =
two types have to be proven, it is always accompanied \
with another error that provides more context."
(obj2
(req "firstType" ex_ty_enc)
(req "otherType" ex_ty_enc))
(req "firstType" Script.expr_encoding)
(req "otherType" Script.expr_encoding))
(function
| Inconsistent_types (tya, tyb) ->
Some (Ex_ty tya, Ex_ty tyb)
| Inconsistent_types (tya, tyb) -> Some (tya, tyb)
| _ -> None)
(fun (Ex_ty tya, Ex_ty tyb) ->
Inconsistent_types (tya, tyb)) ;
(fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ;
(* -- Instruction typing errors ------------------- *)
(* Invalid map body *)
register_error_kind
@ -536,13 +494,11 @@ let () =
"The body of a map block did not match the expected type"
(obj2
(req "loc" Script.location_encoding)
(req "bodyType" ex_stack_ty_enc))
(req "bodyType" stack_ty_enc))
(function
| Invalid_map_body (loc, stack) ->
Some (loc, Ex_stack_ty stack)
| Invalid_map_body (loc, stack) -> Some (loc, stack)
| _ -> None)
(fun (loc, Ex_stack_ty stack) ->
Invalid_map_body (loc, stack)) ;
(fun (loc, stack) -> Invalid_map_body (loc, stack)) ;
(* Invalid map block FAIL *)
register_error_kind
`Permanent
@ -565,12 +521,12 @@ let () =
the ITER."
(obj3
(req "loc" Script.location_encoding)
(req "befStack" ex_stack_ty_enc)
(req "aftStack" ex_stack_ty_enc))
(req "befStack" stack_ty_enc)
(req "aftStack" stack_ty_enc))
(function
| Invalid_iter_body (loc, bef, aft) -> Some (loc, Ex_stack_ty bef, Ex_stack_ty aft)
| Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft)
| _ -> None)
(fun (loc, Ex_stack_ty bef, Ex_stack_ty aft) -> Invalid_iter_body (loc, bef, aft)) ;
(fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ;
(* Type too large *)
register_error_kind
`Permanent
@ -597,13 +553,12 @@ let () =
(always followed by more precise errors)."
(obj3
(opt "identifier" string)
(req "expectedType" ex_ty_enc)
(req "expectedType" Script.expr_encoding)
(req "illTypedExpression" Script.expr_encoding))
(function
| Ill_typed_data (name, expr, ty) -> Some (name, Ex_ty ty, expr)
| Ill_typed_data (name, expr, ty) -> Some (name, ty, expr)
| _ -> None)
(fun (name, Ex_ty ty, expr) ->
Ill_typed_data (name, expr, ty)) ;
(fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ;
(* Ill formed type *)
register_error_kind
`Permanent
@ -638,4 +593,14 @@ let () =
Some (expr, type_map)
| _ -> None)
(fun (expr, type_map) ->
Ill_typed_contract (expr, type_map))
Ill_typed_contract (expr, type_map)) ;
(* Cannot serialize error *)
register_error_kind
`Temporary
~id:"cannotSerializeError"
~title:"Not enough gas to serialize error"
~description:"The error was too big to be serialized with \
the provided gas"
Data_encoding.empty
(function Cannot_serialize_error -> Some () | _ -> None)
(fun () -> Cannot_serialize_error)