From 2a091edbc0c299c6239476f3f3bdd7a9a02ead1a Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 20 May 2019 16:17:26 +0000 Subject: [PATCH] transpile to mini_c expressions --- src/compiler/compiler_environment.ml | 20 ++- src/compiler/compiler_program.ml | 95 ++++++++---- src/contracts/assign.ligo | 4 + src/contracts/condition-simple.ligo | 8 + src/contracts/declaration-local.ligo | 3 + src/mini_c/PP.ml | 8 +- src/mini_c/combinators.ml | 27 ++-- src/mini_c/types.ml | 4 +- src/test/compiler_tests.ml | 26 +--- src/test/integration_tests.ml | 20 +++ src/test/test_helpers.ml | 2 +- src/transpiler/transpiler.ml | 220 ++++----------------------- 12 files changed, 181 insertions(+), 256 deletions(-) create mode 100644 src/contracts/assign.ligo create mode 100644 src/contracts/condition-simple.ligo create mode 100644 src/contracts/declaration-local.ligo diff --git a/src/compiler/compiler_environment.ml b/src/compiler/compiler_environment.ml index 2ea43b621..05c749095 100644 --- a/src/compiler/compiler_environment.ml +++ b/src/compiler/compiler_environment.ml @@ -135,11 +135,18 @@ let select : environment -> string list -> michelson result = fun e lst -> ok code -let clear : environment -> michelson result = fun e -> select e [] +let select_env : environment -> environment -> michelson result = fun source filter -> + let lst = Environment.get_names filter in + select source lst -let select_env : environment -> environment -> michelson result = fun e e' -> - let lst = Environment.get_names e' in - select e lst +let clear : environment -> (michelson * environment) result = fun e -> + let lst = Environment.get_names e in + let%bind first_name = + trace_option (simple_error "try to clear empty env") @@ + List.nth_opt lst 0 in + let%bind code = select e [ first_name ] in + let e' = Environment.select [ first_name ] e in + ok (code , e') let pack : environment -> michelson result = fun e -> let%bind () = @@ -276,3 +283,8 @@ let add_packed_anon : environment -> type_value -> michelson result = fun e type in ok code + +let pop : environment -> environment result = fun e -> + match e with + | [] -> simple_fail "pop empty env" + | _ :: tl -> ok tl diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index 4538bae16..141c7d54c 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -87,6 +87,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m let error_message () = Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_ ty in + let i_skip = i_push_unit in let return ?prepend_env ?end_env code = let%bind env' = @@ -123,6 +124,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m trace (error (thunk "compiling expression") error_message) @@ match expr' with + | E_skip -> return @@ i_skip | E_environment_capture c -> let%bind code = Compiler_environment.pack_select env c in return @@ code @@ -130,14 +132,26 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m let%bind (expr' , _) = translate_expression expr env in let%bind clear = Compiler_environment.select env [] in let%bind unpack = Compiler_environment.unpack load_env in - return ~end_env:load_env @@ seq [ + return ~prepend_env:load_env @@ seq [ expr' ; dip clear ; unpack ; + i_skip ; ] | E_environment_select sub_env -> let%bind code = Compiler_environment.select_env env sub_env in - return ~end_env:sub_env code + return ~prepend_env:sub_env @@ seq [ + code ; + i_skip ; + ] + | E_environment_return expr -> ( + let%bind (expr' , env) = translate_expression expr env in + let%bind (code , cleared_env) = Compiler_environment.clear env in + return ~end_env:cleared_env @@ seq [ + expr' ; + code ; + ] + ) | E_literal v -> let%bind v = translate_value v in let%bind t = Compiler_type.type_ ty in @@ -195,11 +209,21 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m return code | E_sequence (a , b) -> let%bind (a' , env_a) = translate_expression a env in - let%bind (b' , env_b) = translate_expression b env_a in - return ~prepend_env:env_b @@ seq [ + let%bind env_a' = Compiler_environment.pop env_a in + let%bind (b' , env_b) = translate_expression b env_a' in + return ~end_env:env_b @@ seq [ a' ; + i_drop ; b' ; ] + (* | E_sequence_drop (a , b) -> + * let%bind (a' , env_a) = translate_expression a env in + * let%bind (b' , env_b) = translate_expression b env_a in + * return ~end_env:env_b @@ seq [ + * a' ; + * i_drop ; + * b' ; + * ] *) | E_constant(str, lst) -> let module L = Logger.Stateful() in let%bind lst' = @@ -250,8 +274,9 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m return @@ i_none o' | E_if_bool (c, a, b) -> ( let%bind (c' , env') = translate_expression c env in - let%bind (a' , _) = translate_expression a env' in - let%bind (b' , _) = translate_expression b env' in + let%bind popped = Compiler_environment.pop env' in + let%bind (a' , _) = translate_expression a popped in + let%bind (b' , _) = translate_expression b popped in let%bind code = ok (seq [ c' ; i_if a' b' ; @@ -259,16 +284,18 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m return code ) | E_if_none (c, n, (ntv , s)) -> ( - let%bind (c' , _env') = translate_expression c env in - let%bind (n' , _) = translate_expression n env in - let s_env = Environment.add ntv env in - let%bind (s' , _) = translate_expression s s_env in - let%bind restrict_s = Compiler_environment.select_env s_env env in + let%bind (c' , env') = translate_expression c env in + let%bind popped = Compiler_environment.pop env' in + let%bind (n' , _) = translate_expression n popped in + let s_env = Environment.add ntv popped in + let%bind (s' , s_env') = translate_expression s s_env in + let%bind popped' = Compiler_environment.pop s_env' in + let%bind restrict_s = Compiler_environment.select_env popped' popped in let%bind code = ok (seq [ c' ; i_if_none n' (seq [ s' ; - restrict_s ; + dip restrict_s ; ]) ; ]) in @@ -298,10 +325,14 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m return code ) | E_let_in (v, expr , body) -> ( - let%bind (expr' , _) = translate_expression expr env in - let env' = Environment.add v env in - let%bind (body' , _) = translate_expression body env' in - let%bind restrict = Compiler_environment.select_env env' env in + let%bind (expr' , expr_env) = translate_expression expr env in + let%bind env' = + let%bind popped = Compiler_environment.pop expr_env in + ok @@ Environment.add v popped in + let%bind (body' , body_env) = translate_expression body env' in + let%bind restrict = + let%bind popped = Compiler_environment.pop body_env in + Compiler_environment.select_env popped env in let%bind code = ok (seq [ expr' ; body' ; @@ -312,6 +343,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m ) | E_assignment (name , lrs , expr) -> ( let%bind (expr' , env') = translate_expression expr env in + (* Format.printf "\nass env':%a\n" PP.environment env' ; *) let%bind get_code = Compiler_environment.get env' name in let modify_code = let aux acc step = match step with @@ -333,23 +365,33 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m in error title content in trace error @@ - return ~end_env:env @@ seq [ + return ~prepend_env:env @@ seq [ + i_comment "assign: start # env" ; expr' ; + i_comment "assign: compute rhs # rhs : env" ; get_code ; - i_swap ; modify_code ; + i_comment "assign: get name # name : rhs : env" ; + i_swap ; + i_comment "assign: swap # rhs : name : env" ; + modify_code ; + i_comment "assign: modify code # name+rhs : env" ; set_code ; + i_comment "assign: set new # new_env" ; + i_skip ; ] ) | E_while (expr, block) -> ( let%bind (expr' , env') = translate_expression expr env in - let%bind (block' , env'') = translate_expression block env' in - let%bind restrict_block = Compiler_environment.select_env env'' env' in + let%bind popped = Compiler_environment.pop env' in + let%bind (block' , env'') = translate_expression block popped in + let%bind restrict_block = Compiler_environment.select_env env'' popped in return @@ seq [ expr' ; prim ~children:[seq [ block' ; restrict_block ; expr']] I_LOOP ; + i_skip ; ] ) @@ -528,16 +570,12 @@ and translate_regular_block ((b, env):block) : michelson result = let code = seq (List.rev codes) in ok code -and translate_quote_body ({body;result} as f:anon_function) : michelson result = - let%bind body' = translate_regular_block body in - let%bind (expr , _) = translate_expression result (snd body).post_environment in - let%bind restrict = Compiler_environment.clear (snd body).post_environment in +and translate_quote_body ({result ; binder ; input} as f:anon_function) : michelson result = + let env = Environment.(add (binder , input) empty) in + let%bind (expr , _) = translate_expression result env in let code = seq [ - i_comment "function body" ; - body' ; i_comment "function result" ; expr ; - dip restrict ; ] in let%bind _assert_type = @@ -547,11 +585,10 @@ and translate_quote_body ({body;result} as f:anon_function) : michelson result = let output_stack_ty = Stack.(output_ty @: nil) in let error_message () = Format.asprintf - "\ncode : %a\ninput : %a\noutput : %a\nenv : %a\n" + "\ncode : %a\ninput : %a\noutput : %a\n" Michelson.pp code PP.type_ f.input PP.type_ f.output - PP.environment (snd body).post_environment in let%bind _ = Trace.trace_tzresult_lwt ( diff --git a/src/contracts/assign.ligo b/src/contracts/assign.ligo new file mode 100644 index 000000000..d882d0e40 --- /dev/null +++ b/src/contracts/assign.ligo @@ -0,0 +1,4 @@ +function main (const i : int) : int is + begin + i := i + 1 ; + end with i diff --git a/src/contracts/condition-simple.ligo b/src/contracts/condition-simple.ligo new file mode 100644 index 000000000..708d4c6b5 --- /dev/null +++ b/src/contracts/condition-simple.ligo @@ -0,0 +1,8 @@ +function main (const i : int) : int is + begin + if 1 = 1 then + i := 42 + else + i := 0 + end with i + diff --git a/src/contracts/declaration-local.ligo b/src/contracts/declaration-local.ligo new file mode 100644 index 000000000..94d443b32 --- /dev/null +++ b/src/contracts/declaration-local.ligo @@ -0,0 +1,3 @@ +function main (const i : int) : int is block { + const j : int = 42 ; +} with j diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 6209a624a..972707548 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -64,6 +64,8 @@ and expression' ppf (e:expression') = match e with | E_environment_capture s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s | E_environment_load (expr , env) -> fprintf ppf "load %a in %a" expression expr environment env | E_environment_select env -> fprintf ppf "select %a" environment env + | E_environment_return expr -> fprintf ppf "return %a" expression expr + | E_skip -> fprintf ppf "skip" | E_variable v -> fprintf ppf "%s" v | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b | E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst @@ -76,6 +78,7 @@ and expression' ppf (e:expression') = match e with | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r | E_sequence (a , b) -> fprintf ppf "%a ; %a" expression a expression b + (* | E_sequence_drop (a , b) -> fprintf ppf "%a ;- %a" expression a expression b *) | E_let_in ((name , _) , expr , body) -> fprintf ppf "let %s = %a in %a" name expression expr expression body | E_assignment (r , path , e) -> @@ -91,12 +94,11 @@ and expression_with_type : _ -> expression -> _ = fun ppf e -> expression' e.content type_ e.type_value -and function_ ppf ({binder ; input ; output ; body ; result}:anon_function) = - fprintf ppf "fun (%s:%a) : %a %a return %a" +and function_ ppf ({binder ; input ; output ; result}:anon_function) = + fprintf ppf "fun (%s:%a) : %a return %a" binder type_ input type_ output - block body expression result and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index 608b59648..d4528b24e 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -136,25 +136,34 @@ let t_deep_closure x y z : type_value = T_deep_closure ( x , y , z ) let t_pair x y : type_value = T_pair ( x , y ) let t_union x y : type_value = T_or ( x , y ) -let quote binder input output body result : anon_function = +let quote binder input output result : anon_function = { binder ; input ; output ; - body ; result ; + result ; } -let basic_quote i o b : anon_function result = - let%bind (_, _e) = get_last_statement b in - let r : expression = Expression.make_tpl (E_variable "output", o) in - ok @@ quote "input" i o b r - -let basic_int_quote b : anon_function result = - basic_quote t_int t_int b let e_int expr : expression = Expression.make_tpl (expr, t_int) let e_unit : expression = Expression.make_tpl (E_literal D_unit, t_unit) +let e_skip : expression = Expression.make_tpl (E_skip, t_unit) let e_var_int name : expression = e_int (E_variable name) +let e_let_int v tv expr body : expression = Expression.(make_tpl ( + E_let_in ((v , tv) , expr , body) , + get_type body + )) + +let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl (a , t_unit) , b) , get_type b)) + +let ez_e_return e : expression = Expression.(make_tpl ((E_environment_return e) , get_type e)) let d_unit : value = D_unit +let basic_quote i o expr : anon_function result = + ok @@ quote "input" i o (ez_e_return expr) + +let basic_int_quote expr : anon_function result = + basic_quote t_int t_int expr + + let environment_wrap pre_environment post_environment = { pre_environment ; post_environment } let id_environment_wrap e = environment_wrap e e diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 456770d23..b3f33be6b 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -56,6 +56,8 @@ and expression' = | E_environment_capture of selector | E_environment_select of environment | E_environment_load of (expression * environment) + | E_environment_return of expression + | E_skip | E_constant of string * expression list | E_application of expression * expression | E_variable of var_name @@ -67,6 +69,7 @@ and 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_sequence_drop of (expression * expression) *) | E_assignment of (string * [`Left | `Right] list * expression) | E_while of expression * expression @@ -98,7 +101,6 @@ and anon_function = { binder : string ; input : type_value ; output : type_value ; - body : block ; result : expression ; } diff --git a/src/test/compiler_tests.ml b/src/test/compiler_tests.ml index a6db44def..2424d0cd4 100644 --- a/src/test/compiler_tests.ml +++ b/src/test/compiler_tests.ml @@ -11,29 +11,19 @@ let run_entry_int (e:anon_function) (n:int) : int result = | _ -> simple_fail "result is not an int" let identity () : unit result = - let e = basic_int_quote_env in - let s = statement (S_declaration ("output", e_var_int "input")) e in - let%bind b = block [s] in - let%bind f = basic_int_quote b in + let%bind f = basic_int_quote (e_var_int "input") in let%bind result = run_entry_int f 42 in let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in ok () let multiple_vars () : unit result = - let e = basic_int_quote_env in - (* - Statements can change the environment, and you don't want to pass the new environment manually. - [statements] deals with this and this is why those statements are parametrized over an environment. - Yes. One could do a monad. Feel free when we have the time. - *) - let ss = statements [ - (fun e -> statement (S_declaration ("a", e_var_int "input")) e) ; - (fun e -> statement (S_declaration ("b", e_var_int "input")) e) ; - (fun e -> statement (S_declaration ("c", e_var_int "a")) e) ; - (fun e -> statement (S_declaration ("output", e_var_int "c")) e) ; - ] e in - let%bind b = block ss in - let%bind f = basic_int_quote b in + let expr = + e_let_int "a" t_int (e_var_int "input") @@ + e_let_int "b" t_int (e_var_int "input") @@ + e_let_int "c" t_int (e_var_int "a") @@ + e_let_int "output" t_int (e_var_int "c") @@ + e_var_int "output" in + let%bind f = basic_int_quote expr in let%bind result = run_entry_int f 42 in let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in ok () diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 5291a0119..5241f83a9 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -15,6 +15,11 @@ let function_ () : unit result = let make_expect = fun n -> n in expect_eq_n_int program "main" make_expect +let assign () : unit result = + let%bind program = type_file "./contracts/assign.ligo" in + let make_expect = fun n -> n + 1 in + expect_eq_n_int program "main" make_expect + let annotation () : unit result = let%bind program = type_file "./contracts/annotation.ligo" in let%bind () = @@ -311,6 +316,12 @@ let condition () : unit result = let make_expected = fun n -> e_a_int (if n = 2 then 42 else 0) in expect_eq_n program "main" make_input make_expected +let condition_simple () : unit result = + let%bind program = type_file "./contracts/condition-simple.ligo" in + let make_input = e_a_int in + let make_expected = fun _ -> e_a_int 42 in + expect_eq_n program "main" make_input make_expected + let loop () : unit result = let%bind program = type_file "./contracts/loop.ligo" in let%bind () = @@ -379,6 +390,12 @@ let declarations () : unit result = let make_expected = fun n -> e_a_int (42 + n) in expect_eq_n program "main" make_input make_expected +let declaration_local () : unit result = + let%bind program = type_file "./contracts/declaration-local.ligo" in + let make_input = e_a_int in + let make_expected = fun _ -> e_a_int 42 in + expect_eq_n program "main" make_input make_expected + let quote_declaration () : unit result = let%bind program = type_file "./contracts/quote-declaration.ligo" in let make_input = e_a_int in @@ -436,11 +453,14 @@ let guess_the_hash_mligo () : unit result = let main = "Integration (End to End)", [ test "function" function_ ; + test "assign" assign ; + test "declaration local" declaration_local ; test "complex function" complex_function ; test "variant" variant ; test "variant matching" variant_matching ; test "tuple" tuple ; test "record" record ; + test "condition simple" condition_simple ; test "condition" condition ; test "shadow" shadow ; test "annotation" annotation ; diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index e24e8ac48..b22d8a034 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -20,7 +20,7 @@ let expect ?options program entry_point input expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace run_error @@ - Ligo.easy_run_typed_simplified ~debug_michelson:false ?options entry_point program input in + Ligo.easy_run_typed_simplified ~debug_michelson:true ?options entry_point program input in expecter result let expect_eq ?options program entry_point input expected = diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 563ac59be..c21726105 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -119,107 +119,17 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string - bind_fold_list aux (ty , []) lr_path in ok lst -(* let rec translate_block env (b:AST.block) : block result = - * let aux = fun (precs, env) instruction -> - * let%bind lst = translate_instruction env instruction in - * let env' = List.fold_left (fun _ i -> (snd i).post_environment) env lst in (\* Get last environment *\) - * ok (precs @ lst, env') in - * let%bind (instructions, env') = bind_fold_list aux ([], env) b in - * ok (instructions, environment_wrap env env') - * - * and translate_instruction (env:Environment.t) (i:AST.instruction) : statement list result = - * let return ?(env' = env) x : statement list result = ok ([x, environment_wrap env env']) in - * match i with - * | I_declaration {name;annotated_expression} -> - * let%bind expression = translate_annotated_expression annotated_expression in - * let env' = Environment.add (name, (Combinators.Expression.get_type expression)) env in - * return ~env' (S_declaration (name, expression)) - * | I_assignment {name;annotated_expression} -> - * let%bind expression = translate_annotated_expression annotated_expression in - * return (S_assignment (name, expression)) - * | I_patch (r, s, v) -> ( - * let ty = r.type_value in - * let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result = - * fun (prev, acc) cur -> - * let%bind ty' = translate_type prev in - * match cur with - * | Access_tuple ind -> - * let%bind ty_lst = AST.Combinators.get_t_tuple prev in - * let%bind ty'_lst = bind_map_list translate_type ty_lst in - * let%bind path = tuple_access_to_lr ty' ty'_lst ind in - * let path' = List.map snd path in - * ok (List.nth ty_lst ind, acc @ path') - * | Access_record prop -> - * let%bind ty_map = - * let error = - * let title () = "accessing property on not a record" in - * let content () = Format.asprintf "%s on %a in %a" - * prop Ast_typed.PP.type_value prev Ast_typed.PP.instruction i in - * error title content - * in - * trace error @@ - * AST.Combinators.get_t_record prev in - * let%bind ty'_map = bind_map_smap translate_type ty_map in - * let%bind path = record_access_to_lr ty' ty'_map prop in - * let path' = List.map snd path in - * ok (Map.String.find prop ty_map, acc @ path') - * | Access_map _k -> simple_fail "no patch for map yet" - * in - * let%bind (_, path) = bind_fold_right_list aux (ty, []) s in - * let%bind v' = translate_annotated_expression v in - * return (S_patch (r.type_name, path, v')) - * ) - * | I_matching (expr, m) -> ( - * let%bind expr' = translate_annotated_expression expr in - * let env' = env in - * let return s = - * ok [ (s, environment_wrap env env) ] in - * match m with - * | Match_bool {match_true ; match_false} -> ( - * let%bind true_branch = translate_block env' match_true in - * let%bind false_branch = translate_block env' match_false in - * return @@ S_cond (expr', true_branch, false_branch) - * ) - * | Match_option {match_none ; match_some = ((name, t), sm)} -> ( - * let%bind none_branch = translate_block env' match_none in - * let%bind t' = translate_type t in - * let%bind some_branch = - * let env'' = Environment.add (name, t') env' in - * translate_block env'' sm - * in - * return @@ S_if_none (expr', none_branch, ((name, t'), some_branch)) - * ) - * | _ -> simple_fail "todo : match" - * ) - * | I_loop (expr, body) -> - * let%bind expr' = translate_annotated_expression expr in - * let%bind body' = translate_block env body in - * return (S_while (expr', body')) - * | I_skip -> ok [] - * | I_do ae -> ( - * let%bind ae' = translate_annotated_expression ae in - * return @@ S_do ae' - * ) *) - -let rec translate_block env (b:AST.block) : block result = - let aux = fun (precs, env) instruction -> - let%bind lst = translate_instruction env instruction in - let env' = List.fold_left (fun _ i -> (snd i).post_environment) env lst in (* Get last environment *) - ok (precs @ lst, env') in - let%bind (instructions, env') = bind_fold_list aux ([], env) b in - ok (instructions, environment_wrap env env') - -and translate_block' : expression option -> AST.block -> expression result = fun expr_opt block -> +let rec translate_block : expression option -> AST.block -> expression result = fun expr_opt block -> let aux = fun expr_opt i -> - let%bind expr = translate_instruction' i expr_opt in + let%bind expr = translate_instruction i expr_opt in ok (Some expr) in let%bind expr_opt = bind_fold_right_list aux expr_opt block in let default = e_unit in ok (Option.unopt ~default expr_opt) -and translate_instruction' : AST.instruction -> expression option -> expression result = fun i expr_opt -> +and translate_instruction : AST.instruction -> expression option -> expression result = fun i expr_opt -> let expr = - let default = e_unit in + let default = e_skip in Option.unopt ~default expr_opt in let return ?(tv = expr.type_value) expr' = ok @@ Combinators.Expression.make_tpl (expr' , tv) in let skip = ok expr in @@ -227,6 +137,11 @@ and translate_instruction' : AST.instruction -> expression option -> expression let lhs = Expression.make_tpl (expr' , t_unit) in let rhs = expr in ok @@ Combinators.Expression.make_tpl (E_sequence ( lhs , rhs ) , tv) in + let return_seq_drop ?(tv = expr.type_value) expr' = + let lhs = Expression.make_tpl (expr' , t_unit) in + let rhs = expr in + (* ok @@ Combinators.Expression.make_tpl (E_sequence_drop ( lhs , rhs ) , tv) in *) + ok @@ Combinators.Expression.make_tpl (E_sequence ( lhs , rhs ) , tv) in match i with | I_declaration { name ; annotated_expression } -> let%bind rhs = translate_annotated_expression annotated_expression in @@ -238,15 +153,15 @@ and translate_instruction' : AST.instruction -> expression option -> expression let%bind expr' = translate_annotated_expression matched in match clauses with | Match_bool {match_true ; match_false} -> - let%bind (t , f) = bind_map_pair (translate_block' None) (match_true, match_false) in - return_seq @@ E_if_bool (expr', t, f) + let%bind (t , f) = bind_map_pair (translate_block None) (match_true, match_false) in + return_seq_drop @@ E_if_bool (expr', t, f) | Match_option { match_none; match_some = ((name, tv), s) } -> - let%bind n = translate_block' None match_none in + let%bind n = translate_block None match_none in let%bind (tv' , s') = let%bind tv' = translate_type tv in - let%bind s' = translate_block' None s in + let%bind s' = translate_block None s in ok (tv' , s') in - return_seq @@ E_if_none (expr' , n , ((name , tv') , s')) + return_seq_drop @@ E_if_none (expr' , n , ((name , tv') , s')) | Match_variant (lst , variant) -> ( let%bind tree = tree_of_sum variant in let%bind tree' = match tree with @@ -272,7 +187,7 @@ and translate_instruction' : AST.instruction -> expression option -> expression let%bind ((_ , name) , body) = trace_option (simple_error "not supposed to happen here: missing match clause") @@ List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in - let%bind body' = translate_block' None body in + let%bind body' = translate_block None body in return @@ E_let_in ((name , tv) , top , body') ) | ((`Node (a , b)) , tv) -> @@ -288,7 +203,7 @@ and translate_instruction' : AST.instruction -> expression option -> expression let%bind e = aux (((Expression.make (E_variable "right") b_ty))) b in ok (b_var , e) in - return @@ E_if_left (top , a' , b') + return_seq_drop @@ E_if_left (top , a' , b') in aux expr' tree'' ) @@ -297,7 +212,7 @@ and translate_instruction' : AST.instruction -> expression option -> expression ) | I_loop (condition , body) -> let%bind condition' = translate_annotated_expression condition in - let%bind body' = translate_block' None body in + let%bind body' = translate_block None body in return_seq @@ E_while (condition' , body') | I_do action -> let%bind action' = translate_annotated_expression action in @@ -336,80 +251,6 @@ and translate_instruction' : AST.instruction -> expression option -> expression return_seq (E_assignment (typed_name.type_name, path, expr')) ) -and translate_instruction (env:Environment.t) (i:AST.instruction) : statement list result = - let return ?(env' = env) x : statement list result = ok ([x, environment_wrap env env']) in - match i with - | I_declaration {name;annotated_expression} -> - let%bind expression = translate_annotated_expression annotated_expression in - let env' = Environment.add (name, (Combinators.Expression.get_type expression)) env in - return ~env' (S_declaration (name, expression)) - | I_assignment {name;annotated_expression} -> - let%bind expression = translate_annotated_expression annotated_expression in - return (S_assignment (name, expression)) - | I_patch (r, s, v) -> ( - let ty = r.type_value in - let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result = - fun (prev, acc) cur -> - let%bind ty' = translate_type prev in - match cur with - | Access_tuple ind -> - let%bind ty_lst = AST.Combinators.get_t_tuple prev in - let%bind ty'_lst = bind_map_list translate_type ty_lst in - let%bind path = tuple_access_to_lr ty' ty'_lst ind in - let path' = List.map snd path in - ok (List.nth ty_lst ind, acc @ path') - | Access_record prop -> - let%bind ty_map = - let error = - let title () = "accessing property on not a record" in - let content () = Format.asprintf "%s on %a in %a" - prop Ast_typed.PP.type_value prev Ast_typed.PP.instruction i in - error title content - in - trace error @@ - AST.Combinators.get_t_record prev in - let%bind ty'_map = bind_map_smap translate_type ty_map in - let%bind path = record_access_to_lr ty' ty'_map prop in - let path' = List.map snd path in - ok (Map.String.find prop ty_map, acc @ path') - | Access_map _k -> simple_fail "no patch for map yet" - in - let%bind (_, path) = bind_fold_right_list aux (ty, []) s in - let%bind v' = translate_annotated_expression v in - return (S_patch (r.type_name, path, v')) - ) - | I_matching (expr, m) -> ( - let%bind expr' = translate_annotated_expression expr in - let env' = env in - let return s = - ok [ (s, environment_wrap env env) ] in - match m with - | Match_bool {match_true ; match_false} -> ( - let%bind true_branch = translate_block env' match_true in - let%bind false_branch = translate_block env' match_false in - return @@ S_cond (expr', true_branch, false_branch) - ) - | Match_option {match_none ; match_some = ((name, t), sm)} -> ( - let%bind none_branch = translate_block env' match_none in - let%bind t' = translate_type t in - let%bind some_branch = - let env'' = Environment.add (name, t') env' in - translate_block env'' sm - in - return @@ S_if_none (expr', none_branch, ((name, t'), some_branch)) - ) - | _ -> simple_fail "todo : match" - ) - | I_loop (expr, body) -> - let%bind expr' = translate_annotated_expression expr in - let%bind body' = translate_block env body in - return (S_while (expr', body')) - | I_skip -> ok [] - | I_do ae -> ( - let%bind ae' = translate_annotated_expression ae in - return @@ S_do ae' - ) - and translate_literal : AST.literal -> value = fun l -> match l with | Literal_bool b -> D_bool b | Literal_int n -> D_int n @@ -701,17 +542,16 @@ and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.express let init_env = Environment.(add (binder , raw_input) c_env) in let input = Environment.closure_representation init_env in let%bind output = translate_type output_type in - let%bind (statements , body_env) = translate_block init_env body in - let body = - let load_env = Environment.(add ("closure_arg" , input) empty) in - let load_expr = Expression.make_tpl (E_variable "closure_arg" , input) in - let load_st = Mini_c.statement (S_environment_load (load_expr , init_env)) load_env in - let statements' = load_st :: statements in - (statements' , body_env) - in - let%bind result = translate_annotated_expression result in + let%bind result = + let%bind result_expression = translate_annotated_expression result in + let%bind body_expression = translate_block (Some result_expression) body in + let%bind body_wrap_expression = + let load_expr = Expression.make_tpl (E_variable binder , input) in + ok @@ ez_e_return @@ ez_e_sequence (E_environment_load (load_expr , init_env)) body_expression + in + ok body_wrap_expression in let tv = Mini_c.t_function input output in - let f_literal = D_function { binder ; input ; output ; body ; result } in + let f_literal = D_function { binder ; input ; output ; result } in let expr = Expression.make_tpl (E_literal f_literal , tv) in ok (expr , raw_input , output) in let%bind c_expr = @@ -731,16 +571,14 @@ and translate_lambda env l = let%bind result = 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 body' = translate_block empty_env body in let%bind result' = translate_annotated_expression result in + let%bind body_expression = translate_block (Some result') body in + let body_wrapped = ez_e_return body_expression in trace (simple_error "translate quote") @@ 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 = D_function {binder;input;output;body=body';result=result'} in + let content = D_function {binder;input;output;result=body_wrapped} in ok @@ Combinators.Expression.make_tpl (E_literal content, tv) ) | _ -> (