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

Michelson: introducing big maps, limited edition

Browse Source 
Quick and dirty (yet safe, of course) implementation of lazily
  deserialized maps for storing large collections of indexed data.

  Only one big_map is allowed, as the left component of the toplevel
  storage pair.

  Review and bugfixes: Benjamin Canou <benjamin@canou.fr>
This commit is contained in:
Milo Davis 2017-12-14 16:45:04 +01:00 committed by Benjamin Canou
parent ec86dea35f
commit 79472c727a
30 changed files with 511 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/bin_client/test/contracts/big_map_get_add.tz Normal file
View File

@ -0,0 +1,8 @@
parameter (pair (pair @set_pair int (option int)) (pair @check_pair int (option int))) ;
storage (pair (big_map int int) unit) ;
return unit ;
code { DUP ; DIP { CDAR } ;
DUP ; DIP { CADR; DUP ; CAR ; DIP { CDR } ; UPDATE ; DUP } ;
CADR ; DUP ; CDR ; DIP { CAR ; GET } ;
IF_SOME { SWAP ; IF_SOME { ASSERT_CMPEQ } {FAIL}} { ASSERT_NONE } ;
UNIT ; SWAP ; PAIR ; UNIT ; PAIR }

6
src/bin_client/test/contracts/big_map_mem.tz Normal file
View File

@ -0,0 +1,6 @@
# Fails if the boolean does not match the membership criteria
parameter (pair int bool) ;
storage (pair (big_map int unit) unit) ;
return unit ;
code { DUP ; DUP ; CADR ; DIP { CAAR ; DIP { CDAR ; DUP } ; MEM } ;
ASSERT_CMPEQ ; UNIT ; SWAP ; PAIR ; UNIT ; PAIR }

30
src/bin_client/test/test_contracts.sh
View File

@ -405,12 +405,13 @@ init_with_transfer $contract_dir/self.tz $key1 \
$client transfer 0 from bootstrap1 to self
assert_storage_contains self "\"$(get_contract_addr self)\""
# Test sets and map literals
assert_fails $client typecheck data '{ Elt 0 1 ; Elt 0 1 }' against type '(map nat nat)'
assert_fails $client typecheck data '{ Elt 0 1 ; Elt 10 1 ; Elt 5 1 }' against type '(map nat nat)'
assert_fails $client typecheck data '{ "A" ; "C" ; "B" }' against type '(set string)'
assert_fails $client typecheck data '{ "A" ; "B" ; "B" }' against type '(set string)'
# Test hash consistency between Michelson and the CLI
hash_result=`$client hash data '(Pair "22220.00" (Pair "2017-12-13T04:49:00Z" 034))' \
of type '(pair tez (pair timestamp int))'`
@ -420,6 +421,33 @@ assert_output $contract_dir/hash_consistency_checker.tz Unit \
assert_output $contract_dir/hash_consistency_checker.tz Unit \
'(Pair "22,220" (Pair "2017-12-13T04:49:00+00:00" 34))' "$hash_result"
# Test for big maps
init_with_transfer $contract_dir/big_map_mem.tz $key1\
'(Pair { Elt 1 Unit ; Elt 2 Unit ; Elt 3 Unit } Unit)' \
100 bootstrap1
$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 0 False)'
assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 0 True)'
$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 1 True)'
assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 1 False)'
$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 2 True)'
assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 2 False)'
$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 3 True)'
assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 3 False)'
$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 4 False)'
assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 4 True)'
init_with_transfer $contract_dir/big_map_get_add.tz $key1\
'(Pair { Elt 0 1 ; Elt 1 2 ; Elt 2 3 } Unit)' \
100 bootstrap1
$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 200 (Some 2)) (Pair 200 (Some 2)))'
$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 200 None) (Pair 200 None))'
$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 200 None) (Pair 300 None))'
$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 1 None) (Pair 200 None))'
$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 1 (Some 2)) (Pair 0 (Some 1)))'
$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 400 (Some 1232)) (Pair 400 (Some 1232)))'
$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 401 (Some 0)) (Pair 400 (Some 1232)))'
printf "\nEnd of test\n"
show_logs="no"

31
src/proto_alpha/lib_client/client_proto_programs.ml
View File

