Michelson: add untyped address type, and instructions ADDRESS and CONTRACT

docs/whitedoc/michelson.rst

@@ -1378,6 +1378,7 @@ Operations on contracts
 
 ::
 
+    :: address : 'S   ->   key_hash : 'S
     :: contract 'p : 'S   ->   key_hash : 'S
 
 -  ``CREATE_CONTRACT``: Forge a new contract.

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -127,6 +127,8 @@ module Gas : sig
   val alloc_cost : int -> cost
   val alloc_bytes_cost : int -> cost
   val alloc_bits_cost : int -> cost
+  val read_bytes_cost : Z.t -> cost
+  val write_bytes_cost : Z.t -> cost
 
   val ( *@ ) : int -> cost -> cost
   val ( +@ ) : cost -> cost -> cost
@@ -239,6 +241,8 @@ module Script : sig
     | I_XOR
     | I_ITER
     | I_LOOP_LEFT
+    | I_ADDRESS
+    | I_CONTRACT
     | T_bool
     | T_contract
     | T_int
@@ -259,6 +263,7 @@ module Script : sig
     | T_timestamp
     | T_unit
     | T_operation
+    | T_address
 
   type location = Micheline.canonical_location
 

src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml

@@ -169,6 +169,8 @@ module Cost_of = struct
   let compare_res = step_cost 1
 
   (* TODO: protocol operations *)
+  let address = step_cost 3
+  let contract = Gas.read_bytes_cost Z.zero +@ step_cost 3
   let manager = step_cost 3
   let transfer = step_cost 50
   let create_account = step_cost 20
@@ -193,6 +195,7 @@ module Cost_of = struct
   let compare_nat = compare_int
   let compare_key_hash _ _ = alloc_bytes_cost 36
   let compare_timestamp t1 t2 = compare_zint (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2)
+  let compare_address _ _ = step_cost 20
 
   module Typechecking = struct
     let cycle = step_cost 1

src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli

@@ -64,6 +64,8 @@ module Cost_of : sig
   val exec : Gas.cost
   val push : Gas.cost
   val compare_res : Gas.cost
+  val address : Gas.cost
+  val contract : Gas.cost
   val manager : Gas.cost
   val transfer : Gas.cost
   val create_account : Gas.cost
@@ -86,6 +88,7 @@ module Cost_of : sig
   val compare_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
   val compare_key_hash : 'a -> 'b -> Gas.cost
   val compare_timestamp : Script_timestamp.t -> Script_timestamp.t -> Gas.cost
+  val compare_address : Contract.t -> Contract.t -> Gas.cost
 
   module Typechecking : sig
     val cycle : Gas.cost

src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml

@@ -94,6 +94,8 @@ type prim =
   | I_XOR
   | I_ITER
   | I_LOOP_LEFT
+  | I_ADDRESS
+  | I_CONTRACT
   | T_bool
   | T_contract
   | T_int
@@ -114,6 +116,7 @@ type prim =
   | T_timestamp
   | T_unit
   | T_operation
+  | T_address
 
 let valid_case name =
   let is_lower = function  '_' | 'a'..'z' -> true | _ -> false in
@@ -215,6 +218,8 @@ let string_of_prim = function
   | I_XOR -> "XOR"
   | I_ITER -> "ITER"
   | I_LOOP_LEFT -> "LOOP_LEFT"
+  | I_ADDRESS -> "ADDRESS"
+  | I_CONTRACT -> "CONTRACT"
   | T_bool -> "bool"
   | T_contract -> "contract"
   | T_int -> "int"
@@ -235,6 +240,7 @@ let string_of_prim = function
   | T_timestamp -> "timestamp"
   | T_unit -> "unit"
   | T_operation -> "operation"
+  | T_address -> "address"
 
 let prim_of_string = function
   | "parameter" -> ok K_parameter
@@ -317,6 +323,8 @@ let prim_of_string = function
   | "XOR" -> ok I_XOR
   | "ITER" -> ok I_ITER
   | "LOOP_LEFT" -> ok I_LOOP_LEFT
+  | "ADDRESS" -> ok I_ADDRESS
+  | "CONTRACT" -> ok I_CONTRACT
   | "bool" -> ok T_bool
   | "contract" -> ok T_contract
   | "int" -> ok T_int
