Interpreter 1.0 Compiler 1.0 JIT 0.0

lib/Backend.hs

@@ -0,0 +1,5 @@
+module Backend (BFExecutor (exec, execStr)) where
+
+class BFExecutor a where
+    exec :: a -> Char -> IO a
+    execStr :: a -> String -> IO a

lib/Backend/Compiler.hs

@@ -0,0 +1,103 @@
+module Backend.Compiler (Compiler (Compiler), Optimization (Zero, One, Two, Three, Size, SizeSize)) where
+
+import Backend
+import Data.Bifoldable (bimapM_)
+import Data.List (singleton)
+import qualified IR
+import System.IO (Handle, hClose, hFlush, hPutStr, openTempFile, stdout)
+import System.Posix (getProcessID, rename)
+import System.Process (callProcess)
+
+type File = String
+type Compile = Bool
+data Optimization = Zero | One | Two | Three | Size | SizeSize deriving (Eq, Show)
+
+data Step = Opt | Llc | LdLLd
+
+getFlag :: Step -> Optimization -> String
+getFlag step = case (step) of
+    Opt -> getFlagOpt
+    Llc -> getFlagLlc
+    LdLLd -> getFlagLdLLd
+  where
+    getFlagOpt level = case (level) of
+        Zero -> "--O0"
+        One -> "--O1"
+        Two -> "--O2"
+        Three -> "--O3"
+        Size -> "--Os"
+        SizeSize -> "--Oz"
+    getFlagLlc level = case (level) of
+        Zero -> "-O0"
+        One -> "-O1"
+        Two -> "-O2"
+        Three -> "-O3"
+        Size -> "-O2"
+        SizeSize -> "-O2"
+    getFlagLdLLd level = case (level) of
+        Zero -> "-O0"
+        One -> "-O1"
+        Two -> "-O2"
+        Three -> "-O2"
+        Size -> "-O2"
+        SizeSize -> "-O2"
+
+data Compiler = Compiler File Compile Optimization
+
+instance BFExecutor Compiler where
+    exec c = execStr c . singleton
+    execStr (Compiler out comp optLevel) code =
+        print out
+            >> ( openTempFile "./" (out ++ ".ll")
+                    >>> (\(_, f) -> return f >>> append IR.setup >>> append IR.main_start >>> compile code >>> append IR.main_end >>> hFlush)
+                    >>= bimapM_
+                        ( if (comp)
+                            then (\f -> opt f >>= llc >>= ldLld >>= flip rename out)
+                            else flip rename out
+                        )
+                        hClose
+               )
+            >> return (Compiler out comp optLevel)
+      where
+        opt unopt = file >>= (\r -> callProcess "opt" [getFlag Opt optLevel, "-o", r, "-S", unopt]) >> file
+          where
+            file = getProcessID >>= (\r -> return $ "./" ++ out ++ (show r) ++ ".opt")
+        llc uncomp = file >>= (\r -> callProcess "llc" [getFlag Llc optLevel, "-o", r, uncomp, "--filetype=obj"]) >> file
+          where
+            file = getProcessID >>= (\r -> return $ "./" ++ out ++ (show r) ++ ".o")
+        ldLld unlinked = file >>= (\r -> callProcess "ld.lld" [getFlag Llc optLevel, "-o", r, unlinked]) >> file
+          where
+            file = getProcessID >>= (\r -> return $ "./" ++ out ++ (show r))
+
+compile :: String -> Handle -> IO ()
+compile s h = putStr s >> (() <$ _compile s (1, []) h)
+
+(>>>) :: (Monad m) => m a -> (a -> m b) -> m a
+v >>> f = v >>= \x -> f x >> return x
+
+-- +[-]
+-- append val_inc
+-- append paren_opening 1
+-- append val_dec
+-- append paren_close 1
+_compile :: String -> (Int, [Int]) -> Handle -> IO String
+_compile (x : xs) loop_counter file =
+    putStr [x]
+        >> case (x) of
+            '>' -> use file >>> append IR.index_inc >>= _compile xs loop_counter
+            '<' -> use file >>> append IR.index_dec >>= _compile xs loop_counter
+            '+' -> use file >>> append IR.val_inc >>= _compile xs loop_counter
+            '-' -> use file >>> append IR.val_dec >>= _compile xs loop_counter
+            '.' -> use file >>> append IR.point >>= _compile xs loop_counter
+            ',' -> use file >>> append IR.comma >>= _compile xs loop_counter
+            '[' -> use file >>> append (IR.paren_opening (fst loop_counter)) >>= _compile xs (fst loop_counter + 1, [fst loop_counter] ++ snd loop_counter)
+            ']' -> use file >>> append (IR.paren_close (_head $ snd loop_counter)) >>= _compile xs (fst loop_counter, _drop 1 $ snd loop_counter)
+            _ -> _compile xs loop_counter file
+  where
+    use = return
+    _head a = if (length a > 0) then a !! 0 else error "unmatched closed parenthesis"
+    _drop n a = if (length a > 0) then drop n a else error "unmatched closed parenthesis"
+_compile [] _ _ = return ""
+
+append :: String -> Handle -> IO ()
+append = flip hPutStr