@ -35,23 +35,44 @@ let print_errors (cctxt : #Client_commands.logger) errs ~show_source ~parsed =
cctxt#error "error running program" >>= fun () ->
return ()
let print_big_map_diff ppf = function
| None -> ()
| Some diff ->
Format.fprintf ppf
"@[<v 2>map diff:@,%a@]@,"
(Format.pp_print_list
~pp_sep:Format.pp_print_space
(fun ppf (key, value) ->
Format.fprintf ppf "%s %a%a"
(match value with
| None -> "-"
| Some _ -> "+")
print_expr key
(fun ppf -> function
| None -> ()
| Some x -> Format.fprintf ppf "-> %a" print_expr x)
value))
diff
let print_run_result (cctxt : #Client_commands.logger) ~show_source ~parsed = function
| Ok (storage, output) ->
cctxt#message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
| Ok (storage, output, maybe_diff) ->
cctxt#message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[%a@]@]@."
print_expr storage
print_expr output >>= fun () ->
print_expr output
print_big_map_diff maybe_diff >>= fun () ->
return ()
| Error errs ->
print_errors cctxt errs ~show_source ~parsed
let print_trace_result (cctxt : #Client_commands.logger) ~show_source ~parsed =
function
| Ok (storage, output, trace) ->
| Ok (storage, output, trace, maybe_big_map_diff) ->
cctxt#message
"@[<v 0>@[<v 2>storage@,%a@]@,\
@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
@[<v 2>output@,%a@]@,%a@[<v 2>@[<v 2>trace@,%a@]@]@."
print_expr storage
print_expr output
print_big_map_diff maybe_big_map_diff
(Format.pp_print_list
(fun ppf (loc, gas, stack) ->
Format.fprintf ppf

21
src/proto_alpha/lib_client/client_proto_programs.mli
View File

@ -21,7 +21,7 @@ val run :
input:Michelson_v1_parser.parsed ->
Client_rpcs.block ->
#Client_rpcs.ctxt ->
(Script.expr * Script.expr) tzresult Lwt.t
(Script.expr * Script.expr * (Script.expr * Script.expr option) list option) tzresult Lwt.t
val trace :
?amount:Tez.t ->
@ -30,23 +30,24 @@ val trace :
input:Michelson_v1_parser.parsed ->
Client_rpcs.block ->
#Client_rpcs.ctxt ->
(Script.expr * Script.expr * (int * Gas.t * Script.expr list) list) tzresult Lwt.t
(Script.expr * Script.expr * (int * Gas.t * Script.expr list) list * (Script.expr * Script.expr option) list option) tzresult Lwt.t
val print_run_result :
#Client_commands.logger ->
show_source:bool ->
parsed:Michelson_v1_parser.parsed ->
(Script_repr.expr * Script_repr.expr *
(Script_repr.expr * Script_repr.expr option) list option) tzresult -> unit tzresult Lwt.t
val print_trace_result :
#Client_commands.logger ->
show_source:bool ->
parsed:Michelson_v1_parser.parsed ->
(Script_repr.expr * Script_repr.expr *
(int * Gas.t * Script_repr.expr list) list)
(int * Gas.t * Script_repr.expr list) list *
(Script_repr.expr * Script_repr.expr option) list option)
tzresult -> unit tzresult Lwt.t
val print_run_result :
#Client_commands.logger ->
show_source:bool ->
parsed:Michelson_v1_parser.parsed ->
(Script.expr * Script.expr) tzresult ->
unit tzresult Lwt.t
val hash_and_sign :
Michelson_v1_parser.parsed ->
Michelson_v1_parser.parsed ->

5
src/proto_alpha/lib_client/client_proto_rpcs.mli
View File

@ -160,13 +160,14 @@ module Helpers : sig
#Client_rpcs.ctxt ->
block -> Script.expr ->
(Script.expr * Script.expr * Tez.t) ->
(Script.expr * Script.expr) tzresult Lwt.t
(Script.expr * Script.expr * (Script.expr * Script.expr option) list option) tzresult Lwt.t
val trace_code:
#Client_rpcs.ctxt ->
block -> Script.expr ->
(Script.expr * Script.expr * Tez.t) ->
(Script.expr * Script.expr *
(Script.location * Gas.t * Script.expr list) list) tzresult Lwt.t
(Script.location * Gas.t * Script.expr list) list *
(Script.expr * Script.expr option) list option) tzresult Lwt.t
val typecheck_code:
#Client_rpcs.ctxt ->
block -> Script.expr -> Script_tc_errors.type_map tzresult Lwt.t

5
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml
View File

@ -66,6 +66,7 @@ let collect_error_locations errs =
| Invalid_primitive (loc, _, _)
| Invalid_kind (loc, _, _)
| Duplicate_field (loc, _)
| Unexpected_big_map loc
| Fail_not_in_tail_position loc
| Undefined_binop (loc, _, _, _)
| Undefined_unop (loc, _, _)
@ -167,6 +168,10 @@ let report_errors ~details ~show_source ?parsed ppf errs =
print_loc loc
(Michelson_v1_primitives.string_of_prim prim) ;
print_trace locations rest
| Unexpected_big_map loc :: rest ->
Format.fprintf ppf "%abig_map type only allowed on the left of the toplevel storage pair"
print_loc loc ;
print_trace locations rest
| Runtime_contract_error (contract, expr) :: rest ->
let parsed =
match parsed with

29
src/proto_alpha/lib_protocol/src/apply.ml
View File

@ -135,12 +135,17 @@ let apply_manager_operation_content
source destination ctxt script amount argument
(Gas.of_int (Constants.max_gas ctxt))
>>= function
| Ok (storage_res, _res, _steps, ctxt, origination_nonce) ->
| Ok (storage_res, _res, _steps, ctxt, origination_nonce, maybe_big_map_diff) ->
(* TODO: pay for the steps and the storage diff:
update_script_storage checks the storage cost *)
Contract.update_script_storage_and_fees
ctxt destination
Script_interpreter.dummy_storage_fee storage_res >>=? fun ctxt ->
Script_interpreter.dummy_storage_fee
storage_res
(match maybe_big_map_diff with
| None -> None
| Some map ->
Some (Script_ir_translator.to_serializable_big_map map)) >>=? fun ctxt ->
return (ctxt, origination_nonce, None)
| Error err ->
return (ctxt, origination_nonce, Some err) in
@ -161,18 +166,30 @@ let apply_manager_operation_content
| Origination { manager ; delegate ; script ;
spendable ; delegatable ; credit } ->
begin match script with
| None -> return None
| None -> return (None, None)
| Some script ->
Script_ir_translator.parse_script ctxt script >>=? fun _ ->
return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee)))
end >>=? fun script ->
Script_ir_translator.erase_big_map_initialization ctxt script >>=? fun (script, big_map_diff) ->
return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee)),
big_map_diff)
end >>=? fun (script, big_map) ->
Contract.spend ctxt source Constants.origination_burn >>=? fun ctxt ->
Contract.spend ctxt source credit >>=? fun ctxt ->
Contract.originate ctxt
origination_nonce
~manager ~delegate ~balance:credit
?script
~spendable ~delegatable >>=? fun (ctxt, _, origination_nonce) ->
~spendable ~delegatable >>=? fun (ctxt, contract, origination_nonce) ->
begin match big_map with
| None -> return ctxt
| Some diff ->
fold_left_s (fun ctxt (key, value) ->
match value with
| None -> Contract.Big_map_storage.remove ctxt contract key
| Some v ->
Contract.Big_map_storage.set ctxt contract key v)
ctxt diff
end >>=? fun ctxt ->
return (ctxt, origination_nonce, None)
| Delegation delegate ->
Contract.set_delegate ctxt source delegate >>=? fun ctxt ->

22
src/proto_alpha/lib_protocol/src/contract_storage.ml
View File

@ -237,6 +237,7 @@ let delete c contract =
Storage.Contract.Storage.remove c contract >>= fun c ->
Storage.Contract.Code_fees.remove c contract >>= fun c ->
Storage.Contract.Storage_fees.remove c contract >>= fun c ->
Storage.Contract.Big_map.clear (c, contract) >>= fun c ->
return c
let exists c contract =
@ -372,7 +373,9 @@ let contract_fee c contract =
Lwt.return Tez_repr.(code_fees +? storage_fees) >>=? fun script_fees ->
Lwt.return Tez_repr.(Constants_repr.minimal_contract_balance +? script_fees)
let update_script_storage_and_fees c contract storage_fees storage =
type big_map_diff = (string * Script_repr.expr option) list
let update_script_storage_and_fees c contract storage_fees storage big_map =
Storage.Contract.Balance.get_option c contract >>=? function
| None ->
(* The contract was destroyed *)
@ -382,6 +385,16 @@ let update_script_storage_and_fees c contract storage_fees storage =
contract_fee c contract >>=? fun fee ->
fail_unless Tez_repr.(balance > fee)
(Cannot_pay_storage_fee (contract, balance, fee)) >>=? fun () ->
begin match big_map with
| None -> return c
| Some diff ->
fold_left_s (fun c (key, value) ->
match value with
| None -> Storage.Contract.Big_map.remove (c, contract) key >>= return
| Some v ->
Storage.Contract.Big_map.init_set (c, contract) key v >>= return)
c diff
end >>=? fun c ->
Storage.Contract.Storage.set c contract storage
let spend_from_script c contract amount =
@ -432,3 +445,10 @@ let originate c nonce ~balance ~manager ?script ~delegate ~spendable ~delegatabl
let init c =
Storage.Contract.Global_counter.init c 0l
module Big_map = struct
let set handle key value = Storage.Contract.Big_map.init_set handle key value >>= return
let remove = Storage.Contract.Big_map.delete
let mem = Storage.Contract.Big_map.mem
let get_opt = Storage.Contract.Big_map.get_option
end

18
src/proto_alpha/lib_protocol/src/contract_storage.mli
View File

@ -46,7 +46,12 @@ val get_counter: Raw_context.t -> Contract_repr.t -> int32 tzresult Lwt.t
val get_script: Raw_context.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t
val get_storage: Raw_context.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t
val update_script_storage_and_fees: Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> Raw_context.t tzresult Lwt.t
type big_map_diff = (string * Script_repr.expr option) list
val update_script_storage_and_fees:
Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr ->
big_map_diff option ->
Raw_context.t tzresult Lwt.t
(** fails if the contract is not delegatable *)
val set_delegate : Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option -> Raw_context.t tzresult Lwt.t
@ -72,3 +77,14 @@ val originate :
val init :
Raw_context.t -> Raw_context.t tzresult Lwt.t
module Big_map : sig
val set :
Storage.Contract.bigmap_key ->
string -> Script_repr.expr -> Raw_context.t tzresult Lwt.t
val remove :
Storage.Contract.bigmap_key -> string -> Raw_context.t tzresult Lwt.t
val mem : Storage.Contract.bigmap_key -> string -> bool Lwt.t
val get_opt :
Storage.Contract.bigmap_key -> string -> Script_repr.expr option tzresult Lwt.t
end

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

@ -149,6 +149,10 @@ module Cost_of = struct
let map_size = step_cost 2
let big_map_mem _key _map = step_cost 200
let big_map_get _key _map = step_cost 200
let big_map_update _key _value _map = step_cost 200
let set_access : type elt. elt -> elt Script_typed_ir.set -> int
= fun _key (module Box) ->
log2 @@ Box.size

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