@@ -337,6 +345,7 @@ let prim_of_string = function
   | "timestamp" -> ok T_timestamp
   | "unit" -> ok T_unit
   | "operation" -> ok T_operation
+  | "address" -> ok T_address
   | n ->
       if valid_case n then
         error (Unknown_primitive_name n)
@@ -463,6 +472,8 @@ let prim_encoding =
     ("XOR", I_XOR) ;
     ("ITER", I_ITER) ;
     ("LOOP_LEFT", I_LOOP_LEFT) ;
+    ("ADDRESS", I_ADDRESS) ;
+    ("CONTRACT", I_CONTRACT) ;
     ("bool", T_bool) ;
     ("contract", T_contract) ;
     ("int", T_int) ;
@@ -482,7 +493,8 @@ let prim_encoding =
     ("tez", T_tez) ;
     ("timestamp", T_timestamp) ;
     ("unit", T_unit) ;
-    ("operation", T_operation) ]
+    ("operation", T_operation) ;
+    ("address", T_address) ]
 
 let () =
   register_error_kind

src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli

@@ -92,6 +92,8 @@ type prim =
   | I_XOR
   | I_ITER
   | I_LOOP_LEFT
+  | I_ADDRESS
+  | I_CONTRACT
   | T_bool
   | T_contract
   | T_int
@@ -112,6 +114,7 @@ type prim =
   | T_timestamp
   | T_unit
   | T_operation
+  | T_address
 
 val prim_encoding : prim Data_encoding.encoding
 

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -605,6 +605,8 @@ let rec interp
               Interp_costs.compare_key_hash a b rest
         | Compare Timestamp_key, Item (a, Item (b, rest)) ->
             consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest
+        | Compare Address_key, Item (a, Item (b, rest)) ->
+            consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest
         (* comparators *)
         | Eq, Item (cmpres, rest) ->
             let cmpres = Script_int.compare cmpres Script_int.zero in
@@ -637,10 +639,29 @@ let rec interp
             Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
             logged_return (Item (cmpres, rest), ctxt)
         (* protocol *)
+        | Address, Item ((_, contract), rest) ->
+            Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt ->
+            logged_return (Item (contract, rest), ctxt)
+        | Contract t, Item (contract, rest) ->
+            Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt ->
+            Contract.exists ctxt contract >>=? fun exists ->
+            if exists then
+              Script_ir_translator.parse_contract ctxt loc t contract >>=? fun (ctxt, contract) ->
+              logged_return (Item (Some contract, rest), ctxt)
+            else
+              logged_return (Item (None, rest), ctxt)
         | Manager, Item ((_, contract), rest) ->
             Lwt.return (Gas.consume ctxt Interp_costs.manager) >>=? fun ctxt ->
             Contract.get_manager ctxt contract >>=? fun manager ->
             logged_return (Item (manager, rest), ctxt)
+        | Address_manager, Item (contract, rest) ->
+            Lwt.return (Gas.consume ctxt Interp_costs.manager) >>=? fun ctxt ->
+            Contract.exists ctxt contract >>=? fun exists ->
+            if exists then
+              Contract.get_manager ctxt contract >>=? fun manager ->
+              logged_return (Item (Some manager, rest), ctxt)
+            else
+              logged_return (Item (None, rest), ctxt)
         | Transfer_tokens,
           Item (p, Item (amount, Item ((tp, destination), rest))) ->
             Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -46,6 +46,7 @@ let comparable_type_size : type t. t comparable_ty -> int = function
   | Bool_key -> 1
   | Key_hash_key -> 1
   | Timestamp_key -> 1
+  | Address_key -> 1
 
 let rec type_size : type t. t ty -> int = function
   | Unit_t -> 1
@@ -57,6 +58,7 @@ let rec type_size : type t. t ty -> int = function
   | Key_hash_t -> 1
   | Key_t -> 1
   | Timestamp_t -> 1
+  | Address_t -> 1
   | Bool_t -> 1
   | Operation_t -> 1
   | Pair_t ((l, _), (r, _)) ->
@@ -189,7 +191,10 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
   | Gt -> 0
   | Le -> 0
   | Ge -> 0
+  | Address -> 0
+  | Contract _ -> 1
   | Manager -> 0
+  | Address_manager -> 0
   | Transfer_tokens -> 1
   | Create_account -> 0
   | Implicit_account -> 0
@@ -299,7 +304,9 @@ let namespace = function
   | I_UPDATE
   | I_XOR
   | I_ITER
