Brainfuck を LLVM にコンパイルするやつ

README.md

Compile:

$ ghc BrainfuckCompiler.hs
$ ./BrainfuckCompiler -e '+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+.' > hello.ll
$ llc -filetype=obj -o hello.o hello.ll
$ gcc hello.o

Optimize:

$ opt -S -mem2reg hello.ll -o hello_reg.ll

BrainfuckCompiler.hs

{-# LANGUAGE LambdaCase #-}

import Control.Monad
import Control.Monad.State
import Control.Lens
import Data.List
import System.Environment

type Instr = Char
type Code  = [Instr]
type LLAsm = String
type Local = Int
type Label = Int
type Var   = String

infixr 5 +!+
x +!+ y = x ++ "\n" ++ y

compile :: Code -> LLAsm
compile code = prefix +!+ runState compile' (code, 0, 0, "")^._2._4 +!+ suffix

-- (current-code, local-variable-number, bracket-count, result-assembly)
compile' :: Monad m => StateT (Code, Local, Label, LLAsm) m LLAsm
compile' = do
  code <- use _1
  forM code $ \instr -> do
    r <- compileInstr instr
    _4 %= (+!+ r)
  use _4

compileInstr :: Monad m => Instr -> StateT (Code, Local, Label, LLAsm) m LLAsm
compileInstr '[' = do
  _3 += 1
  label <- use _3
  ptr <- newLocalVar
  val <- newLocalVar
  i <- newLocalVar
  j <- newLocalVar
  return $ getVal ptr val i +!+ isZero i j  +!+ jumpIf j label +!+ concat ["while", show label, ".beg:"]

compileInstr ']' = do
  label <- use _3
  ptr <- newLocalVar
  val <- newLocalVar
  i <- newLocalVar
  j <- newLocalVar
  return $ getVal ptr val i +!+ isZero i j  +!+ jumpIf j label +!+ concat ["while", show label, ".end:"]

compileInstr '>' = do
  ptr <- newLocalVar
  x <- newLocalVar
  return $ concat
    [ ptr, " = load i32* %ptr\n"
    , x, " = add i32 ", ptr, ", 1\n", "store i32 ", x, ", i32* ", "%ptr"
    ]

compileInstr '<' = do
  ptr <- newLocalVar
  x <- newLocalVar
  return $ concat
    [ ptr, " = load i32* %ptr\n"
    , x, " = sub i32 ", ptr, ", 1\n", "store i32 ", x, ", i32* ", "%ptr"
    ]

compileInstr '+' = do
  a <- newLocalVar
  b <- newLocalVar
  x <- newLocalVar
  y <- newLocalVar
  c <- newLocalVar
  d <- newLocalVar
  return $ getVal a b x +!+ concat [y, " = add i8 ", x, ", 1"] +!+ setVal c d y

compileInstr '-' = do
  a <- newLocalVar
  b <- newLocalVar
  x <- newLocalVar
  y <- newLocalVar
  c <- newLocalVar
  d <- newLocalVar
  return $ getVal a b x +!+ concat [y, " = sub i8 ", x, ", 1"] +!+ setVal c d y

compileInstr '.' = do
  a <- newLocalVar
  b <- newLocalVar
  x <- newLocalVar
  c <- newLocalVar
  return $ getVal a b x +!+ concat [c, " = call i32 (i8, ...)* @putchar(i8 ", x , " )"]

compileInstr ',' = do
  x <- newLocalVar
  a <- newLocalVar
  b <- newLocalVar
  c <- newLocalVar
  return $ concat [x, " = call i32 (...)* @getchar()"] +!+ concat [a, " = trunc i32 ", x, " to i8"] +!+ setVal b c a

compileInstr _ = return ""

newLocalVar :: Monad m => StateT (Code, Local, Label, LLAsm) m Var
newLocalVar = do
  _2 += 1
  uses _2 (("%" ++) . show)

getVal :: Var -> Var -> Var -> LLAsm
getVal ptr val v = concat
  [ ptr, " = load i32* %ptr\n"
  , val, " = getelementptr inbounds i8* %memory, i32 ", ptr, "\n"
  , v,   " = load i8* ", val ]

setVal :: Var -> Var -> Var -> LLAsm
setVal ptr val v = concat
  [ ptr, " = load i32* %ptr\n"
  , val, " = getelementptr inbounds i8* %memory, i32 ", ptr, "\n"
  , "store i8 ", v, ", i8* ", val ]

isZero :: Var -> Var -> LLAsm
isZero ptr v = concat [v, " = icmp eq i8 ", ptr, ", 0"]

jumpIf :: Var -> Label -> LLAsm
jumpIf cond label = concat ["br i1 ", cond, ", label %while", show label, ".end, label %while", show label, ".beg\n"]

main = getArgs >>= \case
  ("-e" : code : []) -> putStr $ compile code
  args          -> error ("unrecognised arguments: " ++ joinArgs args) where
    joinArgs = concat . intersperse " "

prefix = concat
  [ "define i32 @main() {\n"
  , "%memory = alloca i8, i8 30000\n"
  , "%ptr = alloca i32, align 4\n"
  , "store i32 0, i32* %ptr"
  ]

suffix = concat
  [ "ret i32 0\n"
  , "}\n"
  , "\n"
  , "declare i32 @putchar(i8, ...)\n"
  , "declare i32 @getchar(...)\n"
  ]