@ -48,6 +48,9 @@ module Cost_of : sig
val map_update :
'a -> 'b -> ('c, 'd) Script_typed_ir.map -> cost
val map_size : cost
val big_map_mem : 'key -> ('key, 'value) Script_typed_ir.big_map -> cost
val big_map_get : 'key -> ('key, 'value) Script_typed_ir.big_map -> cost
val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> cost
val set_to_list : 'a Script_typed_ir.set -> cost
val set_update : 'a -> 'b -> 'a Script_typed_ir.set -> cost
val set_mem : 'a -> 'a Script_typed_ir.set -> cost

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

@ -103,6 +103,7 @@ type prim =
| T_lambda
| T_list
| T_map
| T_big_map
| T_nat
| T_option
| T_or
@ -223,6 +224,7 @@ let string_of_prim = function
| T_lambda -> "lambda"
| T_list -> "list"
| T_map -> "map"
| T_big_map -> "big_map"
| T_nat -> "nat"
| T_option -> "option"
| T_or -> "or"
@ -324,6 +326,7 @@ let prim_of_string = function
| "lambda" -> ok T_lambda
| "list" -> ok T_list
| "map" -> ok T_map
| "big_map" -> ok T_big_map
| "nat" -> ok T_nat
| "option" -> ok T_option
| "or" -> ok T_or
@ -469,6 +472,7 @@ let prim_encoding =
("lambda", T_lambda) ;
("list", T_list) ;
("map", T_map) ;
("big_map", T_big_map) ;
("nat", T_nat) ;
("option", T_option) ;
("or", T_or) ;

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

@ -101,6 +101,7 @@ type prim =
| T_lambda
| T_list
| T_map
| T_big_map
| T_nat
| T_option
| T_or

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

@ -392,6 +392,21 @@ let rec interp
gas_check_terop descr (map_update, k, v, map) Gas.Cost_of.map_update rest
| Map_size, Item (map, rest) ->
gas_check_unop descr (map_size, map) (fun _ -> Gas.Cost_of.map_size) rest ctxt
(* Big map operations *)
| Big_map_mem, Item (key, Item (map, rest)) ->
let gas = Gas.consume gas (Gas.Cost_of.big_map_mem key map) in
Gas.check gas >>=? fun () ->
Script_ir_translator.big_map_mem ctxt source key map >>= fun res ->
logged_return (Item (res, rest), gas, ctxt)
| Big_map_get, Item (key, Item (map, rest)) ->
let gas = Gas.consume gas (Gas.Cost_of.big_map_get key map) in
Gas.check gas >>=? fun () ->
Script_ir_translator.big_map_get ctxt source key map >>=? fun res ->
logged_return (Item (res, rest), gas, ctxt)
| Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) ->
gas_check_terop descr
(Script_ir_translator.big_map_update, key, maybe_value, map)
Gas.Cost_of.big_map_update rest
(* timestamp operations *)
| Add_seconds_to_timestamp, Item (n, Item (t, rest)) ->
gas_check_binop descr
@ -633,14 +648,16 @@ let rec interp
Contract.get_manager ctxt contract >>=? fun manager ->
logged_return (Item (manager, rest), gas, ctxt)
| Transfer_tokens storage_type,
Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (sto, Empty)))) -> begin
Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (storage, Empty)))) -> begin
let gas = Gas.consume gas Gas.Cost_of.transfer in
Gas.check gas >>=? fun () ->
Contract.spend_from_script ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? fun destination_script ->
let sto = Micheline.strip_locations (unparse_data storage_type sto) in
Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt ->
let sto = Micheline.strip_locations (unparse_data storage_type storage) in
Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto
(Option.map ~f:Script_ir_translator.to_serializable_big_map
(Script_ir_translator.extract_big_map storage_type storage)) >>=? fun ctxt ->
begin match destination_script with
| None ->
(* we see non scripted contracts as (unit, unit) contract *)
@ -650,8 +667,9 @@ let rec interp
| Some script ->
let p = unparse_data tp p in
execute origination source destination ctxt script amount p gas
>>=? fun (csto, ret, gas, ctxt, origination) ->
Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee csto >>=? fun ctxt ->
>>=? fun (csto, ret, gas, ctxt, origination, maybe_diff) ->
Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee csto
(Option.map ~f:Script_ir_translator.to_serializable_big_map maybe_diff) >>=? fun ctxt ->
trace
(Invalid_contract (loc, destination))
(parse_data ctxt Unit_t ret) >>=? fun () ->
@ -672,12 +690,16 @@ let rec interp
Contract.get_script ctxt destination >>=? function
| None -> fail (Invalid_contract (loc, destination))
| Some script ->
let maybe_diff = Script_ir_translator.(
Option.map ~f:to_serializable_big_map
@@ extract_big_map storage_type sto) in
let sto = Micheline.strip_locations (unparse_data storage_type sto) in
Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt ->
Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto maybe_diff >>=? fun ctxt ->
let p = unparse_data tp p in
execute origination source destination ctxt script amount p gas
>>=? fun (sto, ret, gas, ctxt, origination) ->
Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee sto >>=? fun ctxt ->
>>=? fun (sto, ret, gas, ctxt, origination, maybe_diff) ->
Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee sto
(Option.map ~f:Script_ir_translator.to_serializable_big_map maybe_diff) >>=? fun ctxt ->
trace
(Invalid_contract (loc, destination))
(parse_data ctxt tr ret) >>=? fun v ->
@ -771,7 +793,9 @@ let rec interp
(* ---- contract handling ---------------------------------------------------*)
and execute ?log origination orig source ctxt script amount arg gas =
and execute ?log origination orig source ctxt script amount arg gas :
(Script.expr * Script.node * Gas.t * context * Contract.origination_nonce *
Script_typed_ir.ex_big_map option) tzresult Lwt.t =
parse_script ctxt script
>>=? fun (Ex_script { code; arg_type; ret_type; storage; storage_type }) ->
parse_data ctxt arg_type arg >>=? fun arg ->
@ -781,15 +805,16 @@ and execute ?log origination orig source ctxt script amount arg gas =
>>=? fun ((ret, storage), gas, ctxt, origination) ->
return (Micheline.strip_locations (unparse_data storage_type storage),
unparse_data ret_type ret,
gas, ctxt, origination)
gas, ctxt, origination,
Script_ir_translator.extract_big_map storage_type storage)
let trace origination orig source ctxt script amount arg gas =
let log = ref [] in
execute ~log origination orig source ctxt script amount (Micheline.root arg) gas
>>=? fun (sto, res, gas, ctxt, origination) ->
return ((sto, Micheline.strip_locations res, gas, ctxt, origination), List.rev !log)
>>=? fun (sto, res, gas, ctxt, origination, maybe_big_map) ->
return ((sto, Micheline.strip_locations res, gas, ctxt, origination, maybe_big_map), List.rev !log)
let execute origination orig source ctxt script amount arg gas =
execute origination orig source ctxt script amount (Micheline.root arg) gas
>>=? fun (sto, res, gas, ctxt, origination) ->
return (sto, Micheline.strip_locations res, gas, ctxt, origination)
>>=? fun (sto, res, gas, ctxt, origination, maybe_big_map) ->
return (sto, Micheline.strip_locations res, gas, ctxt, origination, maybe_big_map)

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

