From b798ac29c37299b2f761243ae92ab8f7c4c4d7f1 Mon Sep 17 00:00:00 2001
From: Paweł Dybiec <pdybiec@stud.cs.uni.wroc.pl>
Date: Tue, 30 Oct 2018 15:32:56 +0100
Subject: Initial commit

---
 source/xi/pipeline.ml | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 137 insertions(+)
 create mode 100644 source/xi/pipeline.ml

(limited to 'source/xi/pipeline.ml')

diff --git a/source/xi/pipeline.ml b/source/xi/pipeline.ml
new file mode 100644
index 0000000..34a06f9
--- /dev/null
+++ b/source/xi/pipeline.ml
@@ -0,0 +1,137 @@
+open Xi_lib
+open Iface
+
+module type PARAMS = sig
+    val stop_point : string
+    val output: string
+end
+
+module Make(Steps:COMPILER_STEPS)(Params:PARAMS) = struct
+
+  module Hack = Xi_lib.Analysis
+
+  open Params
+  module Toolbox = Steps.Toolbox
+
+  module Parser_wrapper = Parser_wrapper.Make(Steps.LexerAndParser)
+
+  let check_stop_point name cont x =
+    if name = stop_point then Ok ()
+    else cont x
+
+
+  let describe_register_mapping mapping =
+    let describe_map k v xs =
+      let entry = Format.sprintf "%s -> %s" (Ir.string_of_reg k) (Ir.string_of_reg v) in
+      entry :: xs
+    in
+    String.concat "\n" @@ Hashtbl.fold describe_map mapping []
+
+  let dump_register_mapping proc_ir mapping =
+    Logger.dump_string "regmapping" @@ describe_register_mapping mapping
+
+  let dump_schedule proc_ir schedule = 
+    let title = Format.sprintf "%s.schedule" (Ir_utils.string_of_procid @@ Ir.procid_of_procedure proc_ir) in
+    let output = Ir_utils.string_of_labellist schedule in
+    Logger.dump_string title output
+
+  module IrPhases = struct
+
+    let regalloc proc =
+      let register_mapping = Steps.RegisterAllocator.regalloc proc in
+      dump_register_mapping proc register_mapping;
+      Ir_utils.remap_registers_proc register_mapping proc
+
+    let scale_to_program f name ir =
+      let handle_proc proc =
+        Logger.new_phase_proc @@ Ir.procid_of_procedure proc;
+        Measure.measure name (fun () -> f proc);
+        Logger.dump_ir_proc "final.irproc" proc
+      in
+      Measure.measure ("whole " ^ name) (fun () ->
+        List.iter handle_proc  @@ Ir.procedures_of_program ir;
+        Logger.close_phase_proc ()
+      );
+      Logger.dump_ir_program "final.ir" ir
+
+    let ir_phases =
+      [ "jump_threading", scale_to_program Steps.JumpThreading.jump_threading
+      ; "hi_lower", scale_to_program Steps.HiLower.lower
+      ; "constant_folding", scale_to_program Steps.ConstantFolding.fold_constants 
+      ; "dead_code_elimination", scale_to_program Steps.DeadCodeElimination.eliminate_dead_code
+      ; "callconv", scale_to_program Steps.CallConv.callconv
+      ; "mips_lower", scale_to_program Steps.MipsLower.lower
+      ; "regalloc", scale_to_program regalloc
+      ; "dead_code_elimination", scale_to_program Steps.DeadCodeElimination.eliminate_dead_code
+      ]
+
+
+    let rec execute_ir_phases ir = function
+      | [] ->
+        ()
+      | (name, f)::rest ->
+        Logger.new_phase name;
+        f name ir;
+        execute_ir_phases ir rest
+
+    let transform_ir ir =
+      execute_ir_phases ir ir_phases
+
+  end
+
+  let finish result =
+    Format.printf "done\n";
+    let out = open_out output in 
+    output_string out result;
+    output_string out "\n";
+    close_out out;
+    Ok ()
+
+  let codegen ir =
+    Logger.new_phase "codegen";
+    let schedule = Toolbox.Scheduler.schedule ir in
+    Hashtbl.iter dump_schedule schedule;
+    let assembler = Steps.Codegen.codegen schedule ir in
+    let result = Hardcoded.preamble ^ Mips32.string_of_program assembler in
+    Logger.dump_string "final" result;
+    finish result
+
+  let translate (ast, node2type) =
+    Logger.new_phase "translate";
+    let ir = Steps.Translator.translate_module ast node2type in
+    Logger.dump_ir_program "translated.ir" ir;
+    IrPhases.transform_ir ir;
+    codegen ir
+
+  let type_check ast = 
+    Logger.new_phase "typechecking";
+    match Steps.Typechecker.check_module ast with
+    | Error xs ->
+      let xs = List.map Typechecker_errors.string_of_type_checking_error xs in 
+      List.iter prerr_endline xs;
+      Error "typechecker"
+    | Ok (node2type) ->
+      if Invariants.AllExpressionsAreTypecheck.verify_module_definition node2type ast then
+        check_stop_point "typechecker" translate (ast, node2type)
+      else
+        Error "typechecker"
+
+
+  let parse_step source =
+    Logger.new_phase "parsing";
+    match Parser_wrapper.parse_file source with
+    | Error (loc, descr) ->
+      Format.printf "%s: %s\n%!" (Ast.string_of_location loc) descr;
+      Error "parser"
+
+    | Ok ok ->
+      let ast_str = Ast_printer.show_module_definition ok in 
+      Logger.dump_string "ast" ast_str;
+      let ast_str = Ast_rawprinter.show_module_definition ok in 
+      Logger.dump_string "raw.ast" ast_str;
+      check_stop_point "parser" type_check ok
+
+
+  let compile = 
+      parse_step
+end
-- 
cgit 1.4.1