diff options
| -rw-r--r-- | .gitignore | 5 | ||||
| -rw-r--r-- | ast.hs | 70 | ||||
| -rw-r--r-- | compiler.hs | 131 | ||||
| -rw-r--r-- | interpreter.hs | 46 | ||||
| -rw-r--r-- | main.hs | 46 | ||||
| -rw-r--r-- | mandel.bf | 145 | ||||
| -rw-r--r-- | o.bf | 1 | ||||
| -rw-r--r-- | optimiser.hs | 154 | ||||
| -rw-r--r-- | parser.hs | 33 |
9 files changed, 631 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..25c1742 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +main +*.o +*.hi +*.asm +*.exe @@ -0,0 +1,70 @@ +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 + | IMove Offset [(Offset, Byte)] -- IMove 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 + +isIMove :: Instruction -> Bool +isIMove (IMove _ _) = True +isIMove _ = False + +isISlide :: Instruction -> Bool +isISlide (ISlide _) = True +isISlide _ = False + +offsetOf :: Instruction -> Offset +offsetOf (IAdd _ o) = o +offsetOf (ISet _ o) = o +offsetOf (IMove 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) = concatMap 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 (IMove from tos) = + 'M' : show from ++ '(' : intercalate "," (map (\(o,m) -> show o ++ '*' : show m) tos) ++ ")" + insSuccinct (ISlide o) = '>' : show o + insSuccinct (ILoop inss' off) = "[(" ++ show off ++ ')' : concatMap 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..8a98a2d --- /dev/null +++ b/compiler.hs @@ -0,0 +1,131 @@ +{-# 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 + +cursor :: String +cursor = "rbx" + +compileIns :: Instruction -> LineWriter () +compileIns (IAdd v off) = emit $ "add byte [" ++ cursor ++ " + " ++ show off ++ "], " ++ show v +compileIns (ISet v off) = emit $ "mov byte [" ++ cursor ++ " + " ++ show off ++ "], " ++ show v +compileIns (IMove from []) = do + emit $ "mov byte [" ++ cursor ++ " + " ++ show from ++ "], 0" +compileIns (IMove from [(o,m)]) = do + emit $ "mov al, [" ++ cursor ++ " + " ++ show from ++ "]" + if m == 1 then return () + else do + emit $ "mov cl, " ++ show m + emit "mul byte cl" + emit $ "add [" ++ cursor ++ " + " ++ show o ++ "], al" + emit $ "mov byte [" ++ cursor ++ " + " ++ show from ++ "], 0" +compileIns (IMove from tos) = do + emit $ "mov dl, [" ++ cursor ++ " + " ++ show from ++ "]" + emit $ "mov byte [" ++ cursor ++ " + " ++ show from ++ "], 0" + forM_ tos $ \(o,m) -> do + emit "mov al, dl" + if m == 1 then return () + else do + emit $ "mov cl, " ++ show m + emit "mul byte cl" + emit $ "add [" ++ cursor ++ " + " ++ show o ++ "], al" +compileIns (ISlide off) = emit $ "add " ++ cursor ++ ", " ++ show off +compileIns (ILoop inss off) = do + loopid <- genId + emit $ "cmp byte [" ++ cursor ++ " + " ++ show off ++ "], 0" + emit $ "jz .Laf_" ++ show loopid + emit0 $ ".Lbd_" ++ show loopid ++ ":" + mapM_ compileIns inss + emit $ "cmp byte [" ++ cursor ++ " + " ++ show off ++ "], 0" + emit $ "jnz .Lbd_" ++ show loopid + emit0 $ ".Laf_" ++ show loopid ++ ":" +compileIns (IInput off) = do + emit "call _getchar" + emit $ "mov [" ++ cursor ++ " + " ++ show off ++ "], al" +compileIns (IOutput off) = do + emit "xor edi, edi" + emit $ "mov dil, [" ++ cursor ++ " + " ++ show off ++ "]" + emit "call _putchar" +compileIns IStart = return () + + +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..59b9402 --- /dev/null +++ b/interpreter.hs @@ -0,0 +1,46 @@ +{-# 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 + (IMove from tos) -> do + value <- MV.read tape (memp + from) + MV.write tape (memp + from) 0 + mapM_ (\(offset, multiplier) -> MV.modify tape ((+) (multiplier * value)) (memp + offset)) tos + 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 @@ -0,0 +1,46 @@ +module Main where + +import Control.DeepSeq +import Control.Monad +import Data.Char +import System.Environment +import System.Exit + +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 <source.bf> [source.bf.asm]" + let fname = head args + destfname = if length args == 2 then args !! 1 else fname ++ ".asm" + + prog <- readFile fname >>= either die return . parseProgram + + -- putStrLn $ astSuccinct prog + -- print prog + let opt = optimise prog + showopt = force $ show opt + when False $ putStrLn $ astSuccinct opt + when False $ putStrLn showopt + + case executionMode of + EMInterpret -> do + -- input <- getContents + -- putStr $ map (chr . fromIntegral) $ interpret opt (map (fromIntegral . ord) input) + input <- getContents + interpret opt (map (fromIntegral . ord) input) >>= (putStr . map (chr . fromIntegral)) + EMCompile -> do + writeFile destfname $ compile opt diff --git a/mandel.bf b/mandel.bf new file mode 100644 index 0000000..6cd75ae --- /dev/null +++ b/mandel.bf @@ -0,0 +1,145 @@ + A mandelbrot set fractal viewer in brainf*** written by Erik Bosman ++++++++++++++[->++>>>+++++>++>+<<<<<<]>>>>>++++++>--->>>>>>>>>>+++++++++++++++[[ +>>>>>>>>>]+[<<<<<<<<<]>>>>>>>>>-]+[>>>>>>>>[-]>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>[-]+ +<<<<<<<+++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>>>>+>>>>>>>>>>>>>>>>>>>>>>>>>> +>+<<<<<<<<<<<<<<<<<[<<<<<<<<<]>>>[-]+[>>>>>>[>>>>>>>[-]>>]<<<<<<<<<[<<<<<<<<<]>> +>>>>>[-]+<<<<<<++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>>>+<<<<<<+++++++[-[->>> +>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>>>+<<<<<<<<<<<<<<<<[<<<<<<<<<]>>>[[-]>>>>>>[>>>>> +>>[-<<<<<<+>>>>>>]<<<<<<[->>>>>>+<<+<<<+<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>> +[>>>>>>>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+<<+<<<+<<]>>>>>>>>]<<<<<<<<<[<<<<<<< +<<]>>>>>>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+<<+<<<<<]>>>>>>>>>+++++++++++++++[[ +>>>>>>>>>]+>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+[ +>+>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>[-<<<<+>>>>]<<<<[->>>>+<<<<<[->>[ +-<<+>>]<<[->>+>>+<<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>>>>>>>>>]<<<<<<< +<<[>[->>>>>>>>>+<<<<<<<<<]<<<<<<<<<<]>[->>>>>>>>>+<<<<<<<<<]<+>>>>>>>>]<<<<<<<<< +[>[-]<->>>>[-<<<<+>[<->-<<<<<<+>>>>>>]<[->+<]>>>>]<<<[->>>+<<<]<+<<<<<<<<<]>>>>> +>>>>[>+>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>>[-<<<<<+>>>>>]<<<<<[->>>>>+ +<<<<<<[->>>[-<<<+>>>]<<<[->>>+>+<<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>> +>>>>>>>]<<<<<<<<<[>>[->>>>>>>>>+<<<<<<<<<]<<<<<<<<<<<]>>[->>>>>>>>>+<<<<<<<<<]<< ++>>>>>>>>]<<<<<<<<<[>[-]<->>>>[-<<<<+>[<->-<<<<<<+>>>>>>]<[->+<]>>>>]<<<[->>>+<< +<]<+<<<<<<<<<]>>>>>>>>>[>>>>[-<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<+>>>>>>>>>>>>> +>>>>>>>>>>>>>>>>>>>>>>>]>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>+++++++++++++++[[>>>> +>>>>>]<<<<<<<<<-<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+>>>>>>>>>>>>>>>>>>>>>+<<<[<<<<<< +<<<]>>>>>>>>>[>>>[-<<<->>>]+<<<[->>>->[-<<<<+>>>>]<<<<[->>>>+<<<<<<<<<<<<<[<<<<< +<<<<]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>>>[-<<<<->>>>]+<<<<[->>>>-<[-<<<+>>>]<<<[-> +>>+<<<<<<<<<<<<[<<<<<<<<<]>>>[-]+>>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>>>>>>>>>]<<<<<< +<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]<<<<<<<[->+>>>-<<<<]>>>>>>>>>+++++++++++++++++++ ++++++++>>[-<<<<+>>>>]<<<<[->>>>+<<[-]<<]>>[<<<<<<<+<[-<+>>>>+<<[-]]>[-<<[->+>>>- +<<<<]>>>]>>>>>>>>>>>>>[>>[-]>[-]>[-]>>>>>]<<<<<<<<<[<<<<<<<<<]>>>[-]>>>>>>[>>>>> +[-<<<<+>>>>]<<<<[->>>>+<<<+<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>>[-<<<<<<<< +<+>>>>>>>>>]>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>+++++++++++++++[[>>>>>>>>>]+>[- +]>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+[>+>>>>>>>>]<<< +<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>>[-<<<<<+>>>>>]<<<<<[->>>>>+<<<<<<[->>[-<<+>>]< +<[->>+>+<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>>>>>>>>>]<<<<<<<<<[>[->>>> +>>>>>+<<<<<<<<<]<<<<<<<<<<]>[->>>>>>>>>+<<<<<<<<<]<+>>>>>>>>]<<<<<<<<<[>[-]<->>> +[-<<<+>[<->-<<<<<<<+>>>>>>>]<[->+<]>>>]<<[->>+<<]<+<<<<<<<<<]>>>>>>>>>[>>>>>>[-< +<<<<+>>>>>]<<<<<[->>>>>+<<<<+<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>+>>>>>>>> +]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>>[-<<<<<+>>>>>]<<<<<[->>>>>+<<<<<<[->>[-<<+ +>>]<<[->>+>>+<<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>>>>>>>>>]<<<<<<<<<[> +[->>>>>>>>>+<<<<<<<<<]<<<<<<<<<<]>[->>>>>>>>>+<<<<<<<<<]<+>>>>>>>>]<<<<<<<<<[>[- +]<->>>>[-<<<<+>[<->-<<<<<<+>>>>>>]<[->+<]>>>>]<<<[->>>+<<<]<+<<<<<<<<<]>>>>>>>>> +[>>>>[-<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<+>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +]>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>[-<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<+> +>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>]>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>++++++++ ++++++++[[>>>>>>>>>]<<<<<<<<<-<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+[>>>>>>>>[-<<<<<<<+ +>>>>>>>]<<<<<<<[->>>>>>>+<<<<<<+<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>>>>[ +-]>>>]<<<<<<<<<[<<<<<<<<<]>>>>+>[-<-<<<<+>>>>>]>[-<<<<<<[->>>>>+<++<<<<]>>>>>[-< +<<<<+>>>>>]<->+>]<[->+<]<<<<<[->>>>>+<<<<<]>>>>>>[-]<<<<<<+>>>>[-<<<<->>>>]+<<<< +[->>>>->>>>>[>>[-<<->>]+<<[->>->[-<<<+>>>]<<<[->>>+<<<<<<<<<<<<[<<<<<<<<<]>>>[-] ++>>>>>>[>>>>>>>>>]>+<]]+>>>[-<<<->>>]+<<<[->>>-<[-<<+>>]<<[->>+<<<<<<<<<<<[<<<<< +<<<<]>>>>[-]+>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>>>>>>>>>]<<<<<<<<]>>>>>>>>]<<<<<<<<< +[<<<<<<<<<]>>>>[-<<<<+>>>>]<<<<[->>>>+>>>>>[>+>>[-<<->>]<<[->>+<<]>>>>>>>>]<<<<< +<<<+<[>[->>>>>+<<<<[->>>>-<<<<<<<<<<<<<<+>>>>>>>>>>>[->>>+<<<]<]>[->>>-<<<<<<<<< +<<<<<+>>>>>>>>>>>]<<]>[->>>>+<<<[->>>-<<<<<<<<<<<<<<+>>>>>>>>>>>]<]>[->>>+<<<]<< +<<<<<<<<<<]>>>>[-]<<<<]>>>[-<<<+>>>]<<<[->>>+>>>>>>[>+>[-<->]<[->+<]>>>>>>>>]<<< +<<<<<+<[>[->>>>>+<<<[->>>-<<<<<<<<<<<<<<+>>>>>>>>>>[->>>>+<<<<]>]<[->>>>-<<<<<<< +<<<<<<<+>>>>>>>>>>]<]>>[->>>+<<<<[->>>>-<<<<<<<<<<<<<<+>>>>>>>>>>]>]<[->>>>+<<<< +]<<<<<<<<<<<]>>>>>>+<<<<<<]]>>>>[-<<<<+>>>>]<<<<[->>>>+>>>>>[>>>>>>>>>]<<<<<<<<< +[>[->>>>>+<<<<[->>>>-<<<<<<<<<<<<<<+>>>>>>>>>>>[->>>+<<<]<]>[->>>-<<<<<<<<<<<<<< ++>>>>>>>>>>>]<<]>[->>>>+<<<[->>>-<<<<<<<<<<<<<<+>>>>>>>>>>>]<]>[->>>+<<<]<<<<<<< +<<<<<]]>[-]>>[-]>[-]>>>>>[>>[-]>[-]>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>>>[-< +<<<+>>>>]<<<<[->>>>+<<<+<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>+++++++++++++++[ +[>>>>>>>>>]+>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+ +[>+>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>[-<<<<+>>>>]<<<<[->>>>+<<<<<[->> +[-<<+>>]<<[->>+>+<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>>>>>>>>>]<<<<<<<< +<[>[->>>>>>>>>+<<<<<<<<<]<<<<<<<<<<]>[->>>>>>>>>+<<<<<<<<<]<+>>>>>>>>]<<<<<<<<<[ +>[-]<->>>[-<<<+>[<->-<<<<<<<+>>>>>>>]<[->+<]>>>]<<[->>+<<]<+<<<<<<<<<]>>>>>>>>>[ +>>>[-<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<+>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>]> +>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>[-]>>>>+++++++++++++++[[>>>>>>>>>]<<<<<<<<<-<<<<< +<<<<[<<<<<<<<<]>>>>>>>>>-]+[>>>[-<<<->>>]+<<<[->>>->[-<<<<+>>>>]<<<<[->>>>+<<<<< +<<<<<<<<[<<<<<<<<<]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>>>[-<<<<->>>>]+<<<<[->>>>-<[- +<<<+>>>]<<<[->>>+<<<<<<<<<<<<[<<<<<<<<<]>>>[-]+>>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>> +>>>>>>>]<<<<<<<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>[-<<<+>>>]<<<[->>>+>>>>>>[>+>>> +[-<<<->>>]<<<[->>>+<<<]>>>>>>>>]<<<<<<<<+<[>[->+>[-<-<<<<<<<<<<+>>>>>>>>>>>>[-<< ++>>]<]>[-<<-<<<<<<<<<<+>>>>>>>>>>>>]<<<]>>[-<+>>[-<<-<<<<<<<<<<+>>>>>>>>>>>>]<]> +[-<<+>>]<<<<<<<<<<<<<]]>>>>[-<<<<+>>>>]<<<<[->>>>+>>>>>[>+>>[-<<->>]<<[->>+<<]>> +>>>>>>]<<<<<<<<+<[>[->+>>[-<<-<<<<<<<<<<+>>>>>>>>>>>[-<+>]>]<[-<-<<<<<<<<<<+>>>> +>>>>>>>]<<]>>>[-<<+>[-<-<<<<<<<<<<+>>>>>>>>>>>]>]<[-<+>]<<<<<<<<<<<<]>>>>>+<<<<< +]>>>>>>>>>[>>>[-]>[-]>[-]>>>>]<<<<<<<<<[<<<<<<<<<]>>>[-]>[-]>>>>>[>>>>>>>[-<<<<< +<+>>>>>>]<<<<<<[->>>>>>+<<<<+<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>+>[-<-<<<<+>>>> +>]>>[-<<<<<<<[->>>>>+<++<<<<]>>>>>[-<<<<<+>>>>>]<->+>>]<<[->>+<<]<<<<<[->>>>>+<< +<<<]+>>>>[-<<<<->>>>]+<<<<[->>>>->>>>>[>>>[-<<<->>>]+<<<[->>>-<[-<<+>>]<<[->>+<< +<<<<<<<<<[<<<<<<<<<]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>[-<<->>]+<<[->>->[-<<<+>>>]< +<<[->>>+<<<<<<<<<<<<[<<<<<<<<<]>>>[-]+>>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>>>>>>>>>]< +<<<<<<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>[-<<<+>>>]<<<[->>>+>>>>>>[>+>[-<->]<[->+ +<]>>>>>>>>]<<<<<<<<+<[>[->>>>+<<[->>-<<<<<<<<<<<<<+>>>>>>>>>>[->>>+<<<]>]<[->>>- +<<<<<<<<<<<<<+>>>>>>>>>>]<]>>[->>+<<<[->>>-<<<<<<<<<<<<<+>>>>>>>>>>]>]<[->>>+<<< +]<<<<<<<<<<<]>>>>>[-]>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+<<+<<<<<]]>>>>[-<<<<+> +>>>]<<<<[->>>>+>>>>>[>+>>[-<<->>]<<[->>+<<]>>>>>>>>]<<<<<<<<+<[>[->>>>+<<<[->>>- +<<<<<<<<<<<<<+>>>>>>>>>>>[->>+<<]<]>[->>-<<<<<<<<<<<<<+>>>>>>>>>>>]<<]>[->>>+<<[ +->>-<<<<<<<<<<<<<+>>>>>>>>>>>]<]>[->>+<<]<<<<<<<<<<<<]]>>>>[-]<<<<]>>>>[-<<<<+>> +>>]<<<<[->>>>+>[-]>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+<<+<<<<<]>>>>>>>>>[>>>>>> +>>>]<<<<<<<<<[>[->>>>+<<<[->>>-<<<<<<<<<<<<<+>>>>>>>>>>>[->>+<<]<]>[->>-<<<<<<<< +<<<<<+>>>>>>>>>>>]<<]>[->>>+<<[->>-<<<<<<<<<<<<<+>>>>>>>>>>>]<]>[->>+<<]<<<<<<<< +<<<<]]>>>>>>>>>[>>[-]>[-]>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>[-]>[-]>>>>>[>>>>>[-<<<<+ +>>>>]<<<<[->>>>+<<<+<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>>>>[-<<<<<+>>>>> +]<<<<<[->>>>>+<<<+<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>+++++++++++++++[[>>>> +>>>>>]+>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+[>+>> +>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>[-<<<<+>>>>]<<<<[->>>>+<<<<<[->>[-<<+ +>>]<<[->>+>>+<<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>>>>>>>>>]<<<<<<<<<[> +[->>>>>>>>>+<<<<<<<<<]<<<<<<<<<<]>[->>>>>>>>>+<<<<<<<<<]<+>>>>>>>>]<<<<<<<<<[>[- +]<->>>>[-<<<<+>[<->-<<<<<<+>>>>>>]<[->+<]>>>>]<<<[->>>+<<<]<+<<<<<<<<<]>>>>>>>>> +[>+>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>>[-<<<<<+>>>>>]<<<<<[->>>>>+<<<< +<<[->>>[-<<<+>>>]<<<[->>>+>+<<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>>>>>> +>>>]<<<<<<<<<[>>[->>>>>>>>>+<<<<<<<<<]<<<<<<<<<<<]>>[->>>>>>>>>+<<<<<<<<<]<<+>>> +>>>>>]<<<<<<<<<[>[-]<->>>>[-<<<<+>[<->-<<<<<<+>>>>>>]<[->+<]>>>>]<<<[->>>+<<<]<+ +<<<<<<<<<]>>>>>>>>>[>>>>[-<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<+>>>>>>>>>>>>>>>>> +>>>>>>>>>>>>>>>>>>>]>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>+++++++++++++++[[>>>>>>>> +>]<<<<<<<<<-<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+>>>>>>>>>>>>>>>>>>>>>+<<<[<<<<<<<<<] +>>>>>>>>>[>>>[-<<<->>>]+<<<[->>>->[-<<<<+>>>>]<<<<[->>>>+<<<<<<<<<<<<<[<<<<<<<<< +]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>>>[-<<<<->>>>]+<<<<[->>>>-<[-<<<+>>>]<<<[->>>+< +<<<<<<<<<<<[<<<<<<<<<]>>>[-]+>>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>>>>>>>>>]<<<<<<<<]> +>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>->>[-<<<<+>>>>]<<<<[->>>>+<<[-]<<]>>]<<+>>>>[-<<<< +->>>>]+<<<<[->>>>-<<<<<<.>>]>>>>[-<<<<<<<.>>>>>>>]<<<[-]>[-]>[-]>[-]>[-]>[-]>>>[ +>[-]>[-]>[-]>[-]>[-]>[-]>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>>>[-]>>>>]<<<<<<<<< +[<<<<<<<<<]>+++++++++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>+>>>>>>>>>+<<<<<<<< +<<<<<<[<<<<<<<<<]>>>>>>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+[-]>>[>>>>>>>>>]<<<<< +<<<<[>>>>>>>[-<<<<<<+>>>>>>]<<<<<<[->>>>>>+<<<<<<<[<<<<<<<<<]>>>>>>>[-]+>>>]<<<< +<<<<<<]]>>>>>>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+>>[>+>>>>[-<<<<->>>>]<<<<[->>> +>+<<<<]>>>>>>>>]<<+<<<<<<<[>>>>>[->>+<<]<<<<<<<<<<<<<<]>>>>>>>>>[>>>>>>>>>]<<<<< +<<<<[>[-]<->>>>>>>[-<<<<<<<+>[<->-<<<+>>>]<[->+<]>>>>>>>]<<<<<<[->>>>>>+<<<<<<]< ++<<<<<<<<<]>>>>>>>-<<<<[-]+<<<]+>>>>>>>[-<<<<<<<->>>>>>>]+<<<<<<<[->>>>>>>->>[>> +>>>[->>+<<]>>>>]<<<<<<<<<[>[-]<->>>>>>>[-<<<<<<<+>[<->-<<<+>>>]<[->+<]>>>>>>>]<< +<<<<[->>>>>>+<<<<<<]<+<<<<<<<<<]>+++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>+<<< +<<[<<<<<<<<<]>>>>>>>>>[>>>>>[-<<<<<->>>>>]+<<<<<[->>>>>->>[-<<<<<<<+>>>>>>>]<<<< +<<<[->>>>>>>+<<<<<<<<<<<<<<<<[<<<<<<<<<]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>>>>>>[-< +<<<<<<->>>>>>>]+<<<<<<<[->>>>>>>-<<[-<<<<<+>>>>>]<<<<<[->>>>>+<<<<<<<<<<<<<<[<<< +<<<<<<]>>>[-]+>>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>>>>>>>>>]<<<<<<<<]>>>>>>>>]<<<<<<< +<<[<<<<<<<<<]>>>>[-]<<<+++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>-<<<<<[<<<<<<< +<<]]>>>]<<<<.>>>>>>>>>>[>>>>>>[-]>>>]<<<<<<<<<[<<<<<<<<<]>++++++++++[-[->>>>>>>> +>+<<<<<<<<<]>>>>>>>>>]>>>>>+>>>>>>>>>+<<<<<<<<<<<<<<<[<<<<<<<<<]>>>>>>>>[-<<<<<< +<<+>>>>>>>>]<<<<<<<<[->>>>>>>>+[-]>[>>>>>>>>>]<<<<<<<<<[>>>>>>>>[-<<<<<<<+>>>>>> +>]<<<<<<<[->>>>>>>+<<<<<<<<[<<<<<<<<<]>>>>>>>>[-]+>>]<<<<<<<<<<]]>>>>>>>>[-<<<<< +<<<+>>>>>>>>]<<<<<<<<[->>>>>>>>+>[>+>>>>>[-<<<<<->>>>>]<<<<<[->>>>>+<<<<<]>>>>>> +>>]<+<<<<<<<<[>>>>>>[->>+<<]<<<<<<<<<<<<<<<]>>>>>>>>>[>>>>>>>>>]<<<<<<<<<[>[-]<- +>>>>>>>>[-<<<<<<<<+>[<->-<<+>>]<[->+<]>>>>>>>>]<<<<<<<[->>>>>>>+<<<<<<<]<+<<<<<< +<<<]>>>>>>>>-<<<<<[-]+<<<]+>>>>>>>>[-<<<<<<<<->>>>>>>>]+<<<<<<<<[->>>>>>>>->[>>> +>>>[->>+<<]>>>]<<<<<<<<<[>[-]<->>>>>>>>[-<<<<<<<<+>[<->-<<+>>]<[->+<]>>>>>>>>]<< +<<<<<[->>>>>>>+<<<<<<<]<+<<<<<<<<<]>+++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>> ++>>>>>>>>>>>>>>>>>>>>>>>>>>>+<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>>>>[-<<<<<<->>>>>>]+< +<<<<<[->>>>>>->>[-<<<<<<<<+>>>>>>>>]<<<<<<<<[->>>>>>>>+<<<<<<<<<<<<<<<<<[<<<<<<< +<<]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>>>>>>>[-<<<<<<<<->>>>>>>>]+<<<<<<<<[->>>>>>>> +-<<[-<<<<<<+>>>>>>]<<<<<<[->>>>>>+<<<<<<<<<<<<<<<[<<<<<<<<<]>>>[-]+>>>>>>[>>>>>> +>>>]>[-]+<]]+>[-<[>>>>>>>>>]<<<<<<<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>[-]<<<++++ ++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>>->>>>>>>>>>>>>>>>>>>>>>>>>>>-<<<<<<[<<<< +<<<<<]]>>>]
\ No newline at end of file @@ -0,0 +1 @@ ++++++++++++[>++++++++++<-]>+. diff --git a/optimiser.hs b/optimiser.hs new file mode 100644 index 0000000..61096b4 --- /dev/null +++ b/optimiser.hs @@ -0,0 +1,154 @@ +module Optimiser(optimise) where + +import Data.List + +-- import Debug.Trace + +import AST + + +type Optimisation = [Instruction] -> [Instruction] + + +optimisations :: [Optimisation] +optimisations = + [collectSimilar, nullOps, collectAdds, propagateKnowns, firstSets, propagateSlides, uselessEnd, specialLoops, normaliseOrder, deduplicateSets] + +composedOpts :: Optimisation +composedOpts = foldl1 (.) (reverse optimisations) +-- composedOpts = foldl1 (.) (map (traceShowId .) $ 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 (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 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 (ISet v off : rest) = + let pre = takeWhile (\ins -> isIAdd ins || isISet ins || isIMove ins) rest + post = drop (length pre) rest + relevant = filter ((== off) . offsetOf) pre + irrelevant = filter ((/= off) . offsetOf) pre + (res, resins) = accumSetAddMove v relevant + in ISet res off : resins ++ propagateKnowns (irrelevant ++ post) +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 + tos = [(d, sum $ map fst $ filter ((== d) . snd) others) | d <- dests] + in IMove off tos : specialLoops rest +specialLoops (ILoop inss off : rest) = ILoop (specialLoops inss) off : specialLoops rest +specialLoops (ins : rest) = ins : specialLoops rest + +normaliseOrder :: Optimisation +normaliseOrder [] = [] +normaliseOrder inss = + let pre = takeWhile (\ins -> isIAdd ins || isISet ins) inss + post = drop (length pre) inss + in if null pre + then head inss : normaliseOrder (tail inss) + else filter isISet pre ++ filter isIAdd pre ++ normaliseOrder post + +deduplicateSets :: Optimisation +deduplicateSets [] = [] +deduplicateSets (IStart : ISet 0 _ : rest) = IStart : deduplicateSets rest +deduplicateSets (ISet _ o1 : ISet v o2 : rest) | o1 == o2 = deduplicateSets $ ISet v o1 : rest +deduplicateSets (ins : rest) = ins : deduplicateSets 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 (IMove from tos : rest) = IMove (from + inc) [(o+inc,m) | (o,m) <- tos] : 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 + +accumSetAddMove :: Byte -> [Instruction] -> (Byte, [Instruction]) +accumSetAddMove acc [] = (acc, []) +accumSetAddMove _ (ISet v' _ : rest) = accumSetAddMove v' rest +accumSetAddMove acc (IAdd v' _ : rest) = accumSetAddMove (acc + v') rest +accumSetAddMove acc (IMove _ tos : rest) = + let (res, resins) = accumSetAddMove 0 rest + in (res, [IAdd (m * acc) o | (o,m) <- tos] ++ resins) +accumSetAddMove _ _ = 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 |