@ -21,12 +21,13 @@ val execute:
Contract.t -> Contract.t -> Tezos_context.t ->
Script.t -> Tez.t ->
Script.expr -> Gas.t ->
(Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t
(Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce *
Script_typed_ir.ex_big_map option) tzresult Lwt.t
val trace:
Contract.origination_nonce ->
Contract.t -> Contract.t -> Tezos_context.t ->
Script.t -> Tez.t ->
Script.expr -> Gas.t ->
((Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce) *
((Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) *
(Script.location * Gas.t * Script.expr list) list) tzresult Lwt.t

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

@ -74,6 +74,8 @@ let rec type_size : type t. t ty -> int = function
1 + comparable_type_size k
| Map_t (k, v) ->
1 + comparable_type_size k + type_size v
| Big_map_t (k, v) ->
1 + comparable_type_size k + type_size v
| Contract_t (arg, ret) ->
1 + type_size arg + type_size ret
@ -130,6 +132,9 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
| Map_get -> 0
| Map_update -> 0
| Map_size -> 0
| Big_map_get -> 0
| Big_map_update -> 0
| Big_map_mem -> 0
| Concat -> 0
| Add_seconds_to_timestamp -> 0
| Add_timestamp_to_seconds -> 0
@ -305,6 +310,7 @@ let namespace = function
| T_lambda
| T_list
| T_map
| T_big_map
| T_nat
| T_option
| T_or
@ -447,6 +453,19 @@ let map_update
| None -> (Box.OPS.remove k map, size - if contains then 1 else 0)
end)
let map_set
: type a b. a -> b -> (a, b) map -> (a, b) map
= fun k v (module Box) ->
(module struct
type key = a
type value = b
let key_ty = Box.key_ty
module OPS = Box.OPS
let boxed =
let (map, size) = Box.boxed in
(Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1)
end)
let map_mem
: type key value. key -> (key, value) map -> bool
= fun k (module Box) ->
@ -526,6 +545,10 @@ let rec unparse_ty
let ta = unparse_comparable_ty uta in
let tr = unparse_ty None utr in
Prim (-1, T_map, [ ta; tr ], None)
| Big_map_t (uta, utr) ->
let ta = unparse_comparable_ty uta in
let tr = unparse_ty None utr in
Prim (-1, T_big_map, [ ta; tr ], None)
let rec unparse_data
: type a. a ty -> a -> Script.node
@ -598,6 +621,8 @@ let rec unparse_data
:: acc)
map [] in
Seq (-1, List.rev items, None)
| Big_map_t (_kt, _kv), _map ->
Seq (-1, [], None)
| Lambda_t _, Lam (_, original_code) ->
root original_code
@ -638,6 +663,11 @@ let rec ty_eq
ty_eq tar tbr >>? fun Eq ->
(Ok Eq : (ta ty, tb ty) eq tzresult)) |>
record_trace (Inconsistent_types (ta, tb))
| Big_map_t (tal, tar), Big_map_t (tbl, tbr) ->
(comparable_ty_eq tal tbl >>? fun Eq ->
ty_eq tar tbr >>? fun Eq ->
(Ok Eq : (ta ty, tb ty) eq tzresult)) |>
record_trace (Inconsistent_types (ta, tb))
| Set_t ea, Set_t eb ->
(comparable_ty_eq ea eb >>? fun Eq ->
(Ok Eq : (ta ty, tb ty) eq tzresult)) |>
@ -742,6 +772,10 @@ let merge_types :
help tar tbr >>? fun value ->
ty_eq tar value >>? fun Eq ->
ok (Map_t (merge_comparable_types tal tbl, value))
| Big_map_t (tal, tar), Big_map_t (tbl, tbr) ->
help tar tbr >>? fun value ->
ty_eq tar value >>? fun Eq ->
ok (Big_map_t (merge_comparable_types tal tbl, value))
| Set_t ea, Set_t eb ->
ok (Set_t (merge_comparable_types ea eb))
| Pair_t ((tal, left_annot1), (tar, right_annot1)),
@ -842,7 +876,7 @@ let rec parse_comparable_ty : Script.node -> ex_comparable_ty tzresult = functio
| Prim (loc, (T_pair | T_or | T_set | T_map
| T_list | T_option | T_lambda
| T_unit | T_signature | T_contract), _, _) as expr ->
parse_ty expr >>? fun (Ex_ty ty, _) ->
parse_ty false expr >>? fun (Ex_ty ty, _) ->
error (Comparable_type_expected (loc, ty))
| expr ->
error @@ unexpected expr [] Type_namespace
@ -850,7 +884,21 @@ let rec parse_comparable_ty : Script.node -> ex_comparable_ty tzresult = functio
T_string ; T_tez ; T_bool ;
T_key ; T_key_hash ; T_timestamp ]
and parse_ty : Script.node -> (ex_ty * annot) tzresult = function
and parse_ty : bool -> Script.node -> (ex_ty * annot) tzresult = fun big_map_possible -> function
| Prim (_, T_pair, [
Prim (big_map_loc, T_big_map, args, map_annot) ;
remaining_storage ], storage_annot)
when big_map_possible ->
begin match args with
| [ key_ty ; value_ty ] ->
parse_comparable_ty key_ty >>? fun (Ex_comparable_ty key_ty) ->
parse_ty false value_ty >>? fun (Ex_ty value_ty, right_annot) ->
error_unexpected_annot big_map_loc right_annot >>? fun () ->
parse_ty false remaining_storage >>? fun (Ex_ty remaining_storage, remaining_annot) ->
ok (Ex_ty (Pair_t ((Big_map_t (key_ty, value_ty), map_annot), (remaining_storage, remaining_annot))),
storage_annot)
| args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)
end
| Prim (_, T_unit, [], annot) -> ok (Ex_ty Unit_t, annot)
| Prim (_, T_int, [], annot) -> ok (Ex_ty (Int_t), annot)
| Prim (_, T_nat, [], annot) -> ok (Ex_ty (Nat_t), annot)
@ -862,29 +910,29 @@ and parse_ty : Script.node -> (ex_ty * annot) tzresult = function
| Prim (_, T_timestamp, [], annot) -> ok (Ex_ty Timestamp_t, annot)
| Prim (_, T_signature, [], annot) -> ok (Ex_ty Signature_t, annot)
| Prim (loc, T_contract, [ utl; utr ], annot) ->
parse_ty utl >>? fun (Ex_ty tl, left_annot) ->
parse_ty utr >>? fun (Ex_ty tr, right_annot) ->
parse_ty false utl >>? fun (Ex_ty tl, left_annot) ->
parse_ty false utr >>? fun (Ex_ty tr, right_annot) ->
error_unexpected_annot loc left_annot >>? fun () ->
error_unexpected_annot loc right_annot >|? fun () ->
(Ex_ty (Contract_t (tl, tr)), annot)
| Prim (_, T_pair, [ utl; utr ], annot) ->
parse_ty utl >>? fun (Ex_ty tl, left_annot) ->
parse_ty utr >>? fun (Ex_ty tr, right_annot) ->
parse_ty false utl >>? fun (Ex_ty tl, left_annot) ->
parse_ty false utr >>? fun (Ex_ty tr, right_annot) ->
ok (Ex_ty (Pair_t ((tl, left_annot), (tr, right_annot))), annot)
| Prim (_, T_or, [ utl; utr ], annot) ->
parse_ty utl >>? fun (Ex_ty tl, left_annot) ->
parse_ty utr >|? fun (Ex_ty tr, right_annot) ->
parse_ty false utl >>? fun (Ex_ty tl, left_annot) ->
parse_ty false utr >|? fun (Ex_ty tr, right_annot) ->
(Ex_ty (Union_t ((tl, left_annot), (tr, right_annot))), annot)
| Prim (_, T_lambda, [ uta; utr ], annot) ->
parse_ty uta >>? fun (Ex_ty ta, _) ->
parse_ty utr >>? fun (Ex_ty tr, _) ->
parse_ty false uta >>? fun (Ex_ty ta, _) ->
parse_ty false utr >>? fun (Ex_ty tr, _) ->
ok (Ex_ty (Lambda_t (ta, tr)), annot)
| Prim (loc, T_option, [ ut ], annot) ->
parse_ty ut >>? fun (Ex_ty t, opt_annot) ->
parse_ty false ut >>? fun (Ex_ty t, opt_annot) ->
error_unexpected_annot loc annot >|? fun () ->
(Ex_ty (Option_t t), opt_annot)
| Prim (loc, T_list, [ ut ], annot) ->
parse_ty ut >>? fun (Ex_ty t, list_annot) ->
parse_ty false ut >>? fun (Ex_ty t, list_annot) ->
error_unexpected_annot loc list_annot >>? fun () ->
(ok (Ex_ty (List_t t), annot))
| Prim (_, T_set, [ ut ], annot) ->
@ -892,8 +940,10 @@ and parse_ty : Script.node -> (ex_ty * annot) tzresult = function
ok (Ex_ty (Set_t t), annot)
| Prim (_, T_map, [ uta; utr ], annot) ->
parse_comparable_ty uta >>? fun (Ex_comparable_ty ta) ->
parse_ty utr >>? fun (Ex_ty tr, _) ->
parse_ty false utr >>? fun (Ex_ty tr, _) ->
ok (Ex_ty (Map_t (ta, tr)), annot)
| Prim (loc, T_big_map, _, _) ->
error (Unexpected_big_map loc)
| Prim (loc, (T_unit | T_signature
| T_int | T_nat
| T_string | T_tez | T_bool
@ -941,6 +991,30 @@ let rec parse_data
Invalid_constant (location script_data, strip_locations script_data, ty) in
let traced body =
trace (error ()) body in
let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper =
(fold_left_s
(fun (last_value, map) -> function
| Prim (_, D_Elt, [ k; v ], _) ->
parse_comparable_data ?type_logger ctxt key_type k >>=? fun k ->
parse_data ?type_logger ctxt value_type v >>=? fun v ->
begin match last_value with
| Some value ->
if Compare.Int.(0 <= (compare_comparable key_type value k))
then
if Compare.Int.(0 = (compare_comparable key_type value k))
then fail (Duplicate_map_keys (loc, strip_locations expr))
else fail (Unordered_map_keys (loc, strip_locations expr))
else return ()
| None -> return ()
end >>=? fun () ->
return (Some k, map_update k (Some (item_wrapper v)) map)
| Prim (loc, D_Elt, l, _) ->
fail @@ Invalid_arity (loc, D_Elt, 2, List.length l)
| Prim (loc, name, _, _) ->
fail @@ Invalid_primitive (loc, [ D_Elt ], name)
| Int _ | String _ | Seq _ ->
fail (error ()))
(None, empty_map key_type) items) >>|? snd |> traced in
match ty, script_data with
(* Unit *)
| Unit_t, Prim (_, D_Unit, [], _) -> return ()
@ -1115,31 +1189,15 @@ let rec parse_data
(* Maps *)
| Map_t (tk, tv), (Seq (loc, vs, annot) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
(fold_left_s
(fun (last_value, map) -> function
| Prim (_, D_Elt, [ k; v ], _) ->
parse_comparable_data ?type_logger ctxt tk k >>=? fun k ->
parse_data ?type_logger ctxt tv v >>=? fun v ->
begin match last_value with
| Some value ->
if Compare.Int.(0 <= (compare_comparable tk value k))
then
if Compare.Int.(0 = (compare_comparable tk value k))
then fail (Duplicate_map_keys (loc, strip_locations expr))
else fail (Unordered_map_keys (loc, strip_locations expr))
else return ()
| None -> return ()
end >>=? fun () ->
return (Some k, map_update k (Some v) map)
| Prim (loc, D_Elt, l, _) ->
fail @@ Invalid_arity (loc, D_Elt, 2, List.length l)
| Prim (loc, name, _, _) ->
fail @@ Invalid_primitive (loc, [ D_Elt ], name)
| Int _ | String _ | Seq _ ->
fail (error ()))
(None, empty_map tk) vs) >>|? snd |> traced
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
| Map_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
| Big_map_t (tk, tv), (Seq (loc, vs, annot) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun diff ->
{ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }
| Big_map_t (_tk, _tv), expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
and parse_comparable_data
: type a. ?type_logger:(int -> Script.expr list -> Script.expr list -> unit) ->
@ -1218,7 +1276,7 @@ and parse_instr
return (typed loc (Swap, Item_t (w, Item_t (v, rest, cur_top_annot), annot)))
| Prim (loc, I_PUSH, [ t ; d ], instr_annot),
stack ->
(Lwt.return (parse_ty t)) >>=? fun (Ex_ty t, _) ->
(Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) ->
parse_data ?type_logger ctxt t d >>=? fun v ->
return (typed loc (Const v, Item_t (t, stack, instr_annot)))
| Prim (loc, I_UNIT, [], instr_annot),
@ -1230,7 +1288,7 @@ and parse_instr
return (typed loc (Cons_some, Item_t (Option_t t, rest, instr_annot)))
| Prim (loc, I_NONE, [ t ], instr_annot),
stack ->
(Lwt.return (parse_ty t)) >>=? fun (Ex_ty t, _) ->
(Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) ->
return (typed loc (Cons_none t, Item_t (Option_t t, stack, instr_annot)))
| Prim (loc, I_IF_NONE, [ bt ; bf ], instr_annot),
(Item_t (Option_t t, rest, _) as bef) ->
@ -1256,11 +1314,11 @@ and parse_instr
(* unions *)
| Prim (loc, I_LEFT, [ tr ], instr_annot),
Item_t (tl, rest, stack_annot) ->
(Lwt.return (parse_ty tr)) >>=? fun (Ex_ty tr, _) ->
(Lwt.return (parse_ty false tr)) >>=? fun (Ex_ty tr, _) ->
return (typed loc (Left, Item_t (Union_t ((tl, stack_annot), (tr, None)), rest, instr_annot)))
| Prim (loc, I_RIGHT, [ tl ], instr_annot),
Item_t (tr, rest, stack_annot) ->
(Lwt.return (parse_ty tl)) >>=? fun (Ex_ty tl, _) ->
(Lwt.return (parse_ty false tl)) >>=? fun (Ex_ty tl, _) ->
return (typed loc (Right, Item_t (Union_t ((tl, None), (tr, stack_annot)), rest, instr_annot)))
| Prim (loc, I_IF_LEFT, [ bt ; bf ], instr_annot),
(Item_t (Union_t ((tl, left_annot), (tr, right_annot)), rest, _) as bef) ->
@ -1275,7 +1333,7 @@ and parse_instr
(* lists *)
| Prim (loc, I_NIL, [ t ], instr_annot),
stack ->
(Lwt.return (parse_ty t)) >>=? fun (Ex_ty t, _) ->
(Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) ->
return (typed loc (Nil, Item_t (List_t t, stack, instr_annot)))
| Prim (loc, I_CONS, [], instr_annot),
Item_t (tv, Item_t (List_t t, rest, _), _) ->
@ -1376,7 +1434,7 @@ and parse_instr
| Prim (loc, I_EMPTY_MAP, [ tk ; tv ], instr_annot),
stack ->
(Lwt.return (parse_comparable_ty tk)) >>=? fun (Ex_comparable_ty tk) ->
(Lwt.return (parse_ty tv)) >>=? fun (Ex_ty tv, _) ->
(Lwt.return (parse_ty false tv)) >>=? fun (Ex_ty tv, _) ->
return (typed loc (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack, instr_annot)))
| Prim (loc, I_MAP, [], instr_annot),
Item_t (Lambda_t (Pair_t ((pk, _), (pv, _)), ret),
@ -1431,6 +1489,23 @@ and parse_instr
| Prim (loc, I_SIZE, [], instr_annot),
Item_t (Map_t (_, _), rest, _) ->
return (typed loc (Map_size, Item_t (Nat_t, rest, instr_annot)))
(* big_map *)
| Prim (loc, I_MEM, [], instr_annot),
Item_t (set_key, Item_t (Big_map_t (map_key, _), rest, _), _) ->
let k = ty_of_comparable_ty map_key in
check_item_ty set_key k loc I_MEM 1 2 >>=? fun Eq ->
return (typed loc (Big_map_mem, Item_t (Bool_t, rest, instr_annot)))
| Prim (loc, I_GET, [], instr_annot),
Item_t (vk, Item_t (Big_map_t (ck, elt), rest, _), _) ->
let k = ty_of_comparable_ty ck in
check_item_ty vk k loc I_GET 1 2 >>=? fun Eq ->
return (typed loc (Big_map_get, Item_t (Option_t elt, rest, instr_annot)))
| Prim (loc, I_UPDATE, [], instr_annot),
Item_t (set_key, Item_t (Option_t set_value, Item_t (Big_map_t (map_key, map_value), rest, _), _), _) ->
let k = ty_of_comparable_ty map_key in
check_item_ty set_key k loc I_UPDATE 1 3 >>=? fun Eq ->
check_item_ty set_value map_value loc I_UPDATE 2 3 >>=? fun Eq ->
return (typed loc (Big_map_update, Item_t (Big_map_t (map_key, map_value), rest, instr_annot)))
(* control *)
| Seq (loc, [], annot),
stack ->
@ -1504,8 +1579,8 @@ and parse_instr
end
| Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot),
stack ->
(Lwt.return (parse_ty arg)) >>=? fun (Ex_ty arg, arg_annot) ->
(Lwt.return (parse_ty ret)) >>=? fun (Ex_ty ret, _) ->
(Lwt.return (parse_ty false arg)) >>=? fun (Ex_ty arg, arg_annot) ->
(Lwt.return (parse_ty false ret)) >>=? fun (Ex_ty ret, _) ->
check_kind [ Seq_kind ] code >>=? fun () ->
parse_returning Lambda ?type_logger ctxt
(arg, default_annot ~default:default_arg_annot arg_annot)
@ -1776,13 +1851,13 @@ and parse_instr
Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, ret_type, storage_type, code_field) ->
trace
(Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
(Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type, param_annot) ->
(Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) ->
trace
(Ill_formed_type (Some "return", cannonical_code, location ret_type))
(Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type, _) ->
(Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) ->
trace
(Ill_formed_type (Some "storage", cannonical_code, location storage_type))
(Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) ->
(Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot),
(storage_type, default_annot ~default:default_storage_annot storage_annot)) in
let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in
@ -1791,7 +1866,7 @@ and parse_instr
(parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type })
ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=?
fun (Lam ({ bef = Item_t (arg, Empty_t, _) ;
aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda) ->
aft = Item_t (ret, Empty_t, _) }, _) as lambda) ->
Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq ->
Lwt.return @@ ty_eq ret ret_type_full >>=? fun Eq ->
Lwt.return @@ ty_eq storage_type ginit >>=? fun Eq ->
@ -1820,15 +1895,15 @@ and parse_instr
return (typed loc (Steps_to_quota, Item_t (Nat_t, stack, instr_annot)))
| Prim (loc, I_SOURCE, [ ta; tb ], instr_annot),
stack ->
(Lwt.return (parse_ty ta)) >>=? fun (Ex_ty ta, _) ->
(Lwt.return (parse_ty tb)) >>=? fun (Ex_ty tb, _) ->
(Lwt.return (parse_ty false ta)) >>=? fun (Ex_ty ta, _) ->
(Lwt.return (parse_ty false tb)) >>=? fun (Ex_ty tb, _) ->
return (typed loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack, instr_annot)))
| Prim (loc, I_SELF, [], instr_annot),
stack ->
let rec get_toplevel_type : tc_context -> bef judgement tzresult Lwt.t = function
| Lambda -> fail (Self_in_lambda loc)
| Dip (_, prev) -> get_toplevel_type prev
| Toplevel { param_type ; ret_type ; _ } ->
| Toplevel { param_type ; ret_type } ->
return (typed loc (Self (param_type, ret_type),
Item_t (Contract_t (param_type, ret_type), stack, instr_annot))) in
get_toplevel_type tc_context
@ -1860,7 +1935,7 @@ and parse_instr
as name), ([] | [ _ ]
| _ :: _ :: _ :: _ as l), _), _ ->
fail (Invalid_arity (loc, name, 2, List.length l))
| Prim (loc, I_LAMBDA, ([] | [ _ ] | [ _ ; _ ]
| Prim (loc, I_LAMBDA, ([] | [ _ ]
| _ :: _ :: _ :: _ :: _ as l), _), _ ->
fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l))
(* Stack errors *)
@ -1939,11 +2014,11 @@ and parse_contract
let contract : (arg, ret) typed_contract =
(arg, ret, contract) in
ok contract)
| Some { code ; _ } ->
| Some { code } ->
Lwt.return
(parse_toplevel code >>? fun (arg_type, ret_type, _, _) ->
parse_ty arg_type >>? fun (Ex_ty targ, _) ->
parse_ty ret_type >>? fun (Ex_ty tret, _) ->
parse_ty false arg_type >>? fun (Ex_ty targ, _) ->
parse_ty false ret_type >>? fun (Ex_ty tret, _) ->
ty_eq targ arg >>? fun Eq ->
ty_eq tret ret >>? fun Eq ->
let contract : (arg, ret) typed_contract =
@ -2003,13 +2078,13 @@ let parse_script
Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) ->
trace
(Ill_formed_type (Some "parameter", code, location arg_type))
(Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type, param_annot) ->
(Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) ->
trace
(Ill_formed_type (Some "return", code, location ret_type))
(Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type, _) ->
(Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) ->
trace
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) ->
(Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot),
(storage_type, default_annot ~default:default_storage_annot storage_annot)) in
let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in
@ -2031,13 +2106,13 @@ let typecheck_code
(* TODO: annotation checking *)
trace
(Ill_formed_type (Some "parameter", code, location arg_type))
(Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type, param_annot) ->
(Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) ->
trace
(Ill_formed_type (Some "return", code, location ret_type))
(Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type, _) ->
(Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) ->
trace
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) ->
(Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot),
(storage_type, default_annot ~default:default_storage_annot storage_annot)) in
let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in
@ -2058,7 +2133,7 @@ let typecheck_data
= fun ?type_logger ctxt (data, exp_ty) ->
trace
(Ill_formed_type (None, exp_ty, 0))
(Lwt.return (parse_ty (root exp_ty))) >>=? fun (Ex_ty exp_ty, _) ->
(Lwt.return (parse_ty true (root exp_ty))) >>=? fun (Ex_ty exp_ty, _) ->
trace
(Ill_typed_data (None, data, exp_ty))
(parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun _ ->
@ -2068,3 +2143,52 @@ let hash_data typ data =
let unparsed = strip_annotations @@ unparse_data typ data in
let bytes = Data_encoding.Binary.to_bytes expr_encoding (Micheline.strip_locations unparsed) in
Tezos_hash.Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check)
(* ---------------- Big map -------------------------------------------------*)
let big_map_mem ctx contract key { diff ; key_type } =
match map_get key diff with
| None -> Tezos_context.Contract.Big_map_storage.mem ctx contract (hash_data key_type key)
| Some None -> Lwt.return false
| Some (Some _) -> Lwt.return true
let big_map_get ctx contract key { diff ; key_type ; value_type } =
match map_get key diff with
| Some x -> return x
| None ->
Tezos_context.Contract.Big_map_storage.get_opt
ctx contract
(hash_data key_type key) >>=? begin function
| None -> return None
| Some value -> parse_data ctx value_type (Micheline.root value) >>|? fun x -> Some x
end
let big_map_update key value ({ diff } as map) =
{ map with diff = map_set key value diff }
let to_big_map_diff_list { key_type ; value_type ; diff } =
map_fold (fun key value acc ->
(hash_data key_type key,
Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse_data value_type x) value) :: acc)
diff []
(* Get the big map from a contract's storage if one exists *)
let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x ->
match (ty, x) with
| Pair_t ((Big_map_t (_, _), _), _), (map, _) -> Some (Ex_bm map)
| _, _ -> None
let to_serializable_big_map (Ex_bm bm) =
to_big_map_diff_list bm
let to_printable_big_map (Ex_bm { diff ; key_type ; value_type }) =
map_fold (fun key value acc ->
(Micheline.strip_locations @@ unparse_data key_type key,
Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse_data value_type x) value) :: acc) diff []
let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) =
Lwt.return (parse_toplevel code) >>=? fun (_, _, storage_type, _) ->
Lwt.return @@ parse_ty true storage_type >>=? fun (Ex_ty ty, _) ->
parse_data ctxt ty (Micheline.root storage) >>|? fun data ->
({ code ; storage = Micheline.strip_locations @@ unparse_data ty data },
Option.map ~f:to_serializable_big_map (extract_big_map ty data))

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

