bartek/mvm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Split VirtualMachine module

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-09 18:25:15 +01:00
parent 3faa4f4abf
commit bfb231d483
10 changed files with 212 additions and 193 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
MVM.cabal
View File

@@ -27,7 +27,9 @@ executable MVM
-- Modules included in this executable, other than Main. -- Modules included in this executable, other than Main.
other-modules: other-modules:
VirtualMachine VirtualMachine.VM
VirtualMachine.Instruction
VirtualMachine.Interpreter
Assembler.Tokenizer Assembler.Tokenizer
Assembler.Parser Assembler.Parser
Assembler.Emitter Assembler.Emitter
@@ -66,7 +68,9 @@ test-suite spec
Assembler.EmitterSpec Assembler.EmitterSpec
UtilSpec UtilSpec
VirtualMachine VirtualMachine.VM
VirtualMachine.Instruction
VirtualMachine.Interpreter
Assembler.Tokenizer Assembler.Tokenizer
Assembler.Parser Assembler.Parser
Assembler.Emitter Assembler.Emitter

2
app/Assembler/Parser.hs
View File

@@ -4,7 +4,7 @@ import Data.List (intercalate)
import Data.Monoid (First(..)) import Data.Monoid (First(..))
import qualified Assembler.Tokenizer as T (Token(..)) import qualified Assembler.Tokenizer as T (Token(..))
import VirtualMachine (Op) import VirtualMachine.VM (Op)
import Util (explode) import Util (explode)

2
app/Assembler/Tokenizer.hs
View File

@@ -4,7 +4,7 @@ import Data.List (sortBy)
import Data.Char (ord, isDigit, isSpace, isAlpha, isAlphaNum, isHexDigit) import Data.Char (ord, isDigit, isSpace, isAlpha, isAlphaNum, isHexDigit)
import Data.Monoid (First(..)) import Data.Monoid (First(..))
import VirtualMachine (Op(..)) import VirtualMachine.VM (Op(..))
import Util (toLowerCase, controlChar, unescape) import Util (toLowerCase, controlChar, unescape)

15
app/Main.hs
View File

@@ -1,22 +1,21 @@
module Main where module Main where
import System.Environment import System.Environment
import qualified Data.ByteString as B import Control.Monad.Trans.Except (runExceptT, except)
import qualified VirtualMachine as VM
import VirtualMachine.VM (VM)
import VirtualMachine.Interpreter (run)
import Assembler.Compiler (compile) import Assembler.Compiler (compile)
import qualified Data.ByteString as B
import Control.Monad.Trans.Except interpret :: String -> IO (Either String VM)
interpret input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= run
run :: String -> IO (Either String VM.VM)
run input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= VM.run
main :: IO () main :: IO ()
main = do main = do
(filename:_) <- getArgs (filename:_) <- getArgs
input <- readFile filename input <- readFile filename
result <- run input result <- interpret input
case result of case result of
(Right vm) -> do (Right vm) -> do
putStrLn $ "\n\nDone:\n" ++ (show vm) putStrLn $ "\n\nDone:\n" ++ (show vm)

186
app/VirtualMachine.hs → app/VirtualMachine/Instruction.hs
View File

@@ -1,48 +1,15 @@
module VirtualMachine where module VirtualMachine.Instruction where
import qualified Data.Map as M
import qualified Data.Sequence as S
import qualified Data.ByteString as B
import Data.Char (chr) import Data.Char (chr)
import Data.Word (Word8) 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 (liftIO)
import Control.Monad.Trans.Except (ExceptT, except, runExceptT) 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 import VirtualMachine.VM (VM(..), Op(..), push, pop, forward, getAt, getPc, getFp, getStackSize, setPc, setFp)
, _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)
type Params = [Int] type Params = [Int]
type Pops = [Int] type Pops = [Int]
@@ -59,13 +26,6 @@ data Unit = Instr { _instr :: Instruction }
| Byte { _byte :: Word8 } | Byte { _byte :: Word8 }
deriving (Show) deriving (Show)
empty :: VM
empty = VM { _pc = 0
, _fp = -1
, _stack = S.empty
, _halt = False
}
instructions :: [Instruction] instructions :: [Instruction]
instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\_ _ -> S.empty) } instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\_ _ -> S.empty) }
, Simple { _op = Push, _noParams = 1, _noPops = 0, _sAction = (\params _ -> S.fromList params) } , 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 } , 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 -> Params -> Pops -> ExceptT String IO VM
call vm (addr:_) _ = except $ return $ flip execState vm $ do call vm (addr:_) _ = except $ return $ flip execState vm $ do
fp <- getFp fp <- getFp
@@ -134,136 +97,3 @@ output vm _ (char:_) = do
liftIO $ putStr $ [chr char] liftIO $ putStr $ [chr char]
return (execState (forward 1) vm) return (execState (forward 1) vm)
output _ _ [] = except $ Left $ "Empty stack - nothing to output" 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

88
app/VirtualMachine/Interpreter.hs Normal file
View File

@@ -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

98
app/VirtualMachine/VM.hs Normal file
View File

@@ -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 ()

2
test/Assembler/EmitterSpec.hs
View File

@@ -8,7 +8,7 @@ import Control.Monad.State (execState)
import Assembler.Tokenizer (tokenize) import Assembler.Tokenizer (tokenize)
import Assembler.Parser (AST(..), parse) import Assembler.Parser (AST(..), parse)
import Assembler.Emitter as E import Assembler.Emitter as E
import VirtualMachine (Op(..)) import VirtualMachine.VM (Op(..))
spec :: Spec spec :: Spec
spec = do spec = do

2
test/Assembler/ParserSpec.hs
View File

@@ -4,7 +4,7 @@ import Test.Hspec
import qualified Assembler.Tokenizer as T import qualified Assembler.Tokenizer as T
import Assembler.Parser import Assembler.Parser
import VirtualMachine import VirtualMachine.VM (Op(..))
success :: AST -> Int -> Maybe ParseResult success :: AST -> Int -> Maybe ParseResult
success ast consumed = Just $ ParseResult ast consumed success ast consumed = Just $ ParseResult ast consumed

2
test/Assembler/TokenizerSpec.hs
View File

@@ -5,7 +5,7 @@ import Numeric (showHex)
import Data.Char (ord) import Data.Char (ord)
import Assembler.Tokenizer import Assembler.Tokenizer
import VirtualMachine import VirtualMachine.VM (Op(..))
success :: Token -> Int -> Maybe TokenizeResult success :: Token -> Int -> Maybe TokenizeResult
success token consumed = Just $ TokenizeResult token consumed success token consumed = Just $ TokenizeResult token consumed