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

Proto: tracing interpreter, RPCs and command line.

Browse Source
This commit is contained in:
Benjamin Canou 2016-11-16 15:05:02 +01:00
parent db6a68a08f
commit 8edfc84ae6
9 changed files with 1010 additions and 857 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
src/client/embedded/bootstrap/client_proto_programs.ml
View File

@ -165,6 +165,16 @@ module Program = Client_aliases.Alias (struct
let commands () = let commands () =
let open Cli_entries in let open Cli_entries in
let show_types = ref false in
let show_types_arg =
"-details",
Arg.Set show_types,
"Show the types of each instruction" in
let trace_stack = ref false in
let trace_stack_arg =
"-trace-stack",
Arg.Set trace_stack,
"Show the stack after each step" in
register_group "programs" "Commands for managing the record of known programs" ; register_group "programs" "Commands for managing the record of known programs" ;
[ [
command command
@ -201,6 +211,7 @@ let commands () =
command command
~group: "programs" ~group: "programs"
~desc: "ask the node to run a program" ~desc: "ask the node to run a program"
~args: [ trace_stack_arg ]
(prefixes [ "run" ; "program" ] (prefixes [ "run" ; "program" ]
@@ Program.source_param @@ Program.source_param
@@ prefixes [ "on" ; "storage" ] @@ prefixes [ "on" ; "storage" ]
@ -210,18 +221,38 @@ let commands () =
@@ stop) @@ stop)
(fun program storage input () -> (fun program storage input () ->
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.run_code (block ()) program (storage, input) >>= function if !trace_stack then
| Ok (storage, output) -> Client_proto_rpcs.Helpers.trace_code (block ()) program (storage, input) >>= function
Format.printf "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@." | Ok (storage, output, trace) ->
(print_ir (fun l -> false)) storage Format.printf "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
(print_ir (fun l -> false)) output ; (print_ir (fun _ -> false)) storage
Lwt.return () (print_ir (fun _ -> false)) output
| Error errs -> (Format.pp_print_list
pp_print_error Format.err_formatter errs ; (fun ppf (loc, gas, stack) ->
error "error running program") ; Format.fprintf ppf
"- @[<v 0>location: %d (remaining gas: %d)@,[ @[<v 0>%a ]@]@]"
loc gas
(Format.pp_print_list (print_ir (fun _ -> false)))
stack))
trace ;
Lwt.return ()
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "error running program"
else
Client_proto_rpcs.Helpers.run_code (block ()) program (storage, input) >>= function
| Ok (storage, output) ->
Format.printf "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
(print_ir (fun _ -> false)) storage
(print_ir (fun _ -> false)) output ;
Lwt.return ()
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "error running program") ;
command command
~group: "programs" ~group: "programs"
~desc: "ask the node to typecheck a program" ~desc: "ask the node to typecheck a program"
~args: [ show_types_arg ]
(prefixes [ "typecheck" ; "program" ] (prefixes [ "typecheck" ; "program" ]
@@ Program.source_param @@ Program.source_param
@@ stop) @@ stop)
@ -231,20 +262,22 @@ let commands () =
| Ok type_map -> | Ok type_map ->
let type_map, program = unexpand_macros type_map program in let type_map, program = unexpand_macros type_map program in
message "Well typed" ; message "Well typed" ;
print_program if !show_types then begin
(fun l -> List.mem_assoc l type_map) print_program
Format.std_formatter program ; (fun l -> List.mem_assoc l type_map)
Format.printf "@." ; Format.std_formatter program ;
List.iter Format.printf "@." ;
(fun (loc, (before, after)) -> List.iter
Format.printf (fun (loc, (before, after)) ->
"%3d@[<v 0> : [ @[<v 0>%a ]@]@,-> [ @[<v 0>%a ]@]@]@." Format.printf
loc "%3d@[<v 0> : [ @[<v 0>%a ]@]@,-> [ @[<v 0>%a ]@]@]@."
(Format.pp_print_list (print_ir (fun _ -> false))) loc
before (Format.pp_print_list (print_ir (fun _ -> false)))
(Format.pp_print_list (print_ir (fun _ -> false))) before
after) (Format.pp_print_list (print_ir (fun _ -> false)))
type_map ; after)
(List.sort compare type_map)
end ;
Lwt.return () Lwt.return ()
| Error errs -> | Error errs ->
pp_print_error Format.err_formatter errs ; pp_print_error Format.err_formatter errs ;

4
src/client/embedded/bootstrap/client_proto_rpcs.ml
View File

@ -131,6 +131,10 @@ module Helpers = struct
call_error_service1 Services.Helpers.run_code call_error_service1 Services.Helpers.run_code
block (code, storage, input, None, None) block (code, storage, input, None, None)
let trace_code block code (storage, input) =
call_error_service1 Services.Helpers.trace_code
block (code, storage, input, None, None)
let typecheck_tagged_data = call_error_service1 Services.Helpers.typecheck_tagged_data let typecheck_tagged_data = call_error_service1 Services.Helpers.typecheck_tagged_data
let typecheck_untagged_data = call_error_service1 Services.Helpers.typecheck_untagged_data let typecheck_untagged_data = call_error_service1 Services.Helpers.typecheck_untagged_data

4
src/client/embedded/bootstrap/client_proto_rpcs.mli
View File

@ -95,6 +95,10 @@ module Helpers : sig
val run_code: block -> Script.code -> val run_code: block -> Script.code ->
(Script.expr * Script.expr) -> (Script.expr * Script.expr) ->
(Script.expr * Script.expr) tzresult Lwt.t (Script.expr * Script.expr) tzresult Lwt.t
val trace_code: block -> Script.code ->
(Script.expr * Script.expr) ->
(Script.expr * Script.expr *
(Script.location * int * Script.expr list) list) tzresult Lwt.t
val typecheck_code: block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t val typecheck_code: block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t
val typecheck_tagged_data: block -> Script.expr -> unit tzresult Lwt.t val typecheck_tagged_data: block -> Script.expr -> unit tzresult Lwt.t
val typecheck_untagged_data: block -> Script.expr * Script.expr -> unit tzresult Lwt.t val typecheck_untagged_data: block -> Script.expr * Script.expr -> unit tzresult Lwt.t

336
src/proto/bootstrap/script_interpreter.ml
View File

@ -65,229 +65,246 @@ type 'tys stack =
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack | Item : 'ty * 'rest stack -> ('ty * 'rest) stack
| Empty : end_of_stack stack | Empty : end_of_stack stack
let rec unparse_stack
: type a. a stack * a stack_ty -> Script.expr list
= function
| Empty, Empty_t -> []
| Item (v, rest), Item_t (ty, rest_ty) ->
unparse_tagged_data ty v :: unparse_stack (rest, rest_ty)
let rec interp let rec interp
: type p r. : type p r.
?log: (Script.location * int * Script.expr list) list ref ->
int -> Contract.t -> Contract.t -> Tez.t -> int -> Contract.t -> Contract.t -> Tez.t ->
context -> (p, r) lambda -> p -> (r * int * context) tzresult Lwt.t context -> (p, r) lambda -> p -> (r * int * context) tzresult Lwt.t
= fun qta orig source amount ctxt (Lam (code, _)) arg -> = fun ?log qta orig source amount ctxt (Lam (code, _)) arg ->
let rec step let rec step
: type b a. : type b a.
int -> context -> (b, a) instr -> b stack -> int -> context -> (b, a) descr -> b stack ->
(a stack * int * context) tzresult Lwt.t = (a stack * int * context) tzresult Lwt.t =
fun qta ctxt instr stack -> fun qta ctxt ({ instr ; loc } as descr) stack ->
if Compare.Int.(qta <= 0) then if Compare.Int.(qta <= 0) then
fail Quota_exceeded fail Quota_exceeded
else match instr, stack with else
let logged_return ((ret, qta, _) as res) =
match log with
| None -> return res
| Some log ->
log := (descr.loc, qta, unparse_stack (ret, descr.aft)) :: !log ;
return res in
match instr, stack with
(* stack ops *) (* stack ops *)
| Drop, Item (_, rest) -> | Drop, Item (_, rest) ->
return (rest, qta - 1, ctxt) logged_return (rest, qta - 1, ctxt)
| Dup, Item (v, rest) -> | Dup, Item (v, rest) ->
return (Item (v, Item (v, rest)), qta - 1, ctxt) logged_return (Item (v, Item (v, rest)), qta - 1, ctxt)
| Swap, Item (vi, Item (vo, rest)) -> | Swap, Item (vi, Item (vo, rest)) ->
return (Item (vo, Item (vi, rest)), qta - 1, ctxt) logged_return (Item (vo, Item (vi, rest)), qta - 1, ctxt)
| Const v, rest -> | Const v, rest ->
return (Item (v, rest), qta - 1, ctxt) logged_return (Item (v, rest), qta - 1, ctxt)
(* options *) (* options *)
| Cons_some, Item (v, rest) -> | Cons_some, Item (v, rest) ->
return (Item (Some v, rest), qta - 1, ctxt) logged_return (Item (Some v, rest), qta - 1, ctxt)
| Cons_none _, rest -> | Cons_none _, rest ->
return (Item (None, rest), qta - 1, ctxt) logged_return (Item (None, rest), qta - 1, ctxt)
| If_none (bt, _), Item (None, rest) -> | If_none (bt, _), Item (None, rest) ->
step qta ctxt bt rest step qta ctxt bt rest
| If_none (_, bf), Item (Some v, rest) -> | If_none (_, bf), Item (Some v, rest) ->
step qta ctxt bf (Item (v, rest)) step qta ctxt bf (Item (v, rest))
(* pairs *) (* pairs *)
| Cons_pair, Item (a, Item (b, rest)) -> | Cons_pair, Item (a, Item (b, rest)) ->
return (Item ((a, b), rest), qta - 1, ctxt) logged_return (Item ((a, b), rest), qta - 1, ctxt)
| Car, Item ((a, _), rest) -> | Car, Item ((a, _), rest) ->
return (Item (a, rest), qta - 1, ctxt) logged_return (Item (a, rest), qta - 1, ctxt)
| Cdr, Item ((_, b), rest) -> | Cdr, Item ((_, b), rest) ->
return (Item (b, rest), qta - 1, ctxt) logged_return (Item (b, rest), qta - 1, ctxt)
(* unions *) (* unions *)
| Left, Item (v, rest) -> | Left, Item (v, rest) ->
return (Item (L v, rest), qta - 1, ctxt) logged_return (Item (L v, rest), qta - 1, ctxt)
| Right, Item (v, rest) -> | Right, Item (v, rest) ->
return (Item (R v, rest), qta - 1, ctxt) logged_return (Item (R v, rest), qta - 1, ctxt)
| If_left (bt, _), Item (L v, rest) -> | If_left (bt, _), Item (L v, rest) ->
step qta ctxt bt (Item (v, rest)) step qta ctxt bt (Item (v, rest))
| If_left (_, bf), Item (R v, rest) -> | If_left (_, bf), Item (R v, rest) ->
step qta ctxt bf (Item (v, rest)) step qta ctxt bf (Item (v, rest))
(* lists *) (* lists *)
| Cons_list, Item (hd, Item (tl, rest)) -> | Cons_list, Item (hd, Item (tl, rest)) ->
return (Item (hd :: tl, rest), qta - 1, ctxt) logged_return (Item (hd :: tl, rest), qta - 1, ctxt)
| Nil, rest -> | Nil, rest ->
return (Item ([], rest), qta - 1, ctxt) logged_return (Item ([], rest), qta - 1, ctxt)
| If_cons (_, bf), Item ([], rest) -> | If_cons (_, bf), Item ([], rest) ->
step qta ctxt bf rest step qta ctxt bf rest
| If_cons (bt, _), Item (hd :: tl, rest) -> | If_cons (bt, _), Item (hd :: tl, rest) ->
step qta ctxt bt (Item (hd, Item (tl, rest))) step qta ctxt bt (Item (hd, Item (tl, rest)))
| List_map, Item (lam, Item (l, rest)) -> | List_map, Item (lam, Item (l, rest)) ->
fold_left_s (fun (tail, qta, ctxt) arg -> fold_left_s (fun (tail, qta, ctxt) arg ->
interp qta orig source amount ctxt lam arg interp ?log qta orig source amount ctxt lam arg
>>=? fun (ret, qta, ctxt) -> >>=? fun (ret, qta, ctxt) ->
return (ret :: tail, qta, ctxt)) return (ret :: tail, qta, ctxt))
([], qta, ctxt) l >>=? fun (res, qta, ctxt) -> ([], qta, ctxt) l >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta, ctxt) logged_return (Item (res, rest), qta, ctxt)
| List_reduce, Item (lam, Item (l, Item (init, rest))) -> | List_reduce, Item (lam, Item (l, Item (init, rest))) ->
fold_left_s fold_left_s
(fun (partial, qta, ctxt) arg -> (fun (partial, qta, ctxt) arg ->
interp qta orig source amount ctxt lam (arg, partial) interp ?log qta orig source amount ctxt lam (arg, partial)
>>=? fun (partial, qta, ctxt) -> >>=? fun (partial, qta, ctxt) ->
return (partial, qta, ctxt)) return (partial, qta, ctxt))
(init, qta, ctxt) l >>=? fun (res, qta, ctxt) -> (init, qta, ctxt) l >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta, ctxt) logged_return (Item (res, rest), qta, ctxt)
(* sets *) (* sets *)
| Empty_set t, rest -> | Empty_set t, rest ->
return (Item (empty_set t, rest), qta - 1, ctxt) logged_return (Item (empty_set t, rest), qta - 1, ctxt)
| Set_map t, Item (lam, Item (set, rest)) -> | Set_map t, Item (lam, Item (set, rest)) ->
let items = let items =
List.rev (set_fold (fun e acc -> e :: acc) set []) in List.rev (set_fold (fun e acc -> e :: acc) set []) in
fold_left_s fold_left_s
(fun (res, qta, ctxt) arg -> (fun (res, qta, ctxt) arg ->
interp qta orig source amount ctxt lam arg >>=? interp ?log qta orig source amount ctxt lam arg >>=?
fun (ret, qta, ctxt) -> fun (ret, qta, ctxt) ->
return (set_update ret true res, qta, ctxt)) return (set_update ret true res, qta, ctxt))
(empty_set t, qta, ctxt) items >>=? fun (res, qta, ctxt) -> (empty_set t, qta, ctxt) items >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta, ctxt) logged_return (Item (res, rest), qta, ctxt)
| Set_reduce, Item (lam, Item (set, Item (init, rest))) -> | Set_reduce, Item (lam, Item (set, Item (init, rest))) ->
let items = let items =
List.rev (set_fold (fun e acc -> e :: acc) set []) in List.rev (set_fold (fun e acc -> e :: acc) set []) in
fold_left_s fold_left_s
(fun (partial, qta, ctxt) arg -> (fun (partial, qta, ctxt) arg ->
interp qta orig source amount ctxt lam (arg, partial) interp ?log qta orig source amount ctxt lam (arg, partial)
>>=? fun (partial, qta, ctxt) -> >>=? fun (partial, qta, ctxt) ->
return (partial, qta, ctxt)) return (partial, qta, ctxt))
(init, qta, ctxt) items >>=? fun (res, qta, ctxt) -> (init, qta, ctxt) items >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta, ctxt) logged_return (Item (res, rest), qta, ctxt)
| Set_mem, Item (v, Item (set, rest)) -> | Set_mem, Item (v, Item (set, rest)) ->
return (Item (set_mem v set, rest), qta - 1, ctxt) logged_return (Item (set_mem v set, rest), qta - 1, ctxt)
| Set_update, Item (v, Item (presence, Item (set, rest))) -> | Set_update, Item (v, Item (presence, Item (set, rest))) ->
return (Item (set_update v presence set, rest), qta - 1, ctxt) logged_return (Item (set_update v presence set, rest), qta - 1, ctxt)
(* maps *) (* maps *)
| Empty_map (t, _), rest -> | Empty_map (t, _), rest ->
return (Item (empty_map t, rest), qta - 1, ctxt) logged_return (Item (empty_map t, rest), qta - 1, ctxt)
| Map_map, Item (lam, Item (map, rest)) -> | Map_map, Item (lam, Item (map, rest)) ->
let items = let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
fold_left_s fold_left_s
(fun (acc, qta, ctxt) (k, v) -> (fun (acc, qta, ctxt) (k, v) ->
interp qta orig source amount ctxt lam (k, v) interp ?log qta orig source amount ctxt lam (k, v)
>>=? fun (ret, qta, ctxt) -> >>=? fun (ret, qta, ctxt) ->
return (map_update k (Some ret) acc, qta, ctxt)) return (map_update k (Some ret) acc, qta, ctxt))
(empty_map (map_key_ty map), qta, ctxt) items >>=? fun (res, qta, ctxt) -> (empty_map (map_key_ty map), qta, ctxt) items >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta, ctxt) logged_return (Item (res, rest), qta, ctxt)
| Map_reduce, Item (lam, Item (map, Item (init, rest))) -> | Map_reduce, Item (lam, Item (map, Item (init, rest))) ->
let items = let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
fold_left_s fold_left_s
(fun (partial, qta, ctxt) arg -> (fun (partial, qta, ctxt) arg ->
interp qta orig source amount ctxt lam (arg, partial) interp ?log qta orig source amount ctxt lam (arg, partial)
>>=? fun (partial, qta, ctxt) -> >>=? fun (partial, qta, ctxt) ->
return (partial, qta, ctxt)) return (partial, qta, ctxt))
(init, qta, ctxt) items >>=? fun (res, qta, ctxt) -> (init, qta, ctxt) items >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta, ctxt) logged_return (Item (res, rest), qta, ctxt)
| Map_mem, Item (v, Item (map, rest)) -> | Map_mem, Item (v, Item (map, rest)) ->
return (Item (map_mem v map, rest), qta - 1, ctxt) logged_return (Item (map_mem v map, rest), qta - 1, ctxt)
| Map_get, Item (v, Item (map, rest)) -> | Map_get, Item (v, Item (map, rest)) ->
return (Item (map_get v map, rest), qta - 1, ctxt) logged_return (Item (map_get v map, rest), qta - 1, ctxt)
| Map_update, Item (k, Item (v, Item (map, rest))) -> | Map_update, Item (k, Item (v, Item (map, rest))) ->
return (Item (map_update k v map, rest), qta - 1, ctxt) logged_return (Item (map_update k v map, rest), qta - 1, ctxt)
(* timestamp operations *) (* timestamp operations *)
| Add_seconds_to_timestamp (kind, _pos), Item (n, Item (t, rest)) -> | Add_seconds_to_timestamp kind, Item (n, Item (t, rest)) ->
let n = Script_int.to_int64 kind n in let n = Script_int.to_int64 kind n in
Lwt.return Lwt.return
(Period.of_seconds n >>? fun p -> (Period.of_seconds n >>? fun p ->
Timestamp.(t +? p) >>? fun res -> Timestamp.(t +? p) >>? fun res ->
Ok (Item (res, rest), qta - 1, ctxt)) Ok (Item (res, rest), qta - 1, ctxt)) >>=? fun res ->
| Add_timestamp_to_seconds (kind, _pos), Item (t, Item (n, rest)) -> logged_return res
| Add_timestamp_to_seconds kind, Item (t, Item (n, rest)) ->
let n = Script_int.to_int64 kind n in let n = Script_int.to_int64 kind n in
Lwt.return Lwt.return
(Period.of_seconds n >>? fun p -> (Period.of_seconds n >>? fun p ->
Timestamp.(t +? p) >>? fun res -> Timestamp.(t +? p) >>? fun res ->
Ok (Item (res, rest), qta - 1, ctxt)) Ok (Item (res, rest), qta - 1, ctxt)) >>=? fun res ->
logged_return res
(* string operations *) (* string operations *)
| Concat, Item (x, Item (y, rest)) -> | Concat, Item (x, Item (y, rest)) ->
return (Item (x ^ y, rest), qta - 1, ctxt) logged_return (Item (x ^ y, rest), qta - 1, ctxt)
(* currency operations *) (* currency operations *)
| Add_tez, Item (x, Item (y, rest)) -> | Add_tez, Item (x, Item (y, rest)) ->
Lwt.return Tez.(x +? y) >>=? fun res -> Lwt.return Tez.(x +? y) >>=? fun res ->
return (Item (res, rest), qta - 1, ctxt) logged_return (Item (res, rest), qta - 1, ctxt)
| Sub_tez, Item (x, Item (y, rest)) -> | Sub_tez, Item (x, Item (y, rest)) ->
Lwt.return Tez.(x -? y) >>=? fun res -> Lwt.return Tez.(x -? y) >>=? fun res ->
return (Item (res, rest), qta - 1, ctxt) logged_return (Item (res, rest), qta - 1, ctxt)
| Mul_tez kind, Item (x, Item (y, rest)) -> | Mul_tez kind, Item (x, Item (y, rest)) ->
Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res -> Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res ->
return (Item (res, rest), qta - 1, ctxt) logged_return (Item (res, rest), qta - 1, ctxt)
| Mul_tez' kind, Item (y, Item (x, rest)) -> | Mul_tez' kind, Item (y, Item (x, rest)) ->
Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res -> Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res ->
return (Item (res, rest), qta - 1, ctxt) logged_return (Item (res, rest), qta - 1, ctxt)
(* boolean operations *) (* boolean operations *)
| Or, Item (x, Item (y, rest)) -> | Or, Item (x, Item (y, rest)) ->
return (Item (x || y, rest), qta - 1, ctxt) logged_return (Item (x || y, rest), qta - 1, ctxt)
| And, Item (x, Item (y, rest)) -> | And, Item (x, Item (y, rest)) ->
return (Item (x && y, rest), qta - 1, ctxt) logged_return (Item (x && y, rest), qta - 1, ctxt)
| Xor, Item (x, Item (y, rest)) -> | Xor, Item (x, Item (y, rest)) ->
return (Item (not x && y || x && not y, rest), qta - 1, ctxt) logged_return (Item (not x && y || x && not y, rest), qta - 1, ctxt)
| Not, Item (x, rest) -> | Not, Item (x, rest) ->
return (Item (not x, rest), qta - 1, ctxt) logged_return (Item (not x, rest), qta - 1, ctxt)
(* integer operations *) (* integer operations *)
| Checked_abs_int (kind, pos), Item (x, rest) -> | Checked_abs_int kind, Item (x, rest) ->
begin match Script_int.checked_abs kind x with begin match Script_int.checked_abs kind x with
| None -> fail (Overflow pos) | None -> fail (Overflow loc)
| Some res -> return (Item (res, rest), qta - 1, ctxt) | Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
end end
| Checked_neg_int (kind, pos), Item (x, rest) -> | Checked_neg_int kind, Item (x, rest) ->
begin match Script_int.checked_neg kind x with begin match Script_int.checked_neg kind x with
| None -> fail (Overflow pos) | None -> fail (Overflow loc)
| Some res -> return (Item (res, rest), qta - 1, ctxt) | Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
end end
| Checked_add_int (kind, pos), Item (x, Item (y, rest)) -> | Checked_add_int kind, Item (x, Item (y, rest)) ->
begin match Script_int.checked_add kind x y with begin match Script_int.checked_add kind x y with
| None -> fail (Overflow pos) | None -> fail (Overflow loc)
| Some res -> return (Item (res, rest), qta - 1, ctxt) | Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
end end
| Checked_sub_int (kind, pos), Item (x, Item (y, rest)) -> | Checked_sub_int kind, Item (x, Item (y, rest)) ->
begin match Script_int.checked_sub kind x y with begin match Script_int.checked_sub kind x y with
| None -> fail (Overflow pos) | None -> fail (Overflow loc)
| Some res -> return (Item (res, rest), qta - 1, ctxt) | Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
end end
| Checked_mul_int (kind, pos), Item (x, Item (y, rest)) -> | Checked_mul_int kind, Item (x, Item (y, rest)) ->
begin match Script_int.checked_mul kind x y with begin match Script_int.checked_mul kind x y with
| None -> fail (Overflow pos) | None -> fail (Overflow loc)
| Some res -> return (Item (res, rest), qta - 1, ctxt) | Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
end end
| Abs_int kind, Item (x, rest) -> | Abs_int kind, Item (x, rest) ->
return (Item (Script_int.abs kind x, rest), qta - 1, ctxt) logged_return (Item (Script_int.abs kind x, rest), qta - 1, ctxt)
| Neg_int kind, Item (x, rest) -> | Neg_int kind, Item (x, rest) ->
return (Item (Script_int.neg kind x, rest), qta - 1, ctxt) logged_return (Item (Script_int.neg kind x, rest), qta - 1, ctxt)
| Add_int kind, Item (x, Item (y, rest)) -> | Add_int kind, Item (x, Item (y, rest)) ->
return (Item (Script_int.add kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.add kind x y, rest), qta - 1, ctxt)
| Sub_int kind, Item (x, Item (y, rest)) -> | Sub_int kind, Item (x, Item (y, rest)) ->
return (Item (Script_int.sub kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.sub kind x y, rest), qta - 1, ctxt)
| Mul_int kind, Item (x, Item (y, rest)) -> | Mul_int kind, Item (x, Item (y, rest)) ->
return (Item (Script_int.mul kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.mul kind x y, rest), qta - 1, ctxt)
| Div_int (kind, pos), Item (x, Item (y, rest)) -> | Div_int kind, Item (x, Item (y, rest)) ->
if Compare.Int64.(Script_int.to_int64 kind y = 0L) then if Compare.Int64.(Script_int.to_int64 kind y = 0L) then
fail (Division_by_zero pos) fail (Division_by_zero loc)
else else
return (Item (Script_int.div kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.div kind x y, rest), qta - 1, ctxt)
| Mod_int (kind, pos), Item (x, Item (y, rest)) -> | Mod_int kind, Item (x, Item (y, rest)) ->
if Compare.Int64.(Script_int.to_int64 kind y = 0L) then if Compare.Int64.(Script_int.to_int64 kind y = 0L) then
fail (Division_by_zero pos) fail (Division_by_zero loc)
else else
return (Item (Script_int.rem kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.rem kind x y, rest), qta - 1, ctxt)
| Lsl_int kind, Item (x, Item (y, rest)) -> | Lsl_int kind, Item (x, Item (y, rest)) ->
return (Item (Script_int.logsl kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.logsl kind x y, rest), qta - 1, ctxt)
| Lsr_int kind, Item (x, Item (y, rest)) -> | Lsr_int kind, Item (x, Item (y, rest)) ->
return (Item (Script_int.logsr kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.logsr kind x y, rest), qta - 1, ctxt)
| Or_int kind, Item (x, Item (y, rest)) -> | Or_int kind, Item (x, Item (y, rest)) ->
return (Item (Script_int.logor kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.logor kind x y, rest), qta - 1, ctxt)
| And_int kind, Item (x, Item (y, rest)) -> | And_int kind, Item (x, Item (y, rest)) ->
return (Item (Script_int.logand kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.logand kind x y, rest), qta - 1, ctxt)
| Xor_int kind, Item (x, Item (y, rest)) -> | Xor_int kind, Item (x, Item (y, rest)) ->
return (Item (Script_int.logxor kind x y, rest), qta - 1, ctxt) logged_return (Item (Script_int.logxor kind x y, rest), qta - 1, ctxt)
| Not_int kind, Item (x, rest) -> | Not_int kind, Item (x, rest) ->
return (Item (Script_int.lognot kind x, rest), qta - 1, ctxt) logged_return (Item (Script_int.lognot kind x, rest), qta - 1, ctxt)
(* control *) (* control *)
| Seq (hd, tl), stack -> | Seq (hd, tl), stack ->
step qta ctxt hd stack >>=? fun (trans, qta, ctxt) -> step qta ctxt hd stack >>=? fun (trans, qta, ctxt) ->
@ -298,83 +315,83 @@ let rec interp
step qta ctxt bf rest step qta ctxt bf rest
| Loop body, Item (true, rest) -> | Loop body, Item (true, rest) ->
step qta ctxt body rest >>=? fun (trans, qta, ctxt) -> step qta ctxt body rest >>=? fun (trans, qta, ctxt) ->
step (qta - 1) ctxt (Loop body) trans step (qta - 1) ctxt descr trans
| Loop _, Item (false, rest) -> | Loop _, Item (false, rest) ->
return (rest, qta, ctxt) logged_return (rest, qta, ctxt)
| Dip b, Item (ign, rest) -> | Dip b, Item (ign, rest) ->
step qta ctxt b rest >>=? fun (res, qta, ctxt) -> step qta ctxt b rest >>=? fun (res, qta, ctxt) ->
return (Item (ign, res), qta, ctxt) logged_return (Item (ign, res), qta, ctxt)
| Exec, Item (arg, Item (lam, rest)) -> | Exec, Item (arg, Item (lam, rest)) ->
interp qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt) -> interp ?log qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta - 1, ctxt) logged_return (Item (res, rest), qta - 1, ctxt)
| Lambda lam, rest -> | Lambda lam, rest ->
return (Item (lam, rest), qta - 1, ctxt) logged_return (Item (lam, rest), qta - 1, ctxt)
| Fail pos, _ -> | Fail, _ ->
fail (Reject pos) fail (Reject loc)
| Nop, stack -> | Nop, stack ->
return (stack, qta - 1, ctxt) logged_return (stack, qta - 1, ctxt)
(* comparison *) (* comparison *)
| Compare Bool_key, Item (a, Item (b, rest)) -> | Compare Bool_key, Item (a, Item (b, rest)) ->
let cmpres = Compare.Bool.compare a b in let cmpres = Compare.Bool.compare a b in
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Compare String_key, Item (a, Item (b, rest)) -> | Compare String_key, Item (a, Item (b, rest)) ->
let cmpres = Compare.String.compare a b in let cmpres = Compare.String.compare a b in
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Compare Tez_key, Item (a, Item (b, rest)) -> | Compare Tez_key, Item (a, Item (b, rest)) ->
let cmpres = Tez.compare a b in let cmpres = Tez.compare a b in
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Compare (Int_key kind), Item (a, Item (b, rest)) -> | Compare (Int_key kind), Item (a, Item (b, rest)) ->
let cmpres = Script_int.compare kind a b in let cmpres = Script_int.compare kind a b in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Compare Key_key, Item (a, Item (b, rest)) -> | Compare Key_key, Item (a, Item (b, rest)) ->
let cmpres = Ed25519.Public_key_hash.compare a b in let cmpres = Ed25519.Public_key_hash.compare a b in
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Compare Timestamp_key, Item (a, Item (b, rest)) -> | Compare Timestamp_key, Item (a, Item (b, rest)) ->
let cmpres = Timestamp.compare a b in let cmpres = Timestamp.compare a b in
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
(* comparators *) (* comparators *)
| Eq, Item (cmpres, rest) -> | Eq, Item (cmpres, rest) ->
let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Script_int.to_int64 Int64 cmpres in
let cmpres = Compare.Int64.(cmpres = 0L) in let cmpres = Compare.Int64.(cmpres = 0L) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Neq, Item (cmpres, rest) -> | Neq, Item (cmpres, rest) ->
let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Script_int.to_int64 Int64 cmpres in
let cmpres = Compare.Int64.(cmpres <> 0L) in let cmpres = Compare.Int64.(cmpres <> 0L) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Lt, Item (cmpres, rest) -> | Lt, Item (cmpres, rest) ->
let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Script_int.to_int64 Int64 cmpres in
let cmpres = Compare.Int64.(cmpres < 0L) in let cmpres = Compare.Int64.(cmpres < 0L) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Gt, Item (cmpres, rest) -> | Gt, Item (cmpres, rest) ->
let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Script_int.to_int64 Int64 cmpres in
let cmpres = Compare.Int64.(cmpres > 0L) in let cmpres = Compare.Int64.(cmpres > 0L) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Le, Item (cmpres, rest) -> | Le, Item (cmpres, rest) ->
let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Script_int.to_int64 Int64 cmpres in
let cmpres = Compare.Int64.(cmpres <= 0L) in let cmpres = Compare.Int64.(cmpres <= 0L) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
| Ge, Item (cmpres, rest) -> | Ge, Item (cmpres, rest) ->
let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Script_int.to_int64 Int64 cmpres in
let cmpres = Compare.Int64.(cmpres >= 0L) in let cmpres = Compare.Int64.(cmpres >= 0L) in
return (Item (cmpres, rest), qta - 1, ctxt) logged_return (Item (cmpres, rest), qta - 1, ctxt)
(* casts *) (* casts *)
| Checked_int_of_int (_, kt, pos), Item (v, rest) -> | Checked_int_of_int (_, kt), Item (v, rest) ->
begin match Script_int.checked_cast kt v with begin match Script_int.checked_cast kt v with
| None -> fail (Overflow pos) | None -> fail (Overflow loc)
| Some res -> return (Item (res, rest), qta - 1, ctxt) | Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
end end
| Int_of_int (_, kt), Item (v, rest) -> | Int_of_int (_, kt), Item (v, rest) ->
return (Item (Script_int.cast kt v, rest), qta - 1, ctxt) logged_return (Item (Script_int.cast kt v, rest), qta - 1, ctxt)
(* protocol *) (* protocol *)
| Manager, Item ((_, _, contract), rest) -> | Manager, Item ((_, _, contract), rest) ->
Contract.get_manager ctxt contract >>=? fun manager -> Contract.get_manager ctxt contract >>=? fun manager ->
return (Item (manager, rest), qta - 1, ctxt) logged_return (Item (manager, rest), qta - 1, ctxt)
| Transfer_tokens (storage_type, loc), | Transfer_tokens storage_type,
Item (p, Item (amount, Item ((tp, Void_t, destination), Item (sto, Empty)))) -> begin Item (p, Item (amount, Item ((tp, Void_t, destination), Item (sto, Empty)))) -> begin
Contract.unconditional_spend ctxt source amount >>=? fun ctxt -> Contract.unconditional_spend ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt ->
@ -402,39 +419,39 @@ let rec interp
| No_script -> assert false | No_script -> assert false
| Script { storage = { storage } } -> | Script { storage = { storage } } ->
parse_untagged_data ctxt storage_type storage >>=? fun sto -> parse_untagged_data ctxt storage_type storage >>=? fun sto ->
return (Item ((), Item (sto, Empty)), qta - 1, ctxt)) logged_return (Item ((), Item (sto, Empty)), qta - 1, ctxt))
end end
| Transfer_tokens (storage_type, loc), | 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
Contract.unconditional_spend ctxt source amount >>=? fun ctxt -> Contract.unconditional_spend ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? function Contract.get_script ctxt destination >>=? function
| No_script -> fail (Invalid_contract (loc, destination)) | No_script -> fail (Invalid_contract (loc, destination))
| Script { code ; storage } -> | Script { code ; storage } ->
let sto = unparse_untagged_data storage_type sto in let sto = unparse_untagged_data storage_type sto in
Contract.update_script_storage ctxt source sto >>=? fun ctxt -> Contract.update_script_storage ctxt source sto >>=? fun ctxt ->
let p = unparse_untagged_data tp p in let p = unparse_untagged_data tp p in
execute source destination ctxt storage code amount p qta execute source destination ctxt storage code amount p qta
>>=? fun (sto, ret, qta, ctxt) -> >>=? fun (sto, ret, qta, ctxt) ->
Contract.update_script_storage Contract.update_script_storage
ctxt destination sto >>=? fun ctxt -> ctxt destination sto >>=? fun ctxt ->
trace trace
(Invalid_contract (loc, destination)) (Invalid_contract (loc, destination))
(parse_untagged_data ctxt tr ret) >>=? fun v -> (parse_untagged_data ctxt tr ret) >>=? fun v ->
Contract.get_script ctxt source >>=? (function Contract.get_script ctxt source >>=? (function
| No_script -> assert false | No_script -> assert false
| Script { storage = { storage } } -> | Script { storage = { storage } } ->
parse_untagged_data ctxt storage_type storage >>=? fun sto -> parse_untagged_data ctxt storage_type storage >>=? fun sto ->
return (Item (v, Item (sto, Empty)), qta - 1, ctxt)) logged_return (Item (v, Item (sto, Empty)), qta - 1, ctxt))
end end
| Create_account, | Create_account,
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
Contract.unconditional_spend ctxt source credit >>=? fun ctxt -> Contract.unconditional_spend ctxt source credit >>=? fun ctxt ->
Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance ->
Contract.originate ctxt Contract.originate ctxt
~manager ~delegate ~balance ~manager ~delegate ~balance
~script:No_script ~spendable:true ~delegatable >>=? fun (ctxt, contract) -> ~script:No_script ~spendable:true ~delegatable >>=? fun (ctxt, contract) ->
return (Item ((Void_t, Void_t, contract), rest), qta - 1, ctxt) logged_return (Item ((Void_t, Void_t, contract), rest), qta - 1, ctxt)
| Create_contract (g, p, r), | Create_contract (g, p, r),
Item (manager, Item (delegate, Item (delegatable, Item (credit, Item (manager, Item (delegate, Item (delegatable, Item (credit,
Item (Lam (_, code), Item (init, rest)))))) -> Item (Lam (_, code), Item (init, rest)))))) ->
@ -454,35 +471,43 @@ let rec interp
~manager ~delegate ~balance ~manager ~delegate ~balance
~script:(Script { code ; storage }) ~spendable:true ~delegatable ~script:(Script { code ; storage }) ~spendable:true ~delegatable
>>=? fun (ctxt, contract) -> >>=? fun (ctxt, contract) ->
return (Item ((p, r, contract), rest), qta - 1, ctxt) logged_return (Item ((p, r, contract), rest), qta - 1, ctxt)
| Balance, rest -> | Balance, rest ->
Contract.get_balance ctxt source >>=? fun balance -> Contract.get_balance ctxt source >>=? fun balance ->
return (Item (balance, rest), qta - 1, ctxt) logged_return (Item (balance, rest), qta - 1, ctxt)
| Now, rest -> | Now, rest ->
Timestamp.get_current ctxt >>=? fun now -> Timestamp.get_current ctxt >>=? fun now ->
return (Item (now, rest), qta - 1, ctxt) logged_return (Item (now, rest), qta - 1, ctxt)
| Check_signature, Item (key, Item ((signature, message), rest)) -> | Check_signature, Item (key, Item ((signature, message), rest)) ->
Public_key.get ctxt key >>=? fun key -> Public_key.get ctxt key >>=? fun key ->
let message = MBytes.of_string message in let message = MBytes.of_string message in
let res = Ed25519.check_signature key signature message in let res = Ed25519.check_signature key signature message in
return (Item (res, rest), qta - 1, ctxt) logged_return (Item (res, rest), qta - 1, ctxt)
| H ty, Item (v, rest) -> | H ty, Item (v, rest) ->
let hash = Script.hash_expr (unparse_untagged_data ty v) in let hash = Script.hash_expr (unparse_untagged_data ty v) in
return (Item (hash, rest), qta - 1, ctxt) logged_return (Item (hash, rest), qta - 1, ctxt)
| Steps_to_quota, rest -> | Steps_to_quota, rest ->
let steps = Script_int.of_int64 Uint32 (Int64.of_int qta) in let steps = Script_int.of_int64 Uint32 (Int64.of_int qta) in
return (Item (steps, rest), qta - 1, ctxt) logged_return (Item (steps, rest), qta - 1, ctxt)
| Source (ta, tb), rest -> | Source (ta, tb), rest ->
return (Item ((ta, tb, orig), rest), qta - 1, ctxt) logged_return (Item ((ta, tb, orig), rest), qta - 1, ctxt)
| Amount, rest -> | Amount, rest ->
return (Item (amount, rest), qta - 1, ctxt) logged_return (Item (amount, rest), qta - 1, ctxt)
in in
step qta ctxt code (Item (arg, Empty)) >>=? fun (Item (ret, Empty), qta, ctxt) -> let stack = (Item (arg, Empty)) in
begin match log with
| None -> ()
| Some log ->
log := (code.loc, qta, unparse_stack (stack, code.bef)) :: !log
end ;
step qta ctxt code stack >>=? fun (Item (ret, Empty), qta, ctxt) ->
return (ret, qta, ctxt) return (ret, qta, ctxt)
(* ---- contract handling ---------------------------------------------------*) (* ---- contract handling ---------------------------------------------------*)
and execute orig source ctxt { storage; storage_type } { code; arg_type; ret_type } amount arg qta = and execute ?log orig source ctxt storage script amount arg qta =
let { Script.storage ; storage_type } = storage in
let { Script.code ; arg_type ; ret_type } = script in
parse_ty arg_type >>=? fun (Ex arg_type) -> parse_ty arg_type >>=? fun (Ex arg_type) ->
parse_ty ret_type >>=? fun (Ex ret_type) -> parse_ty ret_type >>=? fun (Ex ret_type) ->
parse_ty storage_type >>=? fun (Ex storage_type) -> parse_ty storage_type >>=? fun (Ex storage_type) ->
@ -491,8 +516,17 @@ and execute orig source ctxt { storage; storage_type } { code; arg_type; ret_typ
parse_lambda ctxt arg_type_full ret_type_full code >>=? fun lambda -> parse_lambda ctxt arg_type_full ret_type_full code >>=? fun lambda ->
parse_untagged_data ctxt arg_type arg >>=? fun arg -> parse_untagged_data ctxt arg_type arg >>=? fun arg ->
parse_untagged_data ctxt storage_type storage >>=? fun storage -> parse_untagged_data ctxt storage_type storage >>=? fun storage ->
interp qta orig source amount ctxt lambda ((amount, arg), storage) >>=? fun (ret, qta, ctxt) -> interp ?log qta orig source amount ctxt lambda ((amount, arg), storage)
let ret, storage = ret in >>=? fun (ret, qta, ctxt) ->
return (unparse_untagged_data storage_type storage, let ret, storage = ret in
unparse_untagged_data ret_type ret, return (unparse_untagged_data storage_type storage,
qta, ctxt) unparse_untagged_data ret_type ret,
qta, ctxt)
let trace orig source ctxt storage script amount arg qta =
let log = ref [] in
execute ~log orig source ctxt storage script amount arg qta >>=? fun res ->
return (res, List.rev !log)
let execute orig source ctxt storage script amount arg qta =
execute orig source ctxt storage script amount arg qta

6
src/proto/bootstrap/script_interpreter.mli
View File

@ -21,3 +21,9 @@ val execute: Contract.t -> Contract.t -> Tezos_context.t ->
Script.storage -> Script.code -> Tez.t -> Script.storage -> Script.code -> Tez.t ->
Script.expr -> int -> Script.expr -> int ->
(Script.expr * Script.expr * int * context) tzresult Lwt.t (Script.expr * Script.expr * int * context) tzresult Lwt.t
val trace: Contract.t -> Contract.t -> Tezos_context.t ->
Script.storage -> Script.code -> Tez.t ->
Script.expr -> int ->
((Script.expr * Script.expr * int * context) *
(Script.location * int * Script.expr list) list) tzresult Lwt.t

1305
src/proto/bootstrap/script_ir_translator.ml
View File

File diff suppressed because it is too large Load Diff

50
src/proto/bootstrap/script_typed_ir.ml
View File

@ -53,7 +53,7 @@ and ('a, 'b) union = L of 'a | R of 'b
and end_of_stack = unit and end_of_stack = unit
and ('arg, 'ret) lambda = and ('arg, 'ret) lambda =
Lam of ('arg * end_of_stack, 'ret * end_of_stack) instr * Script.expr Lam of ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.expr
and ('arg, 'ret) typed_contract = and ('arg, 'ret) typed_contract =
'arg ty * 'ret ty * Contract.t 'arg ty * 'ret ty * Contract.t
@ -76,6 +76,10 @@ and 'ty ty =
| Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map ty | Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map ty
| Contract_t : 'arg ty * 'ret ty -> ('arg, 'ret) typed_contract ty | Contract_t : 'arg ty * 'ret ty -> ('arg, 'ret) typed_contract ty
and 'ty stack_ty =
| Item_t : 'ty ty * 'rest stack_ty -> ('ty * 'rest) stack_ty
| Empty_t : end_of_stack stack_ty
(* ---- Instructions --------------------------------------------------------*) (* ---- Instructions --------------------------------------------------------*)
(* The low-level, typed instructions, as a GADT whose parameters (* The low-level, typed instructions, as a GADT whose parameters
@ -107,21 +111,21 @@ and ('bef, 'aft) instr =
('v * 'rest, 'v option * 'rest) instr ('v * 'rest, 'v option * 'rest) instr
| Cons_none : 'a ty -> | Cons_none : 'a ty ->
('rest, 'a option * 'rest) instr ('rest, 'a option * 'rest) instr
| If_none : ('bef, 'aft) instr * ('a * 'bef, 'aft) instr -> | If_none : ('bef, 'aft) descr * ('a * 'bef, 'aft) descr ->
('a option * 'bef, 'aft) instr ('a option * 'bef, 'aft) instr
(* unions *) (* unions *)
| Left : | Left :
('l * 'rest, (('l, 'r) union * 'rest)) instr ('l * 'rest, (('l, 'r) union * 'rest)) instr
| Right : | Right :
('r * 'rest, (('l, 'r) union * 'rest)) instr ('r * 'rest, (('l, 'r) union * 'rest)) instr
| If_left : ('l * 'bef, 'aft) instr * ('r * 'bef, 'aft) instr -> | If_left : ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr ->
(('l, 'r) union * 'bef, 'aft) instr (('l, 'r) union * 'bef, 'aft) instr
(* lists *) (* lists *)
| Cons_list : | Cons_list :
('a * ('a list * 'rest), ('a list * 'rest)) instr ('a * ('a list * 'rest), ('a list * 'rest)) instr
| Nil : | Nil :
('rest, ('a list * 'rest)) instr ('rest, ('a list * 'rest)) instr
| If_cons : ('a * ('a list * 'bef), 'aft) instr * ('bef, 'aft) instr -> | If_cons : ('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr ->
('a list * 'bef, 'aft) instr ('a list * 'bef, 'aft) instr
| List_map : | List_map :
(('param, 'ret) lambda * ('param list * 'rest), 'ret list * 'rest) instr (('param, 'ret) lambda * ('param list * 'rest), 'ret list * 'rest) instr
@ -158,9 +162,9 @@ and ('bef, 'aft) instr =
| Concat : | Concat :
(string * (string * 'rest), string * 'rest) instr (string * (string * 'rest), string * 'rest) instr
(* timestamp operations *) (* timestamp operations *)
| Add_seconds_to_timestamp : (unsigned, 'l) int_kind * Script.location -> | Add_seconds_to_timestamp : (unsigned, 'l) int_kind ->
((unsigned, 'l) int_val * (Timestamp.t * 'rest), Timestamp.t * 'rest) instr ((unsigned, 'l) int_val * (Timestamp.t * 'rest), Timestamp.t * 'rest) instr
| Add_timestamp_to_seconds : (unsigned, 'l) int_kind * Script.location -> | Add_timestamp_to_seconds : (unsigned, 'l) int_kind ->
(Timestamp.t * ((unsigned, 'l) int_val * 'rest), Timestamp.t * 'rest) instr (Timestamp.t * ((unsigned, 'l) int_val * 'rest), Timestamp.t * 'rest) instr
(* currency operations *) (* currency operations *)
| Add_tez : | Add_tez :
@ -181,15 +185,15 @@ and ('bef, 'aft) instr =
| Not : | Not :
(bool * 'rest, bool * 'rest) instr (bool * 'rest, bool * 'rest) instr
(* integer operations *) (* integer operations *)
| Checked_neg_int : (signed, 'l) int_kind * Script.location -> | Checked_neg_int : (signed, 'l) int_kind ->
((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr
| Checked_abs_int : (signed, 'l) int_kind * Script.location -> | Checked_abs_int : (signed, 'l) int_kind ->
((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr
| Checked_add_int : ('s, 'l) int_kind * Script.location -> | Checked_add_int : ('s, 'l) int_kind ->
(('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr
| Checked_sub_int : ('s, 'l) int_kind * Script.location -> | Checked_sub_int : ('s, 'l) int_kind ->
(('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr
| Checked_mul_int : ('s, 'l) int_kind * Script.location -> | Checked_mul_int : ('s, 'l) int_kind ->
(('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr
| Neg_int : (signed, 'l) int_kind -> | Neg_int : (signed, 'l) int_kind ->
((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr
@ -201,9 +205,9 @@ and ('bef, 'aft) instr =
(('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr
| Mul_int : ('s, 'l) int_kind -> | Mul_int : ('s, 'l) int_kind ->
(('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr
| Div_int : ('s, 'l) int_kind * Script.location -> | Div_int : ('s, 'l) int_kind ->
(('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr
| Mod_int : ('s, 'l) int_kind * Script.location -> | Mod_int : ('s, 'l) int_kind ->
(('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr
| Lsl_int : (unsigned, 'l) int_kind -> | Lsl_int : (unsigned, 'l) int_kind ->
((unsigned, 'l) int_val * ((unsigned, eight) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr ((unsigned, 'l) int_val * ((unsigned, eight) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr
@ -218,19 +222,19 @@ and ('bef, 'aft) instr =
| Not_int : (unsigned, 'l) int_kind -> | Not_int : (unsigned, 'l) int_kind ->
((unsigned, 'l) int_val * 'rest, (unsigned, 'l) int_val * 'rest) instr ((unsigned, 'l) int_val * 'rest, (unsigned, 'l) int_val * 'rest) instr
(* control *) (* control *)
| Seq : ('bef, 'trans) instr * ('trans, 'aft) instr -> | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr ->
('bef, 'aft) instr ('bef, 'aft) instr
| If : ('bef, 'aft) instr * ('bef, 'aft) instr -> | If : ('bef, 'aft) descr * ('bef, 'aft) descr ->
(bool * 'bef, 'aft) instr (bool * 'bef, 'aft) instr
| Loop : ('rest, bool * 'rest) instr -> | Loop : ('rest, bool * 'rest) descr ->
(bool * 'rest, 'rest) instr (bool * 'rest, 'rest) instr
| Dip : ('bef, 'aft) instr -> | Dip : ('bef, 'aft) descr ->
('top * 'bef, 'top * 'aft) instr ('top * 'bef, 'top * 'aft) instr
| Exec : | Exec :
('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr
| Lambda : ('arg, 'ret) lambda -> | Lambda : ('arg, 'ret) lambda ->
('rest, ('arg, 'ret) lambda * 'rest) instr ('rest, ('arg, 'ret) lambda * 'rest) instr
| Fail : Script.location -> | Fail :
('bef, 'aft) instr ('bef, 'aft) instr
| Nop : | Nop :
('rest, 'rest) instr ('rest, 'rest) instr
@ -253,12 +257,12 @@ and ('bef, 'aft) instr =
(* casts *) (* casts *)
| Int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind -> | Int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind ->
(('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr (('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr
| Checked_int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind * Script.location -> | Checked_int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind ->
(('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr (('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr
(* protocol *) (* protocol *)
| Manager : | Manager :
(('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr (('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr
| Transfer_tokens : 'sto ty * Script.location -> | Transfer_tokens : 'sto ty ->
('arg * (Tez.t * (('arg, 'ret) typed_contract * ('sto * end_of_stack))), 'ret * ('sto * end_of_stack)) instr ('arg * (Tez.t * (('arg, 'ret) typed_contract * ('sto * end_of_stack))), 'ret * ('sto * end_of_stack)) instr
| Create_account : | Create_account :
(public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), (public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))),
@ -281,3 +285,9 @@ and ('bef, 'aft) instr =
('rest, ('p, 'r) typed_contract * 'rest) instr ('rest, ('p, 'r) typed_contract * 'rest) instr
| Amount : | Amount :
('rest, Tez.t * 'rest) instr ('rest, Tez.t * 'rest) instr
and ('bef, 'aft) descr =
{ loc : Script.location ;
bef : 'bef stack_ty ;
aft : 'aft stack_ty ;
instr : ('bef, 'aft) instr }

31
src/proto/bootstrap/services.ml
View File

@ -327,21 +327,40 @@ module Helpers = struct
obj1 (req "timestamp" Timestamp.encoding)) obj1 (req "timestamp" Timestamp.encoding))
RPC.Path.(custom_root / "helpers" / "minimal_timestamp") RPC.Path.(custom_root / "helpers" / "minimal_timestamp")
let run_code_input_encoding =
(obj5
(req "script" Script.code_encoding)
(req "storage" Script.expr_encoding)
(req "input" Script.expr_encoding)
(opt "amount" Tez.encoding)
(opt "contract" Contract.encoding))
let run_code custom_root = let run_code custom_root =
RPC.service RPC.service
~description: "Run a piece of code in the current context" ~description: "Run a piece of code in the current context"
~input: (obj5 ~input: run_code_input_encoding
(req "script" Script.code_encoding)
(req "storage" Script.expr_encoding)
(req "input" Script.expr_encoding)
(opt "amount" Tez.encoding)
(opt "contract" Contract.encoding))
~output: (wrap_tzerror ~output: (wrap_tzerror
(obj2 (obj2
(req "storage" Script.expr_encoding) (req "storage" Script.expr_encoding)
(req "output" Script.expr_encoding))) (req "output" Script.expr_encoding)))
RPC.Path.(custom_root / "helpers" / "run_code") RPC.Path.(custom_root / "helpers" / "run_code")
let trace_code custom_root =
RPC.service
~description: "Run a piece of code in the current context, \
keeping a trace"
~input: run_code_input_encoding
~output: (wrap_tzerror
(obj3
(req "storage" Script.expr_encoding)
(req "output" Script.expr_encoding)
(req "trace"
(list @@ obj3
(req "location" Script.location_encoding)
(req "gas" int31)
(req "stack" (list (Script.expr_encoding)))))))
RPC.Path.(custom_root / "helpers" / "trace_code")
let typecheck_code custom_root = let typecheck_code custom_root =
RPC.service RPC.service
~description: "Typecheck a piece of code in the current context" ~description: "Typecheck a piece of code in the current context"

52
src/proto/bootstrap/services_registration.ml
View File

@ -180,31 +180,45 @@ let minimal_timestamp ctxt prio =
let () = register1 Services.Helpers.minimal_timestamp minimal_timestamp let () = register1 Services.Helpers.minimal_timestamp minimal_timestamp
let () = let () =
let run_parameters ctxt (script, storage, input, amount, contract) =
let amount =
match amount with
| Some amount -> amount
| None ->
match Tez.of_cents 100_00L with
| Some tez -> tez
| None -> Tez.zero in
let contract =
match contract with
| Some contract -> contract
| None ->
Contract.default_contract
(List.hd Bootstrap.accounts).Bootstrap.public_key_hash in
let storage : Script.storage =
{ storage ; storage_type = (script : Script.code).storage_type } in
let qta =
Constants.instructions_per_transaction ctxt in
(script, storage, input, amount, contract, qta) in
register1 Services.Helpers.run_code register1 Services.Helpers.run_code
(fun ctxt (script, storage, input, amount, contract) -> (fun ctxt parameters ->
let amount = let (script, storage, input, amount, contract, qta) =
match amount with run_parameters ctxt parameters in
| Some amount -> amount
| None ->
match Tez.of_cents 100_00L with
| Some tez -> tez
| None -> Tez.zero in
let contract =
match contract with
| Some contract -> contract
| None ->
Contract.default_contract
(List.hd Bootstrap.accounts).Bootstrap.public_key_hash in
let storage =
{ Script.storage ; storage_type = script.storage_type } in
let qta =
Constants.instructions_per_transaction ctxt in
Script_interpreter.execute Script_interpreter.execute
contract (* transaction initiator *) contract (* transaction initiator *)
contract (* script owner *) contract (* script owner *)
ctxt storage script amount input ctxt storage script amount input
qta >>=? fun (sto, ret, _qta, _ctxt) -> qta >>=? fun (sto, ret, _qta, _ctxt) ->
Error_monad.return (sto, ret)) Error_monad.return (sto, ret)) ;
register1 Services.Helpers.trace_code
(fun ctxt parameters ->
let (script, storage, input, amount, contract, qta) =
run_parameters ctxt parameters in
Script_interpreter.trace
contract (* transaction initiator *)
contract (* script owner *)
ctxt storage script amount input
qta >>=? fun ((sto, ret, _qta, _ctxt), trace) ->
Error_monad.return (sto, ret, trace))
let () = let () =
register1 Services.Helpers.typecheck_code register1 Services.Helpers.typecheck_code