From 27f583266ee59795c628a8713da62e965c7d8df5 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Mon, 9 Mar 2020 11:26:13 +0100 Subject: [PATCH] test for tail recursion --- src/bin/expect_tests/contract_tests.ml | 4 +- src/bin/expect_tests/typer_error_tests.ml | 13 +++ src/main/compile/dune | 2 +- src/main/compile/of_simplified.ml | 9 +- src/passes/5-self_ast_typed/helpers.ml | 21 +++- src/passes/5-self_ast_typed/main.ml | 0 src/passes/5-self_ast_typed/self_ast_typed.ml | 13 ++- src/passes/5-self_ast_typed/tail_recursion.ml | 108 ++++++++++++++++++ .../error_no_tail_recursive_function.mligo | 3 + 9 files changed, 159 insertions(+), 14 deletions(-) create mode 100644 src/passes/5-self_ast_typed/main.ml create mode 100644 src/passes/5-self_ast_typed/tail_recursion.ml create mode 100644 src/test/contracts/negative/error_no_tail_recursive_function.mligo diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 1bb5d7969..de2524afe 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -1174,7 +1174,7 @@ let%expect_test _ = let%expect_test _ = run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#808 = #P in let p = rhs#808.0 in let s = rhs#808.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} +ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#809 = #P in let p = rhs#809.0 in let s = rhs#809.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} If you're not sure how to fix this error, you can @@ -1187,7 +1187,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#811 = #P in let p = rhs#811.0 in let s = rhs#811.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} +ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#812 = #P in let p = rhs#812.0 in let s = rhs#812.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} If you're not sure how to fix this error, you can diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index 48d53bcbd..b28509e3f 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -32,6 +32,19 @@ let%expect_test _ = ligo: in file "", line 0, characters 0-0. different kinds: {"a":"( (TO_list(operation)) * sum[Add -> int , Sub -> int] )","b":"sum[Add -> int , Sub -> int]"} + If you're not sure how to fix this error, you can + do one of the following: + + * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/ + * Ask a question on our Discord: https://discord.gg/9rhYaEt + * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new + * Check the changelog by running 'ligo changelog' |}]; + + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_no_tail_recursive_function.mligo"; "f"]; + [%expect {| + ligo: in file "error_no_tail_recursive_function.mligo", line 2, characters 14-21. Recursive call is only allowed as the last operation: {"function":"unvalid","location":"in file \"error_no_tail_recursive_function.mligo\", line 2, characters 14-21"} + + If you're not sure how to fix this error, you can do one of the following: diff --git a/src/main/compile/dune b/src/main/compile/dune index 7629e3d2b..98ff34494 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -9,10 +9,10 @@ interpreter ast_simplified self_ast_simplified - self_ast_typed typer_new typer ast_typed + self_ast_typed transpiler mini_c self_mini_c diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 6a948e6d5..433321da4 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -7,10 +7,11 @@ type form = let compile (cform: form) (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solver.state) result = let%bind (prog_typed , state) = Typer.type_program program in let () = Typer.Solver.discard_state state in - let%bind prog_typed' = match cform with - | Contract entrypoint -> Self_ast_typed.all_contract entrypoint prog_typed - | Env -> ok prog_typed in - ok @@ (prog_typed', state) + let%bind applied = Self_ast_typed.all_program prog_typed in + let%bind applied' = match cform with + | Contract entrypoint -> Self_ast_typed.all_contract entrypoint applied + | Env -> ok applied in + ok @@ (applied', state) let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression) : (Ast_typed.expression * Typer.Solver.state) result = diff --git a/src/passes/5-self_ast_typed/helpers.ml b/src/passes/5-self_ast_typed/helpers.ml index 153093b06..818cdccf5 100644 --- a/src/passes/5-self_ast_typed/helpers.ml +++ b/src/passes/5-self_ast_typed/helpers.ml @@ -25,6 +25,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini ok res ) | E_lambda { binder = _ ; result = e } + | E_recursive {lambda= {result=e}} | E_constructor {element=e} -> ( let%bind res = self init' e in ok res @@ -148,6 +149,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind result = self result in return @@ E_lambda { binder ; result } ) + | E_recursive { fun_name; fun_type; lambda = {binder;result}} -> ( + let%bind result = self result in + return @@ E_recursive { fun_name; fun_type; lambda = {binder;result}} + ) | E_constant c -> ( let%bind args = bind_map_list self c.arguments in return @@ E_constant {c with arguments=args} @@ -172,9 +177,9 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> let%bind some = map_expression f some in ok @@ Match_option { match_none ; match_some = (name , some, te) } ) - | Match_tuple ((names , e), _) -> ( + | Match_tuple ((names , e), te) -> ( let%bind e' = map_expression f e in - ok @@ Match_tuple ((names , e'), []) + ok @@ Match_tuple ((names , e'), te) ) | Match_variant (lst, te) -> ( let aux ((a , b) , e) = @@ -188,9 +193,9 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> and map_program : mapper -> program -> program result = fun m p -> let aux = fun (x : declaration) -> match x with - | Declaration_constant (v , e , i, env) -> ( + | Declaration_constant (n , e , i, env) -> ( let%bind e' = map_expression m e in - ok (Declaration_constant (v , e' , i, env)) + ok (Declaration_constant (n , e' , i, env)) ) in bind_map_list (bind_map_location aux) p @@ -260,6 +265,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,result) = self init' result in ok ( res, return @@ E_lambda { binder ; result }) ) + | E_recursive { fun_name; fun_type; lambda={binder;result}} -> ( + let%bind (res,result) = self init' result in + ok (res, return @@ E_recursive {fun_name; fun_type; lambda={binder;result}}) + ) | E_constant c -> ( let%bind (res,args) = bind_fold_map_list self init' c.arguments in ok (res, return @@ E_constant {c with arguments=args}) @@ -283,9 +292,9 @@ and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_exp let%bind (init, some) = fold_map_expression f init some in ok @@ (init, Match_option { match_none ; match_some = (name , some, te) }) ) - | Match_tuple ((names , e), _) -> ( + | Match_tuple ((names , e), te) -> ( let%bind (init, e') = fold_map_expression f init e in - ok @@ (init, Match_tuple ((names , e'), [])) + ok @@ (init, Match_tuple ((names , e'), te)) ) | Match_variant (lst, te) -> ( let aux init ((a , b) , e) = diff --git a/src/passes/5-self_ast_typed/main.ml b/src/passes/5-self_ast_typed/main.ml new file mode 100644 index 000000000..e69de29bb diff --git a/src/passes/5-self_ast_typed/self_ast_typed.ml b/src/passes/5-self_ast_typed/self_ast_typed.ml index 165a1825f..76bfbdf90 100644 --- a/src/passes/5-self_ast_typed/self_ast_typed.ml +++ b/src/passes/5-self_ast_typed/self_ast_typed.ml @@ -1,6 +1,8 @@ open Trace -let all_passes = [] +let all_passes = [ + Tail_recursion.peephole_expression +] let contract_passes = [ Contract_passes.self_typing ; @@ -22,3 +24,12 @@ let all_contract main_name prg = } in let all_p = List.map (fun pass -> Helpers.fold_map_program pass data) contract_passes in bind_chain_ignore_acc all_p prg +let all = [ + Tail_recursion.peephole_expression +] + +let map_expression = Helpers.map_expression + +let fold_expression = Helpers.fold_expression + +let fold_map_expression = Helpers.fold_map_expression diff --git a/src/passes/5-self_ast_typed/tail_recursion.ml b/src/passes/5-self_ast_typed/tail_recursion.ml new file mode 100644 index 000000000..5d22d6104 --- /dev/null +++ b/src/passes/5-self_ast_typed/tail_recursion.ml @@ -0,0 +1,108 @@ +open Ast_typed +open Trace + +module Errors = struct + let recursive_call_is_only_allowed_as_the_last_operation name loc () = + let title = (thunk ("Recursive call is only allowed as the last operation")) in + let message () = "" in + let data = [ + ("function" , fun () -> Format.asprintf "%a" PP.expression_variable name); + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () +end +open Errors + +let rec check_recursive_call : expression_variable -> bool -> expression -> unit result = fun n final_path e -> + match e.expression_content with + | E_literal _ -> ok () + | E_constant c -> + let%bind _ = bind_map_list (check_recursive_call n false) c.arguments in + ok () + | E_variable v -> ( + let%bind _ = trace_strong (recursive_call_is_only_allowed_as_the_last_operation n e.location) @@ + Assert.assert_true (final_path || n <> v) in + ok () + ) + | E_application {expr1;expr2} -> + let%bind _ = check_recursive_call n final_path expr1 in + let%bind _ = check_recursive_call n false expr2 in + ok () + | E_lambda {result;_} -> + let%bind _ = check_recursive_call n final_path result in + ok () + | E_recursive { fun_name; lambda} -> + let%bind _ = check_recursive_call fun_name true lambda.result in + ok () + | E_let_in {rhs;let_result;_} -> + let%bind _ = check_recursive_call n false rhs in + let%bind _ = check_recursive_call n final_path let_result in + ok () + | E_constructor {element;_} -> + let%bind _ = check_recursive_call n false element in + ok () + | E_matching {matchee;cases} -> + let%bind _ = check_recursive_call n false matchee in + let%bind _ = check_recursive_call_in_matching n final_path cases in + ok () + | E_record elm -> + let es = LMap.to_list elm in + let%bind _ = bind_map_list (check_recursive_call n false) es in + ok () + | E_record_accessor {expr;_} -> + let%bind _ = check_recursive_call n false expr in + ok () + | E_record_update {record;update;_} -> + let%bind _ = check_recursive_call n false record in + let%bind _ = check_recursive_call n false update in + ok () + | E_map eel | E_big_map eel-> + let aux (e1,e2) = + let%bind _ = check_recursive_call n false e1 in + let%bind _ = check_recursive_call n false e2 in + ok () + in + let%bind _ = bind_map_list aux eel in + ok () + | E_list el | E_set el -> + let%bind _ = bind_map_list (check_recursive_call n false) el in + ok () + | E_look_up (e1,e2) -> + let%bind _ = check_recursive_call n false e1 in + let%bind _ = check_recursive_call n false e2 in + ok () + +and check_recursive_call_in_matching = fun n final_path c -> + match c with + | Match_bool {match_true;match_false} -> + let%bind _ = check_recursive_call n final_path match_true in + let%bind _ = check_recursive_call n final_path match_false in + ok () + | Match_list {match_nil;match_cons=(_,_,e,_)} -> + let%bind _ = check_recursive_call n final_path match_nil in + let%bind _ = check_recursive_call n final_path e in + ok () + | Match_option {match_none; match_some=(_,e,_)} -> + let%bind _ = check_recursive_call n final_path match_none in + let%bind _ = check_recursive_call n final_path e in + ok () + | Match_tuple ((_,e),_) -> + let%bind _ = check_recursive_call n final_path e in + ok () + | Match_variant (l,_) -> + let aux (_,e) = + let%bind _ = check_recursive_call n final_path e in + ok () + in + let%bind _ = bind_map_list aux l in + ok () + + +let peephole_expression : expression -> expression result = fun e -> + let return expression_content = ok { e with expression_content } in + match e.expression_content with + | E_recursive {fun_name; lambda} as e-> ( + let%bind _ = check_recursive_call fun_name true lambda.result in + return e + ) + | e -> return e diff --git a/src/test/contracts/negative/error_no_tail_recursive_function.mligo b/src/test/contracts/negative/error_no_tail_recursive_function.mligo new file mode 100644 index 000000000..9ea4d149f --- /dev/null +++ b/src/test/contracts/negative/error_no_tail_recursive_function.mligo @@ -0,0 +1,3 @@ +let rec unvalid (n:int):int = + let res = unvalid (n) in + res + 1