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

let always _ = true
let when_optimize _ = Globals.args.optimize

(* List of all phases, which will be executed in the order defined here. *)
let phases = [
  ("load", Load.phase, always,
   "Load input file");
  ("parse", Parse.phase, always,
   "Parse input");
  ("desug", Desug.phase, always,
   "Desugaring");
  ("context", Context.phase, always,
   "Context analysis");
  ("typecheck", Typecheck.phase, always,
   "Type checking");
  ("dimreduce", Dimreduce.phase, always,
   "Array dimension reduction");
  ("boolop", Boolop.phase, always,
   "Convert bool operations");
  ("extern", Extern.phase, always,
   "Create getters and setters for extern variables");
  ("constprop", Constprop.phase, when_optimize,
   "Constant propagation");
  ("index", Index.phase, always,
   "Index analysis");
  ("assemble", Assemble.phase, always,
   "Assembly");
  ("peephole", Peephole.phase, when_optimize,
   "Peephole optimization");
  ("output", Output.phase, always,
   "Output assembly");
]

(* Parse command-line arguments *)
let parse_args () =
  let rec upto_usage = function
    | [] -> ""
    | (id, _, _, msg) :: tl ->
      "\n" ^ repeat " " 12 ^ expand 10 id ^ ": " ^ msg ^ (upto_usage tl)
  in
  let args_spec = [
    ("<file>", Arg.Rest (fun s -> ()),
             "   Optional input file (default is to read from stdin)");

    ("-o", Arg.String (fun s -> Globals.args.outfile <- Some s),
         "<file> Output file (defaults to foo.s for foo.cvc)");

    ("-v", Arg.Int (fun i -> Globals.args.verbose <- i),
         "<num>  Set verbosity (0: nothing, 1: errors, 2: intermediate, 3: debug)");

    ("-nocpp", Arg.Unit (fun _ -> Globals.args.cpp <- false),
             "   Disable C preprocessor");
    ("-cpp", Arg.Unit (fun _ -> Globals.args.cpp <- true),
           "     Enable C preprocessor (overwrite earlier -nocpp)");

    ("-noopt", Arg.Unit (fun _ -> Globals.args.optimize <- false),
             "   Disable optimization");
    ("-opt", Arg.Unit (fun _ -> Globals.args.optimize <- true),
           "     Enable optimization (overwrite earlier -nocpp)");

    ("-upto", Arg.String (fun s -> Globals.args.endphase <- s),
            "<phase> Stop after the specified phase, and print the intermediate \
             representation to stderr.\n        \
             Possible options are (in order of execution):" ^ upto_usage phases);
  ] in

  let usage =
    "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-nocpp] [-noopt] \
     [-v <verbosity>] [-upto <phase>] [<file>]"
  in

  Arg.parse args_spec (fun s -> Globals.args.infile <- Some s) usage

(* Compile CVC file to assembly code *)
let compile () =
  let rec run_phases input = function
    | [] -> ()
    | (id, phase, cond, msg) :: tl ->
      let output =
        if cond () then begin
          log_plain_line 2 (expand 13 ("- " ^ id ^ ":") ^ msg);
          let output = phase input in
          if id = Globals.args.endphase || Globals.args.verbose >= 2 then begin
            ignore (Print.phase output)
          end;
          output
        end else
          input
      in
      if id = Globals.args.endphase then () else run_phases output tl
  in
  run_phases Empty phases

(* Main function, returns exit status
 * Command-line arguments are stored in lobals.args *)
let main () =
  try
    try
      parse_args ();
      compile ();
      0
    with
    (*| InvalidNode ->
      raise (CompileError "invalid node")*)
    | InvalidInput name ->
      raise (CompileError ("invalid input for phase \"" ^ name ^ "\""))
    | NodeError (node, msg) ->
      (* If no location is given, just stringify the node to at least give
       * some information *)
      let msg = if locof node = noloc then
        msg ^ "\nnode: " ^ Stringify.node2str node
      else msg in
      raise (LocError (locof node, msg))
  with
  | CompileError msg ->
    eprintf "Error: %s\n" msg;
    1
  | LocError (loc, msg) ->
    prerr_loc_msg loc ("Error: " ^ msg);
    1
  | EmptyError ->
    1

let _ = exit (main ())