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

39
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,11 +221,30 @@ let commands () =
@@ stop)
(fun program storage input () ->
let open Data_encoding in
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 l -> false)) storage
(print_ir (fun l -> false)) output ;
(print_ir (fun _ -> false)) storage
(print_ir (fun _ -> false)) output ;
Lwt.return ()
| Error errs ->
pp_print_error Format.err_formatter errs ;
@ -222,6 +252,7 @@ let commands () =
command
~group: "programs"
~desc: "ask the node to typecheck a program"
~args: [ show_types_arg ]
(prefixes [ "typecheck" ; "program" ]
@@ Program.source_param
@@ stop)
@ -231,6 +262,7 @@ let commands () =
| Ok type_map ->
let type_map, program = unexpand_macros type_map program in
message "Well typed" ;
if !show_types then begin
print_program
(fun l -> List.mem_assoc l type_map)
Format.std_formatter program ;
@ -244,7 +276,8 @@ let commands () =
before
(Format.pp_print_list (print_ir (fun _ -> false)))
after)
type_map ;
(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

280
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,9 +419,9 @@ 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))
logged_return (Item ((), Item (sto, Empty)), qta - 1, ctxt))
end
| Transfer_tokens (storage_type, loc),
| 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 ->
@ -425,7 +442,7 @@ let rec interp
| 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))
logged_return (Item (v, Item (sto, Empty)), qta - 1, ctxt))
end
| Create_account,
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
@ -434,7 +451,7 @@ let rec interp
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) ->
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

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

