XML: LLVM + Typecheck (by Michael Gavrilenko, Danila Rudnev-Stepanyan and Daniel Vlasenko)

XML/.gitignore

@@ -5,3 +5,4 @@
 *.o
 *.out
 *.exe
+*.ll

XML/XML.opam

@@ -1,8 +1,10 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-synopsis: "A short LLVM demo"
-maintainer: ["Mikhail Gavrilenko" "Danila Rudnev-Stepanyan"]
-authors: ["Mikhail Gavrilenko" "Danila Rudnev-Stepanyan"]
+synopsis: "A small ML compiler"
+maintainer: [
+  "Mikhail Gavrilenko" "Danila Rudnev-Stepanyan" "Daniel Vlasenko"
+]
+authors: ["Mikhail Gavrilenko" "Danila Rudnev-Stepanyan" "Daniel Vlasenko"]
 license: "LGPL-3.0-or-later WITH OCaml-LGPL-linking-exception"
 homepage: "https://github.com/Kakadu/comp24"
 bug-reports: "https://github.com/Kakadu/comp24/issues"
@@ -33,7 +35,7 @@ build: [
 ]
 dev-repo: "git+https://github.com/Kakadu/comp24.git"
 depexts: [
-  [ "llvm-18-dev" "clang-18" "gcc-riscv64-linux-gnu" "g++-riscv64-linux-gnu" "qemu-user"] {os-distribution = "ubuntu"}
+  [ "llvm-18-dev" "clang-18" "llc-18" "gcc-riscv64-linux-gnu" "g++-riscv64-linux-gnu" "qemu-user"] {os-distribution = "ubuntu"}
 ]
 pin-depends: [
   ["ppx_deriving_qcheck.0.6" "git+https://github.com/c-cube/qcheck.git#42429bf06ba12373cad02b1404f50d0ad6238af5"]

XML/XML.opam.template

@@ -1,5 +1,5 @@
 depexts: [
-  [ "llvm-18-dev" "clang-18" "gcc-riscv64-linux-gnu" "g++-riscv64-linux-gnu" "qemu-user"] {os-distribution = "ubuntu"}
+  [ "llvm-18-dev" "clang-18" "llc-18" "gcc-riscv64-linux-gnu" "g++-riscv64-linux-gnu" "qemu-user"] {os-distribution = "ubuntu"}
 ]
 pin-depends: [
   ["ppx_deriving_qcheck.0.6" "git+https://github.com/c-cube/qcheck.git#42429bf06ba12373cad02b1404f50d0ad6238af5"]

XML/bin/XML.ml

@@ -1,8 +1,9 @@
-(** Copyright 2024-2025, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *)
+(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *)
 
 (** SPDX-License-Identifier: LGPL-3.0-or-later *)
 
 open Format
+open Common.Pprinter
 
 (* ------------------------------- *)
 (*       Command-line Options      *)
@@ -17,6 +18,8 @@ type options =
   ; mutable show_cc : bool
   ; mutable show_ll : bool
   ; mutable gc_stats : bool
+  ; mutable check_types : bool
+  ; mutable show_types : bool
   }
 
 (* ------------------------------- *)
@@ -36,6 +39,17 @@ let to_asm ~gc_stats ast : string =
 
 let compile_and_write options source_code =
   let ast = Common.Parser.parse_str source_code in
+  (if options.check_types
+   then
+     let open Middleend.Infer in
+     match infer_program env_with_things ast with
+     | Ok (env, names) ->
+       if options.show_types
+       then (
+         pprint_env env names;
+         exit 0)
+       else ()
+     | Error err -> Format.printf "Type error: %a\n" Middleend.Infer.pprint_err err);
   if options.show_ast
   then (
     printf "%a\n" Common.Pprinter.pprint_program ast;
@@ -106,6 +120,8 @@ let () =
     ; show_cc = false
     ; show_ll = false
     ; gc_stats = false
+    ; check_types = true
+    ; show_types = false
     }
   in
   let usage_msg =
@@ -136,6 +152,12 @@ let () =
     ; ( "--gc-stats"
       , Arg.Unit (fun () -> options.gc_stats <- true)
       , "     Enable GC statistics and force a collection at program start/end" )
+    ; ( "-notypes"
+      , Arg.Unit (fun () -> options.check_types <- false)
+      , "         Do not typecheck the program before compilation" )
+    ; ( "-typedtree"
+      , Arg.Unit (fun () -> options.show_types <- true)
+      , "         Show all names with their types and exit" )
     ]
   in
   let handle_anon_arg filename =