@ -17,7 +17,6 @@ type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty
type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty
type ex_script = Ex_script : ('a, 'b, 'c) Script_typed_ir.script -> ex_script
(* ---- Sets and Maps -------------------------------------------------------*)
val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set
@ -39,6 +38,14 @@ val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option
val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty
val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num
val big_map_mem : context -> Tezos_context.Contract.t -> 'key -> ('key, 'value) Script_typed_ir.big_map -> bool Lwt.t
val big_map_get :
context -> Tezos_context.Contract.t -> 'key -> ('key, 'value) Script_typed_ir.big_map ->
'value option tzresult Lwt.t
val big_map_update :
'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map ->
('key, 'value) Script_typed_ir.big_map
val ty_eq :
'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty ->
('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq tzresult
@ -49,7 +56,7 @@ val parse_data :
val unparse_data :
'a Script_typed_ir.ty -> 'a -> Script.node
val parse_ty :
val parse_ty : bool ->
Script.node -> (ex_ty * Script_typed_ir.annot) tzresult
val unparse_ty :
string option -> 'a Script_typed_ir.ty -> Script.node
@ -69,3 +76,12 @@ val parse_script :
context -> Script.t -> ex_script tzresult Lwt.t
val hash_data : 'a Script_typed_ir.ty -> 'a -> string
val extract_big_map : 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option
val to_serializable_big_map : Script_typed_ir.ex_big_map -> Contract_storage.big_map_diff
val to_printable_big_map : Script_typed_ir.ex_big_map -> (Script.expr * Script.expr option) list
val erase_big_map_initialization : context -> Script.t ->
(Script.t * Contract_storage.big_map_diff option) tzresult Lwt.t

1
src/proto_alpha/lib_protocol/src/script_tc_errors.ml
View File

@ -26,6 +26,7 @@ type error += Invalid_primitive of Script.location * prim list * prim
type error += Invalid_kind of Script.location * kind list * kind
type error += Missing_field of prim
type error += Duplicate_field of Script.location * prim
type error += Unexpected_big_map of Script.location
(* Instruction typing errors *)
type error += Fail_not_in_tail_position of Script.location

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

@ -30,7 +30,7 @@ let ex_ty_enc =
Data_encoding.conv
(fun (Ex_ty ty) -> strip_locations (unparse_ty None ty))
(fun expr ->
match parse_ty (root expr) with
match parse_ty true (root expr) with
| Ok (Ex_ty ty, _) -> Ex_ty ty
| _ -> Ex_ty Unit_t (* FIXME: ? *))
Script.expr_encoding
@ -164,6 +164,18 @@ let () =
(req "prim" prim_encoding))
(function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None)
(fun (loc, prim) -> Duplicate_field (loc, prim)) ;
(* Unexpected big_map *)
register_error_kind
`Permanent
~id:"unexpectedBigMap"
~title: "Big map in unauthorized position (type error)"
~description:
"When parsing script, a big_map type was found somewhere else \
than in the left component of the toplevel storage pair."
(obj1
(req "loc" location_encoding))
(function Unexpected_big_map loc -> Some loc | _ -> None)
(fun loc -> Unexpected_big_map loc) ;
(* -- Value typing errors ---------------------- *)
(* Unordered map keys *)
register_error_kind

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

@ -41,6 +41,8 @@ end
type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value)
type annot = string option
type ('arg, 'ret, 'storage) script =
{ code : (('arg, 'storage) pair, ('ret, 'storage) pair) lambda ;
arg_type : 'arg ty ;
@ -60,8 +62,6 @@ and ('arg, 'ret) lambda =
and ('arg, 'ret) typed_contract =
'arg ty * 'ret ty * Contract.t
and annot = string option
and 'ty ty =
| Unit_t : unit ty
| Int_t : z num ty
@ -80,12 +80,17 @@ and 'ty ty =
| List_t : 'v ty -> 'v list ty
| Set_t : 'v comparable_ty -> 'v set ty
| Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map ty
| Big_map_t : 'k comparable_ty * 'v ty -> ('k, 'v) big_map ty
| Contract_t : 'arg ty * 'ret ty -> ('arg, 'ret) typed_contract ty
and 'ty stack_ty =
| Item_t : 'ty ty * 'rest stack_ty * annot -> ('ty * 'rest) stack_ty
| Empty_t : end_of_stack stack_ty
and ('key, 'value) big_map = { diff : ('key, 'value option) map ;
key_type : 'key ty ;
value_type : 'value ty }
(* ---- Instructions --------------------------------------------------------*)
(* The low-level, typed instructions, as a GADT whose parameters
@ -176,6 +181,13 @@ and ('bef, 'aft) instr =
| Map_update :
('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr
| Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr
(* big maps *)
| Big_map_mem :
('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr
| Big_map_get :
('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr
| Big_map_update :
('key * ('value option * (('key, 'value) big_map * 'rest)), ('key, 'value) big_map * 'rest) instr
(* string operations *)
| Concat :
(string * (string * 'rest), string * 'rest) instr
@ -343,3 +355,5 @@ and ('bef, 'aft) descr =
bef : 'bef stack_ty ;
aft : 'aft stack_ty ;
instr : ('bef, 'aft) instr }
type ex_big_map = Ex_bm : ('key, 'value) big_map -> ex_big_map

12
src/proto_alpha/lib_protocol/src/services.ml
View File

@ -445,9 +445,10 @@ module Helpers = struct
~query: RPC_query.empty
~input: run_code_input_encoding
~output: (wrap_tzerror
(obj2
(obj3
(req "storage" Script.expr_encoding)
(req "output" Script.expr_encoding)))
(req "output" Script.expr_encoding)
(opt "big_map_diff" (list (tup2 Script.expr_encoding (option Script.expr_encoding))))))
~error: Data_encoding.empty
RPC_path.(custom_root / "helpers" / "run_code")
@ -473,14 +474,15 @@ module Helpers = struct
~query: RPC_query.empty
~input: run_code_input_encoding
~output: (wrap_tzerror
(obj3
(obj4
(req "storage" Script.expr_encoding)
(req "output" Script.expr_encoding)
(req "trace"
(list @@ obj3
(req "location" Script.location_encoding)
(req "gas" Gas.encoding)
(req "stack" (list (Script.expr_encoding)))))))
(req "stack" (list (Script.expr_encoding)))))
(opt "big_map_diff" (list (tup2 Script.expr_encoding (option Script.expr_encoding))))))
~error: Data_encoding.empty
RPC_path.(custom_root / "helpers" / "trace_code")
@ -509,12 +511,12 @@ module Helpers = struct
RPC_service.post_service
~description: "Computes the hash of some data expression \
using the same algorithm as script instruction H"
~query: RPC_query.empty
~input: (obj2 (req "data" Script.expr_encoding)
(req "type" Script.expr_encoding))
~output: (wrap_tzerror @@
obj1 (req "hash" string))
~error: Data_encoding.empty
~query: RPC_query.empty
RPC_path.(custom_root / "helpers" / "hash_data")
let level custom_root =

10
src/proto_alpha/lib_protocol/src/services_registration.ml
View File

@ -297,8 +297,8 @@ let () =
contract (* transaction initiator *)
contract (* script owner *)
ctxt { storage ; code } amount input
(Gas.of_int gas) >>=? fun (sto, ret, _gas, _ctxt, _) ->
Error_monad.return (sto, ret)) ;
(Gas.of_int gas) >>=? fun (sto, ret, _gas, _ctxt, _, maybe_big_map_diff) ->
Error_monad.return (sto, ret, Option.map ~f:Script_ir_translator.to_printable_big_map maybe_big_map_diff)) ;
register1 Services.Helpers.trace_code
(fun ctxt () parameters ->
let (code, storage, input, amount, contract, gas, origination_nonce) =
@ -308,8 +308,8 @@ let () =
contract (* transaction initiator *)
contract (* script owner *)
ctxt { storage ; code } amount input
(Gas.of_int gas) >>=? fun ((sto, ret, _gas, _ctxt, _), trace) ->
Error_monad.return (sto, ret, trace))
(Gas.of_int gas) >>=? fun ((sto, ret, _gas, _ctxt, _, maybe_big_map_diff), trace) ->
Error_monad.return (sto, ret, trace, Option.map ~f:Script_ir_translator.to_printable_big_map maybe_big_map_diff))
let () =
register1 Services.Helpers.typecheck_code
@ -323,7 +323,7 @@ let () =
register1 Services.Helpers.hash_data
(fun ctxt () (expr, typ) ->
let open Script_ir_translator in
Lwt.return @@ parse_ty (Micheline.root typ) >>=? fun (Ex_ty typ, _) ->
Lwt.return @@ parse_ty false (Micheline.root typ) >>=? fun (Ex_ty typ, _) ->
parse_data ctxt typ (Micheline.root expr) >>=? fun data ->
return (Script_ir_translator.hash_data typ data))

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

@ -20,6 +20,15 @@ module Bool = struct
let encoding = Data_encoding.bool
end
module String_index = struct
type t = string
let path_length = 1
let to_path c l = c :: l
let of_path = function
| [ c ] -> Some c
| [] | _ :: _ :: _ -> None
end
(** Contracts handling *)
module Contract = struct
@ -86,6 +95,18 @@ module Contract = struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
end))
type bigmap_key = Raw_context.t * Contract_repr.t
module Big_map =
Storage_functors.Make_indexed_data_storage
(Make_subcontext
(Indexed_context.Raw_context)
(struct let name = ["big_map"] end))
(String_index)
(Make_value (struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
end))
module Code_fees =
Indexed_context.Make_map

7
src/proto_alpha/lib_protocol/src/storage.mli
View File

@ -147,6 +147,13 @@ module Contract : sig
and type value = Tez_repr.t
and type t := Raw_context.t
type bigmap_key = Raw_context.t * Contract_repr.t
module Big_map : Indexed_data_storage
with type key = string
and type value = Script_repr.expr
and type t := bigmap_key
end
(** Votes *)

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

@ -107,6 +107,14 @@ end
module Contract = struct
include Contract_repr
include Contract_storage
module Big_map_storage = struct
let set ctx contract = Contract_storage.Big_map.set (ctx, contract)
let remove ctx contract = Contract_storage.Big_map.remove (ctx, contract)
let mem ctx contract = Contract_storage.Big_map.mem (ctx, contract)
let get_opt ctx contract = Contract_storage.Big_map.get_opt (ctx, contract)
end
end
module Roll = struct
include Roll_repr

15
src/proto_alpha/lib_protocol/src/tezos_context.mli
View File

@ -216,6 +216,7 @@ module Script : sig
| T_lambda
| T_list
| T_map
| T_big_map
| T_nat
| T_option
| T_or
@ -466,7 +467,8 @@ module Contract : sig
context -> contract -> Tez.t -> context tzresult Lwt.t
val update_script_storage_and_fees:
context -> contract -> Tez.t -> Script.expr -> context tzresult Lwt.t
context -> contract -> Tez.t -> Script.expr ->
(string * Script.expr option) list option -> context tzresult Lwt.t
val increment_counter:
context -> contract -> context tzresult Lwt.t
@ -474,6 +476,17 @@ module Contract : sig
val check_counter_increment:
context -> contract -> int32 -> unit tzresult Lwt.t
module Big_map_storage : sig
val set :
context -> contract ->
string -> Script.expr -> context tzresult Lwt.t
val remove :
context -> contract -> string -> context tzresult Lwt.t
val mem : context -> contract -> string -> bool Lwt.t
val get_opt :
context -> contract -> string -> Script_repr.expr option tzresult Lwt.t
end
end
module Vote : sig

2
src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli
View File

@ -13,6 +13,6 @@ open Tezos_context
val init_amount : int
val execute_code_pred :
?tc:Tezos_context.t -> Helpers_block.result -> Script.t -> Script.expr ->
(Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce)
(Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option)
proto_tzresult Lwt.t

2
src/proto_alpha/lib_protocol/test/jbuild
View File

@ -4,11 +4,13 @@
((name main)
(libraries (tezos-base
tezos-test-helpers
tezos-micheline
tezos_proto_alpha_isolate_helpers
tezos_proto_alpha_isolate_michelson_parser))
(flags (:standard -w -9-32 -safe-string
-open Tezos_base__TzPervasives
-open Tezos_test_helpers
-open Tezos_micheline
-open Tezos_proto_alpha_isolate_michelson_parser))))
(alias

18
src/proto_alpha/lib_protocol/test/test_michelson.ml
View File

@ -25,8 +25,6 @@ open Shorthands
let (>>??) = Assert.(>>??)
let (>>=??) = Assert.(>>=??)
open Tezos_micheline
let parse_param s : Proto_alpha.Tezos_context.Script.expr =
let (parsed, _) = Michelson_v1_parser.parse_expression s in
parsed.expanded
@ -50,9 +48,9 @@ let quote s = "\"" ^ s ^ "\""
let parse_execute sb ?tc code_str param_str storage_str =
let param = parse_param param_str in
let script = parse_script code_str storage_str in
Script.execute_code_pred ?tc sb script param >>=?? fun (ret, st, _, tc, nonce) ->
Script.execute_code_pred ?tc sb script param >>=?? fun (ret, st, _, tc, nonce, bgm) ->
let contracts = Contract.originated_contracts nonce in
return (ret, st, tc, contracts)
return (ret, st, tc, contracts, bgm)
let test ctxt ?tc (file_name: string) (storage: string) (input: string) =
let full_path = contract_path // file_name ^ ".tz" in
@ -79,7 +77,7 @@ let string_of_canon output_prim =
output
let test_print ctxt fn s i =
test ctxt fn s i >>=? fun (sp, op, _, _) ->
test ctxt fn s i >>=? fun (sp, op, _, _, _bgm) ->
let ss = string_of_canon sp in
let os = string_of_canon op in
debug "Storage : %s" ss ;
@ -88,7 +86,7 @@ let test_print ctxt fn s i =
let test_output ctxt ?location (file_name: string) (storage: string) (input: string) (expected_output: string) =
test ctxt file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts) ->
test ctxt file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts, _bgm) ->
let output = string_of_canon output_prim in
let msg = Option.unopt ~default:"strings aren't equal" location in
Assert.equal_string ~msg expected_output output ;
@ -96,18 +94,18 @@ let test_output ctxt ?location (file_name: string) (storage: string) (input: str
let test_tc ctxt ?tc (file_name: string) (storage: string) (input: string) =
test ctxt ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, _contracts) ->
test ctxt ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, _contracts, _bgm) ->
return (tc)
let test_contract ctxt ?tc (file_name: string) (storage: string) (input: string) =
test ctxt ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, contracts) ->
test ctxt ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, contracts, _bgm) ->
return (contracts, tc)
let test_storage ctxt ?location (file_name: string) (storage: string) (input: string) (expected_storage: string) =
test ctxt file_name storage input >>=? fun (storage_prim, _output_prim, _tc, _contracts) ->
test ctxt file_name storage input >>=? fun (storage_prim, _output_prim, _tc, _contracts, _bgm) ->
let storage = string_of_canon storage_prim in
let msg = Option.unopt ~default:"strings aren't equal" location in
Assert.equal_string ~msg expected_storage storage ;
@ -439,7 +437,7 @@ let test_example () =
let contract = List.hd cs in
Proto_alpha.Tezos_context.Contract.get_script tc contract >>=?? fun res ->
let script = Option.unopt_exn (Failure "get_script") res in
Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun (_, ret, _, _, _) ->
Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun (_, ret, _, _, _, _) ->
Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ;
(* Test DEFAULT_ACCOUNT *)