main.ml 15.1 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
38
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

39
40
open Cfg_loops

41
42
43
44
45
46
47
48
49
50
51
52
53
let tokenize file =
  Lexer_generator.tokenize_file file >>= fun tokens ->
  OK (List.map (fun tok -> (tok, None)) tokens)

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.");
54
    ("-cfg-run-after-loop", Arg.Set cfg_run_after_loop, "Run CFG program after loop optimization.");
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
    ("-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)");
    ("-all-run", Arg.Unit (fun () ->
         e_run := true;
         cfg_run := true;
73
         cfg_run_after_loop := true;
74
75
76
77
78
79
80
81
82
83
84
85
86
87
         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");
88
    ("-json", Arg.String (fun s -> output_json := s), "Output JSON summary");
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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
    ("-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.");
    ("--", Arg.Rest (fun p -> params := int_of_string p::!params), "Run parameters.")
  ]



type run_result = {
  step: string;
  retval: int option;
  output: string;
  error: string option;
}

type compile_result = {
  step: string;
  error: string option;
  data: Yojson.t
}

type result = RunRes of run_result
            | CompRes of compile_result


let results = ref []

let run step flag eval p =
  if flag then begin
    begin match eval Format.str_formatter p !heapsize !params with
      | OK v ->
        let output = Format.flush_str_formatter () in
        results := !results @ [RunRes { step ; retval = v; output; error = None}];
        add_to_report step ("Run " ^ step) (
          Paragraph 
            (
              Printf.sprintf "With parameters : [%s]<br>\n" (String.concat"," (List.map string_of_int !params))
              ^ Printf.sprintf "Mem size : %d bytes<br>\n" !heapsize
              ^ Printf.sprintf "Return value : %s<br>\n" (match v with | Some v -> string_of_int v | _ -> "none")
              ^ Printf.sprintf "Output : <pre style=\"padding: 1em; background-color: #ccc;\">%s</pre>\n" output
            )
        )
      | Error msg ->
        let output  = Format.flush_str_formatter () in
        results := !results @ [RunRes { step ; retval = None; output; error = Some msg}];
        add_to_report step ("Run " ^ step) (
          Paragraph 
            (
              Printf.sprintf "With parameters : [%s]<br>\n" (String.concat"," (List.map string_of_int !params))
              ^ Printf.sprintf "Mem size : %d bytes<br>\n" !heapsize
              ^ Printf.sprintf "Return value : none<br>\n"
              ^ Printf.sprintf "Output : <pre style=\"padding: 1em; background-color: #ccc;\">%s</pre>\n" output
              ^ Printf.sprintf "Error : <pre style=\"padding: 1em; background-color: #fcc;\">\n%s</pre>\n" msg
            )
        )

    end
  end

let record_compile_result ?error:(error=None) ?data:(data=[]) step =
  let data = if not !Options.nostats then `List data else `Null in
  results := !results @ [CompRes { step; error; data}]

let dump file dumpf p additional_command =
  begin match file with
    | None -> ()
    | Some file ->
      let oc, close = 
        if file = "-"
        then (Format.std_formatter, fun _ -> ())
        else
          let oc = open_out file in
          (Format.formatter_of_out_channel oc, fun () -> close_out oc)
      in
      dumpf oc p; close ();
      additional_command file ()
  end



let process_output_to_list2 = fun command ->
  let chan = Unix.open_process_in command in
  let res = ref ([] : string list) in
  let rec process_otl_aux () =
    let e = input_line chan in
    res := e::!res;
    process_otl_aux() in
  try process_otl_aux ()
  with End_of_file ->
    let stat = Unix.close_process_in chan in (List.rev !res,stat)

let cmd_to_list command =
  let (l,_) = process_output_to_list2 command in l

let file_contents file =
  match
    let ic = open_in file in
    let rec aux s () =
      try
        let line = input_line ic in  (* read line from in_channel and discard \n *)
        aux (s ^ line ^ "\n") ()   (* close the input channel *)
      with e ->                      (* some unexpected exception occurs *)
        close_in_noerr ic;           (* emergency closing *)
        s in
    aux "" ()
  with
  | exception Sys_error _ -> failwith (Printf.sprintf "Could not open file %s\n" file)
  | x -> x

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
    let out, _ =
      Format.sprintf
        "%s -nostdlib -nostartfiles -T %s/link.ld -o \"%s.exe\" \"%s\" %s/lib%d.s %s/mul%d.S 2>&1"
        !Archi.assembler Config.runtime_dir basename asmfile 
        Config.runtime_dir !Archi.nbits
        Config.runtime_dir !Archi.nbits
      |> process_output_to_list2 in
    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
  dump (Some rvp) dump_riscv_prog ltl (fun file () -> error := compile_rv basename file ());
  match !error with
  | Some e -> Error ("RiscV generation error:\n" ^e)
  | None ->
    let l = cmd_to_list (Format.sprintf "%s%d-static \"%s.exe\" %s" Config.qemu_path !Archi.nbits basename
                           (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 call_dot report_sectid report_secttitle file () : unit =
  if not !Options.no_dot
  then begin
    let r = Sys.command (Format.sprintf "dot -Tsvg %s -o %s.svg" file file) in
    add_to_report report_sectid report_secttitle (Img (Filename.basename file^".svg"));
    ignore r
  end

let _ =
  Arg.parse speclist (fun s -> ()) "Usage";
  init_archi !archi ();
  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 ->
      begin
        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 ltl_dump basename ".ltl";
        end;

        tokenize input >>* (fun msg ->
            record_compile_result ~error:(Some msg) "Lexing";
          ) $ fun tokens ->
            record_compile_result "Lexing";
            dump !show_tokens (fun oc tokens ->
            List.iter (fun (tok,_) ->
                Format.fprintf oc "%s\n" (string_of_symbol tok)
                  ) tokens) tokens (fun f () -> add_to_report "lexer" "Lexer" (Code (file_contents f)));
        parse tokens () >>* (fun msg ->
            record_compile_result ~error:(Some msg) "Parsing";
          ) $ fun (ast, tokens) ->
            record_compile_result "Parsing";
            dump !ast_tree draw_ast_tree ast (call_dot "ast" "AST");
            if !ast_dump then Format.printf "%s\n" (string_of_ast ast) else ();

            match make_eprog_of_ast ast with
            | Error msg -> record_compile_result ~error:(Some msg) "Elang"
            | OK  ep ->
            dump !e_dump dump_e ep (fun file () ->
                add_to_report "e" "E" (Code (file_contents file)));
            run "Elang" !e_run eval_eprog ep;

            cfg_prog_of_eprog ep >>! fun cfg ->
296
297
            record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "CFG";

298
299
300
            dump !cfg_dump dump_cfg_prog cfg (call_dot "cfg" "CFG");
            run "CFG" !cfg_run eval_cfgprog cfg;

301
302
            let cfg = optimize_loop_cfg cfg in
            record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "CFG loops";
303
            dump (!cfg_dump >*> fun s -> s ^ "0") dump_cfg_prog cfg
304
305
306
307
308
309
310
              (call_dot "cfg-after-loop" "CFG after loop optim");
            run "CFG after loop optim" !cfg_run_after_loop eval_cfgprog cfg;


            let cfg = constant_propagation cfg in
            record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "Constprop";
            dump (!cfg_dump >*> fun s -> s ^ "1") dump_cfg_prog cfg
311
312
313
314
              (call_dot "cfg-after-cstprop" "CFG after Constant Propagation");
            run "CFG after constant_propagation" !cfg_run_after_cp eval_cfgprog cfg;

            let cfg = dead_assign_elimination cfg in
315
316
            record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "DeadAssign";
            dump (!cfg_dump >*> fun s -> s ^ "2") dump_cfg_prog cfg
317
318
319
320
              (call_dot "cfg-after-dae" "CFG after DAE");
            run "CFG after dead_assign_elimination" !cfg_run_after_dae eval_cfgprog cfg;

            let cfg = nop_elimination cfg in
321
322
            record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "NopElim";
            dump (!cfg_dump >*> fun s -> s ^ "3") dump_cfg_prog cfg
323
324
325
              (call_dot "cfg-after-nop" "CFG after NOP elim");
            run "CFG after nop_elimination" !cfg_run_after_ne eval_cfgprog cfg;

326

327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
            let rtl = rtl_of_cfg cfg in
            dump !rtl_dump dump_rtl_prog rtl
              (fun file () -> add_to_report "rtl" "RTL" (Code (file_contents file)));
            run "RTL" !rtl_run exec_rtl_prog rtl;

            let linear = linear_of_rtl rtl in
            let lives = liveness_linear_prog linear in
            dump !linear_dump (fun oc -> dump_linear_prog oc (Some lives)) linear
              (fun file () -> add_to_report "linear" "Linear" (Code (file_contents file)));
            run "Linear" !linear_run exec_linear_prog linear;

            let linear = dse_prog linear lives in
            record_compile_result "DSE";
            dump (!linear_dump >*> fun s -> s ^ "1")
              (fun oc -> dump_linear_prog oc (Some lives)) linear
              (fun file () -> add_to_report "linear-after-dse" "Linear after DSE"
                  (Code (file_contents file)));
            run "Linear after DSE" !linear_run_after_dse exec_linear_prog linear;

            let ltl = ltl_prog_of_linear linear () in
            dump !ltl_dump dump_ltl_prog ltl
              (fun file () -> add_to_report "ltl" "LTL" (Code (file_contents file)));
            run "LTL" !ltl_run (exec_ltl_prog) ltl;
            (if !ltl_debug then debug_ltl_prog input ltl !heapsize !params);

352
353
354
            dump !riscv_dump dump_riscv_prog ltl (fun file () ->
                add_to_report "riscv" "RISC-V" (Code (file_contents file));
                ignore (compile_rv basename file ()));
355
356
357
358
359
360
            if not !Options.nostart then begin
              run "Risc-V" !riscv_run (exec_rv_prog ltl basename) !riscv_dump
            end;

      end;

361
      let json_output_string = 
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
        let open Yojson in
        let jstring_of_ostring o =
          match o with
          | None -> `Null
          | Some s -> `String s
        in
        let j = `List (List.map (function
            | RunRes { step; retval; output; error; } ->
              `Assoc [("runstep",`String step);
                      ("retval", match retval with Some r -> `Int r | None -> `Null);
                      ("output", `String output);
                      ("error", jstring_of_ostring error);
                     ]
            | CompRes { step; error; data } ->
              `Assoc [("compstep",`String step);
                      ("error", jstring_of_ostring error);
                      ("data", data)
                     ]
          ) !results) in
381
382
383
384
385
386
        (Yojson.pretty_to_string j) in


      dump (Some !output_json) (fun oc p ->
          Format.fprintf oc "%s\n" p
        ) json_output_string (fun _ () -> ());
387
      make_report input report ()