civicaml/main.ml

open Printf
open Lexing
open Types
open Util

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

let phases = [
    ("load", Load.phase, always,
     "Load input file");
    ("parse", Parse.phase, always,
     "Parse input");
    ("desug", Desug.phase, always,
     "Desugaring");
    ("context", Context_analysis.phase, always,
     "Context analysis");
    ("typecheck", Typecheck.phase, always,
     "Type checking");
    ("dimreduce", Dim_reduce.phase, always,
     "Array dimension reduction");
    ("boolop", Bool_op.phase, always,
     "Convert bool operations");
    ("extern", Extern_vars.phase, always,
     "Create getters and setters for extern variables");
    ("constant", Constant_propagation.phase, when_optimize,
     "Constant propagation");
    ("index", Index_analysis.phase, always,
     "Index analysis");
    ("assemble", Assemble.phase, always,
     "Assembly");
    ("peephole", Peephole.phase, when_optimize,
     "Peephole optimization");
    ("output", Output.phase, always,
     "Output assembly");
]

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

(* Main function, returns exit status
 * Command-line arguments are stored in Util.args
 * () -> int *)
let main () =
    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 -> args.outfile <- Some s),
             "<file> Output file (defaults to foo.s for foo.cvc)");

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

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

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

        ("-upto", Arg.String (fun s -> 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

    try
        try
            Arg.parse args_spec (fun s -> args.infile <- Some s) usage;
            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 ())