Add LLVM CompilerHEADmaster

Remember, now you have to run this by first doing:

 $ ghc --make bf

Then you can run bf with:

 $ ./bf -c examples/hello.bf

Then you can link the bitcode with:

 $ llvm-ld -o hello examples/hello.bc

And you can run ./hello

1 files changed, 103 insertions, 4 deletions

diff --git a/bf.hs b/bf.hs
index 619707b..d369a87 100644
--- a/bf.hs
+++ b/bf.hs
@@ -7,6 +7,9 @@ import System.Environment
 import System.Console.GetOpt
 import System.Exit
 import Data.Maybe
+import System.FilePath
+import LLVM.Core
+import LLVM.Util.Optimize
 
 data BFInstruction = GoBack | GoForward | Increment | Decrement | Input
                    | Output | Loop [BFInstruction]
@@ -83,7 +86,7 @@ runInstructions :: [BFInstruction] -> BFRunner
 runInstructions = mapM_ runInstruction
 
 --------------------- Options --------------------------------
-data Action = ParseOnly | Interpret deriving (Show, Eq)
+data Action = ParseOnly | Interpret | Bitcode deriving (Show, Eq)
 
 data Options = Options
                { optHelp :: Bool
@@ -112,6 +115,9 @@ options = [ Option ['v']     ["version"]
           , Option ['i']     ["interpret"]
             (NoArg (\ opts -> opts { optAction = Interpret }))
             "parse the input and interpret it"
+          , Option ['c']     ["bitcode"]
+            (NoArg (\ opts -> opts { optAction = Bitcode }))
+            "parse the input and outputs a bitcode file"
           ]
 
 usage :: String
@@ -126,6 +132,98 @@ bfOptions argv =
     (o, _,   []  ) -> return (foldl (flip id) defaultOptions o, Nothing)
     (_, _,   errs) -> ioError $ userError $ concat errs ++ usage
 
+---------- Compiler ------------
+
+compileBody :: [BFInstruction] -> CodeGenModule (Function (IO Word32))
+compileBody insn = do
+  getc <- newNamedFunction ExternalLinkage "getchar" :: TFunction (IO Word8)
+  putc <- newNamedFunction ExternalLinkage "putchar" :: TFunction (Word8 -> IO ())
+  bzero <- newNamedFunction ExternalLinkage "bzero"  :: TFunction (Ptr Word8 -> Word32 -> IO ())
+
+  createNamedFunction ExternalLinkage "main" $ do
+    headp <- alloca
+    tape <- (arrayAlloca (65536 :: Word32)) :: CodeGenFunction r0 (Value (Ptr Word8))
+    store (value zero) headp
+
+    call bzero tape $ valueOf 65536
+
+    let compileInstruction :: BFInstruction -> CodeGenFunction r0 Terminate
+        compileInstruction GoBack = do
+          head' <- load (headp :: Value (Ptr Word16))
+          head'' <- isub head' (1 :: Word16)
+          store head'' headp
+
+        compileInstruction GoForward = do
+          head' <- load (headp :: Value (Ptr Word16))
+          head'' <- iadd head' (1 :: Word16)
+          store head'' headp
+
+        compileInstruction Increment = do
+          head' <- load (headp :: Value (Ptr Word16))
+          head'' <- zext head'
+          vp <- getElementPtr tape ((head'' :: Value Word32), ())
+          val <- load vp
+          val' <- iadd val (1 :: Word8)
+          store val' vp
+
+        compileInstruction Decrement = do
+          head' <- load (headp :: Value (Ptr Word16))
+          head'' <- zext head'
+          vp <- getElementPtr tape ((head'' :: Value Word32), ())
+          val <- load vp
+          val' <- isub val (1 :: Word8)
+          store val' vp
+
+        compileInstruction Input = do
+          head' <- load (headp :: Value (Ptr Word16))
+          head'' <- zext head'
+          vp <- getElementPtr tape ((head'' :: Value Word32), ())
+          c <- call getc
+          store c vp
+
+        compileInstruction Output = do
+          head' <- load (headp :: Value (Ptr Word16))
+          head'' <- zext head'
+          vp <- getElementPtr tape ((head'' :: Value Word32), ())
+          c <- load vp
+          call putc c
+          return ()
+
+        compileInstruction (Loop is') = do
+          loop <- newBasicBlock
+          body <- newBasicBlock
+          exit <- newBasicBlock
+
+          br loop
+
+          defineBasicBlock loop
+
+          head' <- load (headp :: Value (Ptr Word16))
+          head'' <- zext head'
+          vp <- getElementPtr tape ((head'' :: Value Word32), ())
+          c <- load vp
+          t <- cmp CmpNE c (0::Word8)
+          condBr t body exit
+
+          defineBasicBlock body
+          compileInstructions is'
+          br loop
+
+          defineBasicBlock exit
+
+        compileInstructions = mapM_ compileInstruction
+
+    compileInstructions insn
+    ret (0 :: Word32)
+
+
+writeBitcodeFile :: [BFInstruction] -> FilePath -> IO ()
+writeBitcodeFile insns fname = do
+  m <- newModule
+  defineModule m (compileBody insns)
+  optimizeModule 100 m
+  writeBitcodeToFile fname m
+
 main :: IO ()
 main = do
   argv <- getArgs
@@ -147,6 +245,7 @@ main = do
   case parse parseInstructions fname' cont of
     Left e -> print e
     Right insns -> do
-      if action == ParseOnly
-        then print insns
-        else evalStateT (runInstructions insns) (0, M.empty)
+      case action of
+        ParseOnly -> print insns
+        Interpret -> evalStateT (runInstructions insns) (0, M.empty)
+        Bitcode -> writeBitcodeFile insns (replaceExtension fname' ".bc")