@ -14,10 +14,6 @@ open Script_typed_ir
(* ---- Error reporting -----------------------------------------------------*)
type 'ty stack_ty =
| Item_t : 'ty ty * 'rest stack_ty -> ('ty * 'rest) stack_ty
| Empty_t : end_of_stack stack_ty
(* Boxed existentials types to put in exception constructors *)
type stack_ty_val = Stack_ty : _ stack_ty -> stack_ty_val
type ty_val =
@ -282,13 +278,13 @@ let map_fold
(* ---- Type checker resuls -------------------------------------------------*)
type 'bef judgement =
| Typed : ('bef, 'aft) instr * 'aft stack_ty -> 'bef judgement
| Failed : { instr : 'aft. 'aft stack_ty -> ('bef, 'aft) instr } -> 'bef judgement
| Typed : ('bef, 'aft) descr -> 'bef judgement
| Failed : { descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr } -> 'bef judgement
(* ---- type checker --------------------------------------------------------*)
type ('t, 'f, 'b) branch =
{ branch : 'r. ('t, 'r) instr -> ('f, 'r) instr -> ('b, 'r) instr } [@@unboxed]
{ branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr } [@@unboxed]
let merge_branches
: type bef a b. int -> a judgement -> b judgement ->
@ -296,19 +292,19 @@ let merge_branches
bef judgement tzresult Lwt.t
= fun loc btr bfr { branch } ->
match btr, bfr with
| Typed (ibt, aftbt), Typed (ibf, aftbf) ->
| Typed ({ aft = aftbt } as dbt), Typed ({ aft = aftbf } as dbf) ->
trace
(Unmatched_branches (loc, Stack_ty aftbt, Stack_ty aftbf))
(Lwt.return (stack_ty_eq 0 aftbt aftbf)) >>=? fun (Eq _) ->
return (Typed (branch ibt ibf, aftbt))
| Failed { instr = instrt }, Failed { instr = instrf } ->
let instr ret =
branch (instrt ret) (instrf ret) in
return (Failed { instr })
| Typed (ibt, aftbt), Failed { instr = instrf } ->
return (Typed (branch ibt (instrf aftbt), aftbt))
| Failed { instr = instrt }, Typed (ibf, aftbf) ->
return (Typed (branch (instrt aftbf) ibf, aftbf))
return (Typed (branch dbt dbf))
| Failed { descr = descrt }, Failed { descr = descrf } ->
let descr ret =
branch (descrt ret) (descrf ret) in
return (Failed { descr })
| Typed dbt, Failed { descr = descrf } ->
return (Typed (branch dbt (descrf dbt.aft)))
| Failed { descr = descrt }, Typed dbf ->
return (Typed (branch (descrt dbf.aft) dbf))
type ex_comparable_ty = Ex : 'a comparable_ty -> ex_comparable_ty
@ -760,130 +756,132 @@ and parse_untagged_comparable_data
and parse_lambda
: type arg ret storage. context ->
?log: (int -> (stack_ty_val * stack_ty_val) -> unit) ->
?storage_type: storage ty ->
arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t =
fun ctxt ?log ?storage_type arg ret script_instr ->
let loc = location script_instr in
parse_instr ctxt ?log ?storage_type script_instr (Item_t (arg, Empty_t)) >>=? function
| Typed (instr, (Item_t (ty, Empty_t) as stack_ty)) ->
fun ctxt ?storage_type arg ret script_instr ->
parse_instr ctxt ?storage_type script_instr (Item_t (arg, Empty_t)) >>=? function
| Typed ({ loc ; aft = (Item_t (ty, Empty_t) as stack_ty) } as descr) ->
trace
(Bad_return (loc, Stack_ty stack_ty, Ty ret))
(Lwt.return (ty_eq ty ret)) >>=? fun (Eq _) ->
return (Lam (instr, script_instr) : (arg, ret) lambda)
| Typed (_, stack_ty) ->
return (Lam (descr, script_instr) : (arg, ret) lambda)
| Typed { loc ; aft = stack_ty } ->
fail (Bad_return (loc, Stack_ty stack_ty, Ty ret))
| Failed { instr } ->
return (Lam (instr (Item_t (ret, Empty_t)), script_instr) : (arg, ret) lambda)
| Failed { descr } ->
return (Lam (descr (Item_t (ret, Empty_t)), script_instr) : (arg, ret) lambda)
and parse_instr
: type bef storage. context ->
?log: (int -> (stack_ty_val * stack_ty_val) -> unit) ->
?storage_type: storage ty ->
Script.expr -> bef stack_ty -> bef judgement tzresult Lwt.t =
fun ctxt ?log ?storage_type script_instr stack_ty ->
fun ctxt ?storage_type script_instr stack_ty ->
let return : bef judgement -> bef judgement tzresult Lwt.t = return in
let check_item_ty got exp pos n =
ty_eq got exp |> record_trace (Bad_stack_item (pos, n)) |> Lwt.return in
begin match script_instr, stack_ty with
let typed loc (instr, aft) =
Typed { loc ; instr ; bef = stack_ty ; aft } in
match script_instr, stack_ty with
(* stack ops *)
| Prim (_, "drop", []),
| Prim (loc, "drop", []),
Item_t (_, rest) ->
return (Typed (Drop, rest))
| Prim (_, "dup", []),
return (typed loc (Drop, rest))
| Prim (loc, "dup", []),
Item_t (v, rest) ->
return (Typed (Dup, Item_t (v, Item_t (v, rest))))
| Prim (_, "swap", []),
return (typed loc (Dup, Item_t (v, Item_t (v, rest))))
| Prim (loc, "swap", []),
Item_t (v, Item_t (w, rest)) ->
return (Typed (Swap, Item_t (w, Item_t (v, rest))))
| Prim (_, "push", [ td ]),
return (typed loc (Swap, Item_t (w, Item_t (v, rest))))
| Prim (loc, "push", [ td ]),
stack ->
parse_tagged_data ctxt td >>=? fun (Ex (t, v)) ->
return (Typed (Const v, Item_t (t, stack)))
return (typed loc (Const v, Item_t (t, stack)))
(* options *)
| Prim (_, "some", []),
| Prim (loc, "some", []),
Item_t (t, rest) ->
return (Typed (Cons_some, Item_t (Option_t t, rest)))
| Prim (_, "none", [ t ]),
return (typed loc (Cons_some, Item_t (Option_t t, rest)))
| Prim (loc, "none", [ t ]),
stack ->
parse_ty t >>=? fun (Ex t) ->
return (Typed (Cons_none t, Item_t (Option_t t, stack)))
return (typed loc (Cons_none t, Item_t (Option_t t, stack)))
| Prim (loc, "if_none", [ bt ; bf ]),
Item_t (Option_t t, rest) ->
(Item_t (Option_t t, rest) as bef) ->
expect_sequence_parameter loc Instr "if_none" 0 bt >>=? fun () ->
expect_sequence_parameter loc Instr "if_none" 1 bf >>=? fun () ->
parse_instr ?log ?storage_type ctxt bt rest >>=? fun btr ->
parse_instr ?log ?storage_type ctxt bf (Item_t (t, rest)) >>=? fun bfr ->
let branch ibt ibf = If_none (ibt, ibf) in
parse_instr ?storage_type ctxt bt rest >>=? fun btr ->
parse_instr ?storage_type ctxt bf (Item_t (t, rest)) >>=? fun bfr ->
let branch ibt ibf =
{ loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in
merge_branches loc btr bfr { branch }
(* pairs *)
| Prim (_, "pair", []),
| Prim (loc, "pair", []),
Item_t (a, Item_t (b, rest)) ->
return (Typed (Cons_pair, Item_t (Pair_t(a, b), rest)))
| Prim (_, "car", []),
return (typed loc (Cons_pair, Item_t (Pair_t(a, b), rest)))
| Prim (loc, "car", []),
Item_t (Pair_t (a, _), rest) ->
return (Typed (Car, Item_t (a, rest)))
| Prim (_, "cdr", []),
return (typed loc (Car, Item_t (a, rest)))
| Prim (loc, "cdr", []),
Item_t (Pair_t (_, b), rest) ->
return (Typed (Cdr, Item_t (b, rest)))
return (typed loc (Cdr, Item_t (b, rest)))
(* unions *)
| Prim (_, "left", [ tr ]),
| Prim (loc, "left", [ tr ]),
Item_t (tl, rest) ->
parse_ty tr >>=? fun (Ex tr) ->
return (Typed (Left, Item_t (Union_t (tl, tr), rest)))
| Prim (_, "right", [ tl ]),
return (typed loc (Left, Item_t (Union_t (tl, tr), rest)))
| Prim (loc, "right", [ tl ]),
Item_t (tr, rest) ->
parse_ty tl >>=? fun (Ex tl) ->
return (Typed (Right, Item_t (Union_t (tl, tr), rest)))
return (typed loc (Right, Item_t (Union_t (tl, tr), rest)))
| Prim (loc, "if_left", [ bt ; bf ]),
Item_t (Union_t (tl, tr), rest) ->
(Item_t (Union_t (tl, tr), rest) as bef) ->
expect_sequence_parameter loc Instr "if_left" 0 bt >>=? fun () ->
expect_sequence_parameter loc Instr "if_left" 1 bf >>=? fun () ->
parse_instr ?log ?storage_type ctxt bt (Item_t (tl, rest)) >>=? fun btr ->
parse_instr ?log ?storage_type ctxt bf (Item_t (tr, rest)) >>=? fun bfr ->
let branch ibt ibf = If_left (ibt, ibf) in
parse_instr ?storage_type ctxt bt (Item_t (tl, rest)) >>=? fun btr ->
parse_instr ?storage_type ctxt bf (Item_t (tr, rest)) >>=? fun bfr ->
let branch ibt ibf =
{ loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in
merge_branches loc btr bfr { branch }
(* lists *)
| Prim (_, "nil", [ t ]),
| Prim (loc, "nil", [ t ]),
stack ->
parse_ty t >>=? fun (Ex t) ->
return (Typed (Nil, Item_t (List_t t, stack)))
return (typed loc (Nil, Item_t (List_t t, stack)))
| Prim (loc, "cons", []),
Item_t (tv, Item_t (List_t t, rest)) ->
trace
(Bad_stack_item (loc, 2))
(Lwt.return (ty_eq t tv)) >>=? fun (Eq _) ->
return (Typed (Cons_list, Item_t (List_t t, rest)))
return (typed loc (Cons_list, Item_t (List_t t, rest)))
| Prim (loc, "if_cons", [ bt ; bf ]),
Item_t (List_t t, rest) ->
(Item_t (List_t t, rest) as bef) ->
expect_sequence_parameter loc Instr "if_cons" 0 bt >>=? fun () ->
expect_sequence_parameter loc Instr "if_cons" 1 bf >>=? fun () ->
parse_instr ?log ?storage_type ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun btr ->
parse_instr ?log ?storage_type ctxt bf rest >>=? fun bfr ->
let branch ibt ibf = If_cons (ibt, ibf) in
parse_instr ?storage_type ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun btr ->
parse_instr ?storage_type ctxt bf rest >>=? fun bfr ->
let branch ibt ibf =
{ loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in
merge_branches loc btr bfr { branch }
| Prim (loc, "map", []),
Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) ->
check_item_ty elt param loc 2 >>=? fun (Eq _) ->
return (Typed (List_map, Item_t (List_t ret, rest)))
return (typed loc (List_map, Item_t (List_t ret, rest)))
| Prim (loc, "reduce", []),
Item_t (Lambda_t (Pair_t (pelt, pr), r),
Item_t (List_t elt, Item_t (init, rest))) ->
check_item_ty r pr loc 1 >>=? fun (Eq _) ->
check_item_ty elt pelt loc 2 >>=? fun (Eq _) ->
check_item_ty init r loc 3 >>=? fun (Eq _) ->
return (Typed (List_reduce, Item_t (r, rest)))
return (typed loc (List_reduce, Item_t (r, rest)))
(* sets *)
| Prim (_, "empty_set", [ t ]),
| Prim (loc, "empty_set", [ t ]),
rest ->
parse_comparable_ty t >>=? fun (Ex t) ->
return (Typed (Empty_set t, Item_t (Set_t t, rest)))
return (typed loc (Empty_set t, Item_t (Set_t t, rest)))
| Prim (loc, "map", []),
Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) ->
let elt = ty_of_comparable_ty elt in
trace (Bad_stack_item (loc, 1)) (Lwt.return (comparable_ty_of_ty ret)) >>=? fun ret ->
check_item_ty elt param loc 2 >>=? fun (Eq _) ->
return (Typed (Set_map ret, Item_t (Set_t ret, rest)))
return (typed loc (Set_map ret, Item_t (Set_t ret, rest)))
| Prim (loc, "reduce", []),
Item_t (Lambda_t (Pair_t (pelt, pr), r),
Item_t (Set_t elt, Item_t (init, rest))) ->
@ -891,29 +889,29 @@ and parse_instr
check_item_ty r pr loc 1 >>=? fun (Eq _) ->
check_item_ty elt pelt loc 2 >>=? fun (Eq _) ->
check_item_ty init r loc 3 >>=? fun (Eq _) ->
return (Typed (Set_reduce, Item_t (r, rest)))
return (typed loc (Set_reduce, Item_t (r, rest)))
| Prim (loc, "mem", []),
Item_t (v, Item_t (Set_t elt, rest)) ->
let elt = ty_of_comparable_ty elt in
check_item_ty elt v loc 2 >>=? fun (Eq _) ->
return (Typed (Set_mem, Item_t (Bool_t, rest)))
return (typed loc (Set_mem, Item_t (Bool_t, rest)))
| Prim (loc, "update", []),
Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) ->
let ty = ty_of_comparable_ty elt in
check_item_ty ty v loc 3 >>=? fun (Eq _) ->
return (Typed (Set_update, Item_t (Set_t elt, rest)))
return (typed loc (Set_update, Item_t (Set_t elt, rest)))
(* maps *)
| Prim (_, "empty_map", [ tk ; tv ]),
| Prim (loc, "empty_map", [ tk ; tv ]),
stack ->
parse_comparable_ty tk >>=? fun (Ex tk) ->
parse_ty tv >>=? fun (Ex tv) ->
return (Typed (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack)))
return (typed loc (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack)))
| Prim (loc, "map", []),
Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) ->
let k = ty_of_comparable_ty ck in
check_item_ty pk k loc 2 >>=? fun (Eq _) ->
check_item_ty pv v loc 2 >>=? fun (Eq _) ->
return (Typed (Map_map, Item_t (Map_t (ck, ret), rest)))
return (typed loc (Map_map, Item_t (Map_t (ck, ret), rest)))
| Prim (loc, "reduce", []),
Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r),
Item_t (Map_t (ck, v), Item_t (init, rest))) ->
@ -922,225 +920,228 @@ and parse_instr
check_item_ty pv v loc 2 >>=? fun (Eq _) ->
check_item_ty r pr loc 1 >>=? fun (Eq _) ->
check_item_ty init r loc 3 >>=? fun (Eq _) ->
return (Typed (Map_reduce, Item_t (r, rest)))
return (typed loc (Map_reduce, Item_t (r, rest)))
| Prim (loc, "mem", []),
Item_t (vk, Item_t (Map_t (ck, _), rest)) ->
let k = ty_of_comparable_ty ck in
check_item_ty vk k loc 1 >>=? fun (Eq _) ->
return (Typed (Map_mem, Item_t (Bool_t, rest)))
return (typed loc (Map_mem, Item_t (Bool_t, rest)))
| Prim (loc, "get", []),
Item_t (vk, Item_t (Map_t (ck, elt), rest)) ->
let k = ty_of_comparable_ty ck in
check_item_ty vk k loc 1 >>=? fun (Eq _) ->
return (Typed (Map_get, Item_t (Option_t elt, rest)))
return (typed loc (Map_get, Item_t (Option_t elt, rest)))
| Prim (loc, "update", []),
Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) ->
let k = ty_of_comparable_ty ck in
check_item_ty vk k loc 1 >>=? fun (Eq _) ->
check_item_ty vv v loc 2 >>=? fun (Eq _) ->
return (Typed (Map_update, Item_t (Map_t (ck, v), rest)))
return (typed loc (Map_update, Item_t (Map_t (ck, v), rest)))
(* control *)
| Seq (_, []),
| Seq (loc, []),
stack ->
return (Typed (Nop, stack))
return (typed loc (Nop, stack))
| Seq (_, [ single ]),
stack ->
parse_instr ?log ?storage_type ctxt single stack
parse_instr ?storage_type ctxt single stack
| Seq (loc, hd :: tl),
stack ->
parse_instr ?log ?storage_type ctxt hd stack >>=? begin function
parse_instr ?storage_type ctxt hd stack >>=? begin function
| Failed _ ->
fail (Fail_not_in_tail_position loc)
| Typed (ihd, trans) ->
parse_instr ?log ?storage_type ctxt (Seq (loc, tl)) trans >>=? function
| Failed { instr } ->
let instr ret = Seq (ihd, instr ret) in
return (Failed { instr })
| Typed (itl, aft) ->
return (Typed (Seq (ihd, itl), aft))
| Typed ({ aft = middle } as ihd) ->
parse_instr ?storage_type ctxt (Seq (loc, tl)) middle >>=? function
| Failed { descr } ->
let descr ret =
{ loc ; instr = Seq (ihd, descr ret) ;
bef = stack ; aft = ret } in
return (Failed { descr })
| Typed itl ->
return (typed loc (Seq (ihd, itl), itl.aft))
end
| Prim (loc, "if", [ bt ; bf ]),
Item_t (Bool_t, rest) ->
(Item_t (Bool_t, rest) as bef) ->
expect_sequence_parameter loc Instr "if" 0 bt >>=? fun () ->
expect_sequence_parameter loc Instr "if" 1 bf >>=? fun () ->
parse_instr ?log ?storage_type ctxt bt rest >>=? fun btr ->
parse_instr ?log ?storage_type ctxt bf rest >>=? fun bfr ->
let branch ibt ibf = If (ibt, ibf) in
parse_instr ?storage_type ctxt bt rest >>=? fun btr ->
parse_instr ?storage_type ctxt bf rest >>=? fun bfr ->
let branch ibt ibf =
{ loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in
merge_branches loc btr bfr { branch }
| Prim (loc, "loop", [ body ]),
(Item_t (Bool_t, rest) as stack) ->
expect_sequence_parameter loc Instr "loop" 0 body >>=? fun () ->
parse_instr ?log ?storage_type ctxt body rest >>=? begin function
| Typed (ibody, aftbody) ->
parse_instr ?storage_type ctxt body rest >>=? begin function
| Typed ibody ->
trace
(Unmatched_branches (loc, Stack_ty aftbody, Stack_ty stack))
(Lwt.return (stack_ty_eq 0 aftbody stack)) >>=? fun (Eq _) ->
return (Typed (Loop ibody, rest))
| Failed { instr } ->
let ibody = instr (Item_t (Bool_t, rest)) in
return (Typed (Loop ibody, rest))
(Unmatched_branches (loc, Stack_ty ibody.aft, Stack_ty stack))
(Lwt.return (stack_ty_eq 0 ibody.aft stack)) >>=? fun (Eq _) ->
return (typed loc (Loop ibody, rest))
| Failed { descr } ->
let ibody = descr (Item_t (Bool_t, rest)) in
return (typed loc (Loop ibody, rest))
end
| Prim (loc, "lambda", [ arg ; ret ; code ]),
stack ->
parse_ty arg >>=? fun (Ex arg) ->
parse_ty ret >>=? fun (Ex ret) ->
expect_sequence_parameter loc Instr "lambda" 2 code >>=? fun () ->
parse_lambda ctxt ?log arg ret code >>=? fun lambda ->
return (Typed (Lambda lambda, Item_t (Lambda_t (arg, ret), stack)))
parse_lambda ctxt arg ret code >>=? fun lambda ->
return (typed loc (Lambda lambda, Item_t (Lambda_t (arg, ret), stack)))
| Prim (loc, "exec", []),
Item_t (arg, Item_t (Lambda_t (param, ret), rest)) ->
check_item_ty arg param loc 1 >>=? fun (Eq _) ->
return (Typed (Exec, Item_t (ret, rest)))
return (typed loc (Exec, Item_t (ret, rest)))
| Prim (loc, "dip", [ code ]),
Item_t (v, rest) ->
expect_sequence_parameter loc Instr "dip" 0 code >>=? fun () ->
parse_instr ?log ctxt code rest >>=? begin function
| Typed (instr, aft_rest) ->
return (Typed (Dip instr, Item_t (v, aft_rest)))
parse_instr ctxt code rest >>=? begin function
| Typed descr ->
return (typed loc (Dip descr, Item_t (v, descr.aft)))
| Failed _ ->
fail (Fail_not_in_tail_position loc)
end
| Prim (loc, "fail", []),
_ ->
let instr _ = Fail loc in
return (Failed { instr })
| Prim (_, "nop", []),
bef ->
let descr aft = { loc ; instr = Fail ; bef ; aft } in
return (Failed { descr })
| Prim (loc, "nop", []),
stack ->
return (Typed (Nop, stack))
return (typed loc (Nop, stack))
(* timestamp operations *)
| Prim (loc, "add", []),
Item_t (Timestamp_t, Item_t (Int_t kind, rest)) ->
trace
(Bad_stack_item (loc, 2))
(Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) ->
return (Typed (Add_timestamp_to_seconds (kind, loc), Item_t (Timestamp_t, rest)))
return (typed loc (Add_timestamp_to_seconds kind, Item_t (Timestamp_t, rest)))
| Prim (loc, "add", []),
Item_t (Int_t kind, Item_t (Timestamp_t, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) ->
return (Typed (Add_seconds_to_timestamp (kind, loc), Item_t (Timestamp_t, rest)))
return (typed loc (Add_seconds_to_timestamp kind, Item_t (Timestamp_t, rest)))
(* string operations *)
| Prim (_, "concat", []),
| Prim (loc, "concat", []),
Item_t (String_t, Item_t (String_t, rest)) ->
return (Typed (Concat, Item_t (String_t, rest)))
return (typed loc (Concat, Item_t (String_t, rest)))
(* currency operations *)
| Prim (_, "add", []),
| Prim (loc, "add", []),
Item_t (Tez_t, Item_t (Tez_t, rest)) ->
return (Typed (Add_tez, Item_t (Tez_t, rest)))
| Prim (_, "sub", []),
return (typed loc (Add_tez, Item_t (Tez_t, rest)))
| Prim (loc, "sub", []),
Item_t (Tez_t, Item_t (Tez_t, rest)) ->
return (Typed (Sub_tez, Item_t (Tez_t, rest)))
return (typed loc (Sub_tez, Item_t (Tez_t, rest)))
| Prim (loc, "mul", []),
Item_t (Tez_t, Item_t (Int_t kind, rest)) ->
trace
(Bad_stack_item (loc, 2))
(Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) ->
return (Typed (Mul_tez kind, Item_t (Tez_t, rest)))
return (typed loc (Mul_tez kind, Item_t (Tez_t, rest)))
| Prim (loc, "mul", []),
Item_t (Int_t kind, Item_t (Tez_t, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) ->
return (Typed (Mul_tez' kind, Item_t (Tez_t, rest)))
return (typed loc (Mul_tez' kind, Item_t (Tez_t, rest)))
(* boolean operations *)
| Prim (_, "or", []),
| Prim (loc, "or", []),
Item_t (Bool_t, Item_t (Bool_t, rest)) ->
return (Typed (Or, Item_t (Bool_t, rest)))
| Prim (_, "and", []),
return (typed loc (Or, Item_t (Bool_t, rest)))
| Prim (loc, "and", []),
Item_t (Bool_t, Item_t (Bool_t, rest)) ->
return (Typed (And, Item_t (Bool_t, rest)))
| Prim (_, "xor", []),
return (typed loc (And, Item_t (Bool_t, rest)))
| Prim (loc, "xor", []),
Item_t (Bool_t, Item_t (Bool_t, rest)) ->
return (Typed (Xor, Item_t (Bool_t, rest)))
| Prim (_, "not", []),
return (typed loc (Xor, Item_t (Bool_t, rest)))
| Prim (loc, "not", []),
Item_t (Bool_t, rest) ->
return (Typed (Not, Item_t (Bool_t, rest)))
return (typed loc (Not, Item_t (Bool_t, rest)))
(* integer operations *)
| Prim (loc, "checked_abs", []),
Item_t (Int_t k, rest) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (signed_int_kind k)) >>=? fun (Eq _) ->
return (Typed (Checked_abs_int (k, loc), Item_t (Int_t k, rest)))
return (typed loc (Checked_abs_int k, Item_t (Int_t k, rest)))
| Prim (loc, "checked_neg", []),
Item_t (Int_t k, rest) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (signed_int_kind k)) >>=? fun (Eq _) ->
return (Typed (Checked_neg_int (k, loc), Item_t (Int_t k, rest)))
return (typed loc (Checked_neg_int k, Item_t (Int_t k, rest)))
| Prim (loc, "checked_add", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Checked_add_int (kl, loc), Item_t (Int_t kl, rest)))
return (typed loc (Checked_add_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "checked_sub", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Checked_sub_int (kl, loc), Item_t (Int_t kl, rest)))
return (typed loc (Checked_sub_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "checked_mul", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Checked_mul_int (kl, loc), Item_t (Int_t kl, rest)))
return (typed loc (Checked_mul_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "abs", []),
Item_t (Int_t k, rest) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (signed_int_kind k)) >>=? fun (Eq _) ->
return (Typed (Abs_int k, Item_t (Int_t k, rest)))
return (typed loc (Abs_int k, Item_t (Int_t k, rest)))
| Prim (loc, "neg", []),
Item_t (Int_t k, rest) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (signed_int_kind k)) >>=? fun (Eq _) ->
return (Typed (Neg_int k, Item_t (Int_t k, rest)))
return (typed loc (Neg_int k, Item_t (Int_t k, rest)))
| Prim (loc, "add", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Add_int kl, Item_t (Int_t kl, rest)))
return (typed loc (Add_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "sub", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Sub_int kl, Item_t (Int_t kl, rest)))
return (typed loc (Sub_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "mul", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Mul_int kl, Item_t (Int_t kl, rest)))
return (typed loc (Mul_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "div", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Div_int (kl, loc), Item_t (Int_t kl, rest)))
return (typed loc (Div_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "mod", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Mod_int (kl, loc), Item_t (Int_t kl, rest)))
return (typed loc (Mod_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "lsl", []),
Item_t (Int_t k, Item_t (Int_t Uint8, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) ->
return (Typed (Lsl_int k, Item_t (Int_t k, rest)))
return (typed loc (Lsl_int k, Item_t (Int_t k, rest)))
| Prim (loc, "lsr", []),
Item_t (Int_t k, Item_t (Int_t Uint8, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) ->
return (Typed (Lsr_int k, Item_t (Int_t k, rest)))
return (typed loc (Lsr_int k, Item_t (Int_t k, rest)))
| Prim (loc, "or", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
@ -1149,7 +1150,7 @@ and parse_instr
trace
(Bad_stack_item (loc, 2))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Or_int kl, Item_t (Int_t kl, rest)))
return (typed loc (Or_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "and", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
@ -1158,7 +1159,7 @@ and parse_instr
trace
(Bad_stack_item (loc, 2))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (And_int kl, Item_t (Int_t kl, rest)))
return (typed loc (And_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "xor", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
@ -1167,61 +1168,61 @@ and parse_instr
trace
(Bad_stack_item (loc, 2))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Xor_int kl, Item_t (Int_t kl, rest)))
return (typed loc (Xor_int kl, Item_t (Int_t kl, rest)))
| Prim (loc, "not", []),
Item_t (Int_t k, rest) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) ->
return (Typed (Not_int k, Item_t (Int_t k, rest)))
return (typed loc (Not_int k, Item_t (Int_t k, rest)))
(* comparison *)
| Prim (loc, "compare", []),
Item_t (Int_t kl, Item_t (Int_t kr, rest)) ->
trace
(Bad_stack_item (loc, 1))
(Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) ->
return (Typed (Compare (Int_key kl), Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []),
return (typed loc (Compare (Int_key kl), Item_t (Int_t Int64, rest)))
| Prim (loc, "compare", []),
Item_t (Bool_t, Item_t (Bool_t, rest)) ->
return (Typed (Compare Bool_key, Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []),
return (typed loc (Compare Bool_key, Item_t (Int_t Int64, rest)))
| Prim (loc, "compare", []),
Item_t (String_t, Item_t (String_t, rest)) ->
return (Typed (Compare String_key, Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []),
return (typed loc (Compare String_key, Item_t (Int_t Int64, rest)))
| Prim (loc, "compare", []),
Item_t (Tez_t, Item_t (Tez_t, rest)) ->
return (Typed (Compare Tez_key, Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []),
return (typed loc (Compare Tez_key, Item_t (Int_t Int64, rest)))
| Prim (loc, "compare", []),
Item_t (Key_t, Item_t (Key_t, rest)) ->
return (Typed (Compare Key_key, Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []),
return (typed loc (Compare Key_key, Item_t (Int_t Int64, rest)))
| Prim (loc, "compare", []),
Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) ->
return (Typed (Compare Timestamp_key, Item_t (Int_t Int64, rest)))
return (typed loc (Compare Timestamp_key, Item_t (Int_t Int64, rest)))
(* comparators *)
| Prim (_, "eq", []),
| Prim (loc, "eq", []),
Item_t (Int_t Int64, rest) ->
return (Typed (Eq, Item_t (Bool_t, rest)))
| Prim (_, "neq", []),
return (typed loc (Eq, Item_t (Bool_t, rest)))
| Prim (loc, "neq", []),
Item_t (Int_t Int64, rest) ->
return (Typed (Neq, Item_t (Bool_t, rest)))
| Prim (_, "lt", []),
return (typed loc (Neq, Item_t (Bool_t, rest)))
| Prim (loc, "lt", []),
Item_t (Int_t Int64, rest) ->
return (Typed (Lt, Item_t (Bool_t, rest)))
| Prim (_, "gt", []),
return (typed loc (Lt, Item_t (Bool_t, rest)))
| Prim (loc, "gt", []),
Item_t (Int_t Int64, rest) ->
return (Typed (Gt, Item_t (Bool_t, rest)))
| Prim (_, "le", []),
return (typed loc (Gt, Item_t (Bool_t, rest)))
| Prim (loc, "le", []),
Item_t (Int_t Int64, rest) ->
return (Typed (Le, Item_t (Bool_t, rest)))
| Prim (_, "ge", []),
return (typed loc (Le, Item_t (Bool_t, rest)))
| Prim (loc, "ge", []),
Item_t (Int_t Int64, rest) ->
return (Typed (Ge, Item_t (Bool_t, rest)))
return (typed loc (Ge, Item_t (Bool_t, rest)))
(* casts *)
| Prim (loc, "checked_cast", [ t ]),
stack ->
parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with
| Int_t kt,
Item_t (Int_t kf, rest) ->
return (Typed (Checked_int_of_int (kf, kt, loc),
return (typed loc (Checked_int_of_int (kf, kt),
Item_t (Int_t kt, rest)))
| ty, Item_t (ty', _) ->
fail (Undefined_cast (loc, Ty ty', Ty ty))
@ -1232,7 +1233,7 @@ and parse_instr
stack ->
parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with
| Int_t kt, Item_t (Int_t kf, rest) ->
return (Typed (Int_of_int (kf, kt),
return (typed loc (Int_of_int (kf, kt),
Item_t (Int_t kt, rest)))
| ty, Item_t (ty', _) ->
fail (Undefined_cast (loc, Ty ty', Ty ty))
@ -1240,9 +1241,9 @@ and parse_instr
fail (Bad_stack (loc, 1, Stack_ty stack))
end
(* protocol *)
| Prim (_, "manager", []),
| Prim (loc, "manager", []),
Item_t (Contract_t _, rest) ->
return (Typed (Manager, Item_t (Key_t, rest)))
return (typed loc (Manager, Item_t (Key_t, rest)))
| Prim (loc, "transfer_tokens", []),
Item_t (p, Item_t
(Tez_t, Item_t
@ -1252,18 +1253,18 @@ and parse_instr
begin match storage_type with
| Some storage_type ->
check_item_ty storage storage_type loc 3 >>=? fun (Eq _) ->
return (Typed (Transfer_tokens (storage, loc),
return (typed loc (Transfer_tokens storage,
Item_t (cr, Item_t (storage, Empty_t))))
| None ->
fail (Transfer_in_lambda loc)
end
| Prim (_, "create_account", []),
| Prim (loc, "create_account", []),
Item_t
(Key_t, Item_t
(Option_t Key_t, Item_t
(Bool_t, Item_t
(Tez_t, rest)))) ->
return (Typed (Create_account,
return (typed loc (Create_account,
Item_t (Contract_t (Void_t, Void_t), rest)))
| Prim (loc, "create_contract", []),
Item_t
@ -1276,31 +1277,31 @@ and parse_instr
(ginit, rest)))))) ->
check_item_ty gp gr loc 5 >>=? fun (Eq _) ->
check_item_ty ginit gp loc 6 >>=? fun (Eq _) ->
return (Typed (Create_contract (gp, p, r),
return (typed loc (Create_contract (gp, p, r),
Item_t (Contract_t (p, r), rest)))
| Prim (_, "now", []),
| Prim (loc, "now", []),
stack ->
return (Typed (Now, Item_t (Timestamp_t, stack)))
| Prim (_, "amount", []),
return (typed loc (Now, Item_t (Timestamp_t, stack)))
| Prim (loc, "amount", []),
stack ->
return (Typed (Amount, Item_t (Tez_t, stack)))
| Prim (_, "balance", []),
return (typed loc (Amount, Item_t (Tez_t, stack)))
| Prim (loc, "balance", []),
stack ->
return (Typed (Balance, Item_t (Tez_t, stack)))
| Prim (_, "check_signature", []),
return (typed loc (Balance, Item_t (Tez_t, stack)))
| Prim (loc, "check_signature", []),
Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) ->
return (Typed (Check_signature, Item_t (Bool_t, rest)))
| Prim (_, "h", []),
return (typed loc (Check_signature, Item_t (Bool_t, rest)))
| Prim (loc, "h", []),
Item_t (t, rest) ->
return (Typed (H t, Item_t (String_t, rest)))
| Prim (_, "steps_to_quota", []),
return (typed loc (H t, Item_t (String_t, rest)))
| Prim (loc, "steps_to_quota", []),
stack ->
return (Typed (Steps_to_quota, Item_t (Int_t Uint32, stack)))
| Prim (_, "source", [ ta; tb ]),
return (typed loc (Steps_to_quota, Item_t (Int_t Uint32, stack)))
| Prim (loc, "source", [ ta; tb ]),
stack ->
parse_ty ta >>=? fun (Ex ta) ->
parse_ty tb >>=? fun (Ex tb) ->
return (Typed (Source (ta, tb), Item_t (Contract_t (ta, tb), stack)))
return (typed loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack)))
(* Primitive parsing errors *)
| Prim (loc, ("drop" | "dup" | "swap" | "some"
| "pair" | "car" | "cdr" | "cons"
@ -1378,13 +1379,6 @@ and parse_instr
fail @@ Invalid_primitive (loc, Instr, prim)
| (Int (loc, _) | String (loc, _)), _ ->
fail @@ Invalid_expression_kind loc
end >>=? fun judgement ->
begin match judgement, script_instr, log with
| Typed (_, after_ty), Prim (loc, _, _), Some log ->
log loc (Stack_ty stack_ty, Stack_ty after_ty)
| _ -> ()
end ;
return judgement
and parse_contract
: type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t ->
@ -1647,6 +1641,48 @@ let type_map_enc =
(list Script.expr_encoding)
(list Script.expr_encoding)))
let type_map descr =
let rec unparse_stack
: type a. a stack_ty -> Script.expr list
= function
| Empty_t -> []
| Item_t (ty, rest) -> unparse_ty ty :: unparse_stack rest in
let rec type_map
: type bef aft. type_map -> (bef, aft) descr -> type_map
= fun acc { loc ; instr ; bef ; aft } ->
let self acc =
(loc, (unparse_stack bef, unparse_stack aft)) :: acc in
match instr with
| If_none (dbt, dbf) ->
let acc = type_map acc dbt in
let acc = type_map acc dbf in
self acc
| If_left (dbt, dbf) ->
let acc = type_map acc dbt in
let acc = type_map acc dbf in
self acc
| If_cons (dbt, dbf) ->
let acc = type_map acc dbt in
let acc = type_map acc dbf in
self acc
| Seq (dl, dr) ->
let acc = type_map acc dl in
let acc = type_map acc dr in
acc
| If (dbt, dbf) ->
let acc = type_map acc dbt in
let acc = type_map acc dbf in
self acc
| Loop body ->
let acc = type_map acc body in
self acc
| Dip body ->
let acc = type_map acc body in
self acc
| _ ->
self acc in
type_map [] descr
let typecheck_code
: context -> Script.code -> type_map tzresult Lwt.t
= fun ctxt { code; arg_type; ret_type; storage_type } ->
@ -1655,16 +1691,9 @@ let typecheck_code
parse_ty storage_type >>=? fun (Ex storage_type) ->
let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in
let ret_type_full = Pair_t (ret_type, storage_type) in
let result = ref [] in
let log loc (Stack_ty before, Stack_ty after) =
let rec unparse_stack
: type a. a stack_ty -> Script.expr list
= function
| Empty_t -> []
| Item_t (ty, rest) -> unparse_ty ty :: unparse_stack rest in
result := (loc, (unparse_stack before, unparse_stack after)) :: !result in
parse_lambda ctxt ~log ~storage_type arg_type_full ret_type_full code >>=? fun _ ->
return !result
parse_lambda ctxt ~storage_type arg_type_full ret_type_full code
>>=? fun (Lam (descr,_)) ->
return (type_map descr)
let typecheck_tagged_data
: context -> Script.expr -> unit tzresult Lwt.t

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 }

27
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 custom_root =
RPC.service
~description: "Run a piece of code in the current context"
~input: (obj5
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: 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"

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

@ -180,8 +180,7 @@ let minimal_timestamp ctxt prio =
let () = register1 Services.Helpers.minimal_timestamp minimal_timestamp
let () =
register1 Services.Helpers.run_code
(fun ctxt (script, storage, input, amount, contract) ->
let run_parameters ctxt (script, storage, input, amount, contract) =
let amount =
match amount with
| Some amount -> amount
@ -195,16 +194,31 @@ let () =
| None ->
Contract.default_contract
(List.hd Bootstrap.accounts).Bootstrap.public_key_hash in
let storage =
{ Script.storage ; storage_type = script.storage_type } 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 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