civicaml/main.ml

open Printf
open Lexing
open Types
open Util

(* For some reason OCaml wants me to redefine this type's implementation -.- *)
type phase_func = Types.intermediate -> Types.intermediate

(* Parse command-line arguments *)
let parse_args () =
  let usage =
"Usage: " ^ Sys.argv.(0) ^ " \
[-h] [-o <file>] [-v <verbosity>] [-nocpp] [-noopt] [-upto <phase>] [<file>]
-h            Display this help message
-o <file>     Optional output file (defaults to stdout)
-v <num>      Set verbosity: 0: nothing, 1: errors (default), 2: intermediate, 3: debug
-nocpp        Disable C preprocessor
-noopt        Disable optimization phases (constprop, unroll, peephole)
-upto <phase> Stop after the specified phase, and print the intermediate
              representation to stderr.
              Possible options are (in order of execution):
                load      : Load input file and run C preprocessor
                parse     : Parse input
                desug     : Desugaring
                context   : Context analysis
                typecheck : Type checking
                dimreduce : Array dimension reduction
                boolop    : Convert boolean operations
                constprop : Constant propagation and folding
                unroll    : Loop unrolling
                assemble  : Assembly code generation
                peephole  : Peephole optimization
<file>        Optional input file (default is to read from stdin)
"
  in

  let rec handle = function
    | [("-v" | "-o" | "-upto") as arg] ->
      raise (Failure ("missing argument value for \"" ^ arg ^ "\""))
    | ("-v" | "-o" | "-upto") as arg :: next :: _ when next.[0] = '-' ->
      raise (Failure ("missing argument value for \"" ^ arg ^ "\""))

    | "-h" :: _ ->
      prerr_string usage;
      exit 0

    | "-v" :: num :: tl ->
      begin
        try
          Globals.args.verbose <- int_of_string num;
          handle tl
        with Failure "int_of_string" ->
          raise (Failure ("invalid verbosity level"))
      end
    | "-o" :: filename :: tl ->
      Globals.args.outfile <- Some filename;
      handle tl
    | "-nocpp" :: tl ->
      Globals.args.cpp <- false;
      handle tl
    | "-noopt" :: tl ->
      Globals.args.optimize <- false;
      handle tl
    | "-upto" :: id :: tl ->
      Globals.args.endphase <- id;
      handle tl
    | arg :: tl when arg.[0] = '-' ->
      raise (Failure ("unknown option \"" ^ arg ^ "\""))
    | filename :: tl ->
      Globals.args.infile <- Some filename;
      handle tl
    | [] -> ()
  in

  try
    handle (List.tl (Array.to_list Sys.argv))
  with Failure msg ->
    prerr_endline msg;
    prerr_string usage;
    exit 1

(* Main function, returns exit status
 * Command-line arguments are stored in Globals.args *)
let () =
  parse_args ();

  let run_phase condition phase msg = function
    | Some input when condition ->
      if String.length msg > 0 then log_plain_line 2 ("- " ^ msg);
      Some (phase input)
    | value -> value
  in

  let always = true in
  let when_opt = Globals.args.optimize in

  let print_ir condition only_if_endphase id = function
    | Some input when id = Globals.args.endphase ->
      ignore (Print.phase input);
      None
    | Some input when condition && not only_if_endphase && Globals.args.verbose >= 2 ->
      ignore (Print.phase input);
      Some input
    | value -> value
  in

  try
    Some Empty
    |> run_phase always   Load.phase      "Load input file"
    |> print_ir  always   false           "load"
    |> run_phase always   Parse.phase     "Parse input"
    |> print_ir  always   false           "parse"
    |> run_phase always   Desug.phase     "Desugaring"
    |> print_ir  always   false           "desug"
    |> run_phase always   Context.phase   "Context analysis"
    |> print_ir  always   true            "context"
    |> run_phase always   Typecheck.phase "Type checking"
    |> print_ir  always   true            "typecheck"
    |> run_phase always   Dimreduce.phase "Array dimension reduction"
    |> print_ir  always   false           "dimreduce"
    |> run_phase always   Boolop.phase    "Convert boolean operations"
    |> print_ir  always   false           "boolop"
    |> run_phase when_opt Constprop.phase "Constant propagation"
    |> print_ir  when_opt false           "constprop"
    |> run_phase when_opt Unroll.phase    "Loop unrolling"
    |> run_phase when_opt Constprop.phase ""
    |> print_ir  when_opt false           "unroll"
    |> run_phase always   Index.phase     ""
    |> run_phase always   Assemble.phase  "Assembly"
    |> print_ir  always   false           "assemble"
    |> run_phase when_opt Peephole.phase  "Peephole optimization"
    |> print_ir  when_opt false           "peephole"
    |> run_phase always   Output.phase    ""
    |> ignore
  with FatalError err ->
    print_error err;
    exit 1