main.ml 9.09 KB
Newer Older
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
open Batteries
open BatList
open Symbols
open Parser
open Ast
open Elang
open Elang_run
open Elang_print
open Elang_gen
open Cfg
open Cfg_run
open Cfg_print
open Cfg_gen
open Cfg_constprop
open Cfg_dead_assign
open Cfg_nop_elim
open Rtl
open Rtl_run
open Rtl_print
open Rtl_gen
open Linear
open Linear_run
open Linear_print
open Linear_gen
open Linear_liveness
open Linear_dse
open Ltl
open Ltl_run
open Ltl_print
open Ltl_gen
open Ltl_debug
open Riscv
open Utils
open Archi
open Report
open Options
open Lexer_generator
Wilke Pierre's avatar
Wilke Pierre committed
38
open Tokenize
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

let speclist =
  [
    ("-show-tokens", Arg.String (fun s -> show_tokens := Some s), "Output the list of tokens recognized by the lexer.");
    ("-ast-tree", Arg.String (fun s -> ast_tree := Some s), "Output DOT file for dumping the tree.");
    ("-ast-dump", Arg.Set ast_dump, "Dumps the tree in textual form.");
    ("-e-dump", Arg.String (fun s -> e_dump := Some s), "Output Elang file.");
    ("-e-run", Arg.Set e_run, "Run Elang program.");
    ("-cfg-dump", Arg.String (fun s -> cfg_dump := Some s), "Output CFG file.");
    ("-cfg-run", Arg.Set cfg_run, "Run CFG program.");
    ("-cfg-run-after-cp", Arg.Set cfg_run_after_cp, "Run CFG program after constant propagation.");
    ("-cfg-run-after-dae", Arg.Set cfg_run_after_dae, "Run CFG program after dead assign elimination.");
    ("-cfg-run-after-ne", Arg.Set cfg_run_after_ne, "Run CFG program after nop elimination.");
    ("-rtl-dump", Arg.String (fun s -> rtl_dump := Some s), "Output RTL file.");
    ("-rtl-run", Arg.Set rtl_run, "Run RTL program.");
    ("-linear-dump", Arg.String (fun s -> linear_dump := Some s), "Output Linear file.");
    ("-linear-run", Arg.Set linear_run, "Run Linear program.");
    ("-linear-run-after-dse", Arg.Set linear_run_after_dse, "Run Linear program after dead store elimination.");
    ("-ltl-dump", Arg.String (fun s -> ltl_dump := Some s), "Output LTL file.");
    ("-ltl-run", Arg.Set ltl_run, "Run LTL program.");
    ("-ltl-debug", Arg.Set ltl_debug, "Debug LTL program.");
    ("-riscv-dump", Arg.String (fun s -> riscv_dump := Some s), "Output RISC-V file.");
    ("-riscv-run", Arg.Set riscv_run, "Run RISC-V program.");
    ("-no-dump", Arg.Set no_dump, "Do not dump anything but the .s file");
    ("-no-dot", Arg.Set no_dot, "Do not call dot on CFG dumps (default false)");
64
65
66
    ("-clever-regalloc", Arg.Unit (fun () -> naive_regalloc := false), "Use the graph coloring algorithm for register allocation.");
    ("-naive-regalloc", Arg.Unit (fun () -> naive_regalloc := true),
     "Use the naive algorithm for register allocation (all pseudo-registers go on the stack).");
Wilke Pierre's avatar
Wilke Pierre committed
67
68
69
70
    ("-no-cfg-constprop", Arg.Set no_cfg_constprop, "Disable CFG constprop");
    ("-no-cfg-dae", Arg.Set no_cfg_dae, "Disable CFG Dead Assign Elimination");
    ("-no-cfg-ne", Arg.Set no_cfg_ne, "Disable CFG Nop Elimination");
    ("-no-linear-dse", Arg.Set no_linear_dse, "Disable Linear Dead Store Elimination");
71
72
    ("-rig-dump", Arg.String (fun s -> rig_dump := Some s),
    "Path to output the register interference graph");
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
    ("-all-run", Arg.Unit (fun () ->
         e_run := true;
         cfg_run := true;
         cfg_run_after_cp := true;
         cfg_run_after_dae := true;
         cfg_run_after_ne := true;
         rtl_run := true;
         linear_run := true;
         linear_run_after_dse := true;
         ltl_run := true;
         riscv_run := true;
       ), "Run all intermediate languages");
    ("-heap", Arg.Set_int heapsize, "Heap size");
    ("-show", Arg.Set show, "Show Results");
    ("-m32", Arg.Unit (fun _ -> Archi.archi := A32), "32bit mode");
    ("-f", Arg.String (fun s -> input_file := Some s), "file to compile");
    ("-alloc-order-ts", Arg.Unit (fun _ -> Options.alloc_order_st := false), "Allocate t regs before s regs");
90
    ("-json", Arg.String (fun s -> output_json := s), "Output JSON summary");
91
92
93
    ("-nostart", Arg.Set nostart, "Don't output _start code.");
    ("-nostats", Arg.Set nostats, "Don't output stats.");
    ("-nomul", Arg.Unit (fun _ -> has_mul := false), "Target architecture without mul instruction.");
Wilke Pierre's avatar
Wilke Pierre committed
94
95
    ("-linux", Arg.Unit (fun _ -> target := Linux), "emit linux syscalls");
    ("-xv6", Arg.Unit (fun _ -> target := Xv6), "emit xv6 syscalls");
96
97
98
99
100
101
102
103
104
105
    ("--", Arg.Rest (fun p -> params := int_of_string p::!params), "Run parameters.")
  ]

