Michelson: SELF instruction implemented

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."

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 =

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

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) ;

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

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 () ->

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
+  | Dip : 'a stack_ty * tc_context -> tc_context
-  | Toplevel : { storage_type : 'a ty } -> tc_context
+  | Toplevel : { storage_type : 'sto ty ;
+                 param_type : 'param ty ;
+                 ret_type : 'ret ty } -> tc_context
 
-let add_dip ty annot = function
+let add_dip ty annot prev =
-  | Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot))
+  match prev with
-  | Dip stack -> Dip (Item_t (ty, stack, annot))
+  | 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"

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

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
 

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

test/contracts/self.tz

@@ -0,0 +1,4 @@
+parameter unit ;
+storage (contract unit unit) ;
+return unit ;
+code { MAP_CDR { DROP ; SELF } }

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)'