Commit de93f54c authored by Jun Furuse's avatar Jun Furuse

Merge branch 'pre-salting' into 'master'

Pre salting sync

See merge request !5
parents c14d9cd7 2d42db24
Pipeline #113600960 passed with stage
in 9 minutes and 14 seconds
......@@ -37,6 +37,7 @@ end
module Attr = struct
type t =
| Comment of string
| Annot of string
type ts = t list
......@@ -359,7 +360,7 @@ let check_unstorable t =
| Fun _ ->
begin try
IdTys.iter (fun (id, ty) ->
if not & Michelson.Type.is_packable ty then
if not & Michelson.Type.is_packable ~legacy:false ty then
raise (E.Found (id, ty)))
& freevars t;
Ok ()
......
......@@ -35,6 +35,7 @@ end
module Attr : sig
type t =
| Comment of string
| Annot of string
type ts = t list
......
......@@ -425,9 +425,9 @@ let structure t =
let p2, t = get_abst t in
let env = ((p2.desc,p2.typ)::(p1.desc,p1.typ)::env) in
let os = compile env t in
[ COMMENT ("defs", if ops = [] then [] else [DIP (1, ops)])
[ COMMENT ("top defs", if ops = [] then [] else [DIP (1, ops)])
; COMMENT ("entry point init", [DUP ; CDR; DIP (1, [CAR])])
; COMMENT ("entry point", os )
; COMMENT ("entry point code", os )
; COMMENT ("final clean up", [ DIP (1, [ DROP (List.length env) ]) ])]
|> clean_failwith
|> dip_1_drop_n_compaction
......@@ -153,7 +153,7 @@ module Type = struct
f k >>= fun () -> f v >>= fun () ->
if not (is_comparable k) then
Error (ty, "big_map's key type must be comparable")
else if not (is_packable v) then
else if not (is_packable ~legacy:false v) then
Error (ty, "big_map's value type must be packable")
else
Ok ()
......@@ -190,6 +190,7 @@ module Type = struct
f ty
and is_comparable ty =
(* See Script_ir_translator.parse_comparable_ty *)
let rec f ty = match ty.desc with
| TyBigMap _ | TyChainID | TyContract _ | TyKey
| TyLambda _ | TyList _ | TyMap _ | TyOperation
......@@ -202,15 +203,14 @@ module Type = struct
in
f ty
and is_packable ty =
(* ~allow_big_map:false
~allow_operation:false
~allow_contract:legacy
and is_packable ~legacy ty =
(* leagcy: allow to pack contracts for hash/signature checks
See Script_ir_translator.I_PACK case.
*)
let rec f ty = match ty.desc with
| TyBigMap _ -> false
| TyOperation -> false
| TyContract _ -> false
| TyContract _ -> legacy
| TyLambda (_t1, _t2) -> true
| TyList t | TyOption t | TySet t -> f t
| TyPair (t1, t2) | TyOr (t1, t2) | TyMap (t1, t2) -> f t1 && f t2
......
......@@ -79,7 +79,7 @@ module Type : sig
val validate : t -> (unit, (t * string)) Result.t
val is_comparable : t -> bool
val is_packable : t -> bool
val is_packable : legacy: bool -> t -> bool
val is_parameterable : t -> bool
val attribute : string list -> t -> t
......
......@@ -112,12 +112,13 @@ let optimize t =
| Let (p, t1, t2) ->
let t2 = f t2 in
let vmap = count_variables t2 in
let not_expand = not & List.mem (Attr.Annot "not_expand") t.attrs in
begin match VMap.find_opt p.desc vmap with
| None ->
(* let x = e1 in e2 => e2[e1/x] *)
add_attrs & f t2
| Some 1 when IdTys.for_all (fun (_, ty) -> Michelson.Type.is_packable ty) (freevars t1) ->
| Some 1 when IdTys.for_all (fun (_, ty) -> Michelson.Type.is_packable ~legacy:false ty) (freevars t1) && not not_expand ->
(* let x = e1 in e2 => e2[e1/x] *)
(* contract_self_id must not be inlined into LAMBDAs *)
(* XXX This is adhoc *)
......
......@@ -366,7 +366,7 @@ let primitives =
; "Obj.pack", (1, fun ~loc ty pre ->
match args ty 1 with
| [ aty ] ->
if not & M.Type.is_packable aty then
if not & M.Type.is_packable ~legacy:true aty then
errorf ~loc "Obj.pack cannot take a non packable type %a"
M.Type.pp aty;
pre @ [ PACK ]
......@@ -375,7 +375,7 @@ let primitives =
; "Obj.unpack", (1, fun ~loc ty xs ->
match ty.desc with
| TyLambda (_, { desc= TyOption ty }) ->
if not & M.Type.is_packable ty then
if not & M.Type.is_packable ~legacy:false ty then
errorf ~loc "Obj.unpack cannot unpack to a non packable type %a"
M.Type.pp ty;
xs @ [ UNPACK ty ]
......
......@@ -180,14 +180,21 @@ let parameter =
; dest= Contract.implicit_account (Key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")
}
}
; sigs= [ Some (Signature "edsigu4chLHh7rDAUxHyifHYTJyuS8zybSSFQ5eSXydXD7PWtHXrpeS19ds3hA587p5JNjyJcZbLx8QtemuJBEFkLyzjAhTjjta"); None ]
(* signature is obtained by
tezos-client sign bytes 0x0507070707002a050507070080897a0a00000016000002298c03ed7d454a101eb7022bc95f7e5f41ac7807070a00000016011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe6000a000000047a06a770 for bootstrap1
The binary is obtained by app_multisig_target.ml
*)
; sigs= [ Some (Signature "edsigtteMcYkviZ3rTaM6N7DWvgsyoTmEHGo91Q63qNJNYXFhTwWzmytanUj8G44aEZ8QDJt3myyxjuVwvRMikSJauZ96AvshWJ"); None ]
}
let storage =
{ stored_counter= Nat 42
; threshold= Nat 1
; keys= [ Key "edpkuSR6ywqsk17myFVRcw2eXhVib2MeLc9D1QkEQb98ctWUBwSJpF"
; Key "edpkuSR6ywqsk17myFVRcw2eXhVib2MeLc9D1QkEQb98ctWUBwSJpF"
(* keys are obtained from public_keys of sandboxed node *)
; keys= [ Key "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" (* bootstrap1 *)
; Key "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" (* bootstrap2 *)
]
}
......
(*
INPUT= ()
STORAGE= (None : bytes option)
*)
open SCaml
type storage =
{ stored_counter : nat
; threshold : nat
; keys : key list
}
type parameter =
{ payload : payload
; sigs : signature option list
}
and payload =
{ counter : nat
; action : action
}
and action =
| Transfer of transfer
| Delegate of key_hash option
| Change_keys of change_keys
and transfer =
{ amount : tz
; dest : unit contract
}
and change_keys =
{ threshold : nat
; keys : key list
}
(*
(Some 0x0507070707002a050507070080897a0a00000016000002298c03ed7d454a101eb7022bc95f7e5f41ac7807070a00000016011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe6000a000000047a06a770)
*)
let main parameter (storage : bytes option) : operations * bytes option =
(* pair the payload with the current contract address, to ensure signatures
can't be replayed accross different contracts if a key is reused. *)
let signature_target =
Obj.pack ( parameter.payload
, Contract.address Contract.self
, Global.get_chain_id ()
)
in
[], Some signature_target
let parameter =
{ payload= { counter= Nat 42
; action= Transfer { amount= Tz 1.0
; dest= Contract.implicit_account (Key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")
}
}
; sigs= [ Some (Signature "edsigu4chLHh7rDAUxHyifHYTJyuS8zybSSFQ5eSXydXD7PWtHXrpeS19ds3hA587p5JNjyJcZbLx8QtemuJBEFkLyzjAhTjjta"); None ]
}
(*
let storage =
{ stored_counter= Nat 42
; threshold= Nat 1
; keys= [ Key "edpkuSR6ywqsk17myFVRcw2eXhVib2MeLc9D1QkEQb98ctWUBwSJpF"
; Key "edpkuSR6ywqsk17myFVRcw2eXhVib2MeLc9D1QkEQb98ctWUBwSJpF"
]
}
*)
let test () _ =
let ops, res = main parameter None in
ops, res
(* INPUT= ()
STORAGE= (None : (address * address) option)
*)
open SCaml
let main () _ =
[],
Some (Global.get_source (), Global.get_sender ())
(* INPUT= ()
STORAGE= Some (Address "tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN")
*)
open SCaml
let main () _ =
[], Some (Contract.address Contract.self)
(* In test, it seems always
"KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi"
*)
......@@ -41,10 +41,13 @@ function compile () {
# Input: <code>
# Output: CONVERSION
function convert () {
echo "converting $1 ..."
tmp=`mktemp`
echo "open SCaml" > $tmp
echo "let x = $1" >> $tmp
cat $tmp
CONVERSION=$($COMP --scaml-convert -impl $tmp | sed -e 's/^x: //')
echo "converted to $CONVERSION"
}
# Input <ML> <TZ>
......@@ -62,7 +65,7 @@ function run () {
if [ -z "$storage" ]; then
storage='Unit'
else
storage=`echo $storage | sed -e 's/.*STORAGE=//'`
storage=`echo "$storage" | sed -e 's/.*STORAGE=//'`
convert "$storage"
storage=$CONVERSION
fi
......@@ -81,14 +84,15 @@ function run () {
$TEZOS_CLIENT typecheck script $tz
echo Executing $TEZOS_CLIENT run script $tz on storage $storage and input $input
# Really weird but --source is to set SENDER and --payer to set SOURCE
echo Executing $TEZOS_CLIENT run script $tz on storage $storage and input $input --source bootstrap1 --payer bootstrap2
if [ -z "$must_fail" ]; then
$TEZOS_CLIENT run script $tz on storage "$storage" and input "$input"
$TEZOS_CLIENT run script $tz on storage "$storage" and input "$input" --source bootstrap1 --payer bootstrap2
else
echo THIS TEST MUST FAIL
if
$TEZOS_CLIENT run script $tz on storage "$storage" and input "$input"
$TEZOS_CLIENT run script $tz on storage "$storage" and input "$input" --source bootstrap1 --payer bootstrap2
then
echo "Error: TEST UNEXPECTEDLY SUCCEEEDED"; exit 2
else
......
......@@ -1001,7 +1001,7 @@ module Pmatch = struct
(freevars action)
(if vars = [] then [] else List.tl (List.rev vars)) (* the last one cannot be free inside the body *)
in
IdTys.filter (fun (_id,ty) -> not & Michelson.Type.is_packable ty) fvs
IdTys.filter (fun (_id,ty) -> not & Michelson.Type.is_packable ~legacy:false ty) fvs
in
let _must_expand = not & IdTys.is_empty nonstorables in
(* It's inefficient for the storage, but we do not want to get troubled
......@@ -1365,7 +1365,7 @@ and expression (lenv:lenv) { exp_desc; exp_loc=loc; exp_type= mltyp; exp_env= ty
(Ident.unique_name id)
(String.concat ", " (List.map (fun id -> Ident.unique_name id) lenv.local_variables));
if not (List.mem id lenv.local_variables)
&& not (Michelson.Type.is_packable typ)
&& not (Michelson.Type.is_packable ~legacy:false typ)
&& lenv.fun_level > 0 then
errorf ~loc:lenv.fun_loc "Function body cannot have a free variable occurrence `%s` with non storable type."
(Ident.name id);
......@@ -1981,7 +1981,8 @@ let compile_global_entry ty_storage ty_return node =
let add_self self_typ t =
(* let __contract_id = SELF in t *)
(* This variable must not be inlined *)
mklet ~loc:noloc
Attr.add (Attr.Annot "not_expand")
& mklet ~loc:noloc
{ desc= contract_self_id; typ= self_typ; loc= Location.none; attrs= () }
(mke ~loc:noloc self_typ & Prim ("Contract.self", (fun os -> M.Opcode.SELF :: os), []))
t
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment