Implemented a bunch of optimizatons

Makefile

@@ -2,7 +2,7 @@ LD := gcc
 CC := clang
 CFLAGS := -O3
 LDFLAGS := -nostartfiles
-BFFLAGS :=
+BFFLAGS := -o
 BFILES := $(patsubst %.b,%,$(wildcard *.b))
 
 .PHONY: check clean

bf.ml

@@ -2,26 +2,25 @@ open Llvm
 
 type program = command list
 and command =
-  | Incptr | Decptr
-  | Incdata | Decdata
-  | Output | Input
+  | Shift of int
+  | Goto of int
+  | Add of int
+  | Set of int
+  | Out | In
   | Loop of program
-  | Addptr of int
-  | Adddata of int
-  | Setptr of int
-  | Setdata of int
-
+  | Offset of int * command
+  | Mul of int * int
 
 let read_program ic =
   let rec next cur stack =
     try
       match input_char ic, stack with
-      | '>', _ -> next (Incptr :: cur) stack
-      | '<', _ -> next (Decptr :: cur) stack
-      | '+', _ -> next (Incdata :: cur) stack
-      | '-', _ -> next (Decdata :: cur) stack
-      | '.', _ -> next (Output :: cur) stack
-      | ',', _ -> next (Input :: cur) stack
+      | '>', _ -> next (Shift 1 :: cur) stack
+      | '<', _ -> next (Shift (-1) :: cur) stack
+      | '+', _ -> next (Add 1 :: cur) stack
+      | '-', _ -> next (Add (-1) :: cur) stack
+      | '.', _ -> next (Out :: cur) stack
+      | ',', _ -> next (In :: cur) stack
       | '[', _ -> next [] (cur :: stack)
       | ']', [] -> failwith "unmatched ']'"
       | ']', (hd :: tl) -> next (Loop (List.rev cur) :: hd) tl
@@ -39,22 +38,24 @@ let rec string_of_program program =
   in
   cat "" program
 and string_of_command = function
-  | Incptr  -> ">"
-  | Decptr  -> "<"
-  | Incdata -> "+"
-  | Decdata -> "-"
-  | Output  -> "."
-  | Input   -> ","
-  | Loop p  -> "[" ^ string_of_program p ^ "]"
-
-  | Addptr n when n < 0  -> "(<" ^ string_of_int (-n) ^ ")"
-  | Addptr n             -> "(>" ^ string_of_int n ^ ")"
-  | Adddata n when n < 0 -> "(" ^ string_of_int n ^ ")"
-  | Adddata n            -> "(+" ^ string_of_int n ^ ")"
-  | Setptr n             -> "(<>" ^ string_of_int n ^ ")"
-  | Setdata n            -> "(=" ^ string_of_int n ^ ")"
-
-let compile memsize program =
+  | Shift 1            -> ">"
+  | Shift -1           -> "<"
+  | Shift n when n < 0 -> "(<" ^ string_of_int (-n) ^ ")"
+  | Shift n            -> "(+" ^ string_of_int n ^ ")"
+  | Goto n             -> "(_" ^ string_of_int n ^ ")"
+  | Add 1              -> "+"
+  | Add -1             -> "-"
+  | Add n when n < 0   -> "(-" ^ string_of_int (-n) ^ ")"
+  | Add n              -> "(+" ^ string_of_int n ^ ")"
+  | Set n              -> "(=" ^ string_of_int n ^ ")"
+  | Mul (x, y)         -> "(>" ^ string_of_int x ^ "*" ^ string_of_int y ^ ")"
+  | Out                -> "."
+  | In                 -> ","
+  | Loop p             -> "[" ^ string_of_program p ^ "]"
+  | Offset (o, cmd) ->
+    "(" ^ string_of_int o ^ ":" ^ string_of_command cmd ^ ")"
+
+let compile_llvm memsize program =
   let ctx = global_context () in
   let m = create_module ctx "brainfucker" in
 
@@ -89,25 +90,29 @@ let compile memsize program =
   let mem = build_alloca (array_type byte_ty memsize) "mem" b in
   let ptr = build_alloca byteptr_ty "ptr" b in
 
-  set_alignment 2 mem;
-
   let load p = build_load p "" b in
   let store p value = ignore (build_store value p b) in
   let gep n = build_in_bounds_gep (load ptr) [|i32 n|] "" b in
 
   let rec compile_command = function
