diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index ada7a2d61..5f1b8edfa 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -560,6 +560,7 @@ module Combinators = struct type_value (T_sum map) None let t_function param result ?s () : type_value = type_value (T_function (param, result)) s + let t_shallow_closure param result ?s () : type_value = type_value (T_function (param, result)) s let get_annotation (x:annotated_expression) = x.type_annotation diff --git a/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml index 915f2fc87..e0b1caaec 100644 --- a/src/ligo/mini_c/combinators.ml +++ b/src/ligo/mini_c/combinators.ml @@ -80,6 +80,9 @@ let get_last_statement ((b', _):block) : statement result = let t_int : type_value = T_base Base_int let t_nat : type_value = T_base Base_nat +let t_function x y : type_value = T_function ( x , y ) +let t_pair x y : type_value = T_pair ( x , y ) + let quote binder input output body result : anon_function = let content : anon_function_content = { binder ; input ; output ; diff --git a/src/ligo/mini_c/compiler.ml b/src/ligo/mini_c/compiler.ml index 6163757a5..f21920a3f 100644 --- a/src/ligo/mini_c/compiler.ml +++ b/src/ligo/mini_c/compiler.ml @@ -203,8 +203,8 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul ] in ok code | E_function anon -> ( - match ty with - | T_function (_, _) -> + match anon.capture_type with + | No_capture -> let%bind body = translate_function_body anon in let%bind input_type = Compiler_type.type_ anon.input in let%bind output_type = Compiler_type.type_ anon.output in @@ -213,7 +213,7 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul i_pair ; ] in ok code - | T_deep_closure (small_env, _, _) -> + | Deep_capture small_env -> (* Capture the variable bounds, assemble them. On call, append the input. *) let%bind body = translate_function_body anon in let%bind capture = Environment.Small.to_mini_c_capture env small_env in @@ -228,19 +228,18 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul i_pair ; ] in ok code - | T_shallow_closure (_, _, _) -> + | Shallow_capture _ -> (* Capture the whole environment. *) let%bind body = translate_function_body anon in let%bind input_type = Compiler_type.type_ anon.input in let%bind output_type = Compiler_type.type_ anon.output in - let code = seq [ - dip i_dup ; i_swap ; - i_lambda input_type output_type body ; - i_piar ; - i_pair ; + let code = seq [ (* stack :: env *) + dip i_dup ; i_swap ; (* env :: stack :: env *) + i_lambda input_type output_type body ; (* lambda :: env :: stack :: env *) + i_piar ; (* (env * lambda) :: stack :: env *) + i_pair ; (* new_stack :: env *) ] in ok code - | _ -> simple_fail "expected function code" ) | E_Cond (c, a, b) -> ( let%bind c' = translate_expression c in @@ -431,7 +430,9 @@ and translate_function_body ({body;result} as f:anon_function_content) : michels let%bind body = translate_regular_block body in let%bind expr = translate_expression result in let code = seq [ + i_comment "function body" ; body ; + i_comment "function result" ; i_push_unit ; expr ; i_car ; dip i_drop ; ] in @@ -443,8 +444,10 @@ and translate_function_body ({body;result} as f:anon_function_content) : michels let output_stack_ty = Stack.(output_ty @: nil) in let error_message () = Format.asprintf - "\ncode : %a\n" + "\ncode : %a\ninput : %a\noutput : %a\n" Tezos_utils.Micheline.Michelson.pp code + PP.type_ f.input + PP.type_ f.output in let%bind _ = Trace.trace_tzresult_lwt ( diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index bfcd7da7a..6dd408479 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -288,7 +288,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express ok (E_make_none o, tv, env) | _ -> ok (E_constant (name, lst'), tv, env) ) - | E_lambda l -> translate_lambda env l tv + | E_lambda l -> translate_lambda env l | E_list lst -> let%bind t = Mini_c.Combinators.get_t_list tv in let%bind lst' = bind_map_list (translate_annotated_expression env) lst in @@ -320,7 +320,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express simple_fail "only match bool exprs are translated yet" ) -and translate_lambda_shallow env l tv = +and translate_lambda_shallow env l = let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in (* Shallow capture. Capture the whole environment. Extend it with a new scope. Append it the input. *) let%bind input = translate_type input_type in @@ -329,20 +329,20 @@ and translate_lambda_shallow env l tv = let%bind (_, e) as body = translate_block full_env body in let%bind result = translate_annotated_expression e.post_environment result in let capture_type = Shallow_capture sub_env in - let input = Environment.to_mini_c_type full_env in + let input' = Environment.to_mini_c_type full_env in let%bind output = translate_type output_type in - let content = {binder;input;output;body;result;capture_type} in + let tv = + let open Combinators in + let f = t_function input' output in + let env_type = Environment.to_mini_c_type env in + t_pair env_type f + in + let content = {binder;input=input';output;body;result;capture_type} in ok (E_function content, tv, env) -and translate_lambda env l tv = +and translate_lambda env l = let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in (* Try to translate it in an empty env, if it succeeds, transpiles it as a quote value, else, as a closure expression. *) - let%bind init_env = - let%bind input = translate_type input_type in - ok Environment.(add (binder, input) env) in - let%bind empty_env = - let%bind input = translate_type input_type in - ok Environment.(add (binder, input) empty) in let ((_body_bounds , body_fvs) , result_fvs) = AST.Free_variables.( let bindings = singleton binder in let ((body_bounds , _) as b) = block' bindings body in @@ -350,18 +350,22 @@ and translate_lambda env l tv = ) in match (body_fvs, result_fvs) with | [] , [] -> ( + let%bind empty_env = + let%bind input = translate_type input_type in + ok Environment.(add (binder, input) empty) in let%bind ((_, e) as body') = translate_block empty_env body in let%bind result' = translate_annotated_expression e.post_environment result in trace (simple_error "translate quote") @@ let capture_type = No_capture in let%bind input = translate_type input_type in let%bind output = translate_type output_type in + let tv = Combinators.t_function input output in let content = {binder;input;output;body=body';result=result';capture_type} in ok (E_literal (D_function {capture=None;content}), tv, env) ) | _ -> ( trace (simple_error "translate lambda shallow") @@ - translate_lambda_shallow init_env l tv + translate_lambda_shallow env l ) let translate_declaration env (d:AST.declaration) : toplevel_statement result = @@ -380,9 +384,8 @@ let translate_program (lst:AST.program) : program result = let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements -let translate_main (l:AST.lambda) (t:AST.type_value) : anon_function result = - let%bind t' = translate_type t in - let%bind (expr, _, _) = translate_lambda Environment.empty l t' in +let translate_main (l:AST.lambda) (_t:AST.type_value) : anon_function result = + let%bind (expr, _, _) = translate_lambda Environment.empty l in match expr with | E_literal (D_function f) -> ok f | _ -> simple_fail "main is not a function"