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

Michelson: cleaner naming in interpreter

Browse Source
This commit is contained in:
Benjamin Canou 2018-04-08 20:24:25 +02:00 committed by Grégoire Henry
parent 24deb10c8f
commit 59cccd53aa
10 changed files with 138 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -43,11 +43,11 @@ let print_big_map_diff ppf = function
(Format.pp_print_list (Format.pp_print_list
~pp_sep:Format.pp_print_space ~pp_sep:Format.pp_print_space
(fun ppf (key, value) -> (fun ppf (key, value) ->
Format.fprintf ppf "%s %a%a" Format.fprintf ppf "%s %s%a"
(match value with (match value with
| None -> "-" | None -> "-"
| Some _ -> "+") | Some _ -> "+")
print_expr key key
(fun ppf -> function (fun ppf -> function
| None -> () | None -> ()
| Some x -> Format.fprintf ppf "-> %a" print_expr x) | Some x -> Format.fprintf ppf "-> %a" print_expr x)

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

@ -22,7 +22,7 @@ val run :
input:Michelson_v1_parser.parsed -> input:Michelson_v1_parser.parsed ->
Block_services.block -> Block_services.block ->
#Proto_alpha.rpc_context -> #Proto_alpha.rpc_context ->
(Script.expr * Script.expr * (Script.expr * Script.expr option) list option) tzresult Lwt.t (Script.expr * Script.expr * Contract.big_map_diff option) tzresult Lwt.t
val trace : val trace :
?contract:Contract.t -> ?contract:Contract.t ->
@ -32,22 +32,24 @@ val trace :
input:Michelson_v1_parser.parsed -> input:Michelson_v1_parser.parsed ->
Block_services.block -> Block_services.block ->
#Proto_alpha.rpc_context -> #Proto_alpha.rpc_context ->
(Script.expr * Script.expr * (int * Gas.t * Script.expr list) list * (Script.expr * Script.expr option) list option) tzresult Lwt.t (Script.expr * Script.expr *
Script_interpreter.execution_trace *
Contract.big_map_diff option) tzresult Lwt.t
val print_run_result : val print_run_result :
#Client_context.printer -> #Client_context.printer ->
show_source:bool -> show_source:bool ->
parsed:Michelson_v1_parser.parsed -> parsed:Michelson_v1_parser.parsed ->
(Script_repr.expr * Script_repr.expr * (Script_repr.expr * Script_repr.expr *
(Script_repr.expr * Script_repr.expr option) list option) tzresult -> unit tzresult Lwt.t Contract.big_map_diff option) tzresult -> unit tzresult Lwt.t
val print_trace_result : val print_trace_result :
#Client_context.printer -> #Client_context.printer ->
show_source:bool -> show_source:bool ->
parsed:Michelson_v1_parser.parsed -> parsed:Michelson_v1_parser.parsed ->
(Script_repr.expr * Script_repr.expr * (Script_repr.expr * Script_repr.expr *
(int * Gas.t * Script_repr.expr list) list * Script_interpreter.execution_trace *
(Script_repr.expr * Script_repr.expr option) list option) Contract.big_map_diff option)
tzresult -> unit tzresult Lwt.t tzresult -> unit tzresult Lwt.t
val hash_and_sign : val hash_and_sign :

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

@ -388,21 +388,16 @@ let apply_manager_operation_content
| _ -> fail (Bad_contract_parameter (destination, None, parameters)) | _ -> fail (Bad_contract_parameter (destination, None, parameters))
end end
| Some script -> | Some script ->
let call_contract ctxt argument = let call_contract ctxt parameter =
Script_interpreter.execute Script_interpreter.execute
origination_nonce ctxt origination_nonce
source destination ctxt script amount argument ~source ~self:(destination, script) ~amount ~parameter
>>= function >>= function
| Ok (storage_res, _res, ctxt, origination_nonce, maybe_big_map_diff) -> | Ok { ctxt ; origination_nonce ; storage ; big_map_diff ; return_value = _ } ->
begin match maybe_big_map_diff with
| None -> return (None, ctxt)
| Some map ->
Script_ir_translator.to_serializable_big_map ctxt map >>=? fun (diff, ctxt) ->
return (Some diff, ctxt) end >>=? fun (diff, ctxt) ->
Contract.update_script_storage Contract.update_script_storage
ctxt destination ctxt destination storage big_map_diff >>=? fun ctxt ->
storage_res diff >>=? fun ctxt -> Fees.update_script_storage
Fees.update_script_storage ctxt ~source destination >>=? fun (ctxt, fees) -> ctxt ~source destination >>=? fun (ctxt, fees) ->
return (ctxt, origination_nonce, None, fees) return (ctxt, origination_nonce, None, fees)
| Error err -> | Error err ->
return (ctxt, origination_nonce, Some err, Tez.zero) in return (ctxt, origination_nonce, Some err, Tez.zero) in

35
src/proto_alpha/lib_protocol/src/helpers_services.ml
View File

@ -40,7 +40,7 @@ module S = struct
~output: (obj3 ~output: (obj3
(req "storage" Script.expr_encoding) (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))))) (opt "big_map_diff" (list (tup2 string (option Script.expr_encoding)))))
RPC_path.(custom_root / "run_code") RPC_path.(custom_root / "run_code")
let apply_operation = let apply_operation =
@ -71,7 +71,7 @@ module S = struct
(req "location" Script.location_encoding) (req "location" Script.location_encoding)
(req "gas" Gas.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))))) (opt "big_map_diff" (list (tup2 string (option Script.expr_encoding)))))
RPC_path.(custom_root / "trace_code") RPC_path.(custom_root / "trace_code")
let typecheck_code = let typecheck_code =
@ -179,37 +179,34 @@ let () =
end ; end ;
register0 S.apply_operation I.apply_operation ; register0 S.apply_operation I.apply_operation ;
register0 S.run_code begin fun ctxt () parameters -> register0 S.run_code begin fun ctxt () parameters ->
let (code, storage, input, amount, contract, gas, origination_nonce) = let (code, storage, parameter, amount, contract, gas, origination_nonce) =
I.run_parameters ctxt parameters in I.run_parameters ctxt parameters in
begin if Compare.Z.(gas > Z.zero) then begin if Compare.Z.(gas > Z.zero) then
Lwt.return (Gas.set_limit ctxt gas) Lwt.return (Gas.set_limit ctxt gas)
else else
return (Gas.set_unlimited ctxt) end >>=? fun ctxt -> return (Gas.set_unlimited ctxt) end >>=? fun ctxt ->
Script_interpreter.execute Script_interpreter.execute
origination_nonce ctxt origination_nonce
contract (* transaction initiator *) ~source:contract (* transaction initiator *)
contract (* script owner *) ~self:(contract, { storage ; code }) (* script owner *)
ctxt { storage ; code } amount input >>=? fun (sto, ret, _ctxt, _, maybe_big_map_diff) -> ~amount ~parameter
return (sto, ret, >>=? fun { Script_interpreter.storage ; return_value ; big_map_diff ; _ } ->
Option.map maybe_big_map_diff return (storage, return_value, big_map_diff)
~f:(Script_ir_translator.to_printable_big_map ctxt))
end ; end ;
register0 S.trace_code begin fun ctxt () parameters -> register0 S.trace_code begin fun ctxt () parameters ->
let (code, storage, input, amount, contract, gas, origination_nonce) = let (code, storage, parameter, amount, contract, gas, origination_nonce) =
I.run_parameters ctxt parameters in I.run_parameters ctxt parameters in
begin if Compare.Z.(gas > Z.zero) then begin if Compare.Z.(gas > Z.zero) then
Lwt.return (Gas.set_limit ctxt gas) Lwt.return (Gas.set_limit ctxt gas)
else else
return (Gas.set_unlimited ctxt) end >>=? fun ctxt -> return (Gas.set_unlimited ctxt) end >>=? fun ctxt ->
Script_interpreter.trace Script_interpreter.trace
origination_nonce ctxt origination_nonce
contract (* transaction initiator *) ~source:contract (* transaction initiator *)
contract (* script owner *) ~self:(contract, { storage ; code }) (* script owner *)
ctxt { storage ; code } amount input ~amount ~parameter
>>=? fun ((sto, ret, _ctxt, _, maybe_big_map_diff), trace) -> >>=? fun ({ Script_interpreter.storage ; return_value ; big_map_diff ; _ }, trace) ->
return (sto, ret, trace, return (storage, return_value, trace, big_map_diff)
Option.map maybe_big_map_diff
~f:(Script_ir_translator.to_printable_big_map ctxt))
end ; end ;
register0 S.typecheck_code begin fun ctxt () (expr, maybe_gas) -> register0 S.typecheck_code begin fun ctxt () (expr, maybe_gas) ->
begin match maybe_gas with begin match maybe_gas with

