Added a rudimentary peephole optimizer

Makefile

@@ -1,7 +1,7 @@
 RESULT := civicc
 PHASES := load parse print desug context_analysis expand_dims typecheck \
 	dim_reduce bool_op extern_vars constant_propagation depth_analysis assemble \
-	output
+	peephole output
 SOURCES := types.ml stringify.mli stringify.ml util.mli util.ml lexer.mll \
 	parser.mly $(patsubst %,phases/%.ml,$(PHASES)) main.ml
 PRE_TARGETS := types.cmi types.o stringify.cmi stringify.o util.cmi util.o

main.ml

@@ -35,10 +35,8 @@ let compile () =
         Print.phase;
         Assemble.phase;
         Print.phase;
-        (*
         Peephole.phase;
         Print.phase;
-        *)
         Output.phase;
     ]
 

phases/assemble.ml

@@ -126,11 +126,15 @@ let assemble program =
             (trav value) @ pop
 
         (* Expressions *)
-        | Const (BoolVal _ as value, _) ->
-            [LoadImm value]
+        (* Immediate values are handled here, and not in the peephole optimizer,
+         * for convenience: the indices in the constant table would be altered,
+         * so entries cannot be removed. By this early detection (also during
+         * index analysis), they are not added in the first place *)
+        | Const (value, _) when List.mem value immediate_consts ->
+            [InlineComment (LoadImm value, node2str node)]
 
         | Const (value, _) ->
-            Hashtbl.replace consts value (typeof node, indexof node);
+            Hashtbl.replace consts value (indexof node);
             let load = LoadConst (typeof node, indexof node) in
             [InlineComment (load, node2str node)]
 
@@ -237,9 +241,9 @@ let assemble program =
      * If possible, this should be rewritten in the future because it's a little
      * cumbersome right now... *)
     let pairs = ref [] in
-    let add_pair value (ctype, index) =
+    let add_pair value index =
         let com = sprintf "index %d" index in
-        pairs := (InlineComment (ConstDef (ctype, value), com), index) :: !pairs;
+        pairs := (InlineComment (ConstDef value, com), index) :: !pairs;
     in
     Hashtbl.iter add_pair consts;
     let cmp (_, i) (_, j) = compare i j in

phases/depth_analysis.ml

@@ -47,7 +47,7 @@ let tag_index program =
             nimport := !nimport + 1;
             annotate (LabelName name) (annotate (Index index) node)
 