-    | Incptr ->
-      store ptr (gep 1)
-    | Decptr ->
-      store ptr (gep (-1))
-    | Incdata ->
-      build_add (load (gep 0)) (i8 1) "" b |> store (gep 0)
-    | Decdata ->
-      build_sub (load (gep 0)) (i8 1) "" b |> store (gep 0)
-    | Output ->
-      build_call putchar [|load (gep 0)|] "" b |> ignore
-    | Input ->
-      build_call getchar [||] "" b |> store (gep 0)
+    | Shift n ->
+      store ptr (gep n)
+    | Goto n ->
+      let memptr = build_in_bounds_gep mem [|i32 0; i32 n|] "" b in
+      build_bitcast memptr byteptr_ty "" b |> store ptr
+    | Offset (o, Add n) ->
+      build_add (load (gep o)) (i8 n) "" b |> store (gep o)
+    | Offset (o, Set n) ->
+      store (gep o) (i8 n)
+    | Offset (o, Out) ->
+      build_call putchar [|load (gep o)|] "" b |> ignore
+    | Offset (o, In) ->
+      build_call getchar [||] "" b |> store (gep o)
+    | Offset (o, Mul (x, y)) ->
+      let mul = build_mul (load (gep (o + x))) (i8 y) "" b in
+      build_add (load (gep o)) mul "" b |> store (gep o)
+    | (Add _ | Set _ | Out | In | Mul _) as cmd ->
+      compile_command (Offset (0, cmd))
     | Loop p ->
       let bb_end = append_block ctx "" f in
       move_block_after !bb_cur bb_end;
@@ -124,15 +129,8 @@ let compile memsize program =
       build_br bb_cond b |> ignore;
 
       set_cur_bb bb_end
-    | Addptr n ->
-      store ptr (gep n)
-    | Adddata n ->
-      build_add (load (gep 0)) (i8 n) "" b |> store (gep 0)
-    | Setptr n ->
-      let memptr = build_in_bounds_gep mem [|i32 0; i32 n|] "" b in
-      build_bitcast memptr byteptr_ty "" b |> store ptr
-    | Setdata n ->
-      store (gep 0) (i8 n)
+    | cmd ->
+      failwith ("cannot compile: " ^ string_of_command cmd)
   in
 
   (* zero-initialize memory (use intrinsic for optimization assumptions) *)
@@ -149,66 +147,120 @@ let compile memsize program =
   build_ret_void b |> ignore;
   m
 
-let compile_to_c memsize program =
+let compile_c memsize program =
   let indent = Str.global_replace (Str.regexp "^\\(.\\)") "    \\1" in
+  let ptr o = "p[" ^ string_of_int o ^ "]" in
+  let add = function
+    | 1            -> "++"
+    | -1           -> "--"
+    | n when n < 0 -> " -= " ^ string_of_int (-n)
+    | n            -> " += " ^ string_of_int n
+  in
   let rec compile_commands buf = function
     | [] -> buf
     | cmd :: tl -> compile_commands (buf ^ compile_command cmd ^ "\n") tl
+  and compile_offset o = function
+    | Shift n     -> "p" ^ add n
+    | Add n       -> ptr o ^ add n
+    | Goto 0      -> "p = mem"
+    | Goto n      -> "p = mem + " ^ string_of_int n
+    | Set n       -> ptr o ^ " = " ^ string_of_int n
+    | Out         -> "putchar(" ^ ptr o ^ ")"
+    | In          -> ptr o ^ " = getchar()"
+    | Mul (x, 1)  -> ptr o ^ " += " ^ ptr (o + x)
+    | Mul (x, -1) -> ptr o ^ " -= " ^ ptr (o + x)
+    | Mul (x, y)  -> ptr o ^ " += " ^ ptr (o + x) ^ " * " ^ string_of_int y
+    | cmd         -> failwith "cannot offset command: " ^ string_of_command cmd
   and compile_command = function
-    | Incptr    -> "++ptr;"
-    | Decptr    -> "--ptr;"
-    | Incdata   -> "++*ptr;"
-    | Decdata   -> "--*ptr;"
-    | Output    -> "putchar(*ptr);"
-    | Input     -> "*ptr = getchar();"
-    | Loop p    -> "while (*ptr) {\n" ^ indent (compile_commands "" p) ^ "}"
-    | Addptr n  -> "ptr += " ^ string_of_int n ^ ";"
-    | Adddata n -> "*ptr += " ^ string_of_int n ^ ";"
-    | Setptr n  -> "ptr = " ^ string_of_int n ^ ";"
-    | Setdata n -> "*ptr = " ^ string_of_int n ^ ";"
+    | Loop p          -> "while (*p != 0) {\n" ^ indent (compile_commands "" p) ^ "}"
+    | Offset (o, cmd) -> compile_offset o cmd ^ ";"
+    | cmd             -> compile_offset 0 cmd ^ ";"
   in
   "#include <stdio.h>\n" ^
   "#include <stdlib.h>\n" ^
   "void _start() {\n" ^
   "    unsigned char mem[" ^ string_of_int memsize ^ "] = {};\n" ^
-  "    unsigned char *ptr = mem;\n" ^
+  "    unsigned char *p = mem;\n" ^
        indent (compile_commands "" program) ^
   "    exit(0);\n" ^
   "}\n"
 