6
src/proto_alpha/lib_protocol/src/helpers_services.mli
View File

@ -25,15 +25,15 @@ val run_code:
'a #RPC_context.simple -> 'a #RPC_context.simple ->
'a -> Script.expr -> 'a -> Script.expr ->
(Script.expr * Script.expr * Tez.t * Contract.t) -> (Script.expr * Script.expr * Tez.t * Contract.t) ->
(Script.expr * Script.expr * (Script.expr * Script.expr option) list option) shell_tzresult Lwt.t (Script.expr * Script.expr * Contract.big_map_diff option) shell_tzresult Lwt.t
val trace_code: val trace_code:
'a #RPC_context.simple -> 'a #RPC_context.simple ->
'a -> Script.expr -> 'a -> Script.expr ->
(Script.expr * Script.expr * Tez.t * Contract.t) -> (Script.expr * Script.expr * Tez.t * Contract.t) ->
(Script.expr * Script.expr * (Script.expr * Script.expr *
(Script.location * Gas.t * Script.expr list) list * Script_interpreter.execution_trace *
(Script.expr * Script.expr option) list option) shell_tzresult Lwt.t Contract.big_map_diff option) shell_tzresult Lwt.t
val typecheck_code: val typecheck_code:
'a #RPC_context.simple -> 'a #RPC_context.simple ->

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

