diff options
Diffstat (limited to 'compiler.hs')
-rw-r--r-- | compiler.hs | 131 |
1 files changed, 131 insertions, 0 deletions
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" |