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

Michelson: add PACK and UNPACK

Browse Source
This commit is contained in:
Benjamin Canou 2018-06-14 23:03:09 +02:00
parent 5fe6bd9a54
commit 197b29b040
12 changed files with 113 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
docs/whitedoc/michelson.rst
View File

@ -1442,6 +1442,22 @@ Special operations
:: 'S -> timestamp : 'S
Serialization
~~~~~~~~~~~~~
- ``PACK``: Serializes a piece of data to its optimized
binary representation.
::
:: 'a : 'S -> bytes : 'S
- ``UNPACK 'a``: Deserializes a piece of data, is valid.
::
:: bytes : 'S -> option 'a : 'S
Cryptographic primitives
~~~~~~~~~~~~~~~~~~~~~~~~

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

@ -177,6 +177,8 @@ module Script : sig
| D_Some
| D_True
| D_Unit
| I_PACK
| I_UNPACK
| I_BLAKE2B
| I_ABS
| I_ADD

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

@ -168,6 +168,9 @@ module Cost_of = struct
let compare_res = step_cost 1
let unpack bytes = 10 *@ step_cost (MBytes.length bytes)
let pack bytes = alloc_bytes_cost (MBytes.length bytes)
(* TODO: protocol operations *)
let address = step_cost 3
let contract = Gas.read_bytes_cost Z.zero +@ step_cost 3

2
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 pack : MBytes.t -> Gas.cost
val unpack : MBytes.t -> Gas.cost
val address : Gas.cost
val contract : Gas.cost
val manager : Gas.cost

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

@ -26,6 +26,8 @@ type prim =
| D_Some
| D_True
| D_Unit
| I_PACK
| I_UNPACK
| I_BLAKE2B
| I_ABS
| I_ADD
@ -154,6 +156,8 @@ let string_of_prim = function
| D_Some -> "Some"
| D_True -> "True"
| D_Unit -> "Unit"
| I_PACK -> "PACK"
| I_UNPACK -> "UNPACK"
| I_BLAKE2B -> "BLAKE2B"
| I_ABS -> "ABS"
| I_ADD -> "ADD"
@ -263,6 +267,8 @@ let prim_of_string = function
| "Some" -> ok D_Some
| "True" -> ok D_True
| "Unit" -> ok D_Unit
| "PACK" -> ok I_PACK
| "UNPACK" -> ok I_UNPACK
| "BLAKE2B" -> ok I_BLAKE2B
| "ABS" -> ok I_ABS
| "ADD" -> ok I_ADD
@ -417,6 +423,8 @@ let prim_encoding =
("Some", D_Some) ;
("True", D_True) ;
("Unit", D_Unit) ;
("PACK", I_PACK) ;
("UNPACK", I_UNPACK) ;
("BLAKE2B", I_BLAKE2B) ;
("ABS", I_ABS) ;
("ADD", I_ADD) ;

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

@ -24,6 +24,8 @@ type prim =
| D_Some
| D_True
| D_Unit
| I_PACK
| I_UNPACK
| I_BLAKE2B
| I_ABS
| I_ADD

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

