From b0c444e356924b04c81e59308a32ed80b401f9de Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 27 Jan 2026 18:09:17 +0300 Subject: [PATCH 01/84] feat: add skeleton for llvm codegen --- XML/bin/XML_llvm.ml | 4 ++ XML/bin/dune | 5 ++ XML/lib/backend/LL.ml | 94 +++++++++++++++++++++++++++++++++ XML/lib/backend/codegen_llvm.ml | 41 ++++++++++++++ XML/lib/backend/dune | 4 +- 5 files changed, 146 insertions(+), 2 deletions(-) create mode 100644 XML/bin/XML_llvm.ml create mode 100644 XML/lib/backend/LL.ml create mode 100644 XML/lib/backend/codegen_llvm.ml diff --git a/XML/bin/XML_llvm.ml b/XML/bin/XML_llvm.ml new file mode 100644 index 00000000..76699570 --- /dev/null +++ b/XML/bin/XML_llvm.ml @@ -0,0 +1,4 @@ +(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + diff --git a/XML/bin/dune b/XML/bin/dune index c264f986..49495b0b 100644 --- a/XML/bin/dune +++ b/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)) diff --git a/XML/lib/backend/LL.ml b/XML/lib/backend/LL.ml new file mode 100644 index 00000000..53331175 --- /dev/null +++ b/XML/lib/backend/LL.ml @@ -0,0 +1,94 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2023-2024, Kakadu and contributors *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +[@@@ocaml.text "/*"] + +open Llvm +open Printf + +module type S = sig + val context : Llvm.llcontext + val module_ : Llvm.llmodule + val builder : Llvm.llbuilder + val build_store : Llvm.llvalue -> Llvm.llvalue -> Llvm.llvalue + val build_call : lltype -> ?name:string -> llvalue -> llvalue list -> llvalue + val lookup_func_exn : string -> llvalue + val has_toplevel_func : string -> bool + val build_add : ?name:string -> llvalue -> llvalue -> llvalue + val build_sub : ?name:string -> llvalue -> llvalue -> llvalue + val build_mul : ?name:string -> llvalue -> llvalue -> llvalue + val build_sdiv : ?name:string -> llvalue -> llvalue -> llvalue [@@inline] + val build_icmp : ?name:string -> Icmp.t -> llvalue -> llvalue -> llvalue + + (** [set_metadata v kind fmt] sets metadata to value [v] of kind [k]. + Returns this value [v]. Useful for attaching debugging *) + val set_metadata + : llvalue + -> string + -> ('a, Format.formatter, unit, llvalue) format4 + -> 'a + + (* ?? *) + + val build_ptrtoint : ?name:string -> llvalue -> lltype -> llvalue + val build_inttoptr : ?name:string -> llvalue -> lltype -> llvalue + val build_pointercast : ?name:string -> llvalue -> lltype -> llvalue + + (** Just aliases *) + + val const_int : Llvm.lltype -> int -> Llvm.llvalue + val params : Llvm.llvalue -> Llvm.llvalue array + val pp_value : Format.formatter -> llvalue -> unit +end + +let make context builder module_ = + let module L : S = struct + let context = context + let builder = builder + let module_ = module_ + let build_store a b = Llvm.build_store a b builder + + let build_call typ ?(name = "") f args = + build_call typ f (Array.of_list args) name builder + ;; + + let has_toplevel_func fname = + match lookup_function fname module_ with + | Some _ -> true + | None -> false + ;; + + let lookup_func_exn fname = + match lookup_function fname module_ with + | Some f -> f + | None -> failwith (sprintf "Function '%s' not found" fname) + ;; + + let build_add ?(name = "") l r = build_add l r name builder + let build_sub ?(name = "") l r = build_sub l r name builder + let build_mul ?(name = "") l r = build_mul l r name builder + let build_sdiv ?(name = "") l r = build_sdiv l r name builder + let build_icmp ?(name = "") op l r = build_icmp op l r name builder + let build_ptrtoint ?(name = "") e typ = Llvm.build_ptrtoint e typ name builder + let build_inttoptr ?(name = "") e typ = Llvm.build_inttoptr e typ name builder + let build_pointercast ?(name = "") f typ = Llvm.build_pointercast f typ name builder + + let set_metadata v kind fmt = + Format.kasprintf + (fun s -> + Llvm.set_metadata v (Llvm.mdkind_id context kind) (Llvm.mdstring context s); + v) + fmt + ;; + + (* Aliases *) + let const_int = Llvm.const_int + let params = Llvm.params + let pp_value ppf x = Format.fprintf ppf "%s" (Llvm.string_of_llvalue x) + end + in + (module L : S) +;; diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml new file mode 100644 index 00000000..b8e44513 --- /dev/null +++ b/XML/lib/backend/codegen_llvm.ml @@ -0,0 +1,41 @@ +(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Middleend.Anf +open Llvm + +let context = Llvm.global_context () +let i64_type = Llvm.i64_type context +let void_type = Llvm.void_type context +let ptr_type = Llvm.pointer_type context +let builder = Llvm.builder context +let the_module = Llvm.create_module context "main" + +let gen_im_expr_ir = function + | Imm_num _ -> failwith "not implemented" + | Imm_ident _ -> failwith "not_implemented" +;; + +let gen_comp_expr_ir = function + | _ -> failwith "not implemented" +;; + +let gen_anf_expr = function + | Anf_comp_expr _ -> failwith "not implemented" + | Anf_let _ -> failwith "not implemented" +;; + +let gen_astructure_item = function + | Anf_str_eval _ -> failwith "not implemented" + | _ -> failwith "not implemented" +;; + +let gen_program_ir (program : aprogram) (triple : string) = + let () = Llvm.set_target_triple triple the_module in + let () = assert (Llvm_executionengine.initialize ()) in + let _the_execution_engine = Llvm_executionengine.create the_module in + let module LL = (val LL.make context builder the_module) in + (* Fold on program here *) + Llvm.print_module "out.ll" the_module +;; diff --git a/XML/lib/backend/dune b/XML/lib/backend/dune index 76598ff6..4d5b1025 100644 --- a/XML/lib/backend/dune +++ b/XML/lib/backend/dune @@ -1,8 +1,8 @@ (library (name backend) (public_name XML.Backend) - (modules codegen emission machine target) - (libraries angstrom base stdio XML.Common XML.Middleend) + (modules codegen codegen_llvm emission machine target LL) + (libraries angstrom base llvm stdio XML.Common XML.Middleend) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving_qcheck)) (instrumentation From 80f65fb36cd1d9ce02bf05c25e5cb1c16f10f9e3 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 28 Jan 2026 09:50:33 +0300 Subject: [PATCH 02/84] feat: add driver code for llvm, basic codegen --- XML/bin/XML_llvm.ml | 153 +++++++++++++++++++++++++++++++ XML/lib/backend/codegen_llvm.ml | 32 ++++++- XML/lib/backend/codegen_llvm.mli | 8 ++ XML/lib/backend/dune | 12 ++- 4 files changed, 198 insertions(+), 7 deletions(-) create mode 100644 XML/lib/backend/codegen_llvm.mli diff --git a/XML/bin/XML_llvm.ml b/XML/bin/XML_llvm.ml index 76699570..0d9d4f22 100644 --- a/XML/bin/XML_llvm.ml +++ b/XML/bin/XML_llvm.ml @@ -2,3 +2,156 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) +open Format + +(* ------------------------------- *) +(* Command-line Options *) +(* ------------------------------- *) + +type options = + { mutable input_file_name : string option + ; mutable from_file_name : string option + ; mutable output_file_name : string option + ; mutable show_ast : bool + ; mutable show_anf : bool + ; mutable show_cc : bool + ; mutable show_ll : bool + } + +(* ------------------------------- *) +(* Compiler Entry Points *) +(* ------------------------------- *) + +let to_llvm_ir ast : string = + 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 + Backend.Codegen_llvm.gen_program_ir ll_anf triple +;; + +(* in *) +(* Buffer.contents buf *) + +let compile_and_write options source_code = + let ast = Common.Parser.parse_str source_code in + if options.show_ast + then ( + printf "%a\n" Common.Pprinter.pprint_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; + exit 0); + let llvm_ir_code = to_llvm_ir ast 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 + } + in + let usage_msg = + "MiniML Compiler\n\n" + ^ "Usage: dune exec ./bin/compile.exe -- [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) + , " 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) + , " Read source from file (preferred over positional arg)" ) + ; ( "--ll" + , Arg.Unit (fun () -> options.show_ll <- true) + , " Show ANF after lambda lifting and exit" ) + (* ( "--gc-stats" + , Arg.Unit (fun () -> options.gc_stats <- true) + , " Enable GC statistics and force a collection at program start/end" ) *) + ] + 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 +;; diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index b8e44513..30768efb 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -3,7 +3,6 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Middleend.Anf -open Llvm let context = Llvm.global_context () let i64_type = Llvm.i64_type context @@ -11,23 +10,46 @@ let void_type = Llvm.void_type context let ptr_type = Llvm.pointer_type context let builder = Llvm.builder context let the_module = Llvm.create_module context "main" +let env : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 16 let gen_im_expr_ir = function - | Imm_num _ -> failwith "not implemented" - | Imm_ident _ -> failwith "not_implemented" + | Imm_num n -> Llvm.const_int i64_type n + | Imm_ident id -> + (match Hashtbl.find_opt env id with + | Some v -> Llvm.build_load (Llvm.type_of v) v id builder + | None -> invalid_arg ("Name not bound: " ^ id)) ;; let gen_comp_expr_ir = function + | Comp_imm imm -> gen_im_expr_ir imm + | Comp_binop (op, lhs, rhs) -> + let lhs_val = gen_im_expr_ir lhs in + let rhs_val = gen_im_expr_ir rhs in + let build_oper, name = + match op with + | "+" -> Llvm.build_add, "addtmp" + | "-" -> Llvm.build_sub, "subtmp" + | "*" -> Llvm.build_mul, "multmp" + | "/" -> Llvm.build_sdiv, "divtmp" + | "<" -> Llvm.build_icmp Llvm.Icmp.Slt, "cmptmp" + | "<=" -> Llvm.build_icmp Llvm.Icmp.Sle, "cmptmp" + | ">" -> Llvm.build_icmp Llvm.Icmp.Sgt, "cmptmp" + | ">=" -> Llvm.build_icmp Llvm.Icmp.Sge, "cmptmp" + | "=" -> Llvm.build_icmp Llvm.Icmp.Eq, "cmptmp" + | "<>" -> Llvm.build_icmp Llvm.Icmp.Ne, "cmptmp" + | _ -> invalid_arg ("Unsupported binary operator: " ^ op) + in + build_oper lhs_val rhs_val name builder | _ -> failwith "not implemented" ;; let gen_anf_expr = function - | Anf_comp_expr _ -> failwith "not implemented" + | Anf_comp_expr comp -> gen_comp_expr_ir comp | Anf_let _ -> failwith "not implemented" ;; let gen_astructure_item = function - | Anf_str_eval _ -> failwith "not implemented" + | Anf_str_eval expr -> gen_anf_expr expr | _ -> failwith "not implemented" ;; diff --git a/XML/lib/backend/codegen_llvm.mli b/XML/lib/backend/codegen_llvm.mli new file mode 100644 index 00000000..4c50b480 --- /dev/null +++ b/XML/lib/backend/codegen_llvm.mli @@ -0,0 +1,8 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Format + +(* gens program on LLMV IR from the ast *) +val gen_program_ir : Middleend.Anf.aprogram -> string -> unit diff --git a/XML/lib/backend/dune b/XML/lib/backend/dune index 4d5b1025..5f7c372d 100644 --- a/XML/lib/backend/dune +++ b/XML/lib/backend/dune @@ -2,8 +2,16 @@ (name backend) (public_name XML.Backend) (modules codegen codegen_llvm emission machine target LL) - (libraries angstrom base llvm stdio XML.Common XML.Middleend) + (libraries + angstrom + base + llvm + llvm.analysis + llvm.executionengine + stdio + XML.Common + XML.Middleend) (preprocess - (pps ppx_deriving.show ppx_deriving.eq ppx_deriving_qcheck)) + (pps ppx_deriving.show ppx_deriving.eq ppx_deriving_qcheck ppx_inline_test)) (instrumentation (backend bisect_ppx))) From cb31cd8ba4bfcb1f35567cce1d90c63dddae77e7 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sat, 31 Jan 2026 17:55:19 +0300 Subject: [PATCH 03/84] feat: can compile function decls with args and a little more --- XML/bin/XML_llvm.ml | 8 ++- XML/lib/backend/codegen_llvm.ml | 101 ++++++++++++++++++++++++++----- XML/lib/backend/codegen_llvm.mli | 2 +- XML/lib/middleend/anf.ml | 6 +- XML/lib/middleend/anf.mli | 2 +- 5 files changed, 98 insertions(+), 21 deletions(-) diff --git a/XML/bin/XML_llvm.ml b/XML/bin/XML_llvm.ml index 0d9d4f22..f31b60ba 100644 --- a/XML/bin/XML_llvm.ml +++ b/XML/bin/XML_llvm.ml @@ -22,7 +22,7 @@ type options = (* Compiler Entry Points *) (* ------------------------------- *) -let to_llvm_ir ast : string = +let to_llvm_ir ast = 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 @@ -39,7 +39,8 @@ let compile_and_write options source_code = let ast = Common.Parser.parse_str source_code in if options.show_ast then ( - printf "%a\n" Common.Pprinter.pprint_program ast; + (* 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 @@ -54,7 +55,8 @@ let compile_and_write options source_code = 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; + (* 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 in match options.output_file_name with diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 30768efb..1b88d0ac 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -7,16 +7,17 @@ open Middleend.Anf let context = Llvm.global_context () let i64_type = Llvm.i64_type context let void_type = Llvm.void_type context +let default_type = i64_type (* *) let ptr_type = Llvm.pointer_type context let builder = Llvm.builder context let the_module = Llvm.create_module context "main" -let env : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 16 +let named_values : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 16 let gen_im_expr_ir = function | Imm_num n -> Llvm.const_int i64_type n | Imm_ident id -> - (match Hashtbl.find_opt env id with - | Some v -> Llvm.build_load (Llvm.type_of v) v id builder + (match Hashtbl.find_opt named_values id with + | Some v -> Llvm.build_load default_type v id builder | None -> invalid_arg ("Name not bound: " ^ id)) ;; @@ -31,33 +32,103 @@ let gen_comp_expr_ir = function | "-" -> Llvm.build_sub, "subtmp" | "*" -> Llvm.build_mul, "multmp" | "/" -> Llvm.build_sdiv, "divtmp" - | "<" -> Llvm.build_icmp Llvm.Icmp.Slt, "cmptmp" - | "<=" -> Llvm.build_icmp Llvm.Icmp.Sle, "cmptmp" - | ">" -> Llvm.build_icmp Llvm.Icmp.Sgt, "cmptmp" - | ">=" -> Llvm.build_icmp Llvm.Icmp.Sge, "cmptmp" - | "=" -> Llvm.build_icmp Llvm.Icmp.Eq, "cmptmp" - | "<>" -> Llvm.build_icmp Llvm.Icmp.Ne, "cmptmp" + | "<" -> Llvm.build_icmp Llvm.Icmp.Slt, "slttmp" + | "<=" -> Llvm.build_icmp Llvm.Icmp.Sle, "sletmp" + | ">" -> Llvm.build_icmp Llvm.Icmp.Sgt, "sgttmp" + | ">=" -> Llvm.build_icmp Llvm.Icmp.Sge, "sgetmp" + | "=" -> Llvm.build_icmp Llvm.Icmp.Eq, "eqtmp" + | "<>" -> Llvm.build_icmp Llvm.Icmp.Ne, "neqtmp" | _ -> invalid_arg ("Unsupported binary operator: " ^ op) in build_oper lhs_val rhs_val name builder + | Comp_app (Imm_ident f, args) -> + let f_val = + match Llvm.lookup_function f the_module with + | Some name -> name + | None -> invalid_arg ("Undefined function: " ^ f) + in + let _ = + if Int.equal (List.length args) (Array.length (Llvm.params f_val)) + then () + else invalid_arg ("Invalid parameter num for function: " ^ f) + in + let arg_vals = Array.map gen_im_expr_ir (Array.of_list args) in + let arg_types = Array.map Llvm.type_of arg_vals in + let f_type = Llvm.function_type default_type arg_types in + Llvm.build_call f_type f_val arg_vals "calltmp" builder | _ -> failwith "not implemented" ;; let gen_anf_expr = function + (* | Anf_comp_expr (Comp_func (params, body)) -> gen_function params body *) | Anf_comp_expr comp -> gen_comp_expr_ir comp - | Anf_let _ -> failwith "not implemented" + | _ -> failwith "not implemented" +;; + +let create_entry_alloca the_fun var_name = + let builder = Llvm.builder_at context (Llvm.instr_begin (Llvm.entry_block the_fun)) in + Llvm.build_alloca i64_type var_name builder +;; + +let gen_function name (params : string list) body = + Hashtbl.clear named_values; + let param_types = Array.map (fun _ -> default_type) (Array.of_list params) in + let f_type = Llvm.function_type default_type param_types in + let the_fun = + match Llvm.lookup_function name the_module with + | None -> Llvm.declare_function name f_type the_module + | Some f -> + if Int.(Array.length (Llvm.basic_blocks f) = 0) + then () + else invalid_arg ("Redifinition of function: " ^ name); + if Int.(Array.length (Llvm.params f) = List.length params) + then () + else invalid_arg ("Redifinition of function with different number of args: " ^ name); + f + in + (* build allocas and add names for parameters *) + Array.iteri + (fun i pval -> + let name = List.nth params i in + Llvm.set_value_name name pval; + Hashtbl.add named_values name pval) + (Llvm.params the_fun); + let bb = Llvm.append_block context "entry" the_fun in + Llvm.position_at_end bb builder; + Array.iteri + (fun i ai -> + let name = List.nth params i in + let alloca = create_entry_alloca the_fun name in + let _ = Llvm.build_store ai alloca builder in + Hashtbl.replace named_values name alloca) + (Llvm.params the_fun); + (* Need to check for error here *) + let ret_val = gen_anf_expr body in + let _ = Llvm.build_ret ret_val builder in + (match Llvm_analysis.verify_function the_fun with + | true -> () + | false -> + Stdlib.Format.printf + "invalid function generated\n%s\n" + (Llvm.string_of_llvalue the_fun); + Llvm_analysis.assert_valid_function the_fun); + the_fun ;; let gen_astructure_item = function | Anf_str_eval expr -> gen_anf_expr expr - | _ -> failwith "not implemented" + | Anf_str_value (_, name, Anf_comp_expr (Comp_func (params, body))) -> + gen_function name params body + | Anf_str_value (_, _, _) -> + (* gen variable *) + failwith "not implemented" ;; let gen_program_ir (program : aprogram) (triple : string) = - let () = Llvm.set_target_triple triple the_module in - let () = assert (Llvm_executionengine.initialize ()) in + Llvm.set_target_triple triple the_module; + assert (Llvm_executionengine.initialize ()); let _the_execution_engine = Llvm_executionengine.create the_module in let module LL = (val LL.make context builder the_module) in - (* Fold on program here *) - Llvm.print_module "out.ll" the_module + let _ = List.map (fun item -> gen_astructure_item item) program in + Llvm.string_of_llmodule the_module ;; diff --git a/XML/lib/backend/codegen_llvm.mli b/XML/lib/backend/codegen_llvm.mli index 4c50b480..ff3f7bdd 100644 --- a/XML/lib/backend/codegen_llvm.mli +++ b/XML/lib/backend/codegen_llvm.mli @@ -5,4 +5,4 @@ open Format (* gens program on LLMV IR from the ast *) -val gen_program_ir : Middleend.Anf.aprogram -> string -> unit +val gen_program_ir : Middleend.Anf.aprogram -> string -> string diff --git a/XML/lib/middleend/anf.ml b/XML/lib/middleend/anf.ml index fc1379b3..d263cae7 100644 --- a/XML/lib/middleend/anf.ml +++ b/XML/lib/middleend/anf.ml @@ -11,6 +11,7 @@ open Common.Ast type im_expr = | Imm_num of int | Imm_ident of ident +[@@deriving show { with_path = false }] (* Complex/Computable expression *) type comp_expr = @@ -24,16 +25,19 @@ type comp_expr = im_expr list (* Allocate a memory block and initialize it with values. *) | Comp_load of im_expr * int (* Load a value from memory: Comp_load(address, byte_offset). *) +[@@deriving show { with_path = false }] and anf_expr = | Anf_comp_expr of comp_expr | Anf_let of rec_flag * ident * comp_expr * anf_expr +[@@deriving show { with_path = false }] type astructure_item = | Anf_str_eval of anf_expr | Anf_str_value of rec_flag * ident * anf_expr +[@@deriving show { with_path = false }] -type aprogram = astructure_item list +type aprogram = astructure_item list [@@deriving show { with_path = false }] type anf_error = [ `Only_simple_var_params diff --git a/XML/lib/middleend/anf.mli b/XML/lib/middleend/anf.mli index c545c016..9a1c2fc9 100644 --- a/XML/lib/middleend/anf.mli +++ b/XML/lib/middleend/anf.mli @@ -32,7 +32,7 @@ type astructure_item = | Anf_str_eval of anf_expr | Anf_str_value of rec_flag * ident * anf_expr -type aprogram = astructure_item list +type aprogram = astructure_item list [@@deriving show { with_path = false }] type anf_error = [ `Only_simple_var_params From 8683b63986fd9858c75fed9f7ab4fdf4c9786a33 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sat, 31 Jan 2026 22:10:54 +0300 Subject: [PATCH 04/84] feat: allow nested let ... in, draft of gen_variable --- XML/lib/backend/codegen_llvm.ml | 42 ++++++++++++++++++++++++--------- 1 file changed, 31 insertions(+), 11 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 1b88d0ac..ebe34d35 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -13,6 +13,8 @@ let builder = Llvm.builder context let the_module = Llvm.create_module context "main" let named_values : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 16 +(* don't forget about tagged integers *) + let gen_im_expr_ir = function | Imm_num n -> Llvm.const_int i64_type n | Imm_ident id -> @@ -59,17 +61,22 @@ let gen_comp_expr_ir = function | _ -> failwith "not implemented" ;; -let gen_anf_expr = function - (* | Anf_comp_expr (Comp_func (params, body)) -> gen_function params body *) - | Anf_comp_expr comp -> gen_comp_expr_ir comp - | _ -> failwith "not implemented" -;; - let create_entry_alloca the_fun var_name = let builder = Llvm.builder_at context (Llvm.instr_begin (Llvm.entry_block the_fun)) in Llvm.build_alloca i64_type var_name builder ;; +let rec gen_anf_expr = function + | Anf_comp_expr comp -> gen_comp_expr_ir comp + | Anf_let (_, name, comp_expr, body) -> + let init_val = gen_comp_expr_ir comp_expr in + let the_fun = Llvm.block_parent (Llvm.insertion_block builder) in + let alloca = create_entry_alloca the_fun name in + let _ = Llvm.build_store init_val alloca builder in + Hashtbl.add named_values name alloca; + gen_anf_expr body +;; + let gen_function name (params : string list) body = Hashtbl.clear named_values; let param_types = Array.map (fun _ -> default_type) (Array.of_list params) in @@ -80,10 +87,10 @@ let gen_function name (params : string list) body = | Some f -> if Int.(Array.length (Llvm.basic_blocks f) = 0) then () - else invalid_arg ("Redifinition of function: " ^ name); + else invalid_arg ("Redefinition of function: " ^ name); if Int.(Array.length (Llvm.params f) = List.length params) then () - else invalid_arg ("Redifinition of function with different number of args: " ^ name); + else invalid_arg ("Redefinition of function with different number of args: " ^ name); f in (* build allocas and add names for parameters *) @@ -115,13 +122,26 @@ let gen_function name (params : string list) body = the_fun ;; +(* + let gen_variable name value = + let the_var = + match Llvm.lookup_global name the_module with + | None -> Llvm.define_global name value the_module + | Some _ -> invalid_arg ("Redefinition of a global variable: " ^ name) + in + Hashtbl.add named_values name the_var; + the_var +;; *) + let gen_astructure_item = function | Anf_str_eval expr -> gen_anf_expr expr | Anf_str_value (_, name, Anf_comp_expr (Comp_func (params, body))) -> gen_function name params body - | Anf_str_value (_, _, _) -> - (* gen variable *) - failwith "not implemented" + | Anf_str_value (_, name, expr) -> + (* let value = gen_anf_expr expr in + gen_variable name value *) + gen_function name [] expr + | _ -> failwith "not implemented" ;; let gen_program_ir (program : aprogram) (triple : string) = From 8e348d28a716efd7cadae56ff2cd2c4098199741 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sat, 31 Jan 2026 22:52:02 +0300 Subject: [PATCH 05/84] feat: support if then else --- XML/lib/backend/codegen_llvm.ml | 41 ++++++++++++++++++++++++++------- 1 file changed, 33 insertions(+), 8 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index ebe34d35..b851f953 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -23,7 +23,12 @@ let gen_im_expr_ir = function | None -> invalid_arg ("Name not bound: " ^ id)) ;; -let gen_comp_expr_ir = function +let create_entry_alloca the_fun var_name = + let builder = Llvm.builder_at context (Llvm.instr_begin (Llvm.entry_block the_fun)) in + Llvm.build_alloca i64_type var_name builder +;; + +let rec gen_comp_expr_ir = function | Comp_imm imm -> gen_im_expr_ir imm | Comp_binop (op, lhs, rhs) -> let lhs_val = gen_im_expr_ir lhs in @@ -58,15 +63,35 @@ let gen_comp_expr_ir = function let arg_types = Array.map Llvm.type_of arg_vals in let f_type = Llvm.function_type default_type arg_types in Llvm.build_call f_type f_val arg_vals "calltmp" builder + | Comp_branch (cond, br_then, br_else) -> + let cv = gen_im_expr_ir cond in + let zero = Llvm.const_int i64_type 0 in + let cond_val = Llvm.build_icmp Llvm.Icmp.Ne cv zero "cond" builder in + let start_bb = Llvm.insertion_block builder in + let the_fun = Llvm.block_parent start_bb in + let then_bb = Llvm.append_block context "then" the_fun in + Llvm.position_at_end then_bb builder; + let then_val = gen_anf_expr br_then in + let new_then_bb = Llvm.insertion_block builder in + let else_bb = Llvm.append_block context "else" the_fun in + Llvm.position_at_end else_bb builder; + let else_val = gen_anf_expr br_else in + let new_else_bb = Llvm.insertion_block builder in + let merge_bb = Llvm.append_block context "ifcont" the_fun in + Llvm.position_at_end merge_bb builder; + let incoming = [ then_val, new_then_bb; else_val, new_else_bb ] in + let phi = Llvm.build_phi incoming "iftmp" builder in + Llvm.position_at_end start_bb builder; + let _ = Llvm.build_cond_br cond_val then_bb else_bb builder in + Llvm.position_at_end new_then_bb builder; + let _ = Llvm.build_br merge_bb builder in + Llvm.position_at_end new_else_bb builder; + let _ = Llvm.build_br merge_bb builder in + Llvm.position_at_end merge_bb builder; + phi | _ -> failwith "not implemented" -;; - -let create_entry_alloca the_fun var_name = - let builder = Llvm.builder_at context (Llvm.instr_begin (Llvm.entry_block the_fun)) in - Llvm.build_alloca i64_type var_name builder -;; -let rec gen_anf_expr = function +and gen_anf_expr = function | Anf_comp_expr comp -> gen_comp_expr_ir comp | Anf_let (_, name, comp_expr, body) -> let init_val = gen_comp_expr_ir comp_expr in From 06625e3ace06d7cbc83e5436175b9c34db924584 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 2 Feb 2026 11:00:33 +0300 Subject: [PATCH 06/84] feat: add map to store types of declared functions --- XML/lib/backend/codegen_llvm.ml | 133 ++++++++++++++++++++++++-------- 1 file changed, 102 insertions(+), 31 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index b851f953..5070a914 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -3,6 +3,9 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Middleend.Anf +open Common.Ast + +(* Don't forget about tagging ints *) let context = Llvm.global_context () let i64_type = Llvm.i64_type context @@ -11,16 +14,72 @@ let default_type = i64_type (* *) let ptr_type = Llvm.pointer_type context let builder = Llvm.builder context let the_module = Llvm.create_module context "main" -let named_values : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 16 +let named_values : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 32 + +module FuncTypeMap = struct + module K = struct + type t = ident + + let compare = Stdlib.compare + end -(* don't forget about tagged integers *) + module M = Map.Make (K) -let gen_im_expr_ir = function + type t = Llvm.lltype M.t + + let empty () : t = M.empty + let bind (t : t) (x : ident) (ll : Llvm.lltype) : t = M.add x ll t + let find (t : t) (x : ident) : Llvm.lltype option = M.find_opt x t + let keys = M.bindings +end + +(* Return types from runtime.c *) +let initial_arity_map = + let open FuncTypeMap in + let lfty = Llvm.function_type in + let arity_map = empty () in + let arity_map = bind arity_map "print_int" (lfty void_type [| i64_type |]) in + let arity_map = bind arity_map "alloc_block" (lfty i64_type [| i64_type |]) in + let arity_map = + bind arity_map "alloc_closure" (lfty i64_type [| i64_type; i64_type |]) + in + let arity_map = bind arity_map "apply1" (lfty i64_type [| i64_type; i64_type |]) in + let arity_map = bind arity_map "print_gc_status" (lfty void_type [| void_type |]) in + let arity_map = bind arity_map "collect" (lfty void_type [| void_type |]) in + let arity_map = bind arity_map "create_tuple" (lfty i64_type [| i64_type |]) in + let arity_map = bind arity_map "field" (lfty i64_type [| i64_type; i64_type |]) in + arity_map +;; + +let prefill_ftmap (arity_map0 : FuncTypeMap.t) (program : aprogram) : FuncTypeMap.t = + let typ argc = Llvm.function_type i64_type (Array.make argc i64_type) in + List.fold_left + (fun am -> function + | Anf_str_value (_rf, name, anf_expr) -> + (match anf_expr with + | Anf_let (_, _, Comp_func (ps, _), _) -> + FuncTypeMap.bind am name (typ (List.length ps)) + | Anf_comp_expr (Comp_func (ps, _)) -> + FuncTypeMap.bind am name (typ (List.length ps)) + | _ -> FuncTypeMap.bind am name (typ 0)) + | _ -> am) + arity_map0 + program +;; + +let gen_im_expr_ir ftmap = function | Imm_num n -> Llvm.const_int i64_type n | Imm_ident id -> (match Hashtbl.find_opt named_values id with | Some v -> Llvm.build_load default_type v id builder - | None -> invalid_arg ("Name not bound: " ^ id)) + | None -> + (match FuncTypeMap.find ftmap id with + | Some _ -> + (* create a pointer to the code of id and take its number of args + then create a closure and return created call to "alloc_closure" + *) + failwith "not impl" + | None -> invalid_arg ("Name not bound: " ^ id))) ;; let create_entry_alloca the_fun var_name = @@ -28,11 +87,11 @@ let create_entry_alloca the_fun var_name = Llvm.build_alloca i64_type var_name builder ;; -let rec gen_comp_expr_ir = function - | Comp_imm imm -> gen_im_expr_ir imm +let rec gen_comp_expr_ir ftmap = function + | Comp_imm imm -> gen_im_expr_ir ftmap imm | Comp_binop (op, lhs, rhs) -> - let lhs_val = gen_im_expr_ir lhs in - let rhs_val = gen_im_expr_ir rhs in + let lhs_val = gen_im_expr_ir ftmap lhs in + let rhs_val = gen_im_expr_ir ftmap rhs in let build_oper, name = match op with | "+" -> Llvm.build_add, "addtmp" @@ -59,23 +118,23 @@ let rec gen_comp_expr_ir = function then () else invalid_arg ("Invalid parameter num for function: " ^ f) in - let arg_vals = Array.map gen_im_expr_ir (Array.of_list args) in + let arg_vals = Array.map (gen_im_expr_ir ftmap) (Array.of_list args) in let arg_types = Array.map Llvm.type_of arg_vals in let f_type = Llvm.function_type default_type arg_types in Llvm.build_call f_type f_val arg_vals "calltmp" builder | Comp_branch (cond, br_then, br_else) -> - let cv = gen_im_expr_ir cond in + let cv = gen_im_expr_ir ftmap cond in let zero = Llvm.const_int i64_type 0 in let cond_val = Llvm.build_icmp Llvm.Icmp.Ne cv zero "cond" builder in let start_bb = Llvm.insertion_block builder in let the_fun = Llvm.block_parent start_bb in let then_bb = Llvm.append_block context "then" the_fun in Llvm.position_at_end then_bb builder; - let then_val = gen_anf_expr br_then in + let then_val = gen_anf_expr ftmap br_then in let new_then_bb = Llvm.insertion_block builder in let else_bb = Llvm.append_block context "else" the_fun in Llvm.position_at_end else_bb builder; - let else_val = gen_anf_expr br_else in + let else_val = gen_anf_expr ftmap br_else in let new_else_bb = Llvm.insertion_block builder in let merge_bb = Llvm.append_block context "ifcont" the_fun in Llvm.position_at_end merge_bb builder; @@ -89,20 +148,24 @@ let rec gen_comp_expr_ir = function let _ = Llvm.build_br merge_bb builder in Llvm.position_at_end merge_bb builder; phi + (* | Comp_alloc imms | Comp_tuple imms -> + let imm_vals = List.map (fun i -> gen_im_expr_ir ftmap i) imms in + Llvm.build_call ty fn imm_vals "tupletmp" builder in + failwith "a" *) | _ -> failwith "not implemented" -and gen_anf_expr = function - | Anf_comp_expr comp -> gen_comp_expr_ir comp +and gen_anf_expr ftmap = function + | Anf_comp_expr comp -> gen_comp_expr_ir ftmap comp | Anf_let (_, name, comp_expr, body) -> - let init_val = gen_comp_expr_ir comp_expr in + let init_val = gen_comp_expr_ir ftmap comp_expr in let the_fun = Llvm.block_parent (Llvm.insertion_block builder) in let alloca = create_entry_alloca the_fun name in let _ = Llvm.build_store init_val alloca builder in Hashtbl.add named_values name alloca; - gen_anf_expr body + gen_anf_expr ftmap body ;; -let gen_function name (params : string list) body = +let gen_function ftmap name params body = Hashtbl.clear named_values; let param_types = Array.map (fun _ -> default_type) (Array.of_list params) in let f_type = Llvm.function_type default_type param_types in @@ -110,10 +173,10 @@ let gen_function name (params : string list) body = match Llvm.lookup_function name the_module with | None -> Llvm.declare_function name f_type the_module | Some f -> - if Int.(Array.length (Llvm.basic_blocks f) = 0) + if Array.length (Llvm.basic_blocks f) = 0 then () else invalid_arg ("Redefinition of function: " ^ name); - if Int.(Array.length (Llvm.params f) = List.length params) + if Array.length (Llvm.params f) = List.length params then () else invalid_arg ("Redefinition of function with different number of args: " ^ name); f @@ -135,15 +198,15 @@ let gen_function name (params : string list) body = Hashtbl.replace named_values name alloca) (Llvm.params the_fun); (* Need to check for error here *) - let ret_val = gen_anf_expr body in + let ret_val = gen_anf_expr ftmap body in let _ = Llvm.build_ret ret_val builder in - (match Llvm_analysis.verify_function the_fun with + (* (match Llvm_analysis.verify_function the_fun with | true -> () | false -> Stdlib.Format.printf "invalid function generated\n%s\n" (Llvm.string_of_llvalue the_fun); - Llvm_analysis.assert_valid_function the_fun); + Llvm_analysis.assert_valid_function the_fun); *) the_fun ;; @@ -158,22 +221,30 @@ let gen_function name (params : string list) body = the_var ;; *) -let gen_astructure_item = function - | Anf_str_eval expr -> gen_anf_expr expr +let gen_astructure_item ftmap = function + | Anf_str_eval expr -> gen_anf_expr ftmap expr | Anf_str_value (_, name, Anf_comp_expr (Comp_func (params, body))) -> - gen_function name params body + gen_function ftmap name params body | Anf_str_value (_, name, expr) -> - (* let value = gen_anf_expr expr in + (* let value = gen_anf_expr ftmap expr in gen_variable name value *) - gen_function name [] expr - | _ -> failwith "not implemented" + gen_function ftmap name [] expr ;; let gen_program_ir (program : aprogram) (triple : string) = Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); - let _the_execution_engine = Llvm_executionengine.create the_module in - let module LL = (val LL.make context builder the_module) in - let _ = List.map (fun item -> gen_astructure_item item) program in + let arity_map = prefill_ftmap initial_arity_map program in + let keys = FuncTypeMap.keys arity_map in + (* let program = List.rev program in *) + let _ = List.map (fun (n, ty) -> Llvm.declare_function n ty the_module) keys in + (* let _ = List.map (decl_builtin arity_map) builtins in *) + (* *) + (* List.fold_left + (fun armap_acc item -> + match item with + | Anf_str + ) arity_map program *) + let _ = List.map (fun item -> gen_astructure_item arity_map item) program in Llvm.string_of_llmodule the_module ;; From 74523e6a7e0e6b51028673358e5caa4e521dcaee Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 2 Feb 2026 11:38:46 +0300 Subject: [PATCH 07/84] feat: now map also stores fvalues, made declarations easier --- XML/lib/backend/codegen_llvm.ml | 129 ++++++++++++++++---------------- 1 file changed, 66 insertions(+), 63 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 5070a914..7895c6b6 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -16,7 +16,7 @@ let builder = Llvm.builder context let the_module = Llvm.create_module context "main" let named_values : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 32 -module FuncTypeMap = struct +module FuncMap = struct module K = struct type t = ident @@ -25,60 +25,73 @@ module FuncTypeMap = struct module M = Map.Make (K) - type t = Llvm.lltype M.t + type t = (Llvm.llvalue * Llvm.lltype) M.t let empty () : t = M.empty - let bind (t : t) (x : ident) (ll : Llvm.lltype) : t = M.add x ll t - let find (t : t) (x : ident) : Llvm.lltype option = M.find_opt x t + let bind (t : t) (x : ident) (ll : Llvm.llvalue * Llvm.lltype) : t = M.add x ll t + let find (t : t) (x : ident) : (Llvm.llvalue * Llvm.lltype) option = M.find_opt x t let keys = M.bindings end +let decl_and_bind fmap id retty argc = + let argtyps = Array.make argc i64_type in + let ftyp = Llvm.function_type retty argtyps in + let fval = Llvm.declare_function id ftyp the_module in + FuncMap.bind fmap id (fval, ftyp) +;; + (* Return types from runtime.c *) -let initial_arity_map = - let open FuncTypeMap in - let lfty = Llvm.function_type in - let arity_map = empty () in - let arity_map = bind arity_map "print_int" (lfty void_type [| i64_type |]) in - let arity_map = bind arity_map "alloc_block" (lfty i64_type [| i64_type |]) in - let arity_map = - bind arity_map "alloc_closure" (lfty i64_type [| i64_type; i64_type |]) - in - let arity_map = bind arity_map "apply1" (lfty i64_type [| i64_type; i64_type |]) in - let arity_map = bind arity_map "print_gc_status" (lfty void_type [| void_type |]) in - let arity_map = bind arity_map "collect" (lfty void_type [| void_type |]) in - let arity_map = bind arity_map "create_tuple" (lfty i64_type [| i64_type |]) in - let arity_map = bind arity_map "field" (lfty i64_type [| i64_type; i64_type |]) in - arity_map +let initial_fmap = + let fmap = FuncMap.empty () in + let fmap = decl_and_bind fmap "print_int" void_type 1 in + let fmap = decl_and_bind fmap "alloc_block" i64_type 1 in + let fmap = decl_and_bind fmap "alloc_closure" i64_type 1 in + let fmap = decl_and_bind fmap "apply1" i64_type 2 in + let fmap = decl_and_bind fmap "print_gc_status" void_type 0 in + let fmap = decl_and_bind fmap "collect" void_type 0 in + let fmap = decl_and_bind fmap "create_tuple" i64_type 1 in + let fmap = decl_and_bind fmap "field" i64_type 2 in + fmap ;; -let prefill_ftmap (arity_map0 : FuncTypeMap.t) (program : aprogram) : FuncTypeMap.t = - let typ argc = Llvm.function_type i64_type (Array.make argc i64_type) in +let prefill_fmap (fmap0 : FuncMap.t) (program : aprogram) : FuncMap.t = List.fold_left - (fun am -> function + (fun fm -> function | Anf_str_value (_rf, name, anf_expr) -> (match anf_expr with - | Anf_let (_, _, Comp_func (ps, _), _) -> - FuncTypeMap.bind am name (typ (List.length ps)) + | Anf_let (_, _, Comp_func (ps, _), _) + (* FuncMap.bind am name (typ (List.length ps)) *) + (* decl_and_bind fm name i64_type (List.length ps) *) | Anf_comp_expr (Comp_func (ps, _)) -> - FuncTypeMap.bind am name (typ (List.length ps)) - | _ -> FuncTypeMap.bind am name (typ 0)) - | _ -> am) - arity_map0 + decl_and_bind fm name i64_type (List.length ps) + (* FuncMap.bind am name (typ (List.length ps)) *) + | _ -> + (* FuncMap.bind am name (typ 0) *) + decl_and_bind fm name i64_type 0) + | _ -> fm) + fmap0 program ;; -let gen_im_expr_ir ftmap = function +let gen_im_expr_ir fmap = function | Imm_num n -> Llvm.const_int i64_type n | Imm_ident id -> (match Hashtbl.find_opt named_values id with | Some v -> Llvm.build_load default_type v id builder | None -> - (match FuncTypeMap.find ftmap id with + (match FuncMap.find fmap id with | Some _ -> (* create a pointer to the code of id and take its number of args then create a closure and return created call to "alloc_closure" *) - failwith "not impl" + let _ = + match Llvm.lookup_function id the_module with + | Some _ -> failwith "not impl some _" + | None -> failwith "not impl none" + in + failwith "aaa" + (* in *) + (* let cptr = Llvm.build_pointercast "codeptrtmp" builder *) | None -> invalid_arg ("Name not bound: " ^ id))) ;; @@ -87,11 +100,11 @@ let create_entry_alloca the_fun var_name = Llvm.build_alloca i64_type var_name builder ;; -let rec gen_comp_expr_ir ftmap = function - | Comp_imm imm -> gen_im_expr_ir ftmap imm +let rec gen_comp_expr_ir fmap = function + | Comp_imm imm -> gen_im_expr_ir fmap imm | Comp_binop (op, lhs, rhs) -> - let lhs_val = gen_im_expr_ir ftmap lhs in - let rhs_val = gen_im_expr_ir ftmap rhs in + let lhs_val = gen_im_expr_ir fmap lhs in + let rhs_val = gen_im_expr_ir fmap rhs in let build_oper, name = match op with | "+" -> Llvm.build_add, "addtmp" @@ -118,23 +131,23 @@ let rec gen_comp_expr_ir ftmap = function then () else invalid_arg ("Invalid parameter num for function: " ^ f) in - let arg_vals = Array.map (gen_im_expr_ir ftmap) (Array.of_list args) in + let arg_vals = Array.map (gen_im_expr_ir fmap) (Array.of_list args) in let arg_types = Array.map Llvm.type_of arg_vals in let f_type = Llvm.function_type default_type arg_types in Llvm.build_call f_type f_val arg_vals "calltmp" builder | Comp_branch (cond, br_then, br_else) -> - let cv = gen_im_expr_ir ftmap cond in + let cv = gen_im_expr_ir fmap cond in let zero = Llvm.const_int i64_type 0 in let cond_val = Llvm.build_icmp Llvm.Icmp.Ne cv zero "cond" builder in let start_bb = Llvm.insertion_block builder in let the_fun = Llvm.block_parent start_bb in let then_bb = Llvm.append_block context "then" the_fun in Llvm.position_at_end then_bb builder; - let then_val = gen_anf_expr ftmap br_then in + let then_val = gen_anf_expr fmap br_then in let new_then_bb = Llvm.insertion_block builder in let else_bb = Llvm.append_block context "else" the_fun in Llvm.position_at_end else_bb builder; - let else_val = gen_anf_expr ftmap br_else in + let else_val = gen_anf_expr fmap br_else in let new_else_bb = Llvm.insertion_block builder in let merge_bb = Llvm.append_block context "ifcont" the_fun in Llvm.position_at_end merge_bb builder; @@ -149,23 +162,23 @@ let rec gen_comp_expr_ir ftmap = function Llvm.position_at_end merge_bb builder; phi (* | Comp_alloc imms | Comp_tuple imms -> - let imm_vals = List.map (fun i -> gen_im_expr_ir ftmap i) imms in + let imm_vals = List.map (fun i -> gen_im_expr_ir fmap i) imms in Llvm.build_call ty fn imm_vals "tupletmp" builder in failwith "a" *) | _ -> failwith "not implemented" -and gen_anf_expr ftmap = function - | Anf_comp_expr comp -> gen_comp_expr_ir ftmap comp +and gen_anf_expr fmap = function + | Anf_comp_expr comp -> gen_comp_expr_ir fmap comp | Anf_let (_, name, comp_expr, body) -> - let init_val = gen_comp_expr_ir ftmap comp_expr in + let init_val = gen_comp_expr_ir fmap comp_expr in let the_fun = Llvm.block_parent (Llvm.insertion_block builder) in let alloca = create_entry_alloca the_fun name in let _ = Llvm.build_store init_val alloca builder in Hashtbl.add named_values name alloca; - gen_anf_expr ftmap body + gen_anf_expr fmap body ;; -let gen_function ftmap name params body = +let gen_function fmap name params body = Hashtbl.clear named_values; let param_types = Array.map (fun _ -> default_type) (Array.of_list params) in let f_type = Llvm.function_type default_type param_types in @@ -198,7 +211,7 @@ let gen_function ftmap name params body = Hashtbl.replace named_values name alloca) (Llvm.params the_fun); (* Need to check for error here *) - let ret_val = gen_anf_expr ftmap body in + let ret_val = gen_anf_expr fmap body in let _ = Llvm.build_ret ret_val builder in (* (match Llvm_analysis.verify_function the_fun with | true -> () @@ -221,30 +234,20 @@ let gen_function ftmap name params body = the_var ;; *) -let gen_astructure_item ftmap = function - | Anf_str_eval expr -> gen_anf_expr ftmap expr +let gen_astructure_item fmap = function + | Anf_str_eval expr -> gen_anf_expr fmap expr | Anf_str_value (_, name, Anf_comp_expr (Comp_func (params, body))) -> - gen_function ftmap name params body + gen_function fmap name params body | Anf_str_value (_, name, expr) -> - (* let value = gen_anf_expr ftmap expr in + (* let value = gen_anf_expr fmap expr in gen_variable name value *) - gen_function ftmap name [] expr + gen_function fmap name [] expr ;; let gen_program_ir (program : aprogram) (triple : string) = Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); - let arity_map = prefill_ftmap initial_arity_map program in - let keys = FuncTypeMap.keys arity_map in - (* let program = List.rev program in *) - let _ = List.map (fun (n, ty) -> Llvm.declare_function n ty the_module) keys in - (* let _ = List.map (decl_builtin arity_map) builtins in *) - (* *) - (* List.fold_left - (fun armap_acc item -> - match item with - | Anf_str - ) arity_map program *) - let _ = List.map (fun item -> gen_astructure_item arity_map item) program in + let fmap = prefill_fmap initial_fmap program in + let _ = List.map (fun item -> gen_astructure_item fmap item) program in Llvm.string_of_llmodule the_module ;; From 0ea7b0547cf49b51610bff05b4c80e69c54d8cc0 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 2 Feb 2026 15:58:07 +0300 Subject: [PATCH 08/84] feat: add support for closures, draft of tuples --- XML/lib/backend/codegen_llvm.ml | 88 +++++++++++++++++++++------------ 1 file changed, 57 insertions(+), 31 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 7895c6b6..7b2f87d6 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -30,9 +30,29 @@ module FuncMap = struct let empty () : t = M.empty let bind (t : t) (x : ident) (ll : Llvm.llvalue * Llvm.lltype) : t = M.add x ll t let find (t : t) (x : ident) : (Llvm.llvalue * Llvm.lltype) option = M.find_opt x t + let find_exn (t : t) (x : ident) : Llvm.llvalue * Llvm.lltype = M.find x t let keys = M.bindings end +(* Return types from runtime.c *) +let initial_fmap = + let decl fmap id retty argtyps = + let ftyp = Llvm.function_type retty argtyps in + let fval = Llvm.declare_function id ftyp the_module in + FuncMap.bind fmap id (fval, ftyp) + in + let fmap = FuncMap.empty () in + let fmap = decl fmap "print_int" void_type [| i64_type |] in + let fmap = decl fmap "alloc_block" i64_type [| i64_type |] in + let fmap = decl fmap "alloc_closure" i64_type [| ptr_type; i64_type |] in + let fmap = decl fmap "apply1" i64_type [| ptr_type; i64_type |] in + let fmap = decl fmap "print_gc_status" void_type [||] in + let fmap = decl fmap "collect" void_type [||] in + let fmap = decl fmap "create_tuple" ptr_type [| i64_type |] in + let fmap = decl fmap "field" i64_type [| i64_type; i64_type |] in + fmap +;; + let decl_and_bind fmap id retty argc = let argtyps = Array.make argc i64_type in let ftyp = Llvm.function_type retty argtyps in @@ -40,20 +60,6 @@ let decl_and_bind fmap id retty argc = FuncMap.bind fmap id (fval, ftyp) ;; -(* Return types from runtime.c *) -let initial_fmap = - let fmap = FuncMap.empty () in - let fmap = decl_and_bind fmap "print_int" void_type 1 in - let fmap = decl_and_bind fmap "alloc_block" i64_type 1 in - let fmap = decl_and_bind fmap "alloc_closure" i64_type 1 in - let fmap = decl_and_bind fmap "apply1" i64_type 2 in - let fmap = decl_and_bind fmap "print_gc_status" void_type 0 in - let fmap = decl_and_bind fmap "collect" void_type 0 in - let fmap = decl_and_bind fmap "create_tuple" i64_type 1 in - let fmap = decl_and_bind fmap "field" i64_type 2 in - fmap -;; - let prefill_fmap (fmap0 : FuncMap.t) (program : aprogram) : FuncMap.t = List.fold_left (fun fm -> function @@ -73,6 +79,13 @@ let prefill_fmap (fmap0 : FuncMap.t) (program : aprogram) : FuncMap.t = program ;; +let build_alloc_closure fmap func = + let acval, actyp = FuncMap.find_exn fmap "alloc_closure" in + let argc = Array.length (Llvm.params func) in + let argc = Llvm.const_int i64_type argc in + Llvm.build_call actyp acval [| func; argc |] "closure_tmp" builder +;; + let gen_im_expr_ir fmap = function | Imm_num n -> Llvm.const_int i64_type n | Imm_ident id -> @@ -80,18 +93,10 @@ let gen_im_expr_ir fmap = function | Some v -> Llvm.build_load default_type v id builder | None -> (match FuncMap.find fmap id with - | Some _ -> - (* create a pointer to the code of id and take its number of args - then create a closure and return created call to "alloc_closure" + | Some (fval, _) -> + (* return created call to "alloc_closure" *) - let _ = - match Llvm.lookup_function id the_module with - | Some _ -> failwith "not impl some _" - | None -> failwith "not impl none" - in - failwith "aaa" - (* in *) - (* let cptr = Llvm.build_pointercast "codeptrtmp" builder *) + build_alloc_closure fmap fval | None -> invalid_arg ("Name not bound: " ^ id))) ;; @@ -130,6 +135,7 @@ let rec gen_comp_expr_ir fmap = function if Int.equal (List.length args) (Array.length (Llvm.params f_val)) then () else invalid_arg ("Invalid parameter num for function: " ^ f) + (* apply1 here *) in let arg_vals = Array.map (gen_im_expr_ir fmap) (Array.of_list args) in let arg_types = Array.map Llvm.type_of arg_vals in @@ -161,10 +167,30 @@ let rec gen_comp_expr_ir fmap = function let _ = Llvm.build_br merge_bb builder in Llvm.position_at_end merge_bb builder; phi - (* | Comp_alloc imms | Comp_tuple imms -> - let imm_vals = List.map (fun i -> gen_im_expr_ir fmap i) imms in - Llvm.build_call ty fn imm_vals "tupletmp" builder in - failwith "a" *) + | Comp_alloc imms | Comp_tuple imms -> + let ctval, cttyp = FuncMap.find_exn fmap "create_tuple" in + let argc = List.length imms in + let argc = Llvm.const_int i64_type argc in + let ptr = Llvm.build_call cttyp ctval [| argc |] "tuple_tmp" builder in + let ptr_to_0 = + Llvm.build_gep + i64_type + ptr + [| Llvm.const_int i64_type 0 |] + "ptr_to_elem_tmp" + builder + in + ptr_to_0 + (* TEST: STORE 42 IN THE FIRST POSITION SEGFAULT *) + (* Llvm.build_store (Llvm.const_int i64_type 42) ptr_to_0 builder *) + (* let _ = List.mapi + (fun i imm -> + let imval = gen_im_expr_ir fmap imm in + let mem = + Llvm.build_store imval (ptr + 8) builder + ) + imms in + ptr *) | _ -> failwith "not implemented" and gen_anf_expr fmap = function @@ -213,13 +239,13 @@ let gen_function fmap name params body = (* Need to check for error here *) let ret_val = gen_anf_expr fmap body in let _ = Llvm.build_ret ret_val builder in - (* (match Llvm_analysis.verify_function the_fun with + (match Llvm_analysis.verify_function the_fun with | true -> () | false -> Stdlib.Format.printf "invalid function generated\n%s\n" (Llvm.string_of_llvalue the_fun); - Llvm_analysis.assert_valid_function the_fun); *) + Llvm_analysis.assert_valid_function the_fun); the_fun ;; From e294d1a5c8b71c8152dbac728a566c024a1b9e82 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 2 Feb 2026 17:18:47 +0300 Subject: [PATCH 09/84] feat: add partial application --- XML/lib/backend/codegen_llvm.ml | 50 +++++++++++++++++---------------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 7b2f87d6..03630e6d 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -43,13 +43,17 @@ let initial_fmap = in let fmap = FuncMap.empty () in let fmap = decl fmap "print_int" void_type [| i64_type |] in - let fmap = decl fmap "alloc_block" i64_type [| i64_type |] in - let fmap = decl fmap "alloc_closure" i64_type [| ptr_type; i64_type |] in - let fmap = decl fmap "apply1" i64_type [| ptr_type; i64_type |] in + let fmap = decl fmap "alloc_block" i64_type (*ptr*) [| i64_type |] in + let fmap = + decl fmap "alloc_closure" i64_type (*ptr*) [| ptr_type (*ptr*); i64_type |] + in + let fmap = + decl fmap "apply1" i64_type (*ptr or int*) [| ptr_type (*ptr*); i64_type |] + in let fmap = decl fmap "print_gc_status" void_type [||] in let fmap = decl fmap "collect" void_type [||] in - let fmap = decl fmap "create_tuple" ptr_type [| i64_type |] in - let fmap = decl fmap "field" i64_type [| i64_type; i64_type |] in + let fmap = decl fmap "create_tuple" ptr_type (*ptr*) [| i64_type |] in + let fmap = decl fmap "field" i64_type (*ptr or int*) [| i64_type (*ptr*); i64_type |] in fmap ;; @@ -94,8 +98,7 @@ let gen_im_expr_ir fmap = function | None -> (match FuncMap.find fmap id with | Some (fval, _) -> - (* return created call to "alloc_closure" - *) + (* return a pointer to a closure *) build_alloc_closure fmap fval | None -> invalid_arg ("Name not bound: " ^ id))) ;; @@ -126,21 +129,20 @@ let rec gen_comp_expr_ir fmap = function in build_oper lhs_val rhs_val name builder | Comp_app (Imm_ident f, args) -> - let f_val = - match Llvm.lookup_function f the_module with - | Some name -> name - | None -> invalid_arg ("Undefined function: " ^ f) - in - let _ = - if Int.equal (List.length args) (Array.length (Llvm.params f_val)) - then () - else invalid_arg ("Invalid parameter num for function: " ^ f) - (* apply1 here *) - in - let arg_vals = Array.map (gen_im_expr_ir fmap) (Array.of_list args) in - let arg_types = Array.map Llvm.type_of arg_vals in - let f_type = Llvm.function_type default_type arg_types in - Llvm.build_call f_type f_val arg_vals "calltmp" builder + (* Format.printf "Function: %s\n Number of args: %d" f (List.length args); *) + let fval, ftype = FuncMap.find_exn fmap f in + let pvs = Llvm.params fval in + if List.length args = Array.length pvs + then Llvm.build_call ftype fval pvs "calltmp" builder + else ( + (* partial application *) + let fclos = build_alloc_closure fmap fval in + let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in + let apval, aptyp = FuncMap.find_exn fmap "apply1" in + List.fold_left + (fun clos arg -> Llvm.build_call aptyp apval [| clos; arg |] "app_tmp" builder) + fclos + argvs) | Comp_branch (cond, br_then, br_else) -> let cv = gen_im_expr_ir fmap cond in let zero = Llvm.const_int i64_type 0 in @@ -239,13 +241,13 @@ let gen_function fmap name params body = (* Need to check for error here *) let ret_val = gen_anf_expr fmap body in let _ = Llvm.build_ret ret_val builder in - (match Llvm_analysis.verify_function the_fun with + (* (match Llvm_analysis.verify_function the_fun with | true -> () | false -> Stdlib.Format.printf "invalid function generated\n%s\n" (Llvm.string_of_llvalue the_fun); - Llvm_analysis.assert_valid_function the_fun); + Llvm_analysis.assert_valid_function the_fun); *) the_fun ;; From 2b3b228606542848612daa6db5b5af645b5f2d3c Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 10 Feb 2026 10:20:17 +0300 Subject: [PATCH 10/84] feat: add create_tuple_init fun, codegen tuples with it, fix types --- XML/bin/runtime.c | 10 +++++ XML/lib/backend/codegen_llvm.ml | 76 ++++++++++++++++++++------------- 2 files changed, 56 insertions(+), 30 deletions(-) diff --git a/XML/bin/runtime.c b/XML/bin/runtime.c index f8f351f3..902998ef 100644 --- a/XML/bin/runtime.c +++ b/XML/bin/runtime.c @@ -238,6 +238,16 @@ value create_tuple(int64_t n) { return (value)alloc_block(n); } +value create_tuple_init(int64_t n, int64_t* init_arr) { + Block* tuple = create_tuple(n); + + for (int i = 0; i < n; i++) { + tuple->elems[i] = init_arr[i]; + } + + return (value)tuple; +} + value field(value val, int64_t index) { if (IS_INT(val)) panic("field: attempt to access field of an integer"); if (val == 0) panic("field: null pointer dereference"); diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 03630e6d..039783e0 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -9,7 +9,11 @@ open Common.Ast let context = Llvm.global_context () let i64_type = Llvm.i64_type context +let i32_type = Llvm.i32_type context let void_type = Llvm.void_type context +let gcheader_type = Llvm.struct_type context [| i64_type |] +let block_elms_type = Llvm.array_type i64_type 0 +let block_type = Llvm.struct_type context [| gcheader_type; i64_type; block_elms_type |] let default_type = i64_type (* *) let ptr_type = Llvm.pointer_type context let builder = Llvm.builder context @@ -45,14 +49,17 @@ let initial_fmap = let fmap = decl fmap "print_int" void_type [| i64_type |] in let fmap = decl fmap "alloc_block" i64_type (*ptr*) [| i64_type |] in let fmap = - decl fmap "alloc_closure" i64_type (*ptr*) [| ptr_type (*ptr*); i64_type |] + decl fmap "alloc_closure" i64_type (*ptr*) [| i64_type (*ptr*); i64_type |] in let fmap = - decl fmap "apply1" i64_type (*ptr or int*) [| ptr_type (*ptr*); i64_type |] + decl fmap "apply1" i64_type (*ptr or int*) [| i64_type (*ptr*); i64_type |] in let fmap = decl fmap "print_gc_status" void_type [||] in let fmap = decl fmap "collect" void_type [||] in - let fmap = decl fmap "create_tuple" ptr_type (*ptr*) [| i64_type |] in + let fmap = decl fmap "create_tuple" i64_type (*ptr*) [| i64_type |] in + let fmap = + decl fmap "create_tuple_init" i64_type (*ptr*) [| i64_type; i64_type (*ptr*) |] + in let fmap = decl fmap "field" i64_type (*ptr or int*) [| i64_type (*ptr*); i64_type |] in fmap ;; @@ -129,8 +136,13 @@ let rec gen_comp_expr_ir fmap = function in build_oper lhs_val rhs_val name builder | Comp_app (Imm_ident f, args) -> - (* Format.printf "Function: %s\n Number of args: %d" f (List.length args); *) - let fval, ftype = FuncMap.find_exn fmap f in + Format.printf "Function: %s\n Number of args: %d\n" f (List.length args); + (* let fval, ftype = FuncMap.find_exn fmap f in *) + let fval, ftype = + match FuncMap.find fmap f with + | Some (fv, ft) -> fv, ft + | _ -> failwith ("Couldn't find function " ^ f ^ " in fmap") + in let pvs = Llvm.params fval in if List.length args = Array.length pvs then Llvm.build_call ftype fval pvs "calltmp" builder @@ -170,29 +182,27 @@ let rec gen_comp_expr_ir fmap = function Llvm.position_at_end merge_bb builder; phi | Comp_alloc imms | Comp_tuple imms -> - let ctval, cttyp = FuncMap.find_exn fmap "create_tuple" in - let argc = List.length imms in - let argc = Llvm.const_int i64_type argc in - let ptr = Llvm.build_call cttyp ctval [| argc |] "tuple_tmp" builder in - let ptr_to_0 = - Llvm.build_gep - i64_type - ptr - [| Llvm.const_int i64_type 0 |] - "ptr_to_elem_tmp" - builder - in - ptr_to_0 - (* TEST: STORE 42 IN THE FIRST POSITION SEGFAULT *) - (* Llvm.build_store (Llvm.const_int i64_type 42) ptr_to_0 builder *) - (* let _ = List.mapi - (fun i imm -> - let imval = gen_im_expr_ir fmap imm in - let mem = - Llvm.build_store imval (ptr + 8) builder - ) - imms in - ptr *) + let ctval, cttyp = FuncMap.find_exn fmap "create_tuple_init" in + let argc = Llvm.const_int i64_type (List.length imms) in + (* let ret = Llvm.build_call cttyp ctval [| argc |] "tuple_ret" builder in *) + (* let ptr = Llvm.build_inttoptr ret ptr_type "tuple_ptr" builder in *) + let argv = List.map (fun im -> gen_im_expr_ir fmap im) imms in + let alloca = Llvm.build_array_alloca i64_type argc "tuple_vals_alloca" builder in + List.iteri + (fun i elem -> + let ptr_to_elem = + Llvm.build_gep + i64_type + alloca + [| Llvm.const_int i64_type i |] + "ptr_to_elem" + builder + in + let _ = Llvm.build_store elem ptr_to_elem builder in + ()) + argv; + let alloca_as_i64 = Llvm.build_pointercast alloca i64_type "alloca_as_i64" builder in + Llvm.build_call cttyp ctval [| argc; alloca_as_i64 |] "tuple_tmp" builder | _ -> failwith "not implemented" and gen_anf_expr fmap = function @@ -241,13 +251,13 @@ let gen_function fmap name params body = (* Need to check for error here *) let ret_val = gen_anf_expr fmap body in let _ = Llvm.build_ret ret_val builder in - (* (match Llvm_analysis.verify_function the_fun with + (match Llvm_analysis.verify_function the_fun with | true -> () | false -> Stdlib.Format.printf "invalid function generated\n%s\n" (Llvm.string_of_llvalue the_fun); - Llvm_analysis.assert_valid_function the_fun); *) + Llvm_analysis.assert_valid_function the_fun); the_fun ;; @@ -276,6 +286,12 @@ let gen_program_ir (program : aprogram) (triple : string) = Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); let fmap = prefill_fmap initial_fmap program in + let _ = + List.map + (fun (id, (ftyp, _)) -> + Format.printf "Id: %s Arity: %d\n" id (Array.length (Llvm.params ftyp))) + (FuncMap.keys fmap) + in let _ = List.map (fun item -> gen_astructure_item fmap item) program in Llvm.string_of_llmodule the_module ;; From b155c976da4f0c6855c27f6944f99c2e61ca716f Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 10 Feb 2026 12:44:54 +0300 Subject: [PATCH 11/84] fix: authors in dune-project --- XML/XML.opam | 8 +++++--- XML/dune-project | 9 ++++++--- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/XML/XML.opam b/XML/XML.opam index 3a82a71d..2246cee2 100644 --- a/XML/XML.opam +++ b/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" diff --git a/XML/dune-project b/XML/dune-project index 82593997..900634c4 100644 --- a/XML/dune-project +++ b/XML/dune-project @@ -7,15 +7,18 @@ (source (github Kakadu/comp24)) -(authors "Mikhail Gavrilenko" "Danila Rudnev-Stepanyan") +(authors "Mikhail Gavrilenko" "Danila Rudnev-Stepanyan" "Daniel Vlasenko") -(maintainers "Mikhail Gavrilenko" "Danila Rudnev-Stepanyan") +(maintainers + "Mikhail Gavrilenko" + "Danila Rudnev-Stepanyan" + "Daniel Vlasenko") (license "LGPL-3.0-or-later WITH OCaml-LGPL-linking-exception") (package (name XML) - (synopsis "A short LLVM demo") + (synopsis "A small ML compiler") (depends ocaml (dune From 286e602a8f5583a525ef329f9a57663dbf995825 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 10 Feb 2026 13:22:00 +0300 Subject: [PATCH 12/84] feat: gen main, now all vars are inside main --- XML/lib/backend/codegen_llvm.ml | 107 +++++++++++++++++++------------- 1 file changed, 65 insertions(+), 42 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 039783e0..1d13ad8b 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -29,13 +29,43 @@ module FuncMap = struct module M = Map.Make (K) - type t = (Llvm.llvalue * Llvm.lltype) M.t + type status = + | User + | Lib + + type t = (Llvm.llvalue * Llvm.lltype * status) M.t let empty () : t = M.empty - let bind (t : t) (x : ident) (ll : Llvm.llvalue * Llvm.lltype) : t = M.add x ll t - let find (t : t) (x : ident) : (Llvm.llvalue * Llvm.lltype) option = M.find_opt x t - let find_exn (t : t) (x : ident) : Llvm.llvalue * Llvm.lltype = M.find x t + + let bind (t : t) (x : ident) (ll : Llvm.llvalue * Llvm.lltype * status) : t = + M.add x ll t + ;; + + let find (t : t) (x : ident) : (Llvm.llvalue * Llvm.lltype * status) option = + M.find_opt x t + ;; + + let find_exn (t : t) (x : ident) : Llvm.llvalue * Llvm.lltype * status = M.find x t let keys = M.bindings + + let print_fmap (t : t) = + let _ = + List.map + (fun (id, (fval, _, s)) -> + let stat = + match s with + | User -> "user" + | Lib -> "lib" + in + Format.printf + "Id: %s Arity: %d Status: %s\n" + id + (Array.length (Llvm.params fval)) + stat) + (keys t) + in + () + ;; end (* Return types from runtime.c *) @@ -43,7 +73,7 @@ let initial_fmap = let decl fmap id retty argtyps = let ftyp = Llvm.function_type retty argtyps in let fval = Llvm.declare_function id ftyp the_module in - FuncMap.bind fmap id (fval, ftyp) + FuncMap.bind fmap id (fval, ftyp, FuncMap.Lib) in let fmap = FuncMap.empty () in let fmap = decl fmap "print_int" void_type [| i64_type |] in @@ -65,10 +95,14 @@ let initial_fmap = ;; let decl_and_bind fmap id retty argc = - let argtyps = Array.make argc i64_type in - let ftyp = Llvm.function_type retty argtyps in - let fval = Llvm.declare_function id ftyp the_module in - FuncMap.bind fmap id (fval, ftyp) + match FuncMap.find fmap id with + | Some (_, _, FuncMap.Lib) -> fmap + | _ when argc = 0 -> fmap + | _ -> + let argtyps = Array.make argc i64_type in + let ftyp = Llvm.function_type retty argtyps in + let fval = Llvm.declare_function id ftyp the_module in + FuncMap.bind fmap id (fval, ftyp, FuncMap.User) ;; let prefill_fmap (fmap0 : FuncMap.t) (program : aprogram) : FuncMap.t = @@ -76,22 +110,16 @@ let prefill_fmap (fmap0 : FuncMap.t) (program : aprogram) : FuncMap.t = (fun fm -> function | Anf_str_value (_rf, name, anf_expr) -> (match anf_expr with - | Anf_let (_, _, Comp_func (ps, _), _) - (* FuncMap.bind am name (typ (List.length ps)) *) - (* decl_and_bind fm name i64_type (List.length ps) *) - | Anf_comp_expr (Comp_func (ps, _)) -> + | Anf_let (_, _, Comp_func (ps, _), _) | Anf_comp_expr (Comp_func (ps, _)) -> decl_and_bind fm name i64_type (List.length ps) - (* FuncMap.bind am name (typ (List.length ps)) *) - | _ -> - (* FuncMap.bind am name (typ 0) *) - decl_and_bind fm name i64_type 0) + | _ -> decl_and_bind fm name i64_type 0) | _ -> fm) fmap0 program ;; let build_alloc_closure fmap func = - let acval, actyp = FuncMap.find_exn fmap "alloc_closure" in + let acval, actyp, _ = FuncMap.find_exn fmap "alloc_closure" in let argc = Array.length (Llvm.params func) in let argc = Llvm.const_int i64_type argc in Llvm.build_call actyp acval [| func; argc |] "closure_tmp" builder @@ -104,7 +132,7 @@ let gen_im_expr_ir fmap = function | Some v -> Llvm.build_load default_type v id builder | None -> (match FuncMap.find fmap id with - | Some (fval, _) -> + | Some (fval, _, _) -> (* return a pointer to a closure *) build_alloc_closure fmap fval | None -> invalid_arg ("Name not bound: " ^ id))) @@ -140,7 +168,7 @@ let rec gen_comp_expr_ir fmap = function (* let fval, ftype = FuncMap.find_exn fmap f in *) let fval, ftype = match FuncMap.find fmap f with - | Some (fv, ft) -> fv, ft + | Some (fv, ft, _) -> fv, ft | _ -> failwith ("Couldn't find function " ^ f ^ " in fmap") in let pvs = Llvm.params fval in @@ -150,7 +178,7 @@ let rec gen_comp_expr_ir fmap = function (* partial application *) let fclos = build_alloc_closure fmap fval in let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in - let apval, aptyp = FuncMap.find_exn fmap "apply1" in + let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in List.fold_left (fun clos arg -> Llvm.build_call aptyp apval [| clos; arg |] "app_tmp" builder) fclos @@ -182,7 +210,7 @@ let rec gen_comp_expr_ir fmap = function Llvm.position_at_end merge_bb builder; phi | Comp_alloc imms | Comp_tuple imms -> - let ctval, cttyp = FuncMap.find_exn fmap "create_tuple_init" in + let ctval, cttyp, _ = FuncMap.find_exn fmap "create_tuple_init" in let argc = Llvm.const_int i64_type (List.length imms) in (* let ret = Llvm.build_call cttyp ctval [| argc |] "tuple_ret" builder in *) (* let ptr = Llvm.build_inttoptr ret ptr_type "tuple_ptr" builder in *) @@ -261,37 +289,32 @@ let gen_function fmap name params body = the_fun ;; -(* - let gen_variable name value = - let the_var = - match Llvm.lookup_global name the_module with - | None -> Llvm.define_global name value the_module - | Some _ -> invalid_arg ("Redefinition of a global variable: " ^ name) - in - Hashtbl.add named_values name the_var; - the_var -;; *) - let gen_astructure_item fmap = function | Anf_str_eval expr -> gen_anf_expr fmap expr | Anf_str_value (_, name, Anf_comp_expr (Comp_func (params, body))) -> gen_function fmap name params body | Anf_str_value (_, name, expr) -> - (* let value = gen_anf_expr fmap expr in - gen_variable name value *) - gen_function fmap name [] expr + let main_fn = + match Llvm.lookup_function "main" the_module with + | Some fn -> fn + | _ -> failwith ("cannot generate value: " ^ name ^ ", main function not found") + in + Llvm.position_at_end (Llvm.entry_block main_fn) builder; + let value = gen_anf_expr fmap expr in + let alloca = create_entry_alloca main_fn name in + Hashtbl.add named_values name alloca; + Llvm.build_store value alloca builder ;; let gen_program_ir (program : aprogram) (triple : string) = Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); + let main_ty = Llvm.function_type i64_type [||] in + let main_fn = Llvm.define_function "main" main_ty the_module in let fmap = prefill_fmap initial_fmap program in - let _ = - List.map - (fun (id, (ftyp, _)) -> - Format.printf "Id: %s Arity: %d\n" id (Array.length (Llvm.params ftyp))) - (FuncMap.keys fmap) - in + FuncMap.print_fmap fmap; let _ = List.map (fun item -> gen_astructure_item fmap item) program in + Llvm.position_at_end (Llvm.entry_block main_fn) builder; + let _ = Llvm.build_ret (Llvm.const_int i64_type 0) builder in Llvm.string_of_llmodule the_module ;; From 30411de901ee05da21abb736e2d5154972b1583d Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 10 Feb 2026 17:33:19 +0300 Subject: [PATCH 13/84] fix: capture free vars in cc --- XML/lib/middleend/cc.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/XML/lib/middleend/cc.ml b/XML/lib/middleend/cc.ml index 6e76fb55..a193c159 100644 --- a/XML/lib/middleend/cc.ml +++ b/XML/lib/middleend/cc.ml @@ -147,7 +147,8 @@ let rec closure_expr toplvl_set env expr = patterns in let free_vars = free_vars_in fun_bound_vars body in - let captured_vars = SSet.diff free_vars toplvl_set in + (* let captured_vars = SSet.diff free_vars toplvl_set in *) + let captured_vars = SSet.filter (fun v -> not (List.mem v std_lib_names)) free_vars in let captured_vars_list = SSet.elements captured_vars in let new_pats_for_capture = List.map (fun v -> Pat_var v) captured_vars_list in let saturated_patterns = new_pats_for_capture @ patterns in @@ -208,7 +209,10 @@ and transform_bindings toplvl_set env rec_flag bindings = if rec_flag = Recursive then SSet.add v bound_in_fun else bound_in_fun in let free_vars = free_vars_in bound_for_body body in - let captured_vars = SSet.diff free_vars toplvl_set in + (* let captured_vars = SSet.diff free_vars toplvl_set in *) + let captured_vars = + SSet.filter (fun v -> not (List.mem v std_lib_names)) free_vars + in let captured_vars_list = SSet.elements captured_vars in let new_pats_for_capture = List.map (fun v -> Pat_var v) captured_vars_list in let saturated_patterns = new_pats_for_capture @ patterns in From 167f474439702fcac75ca985c1b8dd24decf0a9a Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 10 Feb 2026 17:33:50 +0300 Subject: [PATCH 14/84] fix: closure application --- XML/lib/backend/codegen_llvm.ml | 46 +++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 19 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 1d13ad8b..7be04832 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -164,25 +164,33 @@ let rec gen_comp_expr_ir fmap = function in build_oper lhs_val rhs_val name builder | Comp_app (Imm_ident f, args) -> - Format.printf "Function: %s\n Number of args: %d\n" f (List.length args); - (* let fval, ftype = FuncMap.find_exn fmap f in *) - let fval, ftype = - match FuncMap.find fmap f with - | Some (fv, ft, _) -> fv, ft - | _ -> failwith ("Couldn't find function " ^ f ^ " in fmap") - in - let pvs = Llvm.params fval in - if List.length args = Array.length pvs - then Llvm.build_call ftype fval pvs "calltmp" builder - else ( - (* partial application *) - let fclos = build_alloc_closure fmap fval in - let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in - let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in - List.fold_left - (fun clos arg -> Llvm.build_call aptyp apval [| clos; arg |] "app_tmp" builder) - fclos - argvs) + Format.printf "Id: %s got called with %d args\n" f (List.length args); + (match FuncMap.find fmap f with + | Some (fval, ftype, _) -> + let pvs = Llvm.params fval in + if List.length args = Array.length pvs + then Llvm.build_call ftype fval pvs "calltmp" builder + else ( + (* partial application *) + let fclos = build_alloc_closure fmap fval in + let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in + let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in + List.fold_left + (fun clos arg -> Llvm.build_call aptyp apval [| clos; arg |] "app_tmp" builder) + fclos + argvs) + | _ -> + (* maybe it's a closure in this scope *) + (match Hashtbl.find_opt named_values f with + | Some v -> + let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in + let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in + List.fold_left + (fun clos arg -> + Llvm.build_call aptyp apval [| clos; arg |] "app_tmp" builder) + v + argvs + | _ -> failwith ("Id: " ^ f ^ " not found"))) | Comp_branch (cond, br_then, br_else) -> let cv = gen_im_expr_ir fmap cond in let zero = Llvm.const_int i64_type 0 in From 0b763bba608d7b5622a8ab62f95bf354d87aa491 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 10 Feb 2026 21:28:22 +0300 Subject: [PATCH 15/84] fix: calls to void returning functions don't segfault anymore and don't call function with uninitialized parameters --- XML/lib/backend/codegen_llvm.ml | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 7be04832..1377904c 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -94,6 +94,14 @@ let initial_fmap = fmap ;; +let build_call_mb_void ftype fval argvs name = + match Llvm.return_type ftype with + | ty when ty = void_type -> + let _ = Llvm.build_call ftype fval argvs "" builder in + Llvm.const_int i64_type 0 + | _ -> Llvm.build_call ftype fval argvs name builder +;; + let decl_and_bind fmap id retty argc = match FuncMap.find fmap id with | Some (_, _, FuncMap.Lib) -> fmap @@ -168,15 +176,16 @@ let rec gen_comp_expr_ir fmap = function (match FuncMap.find fmap f with | Some (fval, ftype, _) -> let pvs = Llvm.params fval in + let argvs = Array.map (fun arg -> gen_im_expr_ir fmap arg) (Array.of_list args) in if List.length args = Array.length pvs - then Llvm.build_call ftype fval pvs "calltmp" builder + then + build_call_mb_void ftype fval argvs "calltmp" + (* then Llvm.build_call ftype fval argvs "calltmp" builder *) else ( - (* partial application *) let fclos = build_alloc_closure fmap fval in - let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in - List.fold_left - (fun clos arg -> Llvm.build_call aptyp apval [| clos; arg |] "app_tmp" builder) + Array.fold_left + (fun clos arg -> build_call_mb_void aptyp apval [| clos; arg |] "app_tmp") fclos argvs) | _ -> @@ -186,8 +195,7 @@ let rec gen_comp_expr_ir fmap = function let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in List.fold_left - (fun clos arg -> - Llvm.build_call aptyp apval [| clos; arg |] "app_tmp" builder) + (fun clos arg -> build_call_mb_void aptyp apval [| clos; arg |] "app_tmp") v argvs | _ -> failwith ("Id: " ^ f ^ " not found"))) @@ -324,5 +332,8 @@ let gen_program_ir (program : aprogram) (triple : string) = let _ = List.map (fun item -> gen_astructure_item fmap item) program in Llvm.position_at_end (Llvm.entry_block main_fn) builder; let _ = Llvm.build_ret (Llvm.const_int i64_type 0) builder in + (* match Llvm_analysis.verify_module the_module with + | Some r -> failwith r + | None -> *) Llvm.string_of_llmodule the_module ;; From a447f3349c77d0f7b5b0eb4a35636b71bf09efdd Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Thu, 12 Feb 2026 19:59:32 +0300 Subject: [PATCH 16/84] feat: now can load tuple elements --- XML/lib/backend/codegen_llvm.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 1377904c..fdb930aa 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -199,6 +199,7 @@ let rec gen_comp_expr_ir fmap = function v argvs | _ -> failwith ("Id: " ^ f ^ " not found"))) + | Comp_app (Imm_num _, _) -> failwith "cannot apply number as a function" | Comp_branch (cond, br_then, br_else) -> let cv = gen_im_expr_ir fmap cond in let zero = Llvm.const_int i64_type 0 in @@ -247,7 +248,13 @@ let rec gen_comp_expr_ir fmap = function argv; let alloca_as_i64 = Llvm.build_pointercast alloca i64_type "alloca_as_i64" builder in Llvm.build_call cttyp ctval [| argc; alloca_as_i64 |] "tuple_tmp" builder - | _ -> failwith "not implemented" + | Comp_load (imexpr, offset) -> + (*addr of the tuple *) + let vbase = gen_im_expr_ir fmap imexpr in + let voffst = Llvm.const_int i64_type offset in + let fifn, fity, _ = FuncMap.find_exn fmap "field" in + Llvm.build_call fity fifn [| vbase; voffst |] "load_tmp" builder + | Comp_func (_, _) -> failwith "func are not implemented yet" and gen_anf_expr fmap = function | Anf_comp_expr comp -> gen_comp_expr_ir fmap comp From 990b036b3c8318c31d7063d5a08e4f1c5061ff43 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Thu, 12 Feb 2026 20:50:30 +0300 Subject: [PATCH 17/84] test: add cram tests for llvm codegen, fix cc and compiler warnings --- XML/bin/runtime.c | 2 +- XML/lib/backend/codegen_llvm.ml | 4 +- XML/lib/middleend/cc.ml | 10 +- XML/many_tests/codegen_llvm.t | 1500 +++++++++++++++++++++++++++++++ XML/many_tests/dune | 3 +- 5 files changed, 1510 insertions(+), 9 deletions(-) create mode 100644 XML/many_tests/codegen_llvm.t diff --git a/XML/bin/runtime.c b/XML/bin/runtime.c index 902998ef..b1ef6ee9 100644 --- a/XML/bin/runtime.c +++ b/XML/bin/runtime.c @@ -239,7 +239,7 @@ value create_tuple(int64_t n) { } value create_tuple_init(int64_t n, int64_t* init_arr) { - Block* tuple = create_tuple(n); + Block* tuple = (Block*)create_tuple(n); for (int i = 0; i < n; i++) { tuple->elems[i] = init_arr[i]; diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index fdb930aa..ba6a5d7b 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -172,7 +172,7 @@ let rec gen_comp_expr_ir fmap = function in build_oper lhs_val rhs_val name builder | Comp_app (Imm_ident f, args) -> - Format.printf "Id: %s got called with %d args\n" f (List.length args); + (* Format.printf "Id: %s got called with %d args\n" f (List.length args); *) (match FuncMap.find fmap f with | Some (fval, ftype, _) -> let pvs = Llvm.params fval in @@ -335,7 +335,7 @@ let gen_program_ir (program : aprogram) (triple : string) = let main_ty = Llvm.function_type i64_type [||] in let main_fn = Llvm.define_function "main" main_ty the_module in let fmap = prefill_fmap initial_fmap program in - FuncMap.print_fmap fmap; + (* FuncMap.print_fmap fmap; *) let _ = List.map (fun item -> gen_astructure_item fmap item) program in Llvm.position_at_end (Llvm.entry_block main_fn) builder; let _ = Llvm.build_ret (Llvm.const_int i64_type 0) builder in diff --git a/XML/lib/middleend/cc.ml b/XML/lib/middleend/cc.ml index a193c159..c13197fd 100644 --- a/XML/lib/middleend/cc.ml +++ b/XML/lib/middleend/cc.ml @@ -147,8 +147,8 @@ let rec closure_expr toplvl_set env expr = patterns in let free_vars = free_vars_in fun_bound_vars body in - (* let captured_vars = SSet.diff free_vars toplvl_set in *) - let captured_vars = SSet.filter (fun v -> not (List.mem v std_lib_names)) free_vars in + let captured_vars = SSet.diff free_vars toplvl_set in + (* let captured_vars = SSet.filter (fun v -> not (List.mem v std_lib_names)) free_vars in *) let captured_vars_list = SSet.elements captured_vars in let new_pats_for_capture = List.map (fun v -> Pat_var v) captured_vars_list in let saturated_patterns = new_pats_for_capture @ patterns in @@ -209,10 +209,10 @@ and transform_bindings toplvl_set env rec_flag bindings = if rec_flag = Recursive then SSet.add v bound_in_fun else bound_in_fun in let free_vars = free_vars_in bound_for_body body in - (* let captured_vars = SSet.diff free_vars toplvl_set in *) - let captured_vars = + let captured_vars = SSet.diff free_vars toplvl_set in + (* let captured_vars = SSet.filter (fun v -> not (List.mem v std_lib_names)) free_vars - in + in *) let captured_vars_list = SSet.elements captured_vars in let new_pats_for_capture = List.map (fun v -> Pat_var v) captured_vars_list in let saturated_patterns = new_pats_for_capture @ patterns in diff --git a/XML/many_tests/codegen_llvm.t b/XML/many_tests/codegen_llvm.t new file mode 100644 index 00000000..b4de0f6e --- /dev/null +++ b/XML/many_tests/codegen_llvm.t @@ -0,0 +1,1500 @@ + $ dune exec ./../bin/XML_llvm.exe -- -o factorial.s < let rec fac n = if n = 0 then 1 else n * fac (n - 1) + > + > let main = print_int (fac 4) + + $ cat factorial.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %calltmp = call i64 @fac(i64 4) + store i64 %calltmp, ptr %t_6, align 4 + %t_61 = load i64, ptr %t_6, align 4 + call void @print_int(i64 %t_61) + store i64 0, ptr %t_7, align 4 + %t_72 = load i64, ptr %t_7, align 4 + store i64 %t_72, ptr %main, align 4 + ret i64 0 + } + + define i64 @fac(i64 %n) { + entry: + %t_4 = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 4 + %n2 = load i64, ptr %n1, align 4 + %eqtmp = icmp eq i64 %n2, 0 + store i1 %eqtmp, ptr %t_0, align 1 + %t_03 = load i64, ptr %t_0, align 4 + %cond = icmp ne i64 %t_03, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + br label %ifcont + + else: ; preds = %entry + %n4 = load i64, ptr %n1, align 4 + %subtmp = sub i64 %n4, 1 + store i64 %subtmp, ptr %t_1, align 4 + %t_15 = load i64, ptr %t_1, align 4 + %calltmp = call i64 @fac(i64 %t_15) + store i64 %calltmp, ptr %t_2, align 4 + %n6 = load i64, ptr %n1, align 4 + %t_27 = load i64, ptr %t_2, align 4 + %multmp = mul i64 %n6, %t_27 + store i64 %multmp, ptr %t_3, align 4 + %t_38 = load i64, ptr %t_3, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ 1, %then ], [ %t_38, %else ] + store i64 %iftmp, ptr %t_4, align 4 + %t_49 = load i64, ptr %t_4, align 4 + ret i64 %t_49 + } + +====================== Fibonacci ====================== + $ ../bin/XML_llvm.exe -o fibonacci.s < let rec fib n = if n <= 1 then n else fib (n - 1) + fib (n - 2) + > + > let main = print_int (fib 6) + + $ cat fibonacci.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %calltmp = call i64 @fib(i64 6) + store i64 %calltmp, ptr %t_8, align 4 + %t_81 = load i64, ptr %t_8, align 4 + call void @print_int(i64 %t_81) + store i64 0, ptr %t_9, align 4 + %t_92 = load i64, ptr %t_9, align 4 + store i64 %t_92, ptr %main, align 4 + ret i64 0 + } + + define i64 @fib(i64 %n) { + entry: + %t_6 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 4 + %n2 = load i64, ptr %n1, align 4 + %sletmp = icmp sle i64 %n2, 1 + store i1 %sletmp, ptr %t_0, align 1 + %t_03 = load i64, ptr %t_0, align 4 + %cond = icmp ne i64 %t_03, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + %n4 = load i64, ptr %n1, align 4 + br label %ifcont + + else: ; preds = %entry + %n5 = load i64, ptr %n1, align 4 + %subtmp = sub i64 %n5, 1 + store i64 %subtmp, ptr %t_1, align 4 + %t_16 = load i64, ptr %t_1, align 4 + %calltmp = call i64 @fib(i64 %t_16) + store i64 %calltmp, ptr %t_2, align 4 + %n7 = load i64, ptr %n1, align 4 + %subtmp8 = sub i64 %n7, 2 + store i64 %subtmp8, ptr %t_3, align 4 + %t_39 = load i64, ptr %t_3, align 4 + %calltmp10 = call i64 @fib(i64 %t_39) + store i64 %calltmp10, ptr %t_4, align 4 + %t_211 = load i64, ptr %t_2, align 4 + %t_412 = load i64, ptr %t_4, align 4 + %addtmp = add i64 %t_211, %t_412 + store i64 %addtmp, ptr %t_5, align 4 + %t_513 = load i64, ptr %t_5, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %n4, %then ], [ %t_513, %else ] + store i64 %iftmp, ptr %t_6, align 4 + %t_614 = load i64, ptr %t_6, align 4 + ret i64 %t_614 + } + +====================== Ififif ====================== + $ ../bin/XML_llvm.exe -o ififif.s < let large x = if 0<>x then print_int 0 else print_int 1 + > let main = + > let x = if (if (if 0 = 1 + > then 0 = 1 else (let t42 = print_int 42 in 1 = 1)) + > then 0 else 1) = 1 + > then 0 else 1 in + > large x + + $ cat ififif.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_13 = alloca i64, align 8 + %x = alloca i64, align 8 + %t_12 = alloca i64, align 8 + %t_11 = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t42 = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + store i1 false, ptr %t_5, align 1 + %t_51 = load i64, ptr %t_5, align 4 + %cond = icmp ne i64 %t_51, 0 + br i1 %cond, label %then, label %else + ret i64 0 + + then: ; preds = %entry + store i1 false, ptr %t_6, align 1 + %t_62 = load i64, ptr %t_6, align 4 + br label %ifcont + + else: ; preds = %entry + call void @print_int(i64 42) + store i64 0, ptr %t_7, align 4 + %t_73 = load i64, ptr %t_7, align 4 + store i64 %t_73, ptr %t42, align 4 + store i1 true, ptr %t_8, align 1 + %t_84 = load i64, ptr %t_8, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %t_62, %then ], [ %t_84, %else ] + store i64 %iftmp, ptr %t_9, align 4 + %t_95 = load i64, ptr %t_9, align 4 + %cond6 = icmp ne i64 %t_95, 0 + br i1 %cond6, label %then7, label %else8 + + then7: ; preds = %ifcont + br label %ifcont9 + + else8: ; preds = %ifcont + br label %ifcont9 + + ifcont9: ; preds = %else8, %then7 + %iftmp10 = phi i64 [ 0, %then7 ], [ 1, %else8 ] + store i64 %iftmp10, ptr %t_10, align 4 + %t_1011 = load i64, ptr %t_10, align 4 + %eqtmp = icmp eq i64 %t_1011, 1 + store i1 %eqtmp, ptr %t_11, align 1 + %t_1112 = load i64, ptr %t_11, align 4 + %cond13 = icmp ne i64 %t_1112, 0 + br i1 %cond13, label %then14, label %else15 + + then14: ; preds = %ifcont9 + br label %ifcont16 + + else15: ; preds = %ifcont9 + br label %ifcont16 + + ifcont16: ; preds = %else15, %then14 + %iftmp17 = phi i64 [ 0, %then14 ], [ 1, %else15 ] + store i64 %iftmp17, ptr %t_12, align 4 + %t_1218 = load i64, ptr %t_12, align 4 + store i64 %t_1218, ptr %x, align 4 + %x19 = load i64, ptr %x, align 4 + %calltmp = call i64 @large(i64 %x19) + store i64 %calltmp, ptr %t_13, align 4 + %t_1320 = load i64, ptr %t_13, align 4 + store i64 %t_1320, ptr %main, align 4 + } + + define i64 @large(i64 %x) { + entry: + %t_3 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 4 + %x2 = load i64, ptr %x1, align 4 + %neqtmp = icmp ne i64 0, %x2 + store i1 %neqtmp, ptr %t_0, align 1 + %t_03 = load i64, ptr %t_0, align 4 + %cond = icmp ne i64 %t_03, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + call void @print_int(i64 0) + store i64 0, ptr %t_1, align 4 + %t_14 = load i64, ptr %t_1, align 4 + br label %ifcont + + else: ; preds = %entry + call void @print_int(i64 1) + store i64 0, ptr %t_2, align 4 + %t_25 = load i64, ptr %t_2, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %t_14, %then ], [ %t_25, %else ] + store i64 %iftmp, ptr %t_3, align 4 + %t_36 = load i64, ptr %t_3, align 4 + ret i64 %t_36 + } + +====================== Simple Closure ====================== + $ ../bin/XML_llvm.exe -o closure.s < let simplesum x y = x + y + > let partialapp_sum = simplesum 5 + > let main = print_int (partialapp_sum 5) + $ cat closure.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %partialapp_sum = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %closure_tmp = call i64 @alloc_closure(ptr @simplesum, i64 2) + %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 5) + store i64 %app_tmp, ptr %t_2, align 4 + %t_21 = load i64, ptr %t_2, align 4 + store i64 %t_21, ptr %partialapp_sum, align 4 + %app_tmp2 = call i64 @apply1(ptr %partialapp_sum, i64 5) + store i64 %app_tmp2, ptr %t_3, align 4 + %t_33 = load i64, ptr %t_3, align 4 + call void @print_int(i64 %t_33) + store i64 0, ptr %t_4, align 4 + %t_44 = load i64, ptr %t_4, align 4 + store i64 %t_44, ptr %main, align 4 + ret i64 0 + } + + define i64 @simplesum(i64 %x, i64 %y) { + entry: + %t_0 = alloca i64, align 8 + %y2 = alloca i64, align 8 + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 4 + store i64 %y, ptr %y2, align 4 + %x3 = load i64, ptr %x1, align 4 + %y4 = load i64, ptr %y2, align 4 + %addtmp = add i64 %x3, %y4 + store i64 %addtmp, ptr %t_0, align 4 + %t_05 = load i64, ptr %t_0, align 4 + ret i64 %t_05 + } + +====================== CPS Factorial ====================== + $ ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o 010faccps_ll.s + Call parameter type does not match function signature! + %k2 = alloca i64, align 8 + i64 %app_tmp = call i64 @apply1(ptr %k2, i64 %t_16) + LLVM ERROR: Broken function found, compilation aborted! + Aborted (core dumped) + [134] + + $ cat 010faccps_ll.s + cat: 010faccps_ll.s: No such file or directory + [1] + +====================== CPS Fibbo ====================== + $ ../bin/XML_llvm.exe -fromfile manytests/typed/010fibcps_ll.ml -o 010fibcps_ll.s + Call parameter type does not match function signature! + %k2 = alloca i64, align 8 + i64 %app_tmp = call i64 @apply1(ptr %k2, i64 %t_16) + LLVM ERROR: Broken function found, compilation aborted! + Aborted (core dumped) + [134] + + $ cat 010fibcps_ll.s + cat: 010fibcps_ll.s: No such file or directory + [1] + + $ ../bin/XML_llvm.exe -fromfile manytests/typed/004manyargs.ml -o 004manyargs.s + + $ cat 004manyargs.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %temp2 = alloca i64, align 8 + %t_32 = alloca i64, align 8 + %t_31 = alloca i64, align 8 + %t_30 = alloca i64, align 8 + %t_29 = alloca i64, align 8 + %t_28 = alloca i64, align 8 + %rez = alloca i64, align 8 + %t_27 = alloca i64, align 8 + %t_26 = alloca i64, align 8 + %t_25 = alloca i64, align 8 + %t_24 = alloca i64, align 8 + %t_23 = alloca i64, align 8 + %t_22 = alloca i64, align 8 + %t_21 = alloca i64, align 8 + %t_20 = alloca i64, align 8 + %t_19 = alloca i64, align 8 + %t_18 = alloca i64, align 8 + %t_17 = alloca i64, align 8 + %closure_tmp = call i64 @alloc_closure(ptr @test10, i64 10) + %calltmp = call i64 @wrap(i64 %closure_tmp) + store i64 %calltmp, ptr %t_17, align 4 + %app_tmp = call i64 @apply1(ptr %t_17, i64 1) + store i64 %app_tmp, ptr %t_18, align 4 + %app_tmp1 = call i64 @apply1(ptr %t_18, i64 10) + store i64 %app_tmp1, ptr %t_19, align 4 + %app_tmp2 = call i64 @apply1(ptr %t_19, i64 100) + store i64 %app_tmp2, ptr %t_20, align 4 + %app_tmp3 = call i64 @apply1(ptr %t_20, i64 1000) + store i64 %app_tmp3, ptr %t_21, align 4 + %app_tmp4 = call i64 @apply1(ptr %t_21, i64 10000) + store i64 %app_tmp4, ptr %t_22, align 4 + %app_tmp5 = call i64 @apply1(ptr %t_22, i64 100000) + store i64 %app_tmp5, ptr %t_23, align 4 + %app_tmp6 = call i64 @apply1(ptr %t_23, i64 1000000) + store i64 %app_tmp6, ptr %t_24, align 4 + %app_tmp7 = call i64 @apply1(ptr %t_24, i64 10000000) + store i64 %app_tmp7, ptr %t_25, align 4 + %app_tmp8 = call i64 @apply1(ptr %t_25, i64 100000000) + store i64 %app_tmp8, ptr %t_26, align 4 + %app_tmp9 = call i64 @apply1(ptr %t_26, i64 1000000000) + store i64 %app_tmp9, ptr %t_27, align 4 + %t_2710 = load i64, ptr %t_27, align 4 + store i64 %t_2710, ptr %rez, align 4 + %rez11 = load i64, ptr %rez, align 4 + call void @print_int(i64 %rez11) + store i64 0, ptr %t_28, align 4 + %closure_tmp12 = call i64 @alloc_closure(ptr @test3, i64 3) + %calltmp13 = call i64 @wrap(i64 %closure_tmp12) + store i64 %calltmp13, ptr %t_29, align 4 + %app_tmp14 = call i64 @apply1(ptr %t_29, i64 1) + store i64 %app_tmp14, ptr %t_30, align 4 + %app_tmp15 = call i64 @apply1(ptr %t_30, i64 10) + store i64 %app_tmp15, ptr %t_31, align 4 + %app_tmp16 = call i64 @apply1(ptr %t_31, i64 100) + store i64 %app_tmp16, ptr %t_32, align 4 + %t_3217 = load i64, ptr %t_32, align 4 + store i64 %t_3217, ptr %temp2, align 4 + store i64 0, ptr %main, align 4 + ret i64 0 + } + + define i64 @wrap(i64 %f) { + entry: + %t_1 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %f1 = alloca i64, align 8 + store i64 %f, ptr %f1, align 4 + store i1 true, ptr %t_0, align 1 + %t_02 = load i64, ptr %t_0, align 4 + %cond = icmp ne i64 %t_02, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + %f3 = load i64, ptr %f1, align 4 + br label %ifcont + + else: ; preds = %entry + %f4 = load i64, ptr %f1, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %f3, %then ], [ %f4, %else ] + store i64 %iftmp, ptr %t_1, align 4 + %t_15 = load i64, ptr %t_1, align 4 + ret i64 %t_15 + } + + define i64 @test3(i64 %a, i64 %b, i64 %c) { + entry: + %c12 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %b9 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %a6 = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %c3 = alloca i64, align 8 + %b2 = alloca i64, align 8 + %a1 = alloca i64, align 8 + store i64 %a, ptr %a1, align 4 + store i64 %b, ptr %b2, align 4 + store i64 %c, ptr %c3, align 4 + %a4 = load i64, ptr %a1, align 4 + call void @print_int(i64 %a4) + store i64 0, ptr %t_3, align 4 + %t_35 = load i64, ptr %t_3, align 4 + store i64 %t_35, ptr %a6, align 4 + %b7 = load i64, ptr %b2, align 4 + call void @print_int(i64 %b7) + store i64 0, ptr %t_4, align 4 + %t_48 = load i64, ptr %t_4, align 4 + store i64 %t_48, ptr %b9, align 4 + %c10 = load i64, ptr %c3, align 4 + call void @print_int(i64 %c10) + store i64 0, ptr %t_5, align 4 + %t_511 = load i64, ptr %t_5, align 4 + store i64 %t_511, ptr %c12, align 4 + ret i64 0 + } + + define i64 @test10(i64 %a, i64 %b, i64 %c, i64 %d, i64 %e, i64 %f, i64 %g, i64 %h, i64 %i, i64 %j) { + entry: + %t_15 = alloca i64, align 8 + %t_14 = alloca i64, align 8 + %t_13 = alloca i64, align 8 + %t_12 = alloca i64, align 8 + %t_11 = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %j10 = alloca i64, align 8 + %i9 = alloca i64, align 8 + %h8 = alloca i64, align 8 + %g7 = alloca i64, align 8 + %f6 = alloca i64, align 8 + %e5 = alloca i64, align 8 + %d4 = alloca i64, align 8 + %c3 = alloca i64, align 8 + %b2 = alloca i64, align 8 + %a1 = alloca i64, align 8 + store i64 %a, ptr %a1, align 4 + store i64 %b, ptr %b2, align 4 + store i64 %c, ptr %c3, align 4 + store i64 %d, ptr %d4, align 4 + store i64 %e, ptr %e5, align 4 + store i64 %f, ptr %f6, align 4 + store i64 %g, ptr %g7, align 4 + store i64 %h, ptr %h8, align 4 + store i64 %i, ptr %i9, align 4 + store i64 %j, ptr %j10, align 4 + %a11 = load i64, ptr %a1, align 4 + %b12 = load i64, ptr %b2, align 4 + %addtmp = add i64 %a11, %b12 + store i64 %addtmp, ptr %t_7, align 4 + %t_713 = load i64, ptr %t_7, align 4 + %c14 = load i64, ptr %c3, align 4 + %addtmp15 = add i64 %t_713, %c14 + store i64 %addtmp15, ptr %t_8, align 4 + %t_816 = load i64, ptr %t_8, align 4 + %d17 = load i64, ptr %d4, align 4 + %addtmp18 = add i64 %t_816, %d17 + store i64 %addtmp18, ptr %t_9, align 4 + %t_919 = load i64, ptr %t_9, align 4 + %e20 = load i64, ptr %e5, align 4 + %addtmp21 = add i64 %t_919, %e20 + store i64 %addtmp21, ptr %t_10, align 4 + %t_1022 = load i64, ptr %t_10, align 4 + %f23 = load i64, ptr %f6, align 4 + %addtmp24 = add i64 %t_1022, %f23 + store i64 %addtmp24, ptr %t_11, align 4 + %t_1125 = load i64, ptr %t_11, align 4 + %g26 = load i64, ptr %g7, align 4 + %addtmp27 = add i64 %t_1125, %g26 + store i64 %addtmp27, ptr %t_12, align 4 + %t_1228 = load i64, ptr %t_12, align 4 + %h29 = load i64, ptr %h8, align 4 + %addtmp30 = add i64 %t_1228, %h29 + store i64 %addtmp30, ptr %t_13, align 4 + %t_1331 = load i64, ptr %t_13, align 4 + %i32 = load i64, ptr %i9, align 4 + %addtmp33 = add i64 %t_1331, %i32 + store i64 %addtmp33, ptr %t_14, align 4 + %t_1434 = load i64, ptr %t_14, align 4 + %j35 = load i64, ptr %j10, align 4 + %addtmp36 = add i64 %t_1434, %j35 + store i64 %addtmp36, ptr %t_15, align 4 + %t_1537 = load i64, ptr %t_15, align 4 + ret i64 %t_1537 + } + + $ ../bin/XML_llvm.exe -o tuple_return.s < let make_pair x y = (x, y) + > + > let main = + > let p = make_pair 10 20 in + > let (a, b) = p in + > print_int (a + b) + + $ cat tuple_return.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %b = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %a = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %p = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %closure_tmp = call i64 @alloc_closure(ptr @make_pair, i64 2) + %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 10) + store i64 %app_tmp, ptr %t_2, align 4 + %app_tmp1 = call i64 @apply1(ptr %t_2, i64 20) + store i64 %app_tmp1, ptr %t_3, align 4 + %t_32 = load i64, ptr %t_3, align 4 + store i64 %t_32, ptr %p, align 4 + %p3 = load i64, ptr %p, align 4 + store i64 %p3, ptr %t_4, align 4 + %t_44 = load i64, ptr %t_4, align 4 + %load_tmp = call i64 @field(i64 %t_44, i64 0) + store i64 %load_tmp, ptr %t_8, align 4 + %t_85 = load i64, ptr %t_8, align 4 + store i64 %t_85, ptr %a, align 4 + %t_46 = load i64, ptr %t_4, align 4 + %load_tmp7 = call i64 @field(i64 %t_46, i64 8) + store i64 %load_tmp7, ptr %t_7, align 4 + %t_78 = load i64, ptr %t_7, align 4 + store i64 %t_78, ptr %b, align 4 + %a9 = load i64, ptr %a, align 4 + %b10 = load i64, ptr %b, align 4 + %addtmp = add i64 %a9, %b10 + store i64 %addtmp, ptr %t_5, align 4 + %t_511 = load i64, ptr %t_5, align 4 + call void @print_int(i64 %t_511) + store i64 0, ptr %t_6, align 4 + %t_612 = load i64, ptr %t_6, align 4 + store i64 %t_612, ptr %main, align 4 + ret i64 0 + } + + define i64 @make_pair(i64 %x, i64 %y) { + entry: + %t_0 = alloca i64, align 8 + %y2 = alloca i64, align 8 + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 4 + store i64 %y, ptr %y2, align 4 + %x3 = load i64, ptr %x1, align 4 + %y4 = load i64, ptr %y2, align 4 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 %x3, ptr %ptr_to_elem, align 4 + %ptr_to_elem5 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 %y4, ptr %ptr_to_elem5, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_0, align 4 + %t_06 = load i64, ptr %t_0, align 4 + ret i64 %t_06 + } + + $ ../bin/XML_llvm.exe -o tuple_swap.s < let swap p = + > let (a, b) = p in + > (b, a) + > + > let main = + > let p1 = (1, 2) in + > let p2 = swap p1 in + > let (x, y) = p2 in + > print_int x + + $ cat tuple_swap.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %y = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %x = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %p2 = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %p1 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 1, ptr %ptr_to_elem, align 4 + %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 2, ptr %ptr_to_elem1, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_5, align 4 + %t_52 = load i64, ptr %t_5, align 4 + store i64 %t_52, ptr %p1, align 4 + %p13 = load i64, ptr %p1, align 4 + %calltmp = call i64 @swap(i64 %p13) + store i64 %calltmp, ptr %t_6, align 4 + %t_64 = load i64, ptr %t_6, align 4 + store i64 %t_64, ptr %p2, align 4 + %p25 = load i64, ptr %p2, align 4 + store i64 %p25, ptr %t_7, align 4 + %t_76 = load i64, ptr %t_7, align 4 + %load_tmp = call i64 @field(i64 %t_76, i64 0) + store i64 %load_tmp, ptr %t_10, align 4 + %t_107 = load i64, ptr %t_10, align 4 + store i64 %t_107, ptr %x, align 4 + %t_78 = load i64, ptr %t_7, align 4 + %load_tmp9 = call i64 @field(i64 %t_78, i64 8) + store i64 %load_tmp9, ptr %t_9, align 4 + %t_910 = load i64, ptr %t_9, align 4 + store i64 %t_910, ptr %y, align 4 + %x11 = load i64, ptr %x, align 4 + call void @print_int(i64 %x11) + store i64 0, ptr %t_8, align 4 + %t_812 = load i64, ptr %t_8, align 4 + store i64 %t_812, ptr %main, align 4 + ret i64 0 + } + + define i64 @swap(i64 %p) { + entry: + %t_1 = alloca i64, align 8 + %b = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %a = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %p1 = alloca i64, align 8 + store i64 %p, ptr %p1, align 4 + %p2 = load i64, ptr %p1, align 4 + store i64 %p2, ptr %t_0, align 4 + %t_03 = load i64, ptr %t_0, align 4 + %load_tmp = call i64 @field(i64 %t_03, i64 0) + store i64 %load_tmp, ptr %t_3, align 4 + %t_34 = load i64, ptr %t_3, align 4 + store i64 %t_34, ptr %a, align 4 + %t_05 = load i64, ptr %t_0, align 4 + %load_tmp6 = call i64 @field(i64 %t_05, i64 8) + store i64 %load_tmp6, ptr %t_2, align 4 + %t_27 = load i64, ptr %t_2, align 4 + store i64 %t_27, ptr %b, align 4 + %b8 = load i64, ptr %b, align 4 + %a9 = load i64, ptr %a, align 4 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 %b8, ptr %ptr_to_elem, align 4 + %ptr_to_elem10 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 %a9, ptr %ptr_to_elem10, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_1, align 4 + %t_111 = load i64, ptr %t_1, align 4 + ret i64 %t_111 + } + + $ ../bin/XML_llvm.exe -o tuple_order.s < let f n = + > n + > + > let main = + > let t = (f 10, f 20) in + > let (a, b) = t in + > print_int (a + b) + + $ cat tuple_order.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %b = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %a = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %t = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %calltmp = call i64 @f(i64 10) + store i64 %calltmp, ptr %t_1, align 4 + %calltmp1 = call i64 @f(i64 20) + store i64 %calltmp1, ptr %t_2, align 4 + %t_12 = load i64, ptr %t_1, align 4 + %t_23 = load i64, ptr %t_2, align 4 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 %t_12, ptr %ptr_to_elem, align 4 + %ptr_to_elem4 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 %t_23, ptr %ptr_to_elem4, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_3, align 4 + %t_35 = load i64, ptr %t_3, align 4 + store i64 %t_35, ptr %t, align 4 + %t6 = load i64, ptr %t, align 4 + store i64 %t6, ptr %t_4, align 4 + %t_47 = load i64, ptr %t_4, align 4 + %load_tmp = call i64 @field(i64 %t_47, i64 0) + store i64 %load_tmp, ptr %t_8, align 4 + %t_88 = load i64, ptr %t_8, align 4 + store i64 %t_88, ptr %a, align 4 + %t_49 = load i64, ptr %t_4, align 4 + %load_tmp10 = call i64 @field(i64 %t_49, i64 8) + store i64 %load_tmp10, ptr %t_7, align 4 + %t_711 = load i64, ptr %t_7, align 4 + store i64 %t_711, ptr %b, align 4 + %a12 = load i64, ptr %a, align 4 + %b13 = load i64, ptr %b, align 4 + %addtmp = add i64 %a12, %b13 + store i64 %addtmp, ptr %t_5, align 4 + %t_514 = load i64, ptr %t_5, align 4 + call void @print_int(i64 %t_514) + store i64 0, ptr %t_6, align 4 + %t_615 = load i64, ptr %t_6, align 4 + store i64 %t_615, ptr %main, align 4 + ret i64 0 + } + + define i64 @f(i64 %n) { + entry: + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 4 + %n2 = load i64, ptr %n1, align 4 + ret i64 %n2 + } + + $ ../bin/XML_llvm.exe -o tuple_linked_list.s < let rec sum_list lst = + > if lst = 0 then 0 else + > let (head, tail) = lst in + > head + sum_list tail + > + > let main = + > let lst = (10, (20, (30, 0))) in + > print_int (sum_list lst) + + $ cat tuple_linked_list.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_12 = alloca i64, align 8 + %t_11 = alloca i64, align 8 + %lst = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 30, ptr %ptr_to_elem, align 4 + %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 0, ptr %ptr_to_elem1, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_8, align 4 + %t_82 = load i64, ptr %t_8, align 4 + %tuple_vals_alloca3 = alloca i64, i64 2, align 8 + %ptr_to_elem4 = getelementptr i64, ptr %tuple_vals_alloca3, i64 0 + store i64 20, ptr %ptr_to_elem4, align 4 + %ptr_to_elem5 = getelementptr i64, ptr %tuple_vals_alloca3, i64 1 + store i64 %t_82, ptr %ptr_to_elem5, align 4 + %alloca_as_i646 = ptrtoint ptr %tuple_vals_alloca3 to i64 + %tuple_tmp7 = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i646) + store i64 %tuple_tmp7, ptr %t_9, align 4 + %t_98 = load i64, ptr %t_9, align 4 + %tuple_vals_alloca9 = alloca i64, i64 2, align 8 + %ptr_to_elem10 = getelementptr i64, ptr %tuple_vals_alloca9, i64 0 + store i64 10, ptr %ptr_to_elem10, align 4 + %ptr_to_elem11 = getelementptr i64, ptr %tuple_vals_alloca9, i64 1 + store i64 %t_98, ptr %ptr_to_elem11, align 4 + %alloca_as_i6412 = ptrtoint ptr %tuple_vals_alloca9 to i64 + %tuple_tmp13 = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i6412) + store i64 %tuple_tmp13, ptr %t_10, align 4 + %t_1014 = load i64, ptr %t_10, align 4 + store i64 %t_1014, ptr %lst, align 4 + %lst15 = load i64, ptr %lst, align 4 + %calltmp = call i64 @sum_list(i64 %lst15) + store i64 %calltmp, ptr %t_11, align 4 + %t_1116 = load i64, ptr %t_11, align 4 + call void @print_int(i64 %t_1116) + store i64 0, ptr %t_12, align 4 + %t_1217 = load i64, ptr %t_12, align 4 + store i64 %t_1217, ptr %main, align 4 + ret i64 0 + } + + define i64 @sum_list(i64 %lst) { + entry: + %t_6 = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %tail = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %head = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %lst1 = alloca i64, align 8 + store i64 %lst, ptr %lst1, align 4 + %lst2 = load i64, ptr %lst1, align 4 + %eqtmp = icmp eq i64 %lst2, 0 + store i1 %eqtmp, ptr %t_0, align 1 + %t_03 = load i64, ptr %t_0, align 4 + %cond = icmp ne i64 %t_03, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + br label %ifcont + + else: ; preds = %entry + %lst4 = load i64, ptr %lst1, align 4 + store i64 %lst4, ptr %t_1, align 4 + %t_15 = load i64, ptr %t_1, align 4 + %load_tmp = call i64 @field(i64 %t_15, i64 0) + store i64 %load_tmp, ptr %t_5, align 4 + %t_56 = load i64, ptr %t_5, align 4 + store i64 %t_56, ptr %head, align 4 + %t_17 = load i64, ptr %t_1, align 4 + %load_tmp8 = call i64 @field(i64 %t_17, i64 8) + store i64 %load_tmp8, ptr %t_4, align 4 + %t_49 = load i64, ptr %t_4, align 4 + store i64 %t_49, ptr %tail, align 4 + %tail10 = load i64, ptr %tail, align 4 + %calltmp = call i64 @sum_list(i64 %tail10) + store i64 %calltmp, ptr %t_2, align 4 + %head11 = load i64, ptr %head, align 4 + %t_212 = load i64, ptr %t_2, align 4 + %addtmp = add i64 %head11, %t_212 + store i64 %addtmp, ptr %t_3, align 4 + %t_313 = load i64, ptr %t_3, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ 0, %then ], [ %t_313, %else ] + store i64 %iftmp, ptr %t_6, align 4 + %t_614 = load i64, ptr %t_6, align 4 + ret i64 %t_614 + } + + $ ../bin/XML_llvm.exe -o tuple_large.s < let main = + > let t = (1, 2, 3, 4, 5, 6, 7, 8, 9, 10) in + > let (a, b, c, d, e, f, g, h, i, j) = t in + > print_int j + + $ cat tuple_large.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %j = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %i = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %h = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %g = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %f = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %e = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %d = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %c = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %b = alloca i64, align 8 + %t_11 = alloca i64, align 8 + %a = alloca i64, align 8 + %t_12 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %t = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %tuple_vals_alloca = alloca i64, i64 10, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 1, ptr %ptr_to_elem, align 4 + %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 2, ptr %ptr_to_elem1, align 4 + %ptr_to_elem2 = getelementptr i64, ptr %tuple_vals_alloca, i64 2 + store i64 3, ptr %ptr_to_elem2, align 4 + %ptr_to_elem3 = getelementptr i64, ptr %tuple_vals_alloca, i64 3 + store i64 4, ptr %ptr_to_elem3, align 4 + %ptr_to_elem4 = getelementptr i64, ptr %tuple_vals_alloca, i64 4 + store i64 5, ptr %ptr_to_elem4, align 4 + %ptr_to_elem5 = getelementptr i64, ptr %tuple_vals_alloca, i64 5 + store i64 6, ptr %ptr_to_elem5, align 4 + %ptr_to_elem6 = getelementptr i64, ptr %tuple_vals_alloca, i64 6 + store i64 7, ptr %ptr_to_elem6, align 4 + %ptr_to_elem7 = getelementptr i64, ptr %tuple_vals_alloca, i64 7 + store i64 8, ptr %ptr_to_elem7, align 4 + %ptr_to_elem8 = getelementptr i64, ptr %tuple_vals_alloca, i64 8 + store i64 9, ptr %ptr_to_elem8, align 4 + %ptr_to_elem9 = getelementptr i64, ptr %tuple_vals_alloca, i64 9 + store i64 10, ptr %ptr_to_elem9, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 10, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_0, align 4 + %t_010 = load i64, ptr %t_0, align 4 + store i64 %t_010, ptr %t, align 4 + %t11 = load i64, ptr %t, align 4 + store i64 %t11, ptr %t_1, align 4 + %t_112 = load i64, ptr %t_1, align 4 + %load_tmp = call i64 @field(i64 %t_112, i64 0) + store i64 %load_tmp, ptr %t_12, align 4 + %t_1213 = load i64, ptr %t_12, align 4 + store i64 %t_1213, ptr %a, align 4 + %t_114 = load i64, ptr %t_1, align 4 + %load_tmp15 = call i64 @field(i64 %t_114, i64 8) + store i64 %load_tmp15, ptr %t_11, align 4 + %t_1116 = load i64, ptr %t_11, align 4 + store i64 %t_1116, ptr %b, align 4 + %t_117 = load i64, ptr %t_1, align 4 + %load_tmp18 = call i64 @field(i64 %t_117, i64 16) + store i64 %load_tmp18, ptr %t_10, align 4 + %t_1019 = load i64, ptr %t_10, align 4 + store i64 %t_1019, ptr %c, align 4 + %t_120 = load i64, ptr %t_1, align 4 + %load_tmp21 = call i64 @field(i64 %t_120, i64 24) + store i64 %load_tmp21, ptr %t_9, align 4 + %t_922 = load i64, ptr %t_9, align 4 + store i64 %t_922, ptr %d, align 4 + %t_123 = load i64, ptr %t_1, align 4 + %load_tmp24 = call i64 @field(i64 %t_123, i64 32) + store i64 %load_tmp24, ptr %t_8, align 4 + %t_825 = load i64, ptr %t_8, align 4 + store i64 %t_825, ptr %e, align 4 + %t_126 = load i64, ptr %t_1, align 4 + %load_tmp27 = call i64 @field(i64 %t_126, i64 40) + store i64 %load_tmp27, ptr %t_7, align 4 + %t_728 = load i64, ptr %t_7, align 4 + store i64 %t_728, ptr %f, align 4 + %t_129 = load i64, ptr %t_1, align 4 + %load_tmp30 = call i64 @field(i64 %t_129, i64 48) + store i64 %load_tmp30, ptr %t_6, align 4 + %t_631 = load i64, ptr %t_6, align 4 + store i64 %t_631, ptr %g, align 4 + %t_132 = load i64, ptr %t_1, align 4 + %load_tmp33 = call i64 @field(i64 %t_132, i64 56) + store i64 %load_tmp33, ptr %t_5, align 4 + %t_534 = load i64, ptr %t_5, align 4 + store i64 %t_534, ptr %h, align 4 + %t_135 = load i64, ptr %t_1, align 4 + %load_tmp36 = call i64 @field(i64 %t_135, i64 64) + store i64 %load_tmp36, ptr %t_4, align 4 + %t_437 = load i64, ptr %t_4, align 4 + store i64 %t_437, ptr %i, align 4 + %t_138 = load i64, ptr %t_1, align 4 + %load_tmp39 = call i64 @field(i64 %t_138, i64 72) + store i64 %load_tmp39, ptr %t_3, align 4 + %t_340 = load i64, ptr %t_3, align 4 + store i64 %t_340, ptr %j, align 4 + %j41 = load i64, ptr %j, align 4 + call void @print_int(i64 %j41) + store i64 0, ptr %t_2, align 4 + %t_242 = load i64, ptr %t_2, align 4 + store i64 %t_242, ptr %main, align 4 + ret i64 0 + } + + $ ../bin/XML_llvm.exe -o tuple_basic.s < let main = + > let t = (10, 20) in + > let (a, b) = t in + > print_int (a + b) + + $ cat tuple_basic.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %b = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %a = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %t = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 10, ptr %ptr_to_elem, align 4 + %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 20, ptr %ptr_to_elem1, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_0, align 4 + %t_02 = load i64, ptr %t_0, align 4 + store i64 %t_02, ptr %t, align 4 + %t3 = load i64, ptr %t, align 4 + store i64 %t3, ptr %t_1, align 4 + %t_14 = load i64, ptr %t_1, align 4 + %load_tmp = call i64 @field(i64 %t_14, i64 0) + store i64 %load_tmp, ptr %t_5, align 4 + %t_55 = load i64, ptr %t_5, align 4 + store i64 %t_55, ptr %a, align 4 + %t_16 = load i64, ptr %t_1, align 4 + %load_tmp7 = call i64 @field(i64 %t_16, i64 8) + store i64 %load_tmp7, ptr %t_4, align 4 + %t_48 = load i64, ptr %t_4, align 4 + store i64 %t_48, ptr %b, align 4 + %a9 = load i64, ptr %a, align 4 + %b10 = load i64, ptr %b, align 4 + %addtmp = add i64 %a9, %b10 + store i64 %addtmp, ptr %t_2, align 4 + %t_211 = load i64, ptr %t_2, align 4 + call void @print_int(i64 %t_211) + store i64 0, ptr %t_3, align 4 + %t_312 = load i64, ptr %t_3, align 4 + store i64 %t_312, ptr %main, align 4 + ret i64 0 + } + + $ ../bin/XML_llvm.exe -o tuple_nested.s < let main = + > let complex = (100, (20, 3)) in + > let (a, (b, c)) = complex in + > print_int (a + b + c) + + $ cat tuple_nested.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %c = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %b = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %a = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %complex = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 20, ptr %ptr_to_elem, align 4 + %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 3, ptr %ptr_to_elem1, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_0, align 4 + %t_02 = load i64, ptr %t_0, align 4 + %tuple_vals_alloca3 = alloca i64, i64 2, align 8 + %ptr_to_elem4 = getelementptr i64, ptr %tuple_vals_alloca3, i64 0 + store i64 100, ptr %ptr_to_elem4, align 4 + %ptr_to_elem5 = getelementptr i64, ptr %tuple_vals_alloca3, i64 1 + store i64 %t_02, ptr %ptr_to_elem5, align 4 + %alloca_as_i646 = ptrtoint ptr %tuple_vals_alloca3 to i64 + %tuple_tmp7 = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i646) + store i64 %tuple_tmp7, ptr %t_1, align 4 + %t_18 = load i64, ptr %t_1, align 4 + store i64 %t_18, ptr %complex, align 4 + %complex9 = load i64, ptr %complex, align 4 + store i64 %complex9, ptr %t_2, align 4 + %t_210 = load i64, ptr %t_2, align 4 + %load_tmp = call i64 @field(i64 %t_210, i64 0) + store i64 %load_tmp, ptr %t_9, align 4 + %t_911 = load i64, ptr %t_9, align 4 + store i64 %t_911, ptr %a, align 4 + %t_212 = load i64, ptr %t_2, align 4 + %load_tmp13 = call i64 @field(i64 %t_212, i64 8) + store i64 %load_tmp13, ptr %t_6, align 4 + %t_614 = load i64, ptr %t_6, align 4 + %load_tmp15 = call i64 @field(i64 %t_614, i64 0) + store i64 %load_tmp15, ptr %t_8, align 4 + %t_816 = load i64, ptr %t_8, align 4 + store i64 %t_816, ptr %b, align 4 + %t_617 = load i64, ptr %t_6, align 4 + %load_tmp18 = call i64 @field(i64 %t_617, i64 8) + store i64 %load_tmp18, ptr %t_7, align 4 + %t_719 = load i64, ptr %t_7, align 4 + store i64 %t_719, ptr %c, align 4 + %a20 = load i64, ptr %a, align 4 + %b21 = load i64, ptr %b, align 4 + %addtmp = add i64 %a20, %b21 + store i64 %addtmp, ptr %t_3, align 4 + %t_322 = load i64, ptr %t_3, align 4 + %c23 = load i64, ptr %c, align 4 + %addtmp24 = add i64 %t_322, %c23 + store i64 %addtmp24, ptr %t_4, align 4 + %t_425 = load i64, ptr %t_4, align 4 + call void @print_int(i64 %t_425) + store i64 0, ptr %t_5, align 4 + %t_526 = load i64, ptr %t_5, align 4 + store i64 %t_526, ptr %main, align 4 + ret i64 0 + } + + $ ../bin/XML_llvm.exe -o tuple_arg.s < let sum_pair p = + > let (x, y) = p in + > x + y + > + > let main = + > let p = (40, 2) in + > print_int (sum_pair p) + + $ cat tuple_arg.s + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %p = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 40, ptr %ptr_to_elem, align 4 + %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 2, ptr %ptr_to_elem1, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_5, align 4 + %t_52 = load i64, ptr %t_5, align 4 + store i64 %t_52, ptr %p, align 4 + %p3 = load i64, ptr %p, align 4 + %calltmp = call i64 @sum_pair(i64 %p3) + store i64 %calltmp, ptr %t_6, align 4 + %t_64 = load i64, ptr %t_6, align 4 + call void @print_int(i64 %t_64) + store i64 0, ptr %t_7, align 4 + %t_75 = load i64, ptr %t_7, align 4 + store i64 %t_75, ptr %main, align 4 + ret i64 0 + } + + define i64 @sum_pair(i64 %p) { + entry: + %t_1 = alloca i64, align 8 + %y = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %x = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %p1 = alloca i64, align 8 + store i64 %p, ptr %p1, align 4 + %p2 = load i64, ptr %p1, align 4 + store i64 %p2, ptr %t_0, align 4 + %t_03 = load i64, ptr %t_0, align 4 + %load_tmp = call i64 @field(i64 %t_03, i64 0) + store i64 %load_tmp, ptr %t_3, align 4 + %t_34 = load i64, ptr %t_3, align 4 + store i64 %t_34, ptr %x, align 4 + %t_05 = load i64, ptr %t_0, align 4 + %load_tmp6 = call i64 @field(i64 %t_05, i64 8) + store i64 %load_tmp6, ptr %t_2, align 4 + %t_27 = load i64, ptr %t_2, align 4 + store i64 %t_27, ptr %y, align 4 + %x8 = load i64, ptr %x, align 4 + %y9 = load i64, ptr %y, align 4 + %addtmp = add i64 %x8, %y9 + store i64 %addtmp, ptr %t_1, align 4 + %t_110 = load i64, ptr %t_1, align 4 + ret i64 %t_110 + } + + $ ../bin/XML_llvm.exe -o tuple_gc_stress.s < let rec make_list n acc = + > if n = 0 then acc else + > make_list (n - 1) (n, acc) + > + > let main = + > let _ = print_gc_status in + > let result = make_list 10000 0 in + > let (head, tail) = result in + > let _ = print_gc_status in + > print_int head + Call parameter type does not match function signature! + ptr @make_list + i64 %closure_tmp = call i64 @alloc_closure(ptr @make_list, i64 2) + Call parameter type does not match function signature! + %t_2 = alloca i64, align 8 + i64 %app_tmp12 = call i64 @apply1(ptr %t_2, i64 %t_311) + LLVM ERROR: Broken function found, compilation aborted! + Aborted (core dumped) + [134] + $ cat tuple_gc_stress.s + cat: tuple_gc_stress.s: No such file or directory + [1] diff --git a/XML/many_tests/dune b/XML/many_tests/dune index ad0b05a6..74fd9652 100644 --- a/XML/many_tests/dune +++ b/XML/many_tests/dune @@ -15,9 +15,10 @@ (inline_tests)) (cram - (applies_to codegen anf cc ll gc) + (applies_to codegen codegen_llvm anf cc ll gc) (deps ../bin/XML.exe + ../bin/XML_llvm.exe ../bin/runtime.c manytests/do_not_type/001.ml manytests/do_not_type/002if.ml From d613e88295b8149d8b273e6128b8cf3db2f29cc4 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Fri, 13 Feb 2026 12:30:44 +0300 Subject: [PATCH 18/84] fix: cast ptr to i64 when calling builtin, put return 0 in the END of main --- XML/lib/backend/codegen_llvm.ml | 24 +- XML/many_tests/codegen_llvm.t | 549 ++++++++++++++++++++++++++++---- 2 files changed, 499 insertions(+), 74 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index ba6a5d7b..7dafe3d1 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -130,7 +130,8 @@ let build_alloc_closure fmap func = let acval, actyp, _ = FuncMap.find_exn fmap "alloc_closure" in let argc = Array.length (Llvm.params func) in let argc = Llvm.const_int i64_type argc in - Llvm.build_call actyp acval [| func; argc |] "closure_tmp" builder + let func_as_i64 = Llvm.build_pointercast func i64_type "func_as_i64" builder in + Llvm.build_call actyp acval [| func_as_i64; argc |] "closure_tmp" builder ;; let gen_im_expr_ir fmap = function @@ -185,7 +186,12 @@ let rec gen_comp_expr_ir fmap = function let fclos = build_alloc_closure fmap fval in let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in Array.fold_left - (fun clos arg -> build_call_mb_void aptyp apval [| clos; arg |] "app_tmp") + (fun clos arg -> + let clos_as_i64 = + Llvm.build_pointercast clos i64_type "clos_as_i64" builder + in + (* Llvm.build_call cttyp ctval [| argc; alloca_as_i64 |] "tuple_tmp" builder *) + build_call_mb_void aptyp apval [| clos_as_i64; arg |] "app_tmp") fclos argvs) | _ -> @@ -195,7 +201,11 @@ let rec gen_comp_expr_ir fmap = function let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in List.fold_left - (fun clos arg -> build_call_mb_void aptyp apval [| clos; arg |] "app_tmp") + (fun clos arg -> + let clos_as_i64 = + Llvm.build_pointercast clos i64_type "clos_as_i64" builder + in + build_call_mb_void aptyp apval [| clos_as_i64; arg |] "app_tmp") v argvs | _ -> failwith ("Id: " ^ f ^ " not found"))) @@ -337,10 +347,10 @@ let gen_program_ir (program : aprogram) (triple : string) = let fmap = prefill_fmap initial_fmap program in (* FuncMap.print_fmap fmap; *) let _ = List.map (fun item -> gen_astructure_item fmap item) program in - Llvm.position_at_end (Llvm.entry_block main_fn) builder; + let bbs = Llvm.basic_blocks main_fn in + Llvm.position_at_end bbs.(Array.length bbs - 1) builder; let _ = Llvm.build_ret (Llvm.const_int i64_type 0) builder in - (* match Llvm_analysis.verify_module the_module with + match Llvm_analysis.verify_module the_module with | Some r -> failwith r - | None -> *) - Llvm.string_of_llmodule the_module + | None -> Llvm.string_of_llmodule the_module ;; diff --git a/XML/many_tests/codegen_llvm.t b/XML/many_tests/codegen_llvm.t index b4de0f6e..81fafa43 100644 --- a/XML/many_tests/codegen_llvm.t +++ b/XML/many_tests/codegen_llvm.t @@ -225,7 +225,6 @@ %t_51 = load i64, ptr %t_5, align 4 %cond = icmp ne i64 %t_51, 0 br i1 %cond, label %then, label %else - ret i64 0 then: ; preds = %entry store i1 false, ptr %t_6, align 1 @@ -280,6 +279,7 @@ store i64 %calltmp, ptr %t_13, align 4 %t_1320 = load i64, ptr %t_13, align 4 store i64 %t_1320, ptr %main, align 4 + ret i64 0 } define i64 @large(i64 %x) { @@ -351,12 +351,13 @@ %t_3 = alloca i64, align 8 %partialapp_sum = alloca i64, align 8 %t_2 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(ptr @simplesum, i64 2) + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @simplesum to i64), i64 2) %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 5) store i64 %app_tmp, ptr %t_2, align 4 %t_21 = load i64, ptr %t_2, align 4 store i64 %t_21, ptr %partialapp_sum, align 4 - %app_tmp2 = call i64 @apply1(ptr %partialapp_sum, i64 5) + %clos_as_i64 = ptrtoint ptr %partialapp_sum to i64 + %app_tmp2 = call i64 @apply1(i64 %clos_as_i64, i64 5) store i64 %app_tmp2, ptr %t_3, align 4 %t_33 = load i64, ptr %t_3, align 4 call void @print_int(i64 %t_33) @@ -383,29 +384,318 @@ ====================== CPS Factorial ====================== $ ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o 010faccps_ll.s - Call parameter type does not match function signature! - %k2 = alloca i64, align 8 - i64 %app_tmp = call i64 @apply1(ptr %k2, i64 %t_16) - LLVM ERROR: Broken function found, compilation aborted! - Aborted (core dumped) - [134] $ cat 010faccps_ll.s - cat: 010faccps_ll.s: No such file or directory - [1] + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_15 = alloca i64, align 8 + %t_14 = alloca i64, align 8 + %t_13 = alloca i64, align 8 + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 4) + store i64 %app_tmp, ptr %t_13, align 4 + %closure_tmp1 = call i64 @alloc_closure(i64 ptrtoint (ptr @id to i64), i64 1) + %clos_as_i64 = ptrtoint ptr %t_13 to i64 + %app_tmp2 = call i64 @apply1(i64 %clos_as_i64, i64 %closure_tmp1) + store i64 %app_tmp2, ptr %t_14, align 4 + %t_143 = load i64, ptr %t_14, align 4 + call void @print_int(i64 %t_143) + store i64 0, ptr %t_15, align 4 + store i64 0, ptr %main, align 4 + ret i64 0 + } + + define i64 @id(i64 %x) { + entry: + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 4 + %x2 = load i64, ptr %x1, align 4 + ret i64 %x2 + } + + define i64 @fresh_1(i64 %n, i64 %k, i64 %p) { + entry: + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %p3 = alloca i64, align 8 + %k2 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 4 + store i64 %k, ptr %k2, align 4 + store i64 %p, ptr %p3, align 4 + %p4 = load i64, ptr %p3, align 4 + %n5 = load i64, ptr %n1, align 4 + %multmp = mul i64 %p4, %n5 + store i64 %multmp, ptr %t_1, align 4 + %t_16 = load i64, ptr %t_1, align 4 + %clos_as_i64 = ptrtoint ptr %k2 to i64 + %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 %t_16) + store i64 %app_tmp, ptr %t_2, align 4 + %t_27 = load i64, ptr %t_2, align 4 + ret i64 %t_27 + } + + define i64 @fac_cps(i64 %n, i64 %k) { + entry: + %t_11 = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %k2 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 4 + store i64 %k, ptr %k2, align 4 + %n3 = load i64, ptr %n1, align 4 + %eqtmp = icmp eq i64 %n3, 1 + store i1 %eqtmp, ptr %t_4, align 1 + %t_44 = load i64, ptr %t_4, align 4 + %cond = icmp ne i64 %t_44, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + %clos_as_i64 = ptrtoint ptr %k2 to i64 + %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 1) + store i64 %app_tmp, ptr %t_5, align 4 + %t_55 = load i64, ptr %t_5, align 4 + br label %ifcont + + else: ; preds = %entry + %n6 = load i64, ptr %n1, align 4 + %subtmp = sub i64 %n6, 1 + store i64 %subtmp, ptr %t_6, align 4 + %t_67 = load i64, ptr %t_6, align 4 + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %app_tmp8 = call i64 @apply1(i64 %closure_tmp, i64 %t_67) + store i64 %app_tmp8, ptr %t_7, align 4 + %n9 = load i64, ptr %n1, align 4 + %closure_tmp10 = call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_1 to i64), i64 3) + %app_tmp11 = call i64 @apply1(i64 %closure_tmp10, i64 %n9) + store i64 %app_tmp11, ptr %t_8, align 4 + %k12 = load i64, ptr %k2, align 4 + %clos_as_i6413 = ptrtoint ptr %t_8 to i64 + %app_tmp14 = call i64 @apply1(i64 %clos_as_i6413, i64 %k12) + store i64 %app_tmp14, ptr %t_9, align 4 + %t_915 = load i64, ptr %t_9, align 4 + %clos_as_i6416 = ptrtoint ptr %t_7 to i64 + %app_tmp17 = call i64 @apply1(i64 %clos_as_i6416, i64 %t_915) + store i64 %app_tmp17, ptr %t_10, align 4 + %t_1018 = load i64, ptr %t_10, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %t_55, %then ], [ %t_1018, %else ] + store i64 %iftmp, ptr %t_11, align 4 + %t_1119 = load i64, ptr %t_11, align 4 + ret i64 %t_1119 + } ====================== CPS Fibbo ====================== $ ../bin/XML_llvm.exe -fromfile manytests/typed/010fibcps_ll.ml -o 010fibcps_ll.s - Call parameter type does not match function signature! - %k2 = alloca i64, align 8 - i64 %app_tmp = call i64 @apply1(ptr %k2, i64 %t_16) - LLVM ERROR: Broken function found, compilation aborted! - Aborted (core dumped) - [134] $ cat 010fibcps_ll.s - cat: 010fibcps_ll.s: No such file or directory - [1] + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %z = alloca i64, align 8 + %t_22 = alloca i64, align 8 + %t_21 = alloca i64, align 8 + %t_20 = alloca i64, align 8 + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fib to i64), i64 2) + %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 6) + store i64 %app_tmp, ptr %t_20, align 4 + %closure_tmp1 = call i64 @alloc_closure(i64 ptrtoint (ptr @id to i64), i64 1) + %clos_as_i64 = ptrtoint ptr %t_20 to i64 + %app_tmp2 = call i64 @apply1(i64 %clos_as_i64, i64 %closure_tmp1) + store i64 %app_tmp2, ptr %t_21, align 4 + %t_213 = load i64, ptr %t_21, align 4 + call void @print_int(i64 %t_213) + store i64 0, ptr %t_22, align 4 + %t_224 = load i64, ptr %t_22, align 4 + store i64 %t_224, ptr %z, align 4 + store i64 0, ptr %main, align 4 + ret i64 0 + } + + define i64 @id(i64 %x) { + entry: + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 4 + %x2 = load i64, ptr %x1, align 4 + ret i64 %x2 + } + + define i64 @fresh_2(i64 %p1, i64 %k, i64 %p2) { + entry: + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %p23 = alloca i64, align 8 + %k2 = alloca i64, align 8 + %p11 = alloca i64, align 8 + store i64 %p1, ptr %p11, align 4 + store i64 %k, ptr %k2, align 4 + store i64 %p2, ptr %p23, align 4 + %p14 = load i64, ptr %p11, align 4 + %p25 = load i64, ptr %p23, align 4 + %addtmp = add i64 %p14, %p25 + store i64 %addtmp, ptr %t_1, align 4 + %t_16 = load i64, ptr %t_1, align 4 + %clos_as_i64 = ptrtoint ptr %k2 to i64 + %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 %t_16) + store i64 %app_tmp, ptr %t_2, align 4 + %t_27 = load i64, ptr %t_2, align 4 + ret i64 %t_27 + } + + define i64 @fresh_1(i64 %n, i64 %k, i64 %fib, i64 %p1) { + entry: + %t_8 = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %p14 = alloca i64, align 8 + %fib3 = alloca i64, align 8 + %k2 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 4 + store i64 %k, ptr %k2, align 4 + store i64 %fib, ptr %fib3, align 4 + store i64 %p1, ptr %p14, align 4 + %n5 = load i64, ptr %n1, align 4 + %subtmp = sub i64 %n5, 2 + store i64 %subtmp, ptr %t_4, align 4 + %t_46 = load i64, ptr %t_4, align 4 + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fib to i64), i64 2) + %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 %t_46) + store i64 %app_tmp, ptr %t_5, align 4 + %p17 = load i64, ptr %p14, align 4 + %closure_tmp8 = call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_2 to i64), i64 3) + %app_tmp9 = call i64 @apply1(i64 %closure_tmp8, i64 %p17) + store i64 %app_tmp9, ptr %t_6, align 4 + %k10 = load i64, ptr %k2, align 4 + %clos_as_i64 = ptrtoint ptr %t_6 to i64 + %app_tmp11 = call i64 @apply1(i64 %clos_as_i64, i64 %k10) + store i64 %app_tmp11, ptr %t_7, align 4 + %t_712 = load i64, ptr %t_7, align 4 + %clos_as_i6413 = ptrtoint ptr %t_5 to i64 + %app_tmp14 = call i64 @apply1(i64 %clos_as_i6413, i64 %t_712) + store i64 %app_tmp14, ptr %t_8, align 4 + %t_815 = load i64, ptr %t_8, align 4 + ret i64 %t_815 + } + + define i64 @fib(i64 %n, i64 %k) { + entry: + %t_18 = alloca i64, align 8 + %t_17 = alloca i64, align 8 + %t_16 = alloca i64, align 8 + %t_15 = alloca i64, align 8 + %t_14 = alloca i64, align 8 + %t_13 = alloca i64, align 8 + %t_12 = alloca i64, align 8 + %t_11 = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %k2 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 4 + store i64 %k, ptr %k2, align 4 + %n3 = load i64, ptr %n1, align 4 + %slttmp = icmp slt i64 %n3, 2 + store i1 %slttmp, ptr %t_10, align 1 + %t_104 = load i64, ptr %t_10, align 4 + %cond = icmp ne i64 %t_104, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + %n5 = load i64, ptr %n1, align 4 + %clos_as_i64 = ptrtoint ptr %k2 to i64 + %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 %n5) + store i64 %app_tmp, ptr %t_11, align 4 + %t_116 = load i64, ptr %t_11, align 4 + br label %ifcont + + else: ; preds = %entry + %n7 = load i64, ptr %n1, align 4 + %subtmp = sub i64 %n7, 1 + store i64 %subtmp, ptr %t_12, align 4 + %t_128 = load i64, ptr %t_12, align 4 + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fib to i64), i64 2) + %app_tmp9 = call i64 @apply1(i64 %closure_tmp, i64 %t_128) + store i64 %app_tmp9, ptr %t_13, align 4 + %n10 = load i64, ptr %n1, align 4 + %closure_tmp11 = call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_1 to i64), i64 4) + %app_tmp12 = call i64 @apply1(i64 %closure_tmp11, i64 %n10) + store i64 %app_tmp12, ptr %t_14, align 4 + %k13 = load i64, ptr %k2, align 4 + %clos_as_i6414 = ptrtoint ptr %t_14 to i64 + %app_tmp15 = call i64 @apply1(i64 %clos_as_i6414, i64 %k13) + store i64 %app_tmp15, ptr %t_15, align 4 + %closure_tmp16 = call i64 @alloc_closure(i64 ptrtoint (ptr @fib to i64), i64 2) + %clos_as_i6417 = ptrtoint ptr %t_15 to i64 + %app_tmp18 = call i64 @apply1(i64 %clos_as_i6417, i64 %closure_tmp16) + store i64 %app_tmp18, ptr %t_16, align 4 + %t_1619 = load i64, ptr %t_16, align 4 + %clos_as_i6420 = ptrtoint ptr %t_13 to i64 + %app_tmp21 = call i64 @apply1(i64 %clos_as_i6420, i64 %t_1619) + store i64 %app_tmp21, ptr %t_17, align 4 + %t_1722 = load i64, ptr %t_17, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %t_116, %then ], [ %t_1722, %else ] + store i64 %iftmp, ptr %t_18, align 4 + %t_1823 = load i64, ptr %t_18, align 4 + ret i64 %t_1823 + } $ ../bin/XML_llvm.exe -fromfile manytests/typed/004manyargs.ml -o 004manyargs.s @@ -453,45 +743,58 @@ %t_19 = alloca i64, align 8 %t_18 = alloca i64, align 8 %t_17 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(ptr @test10, i64 10) + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @test10 to i64), i64 10) %calltmp = call i64 @wrap(i64 %closure_tmp) store i64 %calltmp, ptr %t_17, align 4 - %app_tmp = call i64 @apply1(ptr %t_17, i64 1) + %clos_as_i64 = ptrtoint ptr %t_17 to i64 + %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 1) store i64 %app_tmp, ptr %t_18, align 4 - %app_tmp1 = call i64 @apply1(ptr %t_18, i64 10) - store i64 %app_tmp1, ptr %t_19, align 4 - %app_tmp2 = call i64 @apply1(ptr %t_19, i64 100) - store i64 %app_tmp2, ptr %t_20, align 4 - %app_tmp3 = call i64 @apply1(ptr %t_20, i64 1000) - store i64 %app_tmp3, ptr %t_21, align 4 - %app_tmp4 = call i64 @apply1(ptr %t_21, i64 10000) - store i64 %app_tmp4, ptr %t_22, align 4 - %app_tmp5 = call i64 @apply1(ptr %t_22, i64 100000) - store i64 %app_tmp5, ptr %t_23, align 4 - %app_tmp6 = call i64 @apply1(ptr %t_23, i64 1000000) - store i64 %app_tmp6, ptr %t_24, align 4 - %app_tmp7 = call i64 @apply1(ptr %t_24, i64 10000000) - store i64 %app_tmp7, ptr %t_25, align 4 - %app_tmp8 = call i64 @apply1(ptr %t_25, i64 100000000) - store i64 %app_tmp8, ptr %t_26, align 4 - %app_tmp9 = call i64 @apply1(ptr %t_26, i64 1000000000) - store i64 %app_tmp9, ptr %t_27, align 4 - %t_2710 = load i64, ptr %t_27, align 4 - store i64 %t_2710, ptr %rez, align 4 - %rez11 = load i64, ptr %rez, align 4 - call void @print_int(i64 %rez11) + %clos_as_i641 = ptrtoint ptr %t_18 to i64 + %app_tmp2 = call i64 @apply1(i64 %clos_as_i641, i64 10) + store i64 %app_tmp2, ptr %t_19, align 4 + %clos_as_i643 = ptrtoint ptr %t_19 to i64 + %app_tmp4 = call i64 @apply1(i64 %clos_as_i643, i64 100) + store i64 %app_tmp4, ptr %t_20, align 4 + %clos_as_i645 = ptrtoint ptr %t_20 to i64 + %app_tmp6 = call i64 @apply1(i64 %clos_as_i645, i64 1000) + store i64 %app_tmp6, ptr %t_21, align 4 + %clos_as_i647 = ptrtoint ptr %t_21 to i64 + %app_tmp8 = call i64 @apply1(i64 %clos_as_i647, i64 10000) + store i64 %app_tmp8, ptr %t_22, align 4 + %clos_as_i649 = ptrtoint ptr %t_22 to i64 + %app_tmp10 = call i64 @apply1(i64 %clos_as_i649, i64 100000) + store i64 %app_tmp10, ptr %t_23, align 4 + %clos_as_i6411 = ptrtoint ptr %t_23 to i64 + %app_tmp12 = call i64 @apply1(i64 %clos_as_i6411, i64 1000000) + store i64 %app_tmp12, ptr %t_24, align 4 + %clos_as_i6413 = ptrtoint ptr %t_24 to i64 + %app_tmp14 = call i64 @apply1(i64 %clos_as_i6413, i64 10000000) + store i64 %app_tmp14, ptr %t_25, align 4 + %clos_as_i6415 = ptrtoint ptr %t_25 to i64 + %app_tmp16 = call i64 @apply1(i64 %clos_as_i6415, i64 100000000) + store i64 %app_tmp16, ptr %t_26, align 4 + %clos_as_i6417 = ptrtoint ptr %t_26 to i64 + %app_tmp18 = call i64 @apply1(i64 %clos_as_i6417, i64 1000000000) + store i64 %app_tmp18, ptr %t_27, align 4 + %t_2719 = load i64, ptr %t_27, align 4 + store i64 %t_2719, ptr %rez, align 4 + %rez20 = load i64, ptr %rez, align 4 + call void @print_int(i64 %rez20) store i64 0, ptr %t_28, align 4 - %closure_tmp12 = call i64 @alloc_closure(ptr @test3, i64 3) - %calltmp13 = call i64 @wrap(i64 %closure_tmp12) - store i64 %calltmp13, ptr %t_29, align 4 - %app_tmp14 = call i64 @apply1(ptr %t_29, i64 1) - store i64 %app_tmp14, ptr %t_30, align 4 - %app_tmp15 = call i64 @apply1(ptr %t_30, i64 10) - store i64 %app_tmp15, ptr %t_31, align 4 - %app_tmp16 = call i64 @apply1(ptr %t_31, i64 100) - store i64 %app_tmp16, ptr %t_32, align 4 - %t_3217 = load i64, ptr %t_32, align 4 - store i64 %t_3217, ptr %temp2, align 4 + %closure_tmp21 = call i64 @alloc_closure(i64 ptrtoint (ptr @test3 to i64), i64 3) + %calltmp22 = call i64 @wrap(i64 %closure_tmp21) + store i64 %calltmp22, ptr %t_29, align 4 + %clos_as_i6423 = ptrtoint ptr %t_29 to i64 + %app_tmp24 = call i64 @apply1(i64 %clos_as_i6423, i64 1) + store i64 %app_tmp24, ptr %t_30, align 4 + %clos_as_i6425 = ptrtoint ptr %t_30 to i64 + %app_tmp26 = call i64 @apply1(i64 %clos_as_i6425, i64 10) + store i64 %app_tmp26, ptr %t_31, align 4 + %clos_as_i6427 = ptrtoint ptr %t_31 to i64 + %app_tmp28 = call i64 @apply1(i64 %clos_as_i6427, i64 100) + store i64 %app_tmp28, ptr %t_32, align 4 + %t_3229 = load i64, ptr %t_32, align 4 + store i64 %t_3229, ptr %temp2, align 4 store i64 0, ptr %main, align 4 ret i64 0 } @@ -669,10 +972,11 @@ %p = alloca i64, align 8 %t_3 = alloca i64, align 8 %t_2 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(ptr @make_pair, i64 2) + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @make_pair to i64), i64 2) %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 10) store i64 %app_tmp, ptr %t_2, align 4 - %app_tmp1 = call i64 @apply1(ptr %t_2, i64 20) + %clos_as_i64 = ptrtoint ptr %t_2 to i64 + %app_tmp1 = call i64 @apply1(i64 %clos_as_i64, i64 20) store i64 %app_tmp1, ptr %t_3, align 4 %t_32 = load i64, ptr %t_3, align 4 store i64 %t_32, ptr %p, align 4 @@ -1486,15 +1790,126 @@ > let (head, tail) = result in > let _ = print_gc_status in > print_int head - Call parameter type does not match function signature! - ptr @make_list - i64 %closure_tmp = call i64 @alloc_closure(ptr @make_list, i64 2) - Call parameter type does not match function signature! - %t_2 = alloca i64, align 8 - i64 %app_tmp12 = call i64 @apply1(ptr %t_2, i64 %t_311) - LLVM ERROR: Broken function found, compilation aborted! - Aborted (core dumped) - [134] $ cat tuple_gc_stress.s - cat: tuple_gc_stress.s: No such file or directory - [1] + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_12 = alloca i64, align 8 + %t_11 = alloca i64, align 8 + %tail = alloca i64, align 8 + %t_13 = alloca i64, align 8 + %head = alloca i64, align 8 + %t_14 = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %result = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @print_gc_status to i64), i64 0) + store i64 %closure_tmp, ptr %t_7, align 4 + %closure_tmp1 = call i64 @alloc_closure(i64 ptrtoint (ptr @make_list to i64), i64 2) + %app_tmp = call i64 @apply1(i64 %closure_tmp1, i64 10000) + store i64 %app_tmp, ptr %t_8, align 4 + %clos_as_i64 = ptrtoint ptr %t_8 to i64 + %app_tmp2 = call i64 @apply1(i64 %clos_as_i64, i64 0) + store i64 %app_tmp2, ptr %t_9, align 4 + %t_93 = load i64, ptr %t_9, align 4 + store i64 %t_93, ptr %result, align 4 + %result4 = load i64, ptr %result, align 4 + store i64 %result4, ptr %t_10, align 4 + %t_105 = load i64, ptr %t_10, align 4 + %load_tmp = call i64 @field(i64 %t_105, i64 0) + store i64 %load_tmp, ptr %t_14, align 4 + %t_146 = load i64, ptr %t_14, align 4 + store i64 %t_146, ptr %head, align 4 + %t_107 = load i64, ptr %t_10, align 4 + %load_tmp8 = call i64 @field(i64 %t_107, i64 8) + store i64 %load_tmp8, ptr %t_13, align 4 + %t_139 = load i64, ptr %t_13, align 4 + store i64 %t_139, ptr %tail, align 4 + %closure_tmp10 = call i64 @alloc_closure(i64 ptrtoint (ptr @print_gc_status to i64), i64 0) + store i64 %closure_tmp10, ptr %t_11, align 4 + %head11 = load i64, ptr %head, align 4 + call void @print_int(i64 %head11) + store i64 0, ptr %t_12, align 4 + %t_1212 = load i64, ptr %t_12, align 4 + store i64 %t_1212, ptr %main, align 4 + ret i64 0 + } + + define i64 @make_list(i64 %n, i64 %acc) { + entry: + %t_5 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + %acc2 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 4 + store i64 %acc, ptr %acc2, align 4 + %n3 = load i64, ptr %n1, align 4 + %eqtmp = icmp eq i64 %n3, 0 + store i1 %eqtmp, ptr %t_0, align 1 + %t_04 = load i64, ptr %t_0, align 4 + %cond = icmp ne i64 %t_04, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + %acc5 = load i64, ptr %acc2, align 4 + br label %ifcont + + else: ; preds = %entry + %n6 = load i64, ptr %n1, align 4 + %subtmp = sub i64 %n6, 1 + store i64 %subtmp, ptr %t_1, align 4 + %t_17 = load i64, ptr %t_1, align 4 + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @make_list to i64), i64 2) + %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 %t_17) + store i64 %app_tmp, ptr %t_2, align 4 + %n8 = load i64, ptr %n1, align 4 + %acc9 = load i64, ptr %acc2, align 4 + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 %n8, ptr %ptr_to_elem, align 4 + %ptr_to_elem10 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 %acc9, ptr %ptr_to_elem10, align 4 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_3, align 4 + %t_311 = load i64, ptr %t_3, align 4 + %clos_as_i64 = ptrtoint ptr %t_2 to i64 + %app_tmp12 = call i64 @apply1(i64 %clos_as_i64, i64 %t_311) + store i64 %app_tmp12, ptr %t_4, align 4 + %t_413 = load i64, ptr %t_4, align 4 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %acc5, %then ], [ %t_413, %else ] + store i64 %iftmp, ptr %t_5, align 4 + %t_514 = load i64, ptr %t_5, align 4 + ret i64 %t_514 + } From e14ef5f3965764a10b98b7abd57e18638b074a75 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 15 Feb 2026 14:52:05 +0300 Subject: [PATCH 19/84] fix: now ll lifts everything, it works! --- XML/lib/middleend/ll.ml | 29 ++++++++++++++++------------- XML/many_tests/gc.t | 1 - 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/XML/lib/middleend/ll.ml b/XML/lib/middleend/ll.ml index b069a7c3..76a9299d 100644 --- a/XML/lib/middleend/ll.ml +++ b/XML/lib/middleend/ll.ml @@ -43,18 +43,13 @@ let occurs_im x = function ;; let rec escapes_comp x = function - | Comp_imm i -> occurs_im x i - | Comp_binop (_op, a, b) -> occurs_im x a || occurs_im x b - | Comp_app (f, args) -> - List.exists (occurs_im x) args - || - (match f with - | Imm_ident y when String.equal y x -> false - | _ -> occurs_im x f) - | Comp_branch (c, t, e) -> occurs_im x c || escapes_anf x t || escapes_anf x e - | Comp_func (_ps, body) -> SSet.mem x (fv_anf body) - | Comp_tuple is | Comp_alloc is -> List.exists (occurs_im x) is - | Comp_load (addr, _off) -> occurs_im x addr + | Comp_func (ps, body) -> if List.mem x ps then false else SSet.mem x (fv_anf body) + | Comp_branch (_c, t, e) -> escapes_anf x t || escapes_anf x e + | Comp_app (_, _) + | Comp_binop (_, _, _) + | Comp_tuple _ | Comp_alloc _ + | Comp_load (_, _) + | Comp_imm _ -> false and escapes_anf x = function | Anf_comp_expr ce -> escapes_comp x ce @@ -104,7 +99,15 @@ let rec lift_anf (env : ctx) (n : supply) (e : anf_expr) (Nonrecursive, lifted_name, Anf_comp_expr (Comp_func (fvs @ ps, fbody'))) in let (body', defs_e2), n3 = lift_anf env_body n2 body in - (body', defs_body @ (def_item :: defs_e2)), n3) + (* (body', defs_body @ (def_item :: defs_e2)), n3 *) + let new_body = + if SSet.mem x (fv_anf body') + then + (* create a closure with old name *) + Anf_let (Nonrecursive, x, Comp_imm (Imm_ident lifted_name), body') + else body' + in + (new_body, defs_body @ (def_item :: defs_e2)), n3) | Comp_imm (Imm_ident y) -> (match SMap.find_opt y env with | Some (lf, fvs) -> diff --git a/XML/many_tests/gc.t b/XML/many_tests/gc.t index 301204c9..467ff890 100644 --- a/XML/many_tests/gc.t +++ b/XML/many_tests/gc.t @@ -96,7 +96,6 @@ $ qemu-riscv64 -L /usr/riscv64-linux-gnu -cpu rv64 ./prog.exe 7 - $ dune exec ./../bin/XML.exe -- -o gc_oom_block.s < let main = > let _ = alloc_block 10000000 in From f15595d437622ea572d91b88e80107a37b691773 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 15 Feb 2026 15:01:27 +0300 Subject: [PATCH 20/84] fix: change error message --- XML/lib/backend/codegen_llvm.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 7dafe3d1..3aaec911 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -264,7 +264,7 @@ let rec gen_comp_expr_ir fmap = function let voffst = Llvm.const_int i64_type offset in let fifn, fity, _ = FuncMap.find_exn fmap "field" in Llvm.build_call fity fifn [| vbase; voffst |] "load_tmp" builder - | Comp_func (_, _) -> failwith "func are not implemented yet" + | Comp_func (_, _) -> failwith "anonymous functions should be lambda-lifted" and gen_anf_expr fmap = function | Anf_comp_expr comp -> gen_comp_expr_ir fmap comp From 76b14fe9fda2a66fa1dd09ab25496beb71ee80bb Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 15 Feb 2026 15:38:18 +0300 Subject: [PATCH 21/84] feat: add ability to optimize llvm ir --- XML/bin/XML_llvm.ml | 11 ++++++++--- XML/lib/backend/codegen_llvm.ml | 19 ++++++++++++++++++- XML/lib/backend/codegen_llvm.mli | 5 +++-- XML/lib/backend/dune | 1 + 4 files changed, 30 insertions(+), 6 deletions(-) diff --git a/XML/bin/XML_llvm.ml b/XML/bin/XML_llvm.ml index f31b60ba..3c23629f 100644 --- a/XML/bin/XML_llvm.ml +++ b/XML/bin/XML_llvm.ml @@ -12,6 +12,7 @@ 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 show_ast : bool ; mutable show_anf : bool ; mutable show_cc : bool @@ -22,14 +23,14 @@ type options = (* Compiler Entry Points *) (* ------------------------------- *) -let to_llvm_ir ast = +let to_llvm_ir ast opt = 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 - Backend.Codegen_llvm.gen_program_ir ll_anf triple + Backend.Codegen_llvm.gen_program_ir ll_anf triple opt ;; (* in *) @@ -58,7 +59,7 @@ let compile_and_write options source_code = (* 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 in + let llvm_ir_code = to_llvm_ir ast options.optimization_lvl in match options.output_file_name with | Some out_file -> (try @@ -108,6 +109,7 @@ let () = ; show_anf = false ; show_cc = false ; show_ll = false + ; optimization_lvl = None } in let usage_msg = @@ -138,6 +140,9 @@ let () = (* ( "--gc-stats" , Arg.Unit (fun () -> options.gc_stats <- true) , " Enable GC statistics and force a collection at program start/end" ) *) + ; ( "-O" + , Arg.String (fun opt -> options.optimization_lvl <- Some opt) + , " Set IR optimization level, i.e. \"O2\"" ) ] in let handle_anon_arg filename = diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 3aaec911..c709c191 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -339,7 +339,23 @@ let gen_astructure_item fmap = function Llvm.build_store value alloca builder ;; -let gen_program_ir (program : aprogram) (triple : string) = +let optimize_ir (triple : string) (opt : string option) = + let target = Llvm_target.Target.by_triple triple in + let machine = Llvm_target.TargetMachine.create ~triple target in + let opts = Llvm_passbuilder.create_passbuilder_options () in + let optflag = + match opt with + | Some opt -> opt + | _ -> "O0" + in + let optflag = "default<" ^ optflag ^ ">" in + (match Llvm_passbuilder.run_passes the_module optflag machine opts with + | Error e -> failwith e + | Ok () -> ()); + Llvm_passbuilder.dispose_passbuilder_options opts +;; + +let gen_program_ir (program : aprogram) (triple : string) (opt : string option) = Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); let main_ty = Llvm.function_type i64_type [||] in @@ -350,6 +366,7 @@ let gen_program_ir (program : aprogram) (triple : string) = let bbs = Llvm.basic_blocks main_fn in Llvm.position_at_end bbs.(Array.length bbs - 1) builder; let _ = Llvm.build_ret (Llvm.const_int i64_type 0) builder in + optimize_ir triple opt; match Llvm_analysis.verify_module the_module with | Some r -> failwith r | None -> Llvm.string_of_llmodule the_module diff --git a/XML/lib/backend/codegen_llvm.mli b/XML/lib/backend/codegen_llvm.mli index ff3f7bdd..a95768d9 100644 --- a/XML/lib/backend/codegen_llvm.mli +++ b/XML/lib/backend/codegen_llvm.mli @@ -4,5 +4,6 @@ open Format -(* gens program on LLMV IR from the ast *) -val gen_program_ir : Middleend.Anf.aprogram -> string -> string +(** [gen_program_ir prog triple opt] gens program in LLMV IR from the program [prog] +for the target architecture specified by [triple] with optimization level [opt] if not None, O0 otherwise*) +val gen_program_ir : Middleend.Anf.aprogram -> string -> string option -> string diff --git a/XML/lib/backend/dune b/XML/lib/backend/dune index 5f7c372d..e1479cf0 100644 --- a/XML/lib/backend/dune +++ b/XML/lib/backend/dune @@ -8,6 +8,7 @@ llvm llvm.analysis llvm.executionengine + llvm.passbuilder stdio XML.Common XML.Middleend) From 09122f3ef39d0e07b108ee9c26624fde552eafaf Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 15 Feb 2026 20:29:40 +0300 Subject: [PATCH 22/84] feat: user can choose llvm target, rv64 by default --- XML/bin/XML_llvm.ml | 17 +++++++++++----- XML/lib/backend/codegen_llvm.ml | 1 + XML/lib/backend/dune | 1 + XML/many_tests/codegen_llvm.t | 36 ++++++++++++++++----------------- 4 files changed, 32 insertions(+), 23 deletions(-) diff --git a/XML/bin/XML_llvm.ml b/XML/bin/XML_llvm.ml index 3c23629f..5d82df2b 100644 --- a/XML/bin/XML_llvm.ml +++ b/XML/bin/XML_llvm.ml @@ -13,6 +13,7 @@ type options = ; 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 @@ -23,14 +24,16 @@ type options = (* Compiler Entry Points *) (* ------------------------------- *) -let to_llvm_ir ast opt = +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 - Backend.Codegen_llvm.gen_program_ir ll_anf triple opt + (* 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 ;; (* in *) @@ -59,7 +62,7 @@ let compile_and_write options source_code = (* 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.optimization_lvl in + let llvm_ir_code = to_llvm_ir ast options in match options.output_file_name with | Some out_file -> (try @@ -110,6 +113,7 @@ let () = ; show_cc = false ; show_ll = false ; optimization_lvl = None + ; target = "riscv64-unknown-linux-gnu" } in let usage_msg = @@ -142,7 +146,10 @@ let () = , " Enable GC statistics and force a collection at program start/end" ) *) ; ( "-O" , Arg.String (fun opt -> options.optimization_lvl <- Some opt) - , " Set IR optimization level, i.e. \"O2\"" ) + , " Set IR optimization level, \"O0\" by default" ) + ; ( "-t" + , Arg.String (fun targ -> options.target <- targ) + , " Set target platform, \"riscv64-unknown-linux-gnu\" by default" ) ] in let handle_anon_arg filename = diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index c709c191..c9b776df 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -356,6 +356,7 @@ let optimize_ir (triple : string) (opt : string option) = ;; let gen_program_ir (program : aprogram) (triple : string) (opt : string option) = + Llvm_all_backends.initialize (); Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); let main_ty = Llvm.function_type i64_type [||] in diff --git a/XML/lib/backend/dune b/XML/lib/backend/dune index e1479cf0..0826b802 100644 --- a/XML/lib/backend/dune +++ b/XML/lib/backend/dune @@ -9,6 +9,7 @@ llvm.analysis llvm.executionengine llvm.passbuilder + llvm.all_backends stdio XML.Common XML.Middleend) diff --git a/XML/many_tests/codegen_llvm.t b/XML/many_tests/codegen_llvm.t index 81fafa43..82be9ba2 100644 --- a/XML/many_tests/codegen_llvm.t +++ b/XML/many_tests/codegen_llvm.t @@ -1,12 +1,12 @@ - $ dune exec ./../bin/XML_llvm.exe -- -o factorial.s < let rec fac n = if n = 0 then 1 else n * fac (n - 1) > > let main = print_int (fac 4) - $ cat factorial.s + $ cat factorial.ll ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -90,7 +90,7 @@ $ cat fibonacci.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -187,7 +187,7 @@ $ cat ififif.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -324,7 +324,7 @@ $ cat closure.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -388,7 +388,7 @@ $ cat 010faccps_ll.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -522,7 +522,7 @@ $ cat 010fibcps_ll.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -702,7 +702,7 @@ $ cat 004manyargs.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -939,7 +939,7 @@ $ cat tuple_return.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -1039,7 +1039,7 @@ $ cat tuple_swap.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -1155,7 +1155,7 @@ $ cat tuple_order.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -1250,7 +1250,7 @@ $ cat tuple_linked_list.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -1380,7 +1380,7 @@ $ cat tuple_large.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -1522,7 +1522,7 @@ $ cat tuple_basic.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -1597,7 +1597,7 @@ $ cat tuple_nested.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -1701,7 +1701,7 @@ $ cat tuple_arg.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) @@ -1793,7 +1793,7 @@ $ cat tuple_gc_stress.s ; ModuleID = 'main' source_filename = "main" - target triple = "x86_64-pc-linux-gnu" + target triple = "riscv64-unknown-linux-gnu" declare void @print_int(i64) From 5b7173ce0f22a8790465d11883d433d6a7acd84f Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 15 Feb 2026 21:55:50 +0300 Subject: [PATCH 23/84] chore: add *.ll to gitignore --- XML/.gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/XML/.gitignore b/XML/.gitignore index 7de31292..58760c33 100644 --- a/XML/.gitignore +++ b/XML/.gitignore @@ -5,3 +5,4 @@ *.o *.out *.exe +*.ll \ No newline at end of file From 6831a8dca09687d0cae87c8813c409d626c60cc7 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 15 Feb 2026 21:59:03 +0300 Subject: [PATCH 24/84] fix: tag ints in llvm --- XML/lib/backend/codegen_llvm.ml | 57 +++++++++++++++++++++------------ 1 file changed, 36 insertions(+), 21 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index c9b776df..8bf56bd7 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -5,8 +5,6 @@ open Middleend.Anf open Common.Ast -(* Don't forget about tagging ints *) - let context = Llvm.global_context () let i64_type = Llvm.i64_type context let i32_type = Llvm.i32_type context @@ -135,7 +133,7 @@ let build_alloc_closure fmap func = ;; let gen_im_expr_ir fmap = function - | Imm_num n -> Llvm.const_int i64_type n + | Imm_num n -> Llvm.const_int i64_type ((n lsl 1) lor 1) | Imm_ident id -> (match Hashtbl.find_opt named_values id with | Some v -> Llvm.build_load default_type v id builder @@ -152,26 +150,43 @@ let create_entry_alloca the_fun var_name = Llvm.build_alloca i64_type var_name builder ;; +(* working with tagged integers *) +let gen_tagged_binop fmap op lhs rhs = + let left = gen_im_expr_ir fmap lhs in + let right = gen_im_expr_ir fmap rhs in + let one = Llvm.const_int i64_type 1 in + (* let build_oper, name = *) + match op with + | "+" -> + (* Llvm.build_add, "addtmp" *) + let temp = Llvm.build_add left right "addtmp1" builder in + Llvm.build_sub temp one "addtmp2" builder + | "-" -> + let temp = Llvm.build_sub left right "subtmp1" builder in + Llvm.build_add temp one "subtmp2" builder + | "*" -> + let left' = Llvm.build_lshr left one "multmp1" builder in + let right' = Llvm.build_sub right one "multmp2" builder in + let temp = Llvm.build_mul left' right' "multmp3" builder in + Llvm.build_add temp one "multmp4" builder + | "/" -> + let left' = Llvm.build_lshr left one "divtmp1" builder in + let right' = Llvm.build_lshr right one "divtmp2" builder in + let temp = Llvm.build_sdiv left' right' "divtmp3" builder in + let temp1 = Llvm.build_add temp temp "divtmp4" builder in + Llvm.build_add temp1 one "divtmp5" builder + | "<" -> Llvm.build_icmp Llvm.Icmp.Slt left right "slttmp" builder + | "<=" -> Llvm.build_icmp Llvm.Icmp.Sle left right "sletmp" builder + | ">" -> Llvm.build_icmp Llvm.Icmp.Sgt left right "sgttmp" builder + | ">=" -> Llvm.build_icmp Llvm.Icmp.Sge left right "sgetmp" builder + | "=" -> Llvm.build_icmp Llvm.Icmp.Eq left right "eqtmp" builder + | "<>" -> Llvm.build_icmp Llvm.Icmp.Ne left right "neqtmp" builder + | _ -> invalid_arg ("Unsupported binary operator: " ^ op) +;; + let rec gen_comp_expr_ir fmap = function | Comp_imm imm -> gen_im_expr_ir fmap imm - | Comp_binop (op, lhs, rhs) -> - let lhs_val = gen_im_expr_ir fmap lhs in - let rhs_val = gen_im_expr_ir fmap rhs in - let build_oper, name = - match op with - | "+" -> Llvm.build_add, "addtmp" - | "-" -> Llvm.build_sub, "subtmp" - | "*" -> Llvm.build_mul, "multmp" - | "/" -> Llvm.build_sdiv, "divtmp" - | "<" -> Llvm.build_icmp Llvm.Icmp.Slt, "slttmp" - | "<=" -> Llvm.build_icmp Llvm.Icmp.Sle, "sletmp" - | ">" -> Llvm.build_icmp Llvm.Icmp.Sgt, "sgttmp" - | ">=" -> Llvm.build_icmp Llvm.Icmp.Sge, "sgetmp" - | "=" -> Llvm.build_icmp Llvm.Icmp.Eq, "eqtmp" - | "<>" -> Llvm.build_icmp Llvm.Icmp.Ne, "neqtmp" - | _ -> invalid_arg ("Unsupported binary operator: " ^ op) - in - build_oper lhs_val rhs_val name builder + | Comp_binop (op, lhs, rhs) -> gen_tagged_binop fmap op lhs rhs | Comp_app (Imm_ident f, args) -> (* Format.printf "Id: %s got called with %d args\n" f (List.length args); *) (match FuncMap.find fmap f with From 1a86cf5e57a08b2b9471ce89c008047065be909e Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 15 Feb 2026 22:58:31 +0300 Subject: [PATCH 25/84] fix: alignment and wrong size in stores --- XML/lib/backend/codegen_llvm.ml | 46 ++++++++++++++++++++++++--------- 1 file changed, 34 insertions(+), 12 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 8bf56bd7..7f0d9200 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -7,7 +7,7 @@ open Common.Ast let context = Llvm.global_context () let i64_type = Llvm.i64_type context -let i32_type = Llvm.i32_type context +let gl_align = 8 let void_type = Llvm.void_type context let gcheader_type = Llvm.struct_type context [| i64_type |] let block_elms_type = Llvm.array_type i64_type 0 @@ -136,7 +136,10 @@ let gen_im_expr_ir fmap = function | Imm_num n -> Llvm.const_int i64_type ((n lsl 1) lor 1) | Imm_ident id -> (match Hashtbl.find_opt named_values id with - | Some v -> Llvm.build_load default_type v id builder + | Some v -> + let temp = Llvm.build_load default_type v id builder in + Llvm.set_alignment gl_align temp; + temp | None -> (match FuncMap.find fmap id with | Some (fval, _, _) -> @@ -175,12 +178,26 @@ let gen_tagged_binop fmap op lhs rhs = let temp = Llvm.build_sdiv left' right' "divtmp3" builder in let temp1 = Llvm.build_add temp temp "divtmp4" builder in Llvm.build_add temp1 one "divtmp5" builder - | "<" -> Llvm.build_icmp Llvm.Icmp.Slt left right "slttmp" builder - | "<=" -> Llvm.build_icmp Llvm.Icmp.Sle left right "sletmp" builder - | ">" -> Llvm.build_icmp Llvm.Icmp.Sgt left right "sgttmp" builder - | ">=" -> Llvm.build_icmp Llvm.Icmp.Sge left right "sgetmp" builder - | "=" -> Llvm.build_icmp Llvm.Icmp.Eq left right "eqtmp" builder - | "<>" -> Llvm.build_icmp Llvm.Icmp.Ne left right "neqtmp" builder + | "<" -> + (* if we don't extend, Llvm will generate store i1 instead of store i64 + and this will lead to strange behaviour *) + let temp = Llvm.build_icmp Llvm.Icmp.Slt left right "slttmp" builder in + Llvm.build_zext temp i64_type "slttmp_as_i64" builder + | "<=" -> + let temp = Llvm.build_icmp Llvm.Icmp.Sle left right "sletmp" builder in + Llvm.build_zext temp i64_type "sletmp_as_i64" builder + | ">" -> + let temp = Llvm.build_icmp Llvm.Icmp.Sgt left right "sgttmp" builder in + Llvm.build_zext temp i64_type "sgttmp_as_i64" builder + | ">=" -> + let temp = Llvm.build_icmp Llvm.Icmp.Sge left right "sgetmp" builder in + Llvm.build_zext temp i64_type "sgetmp_as_i64" builder + | "=" -> + let temp = Llvm.build_icmp Llvm.Icmp.Eq left right "eqtmp" builder in + Llvm.build_zext temp i64_type "eqtmp_as_i64" builder + | "<>" -> + let temp = Llvm.build_icmp Llvm.Icmp.Ne left right "neqtmp" builder in + Llvm.build_zext temp i64_type "neqtmp_as_i64" builder | _ -> invalid_arg ("Unsupported binary operator: " ^ op) ;; @@ -268,7 +285,8 @@ let rec gen_comp_expr_ir fmap = function "ptr_to_elem" builder in - let _ = Llvm.build_store elem ptr_to_elem builder in + let store = Llvm.build_store elem ptr_to_elem builder in + Llvm.set_alignment gl_align store; ()) argv; let alloca_as_i64 = Llvm.build_pointercast alloca i64_type "alloca_as_i64" builder in @@ -287,7 +305,8 @@ and gen_anf_expr fmap = function let init_val = gen_comp_expr_ir fmap comp_expr in let the_fun = Llvm.block_parent (Llvm.insertion_block builder) in let alloca = create_entry_alloca the_fun name in - let _ = Llvm.build_store init_val alloca builder in + let store = Llvm.build_store init_val alloca builder in + Llvm.set_alignment gl_align store; Hashtbl.add named_values name alloca; gen_anf_expr fmap body ;; @@ -321,7 +340,8 @@ let gen_function fmap name params body = (fun i ai -> let name = List.nth params i in let alloca = create_entry_alloca the_fun name in - let _ = Llvm.build_store ai alloca builder in + let store = Llvm.build_store ai alloca builder in + Llvm.set_alignment gl_align store; Hashtbl.replace named_values name alloca) (Llvm.params the_fun); (* Need to check for error here *) @@ -351,7 +371,9 @@ let gen_astructure_item fmap = function let value = gen_anf_expr fmap expr in let alloca = create_entry_alloca main_fn name in Hashtbl.add named_values name alloca; - Llvm.build_store value alloca builder + let store = Llvm.build_store value alloca builder in + Llvm.set_alignment gl_align store; + store ;; let optimize_ir (triple : string) (opt : string option) = From eaca60b24690a11bb38c55dccf51898da2acad98 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 14:16:19 +0300 Subject: [PATCH 26/84] fix: rv_call in rt and panic msgs --- XML/bin/runtime.c | 80 ++++++++++++++++++++++------------------------- 1 file changed, 38 insertions(+), 42 deletions(-) diff --git a/XML/bin/runtime.c b/XML/bin/runtime.c index b1ef6ee9..5451de2b 100644 --- a/XML/bin/runtime.c +++ b/XML/bin/runtime.c @@ -207,7 +207,10 @@ static void* gc_alloc_bytes(size_t n, GCType* vt) { if (alloc_ptr + n > from_end) { gc_collect(); - if (alloc_ptr + n > from_end) panic("GC: out of memory"); + char msg[100]; + sprintf(msg, "GC: out of memory: asked for %ld bytes, alloc_ptr is %p (end is %p)", n, + alloc_ptr, from_end); + if (alloc_ptr + n > from_end) panic(msg); } uint8_t* p = alloc_ptr; alloc_ptr += n; @@ -284,52 +287,43 @@ Closure* copy_closure(const Closure* src) { static value rv_call(void* fn, value* argv, int64_t n) { int64_t spill = (n > RV_GP_ARGS) ? (n - RV_GP_ARGS) : 0; size_t spill_bytes = (size_t)spill * WORD_SZ; - value* spill_ptr = (spill > 0) ? argv + RV_GP_ARGS : NULL; + size_t align_adj = (spill_bytes + 7) & ~7; value ret; - asm volatile( - "mv t0, %[sz]\n" - "sub sp, sp, t0\n" - - "beqz %[cnt], 2f\n" - "mv t1, sp\n" - "mv t2, %[spill]\n" - "mv t3, %[cnt]\n" - "li t4, 0\n" + __asm__ volatile( + "mv t6, %[fn]\n" + "sub sp, sp, %[adj]\n" + "mv t0, sp\n" + "addi t1, %[argv], 64\n" + "mv t2, %[spill]\n" + "li t3, 0\n" "1:\n" - "beq t4, t3, 2f\n" - "slli t5, t4, 3\n" - "add t6, t2, t5\n" - "ld t0, 0(t6)\n" - "sd t0, 0(t1)\n" + "beq t3, t2, 2f\n" + "ld t4, 0(t1)\n" + "sd t4, 0(t0)\n" "addi t1, t1, 8\n" - "addi t4, t4, 1\n" - "j 1b\n" + "addi t0, t0, 8\n" + "addi t3, t3, 1\n" + "j 1b\n" "2:\n" - "mv a0, %[a0]\n" - "mv a1, %[a1]\n" - "mv a2, %[a2]\n" - "mv a3, %[a3]\n" - "mv a4, %[a4]\n" - "mv a5, %[a5]\n" - "mv a6, %[a6]\n" - "mv a7, %[a7]\n" - - "mv t6, %[fn]\n" - "jalr ra, t6, 0\n" - - "mv t0, %[sz]\n" - "add sp, sp, t0\n" - - "mv %[ret], a0\n" - : [ret] "=r"(ret) - : [fn] "r"(fn), [a0] "r"((n > 0) ? argv[0] : 0), [a1] "r"((n > 1) ? argv[1] : 0), - [a2] "r"((n > 2) ? argv[2] : 0), [a3] "r"((n > 3) ? argv[3] : 0), - [a4] "r"((n > 4) ? argv[4] : 0), [a5] "r"((n > 5) ? argv[5] : 0), - [a6] "r"((n > 6) ? argv[6] : 0), [a7] "r"((n > 7) ? argv[7] : 0), [spill] "r"(spill_ptr), - [cnt] "r"(spill), [sz] "r"(spill_bytes) - : "t0", "t1", "t2", "t3", "t4", "t5", "t6", "a0", "a1", "a2", "a3", "a4", "a5", "a6", "a7", + "ld a0, 0(%[argv])\n" + "ld a1, 8(%[argv])\n" + "ld a2, 16(%[argv])\n" + "ld a3, 24(%[argv])\n" + "ld a4, 32(%[argv])\n" + "ld a5, 40(%[argv])\n" + "ld a6, 48(%[argv])\n" + "ld a7, 56(%[argv])\n" + + "jalr ra, t6\n" + + "add sp, sp, %[adj]\n" + + "mv %0, a0\n" + : "=r"(ret) + : [fn] "r"(fn), [argv] "r"(argv), [spill] "r"(spill), [adj] "r"(align_adj) + : "t0", "t1", "t2", "t3", "t4", "t6", "a0", "a1", "a2", "a3", "a4", "a5", "a6", "a7", "ra", "memory"); return ret; } @@ -354,7 +348,9 @@ value apply1(Closure* f, value arg) { return rv_call(f->code, argv, n); } - panic("apply1: too many arguments"); + char msg[100]; + sprintf(msg, "apply1: too many arguments, should be: %ld, arg is: %ld", n, arg); + panic(msg); __builtin_unreachable(); } From 04894550d5fc987392cc9361f3bbb15bdd3c9209 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 14:44:53 +0300 Subject: [PATCH 27/84] fix: many bugs in codegen_llvm, add gc_llvm tests, now all passes fixed: add rt_init and collect, calls to 0-arg funs, alloca dereference, offset in tuple elem loading, rt_init in rt, refactor code --- XML/lib/backend/codegen_llvm.ml | 78 +- XML/many_tests/codegen_llvm.t | 1931 +++---------------------------- XML/many_tests/dune | 2 +- XML/many_tests/gc.t | 2 +- XML/many_tests/gc_llvm.t | 153 +++ 5 files changed, 374 insertions(+), 1792 deletions(-) create mode 100644 XML/many_tests/gc_llvm.t diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 7f0d9200..c0cf67f8 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -4,10 +4,11 @@ open Middleend.Anf open Common.Ast +open Target let context = Llvm.global_context () let i64_type = Llvm.i64_type context -let gl_align = 8 +let gl_align = Target.word_size let void_type = Llvm.void_type context let gcheader_type = Llvm.struct_type context [| i64_type |] let block_elms_type = Llvm.array_type i64_type 0 @@ -89,6 +90,7 @@ let initial_fmap = decl fmap "create_tuple_init" i64_type (*ptr*) [| i64_type; i64_type (*ptr*) |] in let fmap = decl fmap "field" i64_type (*ptr or int*) [| i64_type (*ptr*); i64_type |] in + let fmap = decl fmap "rt_init" void_type [| i64_type |] in fmap ;; @@ -124,11 +126,20 @@ let prefill_fmap (fmap0 : FuncMap.t) (program : aprogram) : FuncMap.t = program ;; +(* for debug *) +let _print_untag fmap n = + let pival, pityp, _ = FuncMap.find_exn fmap "print_int" in + let _ = build_call_mb_void pityp pival [| n |] "_" in + () +;; + let build_alloc_closure fmap func = let acval, actyp, _ = FuncMap.find_exn fmap "alloc_closure" in let argc = Array.length (Llvm.params func) in let argc = Llvm.const_int i64_type argc in let func_as_i64 = Llvm.build_pointercast func i64_type "func_as_i64" builder in + (* _print_untag fmap func_as_i64; + _print_untag fmap argc; *) Llvm.build_call actyp acval [| func_as_i64; argc |] "closure_tmp" builder ;; @@ -142,9 +153,12 @@ let gen_im_expr_ir fmap = function temp | None -> (match FuncMap.find fmap id with - | Some (fval, _, _) -> - (* return a pointer to a closure *) - build_alloc_closure fmap fval + | Some (fval, ftyp, _) -> + if Array.length (Llvm.params fval) = 0 + then build_call_mb_void ftyp fval [||] "calltmp" + else + (* return a pointer to a closure *) + build_alloc_closure fmap fval | None -> invalid_arg ("Name not bound: " ^ id))) ;; @@ -201,6 +215,18 @@ let gen_tagged_binop fmap op lhs rhs = | _ -> invalid_arg ("Unsupported binary operator: " ^ op) ;; +let build_apply_part fmap fclos args = + let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in + List.fold_left + (fun clos arg -> + let clos_as_i64 = Llvm.build_pointercast clos i64_type "clos_as_i64" builder in + (* _print_untag fmap clos_as_i64; + _print_untag fmap arg; *) + build_call_mb_void aptyp apval [| clos_as_i64; arg |] "apptmp") + fclos + args +;; + let rec gen_comp_expr_ir fmap = function | Comp_imm imm -> gen_im_expr_ir fmap imm | Comp_binop (op, lhs, rhs) -> gen_tagged_binop fmap op lhs rhs @@ -209,37 +235,22 @@ let rec gen_comp_expr_ir fmap = function (match FuncMap.find fmap f with | Some (fval, ftype, _) -> let pvs = Llvm.params fval in - let argvs = Array.map (fun arg -> gen_im_expr_ir fmap arg) (Array.of_list args) in + let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in if List.length args = Array.length pvs then - build_call_mb_void ftype fval argvs "calltmp" - (* then Llvm.build_call ftype fval argvs "calltmp" builder *) + build_call_mb_void ftype fval (Array.of_list argvs) "calltmp" + (* build_apply fmap fval argvs *) else ( let fclos = build_alloc_closure fmap fval in - let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in - Array.fold_left - (fun clos arg -> - let clos_as_i64 = - Llvm.build_pointercast clos i64_type "clos_as_i64" builder - in - (* Llvm.build_call cttyp ctval [| argc; alloca_as_i64 |] "tuple_tmp" builder *) - build_call_mb_void aptyp apval [| clos_as_i64; arg |] "app_tmp") - fclos - argvs) + build_apply_part fmap fclos argvs) | _ -> (* maybe it's a closure in this scope *) (match Hashtbl.find_opt named_values f with - | Some v -> + | Some clos_ptr -> + let clos_val = Llvm.build_load default_type clos_ptr (f ^ "_val") builder in + Llvm.set_alignment gl_align clos_val; let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in - let apval, aptyp, _ = FuncMap.find_exn fmap "apply1" in - List.fold_left - (fun clos arg -> - let clos_as_i64 = - Llvm.build_pointercast clos i64_type "clos_as_i64" builder - in - build_call_mb_void aptyp apval [| clos_as_i64; arg |] "app_tmp") - v - argvs + build_apply_part fmap clos_val argvs | _ -> failwith ("Id: " ^ f ^ " not found"))) | Comp_app (Imm_num _, _) -> failwith "cannot apply number as a function" | Comp_branch (cond, br_then, br_else) -> @@ -294,7 +305,7 @@ let rec gen_comp_expr_ir fmap = function | Comp_load (imexpr, offset) -> (*addr of the tuple *) let vbase = gen_im_expr_ir fmap imexpr in - let voffst = Llvm.const_int i64_type offset in + let voffst = Llvm.const_int i64_type (offset / Target.word_size) in let fifn, fity, _ = FuncMap.find_exn fmap "field" in Llvm.build_call fity fifn [| vbase; voffst |] "load_tmp" builder | Comp_func (_, _) -> failwith "anonymous functions should be lambda-lifted" @@ -396,13 +407,20 @@ let gen_program_ir (program : aprogram) (triple : string) (opt : string option) Llvm_all_backends.initialize (); Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); - let main_ty = Llvm.function_type i64_type [||] in - let main_fn = Llvm.define_function "main" main_ty the_module in let fmap = prefill_fmap initial_fmap program in (* FuncMap.print_fmap fmap; *) + let main_ty = Llvm.function_type i64_type [||] in + let main_fn = Llvm.define_function "main" main_ty the_module in + Llvm.position_at_end (Llvm.entry_block main_fn) builder; + let initfn, initty, _ = FuncMap.find_exn fmap "rt_init" in + let _ = + build_call_mb_void initty initfn [| Llvm.const_int i64_type (5 * 1024) |] "inittmp" + in let _ = List.map (fun item -> gen_astructure_item fmap item) program in let bbs = Llvm.basic_blocks main_fn in Llvm.position_at_end bbs.(Array.length bbs - 1) builder; + let col_fn, col_ty, _ = FuncMap.find_exn fmap "collect" in + let _ = build_call_mb_void col_ty col_fn [||] "_" in let _ = Llvm.build_ret (Llvm.const_int i64_type 0) builder in optimize_ir triple opt; match Llvm_analysis.verify_module the_module with diff --git a/XML/many_tests/codegen_llvm.t b/XML/many_tests/codegen_llvm.t index 82be9ba2..332ca74e 100644 --- a/XML/many_tests/codegen_llvm.t +++ b/XML/many_tests/codegen_llvm.t @@ -1,3 +1,7 @@ + $ clang --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o + +====================== Factorial ====================== + $ dune exec ./../bin/XML_llvm.exe -- -o factorial.ll < let rec fac n = if n = 0 then 1 else n * fac (n - 1) > @@ -26,20 +30,7 @@ declare i64 @field(i64, i64) - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %calltmp = call i64 @fac(i64 4) - store i64 %calltmp, ptr %t_6, align 4 - %t_61 = load i64, ptr %t_6, align 4 - call void @print_int(i64 %t_61) - store i64 0, ptr %t_7, align 4 - %t_72 = load i64, ptr %t_7, align 4 - store i64 %t_72, ptr %main, align 4 - ret i64 0 - } + declare void @rt_init(i64) define i64 @fac(i64 %n) { entry: @@ -49,11 +40,12 @@ %t_1 = alloca i64, align 8 %t_0 = alloca i64, align 8 %n1 = alloca i64, align 8 - store i64 %n, ptr %n1, align 4 - %n2 = load i64, ptr %n1, align 4 - %eqtmp = icmp eq i64 %n2, 0 - store i1 %eqtmp, ptr %t_0, align 1 - %t_03 = load i64, ptr %t_0, align 4 + store i64 %n, ptr %n1, align 8 + %n2 = load i64, ptr %n1, align 8 + %eqtmp = icmp eq i64 %n2, 1 + %eqtmp_as_i64 = zext i1 %eqtmp to i64 + store i64 %eqtmp_as_i64, ptr %t_0, align 8 + %t_03 = load i64, ptr %t_0, align 8 %cond = icmp ne i64 %t_03, 0 br i1 %cond, label %then, label %else @@ -61,121 +53,66 @@ br label %ifcont else: ; preds = %entry - %n4 = load i64, ptr %n1, align 4 - %subtmp = sub i64 %n4, 1 - store i64 %subtmp, ptr %t_1, align 4 - %t_15 = load i64, ptr %t_1, align 4 + %n4 = load i64, ptr %n1, align 8 + %subtmp1 = sub i64 %n4, 3 + %subtmp2 = add i64 %subtmp1, 1 + store i64 %subtmp2, ptr %t_1, align 8 + %t_15 = load i64, ptr %t_1, align 8 %calltmp = call i64 @fac(i64 %t_15) - store i64 %calltmp, ptr %t_2, align 4 - %n6 = load i64, ptr %n1, align 4 - %t_27 = load i64, ptr %t_2, align 4 - %multmp = mul i64 %n6, %t_27 - store i64 %multmp, ptr %t_3, align 4 - %t_38 = load i64, ptr %t_3, align 4 + store i64 %calltmp, ptr %t_2, align 8 + %n6 = load i64, ptr %n1, align 8 + %t_27 = load i64, ptr %t_2, align 8 + %multmp1 = lshr i64 %n6, 1 + %multmp2 = sub i64 %t_27, 1 + %multmp3 = mul i64 %multmp1, %multmp2 + %multmp4 = add i64 %multmp3, 1 + store i64 %multmp4, ptr %t_3, align 8 + %t_38 = load i64, ptr %t_3, align 8 br label %ifcont ifcont: ; preds = %else, %then - %iftmp = phi i64 [ 1, %then ], [ %t_38, %else ] - store i64 %iftmp, ptr %t_4, align 4 - %t_49 = load i64, ptr %t_4, align 4 + %iftmp = phi i64 [ 3, %then ], [ %t_38, %else ] + store i64 %iftmp, ptr %t_4, align 8 + %t_49 = load i64, ptr %t_4, align 8 ret i64 %t_49 } - -====================== Fibonacci ====================== - $ ../bin/XML_llvm.exe -o fibonacci.s < let rec fib n = if n <= 1 then n else fib (n - 1) + fib (n - 2) - > - > let main = print_int (fib 6) - - $ cat fibonacci.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) define i64 @main() { entry: %main = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %calltmp = call i64 @fib(i64 6) - store i64 %calltmp, ptr %t_8, align 4 - %t_81 = load i64, ptr %t_8, align 4 - call void @print_int(i64 %t_81) - store i64 0, ptr %t_9, align 4 - %t_92 = load i64, ptr %t_9, align 4 - store i64 %t_92, ptr %main, align 4 - ret i64 0 - } - - define i64 @fib(i64 %n) { - entry: + %t_7 = alloca i64, align 8 %t_6 = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %n1 = alloca i64, align 8 - store i64 %n, ptr %n1, align 4 - %n2 = load i64, ptr %n1, align 4 - %sletmp = icmp sle i64 %n2, 1 - store i1 %sletmp, ptr %t_0, align 1 - %t_03 = load i64, ptr %t_0, align 4 - %cond = icmp ne i64 %t_03, 0 - br i1 %cond, label %then, label %else - - then: ; preds = %entry - %n4 = load i64, ptr %n1, align 4 - br label %ifcont - - else: ; preds = %entry - %n5 = load i64, ptr %n1, align 4 - %subtmp = sub i64 %n5, 1 - store i64 %subtmp, ptr %t_1, align 4 - %t_16 = load i64, ptr %t_1, align 4 - %calltmp = call i64 @fib(i64 %t_16) - store i64 %calltmp, ptr %t_2, align 4 - %n7 = load i64, ptr %n1, align 4 - %subtmp8 = sub i64 %n7, 2 - store i64 %subtmp8, ptr %t_3, align 4 - %t_39 = load i64, ptr %t_3, align 4 - %calltmp10 = call i64 @fib(i64 %t_39) - store i64 %calltmp10, ptr %t_4, align 4 - %t_211 = load i64, ptr %t_2, align 4 - %t_412 = load i64, ptr %t_4, align 4 - %addtmp = add i64 %t_211, %t_412 - store i64 %addtmp, ptr %t_5, align 4 - %t_513 = load i64, ptr %t_5, align 4 - br label %ifcont - - ifcont: ; preds = %else, %then - %iftmp = phi i64 [ %n4, %then ], [ %t_513, %else ] - store i64 %iftmp, ptr %t_6, align 4 - %t_614 = load i64, ptr %t_6, align 4 - ret i64 %t_614 + call void @rt_init(i64 5120) + %calltmp = call i64 @fac(i64 9) + store i64 %calltmp, ptr %t_6, align 8 + %t_61 = load i64, ptr %t_6, align 8 + call void @print_int(i64 %t_61) + store i64 0, ptr %t_7, align 8 + %t_72 = load i64, ptr %t_7, align 8 + store i64 %t_72, ptr %main, align 8 + call void @collect() + ret i64 0 } + $ llc factorial.ll -o factorial.s + $ clang --target=riscv64-linux-gnu factorial.s runtime.o -o factorial.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./factorial.exe + 24 + +====================== Fibonacci ====================== + $ dune exec -- ../bin/XML_llvm.exe -o fibonacci.ll < let rec fib n = if n <= 1 then n else fib (n - 1) + fib (n - 2) + > + > let main = print_int (fib 6) + + + $ llc fibonacci.ll -o fibonacci.s + $ clang --target=riscv64-linux-gnu -static fibonacci.s runtime.o -o fibonacci.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./fibonacci.exe + 8 + ====================== Ififif ====================== - $ ../bin/XML_llvm.exe -o ififif.s < let large x = if 0<>x then print_int 0 else print_int 1 > let main = > let x = if (if (if 0 = 1 @@ -184,751 +121,59 @@ > then 0 else 1 in > large x - $ cat ififif.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_13 = alloca i64, align 8 - %x = alloca i64, align 8 - %t_12 = alloca i64, align 8 - %t_11 = alloca i64, align 8 - %t_10 = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %t42 = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %t_5 = alloca i64, align 8 - store i1 false, ptr %t_5, align 1 - %t_51 = load i64, ptr %t_5, align 4 - %cond = icmp ne i64 %t_51, 0 - br i1 %cond, label %then, label %else - - then: ; preds = %entry - store i1 false, ptr %t_6, align 1 - %t_62 = load i64, ptr %t_6, align 4 - br label %ifcont - - else: ; preds = %entry - call void @print_int(i64 42) - store i64 0, ptr %t_7, align 4 - %t_73 = load i64, ptr %t_7, align 4 - store i64 %t_73, ptr %t42, align 4 - store i1 true, ptr %t_8, align 1 - %t_84 = load i64, ptr %t_8, align 4 - br label %ifcont - - ifcont: ; preds = %else, %then - %iftmp = phi i64 [ %t_62, %then ], [ %t_84, %else ] - store i64 %iftmp, ptr %t_9, align 4 - %t_95 = load i64, ptr %t_9, align 4 - %cond6 = icmp ne i64 %t_95, 0 - br i1 %cond6, label %then7, label %else8 - - then7: ; preds = %ifcont - br label %ifcont9 - - else8: ; preds = %ifcont - br label %ifcont9 - - ifcont9: ; preds = %else8, %then7 - %iftmp10 = phi i64 [ 0, %then7 ], [ 1, %else8 ] - store i64 %iftmp10, ptr %t_10, align 4 - %t_1011 = load i64, ptr %t_10, align 4 - %eqtmp = icmp eq i64 %t_1011, 1 - store i1 %eqtmp, ptr %t_11, align 1 - %t_1112 = load i64, ptr %t_11, align 4 - %cond13 = icmp ne i64 %t_1112, 0 - br i1 %cond13, label %then14, label %else15 - - then14: ; preds = %ifcont9 - br label %ifcont16 - - else15: ; preds = %ifcont9 - br label %ifcont16 - - ifcont16: ; preds = %else15, %then14 - %iftmp17 = phi i64 [ 0, %then14 ], [ 1, %else15 ] - store i64 %iftmp17, ptr %t_12, align 4 - %t_1218 = load i64, ptr %t_12, align 4 - store i64 %t_1218, ptr %x, align 4 - %x19 = load i64, ptr %x, align 4 - %calltmp = call i64 @large(i64 %x19) - store i64 %calltmp, ptr %t_13, align 4 - %t_1320 = load i64, ptr %t_13, align 4 - store i64 %t_1320, ptr %main, align 4 - ret i64 0 - } - - define i64 @large(i64 %x) { - entry: - %t_3 = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %x1 = alloca i64, align 8 - store i64 %x, ptr %x1, align 4 - %x2 = load i64, ptr %x1, align 4 - %neqtmp = icmp ne i64 0, %x2 - store i1 %neqtmp, ptr %t_0, align 1 - %t_03 = load i64, ptr %t_0, align 4 - %cond = icmp ne i64 %t_03, 0 - br i1 %cond, label %then, label %else - - then: ; preds = %entry - call void @print_int(i64 0) - store i64 0, ptr %t_1, align 4 - %t_14 = load i64, ptr %t_1, align 4 - br label %ifcont - - else: ; preds = %entry - call void @print_int(i64 1) - store i64 0, ptr %t_2, align 4 - %t_25 = load i64, ptr %t_2, align 4 - br label %ifcont - - ifcont: ; preds = %else, %then - %iftmp = phi i64 [ %t_14, %then ], [ %t_25, %else ] - store i64 %iftmp, ptr %t_3, align 4 - %t_36 = load i64, ptr %t_3, align 4 - ret i64 %t_36 - } + $ llc ififif.ll -o ififif.s + $ clang --target=riscv64-linux-gnu -static ififif.s runtime.o -o ififif.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./ififif.exe + 42 + 0 ====================== Simple Closure ====================== - $ ../bin/XML_llvm.exe -o closure.s < let simplesum x y = x + y + > > let partialapp_sum = simplesum 5 + > > let main = print_int (partialapp_sum 5) - $ cat closure.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %partialapp_sum = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @simplesum to i64), i64 2) - %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 5) - store i64 %app_tmp, ptr %t_2, align 4 - %t_21 = load i64, ptr %t_2, align 4 - store i64 %t_21, ptr %partialapp_sum, align 4 - %clos_as_i64 = ptrtoint ptr %partialapp_sum to i64 - %app_tmp2 = call i64 @apply1(i64 %clos_as_i64, i64 5) - store i64 %app_tmp2, ptr %t_3, align 4 - %t_33 = load i64, ptr %t_3, align 4 - call void @print_int(i64 %t_33) - store i64 0, ptr %t_4, align 4 - %t_44 = load i64, ptr %t_4, align 4 - store i64 %t_44, ptr %main, align 4 - ret i64 0 - } - - define i64 @simplesum(i64 %x, i64 %y) { - entry: - %t_0 = alloca i64, align 8 - %y2 = alloca i64, align 8 - %x1 = alloca i64, align 8 - store i64 %x, ptr %x1, align 4 - store i64 %y, ptr %y2, align 4 - %x3 = load i64, ptr %x1, align 4 - %y4 = load i64, ptr %y2, align 4 - %addtmp = add i64 %x3, %y4 - store i64 %addtmp, ptr %t_0, align 4 - %t_05 = load i64, ptr %t_0, align 4 - ret i64 %t_05 - } + + $ llc closure.ll -o closure.s + $ clang --target=riscv64-linux-gnu -static closure.s runtime.o -o closure.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./closure.exe + 10 + ====================== CPS Factorial ====================== - $ ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o 010faccps_ll.s + $ ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o 010faccps_ll.ll + + $ llc 010faccps_ll.ll -o 010faccps_ll.s + $ clang --target=riscv64-linux-gnu -static 010faccps_ll.s runtime.o -o 010faccps_ll.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./010faccps_ll.exe + 24 - $ cat 010faccps_ll.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_15 = alloca i64, align 8 - %t_14 = alloca i64, align 8 - %t_13 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) - %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 4) - store i64 %app_tmp, ptr %t_13, align 4 - %closure_tmp1 = call i64 @alloc_closure(i64 ptrtoint (ptr @id to i64), i64 1) - %clos_as_i64 = ptrtoint ptr %t_13 to i64 - %app_tmp2 = call i64 @apply1(i64 %clos_as_i64, i64 %closure_tmp1) - store i64 %app_tmp2, ptr %t_14, align 4 - %t_143 = load i64, ptr %t_14, align 4 - call void @print_int(i64 %t_143) - store i64 0, ptr %t_15, align 4 - store i64 0, ptr %main, align 4 - ret i64 0 - } - - define i64 @id(i64 %x) { - entry: - %x1 = alloca i64, align 8 - store i64 %x, ptr %x1, align 4 - %x2 = load i64, ptr %x1, align 4 - ret i64 %x2 - } - - define i64 @fresh_1(i64 %n, i64 %k, i64 %p) { - entry: - %t_2 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %p3 = alloca i64, align 8 - %k2 = alloca i64, align 8 - %n1 = alloca i64, align 8 - store i64 %n, ptr %n1, align 4 - store i64 %k, ptr %k2, align 4 - store i64 %p, ptr %p3, align 4 - %p4 = load i64, ptr %p3, align 4 - %n5 = load i64, ptr %n1, align 4 - %multmp = mul i64 %p4, %n5 - store i64 %multmp, ptr %t_1, align 4 - %t_16 = load i64, ptr %t_1, align 4 - %clos_as_i64 = ptrtoint ptr %k2 to i64 - %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 %t_16) - store i64 %app_tmp, ptr %t_2, align 4 - %t_27 = load i64, ptr %t_2, align 4 - ret i64 %t_27 - } - - define i64 @fac_cps(i64 %n, i64 %k) { - entry: - %t_11 = alloca i64, align 8 - %t_10 = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %k2 = alloca i64, align 8 - %n1 = alloca i64, align 8 - store i64 %n, ptr %n1, align 4 - store i64 %k, ptr %k2, align 4 - %n3 = load i64, ptr %n1, align 4 - %eqtmp = icmp eq i64 %n3, 1 - store i1 %eqtmp, ptr %t_4, align 1 - %t_44 = load i64, ptr %t_4, align 4 - %cond = icmp ne i64 %t_44, 0 - br i1 %cond, label %then, label %else - - then: ; preds = %entry - %clos_as_i64 = ptrtoint ptr %k2 to i64 - %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 1) - store i64 %app_tmp, ptr %t_5, align 4 - %t_55 = load i64, ptr %t_5, align 4 - br label %ifcont - - else: ; preds = %entry - %n6 = load i64, ptr %n1, align 4 - %subtmp = sub i64 %n6, 1 - store i64 %subtmp, ptr %t_6, align 4 - %t_67 = load i64, ptr %t_6, align 4 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) - %app_tmp8 = call i64 @apply1(i64 %closure_tmp, i64 %t_67) - store i64 %app_tmp8, ptr %t_7, align 4 - %n9 = load i64, ptr %n1, align 4 - %closure_tmp10 = call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_1 to i64), i64 3) - %app_tmp11 = call i64 @apply1(i64 %closure_tmp10, i64 %n9) - store i64 %app_tmp11, ptr %t_8, align 4 - %k12 = load i64, ptr %k2, align 4 - %clos_as_i6413 = ptrtoint ptr %t_8 to i64 - %app_tmp14 = call i64 @apply1(i64 %clos_as_i6413, i64 %k12) - store i64 %app_tmp14, ptr %t_9, align 4 - %t_915 = load i64, ptr %t_9, align 4 - %clos_as_i6416 = ptrtoint ptr %t_7 to i64 - %app_tmp17 = call i64 @apply1(i64 %clos_as_i6416, i64 %t_915) - store i64 %app_tmp17, ptr %t_10, align 4 - %t_1018 = load i64, ptr %t_10, align 4 - br label %ifcont - - ifcont: ; preds = %else, %then - %iftmp = phi i64 [ %t_55, %then ], [ %t_1018, %else ] - store i64 %iftmp, ptr %t_11, align 4 - %t_1119 = load i64, ptr %t_11, align 4 - ret i64 %t_1119 - } ====================== CPS Fibbo ====================== - $ ../bin/XML_llvm.exe -fromfile manytests/typed/010fibcps_ll.ml -o 010fibcps_ll.s + $ ../bin/XML_llvm.exe -fromfile manytests/typed/010fibcps_ll.ml -o 010fibcps_ll.ll - $ cat 010fibcps_ll.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %z = alloca i64, align 8 - %t_22 = alloca i64, align 8 - %t_21 = alloca i64, align 8 - %t_20 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fib to i64), i64 2) - %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 6) - store i64 %app_tmp, ptr %t_20, align 4 - %closure_tmp1 = call i64 @alloc_closure(i64 ptrtoint (ptr @id to i64), i64 1) - %clos_as_i64 = ptrtoint ptr %t_20 to i64 - %app_tmp2 = call i64 @apply1(i64 %clos_as_i64, i64 %closure_tmp1) - store i64 %app_tmp2, ptr %t_21, align 4 - %t_213 = load i64, ptr %t_21, align 4 - call void @print_int(i64 %t_213) - store i64 0, ptr %t_22, align 4 - %t_224 = load i64, ptr %t_22, align 4 - store i64 %t_224, ptr %z, align 4 - store i64 0, ptr %main, align 4 - ret i64 0 - } - - define i64 @id(i64 %x) { - entry: - %x1 = alloca i64, align 8 - store i64 %x, ptr %x1, align 4 - %x2 = load i64, ptr %x1, align 4 - ret i64 %x2 - } - - define i64 @fresh_2(i64 %p1, i64 %k, i64 %p2) { - entry: - %t_2 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %p23 = alloca i64, align 8 - %k2 = alloca i64, align 8 - %p11 = alloca i64, align 8 - store i64 %p1, ptr %p11, align 4 - store i64 %k, ptr %k2, align 4 - store i64 %p2, ptr %p23, align 4 - %p14 = load i64, ptr %p11, align 4 - %p25 = load i64, ptr %p23, align 4 - %addtmp = add i64 %p14, %p25 - store i64 %addtmp, ptr %t_1, align 4 - %t_16 = load i64, ptr %t_1, align 4 - %clos_as_i64 = ptrtoint ptr %k2 to i64 - %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 %t_16) - store i64 %app_tmp, ptr %t_2, align 4 - %t_27 = load i64, ptr %t_2, align 4 - ret i64 %t_27 - } - - define i64 @fresh_1(i64 %n, i64 %k, i64 %fib, i64 %p1) { - entry: - %t_8 = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %p14 = alloca i64, align 8 - %fib3 = alloca i64, align 8 - %k2 = alloca i64, align 8 - %n1 = alloca i64, align 8 - store i64 %n, ptr %n1, align 4 - store i64 %k, ptr %k2, align 4 - store i64 %fib, ptr %fib3, align 4 - store i64 %p1, ptr %p14, align 4 - %n5 = load i64, ptr %n1, align 4 - %subtmp = sub i64 %n5, 2 - store i64 %subtmp, ptr %t_4, align 4 - %t_46 = load i64, ptr %t_4, align 4 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fib to i64), i64 2) - %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 %t_46) - store i64 %app_tmp, ptr %t_5, align 4 - %p17 = load i64, ptr %p14, align 4 - %closure_tmp8 = call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_2 to i64), i64 3) - %app_tmp9 = call i64 @apply1(i64 %closure_tmp8, i64 %p17) - store i64 %app_tmp9, ptr %t_6, align 4 - %k10 = load i64, ptr %k2, align 4 - %clos_as_i64 = ptrtoint ptr %t_6 to i64 - %app_tmp11 = call i64 @apply1(i64 %clos_as_i64, i64 %k10) - store i64 %app_tmp11, ptr %t_7, align 4 - %t_712 = load i64, ptr %t_7, align 4 - %clos_as_i6413 = ptrtoint ptr %t_5 to i64 - %app_tmp14 = call i64 @apply1(i64 %clos_as_i6413, i64 %t_712) - store i64 %app_tmp14, ptr %t_8, align 4 - %t_815 = load i64, ptr %t_8, align 4 - ret i64 %t_815 - } - - define i64 @fib(i64 %n, i64 %k) { - entry: - %t_18 = alloca i64, align 8 - %t_17 = alloca i64, align 8 - %t_16 = alloca i64, align 8 - %t_15 = alloca i64, align 8 - %t_14 = alloca i64, align 8 - %t_13 = alloca i64, align 8 - %t_12 = alloca i64, align 8 - %t_11 = alloca i64, align 8 - %t_10 = alloca i64, align 8 - %k2 = alloca i64, align 8 - %n1 = alloca i64, align 8 - store i64 %n, ptr %n1, align 4 - store i64 %k, ptr %k2, align 4 - %n3 = load i64, ptr %n1, align 4 - %slttmp = icmp slt i64 %n3, 2 - store i1 %slttmp, ptr %t_10, align 1 - %t_104 = load i64, ptr %t_10, align 4 - %cond = icmp ne i64 %t_104, 0 - br i1 %cond, label %then, label %else - - then: ; preds = %entry - %n5 = load i64, ptr %n1, align 4 - %clos_as_i64 = ptrtoint ptr %k2 to i64 - %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 %n5) - store i64 %app_tmp, ptr %t_11, align 4 - %t_116 = load i64, ptr %t_11, align 4 - br label %ifcont - - else: ; preds = %entry - %n7 = load i64, ptr %n1, align 4 - %subtmp = sub i64 %n7, 1 - store i64 %subtmp, ptr %t_12, align 4 - %t_128 = load i64, ptr %t_12, align 4 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fib to i64), i64 2) - %app_tmp9 = call i64 @apply1(i64 %closure_tmp, i64 %t_128) - store i64 %app_tmp9, ptr %t_13, align 4 - %n10 = load i64, ptr %n1, align 4 - %closure_tmp11 = call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_1 to i64), i64 4) - %app_tmp12 = call i64 @apply1(i64 %closure_tmp11, i64 %n10) - store i64 %app_tmp12, ptr %t_14, align 4 - %k13 = load i64, ptr %k2, align 4 - %clos_as_i6414 = ptrtoint ptr %t_14 to i64 - %app_tmp15 = call i64 @apply1(i64 %clos_as_i6414, i64 %k13) - store i64 %app_tmp15, ptr %t_15, align 4 - %closure_tmp16 = call i64 @alloc_closure(i64 ptrtoint (ptr @fib to i64), i64 2) - %clos_as_i6417 = ptrtoint ptr %t_15 to i64 - %app_tmp18 = call i64 @apply1(i64 %clos_as_i6417, i64 %closure_tmp16) - store i64 %app_tmp18, ptr %t_16, align 4 - %t_1619 = load i64, ptr %t_16, align 4 - %clos_as_i6420 = ptrtoint ptr %t_13 to i64 - %app_tmp21 = call i64 @apply1(i64 %clos_as_i6420, i64 %t_1619) - store i64 %app_tmp21, ptr %t_17, align 4 - %t_1722 = load i64, ptr %t_17, align 4 - br label %ifcont - - ifcont: ; preds = %else, %then - %iftmp = phi i64 [ %t_116, %then ], [ %t_1722, %else ] - store i64 %iftmp, ptr %t_18, align 4 - %t_1823 = load i64, ptr %t_18, align 4 - ret i64 %t_1823 - } + $ llc 010fibcps_ll.ll -o 010fibcps_ll.s + $ clang --target=riscv64-linux-gnu -static 010fibcps_ll.s runtime.o -o 010fibcps_ll.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./010fibcps_ll.exe + 8 + + +====================== Other ====================== + + $ ../bin/XML_llvm.exe -fromfile ./manytests/typed/004manyargs.ml -o 004manyargs.ll + + $ llc 004manyargs.ll -o 004manyargs.s + $ clang --target=riscv64-linux-gnu -static 004manyargs.s runtime.o -o 004manyargs.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./004manyargs.exe + 1111111111 + 1 + 10 + 100 - $ ../bin/XML_llvm.exe -fromfile manytests/typed/004manyargs.ml -o 004manyargs.s - $ cat 004manyargs.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %temp2 = alloca i64, align 8 - %t_32 = alloca i64, align 8 - %t_31 = alloca i64, align 8 - %t_30 = alloca i64, align 8 - %t_29 = alloca i64, align 8 - %t_28 = alloca i64, align 8 - %rez = alloca i64, align 8 - %t_27 = alloca i64, align 8 - %t_26 = alloca i64, align 8 - %t_25 = alloca i64, align 8 - %t_24 = alloca i64, align 8 - %t_23 = alloca i64, align 8 - %t_22 = alloca i64, align 8 - %t_21 = alloca i64, align 8 - %t_20 = alloca i64, align 8 - %t_19 = alloca i64, align 8 - %t_18 = alloca i64, align 8 - %t_17 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @test10 to i64), i64 10) - %calltmp = call i64 @wrap(i64 %closure_tmp) - store i64 %calltmp, ptr %t_17, align 4 - %clos_as_i64 = ptrtoint ptr %t_17 to i64 - %app_tmp = call i64 @apply1(i64 %clos_as_i64, i64 1) - store i64 %app_tmp, ptr %t_18, align 4 - %clos_as_i641 = ptrtoint ptr %t_18 to i64 - %app_tmp2 = call i64 @apply1(i64 %clos_as_i641, i64 10) - store i64 %app_tmp2, ptr %t_19, align 4 - %clos_as_i643 = ptrtoint ptr %t_19 to i64 - %app_tmp4 = call i64 @apply1(i64 %clos_as_i643, i64 100) - store i64 %app_tmp4, ptr %t_20, align 4 - %clos_as_i645 = ptrtoint ptr %t_20 to i64 - %app_tmp6 = call i64 @apply1(i64 %clos_as_i645, i64 1000) - store i64 %app_tmp6, ptr %t_21, align 4 - %clos_as_i647 = ptrtoint ptr %t_21 to i64 - %app_tmp8 = call i64 @apply1(i64 %clos_as_i647, i64 10000) - store i64 %app_tmp8, ptr %t_22, align 4 - %clos_as_i649 = ptrtoint ptr %t_22 to i64 - %app_tmp10 = call i64 @apply1(i64 %clos_as_i649, i64 100000) - store i64 %app_tmp10, ptr %t_23, align 4 - %clos_as_i6411 = ptrtoint ptr %t_23 to i64 - %app_tmp12 = call i64 @apply1(i64 %clos_as_i6411, i64 1000000) - store i64 %app_tmp12, ptr %t_24, align 4 - %clos_as_i6413 = ptrtoint ptr %t_24 to i64 - %app_tmp14 = call i64 @apply1(i64 %clos_as_i6413, i64 10000000) - store i64 %app_tmp14, ptr %t_25, align 4 - %clos_as_i6415 = ptrtoint ptr %t_25 to i64 - %app_tmp16 = call i64 @apply1(i64 %clos_as_i6415, i64 100000000) - store i64 %app_tmp16, ptr %t_26, align 4 - %clos_as_i6417 = ptrtoint ptr %t_26 to i64 - %app_tmp18 = call i64 @apply1(i64 %clos_as_i6417, i64 1000000000) - store i64 %app_tmp18, ptr %t_27, align 4 - %t_2719 = load i64, ptr %t_27, align 4 - store i64 %t_2719, ptr %rez, align 4 - %rez20 = load i64, ptr %rez, align 4 - call void @print_int(i64 %rez20) - store i64 0, ptr %t_28, align 4 - %closure_tmp21 = call i64 @alloc_closure(i64 ptrtoint (ptr @test3 to i64), i64 3) - %calltmp22 = call i64 @wrap(i64 %closure_tmp21) - store i64 %calltmp22, ptr %t_29, align 4 - %clos_as_i6423 = ptrtoint ptr %t_29 to i64 - %app_tmp24 = call i64 @apply1(i64 %clos_as_i6423, i64 1) - store i64 %app_tmp24, ptr %t_30, align 4 - %clos_as_i6425 = ptrtoint ptr %t_30 to i64 - %app_tmp26 = call i64 @apply1(i64 %clos_as_i6425, i64 10) - store i64 %app_tmp26, ptr %t_31, align 4 - %clos_as_i6427 = ptrtoint ptr %t_31 to i64 - %app_tmp28 = call i64 @apply1(i64 %clos_as_i6427, i64 100) - store i64 %app_tmp28, ptr %t_32, align 4 - %t_3229 = load i64, ptr %t_32, align 4 - store i64 %t_3229, ptr %temp2, align 4 - store i64 0, ptr %main, align 4 - ret i64 0 - } - - define i64 @wrap(i64 %f) { - entry: - %t_1 = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %f1 = alloca i64, align 8 - store i64 %f, ptr %f1, align 4 - store i1 true, ptr %t_0, align 1 - %t_02 = load i64, ptr %t_0, align 4 - %cond = icmp ne i64 %t_02, 0 - br i1 %cond, label %then, label %else - - then: ; preds = %entry - %f3 = load i64, ptr %f1, align 4 - br label %ifcont - - else: ; preds = %entry - %f4 = load i64, ptr %f1, align 4 - br label %ifcont - - ifcont: ; preds = %else, %then - %iftmp = phi i64 [ %f3, %then ], [ %f4, %else ] - store i64 %iftmp, ptr %t_1, align 4 - %t_15 = load i64, ptr %t_1, align 4 - ret i64 %t_15 - } - - define i64 @test3(i64 %a, i64 %b, i64 %c) { - entry: - %c12 = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %b9 = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %a6 = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %c3 = alloca i64, align 8 - %b2 = alloca i64, align 8 - %a1 = alloca i64, align 8 - store i64 %a, ptr %a1, align 4 - store i64 %b, ptr %b2, align 4 - store i64 %c, ptr %c3, align 4 - %a4 = load i64, ptr %a1, align 4 - call void @print_int(i64 %a4) - store i64 0, ptr %t_3, align 4 - %t_35 = load i64, ptr %t_3, align 4 - store i64 %t_35, ptr %a6, align 4 - %b7 = load i64, ptr %b2, align 4 - call void @print_int(i64 %b7) - store i64 0, ptr %t_4, align 4 - %t_48 = load i64, ptr %t_4, align 4 - store i64 %t_48, ptr %b9, align 4 - %c10 = load i64, ptr %c3, align 4 - call void @print_int(i64 %c10) - store i64 0, ptr %t_5, align 4 - %t_511 = load i64, ptr %t_5, align 4 - store i64 %t_511, ptr %c12, align 4 - ret i64 0 - } - - define i64 @test10(i64 %a, i64 %b, i64 %c, i64 %d, i64 %e, i64 %f, i64 %g, i64 %h, i64 %i, i64 %j) { - entry: - %t_15 = alloca i64, align 8 - %t_14 = alloca i64, align 8 - %t_13 = alloca i64, align 8 - %t_12 = alloca i64, align 8 - %t_11 = alloca i64, align 8 - %t_10 = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %j10 = alloca i64, align 8 - %i9 = alloca i64, align 8 - %h8 = alloca i64, align 8 - %g7 = alloca i64, align 8 - %f6 = alloca i64, align 8 - %e5 = alloca i64, align 8 - %d4 = alloca i64, align 8 - %c3 = alloca i64, align 8 - %b2 = alloca i64, align 8 - %a1 = alloca i64, align 8 - store i64 %a, ptr %a1, align 4 - store i64 %b, ptr %b2, align 4 - store i64 %c, ptr %c3, align 4 - store i64 %d, ptr %d4, align 4 - store i64 %e, ptr %e5, align 4 - store i64 %f, ptr %f6, align 4 - store i64 %g, ptr %g7, align 4 - store i64 %h, ptr %h8, align 4 - store i64 %i, ptr %i9, align 4 - store i64 %j, ptr %j10, align 4 - %a11 = load i64, ptr %a1, align 4 - %b12 = load i64, ptr %b2, align 4 - %addtmp = add i64 %a11, %b12 - store i64 %addtmp, ptr %t_7, align 4 - %t_713 = load i64, ptr %t_7, align 4 - %c14 = load i64, ptr %c3, align 4 - %addtmp15 = add i64 %t_713, %c14 - store i64 %addtmp15, ptr %t_8, align 4 - %t_816 = load i64, ptr %t_8, align 4 - %d17 = load i64, ptr %d4, align 4 - %addtmp18 = add i64 %t_816, %d17 - store i64 %addtmp18, ptr %t_9, align 4 - %t_919 = load i64, ptr %t_9, align 4 - %e20 = load i64, ptr %e5, align 4 - %addtmp21 = add i64 %t_919, %e20 - store i64 %addtmp21, ptr %t_10, align 4 - %t_1022 = load i64, ptr %t_10, align 4 - %f23 = load i64, ptr %f6, align 4 - %addtmp24 = add i64 %t_1022, %f23 - store i64 %addtmp24, ptr %t_11, align 4 - %t_1125 = load i64, ptr %t_11, align 4 - %g26 = load i64, ptr %g7, align 4 - %addtmp27 = add i64 %t_1125, %g26 - store i64 %addtmp27, ptr %t_12, align 4 - %t_1228 = load i64, ptr %t_12, align 4 - %h29 = load i64, ptr %h8, align 4 - %addtmp30 = add i64 %t_1228, %h29 - store i64 %addtmp30, ptr %t_13, align 4 - %t_1331 = load i64, ptr %t_13, align 4 - %i32 = load i64, ptr %i9, align 4 - %addtmp33 = add i64 %t_1331, %i32 - store i64 %addtmp33, ptr %t_14, align 4 - %t_1434 = load i64, ptr %t_14, align 4 - %j35 = load i64, ptr %j10, align 4 - %addtmp36 = add i64 %t_1434, %j35 - store i64 %addtmp36, ptr %t_15, align 4 - %t_1537 = load i64, ptr %t_15, align 4 - ret i64 %t_1537 - } - $ ../bin/XML_llvm.exe -o tuple_return.s < let make_pair x y = (x, y) > > let main = @@ -936,96 +181,14 @@ > let (a, b) = p in > print_int (a + b) - $ cat tuple_return.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %b = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %a = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %p = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @make_pair to i64), i64 2) - %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 10) - store i64 %app_tmp, ptr %t_2, align 4 - %clos_as_i64 = ptrtoint ptr %t_2 to i64 - %app_tmp1 = call i64 @apply1(i64 %clos_as_i64, i64 20) - store i64 %app_tmp1, ptr %t_3, align 4 - %t_32 = load i64, ptr %t_3, align 4 - store i64 %t_32, ptr %p, align 4 - %p3 = load i64, ptr %p, align 4 - store i64 %p3, ptr %t_4, align 4 - %t_44 = load i64, ptr %t_4, align 4 - %load_tmp = call i64 @field(i64 %t_44, i64 0) - store i64 %load_tmp, ptr %t_8, align 4 - %t_85 = load i64, ptr %t_8, align 4 - store i64 %t_85, ptr %a, align 4 - %t_46 = load i64, ptr %t_4, align 4 - %load_tmp7 = call i64 @field(i64 %t_46, i64 8) - store i64 %load_tmp7, ptr %t_7, align 4 - %t_78 = load i64, ptr %t_7, align 4 - store i64 %t_78, ptr %b, align 4 - %a9 = load i64, ptr %a, align 4 - %b10 = load i64, ptr %b, align 4 - %addtmp = add i64 %a9, %b10 - store i64 %addtmp, ptr %t_5, align 4 - %t_511 = load i64, ptr %t_5, align 4 - call void @print_int(i64 %t_511) - store i64 0, ptr %t_6, align 4 - %t_612 = load i64, ptr %t_6, align 4 - store i64 %t_612, ptr %main, align 4 - ret i64 0 - } - - define i64 @make_pair(i64 %x, i64 %y) { - entry: - %t_0 = alloca i64, align 8 - %y2 = alloca i64, align 8 - %x1 = alloca i64, align 8 - store i64 %x, ptr %x1, align 4 - store i64 %y, ptr %y2, align 4 - %x3 = load i64, ptr %x1, align 4 - %y4 = load i64, ptr %y2, align 4 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 %x3, ptr %ptr_to_elem, align 4 - %ptr_to_elem5 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 %y4, ptr %ptr_to_elem5, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_0, align 4 - %t_06 = load i64, ptr %t_0, align 4 - ret i64 %t_06 - } + $ llc tuple_return.ll -o tuple_return.s + $ clang --target=riscv64-linux-gnu -static tuple_return.s runtime.o -o tuple_return.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_return.exe + 30 + + - $ ../bin/XML_llvm.exe -o tuple_swap.s < let swap p = > let (a, b) = p in > (b, a) @@ -1036,114 +199,13 @@ > let (x, y) = p2 in > print_int x - $ cat tuple_swap.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %y = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %x = alloca i64, align 8 - %t_10 = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %p2 = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %p1 = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 1, ptr %ptr_to_elem, align 4 - %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 2, ptr %ptr_to_elem1, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_5, align 4 - %t_52 = load i64, ptr %t_5, align 4 - store i64 %t_52, ptr %p1, align 4 - %p13 = load i64, ptr %p1, align 4 - %calltmp = call i64 @swap(i64 %p13) - store i64 %calltmp, ptr %t_6, align 4 - %t_64 = load i64, ptr %t_6, align 4 - store i64 %t_64, ptr %p2, align 4 - %p25 = load i64, ptr %p2, align 4 - store i64 %p25, ptr %t_7, align 4 - %t_76 = load i64, ptr %t_7, align 4 - %load_tmp = call i64 @field(i64 %t_76, i64 0) - store i64 %load_tmp, ptr %t_10, align 4 - %t_107 = load i64, ptr %t_10, align 4 - store i64 %t_107, ptr %x, align 4 - %t_78 = load i64, ptr %t_7, align 4 - %load_tmp9 = call i64 @field(i64 %t_78, i64 8) - store i64 %load_tmp9, ptr %t_9, align 4 - %t_910 = load i64, ptr %t_9, align 4 - store i64 %t_910, ptr %y, align 4 - %x11 = load i64, ptr %x, align 4 - call void @print_int(i64 %x11) - store i64 0, ptr %t_8, align 4 - %t_812 = load i64, ptr %t_8, align 4 - store i64 %t_812, ptr %main, align 4 - ret i64 0 - } - - define i64 @swap(i64 %p) { - entry: - %t_1 = alloca i64, align 8 - %b = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %a = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %p1 = alloca i64, align 8 - store i64 %p, ptr %p1, align 4 - %p2 = load i64, ptr %p1, align 4 - store i64 %p2, ptr %t_0, align 4 - %t_03 = load i64, ptr %t_0, align 4 - %load_tmp = call i64 @field(i64 %t_03, i64 0) - store i64 %load_tmp, ptr %t_3, align 4 - %t_34 = load i64, ptr %t_3, align 4 - store i64 %t_34, ptr %a, align 4 - %t_05 = load i64, ptr %t_0, align 4 - %load_tmp6 = call i64 @field(i64 %t_05, i64 8) - store i64 %load_tmp6, ptr %t_2, align 4 - %t_27 = load i64, ptr %t_2, align 4 - store i64 %t_27, ptr %b, align 4 - %b8 = load i64, ptr %b, align 4 - %a9 = load i64, ptr %a, align 4 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 %b8, ptr %ptr_to_elem, align 4 - %ptr_to_elem10 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 %a9, ptr %ptr_to_elem10, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_1, align 4 - %t_111 = load i64, ptr %t_1, align 4 - ret i64 %t_111 - } + $ llc tuple_swap.ll -o tuple_swap.s + $ clang --target=riscv64-linux-gnu -static tuple_swap.s runtime.o -o tuple_swap.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_swap.exe + 2 - $ ../bin/XML_llvm.exe -o tuple_order.s < let f n = > n > @@ -1152,92 +214,13 @@ > let (a, b) = t in > print_int (a + b) - $ cat tuple_order.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %b = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %a = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %t = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %calltmp = call i64 @f(i64 10) - store i64 %calltmp, ptr %t_1, align 4 - %calltmp1 = call i64 @f(i64 20) - store i64 %calltmp1, ptr %t_2, align 4 - %t_12 = load i64, ptr %t_1, align 4 - %t_23 = load i64, ptr %t_2, align 4 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 %t_12, ptr %ptr_to_elem, align 4 - %ptr_to_elem4 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 %t_23, ptr %ptr_to_elem4, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_3, align 4 - %t_35 = load i64, ptr %t_3, align 4 - store i64 %t_35, ptr %t, align 4 - %t6 = load i64, ptr %t, align 4 - store i64 %t6, ptr %t_4, align 4 - %t_47 = load i64, ptr %t_4, align 4 - %load_tmp = call i64 @field(i64 %t_47, i64 0) - store i64 %load_tmp, ptr %t_8, align 4 - %t_88 = load i64, ptr %t_8, align 4 - store i64 %t_88, ptr %a, align 4 - %t_49 = load i64, ptr %t_4, align 4 - %load_tmp10 = call i64 @field(i64 %t_49, i64 8) - store i64 %load_tmp10, ptr %t_7, align 4 - %t_711 = load i64, ptr %t_7, align 4 - store i64 %t_711, ptr %b, align 4 - %a12 = load i64, ptr %a, align 4 - %b13 = load i64, ptr %b, align 4 - %addtmp = add i64 %a12, %b13 - store i64 %addtmp, ptr %t_5, align 4 - %t_514 = load i64, ptr %t_5, align 4 - call void @print_int(i64 %t_514) - store i64 0, ptr %t_6, align 4 - %t_615 = load i64, ptr %t_6, align 4 - store i64 %t_615, ptr %main, align 4 - ret i64 0 - } - - define i64 @f(i64 %n) { - entry: - %n1 = alloca i64, align 8 - store i64 %n, ptr %n1, align 4 - %n2 = load i64, ptr %n1, align 4 - ret i64 %n2 - } + $ llc tuple_order.ll -o tuple_order.s + $ clang --target=riscv64-linux-gnu -static tuple_order.s runtime.o -o tuple_order.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_order.exe + 30 - $ ../bin/XML_llvm.exe -o tuple_linked_list.s < let rec sum_list lst = > if lst = 0 then 0 else > let (head, tail) = lst in @@ -1247,449 +230,52 @@ > let lst = (10, (20, (30, 0))) in > print_int (sum_list lst) - $ cat tuple_linked_list.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_12 = alloca i64, align 8 - %t_11 = alloca i64, align 8 - %lst = alloca i64, align 8 - %t_10 = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 30, ptr %ptr_to_elem, align 4 - %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 0, ptr %ptr_to_elem1, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_8, align 4 - %t_82 = load i64, ptr %t_8, align 4 - %tuple_vals_alloca3 = alloca i64, i64 2, align 8 - %ptr_to_elem4 = getelementptr i64, ptr %tuple_vals_alloca3, i64 0 - store i64 20, ptr %ptr_to_elem4, align 4 - %ptr_to_elem5 = getelementptr i64, ptr %tuple_vals_alloca3, i64 1 - store i64 %t_82, ptr %ptr_to_elem5, align 4 - %alloca_as_i646 = ptrtoint ptr %tuple_vals_alloca3 to i64 - %tuple_tmp7 = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i646) - store i64 %tuple_tmp7, ptr %t_9, align 4 - %t_98 = load i64, ptr %t_9, align 4 - %tuple_vals_alloca9 = alloca i64, i64 2, align 8 - %ptr_to_elem10 = getelementptr i64, ptr %tuple_vals_alloca9, i64 0 - store i64 10, ptr %ptr_to_elem10, align 4 - %ptr_to_elem11 = getelementptr i64, ptr %tuple_vals_alloca9, i64 1 - store i64 %t_98, ptr %ptr_to_elem11, align 4 - %alloca_as_i6412 = ptrtoint ptr %tuple_vals_alloca9 to i64 - %tuple_tmp13 = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i6412) - store i64 %tuple_tmp13, ptr %t_10, align 4 - %t_1014 = load i64, ptr %t_10, align 4 - store i64 %t_1014, ptr %lst, align 4 - %lst15 = load i64, ptr %lst, align 4 - %calltmp = call i64 @sum_list(i64 %lst15) - store i64 %calltmp, ptr %t_11, align 4 - %t_1116 = load i64, ptr %t_11, align 4 - call void @print_int(i64 %t_1116) - store i64 0, ptr %t_12, align 4 - %t_1217 = load i64, ptr %t_12, align 4 - store i64 %t_1217, ptr %main, align 4 - ret i64 0 - } - - define i64 @sum_list(i64 %lst) { - entry: - %t_6 = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %tail = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %head = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %lst1 = alloca i64, align 8 - store i64 %lst, ptr %lst1, align 4 - %lst2 = load i64, ptr %lst1, align 4 - %eqtmp = icmp eq i64 %lst2, 0 - store i1 %eqtmp, ptr %t_0, align 1 - %t_03 = load i64, ptr %t_0, align 4 - %cond = icmp ne i64 %t_03, 0 - br i1 %cond, label %then, label %else - - then: ; preds = %entry - br label %ifcont - - else: ; preds = %entry - %lst4 = load i64, ptr %lst1, align 4 - store i64 %lst4, ptr %t_1, align 4 - %t_15 = load i64, ptr %t_1, align 4 - %load_tmp = call i64 @field(i64 %t_15, i64 0) - store i64 %load_tmp, ptr %t_5, align 4 - %t_56 = load i64, ptr %t_5, align 4 - store i64 %t_56, ptr %head, align 4 - %t_17 = load i64, ptr %t_1, align 4 - %load_tmp8 = call i64 @field(i64 %t_17, i64 8) - store i64 %load_tmp8, ptr %t_4, align 4 - %t_49 = load i64, ptr %t_4, align 4 - store i64 %t_49, ptr %tail, align 4 - %tail10 = load i64, ptr %tail, align 4 - %calltmp = call i64 @sum_list(i64 %tail10) - store i64 %calltmp, ptr %t_2, align 4 - %head11 = load i64, ptr %head, align 4 - %t_212 = load i64, ptr %t_2, align 4 - %addtmp = add i64 %head11, %t_212 - store i64 %addtmp, ptr %t_3, align 4 - %t_313 = load i64, ptr %t_3, align 4 - br label %ifcont - - ifcont: ; preds = %else, %then - %iftmp = phi i64 [ 0, %then ], [ %t_313, %else ] - store i64 %iftmp, ptr %t_6, align 4 - %t_614 = load i64, ptr %t_6, align 4 - ret i64 %t_614 - } - $ ../bin/XML_llvm.exe -o tuple_large.s < let main = > let t = (1, 2, 3, 4, 5, 6, 7, 8, 9, 10) in > let (a, b, c, d, e, f, g, h, i, j) = t in > print_int j - $ cat tuple_large.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %j = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %i = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %h = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %g = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %f = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %e = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %d = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %c = alloca i64, align 8 - %t_10 = alloca i64, align 8 - %b = alloca i64, align 8 - %t_11 = alloca i64, align 8 - %a = alloca i64, align 8 - %t_12 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %t = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %tuple_vals_alloca = alloca i64, i64 10, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 1, ptr %ptr_to_elem, align 4 - %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 2, ptr %ptr_to_elem1, align 4 - %ptr_to_elem2 = getelementptr i64, ptr %tuple_vals_alloca, i64 2 - store i64 3, ptr %ptr_to_elem2, align 4 - %ptr_to_elem3 = getelementptr i64, ptr %tuple_vals_alloca, i64 3 - store i64 4, ptr %ptr_to_elem3, align 4 - %ptr_to_elem4 = getelementptr i64, ptr %tuple_vals_alloca, i64 4 - store i64 5, ptr %ptr_to_elem4, align 4 - %ptr_to_elem5 = getelementptr i64, ptr %tuple_vals_alloca, i64 5 - store i64 6, ptr %ptr_to_elem5, align 4 - %ptr_to_elem6 = getelementptr i64, ptr %tuple_vals_alloca, i64 6 - store i64 7, ptr %ptr_to_elem6, align 4 - %ptr_to_elem7 = getelementptr i64, ptr %tuple_vals_alloca, i64 7 - store i64 8, ptr %ptr_to_elem7, align 4 - %ptr_to_elem8 = getelementptr i64, ptr %tuple_vals_alloca, i64 8 - store i64 9, ptr %ptr_to_elem8, align 4 - %ptr_to_elem9 = getelementptr i64, ptr %tuple_vals_alloca, i64 9 - store i64 10, ptr %ptr_to_elem9, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 10, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_0, align 4 - %t_010 = load i64, ptr %t_0, align 4 - store i64 %t_010, ptr %t, align 4 - %t11 = load i64, ptr %t, align 4 - store i64 %t11, ptr %t_1, align 4 - %t_112 = load i64, ptr %t_1, align 4 - %load_tmp = call i64 @field(i64 %t_112, i64 0) - store i64 %load_tmp, ptr %t_12, align 4 - %t_1213 = load i64, ptr %t_12, align 4 - store i64 %t_1213, ptr %a, align 4 - %t_114 = load i64, ptr %t_1, align 4 - %load_tmp15 = call i64 @field(i64 %t_114, i64 8) - store i64 %load_tmp15, ptr %t_11, align 4 - %t_1116 = load i64, ptr %t_11, align 4 - store i64 %t_1116, ptr %b, align 4 - %t_117 = load i64, ptr %t_1, align 4 - %load_tmp18 = call i64 @field(i64 %t_117, i64 16) - store i64 %load_tmp18, ptr %t_10, align 4 - %t_1019 = load i64, ptr %t_10, align 4 - store i64 %t_1019, ptr %c, align 4 - %t_120 = load i64, ptr %t_1, align 4 - %load_tmp21 = call i64 @field(i64 %t_120, i64 24) - store i64 %load_tmp21, ptr %t_9, align 4 - %t_922 = load i64, ptr %t_9, align 4 - store i64 %t_922, ptr %d, align 4 - %t_123 = load i64, ptr %t_1, align 4 - %load_tmp24 = call i64 @field(i64 %t_123, i64 32) - store i64 %load_tmp24, ptr %t_8, align 4 - %t_825 = load i64, ptr %t_8, align 4 - store i64 %t_825, ptr %e, align 4 - %t_126 = load i64, ptr %t_1, align 4 - %load_tmp27 = call i64 @field(i64 %t_126, i64 40) - store i64 %load_tmp27, ptr %t_7, align 4 - %t_728 = load i64, ptr %t_7, align 4 - store i64 %t_728, ptr %f, align 4 - %t_129 = load i64, ptr %t_1, align 4 - %load_tmp30 = call i64 @field(i64 %t_129, i64 48) - store i64 %load_tmp30, ptr %t_6, align 4 - %t_631 = load i64, ptr %t_6, align 4 - store i64 %t_631, ptr %g, align 4 - %t_132 = load i64, ptr %t_1, align 4 - %load_tmp33 = call i64 @field(i64 %t_132, i64 56) - store i64 %load_tmp33, ptr %t_5, align 4 - %t_534 = load i64, ptr %t_5, align 4 - store i64 %t_534, ptr %h, align 4 - %t_135 = load i64, ptr %t_1, align 4 - %load_tmp36 = call i64 @field(i64 %t_135, i64 64) - store i64 %load_tmp36, ptr %t_4, align 4 - %t_437 = load i64, ptr %t_4, align 4 - store i64 %t_437, ptr %i, align 4 - %t_138 = load i64, ptr %t_1, align 4 - %load_tmp39 = call i64 @field(i64 %t_138, i64 72) - store i64 %load_tmp39, ptr %t_3, align 4 - %t_340 = load i64, ptr %t_3, align 4 - store i64 %t_340, ptr %j, align 4 - %j41 = load i64, ptr %j, align 4 - call void @print_int(i64 %j41) - store i64 0, ptr %t_2, align 4 - %t_242 = load i64, ptr %t_2, align 4 - store i64 %t_242, ptr %main, align 4 - ret i64 0 - } + $ llc tuple_large.ll -o tuple_large.s + $ clang --target=riscv64-linux-gnu -static tuple_large.s runtime.o -o tuple_large.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_large.exe + 10 + - $ ../bin/XML_llvm.exe -o tuple_basic.s < let main = > let t = (10, 20) in > let (a, b) = t in > print_int (a + b) - $ cat tuple_basic.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %b = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %a = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %t = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 10, ptr %ptr_to_elem, align 4 - %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 20, ptr %ptr_to_elem1, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_0, align 4 - %t_02 = load i64, ptr %t_0, align 4 - store i64 %t_02, ptr %t, align 4 - %t3 = load i64, ptr %t, align 4 - store i64 %t3, ptr %t_1, align 4 - %t_14 = load i64, ptr %t_1, align 4 - %load_tmp = call i64 @field(i64 %t_14, i64 0) - store i64 %load_tmp, ptr %t_5, align 4 - %t_55 = load i64, ptr %t_5, align 4 - store i64 %t_55, ptr %a, align 4 - %t_16 = load i64, ptr %t_1, align 4 - %load_tmp7 = call i64 @field(i64 %t_16, i64 8) - store i64 %load_tmp7, ptr %t_4, align 4 - %t_48 = load i64, ptr %t_4, align 4 - store i64 %t_48, ptr %b, align 4 - %a9 = load i64, ptr %a, align 4 - %b10 = load i64, ptr %b, align 4 - %addtmp = add i64 %a9, %b10 - store i64 %addtmp, ptr %t_2, align 4 - %t_211 = load i64, ptr %t_2, align 4 - call void @print_int(i64 %t_211) - store i64 0, ptr %t_3, align 4 - %t_312 = load i64, ptr %t_3, align 4 - store i64 %t_312, ptr %main, align 4 - ret i64 0 - } + $ llc tuple_basic.ll -o tuple_basic.s + $ clang --target=riscv64-linux-gnu -static tuple_basic.s runtime.o -o tuple_basic.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_basic.exe + 30 + - $ ../bin/XML_llvm.exe -o tuple_nested.s < let main = > let complex = (100, (20, 3)) in > let (a, (b, c)) = complex in > print_int (a + b + c) - $ cat tuple_nested.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %c = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %b = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %a = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %complex = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 20, ptr %ptr_to_elem, align 4 - %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 3, ptr %ptr_to_elem1, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_0, align 4 - %t_02 = load i64, ptr %t_0, align 4 - %tuple_vals_alloca3 = alloca i64, i64 2, align 8 - %ptr_to_elem4 = getelementptr i64, ptr %tuple_vals_alloca3, i64 0 - store i64 100, ptr %ptr_to_elem4, align 4 - %ptr_to_elem5 = getelementptr i64, ptr %tuple_vals_alloca3, i64 1 - store i64 %t_02, ptr %ptr_to_elem5, align 4 - %alloca_as_i646 = ptrtoint ptr %tuple_vals_alloca3 to i64 - %tuple_tmp7 = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i646) - store i64 %tuple_tmp7, ptr %t_1, align 4 - %t_18 = load i64, ptr %t_1, align 4 - store i64 %t_18, ptr %complex, align 4 - %complex9 = load i64, ptr %complex, align 4 - store i64 %complex9, ptr %t_2, align 4 - %t_210 = load i64, ptr %t_2, align 4 - %load_tmp = call i64 @field(i64 %t_210, i64 0) - store i64 %load_tmp, ptr %t_9, align 4 - %t_911 = load i64, ptr %t_9, align 4 - store i64 %t_911, ptr %a, align 4 - %t_212 = load i64, ptr %t_2, align 4 - %load_tmp13 = call i64 @field(i64 %t_212, i64 8) - store i64 %load_tmp13, ptr %t_6, align 4 - %t_614 = load i64, ptr %t_6, align 4 - %load_tmp15 = call i64 @field(i64 %t_614, i64 0) - store i64 %load_tmp15, ptr %t_8, align 4 - %t_816 = load i64, ptr %t_8, align 4 - store i64 %t_816, ptr %b, align 4 - %t_617 = load i64, ptr %t_6, align 4 - %load_tmp18 = call i64 @field(i64 %t_617, i64 8) - store i64 %load_tmp18, ptr %t_7, align 4 - %t_719 = load i64, ptr %t_7, align 4 - store i64 %t_719, ptr %c, align 4 - %a20 = load i64, ptr %a, align 4 - %b21 = load i64, ptr %b, align 4 - %addtmp = add i64 %a20, %b21 - store i64 %addtmp, ptr %t_3, align 4 - %t_322 = load i64, ptr %t_3, align 4 - %c23 = load i64, ptr %c, align 4 - %addtmp24 = add i64 %t_322, %c23 - store i64 %addtmp24, ptr %t_4, align 4 - %t_425 = load i64, ptr %t_4, align 4 - call void @print_int(i64 %t_425) - store i64 0, ptr %t_5, align 4 - %t_526 = load i64, ptr %t_5, align 4 - store i64 %t_526, ptr %main, align 4 - ret i64 0 - } - $ ../bin/XML_llvm.exe -o tuple_arg.s < let sum_pair p = > let (x, y) = p in > x + y @@ -1698,88 +284,13 @@ > let p = (40, 2) in > print_int (sum_pair p) - $ cat tuple_arg.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %t_6 = alloca i64, align 8 - %p = alloca i64, align 8 - %t_5 = alloca i64, align 8 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 40, ptr %ptr_to_elem, align 4 - %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 2, ptr %ptr_to_elem1, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_5, align 4 - %t_52 = load i64, ptr %t_5, align 4 - store i64 %t_52, ptr %p, align 4 - %p3 = load i64, ptr %p, align 4 - %calltmp = call i64 @sum_pair(i64 %p3) - store i64 %calltmp, ptr %t_6, align 4 - %t_64 = load i64, ptr %t_6, align 4 - call void @print_int(i64 %t_64) - store i64 0, ptr %t_7, align 4 - %t_75 = load i64, ptr %t_7, align 4 - store i64 %t_75, ptr %main, align 4 - ret i64 0 - } - - define i64 @sum_pair(i64 %p) { - entry: - %t_1 = alloca i64, align 8 - %y = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %x = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %p1 = alloca i64, align 8 - store i64 %p, ptr %p1, align 4 - %p2 = load i64, ptr %p1, align 4 - store i64 %p2, ptr %t_0, align 4 - %t_03 = load i64, ptr %t_0, align 4 - %load_tmp = call i64 @field(i64 %t_03, i64 0) - store i64 %load_tmp, ptr %t_3, align 4 - %t_34 = load i64, ptr %t_3, align 4 - store i64 %t_34, ptr %x, align 4 - %t_05 = load i64, ptr %t_0, align 4 - %load_tmp6 = call i64 @field(i64 %t_05, i64 8) - store i64 %load_tmp6, ptr %t_2, align 4 - %t_27 = load i64, ptr %t_2, align 4 - store i64 %t_27, ptr %y, align 4 - %x8 = load i64, ptr %x, align 4 - %y9 = load i64, ptr %y, align 4 - %addtmp = add i64 %x8, %y9 - store i64 %addtmp, ptr %t_1, align 4 - %t_110 = load i64, ptr %t_1, align 4 - ret i64 %t_110 - } - $ ../bin/XML_llvm.exe -o tuple_gc_stress.s < let rec make_list n acc = > if n = 0 then acc else > make_list (n - 1) (n, acc) @@ -1790,126 +301,26 @@ > let (head, tail) = result in > let _ = print_gc_status in > print_int head - $ cat tuple_gc_stress.s - ; ModuleID = 'main' - source_filename = "main" - target triple = "riscv64-unknown-linux-gnu" - - declare void @print_int(i64) - - declare i64 @alloc_block(i64) - - declare i64 @alloc_closure(i64, i64) - - declare i64 @apply1(i64, i64) - - declare void @print_gc_status() - - declare void @collect() - - declare i64 @create_tuple(i64) - - declare i64 @create_tuple_init(i64, i64) - - declare i64 @field(i64, i64) - - define i64 @main() { - entry: - %main = alloca i64, align 8 - %t_12 = alloca i64, align 8 - %t_11 = alloca i64, align 8 - %tail = alloca i64, align 8 - %t_13 = alloca i64, align 8 - %head = alloca i64, align 8 - %t_14 = alloca i64, align 8 - %t_10 = alloca i64, align 8 - %result = alloca i64, align 8 - %t_9 = alloca i64, align 8 - %t_8 = alloca i64, align 8 - %t_7 = alloca i64, align 8 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @print_gc_status to i64), i64 0) - store i64 %closure_tmp, ptr %t_7, align 4 - %closure_tmp1 = call i64 @alloc_closure(i64 ptrtoint (ptr @make_list to i64), i64 2) - %app_tmp = call i64 @apply1(i64 %closure_tmp1, i64 10000) - store i64 %app_tmp, ptr %t_8, align 4 - %clos_as_i64 = ptrtoint ptr %t_8 to i64 - %app_tmp2 = call i64 @apply1(i64 %clos_as_i64, i64 0) - store i64 %app_tmp2, ptr %t_9, align 4 - %t_93 = load i64, ptr %t_9, align 4 - store i64 %t_93, ptr %result, align 4 - %result4 = load i64, ptr %result, align 4 - store i64 %result4, ptr %t_10, align 4 - %t_105 = load i64, ptr %t_10, align 4 - %load_tmp = call i64 @field(i64 %t_105, i64 0) - store i64 %load_tmp, ptr %t_14, align 4 - %t_146 = load i64, ptr %t_14, align 4 - store i64 %t_146, ptr %head, align 4 - %t_107 = load i64, ptr %t_10, align 4 - %load_tmp8 = call i64 @field(i64 %t_107, i64 8) - store i64 %load_tmp8, ptr %t_13, align 4 - %t_139 = load i64, ptr %t_13, align 4 - store i64 %t_139, ptr %tail, align 4 - %closure_tmp10 = call i64 @alloc_closure(i64 ptrtoint (ptr @print_gc_status to i64), i64 0) - store i64 %closure_tmp10, ptr %t_11, align 4 - %head11 = load i64, ptr %head, align 4 - call void @print_int(i64 %head11) - store i64 0, ptr %t_12, align 4 - %t_1212 = load i64, ptr %t_12, align 4 - store i64 %t_1212, ptr %main, align 4 - ret i64 0 - } - - define i64 @make_list(i64 %n, i64 %acc) { - entry: - %t_5 = alloca i64, align 8 - %t_4 = alloca i64, align 8 - %t_3 = alloca i64, align 8 - %t_2 = alloca i64, align 8 - %t_1 = alloca i64, align 8 - %t_0 = alloca i64, align 8 - %acc2 = alloca i64, align 8 - %n1 = alloca i64, align 8 - store i64 %n, ptr %n1, align 4 - store i64 %acc, ptr %acc2, align 4 - %n3 = load i64, ptr %n1, align 4 - %eqtmp = icmp eq i64 %n3, 0 - store i1 %eqtmp, ptr %t_0, align 1 - %t_04 = load i64, ptr %t_0, align 4 - %cond = icmp ne i64 %t_04, 0 - br i1 %cond, label %then, label %else - - then: ; preds = %entry - %acc5 = load i64, ptr %acc2, align 4 - br label %ifcont - - else: ; preds = %entry - %n6 = load i64, ptr %n1, align 4 - %subtmp = sub i64 %n6, 1 - store i64 %subtmp, ptr %t_1, align 4 - %t_17 = load i64, ptr %t_1, align 4 - %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @make_list to i64), i64 2) - %app_tmp = call i64 @apply1(i64 %closure_tmp, i64 %t_17) - store i64 %app_tmp, ptr %t_2, align 4 - %n8 = load i64, ptr %n1, align 4 - %acc9 = load i64, ptr %acc2, align 4 - %tuple_vals_alloca = alloca i64, i64 2, align 8 - %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 - store i64 %n8, ptr %ptr_to_elem, align 4 - %ptr_to_elem10 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 - store i64 %acc9, ptr %ptr_to_elem10, align 4 - %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 - %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) - store i64 %tuple_tmp, ptr %t_3, align 4 - %t_311 = load i64, ptr %t_3, align 4 - %clos_as_i64 = ptrtoint ptr %t_2 to i64 - %app_tmp12 = call i64 @apply1(i64 %clos_as_i64, i64 %t_311) - store i64 %app_tmp12, ptr %t_4, align 4 - %t_413 = load i64, ptr %t_4, align 4 - br label %ifcont - - ifcont: ; preds = %else, %then - %iftmp = phi i64 [ %acc5, %then ], [ %t_413, %else ] - store i64 %iftmp, ptr %t_5, align 4 - %t_514 = load i64, ptr %t_5, align 4 - ret i64 %t_514 - } + + $ llc tuple_gc_stress.ll -o tuple_gc_stress.s + $ clang --target=riscv64-linux-gnu -static tuple_gc_stress.s runtime.o -o tuple_gc_stress.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_gc_stress.exe + === GC Status === + Current allocated: 0 + Free space: 524288 + Heap size: 524288 + Current bank: 0 + Total allocated: 0 + GC collections: 0 + GC allocations: 0 + ================= + === GC Status === + Current allocated: 231552 + Free space: 292736 + Heap size: 524288 + Current bank: 0 + Total allocated: 1280096 + GC collections: 2 + GC allocations: 30002 + ================= + 1 diff --git a/XML/many_tests/dune b/XML/many_tests/dune index 74fd9652..5d913e15 100644 --- a/XML/many_tests/dune +++ b/XML/many_tests/dune @@ -15,7 +15,7 @@ (inline_tests)) (cram - (applies_to codegen codegen_llvm anf cc ll gc) + (applies_to codegen codegen_llvm anf cc ll gc gc_llvm) (deps ../bin/XML.exe ../bin/XML_llvm.exe diff --git a/XML/many_tests/gc.t b/XML/many_tests/gc.t index 467ff890..7a1655d7 100644 --- a/XML/many_tests/gc.t +++ b/XML/many_tests/gc.t @@ -105,7 +105,7 @@ $ riscv64-linux-gnu-gcc -c ../bin/runtime.c -o runtime.o $ riscv64-linux-gnu-gcc temp.o runtime.o -o prog.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu -cpu rv64 ./prog.exe || true - GC: out of memory + GC: out of memory: asked for 160000024 bytes, alloc_ptr is 0x2aaaab4e8010 (end is 0x2aaaab568010) Aborted (core dumped) diff --git a/XML/many_tests/gc_llvm.t b/XML/many_tests/gc_llvm.t new file mode 100644 index 00000000..baf0a693 --- /dev/null +++ b/XML/many_tests/gc_llvm.t @@ -0,0 +1,153 @@ + $ clang --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o + + $ dune exec ./../bin/XML_llvm.exe -- -o gc_smoke.ll < let main = + > let _ = print_gc_status in + > let _ = collect in + > print_gc_status + + $ llc gc_smoke.ll -o gc_smoke.s + $ clang --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o + $ clang --target=riscv64-linux-gnu -static gc_smoke.s runtime.o -o gc_smoke.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./gc_smoke.exe + === GC Status === + Current allocated: 0 + Free space: 524288 + Heap size: 524288 + Current bank: 0 + Total allocated: 0 + GC collections: 0 + GC allocations: 0 + ================= + === GC Status === + Current allocated: 0 + Free space: 524288 + Heap size: 524288 + Current bank: 1 + Total allocated: 0 + GC collections: 1 + GC allocations: 0 + ================= + + + + $ dune exec ./../bin/XML_llvm.exe -- -o lots_of_garbage.ll < let rec make_garbage n = + > if n = 0 then 0 else + > let _ = alloc_block 1 in + > make_garbage (n - 1) + > let main = + > let _ = print_gc_status in + > let f = (fun x -> x) in + > let _ = make_garbage 2000 in + > let _ = print_gc_status in + > let _ = collect in + > let _ = print_gc_status in + > print_int (f 8) + + $ llc lots_of_garbage.ll -o lots_of_garbage.s + $ clang --target=riscv64-linux-gnu -static lots_of_garbage.s runtime.o -o lots_of_garbage.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./lots_of_garbage.exe + === GC Status === + Current allocated: 0 + Free space: 524288 + Heap size: 524288 + Current bank: 0 + Total allocated: 0 + GC collections: 0 + GC allocations: 0 + ================= + === GC Status === + Current allocated: 80000 + Free space: 444288 + Heap size: 524288 + Current bank: 0 + Total allocated: 80000 + GC collections: 0 + GC allocations: 2000 + ================= + === GC Status === + Current allocated: 0 + Free space: 524288 + Heap size: 524288 + Current bank: 1 + Total allocated: 80000 + GC collections: 1 + GC allocations: 2000 + ================= + 8 + + + + $ dune exec ./../bin/XML_llvm.exe -- -o keep_block_across_gc.ll < let rec spam n = + > if n = 0 then 0 else + > let _ = (fun z -> z) in + > spam (n - 1) + > + > let make n = + > let b = alloc_block n in + > (fun x -> let _u = b in x) + > + > let main = + > let f = make 10 in + > let _ = spam 4000 in + > let _ = collect in + > print_int (f 7) + + $ llc keep_block_across_gc.ll -o keep_block_across_gc.s + $ clang --target=riscv64-linux-gnu -static keep_block_across_gc.s runtime.o -o keep_block_across_gc.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./keep_block_across_gc.exe + 7 + + + + $ dune exec ./../bin/XML_llvm.exe -- -o gc_oom_block.ll < let main = + > let _ = alloc_block 10000000 in + > print_int 0 + + $ llc gc_oom_block.ll -o gc_oom_block.s + $ clang --target=riscv64-linux-gnu -static gc_oom_block.s runtime.o -o gc_oom_block.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./gc_oom_block.exe + GC: out of memory: asked for 160000024 bytes, alloc_ptr is 0x2aaaab32d010 (end is 0x2aaaab3ad010) + Aborted (core dumped) + [134] + + + + + $ ../bin/XML_llvm.exe -o temp.ll < let rec make_list n acc = + > if n = 0 then acc else + > make_list (n - 1) (n, acc) + > + > let main = + > let _ = print_gc_status in + > let result = make_list 10000 0 in + > let (head, tail) = result in + > let _ = print_gc_status in + > print_int head + + $ llc temp.ll -o temp.s + $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe + === GC Status === + Current allocated: 0 + Free space: 524288 + Heap size: 524288 + Current bank: 0 + Total allocated: 0 + GC collections: 0 + GC allocations: 0 + ================= + === GC Status === + Current allocated: 231552 + Free space: 292736 + Heap size: 524288 + Current bank: 0 + Total allocated: 1280096 + GC collections: 2 + GC allocations: 30002 + ================= + 1 From 42842b50509a4e6feb1415bfcbe1ed0feef3d7d9 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 15:07:41 +0300 Subject: [PATCH 28/84] fix: remove unneeded module --- XML/lib/backend/LL.ml | 94 ------------------------------------------- 1 file changed, 94 deletions(-) delete mode 100644 XML/lib/backend/LL.ml diff --git a/XML/lib/backend/LL.ml b/XML/lib/backend/LL.ml deleted file mode 100644 index 53331175..00000000 --- a/XML/lib/backend/LL.ml +++ /dev/null @@ -1,94 +0,0 @@ -[@@@ocaml.text "/*"] - -(** Copyright 2023-2024, Kakadu and contributors *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -[@@@ocaml.text "/*"] - -open Llvm -open Printf - -module type S = sig - val context : Llvm.llcontext - val module_ : Llvm.llmodule - val builder : Llvm.llbuilder - val build_store : Llvm.llvalue -> Llvm.llvalue -> Llvm.llvalue - val build_call : lltype -> ?name:string -> llvalue -> llvalue list -> llvalue - val lookup_func_exn : string -> llvalue - val has_toplevel_func : string -> bool - val build_add : ?name:string -> llvalue -> llvalue -> llvalue - val build_sub : ?name:string -> llvalue -> llvalue -> llvalue - val build_mul : ?name:string -> llvalue -> llvalue -> llvalue - val build_sdiv : ?name:string -> llvalue -> llvalue -> llvalue [@@inline] - val build_icmp : ?name:string -> Icmp.t -> llvalue -> llvalue -> llvalue - - (** [set_metadata v kind fmt] sets metadata to value [v] of kind [k]. - Returns this value [v]. Useful for attaching debugging *) - val set_metadata - : llvalue - -> string - -> ('a, Format.formatter, unit, llvalue) format4 - -> 'a - - (* ?? *) - - val build_ptrtoint : ?name:string -> llvalue -> lltype -> llvalue - val build_inttoptr : ?name:string -> llvalue -> lltype -> llvalue - val build_pointercast : ?name:string -> llvalue -> lltype -> llvalue - - (** Just aliases *) - - val const_int : Llvm.lltype -> int -> Llvm.llvalue - val params : Llvm.llvalue -> Llvm.llvalue array - val pp_value : Format.formatter -> llvalue -> unit -end - -let make context builder module_ = - let module L : S = struct - let context = context - let builder = builder - let module_ = module_ - let build_store a b = Llvm.build_store a b builder - - let build_call typ ?(name = "") f args = - build_call typ f (Array.of_list args) name builder - ;; - - let has_toplevel_func fname = - match lookup_function fname module_ with - | Some _ -> true - | None -> false - ;; - - let lookup_func_exn fname = - match lookup_function fname module_ with - | Some f -> f - | None -> failwith (sprintf "Function '%s' not found" fname) - ;; - - let build_add ?(name = "") l r = build_add l r name builder - let build_sub ?(name = "") l r = build_sub l r name builder - let build_mul ?(name = "") l r = build_mul l r name builder - let build_sdiv ?(name = "") l r = build_sdiv l r name builder - let build_icmp ?(name = "") op l r = build_icmp op l r name builder - let build_ptrtoint ?(name = "") e typ = Llvm.build_ptrtoint e typ name builder - let build_inttoptr ?(name = "") e typ = Llvm.build_inttoptr e typ name builder - let build_pointercast ?(name = "") f typ = Llvm.build_pointercast f typ name builder - - let set_metadata v kind fmt = - Format.kasprintf - (fun s -> - Llvm.set_metadata v (Llvm.mdkind_id context kind) (Llvm.mdstring context s); - v) - fmt - ;; - - (* Aliases *) - let const_int = Llvm.const_int - let params = Llvm.params - let pp_value ppf x = Format.fprintf ppf "%s" (Llvm.string_of_llvalue x) - end - in - (module L : S) -;; From 3f8b5e98fe4911d4a66ab44983f54d180913360f Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 15:26:58 +0300 Subject: [PATCH 29/84] feat: added cram test showing llvm codegen options --- XML/lib/backend/codegen_llvm.mli | 2 - XML/lib/backend/dune | 2 +- XML/many_tests/dune | 2 +- XML/many_tests/llvm_tweaks.t | 708 +++++++++++++++++++++++++++++++ 4 files changed, 710 insertions(+), 4 deletions(-) create mode 100644 XML/many_tests/llvm_tweaks.t diff --git a/XML/lib/backend/codegen_llvm.mli b/XML/lib/backend/codegen_llvm.mli index a95768d9..be5eb619 100644 --- a/XML/lib/backend/codegen_llvm.mli +++ b/XML/lib/backend/codegen_llvm.mli @@ -2,8 +2,6 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open Format - (** [gen_program_ir prog triple opt] gens program in LLMV IR from the program [prog] for the target architecture specified by [triple] with optimization level [opt] if not None, O0 otherwise*) val gen_program_ir : Middleend.Anf.aprogram -> string -> string option -> string diff --git a/XML/lib/backend/dune b/XML/lib/backend/dune index 0826b802..9bd21b08 100644 --- a/XML/lib/backend/dune +++ b/XML/lib/backend/dune @@ -1,7 +1,7 @@ (library (name backend) (public_name XML.Backend) - (modules codegen codegen_llvm emission machine target LL) + (modules codegen codegen_llvm emission machine target) (libraries angstrom base diff --git a/XML/many_tests/dune b/XML/many_tests/dune index 5d913e15..21949fa8 100644 --- a/XML/many_tests/dune +++ b/XML/many_tests/dune @@ -15,7 +15,7 @@ (inline_tests)) (cram - (applies_to codegen codegen_llvm anf cc ll gc gc_llvm) + (applies_to codegen codegen_llvm anf cc ll gc gc_llvm llvm_tweaks) (deps ../bin/XML.exe ../bin/XML_llvm.exe diff --git a/XML/many_tests/llvm_tweaks.t b/XML/many_tests/llvm_tweaks.t new file mode 100644 index 00000000..45bd3957 --- /dev/null +++ b/XML/many_tests/llvm_tweaks.t @@ -0,0 +1,708 @@ + $ clang --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o + +====================== O0 ====================== + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o temp.ll -O O0 + + $ cat temp.ll + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @id(i64 %x) { + entry: + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 8 + %x2 = load i64, ptr %x1, align 8 + ret i64 %x2 + } + + define i64 @fresh_1(i64 %n, i64 %k, i64 %p) { + entry: + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + %p3 = alloca i64, align 8 + %k2 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 8 + store i64 %k, ptr %k2, align 8 + store i64 %p, ptr %p3, align 8 + %p4 = load i64, ptr %p3, align 8 + %n5 = load i64, ptr %n1, align 8 + %multmp1 = lshr i64 %p4, 1 + %multmp2 = sub i64 %n5, 1 + %multmp3 = mul i64 %multmp1, %multmp2 + %multmp4 = add i64 %multmp3, 1 + store i64 %multmp4, ptr %t_1, align 8 + %k_val = load i64, ptr %k2, align 8 + %t_16 = load i64, ptr %t_1, align 8 + %apptmp = call i64 @apply1(i64 %k_val, i64 %t_16) + store i64 %apptmp, ptr %t_2, align 8 + %t_27 = load i64, ptr %t_2, align 8 + ret i64 %t_27 + } + + define i64 @fac_cps(i64 %n, i64 %k) { + entry: + %t_11 = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + %k2 = alloca i64, align 8 + %n1 = alloca i64, align 8 + store i64 %n, ptr %n1, align 8 + store i64 %k, ptr %k2, align 8 + %n3 = load i64, ptr %n1, align 8 + %eqtmp = icmp eq i64 %n3, 3 + %eqtmp_as_i64 = zext i1 %eqtmp to i64 + store i64 %eqtmp_as_i64, ptr %t_4, align 8 + %t_44 = load i64, ptr %t_4, align 8 + %cond = icmp ne i64 %t_44, 0 + br i1 %cond, label %then, label %else + + then: ; preds = %entry + %k_val = load i64, ptr %k2, align 8 + %apptmp = call i64 @apply1(i64 %k_val, i64 3) + store i64 %apptmp, ptr %t_5, align 8 + %t_55 = load i64, ptr %t_5, align 8 + br label %ifcont + + else: ; preds = %entry + %n6 = load i64, ptr %n1, align 8 + %subtmp1 = sub i64 %n6, 3 + %subtmp2 = add i64 %subtmp1, 1 + store i64 %subtmp2, ptr %t_6, align 8 + %t_67 = load i64, ptr %t_6, align 8 + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %apptmp8 = call i64 @apply1(i64 %closure_tmp, i64 %t_67) + store i64 %apptmp8, ptr %t_7, align 8 + %n9 = load i64, ptr %n1, align 8 + %closure_tmp10 = call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_1 to i64), i64 3) + %apptmp11 = call i64 @apply1(i64 %closure_tmp10, i64 %n9) + store i64 %apptmp11, ptr %t_8, align 8 + %t_8_val = load i64, ptr %t_8, align 8 + %k12 = load i64, ptr %k2, align 8 + %apptmp13 = call i64 @apply1(i64 %t_8_val, i64 %k12) + store i64 %apptmp13, ptr %t_9, align 8 + %t_7_val = load i64, ptr %t_7, align 8 + %t_914 = load i64, ptr %t_9, align 8 + %apptmp15 = call i64 @apply1(i64 %t_7_val, i64 %t_914) + store i64 %apptmp15, ptr %t_10, align 8 + %t_1016 = load i64, ptr %t_10, align 8 + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %t_55, %then ], [ %t_1016, %else ] + store i64 %iftmp, ptr %t_11, align 8 + %t_1117 = load i64, ptr %t_11, align 8 + ret i64 %t_1117 + } + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_15 = alloca i64, align 8 + %t_14 = alloca i64, align 8 + %t_13 = alloca i64, align 8 + call void @rt_init(i64 5120) + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %apptmp = call i64 @apply1(i64 %closure_tmp, i64 9) + store i64 %apptmp, ptr %t_13, align 8 + %t_13_val = load i64, ptr %t_13, align 8 + %closure_tmp1 = call i64 @alloc_closure(i64 ptrtoint (ptr @id to i64), i64 1) + %apptmp2 = call i64 @apply1(i64 %t_13_val, i64 %closure_tmp1) + store i64 %apptmp2, ptr %t_14, align 8 + %t_143 = load i64, ptr %t_14, align 8 + call void @print_int(i64 %t_143) + store i64 0, ptr %t_15, align 8 + store i64 1, ptr %main, align 8 + call void @collect() + ret i64 0 + } + + $ llc temp.ll -o temp.s + $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe + 24 + +====================== O1 ====================== + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o temp.ll -O O1 + + $ cat temp.ll + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) local_unnamed_addr + + declare i64 @alloc_closure(i64, i64) local_unnamed_addr + + declare i64 @apply1(i64, i64) local_unnamed_addr + + declare void @collect() local_unnamed_addr + + declare void @rt_init(i64) local_unnamed_addr + + ; Function Attrs: mustprogress nofree norecurse nosync nounwind willreturn memory(none) + define i64 @id(i64 returned %x) #0 { + entry: + ret i64 %x + } + + define i64 @fresh_1(i64 %n, i64 %k, i64 %p) { + entry: + %multmp1 = lshr i64 %p, 1 + %multmp2 = add i64 %n, -1 + %multmp3 = mul i64 %multmp1, %multmp2 + %multmp4 = add i64 %multmp3, 1 + %apptmp = tail call i64 @apply1(i64 %k, i64 %multmp4) + ret i64 %apptmp + } + + define i64 @fac_cps(i64 %n, i64 %k) { + entry: + %eqtmp = icmp eq i64 %n, 3 + br i1 %eqtmp, label %then, label %else + + then: ; preds = %entry + %apptmp = tail call i64 @apply1(i64 %k, i64 3) + br label %ifcont + + else: ; preds = %entry + %subtmp2 = add i64 %n, -2 + %closure_tmp = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %apptmp8 = tail call i64 @apply1(i64 %closure_tmp, i64 %subtmp2) + %closure_tmp10 = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_1 to i64), i64 3) + %apptmp11 = tail call i64 @apply1(i64 %closure_tmp10, i64 %n) + %apptmp13 = tail call i64 @apply1(i64 %apptmp11, i64 %k) + %apptmp15 = tail call i64 @apply1(i64 %apptmp8, i64 %apptmp13) + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %apptmp, %then ], [ %apptmp15, %else ] + ret i64 %iftmp + } + + define noundef i64 @main() local_unnamed_addr { + entry: + tail call void @rt_init(i64 5120) + %closure_tmp = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %apptmp = tail call i64 @apply1(i64 %closure_tmp, i64 9) + %closure_tmp1 = tail call i64 @alloc_closure(i64 ptrtoint (ptr @id to i64), i64 1) + %apptmp2 = tail call i64 @apply1(i64 %apptmp, i64 %closure_tmp1) + tail call void @print_int(i64 %apptmp2) + tail call void @collect() + ret i64 0 + } + + attributes #0 = { mustprogress nofree norecurse nosync nounwind willreturn memory(none) } + + $ llc temp.ll -o temp.s + $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe + 24 + +====================== O2 ====================== + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o temp.ll -O O2 + + $ cat temp.ll + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) local_unnamed_addr + + declare i64 @alloc_closure(i64, i64) local_unnamed_addr + + declare i64 @apply1(i64, i64) local_unnamed_addr + + declare void @collect() local_unnamed_addr + + declare void @rt_init(i64) local_unnamed_addr + + ; Function Attrs: mustprogress nofree norecurse nosync nounwind willreturn memory(none) + define i64 @id(i64 returned %x) #0 { + entry: + ret i64 %x + } + + define i64 @fresh_1(i64 %n, i64 %k, i64 %p) { + entry: + %multmp1 = lshr i64 %p, 1 + %multmp2 = add i64 %n, -1 + %multmp3 = mul i64 %multmp1, %multmp2 + %multmp4 = add i64 %multmp3, 1 + %apptmp = tail call i64 @apply1(i64 %k, i64 %multmp4) + ret i64 %apptmp + } + + define i64 @fac_cps(i64 %n, i64 %k) { + entry: + %eqtmp = icmp eq i64 %n, 3 + br i1 %eqtmp, label %then, label %else + + then: ; preds = %entry + %apptmp = tail call i64 @apply1(i64 %k, i64 3) + br label %ifcont + + else: ; preds = %entry + %subtmp2 = add i64 %n, -2 + %closure_tmp = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %apptmp8 = tail call i64 @apply1(i64 %closure_tmp, i64 %subtmp2) + %closure_tmp10 = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_1 to i64), i64 3) + %apptmp11 = tail call i64 @apply1(i64 %closure_tmp10, i64 %n) + %apptmp13 = tail call i64 @apply1(i64 %apptmp11, i64 %k) + %apptmp15 = tail call i64 @apply1(i64 %apptmp8, i64 %apptmp13) + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %apptmp, %then ], [ %apptmp15, %else ] + ret i64 %iftmp + } + + define noundef i64 @main() local_unnamed_addr { + entry: + tail call void @rt_init(i64 5120) + %closure_tmp = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %apptmp = tail call i64 @apply1(i64 %closure_tmp, i64 9) + %closure_tmp1 = tail call i64 @alloc_closure(i64 ptrtoint (ptr @id to i64), i64 1) + %apptmp2 = tail call i64 @apply1(i64 %apptmp, i64 %closure_tmp1) + tail call void @print_int(i64 %apptmp2) + tail call void @collect() + ret i64 0 + } + + attributes #0 = { mustprogress nofree norecurse nosync nounwind willreturn memory(none) } + + $ llc temp.ll -o temp.s + $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe + 24 + +====================== O3 ====================== + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o temp.ll -O O3 + + $ cat temp.ll + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) local_unnamed_addr + + declare i64 @alloc_closure(i64, i64) local_unnamed_addr + + declare i64 @apply1(i64, i64) local_unnamed_addr + + declare void @collect() local_unnamed_addr + + declare void @rt_init(i64) local_unnamed_addr + + ; Function Attrs: mustprogress nofree norecurse nosync nounwind willreturn memory(none) + define i64 @id(i64 returned %x) #0 { + entry: + ret i64 %x + } + + define i64 @fresh_1(i64 %n, i64 %k, i64 %p) { + entry: + %multmp1 = lshr i64 %p, 1 + %multmp2 = add i64 %n, -1 + %multmp3 = mul i64 %multmp1, %multmp2 + %multmp4 = add i64 %multmp3, 1 + %apptmp = tail call i64 @apply1(i64 %k, i64 %multmp4) + ret i64 %apptmp + } + + define i64 @fac_cps(i64 %n, i64 %k) { + entry: + %eqtmp = icmp eq i64 %n, 3 + br i1 %eqtmp, label %then, label %else + + then: ; preds = %entry + %apptmp = tail call i64 @apply1(i64 %k, i64 3) + br label %ifcont + + else: ; preds = %entry + %subtmp2 = add i64 %n, -2 + %closure_tmp = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %apptmp8 = tail call i64 @apply1(i64 %closure_tmp, i64 %subtmp2) + %closure_tmp10 = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fresh_1 to i64), i64 3) + %apptmp11 = tail call i64 @apply1(i64 %closure_tmp10, i64 %n) + %apptmp13 = tail call i64 @apply1(i64 %apptmp11, i64 %k) + %apptmp15 = tail call i64 @apply1(i64 %apptmp8, i64 %apptmp13) + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ %apptmp, %then ], [ %apptmp15, %else ] + ret i64 %iftmp + } + + define noundef i64 @main() local_unnamed_addr { + entry: + tail call void @rt_init(i64 5120) + %closure_tmp = tail call i64 @alloc_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2) + %apptmp = tail call i64 @apply1(i64 %closure_tmp, i64 9) + %closure_tmp1 = tail call i64 @alloc_closure(i64 ptrtoint (ptr @id to i64), i64 1) + %apptmp2 = tail call i64 @apply1(i64 %apptmp, i64 %closure_tmp1) + tail call void @print_int(i64 %apptmp2) + tail call void @collect() + ret i64 0 + } + + attributes #0 = { mustprogress nofree norecurse nosync nounwind willreturn memory(none) } + + $ llc temp.ll -o temp.s + $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe + 24 + +====================== RISC-V ====================== + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o temp.ll -t "riscv64-unknown-linux-gnu" + $ llc temp.ll -o temp.s + $ cat temp.s + .text + .attribute 4, 16 + .attribute 5, "rv64i2p1" + .file "main" + .globl id # -- Begin function id + .p2align 2 + .type id,@function + id: # @id + .cfi_startproc + # %bb.0: # %entry + addi sp, sp, -16 + .cfi_def_cfa_offset 16 + sd a0, 8(sp) + addi sp, sp, 16 + ret + .Lfunc_end0: + .size id, .Lfunc_end0-id + .cfi_endproc + # -- End function + .globl fresh_1 # -- Begin function fresh_1 + .p2align 2 + .type fresh_1,@function + fresh_1: # @fresh_1 + .cfi_startproc + # %bb.0: # %entry + addi sp, sp, -64 + .cfi_def_cfa_offset 64 + sd ra, 56(sp) # 8-byte Folded Spill + sd s0, 48(sp) # 8-byte Folded Spill + .cfi_offset ra, -8 + .cfi_offset s0, -16 + mv s0, a1 + sd a0, 8(sp) + sd a1, 16(sp) + sd a2, 24(sp) + srli a2, a2, 1 + addi a1, a0, -1 + mv a0, a2 + call __muldi3 + addi a1, a0, 1 + sd a1, 32(sp) + mv a0, s0 + call apply1 + sd a0, 40(sp) + ld ra, 56(sp) # 8-byte Folded Reload + ld s0, 48(sp) # 8-byte Folded Reload + addi sp, sp, 64 + ret + .Lfunc_end1: + .size fresh_1, .Lfunc_end1-fresh_1 + .cfi_endproc + # -- End function + .globl fac_cps # -- Begin function fac_cps + .p2align 2 + .type fac_cps,@function + fac_cps: # @fac_cps + .cfi_startproc + # %bb.0: # %entry + addi sp, sp, -96 + .cfi_def_cfa_offset 96 + sd ra, 88(sp) # 8-byte Folded Spill + sd s0, 80(sp) # 8-byte Folded Spill + .cfi_offset ra, -8 + .cfi_offset s0, -16 + sd a1, 8(sp) + addi a1, a0, -3 + seqz a1, a1 + sd a1, 16(sp) + li a1, 3 + sd a0, 0(sp) + bne a0, a1, .LBB2_2 + # %bb.1: # %then + ld a0, 8(sp) + li a1, 3 + call apply1 + sd a0, 24(sp) + j .LBB2_3 + .LBB2_2: # %else + ld s0, 0(sp) + addi s0, s0, -2 + sd s0, 32(sp) + lui a0, %hi(fac_cps) + addi a0, a0, %lo(fac_cps) + li a1, 2 + call alloc_closure + mv a1, s0 + call apply1 + ld s0, 0(sp) + sd a0, 40(sp) + lui a0, %hi(fresh_1) + addi a0, a0, %lo(fresh_1) + li a1, 3 + call alloc_closure + mv a1, s0 + call apply1 + ld a1, 8(sp) + sd a0, 48(sp) + call apply1 + ld a1, 40(sp) + mv a2, a0 + sd a0, 56(sp) + mv a0, a1 + mv a1, a2 + call apply1 + sd a0, 64(sp) + .LBB2_3: # %ifcont + sd a0, 72(sp) + ld ra, 88(sp) # 8-byte Folded Reload + ld s0, 80(sp) # 8-byte Folded Reload + addi sp, sp, 96 + ret + .Lfunc_end2: + .size fac_cps, .Lfunc_end2-fac_cps + .cfi_endproc + # -- End function + .globl main # -- Begin function main + .p2align 2 + .type main,@function + main: # @main + .cfi_startproc + # %bb.0: # %entry + addi sp, sp, -64 + .cfi_def_cfa_offset 64 + sd ra, 56(sp) # 8-byte Folded Spill + sd s0, 48(sp) # 8-byte Folded Spill + sd s1, 40(sp) # 8-byte Folded Spill + .cfi_offset ra, -8 + .cfi_offset s0, -16 + .cfi_offset s1, -24 + li a0, 5 + slli a0, a0, 10 + call rt_init + lui a0, %hi(fac_cps) + addi a0, a0, %lo(fac_cps) + li a1, 2 + call alloc_closure + li a1, 9 + call apply1 + mv s0, a0 + sd a0, 8(sp) + lui a0, %hi(id) + addi a0, a0, %lo(id) + li a1, 1 + li s1, 1 + call alloc_closure + mv a1, a0 + mv a0, s0 + call apply1 + sd a0, 16(sp) + call print_int + sd zero, 24(sp) + sd s1, 32(sp) + call collect + li a0, 0 + ld ra, 56(sp) # 8-byte Folded Reload + ld s0, 48(sp) # 8-byte Folded Reload + ld s1, 40(sp) # 8-byte Folded Reload + addi sp, sp, 64 + ret + .Lfunc_end3: + .size main, .Lfunc_end3-main + .cfi_endproc + # -- End function + .section ".note.GNU-stack","",@progbits + +====================== x86-64 ====================== + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o temp.ll -t "x86_64-pc-linux-gnu" + $ llc temp.ll -o temp.s + $ cat temp.s + .text + .file "main" + .globl id # -- Begin function id + .p2align 4, 0x90 + .type id,@function + id: # @id + .cfi_startproc + # %bb.0: # %entry + movq %rdi, %rax + movq %rdi, -8(%rsp) + retq + .Lfunc_end0: + .size id, .Lfunc_end0-id + .cfi_endproc + # -- End function + .globl fresh_1 # -- Begin function fresh_1 + .p2align 4, 0x90 + .type fresh_1,@function + fresh_1: # @fresh_1 + .cfi_startproc + # %bb.0: # %entry + subq $40, %rsp + .cfi_def_cfa_offset 48 + movq %rsi, %rax + movq %rdi, (%rsp) + movq %rsi, 8(%rsp) + movq %rdx, 16(%rsp) + shrq %rdx + leaq -1(%rdi), %rsi + imulq %rdx, %rsi + incq %rsi + movq %rsi, 24(%rsp) + movq %rax, %rdi + callq apply1@PLT + movq %rax, 32(%rsp) + addq $40, %rsp + .cfi_def_cfa_offset 8 + retq + .Lfunc_end1: + .size fresh_1, .Lfunc_end1-fresh_1 + .cfi_endproc + # -- End function + .globl fac_cps # -- Begin function fac_cps + .p2align 4, 0x90 + .type fac_cps,@function + fac_cps: # @fac_cps + .cfi_startproc + # %bb.0: # %entry + pushq %rbx + .cfi_def_cfa_offset 16 + subq $80, %rsp + .cfi_def_cfa_offset 96 + .cfi_offset %rbx, -16 + movq %rdi, (%rsp) + movq %rsi, 8(%rsp) + xorl %eax, %eax + cmpq $3, %rdi + sete %al + movq %rax, 24(%rsp) + jne .LBB2_2 + # %bb.1: # %then + movq 8(%rsp), %rdi + movl $3, %esi + callq apply1@PLT + movq %rax, 32(%rsp) + jmp .LBB2_3 + .LBB2_2: # %else + movq (%rsp), %rbx + addq $-2, %rbx + movq %rbx, 40(%rsp) + movq fac_cps@GOTPCREL(%rip), %rdi + movl $2, %esi + callq alloc_closure@PLT + movq %rax, %rdi + movq %rbx, %rsi + callq apply1@PLT + movq %rax, 16(%rsp) + movq (%rsp), %rbx + movq fresh_1@GOTPCREL(%rip), %rdi + movl $3, %esi + callq alloc_closure@PLT + movq %rax, %rdi + movq %rbx, %rsi + callq apply1@PLT + movq %rax, 48(%rsp) + movq 8(%rsp), %rsi + movq %rax, %rdi + callq apply1@PLT + movq %rax, 56(%rsp) + movq 16(%rsp), %rdi + movq %rax, %rsi + callq apply1@PLT + movq %rax, 64(%rsp) + .LBB2_3: # %ifcont + movq %rax, 72(%rsp) + addq $80, %rsp + .cfi_def_cfa_offset 16 + popq %rbx + .cfi_def_cfa_offset 8 + retq + .Lfunc_end2: + .size fac_cps, .Lfunc_end2-fac_cps + .cfi_endproc + # -- End function + .globl main # -- Begin function main + .p2align 4, 0x90 + .type main,@function + main: # @main + .cfi_startproc + # %bb.0: # %entry + pushq %rbx + .cfi_def_cfa_offset 16 + subq $32, %rsp + .cfi_def_cfa_offset 48 + .cfi_offset %rbx, -16 + movl $5120, %edi # imm = 0x1400 + callq rt_init@PLT + movq fac_cps@GOTPCREL(%rip), %rdi + movl $2, %esi + callq alloc_closure@PLT + movl $9, %esi + movq %rax, %rdi + callq apply1@PLT + movq %rax, %rbx + movq %rax, (%rsp) + movq id@GOTPCREL(%rip), %rdi + movl $1, %esi + callq alloc_closure@PLT + movq %rbx, %rdi + movq %rax, %rsi + callq apply1@PLT + movq %rax, 8(%rsp) + movq %rax, %rdi + callq print_int@PLT + movq $0, 16(%rsp) + movq $1, 24(%rsp) + callq collect@PLT + xorl %eax, %eax + addq $32, %rsp + .cfi_def_cfa_offset 16 + popq %rbx + .cfi_def_cfa_offset 8 + retq + .Lfunc_end3: + .size main, .Lfunc_end3-main + .cfi_endproc + # -- End function + .section ".note.GNU-stack","",@progbits From bd23da8fe7564be1f720f738155a44c44b2273d9 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 15:28:55 +0300 Subject: [PATCH 30/84] feat: remove trash --- XML/out.ll | 12 ------------ 1 file changed, 12 deletions(-) delete mode 100644 XML/out.ll diff --git a/XML/out.ll b/XML/out.ll deleted file mode 100644 index d187d623..00000000 --- a/XML/out.ll +++ /dev/null @@ -1,12 +0,0 @@ -; ModuleID = 'main' -source_filename = "main" -target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-i128:128-f80:128-n8:16:32:64-S128" -target triple = "x86_64-pc-linux-gnu" - -declare void @print_int(i64) - -define i64 @main() { -entry: - call void @print_int(i64 70) - ret i64 0 -} From 5ffceca5eb03c1a3dfb2f6fcd4d1d91f8c6315bf Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 16:17:51 +0300 Subject: [PATCH 31/84] fix: warnings --- XML/bin/XML.ml | 2 +- XML/bin/XML.mli | 3 +++ XML/bin/XML_llvm.mli | 3 +++ XML/lib/backend/emission.ml | 2 +- XML/lib/common/ast.ml | 34 +++++++++++++++------------------- 5 files changed, 23 insertions(+), 21 deletions(-) create mode 100644 XML/bin/XML.mli create mode 100644 XML/bin/XML_llvm.mli diff --git a/XML/bin/XML.ml b/XML/bin/XML.ml index 95d69d5c..f501f34e 100644 --- a/XML/bin/XML.ml +++ b/XML/bin/XML.ml @@ -1,4 +1,4 @@ -(** 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 *) diff --git a/XML/bin/XML.mli b/XML/bin/XML.mli new file mode 100644 index 00000000..26ede79c --- /dev/null +++ b/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 *) diff --git a/XML/bin/XML_llvm.mli b/XML/bin/XML_llvm.mli new file mode 100644 index 00000000..26ede79c --- /dev/null +++ b/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 *) diff --git a/XML/lib/backend/emission.ml b/XML/lib/backend/emission.ml index a6a48979..6931887b 100644 --- a/XML/lib/backend/emission.ml +++ b/XML/lib/backend/emission.ml @@ -2,7 +2,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open Base.Format +open Format open Base open Machine open Target diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index c6b2a830..2b44e234 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -42,10 +42,9 @@ let gen_ident = map2 (fun start_sym rest_sym -> Base.Char.to_string start_sym ^ rest_sym) (oneof [ char_range 'A' 'Z'; char_range 'a' 'z'; return '_' ]) - (small_string - ~gen: - (oneof - [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) + (string_small_of + (oneof + [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) in gen_filtered_ident base_gen ;; @@ -55,10 +54,9 @@ let gen_ident_uc = map2 (fun start_sym rest_sym -> Base.Char.to_string start_sym ^ rest_sym) (char_range 'A' 'Z') - (small_string - ~gen: - (oneof - [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) + (string_small_of + (oneof + [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) in gen_filtered_ident base_gen ;; @@ -71,10 +69,9 @@ let gen_ident_lc include_us = map2 (fun start_sym rest_sym -> Base.Char.to_string start_sym ^ rest_sym) start_sym - (small_string - ~gen: - (oneof - [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) + (string_small_of + (oneof + [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) in gen_filtered_ident base_gen ;; @@ -91,10 +88,9 @@ end module Constant = struct type t = - | Const_integer of (int[@gen small_nat]) (** integer as [52] *) + | Const_integer of (int[@gen nat_small]) (** integer as [52] *) | Const_char of (char[@gen gen_charc]) (** char as ['w'] *) - | Const_string of (string[@gen small_string ~gen:gen_charc]) - (** string as ["Kakadu"] *) + | Const_string of (string[@gen string_small_of gen_charc]) (** string as ["Kakadu"] *) [@@deriving eq, show { with_path = false }, qcheck] end @@ -215,7 +211,7 @@ module Structure = struct [@@deriving eq, show { with_path = false }] let gen_structure_item n = - frequency + oneof_weighted [ 0, map (fun expr -> Str_eval expr) (Expression.gen_sized (n / 2)) ; ( 0 , let* rec_flag = @@ -223,15 +219,15 @@ module Structure = struct in let* bind1 = Expression.gen_value_binding Expression.gen_sized (n / 2) in let* bindl = - small_list (Expression.gen_value_binding Expression.gen_sized (n / 2)) + list_small (Expression.gen_value_binding Expression.gen_sized (n / 2)) in return (Str_value (rec_flag, (bind1, bindl))) ) ; ( 1 - , let* tparam = small_list (gen_ident_lc true) in + , let* tparam = list_small (gen_ident_lc true) in let* idt = gen_ident_lc true in let* cons1 = Gen.pair gen_ident_uc (Gen.option (TypeExpr.gen_sized (n / 20))) in let* consl = - small_list (Gen.pair gen_ident_uc (Gen.option (TypeExpr.gen_sized (n / 20)))) + list_small (Gen.pair gen_ident_uc (Gen.option (TypeExpr.gen_sized (n / 20)))) in return (Str_adt (tparam, idt, (cons1, consl))) ) ] From 66e5f738d0c5bcdb6a0fe5c453c48356afb01555 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 16:36:52 +0300 Subject: [PATCH 32/84] fix: add clang-18 and llc-18 to deps --- XML/XML.opam | 2 +- XML/XML.opam.template | 2 +- XML/many_tests/codegen_llvm.t | 66 +++++++++++++++++------------------ XML/many_tests/gc_llvm.t | 24 ++++++------- XML/many_tests/llvm_tweaks.t | 22 ++++++------ 5 files changed, 58 insertions(+), 58 deletions(-) diff --git a/XML/XML.opam b/XML/XML.opam index 2246cee2..4b5db614 100644 --- a/XML/XML.opam +++ b/XML/XML.opam @@ -35,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"] diff --git a/XML/XML.opam.template b/XML/XML.opam.template index f4e537bf..c9653196 100644 --- a/XML/XML.opam.template +++ b/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"] diff --git a/XML/many_tests/codegen_llvm.t b/XML/many_tests/codegen_llvm.t index 332ca74e..c9a5858f 100644 --- a/XML/many_tests/codegen_llvm.t +++ b/XML/many_tests/codegen_llvm.t @@ -1,4 +1,4 @@ - $ clang --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o + $ clang-18 --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o ====================== Factorial ====================== @@ -94,8 +94,8 @@ ret i64 0 } - $ llc factorial.ll -o factorial.s - $ clang --target=riscv64-linux-gnu factorial.s runtime.o -o factorial.exe + $ llc-18 factorial.ll -o factorial.s + $ clang-18 --target=riscv64-linux-gnu factorial.s runtime.o -o factorial.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./factorial.exe 24 @@ -106,8 +106,8 @@ > let main = print_int (fib 6) - $ llc fibonacci.ll -o fibonacci.s - $ clang --target=riscv64-linux-gnu -static fibonacci.s runtime.o -o fibonacci.exe + $ llc-18 fibonacci.ll -o fibonacci.s + $ clang-18 --target=riscv64-linux-gnu -static fibonacci.s runtime.o -o fibonacci.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./fibonacci.exe 8 @@ -121,8 +121,8 @@ > then 0 else 1 in > large x - $ llc ififif.ll -o ififif.s - $ clang --target=riscv64-linux-gnu -static ififif.s runtime.o -o ififif.exe + $ llc-18 ififif.ll -o ififif.s + $ clang-18 --target=riscv64-linux-gnu -static ififif.s runtime.o -o ififif.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./ififif.exe 42 0 @@ -135,8 +135,8 @@ > > let main = print_int (partialapp_sum 5) - $ llc closure.ll -o closure.s - $ clang --target=riscv64-linux-gnu -static closure.s runtime.o -o closure.exe + $ llc-18 closure.ll -o closure.s + $ clang-18 --target=riscv64-linux-gnu -static closure.s runtime.o -o closure.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./closure.exe 10 @@ -144,8 +144,8 @@ ====================== CPS Factorial ====================== $ ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o 010faccps_ll.ll - $ llc 010faccps_ll.ll -o 010faccps_ll.s - $ clang --target=riscv64-linux-gnu -static 010faccps_ll.s runtime.o -o 010faccps_ll.exe + $ llc-18 010faccps_ll.ll -o 010faccps_ll.s + $ clang-18 --target=riscv64-linux-gnu -static 010faccps_ll.s runtime.o -o 010faccps_ll.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./010faccps_ll.exe 24 @@ -153,8 +153,8 @@ ====================== CPS Fibbo ====================== $ ../bin/XML_llvm.exe -fromfile manytests/typed/010fibcps_ll.ml -o 010fibcps_ll.ll - $ llc 010fibcps_ll.ll -o 010fibcps_ll.s - $ clang --target=riscv64-linux-gnu -static 010fibcps_ll.s runtime.o -o 010fibcps_ll.exe + $ llc-18 010fibcps_ll.ll -o 010fibcps_ll.s + $ clang-18 --target=riscv64-linux-gnu -static 010fibcps_ll.s runtime.o -o 010fibcps_ll.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./010fibcps_ll.exe 8 @@ -163,8 +163,8 @@ $ ../bin/XML_llvm.exe -fromfile ./manytests/typed/004manyargs.ml -o 004manyargs.ll - $ llc 004manyargs.ll -o 004manyargs.s - $ clang --target=riscv64-linux-gnu -static 004manyargs.s runtime.o -o 004manyargs.exe + $ llc-18 004manyargs.ll -o 004manyargs.s + $ clang-18 --target=riscv64-linux-gnu -static 004manyargs.s runtime.o -o 004manyargs.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./004manyargs.exe 1111111111 1 @@ -181,8 +181,8 @@ > let (a, b) = p in > print_int (a + b) - $ llc tuple_return.ll -o tuple_return.s - $ clang --target=riscv64-linux-gnu -static tuple_return.s runtime.o -o tuple_return.exe + $ llc-18 tuple_return.ll -o tuple_return.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_return.s runtime.o -o tuple_return.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_return.exe 30 @@ -199,8 +199,8 @@ > let (x, y) = p2 in > print_int x - $ llc tuple_swap.ll -o tuple_swap.s - $ clang --target=riscv64-linux-gnu -static tuple_swap.s runtime.o -o tuple_swap.exe + $ llc-18 tuple_swap.ll -o tuple_swap.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_swap.s runtime.o -o tuple_swap.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_swap.exe 2 @@ -214,8 +214,8 @@ > let (a, b) = t in > print_int (a + b) - $ llc tuple_order.ll -o tuple_order.s - $ clang --target=riscv64-linux-gnu -static tuple_order.s runtime.o -o tuple_order.exe + $ llc-18 tuple_order.ll -o tuple_order.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_order.s runtime.o -o tuple_order.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_order.exe 30 @@ -231,8 +231,8 @@ > print_int (sum_list lst) - $ llc tuple_linked_list.ll -o tuple_linked_list.s - $ clang --target=riscv64-linux-gnu -static tuple_linked_list.s runtime.o -o tuple_linked_list.exe + $ llc-18 tuple_linked_list.ll -o tuple_linked_list.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_linked_list.s runtime.o -o tuple_linked_list.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_linked_list.exe 60 @@ -244,8 +244,8 @@ > let (a, b, c, d, e, f, g, h, i, j) = t in > print_int j - $ llc tuple_large.ll -o tuple_large.s - $ clang --target=riscv64-linux-gnu -static tuple_large.s runtime.o -o tuple_large.exe + $ llc-18 tuple_large.ll -o tuple_large.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_large.s runtime.o -o tuple_large.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_large.exe 10 @@ -256,8 +256,8 @@ > let (a, b) = t in > print_int (a + b) - $ llc tuple_basic.ll -o tuple_basic.s - $ clang --target=riscv64-linux-gnu -static tuple_basic.s runtime.o -o tuple_basic.exe + $ llc-18 tuple_basic.ll -o tuple_basic.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_basic.s runtime.o -o tuple_basic.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_basic.exe 30 @@ -269,8 +269,8 @@ > print_int (a + b + c) - $ llc tuple_nested.ll -o tuple_nested.s - $ clang --target=riscv64-linux-gnu -static tuple_nested.s runtime.o -o tuple_nested.exe + $ llc-18 tuple_nested.ll -o tuple_nested.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_nested.s runtime.o -o tuple_nested.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_nested.exe 123 @@ -285,8 +285,8 @@ > print_int (sum_pair p) - $ llc tuple_arg.ll -o tuple_arg.s - $ clang --target=riscv64-linux-gnu -static tuple_arg.s runtime.o -o tuple_arg.exe + $ llc-18 tuple_arg.ll -o tuple_arg.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_arg.s runtime.o -o tuple_arg.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_arg.exe 42 @@ -302,8 +302,8 @@ > let _ = print_gc_status in > print_int head - $ llc tuple_gc_stress.ll -o tuple_gc_stress.s - $ clang --target=riscv64-linux-gnu -static tuple_gc_stress.s runtime.o -o tuple_gc_stress.exe + $ llc-18 tuple_gc_stress.ll -o tuple_gc_stress.s + $ clang-18 --target=riscv64-linux-gnu -static tuple_gc_stress.s runtime.o -o tuple_gc_stress.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_gc_stress.exe === GC Status === Current allocated: 0 diff --git a/XML/many_tests/gc_llvm.t b/XML/many_tests/gc_llvm.t index baf0a693..b2eb9bdc 100644 --- a/XML/many_tests/gc_llvm.t +++ b/XML/many_tests/gc_llvm.t @@ -1,4 +1,4 @@ - $ clang --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o + $ clang-18 --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o $ dune exec ./../bin/XML_llvm.exe -- -o gc_smoke.ll < let main = @@ -6,9 +6,9 @@ > let _ = collect in > print_gc_status - $ llc gc_smoke.ll -o gc_smoke.s - $ clang --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o - $ clang --target=riscv64-linux-gnu -static gc_smoke.s runtime.o -o gc_smoke.exe + $ llc-18 gc_smoke.ll -o gc_smoke.s + $ clang-18 --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o + $ clang-18 --target=riscv64-linux-gnu -static gc_smoke.s runtime.o -o gc_smoke.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./gc_smoke.exe === GC Status === Current allocated: 0 @@ -45,8 +45,8 @@ > let _ = print_gc_status in > print_int (f 8) - $ llc lots_of_garbage.ll -o lots_of_garbage.s - $ clang --target=riscv64-linux-gnu -static lots_of_garbage.s runtime.o -o lots_of_garbage.exe + $ llc-18 lots_of_garbage.ll -o lots_of_garbage.s + $ clang-18 --target=riscv64-linux-gnu -static lots_of_garbage.s runtime.o -o lots_of_garbage.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./lots_of_garbage.exe === GC Status === Current allocated: 0 @@ -95,8 +95,8 @@ > let _ = collect in > print_int (f 7) - $ llc keep_block_across_gc.ll -o keep_block_across_gc.s - $ clang --target=riscv64-linux-gnu -static keep_block_across_gc.s runtime.o -o keep_block_across_gc.exe + $ llc-18 keep_block_across_gc.ll -o keep_block_across_gc.s + $ clang-18 --target=riscv64-linux-gnu -static keep_block_across_gc.s runtime.o -o keep_block_across_gc.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./keep_block_across_gc.exe 7 @@ -107,8 +107,8 @@ > let _ = alloc_block 10000000 in > print_int 0 - $ llc gc_oom_block.ll -o gc_oom_block.s - $ clang --target=riscv64-linux-gnu -static gc_oom_block.s runtime.o -o gc_oom_block.exe + $ llc-18 gc_oom_block.ll -o gc_oom_block.s + $ clang-18 --target=riscv64-linux-gnu -static gc_oom_block.s runtime.o -o gc_oom_block.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./gc_oom_block.exe GC: out of memory: asked for 160000024 bytes, alloc_ptr is 0x2aaaab32d010 (end is 0x2aaaab3ad010) Aborted (core dumped) @@ -129,8 +129,8 @@ > let _ = print_gc_status in > print_int head - $ llc temp.ll -o temp.s - $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ llc-18 temp.ll -o temp.s + $ clang-18 --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe === GC Status === Current allocated: 0 diff --git a/XML/many_tests/llvm_tweaks.t b/XML/many_tests/llvm_tweaks.t index 45bd3957..32875a50 100644 --- a/XML/many_tests/llvm_tweaks.t +++ b/XML/many_tests/llvm_tweaks.t @@ -1,4 +1,4 @@ - $ clang --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o + $ clang-18 --target=riscv64-linux-gnu --sysroot=/usr/riscv64-unknown-linux-gnu -c ./../bin/runtime.c -o runtime.o ====================== O0 ====================== @@ -144,8 +144,8 @@ ret i64 0 } - $ llc temp.ll -o temp.s - $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ llc-18 temp.ll -o temp.s + $ clang-18 --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe 24 @@ -222,8 +222,8 @@ attributes #0 = { mustprogress nofree norecurse nosync nounwind willreturn memory(none) } - $ llc temp.ll -o temp.s - $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ llc-18 temp.ll -o temp.s + $ clang-18 --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe 24 @@ -300,8 +300,8 @@ attributes #0 = { mustprogress nofree norecurse nosync nounwind willreturn memory(none) } - $ llc temp.ll -o temp.s - $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ llc-18 temp.ll -o temp.s + $ clang-18 --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe 24 @@ -378,15 +378,15 @@ attributes #0 = { mustprogress nofree norecurse nosync nounwind willreturn memory(none) } - $ llc temp.ll -o temp.s - $ clang --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ llc-18 temp.ll -o temp.s + $ clang-18 --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe 24 ====================== RISC-V ====================== $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o temp.ll -t "riscv64-unknown-linux-gnu" - $ llc temp.ll -o temp.s + $ llc-18 temp.ll -o temp.s $ cat temp.s .text .attribute 4, 16 @@ -556,7 +556,7 @@ ====================== x86-64 ====================== $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -o temp.ll -t "x86_64-pc-linux-gnu" - $ llc temp.ll -o temp.s + $ llc-18 temp.ll -o temp.s $ cat temp.s .text .file "main" From 0a0e58a25e85759610d0320f64f462074d4ae71b Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 16:50:36 +0300 Subject: [PATCH 33/84] fix: error message --- XML/bin/runtime.c | 3 +-- XML/many_tests/gc.t | 2 +- XML/many_tests/gc_llvm.t | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/XML/bin/runtime.c b/XML/bin/runtime.c index 5451de2b..35ebbe53 100644 --- a/XML/bin/runtime.c +++ b/XML/bin/runtime.c @@ -208,8 +208,7 @@ static void* gc_alloc_bytes(size_t n, GCType* vt) { if (alloc_ptr + n > from_end) { gc_collect(); char msg[100]; - sprintf(msg, "GC: out of memory: asked for %ld bytes, alloc_ptr is %p (end is %p)", n, - alloc_ptr, from_end); + sprintf(msg, "GC: out of memory: asked for %ld bytes)", n); if (alloc_ptr + n > from_end) panic(msg); } uint8_t* p = alloc_ptr; diff --git a/XML/many_tests/gc.t b/XML/many_tests/gc.t index 7a1655d7..264106a8 100644 --- a/XML/many_tests/gc.t +++ b/XML/many_tests/gc.t @@ -105,7 +105,7 @@ $ riscv64-linux-gnu-gcc -c ../bin/runtime.c -o runtime.o $ riscv64-linux-gnu-gcc temp.o runtime.o -o prog.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu -cpu rv64 ./prog.exe || true - GC: out of memory: asked for 160000024 bytes, alloc_ptr is 0x2aaaab4e8010 (end is 0x2aaaab568010) + GC: out of memory: asked for 160000024 bytes) Aborted (core dumped) diff --git a/XML/many_tests/gc_llvm.t b/XML/many_tests/gc_llvm.t index b2eb9bdc..b9488ed9 100644 --- a/XML/many_tests/gc_llvm.t +++ b/XML/many_tests/gc_llvm.t @@ -110,7 +110,7 @@ $ llc-18 gc_oom_block.ll -o gc_oom_block.s $ clang-18 --target=riscv64-linux-gnu -static gc_oom_block.s runtime.o -o gc_oom_block.exe $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./gc_oom_block.exe - GC: out of memory: asked for 160000024 bytes, alloc_ptr is 0x2aaaab32d010 (end is 0x2aaaab3ad010) + GC: out of memory: asked for 160000024 bytes) Aborted (core dumped) [134] From bfff8199c99896d23341945fea253c96c55cd06a Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 16 Feb 2026 17:09:40 +0300 Subject: [PATCH 34/84] fix: zanuda warnings --- XML/lib/backend/codegen_llvm.ml | 26 +++++++++++++------------- XML/lib/middleend/ll.ml | 2 +- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index c0cf67f8..944e9dce 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -251,8 +251,8 @@ let rec gen_comp_expr_ir fmap = function Llvm.set_alignment gl_align clos_val; let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in build_apply_part fmap clos_val argvs - | _ -> failwith ("Id: " ^ f ^ " not found"))) - | Comp_app (Imm_num _, _) -> failwith "cannot apply number as a function" + | _ -> invalid_arg ("Id: " ^ f ^ " not found"))) + | Comp_app (Imm_num _, _) -> invalid_arg "cannot apply number as a function" | Comp_branch (cond, br_then, br_else) -> let cv = gen_im_expr_ir fmap cond in let zero = Llvm.const_int i64_type 0 in @@ -308,7 +308,7 @@ let rec gen_comp_expr_ir fmap = function let voffst = Llvm.const_int i64_type (offset / Target.word_size) in let fifn, fity, _ = FuncMap.find_exn fmap "field" in Llvm.build_call fity fifn [| vbase; voffst |] "load_tmp" builder - | Comp_func (_, _) -> failwith "anonymous functions should be lambda-lifted" + | Comp_func (_, _) -> invalid_arg "anonymous functions should be lambda-lifted" and gen_anf_expr fmap = function | Anf_comp_expr comp -> gen_comp_expr_ir fmap comp @@ -358,13 +358,13 @@ let gen_function fmap name params body = (* Need to check for error here *) let ret_val = gen_anf_expr fmap body in let _ = Llvm.build_ret ret_val builder in - (match Llvm_analysis.verify_function the_fun with - | true -> () - | false -> - Stdlib.Format.printf - "invalid function generated\n%s\n" - (Llvm.string_of_llvalue the_fun); - Llvm_analysis.assert_valid_function the_fun); + if Llvm_analysis.verify_function the_fun + then () + else ( + Stdlib.Format.printf + "invalid function generated\n%s\n" + (Llvm.string_of_llvalue the_fun); + Llvm_analysis.assert_valid_function the_fun); the_fun ;; @@ -376,7 +376,7 @@ let gen_astructure_item fmap = function let main_fn = match Llvm.lookup_function "main" the_module with | Some fn -> fn - | _ -> failwith ("cannot generate value: " ^ name ^ ", main function not found") + | _ -> invalid_arg ("cannot generate value: " ^ name ^ ", main function not found") in Llvm.position_at_end (Llvm.entry_block main_fn) builder; let value = gen_anf_expr fmap expr in @@ -398,7 +398,7 @@ let optimize_ir (triple : string) (opt : string option) = in let optflag = "default<" ^ optflag ^ ">" in (match Llvm_passbuilder.run_passes the_module optflag machine opts with - | Error e -> failwith e + | Error e -> invalid_arg e | Ok () -> ()); Llvm_passbuilder.dispose_passbuilder_options opts ;; @@ -424,6 +424,6 @@ let gen_program_ir (program : aprogram) (triple : string) (opt : string option) let _ = Llvm.build_ret (Llvm.const_int i64_type 0) builder in optimize_ir triple opt; match Llvm_analysis.verify_module the_module with - | Some r -> failwith r + | Some r -> invalid_arg r | None -> Llvm.string_of_llmodule the_module ;; diff --git a/XML/lib/middleend/ll.ml b/XML/lib/middleend/ll.ml index 76a9299d..602bd189 100644 --- a/XML/lib/middleend/ll.ml +++ b/XML/lib/middleend/ll.ml @@ -43,7 +43,7 @@ let occurs_im x = function ;; let rec escapes_comp x = function - | Comp_func (ps, body) -> if List.mem x ps then false else SSet.mem x (fv_anf body) + | Comp_func (ps, body) -> (not (List.mem x ps)) && SSet.mem x (fv_anf body) | Comp_branch (_c, t, e) -> escapes_anf x t || escapes_anf x e | Comp_app (_, _) | Comp_binop (_, _, _) From edc2623e46ee90f2c1505c3c50a7218a891dfd08 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 25 Feb 2026 01:34:56 +0300 Subject: [PATCH 35/84] feat: add naive typechecking --- XML/bin/XML.ml | 15 + XML/bin/XML_llvm.ml | 15 + XML/lib/middleend/dune | 2 +- XML/lib/middleend/infer.ml | 870 ++++++++++++++++++++++++++++++++ XML/lib/middleend/inferTypes.ml | 188 +++++++ XML/many_tests/codegen.t | 4 +- XML/many_tests/codegen_llvm.t | 4 +- XML/many_tests/gc.t | 2 +- XML/many_tests/gc_llvm.t | 2 +- 9 files changed, 1095 insertions(+), 7 deletions(-) create mode 100644 XML/lib/middleend/infer.ml create mode 100644 XML/lib/middleend/inferTypes.ml diff --git a/XML/bin/XML.ml b/XML/bin/XML.ml index f501f34e..6c3c8594 100644 --- a/XML/bin/XML.ml +++ b/XML/bin/XML.ml @@ -17,6 +17,7 @@ type options = ; mutable show_cc : bool ; mutable show_ll : bool ; mutable gc_stats : bool + ; mutable check_types : bool } (* ------------------------------- *) @@ -36,6 +37,16 @@ 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 typedtree = + Middleend.Infer.run_infer_program ast Middleend.Infer.env_with_things + in + match typedtree with + | Error err -> + Format.printf "Type error: %a\n" Middleend.InferTypes.pp_inf_err err; + exit 1 + | Ok (_, _) -> ()); if options.show_ast then ( printf "%a\n" Common.Pprinter.pprint_program ast; @@ -106,6 +117,7 @@ let () = ; show_cc = false ; show_ll = false ; gc_stats = false + ; check_types = true } in let usage_msg = @@ -136,6 +148,9 @@ 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" ) ] in let handle_anon_arg filename = diff --git a/XML/bin/XML_llvm.ml b/XML/bin/XML_llvm.ml index 5d82df2b..be036778 100644 --- a/XML/bin/XML_llvm.ml +++ b/XML/bin/XML_llvm.ml @@ -18,6 +18,7 @@ type options = ; mutable show_anf : bool ; mutable show_cc : bool ; mutable show_ll : bool + ; mutable check_types : bool } (* ------------------------------- *) @@ -41,6 +42,16 @@ let to_llvm_ir ast options = let compile_and_write options source_code = let ast = Common.Parser.parse_str source_code in + if options.check_types + then ( + let typedtree = + Middleend.Infer.run_infer_program ast Middleend.Infer.env_with_things + in + match typedtree with + | Error err -> + Format.printf "Type error: %a\n" Middleend.InferTypes.pp_inf_err err; + exit 1 + | Ok (_, _) -> ()); if options.show_ast then ( (* printf "%a\n" Common.Pprinter.pprint_program ast; *) @@ -114,6 +125,7 @@ let () = ; show_ll = false ; optimization_lvl = None ; target = "riscv64-unknown-linux-gnu" + ; check_types = true } in let usage_msg = @@ -150,6 +162,9 @@ let () = ; ( "-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" ) ] in let handle_anon_arg filename = diff --git a/XML/lib/middleend/dune b/XML/lib/middleend/dune index 35a9e47c..ecfab3cd 100644 --- a/XML/lib/middleend/dune +++ b/XML/lib/middleend/dune @@ -1,7 +1,7 @@ (library (name middleend) (public_name XML.Middleend) - (modules Anf Pprinter Cc Ll) + (modules Anf Pprinter Cc Ll InferTypes Infer) (libraries angstrom base stdio XML.Common) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving_qcheck)) diff --git a/XML/lib/middleend/infer.ml b/XML/lib/middleend/infer.ml new file mode 100644 index 00000000..afb8dabe --- /dev/null +++ b/XML/lib/middleend/infer.ml @@ -0,0 +1,870 @@ +(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Common.Ast.TypeExpr +open InferTypes + +module MInfer = struct + open Base + + type 'a t = int -> int * ('a, InferTypes.error) Result.t + + let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = + fun m f st -> + let last, r = m st in + match r with + | Result.Error x -> last, Error x + | Ok a -> f a last + ;; + + let fail e st = st, Result.fail e + let return x last = last, Result.return x + let bind x ~f = x >>= f + + let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = + fun x f st -> + match x st with + | st, Ok x -> st, Ok (f x) + | st, Result.Error e -> st, Result.Error e + ;; + + module Syntax = struct + let ( let* ) x f = bind x ~f + end + + module RList = struct + let fold_left xs ~init ~f = + Base.List.fold_left xs ~init ~f:(fun acc x -> + let open Syntax in + let* acc = acc in + f acc x) + ;; + + let fold_left2 xs xl ~init ~f = + Base.List.fold2 + ~f:(fun acc x l -> + let open Syntax in + let* acc = acc in + f acc x l) + ~init + xs + xl + ;; + + let fold_right xs ~init ~f = + Base.List.fold_right xs ~init ~f:(fun x acc -> + let open Syntax in + let* acc = acc in + f x acc) + ;; + end + + let fresh : int t = fun last -> last + 1, Result.Ok last + let run m = snd (m 0) +end + +module Type = struct + type t = Common.Ast.TypeExpr.t + + let rec occurs_check tvar = function + | Type_var binder -> binder = tvar + | Type_arrow (l, r) -> occurs_check tvar l || occurs_check tvar r + | Type_tuple (t1, t2, t) -> + List.fold_left (fun acc h -> acc || occurs_check tvar h) false (t1 :: t2 :: t) + | Type_construct (_, ty) -> + List.fold_left (fun acc h -> acc || occurs_check tvar h) false ty + ;; + + let free_vars = + let rec helper acc = function + | Type_var binder -> VarSet.add binder acc + | Type_arrow (l, r) -> helper (helper acc l) r + | Type_tuple (t1, t2, t) -> + List.fold_left (fun acc h -> helper acc h) acc (t1 :: t2 :: t) + | Type_construct (_, ty) -> List.fold_left (fun acc h -> helper acc h) acc ty + in + helper VarSet.empty + ;; +end + +module Substitution = struct + open MInfer + open MInfer.Syntax + open Base + + type t = (string, Type.t, Base.String.comparator_witness) Base.Map.t + + let empty = Map.empty (module Base.String) + + let singleton k v = + match k, v with + | a, Type_var b when String.equal a b -> return (Base.Map.empty (module Base.String)) + | _ -> + if Type.occurs_check k v + then fail (Occurs_check (k, v)) + else return (Base.Map.singleton (module Base.String) k v) + ;; + + let remove = Map.remove + + let apply sub = + let rec helper = function + | Type_var b as typ -> + (match Map.find sub b with + | Some b -> b + | None -> typ) + | Type_arrow (l, r) -> Type_arrow (helper l, helper r) + | Type_tuple (t1, t2, t) -> Type_tuple (helper t1, helper t2, List.map t ~f:helper) + | Type_construct (id, ty) -> Type_construct (id, List.map ty ~f:helper) + in + helper + ;; + + let fold mp init f = + Map.fold mp ~init ~f:(fun ~key:k ~data:vm acc -> + let* acc = acc in + f k vm acc) + ;; + + let rec unify l r = + match l, r with + | Type_var a, Type_var b when String.equal a b -> return empty + | Type_var b, t | t, Type_var b -> singleton b t + | Type_arrow (l1, r1), Type_arrow (l2, r2) -> + let* subs1 = unify l1 l2 in + let* subs2 = unify (apply subs1 r1) (apply subs1 r2) in + compose subs1 subs2 + | Type_tuple (l11, l12, l1), Type_tuple (l21, l22, l2) -> + (match + Base.List.fold2 + (l11 :: l12 :: l1) + (l21 :: l22 :: l2) + ~init:(return empty) + ~f:(fun acc t1 t2 -> + let* sub1 = acc in + let* sub2 = unify (apply sub1 t1) (apply sub1 t2) in + compose sub1 sub2) + with + | Ok sub -> sub + | _ -> fail (Unification_failed (l, r))) + | Type_construct (id1, ty1), Type_construct (id2, ty2) when String.equal id1 id2 -> + let* subs = + match + Base.List.fold2 ty1 ty2 ~init:(return empty) ~f:(fun acc t1 t2 -> + let* sub1 = acc in + let* sub2 = unify (apply sub1 t1) (apply sub1 t2) in + compose sub1 sub2) + with + | Ok sub -> sub + | _ -> fail (Unification_failed (l, r)) + in + return subs + | _ -> fail (Unification_failed (l, r)) + + and extend k v s = + match Map.find s k with + | None -> + let v = apply s v in + let* s2 = singleton k v in + fold s (return s2) (fun k v acc -> + let* acc = return acc in + let v = apply s2 v in + return (Map.update acc k ~f:(fun _ -> v))) + | Some v2 -> + let* s2 = unify v v2 in + compose s s2 + + and compose s1 s2 = fold s2 (return s1) extend + and compose_all ss = RList.fold_left ss ~init:(return empty) ~f:compose +end + +module Scheme = struct + type t = scheme + + let free_vars = function + | Forall (bs, t) -> VarSet.diff (Type.free_vars t) bs + ;; + + let apply subst (Forall (binder_set, typ)) = + let s2 = VarSet.fold (fun k s -> Substitution.remove s k) binder_set subst in + Forall (binder_set, Substitution.apply s2 typ) + ;; + + let pp_scheme fmt = function + | Forall (st, typ) -> + if VarSet.is_empty st + then + Format.fprintf + fmt + "%a" + (pprint_type ~poly_names_map:(Base.Map.empty (module Base.String))) + typ + else + Format.fprintf + fmt + "%a. %a" + VarSet.pp + st + (pprint_type ~poly_names_map:(Base.Map.empty (module Base.String))) + typ + ;; +end + +module TypeEnv = struct + open Base + + type t = (string, scheme, String.comparator_witness) Map.t + + let extend env name scheme = Map.set env ~key:name ~data:scheme + let empty = Map.empty (module String) + let fold f init mp = Map.fold mp ~init ~f:(fun ~key:k ~data:v acc -> f k v acc) + + let free_vars : t -> VarSet.t = + fold (fun _ s acc -> VarSet.union acc (Scheme.free_vars s)) VarSet.empty + ;; + + let apply s env = Map.map env ~f:(Scheme.apply s) + let find name xs = Map.find xs name + let find_exn name xs = Map.find_exn xs name + let remove sub k = Base.Map.remove sub k + + let pp_env fmt environment = + Map.iteri environment ~f:(fun ~key ~data -> + Stdlib.Format.fprintf fmt "%S: %a\n" key Scheme.pp_scheme data) + ;; +end + +open MInfer +open MInfer.Syntax + +let fresh_var = fresh >>| fun n -> Type_var (Int.to_string n) + +let instantiate : scheme -> Common.Ast.TypeExpr.t MInfer.t = + fun (Forall (bs, t)) -> + VarSet.fold + (fun name typ -> + let* typ = typ in + let* f1 = fresh_var in + let* s = Substitution.singleton name f1 in + return (Substitution.apply s typ)) + bs + (return t) +;; + +let generalize : TypeEnv.t -> Type.t -> Scheme.t = + fun env ty -> + let free = VarSet.diff (Type.free_vars ty) (TypeEnv.free_vars env) in + Forall (free, ty) +;; + +open Common.Ast.Constant +open Common.Ast.Expression +open Common.Ast.Pattern + +let rec infer_pat ~debug pat env = + match pat with + | Pat_any -> + let* fresh = fresh_var in + return (env, fresh) + | Pat_var ident -> + let* fresh = fresh_var in + let new_env = TypeEnv.extend env ident (Forall (VarSet.empty, fresh)) in + return (new_env, fresh) + | Pat_constant const -> + (match const with + | Const_char _ -> return (env, Type_construct ("char", [])) + | Const_integer _ -> return (env, Type_construct ("int", [])) + | Const_string _ -> return (env, Type_construct ("string", []))) + | Pat_tuple (pat1, pat2, rest) -> + let* env1, typ1 = infer_pat ~debug pat1 env in + let* env2, typ2 = infer_pat ~debug pat2 env1 in + let* env3, typ3 = + RList.fold_right + ~f:(fun pat acc -> + let* env_acc, typ_list = return acc in + let* env, typ = infer_pat ~debug pat env_acc in + return (env, typ :: typ_list)) + ~init:(return (env2, [])) + rest + in + return (env3, Type_tuple (typ1, typ2, typ3)) + | Pat_construct (name, pat) -> + (match TypeEnv.find name env with + | None -> fail (Unbound_variable name) + | Some (Forall (x, Type_arrow (arg, adt))) -> + let* typ = instantiate (Forall (x, Type_arrow (arg, adt))) in + (match pat with + | Some const_pat -> + let* patenv, typepat = infer_pat ~debug const_pat env in + let* uni_sub = Substitution.unify arg typepat in + let new_env = TypeEnv.apply uni_sub patenv in + return (new_env, Substitution.apply uni_sub adt) + | None -> return (env, typ)) + | Some el -> + let* typ = instantiate el in + return (env, typ)) + | Pat_constraint (pat, typ) -> + let* pat_env, pat_typ = infer_pat ~debug pat env in + let* uni_sub = Substitution.unify pat_typ typ in + let new_env = TypeEnv.apply uni_sub pat_env in + return (new_env, Substitution.apply uni_sub pat_typ) +;; + +let rec extend_helper env pat (Forall (binder_set, typ) as scheme) = + match pat, typ with + | Pat_var name, _ -> TypeEnv.extend env name scheme + | Pat_tuple (p1, p2, prest), Type_tuple (t1, t2, trest) -> + let new_env = + Base.List.fold2 + ~init:env + ~f:(fun env pat typ -> extend_helper env pat (Forall (binder_set, typ))) + (p1 :: p2 :: prest) + (t1 :: t2 :: trest) + in + (match new_env with + | Ok new_env -> new_env + | _ -> env) + | _ -> env +;; + +let add_names_rec env vb_list = + RList.fold_right + ~f:(fun vb acc -> + match vb with + | { pat = Pat_var name; _ } | { pat = Pat_constraint (Pat_var name, _); _ } -> + let* env_acc, fresh_acc = return acc in + let* fresh = fresh_var in + let env_acc = TypeEnv.extend env_acc name (Forall (VarSet.empty, fresh)) in + return (env_acc, fresh :: fresh_acc) + | _ -> fail Wrong_rec) + vb_list + ~init:(return (env, [])) +;; + +let infer_rest_vb ~debug env_acc sub_acc sub typ pat = + let* comp_sub = Substitution.compose sub_acc sub in + let new_env = TypeEnv.apply comp_sub env_acc in + let new_scheme = generalize new_env (Substitution.apply comp_sub typ) in + let* pat_env, pat_typ = infer_pat ~debug pat new_env in + let new_env = extend_helper pat_env pat new_scheme in + let* uni_sub = Substitution.unify typ pat_typ in + let* res_sub = Substitution.compose comp_sub uni_sub in + let res_env = TypeEnv.apply res_sub new_env in + return (res_env, res_sub) +;; + +let infer_rec_rest_vb sub_acc env_acc fresh typ name new_sub = + let* uni_sub = Substitution.unify (Substitution.apply new_sub fresh) typ in + let* comp_sub = Substitution.compose_all [ new_sub; uni_sub; sub_acc ] in + let env_acc = TypeEnv.apply comp_sub env_acc in + let env_rm = TypeEnv.remove env_acc name in + let new_scheme = generalize env_rm (Substitution.apply comp_sub fresh) in + let env_acc = TypeEnv.extend env_acc name new_scheme in + return (env_acc, comp_sub) +;; + +let rec get_pat_names acc pat = + match pat with + | Pat_var id -> id :: acc + | Pat_tuple (pat1, pat2, rest) -> + Base.List.fold_left ~f:get_pat_names ~init:acc (pat1 :: pat2 :: rest) + | Pat_construct ("Some", Some pat) -> get_pat_names acc pat + | Pat_constraint (pat, _) -> get_pat_names acc pat + | _ -> acc +;; + +let rec infer_exp ~debug exp env = + match exp with + | Exp_ident varname -> + (match TypeEnv.find varname env with + | None -> fail (Unbound_variable varname) + | Some x -> + let* typ = instantiate x in + return (Substitution.empty, typ)) + | Exp_constant const -> + (match const with + | Const_char _ -> return (Substitution.empty, Type_construct ("char", [])) + | Const_integer _ -> return (Substitution.empty, Type_construct ("int", [])) + | Const_string _ -> return (Substitution.empty, Type_construct ("string", []))) + | Exp_apply (Exp_ident op, Exp_tuple (exp1, exp2, [])) -> + (match op with + | "*" | "/" | "+" | "-" | "<" | ">" | "=" | "<>" | "<=" | ">=" | "&&" | "||" -> + let* sub1, typ1 = infer_exp ~debug exp1 env in + let* sub2, typ2 = infer_exp ~debug exp2 (TypeEnv.apply sub1 env) in + let* arg_typ, res_typ = + match TypeEnv.find op env with + | Some (Forall (_, Type_arrow (Type_arrow (arg, _), res))) -> return (arg, res) + | _ -> fail @@ Unsupported_operator op + in + let* unif_sub1 = Substitution.unify (Substitution.apply sub2 typ1) arg_typ in + let* unif_sub2 = Substitution.unify (Substitution.apply unif_sub1 typ2) arg_typ in + let* comp_sub = Substitution.compose_all [ sub1; sub2; unif_sub1; unif_sub2 ] in + return (comp_sub, res_typ) + | _ -> + let* sub1, typ1 = infer_exp ~debug (Exp_ident op) env in + let* sub2, typ2 = + infer_exp ~debug (Exp_tuple (exp1, exp2, [])) (TypeEnv.apply sub1 env) + in + let* fresh = fresh_var in + let* unif_sub = + Substitution.unify (Substitution.apply sub2 typ1) (Type_arrow (typ2, fresh)) + in + let* comp_sub = Substitution.compose_all [ unif_sub; sub2; sub1 ] in + let res_typ = Substitution.apply comp_sub fresh in + return (comp_sub, res_typ)) + | Exp_apply (exp1, exp2) -> + (match exp1 with + | Exp_ident op when op = "+" || op = "-" -> + let* sub1, typ1 = infer_exp ~debug exp2 env in + let* unif_sub = Substitution.unify typ1 (Type_construct ("int", [])) in + let* comp_sub = Substitution.compose sub1 unif_sub in + return (comp_sub, Type_construct ("int", [])) + | _ -> + let* sub1, typ1 = infer_exp ~debug exp1 env in + let* sub2, typ2 = infer_exp ~debug exp2 (TypeEnv.apply sub1 env) in + let* fresh = fresh_var in + let* unif_sub = + Substitution.unify (Substitution.apply sub2 typ1) (Type_arrow (typ2, fresh)) + in + let* comp_sub = Substitution.compose_all [ unif_sub; sub2; sub1 ] in + let res_typ = Substitution.apply comp_sub fresh in + return (comp_sub, res_typ)) + | Exp_fun ((pattern, patterns), expr) -> + let* new_env, typ1 = infer_pat ~debug pattern env in + let* sub1, typ2 = + match patterns with + | hd :: tl -> infer_exp ~debug (Exp_fun ((hd, tl), expr)) new_env + | [] -> infer_exp ~debug expr new_env + in + return (sub1, Type_arrow (Substitution.apply sub1 typ1, typ2)) + | Exp_construct (name, Some expr) -> + let* ty, sub = infer_exp ~debug (Exp_apply (Exp_ident name, expr)) env in + return (ty, sub) + | Exp_construct (name, None) -> + let* ty, sub = infer_exp ~debug (Exp_ident name) env in + return (ty, sub) + | Exp_tuple (exp1, exp2, rest) -> + let* sub1, typ1 = infer_exp ~debug exp1 env in + let new_env = TypeEnv.apply sub1 env in + let* sub2, typ2 = infer_exp ~debug exp2 new_env in + let new_env = TypeEnv.apply sub2 new_env in + let* sub3, typ3 = + RList.fold_right + ~f:(fun exp acc -> + let* sub_acc, typ_list = return acc in + let new_env = TypeEnv.apply sub_acc new_env in + let* sub, typ = infer_exp ~debug exp new_env in + let* sub_acc = Substitution.compose sub_acc sub in + return (sub_acc, typ :: typ_list)) + ~init:(return (Substitution.empty, [])) + rest + in + let* fin_sub = Substitution.compose_all [ sub1; sub2; sub3 ] in + let typ1 = Substitution.apply fin_sub typ1 in + let typ2 = Substitution.apply fin_sub typ2 in + let typ3 = List.map (fun typ -> Substitution.apply fin_sub typ) typ3 in + return (fin_sub, Type_tuple (typ1, typ2, typ3)) + | Exp_if (ifexp, thenexp, Some elseexp) -> + let* sub1, typ1 = infer_exp ~debug ifexp env in + let* uni_sub1 = Substitution.unify typ1 (Type_construct ("bool", [])) in + let* sub2, typ2 = infer_exp ~debug thenexp env in + let* sub3, typ3 = infer_exp ~debug elseexp env in + let* uni_sub2 = Substitution.unify typ2 typ3 in + let* comp_sub = Substitution.compose_all [ sub1; uni_sub1; sub2; sub3; uni_sub2 ] in + return (comp_sub, typ3) + | Exp_if (ifexp, thenexp, None) -> + let* sub1, typ1 = infer_exp ~debug ifexp env in + let* uni_sub1 = Substitution.unify typ1 (Type_construct ("bool", [])) in + let* sub2, typ2 = infer_exp ~debug thenexp env in + let* comp_sub = Substitution.compose_all [ sub1; uni_sub1; sub2 ] in + return (comp_sub, typ2) + | Exp_match (expr, (case, rest)) -> + let* subexpr, typexpr = infer_exp ~debug expr env in + let new_env = TypeEnv.apply subexpr env in + let* fresh = fresh_var in + let* res_sub, res_typ = + RList.fold_left + (case :: rest) + ~init:(return (subexpr, fresh)) + ~f:(fun acc case -> + let* sub, typ = return acc in + let pat_names = get_pat_names [] case.first in + let* pat_env, pat_typ = infer_pat ~debug case.first new_env in + let* uni_sub = Substitution.unify pat_typ typexpr in + let* comp_sub = Substitution.compose sub uni_sub in + let pat_env = + Base.List.fold_left + ~f:(fun env name -> + let (Forall (_, typ)) = TypeEnv.find_exn name env in + let env = TypeEnv.remove env name in + TypeEnv.extend env name (generalize env typ)) + ~init:(TypeEnv.apply uni_sub pat_env) + pat_names + in + let* subexpr, typexpr = + infer_exp ~debug case.second (TypeEnv.apply comp_sub pat_env) + in + let* uni_sub2 = Substitution.unify typexpr typ in + let* res_sub = Substitution.compose_all [ uni_sub2; subexpr; comp_sub ] in + return (res_sub, Substitution.apply res_sub typ)) + in + return (res_sub, res_typ) + | Exp_function (case, rest) -> + let* fresh1 = fresh_var in + let* fresh2 = fresh_var in + let* res_sub, res_typ = + RList.fold_left + (case :: rest) + ~init:(return (Substitution.empty, fresh2)) + ~f:(fun acc case -> + let* sub, typ = return acc in + let* pat_env, pat_typ = infer_pat ~debug case.first env in + let* uni_sub1 = Substitution.unify pat_typ fresh1 in + let* sub1 = Substitution.compose uni_sub1 sub in + let new_env = TypeEnv.apply sub1 pat_env in + let* subexpr, typexpr = infer_exp ~debug case.second new_env in + let* uni_sub2 = Substitution.unify typ typexpr in + let* comp_sub = Substitution.compose_all [ uni_sub2; subexpr; sub1 ] in + return (comp_sub, Substitution.apply comp_sub typ)) + in + return (res_sub, Type_arrow (Substitution.apply res_sub fresh1, res_typ)) + | Exp_let (Nonrecursive, (value_binding, rest), exp) -> + let* new_env, sub, _ = + infer_value_binding_list ~debug (value_binding :: rest) env Substitution.empty + in + let* subb, typp = infer_exp ~debug exp new_env in + let* comp_sub = Substitution.compose sub subb in + return (comp_sub, typp) + | Exp_let (Recursive, (value_binding, rest), exp) -> + let* new_env, fresh_vars = add_names_rec env (value_binding :: rest) in + let* new_env, sub, _ = + infer_rec_value_binding_list + ~debug + (value_binding :: rest) + new_env + Substitution.empty + fresh_vars + in + let* subb, typp = infer_exp ~debug exp new_env in + let* comp_sub = Substitution.compose subb sub in + return (comp_sub, typp) + | Exp_constraint (expr, typ) -> + let* sub, typ1 = infer_exp ~debug expr env in + let* uni_sub = Substitution.unify typ1 typ in + let* comp_sub = Substitution.compose sub uni_sub in + return (comp_sub, typ1) + +and infer_value_binding_list ~debug vb_list env sub = + let* res_env, res_sub, names = + RList.fold_left + vb_list + ~init:(return (env, sub, [])) + ~f:(fun acc vb -> + let* env_acc, sub_acc, names = return acc in + match vb with + | { pat = Pat_constraint (pat, pat_typ); expr = Exp_fun ((fpat, fpatrest), exp) } + -> + let* sub, typ = + infer_exp + ~debug + (Exp_fun ((fpat, fpatrest), Exp_constraint (exp, pat_typ))) + env_acc + in + let* res_env, res_sub = infer_rest_vb ~debug env_acc sub_acc sub typ pat in + let name = get_pat_names names pat in + return (res_env, res_sub, names @ name) + | { pat = Pat_constraint (pat, pat_typ); expr = Exp_function _ as exp } -> + let* sub, typ = infer_exp ~debug (Exp_constraint (exp, pat_typ)) env_acc in + let* res_env, res_sub = infer_rest_vb ~debug env_acc sub_acc sub typ pat in + let name = get_pat_names names pat in + return (res_env, res_sub, names @ name) + | { pat; expr } -> + let* sub, typ = infer_exp ~debug expr env_acc in + let* res_env, res_sub = infer_rest_vb ~debug env_acc sub_acc sub typ pat in + let name = get_pat_names names pat in + return (res_env, res_sub, names @ name)) + in + return (res_env, res_sub, names) + +and infer_rec_value_binding_list ~debug vb_list env sub fresh_vars = + let* res_env, res_sub, names = + match + RList.fold_left2 + vb_list + fresh_vars + ~init:(return (env, sub, [])) + ~f:(fun acc vb fv -> + let* env_acc, sub_acc, names = return acc in + match vb, fv with + | ( ( { pat = Pat_var name; expr = Exp_fun _ as exp } + | { pat = Pat_var name; expr = Exp_function _ as exp } ) + , fresh ) -> + let* subexpr, typexpr = infer_exp ~debug exp env_acc in + let* res_env, res_sub = + infer_rec_rest_vb sub_acc env_acc fresh typexpr name subexpr + in + return (res_env, res_sub, names @ [ name ]) + | ( { pat = Pat_constraint (Pat_var name, pat_typ) + ; expr = Exp_fun ((pat, pat_list), expr) + } + , fresh ) -> + let* subexpr, typexpr = + infer_exp + ~debug + (Exp_fun ((pat, pat_list), Exp_constraint (expr, pat_typ))) + env + in + let* res_env, res_sub = + infer_rec_rest_vb sub_acc env_acc fresh typexpr name subexpr + in + return (res_env, res_sub, names @ [ name ]) + | { pat = Pat_var name; expr }, fresh -> + let* subexpr, typexpr = infer_exp ~debug expr env_acc in + (match typexpr with + | Type_arrow (_, _) -> + let new_fresh = Substitution.apply sub_acc fresh in + if typexpr = new_fresh + then fail Wrong_rec + else + let* res_env, res_sub = + infer_rec_rest_vb sub_acc env_acc fresh typexpr name subexpr + in + return (res_env, res_sub, names @ [ name ]) + | _ -> fail Wrong_rec) + | _ -> fail Wrong_rec) + with + | Ok result -> result + | Unequal_lengths -> fail Incorrect_list_lengths + in + return (res_env, res_sub, names) +;; + +open Common.Ast.Structure + +let rec check_poly_types ~debug typ_list marity = function + | Type_var var when Base.List.mem typ_list var ~equal:String.equal -> return () + | Type_var name -> fail (Unbound_variable name) + | Type_construct (name, args) -> + let* arity = + Base.Map.find marity name + |> Base.Option.value_map ~f:return ~default:(fail (Undeclared_type name)) + in + if arity = Base.List.length args + then check_many ~debug typ_list marity args + else fail Arity_mismatch + | Type_arrow (l, r) -> + let* () = check_poly_types ~debug typ_list marity l in + check_poly_types ~debug typ_list marity r + | Type_tuple (t1, t2, rest) -> + let* () = check_poly_types ~debug typ_list marity t1 in + let* () = check_poly_types ~debug typ_list marity t2 in + check_many ~debug typ_list marity rest + +and check_many ~debug typ_list marity args = + let rec iter = function + | [] -> return () + | arg :: rest -> + let* () = check_poly_types ~debug typ_list marity arg in + iter rest + in + iter args +;; + +let ( ! ) fresh = Type_var fresh + +let infer_structure_item ~debug env item marity names = + match item with + | Str_eval exp -> + let* _, typ = infer_exp ~debug exp env in + let new_env = TypeEnv.extend env "-" (Forall (VarSet.empty, typ)) in + return (new_env, marity, names @ [ "-" ]) + | Str_value (Nonrecursive, (value_binding, rest)) -> + let* env, _, names = + infer_value_binding_list ~debug (value_binding :: rest) env Substitution.empty + in + return (env, marity, names) + | Str_value (Recursive, (value_binding, rest)) -> + let* new_env, fresh_vars = add_names_rec env (value_binding :: rest) in + let* new_env, _, names = + infer_rec_value_binding_list + ~debug + (value_binding :: rest) + new_env + Substitution.empty + fresh_vars + in + return (new_env, marity, names) + | Str_adt (poly, name, (variant, rest)) -> + let adt_type = Type_construct (name, Base.List.map poly ~f:( ! )) in + let type_arity = List.length poly in + let arity_map = Base.Map.set marity ~key:name ~data:type_arity in + let* constrs = + RList.fold_left + (variant :: rest) + ~init:(return env) + ~f:(fun acc (constr_name, constr_types) -> + let* env_acc = return acc in + let* fresh = fresh in + let* new_env = + match constr_types with + | None -> + return + (TypeEnv.extend + env_acc + constr_name + (Forall (VarSet.singleton (Int.to_string fresh), adt_type))) + | Some typ -> + let* () = check_poly_types ~debug poly arity_map typ in + return + (TypeEnv.extend + env_acc + constr_name + (Forall (VarSet.of_list poly, Type_arrow (typ, adt_type)))) + in + return new_env) + in + return (constrs, arity_map, names) +;; + +let infer_program ~debug program env = + let marity = Base.Map.empty (module Base.String) in + let marity = Base.Map.add_exn marity ~key:"int" ~data:0 in + let marity = Base.Map.add_exn marity ~key:"char" ~data:0 in + let marity = Base.Map.add_exn marity ~key:"string" ~data:0 in + let marity = Base.Map.add_exn marity ~key:"bool" ~data:0 in + let marity = Base.Map.add_exn marity ~key:"unit" ~data:0 in + let* env, _, names = + RList.fold_left + program + ~init:(return (env, marity, [])) + ~f:(fun acc item -> + let* env_acc, arr_acc, names = return acc in + let* env, arr, name = infer_structure_item ~debug env_acc item arr_acc names in + return (env, arr, names @ name)) + in + return (env, names) +;; + +let env_with_things = + let things_list = + [ ( "+" + , Forall + ( VarSet.empty + , Type_arrow + ( Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) + , Type_construct ("int", []) ) ) ) + ; ( "-" + , Forall + ( VarSet.empty + , Type_arrow + ( Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) + , Type_construct ("int", []) ) ) ) + ; ( "*" + , Forall + ( VarSet.empty + , Type_arrow + ( Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) + , Type_construct ("int", []) ) ) ) + ; ( "/" + , Forall + ( VarSet.empty + , Type_arrow + ( Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) + , Type_construct ("int", []) ) ) ) + ; ( "<" + , Forall + ( VarSet.singleton "a" + , Type_arrow + (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) + ; ( ">" + , Forall + ( VarSet.singleton "a" + , Type_arrow + (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) + ; ( "<>" + , Forall + ( VarSet.singleton "a" + , Type_arrow + (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) + ; ( "<=" + , Forall + ( VarSet.singleton "a" + , Type_arrow + (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) + ; ( ">=" + , Forall + ( VarSet.singleton "a" + , Type_arrow + (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) + ; ( "=" + , Forall + ( VarSet.singleton "a" + , Type_arrow + (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) + ; ( "||" + , Forall + ( VarSet.empty + , Type_arrow + ( Type_arrow (Type_construct ("bool", []), Type_construct ("bool", [])) + , Type_construct ("bool", []) ) ) ) + ; ( "&&" + , Forall + ( VarSet.empty + , Type_arrow + ( Type_arrow (Type_construct ("bool", []), Type_construct ("bool", [])) + , Type_construct ("bool", []) ) ) ) + ; ( "print_int" + , Forall + ( VarSet.empty + , Type_arrow (Type_construct ("int", []), Type_construct ("unit", [])) ) ) + ; ( "print_endline" + , Forall + ( VarSet.empty + , Type_arrow (Type_construct ("string", []), Type_construct ("unit", [])) ) ) + ; ( "print_char" + , Forall + ( VarSet.empty + , Type_arrow (Type_construct ("char", []), Type_construct ("unit", [])) ) ) + ; ( "print_bool" + , Forall + ( VarSet.empty + , Type_arrow (Type_construct ("bool", []), Type_construct ("unit", [])) ) ) + ; ( "print_gc_status" + , Forall + ( VarSet.empty + , Type_arrow (Type_construct ("unit", []), Type_construct ("unit", [])) ) ) + ; ( "collect" + , Forall + ( VarSet.empty + , Type_arrow (Type_construct ("unit", []), Type_construct ("unit", [])) ) ) + ; ( "alloc_block" + , Forall + ( VarSet.empty + , Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) ) ) + ; ( "Some" + , Forall + ( VarSet.singleton "a" + , Type_arrow (Type_var "a", Type_construct ("option", [ Type_var "a" ])) ) ) + ; "None", Forall (VarSet.singleton "a", Type_construct ("option", [ Type_var "a" ])) + ; ( "::" + , Forall + ( VarSet.singleton "a" + , Type_arrow + ( Type_tuple (Type_var "a", Type_construct ("list", [ Type_var "a" ]), []) + , Type_construct ("list", [ Type_var "a" ]) ) ) ) + ; "[]", Forall (VarSet.singleton "a", Type_construct ("list", [ Type_var "a" ])) + ; "()", Forall (VarSet.empty, Type_construct ("unit", [])) + ; "true", Forall (VarSet.empty, Type_construct ("bool", [])) + ; "false", Forall (VarSet.empty, Type_construct ("bool", [])) + ] + in + List.fold_left + (fun env (id, sch) -> TypeEnv.extend env id sch) + TypeEnv.empty + things_list +;; + +let run_infer_program ?(debug = false) (program : Common.Ast.program) env = + run (infer_program ~debug program env) +;; diff --git a/XML/lib/middleend/inferTypes.ml b/XML/lib/middleend/inferTypes.ml new file mode 100644 index 00000000..0b964882 --- /dev/null +++ b/XML/lib/middleend/inferTypes.ml @@ -0,0 +1,188 @@ +(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Format +open Common.Ast.TypeExpr +open Stdlib + +type binder = int [@@deriving show { with_path = false }] + +module VarSet = struct + include Set.Make (String) + + let pp ppf s = + Format.fprintf ppf "[ "; + iter (Format.fprintf ppf "%s; ") s; + Format.fprintf ppf "]" + ;; +end + +type binder_set = VarSet.t [@@deriving show { with_path = false }] +type scheme = Forall of binder_set * t [@@deriving show { with_path = false }] + +open Base + +(* get polymorphic type names from VarSet *) +let binder_to_list args = + let args = VarSet.elements args in + List.sort (List.map args ~f:Int.of_string) ~compare:Int.compare +;; + +(** turn ['2, '5, '1231, ...] (value is not important, only order) list of + names of polymorphic types into ['a, 'b, 'c ... ] + when english alphabet is out, turn values into ['aa, 'bb, ...] and etc.*) +let minimize dargs = + let counter = 0 in + let coef = 0 in + let m = Map.empty (module Base.String) in + List.fold_left dargs ~init:(m, coef, counter) ~f:(fun (m, coef, counter) el -> + let str = + let rec build coef counter str = + if coef = 0 + then str ^ Char.escaped (Stdlib.Char.chr (counter + 97)) + else build (coef - 1) counter (str ^ Char.escaped (Stdlib.Char.chr (counter + 97))) + in + build coef counter "" + in + let counter = counter + 1 in + let coef = coef + (counter / 26) in + let counter = counter % 26 in + let el = Stdlib.string_of_int el in + Base.Map.set m ~key:el ~data:str, coef, counter) +;; + +let rec pprint_type_tuple ?(poly_names_map = Map.empty (module String)) fmt = function + | [] -> () + | [ h ] -> + (match h with + | Type_arrow (_, _) -> fprintf fmt "(%a)" (pprint_type ~poly_names_map) h + | _ -> fprintf fmt "%a" (pprint_type ~poly_names_map) h) + | h :: tl -> + (match h with + | Type_arrow (_, _) -> + fprintf + fmt + "(%a) * %a" + (pprint_type ~poly_names_map) + h + (pprint_type_tuple ~poly_names_map) + tl + | _ -> + fprintf + fmt + "%a * %a" + (pprint_type ~poly_names_map) + h + (pprint_type_tuple ~poly_names_map) + tl) + +and pprint_type ?(poly_names_map = Map.empty (module String)) fmt = function + | Type_var num -> + (match Map.find poly_names_map num with + | Some k -> fprintf fmt "'%s" k + | None -> fprintf fmt "'%s" num) + | Type_arrow (ty1, ty2) -> + (match ty1, ty2 with + | Type_arrow (_, _), _ -> + fprintf + fmt + "(%a) -> %a" + (pprint_type ~poly_names_map) + ty1 + (pprint_type ~poly_names_map) + ty2 + | _ -> + fprintf + fmt + "%a -> %a" + (pprint_type ~poly_names_map) + ty1 + (pprint_type ~poly_names_map) + ty2) + | Type_tuple (t1, t2, ty_lst) -> + fprintf fmt "%a" (pprint_type_tuple ~poly_names_map) (t1 :: t2 :: ty_lst) + | Type_construct (name, []) -> fprintf fmt "%s" name + | Type_construct (name, ty_list) -> + fprintf fmt "%a %s" (pprint_type_list_with_parens ~poly_names_map) ty_list name + +and pprint_type_list_with_parens ?(poly_names_map = Map.empty (module String)) fmt ty_list + = + let rec print_types fmt = function + | [] -> () + | [ ty ] -> (pprint_type_with_parens_if_tuple ~poly_names_map) fmt ty + | ty :: rest -> + fprintf + fmt + "%a %a" + (pprint_type_with_parens_if_tuple ~poly_names_map) + ty + print_types + rest + in + print_types fmt ty_list + +and pprint_type_with_parens_if_tuple ?(poly_names_map = Map.empty (module String)) fmt ty = + match ty with + | Type_tuple _ -> fprintf fmt "(%a)" (pprint_type ~poly_names_map) ty + | _ -> (pprint_type ~poly_names_map) fmt ty +;; + +(*errors*) +type error = + | Occurs_check of string * Common.Ast.TypeExpr.t + (** same polymotphic type occured while substitution apply ['a : 'a -> 'b]*) + | Unification_failed of Common.Ast.TypeExpr.t * Common.Ast.TypeExpr.t + | Unbound_variable of string + | Arity_mismatch + (** mismatch of types arity + [type 'a foo = Foo + type bar = Bar of foo] *) + | Undeclared_type of string + | Wrong_rec (** invalid right value in recursive let declaration *) + | Unsupported_operator of string (** for binary operators*) + | Incorrect_list_lengths + +let collect_type_vars typ = + let rec aux acc = function + | Type_var num -> num :: acc + | Type_arrow (t1, t2) -> aux (aux acc t1) t2 + | Type_tuple (t1, t2, tl) -> List.fold_left ~f:aux ~init:(aux (aux acc t1) t2) tl + | Type_construct (_, ty_list) -> List.fold_left ~f:aux ~init:acc ty_list + in + aux [] typ +;; + +let collect_vars_from_error = function + | Occurs_check (str, typ) -> str :: collect_type_vars typ + | Unification_failed (t1, t2) -> collect_type_vars t1 @ collect_type_vars t2 + | _ -> [] +;; + +let pp_inf_err fmt err = + let type_vars = collect_vars_from_error err in + let var_map, _, _ = minimize (List.map type_vars ~f:Stdlib.int_of_string) in + match err with + | Occurs_check (str, t) -> + fprintf + fmt + "Occurs_check: %a and %a\n" + (pprint_type ~poly_names_map:var_map) + (Type_var str) + (pprint_type ~poly_names_map:var_map) + t + | Unification_failed (typ1, typ2) -> + fprintf + fmt + "Unification_failed: %a # %a" + (pprint_type ~poly_names_map:var_map) + typ1 + (pprint_type ~poly_names_map:var_map) + typ2 + | Unbound_variable str -> fprintf fmt "Unbound_variable: %S" str + | Arity_mismatch -> fprintf fmt "Arity_mismatch" + | Undeclared_type str -> fprintf fmt "Undeclared_type: %S" str + | Wrong_rec -> fprintf fmt "Wrong right value in rec" + | Unsupported_operator op -> fprintf fmt "Operator %s is not supported" op + | Incorrect_list_lengths -> fprintf fmt "Lists have unequal lengths" +;; diff --git a/XML/many_tests/codegen.t b/XML/many_tests/codegen.t index 105b5591..d6636ac5 100644 --- a/XML/many_tests/codegen.t +++ b/XML/many_tests/codegen.t @@ -1352,7 +1352,7 @@ $ qemu-riscv64 -L /usr/riscv64-linux-gnu -cpu rv64 ./prog.exe 30 - $ ../bin/XML.exe -o tuple_linked_list.s < let rec sum_list lst = > if lst = 0 then 0 else > let (head, tail) = lst in @@ -1409,7 +1409,7 @@ $ qemu-riscv64 -L /usr/riscv64-linux-gnu -cpu rv64 ./prog.exe 42 - $ ../bin/XML.exe -o tuple_gc_stress.s < let rec make_list n acc = > if n = 0 then acc else > make_list (n - 1) (n, acc) diff --git a/XML/many_tests/codegen_llvm.t b/XML/many_tests/codegen_llvm.t index c9a5858f..f8591106 100644 --- a/XML/many_tests/codegen_llvm.t +++ b/XML/many_tests/codegen_llvm.t @@ -220,7 +220,7 @@ 30 - $ ../bin/XML_llvm.exe -o tuple_linked_list.ll < let rec sum_list lst = > if lst = 0 then 0 else > let (head, tail) = lst in @@ -290,7 +290,7 @@ $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./tuple_arg.exe 42 - $ ../bin/XML_llvm.exe -o tuple_gc_stress.ll < let rec make_list n acc = > if n = 0 then acc else > make_list (n - 1) (n, acc) diff --git a/XML/many_tests/gc.t b/XML/many_tests/gc.t index 264106a8..f4234721 100644 --- a/XML/many_tests/gc.t +++ b/XML/many_tests/gc.t @@ -109,7 +109,7 @@ Aborted (core dumped) - $ ../bin/XML.exe -o tuple_gc_stress.s < let rec make_list n acc = > if n = 0 then acc else > make_list (n - 1) (n, acc) diff --git a/XML/many_tests/gc_llvm.t b/XML/many_tests/gc_llvm.t index b9488ed9..979780e9 100644 --- a/XML/many_tests/gc_llvm.t +++ b/XML/many_tests/gc_llvm.t @@ -117,7 +117,7 @@ - $ ../bin/XML_llvm.exe -o temp.ll < let rec make_list n acc = > if n = 0 then acc else > make_list (n - 1) (n, acc) From 28e60c7e36bab585e5cf3db069555d1732e985fa Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Fri, 27 Feb 2026 10:41:36 +0300 Subject: [PATCH 36/84] feat: add skeleton for remy-based infer --- XML/lib/middleend/dune | 2 +- XML/lib/middleend/inferLayers.ml | 133 ++++++++++++++++++++++++++++++ XML/lib/middleend/inferLayers.mli | 0 3 files changed, 134 insertions(+), 1 deletion(-) create mode 100644 XML/lib/middleend/inferLayers.ml create mode 100644 XML/lib/middleend/inferLayers.mli diff --git a/XML/lib/middleend/dune b/XML/lib/middleend/dune index ecfab3cd..29b9e1a5 100644 --- a/XML/lib/middleend/dune +++ b/XML/lib/middleend/dune @@ -1,7 +1,7 @@ (library (name middleend) (public_name XML.Middleend) - (modules Anf Pprinter Cc Ll InferTypes Infer) + (modules Anf Pprinter Cc Ll InferTypes Infer InferLayers) (libraries angstrom base stdio XML.Common) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving_qcheck)) diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml new file mode 100644 index 00000000..3cfc14c5 --- /dev/null +++ b/XML/lib/middleend/inferLayers.ml @@ -0,0 +1,133 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Common.Ast +open Common.Ast.Expression +open Common.Ast.Pattern + +type typ = + | Type_arrow of typ * typ + | Type_tuple of typ List2.t + | Type_var of tv ref + | Quant_type_var of ident + | Type_construct of ident * typ list + +and tv = + | Unbound of ident + | Link of typ + +let rec occurs_check tv = function + | Type_var tv' when tv == tv' -> failwith "occurs check" + | Type_var { contents = Link t } -> occurs_check tv t + | Type_arrow (t1, t2) -> + occurs_check tv t1; + occurs_check tv t2 + | Type_tuple (t1, t2, tl) -> List.map (occurs_check tv) (t1 :: t2 :: tl) |> ignore + | Type_construct (_, lst) -> List.map (occurs_check tv) lst |> ignore + | _ -> () +;; + +let rec unify t1 t2 = + match t1, t2 with + | t1, t2 when t1 == t2 -> () + | Type_var { contents = Link t1 }, t2 | t1, Type_var { contents = Link t2 } -> + unify t1 t2 + | Type_var ({ contents = Unbound _ } as tv), t' + | t', Type_var ({ contents = Unbound _ } as tv) -> + occurs_check tv t'; + tv := Link t1 + | Type_arrow (l1, l2), Type_arrow (r1, r2) -> + unify l1 r1; + unify l2 r2 + | Type_tuple (l1, l2, ltl), Type_tuple (r1, r2, rtl) -> + List.map2 unify (l1 :: l2 :: ltl) (r1 :: r2 :: rtl) |> ignore + | Type_construct (lc, llst), Type_construct (rc, rlst) -> + if lc <> rc + then failwith "can't unify different constructors" + else List.map2 unify llst rlst |> ignore + | _ -> failwith "error" +;; + +let rec gen : typ -> typ = function + | Type_var { contents = Unbound name } -> Quant_type_var name + | Type_var { contents = Link ty } -> gen ty + | Type_arrow (ty1, ty2) -> Type_arrow (gen ty1, gen ty2) + | Type_tuple (t1, t2, tl) -> Type_tuple (gen t1, gen t2, List.map gen tl) + | Type_construct (c, lst) -> Type_construct (c, List.map gen lst) + | ty -> ty +;; + +type env = (ident * typ) list + +let gensym_counter = ref 0 +let reset_gensym : unit -> unit = fun () -> gensym_counter := 0 + +let gensym : unit -> string = + fun () -> + let n = !gensym_counter in + let () = incr gensym_counter in + if n < 26 then String.make 1 (Char.chr (Char.code 'a' + n)) else "t" ^ string_of_int n +;; + +let newvar () = Type_var (ref (Unbound (gensym ()))) + +let inst = + let rec loop subst = function + | Quant_type_var name -> + (match List.assoc_opt name subst with + | Some typ -> typ, subst + | None -> + let tv = newvar () in + tv, (name, tv) :: subst) + | Type_var { contents = Link ty } -> loop subst ty + | Type_arrow (t1, t2) -> + let t1', subst = loop subst t1 in + let t2', subst = loop subst t2 in + Type_arrow (t1', t2'), subst + | Type_tuple (t1, t2, tl) -> + let t1', subst = loop subst t1 in + let t2', subst = loop subst t2 in + let tl'_rev, subst = + List.fold_left + (fun (acc, subst) t -> + let t', subst = loop subst t in + t' :: acc, subst) + ([], subst) + tl + in + let tl' = List.rev tl'_rev in + Type_tuple (t1', t2', tl'), subst + | Type_construct (constr, lst) -> + let lst'_rev, subst = + List.fold_left + (fun (acc, subst) t -> + let t', subst = loop subst t in + t' :: acc, subst) + ([], subst) + lst + in + let lst' = List.rev lst'_rev in + Type_construct (constr, lst'), subst + | ty -> ty, subst + in + fun ty -> fst (loop [] ty) +;; + +let rec infer_exp env = function + | Exp_ident id -> inst (List.assoc id env) + | Exp_fun ((Pat_var id, []), exp) -> + let typ_id = newvar () in + let typ_exp = infer_exp ((id, typ_id) :: env) exp in + Type_arrow (typ_id, typ_exp) + | Exp_apply (f, arg) -> + let typ_f = infer_exp env f in + let typ_arg = infer_exp env arg in + let typ_res = newvar () in + unify typ_f (Type_arrow (typ_arg, typ_res)); + typ_res + | Exp_let (Nonrecursive, ({ pat = Pat_var id; expr }, []), exprb) -> + let typ_e = infer_exp env expr in + infer_exp ((id, gen typ_e) :: env) exprb + | _ -> failwith "infer exp not implemented" +;; diff --git a/XML/lib/middleend/inferLayers.mli b/XML/lib/middleend/inferLayers.mli new file mode 100644 index 00000000..e69de29b From ade1b8fc95dad4c058fe477c20d28a45e24d1ee4 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Fri, 27 Feb 2026 20:20:53 +0300 Subject: [PATCH 37/84] feat: add more to infer_expr, add infer_pat and pp for types --- XML/lib/middleend/inferLayers.ml | 194 ++++++++++++++++++++++++++++-- XML/lib/middleend/inferLayers.mli | 28 +++++ 2 files changed, 209 insertions(+), 13 deletions(-) diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml index 3cfc14c5..13e83468 100644 --- a/XML/lib/middleend/inferLayers.ml +++ b/XML/lib/middleend/inferLayers.ml @@ -11,11 +11,101 @@ type typ = | Type_tuple of typ List2.t | Type_var of tv ref | Quant_type_var of ident - | Type_construct of ident * typ list + | Type_construct of ident * typ list [@deriving] +[@@deriving eq, show { with_path = false }] and tv = | Unbound of ident | Link of typ +[@@deriving eq, show { with_path = false }] + +let rec pprint_type_tuple ?(poly_names_map = Base.Map.empty (module Base.String)) fmt = + let open Format in + function + | [] -> () + | [ h ] -> + (match h with + | Type_arrow (_, _) -> fprintf fmt "(%a)" (pprint_typ ~poly_names_map) h + | _ -> fprintf fmt "%a" (pprint_typ ~poly_names_map) h) + | h :: tl -> + (match h with + | Type_arrow (_, _) -> + fprintf + fmt + "(%a) * %a" + (pprint_typ ~poly_names_map) + h + (pprint_type_tuple ~poly_names_map) + tl + | _ -> + fprintf + fmt + "%a * %a" + (pprint_typ ~poly_names_map) + h + (pprint_type_tuple ~poly_names_map) + tl) + +and pprint_type_list_with_parens + ?(poly_names_map = Base.Map.empty (module Base.String)) + fmt + ty_list + = + let open Format in + let rec print_types fmt = function + | [] -> () + | [ ty ] -> (pprint_type_with_parens_if_tuple ~poly_names_map) fmt ty + | ty :: rest -> + fprintf + fmt + "%a %a" + (pprint_type_with_parens_if_tuple ~poly_names_map) + ty + print_types + rest + in + print_types fmt ty_list + +and pprint_typ fmt ?(poly_names_map = Base.Map.empty (module Base.String)) = + let open Format in + function + | Type_arrow (t1, t2) -> + fprintf + fmt + "(%a -> %a)" + (pprint_typ ~poly_names_map) + t1 + (pprint_typ ~poly_names_map) + t2 + | Type_tuple (t1, t2, tl) -> + fprintf + fmt + "(%s)" + (String.concat + " * " + (List.map + (fun t -> asprintf "%a" (pprint_typ ~poly_names_map) t) + (t1 :: t2 :: tl))) + | Type_var { contents = Unbound id } -> + (match Base.Map.find poly_names_map id with + | Some k -> fprintf fmt "'%s" k + | None -> fprintf fmt "'%s" id) + | Type_var { contents = Link t } -> pprint_typ fmt t + | Quant_type_var id -> fprintf fmt "'%s" id + | Type_construct (name, []) -> fprintf fmt "%s" name + | Type_construct (name, ty_list) -> + fprintf fmt "%a %s" (pprint_type_list_with_parens ~poly_names_map) ty_list name + +and pprint_type_with_parens_if_tuple + ?(poly_names_map = Base.Map.empty (module Base.String)) + fmt + ty + = + let open Format in + match ty with + | Type_tuple _ -> fprintf fmt "(%a)" (pprint_typ ~poly_names_map) ty + | _ -> (pprint_typ ~poly_names_map) fmt ty +;; let rec occurs_check tv = function | Type_var tv' when tv == tv' -> failwith "occurs check" @@ -44,7 +134,7 @@ let rec unify t1 t2 = List.map2 unify (l1 :: l2 :: ltl) (r1 :: r2 :: rtl) |> ignore | Type_construct (lc, llst), Type_construct (rc, rlst) -> if lc <> rc - then failwith "can't unify different constructors" + then failwith ("can't unify different constructors: " ^ lc ^ " and " ^ rc) else List.map2 unify llst rlst |> ignore | _ -> failwith "error" ;; @@ -114,20 +204,98 @@ let inst = fun ty -> fst (loop [] ty) ;; +let rec infer_pat env = function + | Pat_any -> + let fresh = newvar () in + env, fresh + | Pat_var id -> + let fresh = newvar () in + let new_env = (id, fresh) :: env in + new_env, fresh + | Pat_constant const -> + (match const with + | Const_char _ -> env, Type_construct ("char", []) + | Const_integer _ -> env, Type_construct ("int", []) + | Const_string _ -> env, Type_construct ("string", [])) + | Pat_tuple (p1, p2, ptl) -> + let new_env, ty1 = infer_pat env p1 in + let new_env1, ty2 = infer_pat new_env p2 in + let new_env2, tytl = + List.fold_left + (fun (eacc, tacc) exp -> + let curr_env, ty = infer_pat eacc exp in + curr_env, ty :: tacc) + (new_env1, []) + ptl + in + new_env2, Type_tuple (ty1, ty2, List.rev tytl) + | Pat_construct (name, pat) -> + let ty = List.assoc name env in + let inst_ty = inst ty in + (match ty, pat with + | Type_arrow (arg, body), Some p -> + let new_env, new_ty = infer_pat env p in + unify arg new_ty; + new_env, body + | _ -> env, inst_ty) + (* | Pat_constraint (p, ty) -> + let new_env, new_ty = infer_pat env p in + unify ty new_ty; + new_env, new_ty *) + | _ -> failwith "infer pat not implemented" +;; + let rec infer_exp env = function - | Exp_ident id -> inst (List.assoc id env) - | Exp_fun ((Pat_var id, []), exp) -> - let typ_id = newvar () in - let typ_exp = infer_exp ((id, typ_id) :: env) exp in - Type_arrow (typ_id, typ_exp) + | Exp_ident id -> env, inst (List.assoc id env) + | Exp_constant const -> + (match const with + | Const_char _ -> env, Type_construct ("char", []) + | Const_integer _ -> env, Type_construct ("int", []) + | Const_string _ -> env, Type_construct ("string", [])) + | Exp_fun ((pat, []), exp) -> + let new_env, typ_p = infer_pat env pat in + let new_env1, typ_exp = infer_exp new_env exp in + new_env1, Type_arrow (typ_p, typ_exp) | Exp_apply (f, arg) -> - let typ_f = infer_exp env f in - let typ_arg = infer_exp env arg in + let new_env, typ_f = infer_exp env f in + let new_env1, typ_arg = infer_exp new_env arg in let typ_res = newvar () in unify typ_f (Type_arrow (typ_arg, typ_res)); - typ_res - | Exp_let (Nonrecursive, ({ pat = Pat_var id; expr }, []), exprb) -> - let typ_e = infer_exp env expr in - infer_exp ((id, gen typ_e) :: env) exprb + new_env1, typ_res + | Exp_let (Nonrecursive, ({ pat; expr }, []), exprb) -> + let new_env, typ_p = infer_pat env pat in + let new_env1, typ_e = infer_exp new_env expr in + infer_exp new_env1 exprb + | Exp_construct (name, Some exp) -> infer_exp env (Exp_apply (Exp_ident name, exp)) + | Exp_construct (name, None) -> infer_exp env (Exp_ident name) + | Exp_tuple (e1, e2, etl) -> + let new_env, ty1 = infer_exp env e1 in + let new_env1, ty2 = infer_exp new_env e2 in + let new_env2, tytl = + List.fold_left + (fun (eacc, tacc) exp -> + let curr_env, ty = infer_exp eacc exp in + curr_env, ty :: tacc) + (new_env1, []) + etl + in + new_env2, Type_tuple (ty1, ty2, List.rev tytl) + | Exp_if (cond, the, els) -> + let new_env, ty1 = infer_exp env cond in + unify ty1 (Type_construct ("bool", [])); + let new_env1, ty2 = infer_exp new_env the in + (match els with + | None -> + unify ty2 (Type_construct ("unit", [])); + new_env1, ty2 + | Some els -> + let new_env, ty3 = infer_exp new_env1 els in + unify ty2 ty3; + new_env, ty3) + (* | Exp_constraint (exp, ty) -> + let new_env, new_ty = infer_exp env exp in + unify ty new_ty; + new_env new_ty *) + (* |Exp_match _ |Exp_function _ -> *) | _ -> failwith "infer exp not implemented" ;; diff --git a/XML/lib/middleend/inferLayers.mli b/XML/lib/middleend/inferLayers.mli index e69de29b..43e3d2a5 100644 --- a/XML/lib/middleend/inferLayers.mli +++ b/XML/lib/middleend/inferLayers.mli @@ -0,0 +1,28 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Common.Ast + +(* Need to place into Common.Ast *) +type typ = + | Type_arrow of typ * typ + | Type_tuple of typ List2.t + | Type_var of tv ref + | Quant_type_var of ident + | Type_construct of ident * typ list + +and tv = + | Unbound of ident + | Link of typ + +val show_typ : typ -> string +val show_tv : tv -> string + +val pprint_typ + : Format.formatter + -> ?poly_names_map:(ident, ident, Base.String.comparator_witness) Base.Map.t + -> typ + -> unit + +val infer_exp : (ident * typ) list -> Expression.t -> (ident * typ) list * typ From e142472e4f31f1fde565b5637f13c15148b2dcc0 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Fri, 27 Feb 2026 20:21:53 +0300 Subject: [PATCH 38/84] test: add some unit tests for infer_expr --- XML/many_tests/unit/dune | 9 ++ XML/many_tests/unit/infer.ml | 163 +++++++++++++++++++++++++++++++++++ 2 files changed, 172 insertions(+) create mode 100644 XML/many_tests/unit/dune create mode 100644 XML/many_tests/unit/infer.ml diff --git a/XML/many_tests/unit/dune b/XML/many_tests/unit/dune new file mode 100644 index 00000000..8c4b9844 --- /dev/null +++ b/XML/many_tests/unit/dune @@ -0,0 +1,9 @@ +(library + (name XML_unittests) + (public_name XML.Many_tests.Unittests) + (libraries stdio XML.Common XML.Middleend) + (preprocess + (pps ppx_expect ppx_inline_test ppx_expect)) + (instrumentation + (backend bisect_ppx)) + (inline_tests)) diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml new file mode 100644 index 00000000..83ed601c --- /dev/null +++ b/XML/many_tests/unit/infer.ml @@ -0,0 +1,163 @@ +(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Middleend.InferTypes +open Middleend.InferLayers +open Common.Ast.Constant +open Common.Ast.Expression + +(* TODO: get rid of failwith in infer *) + +let pprint_etyp env exp = + let _, ty = infer_exp env exp in + pprint_typ Format.std_formatter ty;; + +let show_etyp env exp = + let _, ty = infer_exp env exp in + Base.print_endline (show_typ ty) + +let type_bool = Type_construct ("bool", []) +let type_unit = Type_construct ("unit", []) + +(************************** Expressions **************************) + +let%expect_test "char" = + pprint_etyp [] (Exp_constant (Const_char 'a')); + [%expect {| char |}];; + + +let%expect_test "int" = + pprint_etyp[] (Exp_constant (Const_integer 1)); + [%expect {| int |}];; + + +let%expect_test "str" = + pprint_etyp [] (Exp_constant (Const_string "Kakadu")); + [%expect {| string |}];; + + + let%expect_test "id in env" = + let env = ["m", (Type_var {contents = Unbound "a"})] in + pprint_etyp env (Exp_ident "m"); + [%expect {| 'a |}];; + + let%expect_test "id not in env" = + pprint_etyp [] (Exp_ident "m"); + [%expect.unreachable] + [@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + Not_found + Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 249, characters 30-49 + Called from XML_unittests__Infer.pprint_etyp in file "many_tests/unit/infer.ml", line 13, characters 15-32 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 46, characters 1-31 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; + + +let%expect_test "tuple 2" = + pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [])); + [%expect {| (int * int) |}];; + + +let%expect_test "tuple 3" = + pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3)])); + [%expect {| (int * int * int) |}];; + + +let%expect_test "tuple 4" = + pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3); Exp_constant(Const_integer 4)])) ; + [%expect {| (int * int * int * int) |}];; + + +let%expect_test "tuples in tuple" = + pprint_etyp [] + (Exp_tuple( + Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), []), + Exp_tuple (Exp_constant (Const_integer 3), Exp_constant (Const_integer 4), []), [])); + [%expect {| ((int * int) * (int * int)) |}];; + + + let%expect_test "construct none" = + let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in + pprint_etyp env (Exp_construct ("None", None)); + [%expect {| 'a option |}] + + + let%expect_test "construct some" = + let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Quant_type_var "a"]))] in + pprint_etyp env (Exp_construct ("Some", Some (Exp_constant (Const_integer 1)))); + [%expect {| 'b option |}] + + +let%expect_test "if (not bool) then a" = + pprint_etyp [] (Exp_if (Exp_constant (Const_string "trololo"), Exp_constant (Const_integer 1), None)) +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: string and bool") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 285, characters 4-43 + Called from XML_unittests__Infer.pprint_etyp in file "many_tests/unit/infer.ml", line 13, characters 15-32 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "if (bool) then (not unit)" = + let env = ["cond", type_bool] in + pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_constant (Const_integer 1), None)); + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: int and unit") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 289, characters 7-46 + Called from XML_unittests__Infer.pprint_etyp in file "many_tests/unit/infer.ml", line 13, characters 15-32 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 112, characters 2-85 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "if (bool) then (unit)" = + let env = ["cond", type_bool; "bodyvar", type_unit] in + pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_ident "bodyvar", None)); + [%expect{| unit |}] + + +let%expect_test "if (bool) then a else a" = + let env = ["cond", type_bool] in + pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_constant (Const_integer 1), (Some (Exp_constant (Const_integer 2))))); + [%expect {| int |}] + + +let%expect_test "if (bool) then a else b" = + let env = ["cond", type_bool] in + pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_constant (Const_integer 1), (Some (Exp_constant (Const_char 'a'))))); + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: int and char") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 293, characters 7-20 + Called from XML_unittests__Infer.pprint_etyp in file "many_tests/unit/infer.ml", line 13, characters 15-32 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 141, characters 2-119 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + + +(************************** Patterns **************************) + +(************************** Mixed **************************) + + (************************** Structure items **************************) + + (************************** Programs **************************) From 711b5466e7320866417c38d5466dbdc2e02377b1 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sat, 28 Feb 2026 14:05:19 +0300 Subject: [PATCH 39/84] test: add tests for patterns, tests for exp_fun and exp_apply --- XML/lib/middleend/inferLayers.mli | 2 + XML/many_tests/unit/infer.ml | 266 +++++++++++++++++++++++++----- 2 files changed, 230 insertions(+), 38 deletions(-) diff --git a/XML/lib/middleend/inferLayers.mli b/XML/lib/middleend/inferLayers.mli index 43e3d2a5..170bde1f 100644 --- a/XML/lib/middleend/inferLayers.mli +++ b/XML/lib/middleend/inferLayers.mli @@ -25,4 +25,6 @@ val pprint_typ -> typ -> unit +val reset_gensym : unit -> unit val infer_exp : (ident * typ) list -> Expression.t -> (ident * typ) list * typ +val infer_pat : (ident * typ) list -> Pattern.t -> (ident * typ) list * typ diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index 83ed601c..58cacc9f 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -9,9 +9,23 @@ open Common.Ast.Expression (* TODO: get rid of failwith in infer *) -let pprint_etyp env exp = - let _, ty = infer_exp env exp in - pprint_typ Format.std_formatter ty;; +let inf_pprint_etyp_env ?(rst=true) env exp = + if rst then reset_gensym (); + let new_env, ty = infer_exp env exp in + pprint_typ Format.std_formatter ty; + new_env + + +let inf_pprint_ptyp_env ?(rst=true) env pat = + if rst then reset_gensym (); + let new_env, ty = infer_pat env pat in + pprint_typ Format.std_formatter ty; + new_env + +let inf_pprint_etyp ?(rst = true) env exp = inf_pprint_etyp_env ~rst env exp |> ignore + +let inf_pprint_ptyp ?(rst = true) env pat = inf_pprint_ptyp_env ~rst env pat |> ignore + let show_etyp env exp = let _, ty = infer_exp env exp in @@ -19,31 +33,34 @@ let show_etyp env exp = let type_bool = Type_construct ("bool", []) let type_unit = Type_construct ("unit", []) +let type_char = Type_construct ("char", []) +let type_int = Type_construct ("int", []) +let type_string = Type_construct ("string", []) (************************** Expressions **************************) let%expect_test "char" = - pprint_etyp [] (Exp_constant (Const_char 'a')); + inf_pprint_etyp [] (Exp_constant (Const_char 'a')); [%expect {| char |}];; let%expect_test "int" = - pprint_etyp[] (Exp_constant (Const_integer 1)); + inf_pprint_etyp [] (Exp_constant (Const_integer 1)); [%expect {| int |}];; let%expect_test "str" = - pprint_etyp [] (Exp_constant (Const_string "Kakadu")); + inf_pprint_etyp [] (Exp_constant (Const_string "Kakadu")); [%expect {| string |}];; let%expect_test "id in env" = let env = ["m", (Type_var {contents = Unbound "a"})] in - pprint_etyp env (Exp_ident "m"); + inf_pprint_etyp env (Exp_ident "m"); [%expect {| 'a |}];; let%expect_test "id not in env" = - pprint_etyp [] (Exp_ident "m"); + inf_pprint_etyp [] (Exp_ident "m"); [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -53,28 +70,29 @@ let%expect_test "str" = Not_found Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 249, characters 30-49 - Called from XML_unittests__Infer.pprint_etyp in file "many_tests/unit/infer.ml", line 13, characters 15-32 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 46, characters 1-31 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 63, characters 1-35 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; let%expect_test "tuple 2" = - pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [])); + inf_pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [])); [%expect {| (int * int) |}];; let%expect_test "tuple 3" = - pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3)])); + inf_pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3)])); [%expect {| (int * int * int) |}];; let%expect_test "tuple 4" = - pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3); Exp_constant(Const_integer 4)])) ; + inf_pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3); Exp_constant(Const_integer 4)])) ; [%expect {| (int * int * int * int) |}];; let%expect_test "tuples in tuple" = - pprint_etyp [] + inf_pprint_etyp [] (Exp_tuple( Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), []), Exp_tuple (Exp_constant (Const_integer 3), Exp_constant (Const_integer 4), []), [])); @@ -83,18 +101,18 @@ let%expect_test "tuples in tuple" = let%expect_test "construct none" = let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in - pprint_etyp env (Exp_construct ("None", None)); + inf_pprint_etyp env (Exp_construct ("None", None)); [%expect {| 'a option |}] let%expect_test "construct some" = let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Quant_type_var "a"]))] in - pprint_etyp env (Exp_construct ("Some", Some (Exp_constant (Const_integer 1)))); - [%expect {| 'b option |}] + inf_pprint_etyp env (Exp_construct ("Some", Some (Exp_constant (Const_integer 1)))); + [%expect {| 'a option |}] -let%expect_test "if (not bool) then a" = - pprint_etyp [] (Exp_if (Exp_constant (Const_string "trololo"), Exp_constant (Const_integer 1), None)) +let%expect_test "if (string) " = + inf_pprint_etyp [] (Exp_if (Exp_constant (Const_string "trololo"), Exp_constant (Const_integer 1), None)) [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. This is strongly discouraged as backtraces are fragile. @@ -102,14 +120,16 @@ let%expect_test "if (not bool) then a" = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 285, characters 4-43 - Called from XML_unittests__Infer.pprint_etyp in file "many_tests/unit/infer.ml", line 13, characters 15-32 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 288, characters 4-43 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 115, characters 2-107 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "if (bool) then (not unit)" = let env = ["cond", type_bool] in - pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_constant (Const_integer 1), None)); + inf_pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_constant (Const_integer 1), None)); [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -118,46 +138,216 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 289, characters 7-46 - Called from XML_unittests__Infer.pprint_etyp in file "many_tests/unit/infer.ml", line 13, characters 15-32 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 112, characters 2-85 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 292, characters 7-46 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 132, characters 2-89 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "if (bool) then (unit)" = let env = ["cond", type_bool; "bodyvar", type_unit] in - pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_ident "bodyvar", None)); + inf_pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_ident "bodyvar", None)); [%expect{| unit |}] -let%expect_test "if (bool) then a else a" = - let env = ["cond", type_bool] in - pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_constant (Const_integer 1), (Some (Exp_constant (Const_integer 2))))); - [%expect {| int |}] +let%expect_test "if (bool) then 'a else 'a" = + let env = ["cond", type_bool; "x", Type_var {contents = Unbound "a"}; "y", Type_var {contents = Unbound "a"}] in + inf_pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_ident "x", (Some (Exp_ident "y")))); + [%expect{| 'a |}] -let%expect_test "if (bool) then a else b" = - let env = ["cond", type_bool] in - pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_constant (Const_integer 1), (Some (Exp_constant (Const_char 'a'))))); +let%expect_test "if (bool) then 'a else 'b" = + let env = ["cond", type_bool; "x", Type_var {contents = Unbound "a"}; "y", Type_var {contents = Unbound "b"}] in + inf_pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_ident "x", (Some (Exp_ident "y")))); + [%expect{| 'b |}] + + +let%expect_test "apply int -> int to int" = + let env = ["f", Type_arrow (type_int, type_int); "x", type_int] in + inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ); + [%expect{| int |}] + + +let%expect_test "apply int -> int to string" = + let env = ["f", Type_arrow (type_int, type_int); "x", type_string] in + inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ); + [%expect.unreachable] + [@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: int and string") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 263, characters 4-47 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 174, characters 2-65 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "apply 'a -> 'a to 'b" = + let env = ["f", Type_arrow (Type_var {contents = Unbound "s"}, Type_var {contents = Unbound "s"}); "x", Type_var {contents = Unbound "t"}] in + inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ) ~rst:false; + [%expect{| 'b |}] + + + +let%expect_test "apply 'a to 'a (different vars)" = + let env = ["f", Type_var {contents = Unbound "t"}; "x", Type_var {contents = Unbound "t"}] in + inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ) ~rst:false; + [%expect {| 'c |}] + +(* +let%expect_test "apply 'a to 'a (same var)" = + let env = ["x", Type_var {contents = Unbound "t"}] in + inf_pprint_etyp env (Exp_apply (Exp_ident "x", Exp_ident "x") ) ~rst:false; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. This is strongly discouraged as backtraces are fragile. Please change this test to not include a backtrace. *) - (Failure "can't unify different constructors: int and char") + (Failure "occurs check") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 293, characters 7-20 - Called from XML_unittests__Infer.pprint_etyp in file "many_tests/unit/infer.ml", line 13, characters 15-32 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 141, characters 2-119 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 114, characters 4-22 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 128, characters 4-22 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 263, characters 4-47 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 42-74 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 178, characters 2-76 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] *) +(* +let%expect_test "apply 'a to 'b" = + let env = ["f", Type_var {contents = Unbound "s"}; "x", Type_var {contents = Unbound "t"}] in + inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ) ~rst:false; + [%expect{| 'd |}] *) (************************** Patterns **************************) + let%expect_test "id in env" = + let env = ["m", (Type_var {contents = Unbound "c"})] in + inf_pprint_ptyp env (Pat_var "m"); + [%expect {| 'a |}];; + + + let%expect_test "id not in env" = + inf_pprint_ptyp [] (Pat_var "m"); + [%expect {| 'a |}];; + + + let%expect_test "any" = + inf_pprint_ptyp [] (Pat_any); + [%expect {| 'a |}];; + + +let%expect_test "char" = + inf_pprint_ptyp [] (Pat_constant (Const_char 'a')); + [%expect {| char |}];; + + +let%expect_test "int" = + inf_pprint_ptyp[] (Pat_constant (Const_integer 1)); + [%expect {| int |}];; + + +let%expect_test "str" = + inf_pprint_ptyp [] (Pat_constant (Const_string "Kakadu")); + [%expect {| string |}];; + + +let%expect_test "tuple 2" = + inf_pprint_ptyp [] (Pat_tuple (Pat_constant (Const_integer 1), Pat_constant (Const_integer 2), [])); + [%expect {| (int * int) |}];; + + +let%expect_test "tuple 3" = + inf_pprint_ptyp [] (Pat_tuple (Pat_constant (Const_integer 1), Pat_constant (Const_integer 2), [Pat_constant (Const_integer 3)])); + [%expect {| (int * int * int) |}];; + + +let%expect_test "tuple 4" = + inf_pprint_ptyp [] (Pat_tuple (Pat_constant (Const_integer 1), Pat_constant (Const_integer 2), [Pat_constant (Const_integer 3); Pat_constant(Const_integer 4)])) ; + [%expect {| (int * int * int * int) |}];; + + +let%expect_test "tuples in tuple" = + inf_pprint_ptyp [] + (Pat_tuple( + Pat_tuple (Pat_constant (Const_integer 1), Pat_constant (Const_integer 2), []), + Pat_tuple (Pat_constant (Const_integer 3), Pat_constant (Const_integer 4), []), [])); + [%expect {| ((int * int) * (int * int)) |}];; + + + let%expect_test "construct none" = + let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in + inf_pprint_ptyp env (Pat_construct ("None", None)); + [%expect {| 'a option |}] + + + let%expect_test "construct some" = + let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Quant_type_var "n"]))] in + inf_pprint_ptyp env (Pat_construct ("Some", Some (Pat_constant (Const_integer 1)))); + [%expect {| 'n option |}] + + (************************** Mixed **************************) +let%expect_test "fun 'a -> 'a (new var)" = + inf_pprint_etyp [] (Exp_fun ((Pat_var "x", []), Exp_ident "x")); + [%expect {| ('a -> 'a) |}] + + +let%expect_test "fun 'a -> 'a (shadow)" = + inf_pprint_etyp ["x", Type_var {contents = Unbound "type 's"}] (Exp_fun ((Pat_var "x", []), Exp_ident "x")); + [%expect {| ('a -> 'a) |}] + + +let%expect_test "fun 'a -> 'b (not in env)" = + inf_pprint_etyp [] (Exp_fun ((Pat_var "x", []), Exp_ident "y")); + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + Not_found + Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 249, characters 30-49 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 257, characters 28-49 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 311, characters 1-64 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "fun 'a -> 'b (in env)" = + inf_pprint_etyp ["y", Type_var {contents = Unbound "s"}] (Exp_fun ((Pat_var "x", []), Exp_ident "y")); + [%expect{| ('a -> 's) |}] + + + (* does not halt! *) +(* let%expect_test "fun x -> fun y -> x y;;" = + inf_pprint_etyp [] (Exp_fun((Pat_var "x", []), Exp_fun((Pat_var "y", []), Exp_apply(Exp_ident "x", Exp_ident "y")))); + [%expect{| 'a |}] *) + + + (* TODO *) + (* let%expect_test {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |} = + inf_pprint_etyp [] (Exp_ident "a"); + [%expect.unreachable] + *) + (************************** Structure items **************************) (************************** Programs **************************) +(* + план такой: дописать тесты на все, что реализовано выше, исправить по необходимости. + затем доделать инфер c failwith и без левелов. + затем добавить левелы. проверить, что тесты не провалились. добавить тесты на то, что левелы работают (со странички и из презы) + затем заменить старый инфер на новый. + затем попытаться убрать failwith, заменяя монадами. *) \ No newline at end of file From b9b672726edbb100311890bdee831d7b82bd566d Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sat, 28 Feb 2026 14:45:51 +0300 Subject: [PATCH 40/84] fix: recursion, very naughty typo --- XML/lib/middleend/inferLayers.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml index 13e83468..6caf0799 100644 --- a/XML/lib/middleend/inferLayers.ml +++ b/XML/lib/middleend/inferLayers.ml @@ -126,7 +126,7 @@ let rec unify t1 t2 = | Type_var ({ contents = Unbound _ } as tv), t' | t', Type_var ({ contents = Unbound _ } as tv) -> occurs_check tv t'; - tv := Link t1 + tv := Link t' | Type_arrow (l1, l2), Type_arrow (r1, r2) -> unify l1 r1; unify l2 r2 From 94f88b6fe2e677246a001d7f626b392bddbdb9e7 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sat, 28 Feb 2026 18:07:26 +0300 Subject: [PATCH 41/84] feat: add infer for let nonrec with tests, improve fail messages --- XML/lib/middleend/inferLayers.ml | 50 +++++--- XML/many_tests/unit/infer.ml | 193 ++++++++++++++++++++++++------- 2 files changed, 189 insertions(+), 54 deletions(-) diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml index 6caf0799..4dbe03cd 100644 --- a/XML/lib/middleend/inferLayers.ml +++ b/XML/lib/middleend/inferLayers.ml @@ -131,20 +131,27 @@ let rec unify t1 t2 = unify l1 r1; unify l2 r2 | Type_tuple (l1, l2, ltl), Type_tuple (r1, r2, rtl) -> + if List.length ltl <> List.length rtl + then failwith "cannot unify tuple types of different size"; List.map2 unify (l1 :: l2 :: ltl) (r1 :: r2 :: rtl) |> ignore | Type_construct (lc, llst), Type_construct (rc, rlst) -> if lc <> rc then failwith ("can't unify different constructors: " ^ lc ^ " and " ^ rc) else List.map2 unify llst rlst |> ignore - | _ -> failwith "error" + | Quant_type_var _, _ | _, Quant_type_var _ -> + failwith "cannot unify with a quantified type" + | _ -> failwith "cannot unify types" ;; -let rec gen : typ -> typ = function +(* | _ -> failwith "error" *) + +let rec generalize : typ -> typ = function | Type_var { contents = Unbound name } -> Quant_type_var name - | Type_var { contents = Link ty } -> gen ty - | Type_arrow (ty1, ty2) -> Type_arrow (gen ty1, gen ty2) - | Type_tuple (t1, t2, tl) -> Type_tuple (gen t1, gen t2, List.map gen tl) - | Type_construct (c, lst) -> Type_construct (c, List.map gen lst) + | Type_var { contents = Link ty } -> generalize ty + | Type_arrow (ty1, ty2) -> Type_arrow (generalize ty1, generalize ty2) + | Type_tuple (t1, t2, tl) -> + Type_tuple (generalize t1, generalize t2, List.map generalize tl) + | Type_construct (c, lst) -> Type_construct (c, List.map generalize lst) | ty -> ty ;; @@ -245,27 +252,33 @@ let rec infer_pat env = function | _ -> failwith "infer pat not implemented" ;; -let rec infer_exp env = function +let rec infer_vb env { pat; expr } = + let new_env, typ_p = infer_pat env pat in + let new_env1, typ_e = infer_exp new_env expr in + unify typ_p (generalize typ_e); + new_env1 + +and infer_exp env = function | Exp_ident id -> env, inst (List.assoc id env) | Exp_constant const -> (match const with | Const_char _ -> env, Type_construct ("char", []) | Const_integer _ -> env, Type_construct ("int", []) | Const_string _ -> env, Type_construct ("string", [])) - | Exp_fun ((pat, []), exp) -> + | Exp_fun ((pat, pats), exp) -> let new_env, typ_p = infer_pat env pat in - let new_env1, typ_exp = infer_exp new_env exp in - new_env1, Type_arrow (typ_p, typ_exp) + let newest_env, typ_exp = + match pats with + | hd :: tl -> infer_exp new_env (Exp_fun ((hd, tl), exp)) + | [] -> infer_exp new_env exp + in + newest_env, Type_arrow (typ_p, typ_exp) | Exp_apply (f, arg) -> let new_env, typ_f = infer_exp env f in let new_env1, typ_arg = infer_exp new_env arg in let typ_res = newvar () in unify typ_f (Type_arrow (typ_arg, typ_res)); new_env1, typ_res - | Exp_let (Nonrecursive, ({ pat; expr }, []), exprb) -> - let new_env, typ_p = infer_pat env pat in - let new_env1, typ_e = infer_exp new_env expr in - infer_exp new_env1 exprb | Exp_construct (name, Some exp) -> infer_exp env (Exp_apply (Exp_ident name, exp)) | Exp_construct (name, None) -> infer_exp env (Exp_ident name) | Exp_tuple (e1, e2, etl) -> @@ -292,6 +305,12 @@ let rec infer_exp env = function let new_env, ty3 = infer_exp new_env1 els in unify ty2 ty3; new_env, ty3) + | Exp_let (Nonrecursive, (vb, vbs), exprb) -> + let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in + infer_exp new_env exprb + | Exp_let (Recursive, (vb, vbs), exprb) -> + let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in + infer_exp new_env exprb (* | Exp_constraint (exp, ty) -> let new_env, new_ty = infer_exp env exp in unify ty new_ty; @@ -299,3 +318,6 @@ let rec infer_exp env = function (* |Exp_match _ |Exp_function _ -> *) | _ -> failwith "infer exp not implemented" ;; + +(* нужно реализовать матчи, фанкшены, леты. затем протестить, +что все работает, как надо, затем добавлять левела *) diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index 58cacc9f..ff2f3adc 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -69,10 +69,10 @@ let%expect_test "str" = Not_found Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 249, characters 30-49 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 63, characters 1-35 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 262, characters 30-49 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 71, characters 1-35 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; @@ -120,10 +120,10 @@ let%expect_test "if (string) " = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 288, characters 4-43 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 115, characters 2-107 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 298, characters 4-43 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 123, characters 2-107 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -138,10 +138,10 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 292, characters 7-46 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 132, characters 2-89 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 302, characters 7-46 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 140, characters 2-89 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -181,10 +181,10 @@ let%expect_test "apply int -> int to string" = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 263, characters 4-47 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 174, characters 2-65 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 182, characters 2-65 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -194,13 +194,13 @@ let%expect_test "apply 'a -> 'a to 'b" = [%expect{| 'b |}] - + (* not sure if this is right *) let%expect_test "apply 'a to 'a (different vars)" = let env = ["f", Type_var {contents = Unbound "t"}; "x", Type_var {contents = Unbound "t"}] in inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ) ~rst:false; [%expect {| 'c |}] -(* + let%expect_test "apply 'a to 'a (same var)" = let env = ["x", Type_var {contents = Unbound "t"}] in inf_pprint_etyp env (Exp_apply (Exp_ident "x", Exp_ident "x") ) ~rst:false; @@ -214,17 +214,17 @@ let%expect_test "apply 'a to 'a (same var)" = Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 114, characters 4-22 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 128, characters 4-22 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 263, characters 4-47 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 42-74 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 178, characters 2-76 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] *) + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 214, characters 2-76 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + -(* let%expect_test "apply 'a to 'b" = let env = ["f", Type_var {contents = Unbound "s"}; "x", Type_var {contents = Unbound "t"}] in inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ) ~rst:false; - [%expect{| 'd |}] *) + [%expect{| 'e |}] (************************** Patterns **************************) @@ -295,7 +295,7 @@ let%expect_test "tuples in tuple" = [%expect {| 'n option |}] -(************************** Mixed **************************) +(************************** Funs **************************) let%expect_test "fun 'a -> 'a (new var)" = inf_pprint_etyp [] (Exp_fun ((Pat_var "x", []), Exp_ident "x")); @@ -317,11 +317,11 @@ let%expect_test "fun 'a -> 'b (not in env)" = Not_found Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 249, characters 30-49 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 257, characters 28-49 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 14, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 25, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 311, characters 1-64 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 262, characters 30-49 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 273, characters 14-35 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 319, characters 1-64 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -330,21 +330,134 @@ let%expect_test "fun 'a -> 'b (in env)" = [%expect{| ('a -> 's) |}] - (* does not halt! *) -(* let%expect_test "fun x -> fun y -> x y;;" = +let%expect_test "fun x -> fun y -> x y;;" = inf_pprint_etyp [] (Exp_fun((Pat_var "x", []), Exp_fun((Pat_var "y", []), Exp_apply(Exp_ident "x", Exp_ident "y")))); - [%expect{| 'a |}] *) + [%expect{| (('b -> 'c) -> ('b -> 'c)) |}] + + +let%expect_test "fun x y -> x y;;" = + inf_pprint_etyp [] (Exp_fun((Pat_var "x", [Pat_var "y"]), Exp_apply(Exp_ident "x", Exp_ident "y"))); + [%expect{| (('b -> 'c) -> ('b -> 'c)) |}] + + +let%expect_test {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |} = + inf_pprint_etyp [] + (Exp_apply + (Exp_apply( + (Exp_apply + (Exp_fun ((Pat_var "f", [Pat_var "a"; Pat_var "b"]), Exp_tuple (Exp_apply (Exp_ident "f", Exp_ident "a"), Exp_apply (Exp_ident "f", Exp_ident "b"), [])), + Exp_fun ((Pat_var "x", []), Exp_ident "x"))), + Exp_constant (Const_integer 1)), + Exp_constant (Const_string "mystr"))); + [%expect.unreachable] + [@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: int and string") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 352, characters 2-366 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +(************************** Let in **************************) + +let%expect_test "let 1 = 1 in 2" = + inf_pprint_etyp [] (Exp_let (Nonrecursive, ({pat = Pat_constant (Const_integer 1); expr = Exp_constant (Const_integer 1)}, []), Exp_constant (Const_integer 2))); + [%expect{| int |}] + + +let%expect_test "let _ = 1 in 2" = + inf_pprint_etyp [] (Exp_let (Nonrecursive, ({pat = Pat_any; expr = Exp_constant (Const_integer 1)}, []), Exp_constant (Const_integer 2))); + [%expect{| int |}] + + +let%expect_test "let a = 1 in a" = + inf_pprint_etyp [] (Exp_let (Nonrecursive, ({pat = Pat_var "a"; expr = Exp_constant (Const_integer 1)}, []), Exp_ident "a")); + [%expect{| int |}] + + +let%expect_test {| let a = 1 in "str" |} = + inf_pprint_etyp [] (Exp_let (Nonrecursive, ({pat = Pat_var "a"; expr = Exp_constant (Const_integer 1)}, []), Exp_constant (Const_string "str"))); + [%expect{| string |}] + +let%expect_test {| let a = fun x -> x in a |} = + inf_pprint_etyp [] (Exp_let (Nonrecursive, + ({pat = Pat_var "a"; expr = Exp_fun ((Pat_var "x", []), Exp_ident "x")}, []), Exp_ident "a")); + [%expect{| ('c -> 'c) |}] - (* TODO *) - (* let%expect_test {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |} = - inf_pprint_etyp [] (Exp_ident "a"); + +let%expect_test {| let a = fun x -> x in (a 1, a "str") |} = + inf_pprint_etyp [] (Exp_let (Nonrecursive, + ({pat = Pat_var "a"; expr = Exp_fun ((Pat_var "x", []), Exp_ident "x")}, []), + Exp_tuple(Exp_apply(Exp_ident "a", Exp_constant (Const_integer 1)), + Exp_apply (Exp_ident "a", Exp_constant (Const_string "str")), []))); + [%expect{| (int * string) |}] + + +let%expect_test {| let a, b = 1, 2 in a |} = + inf_pprint_etyp [] (Exp_let (Nonrecursive, + ({pat = Pat_tuple (Pat_var "a", Pat_var "b", []); expr = Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [])}, []), Exp_ident "a")); + [%expect{| int |}] + + +let%expect_test {| let a, b, c = 1, 2 in a |} = + inf_pprint_etyp [] (Exp_let (Nonrecursive, + ({pat = Pat_tuple (Pat_var "a", Pat_var "b", [Pat_var "c"]); expr = Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [])}, []), Exp_ident "a")); [%expect.unreachable] - *) +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "cannot unify tuple types of different size") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 135, characters 9-62 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 258, characters 2-32 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 309, characters 18-84 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 420, characters 2-216 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + + let%expect_test {| let a, b = 1, 2, 3 in a |} = + inf_pprint_etyp [] (Exp_let (Nonrecursive, + ({pat = Pat_tuple (Pat_var "a", Pat_var "b", []); expr = Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3)])}, []), Exp_ident "a")); + [%expect.unreachable] + [@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "cannot unify tuple types of different size") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 135, characters 9-62 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 258, characters 2-32 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 309, characters 18-84 + Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 + Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 440, characters 2-235 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test {| let a = 1 and b = "punk" in b |} = + inf_pprint_etyp [] (Exp_let (Nonrecursive, + ({pat = Pat_var "a"; expr = Exp_constant (Const_integer 1)}, + [{pat = Pat_var "b"; expr = Exp_constant (Const_string "punk")}]), Exp_ident "b")); + [%expect{| string |}] - (************************** Structure items **************************) +(************************** Structure items **************************) - (************************** Programs **************************) +(************************** Programs **************************) (* план такой: дописать тесты на все, что реализовано выше, исправить по необходимости. затем доделать инфер c failwith и без левелов. From 3c317cc37437b42e8277b89b07fbd6356ebb7d64 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sat, 28 Feb 2026 18:38:24 +0300 Subject: [PATCH 42/84] feat: add fun to make test writing easier --- XML/lib/common/parser.ml | 8 + XML/lib/common/parser.mli | 2 + XML/many_tests/unit/infer.ml | 295 ++++++++++++++++------------------- 3 files changed, 143 insertions(+), 162 deletions(-) diff --git a/XML/lib/common/parser.ml b/XML/lib/common/parser.ml index 55bcd7ef..3da21a32 100644 --- a/XML/lib/common/parser.ml +++ b/XML/lib/common/parser.ml @@ -619,5 +619,13 @@ let pstructure = sep_by psemicolon pstr_item <* psemicolon <* pass_ws ;; +let parse_exp_str str = + parse_string ~consume:All (pass_ws *> pexpr <* pass_ws) str |> Result.ok_or_failwith +;; + +let parse_pat_str str = + parse_string ~consume:All (pass_ws *> ppattern <* pass_ws) str |> Result.ok_or_failwith +;; + let parse str = parse_string ~consume:All pstructure str let parse_str str = parse str |> Result.ok_or_failwith diff --git a/XML/lib/common/parser.mli b/XML/lib/common/parser.mli index ceac05ff..3b77d055 100644 --- a/XML/lib/common/parser.mli +++ b/XML/lib/common/parser.mli @@ -6,6 +6,8 @@ open Ast val parse : string -> (program, string) result val parse_str : string -> program +val parse_exp_str : string -> Expression.t +val parse_pat_str : string -> Pattern.t val pass_ws : unit Angstrom.t val pass_ws1 : unit Angstrom.t val token : string -> string Angstrom.t diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index ff2f3adc..e12a805f 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -2,30 +2,24 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open Middleend.InferTypes open Middleend.InferLayers open Common.Ast.Constant open Common.Ast.Expression +open Common.Parser (* TODO: get rid of failwith in infer *) -let inf_pprint_etyp_env ?(rst=true) env exp = +let infer_exp_str ?(rst = true) ?(env = []) str = + let exp = parse_exp_str str in if rst then reset_gensym (); - let new_env, ty = infer_exp env exp in - pprint_typ Format.std_formatter ty; - new_env - + let _, ty = infer_exp env exp in + pprint_typ Format.std_formatter ty;; -let inf_pprint_ptyp_env ?(rst=true) env pat = +let infer_pat_str ?(rst = true) ?(env = []) str = + let pat = parse_pat_str str in if rst then reset_gensym (); - let new_env, ty = infer_pat env pat in - pprint_typ Format.std_formatter ty; - new_env - -let inf_pprint_etyp ?(rst = true) env exp = inf_pprint_etyp_env ~rst env exp |> ignore - -let inf_pprint_ptyp ?(rst = true) env pat = inf_pprint_ptyp_env ~rst env pat |> ignore - + let _, ty = infer_pat env pat in + pprint_typ Format.std_formatter ty;; let show_etyp env exp = let _, ty = infer_exp env exp in @@ -40,27 +34,27 @@ let type_string = Type_construct ("string", []) (************************** Expressions **************************) let%expect_test "char" = - inf_pprint_etyp [] (Exp_constant (Const_char 'a')); - [%expect {| char |}];; + infer_exp_str {| 'a' |}; + [%expect{| char |}] let%expect_test "int" = - inf_pprint_etyp [] (Exp_constant (Const_integer 1)); - [%expect {| int |}];; + infer_exp_str {| 1 |}; + [%expect{| int |}] let%expect_test "str" = - inf_pprint_etyp [] (Exp_constant (Const_string "Kakadu")); - [%expect {| string |}];; + infer_exp_str {| "Kakadu" |}; + [%expect{| string |}] - let%expect_test "id in env" = - let env = ["m", (Type_var {contents = Unbound "a"})] in - inf_pprint_etyp env (Exp_ident "m"); - [%expect {| 'a |}];; +let%expect_test "id in env" = + infer_exp_str {| m |} ~env:[("m", Type_var {contents = Unbound "a"})]; + [%expect{| 'a |}] - let%expect_test "id not in env" = - inf_pprint_etyp [] (Exp_ident "m"); + +let%expect_test "id not in env" = + infer_exp_str {| m |}; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -70,50 +64,46 @@ let%expect_test "str" = Not_found Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 262, characters 30-49 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 71, characters 1-35 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 76, characters 2-23 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; let%expect_test "tuple 2" = - inf_pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [])); - [%expect {| (int * int) |}];; + infer_exp_str {| (1, 2) |}; + [%expect{| (int * int) |}] let%expect_test "tuple 3" = - inf_pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3)])); - [%expect {| (int * int * int) |}];; + infer_exp_str {| (1, 2, 3) |}; + [%expect{| (int * int * int) |}] -let%expect_test "tuple 4" = - inf_pprint_etyp [] (Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3); Exp_constant(Const_integer 4)])) ; - [%expect {| (int * int * int * int) |}];; + let%expect_test "tuple 4" = + infer_exp_str {| (1, 2, 3, 4) |}; + [%expect{| (int * int * int * int) |}] let%expect_test "tuples in tuple" = - inf_pprint_etyp [] - (Exp_tuple( - Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), []), - Exp_tuple (Exp_constant (Const_integer 3), Exp_constant (Const_integer 4), []), [])); - [%expect {| ((int * int) * (int * int)) |}];; + infer_exp_str {| ((1, 2), (3, 4)) |}; + [%expect{| ((int * int) * (int * int)) |}] let%expect_test "construct none" = - let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in - inf_pprint_etyp env (Exp_construct ("None", None)); + let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in + infer_exp_str {| None |} ~env: env; [%expect {| 'a option |}] - let%expect_test "construct some" = +let%expect_test "construct some" = let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Quant_type_var "a"]))] in - inf_pprint_etyp env (Exp_construct ("Some", Some (Exp_constant (Const_integer 1)))); + infer_exp_str {| Some 1 |} ~env: env; [%expect {| 'a option |}] let%expect_test "if (string) " = - inf_pprint_etyp [] (Exp_if (Exp_constant (Const_string "trololo"), Exp_constant (Const_integer 1), None)) -[@@expect.uncaught_exn {| + infer_exp_str {| if "trololo" then 1 |}; + [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. This is strongly discouraged as backtraces are fragile. Please change this test to not include a backtrace. *) @@ -121,15 +111,13 @@ let%expect_test "if (string) " = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 298, characters 4-43 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 123, characters 2-107 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "if (bool) then (not unit)" = let env = ["cond", type_bool] in - inf_pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_constant (Const_integer 1), None)); + infer_exp_str {| if cond then 1 |} ~env: env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -139,39 +127,38 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 302, characters 7-46 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 140, characters 2-89 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 142, characters 2-46 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "if (bool) then (unit)" = let env = ["cond", type_bool; "bodyvar", type_unit] in - inf_pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_ident "bodyvar", None)); + infer_exp_str {| if cond then bodyvar |} ~env: env; [%expect{| unit |}] let%expect_test "if (bool) then 'a else 'a" = let env = ["cond", type_bool; "x", Type_var {contents = Unbound "a"}; "y", Type_var {contents = Unbound "a"}] in - inf_pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_ident "x", (Some (Exp_ident "y")))); + infer_exp_str {| if cond then x else y |} ~env: env; [%expect{| 'a |}] let%expect_test "if (bool) then 'a else 'b" = let env = ["cond", type_bool; "x", Type_var {contents = Unbound "a"}; "y", Type_var {contents = Unbound "b"}] in - inf_pprint_etyp env (Exp_if ((Exp_ident "cond"), Exp_ident "x", (Some (Exp_ident "y")))); + infer_exp_str {| if cond then x else y |} ~env: env; [%expect{| 'b |}] let%expect_test "apply int -> int to int" = let env = ["f", Type_arrow (type_int, type_int); "x", type_int] in - inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ); + infer_exp_str {| f x |} ~env: env; [%expect{| int |}] let%expect_test "apply int -> int to string" = let env = ["f", Type_arrow (type_int, type_int); "x", type_string] in - inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ); + infer_exp_str {| f x |} ~env: env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -182,28 +169,27 @@ let%expect_test "apply int -> int to string" = Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 182, characters 2-65 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 184, characters 2-35 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "apply 'a -> 'a to 'b" = let env = ["f", Type_arrow (Type_var {contents = Unbound "s"}, Type_var {contents = Unbound "s"}); "x", Type_var {contents = Unbound "t"}] in - inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ) ~rst:false; + infer_exp_str {| f x |} ~env: env ~rst: false; [%expect{| 'b |}] (* not sure if this is right *) let%expect_test "apply 'a to 'a (different vars)" = let env = ["f", Type_var {contents = Unbound "t"}; "x", Type_var {contents = Unbound "t"}] in - inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ) ~rst:false; + infer_exp_str {| f x |} ~env: env ~rst: false; [%expect {| 'c |}] let%expect_test "apply 'a to 'a (same var)" = let env = ["x", Type_var {contents = Unbound "t"}] in - inf_pprint_etyp env (Exp_apply (Exp_ident "x", Exp_ident "x") ) ~rst:false; + infer_exp_str {| x x |} ~env: env ~rst: false; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -215,100 +201,98 @@ let%expect_test "apply 'a to 'a (same var)" = Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 114, characters 4-22 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 128, characters 4-22 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 214, characters 2-76 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 216, characters 2-47 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "apply 'a to 'b" = let env = ["f", Type_var {contents = Unbound "s"}; "x", Type_var {contents = Unbound "t"}] in - inf_pprint_etyp env (Exp_apply (Exp_ident "f", Exp_ident "x") ) ~rst:false; + infer_exp_str {| f x |} ~env: env ~rst: false; [%expect{| 'e |}] (************************** Patterns **************************) - let%expect_test "id in env" = - let env = ["m", (Type_var {contents = Unbound "c"})] in - inf_pprint_ptyp env (Pat_var "m"); - [%expect {| 'a |}];; +let%expect_test "id in env" = + let env = ["m", (Type_var {contents = Unbound "c"})] in + infer_pat_str {| m |} ~env: env; + [%expect {| 'a |}];; - let%expect_test "id not in env" = - inf_pprint_ptyp [] (Pat_var "m"); - [%expect {| 'a |}];; +let%expect_test "id not in env" = + infer_pat_str {| m |}; + [%expect {| 'a |}];; - let%expect_test "any" = - inf_pprint_ptyp [] (Pat_any); - [%expect {| 'a |}];; +let%expect_test "any" = + infer_pat_str {| _ |}; + [%expect {| 'a |}];; let%expect_test "char" = - inf_pprint_ptyp [] (Pat_constant (Const_char 'a')); - [%expect {| char |}];; + infer_pat_str {| 'a' |}; + [%expect {| char |}];; let%expect_test "int" = - inf_pprint_ptyp[] (Pat_constant (Const_integer 1)); - [%expect {| int |}];; + infer_pat_str {| 1 |}; + [%expect {| int |}];; let%expect_test "str" = - inf_pprint_ptyp [] (Pat_constant (Const_string "Kakadu")); - [%expect {| string |}];; + infer_pat_str {| "kakadu" |}; + [%expect {| string |}];; let%expect_test "tuple 2" = - inf_pprint_ptyp [] (Pat_tuple (Pat_constant (Const_integer 1), Pat_constant (Const_integer 2), [])); - [%expect {| (int * int) |}];; + infer_pat_str {| (1, 2) |}; + [%expect {| (int * int) |}];; let%expect_test "tuple 3" = - inf_pprint_ptyp [] (Pat_tuple (Pat_constant (Const_integer 1), Pat_constant (Const_integer 2), [Pat_constant (Const_integer 3)])); - [%expect {| (int * int * int) |}];; + infer_pat_str {| (1, 2, 3) |}; + [%expect {| (int * int * int) |}];; let%expect_test "tuple 4" = - inf_pprint_ptyp [] (Pat_tuple (Pat_constant (Const_integer 1), Pat_constant (Const_integer 2), [Pat_constant (Const_integer 3); Pat_constant(Const_integer 4)])) ; - [%expect {| (int * int * int * int) |}];; + infer_pat_str {| (1, 2, 3, 4) |}; + [%expect {| (int * int * int * int) |}];; let%expect_test "tuples in tuple" = - inf_pprint_ptyp [] - (Pat_tuple( - Pat_tuple (Pat_constant (Const_integer 1), Pat_constant (Const_integer 2), []), - Pat_tuple (Pat_constant (Const_integer 3), Pat_constant (Const_integer 4), []), [])); - [%expect {| ((int * int) * (int * int)) |}];; + infer_pat_str {| ((1, 2), (3, 4)) |}; + [%expect {| ((int * int) * (int * int)) |}];; - let%expect_test "construct none" = - let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in - inf_pprint_ptyp env (Pat_construct ("None", None)); - [%expect {| 'a option |}] +let%expect_test "construct none" = + let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in + infer_pat_str {| None |} ~env: env; + [%expect {| 'a option |}] let%expect_test "construct some" = - let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Quant_type_var "n"]))] in - inf_pprint_ptyp env (Pat_construct ("Some", Some (Pat_constant (Const_integer 1)))); + let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, + Type_construct("option", [Quant_type_var "n"]))] in + infer_pat_str {| Some 1 |} ~env: env; [%expect {| 'n option |}] (************************** Funs **************************) let%expect_test "fun 'a -> 'a (new var)" = - inf_pprint_etyp [] (Exp_fun ((Pat_var "x", []), Exp_ident "x")); + infer_exp_str {| fun x -> x |}; [%expect {| ('a -> 'a) |}] let%expect_test "fun 'a -> 'a (shadow)" = - inf_pprint_etyp ["x", Type_var {contents = Unbound "type 's"}] (Exp_fun ((Pat_var "x", []), Exp_ident "x")); + let env = ["x", Type_var {contents = Unbound "type 's"}] in + infer_exp_str {| fun x -> x |} ~env: env; [%expect {| ('a -> 'a) |}] let%expect_test "fun 'a -> 'b (not in env)" = - inf_pprint_etyp [] (Exp_fun ((Pat_var "x", []), Exp_ident "y")); + infer_exp_str {| fun x -> y |}; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -319,36 +303,29 @@ let%expect_test "fun 'a -> 'b (not in env)" = Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 262, characters 30-49 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 273, characters 14-35 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 319, characters 1-64 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 320, characters 2-31 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "fun 'a -> 'b (in env)" = - inf_pprint_etyp ["y", Type_var {contents = Unbound "s"}] (Exp_fun ((Pat_var "x", []), Exp_ident "y")); + let env = ["y", Type_var {contents = Unbound "s"}] in + infer_exp_str {| fun x -> y |} ~env: env; [%expect{| ('a -> 's) |}] -let%expect_test "fun x -> fun y -> x y;;" = - inf_pprint_etyp [] (Exp_fun((Pat_var "x", []), Exp_fun((Pat_var "y", []), Exp_apply(Exp_ident "x", Exp_ident "y")))); - [%expect{| (('b -> 'c) -> ('b -> 'c)) |}] +let%expect_test _= + infer_exp_str {| fun x -> fun y -> x y |}; + [%expect{| (('b -> 'c) -> ('b -> 'c)) |}] -let%expect_test "fun x y -> x y;;" = - inf_pprint_etyp [] (Exp_fun((Pat_var "x", [Pat_var "y"]), Exp_apply(Exp_ident "x", Exp_ident "y"))); +let%expect_test _ = + infer_exp_str {| fun x y -> x y |}; [%expect{| (('b -> 'c) -> ('b -> 'c)) |}] -let%expect_test {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |} = - inf_pprint_etyp [] - (Exp_apply - (Exp_apply( - (Exp_apply - (Exp_fun ((Pat_var "f", [Pat_var "a"; Pat_var "b"]), Exp_tuple (Exp_apply (Exp_ident "f", Exp_ident "a"), Exp_apply (Exp_ident "f", Exp_ident "b"), [])), - Exp_fun ((Pat_var "x", []), Exp_ident "x"))), - Exp_constant (Const_integer 1)), - Exp_constant (Const_string "mystr"))); +let%expect_test _ = + infer_exp_str {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |}; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -359,57 +336,55 @@ let%expect_test {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |} = Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 352, characters 2-366 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 354, characters 2-68 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] (************************** Let in **************************) -let%expect_test "let 1 = 1 in 2" = - inf_pprint_etyp [] (Exp_let (Nonrecursive, ({pat = Pat_constant (Const_integer 1); expr = Exp_constant (Const_integer 1)}, []), Exp_constant (Const_integer 2))); +let%expect_test _ = + infer_exp_str {| let 1 = 1 in 2 |}; [%expect{| int |}] -let%expect_test "let _ = 1 in 2" = - inf_pprint_etyp [] (Exp_let (Nonrecursive, ({pat = Pat_any; expr = Exp_constant (Const_integer 1)}, []), Exp_constant (Const_integer 2))); +let%expect_test _ = + infer_exp_str {| let a = 1 in 2 |}; [%expect{| int |}] -let%expect_test "let a = 1 in a" = - inf_pprint_etyp [] (Exp_let (Nonrecursive, ({pat = Pat_var "a"; expr = Exp_constant (Const_integer 1)}, []), Exp_ident "a")); +let%expect_test _ = +infer_exp_str {| let a = 1 in a |}; [%expect{| int |}] -let%expect_test {| let a = 1 in "str" |} = - inf_pprint_etyp [] (Exp_let (Nonrecursive, ({pat = Pat_var "a"; expr = Exp_constant (Const_integer 1)}, []), Exp_constant (Const_string "str"))); +let%expect_test _ = + infer_exp_str {| let a = 1 in a |}; + [%expect{| int |}] + + +let%expect_test _ = + infer_exp_str {| let a = 1 in "str" |}; [%expect{| string |}] -let%expect_test {| let a = fun x -> x in a |} = - inf_pprint_etyp [] (Exp_let (Nonrecursive, - ({pat = Pat_var "a"; expr = Exp_fun ((Pat_var "x", []), Exp_ident "x")}, []), Exp_ident "a")); +let%expect_test _ = + infer_exp_str {| let a = fun x -> x in a |}; [%expect{| ('c -> 'c) |}] -let%expect_test {| let a = fun x -> x in (a 1, a "str") |} = - inf_pprint_etyp [] (Exp_let (Nonrecursive, - ({pat = Pat_var "a"; expr = Exp_fun ((Pat_var "x", []), Exp_ident "x")}, []), - Exp_tuple(Exp_apply(Exp_ident "a", Exp_constant (Const_integer 1)), - Exp_apply (Exp_ident "a", Exp_constant (Const_string "str")), []))); +let%expect_test _ = + infer_exp_str {| let a = fun x -> x in (a 1, a "str") |}; [%expect{| (int * string) |}] -let%expect_test {| let a, b = 1, 2 in a |} = - inf_pprint_etyp [] (Exp_let (Nonrecursive, - ({pat = Pat_tuple (Pat_var "a", Pat_var "b", []); expr = Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [])}, []), Exp_ident "a")); +let%expect_test _ = + infer_exp_str {| let a, b = 1, 2 in a |} ; [%expect{| int |}] -let%expect_test {| let a, b, c = 1, 2 in a |} = - inf_pprint_etyp [] (Exp_let (Nonrecursive, - ({pat = Pat_tuple (Pat_var "a", Pat_var "b", [Pat_var "c"]); expr = Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [])}, []), Exp_ident "a")); +let%expect_test _ = + infer_exp_str {| let a, b, c = 1, 2 in a |} ; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -422,15 +397,13 @@ let%expect_test {| let a, b, c = 1, 2 in a |} = Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 258, characters 2-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 309, characters 18-84 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 420, characters 2-216 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 415, characters 2-46 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] - let%expect_test {| let a, b = 1, 2, 3 in a |} = - inf_pprint_etyp [] (Exp_let (Nonrecursive, - ({pat = Pat_tuple (Pat_var "a", Pat_var "b", []); expr = Exp_tuple (Exp_constant (Const_integer 1), Exp_constant (Const_integer 2), [Exp_constant (Const_integer 3)])}, []), Exp_ident "a")); +let%expect_test _ = + infer_exp_str {| let a, b = 1, 2, 3 in a |}; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -443,18 +416,16 @@ let%expect_test {| let a, b, c = 1, 2 in a |} = Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 258, characters 2-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 309, characters 18-84 - Called from XML_unittests__Infer.inf_pprint_etyp_env in file "many_tests/unit/infer.ml", line 22, characters 21-38 - Called from XML_unittests__Infer.inf_pprint_etyp in file "many_tests/unit/infer.ml" (inlined), line 33, characters 44-76 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 440, characters 2-235 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 434, characters 2-45 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] -let%expect_test {| let a = 1 and b = "punk" in b |} = - inf_pprint_etyp [] (Exp_let (Nonrecursive, - ({pat = Pat_var "a"; expr = Exp_constant (Const_integer 1)}, - [{pat = Pat_var "b"; expr = Exp_constant (Const_string "punk")}]), Exp_ident "b")); +let%expect_test _ = + infer_exp_str {| let a = 1 and b = "punk" in b |}; [%expect{| string |}] + (************************** Structure items **************************) (************************** Programs **************************) From 4eab43278756894970edaf5fff9e1e416e21843e Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sat, 28 Feb 2026 19:41:50 +0300 Subject: [PATCH 43/84] feat: add support for let rec .. (and), bin operators, and add more tests --- XML/lib/middleend/inferLayers.ml | 61 ++++++++++++++-- XML/many_tests/unit/infer.ml | 120 +++++++++++++++++++------------ 2 files changed, 133 insertions(+), 48 deletions(-) diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml index 4dbe03cd..8c7df9d5 100644 --- a/XML/lib/middleend/inferLayers.ml +++ b/XML/lib/middleend/inferLayers.ml @@ -140,7 +140,7 @@ let rec unify t1 t2 = else List.map2 unify llst rlst |> ignore | Quant_type_var _, _ | _, Quant_type_var _ -> failwith "cannot unify with a quantified type" - | _ -> failwith "cannot unify types" + | _ -> failwith ("cannot unify types: " ^ show_typ t1 ^ "and: " ^ show_typ t2) ;; (* | _ -> failwith "error" *) @@ -252,14 +252,45 @@ let rec infer_pat env = function | _ -> failwith "infer pat not implemented" ;; +let add_rec_names env vb_list = + List.fold_left + (fun cenv { pat; _ } -> + match pat with + | Pat_var id | Pat_constraint (Pat_var id, _) -> + let ncenv, typ_p = infer_pat cenv pat in + (id, typ_p) :: ncenv + | _ -> + failwith + "only variables are allowed as left-hand side of 'let rec' (during adding rec \ + names)" + (* let fresh = newvar () in *)) + env + vb_list +;; + let rec infer_vb env { pat; expr } = let new_env, typ_p = infer_pat env pat in let new_env1, typ_e = infer_exp new_env expr in unify typ_p (generalize typ_e); new_env1 +and infer_vb_rec env { pat; expr } = + match pat with + | Pat_var id | Pat_constraint (Pat_var id, _) -> + let new_env, typ_p = infer_pat env pat in + let new_env = (id, typ_p) :: new_env in + let new_env1, typ_e = infer_exp new_env expr in + (* unify typ_p (generalize typ_e); *) + unify typ_p typ_e; + unify typ_p (generalize typ_e); + new_env1 + | _ -> failwith "only variables are allowed as left-hand side of 'let rec'" + and infer_exp env = function - | Exp_ident id -> env, inst (List.assoc id env) + | Exp_ident id -> + (match List.assoc_opt id env with + | Some ty -> env, inst ty + | None -> failwith ("unbound variable: " ^ id)) | Exp_constant const -> (match const with | Const_char _ -> env, Type_construct ("char", []) @@ -273,6 +304,25 @@ and infer_exp env = function | [] -> infer_exp new_env exp in newest_env, Type_arrow (typ_p, typ_exp) + | Exp_apply (Exp_ident op, Exp_tuple (exp1, exp2, [])) -> + (match op with + | "*" | "/" | "+" | "-" | "<" | ">" | "=" | "<>" | "<=" | ">=" | "&&" | "||" -> + let new_env, typ1 = infer_exp env exp1 in + let new_env1, typ2 = infer_exp new_env exp2 in + let arg_typ, res_typ = + match List.assoc_opt op env with + | Some (Type_arrow (arg, Type_arrow (_, res))) -> arg, res + | _ -> failwith ("operator was not found in env: " ^ op) + in + unify typ1 arg_typ; + unify typ2 arg_typ; + new_env1, res_typ + | _ -> + let new_env, typ_op = infer_exp env (Exp_ident op) in + let new_env1, typ_args = infer_exp new_env (Exp_tuple (exp1, exp2, [])) in + let typ_res = newvar () in + unify typ_op (Type_arrow (typ_args, typ_res)); + new_env1, typ_res) | Exp_apply (f, arg) -> let new_env, typ_f = infer_exp env f in let new_env1, typ_arg = infer_exp new_env arg in @@ -309,8 +359,11 @@ and infer_exp env = function let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in infer_exp new_env exprb | Exp_let (Recursive, (vb, vbs), exprb) -> - let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in - infer_exp new_env exprb + let new_env = add_rec_names env (vb :: vbs) in + let new_env1 = + List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) + in + infer_exp new_env1 exprb (* | Exp_constraint (exp, ty) -> let new_env, new_ty = infer_exp env exp in unify ty new_ty; diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index e12a805f..94691558 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -61,11 +61,10 @@ let%expect_test "id not in env" = This is strongly discouraged as backtraces are fragile. Please change this test to not include a backtrace. *) - Not_found - Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 262, characters 30-49 + (Failure "unbound variable: m") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 76, characters 2-23 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 57, characters 2-23 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; @@ -91,13 +90,13 @@ let%expect_test "tuples in tuple" = let%expect_test "construct none" = let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in - infer_exp_str {| None |} ~env: env; + infer_exp_str {| None |} ~env; [%expect {| 'a option |}] let%expect_test "construct some" = let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Quant_type_var "a"]))] in - infer_exp_str {| Some 1 |} ~env: env; + infer_exp_str {| Some 1 |} ~env; [%expect {| 'a option |}] @@ -110,14 +109,14 @@ let%expect_test "if (string) " = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 298, characters 4-43 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 348, characters 4-43 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "if (bool) then (not unit)" = let env = ["cond", type_bool] in - infer_exp_str {| if cond then 1 |} ~env: env; + infer_exp_str {| if cond then 1 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -126,39 +125,39 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 302, characters 7-46 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 352, characters 7-46 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 142, characters 2-46 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 119, characters 2-41 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "if (bool) then (unit)" = let env = ["cond", type_bool; "bodyvar", type_unit] in - infer_exp_str {| if cond then bodyvar |} ~env: env; + infer_exp_str {| if cond then bodyvar |} ~env; [%expect{| unit |}] let%expect_test "if (bool) then 'a else 'a" = let env = ["cond", type_bool; "x", Type_var {contents = Unbound "a"}; "y", Type_var {contents = Unbound "a"}] in - infer_exp_str {| if cond then x else y |} ~env: env; + infer_exp_str {| if cond then x else y |} ~env; [%expect{| 'a |}] let%expect_test "if (bool) then 'a else 'b" = let env = ["cond", type_bool; "x", Type_var {contents = Unbound "a"}; "y", Type_var {contents = Unbound "b"}] in - infer_exp_str {| if cond then x else y |} ~env: env; + infer_exp_str {| if cond then x else y |} ~env; [%expect{| 'b |}] let%expect_test "apply int -> int to int" = let env = ["f", Type_arrow (type_int, type_int); "x", type_int] in - infer_exp_str {| f x |} ~env: env; + infer_exp_str {| f x |} ~env; [%expect{| int |}] let%expect_test "apply int -> int to string" = let env = ["f", Type_arrow (type_int, type_int); "x", type_string] in - infer_exp_str {| f x |} ~env: env; + infer_exp_str {| f x |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -168,28 +167,28 @@ let%expect_test "apply int -> int to string" = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 330, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 184, characters 2-35 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 160, characters 2-30 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "apply 'a -> 'a to 'b" = let env = ["f", Type_arrow (Type_var {contents = Unbound "s"}, Type_var {contents = Unbound "s"}); "x", Type_var {contents = Unbound "t"}] in - infer_exp_str {| f x |} ~env: env ~rst: false; + infer_exp_str {| f x |} ~env ~rst: false; [%expect{| 'b |}] (* not sure if this is right *) let%expect_test "apply 'a to 'a (different vars)" = let env = ["f", Type_var {contents = Unbound "t"}; "x", Type_var {contents = Unbound "t"}] in - infer_exp_str {| f x |} ~env: env ~rst: false; + infer_exp_str {| f x |} ~env ~rst: false; [%expect {| 'c |}] let%expect_test "apply 'a to 'a (same var)" = let env = ["x", Type_var {contents = Unbound "t"}] in - infer_exp_str {| x x |} ~env: env ~rst: false; + infer_exp_str {| x x |} ~env ~rst: false; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -200,23 +199,28 @@ let%expect_test "apply 'a to 'a (same var)" = Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 114, characters 4-22 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 128, characters 4-22 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 330, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 216, characters 2-47 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 191, characters 2-42 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "apply 'a to 'b" = let env = ["f", Type_var {contents = Unbound "s"}; "x", Type_var {contents = Unbound "t"}] in - infer_exp_str {| f x |} ~env: env ~rst: false; + infer_exp_str {| f x |} ~env ~rst: false; [%expect{| 'e |}] +let%expect_test "binary op" = + let env = ["=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool))] in + infer_exp_str {| 1 = 1 |} ~env; + [%expect {| bool |}] + (************************** Patterns **************************) let%expect_test "id in env" = let env = ["m", (Type_var {contents = Unbound "c"})] in - infer_pat_str {| m |} ~env: env; + infer_pat_str {| m |} ~env; [%expect {| 'a |}];; @@ -267,14 +271,14 @@ let%expect_test "tuples in tuple" = let%expect_test "construct none" = let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in - infer_pat_str {| None |} ~env: env; + infer_pat_str {| None |} ~env; [%expect {| 'a option |}] let%expect_test "construct some" = let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Quant_type_var "n"]))] in - infer_pat_str {| Some 1 |} ~env: env; + infer_pat_str {| Some 1 |} ~env; [%expect {| 'n option |}] @@ -287,7 +291,7 @@ let%expect_test "fun 'a -> 'a (new var)" = let%expect_test "fun 'a -> 'a (shadow)" = let env = ["x", Type_var {contents = Unbound "type 's"}] in - infer_exp_str {| fun x -> x |} ~env: env; + infer_exp_str {| fun x -> x |} ~env; [%expect {| ('a -> 'a) |}] @@ -299,18 +303,17 @@ let%expect_test "fun 'a -> 'b (not in env)" = This is strongly discouraged as backtraces are fragile. Please change this test to not include a backtrace. *) - Not_found - Raised at Stdlib__List.assoc in file "list.ml", line 191, characters 10-25 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 262, characters 30-49 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 273, characters 14-35 + (Failure "unbound variable: y") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 304, characters 14-35 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 320, characters 2-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 299, characters 2-32 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "fun 'a -> 'b (in env)" = let env = ["y", Type_var {contents = Unbound "s"}] in - infer_exp_str {| fun x -> y |} ~env: env; + infer_exp_str {| fun x -> y |} ~env; [%expect{| ('a -> 's) |}] @@ -335,9 +338,9 @@ let%expect_test _ = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 280, characters 4-47 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 330, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 354, characters 2-68 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 331, characters 2-68 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -394,11 +397,11 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 135, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 258, characters 2-32 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 274, characters 2-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 309, characters 18-84 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 415, characters 2-46 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 390, characters 2-46 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -413,17 +416,46 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 135, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 258, characters 2-32 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 274, characters 2-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 309, characters 18-84 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 434, characters 2-45 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 409, characters 2-45 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] -let%expect_test _ = - infer_exp_str {| let a = 1 and b = "punk" in b |}; - [%expect{| string |}] +let%expect_test "and" = + infer_exp_str {| let a = 1 and b = "punk" in b |}; + [%expect {| string |}] + + +let%expect_test "FACTORIAL" = + let env = ["=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool)); + "*", Type_arrow (type_int, Type_arrow(type_int, type_int)); + "-", Type_arrow (type_int, Type_arrow(type_int, type_int))] in + infer_exp_str {| let rec fac n = if n = 1 then 1 else n * fac (n-1) in fac 4 |} ~env; + [%expect {| int |}] + + +let%expect_test "FIBONACCI" = + let env = ["<=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool)); + "-", Type_arrow (type_int, Type_arrow(type_int, type_int)); + "+", Type_arrow (type_int, Type_arrow(type_int, type_int))] in + infer_exp_str {| let rec fib n = if n <= 1 then 1 else (fib (n-1)) + (fib (n-2)) in fib 4 |} ~env; + [%expect {| int |}] + + +let%expect_test "mutual recursion" = + let env = ["=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool)); + "-", Type_arrow (type_int, Type_arrow(type_int, type_int)); + "not", Type_arrow (type_bool, type_bool); "true", type_bool] in + infer_exp_str ~env {| + let rec is_odd n = + if n = 0 then true else is_even (n-1) + and is_even n = not (is_odd n) + in is_odd 5 + |}; + [%expect {| bool |}] (************************** Structure items **************************) From ea6d35ccdae2fe43d8b8c931be209ab1573c5206 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 1 Mar 2026 10:50:58 +0300 Subject: [PATCH 44/84] feat: add infer for match and function match exprs, and tests --- XML/lib/middleend/inferLayers.ml | 76 +++++++++++- XML/many_tests/unit/infer.ml | 204 ++++++++++++++++++++++++++----- 2 files changed, 246 insertions(+), 34 deletions(-) diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml index 8c7df9d5..691c8d5b 100644 --- a/XML/lib/middleend/inferLayers.ml +++ b/XML/lib/middleend/inferLayers.ml @@ -107,6 +107,25 @@ and pprint_type_with_parens_if_tuple | _ -> (pprint_typ ~poly_names_map) fmt ty ;; +let show_env env = + let buf = Buffer.create 64 in + let fmt = Format.formatter_of_buffer buf in + let empty_map = Base.Map.empty (module Base.String) in + let rec loop = function + | [] -> () + | [ (name, typ) ] -> + Format.fprintf fmt "(%s, %a)" name (pprint_typ ~poly_names_map:empty_map) typ + | (name, typ) :: rest -> + Format.fprintf fmt "(%s, %a) :: " name (pprint_typ ~poly_names_map:empty_map) typ; + loop rest + in + Format.fprintf fmt "["; + loop env; + Format.fprintf fmt "]"; + Format.pp_print_flush fmt (); + Buffer.contents buf +;; + let rec occurs_check tv = function | Type_var tv' when tv == tv' -> failwith "occurs check" | Type_var { contents = Link t } -> occurs_check tv t @@ -268,6 +287,16 @@ let add_rec_names env vb_list = vb_list ;; +let rec get_pat_names acc pat = + match pat with + | Pat_var id -> id :: acc + | Pat_tuple (pat1, pat2, rest) -> + Base.List.fold_left ~f:get_pat_names ~init:acc (pat1 :: pat2 :: rest) + | Pat_construct ("Some", Some pat) -> get_pat_names acc pat + | Pat_constraint (pat, _) -> get_pat_names acc pat + | _ -> acc +;; + let rec infer_vb env { pat; expr } = let new_env, typ_p = infer_pat env pat in let new_env1, typ_e = infer_exp new_env expr in @@ -364,12 +393,47 @@ and infer_exp env = function List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) in infer_exp new_env1 exprb - (* | Exp_constraint (exp, ty) -> - let new_env, new_ty = infer_exp env exp in - unify ty new_ty; - new_env new_ty *) - (* |Exp_match _ |Exp_function _ -> *) - | _ -> failwith "infer exp not implemented" + | Exp_match (expr, (case, rest)) -> + let new_env, typ_main = infer_exp env expr in + let fresh = newvar () in + let typ_res = + List.fold_left + (fun acc_typ curr_case -> + let pat_names = get_pat_names [] curr_case.first in + let pat_env, typ_pat = infer_pat new_env curr_case.first in + unify typ_pat typ_main; + let pat_env = + List.fold_left + (fun env name -> + let typ = List.assoc name env in + let env = List.remove_assoc name env in + (name, generalize typ) :: env) + pat_env + pat_names + in + let _, typ_exp = infer_exp pat_env curr_case.second in + unify acc_typ typ_exp; + acc_typ) + fresh + (case :: rest) + in + new_env, typ_res + | Exp_function (case, rest) -> + let fresh_p = newvar () in + let fresh_e = newvar () in + let typ_res = + List.fold_left + (fun acc_typ curr_case -> + let env_pat, typ_pat = infer_pat env curr_case.first in + unify typ_pat fresh_p; + let _, typ_exp = infer_exp env_pat curr_case.second in + unify acc_typ typ_exp; + acc_typ) + fresh_e + (case :: rest) + in + env, Type_arrow (fresh_p, typ_res) + | Exp_constraint _ -> failwith " exp constraint is not implemented yet" ;; (* нужно реализовать матчи, фанкшены, леты. затем протестить, diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index 94691558..7d50023e 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -89,13 +89,13 @@ let%expect_test "tuples in tuple" = let%expect_test "construct none" = - let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in + let env = ["None", Type_construct ("option", [ Type_var {contents = Unbound "a"}])] in infer_exp_str {| None |} ~env; [%expect {| 'a option |}] let%expect_test "construct some" = - let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Quant_type_var "a"]))] in + let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [ Type_var {contents = Unbound "a"} ]))] in infer_exp_str {| Some 1 |} ~env; [%expect {| 'a option |}] @@ -109,7 +109,7 @@ let%expect_test "if (string) " = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 348, characters 4-43 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 377, characters 4-43 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -125,7 +125,7 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 352, characters 7-46 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 381, characters 7-46 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 119, characters 2-41 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -166,8 +166,8 @@ let%expect_test "apply int -> int to string" = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 330, characters 4-47 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 150, characters 4-15 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 160, characters 2-30 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -197,9 +197,9 @@ let%expect_test "apply 'a to 'a (same var)" = (Failure "occurs check") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 114, characters 4-22 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 128, characters 4-22 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 330, characters 4-47 + Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 133, characters 4-22 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 147, characters 4-22 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 191, characters 2-42 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -270,16 +270,16 @@ let%expect_test "tuples in tuple" = let%expect_test "construct none" = - let env = ["None", Type_construct ("option", [ Quant_type_var "a" ])] in + let env = ["None", Type_construct ("option", [ Type_var {contents = Unbound "a"} ])] in infer_pat_str {| None |} ~env; [%expect {| 'a option |}] let%expect_test "construct some" = let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, - Type_construct("option", [Quant_type_var "n"]))] in + Type_construct("option", [Type_var {contents = Unbound "a"}]))] in infer_pat_str {| Some 1 |} ~env; - [%expect {| 'n option |}] + [%expect {| 'a option |}] (************************** Funs **************************) @@ -305,7 +305,7 @@ let%expect_test "fun 'a -> 'b (not in env)" = (Failure "unbound variable: y") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 304, characters 14-35 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 333, characters 14-35 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 299, characters 2-32 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -337,13 +337,166 @@ let%expect_test _ = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 131, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 330, characters 4-47 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 150, characters 4-15 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 331, characters 2-68 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] +(************************** Match, function **************************) + +let match_env = [ + "Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Type_var {contents = Unbound "a"}])); + "None", Type_construct ("option", [ Type_var {contents = Unbound "a"}]); + "::", Type_arrow + ( Type_tuple (Type_var {contents = Unbound "a"}, Type_construct ("list", [ Type_var {contents = Unbound "a"}]), []) + , Type_construct ("list", [ Type_var {contents = Unbound "a"}])); + "[]", Type_construct ("list", [Type_var {contents = Unbound "a"}]); + "a", Type_construct("option", [Type_var {contents = Unbound "a"}]); + "b", Type_construct("list", [Type_var {contents = Unbound "a"}])] + + +let%expect_test "correct match" = + infer_exp_str {| match a with | Some x -> 1 | None -> 2 |} ~env: match_env; + [%expect {| + int |}] + + +let%expect_test "match different constructors" = + infer_exp_str {| match a with | Some x -> 1 | [] -> 2 |} ~env: match_env; + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: list and option") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 404, characters 11-33 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 400, characters 6-685 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 367, characters 2-74 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "match option with list constructors" = + infer_exp_str {| match a with | x :: tl -> 1 | [] -> 2 |} ~env: match_env; + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: list and option") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 404, characters 11-33 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 400, characters 6-685 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 385, characters 2-75 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "match different types of expr 1" = + infer_exp_str {| match a with | Some x -> 'a' | None -> 1234 |} ~env: match_env; + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: char and int") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 415, characters 11-32 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 400, characters 6-685 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 403, characters 2-81 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "match different types of expr 2" = + infer_exp_str {| match b with | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env: match_env; + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: char and int") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 415, characters 11-32 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 400, characters 6-685 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 421, characters 2-101 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + + +let%expect_test "correct function" = + infer_exp_str {| function | Some x -> 1 | None -> 2 |} ~env: match_env; + [%expect {| + ('a option -> int) |}] + + +let%expect_test "function different constructors" = + infer_exp_str {| function | Some x -> 1 | [] -> 2 |} ~env: match_env; + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: list and option") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 428, characters 11-32 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-320 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 446, characters 2-70 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "function different types of expr 1" = + infer_exp_str {| function | Some x -> 'a' | None -> 1234 |} ~env: match_env; + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: char and int") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 430, characters 11-32 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-320 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 464, characters 2-77 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "function different types of expr 2" = + infer_exp_str {| function | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env: match_env; + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "can't unify different constructors: char and int") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 430, characters 11-32 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-320 + Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 482, characters 2-97 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + + (************************** Let in **************************) let%expect_test _ = @@ -361,11 +514,6 @@ infer_exp_str {| let a = 1 in a |}; [%expect{| int |}] -let%expect_test _ = - infer_exp_str {| let a = 1 in a |}; - [%expect{| int |}] - - let%expect_test _ = infer_exp_str {| let a = 1 in "str" |}; [%expect{| string |}] @@ -396,12 +544,12 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 135, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 274, characters 2-32 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 154, characters 9-62 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 303, characters 2-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 18-84 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 388, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 390, characters 2-46 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 543, characters 2-46 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -415,12 +563,12 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 135, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 274, characters 2-32 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 154, characters 9-62 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 303, characters 2-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 18-84 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 388, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 409, characters 2-45 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 562, characters 2-45 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] From fde97efcba106b3275d9016816b689908cca2201 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Sun, 1 Mar 2026 19:40:24 +0300 Subject: [PATCH 45/84] feat: add infer for str items and prog, fix generalization --- XML/lib/middleend/inferLayers.ml | 97 +++++++++++++- XML/lib/middleend/inferLayers.mli | 26 ++++ XML/many_tests/unit/infer.ml | 215 +++++++++++++++++------------- 3 files changed, 235 insertions(+), 103 deletions(-) diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml index 691c8d5b..64b49024 100644 --- a/XML/lib/middleend/inferLayers.ml +++ b/XML/lib/middleend/inferLayers.ml @@ -4,6 +4,7 @@ open Common.Ast open Common.Ast.Expression +open Common.Ast.Structure open Common.Ast.Pattern type typ = @@ -19,6 +20,11 @@ and tv = | Link of typ [@@deriving eq, show { with_path = false }] +let rec follow_links = function + | Type_var { contents = Link t } -> follow_links t + | t -> t +;; + let rec pprint_type_tuple ?(poly_names_map = Base.Map.empty (module Base.String)) fmt = let open Format in function @@ -300,8 +306,18 @@ let rec get_pat_names acc pat = let rec infer_vb env { pat; expr } = let new_env, typ_p = infer_pat env pat in let new_env1, typ_e = infer_exp new_env expr in - unify typ_p (generalize typ_e); - new_env1 + unify typ_p typ_e; + let pat_names = get_pat_names [] pat in + let new_env2 = + List.fold_left + (fun env name -> + let typ = List.assoc name env in + let env = List.remove_assoc name env in + (name, generalize typ) :: env) + new_env1 + pat_names + in + new_env2 and infer_vb_rec env { pat; expr } = match pat with @@ -311,8 +327,17 @@ and infer_vb_rec env { pat; expr } = let new_env1, typ_e = infer_exp new_env expr in (* unify typ_p (generalize typ_e); *) unify typ_p typ_e; - unify typ_p (generalize typ_e); - new_env1 + let pat_names = get_pat_names [] pat in + let new_env2 = + List.fold_left + (fun env name -> + let typ = List.assoc name env in + let env = List.remove_assoc name env in + (name, generalize typ) :: env) + new_env1 + pat_names + in + new_env2 | _ -> failwith "only variables are allowed as left-hand side of 'let rec'" and infer_exp env = function @@ -340,7 +365,7 @@ and infer_exp env = function let new_env1, typ2 = infer_exp new_env exp2 in let arg_typ, res_typ = match List.assoc_opt op env with - | Some (Type_arrow (arg, Type_arrow (_, res))) -> arg, res + | Some (Type_arrow (arg, Type_arrow (_, res))) -> inst arg, inst res | _ -> failwith ("operator was not found in env: " ^ op) in unify typ1 arg_typ; @@ -436,5 +461,63 @@ and infer_exp env = function | Exp_constraint _ -> failwith " exp constraint is not implemented yet" ;; -(* нужно реализовать матчи, фанкшены, леты. затем протестить, -что все работает, как надо, затем добавлять левела *) +let infer_structure_item env = function + | Str_eval exp -> + let _, typ = infer_exp env exp in + ("-", typ) :: env + | Str_value (Nonrecursive, (vb, vbs)) -> + let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in + new_env + | Str_value (Recursive, (vb, vbs)) -> + let new_env = add_rec_names env (vb :: vbs) in + let new_env1 = + List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) + in + new_env1 + | Str_adt _ -> failwith "str_adt will be removed" +;; + +let infer_program env prog = + let new_env = + List.fold_left (fun env str_item -> infer_structure_item env str_item) env prog + in + new_env +;; + +let env_with_things = + let type_bool = Type_construct ("bool", []) in + let type_unit = Type_construct ("unit", []) in + let type_int = Type_construct ("int", []) in + let things_list = + [ "||", Type_arrow (type_bool, Type_arrow (type_bool, type_bool)) + ; "&&", Type_arrow (type_bool, Type_arrow (type_bool, type_bool)) + ; "print_int", Type_arrow (type_int, type_unit) + ; "print_gc_status", Type_arrow (type_unit, type_unit) + ; "collect", Type_arrow (type_unit, type_unit) + ; "+", Type_arrow (type_int, Type_arrow (type_int, type_int)) + ; "-", Type_arrow (type_int, Type_arrow (type_int, type_int)) + ; "*", Type_arrow (type_int, Type_arrow (type_int, type_int)) + ; "/", Type_arrow (type_int, Type_arrow (type_int, type_int)) + ; "=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; "<>", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; "<", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; "<=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; ">", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; ">=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; "None", Type_construct ("option", [ Quant_type_var "a" ]) + ; ( "Some" + , Type_arrow (Quant_type_var "a", Type_construct ("option", [ Quant_type_var "a" ])) + ) + ; "true", type_bool + ; "false", type_bool + ; "()", type_unit + ; "[]", Type_construct ("list", [ Quant_type_var "a" ]) + ; ( "::" + , Type_arrow + ( Type_tuple + (Quant_type_var "a", Type_construct ("list", [ Quant_type_var "a" ]), []) + , Type_construct ("list", [ Quant_type_var "a" ]) ) ) + ] + in + things_list +;; diff --git a/XML/lib/middleend/inferLayers.mli b/XML/lib/middleend/inferLayers.mli index 170bde1f..1f799b74 100644 --- a/XML/lib/middleend/inferLayers.mli +++ b/XML/lib/middleend/inferLayers.mli @@ -25,6 +25,32 @@ val pprint_typ -> typ -> unit +(** resets counter for type variables *) val reset_gensym : unit -> unit + +(** [infer_exp env exp] infers type of the expression [exp] in the environment [env] and returns + updated environment and type of [exp] *) val infer_exp : (ident * typ) list -> Expression.t -> (ident * typ) list * typ + +(** [infer_pat env pat] infers type of the pattern [pat] in the environment [env] and returns + updated environment and type of [pat] *) val infer_pat : (ident * typ) list -> Pattern.t -> (ident * typ) list * typ + +(** [infer_structure_item env item] infers type of the item [item] in the environment [env] and returns + updated environment and type of [item] *) +val infer_structure_item + : (ident * typ) list + -> Structure.structure_item + -> (ident * typ) list + +(** [infer_program env prog] infers all types in program [prog] with initial environment [env] and returns + updated environment + + for basic environment, use [env_with_things] *) +val infer_program + : (ident * typ) list + -> Structure.structure_item list + -> (ident * typ) list + +(** [env_with_things] is the basic environment that contains built-in functions and constructors *) +val env_with_things : (ident * typ) list diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index 7d50023e..14a7a2cf 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -21,6 +21,17 @@ let infer_pat_str ?(rst = true) ?(env = []) str = let _, ty = infer_pat env pat in pprint_typ Format.std_formatter ty;; +let infer_prog_str ?(env = env_with_things) str = + let prog = parse_str str in + reset_gensym (); + let new_env = infer_program env prog in + List.iter (fun (id, typ) -> + Format.printf "%s : " id; + pprint_typ Format.std_formatter typ; + Format.printf "\n%!") + new_env; + () + let show_etyp env exp = let _, ty = infer_exp env exp in Base.print_endline (show_typ ty) @@ -31,6 +42,8 @@ let type_char = Type_construct ("char", []) let type_int = Type_construct ("int", []) let type_string = Type_construct ("string", []) +let env = env_with_things + (************************** Expressions **************************) let%expect_test "char" = @@ -64,7 +77,7 @@ let%expect_test "id not in env" = (Failure "unbound variable: m") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 57, characters 2-23 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 70, characters 2-23 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; @@ -89,15 +102,13 @@ let%expect_test "tuples in tuple" = let%expect_test "construct none" = - let env = ["None", Type_construct ("option", [ Type_var {contents = Unbound "a"}])] in infer_exp_str {| None |} ~env; [%expect {| 'a option |}] let%expect_test "construct some" = - let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [ Type_var {contents = Unbound "a"} ]))] in infer_exp_str {| Some 1 |} ~env; - [%expect {| 'a option |}] + [%expect {| int option |}] let%expect_test "if (string) " = @@ -109,7 +120,7 @@ let%expect_test "if (string) " = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 377, characters 4-43 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 402, characters 4-43 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -125,9 +136,9 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 381, characters 7-46 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 406, characters 7-46 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 119, characters 2-41 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 130, characters 2-41 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -153,7 +164,7 @@ let%expect_test "apply int -> int to int" = let env = ["f", Type_arrow (type_int, type_int); "x", type_int] in infer_exp_str {| f x |} ~env; [%expect{| int |}] - + let%expect_test "apply int -> int to string" = let env = ["f", Type_arrow (type_int, type_int); "x", type_string] in @@ -166,10 +177,10 @@ let%expect_test "apply int -> int to string" = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 150, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 4-47 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 156, characters 4-15 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 384, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 160, characters 2-30 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 171, characters 2-30 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -197,11 +208,11 @@ let%expect_test "apply 'a to 'a (same var)" = (Failure "occurs check") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 133, characters 4-22 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 147, characters 4-22 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 4-47 + Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 139, characters 4-22 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 153, characters 4-22 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 384, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 191, characters 2-42 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 202, characters 2-42 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -211,11 +222,6 @@ let%expect_test "apply 'a to 'b" = [%expect{| 'e |}] -let%expect_test "binary op" = - let env = ["=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool))] in - infer_exp_str {| 1 = 1 |} ~env; - [%expect {| bool |}] - (************************** Patterns **************************) let%expect_test "id in env" = @@ -270,16 +276,24 @@ let%expect_test "tuples in tuple" = let%expect_test "construct none" = - let env = ["None", Type_construct ("option", [ Type_var {contents = Unbound "a"} ])] in infer_pat_str {| None |} ~env; [%expect {| 'a option |}] let%expect_test "construct some" = - let env = ["Some", Type_arrow (Type_var {contents = Unbound "a" }, - Type_construct("option", [Type_var {contents = Unbound "a"}]))] in infer_pat_str {| Some 1 |} ~env; - [%expect {| 'a option |}] + [%expect.unreachable] + [@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure "cannot unify with a quantified type") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_pat in file "lib/middleend/inferLayers.ml", line 270, characters 7-23 + Called from XML_unittests__Infer.infer_pat_str in file "many_tests/unit/infer.ml", line 21, characters 14-31 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 284, characters 2-33 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] (************************** Funs **************************) @@ -305,9 +319,9 @@ let%expect_test "fun 'a -> 'b (not in env)" = (Failure "unbound variable: y") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 333, characters 14-35 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 358, characters 14-35 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 299, characters 2-32 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 313, characters 2-32 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -337,34 +351,32 @@ let%expect_test _ = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 150, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 359, characters 4-47 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 156, characters 4-15 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 384, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 331, characters 2-68 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 345, characters 2-68 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] (************************** Match, function **************************) -let match_env = [ - "Some", Type_arrow (Type_var {contents = Unbound "a" }, Type_construct("option", [Type_var {contents = Unbound "a"}])); - "None", Type_construct ("option", [ Type_var {contents = Unbound "a"}]); - "::", Type_arrow - ( Type_tuple (Type_var {contents = Unbound "a"}, Type_construct ("list", [ Type_var {contents = Unbound "a"}]), []) - , Type_construct ("list", [ Type_var {contents = Unbound "a"}])); - "[]", Type_construct ("list", [Type_var {contents = Unbound "a"}]); - "a", Type_construct("option", [Type_var {contents = Unbound "a"}]); - "b", Type_construct("list", [Type_var {contents = Unbound "a"}])] +let%expect_test "correct match" = + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + infer_exp_str {| match a with | Some x -> 1 | None -> 2 |} ~env; + [%expect {| + int |}] -let%expect_test "correct match" = - infer_exp_str {| match a with | Some x -> 1 | None -> 2 |} ~env: match_env; +let%expect_test "use match pattern in body" = + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + infer_exp_str {| match a with | Some x -> x | None -> 2 |} ~env; [%expect {| int |}] let%expect_test "match different constructors" = - infer_exp_str {| match a with | Some x -> 1 | [] -> 2 |} ~env: match_env; + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + infer_exp_str {| match a with | Some x -> 1 | [] -> 2 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -373,16 +385,17 @@ let%expect_test "match different constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 404, characters 11-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 429, characters 11-33 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 400, characters 6-685 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 367, characters 2-74 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 379, characters 2-63 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "match option with list constructors" = - infer_exp_str {| match a with | x :: tl -> 1 | [] -> 2 |} ~env: match_env; + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + infer_exp_str {| match a with | x :: tl -> 1 | [] -> 2 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -391,16 +404,17 @@ let%expect_test "match option with list constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 404, characters 11-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 429, characters 11-33 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 400, characters 6-685 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 385, characters 2-75 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 398, characters 2-64 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "match different types of expr 1" = - infer_exp_str {| match a with | Some x -> 'a' | None -> 1234 |} ~env: match_env; + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + infer_exp_str {| match a with | Some x -> 'a' | None -> 1234 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -409,16 +423,17 @@ let%expect_test "match different types of expr 1" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 415, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 440, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 400, characters 6-685 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 403, characters 2-81 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 417, characters 2-70 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "match different types of expr 2" = - infer_exp_str {| match b with | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env: match_env; + let env = [ "b", Type_construct("list", [Type_var {contents = Unbound "a"}])] @ env in + infer_exp_str {| match b with | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -427,23 +442,28 @@ let%expect_test "match different types of expr 2" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 415, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 440, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 400, characters 6-685 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 421, characters 2-101 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 436, characters 2-90 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] - let%expect_test "correct function" = - infer_exp_str {| function | Some x -> 1 | None -> 2 |} ~env: match_env; + infer_exp_str {| function | Some x -> 1 | None -> 2 |} ~env; + [%expect {| + ('a option -> int) |}] + + +let%expect_test "use function pattern in body" = + infer_exp_str {| function | Some x -> x | None -> 2 |} ~env; [%expect {| ('a option -> int) |}] let%expect_test "function different constructors" = - infer_exp_str {| function | Some x -> 1 | [] -> 2 |} ~env: match_env; + infer_exp_str {| function | Some x -> 1 | [] -> 2 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -452,16 +472,16 @@ let%expect_test "function different constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 428, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 453, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-320 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 450, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 446, characters 2-70 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 466, characters 2-59 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "function different types of expr 1" = - infer_exp_str {| function | Some x -> 'a' | None -> 1234 |} ~env: match_env; + infer_exp_str {| function | Some x -> 'a' | None -> 1234 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -470,16 +490,16 @@ let%expect_test "function different types of expr 1" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 430, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 455, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-320 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 450, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 464, characters 2-77 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 484, characters 2-66 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "function different types of expr 2" = - infer_exp_str {| function | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env: match_env; + infer_exp_str {| function | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| (* CR expect_test_collector: This test expectation appears to contain a backtrace. @@ -488,15 +508,14 @@ let%expect_test "function different types of expr 2" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 430, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 455, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-320 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 450, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 482, characters 2-97 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 502, characters 2-86 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] - (************************** Let in **************************) let%expect_test _ = @@ -519,16 +538,22 @@ let%expect_test _ = [%expect{| string |}] -let%expect_test _ = - infer_exp_str {| let a = fun x -> x in a |}; - [%expect{| ('c -> 'c) |}] +let%expect_test "let poly" = + show_etyp [] (parse_exp_str {| let a = fun x -> x in a |}); + [%expect {| (Type_arrow ((Type_var ref ((Unbound "d"))), (Type_var ref ((Unbound "d"))))) |}] -let%expect_test _ = +let%expect_test "let poly 2" = infer_exp_str {| let a = fun x -> x in (a 1, a "str") |}; [%expect{| (int * string) |}] +let%expect_test "poly in env" = + let env = ["=", Type_arrow (Quant_type_var "a", Type_arrow(Quant_type_var "a", type_bool))] in + infer_exp_str {| let a = 1 in 1 = 1, "str" = "str" |} ~env; + [%expect{| (bool * bool) |}] + + let%expect_test _ = infer_exp_str {| let a, b = 1, 2 in a |} ; [%expect{| int |}] @@ -544,12 +569,12 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 154, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 303, characters 2-32 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 160, characters 9-62 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 309, characters 2-19 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 388, characters 18-84 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 413, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 543, characters 2-46 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 563, characters 2-46 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -563,29 +588,29 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 154, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 303, characters 2-32 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 160, characters 9-62 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 309, characters 2-19 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 388, characters 18-84 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 413, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 562, characters 2-45 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 582, characters 2-45 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] -let%expect_test "and" = +let%expect_test "let and" = infer_exp_str {| let a = 1 and b = "punk" in b |}; [%expect {| string |}] -let%expect_test "FACTORIAL" = - let env = ["=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool)); +let%expect_test "factorial" = + let env = ["=", Type_arrow (Quant_type_var "a", Type_arrow(Quant_type_var "a", type_bool)); "*", Type_arrow (type_int, Type_arrow(type_int, type_int)); "-", Type_arrow (type_int, Type_arrow(type_int, type_int))] in infer_exp_str {| let rec fac n = if n = 1 then 1 else n * fac (n-1) in fac 4 |} ~env; [%expect {| int |}] -let%expect_test "FIBONACCI" = +let%expect_test "fibonacci" = let env = ["<=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool)); "-", Type_arrow (type_int, Type_arrow(type_int, type_int)); "+", Type_arrow (type_int, Type_arrow(type_int, type_int))] in @@ -606,12 +631,10 @@ let%expect_test "mutual recursion" = [%expect {| bool |}] -(************************** Structure items **************************) - -(************************** Programs **************************) -(* - план такой: дописать тесты на все, что реализовано выше, исправить по необходимости. - затем доделать инфер c failwith и без левелов. - затем добавить левелы. проверить, что тесты не провалились. добавить тесты на то, что левелы работают (со странички и из презы) - затем заменить старый инфер на новый. - затем попытаться убрать failwith, заменяя монадами. *) \ No newline at end of file +(* сделать pprint для текущего инфера + заменить старый инфер на новый + проверить, что тесты не упали, если упали, то починить + затем добавить уровни + проверить что тесты не упали, если упали, то починить + добавить монады вместо failwith + *) \ No newline at end of file From 3ecc3e9d811ec609c6b441c55aed69e5189fc3d3 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 2 Mar 2026 19:01:54 +0300 Subject: [PATCH 46/84] feat: add cram tests for infer, enhance pretty-print, fix numerous bugs bugs are: order of inference in infer_vb, forgotten inst, let rec x = x, unary minus, alloc_block now in env unsound generalization is working, too --- XML/bin/XML_llvm.ml | 35 +++-- XML/lib/middleend/inferLayers.ml | 185 +++++++++++++++++++----- XML/lib/middleend/inferLayers.mli | 17 ++- XML/many_tests/dune | 2 +- XML/many_tests/infer.t | 112 +++++++++++++++ XML/many_tests/unit/dune | 2 +- XML/many_tests/unit/infer.ml | 231 ++++++++++++++++++------------ 7 files changed, 442 insertions(+), 142 deletions(-) create mode 100644 XML/many_tests/infer.t diff --git a/XML/bin/XML_llvm.ml b/XML/bin/XML_llvm.ml index be036778..7172b506 100644 --- a/XML/bin/XML_llvm.ml +++ b/XML/bin/XML_llvm.ml @@ -19,6 +19,7 @@ type options = ; mutable show_cc : bool ; mutable show_ll : bool ; mutable check_types : bool + ; mutable show_types : bool } (* ------------------------------- *) @@ -42,16 +43,30 @@ let to_llvm_ir ast options = let compile_and_write options source_code = let ast = Common.Parser.parse_str source_code in - if options.check_types - then ( - let typedtree = - Middleend.Infer.run_infer_program ast Middleend.Infer.env_with_things - in - match typedtree with - | Error err -> + (if options.check_types + then + let open Middleend.InferLayers in + let env, names = + (* Middleend.Infer.run_infer_program ast Middleend.Infer.env_with_things *) + infer_program env_with_things ast + in + (* List.iter (fun id -> printf "%s\n" id) names; *) + (* match typedtree with + | Error err -> Format.printf "Type error: %a\n" Middleend.InferTypes.pp_inf_err err; exit 1 - | Ok (_, _) -> ()); + | Ok (env, names) -> + if options.show_types + then ( + Middleend.Infer.pprint_result env names; + exit 0) + else ()); *) + if options.show_types + then ( + let env = filter_env env names in + pprint_env env names; + exit 0) + else ()); if options.show_ast then ( (* printf "%a\n" Common.Pprinter.pprint_program ast; *) @@ -126,6 +141,7 @@ let () = ; optimization_lvl = None ; target = "riscv64-unknown-linux-gnu" ; check_types = true + ; show_types = false } in let usage_msg = @@ -165,6 +181,9 @@ let () = ; ( "-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 = diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml index 64b49024..c2122097 100644 --- a/XML/lib/middleend/inferLayers.ml +++ b/XML/lib/middleend/inferLayers.ml @@ -25,6 +25,56 @@ let rec follow_links = function | t -> t ;; +let rearr_typvars typ = + let open Base in + let var_counter = ref 0 in + let rec rename (t : typ) (var_map : (string, string, String.comparator_witness) Map.t) + : typ * (string, string, String.comparator_witness) Map.t + = + match t with + | Type_arrow (t1, t2) -> + let t1', map1 = rename t1 var_map in + let t2', map2 = rename t2 map1 in + Type_arrow (t1', t2'), map2 + | Type_tuple (t1, t2, tl) -> + let t1', map1 = rename t1 var_map in + let t2', map2 = rename t2 map1 in + let ts = tl in + List.fold_left ts ~init:([], map2) ~f:(fun (acc_ts, acc_map) t_elem -> + let t_elem', new_map = rename t_elem acc_map in + t_elem' :: acc_ts, new_map) + |> fun (rev_ts, final_map) -> Type_tuple (t1', t2', List.rev rev_ts), final_map + | Type_var tv_ref -> + (match !tv_ref with + | Unbound _ -> Type_var tv_ref, var_map + | Link linked_t -> rename linked_t var_map) + | Quant_type_var id -> + (match Map.find var_map id with + | Some new_id -> Quant_type_var new_id, var_map + | None -> + let idx = !var_counter in + var_counter := idx + 1; + let new_id = + if idx < 26 + then String.make 1 (Char.of_int_exn (97 + idx)) + else ( + let prefix_count = (idx / 26) - 1 in + let suffix_idx = idx mod 26 in + "'" + ^ String.make (prefix_count + 1) (Char.of_int_exn (97 + (idx / 26) - 1)) + ^ String.make 1 (Char.of_int_exn (97 + suffix_idx))) + in + let new_map = Map.set var_map ~key:id ~data:new_id in + Quant_type_var new_id, new_map) + | Type_construct (id, args) -> + List.fold_left args ~init:([], var_map) ~f:(fun (acc_args, acc_map) arg -> + let arg', new_map = rename arg acc_map in + arg' :: acc_args, new_map) + |> fun (rev_args, final_map) -> Type_construct (id, List.rev rev_args), final_map + in + fst (rename typ (Map.empty (module String))) +;; + let rec pprint_type_tuple ?(poly_names_map = Base.Map.empty (module Base.String)) fmt = let open Format in function @@ -72,25 +122,40 @@ and pprint_type_list_with_parens in print_types fmt ty_list -and pprint_typ fmt ?(poly_names_map = Base.Map.empty (module Base.String)) = +and pprint_typ fmt ?(poly_names_map = Base.Map.empty (module Base.String)) typ = + let rec is_arrow = function + | Type_arrow _ -> true + | Type_var { contents = Link t } -> is_arrow t + | _ -> false + in + let rec is_tuple = function + | Type_tuple _ -> true + | Type_var { contents = Link t } -> is_tuple t + | _ -> false + in let open Format in - function - | Type_arrow (t1, t2) -> + match typ with + | Type_arrow (t1, t2) when is_arrow t1 -> fprintf fmt - "(%a -> %a)" + "(%a) -> %a" (pprint_typ ~poly_names_map) t1 (pprint_typ ~poly_names_map) t2 + | Type_arrow (t1, t2) -> + fprintf fmt "%a -> %a" (pprint_typ ~poly_names_map) t1 (pprint_typ ~poly_names_map) t2 | Type_tuple (t1, t2, tl) -> fprintf fmt - "(%s)" + "%s" (String.concat " * " (List.map - (fun t -> asprintf "%a" (pprint_typ ~poly_names_map) t) + (fun t -> + if is_tuple t + then asprintf "(%a)" (pprint_typ ~poly_names_map) t + else asprintf "%a" (pprint_typ ~poly_names_map) t) (t1 :: t2 :: tl))) | Type_var { contents = Unbound id } -> (match Base.Map.find poly_names_map id with @@ -113,23 +178,41 @@ and pprint_type_with_parens_if_tuple | _ -> (pprint_typ ~poly_names_map) fmt ty ;; -let show_env env = - let buf = Buffer.create 64 in - let fmt = Format.formatter_of_buffer buf in - let empty_map = Base.Map.empty (module Base.String) in - let rec loop = function - | [] -> () - | [ (name, typ) ] -> - Format.fprintf fmt "(%s, %a)" name (pprint_typ ~poly_names_map:empty_map) typ - | (name, typ) :: rest -> - Format.fprintf fmt "(%s, %a) :: " name (pprint_typ ~poly_names_map:empty_map) typ; - loop rest - in - Format.fprintf fmt "["; - loop env; - Format.fprintf fmt "]"; - Format.pp_print_flush fmt (); - Buffer.contents buf +let filter_env (env : (ident * typ) list) (names : ident list) = + List.fold_left + (fun acc name -> + match List.assoc_opt name env, List.assoc_opt name acc with + | Some ty, None -> (name, ty) :: acc + | _ -> acc) + [] + names +;; + +let pprint_env env names = + let open Format in + let new_env = filter_env env names in + List.iter + (fun (key, typ) -> + if + String.length key > 0 + && Stdlib.Char.code key.[0] >= 65 + && Stdlib.Char.code key.[0] <= 90 + then () + else if key = "-" + then + printf + "%s : %a\n" + key + (pprint_typ ~poly_names_map:(Base.Map.empty (module Base.String))) + typ + else ( + let typ = rearr_typvars typ in + printf + "val %s : %a\n" + key + (pprint_typ ~poly_names_map:(Base.Map.empty (module Base.String))) + typ)) + new_env ;; let rec occurs_check tv = function @@ -165,7 +248,15 @@ let rec unify t1 t2 = else List.map2 unify llst rlst |> ignore | Quant_type_var _, _ | _, Quant_type_var _ -> failwith "cannot unify with a quantified type" - | _ -> failwith ("cannot unify types: " ^ show_typ t1 ^ "and: " ^ show_typ t2) + (* | _ -> failwith ("cannot unify types: " ^ show_typ t1 ^ "and: " ^ show_typ t2) *) + | _ -> + failwith + (Format.asprintf + "cannot unify types: %a and %a" + (fun fmt -> pprint_typ fmt ~poly_names_map:(Base.Map.empty (module Base.String))) + t1 + (fun fmt -> pprint_typ fmt ~poly_names_map:(Base.Map.empty (module Base.String))) + t2) ;; (* | _ -> failwith "error" *) @@ -264,7 +355,7 @@ let rec infer_pat env = function | Pat_construct (name, pat) -> let ty = List.assoc name env in let inst_ty = inst ty in - (match ty, pat with + (match inst_ty, pat with | Type_arrow (arg, body), Some p -> let new_env, new_ty = infer_pat env p in unify arg new_ty; @@ -304,27 +395,33 @@ let rec get_pat_names acc pat = ;; let rec infer_vb env { pat; expr } = + (* we don't need local names *) + let _, typ_e = infer_exp env expr in let new_env, typ_p = infer_pat env pat in - let new_env1, typ_e = infer_exp new_env expr in unify typ_p typ_e; let pat_names = get_pat_names [] pat in - let new_env2 = + let new_env1 = List.fold_left (fun env name -> let typ = List.assoc name env in let env = List.remove_assoc name env in (name, generalize typ) :: env) - new_env1 + new_env pat_names in - new_env2 + new_env1 and infer_vb_rec env { pat; expr } = match pat with | Pat_var id | Pat_constraint (Pat_var id, _) -> let new_env, typ_p = infer_pat env pat in let new_env = (id, typ_p) :: new_env in - let new_env1, typ_e = infer_exp new_env expr in + let new_env1, typ_e = + match expr with + | Exp_ident eid when id = eid -> + failwith "this kind of expression is not allowed as right-hand side of `let rec'" + | _ -> infer_exp new_env expr + in (* unify typ_p (generalize typ_e); *) unify typ_p typ_e; let pat_names = get_pat_names [] pat in @@ -377,6 +474,10 @@ and infer_exp env = function let typ_res = newvar () in unify typ_op (Type_arrow (typ_args, typ_res)); new_env1, typ_res) + | Exp_apply (Exp_ident "-", arg) -> + let new_env1, typ_arg = infer_exp env arg in + unify typ_arg (Type_construct ("int", [])); + new_env1, Type_construct ("int", []) | Exp_apply (f, arg) -> let new_env, typ_f = infer_exp env f in let new_env1, typ_arg = infer_exp new_env arg in @@ -464,24 +565,35 @@ and infer_exp env = function let infer_structure_item env = function | Str_eval exp -> let _, typ = infer_exp env exp in - ("-", typ) :: env + ("-", typ) :: env, [] | Str_value (Nonrecursive, (vb, vbs)) -> + let new_names = + List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) + in let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in - new_env + new_env, new_names | Str_value (Recursive, (vb, vbs)) -> + let new_names = + List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) + in let new_env = add_rec_names env (vb :: vbs) in let new_env1 = List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) in - new_env1 + new_env1, new_names | Str_adt _ -> failwith "str_adt will be removed" ;; let infer_program env prog = - let new_env = - List.fold_left (fun env str_item -> infer_structure_item env str_item) env prog + let new_env, new_names = + List.fold_left + (fun (env, names) str_item -> + let new_env, new_names = infer_structure_item env str_item in + new_env, new_names @ names) + (env, []) + prog in - new_env + new_env, new_names ;; let env_with_things = @@ -494,6 +606,7 @@ let env_with_things = ; "print_int", Type_arrow (type_int, type_unit) ; "print_gc_status", Type_arrow (type_unit, type_unit) ; "collect", Type_arrow (type_unit, type_unit) + ; "alloc_block", Type_arrow (type_int, type_unit) ; "+", Type_arrow (type_int, Type_arrow (type_int, type_int)) ; "-", Type_arrow (type_int, Type_arrow (type_int, type_int)) ; "*", Type_arrow (type_int, Type_arrow (type_int, type_int)) diff --git a/XML/lib/middleend/inferLayers.mli b/XML/lib/middleend/inferLayers.mli index 1f799b74..54e54416 100644 --- a/XML/lib/middleend/inferLayers.mli +++ b/XML/lib/middleend/inferLayers.mli @@ -25,6 +25,15 @@ val pprint_typ -> typ -> unit +(** [pprint_env env names] pretty-prints all types in environment [env] for + names in [names], skipping repeats or non-existent names *) +val pprint_env : (ident * typ) list -> ident list -> unit + +(** [filter_env env names] filters [env], leaving only bindings for + the names from [names], if they are present in environment. + if [env] contains duplicates for the same name, only the first binding is preserved *) +val filter_env : (ident * typ) list -> ident list -> (ident * typ) list + (** resets counter for type variables *) val reset_gensym : unit -> unit @@ -37,20 +46,20 @@ val infer_exp : (ident * typ) list -> Expression.t -> (ident * typ) list * typ val infer_pat : (ident * typ) list -> Pattern.t -> (ident * typ) list * typ (** [infer_structure_item env item] infers type of the item [item] in the environment [env] and returns - updated environment and type of [item] *) + updated environment and new names *) val infer_structure_item : (ident * typ) list -> Structure.structure_item - -> (ident * typ) list + -> (ident * typ) list * ident list (** [infer_program env prog] infers all types in program [prog] with initial environment [env] and returns - updated environment + updated environment and names of all new global identificators for basic environment, use [env_with_things] *) val infer_program : (ident * typ) list -> Structure.structure_item list - -> (ident * typ) list + -> (ident * typ) list * ident list (** [env_with_things] is the basic environment that contains built-in functions and constructors *) val env_with_things : (ident * typ) list diff --git a/XML/many_tests/dune b/XML/many_tests/dune index 21949fa8..5263fa5e 100644 --- a/XML/many_tests/dune +++ b/XML/many_tests/dune @@ -15,7 +15,7 @@ (inline_tests)) (cram - (applies_to codegen codegen_llvm anf cc ll gc gc_llvm llvm_tweaks) + (applies_to codegen codegen_llvm anf cc ll gc gc_llvm llvm_tweaks infer) (deps ../bin/XML.exe ../bin/XML_llvm.exe diff --git a/XML/many_tests/infer.t b/XML/many_tests/infer.t new file mode 100644 index 00000000..46435609 --- /dev/null +++ b/XML/many_tests/infer.t @@ -0,0 +1,112 @@ + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/001fac.ml -typedtree + val fac : int -> int + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/002fac.ml -typedtree + val fac_cps : int -> (int -> 'a) -> 'a + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/003fib.ml -typedtree + val fib_acc : int -> int -> int -> int + val fib : int -> int + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/004manyargs.ml -typedtree + 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 + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/005fix.ml -typedtree + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val fac : (int -> int) -> int -> int + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/006partial.ml -typedtree + val foo : int -> int + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/006partial2.ml -typedtree + val foo : int + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/006partial3.ml -typedtree + val foo : int -> int -> int -> unit + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/007order.ml -typedtree + val _start : unit -> unit -> int -> unit -> int -> int -> unit -> int -> int -> int + val main : unit + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/008ascription.ml -typedtree + Fatal error: exception Failure(" exp constraint is not implemented yet") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 455, characters 14-35 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 454, characters 20-63 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 454, characters 20-63 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 399, characters 20-38 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_structure_item in file "lib/middleend/inferLayers.ml", line 573, characters 18-84 + Called from Middleend__InferLayers.infer_program.(fun) in file "lib/middleend/inferLayers.ml", line 591, characters 34-67 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_program in file "lib/middleend/inferLayers.ml", line 589, characters 4-189 + Called from Dune__exe__XML_llvm.compile_and_write in file "bin/XML_llvm.ml", line 51, characters 7-40 + [2] + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/009let_poly.ml -typedtree + val temp : int * bool + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010fac_anf.ml -typedtree + val fac : int -> int + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010faccps_ll.ml -typedtree + val id : 'a -> 'a + val fresh_1 : int -> (int -> 'a) -> int -> 'a + val fac_cps : int -> (int -> 'a) -> 'a + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/010fibcps_ll.ml -typedtree + val id : 'a -> 'a + val fresh_2 : int -> (int -> 'a) -> int -> 'a + val fresh_1 : int -> (int -> 'a) -> (int -> (int -> 'a) -> 'b) -> int -> 'b + val fib : int -> (int -> 'a) -> 'a + val main : int + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/011mapcps.ml -typedtree + val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c + val iter : ('a -> 'b) -> 'a list -> unit + val main : unit + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/012fibcps.ml -typedtree + val fib : int -> (int -> 'a) -> 'a + val main : unit + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/013foldfoldr.ml -typedtree + 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 + +map is wrong because gen is unsound? + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/015tuples.ml -typedtree + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val map : ('a -> 'b) -> 'c * 'd -> 'b * 'b + val fixpoly : 'a -> 'b -> 'c * 'b -> 'c + val feven : 'a * 'b -> int -> int + val fodd : 'a * 'b -> int -> int + val tie : 'a -> 'b * 'a -> 'b + val meven : int -> int + val modd : int -> int + val main : int + + + $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/016lists.ml -typedtree + 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 diff --git a/XML/many_tests/unit/dune b/XML/many_tests/unit/dune index 8c4b9844..0879bb83 100644 --- a/XML/many_tests/unit/dune +++ b/XML/many_tests/unit/dune @@ -1,7 +1,7 @@ (library (name XML_unittests) (public_name XML.Many_tests.Unittests) - (libraries stdio XML.Common XML.Middleend) + (libraries base stdio XML.Common XML.Middleend) (preprocess (pps ppx_expect ppx_inline_test ppx_expect)) (instrumentation diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index 14a7a2cf..d08d68e3 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -24,13 +24,9 @@ let infer_pat_str ?(rst = true) ?(env = []) str = let infer_prog_str ?(env = env_with_things) str = let prog = parse_str str in reset_gensym (); - let new_env = infer_program env prog in - List.iter (fun (id, typ) -> - Format.printf "%s : " id; - pprint_typ Format.std_formatter typ; - Format.printf "\n%!") - new_env; - () + let env, names = infer_program env prog in + let env = filter_env env names in + pprint_env env names let show_etyp env exp = let _, ty = infer_exp env exp in @@ -77,28 +73,28 @@ let%expect_test "id not in env" = (Failure "unbound variable: m") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 70, characters 2-23 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 66, characters 2-23 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; let%expect_test "tuple 2" = infer_exp_str {| (1, 2) |}; - [%expect{| (int * int) |}] + [%expect{| int * int |}] let%expect_test "tuple 3" = infer_exp_str {| (1, 2, 3) |}; - [%expect{| (int * int * int) |}] + [%expect{| int * int * int |}] let%expect_test "tuple 4" = infer_exp_str {| (1, 2, 3, 4) |}; - [%expect{| (int * int * int * int) |}] + [%expect{| int * int * int * int |}] let%expect_test "tuples in tuple" = infer_exp_str {| ((1, 2), (3, 4)) |}; - [%expect{| ((int * int) * (int * int)) |}] + [%expect{| (int * int) * (int * int) |}] let%expect_test "construct none" = @@ -120,7 +116,7 @@ let%expect_test "if (string) " = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 402, characters 4-43 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 503, characters 4-43 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -136,9 +132,9 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 406, characters 7-46 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 507, characters 7-46 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 130, characters 2-41 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 126, characters 2-41 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -177,10 +173,10 @@ let%expect_test "apply int -> int to string" = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 156, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 384, characters 4-47 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 239, characters 4-15 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 485, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 171, characters 2-30 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 167, characters 2-30 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -208,11 +204,11 @@ let%expect_test "apply 'a to 'a (same var)" = (Failure "occurs check") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 139, characters 4-22 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 153, characters 4-22 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 384, characters 4-47 + Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 222, characters 4-22 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 236, characters 4-22 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 485, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 202, characters 2-42 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 198, characters 2-42 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -257,22 +253,22 @@ let%expect_test "str" = let%expect_test "tuple 2" = infer_pat_str {| (1, 2) |}; - [%expect {| (int * int) |}];; + [%expect {| int * int |}];; let%expect_test "tuple 3" = infer_pat_str {| (1, 2, 3) |}; - [%expect {| (int * int * int) |}];; + [%expect {| int * int * int |}];; let%expect_test "tuple 4" = infer_pat_str {| (1, 2, 3, 4) |}; - [%expect {| (int * int * int * int) |}];; + [%expect {| int * int * int * int |}];; let%expect_test "tuples in tuple" = infer_pat_str {| ((1, 2), (3, 4)) |}; - [%expect {| ((int * int) * (int * int)) |}];; + [%expect {| (int * int) * (int * int) |}];; let%expect_test "construct none" = @@ -282,31 +278,20 @@ let%expect_test "construct none" = let%expect_test "construct some" = infer_pat_str {| Some 1 |} ~env; - [%expect.unreachable] - [@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "cannot unify with a quantified type") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_pat in file "lib/middleend/inferLayers.ml", line 270, characters 7-23 - Called from XML_unittests__Infer.infer_pat_str in file "many_tests/unit/infer.ml", line 21, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 284, characters 2-33 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| int option |}] (************************** Funs **************************) let%expect_test "fun 'a -> 'a (new var)" = infer_exp_str {| fun x -> x |}; - [%expect {| ('a -> 'a) |}] + [%expect {| 'a -> 'a |}] let%expect_test "fun 'a -> 'a (shadow)" = let env = ["x", Type_var {contents = Unbound "type 's"}] in infer_exp_str {| fun x -> x |} ~env; - [%expect {| ('a -> 'a) |}] + [%expect {| 'a -> 'a |}] let%expect_test "fun 'a -> 'b (not in env)" = @@ -319,26 +304,26 @@ let%expect_test "fun 'a -> 'b (not in env)" = (Failure "unbound variable: y") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 358, characters 14-35 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 455, characters 14-35 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 313, characters 2-32 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 298, characters 2-32 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "fun 'a -> 'b (in env)" = let env = ["y", Type_var {contents = Unbound "s"}] in infer_exp_str {| fun x -> y |} ~env; - [%expect{| ('a -> 's) |}] + [%expect{| 'a -> 's |}] let%expect_test _= infer_exp_str {| fun x -> fun y -> x y |}; - [%expect{| (('b -> 'c) -> ('b -> 'c)) |}] + [%expect{| ('b -> 'c) -> 'b -> 'c |}] let%expect_test _ = infer_exp_str {| fun x y -> x y |}; - [%expect{| (('b -> 'c) -> ('b -> 'c)) |}] + [%expect{| ('b -> 'c) -> 'b -> 'c |}] let%expect_test _ = @@ -351,10 +336,10 @@ let%expect_test _ = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 156, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 384, characters 4-47 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 239, characters 4-15 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 485, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 345, characters 2-68 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 330, characters 2-68 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -385,11 +370,11 @@ let%expect_test "match different constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 429, characters 11-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 530, characters 11-33 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-685 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 526, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 379, characters 2-63 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 364, characters 2-63 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -404,11 +389,11 @@ let%expect_test "match option with list constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 429, characters 11-33 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 530, characters 11-33 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-685 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 526, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 398, characters 2-64 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 383, characters 2-64 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -423,11 +408,11 @@ let%expect_test "match different types of expr 1" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 440, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 541, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-685 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 526, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 417, characters 2-70 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 402, characters 2-70 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -442,24 +427,24 @@ let%expect_test "match different types of expr 2" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 440, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 541, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 425, characters 6-685 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 526, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 436, characters 2-90 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 421, characters 2-90 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "correct function" = infer_exp_str {| function | Some x -> 1 | None -> 2 |} ~env; [%expect {| - ('a option -> int) |}] + 'd option -> int |}] let%expect_test "use function pattern in body" = infer_exp_str {| function | Some x -> x | None -> 2 |} ~env; [%expect {| - ('a option -> int) |}] + int option -> int |}] let%expect_test "function different constructors" = @@ -472,11 +457,11 @@ let%expect_test "function different constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 453, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 554, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 450, characters 6-314 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 551, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 466, characters 2-59 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 451, characters 2-59 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -490,11 +475,11 @@ let%expect_test "function different types of expr 1" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 455, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 556, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 450, characters 6-314 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 551, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 484, characters 2-66 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 469, characters 2-66 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -508,11 +493,11 @@ let%expect_test "function different types of expr 2" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 455, characters 11-32 + Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 556, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 450, characters 6-314 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 551, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 502, characters 2-86 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 487, characters 2-86 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -539,19 +524,19 @@ let%expect_test _ = let%expect_test "let poly" = - show_etyp [] (parse_exp_str {| let a = fun x -> x in a |}); - [%expect {| (Type_arrow ((Type_var ref ((Unbound "d"))), (Type_var ref ((Unbound "d"))))) |}] + infer_exp_str {| let a = fun x -> x in a |}; + [%expect {| 'c -> 'c |}] let%expect_test "let poly 2" = infer_exp_str {| let a = fun x -> x in (a 1, a "str") |}; - [%expect{| (int * string) |}] + [%expect{| int * string |}] let%expect_test "poly in env" = let env = ["=", Type_arrow (Quant_type_var "a", Type_arrow(Quant_type_var "a", type_bool))] in infer_exp_str {| let a = 1 in 1 = 1, "str" = "str" |} ~env; - [%expect{| (bool * bool) |}] + [%expect{| bool * bool |}] let%expect_test _ = @@ -569,12 +554,12 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 160, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 309, characters 2-19 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 243, characters 9-62 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 401, characters 2-19 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 413, characters 18-84 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 514, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 563, characters 2-46 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 548, characters 2-46 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -588,12 +573,12 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 160, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 309, characters 2-19 + Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 243, characters 9-62 + Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 401, characters 2-19 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 413, characters 18-84 + Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 514, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 582, characters 2-45 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 567, characters 2-45 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -603,25 +588,17 @@ let%expect_test "let and" = let%expect_test "factorial" = - let env = ["=", Type_arrow (Quant_type_var "a", Type_arrow(Quant_type_var "a", type_bool)); - "*", Type_arrow (type_int, Type_arrow(type_int, type_int)); - "-", Type_arrow (type_int, Type_arrow(type_int, type_int))] in infer_exp_str {| let rec fac n = if n = 1 then 1 else n * fac (n-1) in fac 4 |} ~env; [%expect {| int |}] let%expect_test "fibonacci" = - let env = ["<=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool)); - "-", Type_arrow (type_int, Type_arrow(type_int, type_int)); - "+", Type_arrow (type_int, Type_arrow(type_int, type_int))] in infer_exp_str {| let rec fib n = if n <= 1 then 1 else (fib (n-1)) + (fib (n-2)) in fib 4 |} ~env; [%expect {| int |}] let%expect_test "mutual recursion" = - let env = ["=", Type_arrow (Type_var {contents = Unbound "a"}, Type_arrow(Type_var {contents = Unbound "a"}, type_bool)); - "-", Type_arrow (type_int, Type_arrow(type_int, type_int)); - "not", Type_arrow (type_bool, type_bool); "true", type_bool] in + let env = env @ ["not", Type_arrow (type_bool, type_bool); "true", type_bool] in infer_exp_str ~env {| let rec is_odd n = if n = 0 then true else is_even (n-1) @@ -631,6 +608,76 @@ let%expect_test "mutual recursion" = [%expect {| bool |}] +let%expect_test "shadow with itself" = + infer_prog_str + {| + let test3 a b c = + let a = print_int a in 0 + |}; +[%expect{| val test3 : int -> 'a -> 'b -> int |}];; + + +let%expect_test "shadow" = + infer_prog_str {| + let x = 5 + + let x = "string" + |}; +[%expect {| + val x : string |}] + + +let%expect_test "shadow with itself 2" = + infer_prog_str {| + let x = 5 + + let x = x + |}; +[%expect {| + val x : int |}] + + +let%expect_test "weird let rec" = + infer_prog_str {| let rec x = x |}; +[%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure + "this kind of expression is not allowed as right-hand side of `let rec'") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Middleend__InferLayers.infer_vb_rec in file "lib/middleend/inferLayers.ml", line 422, characters 8-89 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_structure_item in file "lib/middleend/inferLayers.ml", line 581, characters 6-80 + Called from Middleend__InferLayers.infer_program.(fun) in file "lib/middleend/inferLayers.ml", line 591, characters 34-67 + Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 + Called from Middleend__InferLayers.infer_program in file "lib/middleend/inferLayers.ml", line 589, characters 4-189 + Called from XML_unittests__Infer.infer_prog_str in file "many_tests/unit/infer.ml", line 27, characters 19-41 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 641, characters 2-36 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + + +let%expect_test "too polymorphic1" = + infer_prog_str {| let map f p = let (a,b) = p in (f a, f b) |}; +[%expect {| val map : ('a -> 'b) -> 'c * 'd -> 'b * 'b |}] + +let%expect_test "too polymorphic" = + show_etyp [] (parse_exp_str {| let map f p = let (a,b) = p in (f a, f b) in map |}); +[%expect {| + (Type_arrow ( + (Type_arrow ((Type_var ref ((Unbound "s"))), + (Type_var ref ((Unbound "t"))))), + (Type_arrow ( + (Type_tuple + ((Type_var ref ((Unbound "u"))), (Type_var ref ((Unbound "v"))), [])), + (Type_tuple + ((Type_var ref ((Unbound "t"))), (Type_var ref ((Unbound "t"))), [])) + )) + )) |}] + + (* сделать pprint для текущего инфера заменить старый инфер на новый проверить, что тесты не упали, если упали, то починить From 0421c39122ffc127c8f0821c003b04f58ba72773 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 2 Mar 2026 20:56:43 +0300 Subject: [PATCH 47/84] feat: move new types to ast, add infer for typed pats/exprs, delete previous type sys --- XML/lib/common/ast.ml | 21 +- XML/lib/common/ast.mli | 14 +- XML/lib/common/parser.ml | 2 +- XML/lib/common/pprinter.ml | 164 +++- XML/lib/common/pprinter.mli | 1 + XML/lib/middleend/dune | 2 +- XML/lib/middleend/infer.ml | 1160 +++++++++-------------------- XML/lib/middleend/infer.mli | 41 + XML/lib/middleend/inferLayers.ml | 636 ---------------- XML/lib/middleend/inferLayers.mli | 65 -- XML/lib/middleend/inferTypes.ml | 188 ----- XML/many_tests/infer.t | 17 +- XML/many_tests/unit/infer.ml | 113 ++- 13 files changed, 628 insertions(+), 1796 deletions(-) create mode 100644 XML/lib/middleend/infer.mli delete mode 100644 XML/lib/middleend/inferLayers.ml delete mode 100644 XML/lib/middleend/inferLayers.mli delete mode 100644 XML/lib/middleend/inferTypes.ml diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 2b44e234..acc590d1 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -95,7 +95,7 @@ module Constant = struct end module TypeExpr = struct - type t = + (* type t = | Type_arrow of t * t (** [Type_arrow(T1, T2)] represents: [T1 -> T2] *) @@ -105,7 +105,24 @@ module TypeExpr = struct (** [Type_construct(lident, l)] represents: - [tconstr] when [l=[]], - [T tconstr] when [l=[T]], - - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. *) + - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. *) *) + + let gen_ref inner_gen = + let open QCheck.Gen in + map (fun x -> ref x) inner_gen + ;; + + type t = + | Type_arrow of t * t + | Type_tuple of t List2.t + | Type_var of tv ref + | Quant_type_var of ident + | Type_construct of ident * t list + [@@deriving eq, show { with_path = false }, qcheck] + + and tv = + | Unbound of ident + | Link of t [@@deriving eq, show { with_path = false }, qcheck] end diff --git a/XML/lib/common/ast.mli b/XML/lib/common/ast.mli index da329dc5..98196938 100644 --- a/XML/lib/common/ast.mli +++ b/XML/lib/common/ast.mli @@ -48,12 +48,24 @@ module Constant : sig end module TypeExpr : sig - type t = + (* + type t = | Type_arrow of t * t (** Represents a function type: [T1 -> T2]. *) | Type_var of ident (** Represents a type variable: ['a]. *) | Type_tuple of t List2.t (** Represents a tuple type: [(T1, T2, ..., Tn)]. *) | Type_construct of ident * t list (** Represents a type constructor with arguments: [C T1 ... Tn]. *) + *) + type t = + | Type_arrow of t * t + | Type_tuple of t List2.t + | Type_var of tv ref + | Quant_type_var of ident + | Type_construct of ident * t list + + and tv = + | Unbound of ident + | Link of t val equal : t -> t -> bool val pp : Format.formatter -> t -> unit diff --git a/XML/lib/common/parser.ml b/XML/lib/common/parser.ml index 3da21a32..90d8eecd 100644 --- a/XML/lib/common/parser.ml +++ b/XML/lib/common/parser.ml @@ -151,7 +151,7 @@ let pmultiargsapp pty = let ptypevar = let* id = token "'" *> (pident_lc <|> pident_cap) in - return (TypeExpr.Type_var id) + return (TypeExpr.Type_var { contents = Unbound id }) ;; let ptypetuple ptype = diff --git a/XML/lib/common/pprinter.ml b/XML/lib/common/pprinter.ml index 5ac80715..9161471a 100644 --- a/XML/lib/common/pprinter.ml +++ b/XML/lib/common/pprinter.ml @@ -38,38 +38,148 @@ let pprint_constant fmt = | Const_string s -> fprintf fmt "%S" s ;; -let rec pprint_type fmt = +let rearr_typvars typ = + let open Base in + let open TypeExpr in + let var_counter = ref 0 in + let rec rename t var_map = + match t with + | Type_arrow (t1, t2) -> + let t1', map1 = rename t1 var_map in + let t2', map2 = rename t2 map1 in + Type_arrow (t1', t2'), map2 + | Type_tuple (t1, t2, tl) -> + let t1', map1 = rename t1 var_map in + let t2', map2 = rename t2 map1 in + let ts = tl in + List.fold_left ts ~init:([], map2) ~f:(fun (acc_ts, acc_map) t_elem -> + let t_elem', new_map = rename t_elem acc_map in + t_elem' :: acc_ts, new_map) + |> fun (rev_ts, final_map) -> Type_tuple (t1', t2', List.rev rev_ts), final_map + | Type_var tv_ref -> + (match !tv_ref with + | Unbound _ -> Type_var tv_ref, var_map + | Link linked_t -> rename linked_t var_map) + | Quant_type_var id -> + (match Map.find var_map id with + | Some new_id -> Quant_type_var new_id, var_map + | None -> + let idx = !var_counter in + var_counter := idx + 1; + let new_id = + if idx < 26 + then String.make 1 (Char.of_int_exn (97 + idx)) + else ( + let prefix_count = (idx / 26) - 1 in + let suffix_idx = idx mod 26 in + "'" + ^ String.make (prefix_count + 1) (Char.of_int_exn (97 + (idx / 26) - 1)) + ^ String.make 1 (Char.of_int_exn (97 + suffix_idx))) + in + let new_map = Map.set var_map ~key:id ~data:new_id in + Quant_type_var new_id, new_map) + | Type_construct (id, args) -> + List.fold_left args ~init:([], var_map) ~f:(fun (acc_args, acc_map) arg -> + let arg', new_map = rename arg acc_map in + arg' :: acc_args, new_map) + |> fun (rev_args, final_map) -> Type_construct (id, List.rev rev_args), final_map + in + fst (rename typ (Map.empty (module String))) +;; + +let rec pprint_type_tuple fmt = + let open Format in let open TypeExpr in function - | Type_arrow (tye1, tye2) -> fprintf fmt "(%a -> %a)" pprint_type tye1 pprint_type tye2 - | Type_var id -> fprintf fmt "'%s" id - | Type_tuple (tye1, tye2, tyel) -> + | [] -> () + | [ h ] -> + (match h with + | Type_arrow (_, _) -> fprintf fmt "(%a)" pprint_type h + | _ -> fprintf fmt "%a" pprint_type h) + | h :: tl -> + (match h with + | Type_arrow (_, _) -> fprintf fmt "(%a) * %a" pprint_type h pprint_type_tuple tl + | _ -> fprintf fmt "%a * %a" pprint_type h pprint_type_tuple tl) + +and pprint_type_list_with_parens fmt ty_list = + let open Format in + let rec print_types fmt = function + | [] -> () + | [ ty ] -> pprint_type_with_parens_if_tuple fmt ty + | ty :: rest -> + fprintf fmt "%a %a" pprint_type_with_parens_if_tuple ty print_types rest + in + print_types fmt ty_list + +and pprint_type fmt typ = + let open TypeExpr in + let rec is_arrow = function + | Type_arrow _ -> true + | Type_var { contents = Link t } -> is_arrow t + | _ -> false + in + let rec is_tuple = function + | Type_tuple _ -> true + | Type_var { contents = Link t } -> is_tuple t + | _ -> false + in + let open Format in + match typ with + | Type_arrow (t1, t2) when is_arrow t1 -> + fprintf fmt "(%a) -> %a" pprint_type t1 pprint_type t2 + | Type_arrow (t1, t2) -> fprintf fmt "%a -> %a" pprint_type t1 pprint_type t2 + | Type_tuple (t1, t2, tl) -> fprintf fmt - "(%s)" - (String.concat + "%s" + (Base.String.concat ~sep:" * " - (List.map (tye1 :: tye2 :: tyel) ~f:(fun t -> asprintf "%a" pprint_type t))) - | Type_construct (id, tyel) -> - let tyel_str = - String.concat - ~sep:", " - (List.map tyel ~f:(fun t -> - match t with - | Type_var tye -> asprintf "'%s" tye - | Type_tuple (t1, t2, rest) -> - let tuple_types = t1 :: t2 :: rest in - let tuple_str = String.concat ~sep:" * " (List.map tuple_types ~f:show) in - "(" ^ tuple_str ^ ")" - | _ -> show t)) - in - let tyel_strf = - match List.length tyel with - | 0 -> "" - | 1 -> tyel_str ^ " " - | _ -> "(" ^ tyel_str ^ ") " - in - fprintf fmt "%s%s" tyel_strf id + (List.map + ~f:(fun t -> + if is_tuple t + then asprintf "(%a)" pprint_type t + else asprintf "%a" pprint_type t) + (t1 :: t2 :: tl))) + | Type_var { contents = Unbound id } -> fprintf fmt "'%s" id + | Type_var { contents = Link t } -> pprint_type fmt t + | Quant_type_var id -> fprintf fmt "'%s" id + | Type_construct (name, []) -> fprintf fmt "%s" name + | Type_construct (name, ty_list) -> + fprintf fmt "%a %s" pprint_type_list_with_parens ty_list name + +and pprint_type_with_parens_if_tuple fmt ty = + let open Format in + match ty with + | Type_tuple _ -> fprintf fmt "(%a)" pprint_type ty + | _ -> pprint_type fmt ty +;; + +let filter_env (env : (ident * TypeExpr.t) list) (names : ident list) = + List.fold_left + ~f:(fun acc name -> + match Stdlib.List.assoc_opt name env, Stdlib.List.assoc_opt name acc with + | Some ty, None -> (name, ty) :: acc + | _ -> acc) + ~init:[] + names +;; + +let pprint_env env names = + let open Format in + let new_env = filter_env env names in + List.iter + ~f:(fun (key, typ) -> + if + String.length key > 0 + && Stdlib.Char.code key.[0] >= 65 + && Stdlib.Char.code key.[0] <= 90 + then () + else if String.equal key "-" + then printf "%s : %a\n" key pprint_type typ + else ( + let typ = rearr_typvars typ in + printf "val %s : %a\n" key pprint_type typ)) + new_env ;; let rec pprint_pattern fmt = diff --git a/XML/lib/common/pprinter.mli b/XML/lib/common/pprinter.mli index c709f7d2..4bc58c7e 100644 --- a/XML/lib/common/pprinter.mli +++ b/XML/lib/common/pprinter.mli @@ -6,6 +6,7 @@ open Ast val pprint_constant : Format.formatter -> Constant.t -> unit val pprint_type : Format.formatter -> TypeExpr.t -> unit +val pprint_env : (ident * TypeExpr.t) list -> ident list -> unit val pprint_pattern : Format.formatter -> Pattern.t -> unit val pprint_rec : Format.formatter -> Expression.rec_flag -> unit val pprint_expression : Format.formatter -> int -> Expression.t -> unit diff --git a/XML/lib/middleend/dune b/XML/lib/middleend/dune index 29b9e1a5..9bd1699a 100644 --- a/XML/lib/middleend/dune +++ b/XML/lib/middleend/dune @@ -1,7 +1,7 @@ (library (name middleend) (public_name XML.Middleend) - (modules Anf Pprinter Cc Ll InferTypes Infer InferLayers) + (modules Anf Pprinter Cc Ll Infer) (libraries angstrom base stdio XML.Common) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving_qcheck)) diff --git a/XML/lib/middleend/infer.ml b/XML/lib/middleend/infer.ml index afb8dabe..2f0aadb8 100644 --- a/XML/lib/middleend/infer.ml +++ b/XML/lib/middleend/infer.ml @@ -1,367 +1,171 @@ -(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) (** SPDX-License-Identifier: LGPL-3.0-or-later *) +open Common.Ast +open Common.Ast.Expression +open Common.Ast.Structure +open Common.Ast.Pattern open Common.Ast.TypeExpr -open InferTypes - -module MInfer = struct - open Base - - type 'a t = int -> int * ('a, InferTypes.error) Result.t - - let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = - fun m f st -> - let last, r = m st in - match r with - | Result.Error x -> last, Error x - | Ok a -> f a last - ;; - - let fail e st = st, Result.fail e - let return x last = last, Result.return x - let bind x ~f = x >>= f - - let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = - fun x f st -> - match x st with - | st, Ok x -> st, Ok (f x) - | st, Result.Error e -> st, Result.Error e - ;; - - module Syntax = struct - let ( let* ) x f = bind x ~f - end - - module RList = struct - let fold_left xs ~init ~f = - Base.List.fold_left xs ~init ~f:(fun acc x -> - let open Syntax in - let* acc = acc in - f acc x) - ;; - - let fold_left2 xs xl ~init ~f = - Base.List.fold2 - ~f:(fun acc x l -> - let open Syntax in - let* acc = acc in - f acc x l) - ~init - xs - xl - ;; - - let fold_right xs ~init ~f = - Base.List.fold_right xs ~init ~f:(fun x acc -> - let open Syntax in - let* acc = acc in - f x acc) - ;; - end - - let fresh : int t = fun last -> last + 1, Result.Ok last - let run m = snd (m 0) -end - -module Type = struct - type t = Common.Ast.TypeExpr.t - - let rec occurs_check tvar = function - | Type_var binder -> binder = tvar - | Type_arrow (l, r) -> occurs_check tvar l || occurs_check tvar r - | Type_tuple (t1, t2, t) -> - List.fold_left (fun acc h -> acc || occurs_check tvar h) false (t1 :: t2 :: t) - | Type_construct (_, ty) -> - List.fold_left (fun acc h -> acc || occurs_check tvar h) false ty - ;; - - let free_vars = - let rec helper acc = function - | Type_var binder -> VarSet.add binder acc - | Type_arrow (l, r) -> helper (helper acc l) r - | Type_tuple (t1, t2, t) -> - List.fold_left (fun acc h -> helper acc h) acc (t1 :: t2 :: t) - | Type_construct (_, ty) -> List.fold_left (fun acc h -> helper acc h) acc ty - in - helper VarSet.empty - ;; -end - -module Substitution = struct - open MInfer - open MInfer.Syntax - open Base - - type t = (string, Type.t, Base.String.comparator_witness) Base.Map.t - - let empty = Map.empty (module Base.String) - - let singleton k v = - match k, v with - | a, Type_var b when String.equal a b -> return (Base.Map.empty (module Base.String)) - | _ -> - if Type.occurs_check k v - then fail (Occurs_check (k, v)) - else return (Base.Map.singleton (module Base.String) k v) - ;; - - let remove = Map.remove - - let apply sub = - let rec helper = function - | Type_var b as typ -> - (match Map.find sub b with - | Some b -> b - | None -> typ) - | Type_arrow (l, r) -> Type_arrow (helper l, helper r) - | Type_tuple (t1, t2, t) -> Type_tuple (helper t1, helper t2, List.map t ~f:helper) - | Type_construct (id, ty) -> Type_construct (id, List.map ty ~f:helper) - in - helper - ;; - - let fold mp init f = - Map.fold mp ~init ~f:(fun ~key:k ~data:vm acc -> - let* acc = acc in - f k vm acc) - ;; - - let rec unify l r = - match l, r with - | Type_var a, Type_var b when String.equal a b -> return empty - | Type_var b, t | t, Type_var b -> singleton b t - | Type_arrow (l1, r1), Type_arrow (l2, r2) -> - let* subs1 = unify l1 l2 in - let* subs2 = unify (apply subs1 r1) (apply subs1 r2) in - compose subs1 subs2 - | Type_tuple (l11, l12, l1), Type_tuple (l21, l22, l2) -> - (match - Base.List.fold2 - (l11 :: l12 :: l1) - (l21 :: l22 :: l2) - ~init:(return empty) - ~f:(fun acc t1 t2 -> - let* sub1 = acc in - let* sub2 = unify (apply sub1 t1) (apply sub1 t2) in - compose sub1 sub2) - with - | Ok sub -> sub - | _ -> fail (Unification_failed (l, r))) - | Type_construct (id1, ty1), Type_construct (id2, ty2) when String.equal id1 id2 -> - let* subs = - match - Base.List.fold2 ty1 ty2 ~init:(return empty) ~f:(fun acc t1 t2 -> - let* sub1 = acc in - let* sub2 = unify (apply sub1 t1) (apply sub1 t2) in - compose sub1 sub2) - with - | Ok sub -> sub - | _ -> fail (Unification_failed (l, r)) - in - return subs - | _ -> fail (Unification_failed (l, r)) - - and extend k v s = - match Map.find s k with - | None -> - let v = apply s v in - let* s2 = singleton k v in - fold s (return s2) (fun k v acc -> - let* acc = return acc in - let v = apply s2 v in - return (Map.update acc k ~f:(fun _ -> v))) - | Some v2 -> - let* s2 = unify v v2 in - compose s s2 - - and compose s1 s2 = fold s2 (return s1) extend - and compose_all ss = RList.fold_left ss ~init:(return empty) ~f:compose -end - -module Scheme = struct - type t = scheme - - let free_vars = function - | Forall (bs, t) -> VarSet.diff (Type.free_vars t) bs - ;; - - let apply subst (Forall (binder_set, typ)) = - let s2 = VarSet.fold (fun k s -> Substitution.remove s k) binder_set subst in - Forall (binder_set, Substitution.apply s2 typ) - ;; - - let pp_scheme fmt = function - | Forall (st, typ) -> - if VarSet.is_empty st - then - Format.fprintf - fmt - "%a" - (pprint_type ~poly_names_map:(Base.Map.empty (module Base.String))) - typ - else - Format.fprintf - fmt - "%a. %a" - VarSet.pp - st - (pprint_type ~poly_names_map:(Base.Map.empty (module Base.String))) - typ - ;; -end - -module TypeEnv = struct - open Base - - type t = (string, scheme, String.comparator_witness) Map.t - - let extend env name scheme = Map.set env ~key:name ~data:scheme - let empty = Map.empty (module String) - let fold f init mp = Map.fold mp ~init ~f:(fun ~key:k ~data:v acc -> f k v acc) - - let free_vars : t -> VarSet.t = - fold (fun _ s acc -> VarSet.union acc (Scheme.free_vars s)) VarSet.empty - ;; +open Common.Pprinter + +let rec occurs_check tv = function + | Type_var tv' when tv == tv' -> failwith "occurs check" + | Type_var { contents = Link t } -> occurs_check tv t + | Type_arrow (t1, t2) -> + occurs_check tv t1; + occurs_check tv t2 + | Type_tuple (t1, t2, tl) -> List.map (occurs_check tv) (t1 :: t2 :: tl) |> ignore + | Type_construct (_, lst) -> List.map (occurs_check tv) lst |> ignore + | _ -> () +;; - let apply s env = Map.map env ~f:(Scheme.apply s) - let find name xs = Map.find xs name - let find_exn name xs = Map.find_exn xs name - let remove sub k = Base.Map.remove sub k +let rec unify t1 t2 = + match t1, t2 with + | t1, t2 when t1 == t2 -> () + | Type_var { contents = Link t1 }, t2 | t1, Type_var { contents = Link t2 } -> + unify t1 t2 + | Type_var ({ contents = Unbound _ } as tv), t' + | t', Type_var ({ contents = Unbound _ } as tv) -> + occurs_check tv t'; + tv := Link t' + | Type_arrow (l1, l2), Type_arrow (r1, r2) -> + unify l1 r1; + unify l2 r2 + | Type_tuple (l1, l2, ltl), Type_tuple (r1, r2, rtl) -> + if List.length ltl <> List.length rtl + then failwith "cannot unify tuple types of different size"; + List.map2 unify (l1 :: l2 :: ltl) (r1 :: r2 :: rtl) |> ignore + | Type_construct (lc, llst), Type_construct (rc, rlst) -> + if lc <> rc + then failwith ("can't unify different constructors: " ^ lc ^ " and " ^ rc) + else List.map2 unify llst rlst |> ignore + | Quant_type_var _, _ | _, Quant_type_var _ -> + failwith "cannot unify with a quantified type" + | _ -> + failwith + (Format.asprintf "cannot unify types: %a and %a" pprint_type t1 pprint_type t2) +;; - let pp_env fmt environment = - Map.iteri environment ~f:(fun ~key ~data -> - Stdlib.Format.fprintf fmt "%S: %a\n" key Scheme.pp_scheme data) - ;; -end +let rec generalize = function + | Type_var { contents = Unbound name } -> Quant_type_var name + | Type_var { contents = Link ty } -> generalize ty + | Type_arrow (ty1, ty2) -> Type_arrow (generalize ty1, generalize ty2) + | Type_tuple (t1, t2, tl) -> + Type_tuple (generalize t1, generalize t2, List.map generalize tl) + | Type_construct (c, lst) -> Type_construct (c, List.map generalize lst) + | ty -> ty +;; -open MInfer -open MInfer.Syntax +type env = (ident * TypeExpr.t) list -let fresh_var = fresh >>| fun n -> Type_var (Int.to_string n) +let gensym_counter = ref 0 +let reset_gensym : unit -> unit = fun () -> gensym_counter := 0 -let instantiate : scheme -> Common.Ast.TypeExpr.t MInfer.t = - fun (Forall (bs, t)) -> - VarSet.fold - (fun name typ -> - let* typ = typ in - let* f1 = fresh_var in - let* s = Substitution.singleton name f1 in - return (Substitution.apply s typ)) - bs - (return t) +let gensym : unit -> string = + fun () -> + let n = !gensym_counter in + let () = incr gensym_counter in + if n < 26 then String.make 1 (Char.chr (Char.code 'a' + n)) else "t" ^ string_of_int n ;; -let generalize : TypeEnv.t -> Type.t -> Scheme.t = - fun env ty -> - let free = VarSet.diff (Type.free_vars ty) (TypeEnv.free_vars env) in - Forall (free, ty) +let newvar () = Type_var (ref (Unbound (gensym ()))) + +let inst = + let rec loop subst = function + | Quant_type_var name -> + (match List.assoc_opt name subst with + | Some typ -> typ, subst + | None -> + let tv = newvar () in + tv, (name, tv) :: subst) + | Type_var { contents = Link ty } -> loop subst ty + | Type_arrow (t1, t2) -> + let t1', subst = loop subst t1 in + let t2', subst = loop subst t2 in + Type_arrow (t1', t2'), subst + | Type_tuple (t1, t2, tl) -> + let t1', subst = loop subst t1 in + let t2', subst = loop subst t2 in + let tl'_rev, subst = + List.fold_left + (fun (acc, subst) t -> + let t', subst = loop subst t in + t' :: acc, subst) + ([], subst) + tl + in + let tl' = List.rev tl'_rev in + Type_tuple (t1', t2', tl'), subst + | Type_construct (constr, lst) -> + let lst'_rev, subst = + List.fold_left + (fun (acc, subst) t -> + let t', subst = loop subst t in + t' :: acc, subst) + ([], subst) + lst + in + let lst' = List.rev lst'_rev in + Type_construct (constr, lst'), subst + | ty -> ty, subst + in + fun ty -> fst (loop [] ty) ;; -open Common.Ast.Constant -open Common.Ast.Expression -open Common.Ast.Pattern - -let rec infer_pat ~debug pat env = - match pat with +let rec infer_pat env = function | Pat_any -> - let* fresh = fresh_var in - return (env, fresh) - | Pat_var ident -> - let* fresh = fresh_var in - let new_env = TypeEnv.extend env ident (Forall (VarSet.empty, fresh)) in - return (new_env, fresh) + let fresh = newvar () in + env, fresh + | Pat_var id -> + let fresh = newvar () in + let new_env = (id, fresh) :: env in + new_env, fresh | Pat_constant const -> (match const with - | Const_char _ -> return (env, Type_construct ("char", [])) - | Const_integer _ -> return (env, Type_construct ("int", [])) - | Const_string _ -> return (env, Type_construct ("string", []))) - | Pat_tuple (pat1, pat2, rest) -> - let* env1, typ1 = infer_pat ~debug pat1 env in - let* env2, typ2 = infer_pat ~debug pat2 env1 in - let* env3, typ3 = - RList.fold_right - ~f:(fun pat acc -> - let* env_acc, typ_list = return acc in - let* env, typ = infer_pat ~debug pat env_acc in - return (env, typ :: typ_list)) - ~init:(return (env2, [])) - rest + | Const_char _ -> env, Type_construct ("char", []) + | Const_integer _ -> env, Type_construct ("int", []) + | Const_string _ -> env, Type_construct ("string", [])) + | Pat_tuple (p1, p2, ptl) -> + let new_env, ty1 = infer_pat env p1 in + let new_env1, ty2 = infer_pat new_env p2 in + let new_env2, tytl = + List.fold_left + (fun (eacc, tacc) exp -> + let curr_env, ty = infer_pat eacc exp in + curr_env, ty :: tacc) + (new_env1, []) + ptl in - return (env3, Type_tuple (typ1, typ2, typ3)) + new_env2, Type_tuple (ty1, ty2, List.rev tytl) | Pat_construct (name, pat) -> - (match TypeEnv.find name env with - | None -> fail (Unbound_variable name) - | Some (Forall (x, Type_arrow (arg, adt))) -> - let* typ = instantiate (Forall (x, Type_arrow (arg, adt))) in - (match pat with - | Some const_pat -> - let* patenv, typepat = infer_pat ~debug const_pat env in - let* uni_sub = Substitution.unify arg typepat in - let new_env = TypeEnv.apply uni_sub patenv in - return (new_env, Substitution.apply uni_sub adt) - | None -> return (env, typ)) - | Some el -> - let* typ = instantiate el in - return (env, typ)) - | Pat_constraint (pat, typ) -> - let* pat_env, pat_typ = infer_pat ~debug pat env in - let* uni_sub = Substitution.unify pat_typ typ in - let new_env = TypeEnv.apply uni_sub pat_env in - return (new_env, Substitution.apply uni_sub pat_typ) + let ty = List.assoc name env in + let inst_ty = inst ty in + (match inst_ty, pat with + | Type_arrow (arg, body), Some p -> + let new_env, new_ty = infer_pat env p in + unify arg new_ty; + new_env, body + | _ -> env, inst_ty) + | Pat_constraint (p, ty) -> + let new_env, new_ty = infer_pat env p in + unify ty new_ty; + new_env, new_ty ;; -let rec extend_helper env pat (Forall (binder_set, typ) as scheme) = - match pat, typ with - | Pat_var name, _ -> TypeEnv.extend env name scheme - | Pat_tuple (p1, p2, prest), Type_tuple (t1, t2, trest) -> - let new_env = - Base.List.fold2 - ~init:env - ~f:(fun env pat typ -> extend_helper env pat (Forall (binder_set, typ))) - (p1 :: p2 :: prest) - (t1 :: t2 :: trest) - in - (match new_env with - | Ok new_env -> new_env - | _ -> env) - | _ -> env -;; - -let add_names_rec env vb_list = - RList.fold_right - ~f:(fun vb acc -> - match vb with - | { pat = Pat_var name; _ } | { pat = Pat_constraint (Pat_var name, _); _ } -> - let* env_acc, fresh_acc = return acc in - let* fresh = fresh_var in - let env_acc = TypeEnv.extend env_acc name (Forall (VarSet.empty, fresh)) in - return (env_acc, fresh :: fresh_acc) - | _ -> fail Wrong_rec) +let add_rec_names env vb_list = + List.fold_left + (fun cenv { pat; _ } -> + match pat with + | Pat_var id | Pat_constraint (Pat_var id, _) -> + let ncenv, typ_p = infer_pat cenv pat in + (id, typ_p) :: ncenv + | _ -> + failwith + "only variables are allowed as left-hand side of 'let rec' (during adding rec \ + names)") + env vb_list - ~init:(return (env, [])) -;; - -let infer_rest_vb ~debug env_acc sub_acc sub typ pat = - let* comp_sub = Substitution.compose sub_acc sub in - let new_env = TypeEnv.apply comp_sub env_acc in - let new_scheme = generalize new_env (Substitution.apply comp_sub typ) in - let* pat_env, pat_typ = infer_pat ~debug pat new_env in - let new_env = extend_helper pat_env pat new_scheme in - let* uni_sub = Substitution.unify typ pat_typ in - let* res_sub = Substitution.compose comp_sub uni_sub in - let res_env = TypeEnv.apply res_sub new_env in - return (res_env, res_sub) -;; - -let infer_rec_rest_vb sub_acc env_acc fresh typ name new_sub = - let* uni_sub = Substitution.unify (Substitution.apply new_sub fresh) typ in - let* comp_sub = Substitution.compose_all [ new_sub; uni_sub; sub_acc ] in - let env_acc = TypeEnv.apply comp_sub env_acc in - let env_rm = TypeEnv.remove env_acc name in - let new_scheme = generalize env_rm (Substitution.apply comp_sub fresh) in - let env_acc = TypeEnv.extend env_acc name new_scheme in - return (env_acc, comp_sub) ;; let rec get_pat_names acc pat = @@ -374,497 +178,245 @@ let rec get_pat_names acc pat = | _ -> acc ;; -let rec infer_exp ~debug exp env = - match exp with - | Exp_ident varname -> - (match TypeEnv.find varname env with - | None -> fail (Unbound_variable varname) - | Some x -> - let* typ = instantiate x in - return (Substitution.empty, typ)) +let rec infer_vb env { pat; expr } = + (* we don't need local names *) + let _, typ_e = infer_exp env expr in + let new_env, typ_p = infer_pat env pat in + unify typ_p typ_e; + let pat_names = get_pat_names [] pat in + let new_env1 = + List.fold_left + (fun env name -> + let typ = List.assoc name env in + let env = List.remove_assoc name env in + (name, generalize typ) :: env) + new_env + pat_names + in + new_env1 + +and infer_vb_rec env { pat; expr } = + match pat with + | Pat_var id | Pat_constraint (Pat_var id, _) -> + let new_env, typ_p = infer_pat env pat in + let new_env = (id, typ_p) :: new_env in + let new_env1, typ_e = + match expr with + | Exp_ident eid when id = eid -> + failwith "this kind of expression is not allowed as right-hand side of `let rec'" + | _ -> infer_exp new_env expr + in + unify typ_p typ_e; + let pat_names = get_pat_names [] pat in + let new_env2 = + List.fold_left + (fun env name -> + let typ = List.assoc name env in + let env = List.remove_assoc name env in + (name, generalize typ) :: env) + new_env1 + pat_names + in + new_env2 + | _ -> failwith "only variables are allowed as left-hand side of 'let rec'" + +and infer_exp env = function + | Exp_ident id -> + (match List.assoc_opt id env with + | Some ty -> env, inst ty + | None -> failwith ("unbound variable: " ^ id)) | Exp_constant const -> (match const with - | Const_char _ -> return (Substitution.empty, Type_construct ("char", [])) - | Const_integer _ -> return (Substitution.empty, Type_construct ("int", [])) - | Const_string _ -> return (Substitution.empty, Type_construct ("string", []))) + | Const_char _ -> env, Type_construct ("char", []) + | Const_integer _ -> env, Type_construct ("int", []) + | Const_string _ -> env, Type_construct ("string", [])) + | Exp_fun ((pat, pats), exp) -> + let new_env, typ_p = infer_pat env pat in + let newest_env, typ_exp = + match pats with + | hd :: tl -> infer_exp new_env (Exp_fun ((hd, tl), exp)) + | [] -> infer_exp new_env exp + in + newest_env, Type_arrow (typ_p, typ_exp) | Exp_apply (Exp_ident op, Exp_tuple (exp1, exp2, [])) -> (match op with | "*" | "/" | "+" | "-" | "<" | ">" | "=" | "<>" | "<=" | ">=" | "&&" | "||" -> - let* sub1, typ1 = infer_exp ~debug exp1 env in - let* sub2, typ2 = infer_exp ~debug exp2 (TypeEnv.apply sub1 env) in - let* arg_typ, res_typ = - match TypeEnv.find op env with - | Some (Forall (_, Type_arrow (Type_arrow (arg, _), res))) -> return (arg, res) - | _ -> fail @@ Unsupported_operator op + let new_env, typ1 = infer_exp env exp1 in + let new_env1, typ2 = infer_exp new_env exp2 in + let arg_typ, res_typ = + match List.assoc_opt op env with + | Some (Type_arrow (arg, Type_arrow (_, res))) -> inst arg, inst res + | _ -> failwith ("operator was not found in env: " ^ op) in - let* unif_sub1 = Substitution.unify (Substitution.apply sub2 typ1) arg_typ in - let* unif_sub2 = Substitution.unify (Substitution.apply unif_sub1 typ2) arg_typ in - let* comp_sub = Substitution.compose_all [ sub1; sub2; unif_sub1; unif_sub2 ] in - return (comp_sub, res_typ) + unify typ1 arg_typ; + unify typ2 arg_typ; + new_env1, res_typ | _ -> - let* sub1, typ1 = infer_exp ~debug (Exp_ident op) env in - let* sub2, typ2 = - infer_exp ~debug (Exp_tuple (exp1, exp2, [])) (TypeEnv.apply sub1 env) - in - let* fresh = fresh_var in - let* unif_sub = - Substitution.unify (Substitution.apply sub2 typ1) (Type_arrow (typ2, fresh)) - in - let* comp_sub = Substitution.compose_all [ unif_sub; sub2; sub1 ] in - let res_typ = Substitution.apply comp_sub fresh in - return (comp_sub, res_typ)) - | Exp_apply (exp1, exp2) -> - (match exp1 with - | Exp_ident op when op = "+" || op = "-" -> - let* sub1, typ1 = infer_exp ~debug exp2 env in - let* unif_sub = Substitution.unify typ1 (Type_construct ("int", [])) in - let* comp_sub = Substitution.compose sub1 unif_sub in - return (comp_sub, Type_construct ("int", [])) - | _ -> - let* sub1, typ1 = infer_exp ~debug exp1 env in - let* sub2, typ2 = infer_exp ~debug exp2 (TypeEnv.apply sub1 env) in - let* fresh = fresh_var in - let* unif_sub = - Substitution.unify (Substitution.apply sub2 typ1) (Type_arrow (typ2, fresh)) - in - let* comp_sub = Substitution.compose_all [ unif_sub; sub2; sub1 ] in - let res_typ = Substitution.apply comp_sub fresh in - return (comp_sub, res_typ)) - | Exp_fun ((pattern, patterns), expr) -> - let* new_env, typ1 = infer_pat ~debug pattern env in - let* sub1, typ2 = - match patterns with - | hd :: tl -> infer_exp ~debug (Exp_fun ((hd, tl), expr)) new_env - | [] -> infer_exp ~debug expr new_env + let new_env, typ_op = infer_exp env (Exp_ident op) in + let new_env1, typ_args = infer_exp new_env (Exp_tuple (exp1, exp2, [])) in + let typ_res = newvar () in + unify typ_op (Type_arrow (typ_args, typ_res)); + new_env1, typ_res) + | Exp_apply (Exp_ident "-", arg) -> + let new_env1, typ_arg = infer_exp env arg in + unify typ_arg (Type_construct ("int", [])); + new_env1, Type_construct ("int", []) + | Exp_apply (f, arg) -> + let new_env, typ_f = infer_exp env f in + let new_env1, typ_arg = infer_exp new_env arg in + let typ_res = newvar () in + unify typ_f (Type_arrow (typ_arg, typ_res)); + new_env1, typ_res + | Exp_construct (name, Some exp) -> infer_exp env (Exp_apply (Exp_ident name, exp)) + | Exp_construct (name, None) -> infer_exp env (Exp_ident name) + | Exp_tuple (e1, e2, etl) -> + let new_env, ty1 = infer_exp env e1 in + let new_env1, ty2 = infer_exp new_env e2 in + let new_env2, tytl = + List.fold_left + (fun (eacc, tacc) exp -> + let curr_env, ty = infer_exp eacc exp in + curr_env, ty :: tacc) + (new_env1, []) + etl in - return (sub1, Type_arrow (Substitution.apply sub1 typ1, typ2)) - | Exp_construct (name, Some expr) -> - let* ty, sub = infer_exp ~debug (Exp_apply (Exp_ident name, expr)) env in - return (ty, sub) - | Exp_construct (name, None) -> - let* ty, sub = infer_exp ~debug (Exp_ident name) env in - return (ty, sub) - | Exp_tuple (exp1, exp2, rest) -> - let* sub1, typ1 = infer_exp ~debug exp1 env in - let new_env = TypeEnv.apply sub1 env in - let* sub2, typ2 = infer_exp ~debug exp2 new_env in - let new_env = TypeEnv.apply sub2 new_env in - let* sub3, typ3 = - RList.fold_right - ~f:(fun exp acc -> - let* sub_acc, typ_list = return acc in - let new_env = TypeEnv.apply sub_acc new_env in - let* sub, typ = infer_exp ~debug exp new_env in - let* sub_acc = Substitution.compose sub_acc sub in - return (sub_acc, typ :: typ_list)) - ~init:(return (Substitution.empty, [])) - rest + new_env2, Type_tuple (ty1, ty2, List.rev tytl) + | Exp_if (cond, the, els) -> + let new_env, ty1 = infer_exp env cond in + unify ty1 (Type_construct ("bool", [])); + let new_env1, ty2 = infer_exp new_env the in + (match els with + | None -> + unify ty2 (Type_construct ("unit", [])); + new_env1, ty2 + | Some els -> + let new_env, ty3 = infer_exp new_env1 els in + unify ty2 ty3; + new_env, ty3) + | Exp_let (Nonrecursive, (vb, vbs), exprb) -> + let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in + infer_exp new_env exprb + | Exp_let (Recursive, (vb, vbs), exprb) -> + let new_env = add_rec_names env (vb :: vbs) in + let new_env1 = + List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) in - let* fin_sub = Substitution.compose_all [ sub1; sub2; sub3 ] in - let typ1 = Substitution.apply fin_sub typ1 in - let typ2 = Substitution.apply fin_sub typ2 in - let typ3 = List.map (fun typ -> Substitution.apply fin_sub typ) typ3 in - return (fin_sub, Type_tuple (typ1, typ2, typ3)) - | Exp_if (ifexp, thenexp, Some elseexp) -> - let* sub1, typ1 = infer_exp ~debug ifexp env in - let* uni_sub1 = Substitution.unify typ1 (Type_construct ("bool", [])) in - let* sub2, typ2 = infer_exp ~debug thenexp env in - let* sub3, typ3 = infer_exp ~debug elseexp env in - let* uni_sub2 = Substitution.unify typ2 typ3 in - let* comp_sub = Substitution.compose_all [ sub1; uni_sub1; sub2; sub3; uni_sub2 ] in - return (comp_sub, typ3) - | Exp_if (ifexp, thenexp, None) -> - let* sub1, typ1 = infer_exp ~debug ifexp env in - let* uni_sub1 = Substitution.unify typ1 (Type_construct ("bool", [])) in - let* sub2, typ2 = infer_exp ~debug thenexp env in - let* comp_sub = Substitution.compose_all [ sub1; uni_sub1; sub2 ] in - return (comp_sub, typ2) + infer_exp new_env1 exprb | Exp_match (expr, (case, rest)) -> - let* subexpr, typexpr = infer_exp ~debug expr env in - let new_env = TypeEnv.apply subexpr env in - let* fresh = fresh_var in - let* res_sub, res_typ = - RList.fold_left + let new_env, typ_main = infer_exp env expr in + let fresh = newvar () in + let typ_res = + List.fold_left + (fun acc_typ curr_case -> + let pat_names = get_pat_names [] curr_case.first in + let pat_env, typ_pat = infer_pat new_env curr_case.first in + unify typ_pat typ_main; + let pat_env = + List.fold_left + (fun env name -> + let typ = List.assoc name env in + let env = List.remove_assoc name env in + (name, generalize typ) :: env) + pat_env + pat_names + in + let _, typ_exp = infer_exp pat_env curr_case.second in + unify acc_typ typ_exp; + acc_typ) + fresh (case :: rest) - ~init:(return (subexpr, fresh)) - ~f:(fun acc case -> - let* sub, typ = return acc in - let pat_names = get_pat_names [] case.first in - let* pat_env, pat_typ = infer_pat ~debug case.first new_env in - let* uni_sub = Substitution.unify pat_typ typexpr in - let* comp_sub = Substitution.compose sub uni_sub in - let pat_env = - Base.List.fold_left - ~f:(fun env name -> - let (Forall (_, typ)) = TypeEnv.find_exn name env in - let env = TypeEnv.remove env name in - TypeEnv.extend env name (generalize env typ)) - ~init:(TypeEnv.apply uni_sub pat_env) - pat_names - in - let* subexpr, typexpr = - infer_exp ~debug case.second (TypeEnv.apply comp_sub pat_env) - in - let* uni_sub2 = Substitution.unify typexpr typ in - let* res_sub = Substitution.compose_all [ uni_sub2; subexpr; comp_sub ] in - return (res_sub, Substitution.apply res_sub typ)) in - return (res_sub, res_typ) + new_env, typ_res | Exp_function (case, rest) -> - let* fresh1 = fresh_var in - let* fresh2 = fresh_var in - let* res_sub, res_typ = - RList.fold_left + let fresh_p = newvar () in + let fresh_e = newvar () in + let typ_res = + List.fold_left + (fun acc_typ curr_case -> + let env_pat, typ_pat = infer_pat env curr_case.first in + unify typ_pat fresh_p; + let _, typ_exp = infer_exp env_pat curr_case.second in + unify acc_typ typ_exp; + acc_typ) + fresh_e (case :: rest) - ~init:(return (Substitution.empty, fresh2)) - ~f:(fun acc case -> - let* sub, typ = return acc in - let* pat_env, pat_typ = infer_pat ~debug case.first env in - let* uni_sub1 = Substitution.unify pat_typ fresh1 in - let* sub1 = Substitution.compose uni_sub1 sub in - let new_env = TypeEnv.apply sub1 pat_env in - let* subexpr, typexpr = infer_exp ~debug case.second new_env in - let* uni_sub2 = Substitution.unify typ typexpr in - let* comp_sub = Substitution.compose_all [ uni_sub2; subexpr; sub1 ] in - return (comp_sub, Substitution.apply comp_sub typ)) - in - return (res_sub, Type_arrow (Substitution.apply res_sub fresh1, res_typ)) - | Exp_let (Nonrecursive, (value_binding, rest), exp) -> - let* new_env, sub, _ = - infer_value_binding_list ~debug (value_binding :: rest) env Substitution.empty - in - let* subb, typp = infer_exp ~debug exp new_env in - let* comp_sub = Substitution.compose sub subb in - return (comp_sub, typp) - | Exp_let (Recursive, (value_binding, rest), exp) -> - let* new_env, fresh_vars = add_names_rec env (value_binding :: rest) in - let* new_env, sub, _ = - infer_rec_value_binding_list - ~debug - (value_binding :: rest) - new_env - Substitution.empty - fresh_vars - in - let* subb, typp = infer_exp ~debug exp new_env in - let* comp_sub = Substitution.compose subb sub in - return (comp_sub, typp) - | Exp_constraint (expr, typ) -> - let* sub, typ1 = infer_exp ~debug expr env in - let* uni_sub = Substitution.unify typ1 typ in - let* comp_sub = Substitution.compose sub uni_sub in - return (comp_sub, typ1) - -and infer_value_binding_list ~debug vb_list env sub = - let* res_env, res_sub, names = - RList.fold_left - vb_list - ~init:(return (env, sub, [])) - ~f:(fun acc vb -> - let* env_acc, sub_acc, names = return acc in - match vb with - | { pat = Pat_constraint (pat, pat_typ); expr = Exp_fun ((fpat, fpatrest), exp) } - -> - let* sub, typ = - infer_exp - ~debug - (Exp_fun ((fpat, fpatrest), Exp_constraint (exp, pat_typ))) - env_acc - in - let* res_env, res_sub = infer_rest_vb ~debug env_acc sub_acc sub typ pat in - let name = get_pat_names names pat in - return (res_env, res_sub, names @ name) - | { pat = Pat_constraint (pat, pat_typ); expr = Exp_function _ as exp } -> - let* sub, typ = infer_exp ~debug (Exp_constraint (exp, pat_typ)) env_acc in - let* res_env, res_sub = infer_rest_vb ~debug env_acc sub_acc sub typ pat in - let name = get_pat_names names pat in - return (res_env, res_sub, names @ name) - | { pat; expr } -> - let* sub, typ = infer_exp ~debug expr env_acc in - let* res_env, res_sub = infer_rest_vb ~debug env_acc sub_acc sub typ pat in - let name = get_pat_names names pat in - return (res_env, res_sub, names @ name)) - in - return (res_env, res_sub, names) - -and infer_rec_value_binding_list ~debug vb_list env sub fresh_vars = - let* res_env, res_sub, names = - match - RList.fold_left2 - vb_list - fresh_vars - ~init:(return (env, sub, [])) - ~f:(fun acc vb fv -> - let* env_acc, sub_acc, names = return acc in - match vb, fv with - | ( ( { pat = Pat_var name; expr = Exp_fun _ as exp } - | { pat = Pat_var name; expr = Exp_function _ as exp } ) - , fresh ) -> - let* subexpr, typexpr = infer_exp ~debug exp env_acc in - let* res_env, res_sub = - infer_rec_rest_vb sub_acc env_acc fresh typexpr name subexpr - in - return (res_env, res_sub, names @ [ name ]) - | ( { pat = Pat_constraint (Pat_var name, pat_typ) - ; expr = Exp_fun ((pat, pat_list), expr) - } - , fresh ) -> - let* subexpr, typexpr = - infer_exp - ~debug - (Exp_fun ((pat, pat_list), Exp_constraint (expr, pat_typ))) - env - in - let* res_env, res_sub = - infer_rec_rest_vb sub_acc env_acc fresh typexpr name subexpr - in - return (res_env, res_sub, names @ [ name ]) - | { pat = Pat_var name; expr }, fresh -> - let* subexpr, typexpr = infer_exp ~debug expr env_acc in - (match typexpr with - | Type_arrow (_, _) -> - let new_fresh = Substitution.apply sub_acc fresh in - if typexpr = new_fresh - then fail Wrong_rec - else - let* res_env, res_sub = - infer_rec_rest_vb sub_acc env_acc fresh typexpr name subexpr - in - return (res_env, res_sub, names @ [ name ]) - | _ -> fail Wrong_rec) - | _ -> fail Wrong_rec) - with - | Ok result -> result - | Unequal_lengths -> fail Incorrect_list_lengths - in - return (res_env, res_sub, names) -;; - -open Common.Ast.Structure - -let rec check_poly_types ~debug typ_list marity = function - | Type_var var when Base.List.mem typ_list var ~equal:String.equal -> return () - | Type_var name -> fail (Unbound_variable name) - | Type_construct (name, args) -> - let* arity = - Base.Map.find marity name - |> Base.Option.value_map ~f:return ~default:(fail (Undeclared_type name)) in - if arity = Base.List.length args - then check_many ~debug typ_list marity args - else fail Arity_mismatch - | Type_arrow (l, r) -> - let* () = check_poly_types ~debug typ_list marity l in - check_poly_types ~debug typ_list marity r - | Type_tuple (t1, t2, rest) -> - let* () = check_poly_types ~debug typ_list marity t1 in - let* () = check_poly_types ~debug typ_list marity t2 in - check_many ~debug typ_list marity rest - -and check_many ~debug typ_list marity args = - let rec iter = function - | [] -> return () - | arg :: rest -> - let* () = check_poly_types ~debug typ_list marity arg in - iter rest - in - iter args + env, Type_arrow (fresh_p, typ_res) + | Exp_constraint (e, ty) -> + let new_env, new_ty = infer_exp env e in + unify ty new_ty; + new_env, new_ty ;; -let ( ! ) fresh = Type_var fresh - -let infer_structure_item ~debug env item marity names = - match item with +let infer_structure_item env = function | Str_eval exp -> - let* _, typ = infer_exp ~debug exp env in - let new_env = TypeEnv.extend env "-" (Forall (VarSet.empty, typ)) in - return (new_env, marity, names @ [ "-" ]) - | Str_value (Nonrecursive, (value_binding, rest)) -> - let* env, _, names = - infer_value_binding_list ~debug (value_binding :: rest) env Substitution.empty + let _, typ = infer_exp env exp in + ("-", typ) :: env, [] + | Str_value (Nonrecursive, (vb, vbs)) -> + let new_names = + List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) in - return (env, marity, names) - | Str_value (Recursive, (value_binding, rest)) -> - let* new_env, fresh_vars = add_names_rec env (value_binding :: rest) in - let* new_env, _, names = - infer_rec_value_binding_list - ~debug - (value_binding :: rest) - new_env - Substitution.empty - fresh_vars + let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in + new_env, new_names + | Str_value (Recursive, (vb, vbs)) -> + let new_names = + List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) in - return (new_env, marity, names) - | Str_adt (poly, name, (variant, rest)) -> - let adt_type = Type_construct (name, Base.List.map poly ~f:( ! )) in - let type_arity = List.length poly in - let arity_map = Base.Map.set marity ~key:name ~data:type_arity in - let* constrs = - RList.fold_left - (variant :: rest) - ~init:(return env) - ~f:(fun acc (constr_name, constr_types) -> - let* env_acc = return acc in - let* fresh = fresh in - let* new_env = - match constr_types with - | None -> - return - (TypeEnv.extend - env_acc - constr_name - (Forall (VarSet.singleton (Int.to_string fresh), adt_type))) - | Some typ -> - let* () = check_poly_types ~debug poly arity_map typ in - return - (TypeEnv.extend - env_acc - constr_name - (Forall (VarSet.of_list poly, Type_arrow (typ, adt_type)))) - in - return new_env) + let new_env = add_rec_names env (vb :: vbs) in + let new_env1 = + List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) in - return (constrs, arity_map, names) + new_env1, new_names + | Str_adt _ -> failwith "str_adts are not supported" ;; -let infer_program ~debug program env = - let marity = Base.Map.empty (module Base.String) in - let marity = Base.Map.add_exn marity ~key:"int" ~data:0 in - let marity = Base.Map.add_exn marity ~key:"char" ~data:0 in - let marity = Base.Map.add_exn marity ~key:"string" ~data:0 in - let marity = Base.Map.add_exn marity ~key:"bool" ~data:0 in - let marity = Base.Map.add_exn marity ~key:"unit" ~data:0 in - let* env, _, names = - RList.fold_left - program - ~init:(return (env, marity, [])) - ~f:(fun acc item -> - let* env_acc, arr_acc, names = return acc in - let* env, arr, name = infer_structure_item ~debug env_acc item arr_acc names in - return (env, arr, names @ name)) +let infer_program env prog = + let new_env, new_names = + List.fold_left + (fun (env, names) str_item -> + let new_env, new_names = infer_structure_item env str_item in + new_env, new_names @ names) + (env, []) + prog in - return (env, names) + new_env, new_names ;; let env_with_things = + let type_bool = Type_construct ("bool", []) in + let type_unit = Type_construct ("unit", []) in + let type_int = Type_construct ("int", []) in let things_list = - [ ( "+" - , Forall - ( VarSet.empty - , Type_arrow - ( Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) - , Type_construct ("int", []) ) ) ) - ; ( "-" - , Forall - ( VarSet.empty - , Type_arrow - ( Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) - , Type_construct ("int", []) ) ) ) - ; ( "*" - , Forall - ( VarSet.empty - , Type_arrow - ( Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) - , Type_construct ("int", []) ) ) ) - ; ( "/" - , Forall - ( VarSet.empty - , Type_arrow - ( Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) - , Type_construct ("int", []) ) ) ) - ; ( "<" - , Forall - ( VarSet.singleton "a" - , Type_arrow - (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) - ; ( ">" - , Forall - ( VarSet.singleton "a" - , Type_arrow - (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) - ; ( "<>" - , Forall - ( VarSet.singleton "a" - , Type_arrow - (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) - ; ( "<=" - , Forall - ( VarSet.singleton "a" - , Type_arrow - (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) - ; ( ">=" - , Forall - ( VarSet.singleton "a" - , Type_arrow - (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) - ; ( "=" - , Forall - ( VarSet.singleton "a" - , Type_arrow - (Type_arrow (Type_var "a", Type_var "a"), Type_construct ("bool", [])) ) ) - ; ( "||" - , Forall - ( VarSet.empty - , Type_arrow - ( Type_arrow (Type_construct ("bool", []), Type_construct ("bool", [])) - , Type_construct ("bool", []) ) ) ) - ; ( "&&" - , Forall - ( VarSet.empty - , Type_arrow - ( Type_arrow (Type_construct ("bool", []), Type_construct ("bool", [])) - , Type_construct ("bool", []) ) ) ) - ; ( "print_int" - , Forall - ( VarSet.empty - , Type_arrow (Type_construct ("int", []), Type_construct ("unit", [])) ) ) - ; ( "print_endline" - , Forall - ( VarSet.empty - , Type_arrow (Type_construct ("string", []), Type_construct ("unit", [])) ) ) - ; ( "print_char" - , Forall - ( VarSet.empty - , Type_arrow (Type_construct ("char", []), Type_construct ("unit", [])) ) ) - ; ( "print_bool" - , Forall - ( VarSet.empty - , Type_arrow (Type_construct ("bool", []), Type_construct ("unit", [])) ) ) - ; ( "print_gc_status" - , Forall - ( VarSet.empty - , Type_arrow (Type_construct ("unit", []), Type_construct ("unit", [])) ) ) - ; ( "collect" - , Forall - ( VarSet.empty - , Type_arrow (Type_construct ("unit", []), Type_construct ("unit", [])) ) ) - ; ( "alloc_block" - , Forall - ( VarSet.empty - , Type_arrow (Type_construct ("int", []), Type_construct ("int", [])) ) ) + [ "||", Type_arrow (type_bool, Type_arrow (type_bool, type_bool)) + ; "&&", Type_arrow (type_bool, Type_arrow (type_bool, type_bool)) + ; "print_int", Type_arrow (type_int, type_unit) + ; "print_gc_status", Type_arrow (type_unit, type_unit) + ; "collect", Type_arrow (type_unit, type_unit) + ; "alloc_block", Type_arrow (type_int, type_unit) + ; "+", Type_arrow (type_int, Type_arrow (type_int, type_int)) + ; "-", Type_arrow (type_int, Type_arrow (type_int, type_int)) + ; "*", Type_arrow (type_int, Type_arrow (type_int, type_int)) + ; "/", Type_arrow (type_int, Type_arrow (type_int, type_int)) + ; "=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; "<>", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; "<", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; "<=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; ">", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; ">=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) + ; "None", Type_construct ("option", [ Quant_type_var "a" ]) ; ( "Some" - , Forall - ( VarSet.singleton "a" - , Type_arrow (Type_var "a", Type_construct ("option", [ Type_var "a" ])) ) ) - ; "None", Forall (VarSet.singleton "a", Type_construct ("option", [ Type_var "a" ])) + , Type_arrow (Quant_type_var "a", Type_construct ("option", [ Quant_type_var "a" ])) + ) + ; "true", type_bool + ; "false", type_bool + ; "()", type_unit + ; "[]", Type_construct ("list", [ Quant_type_var "a" ]) ; ( "::" - , Forall - ( VarSet.singleton "a" - , Type_arrow - ( Type_tuple (Type_var "a", Type_construct ("list", [ Type_var "a" ]), []) - , Type_construct ("list", [ Type_var "a" ]) ) ) ) - ; "[]", Forall (VarSet.singleton "a", Type_construct ("list", [ Type_var "a" ])) - ; "()", Forall (VarSet.empty, Type_construct ("unit", [])) - ; "true", Forall (VarSet.empty, Type_construct ("bool", [])) - ; "false", Forall (VarSet.empty, Type_construct ("bool", [])) + , Type_arrow + ( Type_tuple + (Quant_type_var "a", Type_construct ("list", [ Quant_type_var "a" ]), []) + , Type_construct ("list", [ Quant_type_var "a" ]) ) ) ] in - List.fold_left - (fun env (id, sch) -> TypeEnv.extend env id sch) - TypeEnv.empty - things_list -;; - -let run_infer_program ?(debug = false) (program : Common.Ast.program) env = - run (infer_program ~debug program env) + things_list ;; diff --git a/XML/lib/middleend/infer.mli b/XML/lib/middleend/infer.mli new file mode 100644 index 00000000..2766101c --- /dev/null +++ b/XML/lib/middleend/infer.mli @@ -0,0 +1,41 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Common.Ast + +(** resets counter for type variables *) +val reset_gensym : unit -> unit + +(** [infer_exp env exp] infers type of the expression [exp] in the environment [env] and returns + updated environment and type of [exp] *) +val infer_exp + : (ident * TypeExpr.t) list + -> Expression.t + -> (ident * TypeExpr.t) list * TypeExpr.t + +(** [infer_pat env pat] infers type of the pattern [pat] in the environment [env] and returns + updated environment and type of [pat] *) +val infer_pat + : (ident * TypeExpr.t) list + -> Pattern.t + -> (ident * TypeExpr.t) list * TypeExpr.t + +(** [infer_structure_item env item] infers type of the item [item] in the environment [env] and returns + updated environment and new names *) +val infer_structure_item + : (ident * TypeExpr.t) list + -> Structure.structure_item + -> (ident * TypeExpr.t) list * ident list + +(** [infer_program env prog] infers all types in program [prog] with initial environment [env] and returns + updated environment and names of all new global identificators + + for basic environment, use [env_with_things] *) +val infer_program + : (ident * TypeExpr.t) list + -> Structure.structure_item list + -> (ident * TypeExpr.t) list * ident list + +(** [env_with_things] is the basic environment that contains built-in functions and constructors *) +val env_with_things : (ident * TypeExpr.t) list diff --git a/XML/lib/middleend/inferLayers.ml b/XML/lib/middleend/inferLayers.ml deleted file mode 100644 index c2122097..00000000 --- a/XML/lib/middleend/inferLayers.ml +++ /dev/null @@ -1,636 +0,0 @@ -(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -open Common.Ast -open Common.Ast.Expression -open Common.Ast.Structure -open Common.Ast.Pattern - -type typ = - | Type_arrow of typ * typ - | Type_tuple of typ List2.t - | Type_var of tv ref - | Quant_type_var of ident - | Type_construct of ident * typ list [@deriving] -[@@deriving eq, show { with_path = false }] - -and tv = - | Unbound of ident - | Link of typ -[@@deriving eq, show { with_path = false }] - -let rec follow_links = function - | Type_var { contents = Link t } -> follow_links t - | t -> t -;; - -let rearr_typvars typ = - let open Base in - let var_counter = ref 0 in - let rec rename (t : typ) (var_map : (string, string, String.comparator_witness) Map.t) - : typ * (string, string, String.comparator_witness) Map.t - = - match t with - | Type_arrow (t1, t2) -> - let t1', map1 = rename t1 var_map in - let t2', map2 = rename t2 map1 in - Type_arrow (t1', t2'), map2 - | Type_tuple (t1, t2, tl) -> - let t1', map1 = rename t1 var_map in - let t2', map2 = rename t2 map1 in - let ts = tl in - List.fold_left ts ~init:([], map2) ~f:(fun (acc_ts, acc_map) t_elem -> - let t_elem', new_map = rename t_elem acc_map in - t_elem' :: acc_ts, new_map) - |> fun (rev_ts, final_map) -> Type_tuple (t1', t2', List.rev rev_ts), final_map - | Type_var tv_ref -> - (match !tv_ref with - | Unbound _ -> Type_var tv_ref, var_map - | Link linked_t -> rename linked_t var_map) - | Quant_type_var id -> - (match Map.find var_map id with - | Some new_id -> Quant_type_var new_id, var_map - | None -> - let idx = !var_counter in - var_counter := idx + 1; - let new_id = - if idx < 26 - then String.make 1 (Char.of_int_exn (97 + idx)) - else ( - let prefix_count = (idx / 26) - 1 in - let suffix_idx = idx mod 26 in - "'" - ^ String.make (prefix_count + 1) (Char.of_int_exn (97 + (idx / 26) - 1)) - ^ String.make 1 (Char.of_int_exn (97 + suffix_idx))) - in - let new_map = Map.set var_map ~key:id ~data:new_id in - Quant_type_var new_id, new_map) - | Type_construct (id, args) -> - List.fold_left args ~init:([], var_map) ~f:(fun (acc_args, acc_map) arg -> - let arg', new_map = rename arg acc_map in - arg' :: acc_args, new_map) - |> fun (rev_args, final_map) -> Type_construct (id, List.rev rev_args), final_map - in - fst (rename typ (Map.empty (module String))) -;; - -let rec pprint_type_tuple ?(poly_names_map = Base.Map.empty (module Base.String)) fmt = - let open Format in - function - | [] -> () - | [ h ] -> - (match h with - | Type_arrow (_, _) -> fprintf fmt "(%a)" (pprint_typ ~poly_names_map) h - | _ -> fprintf fmt "%a" (pprint_typ ~poly_names_map) h) - | h :: tl -> - (match h with - | Type_arrow (_, _) -> - fprintf - fmt - "(%a) * %a" - (pprint_typ ~poly_names_map) - h - (pprint_type_tuple ~poly_names_map) - tl - | _ -> - fprintf - fmt - "%a * %a" - (pprint_typ ~poly_names_map) - h - (pprint_type_tuple ~poly_names_map) - tl) - -and pprint_type_list_with_parens - ?(poly_names_map = Base.Map.empty (module Base.String)) - fmt - ty_list - = - let open Format in - let rec print_types fmt = function - | [] -> () - | [ ty ] -> (pprint_type_with_parens_if_tuple ~poly_names_map) fmt ty - | ty :: rest -> - fprintf - fmt - "%a %a" - (pprint_type_with_parens_if_tuple ~poly_names_map) - ty - print_types - rest - in - print_types fmt ty_list - -and pprint_typ fmt ?(poly_names_map = Base.Map.empty (module Base.String)) typ = - let rec is_arrow = function - | Type_arrow _ -> true - | Type_var { contents = Link t } -> is_arrow t - | _ -> false - in - let rec is_tuple = function - | Type_tuple _ -> true - | Type_var { contents = Link t } -> is_tuple t - | _ -> false - in - let open Format in - match typ with - | Type_arrow (t1, t2) when is_arrow t1 -> - fprintf - fmt - "(%a) -> %a" - (pprint_typ ~poly_names_map) - t1 - (pprint_typ ~poly_names_map) - t2 - | Type_arrow (t1, t2) -> - fprintf fmt "%a -> %a" (pprint_typ ~poly_names_map) t1 (pprint_typ ~poly_names_map) t2 - | Type_tuple (t1, t2, tl) -> - fprintf - fmt - "%s" - (String.concat - " * " - (List.map - (fun t -> - if is_tuple t - then asprintf "(%a)" (pprint_typ ~poly_names_map) t - else asprintf "%a" (pprint_typ ~poly_names_map) t) - (t1 :: t2 :: tl))) - | Type_var { contents = Unbound id } -> - (match Base.Map.find poly_names_map id with - | Some k -> fprintf fmt "'%s" k - | None -> fprintf fmt "'%s" id) - | Type_var { contents = Link t } -> pprint_typ fmt t - | Quant_type_var id -> fprintf fmt "'%s" id - | Type_construct (name, []) -> fprintf fmt "%s" name - | Type_construct (name, ty_list) -> - fprintf fmt "%a %s" (pprint_type_list_with_parens ~poly_names_map) ty_list name - -and pprint_type_with_parens_if_tuple - ?(poly_names_map = Base.Map.empty (module Base.String)) - fmt - ty - = - let open Format in - match ty with - | Type_tuple _ -> fprintf fmt "(%a)" (pprint_typ ~poly_names_map) ty - | _ -> (pprint_typ ~poly_names_map) fmt ty -;; - -let filter_env (env : (ident * typ) list) (names : ident list) = - List.fold_left - (fun acc name -> - match List.assoc_opt name env, List.assoc_opt name acc with - | Some ty, None -> (name, ty) :: acc - | _ -> acc) - [] - names -;; - -let pprint_env env names = - let open Format in - let new_env = filter_env env names in - List.iter - (fun (key, typ) -> - if - String.length key > 0 - && Stdlib.Char.code key.[0] >= 65 - && Stdlib.Char.code key.[0] <= 90 - then () - else if key = "-" - then - printf - "%s : %a\n" - key - (pprint_typ ~poly_names_map:(Base.Map.empty (module Base.String))) - typ - else ( - let typ = rearr_typvars typ in - printf - "val %s : %a\n" - key - (pprint_typ ~poly_names_map:(Base.Map.empty (module Base.String))) - typ)) - new_env -;; - -let rec occurs_check tv = function - | Type_var tv' when tv == tv' -> failwith "occurs check" - | Type_var { contents = Link t } -> occurs_check tv t - | Type_arrow (t1, t2) -> - occurs_check tv t1; - occurs_check tv t2 - | Type_tuple (t1, t2, tl) -> List.map (occurs_check tv) (t1 :: t2 :: tl) |> ignore - | Type_construct (_, lst) -> List.map (occurs_check tv) lst |> ignore - | _ -> () -;; - -let rec unify t1 t2 = - match t1, t2 with - | t1, t2 when t1 == t2 -> () - | Type_var { contents = Link t1 }, t2 | t1, Type_var { contents = Link t2 } -> - unify t1 t2 - | Type_var ({ contents = Unbound _ } as tv), t' - | t', Type_var ({ contents = Unbound _ } as tv) -> - occurs_check tv t'; - tv := Link t' - | Type_arrow (l1, l2), Type_arrow (r1, r2) -> - unify l1 r1; - unify l2 r2 - | Type_tuple (l1, l2, ltl), Type_tuple (r1, r2, rtl) -> - if List.length ltl <> List.length rtl - then failwith "cannot unify tuple types of different size"; - List.map2 unify (l1 :: l2 :: ltl) (r1 :: r2 :: rtl) |> ignore - | Type_construct (lc, llst), Type_construct (rc, rlst) -> - if lc <> rc - then failwith ("can't unify different constructors: " ^ lc ^ " and " ^ rc) - else List.map2 unify llst rlst |> ignore - | Quant_type_var _, _ | _, Quant_type_var _ -> - failwith "cannot unify with a quantified type" - (* | _ -> failwith ("cannot unify types: " ^ show_typ t1 ^ "and: " ^ show_typ t2) *) - | _ -> - failwith - (Format.asprintf - "cannot unify types: %a and %a" - (fun fmt -> pprint_typ fmt ~poly_names_map:(Base.Map.empty (module Base.String))) - t1 - (fun fmt -> pprint_typ fmt ~poly_names_map:(Base.Map.empty (module Base.String))) - t2) -;; - -(* | _ -> failwith "error" *) - -let rec generalize : typ -> typ = function - | Type_var { contents = Unbound name } -> Quant_type_var name - | Type_var { contents = Link ty } -> generalize ty - | Type_arrow (ty1, ty2) -> Type_arrow (generalize ty1, generalize ty2) - | Type_tuple (t1, t2, tl) -> - Type_tuple (generalize t1, generalize t2, List.map generalize tl) - | Type_construct (c, lst) -> Type_construct (c, List.map generalize lst) - | ty -> ty -;; - -type env = (ident * typ) list - -let gensym_counter = ref 0 -let reset_gensym : unit -> unit = fun () -> gensym_counter := 0 - -let gensym : unit -> string = - fun () -> - let n = !gensym_counter in - let () = incr gensym_counter in - if n < 26 then String.make 1 (Char.chr (Char.code 'a' + n)) else "t" ^ string_of_int n -;; - -let newvar () = Type_var (ref (Unbound (gensym ()))) - -let inst = - let rec loop subst = function - | Quant_type_var name -> - (match List.assoc_opt name subst with - | Some typ -> typ, subst - | None -> - let tv = newvar () in - tv, (name, tv) :: subst) - | Type_var { contents = Link ty } -> loop subst ty - | Type_arrow (t1, t2) -> - let t1', subst = loop subst t1 in - let t2', subst = loop subst t2 in - Type_arrow (t1', t2'), subst - | Type_tuple (t1, t2, tl) -> - let t1', subst = loop subst t1 in - let t2', subst = loop subst t2 in - let tl'_rev, subst = - List.fold_left - (fun (acc, subst) t -> - let t', subst = loop subst t in - t' :: acc, subst) - ([], subst) - tl - in - let tl' = List.rev tl'_rev in - Type_tuple (t1', t2', tl'), subst - | Type_construct (constr, lst) -> - let lst'_rev, subst = - List.fold_left - (fun (acc, subst) t -> - let t', subst = loop subst t in - t' :: acc, subst) - ([], subst) - lst - in - let lst' = List.rev lst'_rev in - Type_construct (constr, lst'), subst - | ty -> ty, subst - in - fun ty -> fst (loop [] ty) -;; - -let rec infer_pat env = function - | Pat_any -> - let fresh = newvar () in - env, fresh - | Pat_var id -> - let fresh = newvar () in - let new_env = (id, fresh) :: env in - new_env, fresh - | Pat_constant const -> - (match const with - | Const_char _ -> env, Type_construct ("char", []) - | Const_integer _ -> env, Type_construct ("int", []) - | Const_string _ -> env, Type_construct ("string", [])) - | Pat_tuple (p1, p2, ptl) -> - let new_env, ty1 = infer_pat env p1 in - let new_env1, ty2 = infer_pat new_env p2 in - let new_env2, tytl = - List.fold_left - (fun (eacc, tacc) exp -> - let curr_env, ty = infer_pat eacc exp in - curr_env, ty :: tacc) - (new_env1, []) - ptl - in - new_env2, Type_tuple (ty1, ty2, List.rev tytl) - | Pat_construct (name, pat) -> - let ty = List.assoc name env in - let inst_ty = inst ty in - (match inst_ty, pat with - | Type_arrow (arg, body), Some p -> - let new_env, new_ty = infer_pat env p in - unify arg new_ty; - new_env, body - | _ -> env, inst_ty) - (* | Pat_constraint (p, ty) -> - let new_env, new_ty = infer_pat env p in - unify ty new_ty; - new_env, new_ty *) - | _ -> failwith "infer pat not implemented" -;; - -let add_rec_names env vb_list = - List.fold_left - (fun cenv { pat; _ } -> - match pat with - | Pat_var id | Pat_constraint (Pat_var id, _) -> - let ncenv, typ_p = infer_pat cenv pat in - (id, typ_p) :: ncenv - | _ -> - failwith - "only variables are allowed as left-hand side of 'let rec' (during adding rec \ - names)" - (* let fresh = newvar () in *)) - env - vb_list -;; - -let rec get_pat_names acc pat = - match pat with - | Pat_var id -> id :: acc - | Pat_tuple (pat1, pat2, rest) -> - Base.List.fold_left ~f:get_pat_names ~init:acc (pat1 :: pat2 :: rest) - | Pat_construct ("Some", Some pat) -> get_pat_names acc pat - | Pat_constraint (pat, _) -> get_pat_names acc pat - | _ -> acc -;; - -let rec infer_vb env { pat; expr } = - (* we don't need local names *) - let _, typ_e = infer_exp env expr in - let new_env, typ_p = infer_pat env pat in - unify typ_p typ_e; - let pat_names = get_pat_names [] pat in - let new_env1 = - List.fold_left - (fun env name -> - let typ = List.assoc name env in - let env = List.remove_assoc name env in - (name, generalize typ) :: env) - new_env - pat_names - in - new_env1 - -and infer_vb_rec env { pat; expr } = - match pat with - | Pat_var id | Pat_constraint (Pat_var id, _) -> - let new_env, typ_p = infer_pat env pat in - let new_env = (id, typ_p) :: new_env in - let new_env1, typ_e = - match expr with - | Exp_ident eid when id = eid -> - failwith "this kind of expression is not allowed as right-hand side of `let rec'" - | _ -> infer_exp new_env expr - in - (* unify typ_p (generalize typ_e); *) - unify typ_p typ_e; - let pat_names = get_pat_names [] pat in - let new_env2 = - List.fold_left - (fun env name -> - let typ = List.assoc name env in - let env = List.remove_assoc name env in - (name, generalize typ) :: env) - new_env1 - pat_names - in - new_env2 - | _ -> failwith "only variables are allowed as left-hand side of 'let rec'" - -and infer_exp env = function - | Exp_ident id -> - (match List.assoc_opt id env with - | Some ty -> env, inst ty - | None -> failwith ("unbound variable: " ^ id)) - | Exp_constant const -> - (match const with - | Const_char _ -> env, Type_construct ("char", []) - | Const_integer _ -> env, Type_construct ("int", []) - | Const_string _ -> env, Type_construct ("string", [])) - | Exp_fun ((pat, pats), exp) -> - let new_env, typ_p = infer_pat env pat in - let newest_env, typ_exp = - match pats with - | hd :: tl -> infer_exp new_env (Exp_fun ((hd, tl), exp)) - | [] -> infer_exp new_env exp - in - newest_env, Type_arrow (typ_p, typ_exp) - | Exp_apply (Exp_ident op, Exp_tuple (exp1, exp2, [])) -> - (match op with - | "*" | "/" | "+" | "-" | "<" | ">" | "=" | "<>" | "<=" | ">=" | "&&" | "||" -> - let new_env, typ1 = infer_exp env exp1 in - let new_env1, typ2 = infer_exp new_env exp2 in - let arg_typ, res_typ = - match List.assoc_opt op env with - | Some (Type_arrow (arg, Type_arrow (_, res))) -> inst arg, inst res - | _ -> failwith ("operator was not found in env: " ^ op) - in - unify typ1 arg_typ; - unify typ2 arg_typ; - new_env1, res_typ - | _ -> - let new_env, typ_op = infer_exp env (Exp_ident op) in - let new_env1, typ_args = infer_exp new_env (Exp_tuple (exp1, exp2, [])) in - let typ_res = newvar () in - unify typ_op (Type_arrow (typ_args, typ_res)); - new_env1, typ_res) - | Exp_apply (Exp_ident "-", arg) -> - let new_env1, typ_arg = infer_exp env arg in - unify typ_arg (Type_construct ("int", [])); - new_env1, Type_construct ("int", []) - | Exp_apply (f, arg) -> - let new_env, typ_f = infer_exp env f in - let new_env1, typ_arg = infer_exp new_env arg in - let typ_res = newvar () in - unify typ_f (Type_arrow (typ_arg, typ_res)); - new_env1, typ_res - | Exp_construct (name, Some exp) -> infer_exp env (Exp_apply (Exp_ident name, exp)) - | Exp_construct (name, None) -> infer_exp env (Exp_ident name) - | Exp_tuple (e1, e2, etl) -> - let new_env, ty1 = infer_exp env e1 in - let new_env1, ty2 = infer_exp new_env e2 in - let new_env2, tytl = - List.fold_left - (fun (eacc, tacc) exp -> - let curr_env, ty = infer_exp eacc exp in - curr_env, ty :: tacc) - (new_env1, []) - etl - in - new_env2, Type_tuple (ty1, ty2, List.rev tytl) - | Exp_if (cond, the, els) -> - let new_env, ty1 = infer_exp env cond in - unify ty1 (Type_construct ("bool", [])); - let new_env1, ty2 = infer_exp new_env the in - (match els with - | None -> - unify ty2 (Type_construct ("unit", [])); - new_env1, ty2 - | Some els -> - let new_env, ty3 = infer_exp new_env1 els in - unify ty2 ty3; - new_env, ty3) - | Exp_let (Nonrecursive, (vb, vbs), exprb) -> - let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in - infer_exp new_env exprb - | Exp_let (Recursive, (vb, vbs), exprb) -> - let new_env = add_rec_names env (vb :: vbs) in - let new_env1 = - List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) - in - infer_exp new_env1 exprb - | Exp_match (expr, (case, rest)) -> - let new_env, typ_main = infer_exp env expr in - let fresh = newvar () in - let typ_res = - List.fold_left - (fun acc_typ curr_case -> - let pat_names = get_pat_names [] curr_case.first in - let pat_env, typ_pat = infer_pat new_env curr_case.first in - unify typ_pat typ_main; - let pat_env = - List.fold_left - (fun env name -> - let typ = List.assoc name env in - let env = List.remove_assoc name env in - (name, generalize typ) :: env) - pat_env - pat_names - in - let _, typ_exp = infer_exp pat_env curr_case.second in - unify acc_typ typ_exp; - acc_typ) - fresh - (case :: rest) - in - new_env, typ_res - | Exp_function (case, rest) -> - let fresh_p = newvar () in - let fresh_e = newvar () in - let typ_res = - List.fold_left - (fun acc_typ curr_case -> - let env_pat, typ_pat = infer_pat env curr_case.first in - unify typ_pat fresh_p; - let _, typ_exp = infer_exp env_pat curr_case.second in - unify acc_typ typ_exp; - acc_typ) - fresh_e - (case :: rest) - in - env, Type_arrow (fresh_p, typ_res) - | Exp_constraint _ -> failwith " exp constraint is not implemented yet" -;; - -let infer_structure_item env = function - | Str_eval exp -> - let _, typ = infer_exp env exp in - ("-", typ) :: env, [] - | Str_value (Nonrecursive, (vb, vbs)) -> - let new_names = - List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) - in - let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in - new_env, new_names - | Str_value (Recursive, (vb, vbs)) -> - let new_names = - List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) - in - let new_env = add_rec_names env (vb :: vbs) in - let new_env1 = - List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) - in - new_env1, new_names - | Str_adt _ -> failwith "str_adt will be removed" -;; - -let infer_program env prog = - let new_env, new_names = - List.fold_left - (fun (env, names) str_item -> - let new_env, new_names = infer_structure_item env str_item in - new_env, new_names @ names) - (env, []) - prog - in - new_env, new_names -;; - -let env_with_things = - let type_bool = Type_construct ("bool", []) in - let type_unit = Type_construct ("unit", []) in - let type_int = Type_construct ("int", []) in - let things_list = - [ "||", Type_arrow (type_bool, Type_arrow (type_bool, type_bool)) - ; "&&", Type_arrow (type_bool, Type_arrow (type_bool, type_bool)) - ; "print_int", Type_arrow (type_int, type_unit) - ; "print_gc_status", Type_arrow (type_unit, type_unit) - ; "collect", Type_arrow (type_unit, type_unit) - ; "alloc_block", Type_arrow (type_int, type_unit) - ; "+", Type_arrow (type_int, Type_arrow (type_int, type_int)) - ; "-", Type_arrow (type_int, Type_arrow (type_int, type_int)) - ; "*", Type_arrow (type_int, Type_arrow (type_int, type_int)) - ; "/", Type_arrow (type_int, Type_arrow (type_int, type_int)) - ; "=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) - ; "<>", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) - ; "<", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) - ; "<=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) - ; ">", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) - ; ">=", Type_arrow (Quant_type_var "a", Type_arrow (Quant_type_var "a", type_bool)) - ; "None", Type_construct ("option", [ Quant_type_var "a" ]) - ; ( "Some" - , Type_arrow (Quant_type_var "a", Type_construct ("option", [ Quant_type_var "a" ])) - ) - ; "true", type_bool - ; "false", type_bool - ; "()", type_unit - ; "[]", Type_construct ("list", [ Quant_type_var "a" ]) - ; ( "::" - , Type_arrow - ( Type_tuple - (Quant_type_var "a", Type_construct ("list", [ Quant_type_var "a" ]), []) - , Type_construct ("list", [ Quant_type_var "a" ]) ) ) - ] - in - things_list -;; diff --git a/XML/lib/middleend/inferLayers.mli b/XML/lib/middleend/inferLayers.mli deleted file mode 100644 index 54e54416..00000000 --- a/XML/lib/middleend/inferLayers.mli +++ /dev/null @@ -1,65 +0,0 @@ -(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -open Common.Ast - -(* Need to place into Common.Ast *) -type typ = - | Type_arrow of typ * typ - | Type_tuple of typ List2.t - | Type_var of tv ref - | Quant_type_var of ident - | Type_construct of ident * typ list - -and tv = - | Unbound of ident - | Link of typ - -val show_typ : typ -> string -val show_tv : tv -> string - -val pprint_typ - : Format.formatter - -> ?poly_names_map:(ident, ident, Base.String.comparator_witness) Base.Map.t - -> typ - -> unit - -(** [pprint_env env names] pretty-prints all types in environment [env] for - names in [names], skipping repeats or non-existent names *) -val pprint_env : (ident * typ) list -> ident list -> unit - -(** [filter_env env names] filters [env], leaving only bindings for - the names from [names], if they are present in environment. - if [env] contains duplicates for the same name, only the first binding is preserved *) -val filter_env : (ident * typ) list -> ident list -> (ident * typ) list - -(** resets counter for type variables *) -val reset_gensym : unit -> unit - -(** [infer_exp env exp] infers type of the expression [exp] in the environment [env] and returns - updated environment and type of [exp] *) -val infer_exp : (ident * typ) list -> Expression.t -> (ident * typ) list * typ - -(** [infer_pat env pat] infers type of the pattern [pat] in the environment [env] and returns - updated environment and type of [pat] *) -val infer_pat : (ident * typ) list -> Pattern.t -> (ident * typ) list * typ - -(** [infer_structure_item env item] infers type of the item [item] in the environment [env] and returns - updated environment and new names *) -val infer_structure_item - : (ident * typ) list - -> Structure.structure_item - -> (ident * typ) list * ident list - -(** [infer_program env prog] infers all types in program [prog] with initial environment [env] and returns - updated environment and names of all new global identificators - - for basic environment, use [env_with_things] *) -val infer_program - : (ident * typ) list - -> Structure.structure_item list - -> (ident * typ) list * ident list - -(** [env_with_things] is the basic environment that contains built-in functions and constructors *) -val env_with_things : (ident * typ) list diff --git a/XML/lib/middleend/inferTypes.ml b/XML/lib/middleend/inferTypes.ml deleted file mode 100644 index 0b964882..00000000 --- a/XML/lib/middleend/inferTypes.ml +++ /dev/null @@ -1,188 +0,0 @@ -(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -open Format -open Common.Ast.TypeExpr -open Stdlib - -type binder = int [@@deriving show { with_path = false }] - -module VarSet = struct - include Set.Make (String) - - let pp ppf s = - Format.fprintf ppf "[ "; - iter (Format.fprintf ppf "%s; ") s; - Format.fprintf ppf "]" - ;; -end - -type binder_set = VarSet.t [@@deriving show { with_path = false }] -type scheme = Forall of binder_set * t [@@deriving show { with_path = false }] - -open Base - -(* get polymorphic type names from VarSet *) -let binder_to_list args = - let args = VarSet.elements args in - List.sort (List.map args ~f:Int.of_string) ~compare:Int.compare -;; - -(** turn ['2, '5, '1231, ...] (value is not important, only order) list of - names of polymorphic types into ['a, 'b, 'c ... ] - when english alphabet is out, turn values into ['aa, 'bb, ...] and etc.*) -let minimize dargs = - let counter = 0 in - let coef = 0 in - let m = Map.empty (module Base.String) in - List.fold_left dargs ~init:(m, coef, counter) ~f:(fun (m, coef, counter) el -> - let str = - let rec build coef counter str = - if coef = 0 - then str ^ Char.escaped (Stdlib.Char.chr (counter + 97)) - else build (coef - 1) counter (str ^ Char.escaped (Stdlib.Char.chr (counter + 97))) - in - build coef counter "" - in - let counter = counter + 1 in - let coef = coef + (counter / 26) in - let counter = counter % 26 in - let el = Stdlib.string_of_int el in - Base.Map.set m ~key:el ~data:str, coef, counter) -;; - -let rec pprint_type_tuple ?(poly_names_map = Map.empty (module String)) fmt = function - | [] -> () - | [ h ] -> - (match h with - | Type_arrow (_, _) -> fprintf fmt "(%a)" (pprint_type ~poly_names_map) h - | _ -> fprintf fmt "%a" (pprint_type ~poly_names_map) h) - | h :: tl -> - (match h with - | Type_arrow (_, _) -> - fprintf - fmt - "(%a) * %a" - (pprint_type ~poly_names_map) - h - (pprint_type_tuple ~poly_names_map) - tl - | _ -> - fprintf - fmt - "%a * %a" - (pprint_type ~poly_names_map) - h - (pprint_type_tuple ~poly_names_map) - tl) - -and pprint_type ?(poly_names_map = Map.empty (module String)) fmt = function - | Type_var num -> - (match Map.find poly_names_map num with - | Some k -> fprintf fmt "'%s" k - | None -> fprintf fmt "'%s" num) - | Type_arrow (ty1, ty2) -> - (match ty1, ty2 with - | Type_arrow (_, _), _ -> - fprintf - fmt - "(%a) -> %a" - (pprint_type ~poly_names_map) - ty1 - (pprint_type ~poly_names_map) - ty2 - | _ -> - fprintf - fmt - "%a -> %a" - (pprint_type ~poly_names_map) - ty1 - (pprint_type ~poly_names_map) - ty2) - | Type_tuple (t1, t2, ty_lst) -> - fprintf fmt "%a" (pprint_type_tuple ~poly_names_map) (t1 :: t2 :: ty_lst) - | Type_construct (name, []) -> fprintf fmt "%s" name - | Type_construct (name, ty_list) -> - fprintf fmt "%a %s" (pprint_type_list_with_parens ~poly_names_map) ty_list name - -and pprint_type_list_with_parens ?(poly_names_map = Map.empty (module String)) fmt ty_list - = - let rec print_types fmt = function - | [] -> () - | [ ty ] -> (pprint_type_with_parens_if_tuple ~poly_names_map) fmt ty - | ty :: rest -> - fprintf - fmt - "%a %a" - (pprint_type_with_parens_if_tuple ~poly_names_map) - ty - print_types - rest - in - print_types fmt ty_list - -and pprint_type_with_parens_if_tuple ?(poly_names_map = Map.empty (module String)) fmt ty = - match ty with - | Type_tuple _ -> fprintf fmt "(%a)" (pprint_type ~poly_names_map) ty - | _ -> (pprint_type ~poly_names_map) fmt ty -;; - -(*errors*) -type error = - | Occurs_check of string * Common.Ast.TypeExpr.t - (** same polymotphic type occured while substitution apply ['a : 'a -> 'b]*) - | Unification_failed of Common.Ast.TypeExpr.t * Common.Ast.TypeExpr.t - | Unbound_variable of string - | Arity_mismatch - (** mismatch of types arity - [type 'a foo = Foo - type bar = Bar of foo] *) - | Undeclared_type of string - | Wrong_rec (** invalid right value in recursive let declaration *) - | Unsupported_operator of string (** for binary operators*) - | Incorrect_list_lengths - -let collect_type_vars typ = - let rec aux acc = function - | Type_var num -> num :: acc - | Type_arrow (t1, t2) -> aux (aux acc t1) t2 - | Type_tuple (t1, t2, tl) -> List.fold_left ~f:aux ~init:(aux (aux acc t1) t2) tl - | Type_construct (_, ty_list) -> List.fold_left ~f:aux ~init:acc ty_list - in - aux [] typ -;; - -let collect_vars_from_error = function - | Occurs_check (str, typ) -> str :: collect_type_vars typ - | Unification_failed (t1, t2) -> collect_type_vars t1 @ collect_type_vars t2 - | _ -> [] -;; - -let pp_inf_err fmt err = - let type_vars = collect_vars_from_error err in - let var_map, _, _ = minimize (List.map type_vars ~f:Stdlib.int_of_string) in - match err with - | Occurs_check (str, t) -> - fprintf - fmt - "Occurs_check: %a and %a\n" - (pprint_type ~poly_names_map:var_map) - (Type_var str) - (pprint_type ~poly_names_map:var_map) - t - | Unification_failed (typ1, typ2) -> - fprintf - fmt - "Unification_failed: %a # %a" - (pprint_type ~poly_names_map:var_map) - typ1 - (pprint_type ~poly_names_map:var_map) - typ2 - | Unbound_variable str -> fprintf fmt "Unbound_variable: %S" str - | Arity_mismatch -> fprintf fmt "Arity_mismatch" - | Undeclared_type str -> fprintf fmt "Undeclared_type: %S" str - | Wrong_rec -> fprintf fmt "Wrong right value in rec" - | Unsupported_operator op -> fprintf fmt "Operator %s is not supported" op - | Incorrect_list_lengths -> fprintf fmt "Lists have unequal lengths" -;; diff --git a/XML/many_tests/infer.t b/XML/many_tests/infer.t index 46435609..3c0d273d 100644 --- a/XML/many_tests/infer.t +++ b/XML/many_tests/infer.t @@ -27,7 +27,7 @@ val main : int $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/006partial2.ml -typedtree - val foo : int + val foo : int -> int -> int -> int val main : int $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/006partial3.ml -typedtree @@ -39,19 +39,8 @@ val main : unit $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/008ascription.ml -typedtree - Fatal error: exception Failure(" exp constraint is not implemented yet") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 455, characters 14-35 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 454, characters 20-63 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 454, characters 20-63 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 399, characters 20-38 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_structure_item in file "lib/middleend/inferLayers.ml", line 573, characters 18-84 - Called from Middleend__InferLayers.infer_program.(fun) in file "lib/middleend/inferLayers.ml", line 591, characters 34-67 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_program in file "lib/middleend/inferLayers.ml", line 589, characters 4-189 - Called from Dune__exe__XML_llvm.compile_and_write in file "bin/XML_llvm.ml", line 51, characters 7-40 - [2] + val addi : ('a -> bool -> int) -> ('a -> bool) -> 'a -> int + val main : int $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/009let_poly.ml -typedtree val temp : int * bool diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index d08d68e3..cc311c0e 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -2,10 +2,10 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open Middleend.InferLayers -open Common.Ast.Constant -open Common.Ast.Expression +open Middleend.Infer open Common.Parser +open Common.Pprinter +open Common.Ast.TypeExpr (* TODO: get rid of failwith in infer *) @@ -13,24 +13,23 @@ let infer_exp_str ?(rst = true) ?(env = []) str = let exp = parse_exp_str str in if rst then reset_gensym (); let _, ty = infer_exp env exp in - pprint_typ Format.std_formatter ty;; + pprint_type Format.std_formatter ty;; let infer_pat_str ?(rst = true) ?(env = []) str = let pat = parse_pat_str str in if rst then reset_gensym (); let _, ty = infer_pat env pat in - pprint_typ Format.std_formatter ty;; + pprint_type Format.std_formatter ty;; let infer_prog_str ?(env = env_with_things) str = let prog = parse_str str in reset_gensym (); let env, names = infer_program env prog in - let env = filter_env env names in pprint_env env names let show_etyp env exp = let _, ty = infer_exp env exp in - Base.print_endline (show_typ ty) + Base.print_endline (Common.Ast.TypeExpr.show ty) let type_bool = Type_construct ("bool", []) let type_unit = Type_construct ("unit", []) @@ -73,7 +72,7 @@ let%expect_test "id not in env" = (Failure "unbound variable: m") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 66, characters 2-23 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 65, characters 2-23 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; @@ -116,7 +115,7 @@ let%expect_test "if (string) " = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 503, characters 4-43 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 286, characters 4-43 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -132,9 +131,9 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 507, characters 7-46 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 290, characters 7-46 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 126, characters 2-41 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 125, characters 2-41 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -173,10 +172,10 @@ let%expect_test "apply int -> int to string" = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 239, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 485, characters 4-47 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 33, characters 4-15 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 268, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 167, characters 2-30 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 166, characters 2-30 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -204,11 +203,11 @@ let%expect_test "apply 'a to 'a (same var)" = (Failure "occurs check") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.occurs_check in file "lib/middleend/inferLayers.ml", line 222, characters 4-22 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 236, characters 4-22 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 485, characters 4-47 + Called from Middleend__Infer.occurs_check in file "lib/middleend/infer.ml", line 16, characters 4-22 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 30, characters 4-22 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 268, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 198, characters 2-42 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 197, characters 2-42 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -304,9 +303,9 @@ let%expect_test "fun 'a -> 'b (not in env)" = (Failure "unbound variable: y") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 455, characters 14-35 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 238, characters 14-35 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 298, characters 2-32 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 297, characters 2-32 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -336,10 +335,10 @@ let%expect_test _ = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 239, characters 4-15 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 485, characters 4-47 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 33, characters 4-15 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 268, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 330, characters 2-68 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 329, characters 2-68 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -370,11 +369,11 @@ let%expect_test "match different constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 530, characters 11-33 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 313, characters 11-33 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 526, characters 6-685 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 309, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 364, characters 2-63 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 363, characters 2-63 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -389,11 +388,11 @@ let%expect_test "match option with list constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 530, characters 11-33 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 313, characters 11-33 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 526, characters 6-685 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 309, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 383, characters 2-64 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 382, characters 2-64 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -408,11 +407,11 @@ let%expect_test "match different types of expr 1" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 541, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 324, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 526, characters 6-685 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 309, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 402, characters 2-70 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 401, characters 2-70 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -427,11 +426,11 @@ let%expect_test "match different types of expr 2" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 541, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 324, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 526, characters 6-685 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 309, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 421, characters 2-90 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 420, characters 2-90 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -457,11 +456,11 @@ let%expect_test "function different constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 554, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 337, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 551, characters 6-314 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 334, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 451, characters 2-59 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 450, characters 2-59 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -475,11 +474,11 @@ let%expect_test "function different types of expr 1" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 556, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 339, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 551, characters 6-314 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 334, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 469, characters 2-66 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 468, characters 2-66 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -493,11 +492,11 @@ let%expect_test "function different types of expr 2" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_exp.(fun) in file "lib/middleend/inferLayers.ml", line 556, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 339, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 551, characters 6-314 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 334, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 487, characters 2-86 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 486, characters 2-86 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -554,12 +553,12 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 243, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 401, characters 2-19 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 37, characters 9-62 + Called from Middleend__Infer.infer_vb in file "lib/middleend/infer.ml", line 185, characters 2-19 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 514, characters 18-84 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 297, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 548, characters 2-46 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 547, characters 2-46 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -573,12 +572,12 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.unify in file "lib/middleend/inferLayers.ml", line 243, characters 9-62 - Called from Middleend__InferLayers.infer_vb in file "lib/middleend/inferLayers.ml", line 401, characters 2-19 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 37, characters 9-62 + Called from Middleend__Infer.infer_vb in file "lib/middleend/infer.ml", line 185, characters 2-19 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_exp in file "lib/middleend/inferLayers.ml", line 514, characters 18-84 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 297, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 567, characters 2-45 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 566, characters 2-45 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -648,14 +647,14 @@ let%expect_test "weird let rec" = (Failure "this kind of expression is not allowed as right-hand side of `let rec'") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__InferLayers.infer_vb_rec in file "lib/middleend/inferLayers.ml", line 422, characters 8-89 + Called from Middleend__Infer.infer_vb_rec in file "lib/middleend/infer.ml", line 206, characters 8-89 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_structure_item in file "lib/middleend/inferLayers.ml", line 581, characters 6-80 - Called from Middleend__InferLayers.infer_program.(fun) in file "lib/middleend/inferLayers.ml", line 591, characters 34-67 + Called from Middleend__Infer.infer_structure_item in file "lib/middleend/infer.ml", line 367, characters 6-80 + Called from Middleend__Infer.infer_program.(fun) in file "lib/middleend/infer.ml", line 377, characters 34-67 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__InferLayers.infer_program in file "lib/middleend/inferLayers.ml", line 589, characters 4-189 + Called from Middleend__Infer.infer_program in file "lib/middleend/infer.ml", line 375, characters 4-189 Called from XML_unittests__Infer.infer_prog_str in file "many_tests/unit/infer.ml", line 27, characters 19-41 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 641, characters 2-36 + Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 640, characters 2-36 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] From d2f5aa4e8ffecdaa5e7e1ba2a08f9c3c8371d3ae Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 3 Mar 2026 02:10:56 +0300 Subject: [PATCH 48/84] feat: add levels, generalization is sound now --- XML/lib/common/ast.ml | 16 +---- XML/lib/common/ast.mli | 12 +--- XML/lib/common/parser.ml | 2 +- XML/lib/common/pprinter.ml | 4 +- XML/lib/middleend/infer.ml | 24 ++++++- XML/many_tests/infer.t | 12 ++-- XML/many_tests/unit/infer.ml | 134 ++++++++++++++++------------------- 7 files changed, 98 insertions(+), 106 deletions(-) diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index acc590d1..3bd0f0ee 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -95,23 +95,13 @@ module Constant = struct end module TypeExpr = struct - (* type t = - | Type_arrow of t * t - (** [Type_arrow(T1, T2)] represents: - [T1 -> T2] *) - | Type_var of (ident[@gen gen_ident]) - | Type_tuple of t List2.t (** [Type_tuple([T1, T2, ... Tn])] *) - | Type_construct of ident * t list - (** [Type_construct(lident, l)] represents: - - [tconstr] when [l=[]], - - [T tconstr] when [l=[T]], - - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. *) *) - let gen_ref inner_gen = let open QCheck.Gen in map (fun x -> ref x) inner_gen ;; + type level = int [@@deriving eq, show { with_path = false }, qcheck] + type t = | Type_arrow of t * t | Type_tuple of t List2.t @@ -121,7 +111,7 @@ module TypeExpr = struct [@@deriving eq, show { with_path = false }, qcheck] and tv = - | Unbound of ident + | Unbound of ident * level | Link of t [@@deriving eq, show { with_path = false }, qcheck] end diff --git a/XML/lib/common/ast.mli b/XML/lib/common/ast.mli index 98196938..1ba948d7 100644 --- a/XML/lib/common/ast.mli +++ b/XML/lib/common/ast.mli @@ -48,14 +48,8 @@ module Constant : sig end module TypeExpr : sig - (* - type t = - | Type_arrow of t * t (** Represents a function type: [T1 -> T2]. *) - | Type_var of ident (** Represents a type variable: ['a]. *) - | Type_tuple of t List2.t (** Represents a tuple type: [(T1, T2, ..., Tn)]. *) - | Type_construct of ident * t list - (** Represents a type constructor with arguments: [C T1 ... Tn]. *) - *) + type level = int + type t = | Type_arrow of t * t | Type_tuple of t List2.t @@ -64,7 +58,7 @@ module TypeExpr : sig | Type_construct of ident * t list and tv = - | Unbound of ident + | Unbound of ident * level | Link of t val equal : t -> t -> bool diff --git a/XML/lib/common/parser.ml b/XML/lib/common/parser.ml index 90d8eecd..e2a79ba2 100644 --- a/XML/lib/common/parser.ml +++ b/XML/lib/common/parser.ml @@ -151,7 +151,7 @@ let pmultiargsapp pty = let ptypevar = let* id = token "'" *> (pident_lc <|> pident_cap) in - return (TypeExpr.Type_var { contents = Unbound id }) + return (TypeExpr.Type_var { contents = Unbound (id, 0) }) ;; let ptypetuple ptype = diff --git a/XML/lib/common/pprinter.ml b/XML/lib/common/pprinter.ml index 9161471a..a5b9fc20 100644 --- a/XML/lib/common/pprinter.ml +++ b/XML/lib/common/pprinter.ml @@ -136,11 +136,11 @@ and pprint_type fmt typ = ~sep:" * " (List.map ~f:(fun t -> - if is_tuple t + if is_tuple t || is_arrow t then asprintf "(%a)" pprint_type t else asprintf "%a" pprint_type t) (t1 :: t2 :: tl))) - | Type_var { contents = Unbound id } -> fprintf fmt "'%s" id + | Type_var { contents = Unbound (id, _) } -> fprintf fmt "'%s" id | Type_var { contents = Link t } -> pprint_type fmt t | Quant_type_var id -> fprintf fmt "'%s" id | Type_construct (name, []) -> fprintf fmt "%s" name diff --git a/XML/lib/middleend/infer.ml b/XML/lib/middleend/infer.ml index 2f0aadb8..78a006fe 100644 --- a/XML/lib/middleend/infer.ml +++ b/XML/lib/middleend/infer.ml @@ -9,8 +9,19 @@ open Common.Ast.Pattern open Common.Ast.TypeExpr open Common.Pprinter +let current_level = ref 0 +let enter_level () = incr current_level +let leave_level () = decr current_level + let rec occurs_check tv = function | Type_var tv' when tv == tv' -> failwith "occurs check" + | Type_var ({ contents = Unbound (name, l) } as tv') -> + let min_lvl = + match !tv with + | Unbound (_, l') -> min l l' + | _ -> l + in + tv' := Unbound (name, min_lvl) | Type_var { contents = Link t } -> occurs_check tv t | Type_arrow (t1, t2) -> occurs_check tv t1; @@ -48,7 +59,8 @@ let rec unify t1 t2 = ;; let rec generalize = function - | Type_var { contents = Unbound name } -> Quant_type_var name + | Type_var { contents = Unbound (name, l) } when l >= !current_level -> + Quant_type_var name | Type_var { contents = Link ty } -> generalize ty | Type_arrow (ty1, ty2) -> Type_arrow (generalize ty1, generalize ty2) | Type_tuple (t1, t2, tl) -> @@ -69,7 +81,7 @@ let gensym : unit -> string = if n < 26 then String.make 1 (Char.chr (Char.code 'a' + n)) else "t" ^ string_of_int n ;; -let newvar () = Type_var (ref (Unbound (gensym ()))) +let newvar () = Type_var (ref (Unbound (gensym (), !current_level))) let inst = let rec loop subst = function @@ -294,13 +306,17 @@ and infer_exp env = function unify ty2 ty3; new_env, ty3) | Exp_let (Nonrecursive, (vb, vbs), exprb) -> + enter_level (); let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in + leave_level (); infer_exp new_env exprb | Exp_let (Recursive, (vb, vbs), exprb) -> let new_env = add_rec_names env (vb :: vbs) in + enter_level (); let new_env1 = List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) in + leave_level (); infer_exp new_env1 exprb | Exp_match (expr, (case, rest)) -> let new_env, typ_main = infer_exp env expr in @@ -356,16 +372,20 @@ let infer_structure_item env = function let new_names = List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) in + (* enter_level (); *) let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in + (* leave_level (); *) new_env, new_names | Str_value (Recursive, (vb, vbs)) -> let new_names = List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) in let new_env = add_rec_names env (vb :: vbs) in + (* enter_level (); *) let new_env1 = List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) in + (* leave_level (); *) new_env1, new_names | Str_adt _ -> failwith "str_adts are not supported" ;; diff --git a/XML/many_tests/infer.t b/XML/many_tests/infer.t index 3c0d273d..c97c32d8 100644 --- a/XML/many_tests/infer.t +++ b/XML/many_tests/infer.t @@ -77,19 +77,17 @@ val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a val main : unit -map is wrong because gen is unsound? $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/015tuples.ml -typedtree val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b - val map : ('a -> 'b) -> 'c * 'd -> 'b * 'b - val fixpoly : 'a -> 'b -> 'c * 'b -> 'c - val feven : 'a * 'b -> int -> int - val fodd : 'a * 'b -> int -> int - val tie : 'a -> 'b * 'a -> 'b + val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b + val fixpoly : 'a -> ('b -> 'c) * ('b -> 'c) + val feven : 'a * (int -> int) -> int -> int + val fodd : (int -> int) * 'a -> int -> int + val tie : ('a -> 'b) * ('a -> 'b) val meven : int -> int val modd : int -> int val main : int - $ dune exec -- ../bin/XML_llvm.exe -fromfile manytests/typed/016lists.ml -typedtree val length : 'a list -> int val length_tail : 'a list -> int diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index cc311c0e..32556429 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -57,7 +57,7 @@ let%expect_test "str" = let%expect_test "id in env" = - infer_exp_str {| m |} ~env:[("m", Type_var {contents = Unbound "a"})]; + infer_exp_str {| m |} ~env:[("m", Type_var {contents = Unbound ("a", 0)})]; [%expect{| 'a |}] @@ -115,7 +115,7 @@ let%expect_test "if (string) " = (Failure "can't unify different constructors: string and bool") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 286, characters 4-43 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 298, characters 4-43 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -131,7 +131,7 @@ let%expect_test "if (bool) then (not unit)" = (Failure "can't unify different constructors: int and unit") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 290, characters 7-46 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 302, characters 7-46 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 125, characters 2-41 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -144,13 +144,13 @@ let%expect_test "if (bool) then (unit)" = let%expect_test "if (bool) then 'a else 'a" = - let env = ["cond", type_bool; "x", Type_var {contents = Unbound "a"}; "y", Type_var {contents = Unbound "a"}] in + let env = ["cond", type_bool; "x", Type_var {contents = Unbound ("a", 0)}; "y", Type_var {contents = Unbound ("a", 0)}] in infer_exp_str {| if cond then x else y |} ~env; [%expect{| 'a |}] let%expect_test "if (bool) then 'a else 'b" = - let env = ["cond", type_bool; "x", Type_var {contents = Unbound "a"}; "y", Type_var {contents = Unbound "b"}] in + let env = ["cond", type_bool; "x", Type_var {contents = Unbound ("a", 0)}; "y", Type_var {contents = Unbound ("b", 0)}] in infer_exp_str {| if cond then x else y |} ~env; [%expect{| 'b |}] @@ -172,28 +172,28 @@ let%expect_test "apply int -> int to string" = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 33, characters 4-15 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 268, characters 4-47 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 44, characters 4-15 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 280, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 166, characters 2-30 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "apply 'a -> 'a to 'b" = - let env = ["f", Type_arrow (Type_var {contents = Unbound "s"}, Type_var {contents = Unbound "s"}); "x", Type_var {contents = Unbound "t"}] in + let env = ["f", Type_arrow (Type_var {contents = Unbound ("s", 0)}, Type_var {contents = Unbound ("s", 0)}); "x", Type_var {contents = Unbound ("t", 0)}] in infer_exp_str {| f x |} ~env ~rst: false; [%expect{| 'b |}] (* not sure if this is right *) let%expect_test "apply 'a to 'a (different vars)" = - let env = ["f", Type_var {contents = Unbound "t"}; "x", Type_var {contents = Unbound "t"}] in + let env = ["f", Type_var {contents = Unbound ("t", 0)}; "x", Type_var {contents = Unbound ("t", 0)}] in infer_exp_str {| f x |} ~env ~rst: false; [%expect {| 'c |}] let%expect_test "apply 'a to 'a (same var)" = - let env = ["x", Type_var {contents = Unbound "t"}] in + let env = ["x", Type_var {contents = Unbound ("t", 0)}] in infer_exp_str {| x x |} ~env ~rst: false; [%expect.unreachable] [@@expect.uncaught_exn {| @@ -203,16 +203,16 @@ let%expect_test "apply 'a to 'a (same var)" = (Failure "occurs check") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.occurs_check in file "lib/middleend/infer.ml", line 16, characters 4-22 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 30, characters 4-22 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 268, characters 4-47 + Called from Middleend__Infer.occurs_check in file "lib/middleend/infer.ml", line 27, characters 4-22 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 41, characters 4-22 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 280, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 197, characters 2-42 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "apply 'a to 'b" = - let env = ["f", Type_var {contents = Unbound "s"}; "x", Type_var {contents = Unbound "t"}] in + let env = ["f", Type_var {contents = Unbound ("s", 0)}; "x", Type_var {contents = Unbound ("t", 0)}] in infer_exp_str {| f x |} ~env ~rst: false; [%expect{| 'e |}] @@ -220,7 +220,7 @@ let%expect_test "apply 'a to 'b" = (************************** Patterns **************************) let%expect_test "id in env" = - let env = ["m", (Type_var {contents = Unbound "c"})] in + let env = ["m", (Type_var {contents = Unbound ("c", 0)})] in infer_pat_str {| m |} ~env; [%expect {| 'a |}];; @@ -288,7 +288,7 @@ let%expect_test "fun 'a -> 'a (new var)" = let%expect_test "fun 'a -> 'a (shadow)" = - let env = ["x", Type_var {contents = Unbound "type 's"}] in + let env = ["x", Type_var {contents = Unbound ("s", 0)}] in infer_exp_str {| fun x -> x |} ~env; [%expect {| 'a -> 'a |}] @@ -303,14 +303,14 @@ let%expect_test "fun 'a -> 'b (not in env)" = (Failure "unbound variable: y") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 238, characters 14-35 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 250, characters 14-35 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 297, characters 2-32 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "fun 'a -> 'b (in env)" = - let env = ["y", Type_var {contents = Unbound "s"}] in + let env = ["y", Type_var {contents = Unbound ("s", 0)}] in infer_exp_str {| fun x -> y |} ~env; [%expect{| 'a -> 's |}] @@ -335,8 +335,8 @@ let%expect_test _ = (Failure "can't unify different constructors: int and string") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 33, characters 4-15 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 268, characters 4-47 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 44, characters 4-15 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 280, characters 4-47 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 329, characters 2-68 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -345,21 +345,21 @@ let%expect_test _ = (************************** Match, function **************************) let%expect_test "correct match" = - let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match a with | Some x -> 1 | None -> 2 |} ~env; [%expect {| int |}] let%expect_test "use match pattern in body" = - let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match a with | Some x -> x | None -> 2 |} ~env; [%expect {| int |}] let%expect_test "match different constructors" = - let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match a with | Some x -> 1 | [] -> 2 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| @@ -369,16 +369,16 @@ let%expect_test "match different constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 313, characters 11-33 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 329, characters 11-33 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 309, characters 6-685 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 325, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 363, characters 2-63 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "match option with list constructors" = - let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match a with | x :: tl -> 1 | [] -> 2 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| @@ -388,16 +388,16 @@ let%expect_test "match option with list constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 313, characters 11-33 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 329, characters 11-33 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 309, characters 6-685 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 325, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 382, characters 2-64 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "match different types of expr 1" = - let env = [ "a", Type_construct("option", [Type_var {contents = Unbound "a"}])] @ env in + let env = [ "a", Type_construct("option", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match a with | Some x -> 'a' | None -> 1234 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| @@ -407,16 +407,16 @@ let%expect_test "match different types of expr 1" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 324, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 340, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 309, characters 6-685 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 325, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 401, characters 2-70 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] let%expect_test "match different types of expr 2" = - let env = [ "b", Type_construct("list", [Type_var {contents = Unbound "a"}])] @ env in + let env = [ "b", Type_construct("list", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match b with | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env; [%expect.unreachable] [@@expect.uncaught_exn {| @@ -426,9 +426,9 @@ let%expect_test "match different types of expr 2" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 324, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 340, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 309, characters 6-685 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 325, characters 6-685 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 420, characters 2-90 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -456,9 +456,9 @@ let%expect_test "function different constructors" = (Failure "can't unify different constructors: list and option") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 337, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 353, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 334, characters 6-314 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 350, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 450, characters 2-59 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -474,9 +474,9 @@ let%expect_test "function different types of expr 1" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 339, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 355, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 334, characters 6-314 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 350, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 468, characters 2-66 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -492,9 +492,9 @@ let%expect_test "function different types of expr 2" = (Failure "can't unify different constructors: char and int") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 339, characters 11-32 + Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 355, characters 11-32 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 334, characters 6-314 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 350, characters 6-314 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 486, characters 2-86 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -553,10 +553,10 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 37, characters 9-62 - Called from Middleend__Infer.infer_vb in file "lib/middleend/infer.ml", line 185, characters 2-19 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 48, characters 9-62 + Called from Middleend__Infer.infer_vb in file "lib/middleend/infer.ml", line 197, characters 2-19 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 297, characters 18-84 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 310, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 547, characters 2-46 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -572,10 +572,10 @@ let%expect_test _ = (Failure "cannot unify tuple types of different size") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 37, characters 9-62 - Called from Middleend__Infer.infer_vb in file "lib/middleend/infer.ml", line 185, characters 2-19 + Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 48, characters 9-62 + Called from Middleend__Infer.infer_vb in file "lib/middleend/infer.ml", line 197, characters 2-19 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 297, characters 18-84 + Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 310, characters 18-84 Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 566, characters 2-45 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -647,12 +647,12 @@ let%expect_test "weird let rec" = (Failure "this kind of expression is not allowed as right-hand side of `let rec'") Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_vb_rec in file "lib/middleend/infer.ml", line 206, characters 8-89 + Called from Middleend__Infer.infer_vb_rec in file "lib/middleend/infer.ml", line 218, characters 8-89 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_structure_item in file "lib/middleend/infer.ml", line 367, characters 6-80 - Called from Middleend__Infer.infer_program.(fun) in file "lib/middleend/infer.ml", line 377, characters 34-67 + Called from Middleend__Infer.infer_structure_item in file "lib/middleend/infer.ml", line 386, characters 6-80 + Called from Middleend__Infer.infer_program.(fun) in file "lib/middleend/infer.ml", line 397, characters 34-67 Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_program in file "lib/middleend/infer.ml", line 375, characters 4-189 + Called from Middleend__Infer.infer_program in file "lib/middleend/infer.ml", line 395, characters 4-189 Called from XML_unittests__Infer.infer_prog_str in file "many_tests/unit/infer.ml", line 27, characters 19-41 Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 640, characters 2-36 Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] @@ -660,27 +660,17 @@ let%expect_test "weird let rec" = let%expect_test "too polymorphic1" = infer_prog_str {| let map f p = let (a,b) = p in (f a, f b) |}; -[%expect {| val map : ('a -> 'b) -> 'c * 'd -> 'b * 'b |}] +[%expect {| val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b |}] -let%expect_test "too polymorphic" = - show_etyp [] (parse_exp_str {| let map f p = let (a,b) = p in (f a, f b) in map |}); +let%expect_test "too polymorphic2" = + infer_prog_str {| + let rec fix f x = f (fix f) x + let map f p = let (a,b) = p in (f a, f b) + let fixpoly l = + fix (fun self l -> map (fun li x -> li (self l) x) l) l + |}; [%expect {| - (Type_arrow ( - (Type_arrow ((Type_var ref ((Unbound "s"))), - (Type_var ref ((Unbound "t"))))), - (Type_arrow ( - (Type_tuple - ((Type_var ref ((Unbound "u"))), (Type_var ref ((Unbound "v"))), [])), - (Type_tuple - ((Type_var ref ((Unbound "t"))), (Type_var ref ((Unbound "t"))), [])) - )) - )) |}] - - -(* сделать pprint для текущего инфера - заменить старый инфер на новый - проверить, что тесты не упали, если упали, то починить - затем добавить уровни - проверить что тесты не упали, если упали, то починить - добавить монады вместо failwith - *) \ No newline at end of file + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b + val fixpoly : 'a -> ('b -> 'c) * ('b -> 'c) |}] + From dc019fa924c8b107480b24a26eabe84a116f9d18 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 3 Mar 2026 03:13:13 +0300 Subject: [PATCH 49/84] feat: monadic errors in infer, finally no failwith --- XML/lib/middleend/infer.ml | 375 +++++++++++++++++++++-------------- XML/lib/middleend/infer.mli | 12 +- XML/many_tests/unit/infer.ml | 285 +++----------------------- 3 files changed, 271 insertions(+), 401 deletions(-) diff --git a/XML/lib/middleend/infer.ml b/XML/lib/middleend/infer.ml index 78a006fe..6fb9f08c 100644 --- a/XML/lib/middleend/infer.ml +++ b/XML/lib/middleend/infer.ml @@ -9,53 +9,115 @@ open Common.Ast.Pattern open Common.Ast.TypeExpr open Common.Pprinter +type error = + | Occurs_check + | Cannot_unify of TypeExpr.t * TypeExpr.t + | Cannot_unify_tuple_size + | Cannot_unify_constructors of string * string + | Cannot_unify_quantified + | Unbound_variable of string + | Operator_not_found of string + | Invalid_let_rec_rhs + | Invalid_let_rec_lhs + | Not_supported of string + +let pprint_err ppf = function + | Occurs_check -> Format.fprintf ppf "Occurs check" + | Cannot_unify (t1, t2) -> + Format.fprintf ppf "Cannot unify types: %a and %a" pprint_type t1 pprint_type t2 + | Cannot_unify_tuple_size -> Format.fprintf ppf "Cannot unify tuples of different sizes" + | Cannot_unify_constructors (c1, c2) -> + Format.fprintf ppf "Cannot unify different constructors: %s and %s" c1 c2 + | Cannot_unify_quantified -> Format.fprintf ppf "Cannot unify quantified variable" + | Unbound_variable id -> Format.fprintf ppf "Unbound variable %s" id + | Operator_not_found op -> Format.fprintf ppf "Operator not found: %s" op + | Invalid_let_rec_rhs -> + Format.fprintf + ppf + "This kind of expression is not allowed as right-hand side of `let rec'" + | Invalid_let_rec_lhs -> + Format.fprintf ppf "Only variables are allowed as left-hand side of `let rec'" + | Not_supported string -> Format.fprintf ppf "Not supported: %s" string +;; + +type 'a t = ('a, error) result + +let return x = Ok x +let fail e = Error e +let ( let* ) = Result.bind let current_level = ref 0 let enter_level () = incr current_level let leave_level () = decr current_level let rec occurs_check tv = function - | Type_var tv' when tv == tv' -> failwith "occurs check" + | Type_var tv' when tv == tv' -> fail Occurs_check | Type_var ({ contents = Unbound (name, l) } as tv') -> let min_lvl = match !tv with | Unbound (_, l') -> min l l' | _ -> l in - tv' := Unbound (name, min_lvl) + tv' := Unbound (name, min_lvl); + return () | Type_var { contents = Link t } -> occurs_check tv t | Type_arrow (t1, t2) -> - occurs_check tv t1; - occurs_check tv t2 - | Type_tuple (t1, t2, tl) -> List.map (occurs_check tv) (t1 :: t2 :: tl) |> ignore - | Type_construct (_, lst) -> List.map (occurs_check tv) lst |> ignore - | _ -> () + let* () = occurs_check tv t1 in + let* () = occurs_check tv t2 in + return () + | Type_tuple (t1, t2, tl) -> + List.fold_left + (fun acc t -> + let* () = acc in + occurs_check tv t) + (return ()) + (t1 :: t2 :: tl) + | Type_construct (_, lst) -> + List.fold_left + (fun acc t -> + let* () = acc in + occurs_check tv t) + (return ()) + lst + | _ -> return () ;; let rec unify t1 t2 = match t1, t2 with - | t1, t2 when t1 == t2 -> () + | t1, t2 when t1 == t2 -> return () | Type_var { contents = Link t1 }, t2 | t1, Type_var { contents = Link t2 } -> unify t1 t2 | Type_var ({ contents = Unbound _ } as tv), t' | t', Type_var ({ contents = Unbound _ } as tv) -> - occurs_check tv t'; - tv := Link t' + let* () = occurs_check tv t' in + tv := Link t'; + return () | Type_arrow (l1, l2), Type_arrow (r1, r2) -> - unify l1 r1; + let* () = unify l1 r1 in unify l2 r2 | Type_tuple (l1, l2, ltl), Type_tuple (r1, r2, rtl) -> if List.length ltl <> List.length rtl - then failwith "cannot unify tuple types of different size"; - List.map2 unify (l1 :: l2 :: ltl) (r1 :: r2 :: rtl) |> ignore + then fail Cannot_unify_tuple_size + else + List.fold_left2 + (fun acc l r -> + let* () = acc in + unify l r) + (return ()) + (l1 :: l2 :: ltl) + (r1 :: r2 :: rtl) | Type_construct (lc, llst), Type_construct (rc, rlst) -> if lc <> rc - then failwith ("can't unify different constructors: " ^ lc ^ " and " ^ rc) - else List.map2 unify llst rlst |> ignore - | Quant_type_var _, _ | _, Quant_type_var _ -> - failwith "cannot unify with a quantified type" - | _ -> - failwith - (Format.asprintf "cannot unify types: %a and %a" pprint_type t1 pprint_type t2) + then fail (Cannot_unify_constructors (lc, rc)) + else + List.fold_left2 + (fun acc l r -> + let* () = acc in + unify l r) + (return ()) + llst + rlst + | Quant_type_var _, _ | _, Quant_type_var _ -> fail Cannot_unify_quantified + | _ -> fail (Cannot_unify (t1, t2)) ;; let rec generalize = function @@ -128,55 +190,54 @@ let inst = let rec infer_pat env = function | Pat_any -> let fresh = newvar () in - env, fresh + return (env, fresh) | Pat_var id -> let fresh = newvar () in let new_env = (id, fresh) :: env in - new_env, fresh + return (new_env, fresh) | Pat_constant const -> (match const with - | Const_char _ -> env, Type_construct ("char", []) - | Const_integer _ -> env, Type_construct ("int", []) - | Const_string _ -> env, Type_construct ("string", [])) + | Const_char _ -> return (env, Type_construct ("char", [])) + | Const_integer _ -> return (env, Type_construct ("int", [])) + | Const_string _ -> return (env, Type_construct ("string", []))) | Pat_tuple (p1, p2, ptl) -> - let new_env, ty1 = infer_pat env p1 in - let new_env1, ty2 = infer_pat new_env p2 in - let new_env2, tytl = + let* new_env, ty1 = infer_pat env p1 in + let* new_env1, ty2 = infer_pat new_env p2 in + let* new_env2, tytl = List.fold_left - (fun (eacc, tacc) exp -> - let curr_env, ty = infer_pat eacc exp in - curr_env, ty :: tacc) - (new_env1, []) + (fun acc exp -> + let* eacc, tacc = acc in + let* curr_env, ty = infer_pat eacc exp in + return (curr_env, ty :: tacc)) + (return (new_env1, [])) ptl in - new_env2, Type_tuple (ty1, ty2, List.rev tytl) + return (new_env2, Type_tuple (ty1, ty2, List.rev tytl)) | Pat_construct (name, pat) -> let ty = List.assoc name env in let inst_ty = inst ty in (match inst_ty, pat with | Type_arrow (arg, body), Some p -> - let new_env, new_ty = infer_pat env p in - unify arg new_ty; - new_env, body - | _ -> env, inst_ty) + let* new_env, new_ty = infer_pat env p in + let* () = unify arg new_ty in + return (new_env, body) + | _ -> return (env, inst_ty)) | Pat_constraint (p, ty) -> - let new_env, new_ty = infer_pat env p in - unify ty new_ty; - new_env, new_ty + let* new_env, new_ty = infer_pat env p in + let* () = unify ty new_ty in + return (new_env, new_ty) ;; let add_rec_names env vb_list = List.fold_left (fun cenv { pat; _ } -> + let* cenv = cenv in match pat with | Pat_var id | Pat_constraint (Pat_var id, _) -> - let ncenv, typ_p = infer_pat cenv pat in - (id, typ_p) :: ncenv - | _ -> - failwith - "only variables are allowed as left-hand side of 'let rec' (during adding rec \ - names)") - env + let* ncenv, typ_p = infer_pat cenv pat in + return ((id, typ_p) :: ncenv) + | _ -> fail Invalid_let_rec_lhs) + (return env) vb_list ;; @@ -192,9 +253,9 @@ let rec get_pat_names acc pat = let rec infer_vb env { pat; expr } = (* we don't need local names *) - let _, typ_e = infer_exp env expr in - let new_env, typ_p = infer_pat env pat in - unify typ_p typ_e; + let* _, typ_e = infer_exp env expr in + let* new_env, typ_p = infer_pat env pat in + let* () = unify typ_p typ_e in let pat_names = get_pat_names [] pat in let new_env1 = List.fold_left @@ -205,20 +266,19 @@ let rec infer_vb env { pat; expr } = new_env pat_names in - new_env1 + return new_env1 and infer_vb_rec env { pat; expr } = match pat with | Pat_var id | Pat_constraint (Pat_var id, _) -> - let new_env, typ_p = infer_pat env pat in + let* new_env, typ_p = infer_pat env pat in let new_env = (id, typ_p) :: new_env in - let new_env1, typ_e = + let* new_env1, typ_e = match expr with - | Exp_ident eid when id = eid -> - failwith "this kind of expression is not allowed as right-hand side of `let rec'" + | Exp_ident eid when id = eid -> fail Invalid_let_rec_rhs | _ -> infer_exp new_env expr in - unify typ_p typ_e; + let* () = unify typ_p typ_e in let pat_names = get_pat_names [] pat in let new_env2 = List.fold_left @@ -229,177 +289,202 @@ and infer_vb_rec env { pat; expr } = new_env1 pat_names in - new_env2 - | _ -> failwith "only variables are allowed as left-hand side of 'let rec'" + return new_env2 + | _ -> fail Invalid_let_rec_lhs and infer_exp env = function | Exp_ident id -> (match List.assoc_opt id env with - | Some ty -> env, inst ty - | None -> failwith ("unbound variable: " ^ id)) + | Some ty -> return (env, inst ty) + | None -> fail (Unbound_variable id)) | Exp_constant const -> (match const with - | Const_char _ -> env, Type_construct ("char", []) - | Const_integer _ -> env, Type_construct ("int", []) - | Const_string _ -> env, Type_construct ("string", [])) + | Const_char _ -> return (env, Type_construct ("char", [])) + | Const_integer _ -> return (env, Type_construct ("int", [])) + | Const_string _ -> return (env, Type_construct ("string", []))) | Exp_fun ((pat, pats), exp) -> - let new_env, typ_p = infer_pat env pat in - let newest_env, typ_exp = + let* new_env, typ_p = infer_pat env pat in + let* newest_env, typ_exp = match pats with | hd :: tl -> infer_exp new_env (Exp_fun ((hd, tl), exp)) | [] -> infer_exp new_env exp in - newest_env, Type_arrow (typ_p, typ_exp) + return (newest_env, Type_arrow (typ_p, typ_exp)) | Exp_apply (Exp_ident op, Exp_tuple (exp1, exp2, [])) -> (match op with | "*" | "/" | "+" | "-" | "<" | ">" | "=" | "<>" | "<=" | ">=" | "&&" | "||" -> - let new_env, typ1 = infer_exp env exp1 in - let new_env1, typ2 = infer_exp new_env exp2 in - let arg_typ, res_typ = + let* new_env, typ1 = infer_exp env exp1 in + let* new_env1, typ2 = infer_exp new_env exp2 in + let* arg_typ, res_typ = match List.assoc_opt op env with - | Some (Type_arrow (arg, Type_arrow (_, res))) -> inst arg, inst res - | _ -> failwith ("operator was not found in env: " ^ op) + | Some (Type_arrow (arg, Type_arrow (_, res))) -> return (inst arg, inst res) + | _ -> fail (Operator_not_found op) in - unify typ1 arg_typ; - unify typ2 arg_typ; - new_env1, res_typ + let* () = unify typ1 arg_typ in + let* () = unify typ2 arg_typ in + return (new_env1, res_typ) | _ -> - let new_env, typ_op = infer_exp env (Exp_ident op) in - let new_env1, typ_args = infer_exp new_env (Exp_tuple (exp1, exp2, [])) in + let* new_env, typ_op = infer_exp env (Exp_ident op) in + let* new_env1, typ_args = infer_exp new_env (Exp_tuple (exp1, exp2, [])) in let typ_res = newvar () in - unify typ_op (Type_arrow (typ_args, typ_res)); - new_env1, typ_res) + let* () = unify typ_op (Type_arrow (typ_args, typ_res)) in + return (new_env1, typ_res)) | Exp_apply (Exp_ident "-", arg) -> - let new_env1, typ_arg = infer_exp env arg in - unify typ_arg (Type_construct ("int", [])); - new_env1, Type_construct ("int", []) + let* new_env1, typ_arg = infer_exp env arg in + let* () = unify typ_arg (Type_construct ("int", [])) in + return (new_env1, Type_construct ("int", [])) | Exp_apply (f, arg) -> - let new_env, typ_f = infer_exp env f in - let new_env1, typ_arg = infer_exp new_env arg in + let* new_env, typ_f = infer_exp env f in + let* new_env1, typ_arg = infer_exp new_env arg in let typ_res = newvar () in - unify typ_f (Type_arrow (typ_arg, typ_res)); - new_env1, typ_res + let* () = unify typ_f (Type_arrow (typ_arg, typ_res)) in + return (new_env1, typ_res) | Exp_construct (name, Some exp) -> infer_exp env (Exp_apply (Exp_ident name, exp)) | Exp_construct (name, None) -> infer_exp env (Exp_ident name) | Exp_tuple (e1, e2, etl) -> - let new_env, ty1 = infer_exp env e1 in - let new_env1, ty2 = infer_exp new_env e2 in - let new_env2, tytl = + let* new_env, ty1 = infer_exp env e1 in + let* new_env1, ty2 = infer_exp new_env e2 in + let* new_env2, tytl = List.fold_left - (fun (eacc, tacc) exp -> - let curr_env, ty = infer_exp eacc exp in - curr_env, ty :: tacc) - (new_env1, []) + (fun acc exp -> + let* eacc, tacc = acc in + let* curr_env, ty = infer_exp eacc exp in + return (curr_env, ty :: tacc)) + (return (new_env1, [])) etl in - new_env2, Type_tuple (ty1, ty2, List.rev tytl) + return (new_env2, Type_tuple (ty1, ty2, List.rev tytl)) | Exp_if (cond, the, els) -> - let new_env, ty1 = infer_exp env cond in - unify ty1 (Type_construct ("bool", [])); - let new_env1, ty2 = infer_exp new_env the in + let* new_env, ty1 = infer_exp env cond in + let* () = unify ty1 (Type_construct ("bool", [])) in + let* new_env1, ty2 = infer_exp new_env the in (match els with | None -> - unify ty2 (Type_construct ("unit", [])); - new_env1, ty2 + let* () = unify ty2 (Type_construct ("unit", [])) in + return (new_env1, ty2) | Some els -> - let new_env, ty3 = infer_exp new_env1 els in - unify ty2 ty3; - new_env, ty3) + let* new_env, ty3 = infer_exp new_env1 els in + let* () = unify ty2 ty3 in + return (new_env, ty3)) | Exp_let (Nonrecursive, (vb, vbs), exprb) -> enter_level (); - let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in + let* new_env = + List.fold_left + (fun env bind -> + let* env = env in + infer_vb env bind) + (return env) + (vb :: vbs) + in leave_level (); infer_exp new_env exprb | Exp_let (Recursive, (vb, vbs), exprb) -> let new_env = add_rec_names env (vb :: vbs) in enter_level (); - let new_env1 = - List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) + let* new_env1 = + List.fold_left + (fun env bind -> + let* env = env in + infer_vb_rec env bind) + new_env + (vb :: vbs) in leave_level (); infer_exp new_env1 exprb | Exp_match (expr, (case, rest)) -> - let new_env, typ_main = infer_exp env expr in + let* new_env, typ_main = infer_exp env expr in let fresh = newvar () in - let typ_res = + let* typ_res = List.fold_left (fun acc_typ curr_case -> + let* acc_typ = acc_typ in let pat_names = get_pat_names [] curr_case.first in - let pat_env, typ_pat = infer_pat new_env curr_case.first in - unify typ_pat typ_main; - let pat_env = + let* pat_env, typ_pat = infer_pat new_env curr_case.first in + let* () = unify typ_pat typ_main in + let* pat_env = List.fold_left (fun env name -> + let* env = env in let typ = List.assoc name env in let env = List.remove_assoc name env in - (name, generalize typ) :: env) - pat_env + return ((name, generalize typ) :: env)) + (return pat_env) pat_names in - let _, typ_exp = infer_exp pat_env curr_case.second in - unify acc_typ typ_exp; - acc_typ) - fresh + let* _, typ_exp = infer_exp pat_env curr_case.second in + let* () = unify acc_typ typ_exp in + return acc_typ) + (return fresh) (case :: rest) in - new_env, typ_res + return (new_env, typ_res) | Exp_function (case, rest) -> let fresh_p = newvar () in let fresh_e = newvar () in - let typ_res = + let* typ_res = List.fold_left (fun acc_typ curr_case -> - let env_pat, typ_pat = infer_pat env curr_case.first in - unify typ_pat fresh_p; - let _, typ_exp = infer_exp env_pat curr_case.second in - unify acc_typ typ_exp; - acc_typ) - fresh_e + let* acc_typ = acc_typ in + let* env_pat, typ_pat = infer_pat env curr_case.first in + let* () = unify typ_pat fresh_p in + let* _, typ_exp = infer_exp env_pat curr_case.second in + let* () = unify acc_typ typ_exp in + return acc_typ) + (return fresh_e) (case :: rest) in - env, Type_arrow (fresh_p, typ_res) + return (env, Type_arrow (fresh_p, typ_res)) | Exp_constraint (e, ty) -> - let new_env, new_ty = infer_exp env e in - unify ty new_ty; - new_env, new_ty + let* new_env, new_ty = infer_exp env e in + let* () = unify ty new_ty in + return (new_env, new_ty) ;; let infer_structure_item env = function | Str_eval exp -> - let _, typ = infer_exp env exp in - ("-", typ) :: env, [] + let* _, typ = infer_exp env exp in + return (("-", typ) :: env, []) | Str_value (Nonrecursive, (vb, vbs)) -> let new_names = List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) in - (* enter_level (); *) - let new_env = List.fold_left (fun env bind -> infer_vb env bind) env (vb :: vbs) in - (* leave_level (); *) - new_env, new_names + let* new_env = + List.fold_left + (fun env bind -> + let* env = env in + infer_vb env bind) + (return env) + (vb :: vbs) + in + return (new_env, new_names) | Str_value (Recursive, (vb, vbs)) -> let new_names = List.fold_left (fun names { pat; _ } -> get_pat_names names pat) [] (vb :: vbs) in let new_env = add_rec_names env (vb :: vbs) in - (* enter_level (); *) - let new_env1 = - List.fold_left (fun env bind -> infer_vb_rec env bind) new_env (vb :: vbs) + let* new_env1 = + List.fold_left + (fun env bind -> + let* env = env in + infer_vb_rec env bind) + new_env + (vb :: vbs) in - (* leave_level (); *) - new_env1, new_names - | Str_adt _ -> failwith "str_adts are not supported" + return (new_env1, new_names) + | Str_adt _ -> fail (Not_supported "str_adts") ;; let infer_program env prog = - let new_env, new_names = + let* new_env, new_names = List.fold_left - (fun (env, names) str_item -> - let new_env, new_names = infer_structure_item env str_item in - new_env, new_names @ names) - (env, []) + (fun acc str_item -> + let* env, names = acc in + let* new_env, new_names = infer_structure_item env str_item in + return (new_env, new_names @ names)) + (return (env, [])) prog in - new_env, new_names + return (new_env, new_names) ;; let env_with_things = diff --git a/XML/lib/middleend/infer.mli b/XML/lib/middleend/infer.mli index 2766101c..ff6e0cfb 100644 --- a/XML/lib/middleend/infer.mli +++ b/XML/lib/middleend/infer.mli @@ -4,6 +4,10 @@ open Common.Ast +type error + +val pprint_err : Format.formatter -> error -> unit + (** resets counter for type variables *) val reset_gensym : unit -> unit @@ -12,21 +16,21 @@ val reset_gensym : unit -> unit val infer_exp : (ident * TypeExpr.t) list -> Expression.t - -> (ident * TypeExpr.t) list * TypeExpr.t + -> ((ident * TypeExpr.t) list * TypeExpr.t, error) result (** [infer_pat env pat] infers type of the pattern [pat] in the environment [env] and returns updated environment and type of [pat] *) val infer_pat : (ident * TypeExpr.t) list -> Pattern.t - -> (ident * TypeExpr.t) list * TypeExpr.t + -> ((ident * TypeExpr.t) list * TypeExpr.t, error) result (** [infer_structure_item env item] infers type of the item [item] in the environment [env] and returns updated environment and new names *) val infer_structure_item : (ident * TypeExpr.t) list -> Structure.structure_item - -> (ident * TypeExpr.t) list * ident list + -> ((ident * TypeExpr.t) list * ident list, error) result (** [infer_program env prog] infers all types in program [prog] with initial environment [env] and returns updated environment and names of all new global identificators @@ -35,7 +39,7 @@ val infer_structure_item val infer_program : (ident * TypeExpr.t) list -> Structure.structure_item list - -> (ident * TypeExpr.t) list * ident list + -> ((ident * TypeExpr.t) list * ident list, error) result (** [env_with_things] is the basic environment that contains built-in functions and constructors *) val env_with_things : (ident * TypeExpr.t) list diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index 32556429..393e3ae5 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -7,29 +7,37 @@ open Common.Parser open Common.Pprinter open Common.Ast.TypeExpr -(* TODO: get rid of failwith in infer *) +let (let*) = Result.bind let infer_exp_str ?(rst = true) ?(env = []) str = let exp = parse_exp_str str in if rst then reset_gensym (); - let _, ty = infer_exp env exp in - pprint_type Format.std_formatter ty;; + match infer_exp env exp with + | Ok (_, ty) -> + pprint_type Format.std_formatter ty + | Error err -> pprint_err Format.std_formatter err let infer_pat_str ?(rst = true) ?(env = []) str = let pat = parse_pat_str str in if rst then reset_gensym (); - let _, ty = infer_pat env pat in - pprint_type Format.std_formatter ty;; + match infer_pat env pat with + | Ok (_, ty) -> + pprint_type Format.std_formatter ty + | Error err -> pprint_err Format.std_formatter err let infer_prog_str ?(env = env_with_things) str = let prog = parse_str str in reset_gensym (); - let env, names = infer_program env prog in - pprint_env env names + match infer_program env prog with + | Ok (new_env, names) -> + pprint_env new_env names + | Error err -> pprint_err Format.std_formatter err let show_etyp env exp = - let _, ty = infer_exp env exp in + match infer_exp env exp with + | Ok (_, ty) -> Base.print_endline (Common.Ast.TypeExpr.show ty) + | Error err -> pprint_err Format.std_formatter err let type_bool = Type_construct ("bool", []) let type_unit = Type_construct ("unit", []) @@ -63,17 +71,7 @@ let%expect_test "id in env" = let%expect_test "id not in env" = infer_exp_str {| m |}; - [%expect.unreachable] - [@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "unbound variable: m") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 65, characters 2-23 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}];; + [%expect{| Unbound variable m |}];; let%expect_test "tuple 2" = @@ -108,33 +106,13 @@ let%expect_test "construct some" = let%expect_test "if (string) " = infer_exp_str {| if "trololo" then 1 |}; - [@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: string and bool") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 298, characters 4-43 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect {| Cannot unify different constructors: string and bool |}] let%expect_test "if (bool) then (not unit)" = let env = ["cond", type_bool] in infer_exp_str {| if cond then 1 |} ~env; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: int and unit") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 302, characters 7-46 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 125, characters 2-41 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: int and unit |}] let%expect_test "if (bool) then (unit)" = @@ -164,19 +142,7 @@ let%expect_test "apply int -> int to int" = let%expect_test "apply int -> int to string" = let env = ["f", Type_arrow (type_int, type_int); "x", type_string] in infer_exp_str {| f x |} ~env; - [%expect.unreachable] - [@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: int and string") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 44, characters 4-15 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 280, characters 4-47 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 166, characters 2-30 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: int and string |}] let%expect_test "apply 'a -> 'a to 'b" = @@ -195,20 +161,7 @@ let%expect_test "apply 'a to 'a (different vars)" = let%expect_test "apply 'a to 'a (same var)" = let env = ["x", Type_var {contents = Unbound ("t", 0)}] in infer_exp_str {| x x |} ~env ~rst: false; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "occurs check") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.occurs_check in file "lib/middleend/infer.ml", line 27, characters 4-22 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 41, characters 4-22 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 280, characters 4-47 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 197, characters 2-42 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Occurs check |}] let%expect_test "apply 'a to 'b" = @@ -295,18 +248,7 @@ let%expect_test "fun 'a -> 'a (shadow)" = let%expect_test "fun 'a -> 'b (not in env)" = infer_exp_str {| fun x -> y |}; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "unbound variable: y") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 250, characters 14-35 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 297, characters 2-32 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Unbound variable y |}] let%expect_test "fun 'a -> 'b (in env)" = @@ -327,19 +269,7 @@ let%expect_test _ = let%expect_test _ = infer_exp_str {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |}; - [%expect.unreachable] - [@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: int and string") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 44, characters 4-15 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 280, characters 4-47 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 329, characters 2-68 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: int and string |}] (************************** Match, function **************************) @@ -361,77 +291,25 @@ let%expect_test "use match pattern in body" = let%expect_test "match different constructors" = let env = [ "a", Type_construct("option", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match a with | Some x -> 1 | [] -> 2 |} ~env; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: list and option") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 329, characters 11-33 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 325, characters 6-685 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 363, characters 2-63 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: list and option |}] let%expect_test "match option with list constructors" = let env = [ "a", Type_construct("option", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match a with | x :: tl -> 1 | [] -> 2 |} ~env; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: list and option") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 329, characters 11-33 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 325, characters 6-685 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 382, characters 2-64 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: list and option |}] let%expect_test "match different types of expr 1" = let env = [ "a", Type_construct("option", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match a with | Some x -> 'a' | None -> 1234 |} ~env; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: char and int") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 340, characters 11-32 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 325, characters 6-685 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 401, characters 2-70 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: char and int |}] let%expect_test "match different types of expr 2" = let env = [ "b", Type_construct("list", [Type_var {contents = Unbound ("a", 0)}])] @ env in infer_exp_str {| match b with | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: char and int") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 340, characters 11-32 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 325, characters 6-685 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 420, characters 2-90 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: char and int |}] let%expect_test "correct function" = @@ -448,56 +326,17 @@ let%expect_test "use function pattern in body" = let%expect_test "function different constructors" = infer_exp_str {| function | Some x -> 1 | [] -> 2 |} ~env; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: list and option") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 353, characters 11-32 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 350, characters 6-314 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 450, characters 2-59 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: list and option |}] let%expect_test "function different types of expr 1" = infer_exp_str {| function | Some x -> 'a' | None -> 1234 |} ~env; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: char and int") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 355, characters 11-32 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 350, characters 6-314 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 468, characters 2-66 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: char and int |}] let%expect_test "function different types of expr 2" = infer_exp_str {| function | x :: y :: tl -> 'a' | x :: tl -> 'b' | _ -> 1234 |} ~env; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "can't unify different constructors: char and int") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_exp.(fun) in file "lib/middleend/infer.ml", line 355, characters 11-32 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 350, characters 6-314 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 486, characters 2-86 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify different constructors: char and int |}] (************************** Let in **************************) @@ -545,40 +384,12 @@ let%expect_test _ = let%expect_test _ = infer_exp_str {| let a, b, c = 1, 2 in a |} ; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "cannot unify tuple types of different size") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 48, characters 9-62 - Called from Middleend__Infer.infer_vb in file "lib/middleend/infer.ml", line 197, characters 2-19 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 310, characters 18-84 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 547, characters 2-46 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify tuples of different sizes |}] let%expect_test _ = infer_exp_str {| let a, b = 1, 2, 3 in a |}; - [%expect.unreachable] - [@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure "cannot unify tuple types of different size") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.unify in file "lib/middleend/infer.ml", line 48, characters 9-62 - Called from Middleend__Infer.infer_vb in file "lib/middleend/infer.ml", line 197, characters 2-19 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_exp in file "lib/middleend/infer.ml", line 310, characters 18-84 - Called from XML_unittests__Infer.infer_exp_str in file "many_tests/unit/infer.ml", line 15, characters 14-31 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 566, characters 2-45 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + [%expect{| Cannot unify tuples of different sizes |}] let%expect_test "let and" = @@ -638,39 +449,9 @@ let%expect_test "shadow with itself 2" = let%expect_test "weird let rec" = infer_prog_str {| let rec x = x |}; -[%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure - "this kind of expression is not allowed as right-hand side of `let rec'") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Middleend__Infer.infer_vb_rec in file "lib/middleend/infer.ml", line 218, characters 8-89 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_structure_item in file "lib/middleend/infer.ml", line 386, characters 6-80 - Called from Middleend__Infer.infer_program.(fun) in file "lib/middleend/infer.ml", line 397, characters 34-67 - Called from Stdlib__List.fold_left in file "list.ml", line 121, characters 24-34 - Called from Middleend__Infer.infer_program in file "lib/middleend/infer.ml", line 395, characters 4-189 - Called from XML_unittests__Infer.infer_prog_str in file "many_tests/unit/infer.ml", line 27, characters 19-41 - Called from XML_unittests__Infer.(fun) in file "many_tests/unit/infer.ml", line 640, characters 2-36 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] +[%expect{| This kind of expression is not allowed as right-hand side of `let rec' |}] let%expect_test "too polymorphic1" = infer_prog_str {| let map f p = let (a,b) = p in (f a, f b) |}; [%expect {| val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b |}] - -let%expect_test "too polymorphic2" = - infer_prog_str {| - let rec fix f x = f (fix f) x - let map f p = let (a,b) = p in (f a, f b) - let fixpoly l = - fix (fun self l -> map (fun li x -> li (self l) x) l) l - |}; -[%expect {| - val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b - val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b - val fixpoly : 'a -> ('b -> 'c) * ('b -> 'c) |}] - From 90dd64f1818dfc9cfd2c958488d34fadc8f507c0 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 3 Mar 2026 03:14:58 +0300 Subject: [PATCH 50/84] feat: update call to infer from driver code --- XML/bin/XML.ml | 27 +++++++++++++++++---------- XML/bin/XML_llvm.ml | 38 ++++++++++---------------------------- 2 files changed, 27 insertions(+), 38 deletions(-) diff --git a/XML/bin/XML.ml b/XML/bin/XML.ml index 6c3c8594..706ec3df 100644 --- a/XML/bin/XML.ml +++ b/XML/bin/XML.ml @@ -3,6 +3,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Format +open Common.Pprinter (* ------------------------------- *) (* Command-line Options *) @@ -18,6 +19,7 @@ type options = ; mutable show_ll : bool ; mutable gc_stats : bool ; mutable check_types : bool + ; mutable show_types : bool } (* ------------------------------- *) @@ -37,16 +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 typedtree = - Middleend.Infer.run_infer_program ast Middleend.Infer.env_with_things - in - match typedtree with - | Error err -> - Format.printf "Type error: %a\n" Middleend.InferTypes.pp_inf_err err; - exit 1 - | Ok (_, _) -> ()); + (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; @@ -118,6 +121,7 @@ let () = ; show_ll = false ; gc_stats = false ; check_types = true + ; show_types = false } in let usage_msg = @@ -151,6 +155,9 @@ let () = ; ( "-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 = diff --git a/XML/bin/XML_llvm.ml b/XML/bin/XML_llvm.ml index 7172b506..873d47f4 100644 --- a/XML/bin/XML_llvm.ml +++ b/XML/bin/XML_llvm.ml @@ -3,6 +3,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Format +open Common.Pprinter (* ------------------------------- *) (* Command-line Options *) @@ -38,35 +39,19 @@ let to_llvm_ir ast options = Backend.Codegen_llvm.gen_program_ir ll_anf target opt ;; -(* in *) -(* Buffer.contents buf *) - let compile_and_write options source_code = let ast = Common.Parser.parse_str source_code in (if options.check_types then - let open Middleend.InferLayers in - let env, names = - (* Middleend.Infer.run_infer_program ast Middleend.Infer.env_with_things *) - infer_program env_with_things ast - in - (* List.iter (fun id -> printf "%s\n" id) names; *) - (* match typedtree with - | Error err -> - Format.printf "Type error: %a\n" Middleend.InferTypes.pp_inf_err err; - exit 1 - | Ok (env, names) -> - if options.show_types - then ( - Middleend.Infer.pprint_result env names; - exit 0) - else ()); *) - if options.show_types - then ( - let env = filter_env env names in - pprint_env env names; - exit 0) - else ()); + 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; *) @@ -169,9 +154,6 @@ let () = ; ( "--ll" , Arg.Unit (fun () -> options.show_ll <- true) , " Show ANF after lambda lifting and exit" ) - (* ( "--gc-stats" - , Arg.Unit (fun () -> options.gc_stats <- true) - , " Enable GC statistics and force a collection at program start/end" ) *) ; ( "-O" , Arg.String (fun opt -> options.optimization_lvl <- Some opt) , " Set IR optimization level, \"O0\" by default" ) From 2994f337a8a67b899a3e79793b070c01a4d10ac0 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 3 Mar 2026 12:50:22 +0300 Subject: [PATCH 51/84] test: add some tests --- XML/lib/backend/codegen_llvm.ml | 47 ++-- XML/lib/backend/codegen_llvm.mli | 69 ++++- XML/many_tests/unit/codegen_llvm.ml | 397 ++++++++++++++++++++++++++++ XML/many_tests/unit/dune | 2 +- 4 files changed, 489 insertions(+), 26 deletions(-) create mode 100644 XML/many_tests/unit/codegen_llvm.ml diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 944e9dce..845f2ea2 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -13,10 +13,8 @@ let void_type = Llvm.void_type context let gcheader_type = Llvm.struct_type context [| i64_type |] let block_elms_type = Llvm.array_type i64_type 0 let block_type = Llvm.struct_type context [| gcheader_type; i64_type; block_elms_type |] -let default_type = i64_type (* *) let ptr_type = Llvm.pointer_type context let builder = Llvm.builder context -let the_module = Llvm.create_module context "main" let named_values : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 32 module FuncMap = struct @@ -68,10 +66,10 @@ module FuncMap = struct end (* Return types from runtime.c *) -let initial_fmap = +let initial_fmap the_mod = let decl fmap id retty argtyps = let ftyp = Llvm.function_type retty argtyps in - let fval = Llvm.declare_function id ftyp the_module in + let fval = Llvm.declare_function id ftyp the_mod in FuncMap.bind fmap id (fval, ftyp, FuncMap.Lib) in let fmap = FuncMap.empty () in @@ -102,25 +100,25 @@ let build_call_mb_void ftype fval argvs name = | _ -> Llvm.build_call ftype fval argvs name builder ;; -let decl_and_bind fmap id retty argc = +let decl_and_bind fmap the_mod id retty argc = match FuncMap.find fmap id with | Some (_, _, FuncMap.Lib) -> fmap | _ when argc = 0 -> fmap | _ -> let argtyps = Array.make argc i64_type in let ftyp = Llvm.function_type retty argtyps in - let fval = Llvm.declare_function id ftyp the_module in + let fval = Llvm.declare_function id ftyp the_mod in FuncMap.bind fmap id (fval, ftyp, FuncMap.User) ;; -let prefill_fmap (fmap0 : FuncMap.t) (program : aprogram) : FuncMap.t = +let prefill_fmap (fmap0 : FuncMap.t) the_mod (program : aprogram) : FuncMap.t = List.fold_left (fun fm -> function | Anf_str_value (_rf, name, anf_expr) -> (match anf_expr with | Anf_let (_, _, Comp_func (ps, _), _) | Anf_comp_expr (Comp_func (ps, _)) -> - decl_and_bind fm name i64_type (List.length ps) - | _ -> decl_and_bind fm name i64_type 0) + decl_and_bind fm the_mod name i64_type (List.length ps) + | _ -> decl_and_bind fm the_mod name i64_type 0) | _ -> fm) fmap0 program @@ -148,7 +146,7 @@ let gen_im_expr_ir fmap = function | Imm_ident id -> (match Hashtbl.find_opt named_values id with | Some v -> - let temp = Llvm.build_load default_type v id builder in + let temp = Llvm.build_load i64_type v id builder in Llvm.set_alignment gl_align temp; temp | None -> @@ -247,7 +245,7 @@ let rec gen_comp_expr_ir fmap = function (* maybe it's a closure in this scope *) (match Hashtbl.find_opt named_values f with | Some clos_ptr -> - let clos_val = Llvm.build_load default_type clos_ptr (f ^ "_val") builder in + let clos_val = Llvm.build_load i64_type clos_ptr (f ^ "_val") builder in Llvm.set_alignment gl_align clos_val; let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in build_apply_part fmap clos_val argvs @@ -322,13 +320,13 @@ and gen_anf_expr fmap = function gen_anf_expr fmap body ;; -let gen_function fmap name params body = +let gen_function fmap the_mod name params body = Hashtbl.clear named_values; - let param_types = Array.map (fun _ -> default_type) (Array.of_list params) in - let f_type = Llvm.function_type default_type param_types in + let param_types = Array.map (fun _ -> i64_type) (Array.of_list params) in + let f_type = Llvm.function_type i64_type param_types in let the_fun = - match Llvm.lookup_function name the_module with - | None -> Llvm.declare_function name f_type the_module + match Llvm.lookup_function name the_mod with + | None -> Llvm.declare_function name f_type the_mod | Some f -> if Array.length (Llvm.basic_blocks f) = 0 then () @@ -368,13 +366,13 @@ let gen_function fmap name params body = the_fun ;; -let gen_astructure_item fmap = function +let gen_astructure_item fmap the_mod = function | Anf_str_eval expr -> gen_anf_expr fmap expr | Anf_str_value (_, name, Anf_comp_expr (Comp_func (params, body))) -> - gen_function fmap name params body + gen_function fmap the_mod name params body | Anf_str_value (_, name, expr) -> let main_fn = - match Llvm.lookup_function "main" the_module with + match Llvm.lookup_function "main" the_mod with | Some fn -> fn | _ -> invalid_arg ("cannot generate value: " ^ name ^ ", main function not found") in @@ -387,7 +385,7 @@ let gen_astructure_item fmap = function store ;; -let optimize_ir (triple : string) (opt : string option) = +let optimize_ir the_mod (triple : string) (opt : string option) = let target = Llvm_target.Target.by_triple triple in let machine = Llvm_target.TargetMachine.create ~triple target in let opts = Llvm_passbuilder.create_passbuilder_options () in @@ -397,17 +395,18 @@ let optimize_ir (triple : string) (opt : string option) = | _ -> "O0" in let optflag = "default<" ^ optflag ^ ">" in - (match Llvm_passbuilder.run_passes the_module optflag machine opts with + (match Llvm_passbuilder.run_passes the_mod optflag machine opts with | Error e -> invalid_arg e | Ok () -> ()); Llvm_passbuilder.dispose_passbuilder_options opts ;; let gen_program_ir (program : aprogram) (triple : string) (opt : string option) = + let the_module = Llvm.create_module context "main" in Llvm_all_backends.initialize (); Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); - let fmap = prefill_fmap initial_fmap program in + let fmap = prefill_fmap (initial_fmap the_module) the_module program in (* FuncMap.print_fmap fmap; *) let main_ty = Llvm.function_type i64_type [||] in let main_fn = Llvm.define_function "main" main_ty the_module in @@ -416,13 +415,13 @@ let gen_program_ir (program : aprogram) (triple : string) (opt : string option) let _ = build_call_mb_void initty initfn [| Llvm.const_int i64_type (5 * 1024) |] "inittmp" in - let _ = List.map (fun item -> gen_astructure_item fmap item) program in + let _ = List.map (gen_astructure_item fmap the_module) program in let bbs = Llvm.basic_blocks main_fn in Llvm.position_at_end bbs.(Array.length bbs - 1) builder; let col_fn, col_ty, _ = FuncMap.find_exn fmap "collect" in let _ = build_call_mb_void col_ty col_fn [||] "_" in let _ = Llvm.build_ret (Llvm.const_int i64_type 0) builder in - optimize_ir triple opt; + optimize_ir the_module triple opt; match Llvm_analysis.verify_module the_module with | Some r -> invalid_arg r | None -> Llvm.string_of_llmodule the_module diff --git a/XML/lib/backend/codegen_llvm.mli b/XML/lib/backend/codegen_llvm.mli index be5eb619..eeaac5c4 100644 --- a/XML/lib/backend/codegen_llvm.mli +++ b/XML/lib/backend/codegen_llvm.mli @@ -2,6 +2,73 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -(** [gen_program_ir prog triple opt] gens program in LLMV IR from the program [prog] +module FuncMap : sig + module K : sig + type t + + val compare : 'a -> 'a -> int + end + + type status = + | User + | Lib + + type t + + module M : sig + type key + type 'a t + + val empty : 'a t + val is_empty : 'a t -> bool + val mem : key -> 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + val singleton : key -> 'a -> 'a t + val remove : key -> 'a t -> 'a t + val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all : (key -> 'a -> bool) -> 'a t -> bool + val exists : (key -> 'a -> bool) -> 'a t -> bool + val filter : (key -> 'a -> bool) -> 'a t -> 'a t + val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t + val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal : 'a t -> int + val bindings : 'a t -> (key * 'a) list + val min_binding : 'a t -> key * 'a + val min_binding_opt : 'a t -> (key * 'a) option + val max_binding : 'a t -> key * 'a + val max_binding_opt : 'a t -> (key * 'a) option + val choose : 'a t -> key * 'a + val choose_opt : 'a t -> (key * 'a) option + val split : key -> 'a t -> 'a t * 'a option * 'a t + val find : key -> 'a t -> 'a + val find_opt : key -> 'a t -> 'a option + val find_first : (key -> bool) -> 'a t -> key * 'a + val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option + val find_last : (key -> bool) -> 'a t -> key * 'a + val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option + val map : ('a -> 'b) -> 'a t -> 'b t + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + val to_seq : 'a t -> (key * 'a) Seq.t + val to_rev_seq : 'a t -> (key * 'a) Seq.t + val to_seq_from : key -> 'a t -> (key * 'a) Seq.t + val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t + val of_seq : (key * 'a) Seq.t -> 'a t + end + + val empty : unit -> t + val bind : t -> string -> Llvm.llvalue * Llvm.lltype * status -> t + val find : t -> string -> (Llvm.llvalue * Llvm.lltype * status) option + val find_exn : t -> string -> Llvm.llvalue * Llvm.lltype * status + val keys : 'a M.t -> (string * 'a) list + val print_fmap : t -> unit +end + +(** [gen_program_ir prog triple opt] generates a LLMV IR string from the program [prog] for the target architecture specified by [triple] with optimization level [opt] if not None, O0 otherwise*) val gen_program_ir : Middleend.Anf.aprogram -> string -> string option -> string diff --git a/XML/many_tests/unit/codegen_llvm.ml b/XML/many_tests/unit/codegen_llvm.ml new file mode 100644 index 00000000..35596d30 --- /dev/null +++ b/XML/many_tests/unit/codegen_llvm.ml @@ -0,0 +1,397 @@ +open Backend.Codegen_llvm +open Middleend.Anf +open Middleend.Ll +open Common.Parser + +let codegen_prog_str str = + let prog = parse_str str in + let anf = anf_program prog in + let ll = lambda_lift_program anf in + print_string (gen_program_ir ll "riscv64-unknown-linux-gnu" None) + +let%expect_test "num" = + codegen_prog_str {| 5 |}; + [%expect {| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @main() { + entry: + call void @rt_init(i64 5120) + call void @collect() + ret i64 0 + } |}] + +let%expect_test "comp binop" = + codegen_prog_str {| 1 + 2 |}; + [%expect {| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @main() { + entry: + call void @rt_init(i64 5120) + call void @collect() + ret i64 0 + } |}] + +let%expect_test "print_int 5" = + codegen_prog_str {| print_int 5 |}; + [%expect {| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @main() { + entry: + %t_0 = alloca i64, align 8 + call void @rt_init(i64 5120) + call void @print_int(i64 11) + store i64 0, ptr %t_0, align 8 + %t_01 = load i64, ptr %t_0, align 8 + call void @collect() + ret i64 0 + } |}] + +let%expect_test "if 1 then 1 else 2 " = + codegen_prog_str {| if true then 1 else 2 |}; + [%expect.unreachable] +[@@expect.uncaught_exn {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Invalid_argument "unsupported expression in ANF normaliser") + Raised at Stdlib.invalid_arg in file "stdlib.ml", line 30, characters 20-45 + Called from XML_unittests__Codegen_llvm.codegen_prog_str in file "many_tests/unit/codegen_llvm.ml", line 8, characters 12-28 + Called from XML_unittests__Codegen_llvm.(fun) in file "many_tests/unit/codegen_llvm.ml", line 119, characters 2-46 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + +let%expect_test "tuple" = + codegen_prog_str {| (1, 2, 3, 4) |}; + [%expect {| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @main() { + entry: + %t_0 = alloca i64, align 8 + call void @rt_init(i64 5120) + %tuple_vals_alloca = alloca i64, i64 4, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 3, ptr %ptr_to_elem, align 8 + %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 5, ptr %ptr_to_elem1, align 8 + %ptr_to_elem2 = getelementptr i64, ptr %tuple_vals_alloca, i64 2 + store i64 7, ptr %ptr_to_elem2, align 8 + %ptr_to_elem3 = getelementptr i64, ptr %tuple_vals_alloca, i64 3 + store i64 9, ptr %ptr_to_elem3, align 8 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 4, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_0, align 8 + %t_04 = load i64, ptr %t_0, align 8 + call void @collect() + ret i64 0 + } |}] + +let%expect_test "load" = + codegen_prog_str {| let a, b = (1, 2) in a, b |}; + [%expect {| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @main() { + entry: + %t_1 = alloca i64, align 8 + %b = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %a = alloca i64, align 8 + %t_3 = alloca i64, align 8 + %t_0 = alloca i64, align 8 + call void @rt_init(i64 5120) + %tuple_vals_alloca = alloca i64, i64 2, align 8 + %ptr_to_elem = getelementptr i64, ptr %tuple_vals_alloca, i64 0 + store i64 3, ptr %ptr_to_elem, align 8 + %ptr_to_elem1 = getelementptr i64, ptr %tuple_vals_alloca, i64 1 + store i64 5, ptr %ptr_to_elem1, align 8 + %alloca_as_i64 = ptrtoint ptr %tuple_vals_alloca to i64 + %tuple_tmp = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i64) + store i64 %tuple_tmp, ptr %t_0, align 8 + %t_02 = load i64, ptr %t_0, align 8 + %load_tmp = call i64 @field(i64 %t_02, i64 0) + store i64 %load_tmp, ptr %t_3, align 8 + %t_33 = load i64, ptr %t_3, align 8 + store i64 %t_33, ptr %a, align 8 + %t_04 = load i64, ptr %t_0, align 8 + %load_tmp5 = call i64 @field(i64 %t_04, i64 1) + store i64 %load_tmp5, ptr %t_2, align 8 + %t_26 = load i64, ptr %t_2, align 8 + store i64 %t_26, ptr %b, align 8 + %a7 = load i64, ptr %a, align 8 + %b8 = load i64, ptr %b, align 8 + %tuple_vals_alloca9 = alloca i64, i64 2, align 8 + %ptr_to_elem10 = getelementptr i64, ptr %tuple_vals_alloca9, i64 0 + store i64 %a7, ptr %ptr_to_elem10, align 8 + %ptr_to_elem11 = getelementptr i64, ptr %tuple_vals_alloca9, i64 1 + store i64 %b8, ptr %ptr_to_elem11, align 8 + %alloca_as_i6412 = ptrtoint ptr %tuple_vals_alloca9 to i64 + %tuple_tmp13 = call i64 @create_tuple_init(i64 2, i64 %alloca_as_i6412) + store i64 %tuple_tmp13, ptr %t_1, align 8 + %t_114 = load i64, ptr %t_1, align 8 + call void @collect() + ret i64 0 + } |}] + +let%expect_test "new function " = + codegen_prog_str {| let a = fun x -> x |}; + [%expect {| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @a(i64 %x) { + entry: + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 8 + %x2 = load i64, ptr %x1, align 8 + ret i64 %x2 + } + + define i64 @main() { + entry: + call void @rt_init(i64 5120) + call void @collect() + ret i64 0 + } |}] + +let%expect_test "call function " = + codegen_prog_str {| + let a = fun x -> x;; + + let main = a 5;; + |}; + [%expect {| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @a(i64 %x) { + entry: + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 8 + %x2 = load i64, ptr %x1, align 8 + ret i64 %x2 + } + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_1 = alloca i64, align 8 + call void @rt_init(i64 5120) + %calltmp = call i64 @a(i64 11) + store i64 %calltmp, ptr %t_1, align 8 + %t_11 = load i64, ptr %t_1, align 8 + store i64 %t_11, ptr %main, align 8 + call void @collect() + ret i64 0 + } |}] + + +let%expect_test "partial " = + codegen_prog_str {| + let a = fun x -> fun y -> x;; + + let main = a 5;; + |}; + [%expect {| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @a(i64 %x, i64 %y) { + entry: + %y2 = alloca i64, align 8 + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 8 + store i64 %y, ptr %y2, align 8 + %x3 = load i64, ptr %x1, align 8 + ret i64 %x3 + } + + define i64 @main() { + entry: + %main = alloca i64, align 8 + %t_1 = alloca i64, align 8 + call void @rt_init(i64 5120) + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @a to i64), i64 2) + %apptmp = call i64 @apply1(i64 %closure_tmp, i64 11) + store i64 %apptmp, ptr %t_1, align 8 + %t_11 = load i64, ptr %t_1, align 8 + store i64 %t_11, ptr %main, align 8 + call void @collect() + ret i64 0 + } |}] \ No newline at end of file diff --git a/XML/many_tests/unit/dune b/XML/many_tests/unit/dune index 0879bb83..0702230e 100644 --- a/XML/many_tests/unit/dune +++ b/XML/many_tests/unit/dune @@ -1,7 +1,7 @@ (library (name XML_unittests) (public_name XML.Many_tests.Unittests) - (libraries base stdio XML.Common XML.Middleend) + (libraries base stdio XML.Common XML.Middleend XML.Backend) (preprocess (pps ppx_expect ppx_inline_test ppx_expect)) (instrumentation From 25e0e4b6335ecf56b329914653eb326c81c8e67d Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 22:22:45 +0300 Subject: [PATCH 52/84] fix: user-defined main fun, add tests for it and reserved names --- XML/lib/backend/codegen_llvm.ml | 11 +- XML/many_tests/codegen_llvm.t | 27 +++++ XML/many_tests/unit/codegen_llvm.ml | 173 +++++++++++++++++++++++++++- 3 files changed, 205 insertions(+), 6 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 845f2ea2..129bb118 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -15,6 +15,7 @@ let block_elms_type = Llvm.array_type i64_type 0 let block_type = Llvm.struct_type context [| gcheader_type; i64_type; block_elms_type |] let ptr_type = Llvm.pointer_type context let builder = Llvm.builder context +let subst_main = "__user_main" let named_values : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 32 module FuncMap = struct @@ -101,6 +102,7 @@ let build_call_mb_void ftype fval argvs name = ;; let decl_and_bind fmap the_mod id retty argc = + let id = if id = "main" then subst_main else id in match FuncMap.find fmap id with | Some (_, _, FuncMap.Lib) -> fmap | _ when argc = 0 -> fmap @@ -136,8 +138,6 @@ let build_alloc_closure fmap func = let argc = Array.length (Llvm.params func) in let argc = Llvm.const_int i64_type argc in let func_as_i64 = Llvm.build_pointercast func i64_type "func_as_i64" builder in - (* _print_untag fmap func_as_i64; - _print_untag fmap argc; *) Llvm.build_call actyp acval [| func_as_i64; argc |] "closure_tmp" builder ;; @@ -150,6 +150,7 @@ let gen_im_expr_ir fmap = function Llvm.set_alignment gl_align temp; temp | None -> + let id = if id = "main" then subst_main else id in (match FuncMap.find fmap id with | Some (fval, ftyp, _) -> if Array.length (Llvm.params fval) = 0 @@ -218,8 +219,6 @@ let build_apply_part fmap fclos args = List.fold_left (fun clos arg -> let clos_as_i64 = Llvm.build_pointercast clos i64_type "clos_as_i64" builder in - (* _print_untag fmap clos_as_i64; - _print_untag fmap arg; *) build_call_mb_void aptyp apval [| clos_as_i64; arg |] "apptmp") fclos args @@ -229,8 +228,9 @@ let rec gen_comp_expr_ir fmap = function | Comp_imm imm -> gen_im_expr_ir fmap imm | Comp_binop (op, lhs, rhs) -> gen_tagged_binop fmap op lhs rhs | Comp_app (Imm_ident f, args) -> + let f_map = if f = "main" then subst_main else f in (* Format.printf "Id: %s got called with %d args\n" f (List.length args); *) - (match FuncMap.find fmap f with + (match FuncMap.find fmap f_map with | Some (fval, ftype, _) -> let pvs = Llvm.params fval in let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in @@ -322,6 +322,7 @@ and gen_anf_expr fmap = function let gen_function fmap the_mod name params body = Hashtbl.clear named_values; + let name = if name = "main" then subst_main else name in let param_types = Array.map (fun _ -> i64_type) (Array.of_list params) in let f_type = Llvm.function_type i64_type param_types in let the_fun = diff --git a/XML/many_tests/codegen_llvm.t b/XML/many_tests/codegen_llvm.t index f8591106..d869594b 100644 --- a/XML/many_tests/codegen_llvm.t +++ b/XML/many_tests/codegen_llvm.t @@ -324,3 +324,30 @@ GC allocations: 30002 ================= 1 + + $ ../bin/XML_llvm.exe -o user_main.ll -notypes < let main x = x + > + > let a = print_int (main 5) + + $ llc-18 user_main.ll -o temp.s + $ clang-18 --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe + 5 + + + $ ../bin/XML_llvm.exe -o use_reserved_name.ll -notypes < let some_fun x y = x + y + > let closure_tmp x y = x + y + > + > let a = print_int (some_fun 5 10) + > let b = print_int (closure_tmp 5 10) + > let closure_tmp = 5 + > let c = print_int closure_tmp + + $ llc-18 use_reserved_name.ll -o temp.s + $ clang-18 --target=riscv64-linux-gnu -static temp.s runtime.o -o temp.exe + $ qemu-riscv64 -L /usr/riscv64-linux-gnu/ -cpu rv64 ./temp.exe + 15 + 15 + 5 diff --git a/XML/many_tests/unit/codegen_llvm.ml b/XML/many_tests/unit/codegen_llvm.ml index 35596d30..2efe7a6a 100644 --- a/XML/many_tests/unit/codegen_llvm.ml +++ b/XML/many_tests/unit/codegen_llvm.ml @@ -394,4 +394,175 @@ let%expect_test "partial " = store i64 %t_11, ptr %main, align 8 call void @collect() ret i64 0 - } |}] \ No newline at end of file + } |}] + + +let%expect_test "user main" = + codegen_prog_str {| + let main x = x + + let a = print_int (main 5) + |}; + [%expect{| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @__user_main(i64 %x) { + entry: + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 8 + %x2 = load i64, ptr %x1, align 8 + ret i64 %x2 + } + + define i64 @main() { + entry: + %a = alloca i64, align 8 + %t_2 = alloca i64, align 8 + %t_1 = alloca i64, align 8 + call void @rt_init(i64 5120) + %calltmp = call i64 @__user_main(i64 11) + store i64 %calltmp, ptr %t_1, align 8 + %t_11 = load i64, ptr %t_1, align 8 + call void @print_int(i64 %t_11) + store i64 0, ptr %t_2, align 8 + %t_22 = load i64, ptr %t_2, align 8 + store i64 %t_22, ptr %a, align 8 + call void @collect() + ret i64 0 + } |}] + + +let%expect_test "use reserved name" = + codegen_prog_str {| + let some_fun x y = x + y + let closure_tmp x y = x + y + + let a = print_int (some_fun 5 10) + let b = print_int (closure_tmp 5 10) + let closure_tmp = 5 + let c = print_int closure_tmp + |}; + [%expect{| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @some_fun(i64 %x, i64 %y) { + entry: + %t_0 = alloca i64, align 8 + %y2 = alloca i64, align 8 + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 8 + store i64 %y, ptr %y2, align 8 + %x3 = load i64, ptr %x1, align 8 + %y4 = load i64, ptr %y2, align 8 + %addtmp1 = add i64 %x3, %y4 + %addtmp2 = sub i64 %addtmp1, 1 + store i64 %addtmp2, ptr %t_0, align 8 + %t_05 = load i64, ptr %t_0, align 8 + ret i64 %t_05 + } + + define i64 @closure_tmp(i64 %x, i64 %y) { + entry: + %t_2 = alloca i64, align 8 + %y2 = alloca i64, align 8 + %x1 = alloca i64, align 8 + store i64 %x, ptr %x1, align 8 + store i64 %y, ptr %y2, align 8 + %x3 = load i64, ptr %x1, align 8 + %y4 = load i64, ptr %y2, align 8 + %addtmp1 = add i64 %x3, %y4 + %addtmp2 = sub i64 %addtmp1, 1 + store i64 %addtmp2, ptr %t_2, align 8 + %t_25 = load i64, ptr %t_2, align 8 + ret i64 %t_25 + } + + define i64 @main() { + entry: + %c = alloca i64, align 8 + %t_10 = alloca i64, align 8 + %closure_tmp9 = alloca i64, align 8 + %b = alloca i64, align 8 + %t_9 = alloca i64, align 8 + %t_8 = alloca i64, align 8 + %t_7 = alloca i64, align 8 + %a = alloca i64, align 8 + %t_6 = alloca i64, align 8 + %t_5 = alloca i64, align 8 + %t_4 = alloca i64, align 8 + call void @rt_init(i64 5120) + %closure_tmp = call i64 @alloc_closure(i64 ptrtoint (ptr @some_fun to i64), i64 2) + %apptmp = call i64 @apply1(i64 %closure_tmp, i64 11) + store i64 %apptmp, ptr %t_4, align 8 + %t_4_val = load i64, ptr %t_4, align 8 + %apptmp1 = call i64 @apply1(i64 %t_4_val, i64 21) + store i64 %apptmp1, ptr %t_5, align 8 + %t_52 = load i64, ptr %t_5, align 8 + call void @print_int(i64 %t_52) + store i64 0, ptr %t_6, align 8 + %t_63 = load i64, ptr %t_6, align 8 + store i64 %t_63, ptr %a, align 8 + %closure_tmp4 = call i64 @alloc_closure(i64 ptrtoint (ptr @closure_tmp to i64), i64 2) + %apptmp5 = call i64 @apply1(i64 %closure_tmp4, i64 11) + store i64 %apptmp5, ptr %t_7, align 8 + %t_7_val = load i64, ptr %t_7, align 8 + %apptmp6 = call i64 @apply1(i64 %t_7_val, i64 21) + store i64 %apptmp6, ptr %t_8, align 8 + %t_87 = load i64, ptr %t_8, align 8 + call void @print_int(i64 %t_87) + store i64 0, ptr %t_9, align 8 + %t_98 = load i64, ptr %t_9, align 8 + store i64 %t_98, ptr %b, align 8 + store i64 11, ptr %closure_tmp9, align 8 + %closure_tmp10 = load i64, ptr %closure_tmp9, align 8 + call void @print_int(i64 %closure_tmp10) + store i64 0, ptr %t_10, align 8 + %t_1011 = load i64, ptr %t_10, align 8 + store i64 %t_1011, ptr %c, align 8 + call void @collect() + ret i64 0 + } |}] From 80b0e637a52a5be8732f1923b1468f53af934748 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 22:51:02 +0300 Subject: [PATCH 53/84] ref: replace hashtbl with map in codegen_llvm --- XML/lib/backend/codegen_llvm.ml | 115 ++++++++++++++------------------ 1 file changed, 50 insertions(+), 65 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 129bb118..7360597e 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -16,7 +16,8 @@ let block_type = Llvm.struct_type context [| gcheader_type; i64_type; block_elms let ptr_type = Llvm.pointer_type context let builder = Llvm.builder context let subst_main = "__user_main" -let named_values : (string, Llvm.llvalue) Hashtbl.t = Hashtbl.create 32 + +module ParamMap = Map.Make (String) module FuncMap = struct module K = struct @@ -141,10 +142,10 @@ let build_alloc_closure fmap func = Llvm.build_call actyp acval [| func_as_i64; argc |] "closure_tmp" builder ;; -let gen_im_expr_ir fmap = function +let gen_im_expr_ir fmap env = function | Imm_num n -> Llvm.const_int i64_type ((n lsl 1) lor 1) | Imm_ident id -> - (match Hashtbl.find_opt named_values id with + (match ParamMap.find_opt id env with | Some v -> let temp = Llvm.build_load i64_type v id builder in Llvm.set_alignment gl_align temp; @@ -155,9 +156,7 @@ let gen_im_expr_ir fmap = function | Some (fval, ftyp, _) -> if Array.length (Llvm.params fval) = 0 then build_call_mb_void ftyp fval [||] "calltmp" - else - (* return a pointer to a closure *) - build_alloc_closure fmap fval + else build_alloc_closure fmap fval | None -> invalid_arg ("Name not bound: " ^ id))) ;; @@ -167,14 +166,12 @@ let create_entry_alloca the_fun var_name = ;; (* working with tagged integers *) -let gen_tagged_binop fmap op lhs rhs = - let left = gen_im_expr_ir fmap lhs in - let right = gen_im_expr_ir fmap rhs in +let gen_tagged_binop fmap env op lhs rhs = + let left = gen_im_expr_ir fmap env lhs in + let right = gen_im_expr_ir fmap env rhs in let one = Llvm.const_int i64_type 1 in - (* let build_oper, name = *) match op with | "+" -> - (* Llvm.build_add, "addtmp" *) let temp = Llvm.build_add left right "addtmp1" builder in Llvm.build_sub temp one "addtmp2" builder | "-" -> @@ -192,8 +189,6 @@ let gen_tagged_binop fmap op lhs rhs = let temp1 = Llvm.build_add temp temp "divtmp4" builder in Llvm.build_add temp1 one "divtmp5" builder | "<" -> - (* if we don't extend, Llvm will generate store i1 instead of store i64 - and this will lead to strange behaviour *) let temp = Llvm.build_icmp Llvm.Icmp.Slt left right "slttmp" builder in Llvm.build_zext temp i64_type "slttmp_as_i64" builder | "<=" -> @@ -224,46 +219,42 @@ let build_apply_part fmap fclos args = args ;; -let rec gen_comp_expr_ir fmap = function - | Comp_imm imm -> gen_im_expr_ir fmap imm - | Comp_binop (op, lhs, rhs) -> gen_tagged_binop fmap op lhs rhs +let rec gen_comp_expr_ir fmap env = function + | Comp_imm imm -> gen_im_expr_ir fmap env imm + | Comp_binop (op, lhs, rhs) -> gen_tagged_binop fmap env op lhs rhs | Comp_app (Imm_ident f, args) -> let f_map = if f = "main" then subst_main else f in - (* Format.printf "Id: %s got called with %d args\n" f (List.length args); *) (match FuncMap.find fmap f_map with | Some (fval, ftype, _) -> let pvs = Llvm.params fval in - let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in + let argvs = List.map (fun arg -> gen_im_expr_ir fmap env arg) args in if List.length args = Array.length pvs - then - build_call_mb_void ftype fval (Array.of_list argvs) "calltmp" - (* build_apply fmap fval argvs *) + then build_call_mb_void ftype fval (Array.of_list argvs) "calltmp" else ( let fclos = build_alloc_closure fmap fval in build_apply_part fmap fclos argvs) - | _ -> - (* maybe it's a closure in this scope *) - (match Hashtbl.find_opt named_values f with + | None -> + (match ParamMap.find_opt f env with | Some clos_ptr -> let clos_val = Llvm.build_load i64_type clos_ptr (f ^ "_val") builder in Llvm.set_alignment gl_align clos_val; - let argvs = List.map (fun arg -> gen_im_expr_ir fmap arg) args in + let argvs = List.map (fun arg -> gen_im_expr_ir fmap env arg) args in build_apply_part fmap clos_val argvs - | _ -> invalid_arg ("Id: " ^ f ^ " not found"))) + | None -> invalid_arg ("Id: " ^ f ^ " not found"))) | Comp_app (Imm_num _, _) -> invalid_arg "cannot apply number as a function" | Comp_branch (cond, br_then, br_else) -> - let cv = gen_im_expr_ir fmap cond in + let cv = gen_im_expr_ir fmap env cond in let zero = Llvm.const_int i64_type 0 in let cond_val = Llvm.build_icmp Llvm.Icmp.Ne cv zero "cond" builder in let start_bb = Llvm.insertion_block builder in let the_fun = Llvm.block_parent start_bb in let then_bb = Llvm.append_block context "then" the_fun in Llvm.position_at_end then_bb builder; - let then_val = gen_anf_expr fmap br_then in + let then_val, _ = gen_anf_expr fmap env br_then in let new_then_bb = Llvm.insertion_block builder in let else_bb = Llvm.append_block context "else" the_fun in Llvm.position_at_end else_bb builder; - let else_val = gen_anf_expr fmap br_else in + let else_val, _ = gen_anf_expr fmap env br_else in let new_else_bb = Llvm.insertion_block builder in let merge_bb = Llvm.append_block context "ifcont" the_fun in Llvm.position_at_end merge_bb builder; @@ -280,9 +271,7 @@ let rec gen_comp_expr_ir fmap = function | Comp_alloc imms | Comp_tuple imms -> let ctval, cttyp, _ = FuncMap.find_exn fmap "create_tuple_init" in let argc = Llvm.const_int i64_type (List.length imms) in - (* let ret = Llvm.build_call cttyp ctval [| argc |] "tuple_ret" builder in *) - (* let ptr = Llvm.build_inttoptr ret ptr_type "tuple_ptr" builder in *) - let argv = List.map (fun im -> gen_im_expr_ir fmap im) imms in + let argv = List.map (fun im -> gen_im_expr_ir fmap env im) imms in let alloca = Llvm.build_array_alloca i64_type argc "tuple_vals_alloca" builder in List.iteri (fun i elem -> @@ -301,27 +290,27 @@ let rec gen_comp_expr_ir fmap = function let alloca_as_i64 = Llvm.build_pointercast alloca i64_type "alloca_as_i64" builder in Llvm.build_call cttyp ctval [| argc; alloca_as_i64 |] "tuple_tmp" builder | Comp_load (imexpr, offset) -> - (*addr of the tuple *) - let vbase = gen_im_expr_ir fmap imexpr in + let vbase = gen_im_expr_ir fmap env imexpr in let voffst = Llvm.const_int i64_type (offset / Target.word_size) in let fifn, fity, _ = FuncMap.find_exn fmap "field" in Llvm.build_call fity fifn [| vbase; voffst |] "load_tmp" builder | Comp_func (_, _) -> invalid_arg "anonymous functions should be lambda-lifted" -and gen_anf_expr fmap = function - | Anf_comp_expr comp -> gen_comp_expr_ir fmap comp +and gen_anf_expr fmap env = function + | Anf_comp_expr comp -> + let v = gen_comp_expr_ir fmap env comp in + v, env | Anf_let (_, name, comp_expr, body) -> - let init_val = gen_comp_expr_ir fmap comp_expr in + let init_val = gen_comp_expr_ir fmap env comp_expr in let the_fun = Llvm.block_parent (Llvm.insertion_block builder) in let alloca = create_entry_alloca the_fun name in let store = Llvm.build_store init_val alloca builder in Llvm.set_alignment gl_align store; - Hashtbl.add named_values name alloca; - gen_anf_expr fmap body + let new_env = ParamMap.add name alloca env in + gen_anf_expr fmap new_env body ;; let gen_function fmap the_mod name params body = - Hashtbl.clear named_values; let name = if name = "main" then subst_main else name in let param_types = Array.map (fun _ -> i64_type) (Array.of_list params) in let f_type = Llvm.function_type i64_type param_types in @@ -337,25 +326,19 @@ let gen_function fmap the_mod name params body = else invalid_arg ("Redefinition of function with different number of args: " ^ name); f in - (* build allocas and add names for parameters *) - Array.iteri - (fun i pval -> - let name = List.nth params i in - Llvm.set_value_name name pval; - Hashtbl.add named_values name pval) - (Llvm.params the_fun); let bb = Llvm.append_block context "entry" the_fun in Llvm.position_at_end bb builder; + let env = ref ParamMap.empty in Array.iteri - (fun i ai -> + (fun i pval -> let name = List.nth params i in + Llvm.set_value_name name pval; let alloca = create_entry_alloca the_fun name in - let store = Llvm.build_store ai alloca builder in + let store = Llvm.build_store pval alloca builder in Llvm.set_alignment gl_align store; - Hashtbl.replace named_values name alloca) + env := ParamMap.add name alloca !env) (Llvm.params the_fun); - (* Need to check for error here *) - let ret_val = gen_anf_expr fmap body in + let ret_val, _ = gen_anf_expr fmap !env body in let _ = Llvm.build_ret ret_val builder in if Llvm_analysis.verify_function the_fun then () @@ -367,23 +350,20 @@ let gen_function fmap the_mod name params body = the_fun ;; -let gen_astructure_item fmap the_mod = function - | Anf_str_eval expr -> gen_anf_expr fmap expr +let gen_astructure_item fmap the_mod main_fn env = function + | Anf_str_eval expr -> + let _, new_env = gen_anf_expr fmap env expr in + new_env | Anf_str_value (_, name, Anf_comp_expr (Comp_func (params, body))) -> - gen_function fmap the_mod name params body + let _ = gen_function fmap the_mod name params body in + env | Anf_str_value (_, name, expr) -> - let main_fn = - match Llvm.lookup_function "main" the_mod with - | Some fn -> fn - | _ -> invalid_arg ("cannot generate value: " ^ name ^ ", main function not found") - in Llvm.position_at_end (Llvm.entry_block main_fn) builder; - let value = gen_anf_expr fmap expr in + let value, _ = gen_anf_expr fmap env expr in let alloca = create_entry_alloca main_fn name in - Hashtbl.add named_values name alloca; let store = Llvm.build_store value alloca builder in Llvm.set_alignment gl_align store; - store + ParamMap.add name alloca env ;; let optimize_ir the_mod (triple : string) (opt : string option) = @@ -408,7 +388,6 @@ let gen_program_ir (program : aprogram) (triple : string) (opt : string option) Llvm.set_target_triple triple the_module; assert (Llvm_executionengine.initialize ()); let fmap = prefill_fmap (initial_fmap the_module) the_module program in - (* FuncMap.print_fmap fmap; *) let main_ty = Llvm.function_type i64_type [||] in let main_fn = Llvm.define_function "main" main_ty the_module in Llvm.position_at_end (Llvm.entry_block main_fn) builder; @@ -416,7 +395,13 @@ let gen_program_ir (program : aprogram) (triple : string) (opt : string option) let _ = build_call_mb_void initty initfn [| Llvm.const_int i64_type (5 * 1024) |] "inittmp" in - let _ = List.map (gen_astructure_item fmap the_module) program in + let env = ParamMap.empty in + let _ = + List.fold_left + (fun env item -> gen_astructure_item fmap the_module main_fn env item) + env + program + in let bbs = Llvm.basic_blocks main_fn in Llvm.position_at_end bbs.(Array.length bbs - 1) builder; let col_fn, col_ty, _ = FuncMap.find_exn fmap "collect" in From 5e54879b9f168441e33efba28583679c9fdeea68 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 22:52:05 +0300 Subject: [PATCH 54/84] chore: add bin and infer to .zanuda --- XML/.zanuda | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XML/.zanuda b/XML/.zanuda index a5705ca5..ebd29b23 100644 --- a/XML/.zanuda +++ b/XML/.zanuda @@ -1 +1 @@ -forward mutability_check ignore bin/XML.ml \ No newline at end of file +forward mutability_check ignore bin/XML.ml bin/XML_llvm.ml lib/middleend/infer.ml \ No newline at end of file From 8fe9658f1227193da5e65f2bfac19ef99b7dc209 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 22:55:27 +0300 Subject: [PATCH 55/84] ref: add names to infer unit tests --- XML/many_tests/unit/infer.ml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index 393e3ae5..ce39c798 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -262,12 +262,12 @@ let%expect_test _= [%expect{| ('b -> 'c) -> 'b -> 'c |}] -let%expect_test _ = +let%expect_test {| fun x y -> x y |} = infer_exp_str {| fun x y -> x y |}; [%expect{| ('b -> 'c) -> 'b -> 'c |}] -let%expect_test _ = +let%expect_test {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |} = infer_exp_str {| (fun f a b -> f a, f b) (fun x -> x) 1 "mystr" |}; [%expect{| Cannot unify different constructors: int and string |}] @@ -341,22 +341,22 @@ let%expect_test "function different types of expr 2" = (************************** Let in **************************) -let%expect_test _ = +let%expect_test {| let 1 = 1 in 2 |} = infer_exp_str {| let 1 = 1 in 2 |}; [%expect{| int |}] -let%expect_test _ = +let%expect_test {| let a = 1 in 2 |} = infer_exp_str {| let a = 1 in 2 |}; [%expect{| int |}] -let%expect_test _ = +let%expect_test {| let a = 1 in a |} = infer_exp_str {| let a = 1 in a |}; [%expect{| int |}] -let%expect_test _ = +let%expect_test {| let a = 1 in "str" |} = infer_exp_str {| let a = 1 in "str" |}; [%expect{| string |}] @@ -377,17 +377,17 @@ let%expect_test "poly in env" = [%expect{| bool * bool |}] -let%expect_test _ = +let%expect_test {| let a, b = 1, 2 in a |} = infer_exp_str {| let a, b = 1, 2 in a |} ; [%expect{| int |}] -let%expect_test _ = +let%expect_test {| let a, b, c = 1, 2 in a |} = infer_exp_str {| let a, b, c = 1, 2 in a |} ; [%expect{| Cannot unify tuples of different sizes |}] -let%expect_test _ = +let%expect_test {| let a, b = 1, 2, 3 in a |} = infer_exp_str {| let a, b = 1, 2, 3 in a |}; [%expect{| Cannot unify tuples of different sizes |}] From 635a662ceb086b6831cefd3e5c31c9533b736d65 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 22:57:24 +0300 Subject: [PATCH 56/84] chore: add copyright to a test --- XML/many_tests/unit/codegen_llvm.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/XML/many_tests/unit/codegen_llvm.ml b/XML/many_tests/unit/codegen_llvm.ml index 2efe7a6a..162b26df 100644 --- a/XML/many_tests/unit/codegen_llvm.ml +++ b/XML/many_tests/unit/codegen_llvm.ml @@ -1,3 +1,7 @@ +(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + open Backend.Codegen_llvm open Middleend.Anf open Middleend.Ll From f567c0f43983df6f27abb697eddd0496e7245826 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 23:00:19 +0300 Subject: [PATCH 57/84] fix: zanuda warnings, ass ast to .zanuda (tv ref) --- XML/.zanuda | 2 +- XML/lib/common/ast.ml | 2 +- XML/lib/middleend/infer.ml | 3 +-- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/XML/.zanuda b/XML/.zanuda index ebd29b23..47e56343 100644 --- a/XML/.zanuda +++ b/XML/.zanuda @@ -1 +1 @@ -forward mutability_check ignore bin/XML.ml bin/XML_llvm.ml lib/middleend/infer.ml \ No newline at end of file +forward mutability_check ignore bin/XML.ml bin/XML_llvm.ml lib/middleend/infer.ml lib/common/ast.ml \ No newline at end of file diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 3bd0f0ee..8d432a2c 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -97,7 +97,7 @@ end module TypeExpr = struct let gen_ref inner_gen = let open QCheck.Gen in - map (fun x -> ref x) inner_gen + map ref inner_gen ;; type level = int [@@deriving eq, show { with_path = false }, qcheck] diff --git a/XML/lib/middleend/infer.ml b/XML/lib/middleend/infer.ml index 6fb9f08c..496f04c8 100644 --- a/XML/lib/middleend/infer.ml +++ b/XML/lib/middleend/infer.ml @@ -241,8 +241,7 @@ let add_rec_names env vb_list = vb_list ;; -let rec get_pat_names acc pat = - match pat with +let rec get_pat_names acc = function | Pat_var id -> id :: acc | Pat_tuple (pat1, pat2, rest) -> Base.List.fold_left ~f:get_pat_names ~init:acc (pat1 :: pat2 :: rest) From ee2caa274e72e44052a3bd61f421f52551e9144f Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 23:03:42 +0300 Subject: [PATCH 58/84] fix: zanuda syntax --- XML/.zanuda | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XML/.zanuda b/XML/.zanuda index 47e56343..0d95242f 100644 --- a/XML/.zanuda +++ b/XML/.zanuda @@ -1 +1 @@ -forward mutability_check ignore bin/XML.ml bin/XML_llvm.ml lib/middleend/infer.ml lib/common/ast.ml \ No newline at end of file +forward mutability_check ignore bin/XML.ml,bin/XML_llvm.ml,lib/middleend/infer.ml,lib/common/ast.ml \ No newline at end of file From 9241b791025629a6f11042a2c5195e14fadb1e0e Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 23:27:55 +0300 Subject: [PATCH 59/84] fix: typo in test --- XML/many_tests/unit/codegen_llvm.ml | 57 +++++++++++++++++++++++------ 1 file changed, 45 insertions(+), 12 deletions(-) diff --git a/XML/many_tests/unit/codegen_llvm.ml b/XML/many_tests/unit/codegen_llvm.ml index 162b26df..41c4a98d 100644 --- a/XML/many_tests/unit/codegen_llvm.ml +++ b/XML/many_tests/unit/codegen_llvm.ml @@ -120,18 +120,51 @@ let%expect_test "print_int 5" = } |}] let%expect_test "if 1 then 1 else 2 " = - codegen_prog_str {| if true then 1 else 2 |}; - [%expect.unreachable] -[@@expect.uncaught_exn {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Invalid_argument "unsupported expression in ANF normaliser") - Raised at Stdlib.invalid_arg in file "stdlib.ml", line 30, characters 20-45 - Called from XML_unittests__Codegen_llvm.codegen_prog_str in file "many_tests/unit/codegen_llvm.ml", line 8, characters 12-28 - Called from XML_unittests__Codegen_llvm.(fun) in file "many_tests/unit/codegen_llvm.ml", line 119, characters 2-46 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 |}] + codegen_prog_str {| if 1 then 1 else 2 |}; + [%expect{| + ; ModuleID = 'main' + source_filename = "main" + target triple = "riscv64-unknown-linux-gnu" + + declare void @print_int(i64) + + declare i64 @alloc_block(i64) + + declare i64 @alloc_closure(i64, i64) + + declare i64 @apply1(i64, i64) + + declare void @print_gc_status() + + declare void @collect() + + declare i64 @create_tuple(i64) + + declare i64 @create_tuple_init(i64, i64) + + declare i64 @field(i64, i64) + + declare void @rt_init(i64) + + define i64 @main() { + entry: + %t_0 = alloca i64, align 8 + call void @rt_init(i64 5120) + br i1 true, label %then, label %else + + then: ; preds = %entry + br label %ifcont + + else: ; preds = %entry + br label %ifcont + + ifcont: ; preds = %else, %then + %iftmp = phi i64 [ 3, %then ], [ 5, %else ] + store i64 %iftmp, ptr %t_0, align 8 + %t_01 = load i64, ptr %t_0, align 8 + call void @collect() + ret i64 0 + } |}] let%expect_test "tuple" = codegen_prog_str {| (1, 2, 3, 4) |}; From 367147ef2e9649402225071a39dfbf7b96d52a16 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 23:31:27 +0300 Subject: [PATCH 60/84] doc: add doc-coms to ast --- XML/lib/common/ast.ml | 14 +++++++------- XML/lib/common/ast.mli | 14 +++++++------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 8d432a2c..e37ce9bc 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -103,16 +103,16 @@ module TypeExpr = struct type level = int [@@deriving eq, show { with_path = false }, qcheck] type t = - | Type_arrow of t * t - | Type_tuple of t List2.t - | Type_var of tv ref - | Quant_type_var of ident - | Type_construct of ident * t list + | Type_arrow of t * t (** Function type [t1 -> t2] *) + | Type_tuple of t List2.t (** Tuple type [t1 * t2 * ...] *) + | Type_var of tv ref (** Type variable ['a] *) + | Quant_type_var of ident (** Quantified type variable ['a. 'a] *) + | Type_construct of ident * t list (** *) [@@deriving eq, show { with_path = false }, qcheck] and tv = - | Unbound of ident * level - | Link of t + | Unbound of ident * level (** Free type variable *) + | Link of t (** Unified type variable *) [@@deriving eq, show { with_path = false }, qcheck] end diff --git a/XML/lib/common/ast.mli b/XML/lib/common/ast.mli index 1ba948d7..01197e68 100644 --- a/XML/lib/common/ast.mli +++ b/XML/lib/common/ast.mli @@ -51,15 +51,15 @@ module TypeExpr : sig type level = int type t = - | Type_arrow of t * t - | Type_tuple of t List2.t - | Type_var of tv ref - | Quant_type_var of ident - | Type_construct of ident * t list + | Type_arrow of t * t (** Function type [t1 -> t2] *) + | Type_tuple of t List2.t (** Tuple type [t1 * t2 * ...] *) + | Type_var of tv ref (** Type variable ['a] *) + | Quant_type_var of ident (** Quantified type variable ['a. 'a] *) + | Type_construct of ident * t list (** *) and tv = - | Unbound of ident * level - | Link of t + | Unbound of ident * level (** Free type variable *) + | Link of t (** Unified type variable *) val equal : t -> t -> bool val pp : Format.formatter -> t -> unit From d8b73b85c17bfb080b5206b92119ae5adf7b5b28 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 23:49:03 +0300 Subject: [PATCH 61/84] fix: remove ref, fix doc-comment --- XML/lib/backend/codegen_llvm.ml | 24 +++++++++++++----------- XML/lib/middleend/infer.ml | 2 +- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 7360597e..97327a89 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -328,17 +328,19 @@ let gen_function fmap the_mod name params body = in let bb = Llvm.append_block context "entry" the_fun in Llvm.position_at_end bb builder; - let env = ref ParamMap.empty in - Array.iteri - (fun i pval -> - let name = List.nth params i in - Llvm.set_value_name name pval; - let alloca = create_entry_alloca the_fun name in - let store = Llvm.build_store pval alloca builder in - Llvm.set_alignment gl_align store; - env := ParamMap.add name alloca !env) - (Llvm.params the_fun); - let ret_val, _ = gen_anf_expr fmap !env body in + let env = + List.fold_left2 + (fun env name pval -> + Llvm.set_value_name name pval; + let alloca = create_entry_alloca the_fun name in + let store = Llvm.build_store pval alloca builder in + Llvm.set_alignment gl_align store; + ParamMap.add name alloca env) + ParamMap.empty + params + (Array.to_list (Llvm.params the_fun)) + in + let ret_val, _ = gen_anf_expr fmap env body in let _ = Llvm.build_ret ret_val builder in if Llvm_analysis.verify_function the_fun then () diff --git a/XML/lib/middleend/infer.ml b/XML/lib/middleend/infer.ml index 496f04c8..b007d3ef 100644 --- a/XML/lib/middleend/infer.ml +++ b/XML/lib/middleend/infer.ml @@ -1,4 +1,4 @@ -(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) (** SPDX-License-Identifier: LGPL-3.0-or-later *) From e49413be2cd86214d113ecaf9e14494370309733 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 4 Mar 2026 23:49:48 +0300 Subject: [PATCH 62/84] fix: another unnamed test --- XML/many_tests/unit/infer.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index ce39c798..f7297dd8 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -257,7 +257,7 @@ let%expect_test "fun 'a -> 'b (in env)" = [%expect{| 'a -> 's |}] -let%expect_test _= +let%expect_test {| fun x -> fun y -> x y |} = infer_exp_str {| fun x -> fun y -> x y |}; [%expect{| ('b -> 'c) -> 'b -> 'c |}] From f77e242de59bc71a73e98625ac0b7098e2ba59a2 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 9 Mar 2026 16:06:54 +0300 Subject: [PATCH 63/84] fix: date in .mli --- XML/lib/backend/codegen_llvm.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index 97327a89..cb1dad28 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -1,4 +1,4 @@ -(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) (** SPDX-License-Identifier: LGPL-3.0-or-later *) From aab0e8b23cd5f3c47d74f64e9bb51bc6983aba72 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 9 Mar 2026 16:12:12 +0300 Subject: [PATCH 64/84] zanuda: add physical_equality and ast.mli --- XML/.zanuda | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XML/.zanuda b/XML/.zanuda index 0d95242f..d3b98575 100644 --- a/XML/.zanuda +++ b/XML/.zanuda @@ -1 +1 @@ -forward mutability_check ignore bin/XML.ml,bin/XML_llvm.ml,lib/middleend/infer.ml,lib/common/ast.ml \ No newline at end of file +forward mutability_check physical_equality ignore bin/XML.ml,bin/XML_llvm.ml,lib/middleend/infer.ml,lib/common/ast.ml,lib/common/ast.mli,lib/common/pprinter.ml \ No newline at end of file From 8bd29928e6283a1c739faa78d8f2086ccf934325 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 9 Mar 2026 16:25:51 +0300 Subject: [PATCH 65/84] fix: add .mlis for unit tests --- XML/many_tests/unit/codegen_llvm.mli | 3 +++ XML/many_tests/unit/infer.mli | 3 +++ 2 files changed, 6 insertions(+) create mode 100644 XML/many_tests/unit/codegen_llvm.mli create mode 100644 XML/many_tests/unit/infer.mli diff --git a/XML/many_tests/unit/codegen_llvm.mli b/XML/many_tests/unit/codegen_llvm.mli new file mode 100644 index 00000000..26ede79c --- /dev/null +++ b/XML/many_tests/unit/codegen_llvm.mli @@ -0,0 +1,3 @@ +(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/XML/many_tests/unit/infer.mli b/XML/many_tests/unit/infer.mli new file mode 100644 index 00000000..26ede79c --- /dev/null +++ b/XML/many_tests/unit/infer.mli @@ -0,0 +1,3 @@ +(** Copyright 2025-2026, Mikhail Gavrilenko,Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From 0b77fdd17f1c03ccfd197cc64a7e85ffa6254166 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Mon, 9 Mar 2026 16:31:26 +0300 Subject: [PATCH 66/84] fix: .zanuda syntax --- XML/.zanuda | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/XML/.zanuda b/XML/.zanuda index d3b98575..b8d51fc1 100644 --- a/XML/.zanuda +++ b/XML/.zanuda @@ -1 +1,2 @@ -forward mutability_check physical_equality ignore bin/XML.ml,bin/XML_llvm.ml,lib/middleend/infer.ml,lib/common/ast.ml,lib/common/ast.mli,lib/common/pprinter.ml \ No newline at end of file +forward mutability_check ignore bin/XML.ml,bin/XML_llvm.ml,lib/middleend/infer.ml,lib/common/ast.ml,lib/common/ast.mli,lib/common/pprinter.ml +forward physical_equality ignore lib/middleend/infer.ml \ No newline at end of file From 2f1a210b077ebe976719f2ff17c495b2e426c4f5 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 10 Mar 2026 21:14:47 +0300 Subject: [PATCH 67/84] test: add unit tests for anf --- XML/many_tests/unit/anf.ml | 120 +++++++++++++++++++++++++++++++++++ XML/many_tests/unit/anf.mli | 3 + XML/many_tests/unit/infer.ml | 2 - 3 files changed, 123 insertions(+), 2 deletions(-) create mode 100644 XML/many_tests/unit/anf.ml create mode 100644 XML/many_tests/unit/anf.mli diff --git a/XML/many_tests/unit/anf.ml b/XML/many_tests/unit/anf.ml new file mode 100644 index 00000000..65e3f0a2 --- /dev/null +++ b/XML/many_tests/unit/anf.ml @@ -0,0 +1,120 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Middleend.Anf +open Middleend.Pprinter +open Common.Parser + +let to_anf_prog str = + let prog = parse_str str in + let aprog = anf_program_res prog in + match aprog with + | Ok aprog -> + print_anf_program Format.std_formatter aprog + | Error e -> Format.fprintf Format.std_formatter "%s" (pp_anf_error e) + + +(************************** Expressions **************************) + + +let%expect_test "char" = + to_anf_prog {| 'a' |}; + [%expect{| a;; |}] + + +let%expect_test "int" = + to_anf_prog {| 1 |}; + [%expect{| 1;; |}] + + +let%expect_test "str" = + to_anf_prog {| "Kakadu" |}; + [%expect{| Kakadu;; |}] + + +let%expect_test "tuple 2" = + to_anf_prog {| (1, 2) |}; + [%expect{| let t_0 = alloc(1, 2) in t_0;; |}] + + +let%expect_test "tuple 3" = + to_anf_prog {| (1, 2, 3) |}; + [%expect{| let t_0 = alloc(1, 2, 3) in t_0;; |}] + + +let%expect_test "tuples in tuple" = + to_anf_prog {| ((1, 2), (3, 4)) |}; + [%expect{| + let t_0 = alloc(1, 2) + in let t_1 = alloc(3, 4) in let t_2 = alloc(t_0, t_1) in t_2;; |}] + + +let%expect_test "if a then b" = + to_anf_prog {| if a then b |}; + [%expect{| unsupported expression in ANF normaliser |}] + + +let%expect_test "if a then b else c" = + to_anf_prog {| if a then b else c |}; + [%expect{| let t_0 = if a then b else c in t_0;; |}] + + +let%expect_test "apply f x" = + to_anf_prog {| f x |}; + [%expect{| let t_0 = f x in t_0;; |}] + + + let%expect_test "apply f (let a = x in a)" = + to_anf_prog {| f (let a = x in a) |}; + [%expect{| let t_0 = x in let a = t_0 in let t_1 = f a in t_1;; |}] + + +let%expect_test "apply f x y" = + to_anf_prog {| f x y |}; + [%expect{| let t_0 = f x in let t_1 = t_0 y in t_1;; |}] + + +let%expect_test "apply 1 + 2" = + to_anf_prog {| 1 + 2 |}; + [%expect{| 3;; |}] + + +let%expect_test "fun x -> x" = + to_anf_prog {| fun x -> x |}; + [%expect{| let t_0 = fun x -> x in t_0;; |}] + + +let%expect_test "apply (fun x -> x) 10" = + to_anf_prog {| (fun x -> x) 10 |}; + [%expect{| let t_0 = fun x -> x in let t_1 = t_0 10 in t_1;; |}] + + +let%expect_test "let a = 5 in a + 10" = + to_anf_prog {| let a = 5 in a + 10 |}; + [%expect{| let t_0 = 5 in let a = t_0 in let t_1 = (a + 10) in t_1;; |}] + + +let%expect_test "factorial" = + to_anf_prog {| let rec fac n = if n <= 0 then 1 else n * (fac (n-1)) in fac |}; + [%expect{| + let rec t_5 = fun n -> let t_0 = (n <= 0) + in let t_4 = if t_0 then 1 else let t_1 = (n - 1) + in let t_2 = fac t_1 + in let t_3 = (n * t_2) + in t_3 + in t_4 in let fac = t_5 in fac;; |}] + +(************************** Structure item **************************) + +let%expect_test "factorial" = + to_anf_prog {| let rec fac n = if n <= 0 then 1 else n * (fac (n-1)) |}; + [%expect{| + let rec fac = let t_5 = fun n -> let t_0 = (n <= 0) + in let t_4 = if t_0 then 1 else let t_1 = (n - 1) + in + let t_2 = fac t_1 + in + let t_3 = (n * t_2) + in t_3 + in t_4 in t_5;; |}] diff --git a/XML/many_tests/unit/anf.mli b/XML/many_tests/unit/anf.mli new file mode 100644 index 00000000..536d103e --- /dev/null +++ b/XML/many_tests/unit/anf.mli @@ -0,0 +1,3 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index f7297dd8..cb36048c 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -7,8 +7,6 @@ open Common.Parser open Common.Pprinter open Common.Ast.TypeExpr -let (let*) = Result.bind - let infer_exp_str ?(rst = true) ?(env = []) str = let exp = parse_exp_str str in if rst then reset_gensym (); From c9c75b86988aba6574404d046c752cfbb97a6ad7 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Tue, 10 Mar 2026 21:43:45 +0300 Subject: [PATCH 68/84] test: add unit tests for cc --- XML/many_tests/unit/cc.ml | 62 ++++++++++++++++++++++++++++++++++++++ XML/many_tests/unit/cc.mli | 3 ++ 2 files changed, 65 insertions(+) create mode 100644 XML/many_tests/unit/cc.ml create mode 100644 XML/many_tests/unit/cc.mli diff --git a/XML/many_tests/unit/cc.ml b/XML/many_tests/unit/cc.ml new file mode 100644 index 00000000..b74665ae --- /dev/null +++ b/XML/many_tests/unit/cc.ml @@ -0,0 +1,62 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Middleend.Anf +open Middleend.Pprinter +open Middleend.Cc +open Middleend.Ll +open Common.Parser +open Common.Pprinter + +let to_cc str = + let prog = parse_str str in + let ccprog = cc_program prog in + (* let aprog = anf_program ccprog in + let llprog = lambda_lift_program aprog in *) + pprint_program Format.std_formatter ccprog + + +let%expect_test "020closures.pdf" = +to_cc {| + let fac n = + let rec fack n k = + if n <= 1 then k 1 + else fack (n-1) (fun m -> k (m * n)) + in + fack n (fun x -> x) +|}; +[%expect {| + let fac = (fun n -> (let rec fack = (fun 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)));; |}] + + +let%expect_test "LN_CC_1" = +to_cc {| + let f x = + let g y = x + in + g +|}; +[%expect {| + let f = (fun x -> (let g = ((fun x y -> x) x) in (g x)));; |}] + + +let%expect_test "LN_CC_2" = +to_cc {| + fun x -> x + a + b +|}; +[%expect {| + ((fun a b x -> x + a + b) a) b ;; |}] + + +let%expect_test "LN_CC_3" = +to_cc {| + let mkPair = fun x -> + let add = fun y -> x + y in + let mul = fun z -> x * z in + (add, mul) +|}; +[%expect {| + let mkPair = (fun x -> (let add = ((fun x y -> x + y) x) in (let mul = ((fun x z -> x * z) x) in ((add x), (mul x)))));; |}] diff --git a/XML/many_tests/unit/cc.mli b/XML/many_tests/unit/cc.mli new file mode 100644 index 00000000..536d103e --- /dev/null +++ b/XML/many_tests/unit/cc.mli @@ -0,0 +1,3 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From 0ebf402da1b9679d9d8a0a29ecebe2ce07c9dba8 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 09:35:23 +0300 Subject: [PATCH 69/84] test: add tests for ast + parser --- XML/lib/common/ast.ml | 71 +++++++++++++++---------- XML/many_tests/qcheck/ast_qcheck.t | 4 ++ XML/many_tests/qcheck/dune | 13 +++++ XML/many_tests/qcheck/run_ast_qcheck.ml | 60 +++++++++++++++++++++ 4 files changed, 120 insertions(+), 28 deletions(-) create mode 100644 XML/many_tests/qcheck/ast_qcheck.t create mode 100644 XML/many_tests/qcheck/dune create mode 100644 XML/many_tests/qcheck/run_ast_qcheck.ml diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index e37ce9bc..8baabd44 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -1,6 +1,6 @@ (** Copyright 2024, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) -(** SPDX-License-Identifier: LGPL-3.0-or-later *) +(** SPDX-License-(ident[@gen gen_ident])ifier: LGPL-3.0-or-later *) open QCheck open Base @@ -33,20 +33,30 @@ let is_not_keyword = function let rec gen_filtered_ident base_gen = let open QCheck.Gen in base_gen - >>= fun ident -> - if is_not_keyword ident then return ident else gen_filtered_ident base_gen + >>= fun (ident [@gen gen_ident]) -> + if is_not_keyword (ident [@gen gen_ident]) + then return (ident [@gen gen_ident]) + else gen_filtered_ident base_gen +;; + +let gen_id_first_char = frequency [ 5, char_range 'a' 'z'; 1, return '_' ] +let gen_digit = char_range '0' '9' + +let gen_id_char = + frequency [ 5, gen_id_first_char; 5, char_range 'A' 'Z'; 5, gen_digit; 1, return '\'' ] ;; let gen_ident = - let base_gen = - map2 - (fun start_sym rest_sym -> Base.Char.to_string start_sym ^ rest_sym) - (oneof [ char_range 'A' 'Z'; char_range 'a' 'z'; return '_' ]) - (string_small_of - (oneof - [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) + let gen_name = + let* fst = gen_id_first_char >|= fun c -> Base.Char.to_string c in + let range = if Base.String.( = ) fst "_" then 1 -- 4 else 0 -- 4 in + let* rest = string_size ~gen:gen_id_char range in + return (fst ^ rest) in - gen_filtered_ident base_gen + let rec loop gen = + gen >>= fun name -> if is_not_keyword name then return name else loop gen + in + loop gen_name ;; let gen_ident_uc = @@ -100,19 +110,20 @@ module TypeExpr = struct map ref inner_gen ;; - type level = int [@@deriving eq, show { with_path = false }, qcheck] + type level = (int[@gen nat_small]) [@@deriving eq, show { with_path = false }, qcheck] type t = - | Type_arrow of t * t (** Function type [t1 -> t2] *) + | Type_arrow of (t[@gen gen_sized (n / 2)]) * (t[@gen gen_sized (n / 2)]) + (** Function type [t1 -> t2] *) | Type_tuple of t List2.t (** Tuple type [t1 * t2 * ...] *) | Type_var of tv ref (** Type variable ['a] *) - | Quant_type_var of ident (** Quantified type variable ['a. 'a] *) - | Type_construct of ident * t list (** *) + | Quant_type_var of (ident[@gen gen_ident]) (** Quantified type variable ['a. 'a] *) + | Type_construct of (ident[@gen gen_ident]) * t list (** *) [@@deriving eq, show { with_path = false }, qcheck] and tv = - | Unbound of ident * level (** Free type variable *) - | Link of t (** Unified type variable *) + | Unbound of (ident[@gen gen_ident]) * level (** Free type variable *) + | Link of (t[@gen gen_sized (n / 2)]) (** Unified type variable *) [@@deriving eq, show { with_path = false }, qcheck] end @@ -121,10 +132,10 @@ module Pattern = struct | Pat_constraint of t * (TypeExpr.t[@gen TypeExpr.gen_sized (n / 2)]) (** Pattern [(P : T)] *) | Pat_any (** The pattern [_]. *) - | Pat_var of (ident[@gen gen_ident_lc false]) (** A variable pattern such as [x] *) + | Pat_var of (ident[@gen gen_ident]) (** A variable pattern such as [x] *) | Pat_constant of Constant.t (** Patterns such as [52], ['w'], ["uwu"] *) | Pat_tuple of t List2.t (** Patterns [(P1, ..., Pn)]. *) - | Pat_construct of (ident[@gen gen_ident_uc]) * t option + | Pat_construct of (ident[@gen gen_ident]) * t option (** [Pat_construct(C, args)] represents: - [C] when [args] is [None], - [C P] when [args] is [Some (P)] @@ -163,7 +174,8 @@ module Expression = struct ;; type t = - | Exp_ident of (ident[@gen gen_ident_lc true]) (** Identifiers such as [x] *) + | Exp_ident of (ident[@gen gen_ident]) + (** (ident[@gen gen_ident])ifiers such as [x] *) | Exp_constant of Constant.t (** Expressions constant such as [1], ['a'], ["true"]**) | Exp_tuple of t List2.t (** Expressions [(E1, E2, ..., En)] *) | Exp_function of (t case[@gen gen_case gen_sized (n / 2)]) List1.t @@ -186,7 +198,7 @@ module Expression = struct when [flag] is [Nonrecursive], - [let rec P1 = E1 and ... and Pn = EN in E] when [flag] is [Recursive]. *) - | Exp_construct of (ident[@gen gen_ident_uc]) * t option + | Exp_construct of (ident[@gen gen_ident]) * t option (** [Exp_construct(C, exp)] represents: - [C] when [exp] is [None], - [C E] when [exp] is [Some E], @@ -203,7 +215,10 @@ module Structure = struct when [rec] is [Nonrecursive], - [let rec P1 = E1 and ... and Pn = EN ] when [rec] is [Recursiv e ee]. *) - | Str_adt of ident list * ident * (ident * TypeExpr.t option) List1.t + | Str_adt of + (ident[@gen gen_ident]) list + * (ident[@gen gen_ident]) + * ((ident[@gen gen_ident]) * TypeExpr.t option) List1.t (** [Str_type(C0, [(C1, [(T11; T12; ... ; T1n_1)]); (C2, [(T21;T22; ... ; T2n_2)]); ... ; (Cm, [(Tm1;Tm2; ... ; Tmn_n)]) ])] represents: @@ -220,7 +235,7 @@ module Structure = struct let gen_structure_item n = oneof_weighted [ 0, map (fun expr -> Str_eval expr) (Expression.gen_sized (n / 2)) - ; ( 0 + ; ( 1 , let* rec_flag = oneof [ return Expression.Nonrecursive; return Expression.Recursive ] in @@ -229,12 +244,12 @@ module Structure = struct list_small (Expression.gen_value_binding Expression.gen_sized (n / 2)) in return (Str_value (rec_flag, (bind1, bindl))) ) - ; ( 1 - , let* tparam = list_small (gen_ident_lc true) in - let* idt = gen_ident_lc true in - let* cons1 = Gen.pair gen_ident_uc (Gen.option (TypeExpr.gen_sized (n / 20))) in + ; ( 0 + , let* tparam = list_small gen_ident in + let* idt = gen_ident in + let* cons1 = Gen.pair gen_ident (Gen.option (TypeExpr.gen_sized (n / 20))) in let* consl = - list_small (Gen.pair gen_ident_uc (Gen.option (TypeExpr.gen_sized (n / 20)))) + list_small (Gen.pair gen_ident (Gen.option (TypeExpr.gen_sized (n / 20)))) in return (Str_adt (tparam, idt, (cons1, consl))) ) ] diff --git a/XML/many_tests/qcheck/ast_qcheck.t b/XML/many_tests/qcheck/ast_qcheck.t new file mode 100644 index 00000000..4c01590b --- /dev/null +++ b/XML/many_tests/qcheck/ast_qcheck.t @@ -0,0 +1,4 @@ + $ ./run_ast_qcheck.exe -seed 160355461 -gen 1 + random seed: 160355461 + ================================================================================ + success (ran 1 tests) diff --git a/XML/many_tests/qcheck/dune b/XML/many_tests/qcheck/dune new file mode 100644 index 00000000..9fbb86d5 --- /dev/null +++ b/XML/many_tests/qcheck/dune @@ -0,0 +1,13 @@ +(executable + (name run_ast_qcheck) + (libraries + stdio + XML.Common + XML.Backend + qcheck-core + qcheck-core.runner + ppx_deriving_qcheck)) + +(cram + (applies_to ast_qcheck) + (deps ./run_ast_qcheck.exe)) diff --git a/XML/many_tests/qcheck/run_ast_qcheck.ml b/XML/many_tests/qcheck/run_ast_qcheck.ml new file mode 100644 index 00000000..501d8b46 --- /dev/null +++ b/XML/many_tests/qcheck/run_ast_qcheck.ml @@ -0,0 +1,60 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Common.Pprinter +open Common.Ast +open Common.Ast.Program +open Common.Parser +open Format + +let parse_prog str = Angstrom.parse_string ~consume:Angstrom.Consume.All pstructure str + +let print_prog_with_ast prog = + let parsed = (parse_prog (asprintf "%a" pprint_program prog)) in + asprintf + "AST:\n\n%s\n\nPprinted:\n\n%s\n\nParsed:\n\n%s\n\nParsed Pprinted:\n\n%s\n\n" + (show_program prog) + (asprintf "%a" pprint_program prog) + (show_program (((fun r -> + if Result.is_ok r + then Result.get_ok r + else (printf "Result is not ok, printing initial prog\n"; + prog)) + parsed ))) + (asprintf "%a" pprint_program ((fun r -> + if Result.is_ok r + then Result.get_ok r + else (printf "Result is not ok, printing initial prog\n"; + prog)) + parsed)) +;; + +let arb_program = + QCheck.make + ~print:print_prog_with_ast + (QCheck.Gen.sized Program.gen_program) + +let run n = + QCheck_base_runner.run_tests + [ QCheck.( + Test.make arb_program ~count:n (fun pr -> + let res = parse_str (asprintf "%a\n" pprint_program pr) in + pr = res)) + ] +;; + +let run_tests n = + let _ = run n in + () +;; + +let () = + Arg.parse + [ "-seed", Arg.Int QCheck_base_runner.set_seed, " Set seed" + ; "-stop", Arg.Unit (fun _ -> exit 0), " Exit" + ; "-gen", Arg.Int run_tests, " Exit" + ] + (fun _ -> assert false) + "help" +;; \ No newline at end of file From f1667a7a2471c7e5324023301cdab613c3e1cd11 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 09:38:27 +0300 Subject: [PATCH 70/84] chore: remove unused opens --- XML/many_tests/unit/cc.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/XML/many_tests/unit/cc.ml b/XML/many_tests/unit/cc.ml index b74665ae..066451c1 100644 --- a/XML/many_tests/unit/cc.ml +++ b/XML/many_tests/unit/cc.ml @@ -2,10 +2,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open Middleend.Anf -open Middleend.Pprinter open Middleend.Cc -open Middleend.Ll open Common.Parser open Common.Pprinter From 4ab7261b48bb7d3517d88ab550e1811f96111903 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 10:15:51 +0300 Subject: [PATCH 71/84] test: add more ast tests --- XML/many_tests/qcheck/ast_qcheck.t | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/XML/many_tests/qcheck/ast_qcheck.t b/XML/many_tests/qcheck/ast_qcheck.t index 4c01590b..b18a94e4 100644 --- a/XML/many_tests/qcheck/ast_qcheck.t +++ b/XML/many_tests/qcheck/ast_qcheck.t @@ -2,3 +2,33 @@ random seed: 160355461 ================================================================================ success (ran 1 tests) + + $ ./run_ast_qcheck.exe -seed 142495613 -gen 1 + random seed: 142495613 + ================================================================================ + success (ran 1 tests) + + $ ./run_ast_qcheck.exe -seed 512010308 -gen 1 + random seed: 512010308 + ================================================================================ + success (ran 1 tests) + + $ ./run_ast_qcheck.exe -seed 352654714 -gen 1 + random seed: 352654714 + ================================================================================ + success (ran 1 tests) + + $ ./run_ast_qcheck.exe -seed 18353380 -gen 1 + random seed: 18353380 + ================================================================================ + success (ran 1 tests) + + $ ./run_ast_qcheck.exe -seed 340151730 -gen 1 + random seed: 340151730 + ================================================================================ + success (ran 1 tests) + + $ ./run_ast_qcheck.exe -seed 372987422 -gen 1 + random seed: 372987422 + ================================================================================ + success (ran 1 tests) From 2e9aed44acc634315686ec23b8cae8d4131e5355 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 11:11:30 +0300 Subject: [PATCH 72/84] test: add tests for machine --- XML/lib/backend/machine.ml | 48 +- XML/lib/backend/machine.mli | 4 + XML/many_tests/qcheck/dune | 14 + XML/many_tests/qcheck/machine_qcheck.t | 522 ++++++++++++++++++++ XML/many_tests/qcheck/run_machine_qcheck.ml | 36 ++ 5 files changed, 607 insertions(+), 17 deletions(-) create mode 100644 XML/many_tests/qcheck/machine_qcheck.t create mode 100644 XML/many_tests/qcheck/run_machine_qcheck.ml diff --git a/XML/lib/backend/machine.ml b/XML/lib/backend/machine.ml index 33597658..10856947 100644 --- a/XML/lib/backend/machine.ml +++ b/XML/lib/backend/machine.ml @@ -9,9 +9,20 @@ type reg = | RA | SP | Zero -[@@deriving eq] +[@@deriving eq, qcheck] -type offset = reg * int [@@deriving eq] +let gen_reg = + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.map (fun gen0 -> A gen0) QCheck.Gen.(0 -- 7) + ; 1, QCheck.Gen.map (fun gen0 -> T gen0) QCheck.Gen.(0 -- 6) + ; 1, QCheck.Gen.map (fun gen0 -> S gen0) QCheck.Gen.(0 -- 11) + ; 1, QCheck.Gen.pure RA + ; 1, QCheck.Gen.pure SP + ; 1, QCheck.Gen.pure Zero + ] +;; + +type offset = reg * (int[@gen QCheck.Gen.nat_small]) [@@deriving eq, qcheck] let pp_reg ppf = let open Format in @@ -25,9 +36,11 @@ let pp_reg ppf = ;; let pp_offset ppf (reg, off) = Format.fprintf ppf "%d(%a)" off pp_reg reg +let gen_label = QCheck.Gen.return "label" +let gen_comm = QCheck.Gen.return "comment" type instr = - | Addi of reg * reg * int (* ADD immediate *) + | Addi of reg * reg * (int[@gen QCheck.Gen.nat_small]) (* ADD immediate *) | Add of reg * reg * reg (* ADD *) | Sub of reg * reg * reg (* SUB *) | Mul of reg * reg * reg (* MUL *) @@ -35,25 +48,26 @@ type instr = | Seqz of reg * reg (* SEQZ: set equal zero *) | Snez of reg * reg (* SNEZ: set not equal zero *) | Xor of reg * reg * reg (* XOR *) - | Xori of reg * reg * int (* XOR immediate *) - | Beq of reg * reg * string (* BEQ: branch if equal *) - | Blt of reg * reg * string (* BLT: branch if less than *) - | Ble of reg * reg * string (* BLE: branch if less or equal *) - | Lla of reg * string (* LLA: load address *) - | Li of reg * int (* LI: load immediate *) + | Xori of reg * reg * (int[@gen QCheck.Gen.nat_small]) (* XOR immediate *) + | Beq of reg * reg * (string[@gen gen_label]) (* BEQ: branch if equal *) + | Blt of reg * reg * (string[@gen gen_label]) (* BLT: branch if less than *) + | Ble of reg * reg * (string[@gen gen_label]) (* BLE: branch if less or equal *) + | Lla of reg * (string[@gen gen_label]) (* LLA: load address *) + | Li of reg * (int[@gen QCheck.Gen.nat_small]) (* LI: load immediate *) | Ld of reg * offset (* LD: load doubleword *) | Sd of reg * offset (* SD: store doubleword *) | Mv of reg * reg (* MV: move *) - | Comment of string (* Assembler comment *) - | Label of string (* Assembler label *) - | Call of string (* CALL *) - | J of string (* J: jump *) + | Comment of (string[@gen gen_comm]) (* Assembler comment *) + | Label of (string[@gen gen_label]) (* Assembler label *) + | Call of (string[@gen gen_label]) (* CALL *) + | J of (string[@gen gen_label]) (* J: jump *) | Ecall (* ECALL *) | Ret (* return *) - | La of reg * string (* Load Address of labeled function into the reg *) - | Slli of reg * reg * int (* << imm *) - | Srai of reg * reg * int (* >> imm *) -[@@deriving eq] + | La of reg * (string[@gen gen_label]) + (* Load Address of labeled function into the reg *) + | Slli of reg * reg * (int[@gen QCheck.Gen.nat_small]) (* << imm *) + | Srai of reg * reg * (int[@gen QCheck.Gen.nat_small]) (* >> imm *) +[@@deriving eq, qcheck] let pp_instr ppf = let open Format in diff --git a/XML/lib/backend/machine.mli b/XML/lib/backend/machine.mli index 401ef15d..3d3dc620 100644 --- a/XML/lib/backend/machine.mli +++ b/XML/lib/backend/machine.mli @@ -10,11 +10,14 @@ type reg = | SP | Zero +val gen_reg : reg QCheck.Gen.t val equal_reg : reg -> reg -> bool val pp_reg : Format.formatter -> reg -> unit type offset = reg * int +val gen_offset : offset QCheck.Gen.t + type instr = | Addi of reg * reg * int (* ADD immediate *) | Add of reg * reg * reg (* ADD *) @@ -43,6 +46,7 @@ type instr = | Slli of reg * reg * int (* << imm *) | Srai of reg * reg * int (* >> imm (arith) *) +val gen_instr : instr QCheck.Gen.t val pp_instr : Format.formatter -> instr -> unit val addi : (instr -> 'a) -> reg -> reg -> int -> 'a val add : (instr -> 'a) -> reg -> reg -> reg -> 'a diff --git a/XML/many_tests/qcheck/dune b/XML/many_tests/qcheck/dune index 9fbb86d5..aa7083aa 100644 --- a/XML/many_tests/qcheck/dune +++ b/XML/many_tests/qcheck/dune @@ -11,3 +11,17 @@ (cram (applies_to ast_qcheck) (deps ./run_ast_qcheck.exe)) + +(executable + (name run_machine_qcheck) + (libraries + stdio + XML.Common + XML.Backend + qcheck-core + qcheck-core.runner + ppx_deriving_qcheck)) + +(cram + (applies_to machine_qcheck) + (deps ./run_machine_qcheck.exe)) diff --git a/XML/many_tests/qcheck/machine_qcheck.t b/XML/many_tests/qcheck/machine_qcheck.t new file mode 100644 index 00000000..678aa29c --- /dev/null +++ b/XML/many_tests/qcheck/machine_qcheck.t @@ -0,0 +1,522 @@ + $ ./run_machine_qcheck.exe -gen 40 + seed: 410641225 + srai a7, s4, 0 + srai s10, a4, 2 + la zero, label + label: + xori a6, t4, 28 + ble a3, a2, label + slt s7, s6, s10 + li s1, 7 + xor t4, sp, a4 + snez t1, zero + j label + ret + sub zero, sp, t2 + snez ra, zero + call label + ble t4, t6, label + call label + mv a4, a1 + mv ra, t5 + seqz ra, ra + slt t1, s8, zero + li a4, 7 + mul ra, s1, t3 + sd t1, 5(sp) + lla zero, label + mv t0, t4 + mv zero, s9 + li a4, 66 + mv zero, a6 + # comment + slt ra, s6, a3 + ld s11, 3(s4) + li ra, 4 + lla ra, label + ld sp, 2(t0) + li zero, 7 + j label + mv a2, t4 + beq ra, zero, label + j label + mv zero, sp + # comment + sd ra, 47(ra) + la ra, label + li s1, 9 + call label + slt sp, ra, sp + la t5, label + ecall + call label + mv s2, sp + xori sp, ra, 0 + ld a7, 4(s10) + label: + j label + sd t4, 9(s10) + # comment + mv s2, s7 + sub sp, zero, ra + xor t1, a2, a2 + xor s11, s9, sp + beq zero, zero, label + ecall + snez ra, zero + j label + j label + label: + label: + lla sp, label + sd s2, 7(a5) + mul a3, s8, ra + ble t4, s10, label + beq t4, sp, label + sub t2, t1, zero + slt s3, zero, sp + sd zero, 29(t2) + xori sp, s7, 3 + ld a3, 12(s11) + lla sp, label + beq sp, t0, label + ret + snez a7, s0 + slt sp, ra, ra + j label + seqz zero, ra + ld t6, 4(zero) + li a2, 7 + ble s4, a6, label + ecall + seqz ra, sp + sd ra, 4(s8) + call label + sd sp, 4(zero) + blt sp, s6, label + sd a5, 3(a5) + ecall + sub t5, s10, zero + srai ra, ra, 4 + ble zero, s4, label + add t6, t3, s6 + sd sp, 8(t0) + sd t5, 25(zero) + ble zero, s6, label + srai t2, a4, 0 + srai a7, a1, 5 + call label + xor t4, a3, a3 + # comment + lla zero, label + snez sp, t3 + ble ra, t0, label + lla t4, label + srai s9, ra, 6 + ld zero, 1(ra) + ld sp, 8(t5) + seqz t0, t2 + sub a3, ra, ra + lla t2, label + mul zero, s9, a3 + slt sp, ra, a0 + blt a5, zero, label + mv sp, zero + # comment + label: + mv sp, zero + li a2, 0 + ecall + ld sp, 89(s10) + lla t4, label + la sp, label + addi sp, sp, 3 + add zero, sp, t1 + li t4, 48 + snez a2, zero + srai s4, zero, 2 + # comment + snez a5, zero + ret + label: + ret + blt sp, a6, label + ble t4, zero, label + ret + slli zero, zero, 5 + la ra, label + label: + seqz sp, a7 + ble zero, sp, label + slt s10, s0, sp + blt ra, sp, label + ret + srai t5, t6, 0 + sd ra, 7(a4) + beq zero, t6, label + slli sp, t1, 3 + seqz ra, s4 + la sp, label + ble t6, a2, label + beq t3, sp, label + mv s8, a4 + ecall + li ra, 90 + slli sp, a3, 9 + mul sp, t5, sp + xori sp, t6, 0 + la ra, label + blt t0, zero, label + sd s4, 3(s2) + ld zero, 1(sp) + sub a7, s10, zero + lla sp, label + label: + xor t3, a4, a4 + seqz s1, s11 + call label + # comment + seqz sp, a1 + sub a2, t0, zero + ecall + # comment + li a2, 9 + j label + li s5, 4 + # comment + lla zero, label + addi t4, sp, 7 + seqz zero, s7 + mv a3, a7 + mul t2, t3, s10 + beq a4, ra, label + sd t2, 41(s1) + la zero, label + mul ra, zero, t5 + li a6, 4 + j label + beq t1, t3, label + mv zero, a0 + snez t2, sp + li t0, 3 + label: + j label + lla t0, label + label: + sub sp, a3, ra + # comment + mul ra, t2, a7 + xor ra, t5, sp + ecall + lla s7, label + ret + sub zero, s1, sp + sub sp, zero, sp + ecall + blt a6, zero, label + sub s0, ra, s1 + xor sp, sp, zero + mul a3, a0, a7 + mul a5, zero, s7 + sub ra, sp, a7 + # comment + sd t0, 2(a7) + srai s7, a7, 1 + snez a7, sp + ret + call label + sd sp, 5(s7) + ld a5, 7(s4) + xor s9, sp, zero + lla zero, label + blt zero, s10, label + mv sp, zero + call label + snez zero, ra + ret + addi a3, t1, 62 + j label + j label + mv ra, ra + call label + ecall + xor t5, t0, zero + li ra, 88 + sub t5, sp, s6 + li s1, 71 + call label + xori s10, a1, 1 + slt t0, ra, sp + sub a2, ra, ra + mv t2, sp + lla zero, label + sub zero, s7, a0 + blt t6, s0, label + seqz a0, sp + mv s6, sp + sub ra, t2, a3 + beq ra, t2, label + li zero, 2 + blt sp, s9, label + ret + slli zero, t3, 5 + blt sp, sp, label + blt a3, t4, label + addi a1, zero, 2 + xori t3, s3, 8 + addi sp, t6, 4 + call label + # comment + add zero, ra, zero + xor zero, zero, a5 + slli zero, ra, 0 + add a6, sp, a4 + sd sp, 96(a6) + slt t5, zero, s8 + mv a0, sp + ecall + slli a6, sp, 55 + mul s3, sp, zero + xor sp, t4, a4 + add zero, zero, t2 + xor t3, sp, a5 + snez t4, sp + lla zero, label + j label + xori ra, zero, 0 + addi sp, ra, 8 + slt sp, sp, t1 + label: + beq ra, t5, label + sub s2, sp, ra + mul ra, t5, sp + srai a6, zero, 86 + mv a5, ra + blt zero, t6, label + # comment + beq zero, a4, label + ecall + beq a2, zero, label + snez a2, t0 + ecall + call label + mv zero, sp + blt t2, s11, label + ld a0, 4(zero) + beq zero, s2, label + ble t6, sp, label + li sp, 3 + snez ra, a3 + label: + xor ra, a6, zero + ecall + slt a3, t5, zero + call label + # comment + seqz ra, s4 + ld sp, 7(sp) + blt sp, t3, label + call label + ret + add ra, s3, zero + mul t3, s4, t1 + label: + add t2, s1, zero + ecall + blt ra, s10, label + ld sp, 74(sp) + sub sp, sp, ra + li ra, 0 + # comment + # comment + snez sp, sp + j label + xori t4, s4, 4 + sub a0, s6, sp + sd s5, 0(ra) + slli t0, zero, 70 + la ra, label + add zero, zero, t3 + sd zero, 0(s11) + lla t1, label + xori t0, ra, 5 + beq ra, ra, label + xori zero, sp, 7 + j label + beq ra, t4, label + slt s7, sp, zero + add zero, zero, a5 + mv zero, s5 + mv sp, sp + j label + mv ra, t0 + snez sp, sp + addi a6, t3, 98 + li ra, 3 + blt a2, sp, label + mv ra, sp + ld zero, 2(ra) + snez a2, sp + xor a5, s9, zero + li t1, 9 + j label + ble zero, sp, label + mv sp, zero + lla s3, label + label: + ble a5, ra, label + j label + mul s7, a0, t0 + ld ra, 34(zero) + j label + call label + la sp, label + j label + call label + add a3, a7, t6 + xori zero, s10, 5 + snez sp, sp + xori sp, sp, 8 + slli s4, t2, 8 + add sp, zero, a1 + srai sp, t4, 5 + beq a2, ra, label + # comment + xor ra, t6, t0 + ecall + # comment + slt ra, sp, s2 + seqz s8, ra + ret + sub zero, a1, ra + xori s7, ra, 14 + blt a7, ra, label + ecall + mul ra, zero, ra + slt a0, t6, sp + xor zero, sp, ra + blt ra, zero, label + ble sp, sp, label + snez zero, ra + mv s9, a3 + j label + label: + xori s1, ra, 7 + add s4, a6, t4 + sub zero, zero, s9 + # comment + ld a3, 8(t2) + sub zero, ra, t1 + ret + add t6, ra, ra + slli a2, t1, 4 + # comment + mul a3, s0, ra + mv t5, sp + call label + # comment + lla a6, label + # comment + beq ra, t4, label + beq zero, zero, label + j label + xori s3, a3, 4 + sd zero, 1(zero) + mv ra, zero + beq ra, s6, label + lla ra, label + snez zero, zero + ble ra, sp, label + slt sp, a1, t0 + slt sp, zero, ra + label: + mul ra, s10, t5 + mv ra, zero + addi s6, sp, 1 + lla s1, label + slli s2, t4, 1 + mul sp, sp, zero + ecall + slli sp, a2, 1 + ble sp, a5, label + lla a2, label + ret + ble s9, t3, label + mul zero, ra, t3 + j label + j label + mv ra, ra + slli s4, a7, 1 + li a6, 3 + xori zero, sp, 8 + # comment + la sp, label + li s5, 9 + ld sp, 3(zero) + srai t4, sp, 44 + seqz s0, a6 + slt s9, sp, zero + sub sp, sp, t4 + ecall + seqz s1, sp + blt zero, sp, label + seqz ra, a6 + call label + seqz a5, sp + beq ra, zero, label + blt ra, sp, label + la sp, label + # comment + addi sp, zero, 7 + j label + blt s9, t4, label + xori a7, s5, 8 + xori s8, zero, 6 + mv t0, t1 + beq a5, t2, label + xor s10, s4, t3 + ret + mul zero, t4, a2 + add zero, zero, zero + mv sp, zero + # comment + ble sp, s0, label + la ra, label + label: + srai ra, a2, 7 + ret + xor t3, a4, a7 + xori sp, zero, 6 + la a1, label + add sp, t2, a2 + slt s2, a7, ra + add sp, t1, s10 + slli sp, a2, 4 + beq zero, s8, label + add zero, sp, s11 + mv zero, ra + label: + ble t6, ra, label + ble s8, sp, label + label: + j label + ld ra, 90(s7) + ld a5, 4(a1) + lla ra, label + la a7, label + ret + li s10, 7 + lla zero, label + addi t1, zero, 3 + ret + call label + xor t0, sp, s3 + add s2, ra, zero + srai sp, t2, 7 + li a0, 4 + slli a2, a0, 0 + lla zero, label + blt t2, ra, label + sub a1, sp, a7 + ================================================================================ + success (ran 1 tests) diff --git a/XML/many_tests/qcheck/run_machine_qcheck.ml b/XML/many_tests/qcheck/run_machine_qcheck.ml new file mode 100644 index 00000000..d6f2fe6a --- /dev/null +++ b/XML/many_tests/qcheck/run_machine_qcheck.ml @@ -0,0 +1,36 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Format +open Backend.Machine +open QCheck.Gen + +let arb_machine_instrs = + QCheck.make + (QCheck.Gen.list_size (5--20) gen_instr) + +let run n = + QCheck_base_runner.run_tests + [ QCheck.( + Test.make arb_machine_instrs ~count:n (fun is -> + List.iter (fun i -> + Format.fprintf std_formatter "%a\n" pp_instr i + ) is; + true)) + ] + +let run_tests n = + let _ = run n in + () +;; + +let () = + Arg.parse + [ "-seed", Arg.Int QCheck_base_runner.set_seed, " Set seed" + ; "-stop", Arg.Unit (fun _ -> exit 0), " Exit" + ; "-gen", Arg.Int run_tests, " Exit" + ] + (fun _ -> assert false) + "help" +;; \ No newline at end of file From c3b1203e6c608f553e3a545970fb08b4d132dcdd Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 11:12:25 +0300 Subject: [PATCH 73/84] fix: doc in ast.ml --- XML/lib/common/ast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 8baabd44..04576129 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -1,6 +1,6 @@ (** Copyright 2024, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko*) -(** SPDX-License-(ident[@gen gen_ident])ifier: LGPL-3.0-or-later *) +(** SPDX-License-Identifier: LGPL-3.0-or-later *) open QCheck open Base From 6b0d370e0803ab06db5ef6c0148896bb4fcd8891 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 11:14:30 +0300 Subject: [PATCH 74/84] fix: some fixes --- XML/lib/common/ast.ml | 2 +- XML/many_tests/qcheck/machine_qcheck.t | 4 ++-- XML/many_tests/qcheck/run_ast_qcheck.ml | 3 +-- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 04576129..4ad8958f 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -48,7 +48,7 @@ let gen_id_char = let gen_ident = let gen_name = - let* fst = gen_id_first_char >|= fun c -> Base.Char.to_string c in + let* fst = gen_id_first_char >|= Base.Char.to_string in let range = if Base.String.( = ) fst "_" then 1 -- 4 else 0 -- 4 in let* rest = string_size ~gen:gen_id_char range in return (fst ^ rest) diff --git a/XML/many_tests/qcheck/machine_qcheck.t b/XML/many_tests/qcheck/machine_qcheck.t index 678aa29c..3606faec 100644 --- a/XML/many_tests/qcheck/machine_qcheck.t +++ b/XML/many_tests/qcheck/machine_qcheck.t @@ -1,5 +1,5 @@ - $ ./run_machine_qcheck.exe -gen 40 - seed: 410641225 + $ ./run_machine_qcheck.exe -seed 410641225 -gen 40 + random seed: 410641225 srai a7, s4, 0 srai s10, a4, 2 la zero, label diff --git a/XML/many_tests/qcheck/run_ast_qcheck.ml b/XML/many_tests/qcheck/run_ast_qcheck.ml index 501d8b46..8bce1f79 100644 --- a/XML/many_tests/qcheck/run_ast_qcheck.ml +++ b/XML/many_tests/qcheck/run_ast_qcheck.ml @@ -4,7 +4,6 @@ open Common.Pprinter open Common.Ast -open Common.Ast.Program open Common.Parser open Format @@ -55,6 +54,6 @@ let () = ; "-stop", Arg.Unit (fun _ -> exit 0), " Exit" ; "-gen", Arg.Int run_tests, " Exit" ] - (fun _ -> assert false) + (fun _ -> print_endline "" ) "help" ;; \ No newline at end of file From 536f5222d04cac4e0d916a797c854168878635e9 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 11:30:07 +0300 Subject: [PATCH 75/84] fix: warnings --- XML/lib/backend/machine.ml | 2 +- XML/lib/common/ast.ml | 5 +++-- XML/lib/common/pprinter.ml | 12 ++++++------ XML/many_tests/unit/infer.ml | 2 +- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/XML/lib/backend/machine.ml b/XML/lib/backend/machine.ml index 10856947..dfd164dc 100644 --- a/XML/lib/backend/machine.ml +++ b/XML/lib/backend/machine.ml @@ -9,7 +9,7 @@ type reg = | RA | SP | Zero -[@@deriving eq, qcheck] +[@@deriving eq] let gen_reg = QCheck.Gen.oneof_weighted diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 4ad8958f..78459362 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -39,11 +39,12 @@ let rec gen_filtered_ident base_gen = else gen_filtered_ident base_gen ;; -let gen_id_first_char = frequency [ 5, char_range 'a' 'z'; 1, return '_' ] +let gen_id_first_char = QCheck.Gen.oneof_weighted [ 5, char_range 'a' 'z'; 1, return '_' ] let gen_digit = char_range '0' '9' let gen_id_char = - frequency [ 5, gen_id_first_char; 5, char_range 'A' 'Z'; 5, gen_digit; 1, return '\'' ] + QCheck.Gen.oneof_weighted + [ 5, gen_id_first_char; 5, char_range 'A' 'Z'; 5, gen_digit; 1, return '\'' ] ;; let gen_ident = diff --git a/XML/lib/common/pprinter.ml b/XML/lib/common/pprinter.ml index a5b9fc20..f5ae1c13 100644 --- a/XML/lib/common/pprinter.ml +++ b/XML/lib/common/pprinter.ml @@ -71,7 +71,7 @@ let rearr_typvars typ = then String.make 1 (Char.of_int_exn (97 + idx)) else ( let prefix_count = (idx / 26) - 1 in - let suffix_idx = idx mod 26 in + let suffix_idx = Int.rem idx 26 in "'" ^ String.make (prefix_count + 1) (Char.of_int_exn (97 + (idx / 26) - 1)) ^ String.make 1 (Char.of_int_exn (97 + suffix_idx))) @@ -88,7 +88,7 @@ let rearr_typvars typ = ;; let rec pprint_type_tuple fmt = - let open Format in + let open Stdlib.Format in let open TypeExpr in function | [] -> () @@ -102,7 +102,7 @@ let rec pprint_type_tuple fmt = | _ -> fprintf fmt "%a * %a" pprint_type h pprint_type_tuple tl) and pprint_type_list_with_parens fmt ty_list = - let open Format in + let open Stdlib.Format in let rec print_types fmt = function | [] -> () | [ ty ] -> pprint_type_with_parens_if_tuple fmt ty @@ -123,7 +123,7 @@ and pprint_type fmt typ = | Type_var { contents = Link t } -> is_tuple t | _ -> false in - let open Format in + let open Stdlib.Format in match typ with | Type_arrow (t1, t2) when is_arrow t1 -> fprintf fmt "(%a) -> %a" pprint_type t1 pprint_type t2 @@ -148,7 +148,7 @@ and pprint_type fmt typ = fprintf fmt "%a %s" pprint_type_list_with_parens ty_list name and pprint_type_with_parens_if_tuple fmt ty = - let open Format in + let open Stdlib.Format in match ty with | Type_tuple _ -> fprintf fmt "(%a)" pprint_type ty | _ -> pprint_type fmt ty @@ -165,7 +165,7 @@ let filter_env (env : (ident * TypeExpr.t) list) (names : ident list) = ;; let pprint_env env names = - let open Format in + let open Stdlib.Format in let new_env = filter_env env names in List.iter ~f:(fun (key, typ) -> diff --git a/XML/many_tests/unit/infer.ml b/XML/many_tests/unit/infer.ml index cb36048c..7bdd676d 100644 --- a/XML/many_tests/unit/infer.ml +++ b/XML/many_tests/unit/infer.ml @@ -34,7 +34,7 @@ let infer_prog_str ?(env = env_with_things) str = let show_etyp env exp = match infer_exp env exp with | Ok (_, ty) -> - Base.print_endline (Common.Ast.TypeExpr.show ty) + Stdio.print_endline (Common.Ast.TypeExpr.show ty) | Error err -> pprint_err Format.std_formatter err let type_bool = Type_construct ("bool", []) From 6182250a57ef35344a9fd5df578320d5485ccbbb Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 11:56:09 +0300 Subject: [PATCH 76/84] fix: deprecated warnings --- XML/lib/backend/machine.ml | 101 ++++++++++++++++- XML/lib/common/ast.ml | 227 +++++++++++++++++++++++++++++++------ XML/test_qc/test_qc.ml | 22 +++- 3 files changed, 312 insertions(+), 38 deletions(-) diff --git a/XML/lib/backend/machine.ml b/XML/lib/backend/machine.ml index dfd164dc..aac90943 100644 --- a/XML/lib/backend/machine.ml +++ b/XML/lib/backend/machine.ml @@ -22,7 +22,13 @@ let gen_reg = ] ;; -type offset = reg * (int[@gen QCheck.Gen.nat_small]) [@@deriving eq, qcheck] +type offset = reg * (int[@gen QCheck.Gen.nat_small]) [@@deriving eq] + +let gen_offset = + QCheck.Gen.map + (fun (gen0, gen1) -> gen0, gen1) + (QCheck.Gen.pair gen_reg QCheck.Gen.nat_small) +;; let pp_reg ppf = let open Format in @@ -67,7 +73,98 @@ type instr = (* Load Address of labeled function into the reg *) | Slli of reg * reg * (int[@gen QCheck.Gen.nat_small]) (* << imm *) | Srai of reg * reg * (int[@gen QCheck.Gen.nat_small]) (* >> imm *) -[@@deriving eq, qcheck] +[@@deriving eq] + +let gen_instr = + QCheck.Gen.oneof_weighted + [ ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Addi (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg QCheck.Gen.nat_small) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Add (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg gen_reg) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Sub (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg gen_reg) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Mul (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg gen_reg) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Slt (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg gen_reg) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Seqz (gen0, gen1)) + (QCheck.Gen.pair gen_reg gen_reg) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Snez (gen0, gen1)) + (QCheck.Gen.pair gen_reg gen_reg) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Xor (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg gen_reg) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Xori (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg QCheck.Gen.nat_small) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Beq (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg gen_label) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Blt (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg gen_label) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Ble (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg gen_label) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Lla (gen0, gen1)) + (QCheck.Gen.pair gen_reg gen_label) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Li (gen0, gen1)) + (QCheck.Gen.pair gen_reg QCheck.Gen.nat_small) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Ld (gen0, gen1)) + (QCheck.Gen.pair gen_reg gen_offset) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Sd (gen0, gen1)) + (QCheck.Gen.pair gen_reg gen_offset) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Mv (gen0, gen1)) + (QCheck.Gen.pair gen_reg gen_reg) ) + ; 1, QCheck.Gen.map (fun gen0 -> Comment gen0) gen_comm + ; 1, QCheck.Gen.map (fun gen0 -> Label gen0) gen_label + ; 1, QCheck.Gen.map (fun gen0 -> Call gen0) gen_label + ; 1, QCheck.Gen.map (fun gen0 -> J gen0) gen_label + ; 1, QCheck.Gen.pure Ecall + ; 1, QCheck.Gen.pure Ret + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> La (gen0, gen1)) + (QCheck.Gen.pair gen_reg gen_label) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Slli (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg QCheck.Gen.nat_small) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Srai (gen0, gen1, gen2)) + (QCheck.Gen.triple gen_reg gen_reg QCheck.Gen.nat_small) ) + ] +;; let pp_instr ppf = let open Format in diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 78459362..6cc4c465 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -88,21 +88,46 @@ let gen_ident_lc include_us = ;; module List1 = struct - type 'a t = 'a * ('a list[@gen list_size (int_bound 5) gen_a]) - [@@deriving eq, show { with_path = false }, qcheck] + type 'a t = 'a * 'a list [@@deriving eq, show { with_path = false }] + + let gen gen_a = + QCheck.Gen.map + (fun (gen0, gen1) -> gen0, gen1) + (QCheck.Gen.pair gen_a (list_size (int_bound 5) gen_a)) + ;; + + let arb gen_a = QCheck.make @@ gen gen_a end module List2 = struct - type 'a t = 'a * 'a * ('a list[@gen list_size (int_bound 5) gen_a]) - [@@deriving eq, show { with_path = false }, qcheck] + type 'a t = 'a * 'a * 'a list [@@deriving eq, show { with_path = false }] + + let gen gen_a = + QCheck.Gen.map + (fun (gen0, gen1, gen2) -> gen0, gen1, gen2) + (QCheck.Gen.triple gen_a gen_a (QCheck.Gen.list gen_a)) + ;; + + let _ = gen + let arb gen_a = QCheck.make @@ gen gen_a end module Constant = struct type t = - | Const_integer of (int[@gen nat_small]) (** integer as [52] *) - | Const_char of (char[@gen gen_charc]) (** char as ['w'] *) - | Const_string of (string[@gen string_small_of gen_charc]) (** string as ["Kakadu"] *) - [@@deriving eq, show { with_path = false }, qcheck] + | Const_integer of int (** integer as [52] *) + | Const_char of char (** char as ['w'] *) + | Const_string of string (** string as ["Kakadu"] *) + [@@deriving eq, show { with_path = false }] + + let gen = + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.map (fun gen0 -> Const_integer gen0) nat_small + ; 1, QCheck.Gen.map (fun gen0 -> Const_char gen0) gen_charc + ; 1, QCheck.Gen.map (fun gen0 -> Const_string gen0) (string_small_of gen_charc) + ] + ;; + + let arb = QCheck.make @@ gen end module TypeExpr = struct @@ -114,42 +139,117 @@ module TypeExpr = struct type level = (int[@gen nat_small]) [@@deriving eq, show { with_path = false }, qcheck] type t = - | Type_arrow of (t[@gen gen_sized (n / 2)]) * (t[@gen gen_sized (n / 2)]) - (** Function type [t1 -> t2] *) + | Type_arrow of t * t (** Function type [t1 -> t2] *) | Type_tuple of t List2.t (** Tuple type [t1 * t2 * ...] *) | Type_var of tv ref (** Type variable ['a] *) - | Quant_type_var of (ident[@gen gen_ident]) (** Quantified type variable ['a. 'a] *) - | Type_construct of (ident[@gen gen_ident]) * t list (** *) - [@@deriving eq, show { with_path = false }, qcheck] + | Quant_type_var of ident (** Quantified type variable ['a. 'a] *) + | Type_construct of ident * t list (** *) + [@@deriving eq, show { with_path = false }] and tv = | Unbound of (ident[@gen gen_ident]) * level (** Free type variable *) | Link of (t[@gen gen_sized (n / 2)]) (** Unified type variable *) - [@@deriving eq, show { with_path = false }, qcheck] + [@@deriving eq, show { with_path = false }] + + let rec gen_sized n = + match n with + | 0 -> QCheck.Gen.map (fun gen0 -> Quant_type_var gen0) gen_ident + | _ -> + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.map (fun gen0 -> Quant_type_var gen0) gen_ident + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Type_arrow (gen0, gen1)) + (QCheck.Gen.pair (gen_sized (n / 2)) (gen_sized (n / 2))) ) + ; 1, QCheck.Gen.map (fun gen0 -> Type_tuple gen0) (List2.gen (gen_sized (n / 2))) + ; 1, QCheck.Gen.map (fun gen0 -> Type_var gen0) (gen_ref (gen_tv_sized (n / 2))) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Type_construct (gen0, gen1)) + (QCheck.Gen.pair gen_ident (QCheck.Gen.list (gen_sized (n / 2)))) ) + ] + + and gen_tv_sized n = + match n with + | 0 -> + QCheck.Gen.map + (fun (gen0, gen1) -> Unbound (gen0, gen1)) + (QCheck.Gen.pair gen_ident gen_level) + | _ -> + QCheck.Gen.oneof_weighted + [ ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Unbound (gen0, gen1)) + (QCheck.Gen.pair gen_ident gen_level) ) + ; 1, QCheck.Gen.map (fun gen0 -> Link gen0) (gen_sized (n / 2)) + ] + ;; + + let gen = QCheck.Gen.sized gen_sized + let gen_tv = QCheck.Gen.sized gen_tv_sized + let arb_sized n = QCheck.make @@ gen_sized n + let arb_tv_sized n = QCheck.make @@ gen_tv_sized n + let arb = QCheck.make @@ gen + let arb_tv = QCheck.make @@ gen_tv end module Pattern = struct type t = - | Pat_constraint of t * (TypeExpr.t[@gen TypeExpr.gen_sized (n / 2)]) - (** Pattern [(P : T)] *) + | Pat_constraint of t * TypeExpr.t (** Pattern [(P : T)] *) | Pat_any (** The pattern [_]. *) - | Pat_var of (ident[@gen gen_ident]) (** A variable pattern such as [x] *) + | Pat_var of ident (** A variable pattern such as [x] *) | Pat_constant of Constant.t (** Patterns such as [52], ['w'], ["uwu"] *) | Pat_tuple of t List2.t (** Patterns [(P1, ..., Pn)]. *) - | Pat_construct of (ident[@gen gen_ident]) * t option + | Pat_construct of ident * t option (** [Pat_construct(C, args)] represents: - [C] when [args] is [None], - [C P] when [args] is [Some (P)] - [C (P1, ..., Pn)] when [args] is [Some (Pat_tuple [P1; ...; Pn])] *) - [@@deriving eq, show { with_path = false }, qcheck] + [@@deriving eq, show { with_path = false }] + + let rec gen_sized n = + match n with + | 0 -> + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.pure Pat_any + ; 1, QCheck.Gen.map (fun gen0 -> Pat_var gen0) gen_ident + ; 1, QCheck.Gen.map (fun gen0 -> Pat_constant gen0) Constant.gen + ] + | _ -> + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.pure Pat_any + ; 1, QCheck.Gen.map (fun gen0 -> Pat_var gen0) gen_ident + ; 1, QCheck.Gen.map (fun gen0 -> Pat_constant gen0) Constant.gen + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Pat_constraint (gen0, gen1)) + (QCheck.Gen.pair (gen_sized (n / 2)) (TypeExpr.gen_sized (n / 2))) ) + ; 1, QCheck.Gen.map (fun gen0 -> Pat_tuple gen0) (List2.gen (gen_sized (n / 2))) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Pat_construct (gen0, gen1)) + (QCheck.Gen.pair gen_ident (QCheck.Gen.option (gen_sized (n / 2)))) ) + ] + ;; + + let gen = QCheck.Gen.sized gen_sized + let arb_sized n = QCheck.make @@ gen_sized n + let arb = QCheck.make @@ gen end module Expression = struct type rec_flag = | Nonrecursive | Recursive - [@@deriving eq, show { with_path = false }, qcheck] + [@@deriving eq, show { with_path = false }] + + let gen_rec_flag = + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.pure Nonrecursive; 1, QCheck.Gen.pure Recursive ] + ;; + + let arb_rec_flag = QCheck.make @@ gen_rec_flag type 'expr value_binding = { pat : Pattern.t @@ -175,36 +275,94 @@ module Expression = struct ;; type t = - | Exp_ident of (ident[@gen gen_ident]) - (** (ident[@gen gen_ident])ifiers such as [x] *) + | Exp_ident of ident (** (ident[@gen gen_ident])ifiers such as [x] *) | Exp_constant of Constant.t (** Expressions constant such as [1], ['a'], ["true"]**) | Exp_tuple of t List2.t (** Expressions [(E1, E2, ..., En)] *) - | Exp_function of (t case[@gen gen_case gen_sized (n / 2)]) List1.t + | Exp_function of t case List1.t (** [Exp_function (P1, [P2; ...; Pn])] represents [function P1 | ... | Pn] *) - | Exp_fun of (Pattern.t[@gen Pattern.gen_sized (n / 2)]) List1.t * t + | Exp_fun of Pattern.t List1.t * t (**[Exp_fun (P1, [P2; ...; Pn], E)] represents: [fun P1 ... Pn -> E] *) | Exp_apply of t * t (** [Pexp_apply(E0, E1)] represents [E0 E1]*) - | Exp_match of t * (t case[@gen gen_case gen_sized (n / 2)]) List1.t - (** [match E0 with P1 -> E1 || Pn -> En] *) - | Exp_constraint of t * (TypeExpr.t[@gen TypeExpr.gen_sized (n / 2)]) (** [(E : T)] *) + | Exp_match of t * t case List1.t (** [match E0 with P1 -> E1 || Pn -> En] *) + | Exp_constraint of t * TypeExpr.t (** [(E : T)] *) | Exp_if of t * t * t option (** [if E1 then E2 else E3] *) - | Exp_let of - rec_flag * (t value_binding[@gen gen_value_binding gen_sized (n / 2)]) List1.t * t + | Exp_let of rec_flag * t value_binding List1.t * t (** [Exp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: - [let P1 = E1 and ... and Pn = EN in E] when [flag] is [Nonrecursive], - [let rec P1 = E1 and ... and Pn = EN in E] when [flag] is [Recursive]. *) - | Exp_construct of (ident[@gen gen_ident]) * t option + | Exp_construct of ident * t option (** [Exp_construct(C, exp)] represents: - [C] when [exp] is [None], - [C E] when [exp] is [Some E], - [C (E1, ..., En)] when [exp] is [Some (Exp_tuple[E1;...;En])] *) - [@@deriving eq, show { with_path = false }, qcheck] + [@@deriving eq, show { with_path = false }] + + let rec gen_sized n = + match n with + | 0 -> + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.map (fun gen0 -> Exp_ident gen0) gen_ident + ; 1, QCheck.Gen.map (fun gen0 -> Exp_constant gen0) Constant.gen + ] + | _ -> + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.map (fun gen0 -> Exp_ident gen0) gen_ident + ; 1, QCheck.Gen.map (fun gen0 -> Exp_constant gen0) Constant.gen + ; 1, QCheck.Gen.map (fun gen0 -> Exp_tuple gen0) (List2.gen (gen_sized (n / 2))) + ; ( 1 + , QCheck.Gen.map + (fun gen0 -> Exp_function gen0) + (List1.gen (gen_case gen_sized (n / 2))) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Exp_fun (gen0, gen1)) + (QCheck.Gen.pair + (List1.gen (Pattern.gen_sized (n / 2))) + (gen_sized (n / 2))) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Exp_apply (gen0, gen1)) + (QCheck.Gen.pair (gen_sized (n / 2)) (gen_sized (n / 2))) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Exp_match (gen0, gen1)) + (QCheck.Gen.pair + (gen_sized (n / 2)) + (List1.gen (gen_case gen_sized (n / 2)))) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Exp_constraint (gen0, gen1)) + (QCheck.Gen.pair (gen_sized (n / 2)) (TypeExpr.gen_sized (n / 2))) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Exp_if (gen0, gen1, gen2)) + (QCheck.Gen.triple + (gen_sized (n / 2)) + (gen_sized (n / 2)) + (QCheck.Gen.option (gen_sized (n / 2)))) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1, gen2) -> Exp_let (gen0, gen1, gen2)) + (QCheck.Gen.triple + gen_rec_flag + (List1.gen (gen_value_binding gen_sized (n / 2))) + (gen_sized (n / 2))) ) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Exp_construct (gen0, gen1)) + (QCheck.Gen.pair gen_ident (QCheck.Gen.option (gen_sized (n / 2)))) ) + ] + ;; + + let gen = QCheck.Gen.sized gen_sized + let arb_sized n = QCheck.make @@ gen_sized n + let arb = QCheck.make @@ gen end module Structure = struct @@ -216,10 +374,7 @@ module Structure = struct when [rec] is [Nonrecursive], - [let rec P1 = E1 and ... and Pn = EN ] when [rec] is [Recursiv e ee]. *) - | Str_adt of - (ident[@gen gen_ident]) list - * (ident[@gen gen_ident]) - * ((ident[@gen gen_ident]) * TypeExpr.t option) List1.t + | Str_adt of ident list * ident * (ident * TypeExpr.t option) List1.t (** [Str_type(C0, [(C1, [(T11; T12; ... ; T1n_1)]); (C2, [(T21;T22; ... ; T2n_2)]); ... ; (Cm, [(Tm1;Tm2; ... ; Tmn_n)]) ])] represents: @@ -255,6 +410,8 @@ module Structure = struct return (Str_adt (tparam, idt, (cons1, consl))) ) ] ;; + + let arb_structure_item = QCheck.make @@ gen_structure_item 10 end type program = Structure.structure_item list [@@deriving eq, show { with_path = false }] diff --git a/XML/test_qc/test_qc.ml b/XML/test_qc/test_qc.ml index fa125b7f..7ca11dd9 100644 --- a/XML/test_qc/test_qc.ml +++ b/XML/test_qc/test_qc.ml @@ -12,7 +12,27 @@ module AST = struct type t = | Const of (int[@gen QCheck.Gen.return 1]) | Add of t * t - [@@deriving qcheck, show { with_path = false }] + [@@deriving show { with_path = false }] + + let rec gen_sized n = + match n with + | 0 -> QCheck.Gen.map (fun gen0 -> Const gen0) (QCheck.Gen.return 1) + | _ -> + QCheck.Gen.oneof_weighted + [ 1, QCheck.Gen.map (fun gen0 -> Const gen0) (QCheck.Gen.return 1) + ; ( 1 + , QCheck.Gen.map + (fun (gen0, gen1) -> Add (gen0, gen1)) + (QCheck.Gen.pair (gen_sized (n / 2)) (gen_sized (n / 2))) ) + ] + ;; + + let _ = gen_sized + let gen = QCheck.Gen.sized gen_sized + let _ = gen + let arb_sized n = QCheck.make @@ gen_sized n + let _ = arb_sized + let arb = QCheck.make @@ gen end module PP = struct From 3ff42a38a9a80c0689fc72fc30cd57098a84ed27 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 12:03:26 +0300 Subject: [PATCH 77/84] fix: add lost interfaces --- XML/many_tests/qcheck/run_ast_qcheck.mli | 3 +++ XML/many_tests/qcheck/run_machine_qcheck.mli | 3 +++ 2 files changed, 6 insertions(+) create mode 100644 XML/many_tests/qcheck/run_ast_qcheck.mli create mode 100644 XML/many_tests/qcheck/run_machine_qcheck.mli diff --git a/XML/many_tests/qcheck/run_ast_qcheck.mli b/XML/many_tests/qcheck/run_ast_qcheck.mli new file mode 100644 index 00000000..536d103e --- /dev/null +++ b/XML/many_tests/qcheck/run_ast_qcheck.mli @@ -0,0 +1,3 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/XML/many_tests/qcheck/run_machine_qcheck.mli b/XML/many_tests/qcheck/run_machine_qcheck.mli new file mode 100644 index 00000000..536d103e --- /dev/null +++ b/XML/many_tests/qcheck/run_machine_qcheck.mli @@ -0,0 +1,3 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From 0350c73d728751a015bc35c8d828f2c60ef5e8bb Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 20:16:11 +0300 Subject: [PATCH 78/84] zanuda: remove unneeded @@ --- XML/lib/common/ast.ml | 27 +++++++++++++-------------- XML/test_qc/test_qc.ml | 4 ++-- 2 files changed, 15 insertions(+), 16 deletions(-) diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 6cc4c465..57e432f0 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -96,7 +96,7 @@ module List1 = struct (QCheck.Gen.pair gen_a (list_size (int_bound 5) gen_a)) ;; - let arb gen_a = QCheck.make @@ gen gen_a + let arb gen_a = QCheck.make (gen gen_a) end module List2 = struct @@ -108,8 +108,7 @@ module List2 = struct (QCheck.Gen.triple gen_a gen_a (QCheck.Gen.list gen_a)) ;; - let _ = gen - let arb gen_a = QCheck.make @@ gen gen_a + let arb gen_a = QCheck.make (gen gen_a) end module Constant = struct @@ -127,7 +126,7 @@ module Constant = struct ] ;; - let arb = QCheck.make @@ gen + let arb = QCheck.make gen end module TypeExpr = struct @@ -187,10 +186,10 @@ module TypeExpr = struct let gen = QCheck.Gen.sized gen_sized let gen_tv = QCheck.Gen.sized gen_tv_sized - let arb_sized n = QCheck.make @@ gen_sized n - let arb_tv_sized n = QCheck.make @@ gen_tv_sized n - let arb = QCheck.make @@ gen - let arb_tv = QCheck.make @@ gen_tv + let arb_sized n = QCheck.make (gen_sized n) + let arb_tv_sized n = QCheck.make (gen_tv_sized n) + let arb = QCheck.make gen + let arb_tv = QCheck.make gen_tv end module Pattern = struct @@ -234,8 +233,8 @@ module Pattern = struct ;; let gen = QCheck.Gen.sized gen_sized - let arb_sized n = QCheck.make @@ gen_sized n - let arb = QCheck.make @@ gen + let arb_sized n = QCheck.make (gen_sized n) + let arb = QCheck.make gen end module Expression = struct @@ -249,7 +248,7 @@ module Expression = struct [ 1, QCheck.Gen.pure Nonrecursive; 1, QCheck.Gen.pure Recursive ] ;; - let arb_rec_flag = QCheck.make @@ gen_rec_flag + let arb_rec_flag = QCheck.make gen_rec_flag type 'expr value_binding = { pat : Pattern.t @@ -361,8 +360,8 @@ module Expression = struct ;; let gen = QCheck.Gen.sized gen_sized - let arb_sized n = QCheck.make @@ gen_sized n - let arb = QCheck.make @@ gen + let arb_sized n = QCheck.make (gen_sized n) + let arb = QCheck.make gen end module Structure = struct @@ -411,7 +410,7 @@ module Structure = struct ] ;; - let arb_structure_item = QCheck.make @@ gen_structure_item 10 + let arb_structure_item = QCheck.make (gen_structure_item 10) end type program = Structure.structure_item list [@@deriving eq, show { with_path = false }] diff --git a/XML/test_qc/test_qc.ml b/XML/test_qc/test_qc.ml index 7ca11dd9..718195a1 100644 --- a/XML/test_qc/test_qc.ml +++ b/XML/test_qc/test_qc.ml @@ -30,9 +30,9 @@ module AST = struct let _ = gen_sized let gen = QCheck.Gen.sized gen_sized let _ = gen - let arb_sized n = QCheck.make @@ gen_sized n + let arb_sized n = QCheck.make (gen_sized n) let _ = arb_sized - let arb = QCheck.make @@ gen + let arb = QCheck.make gen end module PP = struct From 35670304faf93c68952773ebe03529421304d985 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 20:17:19 +0300 Subject: [PATCH 79/84] zanuda: remove assert false --- XML/many_tests/qcheck/run_ast_qcheck.ml | 2 +- XML/many_tests/qcheck/run_machine_qcheck.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/XML/many_tests/qcheck/run_ast_qcheck.ml b/XML/many_tests/qcheck/run_ast_qcheck.ml index 8bce1f79..07957d12 100644 --- a/XML/many_tests/qcheck/run_ast_qcheck.ml +++ b/XML/many_tests/qcheck/run_ast_qcheck.ml @@ -54,6 +54,6 @@ let () = ; "-stop", Arg.Unit (fun _ -> exit 0), " Exit" ; "-gen", Arg.Int run_tests, " Exit" ] - (fun _ -> print_endline "" ) + (fun _ -> ()) "help" ;; \ No newline at end of file diff --git a/XML/many_tests/qcheck/run_machine_qcheck.ml b/XML/many_tests/qcheck/run_machine_qcheck.ml index d6f2fe6a..25bf1f92 100644 --- a/XML/many_tests/qcheck/run_machine_qcheck.ml +++ b/XML/many_tests/qcheck/run_machine_qcheck.ml @@ -31,6 +31,6 @@ let () = ; "-stop", Arg.Unit (fun _ -> exit 0), " Exit" ; "-gen", Arg.Int run_tests, " Exit" ] - (fun _ -> assert false) + (fun _ -> ()) "help" ;; \ No newline at end of file From 23e04409a491f3bff85e60cd66624a5068448a39 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 20:58:04 +0300 Subject: [PATCH 80/84] test: add more tests for cc --- XML/many_tests/unit/cc.ml | 46 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/XML/many_tests/unit/cc.ml b/XML/many_tests/unit/cc.ml index 066451c1..f2ae3b00 100644 --- a/XML/many_tests/unit/cc.ml +++ b/XML/many_tests/unit/cc.ml @@ -57,3 +57,49 @@ to_cc {| |}; [%expect {| let mkPair = (fun x -> (let add = ((fun x y -> x + y) x) in (let mul = ((fun x z -> x * z) x) in ((add x), (mul x)))));; |}] + + +let%expect_test "if" = +to_cc {| + let f = + let ret1 = 1 in + let ret2 = 2 in + let greater_10 x = if x > 10 then ret1 else ret2 in + greater_10 +|}; +[%expect {| + let f = (let ret1 = 1 in (let ret2 = 2 in (let greater_10 = ((fun ret1 ret2 x -> (if x > 10 + then ret1 + else ret2)) ret1) ret2 in (greater_10 ret1) ret2)));; |}] + + +let%expect_test "tuple" = +to_cc {| + let tuples = + let a, b = 10, 20 in + let to_tuple x = x, a, b in + to_tuple +|}; +[%expect {| + let tuples = (let (a, b) = (10, 20) in (let to_tuple = ((fun a b x -> (x, a, b)) a) b in (to_tuple a) b));; |}] + + +let%expect_test "func" = +to_cc {| + let f x y = + ((fun x -> fun x -> y) x) x +|}; +[%expect {| + let f = (fun x y -> (((fun y x -> ((fun y x -> y) y)) y) x) x);; |}] + + +let%expect_test "load" = +to_cc {| + let f x = + let g y = + let (a, b) = x, y in + a in g +|}; +[%expect{| let f = (fun x -> (let g = ((fun x y -> (let (a, b) = (x, y) in a)) x) in (g x)));; |}] + + \ No newline at end of file From 7d3763afe1e27d7084b44aa7941587f5c1160f1b Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 21:08:36 +0300 Subject: [PATCH 81/84] test: add more anf tests --- XML/many_tests/unit/anf.ml | 47 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) diff --git a/XML/many_tests/unit/anf.ml b/XML/many_tests/unit/anf.ml index 65e3f0a2..e31a0cb2 100644 --- a/XML/many_tests/unit/anf.ml +++ b/XML/many_tests/unit/anf.ml @@ -14,6 +14,8 @@ let to_anf_prog str = print_anf_program Format.std_formatter aprog | Error e -> Format.fprintf Format.std_formatter "%s" (pp_anf_error e) + let pp_error e = + Format.fprintf Format.std_formatter "%s" (pp_anf_error e) (************************** Expressions **************************) @@ -118,3 +120,48 @@ let%expect_test "factorial" = let t_3 = (n * t_2) in t_3 in t_4 in t_5;; |}] + +(************************** Error **************************) + +let%expect_test "Only_simple_var_params" = +pp_error `Only_simple_var_params; +[%expect {| Only simple variable patterns are allowed in function parameters |}] + +let%expect_test "Func_no_params" = +pp_error `Func_no_params; +[%expect {| Function with no parameters found |}] + + +let%expect_test "Let_and_not_supported" = +pp_error `Let_and_not_supported; +[%expect {| let ... and ... is not supported in ANF yet |}] + + +let%expect_test "Unsupported_let_pattern" = +pp_error (`Unsupported_let_pattern "pattern"); +[%expect {| Unsupported pattern in let-binding: pattern |}] + + +let%expect_test "Unsupported_let_pattern" = +pp_error (`Unsupported_let_pattern "wrong_pattern"); +[%expect {| Unsupported pattern in let-binding: wrong_pattern |}] + + +let%expect_test "Unsupported_expr_in_normaliser" = +pp_error (`Unsupported_expr_in_normaliser); +[%expect {| unsupported expression in ANF normaliser |}] + +let%expect_test "Mutual_rec_not_supported" = +pp_error `Mutual_rec_not_supported; +[%expect {| Mutually recursive let ... and ... bindings are not supported yet. |}] + + +let%expect_test "Unsupported_toplevel_let" = +pp_error `Unsupported_toplevel_let; +[%expect {| Unsupported pattern in a top-level let-binding. Only simple variables are allowed. |}] + + +let%expect_test "Unsupported_toplevel_item" = +pp_error `Unsupported_toplevel_item; +[%expect {| Unsupported top-level structure item. |}] + From 7548285a98d7a4938225200c3aba68dc63e1d48d Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 21:15:33 +0300 Subject: [PATCH 82/84] test: add ll and cc tests --- XML/many_tests/unit/cc.ml | 21 ++++- XML/many_tests/unit/ll.ml | 160 +++++++++++++++++++++++++++++++++++++ XML/many_tests/unit/ll.mli | 3 + 3 files changed, 182 insertions(+), 2 deletions(-) create mode 100644 XML/many_tests/unit/ll.ml create mode 100644 XML/many_tests/unit/ll.mli diff --git a/XML/many_tests/unit/cc.ml b/XML/many_tests/unit/cc.ml index f2ae3b00..41bb93bb 100644 --- a/XML/many_tests/unit/cc.ml +++ b/XML/many_tests/unit/cc.ml @@ -83,7 +83,7 @@ to_cc {| [%expect {| let tuples = (let (a, b) = (10, 20) in (let to_tuple = ((fun a b x -> (x, a, b)) a) b in (to_tuple a) b));; |}] - + let%expect_test "func" = to_cc {| let f x y = @@ -92,7 +92,7 @@ to_cc {| [%expect {| let f = (fun x y -> (((fun y x -> ((fun y x -> y) y)) y) x) x);; |}] - + let%expect_test "load" = to_cc {| let f x = @@ -102,4 +102,21 @@ to_cc {| |}; [%expect{| let f = (fun x -> (let g = ((fun x y -> (let (a, b) = (x, y) in a)) x) in (g x)));; |}] + +let%expect_test "match" = +to_cc {| + let f x = + let y = 10 in + let g z = + (match x with + | Some _ -> y + | _ -> z) + in + g +|}; +[%expect{| + let f = (fun x -> (let y = 10 in (let g = ((fun x y z -> (match x with + | Some _ -> y + | _ -> z)) x) y in (g x) y)));; |}] + \ No newline at end of file diff --git a/XML/many_tests/unit/ll.ml b/XML/many_tests/unit/ll.ml new file mode 100644 index 00000000..1858c8b7 --- /dev/null +++ b/XML/many_tests/unit/ll.ml @@ -0,0 +1,160 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + + +open Middleend.Cc +open Middleend.Anf +open Middleend.Pprinter +open Middleend.Ll +open Common.Parser + +let to_ll str = + let prog = parse_str str in + let ccprog = cc_program prog in + let aprog = anf_program ccprog in + let llprog = lambda_lift_program aprog in + print_anf_program Format.std_formatter llprog + + +let%expect_test "020closures.pdf" = +to_ll {| + let fac n = + let rec fack n k = + if n <= 1 then k 1 + else fack (n-1) (fun m -> k (m * n)) + in + fack n (fun x -> x) +|}; +[%expect {| + let fac = fun n -> let t_12 = t_11__ll$1 fack n + in let t_13 = t_13__ll$3 in let t_14 = t_12 t_13 in t_14;; + let t_6__ll$2 = fun k n m -> let t_4 = (m * n) in let t_5 = k t_4 in t_5;; + let t_11__ll$1 = fun fack n + k -> let t_0 = (n <= 1) + in let t_10 = if t_0 then let t_1 = k 1 in t_1 else + let t_2 = (n - 1) + in let t_3 = fack t_2 + in let t_7 = t_6__ll$2 k + in let t_8 = t_7 n + in let t_9 = t_3 t_8 + in t_9 + in t_10;; + let t_13__ll$3 = fun x -> x;; |}] + + +let%expect_test "LN_CC_1" = +to_ll {| + let f x = + let g y = x + in + g +|}; +[%expect {| + let f = fun x -> let t_1 = t_0__ll$1 x in let g = t_1 in let t_2 = g x in t_2;; + + let t_0__ll$1 = fun x y -> x;; |}] + + +let%expect_test "LN_CC_2" = +to_ll {| + fun x -> x + a + b +|}; +[%expect {| + let t_3 = t_2__ll$1 a in let t_4 = t_3 b in t_4;; + let t_2__ll$1 = fun a b x -> let t_0 = (x + a) in let t_1 = (t_0 + b) in t_1;; |}] + + +let%expect_test "LN_CC_3" = +to_ll {| + let mkPair = fun x -> + let add = fun y -> x + y in + let mul = fun z -> x * z in + (add, mul) +|}; +[%expect {| + let mkPair = fun x -> let t_2 = t_1__ll$1 x + in let add = t_2 + in let t_5 = t_4__ll$2 x + in let mul = t_5 + in let t_6 = add x + in let t_7 = mul x + in let t_8 = alloc(t_6, + t_7) in t_8;; + let t_1__ll$1 = fun x y -> let t_0 = (x + y) in t_0;; + let t_4__ll$2 = fun x z -> let t_3 = (x * z) in t_3;; |}] + + +let%expect_test "if" = +to_ll {| + let f = + let ret1 = 1 in + let ret2 = 2 in + let greater_10 x = if x > 10 then ret1 else ret2 in + greater_10 +|}; +[%expect {| + let f = let t_0 = 1 + in let ret1 = t_0 + in let t_1 = 2 + in let ret2 = t_1 + in let t_5 = t_4__ll$1 ret1 + in let t_6 = t_5 ret2 + in let greater_10 = t_6 + in let t_7 = greater_10 ret1 + in let t_8 = t_7 ret2 in t_8;; + let t_4__ll$1 = fun ret1 ret2 + x -> let t_2 = (x > 10) + in let t_3 = if t_2 then ret1 else ret2 in t_3;; |}] + + +let%expect_test "tuple" = +to_ll {| + let tuples = + let a, b = 10, 20 in + let to_tuple x = x, a, b in + to_tuple +|}; +[%expect {| + let tuples = let t_0 = alloc(10, 20) + in let t_8 = t_0[0] + in let a = t_8 + in let t_7 = t_0[8] + in let b = t_7 + in let t_3 = t_2__ll$1 a + in let t_4 = t_3 b + in let to_tuple = t_4 + in let t_5 = to_tuple a + in let t_6 = t_5 b + in t_6;; + let t_2__ll$1 = fun a b x -> let t_1 = alloc(x, a, b) in t_1;; |}] + + +let%expect_test "func" = +to_ll {| + let f x y = + ((fun x -> fun x -> y) x) x +|}; +[%expect {| + let f = fun x + y -> let t_3 = t_2__ll$1 y + in let t_4 = t_3 x in let t_5 = t_4 x in t_5;; + let t_0__ll$2 = fun y x -> y;; + let t_2__ll$1 = fun y x -> let t_1 = t_0__ll$2 y in t_1;; |}] + + +let%expect_test "load" = +to_ll {| + let f x = + let g y = + let (a, b) = x, y in + a in g +|}; +[%expect{| + let f = fun x -> let t_4 = t_3__ll$1 x in let g = t_4 in let t_5 = g x in t_5;; + + let t_3__ll$1 = fun x + y -> let t_0 = alloc(x, y) + in let t_2 = t_0[0] + in let a = t_2 + in let t_1 = t_0[8] in let b = t_1 in a;; |}] diff --git a/XML/many_tests/unit/ll.mli b/XML/many_tests/unit/ll.mli new file mode 100644 index 00000000..536d103e --- /dev/null +++ b/XML/many_tests/unit/ll.mli @@ -0,0 +1,3 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From 1b0bedc1fefa3dde875b8ba04ec7fbcbdbfbedee Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 21:39:36 +0300 Subject: [PATCH 83/84] test: add tests for machine --- XML/many_tests/unit/machine.ml | 272 ++++++++++++++++++++++++++++++++ XML/many_tests/unit/machine.mli | 3 + 2 files changed, 275 insertions(+) create mode 100644 XML/many_tests/unit/machine.ml create mode 100644 XML/many_tests/unit/machine.mli diff --git a/XML/many_tests/unit/machine.ml b/XML/many_tests/unit/machine.ml new file mode 100644 index 00000000..988f9e83 --- /dev/null +++ b/XML/many_tests/unit/machine.ml @@ -0,0 +1,272 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Backend.Machine + +let test x = + if x then Format.fprintf Format.std_formatter "true" else Format.fprintf Format.std_formatter "false" + +let%expect_test "addi" = + test (Addi (SP, SP, 8) = Addi (SP, SP, 8)); + [%expect {| true |}] + +let%expect_test "addi false" = + test (Addi (SP, SP, 8) = Addi (SP, SP, 16)); + [%expect {| false |}] + +let%expect_test "add" = + test (Add (SP, SP, A 0) = Add (SP, SP, A 0)); + [%expect {| true |}] + +let%expect_test "add false" = + test (Add (SP, SP, A 0) = Add (SP, A 0, SP)); + [%expect {| false |}] + +let%expect_test "sub" = + test (Sub (SP, SP, A 0) = Sub (SP, SP, A 0)); + [%expect {| true |}] + +let%expect_test "sub false" = + test (Sub (SP, SP, A 0) = Sub (SP, A 0, SP)); + [%expect {| false |}] + +let%expect_test "mul" = + test (Mul (SP, SP, A 0) = Mul (SP, SP, A 0)); + [%expect {| true |}] + +let%expect_test "mul false" = + test (Mul (SP, SP, A 0) = Mul (SP, A 0, SP)); + [%expect {| false |}] + +let%expect_test "slt" = + test (Slt (SP, SP, A 0) = Slt (SP, SP, A 0)); + [%expect {| true |}] + +let%expect_test "slt false" = + test (Slt (SP, SP, A 0) = Slt (SP, A 0, SP)); + [%expect {| false |}] + +let%expect_test "seqz" = + test (Seqz (SP, A 0) = Seqz (SP, A 0)); + [%expect {| true |}] + +let%expect_test "seqz false" = + test (Seqz (SP, A 0) = Seqz (A 0, SP)); + [%expect {| false |}] + +let%expect_test "snez" = + test (Snez (SP, A 0) = Snez (SP, A 0)); + [%expect {| true |}] + +let%expect_test "snez false" = + test (Snez (SP, A 0) = Snez (A 0, SP)); + [%expect {| false |}] + +let%expect_test "xor" = + test (Xor (SP, SP, A 0) = Xor (SP, SP, A 0)); + [%expect {| true |}] + +let%expect_test "xor false" = + test (Xor (SP, SP, A 0) = Xor (SP, A 0, SP)); + [%expect {| false |}] + +let%expect_test "xori" = + test (Xori (SP, SP, 8) = Xori (SP, SP, 8)); + [%expect {| true |}] + +let%expect_test "xori false" = + test (Xori (SP, SP, 8) = Xori (SP, SP, 16)); + [%expect {| false |}] + +let%expect_test "beq" = + test (Beq (SP, A 0, "label1") = Beq (SP, A 0, "label1")); + [%expect {| true |}] + +let%expect_test "beq false reg" = + test (Beq (SP, A 0, "label1") = Beq (A 0, SP, "label1")); + [%expect {| false |}] + +let%expect_test "beq false label" = + test (Beq (SP, A 0, "label1") = Beq (SP, A 0, "label2")); + [%expect {| false |}] + +let%expect_test "blt" = + test (Blt (SP, A 0, "label1") = Blt (SP, A 0, "label1")); + [%expect {| true |}] + +let%expect_test "blt false reg" = + test (Blt (SP, A 0, "label1") = Blt (A 0, SP, "label1")); + [%expect {| false |}] + +let%expect_test "blt false label" = + test (Blt (SP, A 0, "label1") = Blt (SP, A 0, "label2")); + [%expect {| false |}] + +let%expect_test "ble" = + test (Ble (SP, A 0, "label1") = Ble (SP, A 0, "label1")); + [%expect {| true |}] + +let%expect_test "ble false reg" = + test (Ble (SP, A 0, "label1") = Ble (A 0, SP, "label1")); + [%expect {| false |}] + +let%expect_test "ble false label" = + test (Ble (SP, A 0, "label1") = Ble (SP, A 0, "label2")); + [%expect {| false |}] + +let%expect_test "lla" = + test (Lla (SP, "label1") = Lla (SP, "label1")); + [%expect {| true |}] + +let%expect_test "lla false reg" = + test (Lla (SP, "label1") = Lla (A 0, "label1")); + [%expect {| false |}] + +let%expect_test "lla false label" = + test (Lla (SP, "label1") = Lla (SP, "label2")); + [%expect {| false |}] + +let%expect_test "li" = + test (Li (SP, 42) = Li (SP, 42)); + [%expect {| true |}] + +let%expect_test "li false reg" = + test (Li (SP, 42) = Li (A 0, 42)); + [%expect {| false |}] + +let%expect_test "li false imm" = + test (Li (SP, 42) = Li (SP, 100)); + [%expect {| false |}] + +let%expect_test "ld" = + test (Ld (SP, (SP, 8)) = Ld (SP, (SP, 8))); + [%expect {| true |}] + +let%expect_test "ld false reg" = + test (Ld (SP, (SP, 8)) = Ld (A 0, (SP, 8))); + [%expect {| false |}] + +let%expect_test "ld false reg" = + test (Ld (SP, (SP, 8)) = Ld (SP, (A 0, 8))); + [%expect {| false |}] + +let%expect_test "ld false imm" = + test (Ld (SP, (SP, 8)) = Ld (SP, (SP, 16))); + [%expect {| false |}] + +let%expect_test "sd" = + test (Sd (SP, (SP, 8)) = Sd (SP, (SP, 8))); + [%expect {| true |}] + +let%expect_test "sd false reg" = + test (Sd (SP, (SP, 8)) = Sd (A 0, (SP, 8))); + [%expect {| false |}] + +let%expect_test "sd false reg" = + test (Sd (SP, (SP, 8)) = Sd (SP, (A 0, 8))); + [%expect {| false |}] + +let%expect_test "sd false imm" = + test (Sd (SP, (SP, 8)) = Sd (SP, (SP, 16))); + [%expect {| false |}] + +let%expect_test "mv" = + test (Mv (SP, A 0) = Mv (SP, A 0)); + [%expect {| true |}] + +let%expect_test "mv false" = + test (Mv (SP, A 0) = Mv (A 0, SP)); + [%expect {| false |}] + +let%expect_test "comment" = + test (Comment "test comment" = Comment "test comment"); + [%expect {| true |}] + +let%expect_test "comment false" = + test (Comment "test comment" = Comment "different comment"); + [%expect {| false |}] + +let%expect_test "label" = + test (Label "label1" = Label "label1"); + [%expect {| true |}] + +let%expect_test "label false" = + test (Label "label1" = Label "label2"); + [%expect {| false |}] + +let%expect_test "call" = + test (Call "func1" = Call "func1"); + [%expect {| true |}] + +let%expect_test "call false" = + test (Call "func1" = Call "func2"); + [%expect {| false |}] + +let%expect_test "j" = + test (J "label1" = J "label1"); + [%expect {| true |}] + +let%expect_test "j false" = + test (J "label1" = J "label2"); + [%expect {| false |}] + +let%expect_test "ecall" = + test (Ecall = Ecall); + [%expect {| true |}] + +let%expect_test "ecall false" = + test (Ecall = Ret); + [%expect {| false |}] + +let%expect_test "ret" = + test (Ret = Ret); + [%expect {| true |}] + +let%expect_test "ret false" = + test (Ret = Ecall); + [%expect {| false |}] + +let%expect_test "la" = + test (La (SP, "func1") = La (SP, "func1")); + [%expect {| true |}] + +let%expect_test "la false reg" = + test (La (SP, "func1") = La (A 0, "func1")); + [%expect {| false |}] + +let%expect_test "la false label" = + test (La (SP, "func1") = La (SP, "func2")); + [%expect {| false |}] + +let%expect_test "slli" = + test (Slli (SP, A 0, 4) = Slli (SP, A 0, 4)); + [%expect {| true |}] + +let%expect_test "slli false reg dest" = + test (Slli (SP, A 0, 4) = Slli (A 0, A 0, 4)); + [%expect {| false |}] + +let%expect_test "slli false reg src" = + test (Slli (SP, A 0, 4) = Slli (SP, SP, 4)); + [%expect {| false |}] + +let%expect_test "slli false imm" = + test (Slli (SP, A 0, 4) = Slli (SP, A 0, 8)); + [%expect {| false |}] + +let%expect_test "srai" = + test (Srai (SP, A 0, 4) = Srai (SP, A 0, 4)); + [%expect {| true |}] + +let%expect_test "srai false reg dest" = + test (Srai (SP, A 0, 4) = Srai (A 0, A 0, 4)); + [%expect {| false |}] + +let%expect_test "srai false reg src" = + test (Srai (SP, A 0, 4) = Srai (SP, SP, 4)); + [%expect {| false |}] + +let%expect_test "srai false imm" = + test (Srai (SP, A 0, 4) = Srai (SP, A 0, 8)); + [%expect {| false |}] \ No newline at end of file diff --git a/XML/many_tests/unit/machine.mli b/XML/many_tests/unit/machine.mli new file mode 100644 index 00000000..536d103e --- /dev/null +++ b/XML/many_tests/unit/machine.mli @@ -0,0 +1,3 @@ +(** Copyright 2026, Mikhail Gavrilenko, Danila Rudnev-Stepanyan, Daniel Vlasenko *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From d02abf16a7915883b8488f654b48bd18a6992c75 Mon Sep 17 00:00:00 2001 From: Vlasenco Daniel Date: Wed, 11 Mar 2026 21:49:40 +0300 Subject: [PATCH 84/84] chore: get rid of dead code and unsupported stuff --- XML/lib/backend/codegen.ml | 1 - XML/lib/backend/codegen_llvm.ml | 13 -------- XML/lib/common/ast.ml | 58 +-------------------------------- XML/lib/common/ast.mli | 6 ---- XML/lib/common/parser.ml | 50 +--------------------------- XML/lib/common/pprinter.ml | 23 ------------- XML/lib/middleend/anf.ml | 1 - XML/lib/middleend/cc.ml | 1 - XML/lib/middleend/infer.ml | 3 -- 9 files changed, 2 insertions(+), 154 deletions(-) diff --git a/XML/lib/backend/codegen.ml b/XML/lib/backend/codegen.ml index b6c128c8..642ff5d0 100644 --- a/XML/lib/backend/codegen.ml +++ b/XML/lib/backend/codegen.ml @@ -76,7 +76,6 @@ type 'a r = ('a, cg_error) result let ok x = Ok x let err e = Error e let ( let* ) = Result.bind -let ( let+ ) x f = Result.map f x let fresh_label (prefix : string) (st : cg_state) : string * cg_state = let n = st.next_label in diff --git a/XML/lib/backend/codegen_llvm.ml b/XML/lib/backend/codegen_llvm.ml index cb1dad28..20241531 100644 --- a/XML/lib/backend/codegen_llvm.ml +++ b/XML/lib/backend/codegen_llvm.ml @@ -127,13 +127,6 @@ let prefill_fmap (fmap0 : FuncMap.t) the_mod (program : aprogram) : FuncMap.t = program ;; -(* for debug *) -let _print_untag fmap n = - let pival, pityp, _ = FuncMap.find_exn fmap "print_int" in - let _ = build_call_mb_void pityp pival [| n |] "_" in - () -;; - let build_alloc_closure fmap func = let acval, actyp, _ = FuncMap.find_exn fmap "alloc_closure" in let argc = Array.length (Llvm.params func) in @@ -182,12 +175,6 @@ let gen_tagged_binop fmap env op lhs rhs = let right' = Llvm.build_sub right one "multmp2" builder in let temp = Llvm.build_mul left' right' "multmp3" builder in Llvm.build_add temp one "multmp4" builder - | "/" -> - let left' = Llvm.build_lshr left one "divtmp1" builder in - let right' = Llvm.build_lshr right one "divtmp2" builder in - let temp = Llvm.build_sdiv left' right' "divtmp3" builder in - let temp1 = Llvm.build_add temp temp "divtmp4" builder in - Llvm.build_add temp1 one "divtmp5" builder | "<" -> let temp = Llvm.build_icmp Llvm.Icmp.Slt left right "slttmp" builder in Llvm.build_zext temp i64_type "slttmp_as_i64" builder diff --git a/XML/lib/common/ast.ml b/XML/lib/common/ast.ml index 57e432f0..9655a087 100644 --- a/XML/lib/common/ast.ml +++ b/XML/lib/common/ast.ml @@ -30,15 +30,6 @@ let is_not_keyword = function | _ -> true ;; -let rec gen_filtered_ident base_gen = - let open QCheck.Gen in - base_gen - >>= fun (ident [@gen gen_ident]) -> - if is_not_keyword (ident [@gen gen_ident]) - then return (ident [@gen gen_ident]) - else gen_filtered_ident base_gen -;; - let gen_id_first_char = QCheck.Gen.oneof_weighted [ 5, char_range 'a' 'z'; 1, return '_' ] let gen_digit = char_range '0' '9' @@ -60,33 +51,6 @@ let gen_ident = loop gen_name ;; -let gen_ident_uc = - let base_gen = - map2 - (fun start_sym rest_sym -> Base.Char.to_string start_sym ^ rest_sym) - (char_range 'A' 'Z') - (string_small_of - (oneof - [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) - in - gen_filtered_ident base_gen -;; - -let gen_ident_lc include_us = - let start_sym = - if include_us then oneof [ char_range 'a' 'z'; return '_' ] else char_range 'a' 'z' - in - let base_gen = - map2 - (fun start_sym rest_sym -> Base.Char.to_string start_sym ^ rest_sym) - start_sym - (string_small_of - (oneof - [ char_range 'A' 'Z'; char_range 'a' 'z'; char_range '0' '9'; return '_' ])) - in - gen_filtered_ident base_gen -;; - module List1 = struct type 'a t = 'a * 'a list [@@deriving eq, show { with_path = false }] @@ -373,23 +337,11 @@ module Structure = struct when [rec] is [Nonrecursive], - [let rec P1 = E1 and ... and Pn = EN ] when [rec] is [Recursiv e ee]. *) - | Str_adt of ident list * ident * (ident * TypeExpr.t option) List1.t - (** [Str_type(C0, [(C1, [(T11; T12; ... ; T1n_1)]); (C2, [(T21;T22; ... ; T2n_2)]); ... ; - (Cm, [(Tm1;Tm2; ... ; Tmn_n)]) ])] represents: - - [type C0 = - | C1 of T11 * ... * T1n_1 - | ... - | Cm of Tm1 * ... * Tmn_n - ] - - n_i: [n_i >= 0] - Invariant: [m > 0] *) [@@deriving eq, show { with_path = false }] let gen_structure_item n = oneof_weighted - [ 0, map (fun expr -> Str_eval expr) (Expression.gen_sized (n / 2)) + [ 1, map (fun expr -> Str_eval expr) (Expression.gen_sized (n / 2)) ; ( 1 , let* rec_flag = oneof [ return Expression.Nonrecursive; return Expression.Recursive ] @@ -399,14 +351,6 @@ module Structure = struct list_small (Expression.gen_value_binding Expression.gen_sized (n / 2)) in return (Str_value (rec_flag, (bind1, bindl))) ) - ; ( 0 - , let* tparam = list_small gen_ident in - let* idt = gen_ident in - let* cons1 = Gen.pair gen_ident (Gen.option (TypeExpr.gen_sized (n / 20))) in - let* consl = - list_small (Gen.pair gen_ident (Gen.option (TypeExpr.gen_sized (n / 20)))) - in - return (Str_adt (tparam, idt, (cons1, consl))) ) ] ;; diff --git a/XML/lib/common/ast.mli b/XML/lib/common/ast.mli index 01197e68..6227a185 100644 --- a/XML/lib/common/ast.mli +++ b/XML/lib/common/ast.mli @@ -9,10 +9,7 @@ val pp_ident : Format.formatter -> ident -> unit val show_ident : ident -> string val gen_charc : char QCheck.Gen.t val is_not_keyword : string -> bool -val gen_filtered_ident : string QCheck.Gen.t -> string QCheck.Gen.t val gen_ident : string QCheck.Gen.t -val gen_ident_uc : string QCheck.Gen.t -val gen_ident_lc : bool -> string QCheck.Gen.t module List1 : sig type 'a t = 'a * 'a list @@ -179,9 +176,6 @@ module Structure : sig when [rec] is [rec_flag.Nonrecursive]. - [let rec P1 = E1 and ... and Pn = En] when [rec] is [rec_flag.Recursive]. *) - | Str_adt of ident list * ident * (ident * TypeExpr.t option) List1.t - (** A type declaration for an algebraic data type (ADT), - such as [type t1 = ... | ... | tn = ...]. *) val equal_structure_item : structure_item -> structure_item -> bool val pp_structure_item : Format.formatter -> structure_item -> unit diff --git a/XML/lib/common/parser.ml b/XML/lib/common/parser.ml index e2a79ba2..90bb1761 100644 --- a/XML/lib/common/parser.ml +++ b/XML/lib/common/parser.ml @@ -564,55 +564,7 @@ let pstrlet = return (Structure.Str_value (recflag, (bindingfs, bindingtl))) ;; -let pstradt = - let* _ = token "type" in - let* type_param = - option - [] - (pparenth (sep_by (token ",") (token "'" *> pident_lc)) - <|> many (token "'" *> pident_lc)) - in - let* type_name = pass_ws *> pident_lc in - let var = - let* name = option None (pass_ws *> pident_cap >>= fun n -> return (Some n)) in - match name with - | Some x -> - (* Constructor case: Can have "of" *) - let* ctype = - option - None - (token "of" - *> let* types = sep_by (token "*") ptype_adt in - match types with - | x :: y :: xs -> return (Some (TypeExpr.Type_tuple (x, y, xs))) - | [ x ] -> return (Some x) - | [] -> fail "Expected type after 'of'") - in - return (x, ctype) - | None -> - (* Lowercase type alias case: Must have a type expression *) - let* ctype = - let* types = sep_by (token "*") ptype_adt in - match types with - | x :: y :: xs -> return (Some (TypeExpr.Type_tuple (x, y, xs))) (* Tuple case *) - | [ x ] -> return (Some x) (* Single type *) - | [] -> fail "Expected type definition" - in - return ("", ctype) - in - let* _ = token "=" in - let* fvar = - option - None - (option None (token "|" *> return None) *> (var >>= fun v -> return (Some v))) - in - let* varl = many (token "|" *> var) in - match fvar with - | Some fvar -> return (Structure.Str_adt (type_param, type_name, (fvar, varl))) - | None -> fail "Expected at least one variant" -;; - -let pstr_item = pseval <|> pstrlet <|> pstradt +let pstr_item = pseval <|> pstrlet let pstructure = let psemicolon = many (token ";;") in diff --git a/XML/lib/common/pprinter.ml b/XML/lib/common/pprinter.ml index f5ae1c13..aa76b2a7 100644 --- a/XML/lib/common/pprinter.ml +++ b/XML/lib/common/pprinter.ml @@ -366,29 +366,6 @@ let pprint_structure_item fmt n = asprintf "%a" (fun fmt -> pprint_value_binding fmt n) vb)) in fprintf fmt "let %a%s;;\n\n" pprint_rec rec_flag bindings_str - | Str_adt (tparam, id, (constr1, constrl)) -> - let tparam_ident_str = - match List.length tparam with - | 0 -> "" - | 1 -> asprintf "'%s " (List.hd_exn tparam) - | _ -> - "('" - ^ String.concat ~sep:", '" (List.map tparam ~f:(fun param -> asprintf "%s" param)) - ^ ") " - in - let var_t_str = - match constr1 :: constrl with - | [] -> "" - | _ -> - " | " - ^ String.concat - ~sep:"\n | " - (List.map (constr1 :: constrl) ~f:(fun (id, typ) -> - match typ with - | Some t -> asprintf "%s of %a" id pprint_type t - | None -> asprintf "%s" id)) - in - fprintf fmt "type %s%s =\n%s\n;;\n\n" tparam_ident_str id var_t_str ;; let pprint_program fmt = List.iter ~f:(pprint_structure_item fmt 0) diff --git a/XML/lib/middleend/anf.ml b/XML/lib/middleend/anf.ml index d263cae7..e5a2f332 100644 --- a/XML/lib/middleend/anf.ml +++ b/XML/lib/middleend/anf.ml @@ -262,7 +262,6 @@ let norm_item (item : structure_item) (st : nstate) : (astructure_item * nstate) let* body_anf, st' = norm_body expr st in ok (Anf_str_value (rec_flag, name, body_anf), st') | _ -> err `Unsupported_toplevel_let) - | _ -> err `Unsupported_toplevel_item ;; let anf_program_res (program : structure_item list) : (aprogram, anf_error) result = diff --git a/XML/lib/middleend/cc.ml b/XML/lib/middleend/cc.ml index c13197fd..3b0515d5 100644 --- a/XML/lib/middleend/cc.ml +++ b/XML/lib/middleend/cc.ml @@ -282,7 +282,6 @@ let closure_structure_item_result toplvl_set = function (match new_bindings with | [] -> Error Empty_toplevel_let | hd :: tl -> Ok (Str_value (rec_flag, (hd, tl)), new_toplvl_set)) - | Str_adt _ as item -> Ok (item, toplvl_set) ;; let closure_structure_item toplvl_set item = diff --git a/XML/lib/middleend/infer.ml b/XML/lib/middleend/infer.ml index b007d3ef..781b277a 100644 --- a/XML/lib/middleend/infer.ml +++ b/XML/lib/middleend/infer.ml @@ -19,7 +19,6 @@ type error = | Operator_not_found of string | Invalid_let_rec_rhs | Invalid_let_rec_lhs - | Not_supported of string let pprint_err ppf = function | Occurs_check -> Format.fprintf ppf "Occurs check" @@ -37,7 +36,6 @@ let pprint_err ppf = function "This kind of expression is not allowed as right-hand side of `let rec'" | Invalid_let_rec_lhs -> Format.fprintf ppf "Only variables are allowed as left-hand side of `let rec'" - | Not_supported string -> Format.fprintf ppf "Not supported: %s" string ;; type 'a t = ('a, error) result @@ -470,7 +468,6 @@ let infer_structure_item env = function (vb :: vbs) in return (new_env1, new_names) - | Str_adt _ -> fail (Not_supported "str_adts") ;; let infer_program env prog =