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

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

Browse Source
This commit is contained in:
Benjamin Canou 2018-04-11 00:14:11 +02:00 committed by Grégoire Henry
parent 46efb6f3b3
commit 5579d3cc97
10 changed files with 134 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
docs/whitedoc/michelson.rst
View File

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

5
src/proto_alpha/lib_protocol/src/alpha_context.mli
View File

@ -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

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

@ -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

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

@ -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

14
src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml
View File

@ -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

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

@ -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

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

@ -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 ->

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

@ -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 ->

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

@ -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

8
src/proto_alpha/lib_protocol/src/script_typed_ir.ml
View File

@ -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 :