@ -598,6 +598,22 @@ let rec interp
let cmpres = Compare.Int.(cmpres >= 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
logged_return (Item (cmpres, rest), ctxt)
(* packing *)
| Pack t, Item (value, rest) ->
unparse_data ctxt Optimized t value >>=? fun (expr, ctxt) ->
let expr = (Micheline.strip_locations expr) in
let bytes = Data_encoding.Binary.to_bytes_exn Script.expr_encoding expr in
Lwt.return (Gas.consume ctxt (Interp_costs.unpack bytes)) >>=? fun ctxt ->
logged_return (Item (bytes, rest), ctxt)
| Unpack t, Item (bytes, rest) ->
Lwt.return (Gas.consume ctxt (Interp_costs.pack bytes)) >>=? fun ctxt ->
begin match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
| None ->
logged_return (Item (None, rest), ctxt)
| Some expr ->
parse_data ctxt t (Micheline.root expr) >>=? fun (value, ctxt) ->
logged_return (Item (Some value, rest), ctxt)
end
(* protocol *)
| Address, Item ((_, contract), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt ->

2
src/proto_alpha/lib_protocol/src/script_ir_annot.ml
View File

@ -28,6 +28,8 @@ let default_cdr_annot = Some (`Field_annot "cdr")
let default_contract_annot = Some (`Field_annot "contract")
let default_addr_annot = Some (`Field_annot "address")
let default_manager_annot = Some (`Field_annot "manager")
let default_pack_annot = Some (`Field_annot "packed")
let default_unpack_annot = Some (`Field_annot "unpacked")
let default_elt_annot = Some (`Field_annot "elt")
let default_key_annot = Some (`Field_annot "key")

2
src/proto_alpha/lib_protocol/src/script_ir_annot.mli
View File

@ -28,6 +28,8 @@ val default_cdr_annot : field_annot option
val default_contract_annot : field_annot option
val default_addr_annot : field_annot option
val default_manager_annot : field_annot option
val default_pack_annot : field_annot option
val default_unpack_annot : field_annot option
val default_elt_annot : field_annot option
val default_key_annot : field_annot option

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

@ -209,6 +209,8 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
| Self _ -> 1
| Amount -> 0
| Set_delegate -> 0
| Pack _ -> 0
| Unpack _ -> 1
(* ---- Error helpers -------------------------------------------------------*)
@ -239,6 +241,8 @@ let namespace = function
| D_Some
| D_True
| D_Unit -> Constant_namespace
| I_PACK
| I_UNPACK
| I_BLAKE2B
| I_ABS
| I_ADD
@ -1060,6 +1064,35 @@ and parse_ty :
T_string ; T_bytes ; T_mutez ; T_bool ;
T_key ; T_key_hash ; T_timestamp ]
let check_no_big_map_or_operation loc root =
let rec check : type t. t ty -> unit tzresult = function
| Big_map_t _ -> error (Unexpected_big_map loc)
| Operation_t _ -> error (Unexpected_operation loc)
| Unit_t _ -> ok ()
| Int_t _ -> ok ()
| Nat_t _ -> ok ()
| Signature_t _ -> ok ()
| String_t _ -> ok ()
| Bytes_t _ -> ok ()
| Mutez_t _ -> ok ()
| Key_hash_t _ -> ok ()
| Key_t _ -> ok ()
| Timestamp_t _ -> ok ()
| Address_t _ -> ok ()
| Bool_t _ -> ok ()
| Pair_t ((l_ty, _, _), (r_ty, _, _), _) ->
check l_ty >>? fun () -> check r_ty
| Union_t ((l_ty, _), (r_ty, _), _) ->
check l_ty >>? fun () -> check r_ty
| Lambda_t (l_ty, r_ty, _) ->
check l_ty >>? fun () -> check r_ty
| Option_t ((v_ty, _), _, _) -> check v_ty
| List_t (elt_ty, _) -> check elt_ty
| Set_t (_, _) -> ok ()
| Map_t (_, elt_ty, _) -> check elt_ty
| Contract_t (_, _) -> ok () in
check root
let rec unparse_stack
: type a. a stack_ty -> (Script.expr * Script.annot) list
= function
@ -2240,6 +2273,23 @@ and parse_instr
Item_t (t, stack, _) ->
parse_var_annot loc annot >>=? fun annot -> (* can erase annot *)
typed ctxt loc Nop (Item_t (t, stack, annot))
(* packing *)
| Prim (loc, I_PACK, [], annot),
Item_t (t, rest, unpacked_annot) ->
Lwt.return (check_no_big_map_or_operation loc t) >>=? fun () ->
parse_var_annot loc annot ~default:(gen_access_annot unpacked_annot default_pack_annot)
>>=? fun annot ->
typed ctxt loc (Pack t)
(Item_t (Bytes_t None, rest, annot))
| Prim (loc, I_UNPACK, [ ty ], annot),
Item_t (Bytes_t _, rest, packed_annot) ->
Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t) ->
let stack_annot = gen_access_annot packed_annot default_unpack_annot in
parse_constr_annot loc annot
~if_special_first:(var_to_field_annot stack_annot)
>>=? fun (annot, ty_name, some_field, none_field) ->
typed ctxt loc (Unpack t)
(Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot))
(* protocol *)
| Prim (loc, I_ADDRESS, [], annot),
Item_t (Contract_t _, rest, contract_annot) ->
@ -2802,10 +2852,14 @@ let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } =
return ({ code = lazy_expr (strip_locations code) ;
storage = lazy_expr (strip_locations storage) }, ctxt)
let hash_data ctxt typ data =
let pack_data ctxt typ data =
unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) ->
let unparsed = strip_annotations @@ data in
let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in
return (bytes, ctxt)
let hash_data ctxt typ data =
pack_data ctxt typ data >>=? fun (bytes, ctxt) ->
return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt)
(* ---------------- Big map -------------------------------------------------*)

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

@ -95,6 +95,7 @@ val parse_contract :
context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
(context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t
val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t
val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t
val extract_big_map :

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

@ -339,6 +339,10 @@ and ('bef, 'aft) instr =
(public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr
| Hash_key :
(public_key * 'rest, public_key_hash * 'rest) instr
| Pack : 'a ty ->
('a * 'rest, MBytes.t * 'rest) instr
| Unpack : 'a ty ->
(MBytes.t * 'rest, 'a option * 'rest) instr
| Blake2b : 'a ty ->
('a * 'rest, MBytes.t * 'rest) instr
| Steps_to_quota : (* TODO: check that it always returns a nat *)