-  | I_LOOP_LEFT -> Instr_namespace
+  | I_LOOP_LEFT
+  | I_ADDRESS
+  | I_CONTRACT -> Instr_namespace
   | T_bool
   | T_contract
   | T_int
@@ -319,7 +326,8 @@ let namespace = function
   | T_tez
   | T_timestamp
   | T_unit
-  | T_operation -> Type_namespace
+  | T_operation
+  | T_address -> Type_namespace
 
 
 let unexpected expr exp_kinds exp_ns exp_prims =
@@ -365,6 +373,7 @@ let compare_comparable
         else if Compare.Int.(res > 0) then 1
         else -1
     | Timestamp_key -> Script_timestamp.compare x y
+    | Address_key -> Contract.compare x y
 
 let empty_set
   : type a. a comparable_ty -> a set
@@ -491,6 +500,7 @@ let ty_of_comparable_ty
   | Bool_key -> Bool_t
   | Key_hash_key -> Key_hash_t
   | Timestamp_key -> Timestamp_t
+  | Address_key -> Address_t
 
 let unparse_comparable_ty
   : type a. a comparable_ty -> Script.node = function
@@ -501,6 +511,7 @@ let unparse_comparable_ty
   | Bool_key -> Prim (-1, T_bool, [], None)
   | Key_hash_key -> Prim (-1, T_key_hash, [], None)
   | Timestamp_key -> Prim (-1, T_timestamp, [], None)
+  | Address_key -> Prim (-1, T_address, [], None)
 
 let rec unparse_ty
   : type a. annot -> a ty -> Script.node = fun annot ->
@@ -514,6 +525,7 @@ let rec unparse_ty
   | Key_hash_t -> Prim (-1, T_key_hash, [], annot)
   | Key_t -> Prim (-1, T_key, [], annot)
   | Timestamp_t -> Prim (-1, T_timestamp, [], annot)
+  | Address_t -> Prim (-1, T_address, [], annot)
   | Signature_t -> Prim (-1, T_signature, [], annot)
   | Operation_t -> Prim (-1, T_operation, [], annot)
   | Contract_t ut ->
@@ -581,6 +593,9 @@ let rec unparse_data
           | None -> ok @@ (Int (-1, Script_timestamp.to_zint t), gas)
           | Some s -> ok @@ (String (-1, s), gas)
         end
+    | Address_t, c  ->
+        Gas.consume ctxt Unparse_costs.contract >|? fun gas ->
+        (String (-1, Contract.to_b58check c), gas)
     | Contract_t _, (_, c)  ->
         Gas.consume ctxt Unparse_costs.contract >|? fun gas ->
         (String (-1, Contract.to_b58check c), gas)
@@ -676,6 +691,7 @@ let comparable_ty_eq
     | Bool_key, Bool_key -> Ok Eq
     | Key_hash_key, Key_hash_key -> Ok Eq
     | Timestamp_key, Timestamp_key -> Ok Eq
+    | Address_key, Address_key -> Ok Eq
     | _, _ -> error (Inconsistent_types (ty_of_comparable_ty ta, ty_of_comparable_ty tb))
 
 let rec ty_eq
@@ -691,6 +707,7 @@ let rec ty_eq
     | Signature_t, Signature_t -> Ok Eq
     | Tez_t, Tez_t -> Ok Eq
     | Timestamp_t, Timestamp_t -> Ok Eq
+    | Address_t, Address_t -> Ok Eq
     | Bool_t, Bool_t -> Ok Eq
     | Operation_t, Operation_t -> Ok Eq
     | Map_t (tal, tar), Map_t (tbl, tbr) ->
@@ -771,7 +788,8 @@ let merge_comparable_types
     | Bool_key, Bool_key -> ta
     | Key_hash_key, Key_hash_key -> ta
     | Timestamp_key, Timestamp_key -> ta
-    | _, _ -> assert false
+    | Address_key, Address_key -> ta
+    | _, _ -> assert false (* FIXME: fix injectivity of some types *)
 
 let error_unexpected_annot loc annot =
   match annot with
@@ -801,6 +819,7 @@ let merge_types :
       | Signature_t, Signature_t -> ok Signature_t
       | Tez_t, Tez_t -> ok Tez_t
       | Timestamp_t, Timestamp_t -> ok Timestamp_t
