From 660dcbb79f78ea3ba42782c584fbf3b9cec71014 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Thu, 12 Mar 2020 15:41:26 +0100 Subject: [PATCH] review 3 --- src/bin/expect_tests/contract_tests.ml | 4 +-- .../expect_tests/ligo_interpreter_tests.ml | 3 +- src/bin/expect_tests/typer_error_tests.ml | 2 +- src/passes/6-interpreter/interpreter.ml | 11 +++++-- src/passes/6-transpiler/transpiler.ml | 29 ++++++++++--------- src/passes/8-compiler/compiler_program.ml | 9 ++---- src/stages/ligo_interpreter/PP.ml | 3 +- src/stages/ligo_interpreter/types.ml | 1 + src/test/contracts/interpret_test.mligo | 7 +++++ test.mligo | 8 +++++ 10 files changed, 50 insertions(+), 27 deletions(-) create mode 100644 test.mligo diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 1bb5d7969..1acee5fbc 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#811 = #P in let p = rhs#811.0 in let s = rhs#811.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#814 = #P in let p = rhs#814.0 in let s = rhs#814.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/ligo_interpreter_tests.ml b/src/bin/expect_tests/ligo_interpreter_tests.ml index ac381ea71..3dbf06bde 100644 --- a/src/bin/expect_tests/ligo_interpreter_tests.ml +++ b/src/bin/expect_tests/ligo_interpreter_tests.ml @@ -53,4 +53,5 @@ let%expect_test _ = val s = { ; 1 : int ; 2 : int ; 3 : int} val set_add = { ; 0 = ({ ; 1 : int ; 2 : int ; 3 : int}) ; 1 = ({ ; 1 : int ; 2 : int ; 3 : int ; 4 : int}) ; 2 = ({ ; 1 : int}) } val set_iter_fail = "set_iter_fail" : failure - val set_mem = { ; 0 = (true) ; 1 = (false) ; 2 = (false) } |}] ; \ No newline at end of file + val set_mem = { ; 0 = (true) ; 1 = (false) ; 2 = (false) } + val recursion = 55 : int |}] ; \ No newline at end of file diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index b28509e3f..ecf5ce7e3 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -42,7 +42,7 @@ let%expect_test _ = 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"} + ligo: in file "error_no_tail_recursive_function.mligo", line 2, characters 14-21. Recursion must be achieved through tail-calls only: {"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 diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/6-interpreter/interpreter.ml index b93d0cf60..96957225c 100644 --- a/src/passes/6-interpreter/interpreter.ml +++ b/src/passes/6-interpreter/interpreter.ml @@ -277,10 +277,17 @@ and eval : Ast_typed.expression -> env -> value result let%bind args' = eval args env in let f_env' = Env.extend f_env (arg_names, args') in eval body f_env' + | V_Func_rec (_fun_name,_fun_type,lambda, _env) -> + let%bind args' = eval args env in + let f_env' = Env.extend env (lambda.binder,args') in + eval lambda.result f_env' | _ -> simple_fail "trying to apply on something that is not a function" ) - | E_lambda { binder; result;} -> + | E_lambda {binder; result;} -> ok @@ V_Func_val (binder,result,env) + | E_recursive {fun_name; fun_type;lambda} -> + let env' = Env.extend env (fun_name, V_Func_rec(fun_name,fun_type,lambda,env)) in + ok @@ V_Func_rec (fun_name,fun_type,lambda,env') | E_let_in { let_binder; rhs; let_result; _} -> let%bind rhs' = eval rhs env in eval let_result (Env.extend env (let_binder,rhs')) @@ -371,7 +378,7 @@ and eval : Ast_typed.expression -> env -> value result | _ -> simple_fail "not yet supported case" (* ((ctor,name),body) *) ) - | E_look_up _ | E_recursive _ -> + | E_look_up _ -> let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in simple_fail serr diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index bb959bcd5..3cf73747e 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -536,22 +536,23 @@ and transpile_recursive {fun_name; fun_type; lambda} = let%bind (body,l) = map_lambda fun_name loop_type result in ok @@ (Expression.make (E_closure {binder;body}) loop_type, binder::l) | _ -> - let%bind res = replace_callback fun_name loop_type e in + let%bind res = replace_callback fun_name loop_type false e in ok @@ (res, []) - and replace_callback : AST.expression_variable -> type_value -> AST.expression -> expression result = fun fun_name loop_type e -> + and replace_callback : AST.expression_variable -> type_value -> bool -> AST.expression -> expression result = fun fun_name loop_type shadowed e -> match e.expression_content with - E_let_in li -> - let%bind let_result = replace_callback fun_name loop_type li.let_result in + E_let_in li -> + let shadowed = shadowed || Var.equal li.let_binder fun_name in + let%bind let_result = replace_callback fun_name loop_type shadowed li.let_result in let%bind rhs = transpile_annotated_expression li.rhs in let%bind ty = transpile_type e.type_expression in ok @@ e_let_in li.let_binder ty li.inline rhs let_result | E_matching m -> let%bind ty = transpile_type e.type_expression in - matching fun_name loop_type m ty | + matching fun_name loop_type shadowed m ty | E_application {expr1;expr2} -> ( - match expr1.expression_content with - E_variable name when Var.equal fun_name name -> + match expr1.expression_content,shadowed with + E_variable name, false when Var.equal fun_name name -> let%bind expr = transpile_annotated_expression expr2 in ok @@ Expression.make (E_constant {cons_name=C_LOOP_CONTINUE;arguments=[expr]}) loop_type | _ -> @@ -561,18 +562,18 @@ and transpile_recursive {fun_name; fun_type; lambda} = _ -> let%bind expr = transpile_annotated_expression e in ok @@ Expression.make (E_constant {cons_name=C_LOOP_STOP;arguments=[expr]}) loop_type - and matching : AST.expression_variable -> type_value -> AST.matching -> type_value -> expression result = fun fun_name loop_type m ty -> + and matching : AST.expression_variable -> type_value -> bool -> AST.matching -> type_value -> expression result = fun fun_name loop_type shadowed m ty -> let return ret = ok @@ Expression.make ret @@ ty in let%bind expr = transpile_annotated_expression m.matchee in match m.cases with Match_bool {match_true; match_false} -> - let%bind (t , f) = bind_map_pair (replace_callback fun_name loop_type) (match_true, match_false) in + let%bind (t , f) = bind_map_pair (replace_callback fun_name loop_type shadowed) (match_true, match_false) in return @@ E_if_bool (expr, t, f) | Match_option { match_none; match_some = (name, s, tv) } -> - let%bind n = replace_callback fun_name loop_type match_none in + let%bind n = replace_callback fun_name loop_type shadowed match_none in let%bind (tv' , s') = let%bind tv' = transpile_type tv in - let%bind s' = replace_callback fun_name loop_type s in + let%bind s' = replace_callback fun_name loop_type shadowed s in ok (tv' , s') in return @@ E_if_none (expr , n , ((name , tv') , s')) @@ -580,10 +581,10 @@ and transpile_recursive {fun_name; fun_type; lambda} = match_nil ; match_cons = ((hd_name) , (tl_name), match_cons, ty) ; } -> ( - let%bind nil = replace_callback fun_name loop_type match_nil in + let%bind nil = replace_callback fun_name loop_type shadowed match_nil in let%bind cons = let%bind ty' = transpile_type ty in - let%bind match_cons' = replace_callback fun_name loop_type match_cons in + let%bind match_cons' = replace_callback fun_name loop_type shadowed match_cons in ok (((hd_name , ty') , (tl_name , ty')) , match_cons') in return @@ E_if_cons (expr , nil , cons) @@ -614,7 +615,7 @@ and transpile_recursive {fun_name; fun_type; lambda} = let%bind ((_ , name) , body) = trace_option (corner_case ~loc:__LOC__ "missing match clause") @@ List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in - let%bind body' = replace_callback fun_name loop_type body in + let%bind body' = replace_callback fun_name loop_type shadowed body in return @@ E_let_in ((name , tv) , false , top , body') ) | ((`Node (a , b)) , tv) -> diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 6d24bd06b..9a2001298 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -59,13 +59,12 @@ let rec get_operator : constant' -> type_value -> expression list -> predicate r | C_LOOP_CONTINUE -> ( let%bind (_,ty) = get_t_or ty in let%bind m_ty = Compiler_type.type_ ty in - let m_ty' = t_pair t_unit m_ty in - ok @@ simple_unary @@ prim ~children:[m_ty'] I_LEFT + ok @@ simple_unary @@ prim ~children:[m_ty] I_LEFT ) | C_LOOP_STOP -> ( let%bind (ty, _) = get_t_or ty in let%bind m_ty = Compiler_type.type_ ty in - ok @@ simple_unary @@ seq [ i_push_unit; i_pair; prim ~children:[m_ty] I_RIGHT] + ok @@ simple_unary @@ prim ~children:[m_ty] I_RIGHT ) | C_SET_EMPTY -> ( let%bind ty' = Mini_c.get_t_set ty in @@ -410,12 +409,10 @@ and translate_expression (expr:expression) (env:environment) : michelson result | C_LOOP_LEFT -> ( let%bind (_, ty) = get_t_or (snd v) in let%bind m_ty = Compiler_type.type_ ty in - let m_ty' = t_pair t_unit m_ty in let%bind code = ok (seq [ expr' ; - prim ~children:[m_ty'] I_LEFT; + prim ~children:[m_ty] I_LEFT; i_loop_left body'; - prim I_CDR ]) in return code ) diff --git a/src/stages/ligo_interpreter/PP.ml b/src/stages/ligo_interpreter/PP.ml index b47b4993a..d0e419136 100644 --- a/src/stages/ligo_interpreter/PP.ml +++ b/src/stages/ligo_interpreter/PP.ml @@ -19,6 +19,7 @@ let rec pp_value : value -> string = function recmap "" in Format.asprintf "{ %s }" content | V_Func_val _ -> Format.asprintf "" + | V_Func_rec _ -> Format.asprintf "" | V_Construct (name,v) -> Format.asprintf "%s(%s)" name (pp_value v) | V_List vl -> Format.asprintf "[%s]" @@ @@ -36,4 +37,4 @@ let pp_env : env -> unit = fun env -> Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v)) env in let () = Format.printf "\n}\n" in - () \ No newline at end of file + () diff --git a/src/stages/ligo_interpreter/types.ml b/src/stages/ligo_interpreter/types.ml index 4cd8e79ad..b9f9a7e5e 100644 --- a/src/stages/ligo_interpreter/types.ml +++ b/src/stages/ligo_interpreter/types.ml @@ -31,6 +31,7 @@ and constant_val = and value = | V_Func_val of (expression_variable * Ast_typed.expression * env) + | V_Func_rec of (expression_variable * Ast_typed.type_expression * Ast_typed.lambda * env) | V_Ct of constant_val | V_List of value list | V_Record of value label_map diff --git a/src/test/contracts/interpret_test.mligo b/src/test/contracts/interpret_test.mligo index c06113589..ebabbcf53 100644 --- a/src/test/contracts/interpret_test.mligo +++ b/src/test/contracts/interpret_test.mligo @@ -232,3 +232,10 @@ let set_mem = Set.mem 1 s, Set.mem 4 s, Set.mem 1 (Set.empty : int set) + +let recursion = + let rec sum : int*int -> int = fun ((n,res):int*int) -> + let i = 1 in + if (n<1) then res else sum (n-i,res+n) + in + sum (10,0) diff --git a/test.mligo b/test.mligo new file mode 100644 index 000000000..f197fc1da --- /dev/null +++ b/test.mligo @@ -0,0 +1,8 @@ +let rec fibo2 ((n,n_1,n_0):int*int*int) : int = + let fibo2 : int -> int = fun (k : int) -> k in + if (n < 2) then n_1 else fibo2 3 + +let main (p,s : unit * int) : operation list * int = + let x : int = fibo2 (5, 1, 1) in + (([] : operation list), x) +