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

Michelson: Better macros for PAIR/UNPAIR

Browse Source
This commit is contained in:
Alain Mebsout 2018-05-24 17:02:00 +02:00 committed by Benjamin Canou
parent 435d135aa0
commit b51dae6de5
6 changed files with 180 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/bin_client/test/contracts/big_map_union.tz
View File

@ -1,6 +1,6 @@
parameter (list (pair string int)) ; parameter (list (pair string int)) ;
storage (pair (big_map string int) unit) ; storage (pair (big_map string int) unit) ;
code { UNPAAIAIR ; code { UNPAPAIR ;
ITER { UNPAIR ; DUUUP ; DUUP; GET ; ITER { UNPAIR ; DUUUP ; DUUP; GET ;
IF_NONE { PUSH int 0 } {} ; IF_NONE { PUSH int 0 } {} ;
SWAP ; DIP { ADD ; SOME } ; SWAP ; DIP { ADD ; SOME } ;

2
src/bin_client/test/contracts/pair_macro.tz
View File

@ -1,4 +1,4 @@
parameter unit; parameter unit;
storage unit; storage unit;
code { UNIT; UNIT; UNIT; UNIT; UNIT; PAIAAIAIAIR @name; DROP; code { UNIT; UNIT; UNIT; UNIT; UNIT; PAPAPAPAIR @name; DROP;
CDR; NIL operation; PAIR} CDR; NIL operation; PAIR}

7
src/bin_client/test/contracts/unpair_macro.tz
View File

@ -1,3 +1,8 @@
parameter unit; parameter unit;
storage unit; storage unit;
code { UNIT; UNIT; UNIT; UNIT; PAIAAIR; UNPAIAAIR; DROP; DROP; DROP; DROP; CAR; NIL operation; PAIR } code { UNIT @4; UNIT @3; UNIT @2; UNIT @1;
PAIR; UNPAIR @x1 @x2;
PPAIPAIR; UNPPAIPAIR @uno @due @tres @quatro;
PAPAPAIR; UNPAPAPAIR @un @deux @trois @quatre;
PAPPAIIR; UNPAPPAIIR @one @two @three @four;
DROP; DROP; DROP; DROP; CAR; NIL operation; PAIR }

22
src/proto_alpha/lib_baking/test/test_michelson_parser.ml
View File

@ -211,15 +211,7 @@ let test_expansion () =
(Prim (zero_loc, "PAIR", [], [])) (Prim (zero_loc, "PAIR", [], []))
(Prim (zero_loc, "PAIR", [], [])) >>? fun () -> (Prim (zero_loc, "PAIR", [], [])) >>? fun () ->
assert_expands assert_expands
(Prim (zero_loc, "PAAIR", [], [])) (Prim (zero_loc, "PAPPAIIR", [], []))
(Seq (zero_loc,
[Prim
(zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
[])])) >>? fun () ->
assert_expands
(Prim (zero_loc, "PAAIAIR", [], []))
(Seq (zero_loc, [Prim (Seq (zero_loc, [Prim
(zero_loc, (zero_loc,
"DIP", "DIP",
@ -227,6 +219,13 @@ let test_expansion () =
(zero_loc, (zero_loc,
[Prim (zero_loc, "PAIR", [], [])])], [Prim (zero_loc, "PAIR", [], [])])],
[]); []);
Prim
(zero_loc,
"DIP",
[Seq
(zero_loc,
[Prim (zero_loc, "PAIR", [], [])])],
[]);
Prim (zero_loc, "PAIR", [], [])])) Prim (zero_loc, "PAIR", [], [])]))
let assert_unexpansion_consistent original = let assert_unexpansion_consistent original =
@ -242,7 +241,10 @@ let assert_unexpansion_consistent original =
ok () ok ()
let test_unexpansion_consistency () = let test_unexpansion_consistency () =
assert_unexpansion_consistent (Prim (zero_loc, "PAAAIAIR", [], [])) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "PAPPAIIR", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "PPAIPAIR", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "UNPAPPAIIR", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "UNPAPAPAIR", [], [])) >>? fun () ->
assert_unexpansion_consistent assert_unexpansion_consistent
(Prim (zero_loc, "DIIIP", [ Seq (zero_loc, [ Prim (zero_loc, "DROP", [], []) ]) ], [])) >>? fun () -> (Prim (zero_loc, "DIIIP", [ Seq (zero_loc, [ Prim (zero_loc, "DROP", [], []) ]) ], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "SET_CAR", [], [])) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "SET_CAR", [], [])) >>? fun () ->