XML/bin/XML.mli

@@ -0,0 +1,3 @@
+(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *)
+
+(** SPDX-License-Identifier: LGPL-3.0-or-later *)

XML/bin/XML_llvm.ml

@@ -0,0 +1,187 @@
+(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *)
+
+(** SPDX-License-Identifier: LGPL-3.0-or-later *)
+
+open Format
+open Common.Pprinter
+
+(* ------------------------------- *)
+(*       Command-line Options      *)
+(* ------------------------------- *)
+
+type options =
+  { mutable input_file_name : string option
+  ; mutable from_file_name : string option
+  ; mutable output_file_name : string option
+  ; mutable optimization_lvl : string option
+  ; mutable target : string
+  ; mutable show_ast : bool
+  ; mutable show_anf : bool
+  ; mutable show_cc : bool
+  ; mutable show_ll : bool
+  ; mutable check_types : bool
+  ; mutable show_types : bool
+  }
+
+(* ------------------------------- *)
+(*     Compiler Entry Points       *)
+(* ------------------------------- *)
+
+let to_llvm_ir ast options =
+  let cc_program = Middleend.Cc.cc_program ast in
+  let anf_ast = Middleend.Anf.anf_program cc_program in
+  let ll_anf = Middleend.Ll.lambda_lift_program anf_ast in
+  (* let buf = Buffer.create 1024 in
+  let ppf = formatter_of_buffer buf in *)
+  (* let triple = "x86_64-pc-linux-gnu" in *)
+  let target = options.target in
+  let opt = options.optimization_lvl in
+  Backend.Codegen_llvm.gen_program_ir ll_anf target opt
+;;
+
+let compile_and_write options source_code =
+  let ast = Common.Parser.parse_str source_code in
+  (if options.check_types
+   then
+     let open Middleend.Infer in
+     match infer_program env_with_things ast with
+     | Ok (env, names) ->
+       if options.show_types
+       then (
+         pprint_env env names;
+         exit 0)
+       else ()
+     | Error err -> Format.printf "Type error: %a\n" Middleend.Infer.pprint_err err);
+  if options.show_ast
+  then (
+    (* printf "%a\n" Common.Pprinter.pprint_program ast; *)
+    printf "%s\n" (Common.Ast.show_program ast);
+    exit 0);
+  let cc_ast = Middleend.Cc.cc_program ast in
+  if options.show_cc
+  then (
+    printf "%a\n" Common.Pprinter.pprint_program cc_ast;
+    exit 0);
+  let anf_ast = Middleend.Anf.anf_program cc_ast in
+  if options.show_anf
+  then (
+    Middleend.Pprinter.print_anf_program std_formatter anf_ast;
+    exit 0);
+  let anf_after_ll = Middleend.Ll.lambda_lift_program anf_ast in
+  if options.show_ll
+  then (
+    (* Middleend.Pprinter.print_anf_program std_formatter anf_after_ll; *)
+    printf "%s\n" (Middleend.Anf.show_aprogram anf_after_ll);
+    exit 0);
+  let llvm_ir_code = to_llvm_ir ast options in
+  match options.output_file_name with
+  | Some out_file ->
+    (try
+       let oc = open_out out_file in
+       output_string oc llvm_ir_code;
+       close_out oc
+     with
+     | Sys_error msg ->
+       eprintf "Error: Could not write to output file '%s': %s\n" out_file msg;
+       exit 1)
+  | None -> print_string llvm_ir_code
+;;
+
+let read_channel_to_string ic =
+  let buf = Buffer.create 1024 in
+  try
+    while true do
+      Buffer.add_string buf (input_line ic ^ "\n")
+    done;
+    "" (* Недостижимо *)
+  with
+  | End_of_file -> Buffer.contents buf
+;;
+
+let read_file path =
+  try
+    let ch = open_in path in
+    let s = really_input_string ch (in_channel_length ch) in
+    close_in ch;
+    s
+  with
+  | Sys_error msg ->
+    eprintf "Error: Could not read input file '%s': %s\n" path msg;
+    exit 1
+;;
+
+(* ------------------------------- *)
+(*           Main Driver           *)
+(* ------------------------------- *)
+
+let () =
+  let options =
+    { input_file_name = None
+    ; from_file_name = None
+    ; output_file_name = None
+    ; show_ast = false
+    ; show_anf = false
+    ; show_cc = false
+    ; show_ll = false
+    ; optimization_lvl = None
+    ; target = "riscv64-unknown-linux-gnu"
+    ; check_types = true
+    ; show_types = false
+    }
+  in
+  let usage_msg =
+    "MiniML Compiler\n\n"
+    ^ "Usage: dune exec ./bin/compile.exe -- <options> [input_file.ml]\n"
+    ^ "If no input file is provided, reads from standard input.\n\n"
+    ^ "Options:"
+  in
+  let arg_specs =
+    [ ( "-o"
+      , Arg.String (fun fname -> options.output_file_name <- Some fname)
+      , " <file>  Set the output file name for the llvm ir code" )
+    ; ( "--ast"
+      , Arg.Unit (fun () -> options.show_ast <- true)
+      , "         Show the parsed Abstract Syntax Tree and exit" )
+    ; ( "--anf"
+      , Arg.Unit (fun () -> options.show_anf <- true)
+      , "         Show the ANF representation and exit" )
+    ; ( "--cc"
+      , Arg.Unit (fun () -> options.show_cc <- true)
+      , "         Show the representation after applying CC and exit" )
+    ; ( "-fromfile"
+      , Arg.String (fun fname -> options.from_file_name <- Some fname)
+      , " <file>  Read source from file (preferred over positional arg)" )
+    ; ( "--ll"
+      , Arg.Unit (fun () -> options.show_ll <- true)
+      , "         Show ANF after lambda lifting and exit" )
+    ; ( "-O"
+      , Arg.String (fun opt -> options.optimization_lvl <- Some opt)
+      , "         Set IR optimization level, \"O0\" by default" )
+    ; ( "-t"
+      , Arg.String (fun targ -> options.target <- targ)
+      , "         Set target platform, \"riscv64-unknown-linux-gnu\" by default" )
+    ; ( "-notypes"
+      , Arg.Unit (fun () -> options.check_types <- false)
+      , "         Do not typecheck the program before compilation" )
+    ; ( "-typedtree"
+      , Arg.Unit (fun () -> options.show_types <- true)
+      , "         Show all names with their types and exit" )
+    ]
+  in
+  let handle_anon_arg filename =
+    match options.input_file_name with
+    | None -> options.input_file_name <- Some filename
+    | Some _ ->
+      eprintf "Error: Only one input file is allowed.\n";
+      Arg.usage arg_specs usage_msg;
+      exit 1
+  in
+  Arg.parse arg_specs handle_anon_arg usage_msg;
+  let source_code =
+    match options.from_file_name, options.input_file_name with
+    | Some path, _ -> read_file path
+    | None, Some path -> read_file path
+    | None, None -> read_channel_to_string stdin
+  in
+  compile_and_write options source_code
+;;

XML/bin/XML_llvm.mli

@@ -0,0 +1,3 @@
+(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *)
+
+(** SPDX-License-Identifier: LGPL-3.0-or-later *)

XML/bin/dune

@@ -2,3 +2,8 @@
  (public_name XML)
  (name XML)
  (libraries XML.Backend XML.Common XML.Middleend))
+
+(executable
+ (public_name XML_llvm)
+ (name XML_llvm)
+ (libraries XML.Backend XML.Common XML.Middleend))