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

Reimplement Virtual Machine to handle PC by byte rather than command

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-09 12:46:27 +01:00
parent bf5d24fc84
commit f969793864
2 changed files with 112 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
app/Main.hs
View File

@@ -9,13 +9,15 @@ import Assembler.Compiler (compile)
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
run :: String -> IO () run :: String -> IO (Either String VM.VM)
run input = case compile input of run input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= VM.run
(Right bytes) -> runExceptT (VM.run VM.empty (B.pack bytes)) >>= print >> return ()
(Left err) -> putStrLn err
main :: IO () main :: IO ()
main = do main = do
(filename:_) <- getArgs (filename:_) <- getArgs
input <- readFile filename input <- readFile filename
run input result <- run input
case result of
(Right vm) -> do
putStrLn $ "\n\nDone:\n" ++ (show vm)
(Left err) -> putStrLn $ "\n\nError:\n" ++ err

202
app/VirtualMachine.hs
View File

@@ -1,28 +1,14 @@
module VirtualMachine ( module VirtualMachine where
VM(..),
Op(..),
Instruction(..),
Command(..),
empty,
instructions,
instructionByOp,
toOp,
run
) where
import Data.Word (Word8)
import Data.Foldable (toList)
import Data.Char (chr, toLower, toUpper)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Except (ExceptT(..), except)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Sequence as S import qualified Data.Sequence as S
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Util (byteStr, bytesStr) import Data.Char (chr)
import Data.Word (Word8)
import Data.Foldable (toList)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Except (ExceptT, except)
data VM = VM { _pc :: Int data VM = VM { _pc :: Int
, _fp :: Int , _fp :: Int
@@ -57,24 +43,20 @@ data Op = Nop -- 0x00
| Dbg -- 0x18 | Dbg -- 0x18
deriving (Eq, Ord, Enum, Show, Read, Bounded) deriving (Eq, Ord, Enum, Show, Read, Bounded)
type Args = [Int] type Params = [Int]
type Pops = [Int] type Pops = [Int]
type Pushes = S.Seq Int type Pushes = S.Seq Int
data Instruction = Simple { _op :: Op data Instruction = Simple { _op :: Op, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes }
, _noParams :: Int | Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: VM -> Params -> Pops -> ExceptT String IO VM }
, _noPops :: Int
, _sAction :: Args -> Pops -> Pushes
}
| Complex { _op :: Op
, _noParams :: Int
, _noPops :: Int
, _cAction :: VM -> Args -> Pops -> ExceptT String IO VM
}
data Command = Command { _instr :: Instruction instance Show Instruction where
, _args :: [Int] show (Simple op noParams noPops _) = (show op) ++ "(S," ++ (show noParams) ++ "," ++ (show noPops) ++ ")"
} show (Complex op noParams noPops _) = (show op) ++ "(C," ++ (show noParams) ++ "," ++ (show noPops) ++ ")"
data Unit = Instr { _instr :: Instruction }
| Byte { _byte :: Word8 }
deriving (Show)
empty :: VM empty :: VM
empty = VM { _pc = 0 empty = VM { _pc = 0
@@ -96,7 +78,7 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\
, Simple { _op = Neg, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [-x]) } , Simple { _op = Neg, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [-x]) }
, Simple { _op = Not, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [if x /= 0 then 0 else 1]) } , Simple { _op = Not, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [if x /= 0 then 0 else 1]) }
, Complex { _op = Halt, _noParams = 0, _noPops = 1, _cAction = (\vm _ _ -> except $ Right $ vm { _halt = True }) } , Complex { _op = Halt, _noParams = 0, _noPops = 1, _cAction = (\vm _ _ -> except $ Right $ vm { _halt = True }) }
, Complex { _op = Jmp, _noParams = 1, _noPops = 1, _cAction = (\vm [x] _ -> except $ Right $ vm { _pc = x}) } , Complex { _op = Jmp, _noParams = 1, _noPops = 0, _cAction = (\vm [x] _ -> except $ Right $ vm { _pc = x}) }
, Complex { _op = Je, _noParams = 1, _noPops = 1, _cAction = jumpIf (==) } , Complex { _op = Je, _noParams = 1, _noPops = 1, _cAction = jumpIf (==) }
, Complex { _op = Jne, _noParams = 1, _noPops = 1, _cAction = jumpIf (/=) } , Complex { _op = Jne, _noParams = 1, _noPops = 1, _cAction = jumpIf (/=) }
, Complex { _op = Jg, _noParams = 1, _noPops = 1, _cAction = jumpIf (>) } , Complex { _op = Jg, _noParams = 1, _noPops = 1, _cAction = jumpIf (>) }
@@ -107,80 +89,104 @@ 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 }
] ]
jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> Pops -> ExceptT String IO VM debug :: VM -> Params -> Pops -> ExceptT String IO VM
jumpIf _ _ [] _ = except $ Left $ "Address expected"
jumpIf _ _ _ [] = except $ Left $ "Empty stack - nothing to compare"
jumpIf predicate vm (addr:_) (top:_) = except $ Right $ vm { _pc = pc }
where pc = if top `predicate` 0 then addr else _pc vm + 1
output :: VM -> Args -> Pops -> ExceptT String IO VM
output _ _ [] = except $ Left $ "Empty stack - nothing to output"
output vm _ (char:_) = do
liftIO $ putStr $ [chr char]
return vm { _pc = _pc vm + 1, _stack = S.drop 1 $ _stack vm}
debug :: VM -> Args -> Pops -> ExceptT String IO VM
debug vm _ _ = do debug vm _ _ = do
liftIO $ print vm liftIO $ print vm
return vm { _pc = _pc vm + 1 } return vm { _pc = _pc vm + 1 }
jumpIf :: (Int -> Int -> Bool) -> VM -> Params -> Pops -> ExceptT String IO VM
jumpIf predicate vm (addr:_) (top:_) = except $ Right $ vm { _pc = pc }
where pc = if top `predicate` 0 then addr else _pc vm + 1
jumpIf _ _ [] _ = except $ Left $ "Address expected"
jumpIf _ _ _ [] = except $ Left $ "Empty stack - nothing to compare"
output :: VM -> Params -> Pops -> ExceptT String IO VM
output vm _ (char:_) = do
liftIO $ putStr $ [chr char]
return vm { _pc = _pc vm + 1, _stack = S.drop 1 $ _stack vm}
output _ _ [] = except $ Left $ "Empty stack - nothing to output"
--------------------------------------------------------------------------
instructionByOp :: M.Map Op Instruction instructionByOp :: M.Map Op Instruction
instructionByOp = M.fromList $ map (\i -> (_op i, i)) instructions instructionByOp = M.fromList $ map (\i -> (_op i, i)) instructions
toOp :: String -> Op parseInstr :: [Word8] -> Either String (Instruction, [Word8])
toOp = read . capitalize parseInstr (opCode:rest) = do
where capitalize :: String -> String let op = toEnum . fromIntegral $ opCode :: Op
capitalize [] = [] instr <- case M.lookup op instructionByOp of
capitalize (x:xs) = toUpper x : map toLower xs (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 :: B.ByteString -> Either String [Command]
parse = parseCommands . B.unpack
parseCommands :: [Word8] -> Either String [Command] parse :: [Word8] -> Either String [Unit]
parseCommands [] = Right [] parse [] = Right []
parseCommands code@(x:_) = case parseCommand code of parse code = do
Just (cmd, rest) -> parseCommands rest >>= (\r -> return $ cmd : r) (instr, params) <- parseInstr code
Nothing -> Left $ "Unparseable byte: " ++ byteStr x ++ "\nIn following sequence:\n" ++ bytesStr 16 code let paramBytes = map Byte params
let noParams = _noParams instr
rest <- parse (drop (noParams + 1) code)
return $ [Instr instr] ++ paramBytes ++ rest
parseCommand :: [Word8] -> Maybe (Command, [Word8]) interpret :: VM -> [Unit] -> ExceptT String IO VM
parseCommand [] = Nothing interpret vm@VM { _halt = True} _ = except $ Right $ vm
parseCommand (opByte:xs) = do interpret vm units = do
let op = toEnum . fromIntegral $ opByte :: Op vm' <- interpretUnit vm units
instruction <- M.lookup op instructionByOp interpret vm' units
let paramsNumber = _noParams instruction
let params = map fromIntegral $ take paramsNumber xs :: [Int]
return (Command instruction params, drop paramsNumber xs)
interpret :: [Command] -> VM -> ExceptT String IO VM interpretUnit :: VM -> [Unit] -> ExceptT String IO VM
interpret _ vm@(VM _ _ _ True) = except $ Right $ vm interpretUnit _ [] = except $ Left "Nothing to interpret"
interpret cmds vm = do interpretUnit vm units
vm' <- interpretCommand cmds vm | pc >= progSize = except $ Left $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")"
interpret cmds vm' | otherwise = case unit of
(Instr instr) -> dispatchInstr vm units instr
interpretCommand :: [Command] -> VM -> ExceptT String IO VM (Byte _) -> except $ Left $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction"
interpretCommand [] _ = except $ Left $ "Empty code"
interpretCommand cmds vm@(VM pc _ _ _)
| pc >= length cmds = except $ Right $ vm { _halt = True }
| otherwise = case instr of
(Simple _ _ _ _) -> except $ interpretSimple vm cmd
(Complex _ _ _ _) -> interpretComplex vm cmd
where cmd@(Command instr _) = cmds !! pc
interpretSimple :: VM -> Command -> Either String VM
interpretSimple vm (Command (Simple _ _ noPops operation) args) = vm'
where where
pops = toList . S.take noPops . _stack $ vm pc = _pc vm
stack' = Right $ operation args pops progSize = length units
vm' = stack' >>= (\s -> Right $ vm { _pc = _pc vm + 1 unit = units !! pc
, _stack = s <> (S.drop noPops . _stack) vm
})
interpretSimple _ _ = Left "Unknown operation"
interpretComplex :: VM -> Command -> ExceptT String IO VM dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM
interpretComplex vm (Command (Complex _ _ noPops operation) args) = operation vm args pops 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 = vm'
where
stack = _stack vm
pc = _pc vm
noParams = _noParams instr
noPops = _noPops instr
paramBytes = take noParams $ drop (pc + 1) $ units :: [Unit]
params = map (fromIntegral . _byte) paramBytes :: [Int]
pops = toList $ S.take noPops $ stack :: [Int]
action = _sAction instr
pushes = action params pops
vm' = vm { _pc = pc + noParams + 1, _stack = pushes <> (S.drop noPops stack) }
interpretComplex :: VM -> [Unit] -> Instruction -> ExceptT String IO VM
interpretComplex vm units instr = action vm params pops
where where
pops = toList . S.take noPops . _stack $ vm stack = _stack vm
interpretComplex _ _ = except $ Left "Unknown operation" pc = _pc vm
noParams = _noParams instr
noPops = _noPops instr
paramBytes = take noParams $ drop (pc + 1) $ units :: [Unit]
params = map (fromIntegral . _byte) paramBytes :: [Int]
pops = toList $ S.take noPops $ stack :: [Int]
run :: VM -> B.ByteString -> ExceptT String IO VM action = _cAction instr
run vm code = return code >>= (except . parse) >>= flip interpret vm
run :: B.ByteString -> ExceptT String IO VM
run code = (return $ B.unpack code) >>= (except . parse) >>= interpret empty