From d015d797fe8d152864cdd5f1ce284bd5ff467f9e Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Thu, 13 Jul 2017 23:24:04 +0200 Subject: Initial --- .gitignore | 5 ++ ast.hs | 70 ++++++++++++++++++++++++++ compiler.hs | 131 ++++++++++++++++++++++++++++++++++++++++++++++++ interpreter.hs | 46 +++++++++++++++++ main.hs | 46 +++++++++++++++++ mandel.bf | 145 +++++++++++++++++++++++++++++++++++++++++++++++++++++ o.bf | 1 + optimiser.hs | 154 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ parser.hs | 33 +++++++++++++ 9 files changed, 631 insertions(+) create mode 100644 .gitignore create mode 100644 ast.hs create mode 100644 compiler.hs create mode 100644 interpreter.hs create mode 100644 main.hs create mode 100644 mandel.bf create mode 100644 o.bf create mode 100644 optimiser.hs create mode 100644 parser.hs 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 diff --git a/ast.hs b/ast.hs new file mode 100644 index 0000000..9a4373d --- /dev/null +++ b/ast.hs @@ -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 diff --git a/main.hs b/main.hs new file mode 100644 index 0000000..c46e5da --- /dev/null +++ b/main.hs @@ -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.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 diff --git a/o.bf b/o.bf new file mode 100644 index 0000000..21102a9 --- /dev/null +++ b/o.bf @@ -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 -- cgit v1.2.3-70-g09d2