diff --git a/src/passes/6-transpiler/dune b/src/passes/6-transpiler/dune index 3f483bda3..a547714f0 100644 --- a/src/passes/6-transpiler/dune +++ b/src/passes/6-transpiler/dune @@ -6,6 +6,7 @@ tezos-utils ast_typed mini_c + self_mini_c operators ) (preprocess diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index db7fe394a..0cef7b26b 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -224,12 +224,20 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele -> match (AST.get_type' ele.type_value , ele.definition) with - | (AST.T_function (f , arg) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) -> - let%bind f' = transpile_type f in - let%bind arg' = transpile_type arg in - let%bind env' = transpile_environment ae.environment in - let sub_env = Mini_c.Environment.select captured_variables env' in - ok @@ Combinators.t_deep_closure sub_env f' arg' + | (AST.T_function (arg , ret) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) -> + begin + match ae.expression with + | E_lambda _ -> + let%bind ret' = transpile_type ret in + let%bind arg' = transpile_type arg in + let%bind env' = transpile_environment ae.environment in + let sub_env = Mini_c.Environment.select captured_variables env' in + if sub_env = [] then + transpile_type ele.type_value + else + ok @@ Combinators.t_deep_closure sub_env arg' ret' + | _ -> transpile_type ele.type_value + end | _ -> transpile_type ele.type_value and transpile_small_environment : AST.small_environment -> Environment.t result = fun x -> @@ -275,7 +283,21 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re | E_application (a, b) -> let%bind a = transpile_annotated_expression a in let%bind b = transpile_annotated_expression b in - return @@ E_application (a, b) + let%bind contains_closure = + Self_mini_c.Helpers.fold_type_value + (fun contains_closure exp -> + ok (contains_closure + || match exp with + | T_deep_closure _ -> true + | _ -> false)) + false + b.type_value in + if contains_closure + then + let errmsg = Format.asprintf "Cannot apply closure in function arguments: %a\n" + Mini_c.PP.expression_with_type b in + fail @@ simple_error errmsg + else return @@ E_application (a, b) | E_constructor (m, param) -> ( let%bind param' = transpile_annotated_expression param in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in diff --git a/src/passes/7-self_mini_c/dune b/src/passes/7-self_mini_c/dune new file mode 100644 index 000000000..ec9f97639 --- /dev/null +++ b/src/passes/7-self_mini_c/dune @@ -0,0 +1,11 @@ +(library + (name self_mini_c) + (public_name ligo.self_mini_c) + (libraries + mini_c + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/7-self_mini_c/helpers.ml b/src/passes/7-self_mini_c/helpers.ml new file mode 100644 index 000000000..9904a8083 --- /dev/null +++ b/src/passes/7-self_mini_c/helpers.ml @@ -0,0 +1,160 @@ +open Mini_c +open Trace + +let rec fold_type_value : ('a -> type_value -> 'a result) -> 'a -> type_value -> 'a result = fun f init t -> + let self = fold_type_value f in + let%bind init' = f init t in + match t with + | T_pair ((_, a), (_, b)) + | T_or ((_, a), (_, b)) + | T_function (a, b) + | T_map (a, b) + | T_big_map (a, b) -> + bind_fold_pair self init' (a, b) + | T_deep_closure (env, a, b) -> + bind_fold_list self init' (List.map snd env @ [a; b]) + | T_list a + | T_set a + | T_contract a + | T_option a -> + self init' a + | T_base _ -> + ok init' + +type 'a folder = 'a -> expression -> 'a result +let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> + let self = fold_expression f in + let%bind init' = f init e in + match e.content with + | E_variable _ | E_skip | E_make_none _ + | E_make_empty_map (_,_) | E_make_empty_list _ + | E_make_empty_set _ -> ( + ok init' + ) + | E_literal v -> ( + match v with + | D_function an -> self init' an.body + | _ -> ok init' + ) + | E_constant (_, lst) -> ( + let%bind res = bind_fold_list self init' lst in + ok res + ) + | E_closure af -> ( + let%bind res = self init' af.body in + ok res + ) + | E_application farg -> ( + let%bind res = bind_fold_pair self init' farg in + ok res + ) + | E_iterator (_, ((_ , _) , body) , exp) -> ( + let%bind res = bind_fold_pair self init' (exp,body) in + ok res + ) + | E_fold (((_ , _) , body) , col , init) -> ( + let%bind res = bind_fold_triple self init' (body,col,init) in + ok res + ) + | E_while eb -> ( + let%bind res = bind_fold_pair self init' eb in + ok res + ) + | E_if_bool cab -> ( + let%bind res = bind_fold_triple self init' cab in + ok res + ) + | E_if_none (c, n, ((_, _) , s)) -> ( + let%bind res = bind_fold_triple self init' (c,n,s) in + ok res + ) + | E_if_cons (c, n, (((_, _) , (_, _)) , cons)) -> ( + let%bind res = bind_fold_triple self init' (c,n,cons) in + ok res + ) + | E_if_left (c, ((_, _) , l), ((_, _) , r)) -> ( + let%bind res = bind_fold_triple self init' (c,l,r) in + ok res + ) + | E_let_in ((_, _) , expr , body) -> ( + let%bind res = bind_fold_pair self init' (expr,body) in + ok res + ) + | E_sequence ab -> ( + let%bind res = bind_fold_pair self init' ab in + ok res + ) + | E_assignment (_, _, exp) -> ( + let%bind res = self init' exp in + ok res + ) + +type mapper = expression -> expression result + +let rec map_expression : mapper -> expression -> expression result = fun f e -> + let self = map_expression f in + let%bind e' = f e in + let return content = ok { e' with content } in + match e'.content with + | E_variable _ | E_skip | E_make_none _ + | E_make_empty_map (_,_) | E_make_empty_list _ | E_make_empty_set _ as em -> return em + | E_literal v -> ( + let%bind v' = match v with + | D_function an -> + let%bind body = self an.body in + ok @@ D_function { an with body } + | _ -> ok v in + return @@ E_literal v' + ) + | E_constant (name, lst) -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_constant (name,lst') + ) + | E_closure af -> ( + let%bind body = self af.body in + return @@ E_closure { af with body } + ) + | E_application farg -> ( + let%bind farg' = bind_map_pair self farg in + return @@ E_application farg' + ) + | E_iterator (s, ((name , tv) , body) , exp) -> ( + let%bind (exp',body') = bind_map_pair self (exp,body) in + return @@ E_iterator (s, ((name , tv) , body') , exp') + ) + | E_fold (((name , tv) , body) , col , init) -> ( + let%bind (body',col',init') = bind_map_triple self (body,col,init) in + return @@ E_fold (((name , tv) , body') , col', init') + ) + | E_while eb -> ( + let%bind eb' = bind_map_pair self eb in + return @@ E_while eb' + ) + | E_if_bool cab -> ( + let%bind cab' = bind_map_triple self cab in + return @@ E_if_bool cab' + ) + | E_if_none (c, n, ((name, tv) , s)) -> ( + let%bind (c',n',s') = bind_map_triple self (c,n,s) in + return @@ E_if_none (c', n', ((name, tv) , s')) + ) + | E_if_cons (c, n, (((hd, hdtv) , (tl, tltv)) , cons)) -> ( + let%bind (c',n',cons') = bind_map_triple self (c,n,cons) in + return @@ E_if_cons (c', n', (((hd, hdtv) , (tl, tltv)) , cons')) + ) + | E_if_left (c, ((name_l, tvl) , l), ((name_r, tvr) , r)) -> ( + let%bind (c',l',r') = bind_map_triple self (c,l,r) in + return @@ E_if_left (c', ((name_l, tvl) , l'), ((name_r, tvr) , r')) + ) + | E_let_in ((v , tv) , expr , body) -> ( + let%bind (expr',body') = bind_map_pair self (expr,body) in + return @@ E_let_in ((v , tv) , expr' , body') + ) + | E_sequence ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_sequence ab' + ) + | E_assignment (s, lrl, exp) -> ( + let%bind exp' = self exp in + return @@ E_assignment (s, lrl, exp') + ) diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index 7b7f1093d..5901b7dc6 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -64,7 +64,7 @@ and expression' = | E_closure of anon_function | E_skip | E_constant of string * expression list - | E_application of expression * expression + | E_application of (expression * expression) | E_variable of var_name | E_make_empty_map of (type_value * type_value) | E_make_empty_list of type_value @@ -72,14 +72,14 @@ and expression' = | E_make_none of type_value | E_iterator of (string * ((var_name * type_value) * expression) * expression) | E_fold of (((var_name * type_value) * expression) * expression * expression) - | E_if_bool of expression * expression * expression + | E_if_bool of (expression * expression * expression) | E_if_none of expression * expression * ((var_name * type_value) * expression) | E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression)) | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) | E_let_in of ((var_name * type_value) * expression * expression) | E_sequence of (expression * expression) | E_assignment of (string * [`Left | `Right] list * expression) - | E_while of expression * expression + | E_while of (expression * expression) and expression = { content : expression' ; diff --git a/src/test/contracts/high-order.ligo b/src/test/contracts/high-order.ligo index 7c897d4ee..d3c83170a 100644 --- a/src/test/contracts/high-order.ligo +++ b/src/test/contracts/high-order.ligo @@ -1,8 +1,37 @@ // Test a PascaLIGO function which takes another PascaLIGO function as an argument - function foobar (const i : int) : int is function foo (const i : int) : int is block { skip } with i ; function bar (const f : int -> int) : int is block { skip } with f ( i ) ; block { skip } with bar (foo) ; + +// higher order function with more than one argument +function higher2(const i: int; const f: int -> int): int is + block { + const ii: int = f(i) + } with ii + +function foobar2 (const i : int) : int is + function foo2 (const i : int) : int is + block { skip } with i; + block { skip } with higher2(i,foo2) + +// This is not supported yet: +// const a : int = 123; +// function foobar3 (const i : int) : int is +// function foo2 (const i : int) : int is +// block { skip } with (a+i); +// block { skip } with higher2(i,foo2) + +function f (const i : int) : int is + block { skip } + with i + +function g (const i : int) : int is + block { skip } + with f(i) + +function foobar4 (const i : int) : int is + block { skip } + with g(g(i)) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index fbc966747..16a4c7d69 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -111,7 +111,12 @@ let shadow () : unit result = let higher_order () : unit result = let%bind program = type_file "./contracts/high-order.ligo" in let make_expect = fun n -> n in - expect_eq_n_int program "foobar" make_expect + let%bind _ = expect_eq_n_int program "foobar" make_expect in + let%bind _ = expect_eq_n_int program "foobar2" make_expect in + (* not supported yet: + let%bind _ = expect_eq_n_int program "foobar3" make_expect in *) + let%bind _ = expect_eq_n_int program "foobar4" make_expect in + ok () let shared_function () : unit result = let%bind program = type_file "./contracts/function-shared.ligo" in diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 329203a46..54f69246e 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -592,6 +592,20 @@ let bind_fold_list f init lst = in List.fold_left aux (ok init) lst +let bind_fold_pair f init (a,b) = + let aux x y = + x >>? fun x -> + f x y + in + List.fold_left aux (ok init) [a;b] + +let bind_fold_triple f init (a,b,c) = + let aux x y = + x >>? fun x -> + f x y + in + List.fold_left aux (ok init) [a;b;c] + let bind_fold_map_list = fun f acc lst -> let rec aux (acc , prev) f = function | [] -> ok (acc , prev) @@ -661,10 +675,17 @@ let bind_and (a, b) = a >>? fun a -> b >>? fun b -> ok (a, b) +let bind_and3 (a, b, c) = + a >>? fun a -> + b >>? fun b -> + c >>? fun c -> + ok (a, b, c) let bind_pair = bind_and let bind_map_pair f (a, b) = bind_pair (f a, f b) +let bind_map_triple f (a, b, c) = + bind_and3 (f a, f b, f c) (**