From bfb231d48357b4ee754c447d4f0bb9cfbed7260c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bart=C5=82omiej=20Przemys=C5=82aw=20Pluta?= Date: Tue, 9 Nov 2021 18:25:15 +0100 Subject: [PATCH] Split VirtualMachine module --- MVM.cabal | 8 +- app/Assembler/Parser.hs | 2 +- app/Assembler/Tokenizer.hs | 2 +- app/Main.hs | 15 +- .../Instruction.hs} | 186 +----------------- app/VirtualMachine/Interpreter.hs | 88 +++++++++ app/VirtualMachine/VM.hs | 98 +++++++++ test/Assembler/EmitterSpec.hs | 2 +- test/Assembler/ParserSpec.hs | 2 +- test/Assembler/TokenizerSpec.hs | 2 +- 10 files changed, 212 insertions(+), 193 deletions(-) rename app/{VirtualMachine.hs => VirtualMachine/Instruction.hs} (52%) create mode 100644 app/VirtualMachine/Interpreter.hs create mode 100644 app/VirtualMachine/VM.hs diff --git a/MVM.cabal b/MVM.cabal index dd0d1f1..51d0a42 100644 --- a/MVM.cabal +++ b/MVM.cabal @@ -27,7 +27,9 @@ executable MVM -- Modules included in this executable, other than Main. other-modules: - VirtualMachine + VirtualMachine.VM + VirtualMachine.Instruction + VirtualMachine.Interpreter Assembler.Tokenizer Assembler.Parser Assembler.Emitter @@ -66,7 +68,9 @@ test-suite spec Assembler.EmitterSpec UtilSpec - VirtualMachine + VirtualMachine.VM + VirtualMachine.Instruction + VirtualMachine.Interpreter Assembler.Tokenizer Assembler.Parser Assembler.Emitter diff --git a/app/Assembler/Parser.hs b/app/Assembler/Parser.hs index 4ce4d55..b264547 100644 --- a/app/Assembler/Parser.hs +++ b/app/Assembler/Parser.hs @@ -4,7 +4,7 @@ import Data.List (intercalate) import Data.Monoid (First(..)) import qualified Assembler.Tokenizer as T (Token(..)) -import VirtualMachine (Op) +import VirtualMachine.VM (Op) import Util (explode) diff --git a/app/Assembler/Tokenizer.hs b/app/Assembler/Tokenizer.hs index 5bf306f..f071fff 100644 --- a/app/Assembler/Tokenizer.hs +++ b/app/Assembler/Tokenizer.hs @@ -4,7 +4,7 @@ import Data.List (sortBy) import Data.Char (ord, isDigit, isSpace, isAlpha, isAlphaNum, isHexDigit) import Data.Monoid (First(..)) -import VirtualMachine (Op(..)) +import VirtualMachine.VM (Op(..)) import Util (toLowerCase, controlChar, unescape) diff --git a/app/Main.hs b/app/Main.hs index afb915c..76e384a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,22 +1,21 @@ module Main where import System.Environment -import qualified Data.ByteString as B -import qualified VirtualMachine as VM +import Control.Monad.Trans.Except (runExceptT, except) +import VirtualMachine.VM (VM) +import VirtualMachine.Interpreter (run) import Assembler.Compiler (compile) +import qualified Data.ByteString as B -import Control.Monad.Trans.Except - - -run :: String -> IO (Either String VM.VM) -run input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= VM.run +interpret :: String -> IO (Either String VM) +interpret input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= run main :: IO () main = do (filename:_) <- getArgs input <- readFile filename - result <- run input + result <- interpret input case result of (Right vm) -> do putStrLn $ "\n\nDone:\n" ++ (show vm) diff --git a/app/VirtualMachine.hs b/app/VirtualMachine/Instruction.hs similarity index 52% rename from app/VirtualMachine.hs rename to app/VirtualMachine/Instruction.hs index 8870a34..3cfdf41 100644 --- a/app/VirtualMachine.hs +++ b/app/VirtualMachine/Instruction.hs @@ -1,48 +1,15 @@ -module VirtualMachine where - -import qualified Data.Map as M -import qualified Data.Sequence as S -import qualified Data.ByteString as B +module VirtualMachine.Instruction where import Data.Char (chr) import Data.Word (Word8) -import Data.Foldable (toList) -import Control.Monad.State (State, put, get, execState, evalState, runState) import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Except (ExceptT, except, runExceptT) +import Control.Monad.State (execState, evalState) +import qualified Data.Map as M +import qualified Data.Sequence as S -data VM = VM { _pc :: Int - , _fp :: Int - , _stack :: S.Seq Int - , _halt :: Bool - } deriving (Show, Eq) +import VirtualMachine.VM (VM(..), Op(..), push, pop, forward, getAt, getPc, getFp, getStackSize, setPc, setFp) -data Op = Nop -- 0x00 - | Halt -- 0x01 - | Push -- 0x02 - | Pop -- 0x03 - | Dup -- 0x04 - | Swap -- 0x05 - | Add -- 0x06 - | Sub -- 0x07 - | Mul -- 0x08 - | Div -- 0x09 - | Neg -- 0x0a - | Not -- 0x0b - | Call -- 0x0c - | Ret -- 0x0d - | Jmp -- 0x0e - | Je -- 0x0f - | Jne -- 0x10 - | Jg -- 0x11 - | Jl -- 0x12 - | Jge -- 0x13 - | Jle -- 0x14 - | Ld -- 0x15 - | In -- 0x16 - | Out -- 0x17 - | Dbg -- 0x18 - deriving (Eq, Ord, Enum, Show, Read, Bounded) type Params = [Int] type Pops = [Int] @@ -59,13 +26,6 @@ data Unit = Instr { _instr :: Instruction } | Byte { _byte :: Word8 } deriving (Show) -empty :: VM -empty = VM { _pc = 0 - , _fp = -1 - , _stack = S.empty - , _halt = False - } - instructions :: [Instruction] instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\_ _ -> S.empty) } , Simple { _op = Push, _noParams = 1, _noPops = 0, _sAction = (\params _ -> S.fromList params) } @@ -92,6 +52,9 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\ , Complex { _op = Dbg, _noParams = 0, _noPops = 0, _cAction = debug } ] +instructionByOp :: M.Map Op Instruction +instructionByOp = M.fromList $ map (\i -> (_op i, i)) instructions + call :: VM -> Params -> Pops -> ExceptT String IO VM call vm (addr:_) _ = except $ return $ flip execState vm $ do fp <- getFp @@ -134,136 +97,3 @@ output vm _ (char:_) = do liftIO $ putStr $ [chr char] return (execState (forward 1) vm) output _ _ [] = except $ Left $ "Empty stack - nothing to output" - --------------------------------------------------------------------------- - -push :: [Int] -> State VM () -push = pushS . S.fromList - -pushS :: S.Seq Int -> State VM () -pushS numbers = do - vm <- get - put vm { _stack = numbers <> _stack vm } - return () - -pop :: Int -> State VM [Int] -pop count = do - vm <- get - let stack = _stack vm - put vm { _stack = S.drop count $ stack } - return $ toList $ S.take count $ stack - -getAt :: Int -> String -> ExceptT String (State VM) Int -getAt index err = do - vm <- get - let stack = _stack vm - case (stack S.!? index) of - (Just i) -> return i - Nothing -> except $ Left err - -getPc :: State VM Int -getPc = get >>= (return . _pc) - -getFp :: State VM Int -getFp = get >>= (return . _fp) - -getStackSize :: State VM Int -getStackSize = get >>= (return . length . _stack) - -setPc :: Int -> State VM () -setPc pc' = do - vm <- get - put vm { _pc = pc' } - -setFp :: Int -> State VM () -setFp fp' = do - vm <- get - put vm { _fp = fp' } - -forward :: Int -> State VM () -forward offset = do - vm <- get - put vm { _pc = _pc vm + offset } - return () - --------------------------------------------------------------------------- - -instructionByOp :: M.Map Op Instruction -instructionByOp = M.fromList $ map (\i -> (_op i, i)) instructions - -parseInstr :: [Word8] -> Either String (Instruction, [Word8]) -parseInstr (opCode:rest) = do - let op = toEnum . fromIntegral $ opCode :: Op - instr <- case M.lookup op instructionByOp of - (Just i) -> Right i - Nothing -> Left "Unknown instruction" - let noParams = _noParams instr - let params = map fromIntegral $ take noParams rest :: [Word8] - if length params == noParams - then return (instr, params) - else Left $ "Expected " ++ (show noParams) ++ " parameter(s), got " ++ (show $ length params) ++ " for operator '" ++ (show op) ++ "'" -parseInstr [] = Left "Unexpected end of the file" - - -parse :: [Word8] -> Either String [Unit] -parse [] = Right [] -parse code = do - (instr, params) <- parseInstr code - let paramBytes = map Byte params - let noParams = _noParams instr - rest <- parse (drop (noParams + 1) code) - return $ [Instr instr] ++ paramBytes ++ rest - -interpret :: VM -> [Unit] -> ExceptT String IO VM -interpret vm@VM { _halt = True} _ = except $ Right $ vm -interpret vm units = do - vm' <- interpretUnit vm units - interpret vm' units - -interpretUnit :: VM -> [Unit] -> ExceptT String IO VM -interpretUnit _ [] = except $ Left "Nothing to interpret" -interpretUnit vm units - | pc >= progSize = except $ Left $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")" - | otherwise = case unit of - (Instr instr) -> dispatchInstr vm units instr - (Byte _) -> except $ Left $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction" - where - pc = _pc vm - progSize = length units - unit = units !! pc - -dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM -dispatchInstr vm units instr = case instr of - Simple {} -> except $ Right $ interpretSimple vm units instr - Complex {} -> interpretComplex vm units instr - -interpretSimple :: VM -> [Unit] -> Instruction -> VM -interpretSimple vm units instr = flip execState vm $ do - pc <- getPc - let noParams = _noParams instr - let noPops = _noPops instr - let paramBytes = take noParams $ drop (pc + 1) $ units - let params = map (fromIntegral . _byte) paramBytes - let action = _sAction instr - pops <- pop noPops - let pushes = action params pops - pushS pushes - forward $ noParams + 1 - return () - - -interpretComplex :: VM -> [Unit] -> Instruction -> ExceptT String IO VM -interpretComplex vm units instr = action vm' params pops - where - pc = _pc vm - noParams = _noParams instr - noPops = _noPops instr - - paramBytes = take noParams $ drop (pc + 1) $ units - params = map (fromIntegral . _byte) paramBytes - (pops, vm') = runState (pop noPops) vm - - action = _cAction instr - -run :: B.ByteString -> ExceptT String IO VM -run code = (return $ B.unpack code) >>= (except . parse) >>= interpret empty \ No newline at end of file diff --git a/app/VirtualMachine/Interpreter.hs b/app/VirtualMachine/Interpreter.hs new file mode 100644 index 0000000..cf5ac5d --- /dev/null +++ b/app/VirtualMachine/Interpreter.hs @@ -0,0 +1,88 @@ +module VirtualMachine.Interpreter where + +import Data.Word (Word8) +import Control.Monad.Trans.Except (ExceptT, except) +import Control.Monad.State (runState, execState) +import qualified Data.Map as M +import qualified Data.ByteString as B + +import VirtualMachine.VM (VM(..), Op, empty, pop, pushS, forward, getPc) +import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp) + + +parseInstr :: [Word8] -> Either String (Instruction, [Word8]) +parseInstr (opCode:rest) = do + let op = toEnum . fromIntegral $ opCode :: Op + instr <- case M.lookup op instructionByOp of + (Just i) -> Right i + Nothing -> Left "Unknown instruction" + let noParams = _noParams instr + let params = map fromIntegral $ take noParams rest :: [Word8] + if length params == noParams + then return (instr, params) + else Left $ "Expected " ++ (show noParams) ++ " parameter(s), got " ++ (show $ length params) ++ " for operator '" ++ (show op) ++ "'" +parseInstr [] = Left "Unexpected end of the file" + + +parse :: [Word8] -> Either String [Unit] +parse [] = Right [] +parse code = do + (instr, params) <- parseInstr code + let paramBytes = map Byte params + let noParams = _noParams instr + rest <- parse (drop (noParams + 1) code) + return $ [Instr instr] ++ paramBytes ++ rest + +interpret :: VM -> [Unit] -> ExceptT String IO VM +interpret vm@VM { _halt = True} _ = except $ Right $ vm +interpret vm units = do + vm' <- interpretUnit vm units + interpret vm' units + +interpretUnit :: VM -> [Unit] -> ExceptT String IO VM +interpretUnit _ [] = except $ Left "Nothing to interpret" +interpretUnit vm units + | pc >= progSize = except $ Left $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")" + | otherwise = case unit of + (Instr instr) -> dispatchInstr vm units instr + (Byte _) -> except $ Left $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction" + where + pc = _pc vm + progSize = length units + unit = units !! pc + +dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM +dispatchInstr vm units instr = case instr of + Simple {} -> except $ Right $ interpretSimple vm units instr + Complex {} -> interpretComplex vm units instr + +interpretSimple :: VM -> [Unit] -> Instruction -> VM +interpretSimple vm units instr = flip execState vm $ do + pc <- getPc + let noParams = _noParams instr + let noPops = _noPops instr + let paramBytes = take noParams $ drop (pc + 1) $ units + let params = map (fromIntegral . _byte) paramBytes + let action = _sAction instr + pops <- pop noPops + let pushes = action params pops + pushS pushes + forward $ noParams + 1 + return () + + +interpretComplex :: VM -> [Unit] -> Instruction -> ExceptT String IO VM +interpretComplex vm units instr = action vm' params pops + where + pc = _pc vm + noParams = _noParams instr + noPops = _noPops instr + + paramBytes = take noParams $ drop (pc + 1) $ units + params = map (fromIntegral . _byte) paramBytes + (pops, vm') = runState (pop noPops) vm + + action = _cAction instr + +run :: B.ByteString -> ExceptT String IO VM +run code = (return $ B.unpack code) >>= (except . parse) >>= interpret empty \ No newline at end of file diff --git a/app/VirtualMachine/VM.hs b/app/VirtualMachine/VM.hs new file mode 100644 index 0000000..bee612f --- /dev/null +++ b/app/VirtualMachine/VM.hs @@ -0,0 +1,98 @@ +module VirtualMachine.VM where + +import Data.Foldable (toList) +import Control.Monad.State (State, get, put) +import Control.Monad.Trans.Except (ExceptT, except) +import qualified Data.Sequence as S + + +data VM = VM { _pc :: Int + , _fp :: Int + , _stack :: S.Seq Int + , _halt :: Bool + } deriving (Show, Eq) + +data Op = Nop -- 0x00 + | Halt -- 0x01 + | Push -- 0x02 + | Pop -- 0x03 + | Dup -- 0x04 + | Swap -- 0x05 + | Add -- 0x06 + | Sub -- 0x07 + | Mul -- 0x08 + | Div -- 0x09 + | Neg -- 0x0a + | Not -- 0x0b + | Call -- 0x0c + | Ret -- 0x0d + | Jmp -- 0x0e + | Je -- 0x0f + | Jne -- 0x10 + | Jg -- 0x11 + | Jl -- 0x12 + | Jge -- 0x13 + | Jle -- 0x14 + | Ld -- 0x15 + | In -- 0x16 + | Out -- 0x17 + | Dbg -- 0x18 + deriving (Eq, Ord, Enum, Show, Read, Bounded) + +empty :: VM +empty = VM { _pc = 0 + , _fp = -1 + , _stack = S.empty + , _halt = False + } + +------------------------------------------------------------------------------- + +push :: [Int] -> State VM () +push = pushS . S.fromList + +pushS :: S.Seq Int -> State VM () +pushS numbers = do + vm <- get + put vm { _stack = numbers <> _stack vm } + return () + +pop :: Int -> State VM [Int] +pop count = do + vm <- get + let stack = _stack vm + put vm { _stack = S.drop count $ stack } + return $ toList $ S.take count $ stack + +getAt :: Int -> String -> ExceptT String (State VM) Int +getAt index err = do + vm <- get + let stack = _stack vm + case (stack S.!? index) of + (Just i) -> return i + Nothing -> except $ Left err + +getPc :: State VM Int +getPc = get >>= (return . _pc) + +getFp :: State VM Int +getFp = get >>= (return . _fp) + +getStackSize :: State VM Int +getStackSize = get >>= (return . length . _stack) + +setPc :: Int -> State VM () +setPc pc' = do + vm <- get + put vm { _pc = pc' } + +setFp :: Int -> State VM () +setFp fp' = do + vm <- get + put vm { _fp = fp' } + +forward :: Int -> State VM () +forward offset = do + vm <- get + put vm { _pc = _pc vm + offset } + return () \ No newline at end of file diff --git a/test/Assembler/EmitterSpec.hs b/test/Assembler/EmitterSpec.hs index fbd9f98..860e705 100644 --- a/test/Assembler/EmitterSpec.hs +++ b/test/Assembler/EmitterSpec.hs @@ -8,7 +8,7 @@ import Control.Monad.State (execState) import Assembler.Tokenizer (tokenize) import Assembler.Parser (AST(..), parse) import Assembler.Emitter as E -import VirtualMachine (Op(..)) +import VirtualMachine.VM (Op(..)) spec :: Spec spec = do diff --git a/test/Assembler/ParserSpec.hs b/test/Assembler/ParserSpec.hs index ef53b5e..5d42c08 100644 --- a/test/Assembler/ParserSpec.hs +++ b/test/Assembler/ParserSpec.hs @@ -4,7 +4,7 @@ import Test.Hspec import qualified Assembler.Tokenizer as T import Assembler.Parser -import VirtualMachine +import VirtualMachine.VM (Op(..)) success :: AST -> Int -> Maybe ParseResult success ast consumed = Just $ ParseResult ast consumed diff --git a/test/Assembler/TokenizerSpec.hs b/test/Assembler/TokenizerSpec.hs index af11a34..bbddb9d 100644 --- a/test/Assembler/TokenizerSpec.hs +++ b/test/Assembler/TokenizerSpec.hs @@ -5,7 +5,7 @@ import Numeric (showHex) import Data.Char (ord) import Assembler.Tokenizer -import VirtualMachine +import VirtualMachine.VM (Op(..)) success :: Token -> Int -> Maybe TokenizeResult success token consumed = Just $ TokenizeResult token consumed