Re-wrote main file: added a centralized list of phases and generalized logging format + added -upto option

main.ml

@@ -3,60 +3,93 @@ 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");
+    ("expand", Expand_dims.phase, always,
+     "Expand array dimensions");
+    ("boolop", Bool_op.phase, always,
+     "Convert bool operations");
+    ("dimreduce", Dim_reduce.phase, always,
+     "Array dimension reduction");
+    ("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
         | [] -> ()
-        | h::t -> run_phases (h input) t
+        | (id, phase, cond, msg) :: tl ->
+            let output = if cond () then (
+                log_plain_line 1 (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 [
-        Load.phase;
-        Print.phase;
-        Parse.phase;
-        (*Print.phase;*)
-        Desug.phase;
-        Print.phase;
-        Context_analysis.phase;
-        (*Print.phase;*)
-        Typecheck.phase;
-        (*Print.phase;*)
-        Expand_dims.phase;
-        (*Print.phase;*)
-        Bool_op.phase;
-        (*Print.phase;*)
-        Dim_reduce.phase;
-        (*Print.phase;*)
-        Extern_vars.phase;
-        (*Print.phase;*)
-        Constant_propagation.phase;
-        Print.phase;
-        Index_analysis.phase;
-        Print.phase;
-        Assemble.phase;
-        Print.phase;
-        Peephole.phase;
-        Print.phase;
-        Output.phase;
-    ]
+    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 " " 8 ^ expand 10 id ^ ": " ^ msg ^ (upto_usage tl)
+    in
     let args_spec = [
         ("-o", Arg.String (fun s -> args.outfile <- Some s),
             "Output file (defaults to foo.s for foo.cvc)");
+
         ("-v", Arg.Int (fun i -> args.verbose <- i),
             "Set verbosity (0: nothing, 1: phase titles, 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),
+            "Stop after the specified phase, and print the intermediate " ^
+            "representation to stderr.\n        " ^
+            "Possible options are:" ^ upto_usage phases);
     ] in
+
     let usage =
         "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-nocpp] [-noopt] " ^
-        " [-v <verbosity>] [<file>]"
+        " [-v <verbosity>] [-upto <phase>] [<file>]"
     in
 
     try

phases/assemble.ml

@@ -252,8 +252,6 @@ let assemble program =
 
     instrs @ const_defs
 
-let rec phase input =
-    log_line 1 "- Assembly";
-    match input with
+let phase = function
     | Ast node -> Assembly (assemble node)
     | _ -> raise (InvalidInput "assembly")

phases/bool_op.ml

@@ -59,8 +59,6 @@ and bool_op = function
 
     | node -> transform_children bool_op node
 
-let rec phase input =
-    log_line 1 "- Convert bool operations";
-    match input with
+let phase = function
     | Ast node -> Ast (bool_op node)
     | _ -> raise (InvalidInput "bool operations")

phases/constant_propagation.ml

@@ -164,11 +164,7 @@ let rec prune_vardecs consts = function
 
 let phase = function
     | Ast node as input ->
-        if args.optimize then (
-            log_line 1 "- Constant propagation";
-            let consts = Hashtbl.create 32 in
-            let node = propagate consts node in
-            Ast (prune_vardecs consts node)
-        ) else
-            input
+        let consts = Hashtbl.create 32 in
+        let node = propagate consts node in
+        Ast (prune_vardecs consts node)
     | _ -> raise (InvalidInput "constant propagation")

phases/context_analysis.ml

@@ -161,8 +161,6 @@ let analyse_context program =
     let scope = (Hashtbl.create 20, Hashtbl.create 20) in
     analyse scope 0 program
 
-let rec phase input =
-    log_line 1 "- Context analysis";
-    match input with
+let phase = function
     | Ast node -> Ast (analyse_context node)
     | _ -> raise (InvalidInput "context analysis")

phases/desug.ml

@@ -253,8 +253,6 @@ let rec array_dims = function
 
     | node -> transform_children array_dims node
 
-let rec phase input =
-    log_line 1 "- Desugaring";
-    match input with
+let phase = function
     | Ast node -> Ast (for_to_while (array_init (var_init (array_dims node))))
     | _ -> raise (InvalidInput "desugar")

phases/dim_reduce.ml

@@ -47,8 +47,6 @@ let rec simplify_decs = function
 
     | node -> transform_children simplify_decs node
 
-let rec phase input =
-    log_line 1 "- Array dimension reduction";
-    match input with
+let phase = function
     | Ast node -> Ast (simplify_decs (dim_reduce 0 node))
     | _ -> raise (InvalidInput "dimension reduction")

phases/expand_dims.ml

@@ -35,8 +35,6 @@ let rec expand_dims = function
 
     | node -> transform_children expand_dims node
 
-let rec phase input =
-    log_line 1 "- Expand array dimensions";
-    match input with
+let phase = function
     | Ast node -> Ast (expand_dims node)
     | _ -> raise (InvalidInput "expand dimensions")

phases/extern_vars.ml

@@ -123,9 +123,7 @@ let rec replace_vars scope depth = function
 
     | node -> transform_children (replace_vars scope depth) node
 
-let rec phase input =
-    log_line 1 "- Create getters and setters for extern variables";
-    match input with
+let phase = function
     | Ast node ->
         let globals = Hashtbl.create 20 in
         let node = create_funcs globals node in

phases/index_analysis.ml

@@ -72,10 +72,8 @@ let rec strip_context = function
 
     | node -> transform_children strip_context node
 
-let rec phase input =
-    log_line 1 "- Depth analysis";
-    match input with
+let phase = function
     | Ast node ->
         let tagged = tag_index (strip_context node) in
         Ast (Context_analysis.analyse_context tagged)
-    | _ -> raise (InvalidInput "depth analysis")
+    | _ -> raise (InvalidInput "index analysis")

phases/load.ml

@@ -28,9 +28,7 @@ let input_buffered ic chunksize =
     in
     read_all (String.create chunksize) chunksize 0
 
-let phase ir =
-    log_line 2 "- Load input file";
-    match ir with
+let phase = function
     | Empty ->
         let display_name = match args.infile with
             | Some filename -> filename
@@ -50,7 +48,7 @@ let phase ir =
                     cpp_out
             in
 
-            let _ = log_line 2 "- Run C preprocessor" in
+            let _ = log_line 1 "Run C preprocessor" in
 
             (* Read preprocessed code from cpp's stdout *)
             let preprocessed = input_buffered cpp_out bufsize in

phases/output.ml

@@ -1,9 +1,7 @@
 open Types
 open Util
 
-let rec phase input =
-    log_line 1 "- Output assembly";
-    match input with
+let phase = function
     | Assembly instrs ->
         (match args.outfile with
         | Some filename ->
@@ -11,9 +9,7 @@ let rec phase input =
             Print.print_assembly oc instrs;
             close_out oc
         | None ->
-            if args.verbose >= 2 then (
-                prerr_endline "--------------------------------------------------"
-            );
+            if args.verbose >= 1 then (prerr_endline hline);
             Print.print_assembly stdout instrs
         );
         Empty

phases/parse.ml

@@ -17,9 +17,7 @@ let parse_with_error lexbuf =
     | Parser.Error ->
         raise (LocError ((shift_back lexbuf), "syntax error"))
 
-let phase input =
-    log_line 2 "- Parse input";
-    match input with
+let phase = function
     | FileContent (display_name, content) ->
         let lexbuf = Lexing.from_string content in
         lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = display_name };

phases/peephole.ml

@@ -64,19 +64,14 @@ let count_instrs instrs =
     | hd :: tl -> trav (n + 1) tl
     in trav 0 instrs
 
-let phase input =
-    match input with
-    | Assembly instrs ->
-        if args.optimize then (
-            log_line 1 "- Peephole optimization";
-            let oldcount = count_instrs instrs in
-            let instrs = peephole (strip_comments instrs) in
-            let newcount = count_instrs instrs in
-            log_line 1 (sprintf
-                "  Optimized %d to %d instructions (%d difference)"
-                oldcount newcount (newcount - oldcount)
-            );
-            Assembly instrs
-        ) else
-            input
+let phase = function
+    | Assembly instrs as input ->
+        let oldcount = count_instrs instrs in
+        let instrs = peephole (strip_comments instrs) in
+        let newcount = count_instrs instrs in
+        log_line 1 (sprintf
+            "Optimized %d to %d instructions (%d fewer)"
+            oldcount newcount (oldcount - newcount)
+        );
+        Assembly instrs
     | _ -> raise (InvalidInput "peephole")

phases/print.ml

@@ -7,9 +7,6 @@ let max_instr_width = 26
 
 let si = string_of_int
 
-let rec repeat s n = if n < 1 then "" else s ^ (repeat s (n - 1))
-let expand n text = text ^ repeat " " (n - String.length text)
-
 let ctype2str = Stringify.type2str
 let type2str = function
     | Array (t, dims) -> ctype2str t ^ repeat "," (List.length dims - 1)
@@ -161,28 +158,23 @@ let rec print_assembly oc instrs =
 
 let phase = function
     | Ast node as input ->
-        if args.verbose >= 2 then (
-            prerr_endline "--------------------------------------------------";
-            prerr_endline (node2str node);
-            prerr_endline "--------------------------------------------------"
-        );
+        prerr_endline hline;
+        prerr_endline (node2str node);
+        prerr_endline hline;
         input
 
     | FileContent (display_name, content) as input ->
-        if args.verbose >= 2 then (
-            prerr_endline "--------------------------------------------------";
-            prerr_endline (display_name ^ ":\n");
-            prerr_endline content;
-            prerr_endline "--------------------------------------------------"
-        );
+        prerr_endline hline;
+        prerr_endline (display_name ^ ":\n");
+        prerr_endline content;
+        prerr_endline hline;
         input
 
     | Assembly instrs as input ->
-        if args.verbose >= 2 then (
-            prerr_endline "--------------------------------------------------";
-            print_assembly stderr instrs;
-            prerr_endline "--------------------------------------------------"
-        );
+        prerr_endline hline;
+        print_assembly stderr instrs;
+        prerr_endline hline;
         input
 
+    | Empty -> Empty
     | _ -> raise (InvalidInput "print")

phases/typecheck.ml

@@ -210,8 +210,6 @@ let rec typecheck node =
 
     | _ -> transform_children typecheck node
 
-let rec phase input =
-    log_line 1 "- Type checking";
-    match input with
+let phase = function
     | Ast node -> Ast (typecheck node)
     | _ -> raise (InvalidInput "typecheck")

stringify.ml

@@ -137,17 +137,17 @@ and node2str node =
 
     (* Annotation nodes print more information at higher verbosity, for
      * debugging purposes *)
-    | VarLet (dec, dims, value, _) when args.verbose >= verbosity_debug ->
+    | VarLet (dec, dims, value, _) when args.verbose >= 3 ->
         "<let:" ^ node2str (Assign (nameof dec, dims, value, [])) ^ ">"
-    | VarUse (dec, dims, _)        when args.verbose >= verbosity_debug ->
+    | VarUse (dec, dims, _)        when args.verbose >= 3 ->
         "<use:" ^ node2str (Var (nameof dec, dims, [])) ^ ">"
-    | FunUse (dec, params, _)      when args.verbose >= verbosity_debug ->
+    | FunUse (dec, params, _)      when args.verbose >= 3 ->
         "<use:" ^ node2str (FunCall (nameof dec, params, [])) ^ ">"
-    | Dim (name, _)                when args.verbose >= verbosity_debug ->
+    | Dim (name, _)                when args.verbose >= 3 ->
         "<dim:" ^ name ^ ">"
-    | ArrayScalar value            when args.verbose >= verbosity_debug ->
+    | ArrayScalar value            when args.verbose >= 3 ->
         "<scalar:" ^ str value ^ ">"
-    | Arg node                     when args.verbose >= verbosity_debug ->
+    | Arg node                     when args.verbose >= 3 ->
         "<arg:" ^ str node ^ ">"
 
     | VarLet (dec, dims, value, _) ->

types.ml

@@ -141,21 +141,19 @@ type args_record = {
     mutable verbose  : int;
     mutable cpp      : bool;
     mutable optimize : bool;
+    mutable endphase : string;
 }
 
-(* Default config *)
-let verbosity_default = 2  (* TODO: set to 1 when done with debugging *)
-let verbosity_debug   = 3
-
-(* Commandline args are stored in a global struct
- * (yes, it IS dirty, but I don't know how to do this without passin [args] to
- * every function) *)
+(* Commandline args are stored in a global record
+ * (yes, it is a bit dirty, but I don't know how to do this without passin
+ * [args] to every function) *)
 let args = {
     infile   = None;
     outfile  = None;
-    verbose  = verbosity_default;
+    verbose  = 1;
     cpp      = true;
     optimize = true;
+    endphase = "";
 }
 
 (* intermediate representations between phases *)

util.ml

@@ -2,22 +2,26 @@ open Printf
 open Lexing
 open Types
 
+let rec repeat s n = if n < 1 then "" else s ^ (repeat s (n - 1))
+let expand n text = text ^ repeat " " (n - String.length text)
+
 (* Logging functions *)
 
+let hline = "-----------------------------------------------------------------"
+
 let prt_line = prerr_endline
 
 let prt_node node = prt_line (Stringify.node2str node)
 
-let log_line verbosity line =
+let log_plain_line verbosity line =
     if args.verbose >= verbosity then prt_line line
 
+let log_line verbosity line =
+    log_plain_line verbosity (repeat " " 13 ^ line)
+
 let log_node verbosity node =
     if args.verbose >= verbosity then prt_node node
 
-let dbg_line = log_line verbosity_debug
-
-let dbg_node = log_node verbosity_debug
-
 (* Variable generation *)
 let var_counter = ref 0
 let fresh_var prefix =

util.mli

@@ -1,10 +1,13 @@
+val repeat : string -> int -> string
+val expand : int -> string -> string
+
 (* Logging functions, they print to stderr and consider the verbosity flag *)
+val hline    : string
 val prt_line : string -> unit
 val prt_node : Types.node -> unit
 val log_line : int -> string -> unit
+val log_plain_line : int -> string -> unit
 val log_node : int -> Types.node -> unit
-val dbg_line : string -> unit
-val dbg_node : Types.node -> unit
 
 (* Generate a fresh variable from a given prefix, e.g. "foo" -> "foo$1"  *)
 val fresh_var : string -> string