Michelson: instruction FAILWITH which takes one element on the stack

This commit is contained in:
Alain Mebsout 2018-04-27 19:28:50 +02:00 committed by Benjamin Canou
parent 5e8e6347e2
commit 871a86e32d
9 changed files with 56 additions and 21 deletions

View File

@ -26,18 +26,19 @@ code { DUP; CAR;
CAR %from; CAR %from;
DIIP{ CDAR %withdraw_amount; H @signed_amount }; DIIP{ CDAR %withdraw_amount; H @signed_amount };
DIP{ CDDR %sig }; CHECK_SIGNATURE; DIP{ CDDR %sig }; CHECK_SIGNATURE;
IF {} { FAIL }; IF {} { PUSH string "Bad signature"; FAILWITH };
# Get user account information # Get user account information
DIIP{ CDR %stored_balance; DUP }; DIIP{ CDR %stored_balance; DUP };
CAR %from; HASH_KEY @from_hash; DIP{ SWAP }; GET; CAR %from; HASH_KEY @from_hash; DUP; DIP{ DIP { SWAP }; SWAP}; GET;
# Account does not exist # Account does not exist
IF_NONE { FAIL } IF_NONE { PUSH string "Account does not exist"; PAIR; FAILWITH }
# Account exists # Account exists
{ RENAME @previous_balance; { RENAME @previous_balance;
DIP { DROP };
DUP; DIIP{ DUP; CDAR %withdraw_amount; DUP }; DUP; DIIP{ DUP; CDAR %withdraw_amount; DUP };
# Ensure funds are available # Ensure funds are available
DIP{ CMPLT @not_enough }; SWAP; DIP{ CMPLT @not_enough }; SWAP;
IF { FAIL } IF { PUSH string "Not enough funds"; FAILWITH }
{ SUB @new_balance; DIP{ DUP; DIP{ SWAP }}; DUP; { SUB @new_balance; DIP{ DUP; DIP{ SWAP }}; DUP;
# Delete account if balance is 0 # Delete account if balance is 0
PUSH @zero mutez 0; CMPEQ @null_balance; PUSH @zero mutez 0; CMPEQ @null_balance;

View File

@ -91,7 +91,7 @@ let collect_error_locations errs =
| Invalid_contract (loc, _) | Invalid_contract (loc, _)
| Comparable_type_expected (loc, _) | Comparable_type_expected (loc, _)
| Overflow (loc, _) | Overflow (loc, _)
| Reject (loc, _)) :: rest -> | Reject (loc, _, _)) :: rest ->
collect (loc :: acc) rest collect (loc :: acc) rest
| _ :: rest -> collect acc rest in | _ :: rest -> collect acc rest in
collect [] errs collect [] errs
@ -431,7 +431,7 @@ let report_errors ~details ~show_source ?parsed ppf errs =
@[<hov 2>is not compatible with type@ %a.@]@]" @[<hov 2>is not compatible with type@ %a.@]@]"
print_ty tya print_ty tya
print_ty tyb print_ty tyb
| Reject (loc, trace) -> | Reject (loc, None, trace) ->
Format.fprintf ppf Format.fprintf ppf
"%ascript reached FAIL instruction@ \ "%ascript reached FAIL instruction@ \
%a" %a"
@ -442,6 +442,17 @@ let report_errors ~details ~show_source ?parsed ppf errs =
Format.fprintf ppf "@,@[<v 2>trace@,%a@]" Format.fprintf ppf "@,@[<v 2>trace@,%a@]"
print_execution_trace trace) print_execution_trace trace)
trace trace
| Reject (loc, Some v, trace) ->
Format.fprintf ppf
"%ascript reached FAILWITH instruction@ \
@[<hov 2>with@ %a@]%a"
print_loc loc print_expr v
(fun ppf -> function
| None -> ()
| Some trace ->
Format.fprintf ppf "@,@[<v 2>trace@,%a@]"
print_execution_trace trace)
trace
| Overflow (loc, trace) -> | Overflow (loc, trace) ->
Format.fprintf ppf "%aunexpected arithmetic overflow%a" Format.fprintf ppf "%aunexpected arithmetic overflow%a"
print_loc loc print_loc loc

View File

