From 0c9592bca73d66844f3a985d2d8fd11feedbddc5 Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Thu, 11 Jan 2018 11:15:35 -0500 Subject: [PATCH] Michelson: SELF instruction implemented --- .../michelson_v1_error_reporter.ml | 5 ++ lib_embedded_protocol_alpha/src/gas.ml | 1 + lib_embedded_protocol_alpha/src/gas.mli | 1 + .../src/michelson_v1_primitives.ml | 4 ++ .../src/michelson_v1_primitives.mli | 1 + .../src/script_interpreter.ml | 4 ++ .../src/script_ir_translator.ml | 47 +++++++++++++++---- .../src/script_ir_translator.mli | 1 + .../src/script_typed_ir.ml | 2 + .../src/tezos_context.mli | 1 + test/contracts/self.tz | 4 ++ test/test_contracts.sh | 7 +++ 12 files changed, 69 insertions(+), 9 deletions(-) create mode 100644 test/contracts/self.tz diff --git a/lib_embedded_client_alpha/michelson_v1_error_reporter.ml b/lib_embedded_client_alpha/michelson_v1_error_reporter.ml index e265965df..a68682fd4 100644 --- a/lib_embedded_client_alpha/michelson_v1_error_reporter.ml +++ b/lib_embedded_client_alpha/michelson_v1_error_reporter.ml @@ -68,6 +68,7 @@ let collect_error_locations errs = | Bad_stack (loc, _, _, _) | Unmatched_branches (loc, _, _) | Transfer_in_lambda loc + | Self_in_lambda loc | Transfer_in_dip loc | Invalid_constant (loc, _, _) | Invalid_contract (loc, _) @@ -312,6 +313,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = Format.fprintf ppf "%aThe TRANSFER_TOKENS instruction cannot appear within a DIP." print_loc loc + | Self_in_lambda loc -> + Format.fprintf ppf + "%aThe SELF instruction cannot appear in a lambda." + print_loc loc | Bad_stack_length -> Format.fprintf ppf "Bad stack length." diff --git a/lib_embedded_protocol_alpha/src/gas.ml b/lib_embedded_protocol_alpha/src/gas.ml index b3aa89c5f..b4fa2761d 100644 --- a/lib_embedded_protocol_alpha/src/gas.ml +++ b/lib_embedded_protocol_alpha/src/gas.ml @@ -263,6 +263,7 @@ module Cost_of = struct let steps_to_quota = step_cost 1 let get_steps_to_quota gas = Script_int.abs @@ Script_int.of_int gas.remaining let source = step_cost 3 + let self = step_cost 3 let amount = step_cost 1 let compare_bool _ _ = step_cost 1 let compare_string s1 s2 = diff --git a/lib_embedded_protocol_alpha/src/gas.mli b/lib_embedded_protocol_alpha/src/gas.mli index 4715cd175..3441e4b54 100644 --- a/lib_embedded_protocol_alpha/src/gas.mli +++ b/lib_embedded_protocol_alpha/src/gas.mli @@ -90,6 +90,7 @@ module Cost_of : sig val get_steps_to_quota : t -> Script_int.n Script_int.num val steps_to_quota : cost val source : cost + val self : cost val amount : cost val wrap : cost val compare_bool : 'a -> 'b -> cost diff --git a/lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml b/lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml index ebc865644..e3d4b21f8 100644 --- a/lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml +++ b/lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml @@ -85,6 +85,7 @@ type prim = | I_SIZE | I_SOME | I_SOURCE + | I_SELF | I_STEPS_TO_QUOTA | I_SUB | I_SWAP @@ -204,6 +205,7 @@ let string_of_prim = function | I_SIZE -> "SIZE" | I_SOME -> "SOME" | I_SOURCE -> "SOURCE" + | I_SELF -> "SELF" | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA" | I_SUB -> "SUB" | I_SWAP -> "SWAP" @@ -304,6 +306,7 @@ let prim_of_string = function | "SIZE" -> ok I_SIZE | "SOME" -> ok I_SOME | "SOURCE" -> ok I_SOURCE + | "SELF" -> ok I_SELF | "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA | "SUB" -> ok I_SUB | "SWAP" -> ok I_SWAP @@ -448,6 +451,7 @@ let prim_encoding = ("SIZE", I_SIZE) ; ("SOME", I_SOME) ; ("SOURCE", I_SOURCE) ; + ("SELF", I_SELF) ; ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ; ("SUB", I_SUB) ; ("SWAP", I_SWAP) ; diff --git a/lib_embedded_protocol_alpha/src/michelson_v1_primitives.mli b/lib_embedded_protocol_alpha/src/michelson_v1_primitives.mli index 6be51806f..6d2d2e83e 100644 --- a/lib_embedded_protocol_alpha/src/michelson_v1_primitives.mli +++ b/lib_embedded_protocol_alpha/src/michelson_v1_primitives.mli @@ -83,6 +83,7 @@ type prim = | I_SIZE | I_SOME | I_SOURCE + | I_SELF | I_STEPS_TO_QUOTA | I_SUB | I_SWAP diff --git a/lib_embedded_protocol_alpha/src/script_interpreter.ml b/lib_embedded_protocol_alpha/src/script_interpreter.ml index 12a69e234..99254ec63 100644 --- a/lib_embedded_protocol_alpha/src/script_interpreter.ml +++ b/lib_embedded_protocol_alpha/src/script_interpreter.ml @@ -752,6 +752,10 @@ let rec interp let gas = Gas.consume gas Gas.Cost_of.source in Gas.check gas >>=? fun () -> logged_return (Item ((ta, tb, orig), rest), gas, ctxt) + | Self (ta, tb), rest -> + let gas = Gas.consume gas Gas.Cost_of.self in + Gas.check gas >>=? fun () -> + logged_return (Item ((ta, tb, source), rest), gas, ctxt) | Amount, rest -> let gas = Gas.consume gas Gas.Cost_of.amount in Gas.check gas >>=? fun () -> diff --git a/lib_embedded_protocol_alpha/src/script_ir_translator.ml b/lib_embedded_protocol_alpha/src/script_ir_translator.ml index f3cfd9905..9d95646e0 100644 --- a/lib_embedded_protocol_alpha/src/script_ir_translator.ml +++ b/lib_embedded_protocol_alpha/src/script_ir_translator.ml @@ -36,6 +36,7 @@ type error += Bad_stack : Script.location * prim * int * _ stack_ty -> error type error += Unmatched_branches : Script.location * _ stack_ty * _ stack_ty -> error type error += Transfer_in_lambda of Script.location type error += Transfer_in_dip of Script.location +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 @@ -67,12 +68,15 @@ type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty type tc_context = | Lambda : tc_context - | Dip : 'a stack_ty -> tc_context - | Toplevel : { storage_type : 'a ty } -> tc_context + | Dip : 'a stack_ty * tc_context -> tc_context + | Toplevel : { storage_type : 'sto ty ; + param_type : 'param ty ; + ret_type : 'ret ty } -> tc_context -let add_dip ty annot = function - | Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot)) - | Dip stack -> Dip (Item_t (ty, stack, annot)) +let add_dip ty annot prev = + match prev with + | Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev) + | Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev) let default_param_annot = Some "@parameter" let default_storage_annot = Some "@storage" @@ -244,6 +248,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | H _ -> 0 | Steps_to_quota -> 0 | Source _ -> 1 + | Self _ -> 1 | Amount -> 0 (* ---- Error helpers -------------------------------------------------------*) @@ -332,6 +337,7 @@ let namespace = function | I_SIZE | I_SOME | I_SOURCE + | I_SELF | I_STEPS_TO_QUOTA | I_SUB | I_SWAP @@ -1842,7 +1848,8 @@ and parse_instr let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in trace (Ill_typed_contract (cannonical_code, [])) - (parse_returning (Toplevel { storage_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? + (parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type }) + ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda) -> Lwt.return @@ ty_eq arg arg_type_full >>=? fun (Eq _) -> @@ -1876,6 +1883,15 @@ and parse_instr (Lwt.return (parse_ty ta)) >>=? fun (Ex_ty ta, _) -> (Lwt.return (parse_ty tb)) >>=? fun (Ex_ty tb, _) -> return (typed loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack, instr_annot))) + | Prim (loc, I_SELF, [], instr_annot), + stack -> + let rec get_toplevel_type : tc_context -> bef judgement tzresult Lwt.t = function + | Lambda -> fail (Self_in_lambda loc) + | Dip (_, prev) -> get_toplevel_type prev + | Toplevel { param_type ; ret_type ; _ } -> + return (typed loc (Self (param_type, ret_type), + Item_t (Contract_t (param_type, ret_type), stack, instr_annot))) in + get_toplevel_type tc_context (* Primitive parsing errors *) | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT | I_PAIR | I_CAR | I_CDR | I_CONS @@ -1964,7 +1980,7 @@ and parse_instr I_PUSH ; I_NONE ; I_LEFT ; I_RIGHT ; I_NIL ; I_EMPTY_SET ; I_DIP ; I_LOOP ; I_IF_NONE ; I_IF_LEFT ; I_IF_CONS ; - I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_LAMBDA ] + I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SELF ; I_LAMBDA ] and parse_contract : type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t -> @@ -2062,7 +2078,8 @@ let parse_script (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun storage -> trace (Ill_typed_contract (code, [])) - (parse_returning (Toplevel { storage_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) + (parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type }) + ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun code -> return (Ex_script { code; arg_type; ret_type; storage; storage_type }) @@ -2097,7 +2114,7 @@ let typecheck_code let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in let result = parse_returning - (Toplevel { storage_type }) + (Toplevel { storage_type ; param_type = arg_type ; ret_type }) ctxt ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) (arg_type_full, None) ret_type_full code_field in @@ -2442,6 +2459,18 @@ let () = | _ -> None) (fun (loc, ()) -> Transfer_in_lambda loc) ; + register_error_kind + `Permanent + ~id:"selfInLambda" + ~title: "SELF instruction in lambda (typechecking error)" + ~description: + "A SELF instruction was encountered in a lambda expression." + (located empty) + (function + | Self_in_lambda loc -> Some (loc, ()) + | _ -> None) + (fun (loc, ()) -> + Self_in_lambda loc) ; register_error_kind `Permanent ~id:"inconsistentStackLengthsTypeError" diff --git a/lib_embedded_protocol_alpha/src/script_ir_translator.mli b/lib_embedded_protocol_alpha/src/script_ir_translator.mli index 1ed0e0fd9..1d4fa5331 100644 --- a/lib_embedded_protocol_alpha/src/script_ir_translator.mli +++ b/lib_embedded_protocol_alpha/src/script_ir_translator.mli @@ -45,6 +45,7 @@ type error += Unexpected_annotation of Script.location type error += Transfer_in_lambda of Script.location type error += Transfer_in_dip of Script.location +type error += Self_in_lambda of Script.location type error += Bad_stack_length type error += Bad_stack_item of int type error += Invalid_map_body : Script.location * _ Script_typed_ir.stack_ty -> error diff --git a/lib_embedded_protocol_alpha/src/script_typed_ir.ml b/lib_embedded_protocol_alpha/src/script_typed_ir.ml index 3d702a479..296f6e21b 100644 --- a/lib_embedded_protocol_alpha/src/script_typed_ir.ml +++ b/lib_embedded_protocol_alpha/src/script_typed_ir.ml @@ -335,6 +335,8 @@ and ('bef, 'aft) instr = ('rest, n num * 'rest) instr | Source : 'p ty * 'r ty -> ('rest, ('p, 'r) typed_contract * 'rest) instr + | Self : 'p ty * 'r ty -> + ('rest, ('p, 'r) typed_contract * 'rest) instr | Amount : ('rest, Tez.t * 'rest) instr diff --git a/lib_embedded_protocol_alpha/src/tezos_context.mli b/lib_embedded_protocol_alpha/src/tezos_context.mli index 8ca20570b..16b6cbd32 100644 --- a/lib_embedded_protocol_alpha/src/tezos_context.mli +++ b/lib_embedded_protocol_alpha/src/tezos_context.mli @@ -198,6 +198,7 @@ module Script : sig | I_SIZE | I_SOME | I_SOURCE + | I_SELF | I_STEPS_TO_QUOTA | I_SUB | I_SWAP diff --git a/test/contracts/self.tz b/test/contracts/self.tz new file mode 100644 index 000000000..ab682c252 --- /dev/null +++ b/test/contracts/self.tz @@ -0,0 +1,4 @@ +parameter unit ; +storage (contract unit unit) ; +return unit ; +code { MAP_CDR { DROP ; SELF } } diff --git a/test/test_contracts.sh b/test/test_contracts.sh index cdd1664a6..a5c73e7eb 100755 --- a/test/test_contracts.sh +++ b/test/test_contracts.sh @@ -405,6 +405,13 @@ account=tz1SuakBpFdG9b4twyfrSMqZzruxhpMeSrE5 $client transfer 0 from bootstrap1 to default_account -arg "\"$account\"" assert_balance $account "100 ęś©" +# Test SELF +init_with_transfer $CONTRACT_PATH/self.tz $key1 \ + '"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"' 1,000 bootstrap1 +$client transfer 0 from bootstrap1 to self +assert_storage_contains self "\"$(get_contract_addr self)\"" + + assert_fails $client typecheck data '{ Elt 0 1 ; Elt 0 1 }' against type '(map nat nat)' assert_fails $client typecheck data '{ Elt 0 1 ; Elt 10 1 ; Elt 5 1 }' against type '(map nat nat)' assert_fails $client typecheck data '{ "A" ; "C" ; "B" }' against type '(set string)'