-let rec optimize program =
+let optimize program =
+  let opt_loop p =
+    let rec next buf counter_found = function
+      | Add -1 :: tl when not counter_found ->
+        next buf true tl
+      | Offset (o, Add n) :: tl ->
+        next (Offset (o, Mul (-o, n)) :: buf) counter_found tl
+      | [] when counter_found ->
+        List.rev (Offset (0, Set 0) :: buf)
+      | _ ->
+        [Loop p]
+    in
+    next [] false p
+  in
+  let can_offset = function
+    | Add _ | Set _ | Out | In | Mul _ -> true
+    | _ -> false
+  in
   let rec opt = function
-    | Incptr :: tl -> opt (Addptr 1 :: tl)
-    | Decptr :: tl -> opt (Addptr (-1) :: tl)
-    | Incdata :: tl -> opt (Adddata 1 :: tl)
-    | Decdata :: tl -> opt (Adddata (-1) :: tl)
+    | Shift a :: Shift b :: tl ->
+      Shift (a + b) :: tl |> opt
+    | Add a :: Add b :: tl ->
+      Add (a + b) :: tl |> opt
+
+    | Set 0 :: Loop _ :: tl ->
+      Set 0 :: tl |> opt
+
+    | Goto a :: Shift b :: tl ->
+      Goto (a + b) :: tl |> opt
+    | Set a :: Add b :: tl ->
+      Set (a + b) :: tl |> opt
+
+    | (Shift 0 | Add 0) :: tl
+    | (Shift _ | Goto _) :: (Goto _ :: _ as tl)
+    | (Add _ | Set _) :: (Set _ :: _ as tl) ->
+      opt tl
+
+    | Goto o :: cmd :: tl when can_offset cmd ->
+      Offset (o, cmd) :: Goto o :: tl |> opt
+    | Shift o :: cmd :: tl when can_offset cmd ->
+      Offset (o, cmd) :: Shift o :: tl |> opt
+
+    | Offset (a, Offset (b, cmd)) :: tl ->
+      Offset (a + b, cmd) :: tl |> opt
+    | Offset (0, cmd) :: tl ->
+      cmd :: tl |> opt
+
+    | Offset (i, a) :: Offset (j, b) :: tl when i = j ->
+      begin match opt [a; b] with
+      | [cmd] -> Offset (i, cmd) :: tl |> opt
+      | _ -> Offset (i, a) :: opt (Offset (j, b) :: tl)
+      end
+
+    | Shift i :: Offset (j, cmd) :: tl ->
+      Offset (i + j, cmd) :: Shift i :: tl |> opt
 
-    | Addptr a :: Addptr b :: tl -> opt (Addptr (a + b) :: tl)
-    | Adddata a :: Adddata b :: tl -> opt (Adddata (a + b) :: tl)
+    | Shift i :: cmd :: tl when can_offset cmd ->
+      Offset (i, cmd) :: Shift i :: tl |> opt
 
-    | Loop [Addptr -1] :: tl -> opt (Setptr 0 :: tl)
-    | Loop [Adddata (1 | -1)] :: tl -> opt (Setdata 0 :: tl)
+    | Loop [Add (1 | -1)] :: tl ->
+      Set 0 :: tl |> opt
 
-    | (Addptr 0 | Adddata 0) :: tl
-    | (Addptr _ | Setptr _) :: (Setptr _ :: _ as tl)
-    | (Adddata _ | Setdata _) :: (Setdata _ :: _ as tl) -> opt tl
+    | Loop p :: tl ->
+      begin match opt_loop (check_change p) with
+      | [Loop _ as loop] -> loop :: opt tl
+      | replacement -> opt (replacement @ tl)
+      end
 
-    | Loop p :: tl -> Loop (optimize p) :: opt tl
     | hd :: tl -> hd :: opt tl
     | [] -> []
+  and check_change program =
+    match opt program with
+    | p when p <> program -> check_change p
+    | p -> p
   in
-  match opt program with
-  | p when p <> program -> optimize p
-  | p -> p
-
-let rec flatten = function
-  | Addptr 1 :: tl     -> Incptr :: flatten tl
-  | Addptr (-1) :: tl  -> Decptr :: flatten tl
-  | Adddata 1 :: tl    -> Incdata :: flatten tl
-  | Adddata (-1) :: tl -> Decdata :: flatten tl
-  | Loop p :: tl -> Loop (flatten p) :: flatten tl
-  | hd :: tl -> hd :: flatten tl
-  | [] -> []
+  match check_change (Set 0 :: program) with Set 0 :: p | p -> p
 
 let () =
   let args = List.tl (Array.to_list Sys.argv) in
@@ -216,8 +268,8 @@ let () =
   |> (if List.mem "-o" args then optimize else fun p -> p)
   |> fun program ->
     if List.mem "-e" args then
-      program |> flatten |> string_of_program |> print_endline
+      program |> string_of_program |> print_endline
     else if List.mem "-c" args then
-      program |> flatten |> compile_to_c 30000 |> print_string
+      program |> compile_c 30000 |> print_string
     else
-      program |> compile 30000 |> string_of_llmodule |> print_string
+      program |> compile_llvm 30000 |> string_of_llmodule |> print_string