@ -76,13 +76,17 @@ let unparse_stack ctxt (stack, stack_ty) =
module Interp_costs = Michelson_v1_gas.Cost_of module Interp_costs = Michelson_v1_gas.Cost_of
type execution_trace =
(Script.location * Gas.t * Script.expr list) list
let rec interp let rec interp
: type p r. : type p r.
?log: (Script.location * Gas.t * Script.expr list) list ref -> (?log: execution_trace ref ->
Contract.origination_nonce -> Contract.t -> Contract.t -> Tez.t -> context -> Contract.origination_nonce ->
context -> (p, r) lambda -> p -> source: Contract.t -> self: Contract.t -> Tez.t ->
(r * context * Contract.origination_nonce) tzresult Lwt.t (p, r) lambda -> p ->
= fun ?log origination orig source amount ctxt (Lam (code, _)) arg -> (r * context * Contract.origination_nonce) tzresult Lwt.t)
= fun ?log ctxt origination ~source ~self amount (Lam (code, _)) arg ->
let rec step let rec step
: type b a. : type b a.
Contract.origination_nonce -> context -> (b, a) descr -> b stack -> Contract.origination_nonce -> context -> (b, a) descr -> b stack ->
@ -165,14 +169,14 @@ let rec interp
Prim (0, K_code, [ Micheline.root code ], None) ], None)) in Prim (0, K_code, [ Micheline.root code ], None) ], None)) in
Lwt.return @@ unparse_data ctxt storage_type init >>=? fun (storage, ctxt) -> Lwt.return @@ unparse_data ctxt storage_type init >>=? fun (storage, ctxt) ->
let storage = Micheline.strip_locations storage in let storage = Micheline.strip_locations storage in
Contract.spend_from_script ctxt source credit >>=? fun ctxt -> Contract.spend_from_script ctxt self credit >>=? fun ctxt ->
Contract.originate ctxt Contract.originate ctxt
origination origination
~manager ~delegate ~balance:credit ~manager ~delegate ~balance:credit
~script:({ code ; storage }, None (* TODO: initialize a big map from a map *)) ~script:({ code ; storage }, None (* TODO: initialize a big map from a map *))
~spendable ~delegatable ~spendable ~delegatable
>>=? fun (ctxt, contract, origination) -> >>=? fun (ctxt, contract, origination) ->
Fees.origination_burn ctxt ~source:orig contract >>=? fun ctxt -> Fees.origination_burn ctxt ~source contract >>=? fun ctxt ->
logged_return descr ~origination (Item ((param_type, return_type, contract), rest), ctxt) in logged_return descr ~origination (Item ((param_type, return_type, contract), rest), ctxt) in
let logged_return : ?origination:Contract.origination_nonce -> let logged_return : ?origination:Contract.origination_nonce ->
a stack * context -> a stack * context ->
@ -247,7 +251,7 @@ let rec interp
match l with match l with
| [] -> return (List.rev acc, ctxt, origination) | [] -> return (List.rev acc, ctxt, origination)
| hd :: tl -> | hd :: tl ->
interp ?log origination orig source amount ctxt lam hd interp ?log ctxt origination ~source ~self amount lam hd
>>=? fun (hd, ctxt, origination) -> >>=? fun (hd, ctxt, origination) ->
loop rest ctxt origination tl (hd :: acc) loop rest ctxt origination tl (hd :: acc)
in loop rest ctxt origination l [] >>=? fun (res, ctxt, origination) -> in loop rest ctxt origination l [] >>=? fun (res, ctxt, origination) ->
@ -269,7 +273,7 @@ let rec interp
match l with match l with
| [] -> return (acc, ctxt, origination) | [] -> return (acc, ctxt, origination)
| hd :: tl -> | hd :: tl ->
interp ?log origination orig source amount ctxt lam (hd, acc) interp ?log ctxt origination ~source ~self amount lam (hd, acc)
>>=? fun (acc, ctxt, origination) -> >>=? fun (acc, ctxt, origination) ->
loop rest ctxt origination tl acc loop rest ctxt origination tl acc
in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) ->
@ -306,7 +310,7 @@ let rec interp
match l with match l with
| [] -> return (acc, ctxt, origination) | [] -> return (acc, ctxt, origination)
| hd :: tl -> | hd :: tl ->
interp ?log origination orig source amount ctxt lam (hd, acc) interp ?log ctxt origination ~source ~self amount lam (hd, acc)
>>=? fun (acc, ctxt, origination) -> >>=? fun (acc, ctxt, origination) ->
loop rest ctxt origination tl acc loop rest ctxt origination tl acc
in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) ->
@ -342,7 +346,7 @@ let rec interp
match l with match l with
| [] -> return (acc, ctxt, origination) | [] -> return (acc, ctxt, origination)
| (k, _) as hd :: tl -> | (k, _) as hd :: tl ->
interp ?log origination orig source amount ctxt lam hd interp ?log ctxt origination ~source ~self amount lam hd
>>=? fun (hd, ctxt, origination) -> >>=? fun (hd, ctxt, origination) ->
loop rest ctxt origination tl (map_update k (Some hd) acc) loop rest ctxt origination tl (map_update k (Some hd) acc)
in loop rest ctxt origination l (empty_map (map_key_ty map)) >>=? fun (res, ctxt, origination) -> in loop rest ctxt origination l (empty_map (map_key_ty map)) >>=? fun (res, ctxt, origination) ->
@ -355,7 +359,7 @@ let rec interp
match l with match l with
| [] -> return (acc, ctxt, origination) | [] -> return (acc, ctxt, origination)
| hd :: tl -> | hd :: tl ->
interp ?log origination orig source amount ctxt lam (hd, acc) interp ?log ctxt origination ~source ~self amount lam (hd, acc)
>>=? fun (acc, ctxt, origination) -> >>=? fun (acc, ctxt, origination) ->
loop rest ctxt origination tl acc loop rest ctxt origination tl acc
in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) -> in loop rest ctxt origination l init >>=? fun (res, ctxt, origination) ->
@ -384,11 +388,11 @@ let rec interp
(* Big map operations *) (* Big map operations *)
| Big_map_mem, Item (key, Item (map, rest)) -> | Big_map_mem, Item (key, Item (map, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt ->
Script_ir_translator.big_map_mem ctxt source key map >>=? fun (res, ctxt) -> Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) ->
logged_return (Item (res, rest), ctxt) logged_return (Item (res, rest), ctxt)
| Big_map_get, Item (key, Item (map, rest)) -> | Big_map_get, Item (key, Item (map, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt ->
Script_ir_translator.big_map_get ctxt source key map >>=? fun (res, ctxt) -> Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) ->
logged_return (Item (res, rest), ctxt) logged_return (Item (res, rest), ctxt)
| Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) ->
consume_gas_terop descr consume_gas_terop descr
@ -579,7 +583,7 @@ let rec interp
logged_return ~origination (Item (ign, res), ctxt) logged_return ~origination (Item (ign, res), ctxt)
| Exec, Item (arg, Item (lam, rest)) -> | Exec, Item (arg, Item (lam, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt ->
interp ?log origination orig source amount ctxt lam arg >>=? fun (res, ctxt, origination) -> interp ?log ctxt origination ~source ~self amount lam arg >>=? fun (res, ctxt, origination) ->
logged_return ~origination (Item (res, rest), ctxt) logged_return ~origination (Item (res, rest), ctxt)
| Lambda lam, rest -> | Lambda lam, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
@ -643,7 +647,7 @@ let rec interp
| Transfer_tokens storage_type, | Transfer_tokens storage_type,
Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (storage, Empty)))) -> begin Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (storage, Empty)))) -> begin
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
Contract.spend_from_script ctxt source amount >>=? fun ctxt -> Contract.spend_from_script ctxt self amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? fun (ctxt, destination_script) -> Contract.get_script ctxt destination >>=? fun (ctxt, destination_script) ->
Lwt.return (unparse_data ctxt storage_type storage) >>=? fun (sto, ctxt) -> Lwt.return (unparse_data ctxt storage_type storage) >>=? fun (sto, ctxt) ->
@ -655,8 +659,8 @@ let rec interp
Script_ir_translator.to_serializable_big_map ctxt diff >>=? fun (diff, ctxt) -> Script_ir_translator.to_serializable_big_map ctxt diff >>=? fun (diff, ctxt) ->
return (Some diff, ctxt) return (Some diff, ctxt)
end >>=? fun (diff, ctxt) -> end >>=? fun (diff, ctxt) ->
Contract.update_script_storage ctxt source sto diff >>=? fun ctxt -> Contract.update_script_storage ctxt self sto diff >>=? fun ctxt ->
Fees.update_script_storage ctxt ~source:orig source >>=? fun (ctxt, _) -> Fees.update_script_storage ctxt ~source self >>=? fun (ctxt, _) ->
begin match destination_script with begin match destination_script with
| None -> | None ->
(* we see non scripted contracts as (unit, unit) contract *) (* we see non scripted contracts as (unit, unit) contract *)
@ -665,7 +669,8 @@ let rec interp
return (ctxt, origination) return (ctxt, origination)
| Some script -> | Some script ->
Lwt.return @@ unparse_data ctxt tp p >>=? fun (p, ctxt) -> Lwt.return @@ unparse_data ctxt tp p >>=? fun (p, ctxt) ->
execute origination source destination ctxt script amount p (* FIXME: add a sender parameter *)
execute ctxt origination ~source ~self:destination script amount p
>>=? fun (csto, ret, ctxt, origination, maybe_diff) -> >>=? fun (csto, ret, ctxt, origination, maybe_diff) ->
begin match maybe_diff with begin match maybe_diff with
| None -> | None ->
@ -678,10 +683,10 @@ let rec interp
trace trace
(Invalid_contract (loc, destination)) (Invalid_contract (loc, destination))
(parse_data ctxt Unit_t ret) >>=? fun ((), ctxt) -> (parse_data ctxt Unit_t ret) >>=? fun ((), ctxt) ->
Fees.update_script_storage ctxt ~source:orig destination >>=? fun (ctxt, _) -> Fees.update_script_storage ctxt ~source destination >>=? fun (ctxt, _) ->
return (ctxt, origination) return (ctxt, origination)
end >>=? fun (ctxt, origination) -> end >>=? fun (ctxt, origination) ->
Contract.get_script ctxt source >>=? (fun (ctxt, script) -> match script with Contract.get_script ctxt self >>=? (fun (ctxt, script) -> match script with
| None -> assert false | None -> assert false
| Some { storage; _ } -> | Some { storage; _ } ->
parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) -> parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) ->
@ -690,7 +695,7 @@ let rec interp
| Transfer_tokens storage_type, | Transfer_tokens storage_type,
Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
Contract.spend_from_script ctxt source amount >>=? fun ctxt -> Contract.spend_from_script ctxt self amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with
| None -> fail (Invalid_contract (loc, destination)) | None -> fail (Invalid_contract (loc, destination))
@ -704,10 +709,10 @@ let rec interp
end >>=? fun (maybe_diff, ctxt) -> end >>=? fun (maybe_diff, ctxt) ->
Lwt.return (unparse_data ctxt storage_type sto) >>=? fun (sto, ctxt) -> Lwt.return (unparse_data ctxt storage_type sto) >>=? fun (sto, ctxt) ->
let sto = Micheline.strip_locations sto in let sto = Micheline.strip_locations sto in
Contract.update_script_storage ctxt source sto maybe_diff >>=? fun ctxt -> Contract.update_script_storage ctxt self sto maybe_diff >>=? fun ctxt ->
Fees.update_script_storage ctxt ~source:orig source >>=? fun (ctxt, _) -> Fees.update_script_storage ctxt ~source self >>=? fun (ctxt, _) ->
Lwt.return (unparse_data ctxt tp p) >>=? fun (p, ctxt) -> Lwt.return (unparse_data ctxt tp p) >>=? fun (p, ctxt) ->
execute origination source destination ctxt script amount p execute ctxt origination ~source ~self:destination script amount p
>>=? fun (sto, ret, ctxt, origination, maybe_diff) -> >>=? fun (sto, ret, ctxt, origination, maybe_diff) ->
begin match maybe_diff with begin match maybe_diff with
| None -> | None ->
@ -717,11 +722,11 @@ let rec interp
return (Some diff, ctxt) return (Some diff, ctxt)
end >>=? fun (diff, ctxt) -> end >>=? fun (diff, ctxt) ->
Contract.update_script_storage ctxt destination sto diff >>=? fun ctxt -> Contract.update_script_storage ctxt destination sto diff >>=? fun ctxt ->
Fees.update_script_storage ctxt ~source:orig destination >>=? fun (ctxt, _) -> Fees.update_script_storage ctxt ~source destination >>=? fun (ctxt, _) ->
trace trace
(Invalid_contract (loc, destination)) (Invalid_contract (loc, destination))
(parse_data ctxt tr ret) >>=? fun (v, ctxt) -> (parse_data ctxt tr ret) >>=? fun (v, ctxt) ->
Contract.get_script ctxt source >>=? (fun (ctxt, script) -> match script with Contract.get_script ctxt self >>=? (fun (ctxt, script) -> match script with
| None -> assert false | None -> assert false
| Some { storage ; _ } -> | Some { storage ; _ } ->
parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) -> parse_data ctxt storage_type (Micheline.root storage) >>=? fun (sto, ctxt) ->
@ -730,7 +735,7 @@ let rec interp
| Create_account, | Create_account,
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
Contract.spend_from_script ctxt source credit >>=? fun ctxt -> Contract.spend_from_script ctxt self credit >>=? fun ctxt ->
Lwt.return Tez.(credit -? Constants.origination_burn ctxt) >>=? fun balance -> Lwt.return Tez.(credit -? Constants.origination_burn ctxt) >>=? fun balance ->
Contract.originate ctxt Contract.originate ctxt
origination origination
@ -763,7 +768,7 @@ let rec interp
~param_type ~return_type ~storage_type ~rest ~param_type ~return_type ~storage_type ~rest
| Balance, rest -> | Balance, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt ->
Contract.get_balance ctxt source >>=? fun balance -> Contract.get_balance ctxt self >>=? fun balance ->
logged_return (Item (balance, rest), ctxt) logged_return (Item (balance, rest), ctxt)
| Now, rest -> | Now, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt ->
@ -789,10 +794,10 @@ let rec interp
logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
| Source (ta, tb), rest -> | Source (ta, tb), rest ->
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
logged_return (Item ((ta, tb, orig), rest), ctxt) logged_return (Item ((ta, tb, source), rest), ctxt)
| Self (ta, tb), rest -> | Self (ta, tb), rest ->
Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt ->
logged_return (Item ((ta, tb, source), rest), ctxt) logged_return (Item ((ta, tb, self), rest), ctxt)
| Amount, rest -> | Amount, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt ->
logged_return (Item (amount, rest), ctxt) in logged_return (Item (amount, rest), ctxt) in
@ -807,28 +812,50 @@ let rec interp
(* ---- contract handling ---------------------------------------------------*) (* ---- contract handling ---------------------------------------------------*)
and execute ?log origination orig source ctxt script amount arg : and execute ?log ctxt origination_nonce ~source ~self script amount arg :
(Script.expr * Script.node * context * Contract.origination_nonce * (Script.expr * Script.node * context * Contract.origination_nonce *
Script_typed_ir.ex_big_map option) tzresult Lwt.t = Script_typed_ir.ex_big_map option) tzresult Lwt.t =
parse_script ctxt script parse_script ctxt script
>>=? fun ((Ex_script { code; arg_type; ret_type; storage; storage_type }), ctxt) -> >>=? fun ((Ex_script { code; arg_type; ret_type; storage; storage_type }), ctxt) ->
parse_data ctxt arg_type arg >>=? fun (arg, ctxt) -> parse_data ctxt arg_type arg >>=? fun (arg, ctxt) ->
trace trace
(Runtime_contract_error (source, script.code)) (Runtime_contract_error (self, script.code))
(interp ?log origination orig source amount ctxt code (arg, storage)) (interp ?log ctxt origination_nonce ~source ~self amount code (arg, storage))
>>=? fun ((ret, sto), ctxt, origination) -> >>=? fun ((ret, sto), ctxt, origination) ->
Lwt.return @@ unparse_data ctxt storage_type sto >>=? fun (storage, ctxt) -> Lwt.return @@ unparse_data ctxt storage_type sto >>=? fun (storage, ctxt) ->
Lwt.return @@ unparse_data ctxt ret_type ret >>=? fun (ret, ctxt) -> Lwt.return @@ unparse_data ctxt ret_type ret >>=? fun (ret, ctxt) ->
return (Micheline.strip_locations storage, ret, ctxt, origination, return (Micheline.strip_locations storage, ret, ctxt, origination,
Script_ir_translator.extract_big_map storage_type sto) Script_ir_translator.extract_big_map storage_type sto)
let trace origination orig source ctxt script amount arg = type execution_result =
let log = ref [] in { ctxt : context ;
execute ~log origination orig source ctxt script amount (Micheline.root arg) origination_nonce : Contract.origination_nonce ;
>>=? fun (sto, res, ctxt, origination, maybe_big_map) -> storage : Script.expr ;
return ((sto, Micheline.strip_locations res, ctxt, origination, maybe_big_map), List.rev !log) big_map_diff : Contract.big_map_diff option ;
return_value : Script.expr }
let execute origination orig source ctxt script amount arg = let trace ctxt origination_nonce ~source ~self:(self, script) ~parameter ~amount =
execute origination orig source ctxt script amount (Micheline.root arg) let log = ref [] in
>>=? fun (sto, res, ctxt, origination, maybe_big_map) -> execute ~log ctxt origination_nonce ~source ~self script amount (Micheline.root parameter)
return (sto, Micheline.strip_locations res, ctxt, origination, maybe_big_map) >>=? fun (storage, return_value, ctxt, origination_nonce, big_map_diff) ->
let return_value = Micheline.strip_locations return_value in
begin match big_map_diff with
| None -> return (None, ctxt)
| Some big_map_diff ->
Script_ir_translator.to_serializable_big_map ctxt big_map_diff >>=? fun (big_map_diff, ctxt) ->
return (Some big_map_diff, ctxt)
end >>=? fun (big_map_diff, ctxt) ->
let trace = List.rev !log in
return ({ ctxt ; origination_nonce ; storage ; big_map_diff ; return_value }, trace)
let execute ctxt origination_nonce ~source ~self:(self, script) ~parameter ~amount =
execute ctxt origination_nonce ~source ~self script amount (Micheline.root parameter)
>>=? fun (storage, return_value, ctxt, origination_nonce, big_map_diff) ->
let return_value = Micheline.strip_locations return_value in
begin match big_map_diff with
| None -> return (None, ctxt)
| Some big_map_diff ->
Script_ir_translator.to_serializable_big_map ctxt big_map_diff >>=? fun (big_map_diff, ctxt) ->
return (Some big_map_diff, ctxt)
end >>=? fun (big_map_diff, ctxt) ->
return { ctxt ; origination_nonce ; storage ; big_map_diff ; return_value }

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

@ -13,18 +13,28 @@ type error += Overflow of Script.location
type error += Reject of Script.location type error += Reject of Script.location
type error += Runtime_contract_error : Contract.t * Script.expr -> error type error += Runtime_contract_error : Contract.t * Script.expr -> error
type execution_result =
{ ctxt : context ;
origination_nonce : Contract.origination_nonce ;
storage : Script.expr ;
big_map_diff : Contract.big_map_diff option ;
return_value : Script.expr }
val execute: val execute:
Contract.origination_nonce -> Alpha_context.t -> Contract.origination_nonce ->
Contract.t -> Contract.t -> Alpha_context.t -> source: Contract.t ->
Script.t -> Tez.t -> self: (Contract.t * Script.t) ->
Script.expr -> parameter: Script.expr ->
(Script.expr * Script.expr * context * Contract.origination_nonce * amount: Tez.t ->
Script_typed_ir.ex_big_map option) tzresult Lwt.t execution_result tzresult Lwt.t
type execution_trace =
(Script.location * Gas.t * Script.expr list) list
val trace: val trace:
Contract.origination_nonce -> Alpha_context.t -> Contract.origination_nonce ->
Contract.t -> Contract.t -> Alpha_context.t -> source: Contract.t ->
Script.t -> Tez.t -> self: (Contract.t * Script.t) ->
Script.expr -> parameter: Script.expr ->
((Script.expr * Script.expr * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) * amount: Tez.t ->
(Script.location * Gas.t * Script.expr list) list) tzresult Lwt.t (execution_result * execution_trace) tzresult Lwt.t

8
src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml
View File

@ -14,7 +14,7 @@ open Alpha_context
let init_amount = 20000 let init_amount = 20000
let execute_code_pred let execute_code_pred
?tc (pred : Helpers_block.result) (script : Script.t) (argument : Script.expr) = ?tc (pred : Helpers_block.result) (script : Script.t) (parameter : Script.expr) =
let op = List.nth Helpers_account.bootstrap_accounts 0 in let op = List.nth Helpers_account.bootstrap_accounts 0 in
let tc = Option.unopt ~default:pred.tezos_context tc in let tc = Option.unopt ~default:pred.tezos_context tc in
Helpers_apply.script_origination_pred ~tc ~pred (script, op, init_amount) Helpers_apply.script_origination_pred ~tc ~pred (script, op, init_amount)
@ -32,8 +32,10 @@ let execute_code_pred
let amount = Tez.zero in let amount = Tez.zero in
Lwt.return (Proto_alpha.Alpha_context.Gas.set_limit tc gas) >>=? fun tc -> Lwt.return (Proto_alpha.Alpha_context.Gas.set_limit tc gas) >>=? fun tc ->
let return = Script_interpreter.execute let return = Script_interpreter.execute
dummy_nonce op.contract dst tc dummy_nonce
tc script amount argument in ~source: op.contract
~self: (dst, script)
~amount ~parameter in
return return

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

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

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

@ -48,9 +48,11 @@ let quote s = "\"" ^ s ^ "\""
let parse_execute sb ?tc code_str param_str storage_str = let parse_execute sb ?tc code_str param_str storage_str =
let param = parse_param param_str in let param = parse_param param_str in
let script = parse_script code_str storage_str in let script = parse_script code_str storage_str in
Script.execute_code_pred ?tc sb script param >>=?? fun (ret, st, tc, nonce, bgm) -> Script.execute_code_pred ?tc sb script param
>>=?? fun { return_value = ret ; storage = st ; ctxt = tc ;
origination_nonce = nonce ; big_map_diff = bgm } ->
let contracts = Contract.originated_contracts nonce in let contracts = Contract.originated_contracts nonce in
return (ret, st, tc, contracts, bgm) return (st, ret, tc, contracts, bgm)
let test ctxt ?tc (file_name: string) (storage: string) (input: string) = let test ctxt ?tc (file_name: string) (storage: string) (input: string) =
let full_path = contract_path // file_name ^ ".tz" in let full_path = contract_path // file_name ^ ".tz" in
@ -436,7 +438,7 @@ let test_example () =
let contract = List.hd cs in let contract = List.hd cs in
Proto_alpha.Alpha_context.Contract.get_script tc contract >>=?? fun (_, res) -> Proto_alpha.Alpha_context.Contract.get_script tc contract >>=?? fun (_, res) ->
let script = Option.unopt_exn (Failure "get_script") res in 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 { return_value = ret } ->
Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ; Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ;
(* Test IMPLICIT_ACCOUNT *) (* Test IMPLICIT_ACCOUNT *)