let set_default r v suff =
  match !r with
    None -> r := Some (v ^ suff)
  | _ -> ()

let compile_rv basename asmfile () =
  if not !Options.nostart then begin
Wilke Pierre's avatar
Wilke Pierre committed
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
    let obj_file_prog = Filename.temp_file ~temp_dir:"/tmp" "" ".o" in
    let cmdas_prog = Format.sprintf "%s -I%s -o %s %s"
        (Archi.assembler ())
        (Archi.runtime_lib_include_path ())
        obj_file_prog asmfile in
    let obj_file_lib = Filename.temp_file ~temp_dir:"/tmp" "" ".o" in
    let cmdas_lib = Format.sprintf "%s -I%s -o %s %s"
        (Archi.assembler ())
        (Archi.runtime_lib_include_path ())
        obj_file_lib (Archi.runtime_lib_path ()) in
    let cmdld = Format.sprintf "%s -T %s/link.ld %s %s -o %s.exe"
        (Archi.linker ())
        Config.runtime_dir
        obj_file_prog obj_file_lib
        basename in
    Printf.printf "AS: %s\n" cmdas_prog;
    Printf.printf "AS: %s\n" cmdas_lib;
    Printf.printf "LD: %s\n" cmdld;
    let out_as_prog = cmd_to_list cmdas_prog in
    let out_as_lib = cmd_to_list cmdas_lib in
    let out_ld = cmd_to_list cmdld in
    let out = out_as_prog @ out_as_lib @ out_ld in
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
    match out with
      [] -> None
    | _ -> Some (String.concat "\n" out)
  end
  else None

let exec_rv_prog ltl basename oc rvp heapsize params =
  let rvp =
    match rvp with
      Some rvp -> rvp
    | None ->
      let f = Filename.temp_file ~temp_dir:"/tmp" basename ".s" in
      f
  in
  let error = ref None in
Wilke Pierre's avatar
Wilke Pierre committed
143
144
  dump (Some rvp) (dump_riscv_prog !Archi.target) ltl (fun file () ->
      error := compile_rv basename file ());
145
146
147
  match !error with
  | Some e -> Error ("RiscV generation error:\n" ^e)
  | None ->
Wilke Pierre's avatar
Wilke Pierre committed
148
    let l = cmd_to_list (Format.sprintf "%s \"%s.exe\" %s" (Archi.qemu ())  basename
149
150
151
152
153
154
155
156
157
158
159
                           (params |> List.map string_of_int |> String.concat " " )) in
    try
      let all_but_last = l |> List.rev |> List.tl |> List.rev in
      all_but_last |> print_list (fun oc -> Format.fprintf oc "%s") "" "\n" "" oc;
      let ret = l |> List.last |> int_of_string in
      OK (Some ret)
    with _ -> OK None