-        | Const (value, _) ->
+        | Const (value, _) when not (List.mem value immediate_consts) ->
             let index = if Hashtbl.mem consts value then (
                 Hashtbl.find consts value
             ) else (

phases/peephole.ml

@@ -0,0 +1,49 @@
+open Types
+open Util
+
+let rec strip_comments = function
+    | Comment _ :: tl -> strip_comments tl
+    | InlineComment (EmptyLine, _) :: tl -> strip_comments tl
+    | InlineComment (instr, _) :: tl -> strip_comments (instr :: tl)
+    | hd :: tl -> hd :: (strip_comments tl)
+    | [] -> []
+
+let rec peephole = function
+    (* Constant load before branch becomes a jump when the branch condition
+     * matches the loaded value ... *)
+    | LoadImm (BoolVal b) :: Branch (cond, tgt) :: tl when cond = b ->
+        InlineComment (Jump tgt, "branch -> jump") :: (peephole tl)
+
+    (* ... otherwise, both instructions can be removed *)
+    | LoadImm (BoolVal _) :: Branch (_, tgt) :: tl ->
+        InlineComment (EmptyLine, "load + branch removed") :: peephole tl
+
+    (* Transform addition/subtraction by constant to increment/decrement:
+     * iload L          |   iload L
+     * iloadc[_ ]C      |   iloadc_1
+     * i{add,sub}       |   i{add,sub}
+     * istore L         |   istore L
+     *     |                  |
+     *     v                  v
+     * i{inc,dec} L C   |   i{inc,dec}_1 L
+     *)
+    | (Load (Int, Current, index) :: LoadImm (IntVal i) :: Op (Add, Int) ::
+            Store (Int, Current, store) :: tl
+    |  LoadImm (IntVal i) :: Load (Int, Current, index) :: Op (Add, Int) ::
+            Store (Int, Current, store) :: tl) when store = index ->
+        InlineComment (Inc (index, i), "add -> inc") :: (peephole tl)
+
+    | (Load (Int, Current, index) :: LoadImm (IntVal i) :: Op (Sub, Int) ::
+            Store (Int, Current, store) :: tl
+    |  LoadImm (IntVal i) :: Load (Int, Current, index) :: Op (Sub, Int) ::
+            Store (Int, Current, store) :: tl) when store = index ->
+        InlineComment (Dec (index, i), "sub -> dec") :: (peephole tl)
+
+    | hd :: tl -> hd :: (peephole tl)
+    | [] -> []
+
+let rec phase input =
+    log_line 1 "- Peephole optimization";
+    match input with
+    | Assembly instrs -> Assembly (peephole (strip_comments instrs))
+    | _ -> raise (InvalidInput "peephole")

phases/print.ml

@@ -67,8 +67,8 @@ let rec instr2str = function
         ".import \"" ^ name ^ "\" " ^ (String.concat " " types)
     | Global ctype ->
         ".global " ^ (type2str ctype)
-    | ConstDef (ctype, value) ->
-        ".const " ^ type2str ctype ^ " " ^ const2str value
+    | ConstDef value ->
+        ".const " ^ type2str (const_type value) ^ " " ^ const2str value
 
     (* Store *)
     | Store (ctype, scope, index) ->
@@ -93,6 +93,10 @@ let rec instr2str = function
         tab ^ prefix ctype ^ op2str op
     | Convert (src, tgt) ->
         tab ^ prefix src ^ "2" ^ prefix tgt
+    | Inc (index, const) ->
+        tab ^ "iinc " ^ si index ^ " " ^ si const
+    | Dec (index, const) ->
+        tab ^ "idec " ^ si index ^ " " ^ si const
 
     (* Control flow *)
     | RtnInit scope ->

test/old/peephole.cvc

@@ -0,0 +1,17 @@
+extern void printInt(int val);
+
+export int main() {
+    int a;
+    int b;
+    a = a + 1;  // inc
+    a = a - 1;  // dec
+    b = a + 1;  // NOT inc because not stored in a
+
+    if (true)   // branch is removed
+        a = 2;
+
+    if (false)  // branch is replaced by jump
+        a = 3;
+
+    return 0;
+}

types.ml

@@ -87,7 +87,7 @@ type instr =
     (* .import "<name>" <ret_type> [ <arg_type>; ... ] *)
     | Import of string * ctype * ctype list
     (* .const <value> *)
-    | ConstDef of ctype * const
+    | ConstDef of const
     (* .global <type> *)
     | Global of ctype
 
@@ -97,8 +97,11 @@ type instr =
     | LoadConst of ctype * int           (* [ifb]loadc C *)
     | LoadImm of const                   (* [ifb]load_[01tf] <value> *)
 
+    (* Operators *)
     | Op of operator * ctype             (* [ifb]() *)
     | Convert of ctype * ctype           (* i2f|f2i *)
+    | Inc of int * int                   (* iinc L C *)
+    | Dec of int * int                   (* idec L C *)
 
     (* Control flow *)
     | RtnInit of stack_scope
@@ -108,10 +111,6 @@ type instr =
     | Branch of bool * string
     | Jump of string
 
-    (* Instructions *)
-    | Inc of int * int                   (* iinc L C *)
-    | Dec of int * int                   (* idec L C *)
-
     (* Stack management *)
     | Pop of ctype                       (* [ifb]pop *)
 
@@ -123,6 +122,16 @@ type instr =
     | EmptyLine
     | DummyInstr
 
+let immediate_consts = [
+    BoolVal true;
+    BoolVal false;
+    IntVal (-1);
+    IntVal 0;
+    IntVal 1;
+    FloatVal 0.0;
+    FloatVal 1.0;
+]
+
 (* Container for command-line arguments *)
 type args_record = {
     mutable infile   : string option;

util.ml

@@ -307,6 +307,11 @@ let labelof node =
          | _ :: tl              -> trav tl
      in trav (annof node)
 
+let const_type = function
+    | BoolVal _  -> Bool
+    | IntVal _   -> Int
+    | FloatVal _ -> Float
+
 let prerr_loc (fname, ystart, yend, xstart, xend) =
     let file = open_in fname in
 

util.mli

@@ -31,6 +31,8 @@ val indexof : Types.node -> int
 val typeof  : Types.node -> Types.ctype
 val labelof : Types.node -> string
 
+val const_type : Types.const -> Types.ctype
+
 (* Print file location to stderr *)
 val prerr_loc : Types.location -> unit