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

use apply for closures

Browse Source
This commit is contained in:
galfour 2019-10-17 16:34:02 +02:00
parent 8a4b9695e7
commit 27be6cfcba
5 changed files with 38 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/main/run/of_michelson.ml
View File

@ -10,16 +10,16 @@ let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (inp
let Compiler.Program.{input;output;body} : compiled_program = program in
let (Ex_ty input_ty) = input in
let (Ex_ty output_ty) = output in
(* let%bind input_ty_mich =
* Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@
* Memory_proto_alpha.unparse_michelson_ty input_ty in
* let%bind output_ty_mich =
* Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@
* Memory_proto_alpha.unparse_michelson_ty output_ty in
* Format.printf "code: %a\n" Michelson.pp program.body ;
* Format.printf "input_ty: %a\n" Michelson.pp input_ty_mich ;
* Format.printf "output_ty: %a\n" Michelson.pp output_ty_mich ;
* Format.printf "input: %a\n" Michelson.pp input_michelson ; *)
let%bind input_ty_mich =
Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@
Memory_proto_alpha.unparse_michelson_ty input_ty in
let%bind output_ty_mich =
Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@
Memory_proto_alpha.unparse_michelson_ty output_ty in
Format.printf "code: %a\n" Michelson.pp program.body ;
Format.printf "input_ty: %a\n" Michelson.pp input_ty_mich ;
Format.printf "output_ty: %a\n" Michelson.pp output_ty_mich ;
Format.printf "input: %a\n" Michelson.pp input_michelson ;
let%bind input =
Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
Memory_proto_alpha.parse_michelson_data input_michelson input_ty

11
src/passes/8-compiler/compiler_environment.ml
View File

@ -88,5 +88,12 @@ let pack_closure : environment -> selector -> michelson result = fun e lst ->
ok code
let unpack_closure : environment -> michelson result = fun e ->
let aux = fun code _ -> seq [ i_unpair ; dip code ] in
ok (List.fold_right' aux (seq []) e)
match e with
| [] -> ok @@ seq []
| _ :: tl -> (
let aux = fun code _ -> seq [ i_unpair ; dip code ] in
let unpairs = (List.fold_right' aux (seq []) tl) in
ok @@ seq [ i_unpiar ; dip unpairs ]
)
(* let aux = fun code _ -> seq [ i_unpair ; dip code ] in
* ok (List.fold_right' aux (seq []) e) *)

32
src/passes/8-compiler/compiler_program.ml
View File

@ -151,33 +151,21 @@ and translate_expression (expr:expression) (env:environment) : michelson result
return @@ seq [
closure_pack_code ;
i_push lambda_ty lambda_body_code ;
i_pair ;
i_swap ;
i_apply ;
]
)
| _ -> simple_fail "expected closure type"
)
| E_application (f , arg) -> (
match Combinators.Expression.get_type f with
| T_function _ -> (
trace (simple_error "Compiling quote application") @@
let%bind f = translate_expression f env in
let%bind arg = translate_expression arg env in
return @@ seq [
arg ;
dip f ;
prim I_EXEC ;
]
)
| T_deep_closure (_ , _ , _) -> (
let%bind f_code = translate_expression f env in
let%bind arg_code = translate_expression arg env in
return @@ seq [
arg_code ;
dip (seq [ f_code ; i_unpair ; i_swap ]) ; i_pair ;
prim I_EXEC ;
]
)
| _ -> simple_fail "E_applicationing something not appliable"
trace (simple_error "Compiling quote application") @@
let%bind f = translate_expression f env in
let%bind arg = translate_expression arg env in
return @@ seq [
arg ;
dip f ;
prim I_EXEC ;
]
)
| E_variable x ->
let%bind code = Compiler_environment.get env x in

15
src/passes/8-compiler/compiler_type.ml
View File

@ -115,11 +115,10 @@ module Ty = struct
let%bind (Ex_ty arg) = type_ arg in
let%bind (Ex_ty ret) = type_ ret in
ok @@ Ex_ty (lambda arg ret)
| T_deep_closure (c, arg, ret) ->
let%bind (Ex_ty capture) = environment_representation c in
| T_deep_closure (_, arg, ret) ->
let%bind (Ex_ty arg) = type_ arg in
let%bind (Ex_ty ret) = type_ ret in
ok @@ Ex_ty (pair (lambda (pair arg capture) ret) capture)
ok @@ Ex_ty (lambda arg ret)
| T_map (k, v) ->
let%bind (Ex_comparable_ty k') = comparable_type k in
let%bind (Ex_ty v') = type_ v in
@ -219,10 +218,10 @@ let rec type_ : type_value -> O.michelson result =
let%bind arg = type_ arg in
let%bind ret = type_ ret in
ok @@ O.prim ~children:[arg;ret] T_lambda
| T_deep_closure (c , arg , ret) ->
let%bind capture = environment_closure c in
let%bind lambda = lambda_closure (c , arg , ret) in
ok @@ O.t_pair lambda capture
| T_deep_closure (_ , arg , ret) ->
let%bind arg = type_ arg in
let%bind ret = type_ ret in
ok @@ O.prim ~children:[arg;ret] T_lambda
and annotated : type_value annotated -> O.michelson result =
function
@ -243,7 +242,7 @@ and lambda_closure = fun (c , arg , ret) ->
let%bind capture = environment_closure c in
let%bind arg = type_ arg in
let%bind ret = type_ ret in
ok @@ O.t_lambda (O.t_pair arg capture) ret
ok @@ O.t_lambda (O.t_pair capture arg) ret
and environment_closure =
function

2
vendors/ligo-utils/tezos-utils/x_michelson.ml vendored
View File

@ -45,6 +45,8 @@ let i_push ty code = prim ~children:[ty;code] I_PUSH
let i_push_unit = i_push t_unit d_unit
let i_push_string str = i_push t_string (string str)
let i_apply = prim I_APPLY
let i_comment s : michelson = seq [ i_push_string s ; prim I_DROP ]
let i_none ty = prim ~children:[ty] I_NONE