let _ =
  Arg.parse speclist (fun s -> ()) "Usage";
Wilke Pierre's avatar
Wilke Pierre committed
160
  Archi.archi := !archi;
161
162
163
164
165
166
167
168
169
  match !input_file with
  | None -> failwith "No input file specified.\n"
  | Some input ->
    add_to_report "Source" "Source" (Code (file_contents input));

    match Filename.chop_suffix_opt ".e" input with
      None -> failwith
                (Format.sprintf "File (%s) should end in .e" input)
    | Some basename ->
Wilke Pierre's avatar
Wilke Pierre committed
170
171
172
173
174
175
176
177
178
179
180
      params := List.rev !params;
      set_default riscv_dump basename ".s";
      if not !no_dump then begin
        set_default show_tokens basename ".lex";
        set_default ast_tree basename ".ast";
        set_default e_dump basename ".e.dump";
        set_default cfg_dump basename ".cfg";
        set_default rtl_dump basename ".rtl";
        set_default linear_dump basename ".linear";
        set_default rig_dump basename ".rig";
        set_default ltl_dump basename ".ltl";
181
182
      end;

183
      Printexc.record_backtrace true;
Wilke Pierre's avatar
Wilke Pierre committed
184
      let compiler_res =
185
        try
Wilke Pierre's avatar
Wilke Pierre committed
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
        pass_tokenize input >>= fun tokens ->
        pass_parse tokens >>= fun (ast, _) ->
        pass_elang ast >>= fun ep ->
        run "Elang" !e_run eval_eprog ep;
        pass_cfg_gen ep >>= fun cfg ->
        run "CFG" !cfg_run eval_cfgprog cfg;
        pass_constant_propagation cfg >>= fun cfg ->
        run "CFG after constant_propagation" !cfg_run_after_cp eval_cfgprog cfg;
        pass_dead_assign_elimination cfg >>= fun cfg ->
        run "CFG after dead_assign_elimination" !cfg_run_after_dae eval_cfgprog cfg;
        pass_nop_elimination cfg >>= fun cfg ->
        run "CFG after nop_elimination" !cfg_run_after_ne eval_cfgprog cfg;
        pass_rtl_gen cfg >>= fun rtl ->
        run "RTL" !rtl_run exec_rtl_prog rtl;
        pass_linearize rtl >>= fun (linear, lives) ->
        run "Linear" !linear_run exec_linear_prog linear;
        pass_linear_dse linear lives >>= fun linear ->
        run "Linear after DSE" !linear_run_after_dse exec_linear_prog linear;
        pass_ltl_gen linear
205
206
207
208
        with e ->
          let emsg = Printexc.to_string e ^ "\n" ^ Printexc.get_backtrace () in
          record_compile_result ~error:(Some emsg) "global";
          Error emsg
Wilke Pierre's avatar
Wilke Pierre committed
209
210
211
212
213
214
215
216
217
218
219
220
221
222
      in
      begin
        match compiler_res with
        | Error msg -> ()
        | OK ltl ->
          run "LTL" !ltl_run (exec_ltl_prog) ltl;
          (if !ltl_debug then debug_ltl_prog input ltl !heapsize !params);
          dump !riscv_dump (dump_riscv_prog !Archi.target) ltl (fun file () ->
              add_to_report "riscv" "RISC-V" (Code (file_contents file));
              ignore (compile_rv basename file ()));
          if not !Options.nostart then begin
            run "Risc-V" !riscv_run (exec_rv_prog ltl basename) !riscv_dump
          end
      end;
223
224
      dump (Some !output_json) (fun oc p ->
          Format.fprintf oc "%s\n" p
Wilke Pierre's avatar
Wilke Pierre committed
225
        ) (json_output_string ()) (fun _ () -> ());
226
      make_report input report ()