+      | Address_t, Address_t -> ok Address_t
       | Bool_t, Bool_t -> ok Bool_t
       | Operation_t, Operation_t -> ok Operation_t
       | Map_t (tal, tar), Map_t (tbl, tbr) ->
@@ -907,9 +926,10 @@ let rec parse_comparable_ty
     | Prim (_, T_bool, [], _) -> ok (Ex_comparable_ty Bool_key)
     | Prim (_, T_key_hash, [], _) -> ok (Ex_comparable_ty Key_hash_key)
     | Prim (_, T_timestamp, [], _) -> ok (Ex_comparable_ty Timestamp_key)
+    | Prim (_, T_address, [], _) -> ok (Ex_comparable_ty Address_key)
     | Prim (loc, (T_int | T_nat
                  | T_string | T_tez | T_bool
-                 | T_key | T_timestamp as prim), l, _) ->
+                 | T_key | T_address | T_timestamp as prim), l, _) ->
         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
@@ -959,6 +979,8 @@ and parse_ty
         ok (Ex_ty Key_hash_t, annot)
     | Prim (_, T_timestamp, [], annot) ->
         ok (Ex_ty Timestamp_t, annot)
+    | Prim (_, T_address, [], annot) ->
+        ok (Ex_ty Address_t, annot)
     | Prim (_, T_signature, [], annot) ->
         ok (Ex_ty Signature_t, annot)
     | Prim (_, T_operation, [], annot) ->
@@ -999,7 +1021,8 @@ and parse_ty
     | Prim (loc, (T_unit | T_signature
                  | T_int | T_nat
                  | T_string | T_tez | T_bool
-                 | T_key | T_key_hash | T_timestamp as prim), l, _) ->
+                 | T_key | T_key_hash
+                 | T_timestamp | T_address as prim), l, _) ->
         error (Invalid_arity (loc, prim, 0, List.length l))
     | Prim (loc, (T_set | T_list | T_option as prim), l, _) ->
         error (Invalid_arity (loc, prim, 1, List.length l))
@@ -1180,6 +1203,14 @@ let rec parse_data
       end
     | Operation_t, expr ->
         traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
+    (* Addresses *)
+    | Address_t, String (_, s) ->
+        Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt ->
+        traced @@
+        (Lwt.return (Contract.of_b58check s)) >>=? fun c ->
+        return (c, ctxt)
+    | Address_t, expr ->
+        traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
     (* Contracts *)
     | Contract_t ty1, String (loc, s) ->
         Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt ->
@@ -1955,6 +1986,10 @@ and parse_instr
       Item_t (Timestamp_t, Item_t (Timestamp_t, rest, _), _) ->
         typed ctxt loc (Compare Timestamp_key)
           (Item_t (Int_t, rest, instr_annot))
+    | Prim (loc, I_COMPARE, [], instr_annot),
+      Item_t (Address_t, Item_t (Address_t, rest, _), _) ->
+        typed ctxt loc (Compare Address_key)
+          (Item_t (Int_t, rest, instr_annot))
     (* comparators *)
     | Prim (loc, I_EQ, [], instr_annot),
       Item_t (Int_t, rest, _) ->
@@ -1981,10 +2016,24 @@ and parse_instr
         typed ctxt loc Ge
           (Item_t (Bool_t, rest, instr_annot))
     (* protocol *)
+    | Prim (loc, I_ADDRESS, [], _),
+      Item_t (Contract_t _, rest, instr_annot) ->
+        typed ctxt loc Address
+          (Item_t (Address_t, rest, instr_annot))
+    | Prim (loc, I_CONTRACT, [ ty ], _),
+      Item_t (Address_t, rest, instr_annot) ->
+        Lwt.return (parse_ty ~allow_big_map:false ty) >>=? fun (Ex_ty t, annot) ->
+        fail_unexpected_annot loc annot >>=? fun () ->
+        typed ctxt loc (Contract t)
+          (Item_t (Option_t (Contract_t t), rest, instr_annot))
     | Prim (loc, I_MANAGER, [], instr_annot),
       Item_t (Contract_t _, rest, _) ->
         typed ctxt loc Manager
           (Item_t (Key_hash_t, rest, instr_annot))