lib/Backend/Interpreter.hs

@@ -0,0 +1,64 @@
+module Backend.Interpreter (defaultInterpreter, Interpreter (Interpreter), Index, Size, getArray, modArray, getIndex, modIndex, getSize) where
+
+import Backend
+import Data.Array.Base (UArray, array, (!), (//))
+import Data.List (singleton)
+import Data.Word (Word16, Word8)
+import Text.Printf (printf)
+
+type Index = Word16
+type Size = Word16
+data Interpreter = Interpreter (UArray Index Word8) Index Size
+
+instance BFExecutor Interpreter where
+    exec i = execStr i . singleton
+    execStr i str = _execStr (i, str)
+      where
+        _execStr (interpreter, (x : xs)) =
+            let (arr, index) = (getArray interpreter, getIndex interpreter)
+             in case (x) of
+                    '>' -> _execStr (interpreter `modIndex` (flip mod 30000 . (+) 1), xs)
+                    '<' -> _execStr (interpreter `modIndex` (flip mod 30000 . subtract 1), xs)
+                    '+' -> _execStr (interpreter `modArray` (\a -> a // [(index, (arr ! index) + 1)]), xs)
+                    '-' -> _execStr (interpreter `modArray` (\a -> a // [(index, (arr ! index) - 1)]), xs)
+                    '.' -> (printf "%c" (word8ToChar (arr ! index))) >> _execStr (interpreter, xs)
+                    ',' -> getChar >>= (\c -> _execStr (interpreter `modArray` (\a -> a // [(index, charToWord8 c)]), xs))
+                    '[' ->
+                        if ((arr ! index) == 0)
+                            then _execStr (interpreter, findMatching xs)
+                            else _execStr (interpreter, xs) >>= (\inter -> _execStr (inter, x : xs))
+                    ']' -> return interpreter
+                    _ -> _execStr (interpreter, xs)
+        _execStr (interpreter, []) = return interpreter
+        findMatching (x : xs) = case x of
+            '[' -> findMatching $ findMatching xs
+            ']' -> xs
+            _ -> findMatching xs
+        findMatching [] = error "unclosed loop"
+
+defaultInterpreter :: Interpreter
+defaultInterpreter = Interpreter (array (0, 30000 - 1) [(i, 0) | i <- [0 .. 30000 - 1]]) (0 :: Index) (30000 :: Size)
+
+charToWord8 :: Char -> Word8
+charToWord8 = toEnum . fromEnum
+
+word8ToChar :: Word8 -> Char
+word8ToChar = toEnum . fromEnum
+
+modArray :: Interpreter -> (UArray Index Word8 -> UArray Index Word8) -> Interpreter
+modArray (Interpreter a b c) f = Interpreter (f a) b c
+
+modIndex :: Interpreter -> (Index -> Index) -> Interpreter
+modIndex (Interpreter a b c) f = Interpreter a (f b) c
+
+getArray :: Interpreter -> UArray Index Word8
+{-# INLINE getArray #-}
+getArray (Interpreter arr _ _) = arr
+
+getIndex :: Interpreter -> Index
+{-# INLINE getIndex #-}
+getIndex (Interpreter _ i _) = i
+
+getSize :: Interpreter -> Size
+{-# INLINE getSize #-}
+getSize (Interpreter _ _ s) = s

lib/Backend/JIT.hs

@@ -0,0 +1,4 @@
+module Backend.JIT () where
+
+i :: Integer
+i = 0