test for tail recursion

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

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:
 

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

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
+  let%bind applied = Self_ast_typed.all_program prog_typed in
-    | Contract entrypoint -> Self_ast_typed.all_contract entrypoint prog_typed
+  let%bind applied' = match cform with
-    | Env -> ok prog_typed in
+    | Contract entrypoint -> Self_ast_typed.all_contract entrypoint applied
-  ok @@ (prog_typed', state)
+    | 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 =

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) =

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

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

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