241
src/proto_alpha/lib_client/michelson_v1_macros.ml
View File

@ -10,6 +10,8 @@
open Tezos_micheline open Tezos_micheline
open Micheline open Micheline
module IntMap = Map.Make (Compare.Int)
type 'l node = ('l, string) Micheline.node type 'l node = ('l, string) Micheline.node
type error += Unexpected_macro_annotation of string type error += Unexpected_macro_annotation of string
@ -277,7 +279,44 @@ let expand_dxiiivp original =
exception Not_a_pair exception Not_a_pair
let expand_paaiair original = let rec dip ~loc depth instr =
if depth <= 0
then instr
else dip ~loc (depth - 1) (Prim (loc, "DIP", [ Seq (loc, [ instr ]) ], []))
type pair_item =
| A
| I
| P of int * pair_item * pair_item
let parse_pair_substr str ~len start =
let rec parse ?left i =
if i = len - 1 then
raise_notrace Not_a_pair
else if String.get str i = 'P' then
let next_i, l = parse ~left:true (i + 1) in
let next_i, r = parse ~left:false next_i in
next_i, P (i, l, r)
else if String.get str i = 'A' && left = Some true then
i + 1, A
else if String.get str i = 'I' && left <> Some true then
i + 1, I
else
raise_notrace Not_a_pair in
let last, ast = parse start in
if last <> len - 1 then
raise_notrace Not_a_pair
else
ast
let unparse_pair_item ast =
let rec unparse ast acc = match ast with
| P (_, l, r) -> unparse r (unparse l ("P" :: acc))
| A -> "A" :: acc
| I -> "I" :: acc in
List.rev ("R" :: unparse ast []) |> String.concat ""
let expand_pappaiir original =
match original with match original with
| Prim (loc, str, args, annot) -> | Prim (loc, str, args, annot) ->
let len = String.length str in let len = String.length str in
@ -285,25 +324,20 @@ let expand_paaiair original =
&& String.get str 0 = 'P' && String.get str 0 = 'P'
&& String.get str (len - 1) = 'R' && String.get str (len - 1) = 'R'
&& check_letters str 1 (len - 2) && check_letters str 1 (len - 2)
(function 'A' | 'I' -> true | _ -> false) then (function 'P' | 'A' | 'I' -> true | _ -> false) then
try try
let rec parse i acc = let rec parse p (depth, acc) =
if i = 0 then match p with
acc | P (i, left, right) ->
else if String.get str i = 'I' let annot = if i = 0 then annot else [] in
&& String.get str (i - 1) = 'A' then let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc in
parse (i - 2) (Prim (loc, "PAIR", [], if i = (len - 2) then annot else []) :: acc) (depth, acc)
else if String.get str i = 'A' then |> parse left
match acc with |> parse right
| [] -> | A | I -> (depth + 1, acc)
raise_notrace Not_a_pair in
| acc :: accs -> let ast = parse_pair_substr str ~len 0 in
parse (i - 1) let _, expanded = parse ast (0, []) in
(Prim (loc, "DIP", [ Seq (loc, [ acc ]) ], [])
:: accs)
else
raise_notrace Not_a_pair in
let expanded = parse (len - 2) [] in
begin match args with begin match args with
| [] -> ok () | [] -> ok ()
| _ :: _ -> error (Invalid_arity (str, List.length args, 0)) | _ :: _ -> error (Invalid_arity (str, List.length args, 0))
@ -314,8 +348,7 @@ let expand_paaiair original =
ok None ok None
| _ -> ok None | _ -> ok None
(* TODO incorrect annotations *) let expand_unpappaiir original =
let expand_unpaaiair original =
match original with match original with
| Prim (loc, str, args, annot) -> | Prim (loc, str, args, annot) ->
let len = String.length str in let len = String.length str in
@ -323,42 +356,45 @@ let expand_unpaaiair original =
&& String.sub str 0 3 = "UNP" && String.sub str 0 3 = "UNP"
&& String.get str (len - 1) = 'R' && String.get str (len - 1) = 'R'
&& check_letters str 3 (len - 2) && check_letters str 3 (len - 2)
(function 'A' | 'I' -> true | _ -> false) then (function 'P' | 'A' | 'I' -> true | _ -> false) then
try try
let rec parse i remaining_annots acc = let unpair car_annot cdr_annot =
if i = 2 then Seq (loc, [ Prim (loc, "DUP", [], []) ;
match acc with Prim (loc, "CAR", [], car_annot) ;
| [ Seq _ as acc ] -> acc dip ~loc 1 (Prim (loc, "CDR", [], cdr_annot)) ;
| _ -> Seq (loc, List.rev acc) ]) in
else if String.get str i = 'I' let rec find_annots_pos p_pos ast annots acc =
&& String.get str (i - 1) = 'A' then match ast, annots with
let car_annot, cdr_annot, remaining_annots = | _, [] -> annots, acc
match remaining_annots with | P (i, left, right), _ ->
| [] -> [], [], [] let annots, acc = find_annots_pos i left annots acc in
| a :: b :: r when i = 4 -> [ a ], [ b ], r find_annots_pos i right annots acc
| a :: r -> [ a ], [], r in | A, a :: annots ->
parse (i - 2) remaining_annots let pos = match IntMap.find_opt p_pos acc with
(Seq (loc, [ Prim (loc, "DUP", [], []) ; | None -> [ a ], []
Prim (loc, "CAR", [], car_annot) ; | Some (_, cdr) -> [ a ], cdr in
Prim (loc, "DIP", annots, IntMap.add p_pos pos acc
[ Seq (loc, | I, a :: annots ->
[ Prim (loc, "CDR", [], cdr_annot) ]) ], []) ]) let pos = match IntMap.find_opt p_pos acc with
:: acc) | None -> [], [ a ]
else if String.get str i = 'A' then | Some (car, _) -> car, [ a ] in
match acc with annots, IntMap.add p_pos pos acc in
| [] -> let ast = parse_pair_substr str ~len 2 in
raise_notrace Not_a_pair let _, annots_pos = find_annots_pos 0 ast annot IntMap.empty in
| (Seq _ as acc) :: accs -> let rec parse p (depth, acc) =
parse (i - 1) remaining_annots match p with
(Prim (loc, "DIP", [ acc ], []) :: accs) | P (i, left, right) ->
| acc :: accs -> let car_annot, cdr_annot =
parse (i - 1) remaining_annots match IntMap.find_opt i annots_pos with
(Prim (loc, "DIP", | None -> [], []
[ Seq (loc, [ acc ]) ], | Some (car_annot, cdr_annot) -> car_annot, cdr_annot in
[]) :: accs) let acc = dip ~loc depth (unpair car_annot cdr_annot) :: acc in
else (depth, acc)
raise_notrace Not_a_pair in |> parse left
let expanded = parse (len - 2) annot [] in |> parse right
| A | I -> (depth + 1, acc) in
let _, rev_expanded = parse ast (0, []) in
let expanded = Seq (loc, List.rev rev_expanded) in
begin match args with begin match args with
| [] -> ok () | [] -> ok ()
| _ :: _ -> error (Invalid_arity (str, List.length args, 0)) | _ :: _ -> error (Invalid_arity (str, List.length args, 0))
@ -548,8 +584,10 @@ let expand original =
expand_set_caddadr ; expand_set_caddadr ;
expand_map_caddadr ; expand_map_caddadr ;
expand_dxiiivp ; expand_dxiiivp ;
expand_paaiair ; (* expand_paaiair ; *)
expand_unpaaiair ; expand_pappaiir ;
(* expand_unpaaiair ; *)
expand_unpappaiir ;
expand_duuuuup ; expand_duuuuup ;
expand_compare ; expand_compare ;
expand_asserts ; expand_asserts ;
@ -781,48 +819,81 @@ let unexpand_duuuuup expanded =
| None -> None | None -> None
| Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], [])) | Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], []))
let unexpand_paaiair expanded = let rec normalize_pair_item ?(right=false) = function
| P (i, a, b) -> P (i, normalize_pair_item a, normalize_pair_item ~right:true b)
| A when right -> I
| A -> A
| I -> I
let unexpand_pappaiir expanded =
match expanded with match expanded with
| Seq (_, [ Prim (_, "PAIR", [], []) ]) -> Some expanded | Seq (_, [ Prim (_, "PAIR", [], []) ]) -> Some expanded
| Seq (loc, (_ :: _ as nodes)) -> | Seq (loc, (_ :: _ as nodes)) ->
let rec destruct acc = function let rec exec stack nodes = match nodes, stack with
| [] -> Some acc | [], _ -> stack
| Prim (_, "DIP", [ Seq (_, [ sub ]) ], []) :: rest -> | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, a :: rstack ->
destruct ("A" :: acc) (sub :: rest) exec (a :: exec rstack sub) rest
| Prim (_, "PAIR", [], []) :: rest -> | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, [] ->
destruct ("AI" :: acc) rest exec (A :: exec [] sub) rest
| _ -> None in | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack ->
begin match destruct [] nodes with exec (P (0, a, b) :: rstack) rest
| None -> None | Prim (_, "PAIR", [], []) :: rest, [ a ] ->
| Some seq -> exec [ P (0, a, I) ] rest
let name = String.concat "" ("P" :: List.rev ("R" :: seq)) in | Prim (_, "PAIR", [], []) :: rest, [] ->
exec [ P (0, A, I) ] rest
| _ -> raise_notrace Not_a_pair in
begin match exec [] nodes with
| [] -> None
| res :: _ ->
let res = normalize_pair_item res in
let name = unparse_pair_item res in
Some (Prim (loc, name, [], [])) Some (Prim (loc, name, [], []))
| exception Not_a_pair -> None
end end
| _ -> None | _ -> None
let unexpand_unpaaiair expanded = let unexpand_unpappaiir expanded =
match expanded with match expanded with
| Seq (loc, (_ :: _ as nodes)) -> | Seq (loc, (_ :: _ as nodes)) ->
let rec destruct sacc acc = function let rec exec stack nodes = match nodes, stack with
| [] -> Some acc | [], _ -> stack
| Prim (_, "DIP", [ Seq (_, [ sub ]) ], []) :: rest | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, a :: rstack ->
| Prim (_, "DIP", [ Seq (_, _) as sub ], []) :: rest -> exec (a :: exec rstack sub) rest
destruct ("A" :: sacc) acc (sub :: rest) | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, [] ->
exec (A :: exec [] sub) rest
| Seq (_, [ Prim (_, "DUP", [], []) ; | Seq (_, [ Prim (_, "DUP", [], []) ;
Prim (_, "CAR", [], []) ; Prim (_, "CAR", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Prim (_, "CDR", [], []) ]) ], [ Seq (_, [ Prim (_, "CDR", [], []) ]) ],
[]) ]) :: rest -> []) ]) :: rest,
destruct [] (List.rev ("AI" :: sacc) :: acc) rest a :: b :: rstack ->
| _ -> None in exec (P (0, a, b) :: rstack) rest
begin match destruct [] [ [ "R" ] ] nodes with | Seq (_, [ Prim (_, "DUP", [], []) ;
| None -> None Prim (_, "CAR", [], []) ;
| Some seq -> Prim (_, "DIP",
let name = String.concat "" ("UNP" :: List.flatten seq) in [ Seq (_, [ Prim (_, "CDR", [], []) ]) ],
[]) ]) :: rest,
[ a ] ->
exec [ P (0, a, I) ] rest
| Seq (_, [ Prim (_, "DUP", [], []) ;
Prim (_, "CAR", [], []) ;
Prim (_, "DIP",
[ Seq (_, [ Prim (_, "CDR", [], []) ]) ],
[]) ]) :: rest,
[] ->
exec [ P (0, A, I) ] rest
| _ -> raise_notrace Not_a_pair in
begin match exec [] (List.rev nodes) with
| [] -> None
| res :: _ ->
let res = normalize_pair_item res in
let name = "UN" ^ unparse_pair_item res in
Some (Prim (loc, name, [], [])) Some (Prim (loc, name, [], []))
| exception Not_a_pair -> None
end end
| _ -> None | _ -> None
let unexpand_compare expanded = let unexpand_compare expanded =
match expanded with match expanded with
| Seq (loc, [ Prim (_, "COMPARE", [], _) ; | Seq (loc, [ Prim (_, "COMPARE", [], _) ;
@ -958,8 +1029,8 @@ let unexpand original =
unexpand_set_caddadr ; unexpand_set_caddadr ;
unexpand_map_caddadr ; unexpand_map_caddadr ;
unexpand_dxiiivp ; unexpand_dxiiivp ;
unexpand_paaiair ; unexpand_pappaiir ;
unexpand_unpaaiair ; unexpand_unpappaiir ;
unexpand_duuuuup ; unexpand_duuuuup ;
unexpand_compare ; unexpand_compare ;
unexpand_if_some ; unexpand_if_some ;

8
src/proto_alpha/lib_client/michelson_v1_macros.mli
View File

@ -22,11 +22,11 @@ val expand_caddadr : 'l node -> 'l node option tzresult
val expand_set_caddadr : 'l node -> 'l node option tzresult val expand_set_caddadr : 'l node -> 'l node option tzresult
val expand_map_caddadr : 'l node -> 'l node option tzresult val expand_map_caddadr : 'l node -> 'l node option tzresult
val expand_dxiiivp : 'l node -> 'l node option tzresult val expand_dxiiivp : 'l node -> 'l node option tzresult
val expand_paaiair : 'l node -> 'l node option tzresult val expand_pappaiir : 'l node -> 'l node option tzresult
val expand_duuuuup : 'l node -> 'l node option tzresult val expand_duuuuup : 'l node -> 'l node option tzresult
val expand_compare : 'l node -> 'l node option tzresult val expand_compare : 'l node -> 'l node option tzresult
val expand_asserts : 'l node -> 'l node option tzresult val expand_asserts : 'l node -> 'l node option tzresult
val expand_unpaaiair : 'l node -> 'l node option tzresult val expand_unpappaiir : 'l node -> 'l node option tzresult
val expand_if_some : 'l node -> 'l node option tzresult val expand_if_some : 'l node -> 'l node option tzresult
val expand_if_right : 'l node -> 'l node option tzresult val expand_if_right : 'l node -> 'l node option tzresult
@ -37,10 +37,10 @@ val unexpand_caddadr : 'l node -> 'l node option
val unexpand_set_caddadr : 'l node -> 'l node option val unexpand_set_caddadr : 'l node -> 'l node option
val unexpand_map_caddadr : 'l node -> 'l node option val unexpand_map_caddadr : 'l node -> 'l node option
val unexpand_dxiiivp : 'l node -> 'l node option val unexpand_dxiiivp : 'l node -> 'l node option
val unexpand_paaiair : 'l node -> 'l node option val unexpand_pappaiir : 'l node -> 'l node option
val unexpand_duuuuup : 'l node -> 'l node option val unexpand_duuuuup : 'l node -> 'l node option
val unexpand_compare : 'l node -> 'l node option val unexpand_compare : 'l node -> 'l node option
val unexpand_asserts : 'l node -> 'l node option val unexpand_asserts : 'l node -> 'l node option
val unexpand_unpaaiair : 'l node -> 'l node option val unexpand_unpappaiir : 'l node -> 'l node option
val unexpand_if_some : 'l node -> 'l node option val unexpand_if_some : 'l node -> 'l node option
val unexpand_if_right : 'l node -> 'l node option val unexpand_if_right : 'l node -> 'l node option