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 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" ;
[
command
@ -201,6 +211,7 @@ let commands () =
command
~group: "programs"
~desc: "ask the node to run a program"
~args: [ trace_stack_arg ]
(prefixes [ "run" ; "program" ]
@@ Program.source_param
@@ prefixes [ "on" ; "storage" ]
@ -210,18 +221,38 @@ let commands () =
@@ stop)
(fun program storage input () ->
let open Data_encoding in
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 l -> false)) storage
(print_ir (fun l -> false)) output ;
Lwt.return ()
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "error running program") ;
if !trace_stack then
Client_proto_rpcs.Helpers.trace_code (block ()) program (storage, input) >>= function
| Ok (storage, output, trace) ->
Format.printf "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
(print_ir (fun _ -> false)) storage
(print_ir (fun _ -> false)) output
(Format.pp_print_list
(fun ppf (loc, gas, stack) ->
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
~group: "programs"
~desc: "ask the node to typecheck a program"
~args: [ show_types_arg ]
(prefixes [ "typecheck" ; "program" ]
@@ Program.source_param
@@ stop)
@ -231,20 +262,22 @@ let commands () =
| Ok type_map ->
let type_map, program = unexpand_macros type_map program in
message "Well typed" ;
print_program
(fun l -> List.mem_assoc l type_map)
Format.std_formatter program ;
Format.printf "@." ;
List.iter
(fun (loc, (before, after)) ->
Format.printf
"%3d@[<v 0> : [ @[<v 0>%a ]@]@,-> [ @[<v 0>%a ]@]@]@."
loc
(Format.pp_print_list (print_ir (fun _ -> false)))
before
(Format.pp_print_list (print_ir (fun _ -> false)))
after)
type_map ;
if !show_types then begin
print_program
(fun l -> List.mem_assoc l type_map)
Format.std_formatter program ;
Format.printf "@." ;
List.iter
(fun (loc, (before, after)) ->
Format.printf
"%3d@[<v 0> : [ @[<v 0>%a ]@]@,-> [ @[<v 0>%a ]@]@]@."
loc
(Format.pp_print_list (print_ir (fun _ -> false)))
before
(Format.pp_print_list (print_ir (fun _ -> false)))
after)
(List.sort compare type_map)
end ;
Lwt.return ()
| Error 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
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_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 ->
(Script.expr * Script.expr) ->
(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_tagged_data: block -> 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
| 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
: type p r.
?log: (Script.location * int * Script.expr list) list ref ->
int -> Contract.t -> Contract.t -> Tez.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
: type b a.
int -> context -> (b, a) instr -> b stack ->
int -> context -> (b, a) descr -> b stack ->
(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
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 *)
| Drop, Item (_, rest) ->
return (rest, qta - 1, ctxt)
logged_return (rest, qta - 1, ctxt)
| 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)) ->
return (Item (vo, Item (vi, rest)), qta - 1, ctxt)
logged_return (Item (vo, Item (vi, rest)), qta - 1, ctxt)
| Const v, rest ->
return (Item (v, rest), qta - 1, ctxt)
logged_return (Item (v, rest), qta - 1, ctxt)
(* options *)
| 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 ->
return (Item (None, rest), qta - 1, ctxt)
logged_return (Item (None, rest), qta - 1, ctxt)
| If_none (bt, _), Item (None, rest) ->
step qta ctxt bt rest
| If_none (_, bf), Item (Some v, rest) ->
step qta ctxt bf (Item (v, rest))
(* pairs *)
| 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) ->
return (Item (a, rest), qta - 1, ctxt)
logged_return (Item (a, rest), qta - 1, ctxt)
| Cdr, Item ((_, b), rest) ->
return (Item (b, rest), qta - 1, ctxt)
logged_return (Item (b, rest), qta - 1, ctxt)
(* unions *)
| 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) ->
return (Item (R v, rest), qta - 1, ctxt)
logged_return (Item (R v, rest), qta - 1, ctxt)
| If_left (bt, _), Item (L v, rest) ->
step qta ctxt bt (Item (v, rest))
| If_left (_, bf), Item (R v, rest) ->
step qta ctxt bf (Item (v, rest))
(* lists *)
| 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 ->
return (Item ([], rest), qta - 1, ctxt)
logged_return (Item ([], rest), qta - 1, ctxt)
| If_cons (_, bf), Item ([], rest) ->
step qta ctxt bf rest
| If_cons (bt, _), Item (hd :: tl, rest) ->
step qta ctxt bt (Item (hd, Item (tl, rest)))
| List_map, Item (lam, Item (l, rest)) ->
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) ->
return (ret :: tail, 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))) ->
fold_left_s
(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) ->
return (partial, qta, ctxt))
(init, qta, ctxt) l >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta, ctxt)
logged_return (Item (res, rest), qta, ctxt)
(* sets *)
| 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)) ->
let items =
List.rev (set_fold (fun e acc -> e :: acc) set []) in
fold_left_s
(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) ->
return (set_update ret true 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))) ->
let items =
List.rev (set_fold (fun e acc -> e :: acc) set []) in
fold_left_s
(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) ->
return (partial, 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)) ->
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))) ->
return (Item (set_update v presence set, rest), qta - 1, ctxt)
logged_return (Item (set_update v presence set, rest), qta - 1, ctxt)
(* maps *)
| 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)) ->
let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
fold_left_s
(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) ->
return (map_update k (Some ret) acc, 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))) ->
let items =
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
fold_left_s
(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) ->
return (partial, 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)) ->
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)) ->
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))) ->
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 *)
| 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
Lwt.return
(Period.of_seconds n >>? fun p ->
Timestamp.(t +? p) >>? fun res ->
Ok (Item (res, rest), qta - 1, ctxt))
| Add_timestamp_to_seconds (kind, _pos), Item (t, Item (n, rest)) ->
Ok (Item (res, rest), qta - 1, ctxt)) >>=? fun res ->
logged_return res
| Add_timestamp_to_seconds kind, Item (t, Item (n, rest)) ->
let n = Script_int.to_int64 kind n in
Lwt.return
(Period.of_seconds n >>? fun p ->
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 *)
| 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 *)
| Add_tez, Item (x, Item (y, rest)) ->
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)) ->
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)) ->
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)) ->
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 *)
| 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)) ->
return (Item (x && y, rest), qta - 1, ctxt)
logged_return (Item (x && y, rest), qta - 1, ctxt)
| 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) ->
return (Item (not x, rest), qta - 1, ctxt)
logged_return (Item (not x, rest), qta - 1, ctxt)
(* 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
| None -> fail (Overflow pos)
| Some res -> return (Item (res, rest), qta - 1, ctxt)
| None -> fail (Overflow loc)
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
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
| None -> fail (Overflow pos)
| Some res -> return (Item (res, rest), qta - 1, ctxt)
| None -> fail (Overflow loc)
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
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
| None -> fail (Overflow pos)
| Some res -> return (Item (res, rest), qta - 1, ctxt)
| None -> fail (Overflow loc)
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
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
| None -> fail (Overflow pos)
| Some res -> return (Item (res, rest), qta - 1, ctxt)
| None -> fail (Overflow loc)
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
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
| None -> fail (Overflow pos)
| Some res -> return (Item (res, rest), qta - 1, ctxt)
| None -> fail (Overflow loc)
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
end
| 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) ->
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)) ->
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)) ->
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)) ->
return (Item (Script_int.mul kind x y, rest), qta - 1, ctxt)
| Div_int (kind, pos), Item (x, Item (y, rest)) ->
logged_return (Item (Script_int.mul kind x y, rest), qta - 1, ctxt)
| Div_int kind, Item (x, Item (y, rest)) ->
if Compare.Int64.(Script_int.to_int64 kind y = 0L) then
fail (Division_by_zero pos)
fail (Division_by_zero loc)
else
return (Item (Script_int.div kind x y, rest), qta - 1, ctxt)
| Mod_int (kind, pos), Item (x, Item (y, rest)) ->
logged_return (Item (Script_int.div kind x y, rest), qta - 1, ctxt)
| Mod_int kind, Item (x, Item (y, rest)) ->
if Compare.Int64.(Script_int.to_int64 kind y = 0L) then
fail (Division_by_zero pos)
fail (Division_by_zero loc)
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)) ->
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)) ->
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)) ->
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)) ->
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)) ->
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) ->
return (Item (Script_int.lognot kind x, rest), qta - 1, ctxt)
logged_return (Item (Script_int.lognot kind x, rest), qta - 1, ctxt)
(* control *)
| Seq (hd, tl), stack ->
step qta ctxt hd stack >>=? fun (trans, qta, ctxt) ->
@ -298,83 +315,83 @@ let rec interp
step qta ctxt bf rest
| Loop body, Item (true, rest) ->
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) ->
return (rest, qta, ctxt)
logged_return (rest, qta, ctxt)
| Dip b, Item (ign, rest) ->
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)) ->
interp qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt) ->
return (Item (res, rest), qta - 1, ctxt)
interp ?log qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt) ->
logged_return (Item (res, rest), qta - 1, ctxt)
| Lambda lam, rest ->
return (Item (lam, rest), qta - 1, ctxt)
| Fail pos, _ ->
fail (Reject pos)
logged_return (Item (lam, rest), qta - 1, ctxt)
| Fail, _ ->
fail (Reject loc)
| Nop, stack ->
return (stack, qta - 1, ctxt)
logged_return (stack, qta - 1, ctxt)
(* comparison *)
| Compare Bool_key, Item (a, Item (b, rest)) ->
let cmpres = Compare.Bool.compare a b 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)) ->
let cmpres = Compare.String.compare a b 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)) ->
let cmpres = Tez.compare a b 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)) ->
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)) ->
let cmpres = Ed25519.Public_key_hash.compare a b 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)) ->
let cmpres = Timestamp.compare a b 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 *)
| Eq, Item (cmpres, rest) ->
let cmpres = Script_int.to_int64 Int64 cmpres 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) ->
let cmpres = Script_int.to_int64 Int64 cmpres 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) ->
let cmpres = Script_int.to_int64 Int64 cmpres 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) ->
let cmpres = Script_int.to_int64 Int64 cmpres 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) ->
let cmpres = Script_int.to_int64 Int64 cmpres 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) ->
let cmpres = Script_int.to_int64 Int64 cmpres in
let cmpres = Compare.Int64.(cmpres >= 0L) in
return (Item (cmpres, rest), qta - 1, ctxt)
logged_return (Item (cmpres, rest), qta - 1, ctxt)
(* 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
| None -> fail (Overflow pos)
| Some res -> return (Item (res, rest), qta - 1, ctxt)
| None -> fail (Overflow loc)
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
end
| 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 *)
| Manager, Item ((_, _, contract), rest) ->
Contract.get_manager ctxt contract >>=? fun manager ->
return (Item (manager, rest), qta - 1, ctxt)
| Transfer_tokens (storage_type, loc),
logged_return (Item (manager, rest), qta - 1, ctxt)
| Transfer_tokens storage_type,
Item (p, Item (amount, Item ((tp, Void_t, destination), Item (sto, Empty)))) -> begin
Contract.unconditional_spend ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
@ -402,39 +419,39 @@ let rec interp
| No_script -> assert false
| Script { storage = { storage } } ->
parse_untagged_data ctxt storage_type storage >>=? fun sto ->
return (Item ((), Item (sto, Empty)), qta - 1, ctxt))
end
| Transfer_tokens (storage_type, loc),
Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin
Contract.unconditional_spend ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? function
| No_script -> fail (Invalid_contract (loc, destination))
| Script { code ; storage } ->
let sto = unparse_untagged_data storage_type sto in
Contract.update_script_storage ctxt source sto >>=? fun ctxt ->
let p = unparse_untagged_data tp p in
execute source destination ctxt storage code amount p qta
>>=? fun (sto, ret, qta, ctxt) ->
Contract.update_script_storage
ctxt destination sto >>=? fun ctxt ->
trace
(Invalid_contract (loc, destination))
(parse_untagged_data ctxt tr ret) >>=? fun v ->
Contract.get_script ctxt source >>=? (function
| No_script -> assert false
| Script { storage = { storage } } ->
parse_untagged_data ctxt storage_type storage >>=? fun sto ->
return (Item (v, Item (sto, Empty)), qta - 1, ctxt))
end
| Create_account,
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
logged_return (Item ((), Item (sto, Empty)), qta - 1, ctxt))
end
| Transfer_tokens storage_type,
Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin
Contract.unconditional_spend ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? function
| No_script -> fail (Invalid_contract (loc, destination))
| Script { code ; storage } ->
let sto = unparse_untagged_data storage_type sto in
Contract.update_script_storage ctxt source sto >>=? fun ctxt ->
let p = unparse_untagged_data tp p in
execute source destination ctxt storage code amount p qta
>>=? fun (sto, ret, qta, ctxt) ->
Contract.update_script_storage
ctxt destination sto >>=? fun ctxt ->
trace
(Invalid_contract (loc, destination))
(parse_untagged_data ctxt tr ret) >>=? fun v ->
Contract.get_script ctxt source >>=? (function
| No_script -> assert false
| Script { storage = { storage } } ->
parse_untagged_data ctxt storage_type storage >>=? fun sto ->
logged_return (Item (v, Item (sto, Empty)), qta - 1, ctxt))
end
| Create_account,
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
Contract.unconditional_spend ctxt source credit >>=? fun ctxt ->
Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance ->
Contract.originate ctxt
~manager ~delegate ~balance
~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),
Item (manager, Item (delegate, Item (delegatable, Item (credit,
Item (Lam (_, code), Item (init, rest)))))) ->
@ -454,35 +471,43 @@ let rec interp
~manager ~delegate ~balance
~script:(Script { code ; storage }) ~spendable:true ~delegatable
>>=? fun (ctxt, contract) ->
return (Item ((p, r, contract), rest), qta - 1, ctxt)
logged_return (Item ((p, r, contract), rest), qta - 1, ctxt)
| Balance, rest ->
Contract.get_balance ctxt source >>=? fun balance ->
return (Item (balance, rest), qta - 1, ctxt)
logged_return (Item (balance, rest), qta - 1, ctxt)
| Now, rest ->
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)) ->
Public_key.get ctxt key >>=? fun key ->
let message = MBytes.of_string 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) ->
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 ->
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 ->
return (Item ((ta, tb, orig), rest), qta - 1, ctxt)
logged_return (Item ((ta, tb, orig), rest), qta - 1, ctxt)
| Amount, rest ->
return (Item (amount, rest), qta - 1, ctxt)
logged_return (Item (amount, rest), qta - 1, ctxt)
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)
(* ---- 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 ret_type >>=? fun (Ex ret_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_untagged_data ctxt arg_type arg >>=? fun arg ->
parse_untagged_data ctxt storage_type storage >>=? fun storage ->
interp qta orig source amount ctxt lambda ((amount, arg), storage) >>=? fun (ret, qta, ctxt) ->
let ret, storage = ret in
return (unparse_untagged_data storage_type storage,
unparse_untagged_data ret_type ret,
qta, ctxt)
interp ?log qta orig source amount ctxt lambda ((amount, arg), storage)
>>=? fun (ret, qta, ctxt) ->
let ret, storage = ret in
return (unparse_untagged_data storage_type storage,
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.expr -> int ->
(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 ('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 =
'arg ty * 'ret ty * Contract.t
@ -76,6 +76,10 @@ and 'ty ty =
| Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map 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 --------------------------------------------------------*)
(* The low-level, typed instructions, as a GADT whose parameters
@ -107,21 +111,21 @@ and ('bef, 'aft) instr =
('v * 'rest, 'v option * 'rest) instr
| Cons_none : 'a ty ->
('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
(* unions *)
| Left :
('l * 'rest, (('l, 'r) union * 'rest)) instr
| Right :
('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
(* lists *)
| Cons_list :
('a * ('a list * 'rest), ('a list * 'rest)) instr
| Nil :
('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
| List_map :
(('param, 'ret) lambda * ('param list * 'rest), 'ret list * 'rest) instr
@ -158,9 +162,9 @@ and ('bef, 'aft) instr =
| Concat :
(string * (string * 'rest), string * 'rest) instr
(* 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
| 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
(* currency operations *)
| Add_tez :
@ -181,15 +185,15 @@ and ('bef, 'aft) instr =
| Not :
(bool * 'rest, bool * 'rest) instr
(* 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
| 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
| 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
| 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
| 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
| Neg_int : (signed, 'l) int_kind ->
((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
| Mul_int : ('s, 'l) int_kind ->
(('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
| 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
| Lsl_int : (unsigned, 'l) int_kind ->
((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 ->
((unsigned, 'l) int_val * 'rest, (unsigned, 'l) int_val * 'rest) instr
(* control *)
| Seq : ('bef, 'trans) instr * ('trans, 'aft) instr ->
| Seq : ('bef, 'trans) descr * ('trans, 'aft) descr ->
('bef, 'aft) instr
| If : ('bef, 'aft) instr * ('bef, 'aft) instr ->
| If : ('bef, 'aft) descr * ('bef, 'aft) descr ->
(bool * 'bef, 'aft) instr
| Loop : ('rest, bool * 'rest) instr ->
| Loop : ('rest, bool * 'rest) descr ->
(bool * 'rest, 'rest) instr
| Dip : ('bef, 'aft) instr ->
| Dip : ('bef, 'aft) descr ->
('top * 'bef, 'top * 'aft) instr
| Exec :
('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr
| Lambda : ('arg, 'ret) lambda ->
('rest, ('arg, 'ret) lambda * 'rest) instr
| Fail : Script.location ->
| Fail :
('bef, 'aft) instr
| Nop :
('rest, 'rest) instr
@ -253,12 +257,12 @@ and ('bef, 'aft) instr =
(* casts *)
| Int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind ->
(('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
(* protocol *)
| Manager :
(('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
| Create_account :
(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
| Amount :
('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))
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 =
RPC.service
~description: "Run a piece of code in the current context"
~input: (obj5
(req "script" Script.code_encoding)
(req "storage" Script.expr_encoding)
(req "input" Script.expr_encoding)
(opt "amount" Tez.encoding)
(opt "contract" Contract.encoding))
~input: run_code_input_encoding
~output: (wrap_tzerror
(obj2
(req "storage" Script.expr_encoding)
(req "output" Script.expr_encoding)))
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 =
RPC.service
~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 () =
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
(fun 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_type = script.storage_type } in
let qta =
Constants.instructions_per_transaction ctxt in
(fun ctxt parameters ->
let (script, storage, input, amount, contract, qta) =
run_parameters ctxt parameters in
Script_interpreter.execute
contract (* transaction initiator *)
contract (* script owner *)
ctxt storage script amount input
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 () =
register1 Services.Helpers.typecheck_code