diff --git a/FML/bin/bitecode.t b/FML/bin/bitecode.t new file mode 100644 index 000000000..9741cb8af --- /dev/null +++ b/FML/bin/bitecode.t @@ -0,0 +1,146 @@ + $ ./compiler.exe < manytests/typed/001fac.ml + $ cat < out.ll + ; ModuleID = 'FML' + source_filename = "FML" + target triple = "x86_64-pc-linux-gnu" + + declare i64 @new_closure(i64, i64) + + declare i64 @apply_args(i64, i64, i64, ...) + + declare i64 @print_int(i64) + + declare i64 @rt_add(i64, i64) + + declare i64 @rt_sub(i64, i64) + + declare i64 @rt_mul(i64, i64) + + declare i64 @rt_div(i64, i64) + + declare i64 @rt_leq(i64, i64) + + declare i64 @rt_less(i64, i64) + + declare i64 @rt_geq(i64, i64) + + declare i64 @rt_gre(i64, i64) + + declare i64 @rt_eq(i64, i64) + + declare i64 @rt_neq(i64, i64) + + declare i64 @rt_and(i64, i64) + + declare i64 @rt_or(i64, i64) + + declare i64 @fail_match(i64) + + define i64 @fac(i64 %n) { + entry: + %sle = icmp sle i64 %n, 1 + %sle_i64t = zext i1 %sle to i64 + %cond_v = icmp ne i64 %sle_i64t, 0 + br i1 %cond_v, label %then, label %else + + then: ; preds = %entry + br label %merge + + else: ; preds = %entry + %sub = sub i64 %n, 1 + %call = call i64 @fac(i64 %sub) + %mul = mul i64 %n, %call + br label %merge + + merge: ; preds = %else, %then + %phi = phi i64 [ 1, %then ], [ %mul, %else ] + ret i64 %phi + } + + define i64 @main() { + entry: + %call = call i64 @fac(i64 4) + %call1 = call i64 @print_int(i64 %call) + ret i64 0 + } + + $ ./compiler.exe < manytests/typed/002fac.ml + $ cat < out.ll + ; ModuleID = 'FML' + source_filename = "FML" + target triple = "x86_64-pc-linux-gnu" + + declare i64 @new_closure(i64, i64) + + declare i64 @apply_args(i64, i64, i64, ...) + + declare i64 @print_int(i64) + + declare i64 @rt_add(i64, i64) + + declare i64 @rt_sub(i64, i64) + + declare i64 @rt_mul(i64, i64) + + declare i64 @rt_div(i64, i64) + + declare i64 @rt_leq(i64, i64) + + declare i64 @rt_less(i64, i64) + + declare i64 @rt_geq(i64, i64) + + declare i64 @rt_gre(i64, i64) + + declare i64 @rt_eq(i64, i64) + + declare i64 @rt_neq(i64, i64) + + declare i64 @rt_and(i64, i64) + + declare i64 @rt_or(i64, i64) + + declare i64 @fail_match(i64) + + define i64 @lam_ll0(i64 %k, i64 %n, i64 %p) { + entry: + %mul = mul i64 %p, %n + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 %mul) + ret i64 %applied_closure + } + + define i64 @fac_cps(i64 %n, i64 %k) { + entry: + %eq = icmp eq i64 %n, 1 + %eq_i64t = zext i1 %eq to i64 + %cond_v = icmp ne i64 %eq_i64t, 0 + br i1 %cond_v, label %then, label %else + + then: ; preds = %entry + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 1) + br label %merge + + else: ; preds = %entry + %empty_closure = call i64 @new_closure(i64 ptrtoint (ptr @lam_ll0 to i64), i64 3) + %applied_closure1 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 2, i64 %k, i64 %n) + %sub = sub i64 %n, 1 + %call = call i64 @fac_cps(i64 %sub, i64 %applied_closure1) + br label %merge + + merge: ; preds = %else, %then + %phi = phi i64 [ %applied_closure, %then ], [ %call, %else ] + ret i64 %phi + } + + define i64 @lam_ll1(i64 %print_int_ac0) { + entry: + ret i64 %print_int_ac0 + } + + define i64 @main() { + entry: + %empty_closure = call i64 @new_closure(i64 ptrtoint (ptr @lam_ll1 to i64), i64 1) + %call = call i64 @fac_cps(i64 4, i64 %empty_closure) + %call1 = call i64 @print_int(i64 %call) + ret i64 0 + } diff --git a/FML/bin/compiler.ml b/FML/bin/compiler.ml new file mode 100644 index 000000000..62e86b02a --- /dev/null +++ b/FML/bin/compiler.ml @@ -0,0 +1,26 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match Parser.parse input with + | Ok parsed -> + (match Inferencer.run_program_inferencer parsed with + | Ok types -> Ok (parsed, types) + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok (ast, _) -> + let ast = A_conv.ac_program ast in + let ast_me = Match_elimination.match_elimination ast in + let ast_cc = C_conv.cc_program ast_me in + let ast_ll = Lambda_lift.lambda_lift ast_cc in + let ast_anf = Anf.anf ast_ll in + Codegen.compile_program ast_anf + | Error message -> Format.printf "%s" message +;; diff --git a/FML/bin/dune b/FML/bin/dune index e69de29bb..d63383e2c 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -0,0 +1,62 @@ +(executable + (name compiler) + (public_name compliler) + (modules compiler) + (libraries fml_lib stdio)) + +(cram + (deps ./x013.ml_test.txt)) + +(cram + (applies_to bitecode) + (deps + ./compiler.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to llvm_exec) + (deps + ./compiler.exe + ../lib/llvm/runtime.o + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + ; manytests/typed/x013.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t new file mode 100644 index 000000000..9c12a0c04 --- /dev/null +++ b/FML/bin/llvm_exec.t @@ -0,0 +1,65 @@ + $ ./compiler.exe < manytests/typed/001fac.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 001fac + $ ./001fac + 24 + + $ ./compiler.exe < manytests/typed/002fac.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 002fac + $ ./002fac + 24 + + $ ./compiler.exe < manytests/typed/003fib.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 003fib + $ ./003fib + 33 + + $ ./compiler.exe < manytests/typed/004manyargs.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 004manyargs + $ ./004manyargs + 1111111111110100 + + $ ./compiler.exe < manytests/typed/005fix.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 005fix + $ ./005fix + 720 + + $ ./compiler.exe < manytests/typed/006partial.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 006partial + $ ./006partial + 1122 + + $ ./compiler.exe < manytests/typed/006partial2.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 006partial2 + $ ./006partial2 + 1237 + + $ ./compiler.exe < manytests/typed/006partial3.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 006partial3 + $ ./006partial3 + 489 + + $ ./compiler.exe < manytests/typed/007order.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 007order + $ ./007order + -1421103-55555510000 + + $ ./compiler.exe < manytests/typed/008ascription.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 008ascription + $ ./008ascription + 8 + + $ ./compiler.exe < manytests/typed/012fibcps.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 012fibcps && rm out.ll + $ ./012fibcps && rm -f out.ll + 8 + +$ ls manytests/typed + $ ocaml -w -26 ./x013.ml_test.txt + 1111111111 + + $ ./compiler.exe < ./x013.ml_test.txt + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 013 + $ ./013 + 1111111111 + + diff --git a/FML/bin/manytests b/FML/bin/manytests new file mode 120000 index 000000000..0bd48791d --- /dev/null +++ b/FML/bin/manytests @@ -0,0 +1 @@ +../../manytests \ No newline at end of file diff --git a/FML/bin/x013.ml_test.txt b/FML/bin/x013.ml_test.txt new file mode 100644 index 000000000..1cf8f5d95 --- /dev/null +++ b/FML/bin/x013.ml_test.txt @@ -0,0 +1,18 @@ +let wrap f = if 1 = 1 then f else f + +let test3 a b c = + let a = print_int a in + let b = print_int b in + let c = print_int c in + 0 + +let apply_args a b c d e f g h i j = a + b + c + d + e + f + g + h + i + j + +let main = + let rez = + (wrap apply_args 1 10 100 1000 10000 100000 1000000 10000000 100000000 + 1000000000) + in + let () = print_int rez in + 0 + diff --git a/FML/lib/anf/a_conv.ml b/FML/lib/anf/a_conv.ml new file mode 100644 index 000000000..1cd372f2c --- /dev/null +++ b/FML/lib/anf/a_conv.ml @@ -0,0 +1,136 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Base +open Ast +open Common +open StateMonad + +let get_new_id n name = String.concat [ name; "_ac"; Int.to_string n ] + +let rec ac_pattern env bindings = function + | PIdentifier name when StrSet.find env name -> + let* fr = fresh in + let id = get_new_id fr name in + return + (StrSet.add env id, StrMap.update bindings name ~f:(fun _ -> id), PIdentifier id) + | PIdentifier name as pat -> return (StrSet.add env name, bindings, pat) + | PConstraint (pat, _) -> ac_pattern env bindings pat + | PCons (hd, tl) -> + let* env', bindings', hd_pat = ac_pattern env bindings hd in + let* env'', bindings'', tl_pat = ac_pattern env' bindings' tl in + return (env'', bindings'', PCons (hd_pat, tl_pat)) + | PTuple ps -> + let* env, bindings, ps = + RList.fold_left + ps + ~init:(return (env, bindings, [])) + ~f:(fun (e, b, ps) p -> + let* env, bindings, pat = ac_pattern e b p in + return (env, bindings, pat :: ps)) + in + return (env, bindings, PTuple (List.rev ps)) + | pat -> return (env, bindings, pat) +;; + +let rec ac_expr env bindings = function + | EConst c -> return @@ EConst c + | ENill -> return ENill + | EUnit -> return EUnit + | EConstraint (e, t) -> + let* expr = ac_expr env bindings e in + return @@ EConstraint (expr, t) + | EIdentifier id as expr -> + (match StrMap.find bindings id with + | Some new_id -> return @@ EIdentifier new_id + | None -> return expr) + | ELetIn (NoRec, pat, e1, e2) -> + let* e1' = ac_expr env bindings e1 in + let* env', bindings', pat' = ac_pattern env bindings pat in + let* e2' = ac_expr env' bindings' e2 in + return @@ ELetIn (NoRec, pat', e1', e2') + | ELetIn (Rec, pat, e1, e2) -> + let* env', bindings', pat' = ac_pattern env bindings pat in + let* e1' = ac_expr env' bindings' e1 in + let* e2' = ac_expr env' bindings' e2 in + return @@ ELetIn (Rec, pat', e1', e2') + | EApplication (e1, e2) -> + let* e1' = ac_expr env bindings e1 in + let* e2' = ac_expr env bindings e2 in + return (EApplication (e1', e2')) + | ECons (e1, e2) -> + let* e1' = ac_expr env bindings e1 in + let* e2' = ac_expr env bindings e2 in + return (ECons (e1', e2')) + | EFun (pat, expr) -> + let* env', bindings', pat' = ac_pattern env bindings pat in + let* expr' = ac_expr env' bindings' expr in + return @@ EFun (pat', expr') + | EIf (e_if, e_then, e_else) -> + let* e_if' = ac_expr env bindings e_if in + let* e_then' = ac_expr env bindings e_then in + let* e_else' = ac_expr env bindings e_else in + return @@ EIf (e_if', e_then', e_else') + | ETuple exprs -> + let* l = + RList.fold_left exprs ~init:(return []) ~f:(fun acc expr -> + let* e = ac_expr env bindings expr in + return @@ (e :: acc)) + in + return @@ ETuple (List.rev l) + | EMatch (expr, cases) -> + let* expr' = ac_expr env bindings expr in + let* cases' = + RList.fold_left cases ~init:(return []) ~f:(fun acc (pat, expr) -> + let* env', bindings', pat' = ac_pattern env bindings pat in + let* expr' = ac_expr env' bindings' expr in + return ((pat', expr') :: acc)) + in + return @@ EMatch (expr', List.rev cases') +;; + +let ac_decls env bindings = function + | NoRecDecl decls -> + let* env, bindings, decls = + RList.fold_left + decls + ~init:(return (env, bindings, [])) + ~f:(fun (new_env, new_bindings, decl_list) (DDeclaration (pat, expr)) -> + let* env', bindings', pat' = ac_pattern new_env new_bindings pat in + let* expr' = ac_expr env bindings expr in + return (env', bindings', DDeclaration (pat', expr') :: decl_list)) + in + return (env, bindings, NoRecDecl (List.rev decls)) + | RecDecl decls -> + let* env', bindings', decls' = + RList.fold_left + decls + ~init:(return (env, bindings, [])) + ~f:(fun (new_env, new_bindings, acc_decls) (DDeclaration (pat, expr)) -> + let* env', bindings', pat' = ac_pattern new_env new_bindings pat in + return (env', bindings', DDeclaration (pat', expr) :: acc_decls)) + in + let* env, bindings, decls = + RList.fold_left + decls' + ~init:(return (env', bindings', [])) + ~f:(fun (env, bindings, acc_decls) (DDeclaration (pat, expr)) -> + let* expr' = ac_expr env bindings expr in + return (env', bindings', DDeclaration (pat, expr') :: acc_decls)) + in + return (env, bindings, RecDecl decls) +;; + +let ac_program ast = + run + (let* _, _, decls = + RList.fold_left + ast + ~init:(return (StrSet.of_list builtins, StrMap.empty, [])) + ~f:(fun (env, bindings, decls) decl -> + let* new_env, new_bindings, new_decl = ac_decls env bindings decl in + return (new_env, new_bindings, new_decl :: decls)) + in + return @@ List.rev decls) +;; diff --git a/FML/lib/anf/a_conv.mli b/FML/lib/anf/a_conv.mli new file mode 100644 index 000000000..3a99ea2d7 --- /dev/null +++ b/FML/lib/anf/a_conv.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Ast + +val ac_program : program -> program diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml new file mode 100644 index 000000000..336f1b729 --- /dev/null +++ b/FML/lib/anf/anf.ml @@ -0,0 +1,130 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Anf_ast +open Me_ast +open Common +open StateMonad + +let const_to_immexp = function + | Me_Cint i -> ImmInt i + | Me_CBool b -> ImmBool b +;; + +let rec collect_apps expr = + match expr with + | Me_EApp (f, arg) -> + let f', args = collect_apps f in + f', args @ [ arg ] + | _ -> expr, [] +;; + +let rec to_cexp : me_expr -> ((string * cexpr) list * cexpr) t = function + | Me_ETuple elems -> + let* binds, imm_elems = + RList.fold_left + elems + ~init:(return ([], [])) + ~f:(fun (acc_binds, acc_elems) el -> + let* binds_el, imm_el = check_hard_expr el in + return (acc_binds @ binds_el, acc_elems @ [ imm_el ])) + in + return (binds, CImmExpr (ImmTuple imm_elems)) + | Me_ELet (NoRec, name, e1, e2) -> + let* binds1, ce1 = to_cexp e1 in + let* binds2, ce2 = to_cexp e2 in + return (binds1 @ [ name, ce1 ] @ binds2, ce2) + | Me_ECons (e1, e2) -> + let* binds1, a1 = check_hard_expr e1 in + let* binds2, a2 = check_hard_expr e2 in + return (binds1 @ binds2, CECons (a1, a2)) + | Me_EIf (e1, e2, e3) -> + let* binds1, e1 = check_hard_expr e1 in + let handle_for_let (e : me_expr) = + let* binds, expr = to_cexp e in + RList.fold_right binds ~init:(return @@ ACExpr expr) ~f:(fun (name, cexp) acc -> + return @@ ALetIn (name, cexp, acc)) + in + let* ce2 = handle_for_let e2 in + let* ce3 = handle_for_let e3 in + return (binds1, CEIf (e1, ce2, ce3)) + | Me_EApp (e1, e2) -> + let f_expr, args = collect_apps (Me_EApp (e1, e2)) in + let* binds_f, fun_imm = check_hard_expr f_expr in + let* binds_args, imm_args = + RList.fold_left + (List.rev args) + ~init:(return ([], [])) + ~f:(fun (acc_binds, acc_args) arg -> + let* binds_arg, imm_arg = check_hard_expr arg in + return (acc_binds @ binds_arg, imm_arg :: acc_args)) + in + (match fun_imm with + | ImmIdentifier f_name -> return (binds_f @ binds_args, CEApply (f_name, imm_args)) + | _ -> failwith "Expected function to be an identifier after all") + | Me_EConst c -> return ([], CImmExpr (const_to_immexp c)) + | Me_EIdentifier v -> return ([], CImmExpr (ImmIdentifier v)) + | Me_EUnit -> return ([], CImmExpr ImmUnit) + | Me_ENill -> return ([], CImmExpr ImmNill) + | _ -> failwith "See you later space cowboy" + +(* для обработки сложных выражений в условиях *) +and check_hard_expr = function + | Me_EIdentifier v -> return ([], ImmIdentifier v) + | Me_EConst c -> return ([], const_to_immexp c) + | Me_EUnit -> return ([], ImmUnit) + | Me_ENill -> return ([], ImmNill) + | e -> + let* id = fresh in + let name = "anf" ^ Int.to_string id in + let* binds1, ce = to_cexp e in + return (binds1 @ [ name, ce ], ImmIdentifier name) +;; + +let anf_decl = + let handle_for_let (e : me_expr) = + let* binds, expr = to_cexp e in + RList.fold_right binds ~init:(return @@ ACExpr expr) ~f:(fun (name, cexp) acc -> + return @@ ALetIn (name, cexp, acc)) + in + let is_based_value = function + | Me_EConst _ | Me_EIdentifier _ | Me_EUnit | Me_ENill -> true + | _ -> false + in + function + | Me_Nonrec decls -> + RList.fold_left decls ~init:(return []) ~f:(fun acc (name, e) -> + match e with + | Me_EFun (args, body) -> + let* body' = handle_for_let body in + return (acc @ [ ADNoRec [ ALet (name, args, body') ] ]) + | _ when is_based_value e -> + let* body' = handle_for_let e in + return (acc @ [ Based_value (name, body') ]) + | _ -> + let* expr' = handle_for_let e in + return (acc @ [ ADNoRec [ ALet (name, [], expr') ] ])) + | Me_Rec decls -> + let* bindings = + RList.fold_left decls ~init:(return []) ~f:(fun acc (name, e) -> + let* new_e = + match e with + | Me_EFun (args, body) -> + let* body' = handle_for_let body in + return (ALet (name, args, body')) + | _ -> + let* expr' = handle_for_let e in + return (ALet (name, [], expr')) + in + return (acc @ [ new_e ])) + in + return [ ADRec bindings ] +;; + +let anf prog = + StateMonad.run + (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> + let* d = anf_decl decl in + return (acc @ d))) +;; diff --git a/FML/lib/anf/anf.mli b/FML/lib/anf/anf.mli new file mode 100644 index 000000000..01156784f --- /dev/null +++ b/FML/lib/anf/anf.mli @@ -0,0 +1,8 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Anf_ast +open Me_ast + +val anf : me_program -> anf_prog diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml new file mode 100644 index 000000000..f6e794ee8 --- /dev/null +++ b/FML/lib/anf/anf_ast.ml @@ -0,0 +1,91 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type immexpr = + | ImmInt of int + | ImmIdentifier of string + | ImmBool of bool + | ImmUnit + | ImmNill + | ImmTuple of immexpr list + +type cexpr = + | CEApply of string * immexpr list + | CEIf of immexpr * aexpr * aexpr + | CECons of immexpr * immexpr + | CImmExpr of immexpr + +and aexpr = + | ALetIn of string * cexpr * aexpr + | ACExpr of cexpr + +type anf_binding = ALet of string * string list * aexpr + +type anf_decl = + | Based_value of string * aexpr + | ADNoRec of anf_binding list + | ADRec of anf_binding list + +type anf_prog = anf_decl list + +let imm_id id = ImmIdentifier id +let cimmexpr immexpr = CImmExpr immexpr + +let rec atom_to_str = function + | ImmInt i -> Int.to_string i + | ImmBool b -> Bool.to_string b + | ImmUnit -> "()" + | ImmIdentifier v -> v + | ImmNill -> "[]" + | ImmTuple l -> + Format.sprintf + "(%s)" + (atom_to_str (Base.List.hd_exn l) + ^ Base.List.fold_left + ~f:(fun acc e -> acc ^ Format.sprintf ", %s" (atom_to_str e)) + ~init:"" + (Base.List.tl_exn l)) +;; + +let rec cexp_to_str = function + | CImmExpr a -> atom_to_str a + | CEApply (a1, a_list) -> String.concat " " (a1 :: List.map atom_to_str a_list) + | CEIf (e1, e2, e3) -> + Format.sprintf + "if %s\nthen %s\nelse %s" + (atom_to_str e1) + (exp_to_str e2) + (exp_to_str e3) + | CECons (e1, e2) -> Format.sprintf "(%s::%s)" (atom_to_str e1) (atom_to_str e2) + +and exp_to_str = function + | ALetIn (name, c, e) -> + Format.sprintf "let %s = %s in\n%s" name (cexp_to_str c) (exp_to_str e) + | ACExpr e -> cexp_to_str e +;; + +let fun_to_str = function + | ALet (name, args, body) -> + Format.sprintf "%s = %s" (String.concat " " (name :: args)) (exp_to_str body) +;; + +let declaration_to_str = function + | Based_value (name, e) -> Format.sprintf "let %s = %s\n;;" name (exp_to_str e) + | ADNoRec func_list -> + let funs = List.map fun_to_str func_list in + "let " ^ String.concat "\nand " funs ^ "\n;;" + | ADRec func_list -> + let funs = List.map fun_to_str func_list in + "let rec " ^ String.concat "\nand " funs ^ "\n;;" +;; + +let pp_anf_program ppf p = + let len = List.length p in + Base.List.iteri + ~f:(fun i a -> + if i = len - 1 + then Format.fprintf ppf "%s" (declaration_to_str a) + else Format.fprintf ppf "%s\n\n" (declaration_to_str a)) + p +;; diff --git a/FML/lib/anf/anf_ast.mli b/FML/lib/anf/anf_ast.mli new file mode 100644 index 000000000..392f9bb64 --- /dev/null +++ b/FML/lib/anf/anf_ast.mli @@ -0,0 +1,35 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type immexpr = + | ImmInt of int (** 52 *) + | ImmIdentifier of string (** f *) + | ImmBool of bool (** true *) + | ImmUnit (** () *) + | ImmNill (** [] *) + | ImmTuple of immexpr list (** (IE, IE, IE)*) + +type cexpr = + | CEApply of string * immexpr list (** f IE1 IE2 IE3 ... *) + | CEIf of immexpr * aexpr * aexpr (** if IE then AE1 else AE2 *) + | CECons of immexpr * immexpr (** IE::IE*) + | CImmExpr of immexpr (** IE *) + +and aexpr = + | ALetIn of string * cexpr * aexpr (** let a = CE in AE*) + | ACExpr of cexpr (** CE *) + +type anf_binding = ALet of string * string list * aexpr (** f a b c = AE*) + +type anf_decl = + | Based_value of string * aexpr (** let f = AE*) + | ADNoRec of anf_binding list (** let rec anf_binding *) + | ADRec of anf_binding list (** let anf_binding *) + +(** anf_decl;; anf_decl *) +type anf_prog = anf_decl list + +val imm_id : string -> immexpr +val cimmexpr : immexpr -> cexpr +val pp_anf_program : Format.formatter -> anf_decl list -> unit diff --git a/FML/lib/anf/c_conv.ml b/FML/lib/anf/c_conv.ml new file mode 100644 index 000000000..7f50ac598 --- /dev/null +++ b/FML/lib/anf/c_conv.ml @@ -0,0 +1,115 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Me_ast +open Common + +let rec expr_free_vars binded = + let open StrSet in + function + | Me_EConst _ | Me_ENill | Me_EUnit -> StrSet.empty + | Me_EIdentifier id when find binded id -> empty + | Me_EIdentifier id -> singleton id + | Me_EIf (e1, e2, e3) -> + union_list + [ expr_free_vars binded e1; expr_free_vars binded e2; expr_free_vars binded e3 ] + | Me_ECons (e1, e2) | Me_EApp (e1, e2) -> + union (expr_free_vars binded e1) (expr_free_vars binded e2) + | Me_ETuple es -> + List.fold_left (fun acc expr -> union acc (expr_free_vars binded expr)) empty es + | Me_EFun (args, expr) -> + let binded = union binded (of_list args) in + expr_free_vars binded expr + | Me_ELet (NoRec, name, e1, e2) -> + let binded' = add binded name in + union (expr_free_vars binded e1) (expr_free_vars binded' e2) + | Me_ELet (Rec, name, e1, e2) -> + let binded = add binded name in + union (expr_free_vars binded e1) (expr_free_vars binded e2) +;; + +let rec cc_expr env bindings = function + | Me_EIdentifier id -> + (match StrMap.find bindings id with + | Some new_expr -> new_expr + | None -> Me_EIdentifier id) + | Me_ETuple es -> Me_ETuple (List.map (fun expr -> cc_expr env bindings expr) es) + | Me_EIf (e1, e2, e3) -> + Me_EIf (cc_expr env bindings e1, cc_expr env bindings e2, cc_expr env bindings e3) + | Me_ECons (e1, e2) -> Me_ECons (cc_expr env bindings e1, cc_expr env bindings e2) + | Me_EApp (e1, e2) -> Me_EApp (cc_expr env bindings e1, cc_expr env bindings e2) + | Me_EFun (args, expr) as e -> + let fvs = StrSet.to_list (expr_free_vars env e) in + let body = cc_expr env StrMap.empty expr in + let e_fun = Me_EFun (fvs @ args, body) in + List.fold_left (fun acc arg -> Me_EApp (acc, Me_EIdentifier arg)) e_fun fvs + | Me_ELet (NoRec, name, e1, e2) -> + let new_e1, bindings = + match e1 with + | Me_EFun (args, expr) as e -> + let fvs = StrSet.to_list (expr_free_vars env e) in + let body = cc_expr env StrMap.empty expr in + let new_expr = Me_EFun (fvs @ args, body) in + let apply = + List.fold_left + (fun acc arg -> Me_EApp (acc, Me_EIdentifier arg)) + (Me_EIdentifier name) + fvs + in + new_expr, StrMap.update bindings name ~f:(fun _ -> apply) + | expr -> cc_expr env StrMap.empty expr, bindings + in + let new_e2 = cc_expr env bindings e2 in + Me_ELet (NoRec, name, new_e1, new_e2) + | Me_ELet (Rec, name, e1, e2) -> + let new_e1, bindings = + match e1 with + | Me_EFun (args, expr) as e -> + let fvs = StrSet.to_list (expr_free_vars (StrSet.add env name) e) in + let apply = + List.fold_left + (fun acc arg -> Me_EApp (acc, Me_EIdentifier arg)) + (Me_EIdentifier name) + fvs + in + let body = cc_expr env (StrMap.singleton name apply) expr in + let new_expr = Me_EFun (fvs @ args, body) in + new_expr, StrMap.update bindings name ~f:(fun _ -> apply) + | expr -> cc_expr env StrMap.empty expr, bindings + in + let new_e2 = cc_expr (StrSet.add env name) bindings e2 in + Me_ELet (Rec, name, new_e1, new_e2) + | expr -> expr +;; + +let cc_decl env = function + | Me_Nonrec decls -> + let decls = + List.map (fun (name, expr) -> name, cc_expr env StrMap.empty expr) decls + in + let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in + Me_Nonrec decls, env + | Me_Rec decls -> + (* let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in *) + let decls = + List.map + (fun (name, expr) -> + match expr with + | Me_EFun (args, expr) -> name, Me_EFun (args, cc_expr env StrMap.empty expr) + | expr -> name, cc_expr env StrMap.empty expr) + decls + in + Me_Rec decls, env +;; + +let cc_program ast = + let builtins = StrSet.of_list builtins in + let rec helper last_env = function + | [] -> [] + | hd :: tl -> + let decls, env = cc_decl last_env hd in + decls :: helper env tl + in + helper builtins ast +;; diff --git a/FML/lib/anf/c_conv.mli b/FML/lib/anf/c_conv.mli new file mode 100644 index 000000000..99ba75255 --- /dev/null +++ b/FML/lib/anf/c_conv.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Me_ast + +val cc_program : me_program -> me_program diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml new file mode 100644 index 000000000..e2aa74e47 --- /dev/null +++ b/FML/lib/anf/common.ml @@ -0,0 +1,128 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Base + +module StrMap = struct + type 'a t = (string, 'a, String.comparator_witness) Map.t + + let empty = Map.empty (module String) + let singleton str = Map.singleton (module String) str + let update = Map.update + let find = Map.find + let merge_two fst snd = Map.merge_skewed fst snd ~combine:(fun ~key:_ _ v2 -> v2) +end + +module StrSet = struct + open Base + + type t = (string, String.comparator_witness) Set.t + + let add = Set.add + let empty = Set.empty (module String) + let singleton str = Set.singleton (module String) str + let union = Set.union + let to_list = Set.to_list + let of_list = Set.of_list (module String) + let diff = Set.diff + let union_list lst = Set.union_list (module String) lst + let find = Set.mem +end + +let builtins = + [ "( + )" + ; "( - )" + ; "( > )" + ; "( <= )" + ; "( && )" + ; "( / )" + ; "( * )" + ; "( < )" + ; "( >= )" + ; "( <> )" + ; "( = )" + ; "( != )" + ; "( || )" + ; "not" + ; "print_int" + ; "tuple_get" + ; "is_empty" + ; "is_cons" + ; "hd_list_get" + ; "tl_list_get" + ; "fail_match" + ; "apply_args" + ; "new_closure" + ; "_start" + ] +;; + +module StateMonad : sig + include Base.Monad.Infix + + val return : 'a -> 'a t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + + module RList : sig + val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t + end + + module RMap : sig + val fold_left + : ('a, 'b, 'c) Base.Map.t + -> init:'d t + -> f:('a -> 'b -> 'd -> 'd t) + -> 'd t + end + + val fresh : int t + val run : 'a t -> 'a +end = struct + type 'a t = int -> int * 'a (* State and Result monad composition *) + + let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = + fun m f s -> + let s', v' = m s in + f v' s' + ;; + + let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = + fun m f s -> + let s', x = m s in + s', f x + ;; + + let return v last = last, v + let bind x ~f = x >>= f + let fresh last = last + 1, last (* Get new state *) + let ( let* ) x f = bind x ~f (* Syntax sugar for bind *) + + module RMap = struct + (* Classic map folding. *) + let fold_left mp ~init ~f = + Base.Map.fold mp ~init ~f:(fun ~key ~data acc -> + let* acc = acc in + f key data acc) + ;; + end + + module RList = struct + (* Classic list folding. *) + let fold_left lt ~init ~f = + Base.List.fold_left lt ~init ~f:(fun acc item -> + let* acc = acc in + f acc item) + ;; + + let fold_right lt ~init ~f = + Base.List.fold_right lt ~init ~f:(fun item acc -> + let* acc = acc in + f item acc) + ;; + end + + (* Run and get the internal value. *) + let run m = snd (m 0) +end diff --git a/FML/lib/anf/common.mli b/FML/lib/anf/common.mli new file mode 100644 index 000000000..45883b3b6 --- /dev/null +++ b/FML/lib/anf/common.mli @@ -0,0 +1,52 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +module StrMap : sig + type 'a t + + val empty : 'a t + val singleton : string -> 'a -> 'a t + val update : 'a t -> string -> f:('a option -> 'a) -> 'a t + val find : 'a t -> string -> 'a option + val merge_two : 'a t -> 'a t -> 'a t +end + +module StrSet : sig + type t + + val add : t -> string -> t + val empty : t + val singleton : string -> t + val union : t -> t -> t + val to_list : t -> string list + val of_list : string list -> t + val diff : t -> t -> t + val union_list : t list -> t + val find : t -> string -> bool +end + +val builtins : string list + +module StateMonad : sig + include Base.Monad.Infix + + val return : 'a -> 'a t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + + module RList : sig + val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t + end + + module RMap : sig + val fold_left + : ('a, 'b, 'c) Base.Map.t + -> init:'d t + -> f:('a -> 'b -> 'd -> 'd t) + -> 'd t + end + + val fresh : int t + val run : 'a t -> 'a +end diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml new file mode 100644 index 000000000..603e1142e --- /dev/null +++ b/FML/lib/anf/lambda_lift.ml @@ -0,0 +1,133 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Me_ast +open Base +open Common +open StateMonad + +let get_new_id n name = Base.String.concat [ name; "_ll"; Int.to_string n ] + +let rec ll_expr bindings = function + | (Me_EUnit | Me_ENill | Me_EConst _) as expr -> return ([], expr) + | Me_EIdentifier id -> + (match StrMap.find bindings id with + | Some name -> return ([], Me_EIdentifier name) + | None -> return ([], Me_EIdentifier id)) + | Me_EIf (e1, e2, e3) -> + let* defs1, e1' = ll_expr bindings e1 in + let* defs2, e2' = ll_expr bindings e2 in + let* defs3, e3' = ll_expr bindings e3 in + return (defs1 @ defs2 @ defs3, Me_EIf (e1', e2', e3')) + | Me_EApp (e1, e2) -> + let* defs1, e1' = ll_expr bindings e1 in + let* defs2, e2' = ll_expr bindings e2 in + return (defs1 @ defs2, Me_EApp (e1', e2')) + | Me_ECons (e1, e2) -> + let* defs1, e1' = ll_expr bindings e1 in + let* defs2, e2' = ll_expr bindings e2 in + return (defs1 @ defs2, Me_ECons (e1', e2')) + | Me_ETuple lst -> + let* results = + RList.fold_left + lst + ~init:(return ([], [])) + ~f:(fun (acc_defs, acc_exprs) e -> + let* defs, e' = ll_expr bindings e in + return (acc_defs @ defs, acc_exprs @ [ e' ])) + in + let defs, exprs = results in + return (defs, Me_ETuple exprs) + | Me_ELet (NoRec, name, e1, e2) -> + (match e1 with + | Me_EFun (args, e1) -> + let* defs1, e1' = ll_expr bindings e1 in + let* id = fresh in + let new_name = get_new_id id name in + let new_args = + List.map args ~f:(fun arg -> + match StrMap.find bindings arg with + | Some id -> id + | None -> arg) + in + let def = Me_Nonrec [ new_name, Me_EFun (new_args, e1') ] in + let* defs2, e2' = + ll_expr (StrMap.update bindings name ~f:(fun _ -> new_name)) e2 + in + return (defs1 @ [ def ] @ defs2, e2') + | e1 -> + let* defs1, e1' = ll_expr bindings e1 in + let* defs2, e2' = ll_expr bindings e2 in + return (defs1 @ defs2, Me_ELet (NoRec, name, e1', e2'))) + | Me_ELet (Rec, name, e1, e2) -> + (match e1 with + | Me_EFun (args, e1) -> + let* id = fresh in + let new_name = get_new_id id name in + let bindings' = StrMap.update bindings name ~f:(fun _ -> new_name) in + let* defs1, e1' = ll_expr bindings' e1 in + let new_args = + List.map args ~f:(fun arg -> + match StrMap.find bindings arg with + | Some id -> id + | None -> arg) + in + let def = Me_Rec [ new_name, Me_EFun (new_args, e1') ] in + let* defs2, e2' = ll_expr bindings' e2 in + return (defs1 @ [ def ] @ defs2, e2') + | _ -> failwith "Not reachable") + | Me_EFun (args, body) -> + let* id = fresh in + let name = get_new_id id "lam" in + let* defs, body' = ll_expr bindings body in + let new_args = + List.map args ~f:(fun arg -> + match StrMap.find bindings arg with + | Some id -> id + | None -> arg) + in + let new_fun = Me_EFun (new_args, body') in + let def = Me_Nonrec [ name, new_fun ] in + return (defs @ [ def ], Me_EIdentifier name) +;; + +let ll_binding (name, expr) = + match expr with + | Me_EFun (args, expr) -> + let* defs, expr' = ll_expr StrMap.empty expr in + return (defs, (name, Me_EFun (args, expr'))) + | expr -> + let* defs, expr' = ll_expr StrMap.empty expr in + return (defs, (name, expr')) +;; + +let ll_decl = function + | Me_Nonrec bindings -> + let* all_defs, curr_defs = + RList.fold_left + bindings + ~init:(return ([], [])) + ~f:(fun (acc_defs, acc_curr) b -> + let* defs, binding = ll_binding b in + return (acc_defs @ defs, acc_curr @ [ binding ])) + in + return (all_defs, Me_Nonrec curr_defs) + | Me_Rec bindings -> + let* all_defs, curr_defs = + RList.fold_left + bindings + ~init:(return ([], [])) + ~f:(fun (acc_defs, acc_curr) b -> + let* defs, binding = ll_binding b in + return (acc_defs @ defs, acc_curr @ [ binding ])) + in + return (all_defs, Me_Rec curr_defs) +;; + +let lambda_lift prog = + StateMonad.run + (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> + let* decls, d = ll_decl decl in + return (acc @ decls @ [ d ]))) +;; diff --git a/FML/lib/anf/lambda_lift.mli b/FML/lib/anf/lambda_lift.mli new file mode 100644 index 000000000..262a2061b --- /dev/null +++ b/FML/lib/anf/lambda_lift.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Me_ast + +val lambda_lift : me_program -> me_program diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml new file mode 100644 index 000000000..a711df61d --- /dev/null +++ b/FML/lib/anf/match_elimination.ml @@ -0,0 +1,234 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Ast +open Base +open Me_ast +open Common +open StateMonad + +let get_new_id n name = String.concat [ name; "_me"; Int.to_string n ] + +let const_to_pe_const = function + | CInt a -> Me_Cint a + | CBool a -> Me_CBool a +;; + +let hd_list_get expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) +let tl_list_get expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) + +let tuple_get expr i = + Me_EApp (Me_EApp (Me_EIdentifier "tuple_get", expr), Me_EConst (Me_Cint i)) +;; + +let is_empty expr = Me_EApp (Me_EIdentifier "is_empty", expr) +let is_cons expr = Me_EApp (Me_EIdentifier "is_cons", expr) + +let is_equal e c = + Me_EApp (Me_EApp (Me_EIdentifier "( = )", e), Me_EConst (const_to_pe_const c)) +;; + +let rec pattern_remove = function + | PUnit -> [ "()" ] + | PAny -> [] + | PConst _ -> [] + | PIdentifier id -> [ id ] + | PNill -> [ "[]" ] + | PTuple pats -> List.concat_map ~f:pattern_remove pats + | PCons (hd, tl) -> pattern_remove hd @ pattern_remove tl + | PConstraint (p, _) -> pattern_remove p +;; + +let rec pattern_bindings expr = function + | PIdentifier id -> [ id, expr ] + | PAny | PConst _ | PUnit | PNill -> [] + | PCons (hd, tl) -> + pattern_bindings (hd_list_get expr) hd @ pattern_bindings (tl_list_get expr) tl + | PTuple ps -> List.concat_mapi ps ~f:(fun i p -> pattern_bindings (tuple_get expr i) p) + | PConstraint (p, _) -> pattern_bindings expr p +;; + +let rec pattern_checks expr = function + | PNill -> [ is_empty expr ] + | PCons (h, tl) -> + [ is_cons expr ] + @ pattern_checks (hd_list_get expr) h + @ pattern_checks (tl_list_get expr) tl + | PConstraint (p, _) -> pattern_checks expr p + | PConst c -> [ is_equal expr c ] + | PUnit | PIdentifier _ | PAny -> [] + | PTuple ps -> List.concat_mapi ps ~f:(fun i p -> pattern_checks (tuple_get expr i) p) +;; + +let rec_flags : Ast.rec_flag -> Me_ast.rec_flag = function + | Rec -> Rec + | NoRec -> NoRec +;; + +let rec expr_to_mexpr = function + | EUnit -> return Me_EUnit + | ENill -> return Me_ENill + | EConstraint (e, _) -> expr_to_mexpr e + | EConst c -> return @@ Me_EConst (const_to_pe_const c) + | EIdentifier id -> return @@ Me_EIdentifier id + | EApplication (f, arg) -> + let* f' = expr_to_mexpr f in + let* arg' = expr_to_mexpr arg in + return @@ Me_EApp (f', arg') + | EFun _ as e -> + let rev_pats, expr = + let rec helper acc = function + | EFun (pat, body) -> helper (pat :: acc) body + | expr -> acc, expr + in + helper [] e + in + let* expr = expr_to_mexpr expr in + let* args, checks, expr = + RList.fold_left + rev_pats + ~init:(return ([], [], expr)) + ~f:(fun (args, checks, expr) pat -> + let rec remove_annotations = function + | PConstraint (p, _) -> remove_annotations p + | p -> p + in + let pat = remove_annotations pat in + match pat with + | PTuple _ | PCons _ -> + let* id_num = fresh in + let arg_id = get_new_id id_num "me" in + let bindings = pattern_bindings (Me_EIdentifier arg_id) pat in + let expr = + List.fold_right bindings ~init:expr ~f:(fun (name, e) expr -> + Me_ELet (NoRec, name, e, expr)) + in + let new_checks = pattern_checks (Me_EIdentifier arg_id) pat in + return (arg_id :: args, new_checks @ checks, expr) + | PIdentifier id -> return (id :: args, checks, expr) + | PNill | PConst _ -> + let* id_num = fresh in + let arg_id = get_new_id id_num "me" in + return + (arg_id :: args, pattern_checks (Me_EIdentifier arg_id) pat @ checks, expr) + | PAny -> return ("_" :: args, checks, expr) + | PUnit -> return ("()" :: args, checks, expr) + | PConstraint _ -> return (args, checks, expr)) + in + (match checks with + | [] -> return @@ Me_EFun (args, expr) + | h :: tl -> + let check = + List.fold tl ~init:h ~f:(fun acc c -> + Me_EApp (Me_EApp (Me_EIdentifier "( && )", acc), c)) + in + return + @@ Me_EFun + ( args + , Me_EIf + (check, expr, Me_EApp (Me_EIdentifier "fail_match", Me_EConst (Me_Cint 1))) + )) + | ELetIn (rec_flag, pat, e1, e2) -> + let ids = pattern_remove pat in + let* e1' = expr_to_mexpr e1 in + let* e2' = expr_to_mexpr e2 in + let rec_flag = rec_flags rec_flag in + (match ids with + | [ id ] -> return @@ Me_ELet (rec_flag, id, e1', e2') + | ids_list -> + let transformed_e = + List.mapi ids_list ~f:(fun i id -> + let get_expr = + EApplication (EApplication (EIdentifier "tuple_get", e1), EConst (CInt i)) + in + PIdentifier id, get_expr) + in + let final_expr = + List.fold_right transformed_e ~init:e2 ~f:(fun (pat, expr) acc -> + ELetIn (NoRec, pat, expr, acc)) + in + expr_to_mexpr final_expr) + | ETuple exprs -> + let* exprs' = + RList.fold_left exprs ~init:(return []) ~f:(fun acc e -> + let* e' = expr_to_mexpr e in + return (acc @ [ e' ])) + in + return @@ Me_ETuple exprs' + | EIf (cond, then_, else_) -> + let* cond' = expr_to_mexpr cond in + let* then_' = expr_to_mexpr then_ in + let* else_' = expr_to_mexpr else_ in + return @@ Me_EIf (cond', then_', else_') + | ECons (hd, tl) -> + let* hd' = expr_to_mexpr hd in + let* tl' = expr_to_mexpr tl in + return @@ Me_ECons (hd', tl') + | EMatch (e, branches) -> desugar_match e branches + +and desugar_match expr branches = + let* expr' = expr_to_mexpr expr in + List.fold_right + branches + ~init:(return @@ Me_EApp (Me_EIdentifier "fail_match", Me_EConst (Me_Cint 1))) + ~f:(fun (p, e) acc -> + let check = + match pattern_checks expr' p with + | [] -> Me_EConst (Me_CBool true) + | h :: tl -> + List.fold_right tl ~init:h ~f:(fun c acc -> + Me_EApp (Me_EApp (Me_EIdentifier "( && )", acc), c)) + in + let bindings = pattern_bindings expr' p in + let* e' = expr_to_mexpr e in + let expr = + List.fold_right bindings ~init:e' ~f:(fun (name, e) acc -> + Me_ELet (NoRec, name, e, acc)) + in + let* acc = acc in + return @@ Me_EIf (check, expr, acc)) +;; + +let decl_to_pe_decl decls = + let process_binding pat expr = + let ids = pattern_remove pat in + match ids with + | [ id ] -> + let* e' = expr_to_mexpr expr in + return [ id, e' ] + | _ -> + let* tmp_id_num = fresh in + let tmp_var = get_new_id tmp_id_num "tmp" in + let* e' = expr_to_mexpr expr in + let tmp_expr = Me_EIdentifier tmp_var in + let bindings = pattern_bindings tmp_expr pat in + return ((tmp_var, e') :: bindings) + in + match decls with + | NoRecDecl decls -> + let* converted = + RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> + let* bindings = process_binding pat expr in + return (acc @ bindings)) + in + return @@ Me_Nonrec converted + | RecDecl decls -> + let* converted = + RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> + let ids = pattern_remove pat in + match ids with + | [ id ] -> + let* e' = expr_to_mexpr expr in + return ((id, e') :: acc) + | _ -> failwith "Simple patterns on rec, otherwise it's crazt") + in + return @@ Me_Rec (List.rev converted) +;; + +let match_elimination prog = + StateMonad.run + (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> + let* d = decl_to_pe_decl decl in + return (acc @ [ d ]))) +;; diff --git a/FML/lib/anf/match_elimination.mli b/FML/lib/anf/match_elimination.mli new file mode 100644 index 000000000..16d30c079 --- /dev/null +++ b/FML/lib/anf/match_elimination.mli @@ -0,0 +1,8 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Ast +open Me_ast + +val match_elimination : program -> me_program diff --git a/FML/lib/anf/me_ast.ml b/FML/lib/anf/me_ast.ml new file mode 100644 index 000000000..7337f5550 --- /dev/null +++ b/FML/lib/anf/me_ast.ml @@ -0,0 +1,97 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type rec_flag = + | Rec + | NoRec + +type me_const = + | Me_Cint of int + | Me_CBool of bool + +type me_expr = + | Me_EUnit + | Me_ENill + | Me_EIdentifier of string + | Me_EConst of me_const + | Me_EIf of me_expr * me_expr * me_expr + | Me_EFun of string list * me_expr + | Me_EApp of me_expr * me_expr + | Me_ELet of rec_flag * string * me_expr * me_expr + | Me_ECons of me_expr * me_expr + | Me_ETuple of me_expr list + +type me_declaration = + | Me_Nonrec of (string * me_expr) list + | Me_Rec of (string * me_expr) list + +type me_program = me_declaration list + +let const_to_str = function + | Me_CBool b when b -> "true" + | Me_CBool _ -> "false" + | Me_Cint i -> Format.sprintf "%i" i +;; + +let rec expr_to_str = function + | Me_EUnit -> "()" + | Me_ENill -> "[]" + | Me_EIdentifier a -> a + | Me_EConst c -> const_to_str c + | Me_EIf (e1, e2, e3) -> + Format.sprintf + "if %s\nthen %s\nelse %s" + (expr_to_str e1) + (expr_to_str e2) + (expr_to_str e3) + | Me_EFun (args, e) -> + Format.sprintf "(fun %s -> %s)" (String.concat " " args) (expr_to_str e) + | Me_EApp (e1, e2) -> Format.sprintf "(%s %s)" (expr_to_str e1) (expr_to_str e2) + | Me_ELet (NoRec, name, e1, e2) -> + Format.sprintf "let %s = %s in\n%s" name (expr_to_str e1) (expr_to_str e2) + | Me_ELet (Rec, name1, e1, e2) -> + Format.sprintf "let rec %s = %s in\n%s" name1 (expr_to_str e1) (expr_to_str e2) + | Me_ECons (e1, e2) -> Format.sprintf "(%s::%s)" (expr_to_str e1) (expr_to_str e2) + | Me_ETuple e_list -> + Format.sprintf + "(%s)" + (expr_to_str (List.hd e_list) + ^ List.fold_left + (fun acc e -> acc ^ Format.sprintf ", %s" (expr_to_str e)) + "" + (List.tl e_list)) +;; + +let decl_to_str = function + | Me_Nonrec decl_list -> + (match decl_list with + | [] -> "" + | (name, e) :: tl -> + Format.sprintf "let %s = %s" name (expr_to_str e) + ^ List.fold_left + (fun acc (name, e) -> + acc ^ Format.sprintf "\nlet %s = %s" name (expr_to_str e)) + "" + tl) + | Me_Rec decl_list -> + (match decl_list with + | [] -> "" + | (name, e) :: tl -> + Format.sprintf "let rec %s = %s" name (expr_to_str e) + ^ List.fold_left + (fun acc (name, e) -> + acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) + "" + tl) +;; + +let pp_me_program ppf p = + let len = List.length p in + List.iteri + (fun i a -> + if i = len - 1 + then Format.fprintf ppf "%s" (decl_to_str a) + else Format.fprintf ppf "%s\n\n" (decl_to_str a)) + p +;; diff --git a/FML/lib/anf/me_ast.mli b/FML/lib/anf/me_ast.mli new file mode 100644 index 000000000..dec82744e --- /dev/null +++ b/FML/lib/anf/me_ast.mli @@ -0,0 +1,32 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type rec_flag = + | Rec (** let rec ... *) + | NoRec (** let ... *) + +type me_const = + | Me_Cint of int (** 52 *) + | Me_CBool of bool (** true *) + +type me_expr = + | Me_EUnit (** () *) + | Me_ENill (** [] *) + | Me_EIdentifier of string (** f *) + | Me_EConst of me_const (** 52 || true *) + | Me_EIf of me_expr * me_expr * me_expr (** if E1 then E2 else E3 *) + | Me_EFun of string list * me_expr (** fun a,b,c -> E *) + | Me_EApp of me_expr * me_expr (** E1 E2*) + | Me_ELet of rec_flag * string * me_expr * me_expr (** let [rec] name = E1 in E2 *) + | Me_ECons of me_expr * me_expr (** E1::E2 *) + | Me_ETuple of me_expr list (** (E1, E2, E3) *) + +type me_declaration = + | Me_Nonrec of (string * me_expr) list (** let f = E *) + | Me_Rec of (string * me_expr) list (** let rec f = E *) + +(** me_declaration;; me_declaration *) +type me_program = me_declaration list + +val pp_me_program : Format.formatter -> me_declaration list -> unit diff --git a/FML/lib/ast/ast.ml b/FML/lib/ast/ast.ml index 24d461fd8..fa5892ae7 100644 --- a/FML/lib/ast/ast.ml +++ b/FML/lib/ast/ast.ml @@ -18,6 +18,7 @@ type type_annotation = | AUnit | AInt | ABool + | AVar of int | AList of type_annotation | ATuple of type_annotation list | AFunction of type_annotation * type_annotation diff --git a/FML/lib/ast/ast.mli b/FML/lib/ast/ast.mli new file mode 100644 index 000000000..e5029a86d --- /dev/null +++ b/FML/lib/ast/ast.mli @@ -0,0 +1,88 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type id = string [@@deriving show { with_path = false }] + +type const = + | CInt of int (** 1 *) + | CBool of bool (** true *) +[@@deriving show { with_path = false }] + +type rec_flag = + | Rec (** rec *) + | NoRec (** no rec annotation *) +[@@deriving show { with_path = false }] + +type type_annotation = + | AUnit (** : unit *) + | AInt (** : int *) + | ABool (** : bool *) + | AVar of int (** 'a *) + | AList of type_annotation (** : 'a list *) + | ATuple of type_annotation list (** : 'a * 'b *) + | AFunction of type_annotation * type_annotation (** : 'a -> 'b *) +[@@deriving show { with_path = false }] + +type pattern = + | PNill (** [] *) + | PAny (** _ *) + | PUnit (** () *) + | PConst of const (** 1 || true *) + | PIdentifier of id (** x *) + | PTuple of pattern list (** (x, y, z) *) + | PCons of pattern * pattern (** hd :: tl*) + | PConstraint of pattern * type_annotation (** P : type annotation *) +[@@deriving show { with_path = false }] + +type expression = + | EUnit (** () *) + | ENill (** [] *) + | EConstraint of expression * type_annotation (** E : type annotation *) + | EConst of const (** 1 || true*) + | EIdentifier of id (** x *) + | EApplication of expression * expression (** E1 E2*) + | EFun of pattern * expression (** fun P -> E*) + | ELetIn of rec_flag * pattern * expression * expression (** let f x = E1 *) + | ETuple of expression list (** (E1, E2, E3) *) + | EIf of expression * expression * expression (** if e1 then e2 else e3 *) + | ECons of expression * expression (** [a; b; c], a :: [b; c]*) + | EMatch of expression * (pattern * expression) list + (** match e with p1 -> e1 |...| pn -> en *) +[@@deriving show { with_path = false }] + +type single_declaration = DDeclaration of pattern * expression (** P = E*) +[@@deriving show { with_path = false }] + +type declaration = + | NoRecDecl of single_declaration list + (** let single_declaration (and single_declaration) *) + | RecDecl of single_declaration list + (** let rec single_declaration (and single_declaration) *) +[@@deriving show { with_path = false }] + +(** declaration;; declaration *) +type program = declaration list [@@deriving show { with_path = false }] + +(* Constructors for patterns *) +val cint : int -> const +val cbool : bool -> const +val pany : 'a -> pattern +val pnill : 'a -> pattern +val punit : 'a -> pattern +val pident : id -> pattern +val pconst : const -> pattern +val pcons : pattern -> pattern -> pattern +val ptuple : pattern list -> pattern +val pconstraint : pattern -> type_annotation -> pattern + +(* Constructors for expressions *) + +val econst : const -> expression +val eidentifier : id -> expression +val etuple : expression list -> expression +val efun : pattern -> expression -> expression +val econstraint : expression -> type_annotation -> expression + +(* Constructor for declaration *) +val ddeclaration : pattern -> expression -> single_declaration diff --git a/FML/lib/dune b/FML/lib/dune index 31260dc14..d7fa2e35b 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -3,9 +3,24 @@ (library (name fml_lib) (public_name FML.Lib) - (modules Ast Parser Inf_errors Inf_pprint Inferencer Typedtree) + (modules + Ast + Parser + Inf_errors + Inf_pprint + Inferencer + Typedtree + Common + Me_ast + A_conv + C_conv + Match_elimination + Anf_ast + Anf + Lambda_lift + Codegen) (modules_without_implementation inf_errors) - (libraries base angstrom) + (libraries base angstrom llvm llvm.analysis llvm.executionengine) (preprocess (pps ppx_deriving.show)) (instrumentation diff --git a/FML/lib/inferencer/inferencer.ml b/FML/lib/inferencer/inferencer.ml index 95ac1290a..b9f9d34f6 100644 --- a/FML/lib/inferencer/inferencer.ml +++ b/FML/lib/inferencer/inferencer.ml @@ -297,9 +297,10 @@ let annotation_to_type = | AInt -> tint | ABool -> tbool | AUnit -> tunit + | AVar n -> tvar n | AFunction (l, r) -> tfunction (helper l) (helper r) | AList a -> tlist (helper a) - | ATuple a -> ttuple @@ List.map (fun x -> helper x) a + | ATuple a -> ttuple @@ List.map helper a in helper ;; @@ -309,12 +310,10 @@ let check_unique_vars = Used to detect severeal bound errors in tuple patterns, list constructor patterns. *) let rec helper var_set = function - | PIdentifier v -> - if VarSet.mem v var_set - then - (* If at least one variable is found twice, we raise an error. *) - fail (`Several_bounds v) - else return (VarSet.add v var_set) + | PIdentifier v when VarSet.mem v var_set -> + (* If at least one variable is found twice, we raise an error. *) + fail (`Several_bounds v) + | PIdentifier v -> return (VarSet.add v var_set) | PAny -> return var_set | PNill -> return var_set | PUnit -> return var_set @@ -331,10 +330,8 @@ let check_unique_vars = let check_unique_vars_list patterns = let rec helper var_set = function | [] -> return var_set - | PIdentifier name :: rest -> - if VarSet.mem name var_set - then fail (`Several_bounds name) - else helper (VarSet.add name var_set) rest + | PIdentifier name :: _ when VarSet.mem name var_set -> fail (`Several_bounds name) + | PIdentifier name :: rest -> helper (VarSet.add name var_set) rest | PAny :: rest -> helper var_set rest | PNill :: rest -> helper var_set rest | PUnit :: rest -> helper var_set rest @@ -642,6 +639,8 @@ let start_env = ; "( - )", TFunction (TInt, TFunction (TInt, TInt)) ; "( / )", TFunction (TInt, TFunction (TInt, TInt)) ; "( * )", TFunction (TInt, TFunction (TInt, TInt)) + ; "( && )", TFunction (TBool, TFunction (TBool, TBool)) + ; "( || )", TFunction (TBool, TFunction (TBool, TBool)) ; "( < )", TFunction (TVar 1, TFunction (TVar 1, TBool)) ; "( > )", TFunction (TVar 1, TFunction (TVar 1, TBool)) ; "( <= )", TFunction (TVar 1, TFunction (TVar 1, TBool)) @@ -653,6 +652,12 @@ let start_env = ; "( ~+ )", TFunction (TInt, TInt) ; "not", TFunction (TBool, TBool) ; "print_int", TFunction (TInt, TUnit) + ; "is_empty", TFunction (TList (TVar 1), TBool) + ; "is_cons", TFunction (TList (TVar 1), TBool) + ; "hd_list_get", TFunction (TList (TVar 1), TVar 1) + ; "tl_list_get", TFunction (TList (TVar 1), TList (TVar 1)) + ; "tuple_get", TFunction (TVar 1, TFunction (TInt, TVar 2)) + ; "fail_match", TFunction (TInt, TVar 1) ] in let env = TypeEnv.empty in diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml new file mode 100644 index 000000000..8bb119f36 --- /dev/null +++ b/FML/lib/llvm/codegen.ml @@ -0,0 +1,229 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Llvm +open Anf_ast + +module StrMap = struct + open Base + + let empty = Map.empty (module String) + let update = Map.update + let find = Map.find +end + +let ctx = global_context () +let builder = builder ctx +let module_ = create_module ctx "FML" +let target_triple = Llvm_target.Target.default_triple () +let () = Llvm.set_target_triple target_triple module_ +let i64_t = i64_type ctx + +let get_rt_name = function + | "( + )" -> "rt_add" + | "( - )" -> "rt_sub" + | "( * )" -> "rt_mul" + | "( / )" -> "rt_divd" + | "( = )" -> "rt_eq" + | "( != )" -> "rt_neq" + | "( < )" -> "rt_less" + | "( <= )" -> "rt_leq" + | "( > )" -> "rt_gre" + | "( >= )" -> "rt_geq" + | "( && )" -> "rt_and" + | "( || )" -> "rt_or" + | other -> other +;; + +let compile_immexpr env = function + | ImmInt n -> const_int i64_t n + | ImmBool b -> const_int i64_t (Bool.to_int b) + | ImmUnit -> const_int i64_t 0 + | ImmIdentifier name -> + let name = get_rt_name name in + (match lookup_function name module_ with + | Some f -> + let fun_ptr = build_ptrtoint f i64_t "" builder in + build_call + (function_type i64_t [| i64_t; i64_t |]) + (Option.get @@ lookup_function "new_closure" module_) + [| fun_ptr; const_int i64_t (Array.length (params f)) |] + "empty_closure" + builder + | None -> + (match lookup_global name module_ with + | Some g -> build_load i64_t g "global" builder + | None -> + (match StrMap.find env name with + | Some v -> v + | None -> failwith ("Unknown variable: " ^ name)))) + | _ -> failwith "Not_implemented" +;; + +let is_unnop = function + | "( ~+ )" | "( ~- )" -> true + | _ -> false +;; + +let is_binop = function + | "( + )" + | "( - )" + | "( * )" + | "( / )" + | "( = )" + | "( == )" + | "( <> )" + | "( != )" + | "( > )" + | "( >= )" + | "( < )" + | "( <= )" -> true + | _ -> false +;; + +let compile_unnop op x = + match op with + | "( ~+ )" -> x + | "( ~- )" -> build_sub (const_int i64_t 0) x "sub" builder + | _ -> failwith ("Invalid operator: " ^ op) +;; + +let compile_binop op x y = + match op with + | "( + )" -> build_add x y "add" builder + | "( - )" -> build_sub x y "sub" builder + | "( * )" -> build_mul x y "mul" builder + | "( / )" -> build_sdiv x y "div" builder + | "( = )" | "( == )" -> + build_zext (build_icmp Icmp.Eq x y "eq" builder) i64_t "eq_i64t" builder + | "( <> )" | "( != )" -> + build_zext (build_icmp Icmp.Ne x y "ne" builder) i64_t "ne_i64t" builder + | "( > )" -> build_zext (build_icmp Icmp.Sgt x y "sgt" builder) i64_t "sgt_i64t" builder + | "( >= )" -> + build_zext (build_icmp Icmp.Sge x y "sge" builder) i64_t "sge_i64t" builder + | "( < )" -> build_zext (build_icmp Icmp.Slt x y "slt" builder) i64_t "slt_i64t" builder + | "( <= )" -> + build_zext (build_icmp Icmp.Sle x y "sle" builder) i64_t "sle_i64t" builder + | _ -> failwith ("Invalid operator: " ^ op) +;; + +let rec compile_cexpr env = function + | CImmExpr imm -> compile_immexpr env imm + | CEApply (name, [ arg1 ]) when is_unnop name -> + compile_unnop name (compile_immexpr env arg1) + | CEApply (name, [ arg1; arg2 ]) when is_binop name -> + compile_binop name (compile_immexpr env arg1) (compile_immexpr env arg2) + | CEApply (name, args) -> + let compiled_args = List.map (compile_immexpr env) args in + (match lookup_function name module_ with + | Some f when Array.length (params f) = List.length args -> + let func_type = function_type i64_t (Array.make (List.length args) i64_t) in + build_call func_type f (Array.of_list compiled_args) "call" builder + | _ -> + let f = compile_immexpr env (ImmIdentifier name) in + build_call + (var_arg_function_type i64_t [| i64_t; i64_t |]) + (Option.get (lookup_function "apply_args" module_)) + (Array.of_list + ([ f; const_int i64_t (List.length compiled_args) ] @ compiled_args)) + "applied_closure" + builder) + | CEIf (cond, then_e, else_e) -> + let cond_v = + build_icmp Icmp.Ne (compile_immexpr env cond) (const_int i64_t 0) "cond_v" builder + in + let entry_block = insertion_block builder in + let parent = block_parent entry_block in + let then_block = append_block ctx "then" parent in + position_at_end then_block builder; + let then_ = compile_aexpr env then_e in + let new_then_block = insertion_block builder in + let else_block = append_block ctx "else" parent in + position_at_end else_block builder; + let else_ = compile_aexpr env else_e in + let new_else_block = insertion_block builder in + let merge_bb = append_block ctx "merge" parent in + position_at_end merge_bb builder; + let phi = build_phi [ then_, new_then_block; else_, new_else_block ] "phi" builder in + position_at_end entry_block builder; + let (_ : llvalue) = build_cond_br cond_v then_block else_block builder in + position_at_end new_then_block builder; + let (_ : llvalue) = build_br merge_bb builder in + position_at_end new_else_block builder; + let (_ : llvalue) = build_br merge_bb builder in + position_at_end merge_bb builder; + phi + | _ -> failwith "Not implemented" + +and compile_aexpr env = function + | ACExpr e -> compile_cexpr env e + | ALetIn (name, cexpr, aexpr) -> + let v = compile_cexpr env cexpr in + compile_aexpr (StrMap.update env name ~f:(fun _ -> v)) aexpr +;; + +let declare_func name args = + let arg_types = Array.make (List.length args) i64_t in + let func_type = function_type i64_t arg_types in + declare_function name func_type module_ +;; + +let compile_anf_binding (ALet (name, args, body)) = + let func = declare_func name args in + let bb = append_block ctx "entry" func in + position_at_end bb builder; + let _, env = + Base.List.fold args ~init:(0, StrMap.empty) ~f:(fun (i, env) arg_name -> + let arg_value = param func i in + set_value_name arg_name arg_value; + i + 1, StrMap.update env arg_name ~f:(fun _ -> arg_value)) + in + let body_val = compile_aexpr env body in + let _ = build_ret body_val builder in + ignore func +;; + +let compile_anf_decl = function + | ADNoRec bindings -> + List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings + | ADRec bindings -> + List.iter (fun (ALet (name, args, _)) -> ignore (declare_func name args)) bindings; + List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings + | Based_value (name, body) -> + let body = compile_aexpr StrMap.empty body in + ignore (define_global name body module_) +;; + +let init_runtime = + let runtime_funs = + [ "new_closure", function_type i64_t [| i64_t; i64_t |] + ; "apply_args", var_arg_function_type i64_t [| i64_t; i64_t; i64_t |] + ; "print_int", function_type i64_t [| i64_t |] + ; "rt_add", function_type i64_t [| i64_t; i64_t |] + ; "rt_sub", function_type i64_t [| i64_t; i64_t |] + ; "rt_mul", function_type i64_t [| i64_t; i64_t |] + ; "rt_div", function_type i64_t [| i64_t; i64_t |] + ; "rt_leq", function_type i64_t [| i64_t; i64_t |] + ; "rt_less", function_type i64_t [| i64_t; i64_t |] + ; "rt_geq", function_type i64_t [| i64_t; i64_t |] + ; "rt_gre", function_type i64_t [| i64_t; i64_t |] + ; "rt_eq", function_type i64_t [| i64_t; i64_t |] + ; "rt_neq", function_type i64_t [| i64_t; i64_t |] + ; "rt_and", function_type i64_t [| i64_t; i64_t |] + ; "rt_or", function_type i64_t [| i64_t; i64_t |] + ; "fail_match", function_type i64_t [| i64_t |] + ] + in + List.map (fun (name, ty) -> declare_function name ty module_) runtime_funs +;; + +let create_main program = + ignore init_runtime; + List.iter (fun decl -> ignore (compile_anf_decl decl)) program +;; + +let compile_program program = + let _ = create_main program in + print_module "out.ll" module_ +;; diff --git a/FML/lib/llvm/codegen.mli b/FML/lib/llvm/codegen.mli new file mode 100644 index 000000000..1586011fe --- /dev/null +++ b/FML/lib/llvm/codegen.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Anf_ast + +val compile_program : anf_prog -> unit diff --git a/FML/lib/llvm/dune b/FML/lib/llvm/dune new file mode 100644 index 000000000..181269991 --- /dev/null +++ b/FML/lib/llvm/dune @@ -0,0 +1,5 @@ +(rule + (targets runtime.o) + (deps runtime.c) + (action + (run clang-16 -c runtime.c -o %{targets}))) diff --git a/FML/lib/llvm/runtime.c b/FML/lib/llvm/runtime.c new file mode 100644 index 000000000..cb4c283fd --- /dev/null +++ b/FML/lib/llvm/runtime.c @@ -0,0 +1,128 @@ +#include +#include +#include +#include +#include + +int64_t print_int(int64_t x) +{ + printf("%ld", x); + return 0; +} + +int64_t fail_match(int64_t err) +{ + fprintf(stderr, "Match failure\n"); + exit(err); +} + +int64_t rt_add(int64_t x, int64_t y) { return x + y; } +int64_t rt_sub(int64_t x, int64_t y) { return x - y; } +int64_t rt_mul(int64_t x, int64_t y) { return x * y; } +int64_t rt_divd(int64_t x, int64_t y) { return x / y; } +int64_t rt_eq(int64_t x, int64_t y) { return x == y; } +int64_t rt_neq(int64_t x, int64_t y) { return x != y; } +int64_t rt_less(int64_t x, int64_t y) { return x < y; } +int64_t rt_leq(int64_t x, int64_t y) { return x <= y; } +int64_t rt_gre(int64_t x, int64_t y) { return x > y; } +int64_t rt_geq(int64_t x, int64_t y) { return x >= y; } +int64_t rt_and(int64_t x, int64_t y) { return x && y; } +int64_t rt_or(int64_t x, int64_t y) { return x || y; } + +typedef struct +{ + int64_t fun_ptr; + int64_t args_num; + int64_t args_applied; + int64_t args[]; +} closure_t; + +int64_t +create_closure(int64_t f_ptr, int64_t args_num, int64_t args_applied) +{ + closure_t *closure = malloc(sizeof(closure_t) + args_num * sizeof(int64_t)); + closure->fun_ptr = f_ptr; + closure->args_num = args_num; + closure->args_applied = args_applied; + return (int64_t)closure; +} + +int64_t +new_closure(int64_t f_ptr, int64_t args_num) +{ + return create_closure(f_ptr, args_num, 0); +} + +int64_t call_closure(closure_t *closure) +{ + int64_t args_n = closure->args_num; + ffi_cif cif; + ffi_type *args_types[args_n]; + void *args[args_n]; + for (int64_t i = 0; i < args_n; i++) + { + args_types[i] = &ffi_type_sint64; + args[i] = &closure->args[i]; + } + + if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, args_n, &ffi_type_sint64, args_types) != FFI_OK) + { + fprintf(stderr, "Failed to prepare CIF\n"); + exit(1); + }; + + int64_t res; + + ffi_call(&cif, (void *)closure->fun_ptr, &res, args); + + return res; +} + +int64_t _apply(closure_t *closure, int new_args_num, va_list *args) +{ + int64_t args_to_apply = closure->args_num - closure->args_applied; + + if (new_args_num < args_to_apply) + { + closure_t *new_closure = (closure_t *)create_closure(closure->fun_ptr, closure->args_num, closure->args_applied + new_args_num); + for (int64_t i = 0; i < closure->args_applied; i++) + { + new_closure->args[i] = closure->args[i]; + } + + for (int64_t i = 0; i < new_args_num; i++) + { + int64_t arg = va_arg(*args, int64_t); + new_closure->args[closure->args_applied + i] = arg; + } + return (int64_t)new_closure; + } + else + { + for (int64_t i = 0; i < args_to_apply; i++) + { + int64_t arg = va_arg(*args, int64_t); + closure->args[closure->args_applied + i] = arg; + } + + int64_t res = call_closure(closure); + + new_args_num -= args_to_apply; + if (new_args_num == 0) + { + return res; + } + + closure_t *new_closure = (closure_t *)res; + return _apply(new_closure, new_args_num, args); + } +} + +int64_t apply_args(closure_t *closure, int new_args_num, ...) +{ + va_list args; + va_start(args, new_args_num); + + va_end(args); + return _apply(closure, new_args_num, &args); +} diff --git a/FML/lib/parser/parser.ml b/FML/lib/parser/parser.ml index 6a020fa50..8a872b4c5 100644 --- a/FML/lib/parser/parser.ml +++ b/FML/lib/parser/parser.ml @@ -50,7 +50,7 @@ let keyword s = skip_wspace *> string s <* skip_wspace1 let chainl1 e op = let rec go acc = lift2 (fun f x -> f acc x) op e >>= go <|> return acc in - e >>= fun init -> go init + e >>= go ;; let rec chainr1 e op = e >>= fun a -> op >>= (fun f -> chainr1 e op >>| f a) <|> return a @@ -63,7 +63,8 @@ let parse_name = let parse_identifier constr = parse_name >>= fun name -> - if ((not @@ is_keyword name) && is_lower name.[0]) || name.[0] = '_' + if ((not @@ is_keyword name) && is_lower name.[0]) + || (name.[0] = '_' && String.length name > 1) then return @@ constr name else fail "Syntax error: invalid identifier name" ;; @@ -84,6 +85,14 @@ let parse_primitive_type = ] ;; +let parse_var_type = + parse_name + >>= fun name -> + if String.length name = 2 && name.[0] = '\'' && is_lower name.[1] + then return @@ AVar (int_of_char name.[1]) + else fail "Syntax error." +;; + let parse_list_type p_type = p_type <* token "list" >>= fun l -> return @@ AList l let parse_tuple_type p_type = @@ -97,7 +106,9 @@ let parse_function_type p_type = let parse_type = let typ = - fix @@ fun self -> choice [ parens self; parse_primitive_type; parse_list_type self ] + fix + @@ fun self -> + choice [ parens self; parse_primitive_type; parse_var_type; parse_list_type self ] in let typ = parse_tuple_type typ <|> typ in parse_function_type typ <|> typ @@ -130,7 +141,7 @@ let parse_operators = (* ------------------------ *) (* Pattern parsers*) -let parse_pany = token "_" *> skip_wspace1 >>| pany +let parse_pany = token "_" >>| pany let parse_punit = token "(" *> token ")" >>| punit let parse_pidentifier = parse_operators >>| pident <|> parse_identifier pident let parse_pconst = parse_const pconst @@ -152,11 +163,11 @@ let parse_pattern_wout_type = let patt = choice [ parens self + ; parse_pidentifier ; parse_pany ; parse_punit ; parse_pconst ; parse_pnill - ; parse_pidentifier ; parse_ptuple self ] in diff --git a/FML/tests/a_conv_manytest.t b/FML/tests/a_conv_manytest.t new file mode 100644 index 000000000..ccff26c70 --- /dev/null +++ b/FML/tests/a_conv_manytest.t @@ -0,0 +1,1391 @@ + $ ./a_conv_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + [(NoRecDecl + [(DDeclaration ((PIdentifier "is_empty_ac0"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), (EIdentifier "x"))), + (EConst (CInt 1)))) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "length"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EConst (CInt 0))); + ((PCons (PAny, (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "( + )"), (EConst (CInt 1)) + )), + (EApplication ((EIdentifier "length"), + (EIdentifier "xs"))) + ))) + ] + )) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + [(NoRecDecl + [(DDeclaration ((PIdentifier "fac"), + (EFun ((PIdentifier "n"), + (ELetIn (Rec, (PIdentifier "fack"), + (EFun ((PIdentifier "n_ac0"), + (EFun ((PIdentifier "k"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( <= )"), + (EIdentifier "n_ac0"))), + (EConst (CInt 1)))), + (EApplication ((EIdentifier "k"), (EConst (CInt 1)))), + (EApplication ( + (EApplication ((EIdentifier "fack"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n_ac0"))), + (EConst (CInt 1)))) + )), + (EApplication ( + (EApplication ( + (EFun ((PIdentifier "k_ac1"), + (EFun ((PIdentifier "n_ac2"), + (EFun ((PIdentifier "m"), + (EApplication ( + (EIdentifier "k_ac1"), + (EApplication ( + (EApplication ( + (EIdentifier "( * )"), + (EIdentifier "m"))), + (EIdentifier "n_ac2"))) + )) + )) + )) + )), + (EIdentifier "k"))), + (EIdentifier "n_ac0"))) + )) + )) + )) + )), + (EApplication ( + (EApplication ((EIdentifier "fack"), (EIdentifier "n"))), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/001fac.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fac"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( <= )"), (EIdentifier "n"))), + (EConst (CInt 1)))), + (EConst (CInt 1)), + (EApplication ( + (EApplication ((EIdentifier "( * )"), (EIdentifier "n"))), + (EApplication ((EIdentifier "fac"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "fac"), (EConst (CInt 4)))))), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/002fac.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fac_cps"), + (EFun ((PIdentifier "n"), + (EFun ((PIdentifier "k"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), + (EConst (CInt 1)))), + (EApplication ((EIdentifier "k"), (EConst (CInt 1)))), + (EApplication ( + (EApplication ((EIdentifier "fac_cps"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )), + (EFun ((PIdentifier "p"), + (EApplication ((EIdentifier "k"), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "p"))), + (EIdentifier "n"))) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ((EIdentifier "fac_cps"), (EConst (CInt 4)))), + (EFun ((PIdentifier "print_int_ac0"), + (EIdentifier "print_int_ac0"))) + )) + )), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/003fib.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fib_acc"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), + (EIdentifier "n"))), + (EConst (CInt 1)))), + (EIdentifier "b"), + (ELetIn (NoRec, (PIdentifier "n1"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))), + (ELetIn (NoRec, (PIdentifier "ab"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "a"))), + (EIdentifier "b"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fib_acc"), + (EIdentifier "b"))), + (EIdentifier "ab"))), + (EIdentifier "n1"))) + )) + )) + )) + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "fib"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( < )"), (EIdentifier "n"))), + (EConst (CInt 2)))), + (EIdentifier "n"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )), + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 2)))) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fib_acc"), + (EConst (CInt 0)))), + (EConst (CInt 1)))), + (EConst (CInt 4)))) + )), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "fib"), (EConst (CInt 4)))))), + (EConst (CInt 0)))) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/004manyargs.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "wrap"), + (EFun ((PIdentifier "f"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), (EConst (CInt 1)))), + (EConst (CInt 1)))), + (EIdentifier "f"), (EIdentifier "f"))) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "test3"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "c"), + (ELetIn (NoRec, (PIdentifier "a_ac0"), + (EApplication ((EIdentifier "print_int"), + (EIdentifier "a"))), + (ELetIn (NoRec, (PIdentifier "b_ac1"), + (EApplication ((EIdentifier "print_int"), + (EIdentifier "b"))), + (ELetIn (NoRec, (PIdentifier "c_ac2"), + (EApplication ((EIdentifier "print_int"), + (EIdentifier "c"))), + (EConst (CInt 0)))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "test10"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "c"), + (EFun ((PIdentifier "d"), + (EFun ((PIdentifier "e"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "g"), + (EFun ((PIdentifier "h"), + (EFun ((PIdentifier "i"), + (EFun ((PIdentifier "j"), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EIdentifier + "a"))), + (EIdentifier + "b"))))), + (EIdentifier + "c"))))), + (EIdentifier + "d"))))), + (EIdentifier + "e"))))), + (EIdentifier + "f") + )) + )), + (EIdentifier "g") + )) + )), + (EIdentifier "h"))) + )), + (EIdentifier "i"))) + )), + (EIdentifier "j"))) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, (PIdentifier "rez"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EIdentifier "wrap"), + (EIdentifier "test10"))), + (EConst (CInt 1)))), + (EConst (CInt 10)))), + (EConst (CInt 100)))), + (EConst (CInt 1000)))), + (EConst (CInt 10000)))), + (EConst (CInt 100000)))), + (EConst (CInt 1000000)))), + (EConst (CInt 10000000)))), + (EConst (CInt 100000000)))), + (EConst (CInt 1000000000)))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), (EIdentifier "rez") + )), + (ELetIn (NoRec, (PIdentifier "temp2"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "wrap"), + (EIdentifier "test3"))), + (EConst (CInt 1)))), + (EConst (CInt 10)))), + (EConst (CInt 100)))), + (EConst (CInt 0)))) + )) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/005fix.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fix"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "f"), + (EApplication ((EIdentifier "fix"), (EIdentifier "f"))))), + (EIdentifier "x"))) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "fac"), + (EFun ((PIdentifier "self"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( <= )"), (EIdentifier "n") + )), + (EConst (CInt 1)))), + (EConst (CInt 1)), + (EApplication ( + (EApplication ((EIdentifier "( * )"), (EIdentifier "n") + )), + (EApplication ((EIdentifier "self"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ((EIdentifier "fix"), (EIdentifier "fac"))), + (EConst (CInt 6)))) + )), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/006partial.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "foo"), + (EFun ((PIdentifier "b"), + (EIf ((EIdentifier "b"), + (EFun ((PIdentifier "foo"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), (EIdentifier "foo") + )), + (EConst (CInt 2)))) + )), + (EFun ((PIdentifier "foo"), + (EApplication ( + (EApplication ((EIdentifier "( * )"), (EIdentifier "foo") + )), + (EConst (CInt 10)))) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "foo_ac0"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "foo"), (EConst (CBool true)))), + (EApplication ( + (EApplication ((EIdentifier "foo"), (EConst (CBool false)) + )), + (EApplication ( + (EApplication ((EIdentifier "foo"), + (EConst (CBool true)))), + (EApplication ( + (EApplication ((EIdentifier "foo"), + (EConst (CBool false)))), + (EIdentifier "x"))) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "foo_ac0"), (EConst (CInt 11)))))), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/006partial2.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "foo"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "c"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "a"))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "b"))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "c"))), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "a"))), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "b"))), + (EIdentifier "c"))) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, (PIdentifier "foo_ac0"), + (EApplication ((EIdentifier "foo"), (EConst (CInt 1)))), + (ELetIn (NoRec, (PIdentifier "foo_ac1"), + (EApplication ((EIdentifier "foo_ac0"), (EConst (CInt 2)))), + (ELetIn (NoRec, (PIdentifier "foo_ac2"), + (EApplication ((EIdentifier "foo_ac1"), (EConst (CInt 3)))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "foo_ac2"))), + (EConst (CInt 0)))) + )) + )) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/006partial3.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "foo"), + (EFun ((PIdentifier "a"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), (EIdentifier "a"))), + (EFun ((PIdentifier "b"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "b"))), + (EFun ((PIdentifier "c"), + (EApplication ((EIdentifier "print_int"), + (EIdentifier "c"))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "foo"), (EConst (CInt 4)))), + (EConst (CInt 8)))), + (EConst (CInt 9)))), + (EConst (CInt 0)))) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/007order.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "_start_ac0"), + (EFun (PUnit, + (EFun (PUnit, + (EFun ((PIdentifier "a"), + (EFun (PUnit, + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "_c"), + (EFun (PUnit, + (EFun ((PIdentifier "d"), + (EFun ((PIdentifier "__"), + (ELetIn (NoRec, PUnit, + (EApplication ( + (EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EIdentifier "a"))), + (EIdentifier "b"))) + )), + (ELetIn (NoRec, PUnit, + (EApplication ( + (EIdentifier "print_int"), + (EIdentifier "__"))), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier "( / )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( * )"), + (EIdentifier "a") + )), + (EIdentifier "b"))) + )), + (EIdentifier "_c"))) + )), + (EIdentifier "d"))) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EIdentifier "_start_ac0"), + (EApplication ( + (EIdentifier "print_int"), + (EConst (CInt 1)))) + )), + (EApplication ((EIdentifier "print_int"), + (EConst (CInt 2)))) + )), + (EConst (CInt 3)))), + (EApplication ((EIdentifier "print_int"), + (EConst (CInt 4)))) + )), + (EConst (CInt 100)))), + (EConst (CInt 1000)))), + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "( ~- )"), + (EConst (CInt 1)))) + )) + )), + (EConst (CInt 10000)))), + (EApplication ((EIdentifier "( ~- )"), (EConst (CInt 555555)) + )) + )) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/008ascription.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "addi"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "g"), + (EFun ((PIdentifier "x"), + (EConstraint ( + (EApplication ( + (EApplication ((EIdentifier "f"), (EIdentifier "x"))), + (EConstraint ( + (EApplication ((EIdentifier "g"), (EIdentifier "x") + )), + ABool)) + )), + AInt)) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "addi"), + (EFun ((PIdentifier "x"), + (EFun ((PIdentifier "b"), + (EIf ((EIdentifier "b"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "x"))), + (EConst (CInt 1)))), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "x"))), + (EConst (CInt 2)))) + )) + )) + )) + )), + (EFun ((PIdentifier "_start_ac0"), + (EApplication ( + (EApplication ((EIdentifier "( = )"), + (EApplication ( + (EApplication ((EIdentifier "( / )"), + (EIdentifier "_start_ac0"))), + (EConst (CInt 2)))) + )), + (EConst (CInt 0)))) + )) + )), + (EConst (CInt 4)))) + )), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/009let_poly.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "temp"), + (ELetIn (NoRec, (PIdentifier "f"), + (EFun ((PIdentifier "x"), (EIdentifier "x"))), + (ETuple + [(EApplication ((EIdentifier "f"), (EConst (CInt 1)))); + (EApplication ((EIdentifier "f"), (EConst (CBool true))))]) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/011mapcps.ml + [(RecDecl + [(DDeclaration ((PIdentifier "map"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EFun ((PIdentifier "k"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EApplication ((EIdentifier "k"), ENill))); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "map"), + (EIdentifier "f"))), + (EIdentifier "tl"))), + (EFun ((PIdentifier "tl_ac0"), + (EApplication ((EIdentifier "k"), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "h"))), + (EIdentifier "tl_ac0"))) + )) + )) + ))) + ] + )) + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "iter"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, EUnit); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (ELetIn (NoRec, (PIdentifier "w"), + (EApplication ((EIdentifier "f"), (EIdentifier "h"))), + (EApplication ( + (EApplication ((EIdentifier "iter"), + (EIdentifier "f"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ( + (EApplication ((EIdentifier "iter"), (EIdentifier "print_int"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "map"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "x"))), + (EConst (CInt 1)))) + )) + )), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/012fibcps.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fib"), + (EFun ((PIdentifier "n"), + (EFun ((PIdentifier "k"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( < )"), (EIdentifier "n"))), + (EConst (CInt 2)))), + (EApplication ((EIdentifier "k"), (EIdentifier "n"))), + (EApplication ( + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )), + (EFun ((PIdentifier "a"), + (EApplication ( + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 2)))) + )), + (EFun ((PIdentifier "b"), + (EApplication ((EIdentifier "k"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "a"))), + (EIdentifier "b"))) + )) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ((EIdentifier "fib"), (EConst (CInt 6)))), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/013foldfoldr.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "id"), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "fold_right"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "acc"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EIdentifier "acc")); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "f"), + (EIdentifier "h"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fold_right"), + (EIdentifier "f"))), + (EIdentifier "acc"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "foldl"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "bs"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fold_right"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "g"), + (EFun ((PIdentifier "x"), + (EApplication ((EIdentifier "g"), + (EApplication ( + (EApplication ( + (EIdentifier "f"), + (EIdentifier "x"))), + (EIdentifier "b"))) + )) + )) + )) + )) + )), + (EIdentifier "id"))), + (EIdentifier "bs"))), + (EIdentifier "a"))) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "foldl"), + (EFun ((PIdentifier "x"), + (EFun ((PIdentifier "y"), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "x"))), + (EIdentifier "y"))) + )) + )) + )), + (EConst (CInt 1)))), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/015tuples.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fix"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "f"), + (EApplication ((EIdentifier "fix"), (EIdentifier "f"))))), + (EIdentifier "x"))) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "map"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "p"), + (ELetIn (NoRec, + (PTuple [(PIdentifier "a"); (PIdentifier "b")]), + (EIdentifier "p"), + (ETuple + [(EApplication ((EIdentifier "f"), (EIdentifier "a"))); + (EApplication ((EIdentifier "f"), (EIdentifier "b")))]) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "fixpoly"), + (EFun ((PIdentifier "l"), + (EApplication ( + (EApplication ((EIdentifier "fix"), + (EFun ((PIdentifier "self"), + (EFun ((PIdentifier "l_ac0"), + (EApplication ( + (EApplication ((EIdentifier "map"), + (EFun ((PIdentifier "li"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "li"), + (EApplication ( + (EIdentifier "self"), + (EIdentifier "l_ac0"))) + )), + (EIdentifier "x"))) + )) + )) + )), + (EIdentifier "l_ac0"))) + )) + )) + )), + (EIdentifier "l"))) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "feven"), + (EFun ((PIdentifier "p"), + (EFun ((PIdentifier "n"), + (ELetIn (NoRec, + (PTuple [(PIdentifier "e"); (PIdentifier "o")]), + (EIdentifier "p"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), + (EIdentifier "n"))), + (EConst (CInt 0)))), + (EConst (CInt 1)), + (EApplication ((EIdentifier "o"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "fodd"), + (EFun ((PIdentifier "p"), + (EFun ((PIdentifier "n"), + (ELetIn (NoRec, + (PTuple [(PIdentifier "e"); (PIdentifier "o")]), + (EIdentifier "p"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), + (EIdentifier "n"))), + (EConst (CInt 0)))), + (EConst (CInt 0)), + (EApplication ((EIdentifier "e"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "tie"), + (EApplication ((EIdentifier "fixpoly"), + (ETuple [(EIdentifier "feven"); (EIdentifier "fodd")]))) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "meven"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), + (EConst (CInt 0)))), + (EConst (CInt 1)), + (EApplication ((EIdentifier "modd"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), (EIdentifier "n") + )), + (EConst (CInt 1)))) + )) + )) + )) + )); + (DDeclaration ((PIdentifier "modd"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), + (EConst (CInt 0)))), + (EConst (CInt 1)), + (EApplication ((EIdentifier "meven"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), (EIdentifier "n") + )), + (EConst (CInt 1)))) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "modd"), (EConst (CInt 1)))))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "meven"), (EConst (CInt 2)))))), + (ELetIn (NoRec, + (PTuple [(PIdentifier "even"); (PIdentifier "odd")]), + (EIdentifier "tie"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "odd"), (EConst (CInt 3)) + )) + )), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "even"), + (EConst (CInt 4)))) + )), + (EConst (CInt 0)))) + )) + )) + )) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/016lists.ml + [(RecDecl + [(DDeclaration ((PIdentifier "length"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EConst (CInt 0))); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "( + )"), (EConst (CInt 1)))), + (EApplication ((EIdentifier "length"), (EIdentifier "tl") + )) + ))) + ] + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "length_tail"), + (ELetIn (Rec, (PIdentifier "helper"), + (EFun ((PIdentifier "acc"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EIdentifier "acc")); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "helper"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "acc"))), + (EConst (CInt 1)))) + )), + (EIdentifier "tl")))) + ] + )) + )) + )), + (EApplication ((EIdentifier "helper"), (EConst (CInt 0)))))) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "map"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, ENill); + ((PCons ((PIdentifier "a"), PNill)), + (ECons ( + (EApplication ((EIdentifier "f"), (EIdentifier "a"))), + ENill))); + ((PCons ((PIdentifier "a"), + (PCons ((PIdentifier "b"), PNill)))), + (ECons ( + (EApplication ((EIdentifier "f"), (EIdentifier "a"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "b"))), + ENill)) + ))); + ((PCons ((PIdentifier "a"), + (PCons ((PIdentifier "b"), + (PCons ((PIdentifier "c"), PNill)))) + )), + (ECons ( + (EApplication ((EIdentifier "f"), (EIdentifier "a"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "b"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "c"))), + ENill)) + )) + ))); + ((PCons ((PIdentifier "a"), + (PCons ((PIdentifier "b"), + (PCons ((PIdentifier "c"), + (PCons ((PIdentifier "d"), (PIdentifier "tl"))) + )) + )) + )), + (ECons ( + (EApplication ((EIdentifier "f"), (EIdentifier "a"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "b"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "c"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "d"))), + (EApplication ( + (EApplication ((EIdentifier "map"), + (EIdentifier "f"))), + (EIdentifier "tl"))) + )) + )) + )) + ))) + ] + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "append"), + (EFun ((PIdentifier "xs"), + (EFun ((PIdentifier "ys"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EIdentifier "ys")); + ((PCons ((PIdentifier "x"), (PIdentifier "xs_ac0"))), + (ECons ((EIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "append"), + (EIdentifier "xs_ac0"))), + (EIdentifier "ys"))) + ))) + ] + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "concat"), + (ELetIn (Rec, (PIdentifier "helper"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, ENill); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "append"), + (EIdentifier "h"))), + (EApplication ((EIdentifier "helper"), + (EIdentifier "tl"))) + ))) + ] + )) + )), + (EIdentifier "helper"))) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "iter"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, EUnit); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "f"), (EIdentifier "h"))), + (EApplication ( + (EApplication ((EIdentifier "iter"), + (EIdentifier "f"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "cartesian"), + (EFun ((PIdentifier "xs"), + (EFun ((PIdentifier "ys"), + (EMatch ((EIdentifier "xs"), + [(PNill, ENill); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "append"), + (EApplication ( + (EApplication ((EIdentifier "map"), + (EFun ((PIdentifier "a"), + (ETuple + [(EIdentifier "h"); (EIdentifier "a")]) + )) + )), + (EIdentifier "ys"))) + )), + (EApplication ( + (EApplication ((EIdentifier "cartesian"), + (EIdentifier "tl"))), + (EIdentifier "ys"))) + ))) + ] + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ( + (EApplication ((EIdentifier "iter"), (EIdentifier "print_int") + )), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "length"), + (EApplication ( + (EApplication ((EIdentifier "cartesian"), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), ENill)))) + )), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), + (ECons ((EConst (CInt 4)), ENill)))) + )) + )) + )) + )) + )), + (EConst (CInt 0)))) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./a_conv_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./a_conv_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./a_conv_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./a_conv_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/a_conv_runner.ml b/FML/tests/a_conv_runner.ml new file mode 100644 index 000000000..165927516 --- /dev/null +++ b/FML/tests/a_conv_runner.ml @@ -0,0 +1,25 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Ast +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + Format.printf "%a\n" pp_program ast + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t new file mode 100644 index 000000000..68b582767 --- /dev/null +++ b/FML/tests/anf_manytest.t @@ -0,0 +1,947 @@ + $ ./anf_runner.exe << EOF + > let main = + > let rec fib n k = + > if n < 2 + > then k n + > else fib (n - 1) (fun a -> fib (n - 2) (fun b -> k (a + b))) in print_int(fib 6 (fun x -> x)) + > EOF + let lam_ll2 a k b = let anf0 = ( + ) a b in + k anf0 + ;; + + let lam_ll1 fib_ll0 k n a = let anf1 = lam_ll2 a k in + let anf2 = ( - ) n 2 in + fib_ll0 anf2 anf1 + ;; + + let rec fib_ll0 n k = let anf3 = ( < ) n 2 in + if anf3 + then k n + else let anf4 = lam_ll1 fib_ll0 k n in + let anf5 = ( - ) n 1 in + fib_ll0 anf5 anf4 + ;; + + let lam_ll3 x = x + ;; + + let main = let anf6 = fib_ll0 6 lam_ll3 in + print_int anf6 + ;; + + Типы до приведения в ANF: + val main : unit + + Типы после приведения в ANF: + val lam_ll2 : int -> (int -> 'a) -> int -> 'a + val lam_ll1 : (int -> (int -> 'a) -> 'b) -> (int -> 'a) -> int -> int -> 'b + val fib_ll0 : int -> (int -> 'a) -> 'a + val lam_ll3 : 'a -> 'a + val main : unit + $ ./anf_runner.exe << EOF + > let f x = let g y = x + y in g 5;; + > EOF + let g_ll0 x y = ( + ) x y + ;; + + let f x = g_ll0 x 5 + ;; + + Типы до приведения в ANF: + val f : int -> int + + Типы после приведения в ANF: + val g_ll0 : int -> int -> int + val f : int -> int + + $ ./anf_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let length xs = let anf2 = tl_list_get xs in + let anf1 = is_cons anf2 in + let anf6 = tl_list_get xs in + let anf5 = tl_list_get anf6 in + let anf4 = is_empty anf5 in + let anf7 = is_cons xs in + let anf3 = ( && ) anf7 anf4 in + let anf0 = ( && ) anf3 anf1 in + if anf0 + then let a = hd_list_get xs in + let anf8 = tl_list_get xs in + let b = hd_list_get anf8 in + 2 + else let anf11 = tl_list_get xs in + let anf10 = is_empty anf11 in + let anf12 = is_cons xs in + let anf9 = ( && ) anf12 anf10 in + if anf9 + then let a = hd_list_get xs in + 1 + else let anf13 = is_empty xs in + if anf13 + then 0 + else fail_match 1 + ;; + + Типы до приведения в ANF: + val length : 'a list -> int + + Типы после приведения в ANF: + val length : 'a list -> int + + $ ./anf_runner.exe << EOF + > let is_empty x = x+1 + > + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let is_empty_ac0 x = ( + ) x 1 + ;; + + let rec length xs = let anf0 = is_empty xs in + if anf0 + then 0 + else let anf1 = is_cons xs in + if anf1 + then let tl = tl_list_get xs in + let anf2 = length xs in + ( + ) 1 anf2 + else fail_match 1 + ;; + + Типы до приведения в ANF: + val is_empty : int -> int + val length : 'a list -> int + + Типы после приведения в ANF: + val is_empty_ac0 : int -> int + val length : 'a list -> int + + $ ./anf_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let lam_ll1 k_ac1 n_ac2 m = let anf0 = ( * ) m n_ac2 in + k_ac1 anf0 + ;; + + let rec fack_ll0 n_ac0 k = let anf1 = ( <= ) n_ac0 1 in + if anf1 + then k 1 + else let anf2 = lam_ll1 k n_ac0 in + let anf3 = ( - ) n_ac0 1 in + fack_ll0 anf3 anf2 + ;; + + let lam_ll2 x = x + ;; + + let fac n = fack_ll0 n lam_ll2 + ;; + + Типы до приведения в ANF: + val fac : int -> int + + Типы после приведения в ANF: + val lam_ll1 : (int -> 'a) -> int -> int -> 'a + val fack_ll0 : int -> (int -> 'a) -> 'a + val lam_ll2 : 'a -> 'a + val fac : int -> int + + $ ./anf_runner.exe << EOF + > let f x = match x with + > | 1 -> 12 + > | 12 -> 12 + > | _ -> 325 + > EOF + let f x = let anf0 = ( = ) x 1 in + if anf0 + then 12 + else let anf1 = ( = ) x 12 in + if anf1 + then 12 + else if true + then 325 + else fail_match 1 + ;; + + Типы до приведения в ANF: + val f : int -> int + + Типы после приведения в ANF: + val f : int -> int + + $ ./anf_runner.exe < manytests/typed/001fac.ml + let rec fac n = let anf0 = ( <= ) n 1 in + if anf0 + then 1 + else let anf2 = ( - ) n 1 in + let anf1 = fac anf2 in + ( * ) n anf1 + ;; + + let main = let anf3 = fac 4 in + let () = print_int anf3 in + 0 + ;; + + Типы до приведения в ANF: + val fac : int -> int + val main : int + + Типы после приведения в ANF: + val fac : int -> int + val main : int + + $ ./anf_runner.exe < manytests/typed/002fac.ml + let lam_ll0 k n p = let anf0 = ( * ) p n in + k anf0 + ;; + + let rec fac_cps n k = let anf1 = ( = ) n 1 in + if anf1 + then k 1 + else let anf2 = lam_ll0 k n in + let anf3 = ( - ) n 1 in + fac_cps anf3 anf2 + ;; + + let lam_ll1 print_int_ac0 = print_int_ac0 + ;; + + let main = let anf4 = fac_cps 4 lam_ll1 in + let () = print_int anf4 in + 0 + ;; + + Типы до приведения в ANF: + val fac_cps : int -> (int -> 'a) -> 'a + val main : int + + Типы после приведения в ANF: + val lam_ll0 : (int -> 'a) -> int -> int -> 'a + val fac_cps : int -> (int -> 'a) -> 'a + val lam_ll1 : 'a -> 'a + val main : int + + $ ./anf_runner.exe < manytests/typed/003fib.ml + let rec fib_acc a b n = let anf0 = ( = ) n 1 in + if anf0 + then b + else let n1 = ( - ) n 1 in + let ab = ( + ) a b in + fib_acc b ab n1 + ;; + + let rec fib n = let anf1 = ( < ) n 2 in + if anf1 + then n + else let anf3 = ( - ) n 2 in + let anf2 = fib anf3 in + let anf5 = ( - ) n 1 in + let anf4 = fib anf5 in + ( + ) anf4 anf2 + ;; + + let main = let anf6 = fib_acc 0 1 4 in + let () = print_int anf6 in + let anf7 = fib 4 in + let () = print_int anf7 in + 0 + ;; + + Типы до приведения в ANF: + val fib_acc : int -> int -> int -> int + val fib : int -> int + val main : int + + Типы после приведения в ANF: + val fib_acc : int -> int -> int -> int + val fib : int -> int + val main : int + + $ ./anf_runner.exe < manytests/typed/004manyargs.ml + let wrap f = let anf0 = ( = ) 1 1 in + if anf0 + then f + else f + ;; + + let test3 a b c = let a_ac0 = print_int a in + let b_ac1 = print_int b in + let c_ac2 = print_int c in + 0 + ;; + + let test10 a b c d e f g h i j = let anf8 = ( + ) a b in + let anf7 = ( + ) anf8 c in + let anf6 = ( + ) anf7 d in + let anf5 = ( + ) anf6 e in + let anf4 = ( + ) anf5 f in + let anf3 = ( + ) anf4 g in + let anf2 = ( + ) anf3 h in + let anf1 = ( + ) anf2 i in + ( + ) anf1 j + ;; + + let main = let rez = wrap test10 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000 in + let () = print_int rez in + let temp2 = wrap test3 1 10 100 in + 0 + ;; + + Типы до приведения в ANF: + val wrap : 'a -> 'a + val test3 : int -> int -> int -> int + val test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int + val main : int + + Типы после приведения в ANF: + val wrap : 'a -> 'a + val test3 : int -> int -> int -> int + val test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int + val main : int + + $ ./anf_runner.exe < manytests/typed/005fix.ml + let rec fix f x = let anf0 = fix f in + f anf0 x + ;; + + let fac self n = let anf1 = ( <= ) n 1 in + if anf1 + then 1 + else let anf3 = ( - ) n 1 in + let anf2 = self anf3 in + ( * ) n anf2 + ;; + + let main = let anf4 = fix fac 6 in + let () = print_int anf4 in + 0 + ;; + + Типы до приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val fac : (int -> int) -> int -> int + val main : int + + Типы после приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val fac : (int -> int) -> int -> int + val main : int + + $ ./anf_runner.exe < manytests/typed/006partial.ml + let lam_ll0 foo = ( + ) foo 2 + ;; + + let lam_ll1 foo = ( * ) foo 10 + ;; + + let foo b = if b + then lam_ll0 + else lam_ll1 + ;; + + let foo_ac0 x = let anf2 = foo false x in + let anf1 = foo true anf2 in + let anf0 = foo false anf1 in + foo true anf0 + ;; + + let main = let anf3 = foo_ac0 11 in + let () = print_int anf3 in + 0 + ;; + + Типы до приведения в ANF: + val foo : int -> int + val main : int + + Типы после приведения в ANF: + val lam_ll0 : int -> int + val lam_ll1 : int -> int + val foo : bool -> int -> int + val foo_ac0 : int -> int + val main : int + + $ ./anf_runner.exe < manytests/typed/006partial2.ml + let foo a b c = let () = print_int a in + let () = print_int b in + let () = print_int c in + let anf0 = ( * ) b c in + ( + ) a anf0 + ;; + + let main = let foo_ac0 = foo 1 in + let foo_ac1 = foo_ac0 2 in + let foo_ac2 = foo_ac1 3 in + let () = print_int foo_ac2 in + 0 + ;; + + Типы до приведения в ANF: + val foo : int -> int -> int -> int + val main : int + + Типы после приведения в ANF: + val foo : int -> int -> int -> int + val main : int + $ ./anf_runner.exe < manytests/typed/006partial3.ml + let lam_ll1 c = print_int c + ;; + + let lam_ll0 b = let () = print_int b in + lam_ll1 + ;; + + let foo a = let () = print_int a in + lam_ll0 + ;; + + let main = let () = foo 4 8 9 in + 0 + ;; + + Типы до приведения в ANF: + val foo : int -> int -> int -> unit + val main : int + + Типы после приведения в ANF: + val lam_ll1 : int -> unit + val lam_ll0 : int -> int -> unit + val foo : int -> int -> int -> unit + val main : int + $ ./anf_runner.exe < manytests/typed/007order.ml + let _start_ac0 () () a () b _c () d __ = let anf0 = ( + ) a b in + let () = print_int anf0 in + let () = print_int __ in + let anf2 = ( * ) a b in + let anf1 = ( / ) anf2 _c in + ( + ) anf1 d + ;; + + let main = let anf4 = ( ~- ) 555555 in + let anf6 = ( ~- ) 1 in + let anf5 = print_int anf6 in + let anf7 = print_int 4 in + let anf8 = print_int 2 in + let anf9 = print_int 1 in + let anf3 = _start_ac0 anf9 anf8 3 anf7 100 1000 anf5 10000 anf4 in + print_int anf3 + ;; + + Типы до приведения в ANF: + val _start : unit -> unit -> int -> unit -> int -> int -> unit -> int -> int -> int + val main : unit + + Типы после приведения в ANF: + val _start_ac0 : unit -> unit -> int -> unit -> int -> int -> unit -> int -> int -> int + val main : unit + $ ./anf_runner.exe < manytests/typed/008ascription.ml + let addi f g x = let anf0 = g x in + f x anf0 + ;; + + let lam_ll0 x b = if b + then ( + ) x 1 + else ( * ) x 2 + ;; + + let lam_ll1 _start_ac0 = let anf1 = ( / ) _start_ac0 2 in + ( = ) anf1 0 + ;; + + let main = let anf2 = addi lam_ll0 lam_ll1 4 in + let () = print_int anf2 in + 0 + ;; + + Типы до приведения в ANF: + val addi : ('a -> bool -> int) -> ('a -> bool) -> 'a -> int + val main : int + + Типы после приведения в ANF: + val addi : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c + val lam_ll0 : int -> bool -> int + val lam_ll1 : int -> bool + val main : int + + $ ./anf_runner.exe < manytests/typed/009let_poly.ml + let f_ll0 x = x + ;; + + let temp = let anf0 = f_ll0 1 in + let anf1 = f_ll0 true in + (anf0, anf1) + ;; + + Типы до приведения в ANF: + val temp : int * bool + + Типы после приведения в ANF: + val f_ll0 : 'a -> 'a + val temp : int * bool + + $ ./anf_runner.exe < manytests/typed/011mapcps.ml + let lam_ll0 f h k tl_ac0 = let anf1 = f h in + let anf0 = (anf1::tl_ac0) in + k anf0 + ;; + + let rec map f xs k = let anf2 = is_empty xs in + if anf2 + then k [] + else let anf3 = is_cons xs in + if anf3 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf4 = lam_ll0 f h k in + map f tl anf4 + else fail_match 1 + ;; + + let rec iter f xs = let anf5 = is_empty xs in + if anf5 + then () + else let anf6 = is_cons xs in + if anf6 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let w = f h in + iter f tl + else fail_match 1 + ;; + + let lam_ll1 x = ( + ) x 1 + ;; + + let lam_ll2 x = x + ;; + + let main = let anf10 = (3::[]) in + let anf9 = (2::anf10) in + let anf8 = (1::anf9) in + let anf7 = map lam_ll1 anf8 lam_ll2 in + iter print_int anf7 + ;; + + Типы до приведения в ANF: + val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c + val iter : ('a -> 'b) -> 'a list -> unit + val main : unit + + Типы после приведения в ANF: + val lam_ll0 : ('a -> 'b) -> 'a -> ('b list -> 'c) -> 'b list -> 'c + val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c + val iter : ('a -> 'b) -> 'a list -> unit + val lam_ll1 : int -> int + val lam_ll2 : 'a -> 'a + val main : unit + $ ./anf_runner.exe < manytests/typed/012fibcps.ml + let lam_ll1 a k b = let anf0 = ( + ) a b in + k anf0 + ;; + + let lam_ll0 fib k n a = let anf1 = lam_ll1 a k in + let anf2 = ( - ) n 2 in + fib anf2 anf1 + ;; + + let rec fib n k = let anf3 = ( < ) n 2 in + if anf3 + then k n + else let anf4 = lam_ll0 fib k n in + let anf5 = ( - ) n 1 in + fib anf5 anf4 + ;; + + let lam_ll2 x = x + ;; + + let main = let anf6 = fib 6 lam_ll2 in + print_int anf6 + ;; + + Типы до приведения в ANF: + val fib : int -> (int -> 'a) -> 'a + val main : unit + + Типы после приведения в ANF: + val lam_ll1 : int -> (int -> 'a) -> int -> 'a + val lam_ll0 : (int -> (int -> 'a) -> 'b) -> (int -> 'a) -> int -> int -> 'b + val fib : int -> (int -> 'a) -> 'a + val lam_ll2 : 'a -> 'a + val main : unit + $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml + let id x = x + ;; + + let rec fold_right f acc xs = let anf0 = is_empty xs in + if anf0 + then acc + else let anf1 = is_cons xs in + if anf1 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf2 = fold_right f acc tl in + f h anf2 + else fail_match 1 + ;; + + let lam_ll1 f b g x = let anf3 = f x b in + g anf3 + ;; + + let lam_ll0 fold_right f a bs = let anf4 = lam_ll1 f in + fold_right anf4 id bs a + ;; + + let foldl = lam_ll0 fold_right + ;; + + let lam_ll2 x y = ( * ) x y + ;; + + let main = let anf8 = (3::[]) in + let anf7 = (2::anf8) in + let anf6 = (1::anf7) in + let anf5 = foldl lam_ll2 1 anf6 in + print_int anf5 + ;; + + Типы до приведения в ANF: + val id : 'a -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b + val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val main : unit + + Типы после приведения в ANF: + val id : 'a -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b + val lam_ll1 : ('a -> 'b -> 'c) -> 'b -> ('c -> 'd) -> 'a -> 'd + val lam_ll0 : (('a -> ('b -> 'c) -> 'd -> 'c) -> ('e -> 'e) -> 'f -> 'g -> 'h) -> ('d -> 'a -> 'b) -> 'g -> 'f -> 'h + val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val lam_ll2 : int -> int -> int + val main : unit + + $ ./anf_runner.exe < manytests/typed/015tuples.ml + let rec fix f x = let anf0 = fix f in + f anf0 x + ;; + + let map f p = let a = tuple_get p 0 in + let b = tuple_get p 1 in + let anf1 = f a in + let anf2 = f b in + (anf1, anf2) + ;; + + let lam_ll2 l_ac0 self li x = let anf3 = self l_ac0 in + li anf3 x + ;; + + let lam_ll1 self l_ac0 = let anf4 = lam_ll2 l_ac0 self in + map anf4 l_ac0 + ;; + + let lam_ll0 fix l = fix lam_ll1 l + ;; + + let fixpoly = lam_ll0 fix + ;; + + let feven p n = let e = tuple_get p 0 in + let o = tuple_get p 1 in + let anf5 = ( = ) n 0 in + if anf5 + then 1 + else let anf6 = ( - ) n 1 in + o anf6 + ;; + + let fodd p n = let e = tuple_get p 0 in + let o = tuple_get p 1 in + let anf7 = ( = ) n 0 in + if anf7 + then 0 + else let anf8 = ( - ) n 1 in + e anf8 + ;; + + let tie = let anf9 = (feven, fodd) in + fixpoly anf9 + ;; + + let rec meven n = let anf10 = ( = ) n 0 in + if anf10 + then 1 + else let anf11 = ( - ) n 1 in + modd anf11 + and modd n = let anf12 = ( = ) n 0 in + if anf12 + then 1 + else let anf13 = ( - ) n 1 in + meven anf13 + ;; + + let main = let anf14 = modd 1 in + let () = print_int anf14 in + let anf15 = meven 2 in + let () = print_int anf15 in + let even = tuple_get tie 0 in + let odd = tuple_get tie 1 in + let anf16 = odd 3 in + let () = print_int anf16 in + let anf17 = even 4 in + let () = print_int anf17 in + 0 + ;; + + Типы до приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b + val fixpoly : (('a -> 'b) * ('a -> 'b) -> 'a -> 'b) * (('a -> 'b) * ('a -> 'b) -> 'a -> 'b) -> ('a -> 'b) * ('a -> 'b) + val feven : 'a * (int -> int) -> int -> int + val fodd : (int -> int) * 'a -> int -> int + val tie : (int -> int) * (int -> int) + val meven : int -> int + val modd : int -> int + val main : int + + Типы после приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val map : ('a -> 'b) -> 'c -> 'b * 'b + val lam_ll2 : 'a -> ('a -> 'b) -> ('b -> 'c -> 'd) -> 'c -> 'd + val lam_ll1 : ('a -> 'b) -> 'a -> ('c -> 'd) * ('c -> 'd) + val lam_ll0 : ((('a -> 'b) -> 'a -> ('c -> 'd) * ('c -> 'd)) -> 'e -> 'f) -> 'e -> 'f + val fixpoly : 'a -> ('b -> 'c) * ('b -> 'c) + val feven : 'a -> int -> int + val fodd : 'a -> int -> int + val tie : ('a -> 'b) * ('a -> 'b) + val meven : int -> int + val modd : int -> int + val main : int + + $ ./anf_runner.exe < manytests/typed/016lists.ml + let rec length xs = let anf0 = is_empty xs in + if anf0 + then 0 + else let anf1 = is_cons xs in + if anf1 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf2 = length tl in + ( + ) 1 anf2 + else fail_match 1 + ;; + + let rec helper_ll0 acc xs = let anf3 = is_empty xs in + if anf3 + then acc + else let anf4 = is_cons xs in + if anf4 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf5 = ( + ) acc 1 in + helper_ll0 anf5 tl + else fail_match 1 + ;; + + let length_tail = helper_ll0 0 + ;; + + let rec map f xs = let anf6 = is_empty xs in + if anf6 + then [] + else let anf9 = tl_list_get xs in + let anf8 = is_empty anf9 in + let anf10 = is_cons xs in + let anf7 = ( && ) anf10 anf8 in + if anf7 + then let a = hd_list_get xs in + let anf11 = f a in + (anf11::[]) + else let anf14 = tl_list_get xs in + let anf13 = is_cons anf14 in + let anf18 = tl_list_get xs in + let anf17 = tl_list_get anf18 in + let anf16 = is_empty anf17 in + let anf19 = is_cons xs in + let anf15 = ( && ) anf19 anf16 in + let anf12 = ( && ) anf15 anf13 in + if anf12 + then let a = hd_list_get xs in + let anf20 = tl_list_get xs in + let b = hd_list_get anf20 in + let anf21 = f a in + let anf23 = f b in + let anf22 = (anf23::[]) in + (anf21::anf22) + else let anf26 = tl_list_get xs in + let anf25 = is_cons anf26 in + let anf30 = tl_list_get xs in + let anf29 = tl_list_get anf30 in + let anf28 = is_cons anf29 in + let anf35 = tl_list_get xs in + let anf34 = tl_list_get anf35 in + let anf33 = tl_list_get anf34 in + let anf32 = is_empty anf33 in + let anf36 = is_cons xs in + let anf31 = ( && ) anf36 anf32 in + let anf27 = ( && ) anf31 anf28 in + let anf24 = ( && ) anf27 anf25 in + if anf24 + then let a = hd_list_get xs in + let anf37 = tl_list_get xs in + let b = hd_list_get anf37 in + let anf39 = tl_list_get xs in + let anf38 = tl_list_get anf39 in + let c = hd_list_get anf38 in + let anf40 = f a in + let anf42 = f b in + let anf44 = f c in + let anf43 = (anf44::[]) in + let anf41 = (anf42::anf43) in + (anf40::anf41) + else let anf47 = tl_list_get xs in + let anf46 = is_cons anf47 in + let anf51 = tl_list_get xs in + let anf50 = tl_list_get anf51 in + let anf49 = is_cons anf50 in + let anf56 = tl_list_get xs in + let anf55 = tl_list_get anf56 in + let anf54 = tl_list_get anf55 in + let anf53 = is_cons anf54 in + let anf57 = is_cons xs in + let anf52 = ( && ) anf57 anf53 in + let anf48 = ( && ) anf52 anf49 in + let anf45 = ( && ) anf48 anf46 in + if anf45 + then let a = hd_list_get xs in + let anf58 = tl_list_get xs in + let b = hd_list_get anf58 in + let anf60 = tl_list_get xs in + let anf59 = tl_list_get anf60 in + let c = hd_list_get anf59 in + let anf63 = tl_list_get xs in + let anf62 = tl_list_get anf63 in + let anf61 = tl_list_get anf62 in + let d = hd_list_get anf61 in + let anf66 = tl_list_get xs in + let anf65 = tl_list_get anf66 in + let anf64 = tl_list_get anf65 in + let tl = tl_list_get anf64 in + let anf67 = f a in + let anf69 = f b in + let anf71 = f c in + let anf73 = f d in + let anf74 = map f tl in + let anf72 = (anf73::anf74) in + let anf70 = (anf71::anf72) in + let anf68 = (anf69::anf70) in + (anf67::anf68) + else fail_match 1 + ;; + + let rec append xs ys = let anf75 = is_empty xs in + if anf75 + then ys + else let anf76 = is_cons xs in + if anf76 + then let x = hd_list_get xs in + let xs_ac0 = tl_list_get xs in + let anf77 = append xs_ac0 ys in + (x::anf77) + else fail_match 1 + ;; + + let rec helper_ll1 append xs = let anf78 = is_empty xs in + if anf78 + then [] + else let anf79 = is_cons xs in + if anf79 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf80 = helper_ll1 append tl in + append h anf80 + else fail_match 1 + ;; + + let concat = helper_ll1 append + ;; + + let rec iter f xs = let anf81 = is_empty xs in + if anf81 + then () + else let anf82 = is_cons xs in + if anf82 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let () = f h in + iter f tl + else fail_match 1 + ;; + + let lam_ll2 h a = (h, a) + ;; + + let rec cartesian xs ys = let anf83 = is_empty xs in + if anf83 + then [] + else let anf84 = is_cons xs in + if anf84 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf85 = cartesian tl ys in + let anf87 = lam_ll2 h in + let anf86 = map anf87 ys in + append anf86 anf85 + else fail_match 1 + ;; + + let main = let anf90 = (3::[]) in + let anf89 = (2::anf90) in + let anf88 = (1::anf89) in + let () = iter print_int anf88 in + let anf96 = (4::[]) in + let anf95 = (3::anf96) in + let anf94 = (2::anf95) in + let anf93 = (1::anf94) in + let anf98 = (2::[]) in + let anf97 = (1::anf98) in + let anf92 = cartesian anf97 anf93 in + let anf91 = length anf92 in + let () = print_int anf91 in + 0 + ;; + + Типы до приведения в ANF: + val length : 'a list -> int + val length_tail : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val cartesian : 'a list -> 'b list -> 'a * 'b list + val main : int + + Типы после приведения в ANF: + val length : 'a list -> int + val helper_ll0 : int -> 'a list -> int + val length_tail : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val append : 'a list -> 'a list -> 'a list + val helper_ll1 : ('a -> 'b list -> 'b list) -> 'a list -> 'b list + val concat : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val lam_ll2 : 'a -> 'b -> 'a * 'b + val cartesian : 'a list -> 'b list -> 'a * 'b list + val main : int diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml new file mode 100644 index 000000000..68b452612 --- /dev/null +++ b/FML/tests/anf_runner.ml @@ -0,0 +1,41 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.Inf_pprint +open Fml_lib.A_conv +open Fml_lib.Match_elimination +open Fml_lib.C_conv +open Fml_lib.Anf +open Fml_lib.Lambda_lift +open Fml_lib.Anf_ast + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok types -> Ok (parsed, types) + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok (ast, (env, names_list)) -> + let ast = ac_program ast in + let ast_me = match_elimination ast in + let ast_cc = cc_program ast_me in + let ast_ll = lambda_lift ast_cc in + let ast_anf = anf ast_ll in + let result = Format.asprintf "%a" pp_anf_program ast_anf in + let () = Format.printf "%a\n" pp_anf_program ast_anf in + let () = Format.printf "\nТипы до приведения в ANF:\n" in + let () = print_program_type env names_list in + let () = Format.printf "\nТипы после приведения в ANF:\n" in + (match parse_and_infer result with + | Ok (_, (env, names_list)) -> print_program_type env names_list + | Error e -> Format.printf "%s" e) + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t new file mode 100644 index 000000000..75428a33a --- /dev/null +++ b/FML/tests/c_conv_manytest.t @@ -0,0 +1,345 @@ + $ ./c_conv_runner.exe << EOF + > let main = + > let rec fib n k = + > if n < 2 + > then k n + > else fib (n - 1) (fun a -> fib (n - 2) (fun b -> k (a + b))) in print_int(fib 6 (fun x -> x)) + > EOF + let main = let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) ((((fun fib k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) fib) k) n))) in + (print_int ((fib 6) (fun x -> x))) + + $ ./c_conv_runner.exe << EOF + > let f x = let g y = x + y in g 5;; + > EOF + let f = (fun x -> let g = (fun x y -> ((( + ) x) y)) in + ((g x) 5)) + + $ ./c_conv_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let length = (fun xs -> if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + 2 + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) + then let a = (hd_list_get xs) in + 1 + else if (is_empty xs) + then 0 + else (fail_match 1)) + + $ ./c_conv_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let is_empty_ac0 = (fun x -> ((( + ) x) 1)) + + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let tl = (tl_list_get xs) in + ((( + ) 1) (length xs)) + else (fail_match 1)) + + $ ./c_conv_runner.exe << EOF + > let (a, b) = (5,6) + > EOF + let tmp_me0 = (5, 6) + let a = ((tuple_get tmp_me0) 0) + let b = ((tuple_get tmp_me0) 1) + + $ ./c_conv_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let fac = (fun n -> let rec fack = (fun n_ac0 k -> if ((( <= ) n_ac0) 1) + then (k 1) + else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) k) n_ac0))) in + ((fack n) (fun x -> x))) + + $ ./c_conv_runner.exe << EOF + > let f x = match x with + > | 1 -> 12 + > | 12 -> 12 + > | _ -> 325 + > EOF + let f = (fun x -> if ((( = ) x) 1) + then 12 + else if ((( = ) x) 12) + then 12 + else if true + then 325 + else (fail_match 1)) + + $ ./c_conv_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/002fac.ml + let rec fac_cps = (fun n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) (((fun k n p -> (k ((( * ) p) n))) k) n))) + + let main = let () = (print_int ((fac_cps 4) (fun print_int_ac0 -> print_int_ac0))) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a b c -> let a_ac0 = (print_int a) in + let b_ac1 = (print_int b) in + let c_ac2 = (print_int c) in + 0) + + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let fac = (fun self n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/006partial.ml + let foo = (fun b -> if b + then (fun foo -> ((( + ) foo) 2)) + else (fun foo -> ((( * ) foo) 10))) + + let foo_ac0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) + + let main = let () = (print_int (foo_ac0 11)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))) + + let main = let foo_ac0 = (foo 1) in + let foo_ac1 = (foo_ac0 2) in + let foo_ac2 = (foo_ac1 3) in + let () = (print_int foo_ac2) in + 0 + $ ./c_conv_runner.exe < manytests/typed/006partial3.ml + let foo = (fun a -> let () = (print_int a) in + (fun b -> let () = (print_int b) in + (fun c -> (print_int c)))) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./c_conv_runner.exe < manytests/typed/007order.ml + let _start_ac0 = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) + + let main = (print_int (((((((((_start_ac0 (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./c_conv_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f g x -> ((f x) (g x))) + + let main = let () = (print_int (((addi (fun x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2))) (fun _start_ac0 -> ((( = ) ((( / ) _start_ac0) 2)) 0))) 4)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = (fun x -> x) in + ((f 1), (f true)) + + $ ./c_conv_runner.exe < manytests/typed/011mapcps.ml + let rec map = (fun f xs k -> if (is_empty xs) + then (k []) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + (((map f) tl) ((((fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) f) h) k)) + else (fail_match 1)) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let w = (f h) in + ((iter f) tl) + else (fail_match 1)) + + let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) + $ ./c_conv_runner.exe < manytests/typed/012fibcps.ml + let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) ((((fun fib k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) fib) k) n))) + + let main = (print_int ((fib 6) (fun x -> x))) + $ ./c_conv_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = (fun f acc xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((f h) (((fold_right f) acc) tl)) + else (fail_match 1)) + + let foldl = ((fun fold_right f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) fold_right) + + let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) + + $ ./c_conv_runner.exe < manytests/typed/015tuples.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let map = (fun f p -> let a = ((tuple_get p) 0) in + let b = ((tuple_get p) 1) in + ((f a), (f b))) + + let fixpoly = ((fun fix l -> ((fix (fun self l_ac0 -> ((map (((fun l_ac0 self li x -> ((li (self l_ac0)) x)) l_ac0) self)) l_ac0))) l)) fix) + + let feven = (fun p n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 1 + else (o ((( - ) n) 1))) + + let fodd = (fun p n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 0 + else (e ((( - ) n) 1))) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = ((tuple_get tie) 0) in + let odd = ((tuple_get tie) 1) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/016lists.ml + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length tl)) + else (fail_match 1)) + + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((helper ((( + ) acc) 1)) tl) + else (fail_match 1)) in + (helper 0) + + let rec map = (fun f xs -> if (is_empty xs) + then [] + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) + then let a = (hd_list_get xs) in + ((f a)::[]) + else if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + ((f a)::((f b)::[])) + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + ((f a)::((f b)::((f c)::[]))) + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else (fail_match 1)) + + let rec append = (fun xs ys -> if (is_empty xs) + then ys + else if (is_cons xs) + then let x = (hd_list_get xs) in + let xs_ac0 = (tl_list_get xs) in + (x::((append xs_ac0) ys)) + else (fail_match 1)) + + let concat = let rec helper = (fun append xs -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append h) ((helper append) tl)) + else (fail_match 1)) in + (helper append) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let () = (f h) in + ((iter f) tl) + else (fail_match 1)) + + let rec cartesian = (fun xs ys -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) + else (fail_match 1)) + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + diff --git a/FML/tests/c_conv_runner.ml b/FML/tests/c_conv_runner.ml new file mode 100644 index 000000000..1bc6aab83 --- /dev/null +++ b/FML/tests/c_conv_runner.ml @@ -0,0 +1,29 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv +open Fml_lib.Match_elimination +open Fml_lib.C_conv +open Fml_lib.Me_ast + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + let ast_me = match_elimination ast in + let ast_cc = cc_program ast_me in + Format.printf "%a\n" pp_me_program ast_cc + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/dune b/FML/tests/dune index 7e2970e6b..61df4b66f 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -20,6 +20,36 @@ (modules inferencer_runner) (libraries fml_lib stdio)) +(executable + (name a_conv_runner) + (public_name a_conv_runner) + (modules a_conv_runner) + (libraries fml_lib stdio)) + +(executable + (name c_conv_runner) + (public_name c_conv_runner) + (modules c_conv_runner) + (libraries fml_lib stdio)) + +(executable + (name match_elimination_runner) + (public_name match_elimination_runner) + (modules match_elimination_runner) + (libraries fml_lib stdio)) + +(executable + (name lambda_lift_runner) + (public_name lambda_lift_runner) + (modules lambda_lift_runner) + (libraries fml_lib stdio)) + +(executable + (name anf_runner) + (public_name anf_runner) + (modules anf_runner) + (libraries fml_lib stdio)) + (cram (applies_to parser_manytests) (deps @@ -40,7 +70,9 @@ manytests/typed/007order.ml manytests/typed/008ascription.ml manytests/typed/009let_poly.ml - manytests/typed/010sukharev.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) @@ -64,6 +96,164 @@ manytests/typed/007order.ml manytests/typed/008ascription.ml manytests/typed/009let_poly.ml - manytests/typed/010sukharev.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to a_conv_manytest) + (deps + ./a_conv_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to c_conv_manytest) + (deps + ./c_conv_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to lambda_lifting_manytests) + (deps + ./lambda_lifting_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to match_elimination_manytest) + (deps + ./match_elimination_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to lambda_lift_manytest) + (deps + ./lambda_lift_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to anf_manytest) + (deps + ./anf_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) diff --git a/FML/tests/inferencer_manytests.t b/FML/tests/inferencer_manytests.t index ef8f5b272..249ec35ba 100644 --- a/FML/tests/inferencer_manytests.t +++ b/FML/tests/inferencer_manytests.t @@ -45,6 +45,19 @@ $ ./inferencer_runner.exe < manytests/typed/009let_poly.ml val temp : int * bool + $ ./inferencer_runner.exe < manytests/typed/011mapcps.ml + val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c + val iter : ('a -> 'b) -> 'a list -> unit + val main : unit + $ ./inferencer_runner.exe < manytests/typed/012fibcps.ml + val fib : int -> (int -> 'a) -> 'a + val main : unit + $ ./inferencer_runner.exe < manytests/typed/013foldfoldr.ml + val id : 'a -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b + val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val main : unit + $ ./inferencer_runner.exe < manytests/typed/015tuples.ml val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b @@ -79,4 +92,3 @@ $ ./inferencer_runner.exe < manytests/do_not_type/015tuples.ml Type error: Only variables are allowed as left-hand side of `let rec' - diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t new file mode 100644 index 000000000..705db3864 --- /dev/null +++ b/FML/tests/lambda_lift_manytest.t @@ -0,0 +1,427 @@ + $ ./lambda_lift_runner.exe << EOF + > let main = + > let rec fib n k = + > if n < 2 + > then k n + > else fib (n - 1) (fun a -> fib (n - 2) (fun b -> k (a + b))) in print_int(fib 6 (fun x -> x)) + > EOF + let lam_ll2 = (fun a k b -> (k ((( + ) a) b))) + + let lam_ll1 = (fun fib_ll0 k n a -> ((fib_ll0 ((( - ) n) 2)) ((lam_ll2 a) k))) + + let rec fib_ll0 = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib_ll0 ((( - ) n) 1)) (((lam_ll1 fib_ll0) k) n))) + + let lam_ll3 = (fun x -> x) + + let main = (print_int ((fib_ll0 6) lam_ll3)) + + $ ./lambda_lift_runner.exe << EOF + > let f x = let g y = x + y in g 5;; + > EOF + let g_ll0 = (fun x y -> ((( + ) x) y)) + + let f = (fun x -> ((g_ll0 x) 5)) + + $ ./lambda_lift_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let length = (fun xs -> if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + 2 + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) + then let a = (hd_list_get xs) in + 1 + else if (is_empty xs) + then 0 + else (fail_match 1)) + + $ ./lambda_lift_runner.exe << EOF + > let f = let y x = x + 1 in y 3;; + > EOF + let y_ll0 = (fun x -> ((( + ) x) 1)) + + let f = (y_ll0 3) + + $ ./lambda_lift_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let length = (fun xs -> if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + 2 + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) + then let a = (hd_list_get xs) in + 1 + else if (is_empty xs) + then 0 + else (fail_match 1)) + + $ ./lambda_lift_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let is_empty_ac0 = (fun x -> ((( + ) x) 1)) + + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let tl = (tl_list_get xs) in + ((( + ) 1) (length xs)) + else (fail_match 1)) + + $ ./lambda_lift_runner.exe << EOF + > let (a, b) = (5,6) + > EOF + let tmp_me0 = (5, 6) + let a = ((tuple_get tmp_me0) 0) + let b = ((tuple_get tmp_me0) 1) + + $ ./lambda_lift_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let lam_ll1 = (fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) + + let rec fack_ll0 = (fun n_ac0 k -> if ((( <= ) n_ac0) 1) + then (k 1) + else ((fack_ll0 ((( - ) n_ac0) 1)) ((lam_ll1 k) n_ac0))) + + let lam_ll2 = (fun x -> x) + + let fac = (fun n -> ((fack_ll0 n) lam_ll2)) + + $ ./lambda_lift_runner.exe << EOF + > let f x = match x with + > | 1 -> 12 + > | 12 -> 12 + > | _ -> 325 + > EOF + let f = (fun x -> if ((( = ) x) 1) + then 12 + else if ((( = ) x) 12) + then 12 + else if true + then 325 + else (fail_match 1)) + + $ ./lambda_lift_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/002fac.ml + let lam_ll0 = (fun k n p -> (k ((( * ) p) n))) + + let rec fac_cps = (fun n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) ((lam_ll0 k) n))) + + let lam_ll1 = (fun print_int_ac0 -> print_int_ac0) + + let main = let () = (print_int ((fac_cps 4) lam_ll1)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a b c -> let a_ac0 = (print_int a) in + let b_ac1 = (print_int b) in + let c_ac2 = (print_int c) in + 0) + + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let fac = (fun self n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/006partial.ml + let lam_ll0 = (fun foo -> ((( + ) foo) 2)) + + let lam_ll1 = (fun foo -> ((( * ) foo) 10)) + + let foo = (fun b -> if b + then lam_ll0 + else lam_ll1) + + let foo_ac0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) + + let main = let () = (print_int (foo_ac0 11)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))) + + let main = let foo_ac0 = (foo 1) in + let foo_ac1 = (foo_ac0 2) in + let foo_ac2 = (foo_ac1 3) in + let () = (print_int foo_ac2) in + 0 + $ ./lambda_lift_runner.exe < manytests/typed/006partial3.ml + let lam_ll1 = (fun c -> (print_int c)) + + let lam_ll0 = (fun b -> let () = (print_int b) in + lam_ll1) + + let foo = (fun a -> let () = (print_int a) in + lam_ll0) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./lambda_lift_runner.exe < manytests/typed/007order.ml + let _start_ac0 = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) + + let main = (print_int (((((((((_start_ac0 (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./lambda_lift_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f g x -> ((f x) (g x))) + + let lam_ll0 = (fun x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2)) + + let lam_ll1 = (fun _start_ac0 -> ((( = ) ((( / ) _start_ac0) 2)) 0)) + + let main = let () = (print_int (((addi lam_ll0) lam_ll1) 4)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/009let_poly.ml + let f_ll0 = (fun x -> x) + + let temp = ((f_ll0 1), (f_ll0 true)) + + $ ./lambda_lift_runner.exe < manytests/typed/011mapcps.ml + let lam_ll0 = (fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) + + let rec map = (fun f xs k -> if (is_empty xs) + then (k []) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + (((map f) tl) (((lam_ll0 f) h) k)) + else (fail_match 1)) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let w = (f h) in + ((iter f) tl) + else (fail_match 1)) + + let lam_ll1 = (fun x -> ((( + ) x) 1)) + + let lam_ll2 = (fun x -> x) + + let main = ((iter print_int) (((map lam_ll1) (1::(2::(3::[])))) lam_ll2)) + $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml + let lam_ll1 = (fun a k b -> (k ((( + ) a) b))) + + let lam_ll0 = (fun fib k n a -> ((fib ((( - ) n) 2)) ((lam_ll1 a) k))) + + let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) (((lam_ll0 fib) k) n))) + + let lam_ll2 = (fun x -> x) + + let main = (print_int ((fib 6) lam_ll2)) + $ ./lambda_lift_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = (fun f acc xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((f h) (((fold_right f) acc) tl)) + else (fail_match 1)) + + let lam_ll1 = (fun f b g x -> (g ((f x) b))) + + let lam_ll0 = (fun fold_right f a bs -> ((((fold_right (lam_ll1 f)) id) bs) a)) + + let foldl = (lam_ll0 fold_right) + + let lam_ll2 = (fun x y -> ((( * ) x) y)) + + let main = (print_int (((foldl lam_ll2) 1) (1::(2::(3::[]))))) + + $ ./lambda_lift_runner.exe < manytests/typed/015tuples.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let map = (fun f p -> let a = ((tuple_get p) 0) in + let b = ((tuple_get p) 1) in + ((f a), (f b))) + + let lam_ll2 = (fun l_ac0 self li x -> ((li (self l_ac0)) x)) + + let lam_ll1 = (fun self l_ac0 -> ((map ((lam_ll2 l_ac0) self)) l_ac0)) + + let lam_ll0 = (fun fix l -> ((fix lam_ll1) l)) + + let fixpoly = (lam_ll0 fix) + + let feven = (fun p n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 1 + else (o ((( - ) n) 1))) + + let fodd = (fun p n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 0 + else (e ((( - ) n) 1))) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = ((tuple_get tie) 0) in + let odd = ((tuple_get tie) 1) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/016lists.ml + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length tl)) + else (fail_match 1)) + + let rec helper_ll0 = (fun acc xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((helper_ll0 ((( + ) acc) 1)) tl) + else (fail_match 1)) + + let length_tail = (helper_ll0 0) + + let rec map = (fun f xs -> if (is_empty xs) + then [] + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) + then let a = (hd_list_get xs) in + ((f a)::[]) + else if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + ((f a)::((f b)::[])) + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + ((f a)::((f b)::((f c)::[]))) + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else (fail_match 1)) + + let rec append = (fun xs ys -> if (is_empty xs) + then ys + else if (is_cons xs) + then let x = (hd_list_get xs) in + let xs_ac0 = (tl_list_get xs) in + (x::((append xs_ac0) ys)) + else (fail_match 1)) + + let rec helper_ll1 = (fun append xs -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append h) ((helper_ll1 append) tl)) + else (fail_match 1)) + + let concat = (helper_ll1 append) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let () = (f h) in + ((iter f) tl) + else (fail_match 1)) + + let lam_ll2 = (fun h a -> (h, a)) + + let rec cartesian = (fun xs ys -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append ((map (lam_ll2 h)) ys)) ((cartesian tl) ys)) + else (fail_match 1)) + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + diff --git a/FML/tests/lambda_lift_runner.ml b/FML/tests/lambda_lift_runner.ml new file mode 100644 index 000000000..faadc6d24 --- /dev/null +++ b/FML/tests/lambda_lift_runner.ml @@ -0,0 +1,31 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv +open Fml_lib.Match_elimination +open Fml_lib.Lambda_lift +open Fml_lib.Me_ast +open Fml_lib.C_conv + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + let ast_me = match_elimination ast in + let ast_cc = cc_program ast_me in + let ast_ll = lambda_lift ast_cc in + Format.printf "%a\n" pp_me_program ast_ll + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t new file mode 100644 index 000000000..e770c3d07 --- /dev/null +++ b/FML/tests/match_elimination_manytest.t @@ -0,0 +1,360 @@ + $ ./match_elimination_runner.exe << EOF + > let f (x,y) [] h::[] = x+y + h;; + > let main = let () = print_int ( f (1,2) [] [1]) in 0;; + > EOF + let f = (fun me_me2 me_me1 me_me0 -> if ((( && ) ((( && ) (is_empty me_me1)) (is_cons me_me0))) (is_empty (tl_list_get me_me0))) + then let x = ((tuple_get me_me2) 0) in + let y = ((tuple_get me_me2) 1) in + let h = (hd_list_get me_me0) in + ((( + ) ((( + ) x) y)) h) + else (fail_match 1)) + + let main = let () = (print_int (((f (1, 2)) []) (1::[]))) in + 0 + + $ ./match_elimination_runner.exe << EOF + > let f = let y x = x + 1 in y 3;; + > EOF + let f = let y = (fun x -> ((( + ) x) 1)) in + (y 3) + + $ ./match_elimination_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let length = (fun xs -> if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + 2 + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) + then let a = (hd_list_get xs) in + 1 + else if (is_empty xs) + then 0 + else (fail_match 1)) + + $ ./match_elimination_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let is_empty_ac0 = (fun x -> ((( + ) x) 1)) + + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let tl = (tl_list_get xs) in + ((( + ) 1) (length xs)) + else (fail_match 1)) + + $ ./match_elimination_runner.exe << EOF + > let (a, b) = (5,6) + > EOF + let tmp_me0 = (5, 6) + let a = ((tuple_get tmp_me0) 0) + let b = ((tuple_get tmp_me0) 1) + + $ ./match_elimination_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let fac = (fun n -> let rec fack = (fun n_ac0 k -> if ((( <= ) n_ac0) 1) + then (k 1) + else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) k) n_ac0))) in + ((fack n) (fun x -> x))) + + $ ./match_elimination_runner.exe << EOF + > let f x = match x with + > | 1 -> 12 + > | 12 -> 12 + > | _ -> 325 + > EOF + let f = (fun x -> if ((( = ) x) 1) + then 12 + else if ((( = ) x) 12) + then 12 + else if true + then 325 + else (fail_match 1)) + + $ ./match_elimination_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/002fac.ml + let rec fac_cps = (fun n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n))))) + + let main = let () = (print_int ((fac_cps 4) (fun print_int_ac0 -> print_int_ac0))) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a b c -> let a_ac0 = (print_int a) in + let b_ac1 = (print_int b) in + let c_ac2 = (print_int c) in + 0) + + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let fac = (fun self n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/006partial.ml + let foo = (fun b -> if b + then (fun foo -> ((( + ) foo) 2)) + else (fun foo -> ((( * ) foo) 10))) + + let foo_ac0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) + + let main = let () = (print_int (foo_ac0 11)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))) + + let main = let foo_ac0 = (foo 1) in + let foo_ac1 = (foo_ac0 2) in + let foo_ac2 = (foo_ac1 3) in + let () = (print_int foo_ac2) in + 0 + $ ./match_elimination_runner.exe < manytests/typed/006partial3.ml + let foo = (fun a -> let () = (print_int a) in + (fun b -> let () = (print_int b) in + (fun c -> (print_int c)))) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./match_elimination_runner.exe < manytests/typed/007order.ml + let _start_ac0 = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) + + let main = (print_int (((((((((_start_ac0 (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./match_elimination_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f g x -> ((f x) (g x))) + + let main = let () = (print_int (((addi (fun x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2))) (fun _start_ac0 -> ((( = ) ((( / ) _start_ac0) 2)) 0))) 4)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = (fun x -> x) in + ((f 1), (f true)) + + $ ./match_elimination_runner.exe < manytests/typed/011mapcps.ml + let rec map = (fun f xs k -> if (is_empty xs) + then (k []) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + (((map f) tl) (fun tl_ac0 -> (k ((f h)::tl_ac0)))) + else (fail_match 1)) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let w = (f h) in + ((iter f) tl) + else (fail_match 1)) + + let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) + $ ./match_elimination_runner.exe < manytests/typed/012fibcps.ml + let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) (fun a -> ((fib ((( - ) n) 2)) (fun b -> (k ((( + ) a) b))))))) + + let main = (print_int ((fib 6) (fun x -> x))) + $ ./match_elimination_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = (fun f acc xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((f h) (((fold_right f) acc) tl)) + else (fail_match 1)) + + let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) + + let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) + + $ ./match_elimination_runner.exe < manytests/typed/015tuples.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let map = (fun f p -> let a = ((tuple_get p) 0) in + let b = ((tuple_get p) 1) in + ((f a), (f b))) + + let fixpoly = (fun l -> ((fix (fun self l_ac0 -> ((map (fun li x -> ((li (self l_ac0)) x))) l_ac0))) l)) + + let feven = (fun p n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 1 + else (o ((( - ) n) 1))) + + let fodd = (fun p n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 0 + else (e ((( - ) n) 1))) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = ((tuple_get tie) 0) in + let odd = ((tuple_get tie) 1) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/016lists.ml + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length tl)) + else (fail_match 1)) + + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((helper ((( + ) acc) 1)) tl) + else (fail_match 1)) in + (helper 0) + + let rec map = (fun f xs -> if (is_empty xs) + then [] + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) + then let a = (hd_list_get xs) in + ((f a)::[]) + else if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + ((f a)::((f b)::[])) + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + ((f a)::((f b)::((f c)::[]))) + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else (fail_match 1)) + + let rec append = (fun xs ys -> if (is_empty xs) + then ys + else if (is_cons xs) + then let x = (hd_list_get xs) in + let xs_ac0 = (tl_list_get xs) in + (x::((append xs_ac0) ys)) + else (fail_match 1)) + + let concat = let rec helper = (fun xs -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append h) (helper tl)) + else (fail_match 1)) in + helper + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let () = (f h) in + ((iter f) tl) + else (fail_match 1)) + + let rec cartesian = (fun xs ys -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) + else (fail_match 1)) + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + + $ ./match_elimination_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./match_elimination_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./match_elimination_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./match_elimination_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./match_elimination_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/match_elimination_runner.ml b/FML/tests/match_elimination_runner.ml new file mode 100644 index 000000000..67def54cd --- /dev/null +++ b/FML/tests/match_elimination_runner.ml @@ -0,0 +1,27 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv +open Fml_lib.Match_elimination +open Fml_lib.Me_ast + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + let ast_me = match_elimination ast in + Format.printf "%a\n" pp_me_program ast_me + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/parser_manytests.t b/FML/tests/parser_manytests.t index c4f811f04..8f63ffa06 100644 --- a/FML/tests/parser_manytests.t +++ b/FML/tests/parser_manytests.t @@ -667,7 +667,217 @@ )) ]) ] - + $ ./parser_runner.exe < manytests/typed/011mapcps.ml + [(RecDecl + [(DDeclaration ((PIdentifier "map"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EFun ((PIdentifier "k"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EApplication ((EIdentifier "k"), ENill))); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "map"), + (EIdentifier "f"))), + (EIdentifier "tl"))), + (EFun ((PIdentifier "tl"), + (EApplication ((EIdentifier "k"), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "h"))), + (EIdentifier "tl"))) + )) + )) + ))) + ] + )) + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "iter"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, EUnit); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (ELetIn (NoRec, (PIdentifier "w"), + (EApplication ((EIdentifier "f"), (EIdentifier "h"))), + (EApplication ( + (EApplication ((EIdentifier "iter"), + (EIdentifier "f"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ( + (EApplication ((EIdentifier "iter"), (EIdentifier "print_int"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "map"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "x"))), + (EConst (CInt 1)))) + )) + )), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + ]) + ] + $ ./parser_runner.exe < manytests/typed/012fibcps.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fib"), + (EFun ((PIdentifier "n"), + (EFun ((PIdentifier "k"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( < )"), (EIdentifier "n"))), + (EConst (CInt 2)))), + (EApplication ((EIdentifier "k"), (EIdentifier "n"))), + (EApplication ( + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )), + (EFun ((PIdentifier "a"), + (EApplication ( + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 2)))) + )), + (EFun ((PIdentifier "b"), + (EApplication ((EIdentifier "k"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "a"))), + (EIdentifier "b"))) + )) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ((EIdentifier "fib"), (EConst (CInt 6)))), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + ]) + ] + $ ./parser_runner.exe < manytests/typed/013foldfoldr.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "id"), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "fold_right"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "acc"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EIdentifier "acc")); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "f"), + (EIdentifier "h"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fold_right"), + (EIdentifier "f"))), + (EIdentifier "acc"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "foldl"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "bs"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fold_right"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "g"), + (EFun ((PIdentifier "x"), + (EApplication ((EIdentifier "g"), + (EApplication ( + (EApplication ( + (EIdentifier "f"), + (EIdentifier "x"))), + (EIdentifier "b"))) + )) + )) + )) + )) + )), + (EIdentifier "id"))), + (EIdentifier "bs"))), + (EIdentifier "a"))) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "foldl"), + (EFun ((PIdentifier "x"), + (EFun ((PIdentifier "y"), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "x"))), + (EIdentifier "y"))) + )) + )) + )), + (EConst (CInt 1)))), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )) + )) + )) + ]) + ] $ ./parser_runner.exe < manytests/typed/015tuples.ml [(RecDecl [(DDeclaration ((PIdentifier "fix"), @@ -734,7 +944,7 @@ (EIdentifier "p"), (EIf ( (EApplication ( - (EApplication ((EIdentifier "( == )"), + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), (EConst (CInt 0)))), (EConst (CInt 1)), @@ -759,7 +969,7 @@ (EIdentifier "p"), (EIf ( (EApplication ( - (EApplication ((EIdentifier "( == )"), + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), (EConst (CInt 0)))), (EConst (CInt 0)), @@ -1154,3 +1364,4 @@ (ETuple [(EIdentifier "a"); (EIdentifier "b")]))) ]) ] +