[D] (E) FML: Middleend + LLVM

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
+  }

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
+;;

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

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
+
+

FML/bin/manytests

@@ -0,0 +1 @@
+../../manytests

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
+