Skip to content

B
brainfucker
Commit f5c9feb6 authored by Taddeüs Kroes's avatar Taddeüs Kroes
Browse files
Options

Implemented a bunch of optimizatons

parent cc8d1ce3
Show whitespace changes
Inline Side-by-side
Showing with 147 additions and 95 deletions
Makefile
View file @ f5c9feb6
......@@ -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
View file @ f5c9feb6
......@@ -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 -> ","
| 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 ^ ")"
| 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 =
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
| Addptr a :: Addptr b :: tl -> opt (Addptr (a + b) :: tl)
| Adddata a :: Adddata b :: tl -> opt (Adddata (a + b) :: tl)
| 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
| Loop [Addptr -1] :: tl -> opt (Setptr 0 :: tl)
| Loop [Adddata (1 | -1)] :: tl -> opt (Setdata 0 :: tl)
| Shift i :: Offset (j, cmd) :: tl ->
Offset (i + j, cmd) :: Shift i :: tl |> opt
| (Addptr 0 | Adddata 0) :: tl
| (Addptr _ | Setptr _) :: (Setptr _ :: _ as tl)
| (Adddata _ | Setdata _) :: (Setdata _ :: _ as tl) -> opt tl
| Shift i :: cmd :: tl when can_offset cmd ->
Offset (i, cmd) :: Shift i :: tl |> opt
| Loop [Add (1 | -1)] :: tl ->
Set 0 :: tl |> opt
| 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
| [] -> []
in
and check_change program =
match opt program with
| p when p <> program -> optimize p
| p when p <> program -> check_change 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
| [] -> []
in
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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment