From 27be6cfcba3359fdbe50d12738236d7c1fdc900e Mon Sep 17 00:00:00 2001 From: galfour Date: Thu, 17 Oct 2019 16:34:02 +0200 Subject: [PATCH] use apply for closures --- src/main/run/of_michelson.ml | 20 ++++++------ src/passes/8-compiler/compiler_environment.ml | 11 +++++-- src/passes/8-compiler/compiler_program.ml | 32 ++++++------------- src/passes/8-compiler/compiler_type.ml | 15 ++++----- vendors/ligo-utils/tezos-utils/x_michelson.ml | 2 ++ 5 files changed, 38 insertions(+), 42 deletions(-) diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 37a9b7e20..6dc381f72 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -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 diff --git a/src/passes/8-compiler/compiler_environment.ml b/src/passes/8-compiler/compiler_environment.ml index 4f06f8446..d205c421b 100644 --- a/src/passes/8-compiler/compiler_environment.ml +++ b/src/passes/8-compiler/compiler_environment.ml @@ -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) *) diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index ef3d19395..5ec9d7a7c 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -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 diff --git a/src/passes/8-compiler/compiler_type.ml b/src/passes/8-compiler/compiler_type.ml index 34040b4d8..f7e04adb3 100644 --- a/src/passes/8-compiler/compiler_type.ml +++ b/src/passes/8-compiler/compiler_type.ml @@ -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 diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 1b94837b7..a922fa382 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -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