@ -201,6 +201,7 @@ module Script : sig
| I_EQ | I_EQ
| I_EXEC | I_EXEC
| I_FAIL | I_FAIL
| I_FAILWITH
| I_GE | I_GE
| I_GET | I_GET
| I_GT | I_GT

View File

@ -50,6 +50,7 @@ type prim =
| I_EQ | I_EQ
| I_EXEC | I_EXEC
| I_FAIL | I_FAIL
| I_FAILWITH
| I_GE | I_GE
| I_GET | I_GET
| I_GT | I_GT
@ -177,6 +178,7 @@ let string_of_prim = function
| I_EQ -> "EQ" | I_EQ -> "EQ"
| I_EXEC -> "EXEC" | I_EXEC -> "EXEC"
| I_FAIL -> "FAIL" | I_FAIL -> "FAIL"
| I_FAILWITH -> "FAILWITH"
| I_GE -> "GE" | I_GE -> "GE"
| I_GET -> "GET" | I_GET -> "GET"
| I_GT -> "GT" | I_GT -> "GT"
@ -285,6 +287,7 @@ let prim_of_string = function
| "EQ" -> ok I_EQ | "EQ" -> ok I_EQ
| "EXEC" -> ok I_EXEC | "EXEC" -> ok I_EXEC
| "FAIL" -> ok I_FAIL | "FAIL" -> ok I_FAIL
| "FAILWITH" -> ok I_FAILWITH
| "GE" -> ok I_GE | "GE" -> ok I_GE
| "GET" -> ok I_GET | "GET" -> ok I_GET
| "GT" -> ok I_GT | "GT" -> ok I_GT
@ -438,6 +441,7 @@ let prim_encoding =
("EQ", I_EQ) ; ("EQ", I_EQ) ;
("EXEC", I_EXEC) ; ("EXEC", I_EXEC) ;
("FAIL", I_FAIL) ; ("FAIL", I_FAIL) ;
("FAILWITH", I_FAILWITH) ;
("GE", I_GE) ; ("GE", I_GE) ;
("GET", I_GET) ; ("GET", I_GET) ;
("GT", I_GT) ; ("GT", I_GT) ;

View File

@ -48,6 +48,7 @@ type prim =
| I_EQ | I_EQ
| I_EXEC | I_EXEC
| I_FAIL | I_FAIL
| I_FAILWITH
| I_GE | I_GE
| I_GET | I_GET
| I_GT | I_GT

View File

@ -17,7 +17,7 @@ open Script_ir_translator
type execution_trace = type execution_trace =
(Script.location * Gas.t * (Script.expr * string option) list) list (Script.location * Gas.t * (Script.expr * string option) list) list
type error += Reject of Script.location * execution_trace option type error += Reject of Script.location * Script.expr option * execution_trace option
type error += Overflow of Script.location * execution_trace option type error += Overflow of Script.location * execution_trace option
type error += Runtime_contract_error : Contract.t * Script.expr -> error type error += Runtime_contract_error : Contract.t * Script.expr -> error
type error += Bad_contract_parameter of Contract.t (* `Permanent *) type error += Bad_contract_parameter of Contract.t (* `Permanent *)
@ -38,12 +38,13 @@ let () =
`Temporary `Temporary
~id:"scriptRejectedRuntimeError" ~id:"scriptRejectedRuntimeError"
~title: "Script failed (runtime script error)" ~title: "Script failed (runtime script error)"
~description: "A FAIL instruction was reached" ~description: "A FAILWITH instruction was reached"
(obj2 (obj3
(req "location" Script.location_encoding) (req "location" Script.location_encoding)
(opt "with" Script.expr_encoding)
(opt "trace" trace_encoding)) (opt "trace" trace_encoding))
(function Reject (loc, trace) -> Some (loc, trace) | _ -> None) (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
(fun (loc, trace) -> Reject (loc, trace)); (fun (loc, v, trace) -> Reject (loc, v, trace));
(* Overflow *) (* Overflow *)
register_error_kind register_error_kind
`Temporary `Temporary
@ -542,8 +543,11 @@ let rec interp
| Lambda lam, rest -> | Lambda lam, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
logged_return (Item (lam, rest), ctxt) logged_return (Item (lam, rest), ctxt)
| Fail, _ -> fail (Reject (loc, None, get_log log))
fail (Reject (loc, get_log log)) | Failwith tv, Item (v, _) ->
unparse_data ctxt Optimized tv v >>=? fun (v, _ctxt) ->
let v = Micheline.strip_locations v in
fail (Reject (loc, Some v, get_log log))
| Nop, stack -> | Nop, stack ->
logged_return (stack, ctxt) logged_return (stack, ctxt)
(* comparison *) (* comparison *)

View File

@ -12,7 +12,7 @@ open Alpha_context
type execution_trace = type execution_trace =
(Script.location * Gas.t * (Script.expr * string option) list) list (Script.location * Gas.t * (Script.expr * string option) list) list
type error += Reject of Script.location * execution_trace option type error += Reject of Script.location * Script.expr option * execution_trace option
type error += Overflow of Script.location * execution_trace option type error += Overflow of Script.location * execution_trace option
type error += Runtime_contract_error : Contract.t * Script.expr -> error type error += Runtime_contract_error : Contract.t * Script.expr -> error
type error += Bad_contract_parameter of Contract.t (* `Permanent *) type error += Bad_contract_parameter of Contract.t (* `Permanent *)

View File

@ -183,6 +183,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
| Exec -> 0 | Exec -> 0
| Lambda _ -> 1 | Lambda _ -> 1
| Fail -> 1 | Fail -> 1
| Failwith _ -> 1
| Nop -> 0 | Nop -> 0
| Compare _ -> 1 | Compare _ -> 1
| Eq -> 0 | Eq -> 0
@ -261,6 +262,7 @@ let namespace = function
| I_EQ | I_EQ
| I_EXEC | I_EXEC
| I_FAIL | I_FAIL
| I_FAILWITH
| I_GE | I_GE
| I_GET | I_GET
| I_GT | I_GT
@ -1454,13 +1456,15 @@ and parse_instr
Lwt.return check in Lwt.return check in
let check_item_ty exp got loc n = let check_item_ty exp got loc n =
check_item (ty_eq exp got) loc n in check_item (ty_eq exp got) loc n in
let typed ctxt loc instr aft = let log_stack loc stack_ty aft =
begin match type_logger, script_instr with match type_logger, script_instr with
| None, _ | None, _
| Some _, (Seq (-1, _) | Int _ | String _) -> () | Some _, (Seq (-1, _) | Int _ | String _) -> ()
| Some log, (Prim _ | Seq _) -> | Some log, (Prim _ | Seq _) ->
log loc (unparse_stack stack_ty) (unparse_stack aft) log loc (unparse_stack stack_ty) (unparse_stack aft)
end ; in
let typed ctxt loc instr aft =
log_stack loc stack_ty aft ;
return ctxt (Typed { loc ; instr ; bef = stack_ty ; aft }) in return ctxt (Typed { loc ; instr ; bef = stack_ty ; aft }) in
match script_instr, stack_ty with match script_instr, stack_ty with
(* stack ops *) (* stack ops *)
@ -1886,7 +1890,14 @@ and parse_instr
| Prim (loc, I_FAIL, [], annot), | Prim (loc, I_FAIL, [], annot),
bef -> bef ->
fail_unexpected_annot loc annot >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () ->
let descr aft = { loc ; instr = Fail ; bef ; aft } in let descr aft = { loc ; instr = Fail; bef ; aft } in
log_stack loc stack_ty Empty_t ;
return ctxt (Failed { descr } )
| Prim (loc, I_FAILWITH, [], annot),
Item_t (v, _rest, _) ->
fail_unexpected_annot loc annot >>=? fun () ->
let descr aft = { loc ; instr = Failwith v ; bef = stack_ty ; aft } in
log_stack loc stack_ty Empty_t ;
return ctxt (Failed { descr }) return ctxt (Failed { descr })
(* timestamp operations *) (* timestamp operations *)
| Prim (loc, I_ADD, [], annot), | Prim (loc, I_ADD, [], annot),

View File

@ -294,6 +294,8 @@ and ('bef, 'aft) instr =
('rest, ('arg, 'ret) lambda * 'rest) instr ('rest, ('arg, 'ret) lambda * 'rest) instr
| Fail : | Fail :
('bef, 'aft) instr ('bef, 'aft) instr
| Failwith :
'a ty -> ('a * 'rest, 'aft) instr
| Nop : | Nop :
('rest, 'rest) instr ('rest, 'rest) instr
(* comparison *) (* comparison *)