Did some refactoring on main module and tweaked output options

main.ml

@@ -6,108 +6,132 @@ 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");
-  ("constprop", Constprop.phase, when_optimize,
-   "Constant propagation");
-  ("unroll", Unroll.phase, when_optimize,
-   "Loop unrolling");
-  ("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)
+  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 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 stdout)");
+  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 ^ "\""))
 
-    ("-v", Arg.Int (fun i -> Globals.args.verbose <- i),
-         "<num>  Set verbosity (0: nothing, 1: errors, 2: intermediate, 3: debug)");
+    | "-h" :: _ ->
+      prerr_string usage;
+      exit 0
 
-    ("-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)");
+    | "-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
 
-    ("-noopt", Arg.Unit (fun _ -> Globals.args.optimize <- false),
-             "   Disable optimization");
-    ("-opt", Arg.Unit (fun _ -> Globals.args.optimize <- true),
-           "     Enable optimization (overwrite earlier -noopt)");
+  try
+    handle (List.tl (Array.to_list Sys.argv))
+  with Failure msg ->
+    prerr_endline msg;
+    prerr_string usage;
+    exit 1
 
-    ("-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
+(* Main function, returns exit status
+ * Command-line arguments are stored in Globals.args *)
+let () =
+  parse_args ();
 
-  let usage =
-    "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-nocpp] [-noopt] \
-     [-v <verbosity>] [-upto <phase>] [<file>]"
+  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
 
-  Arg.parse args_spec (fun s -> Globals.args.infile <- Some s) usage
+  let always = true in
+  let when_opt = Globals.args.optimize in
 
-(* 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
+  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
-  run_phases Empty phases
 
-(* Main function, returns exit status
- * Command-line arguments are stored in lobals.args *)
-let main () =
   try
-    parse_args ();
-    compile ();
-    0
+    Some Empty
+    |> run_phase always   Load.phase      "Load input file and run C preprocessor"
+    |> 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 and folding"
+    |> 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 code generation"
+    |> 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;
-    1
-
-let _ = exit (main ())
+    exit 1

main.mli

@@ -1,20 +1,10 @@
 (** Main module, parses command-line arguments and cycles through phases. *)
-(** [Pervasives.exit (]{!main} [())] is executed at the bottom of the file. *)
+(** Command-line arguments are first parsed and the result saved them in
+    {!Globals.args}. Then all phases are executed successively. Run
+    [./civicc -help] in a terminal to see the available command-line options.
+    Exceptions defined in {!Types} are caught and error messages printed
+    accordingly. *)
 
 (** Main function of a phase. Each phase exports a function of this signature
     that is called by the {!main}. *)
 type phase_func = Types.intermediate -> Types.intermediate
-
-(** List of all phases as
-    [(identifier, phase_function, condition, description)]. [identifier] is used
-    for the [-upto] command-line argument, which is saved in
-    {!Globals.args}[.endphase]. [description] is used for logging, and for the
-    usage message of [-upto]. *)
-val phases : (string * phase_func * (unit -> bool) * string) list
-
-(** Main function, returns exit status. Parses command-line arguments, saving
-    them in {!Globals.args}. Then all phases are executed successively. Run
-    [./civicc -help] in a terminal to see the available command-line options.
-    This function catches the exceptions defined in {!Types}, and prints error
-    messages accordingly. In case of error, 1 is returned, otherwise 0. *)
-val main : unit -> int

phases/constprop.ml

@@ -204,11 +204,9 @@ let rec prune_vardecs consts = function
   | VarDec (_, name, _, _) when Hashtbl.mem consts name -> DummyNode
   | node -> traverse_unit (prune_vardecs consts) node
 
-let propagate_consts node =
+let phase = function
+  | Ast node ->
     let consts = Hashtbl.create 32 in
     let node = propagate consts node in
-    prune_vardecs consts node
-
-let phase = function
-  | Ast node -> Ast (propagate_consts node)
+    Ast (prune_vardecs consts node)
   | _ -> raise InvalidInput

phases/constprop.mli

@@ -80,8 +80,5 @@ Constant propagation reduces this to:
 \} v}
     *)
 
-(** Constant propagation traversal. Exported for use in {!Unroll}. *)
-val propagate_consts : Types.node -> Types.node
-
 (** Main phase function, called by {!Main}. Calls {!propagate_consts}. *)
 val phase : Main.phase_func

phases/context.ml

@@ -99,8 +99,7 @@ let rec analyse scope depth node err =
     | _ -> traverse_unit collect node
   in
 
-  let rec traverse scope depth node =
-    match node with
+  let rec traverse scope depth = function
     (* Increase nesting level when entering function *)
     | FunDef (export, ret_type, name, params, body, ann) ->
       let vars, funs = scope in
@@ -122,18 +121,18 @@ let rec analyse scope depth node err =
       add_to_scope (Varname name) node depth scope;
       node
 
-    | VarDec _ -> node
+    | VarDec _ as node -> node
 
-    | Param (_, name, _) ->
+    | Param (_, name, _) as node ->
       let node = annotate (Depth depth) node in
       add_to_scope (Varname name) node depth scope;
       node
 
     (* Do not traverse into external function declarations, since their
      * parameters must not be added to the namespace *)
-    | FunDec _ -> node
+    | FunDec _ as node -> node
 
-    | _ -> traverse_unit (traverse scope depth) node
+    | node  -> traverse_unit (traverse scope depth) node
   in
 
   (*
@@ -145,10 +144,7 @@ let rec analyse scope depth node err =
    * void foo() { glob = 1; }
    * int glob;
    *)
-  let node = collect node in
-
-  let node = traverse scope depth node in
-  node
+  collect node |> traverse scope depth
 
 let analyse_context program =
   let scope = (Hashtbl.create 20, Hashtbl.create 20) in

phases/output.ml

@@ -9,7 +9,6 @@ let phase = function
       Print.print_assembly oc instrs;
       close_out oc
     | None ->
-      if Globals.args.verbose > 1 then prerr_endline hline;
       Print.print_assembly stdout instrs
     end;
     Empty

phases/print.ml

@@ -46,9 +46,9 @@ let rtn_suffix = function
 let rec instr2str = function
   (* Global / directives *)
   | Comment comment ->
-    if Globals.args.verbose >= 2 then "; " ^ comment else ""
+    if Globals.args.verbose >= 1 then "; " ^ comment else ""
   | InlineComment (instr, comment) ->
-    if Globals.args.verbose >= 2 then
+    if Globals.args.verbose >= 1 then
       expand max_instr_width (instr2str instr) ^ " ; " ^ comment
     else
       instr2str instr

phases/unroll.ml

@@ -84,7 +84,5 @@ let rec prune_vardecs counters = function
 let phase = function
   | Ast node ->
     let counters = Hashtbl.create 10 in
-    let node = unroll counters node in
-    let node = prune_vardecs counters node in
-    Ast (Constprop.propagate_consts node)
+    Ast (unroll counters node |> prune_vardecs counters)
   | _ -> raise InvalidInput

util.ml

@@ -19,7 +19,7 @@ let log_plain_line verbosity line =
   if Globals.args.verbose >= verbosity then prerr_endline line
 
 let log_line verbosity line =
-  log_plain_line verbosity (repeat " " 13 ^ line)
+  log_plain_line verbosity ("  " ^ line)
 
 let log_node verbosity node =
   if Globals.args.verbose >= verbosity then prt_node node