From 873c294497c74e85eae5310cbf19269807c75e6d Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Sun, 15 Apr 2018 00:12:01 +0200 Subject: Build with stack --- .gitignore | 5 ++ AST.hs | 73 +++++++++++++++++++++++++ Compiler.hs | 128 +++++++++++++++++++++++++++++++++++++++++++ Interpreter.hs | 45 ++++++++++++++++ Main.hs | 44 +++++++++++++++ Optimiser.hs | 167 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Parser.hs | 33 ++++++++++++ ast.hs | 73 ------------------------- bfcomphs.cabal | 16 ++++++ compiler.hs | 128 ------------------------------------------- interpreter.hs | 45 ---------------- main.hs | 44 --------------- optimiser.hs | 167 --------------------------------------------------------- parser.hs | 33 ------------ stack.yaml | 66 +++++++++++++++++++++++ 15 files changed, 577 insertions(+), 490 deletions(-) create mode 100644 AST.hs create mode 100644 Compiler.hs create mode 100644 Interpreter.hs create mode 100644 Main.hs create mode 100644 Optimiser.hs create mode 100644 Parser.hs delete mode 100644 ast.hs create mode 100644 bfcomphs.cabal delete mode 100644 compiler.hs delete mode 100644 interpreter.hs delete mode 100644 main.hs delete mode 100644 optimiser.hs delete mode 100644 parser.hs create mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore index cc3645e..7b51549 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,8 @@ main *.exe *.ast *.succinct +.stack-work/ +.cabal-sandbox +cabal.sandbox.config +.DS_Store +*.swp diff --git a/AST.hs b/AST.hs new file mode 100644 index 0000000..cd7fed2 --- /dev/null +++ b/AST.hs @@ -0,0 +1,73 @@ +module AST where + +import Data.List +import Data.Word + + +type Byte = Word8 +type Offset = Int + + +newtype Program = Program [Instruction] + deriving (Show, Eq) + +data Instruction + = IAdd Byte Offset + | ISet Byte Offset + | ICopy Offset Offset Byte -- ICopy from to multiplier + | ISlide Offset + | ILoop [Instruction] Offset + | IInput Offset + | IOutput Offset + | IStart + deriving (Show, Eq) + +isIAdd :: Instruction -> Bool +isIAdd (IAdd _ _) = True +isIAdd _ = False + +isISet :: Instruction -> Bool +isISet (ISet _ _) = True +isISet _ = False + +isICopy :: Instruction -> Bool +isICopy (ICopy _ _ _) = True +isICopy _ = False + +isISlide :: Instruction -> Bool +isISlide (ISlide _) = True +isISlide _ = False + +isIStart :: Instruction -> Bool +isIStart IStart = True +isIStart _ = False + +offsetOf :: Instruction -> Offset +offsetOf (IAdd _ o) = o +offsetOf (ISet _ o) = o +offsetOf (ICopy o _ _) = o +offsetOf (ISlide _) = undefined +offsetOf (ILoop _ _) = undefined +offsetOf (IInput o) = o +offsetOf (IOutput o) = o +offsetOf IStart = 0 + +astSuccinct :: Program -> String +astSuccinct (Program inss) = intercalate " " $ map insSuccinct inss + where + insSuccinct :: Instruction -> String + insSuccinct (IAdd v o) = + let sv = signedByte v + in (if sv >= 0 then "+" else "") ++ show (signedByte v) ++ ',' : show o + insSuccinct (ISet v o) = '=' : show (signedByte v) ++ ',' : show o + insSuccinct (ICopy from to v) = 'C' : show from ++ ',' : show to ++ ',' : show v + insSuccinct (ISlide o) = '>' : show o + insSuccinct (ILoop inss' off) = "[(" ++ show off ++ ')' : intercalate " " (map insSuccinct inss') ++ "]" + insSuccinct (IInput o) = ',' : show o + insSuccinct (IOutput o) = '.' : show o + insSuccinct IStart = "$" + + signedByte :: Byte -> Int + signedByte v + | v < 128 = fromIntegral v + | otherwise = fromIntegral v - 256 diff --git a/Compiler.hs b/Compiler.hs new file mode 100644 index 0000000..eab7058 --- /dev/null +++ b/Compiler.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} + +module Compiler(compile) where + +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict +import Data.List + +import AST + + +-- Execution starts in the middle of the tape +tapeLength :: Offset +tapeLength = 60000 + + +newtype LineWriter a = LineWriter {unLineWriter :: WriterT [String] (State Int) a} + deriving (Functor, Applicative, Monad, MonadWriter [String], MonadState Int) + +runLineWriter :: LineWriter a -> String +runLineWriter = (++ "\n") . intercalate "\n" . flip evalState 1 . execWriterT . unLineWriter + +emit0 :: String -> LineWriter () +emit0 = tell . pure + +emit :: String -> LineWriter () +emit = tell . pure . ('\t' :) + +genId :: LineWriter Int +genId = state $ \i -> (i, i + 1) + + +compile :: Program -> String +compile (Program inss) = runLineWriter $ do + emit0 prologue + mapM_ compileIns inss + emit0 epilogue + +cursorReg :: String +cursorReg = "rbx" + +cursorOffset :: Offset -> String +cursorOffset 0 = cursorReg +cursorOffset off = cursorReg ++ " + " ++ show off + +compileIns :: Instruction -> LineWriter () +compileIns (IAdd v off) = emit $ "add byte [" ++ cursorOffset off ++ "], " ++ show v +compileIns (ISet v off) = emit $ "mov byte [" ++ cursorOffset off ++ "], " ++ show v +compileIns (ICopy _ _ 0) = return () +compileIns (ICopy from to m) = do + emit $ "mov al, [" ++ cursorOffset from ++ "]" + case m of + 1 -> return () + _ | Just p <- isTwoPower m -> emit $ "shl al, " ++ show p + | otherwise -> do + emit $ "mov cl, " ++ show m + emit "mul byte cl" + emit $ "add [" ++ cursorOffset to ++ "], al" +compileIns (ISlide off) = emit $ "add " ++ cursorReg ++ ", " ++ show off +compileIns (ILoop inss off) = do + loopid <- genId + emit $ "cmp byte [" ++ cursorOffset off ++ "], 0" + emit $ "jz .Laf_" ++ show loopid + emit0 $ ".Lbd_" ++ show loopid ++ ":" + mapM_ compileIns inss + emit $ "cmp byte [" ++ cursorOffset off ++ "], 0" + emit $ "jnz .Lbd_" ++ show loopid + emit0 $ ".Laf_" ++ show loopid ++ ":" +compileIns (IInput off) = do + emit "call _getchar" + emit $ "mov [" ++ cursorOffset off ++ "], al" +compileIns (IOutput off) = do + emit "xor edi, edi" + emit $ "mov dil, [" ++ cursorOffset off ++ "]" + emit "call _putchar" +compileIns IStart = return () + +isTwoPower :: Byte -> Maybe Int +isTwoPower v = findIndex (==v) (take 8 $ iterate (* 2) 1) + + +prologue :: String +prologue = + "global _main" + ++ "\nextern _calloc, _free, _putchar, _getchar, _write" + ++ "\ndefault rel" + ++ "\nsection .text" + + ++ "\n_main:" + ++ "\n\tpush rbp" + ++ "\n\tmov rbp, rsp" + ++ "\n\tpush rbx" + ++ "\n\tsub rsp, 8" + ++ "\n\tmov edi, " ++ show tapeLength + ++ "\n\tmov esi, 1" + ++ "\n\tcall _calloc" + ++ "\n\ttest rax, rax" + ++ "\n\tjz .allocation_failure" + ++ "\n\tlea rbx, [rax + " ++ show (tapeLength `div` 2) ++ "] ; rbx = cursor" + ++ "\n\tmov [rsp], rax ; [rsp] = start of tape buffer" + ++ "\n" + +epilogue :: String +epilogue = + "\n\tmov rdi, [rsp]" + ++ "\n\tcall _free" + ++ "\n\txor eax, eax" + ++ "\n.return:" + ++ "\n\tadd rsp, 8" + ++ "\n\tpop rbx" + ++ "\n\tmov rsp, rbp" + ++ "\n\tpop rbp" + ++ "\n\tret" + ++ "\n.allocation_failure:" + ++ "\n\tsub rsp, 32" + ++ "\n\tmov rax, 0x697461636f6c6c41 ; \"Allocati\"" + ++ "\n\tmov rbx, 0x756c696166206e6f ; \"on failu\"" + ++ "\n\tmov ecx, 0x000a6572 ; \"re\\n\\0\"" + ++ "\n\tmov [rsp], rax" + ++ "\n\tmov [rsp+8], rbx" + ++ "\n\tmov [rsp+16], ecx" + ++ "\n\tmov edi, 2" + ++ "\n\tmov rsi, rsp" + ++ "\n\tmov edx, 20" + ++ "\n\tcall _write" + ++ "\n\tadd rsp, 32" + ++ "\n\tmov eax, 1" + ++ "\n\tjmp .return" diff --git a/Interpreter.hs b/Interpreter.hs new file mode 100644 index 0000000..4f3f3aa --- /dev/null +++ b/Interpreter.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE BangPatterns #-} + +module Interpreter(interpret) where + +import qualified Data.Vector.Mutable as MV + +import AST + + +type Tape = MV.IOVector Byte + + +interpret :: Program -> [Byte] -> IO [Byte] +interpret (Program inss) inp = MV.replicate 60000 0 >>= \tape -> interInss 0 tape 30000 inss inp + +interInss :: Int -> Tape -> Int -> [Instruction] -> [Byte] -> IO [Byte] +interInss _ _ _ [] _ = return [] +-- interInss count _ _ _ _ | count > 2000000000 = return [] +interInss !count !tape !memp allinss@(ins:rest) inp = case ins of + (IAdd value offset) -> do + MV.modify tape (+ value) (memp + offset) + interInss (count + 1) tape memp rest inp + (ISet value offset) -> do + MV.write tape (memp + offset) value + interInss (count + 1) tape memp rest inp + (ICopy from to mult) -> do + value <- MV.read tape (memp + from) + MV.modify tape ((+) (mult * value)) (memp + to) + interInss (count + 1) tape memp rest inp + (ISlide offset) -> do + interInss (count + 1) tape (memp + offset) rest inp + (ILoop iins offset) -> do + value <- MV.read tape (memp + offset) + if value /= 0 + then interInss (count + 1) tape memp (iins ++ allinss) inp + else interInss (count + 1) tape memp rest inp + (IInput offset) -> do + let (c:cs) = inp + MV.write tape (memp + offset) c + interInss (count + 1) tape memp rest cs + (IOutput offset) -> do + value <- MV.read tape (memp + offset) + (value :) <$> interInss (count + 1) tape memp rest inp + IStart -> do + interInss (count + 1) tape memp rest inp diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..9c33f83 --- /dev/null +++ b/Main.hs @@ -0,0 +1,44 @@ +module Main where + +import Control.Monad +import Data.Char +import System.Environment +import System.Exit +import System.Process + +import AST +import Compiler +import Interpreter +import Parser +import Optimiser + + +data ExecutionMode = EMInterpret | EMCompile + +executionMode :: ExecutionMode +executionMode = EMCompile + + +main :: IO () +main = do + args <- getArgs + when (length args == 0 || length args > 2) + $ die "Usage: bfcomphs " + let fname = head args + + prog <- readFile fname >>= either die return . parseProgram + + -- putStrLn $ astSuccinct prog + -- print prog + let opt = optimise prog + writeFile (fname ++ ".succinct") $ astSuccinct opt + writeFile (fname ++ ".ast") $ show opt + + case executionMode of + EMInterpret -> do + input <- getContents + interpret opt (map (fromIntegral . ord) input) >>= (putStr . map (chr . fromIntegral)) + EMCompile -> do + writeFile (fname ++ ".asm") $ compile opt + callProcess "yasm" ["-f", "macho64", fname ++ ".asm", "-o", fname ++ ".o"] + callProcess "gcc" [fname ++ ".o", "-o", fname ++ ".exe"] diff --git a/Optimiser.hs b/Optimiser.hs new file mode 100644 index 0000000..3163c33 --- /dev/null +++ b/Optimiser.hs @@ -0,0 +1,167 @@ +module Optimiser(optimise) where + +import Data.List +import qualified Data.Map.Strict as Map + +-- import Debug.Trace + +import AST + + +type Optimisation = [Instruction] -> [Instruction] + + +optimisations :: [Optimisation] +optimisations = + [collectSimilar, nullOps, collectAdds, propagateKnowns, firstSets, propagateSlides, uselessEnd, specialLoops, normaliseOrder] + +composedOpts :: Optimisation +composedOpts = foldl1 (.) (reverse optimisations) +-- composedOpts = foldl1 (.) (map (traceShowId .) $ reverse optimisations) +-- composedOpts = foldl1 (.) (map ((\r -> traceShow (take 7 r) r) .) $ reverse optimisations) + +optimise :: Program -> Program +optimise (Program inss) = + Program $ repeated composedOpts inss + + +collectSimilar :: Optimisation +collectSimilar [] = [] +collectSimilar (IAdd x off1 : IAdd y off2 : rest) | off1 == off2 = + collectSimilar $ IAdd (x + y) off1 : rest +collectSimilar (ISlide off1 : ISlide off2 : rest) = + collectSimilar $ ISlide (off1 + off2) : rest +collectSimilar (ILoop inss off : rest) = ILoop (collectSimilar inss) off : collectSimilar rest +collectSimilar (ins : rest) = ins : collectSimilar rest + +nullOps :: Optimisation +nullOps [] = [] +nullOps (IAdd 0 _ : rest) = nullOps rest +nullOps (ICopy _ _ 0 : rest) = nullOps rest +nullOps (ISlide 0 : rest) = nullOps rest +nullOps (ILoop inss off : rest) = ILoop (nullOps inss) off : nullOps rest +nullOps (ins : rest) = ins : nullOps rest + +collectAdds :: Optimisation +collectAdds [] = [] +collectAdds (ICopy from1 to1 m1 : ICopy from2 to2 m2 : rest) + | from1 == from2, m1 == m2 = ICopy from1 to1 m1 : collectAdds (ICopy to1 to2 1 : rest) +collectAdds inss = + let adds = map (\(IAdd v o) -> (v, o)) $ takeWhile isIAdd inss + dests = nub $ map snd adds + collected = [(sum $ map fst $ filter ((== d) . snd) adds, d) | d <- dests] + rest = drop (length adds) inss + rest' = case rest of + [] -> [] + (i:is) -> i : collectAdds is + in map (uncurry IAdd) collected ++ rest' + +propagateKnowns :: Optimisation +propagateKnowns [] = [] +propagateKnowns allinss@(ins : _) | isISet ins || isIStart ins = + let defaultZero = isIStart ins + + go :: [Instruction] -> Map.Map Offset Byte -> ([Instruction], Map.Map Offset Byte) + go (IStart : rest) mp = go rest mp + go (ISet val off : rest) mp = go rest $ Map.insert off val mp + go inss@(IAdd val off : rest) mp = case Map.lookup off mp of + Nothing -> (inss, mp) + Just origval -> go rest $ Map.insert off (origval + val) mp + go inss@(ICopy from to mult : rest) mp = + if defaultZero + then let fromval = maybe 0 id $ Map.lookup from mp + toval = maybe 0 id $ Map.lookup to mp + in go rest $ Map.insert to (toval + mult * fromval) mp + else case (Map.lookup from mp, Map.lookup to mp) of + (Nothing, _) -> (inss, mp) + (_, Nothing) -> (inss, mp) + (Just fromval, Just toval) -> + go rest $ Map.insert to (toval + mult * fromval) mp + go inss mp = (inss, mp) + + compareSetAdd :: Instruction -> Instruction -> Ordering + compareSetAdd (ISet _ _) (IAdd _ _) = LT + compareSetAdd (IAdd _ _) (ISet _ _) = GT + compareSetAdd i1 i2 = compare (offsetOf i1) (offsetOf i2) + + (after, valuemap) = go allinss Map.empty + sets = sortBy compareSetAdd + $ Map.foldlWithKey + (\l off val -> if not defaultZero || val /= 0 then ISet val off : l else l) + [] valuemap + in if isIStart ins then IStart : sets ++ propagateKnowns after else sets ++ propagateKnowns after +propagateKnowns (ILoop inss off : rest) = ILoop (propagateKnowns inss) off : propagateKnowns rest +propagateKnowns (ins : rest) = ins : propagateKnowns rest + +firstSets :: Optimisation +firstSets [] = [] +firstSets (IStart : rest) = + let pre = takeWhile (\ins -> isIAdd ins || isISet ins) rest + post = drop (length pre) rest + dests = nub $ map offsetOf pre + collected = [ISet (accumSetAdd 0 (filter ((== d) . offsetOf) pre)) d | d <- dests] + in IStart : collected ++ post +firstSets inss = inss + +propagateSlides :: Optimisation +propagateSlides [] = [] +propagateSlides (ISlide off : rest) = propagateSlides (incOffsets off rest) ++ [ISlide off] +propagateSlides (ILoop inss off : rest) = ILoop (propagateSlides inss) off : propagateSlides rest +propagateSlides (ins : rest) = ins : propagateSlides rest + +uselessEnd :: Optimisation +uselessEnd [] = [] +uselessEnd inss = reverse $ dropWhile isUseless $ reverse inss + where + isUseless :: Instruction -> Bool + isUseless (IInput _) = False + isUseless (IOutput _) = False + isUseless (ILoop lp _) = all isUseless lp + isUseless _ = True + +specialLoops :: Optimisation +specialLoops [] = [] +specialLoops (ILoop [IAdd v off2] off1 : rest) + | off1 /= off2 = ILoop [] off1 : specialLoops rest + | gcd v 2 == 1 = ISet 0 off1 : specialLoops rest +specialLoops (ILoop inss off : rest) + | all isIAdd inss, + sum (map (\(IAdd v _) -> v) $ filter ((== off) . offsetOf) inss) == -1 = + let others = map (\(IAdd v o) -> (v, o)) $ filter ((/= off) . offsetOf) inss + dests = nub $ map snd others + copies = [ICopy off d (sum $ map fst $ filter ((== d) . snd) others) | d <- dests] + in copies ++ ISet 0 off : specialLoops rest +specialLoops (ILoop inss off : rest) = ILoop (specialLoops inss) off : specialLoops rest +specialLoops (ins : rest) = ins : specialLoops rest + +normaliseOrder :: Optimisation +normaliseOrder [] = [] +normaliseOrder (ICopy from1 to1 m1 : ICopy from2 to2 m2 : rest) + | m2 < m1, to1 /= from2, to2 /= from1 = ICopy from2 to2 m2 : normaliseOrder (ICopy from1 to1 m1 : rest) +normaliseOrder (ILoop inss off : rest) = ILoop (normaliseOrder inss) off : normaliseOrder rest +normaliseOrder (ins : rest) = ins : normaliseOrder rest + + +repeated :: Optimisation -> Optimisation +repeated opt = \inss -> let inss' = opt inss + in if inss == inss' then inss else repeated opt inss' + +incOffsets :: Offset -> [Instruction] -> [Instruction] +incOffsets _ [] = [] +incOffsets inc (IAdd v off : rest) = IAdd v (off + inc) : incOffsets inc rest +incOffsets inc (ISet v off : rest) = ISet v (off + inc) : incOffsets inc rest +incOffsets inc (ICopy from to mult : rest) = ICopy (from + inc) (to + inc) mult : incOffsets inc rest +incOffsets inc (ISlide off : rest) = ISlide off : incOffsets inc rest +incOffsets inc (ILoop inss off : rest) = ILoop (incOffsets inc inss) (off + inc) : incOffsets inc rest +incOffsets inc (IInput off : rest) = IInput (off + inc) : incOffsets inc rest +incOffsets inc (IOutput off : rest) = IOutput (off + inc) : incOffsets inc rest +incOffsets inc (IStart : rest) = IStart : incOffsets inc rest + +accumSetAdd :: Byte -> [Instruction] -> Byte +accumSetAdd acc [] = acc +accumSetAdd _ (ISet v' _ : rest) = accumSetAdd v' rest +accumSetAdd acc (IAdd v' _ : rest) = accumSetAdd (acc + v') rest +accumSetAdd _ _ = unreachable + +unreachable :: a +unreachable = error "Unreachable" diff --git a/Parser.hs b/Parser.hs new file mode 100644 index 0000000..f2961ba --- /dev/null +++ b/Parser.hs @@ -0,0 +1,33 @@ +module Parser(parseProgram) where + +import AST + + +parseProgram :: String -> Either String Program +parseProgram src = do + (inss, "") <- parseLoop 0 src + return $ Program $ IStart : inss + +parseLoop :: Int -> String -> Either String ([Instruction], String) +parseLoop 0 "" = Right ([], "") +parseLoop _ "" = Left "More '[' than ']'" +parseLoop 0 (']':_) = Left "Unexpected ']'" +parseLoop _ (']':cs) = Right ([], cs) +parseLoop d ('[':cs) = do + (lp, rest) <- parseLoop (d+1) cs + (after, rest') <- parseLoop d rest + return (ILoop lp 0 : after, rest') +parseLoop d (c:cs) + | Just ins <- parseSimple c = do + (lp, rest) <- parseLoop d cs + return (ins:lp, rest) +parseLoop d (_:cs) = parseLoop d cs + +parseSimple :: Char -> Maybe Instruction +parseSimple '+' = Just $ IAdd 1 0 +parseSimple '-' = Just $ IAdd (-1) 0 +parseSimple '>' = Just $ ISlide 1 +parseSimple '<' = Just $ ISlide (-1) +parseSimple ',' = Just $ IInput 0 +parseSimple '.' = Just $ IOutput 0 +parseSimple _ = Nothing diff --git a/ast.hs b/ast.hs deleted file mode 100644 index cd7fed2..0000000 --- a/ast.hs +++ /dev/null @@ -1,73 +0,0 @@ -module AST where - -import Data.List -import Data.Word - - -type Byte = Word8 -type Offset = Int - - -newtype Program = Program [Instruction] - deriving (Show, Eq) - -data Instruction - = IAdd Byte Offset - | ISet Byte Offset - | ICopy Offset Offset Byte -- ICopy from to multiplier - | ISlide Offset - | ILoop [Instruction] Offset - | IInput Offset - | IOutput Offset - | IStart - deriving (Show, Eq) - -isIAdd :: Instruction -> Bool -isIAdd (IAdd _ _) = True -isIAdd _ = False - -isISet :: Instruction -> Bool -isISet (ISet _ _) = True -isISet _ = False - -isICopy :: Instruction -> Bool -isICopy (ICopy _ _ _) = True -isICopy _ = False - -isISlide :: Instruction -> Bool -isISlide (ISlide _) = True -isISlide _ = False - -isIStart :: Instruction -> Bool -isIStart IStart = True -isIStart _ = False - -offsetOf :: Instruction -> Offset -offsetOf (IAdd _ o) = o -offsetOf (ISet _ o) = o -offsetOf (ICopy o _ _) = o -offsetOf (ISlide _) = undefined -offsetOf (ILoop _ _) = undefined -offsetOf (IInput o) = o -offsetOf (IOutput o) = o -offsetOf IStart = 0 - -astSuccinct :: Program -> String -astSuccinct (Program inss) = intercalate " " $ map insSuccinct inss - where - insSuccinct :: Instruction -> String - insSuccinct (IAdd v o) = - let sv = signedByte v - in (if sv >= 0 then "+" else "") ++ show (signedByte v) ++ ',' : show o - insSuccinct (ISet v o) = '=' : show (signedByte v) ++ ',' : show o - insSuccinct (ICopy from to v) = 'C' : show from ++ ',' : show to ++ ',' : show v - insSuccinct (ISlide o) = '>' : show o - insSuccinct (ILoop inss' off) = "[(" ++ show off ++ ')' : intercalate " " (map insSuccinct inss') ++ "]" - insSuccinct (IInput o) = ',' : show o - insSuccinct (IOutput o) = '.' : show o - insSuccinct IStart = "$" - - signedByte :: Byte -> Int - signedByte v - | v < 128 = fromIntegral v - | otherwise = fromIntegral v - 256 diff --git a/bfcomphs.cabal b/bfcomphs.cabal new file mode 100644 index 0000000..9eaf31e --- /dev/null +++ b/bfcomphs.cabal @@ -0,0 +1,16 @@ +name: bfcomphs +version: 0.1.0 +cabal-version: >= 1.10 +build-type: Simple +license: MIT +author: Tom Smeding +maintainer: tom.smeding@gmail.com + +executable bfcomphs + hs-source-dirs: . + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -Wall -O2 + build-depends: base >= 4 && < 5, + containers, mtl, vector, process + other-modules: AST, Compiler, Interpreter, Optimiser, Parser diff --git a/compiler.hs b/compiler.hs deleted file mode 100644 index eab7058..0000000 --- a/compiler.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} - -module Compiler(compile) where - -import Control.Monad.State.Strict -import Control.Monad.Writer.Strict -import Data.List - -import AST - - --- Execution starts in the middle of the tape -tapeLength :: Offset -tapeLength = 60000 - - -newtype LineWriter a = LineWriter {unLineWriter :: WriterT [String] (State Int) a} - deriving (Functor, Applicative, Monad, MonadWriter [String], MonadState Int) - -runLineWriter :: LineWriter a -> String -runLineWriter = (++ "\n") . intercalate "\n" . flip evalState 1 . execWriterT . unLineWriter - -emit0 :: String -> LineWriter () -emit0 = tell . pure - -emit :: String -> LineWriter () -emit = tell . pure . ('\t' :) - -genId :: LineWriter Int -genId = state $ \i -> (i, i + 1) - - -compile :: Program -> String -compile (Program inss) = runLineWriter $ do - emit0 prologue - mapM_ compileIns inss - emit0 epilogue - -cursorReg :: String -cursorReg = "rbx" - -cursorOffset :: Offset -> String -cursorOffset 0 = cursorReg -cursorOffset off = cursorReg ++ " + " ++ show off - -compileIns :: Instruction -> LineWriter () -compileIns (IAdd v off) = emit $ "add byte [" ++ cursorOffset off ++ "], " ++ show v -compileIns (ISet v off) = emit $ "mov byte [" ++ cursorOffset off ++ "], " ++ show v -compileIns (ICopy _ _ 0) = return () -compileIns (ICopy from to m) = do - emit $ "mov al, [" ++ cursorOffset from ++ "]" - case m of - 1 -> return () - _ | Just p <- isTwoPower m -> emit $ "shl al, " ++ show p - | otherwise -> do - emit $ "mov cl, " ++ show m - emit "mul byte cl" - emit $ "add [" ++ cursorOffset to ++ "], al" -compileIns (ISlide off) = emit $ "add " ++ cursorReg ++ ", " ++ show off -compileIns (ILoop inss off) = do - loopid <- genId - emit $ "cmp byte [" ++ cursorOffset off ++ "], 0" - emit $ "jz .Laf_" ++ show loopid - emit0 $ ".Lbd_" ++ show loopid ++ ":" - mapM_ compileIns inss - emit $ "cmp byte [" ++ cursorOffset off ++ "], 0" - emit $ "jnz .Lbd_" ++ show loopid - emit0 $ ".Laf_" ++ show loopid ++ ":" -compileIns (IInput off) = do - emit "call _getchar" - emit $ "mov [" ++ cursorOffset off ++ "], al" -compileIns (IOutput off) = do - emit "xor edi, edi" - emit $ "mov dil, [" ++ cursorOffset off ++ "]" - emit "call _putchar" -compileIns IStart = return () - -isTwoPower :: Byte -> Maybe Int -isTwoPower v = findIndex (==v) (take 8 $ iterate (* 2) 1) - - -prologue :: String -prologue = - "global _main" - ++ "\nextern _calloc, _free, _putchar, _getchar, _write" - ++ "\ndefault rel" - ++ "\nsection .text" - - ++ "\n_main:" - ++ "\n\tpush rbp" - ++ "\n\tmov rbp, rsp" - ++ "\n\tpush rbx" - ++ "\n\tsub rsp, 8" - ++ "\n\tmov edi, " ++ show tapeLength - ++ "\n\tmov esi, 1" - ++ "\n\tcall _calloc" - ++ "\n\ttest rax, rax" - ++ "\n\tjz .allocation_failure" - ++ "\n\tlea rbx, [rax + " ++ show (tapeLength `div` 2) ++ "] ; rbx = cursor" - ++ "\n\tmov [rsp], rax ; [rsp] = start of tape buffer" - ++ "\n" - -epilogue :: String -epilogue = - "\n\tmov rdi, [rsp]" - ++ "\n\tcall _free" - ++ "\n\txor eax, eax" - ++ "\n.return:" - ++ "\n\tadd rsp, 8" - ++ "\n\tpop rbx" - ++ "\n\tmov rsp, rbp" - ++ "\n\tpop rbp" - ++ "\n\tret" - ++ "\n.allocation_failure:" - ++ "\n\tsub rsp, 32" - ++ "\n\tmov rax, 0x697461636f6c6c41 ; \"Allocati\"" - ++ "\n\tmov rbx, 0x756c696166206e6f ; \"on failu\"" - ++ "\n\tmov ecx, 0x000a6572 ; \"re\\n\\0\"" - ++ "\n\tmov [rsp], rax" - ++ "\n\tmov [rsp+8], rbx" - ++ "\n\tmov [rsp+16], ecx" - ++ "\n\tmov edi, 2" - ++ "\n\tmov rsi, rsp" - ++ "\n\tmov edx, 20" - ++ "\n\tcall _write" - ++ "\n\tadd rsp, 32" - ++ "\n\tmov eax, 1" - ++ "\n\tjmp .return" diff --git a/interpreter.hs b/interpreter.hs deleted file mode 100644 index 4f3f3aa..0000000 --- a/interpreter.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Interpreter(interpret) where - -import qualified Data.Vector.Mutable as MV - -import AST - - -type Tape = MV.IOVector Byte - - -interpret :: Program -> [Byte] -> IO [Byte] -interpret (Program inss) inp = MV.replicate 60000 0 >>= \tape -> interInss 0 tape 30000 inss inp - -interInss :: Int -> Tape -> Int -> [Instruction] -> [Byte] -> IO [Byte] -interInss _ _ _ [] _ = return [] --- interInss count _ _ _ _ | count > 2000000000 = return [] -interInss !count !tape !memp allinss@(ins:rest) inp = case ins of - (IAdd value offset) -> do - MV.modify tape (+ value) (memp + offset) - interInss (count + 1) tape memp rest inp - (ISet value offset) -> do - MV.write tape (memp + offset) value - interInss (count + 1) tape memp rest inp - (ICopy from to mult) -> do - value <- MV.read tape (memp + from) - MV.modify tape ((+) (mult * value)) (memp + to) - interInss (count + 1) tape memp rest inp - (ISlide offset) -> do - interInss (count + 1) tape (memp + offset) rest inp - (ILoop iins offset) -> do - value <- MV.read tape (memp + offset) - if value /= 0 - then interInss (count + 1) tape memp (iins ++ allinss) inp - else interInss (count + 1) tape memp rest inp - (IInput offset) -> do - let (c:cs) = inp - MV.write tape (memp + offset) c - interInss (count + 1) tape memp rest cs - (IOutput offset) -> do - value <- MV.read tape (memp + offset) - (value :) <$> interInss (count + 1) tape memp rest inp - IStart -> do - interInss (count + 1) tape memp rest inp diff --git a/main.hs b/main.hs deleted file mode 100644 index 9c33f83..0000000 --- a/main.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Main where - -import Control.Monad -import Data.Char -import System.Environment -import System.Exit -import System.Process - -import AST -import Compiler -import Interpreter -import Parser -import Optimiser - - -data ExecutionMode = EMInterpret | EMCompile - -executionMode :: ExecutionMode -executionMode = EMCompile - - -main :: IO () -main = do - args <- getArgs - when (length args == 0 || length args > 2) - $ die "Usage: bfcomphs " - let fname = head args - - prog <- readFile fname >>= either die return . parseProgram - - -- putStrLn $ astSuccinct prog - -- print prog - let opt = optimise prog - writeFile (fname ++ ".succinct") $ astSuccinct opt - writeFile (fname ++ ".ast") $ show opt - - case executionMode of - EMInterpret -> do - input <- getContents - interpret opt (map (fromIntegral . ord) input) >>= (putStr . map (chr . fromIntegral)) - EMCompile -> do - writeFile (fname ++ ".asm") $ compile opt - callProcess "yasm" ["-f", "macho64", fname ++ ".asm", "-o", fname ++ ".o"] - callProcess "gcc" [fname ++ ".o", "-o", fname ++ ".exe"] diff --git a/optimiser.hs b/optimiser.hs deleted file mode 100644 index 3163c33..0000000 --- a/optimiser.hs +++ /dev/null @@ -1,167 +0,0 @@ -module Optimiser(optimise) where - -import Data.List -import qualified Data.Map.Strict as Map - --- import Debug.Trace - -import AST - - -type Optimisation = [Instruction] -> [Instruction] - - -optimisations :: [Optimisation] -optimisations = - [collectSimilar, nullOps, collectAdds, propagateKnowns, firstSets, propagateSlides, uselessEnd, specialLoops, normaliseOrder] - -composedOpts :: Optimisation -composedOpts = foldl1 (.) (reverse optimisations) --- composedOpts = foldl1 (.) (map (traceShowId .) $ reverse optimisations) --- composedOpts = foldl1 (.) (map ((\r -> traceShow (take 7 r) r) .) $ reverse optimisations) - -optimise :: Program -> Program -optimise (Program inss) = - Program $ repeated composedOpts inss - - -collectSimilar :: Optimisation -collectSimilar [] = [] -collectSimilar (IAdd x off1 : IAdd y off2 : rest) | off1 == off2 = - collectSimilar $ IAdd (x + y) off1 : rest -collectSimilar (ISlide off1 : ISlide off2 : rest) = - collectSimilar $ ISlide (off1 + off2) : rest -collectSimilar (ILoop inss off : rest) = ILoop (collectSimilar inss) off : collectSimilar rest -collectSimilar (ins : rest) = ins : collectSimilar rest - -nullOps :: Optimisation -nullOps [] = [] -nullOps (IAdd 0 _ : rest) = nullOps rest -nullOps (ICopy _ _ 0 : rest) = nullOps rest -nullOps (ISlide 0 : rest) = nullOps rest -nullOps (ILoop inss off : rest) = ILoop (nullOps inss) off : nullOps rest -nullOps (ins : rest) = ins : nullOps rest - -collectAdds :: Optimisation -collectAdds [] = [] -collectAdds (ICopy from1 to1 m1 : ICopy from2 to2 m2 : rest) - | from1 == from2, m1 == m2 = ICopy from1 to1 m1 : collectAdds (ICopy to1 to2 1 : rest) -collectAdds inss = - let adds = map (\(IAdd v o) -> (v, o)) $ takeWhile isIAdd inss - dests = nub $ map snd adds - collected = [(sum $ map fst $ filter ((== d) . snd) adds, d) | d <- dests] - rest = drop (length adds) inss - rest' = case rest of - [] -> [] - (i:is) -> i : collectAdds is - in map (uncurry IAdd) collected ++ rest' - -propagateKnowns :: Optimisation -propagateKnowns [] = [] -propagateKnowns allinss@(ins : _) | isISet ins || isIStart ins = - let defaultZero = isIStart ins - - go :: [Instruction] -> Map.Map Offset Byte -> ([Instruction], Map.Map Offset Byte) - go (IStart : rest) mp = go rest mp - go (ISet val off : rest) mp = go rest $ Map.insert off val mp - go inss@(IAdd val off : rest) mp = case Map.lookup off mp of - Nothing -> (inss, mp) - Just origval -> go rest $ Map.insert off (origval + val) mp - go inss@(ICopy from to mult : rest) mp = - if defaultZero - then let fromval = maybe 0 id $ Map.lookup from mp - toval = maybe 0 id $ Map.lookup to mp - in go rest $ Map.insert to (toval + mult * fromval) mp - else case (Map.lookup from mp, Map.lookup to mp) of - (Nothing, _) -> (inss, mp) - (_, Nothing) -> (inss, mp) - (Just fromval, Just toval) -> - go rest $ Map.insert to (toval + mult * fromval) mp - go inss mp = (inss, mp) - - compareSetAdd :: Instruction -> Instruction -> Ordering - compareSetAdd (ISet _ _) (IAdd _ _) = LT - compareSetAdd (IAdd _ _) (ISet _ _) = GT - compareSetAdd i1 i2 = compare (offsetOf i1) (offsetOf i2) - - (after, valuemap) = go allinss Map.empty - sets = sortBy compareSetAdd - $ Map.foldlWithKey - (\l off val -> if not defaultZero || val /= 0 then ISet val off : l else l) - [] valuemap - in if isIStart ins then IStart : sets ++ propagateKnowns after else sets ++ propagateKnowns after -propagateKnowns (ILoop inss off : rest) = ILoop (propagateKnowns inss) off : propagateKnowns rest -propagateKnowns (ins : rest) = ins : propagateKnowns rest - -firstSets :: Optimisation -firstSets [] = [] -firstSets (IStart : rest) = - let pre = takeWhile (\ins -> isIAdd ins || isISet ins) rest - post = drop (length pre) rest - dests = nub $ map offsetOf pre - collected = [ISet (accumSetAdd 0 (filter ((== d) . offsetOf) pre)) d | d <- dests] - in IStart : collected ++ post -firstSets inss = inss - -propagateSlides :: Optimisation -propagateSlides [] = [] -propagateSlides (ISlide off : rest) = propagateSlides (incOffsets off rest) ++ [ISlide off] -propagateSlides (ILoop inss off : rest) = ILoop (propagateSlides inss) off : propagateSlides rest -propagateSlides (ins : rest) = ins : propagateSlides rest - -uselessEnd :: Optimisation -uselessEnd [] = [] -uselessEnd inss = reverse $ dropWhile isUseless $ reverse inss - where - isUseless :: Instruction -> Bool - isUseless (IInput _) = False - isUseless (IOutput _) = False - isUseless (ILoop lp _) = all isUseless lp - isUseless _ = True - -specialLoops :: Optimisation -specialLoops [] = [] -specialLoops (ILoop [IAdd v off2] off1 : rest) - | off1 /= off2 = ILoop [] off1 : specialLoops rest - | gcd v 2 == 1 = ISet 0 off1 : specialLoops rest -specialLoops (ILoop inss off : rest) - | all isIAdd inss, - sum (map (\(IAdd v _) -> v) $ filter ((== off) . offsetOf) inss) == -1 = - let others = map (\(IAdd v o) -> (v, o)) $ filter ((/= off) . offsetOf) inss - dests = nub $ map snd others - copies = [ICopy off d (sum $ map fst $ filter ((== d) . snd) others) | d <- dests] - in copies ++ ISet 0 off : specialLoops rest -specialLoops (ILoop inss off : rest) = ILoop (specialLoops inss) off : specialLoops rest -specialLoops (ins : rest) = ins : specialLoops rest - -normaliseOrder :: Optimisation -normaliseOrder [] = [] -normaliseOrder (ICopy from1 to1 m1 : ICopy from2 to2 m2 : rest) - | m2 < m1, to1 /= from2, to2 /= from1 = ICopy from2 to2 m2 : normaliseOrder (ICopy from1 to1 m1 : rest) -normaliseOrder (ILoop inss off : rest) = ILoop (normaliseOrder inss) off : normaliseOrder rest -normaliseOrder (ins : rest) = ins : normaliseOrder rest - - -repeated :: Optimisation -> Optimisation -repeated opt = \inss -> let inss' = opt inss - in if inss == inss' then inss else repeated opt inss' - -incOffsets :: Offset -> [Instruction] -> [Instruction] -incOffsets _ [] = [] -incOffsets inc (IAdd v off : rest) = IAdd v (off + inc) : incOffsets inc rest -incOffsets inc (ISet v off : rest) = ISet v (off + inc) : incOffsets inc rest -incOffsets inc (ICopy from to mult : rest) = ICopy (from + inc) (to + inc) mult : incOffsets inc rest -incOffsets inc (ISlide off : rest) = ISlide off : incOffsets inc rest -incOffsets inc (ILoop inss off : rest) = ILoop (incOffsets inc inss) (off + inc) : incOffsets inc rest -incOffsets inc (IInput off : rest) = IInput (off + inc) : incOffsets inc rest -incOffsets inc (IOutput off : rest) = IOutput (off + inc) : incOffsets inc rest -incOffsets inc (IStart : rest) = IStart : incOffsets inc rest - -accumSetAdd :: Byte -> [Instruction] -> Byte -accumSetAdd acc [] = acc -accumSetAdd _ (ISet v' _ : rest) = accumSetAdd v' rest -accumSetAdd acc (IAdd v' _ : rest) = accumSetAdd (acc + v') rest -accumSetAdd _ _ = unreachable - -unreachable :: a -unreachable = error "Unreachable" diff --git a/parser.hs b/parser.hs deleted file mode 100644 index f2961ba..0000000 --- a/parser.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Parser(parseProgram) where - -import AST - - -parseProgram :: String -> Either String Program -parseProgram src = do - (inss, "") <- parseLoop 0 src - return $ Program $ IStart : inss - -parseLoop :: Int -> String -> Either String ([Instruction], String) -parseLoop 0 "" = Right ([], "") -parseLoop _ "" = Left "More '[' than ']'" -parseLoop 0 (']':_) = Left "Unexpected ']'" -parseLoop _ (']':cs) = Right ([], cs) -parseLoop d ('[':cs) = do - (lp, rest) <- parseLoop (d+1) cs - (after, rest') <- parseLoop d rest - return (ILoop lp 0 : after, rest') -parseLoop d (c:cs) - | Just ins <- parseSimple c = do - (lp, rest) <- parseLoop d cs - return (ins:lp, rest) -parseLoop d (_:cs) = parseLoop d cs - -parseSimple :: Char -> Maybe Instruction -parseSimple '+' = Just $ IAdd 1 0 -parseSimple '-' = Just $ IAdd (-1) 0 -parseSimple '>' = Just $ ISlide 1 -parseSimple '<' = Just $ ISlide (-1) -parseSimple ',' = Just $ IInput 0 -parseSimple '.' = Just $ IOutput 0 -parseSimple _ = Nothing diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..b1aebdc --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-11.5 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.6" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file -- cgit v1.2.3-70-g09d2