+    | Prim (loc, I_MANAGER, [], instr_annot),
+      Item_t (Address_t, rest, _) ->
+        typed ctxt loc Address_manager
+          (Item_t (Option_t Key_hash_t, rest, instr_annot))
     | Prim (loc, I_TRANSFER_TOKENS, [], instr_annot),
       Item_t (p, Item_t
                 (Tez_t, Item_t
@@ -2105,11 +2154,11 @@ and parse_instr
                  | I_CREATE_CONTRACT | I_NOW
                  | I_IMPLICIT_ACCOUNT | I_AMOUNT | I_BALANCE
                  | I_CHECK_SIGNATURE | I_HASH_KEY
-                 | I_H | I_STEPS_TO_QUOTA
+                 | I_H | I_STEPS_TO_QUOTA | I_ADDRESS
                  as name), (_ :: _ as l), _), _ ->
         fail (Invalid_arity (loc, name, 0, List.length l))
     | Prim (loc, (I_NONE | I_LEFT | I_RIGHT | I_NIL | I_MAP | I_ITER
-                 | I_EMPTY_SET | I_DIP | I_LOOP | I_LOOP_LEFT
+                 | I_EMPTY_SET | I_DIP | I_LOOP | I_LOOP_LEFT | I_CONTRACT
                  as name), ([]
                            | _ :: _ :: _ as l), _), _ ->
         fail (Invalid_arity (loc, name, 1, List.length l))
@@ -2269,6 +2318,23 @@ let parse_script
          ctxt ?type_logger ~check_operations (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) ->
     return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt)
 
+let parse_contract :
+  type t. context -> Script.location -> t Script_typed_ir.ty -> Contract.t ->
+  (context * t Script_typed_ir.typed_contract) tzresult Lwt.t
+  = fun ctxt loc ty contract ->
+    Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with
+    | None ->
+        begin match ty with
+          | Unit_t -> return (ctxt, (ty, contract))
+          | _ -> fail (Invalid_contract (loc, contract))
+        end
+    | Some script ->
+        Lwt.return @@ parse_toplevel script.code >>=? fun (arg_type, _, _) ->
+        let arg_type = Micheline.strip_locations arg_type in
+        Lwt.return (parse_ty ~allow_big_map:false (Micheline.root arg_type)) >>=? fun (Ex_ty arg_type, _) ->
+        Lwt.return (ty_eq ty arg_type) >>=? fun Eq ->
+        return (ctxt, (ty, contract))
+
 let typecheck_code
   : context -> Script.expr -> (type_map * context) tzresult Lwt.t
   = fun ctxt code ->

src/proto_alpha/lib_protocol/src/script_ir_translator.mli

@@ -82,6 +82,10 @@ val parse_script :
   ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
   context -> check_operations: bool -> Script.t -> (ex_script * context) tzresult Lwt.t
 
+val parse_contract :
+  context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
+  (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t
+
 val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (string * context) tzresult
 
 val extract_big_map : 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option

src/proto_alpha/lib_protocol/src/script_typed_ir.ml

@@ -21,6 +21,7 @@ type 'ty comparable_ty =
   | Bool_key : bool comparable_ty
   | Key_hash_key : public_key_hash comparable_ty
   | Timestamp_key : Script_timestamp.t comparable_ty
+  | Address_key : Contract.t comparable_ty
 
 module type Boxed_set = sig
   type elt
@@ -71,6 +72,7 @@ and 'ty ty =
   | Key_hash_t : public_key_hash ty
   | Key_t : public_key ty
   | Timestamp_t : Script_timestamp.t ty
+  | Address_t : Contract.t ty
   | Bool_t : bool ty
   | Pair_t : ('a ty * annot) * ('b ty * annot) -> ('a, 'b) pair ty
   | Union_t : ('a ty * annot) * ('b ty * annot) -> ('a, 'b) union ty
@@ -315,8 +317,14 @@ and ('bef, 'aft) instr =
       (z num * 'rest, bool * 'rest) instr
 
   (* protocol *)
+  | Address :
+      (_ typed_contract * 'rest, Contract.t * 'rest) instr
+  | Contract : 'p ty ->
+    (Contract.t * 'rest, 'p typed_contract option * 'rest) instr
   | Manager :
       ('arg typed_contract * 'rest, public_key_hash * 'rest) instr
+  | Address_manager :
+      (Contract.t * 'rest, public_key_hash option * 'rest) instr
   | Transfer_tokens :
       ('arg * (Tez.t * ('arg typed_contract * 'rest)), internal_operation * 'rest) instr
   | Create_account :