summary refs log tree commit diff
path: root/source/xi/pipeline.ml
blob: ae9a4c9fef8e1c1317723f203f668ed9475482f9 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
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 proc_ir) in
    let output = Ir_utils.string_of_labellist schedule in
    Logger.dump_string title output

  let dump_node2type node2type =
    let title = "types" in 
    let f k v xs =
      let line = Format.sprintf "%s -> %s"
        (Ast.string_of_node_tag k)
        (Types.string_of_normal_type v) in
      line :: xs
    in
    let lines = Hashtbl.fold f node2type [] in
    Logger.dump_string title @@ String.concat "\n" @@ List.sort compare lines

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