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

Update VM to work on State monad

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-12 11:03:57 +01:00
parent bc4350205e
commit e3bcebcece
4 changed files with 191 additions and 157 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
app/Runner.hs
View File

@@ -1,5 +1,7 @@
module Runner where module Runner where
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Except (runExceptT, except) import Control.Monad.Trans.Except (runExceptT, except)
import qualified Data.ByteString as B import qualified Data.ByteString as B
@@ -14,4 +16,4 @@ runDebug :: String -> IO (Either String VM)
runDebug = exec empty { _debug = True } runDebug = exec empty { _debug = True }
exec :: VM -> String -> IO (Either String VM) exec :: VM -> String -> IO (Either String VM)
exec vm input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= VM.run vm exec vm input = runExceptT $ return input >>= (except . compile) >>= (liftIO . VM.run vm . B.pack) >>= except >>= return

123
app/VirtualMachine/Instruction.hs
View File

@@ -2,21 +2,21 @@ module VirtualMachine.Instruction where
import Data.Char (chr) import Data.Char (chr)
import Data.Word (Word8) import Data.Word (Word8)
import Control.Monad.Trans (liftIO) import Control.Monad.Except (throwError)
import Control.Monad.Trans.Except (ExceptT, except, runExceptT) import Control.Monad.Trans (lift, liftIO)
import Control.Monad.State (execState, evalState) 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 VirtualMachine.VM (VM(..), Op(..), push, pop, forward, getAt, getPc, getFp, getStackSize, setPc, setFp) import VirtualMachine.VM (Op(..), Machine, push, pop, forward, getAt, getPc, getFp, getStackSize, setPc, setFp, setHalt)
type Params = [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, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes } data Instruction = Simple { _op :: Op, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes }
| Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: VM -> Params -> Pops -> ExceptT String IO VM } | Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: Params -> Pops -> ExceptT String Machine () }
instance Show Instruction where instance Show Instruction where
show (Simple op noParams noPops _) = (show op) ++ "(S," ++ (show noParams) ++ "," ++ (show noPops) ++ ")" show (Simple op noParams noPops _) = (show op) ++ "(S," ++ (show noParams) ++ "," ++ (show noPops) ++ ")"
@@ -38,10 +38,10 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\
, Simple { _op = Div, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y `div` x]) } , Simple { _op = Div, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y `div` x]) }
, 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 = 0, _cAction = (\vm _ _ -> except $ Right $ vm { _halt = True }) } , Complex { _op = Halt, _noParams = 0, _noPops = 0, _cAction = halt }
, Complex { _op = Call, _noParams = 1, _noPops = 0, _cAction = call } , Complex { _op = Call, _noParams = 1, _noPops = 0, _cAction = call }
, Complex { _op = Ret, _noParams = 0, _noPops = 0, _cAction = ret } , Complex { _op = Ret, _noParams = 0, _noPops = 0, _cAction = ret }
, Complex { _op = Jmp, _noParams = 1, _noPops = 0, _cAction = (\vm [x] _ -> except $ Right $ vm { _pc = x}) } , Complex { _op = Jmp, _noParams = 1, _noPops = 0, _cAction = jump }
, 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 (>) }
@@ -57,72 +57,89 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\
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
call :: VM -> Params -> Pops -> ExceptT String IO VM halt :: Params -> Pops -> ExceptT String Machine ()
call vm (addr:_) _ = except $ return $ flip execState vm $ do halt _ _ = lift $ do
setHalt True
return ()
call :: Params -> Pops -> ExceptT String Machine ()
call (addr:_) _ = lift $ do
fp <- getFp fp <- getFp
fp' <- getStackSize fp' <- getStackSize
retAddr <- getPc >>= return . (+2) retAddr <- getPc >>= return . (+2)
push [retAddr, fp] push [retAddr, fp]
setPc addr setPc addr
setFp fp' setFp fp'
return () return ()
call [] _ = throwError "Address excepted"
call _ [] _ = except $ Left $ "Address excepted" ret :: Params -> Pops -> ExceptT String Machine ()
ret _ _ = do
fp <- lift getFp
stackSize <- lift getStackSize
ret :: VM -> Params -> Pops -> ExceptT String IO VM fp' <- getAt (stackSize - fp - 1) "Cannot determine previous frame pointer (fp)"
ret vm _ _ = do retAddr <- getAt (stackSize - fp - 2) "Cannot determine return address"
let fp = _fp vm
let stack = _stack vm
let stackSize = S.length stack
let stack' = _stack $ flip execState vm $ do
if stackSize - fp == 2
then do
_ <- pop (stackSize - fp)
return ()
else do
retVal <- pop 1
_ <- pop (stackSize - fp - 1)
push retVal
return ()
fp' <- except $ evalState (runExceptT (getAt (stackSize - fp - 1) "Cannot determine previous frame pointer (fp)")) vm if stackSize - fp == 2
retAddr <- except $ evalState (runExceptT (getAt (stackSize - fp - 2) "Cannot determine return address" )) vm then lift $ do
_ <- pop $ stackSize - fp
return ()
else lift $ do
retVal <- pop 1
_ <- pop $ stackSize - fp - 1
push retVal
return ()
return vm { _fp = fp', _pc = retAddr, _stack = stack' } lift $ setFp fp'
lift $ setPc retAddr
jumpIf :: (Int -> Int -> Bool) -> VM -> Params -> Pops -> ExceptT String IO VM return ()
jumpIf predicate vm (addr:_) (top:_) = except $ return $ vm { _pc = pc }
where pc = if top `predicate` 0 then addr else _pc vm + 2
jumpIf _ _ [] _ = except $ Left "Address expected"
jumpIf _ _ _ [] = except $ Left "Empty stack - nothing to compare"
output :: VM -> Params -> Pops -> ExceptT String IO VM jump :: Params -> Pops -> ExceptT String Machine ()
output vm _ (char:_) = do jump (addr:_) _ = lift $ do
setPc addr
return ()
jump [] _ = throwError "Address expected"
jumpIf :: (Int -> Int -> Bool) -> Params -> Pops -> ExceptT String Machine ()
jumpIf p (addr:_) (top:_) = lift $ do
pc <- getPc
setPc $ if top `p` 0 then addr else pc + 2
return ()
jumpIf _ [] _ = throwError "Address expected"
jumpIf _ _ [] = throwError "Empty stack - nothing to compare"
output :: Params -> Pops -> ExceptT String Machine ()
output _ (char:_) = lift $ do
liftIO $ putStr $ [chr char] liftIO $ putStr $ [chr char]
return (execState (forward 1) vm) forward 1
output _ _ [] = except $ Left $ "Empty stack - nothing to output" return ()
output _ [] = except $ Left $ "Empty stack - nothing to output"
load :: VM -> Params -> Pops -> ExceptT String IO VM
load vm (index:_) _ = do
let fp = _fp vm
let stack = _stack vm
let stackSize = S.length stack
val <- except $ evalState (runExceptT (getAt (stackSize - fp + index) ("Index " ++ (show index) ++ " out of stack bounds") )) vm load :: Params -> Pops -> ExceptT String Machine ()
load (index:_) _ = do
fp <- lift getFp
stackSize <- lift getStackSize
val <- getAt (stackSize - fp + index) ("Index " ++ (show index) ++ " out of stack bounds")
lift $ push [val]
lift $ forward 2
return ()
load [] _ = throwError "Local parameter index expected"
return $ execState (push [val] >> forward 2) vm niy :: Op -> Params -> Pops -> ExceptT String Machine ()
load _ [] _ = except $ Left $ "Local parameter index expected" niy op _ _ = do
pc <- lift getPc
throwError $ "Instruction '" ++ (show op) ++ "' ("++ (show $ pc) ++") is not implemented yet"
niy :: Op -> VM -> Params -> Pops -> ExceptT String IO VM clear :: Params -> Pops -> ExceptT String Machine ()
niy op vm _ _ = except $ Left $ "Instruction '" ++ (show op) ++ "' ("++ (show $ _pc vm) ++") is not implemented yet" clear (count:_) _ = lift $ do
clear :: VM -> Params -> Pops -> ExceptT String IO VM
clear vm (count:_) _ = except $ return $ flip execState vm $ do
top <- pop 1 top <- pop 1
_ <- pop count _ <- pop count
push top push top
forward 2 forward 2
return () return ()
clear _ [] _ = except $ Left "Number of elements to be cleaned expected" clear [] _ = except $ Left "Number of elements to be cleaned expected"

119
app/VirtualMachine/Interpreter.hs
View File

@@ -2,13 +2,16 @@ module VirtualMachine.Interpreter where
import Data.Word (Word8) import Data.Word (Word8)
import Data.List (intercalate) import Data.List (intercalate)
import Control.Monad.Trans.State (get, evalStateT)
import Control.Monad.Trans.Except (ExceptT, except, runExceptT) import Control.Monad.Trans.Except (ExceptT, except, runExceptT)
import Control.Monad.Trans (lift)
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Control.Monad.State (get, liftIO, lift, runState, evalState) import Control.Monad.State (liftIO)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString as B import qualified Data.ByteString as B
import VirtualMachine.VM (VM(..), Op, empty, pop, pushS, forward, getPc) import VirtualMachine.VM (VM(..), Op, Machine, pop, pushS, forward, getPc, isHalted, isDebug)
import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp) import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp)
@@ -25,7 +28,6 @@ parseInstr (opCode:rest) = do
else Left $ "Expected " ++ (show noParams) ++ " parameter(s), got " ++ (show $ length params) ++ " for operator '" ++ (show op) ++ "'" else Left $ "Expected " ++ (show noParams) ++ " parameter(s), got " ++ (show $ length params) ++ " for operator '" ++ (show op) ++ "'"
parseInstr [] = Left "Unexpected end of the file" parseInstr [] = Left "Unexpected end of the file"
parse :: [Word8] -> Either String [Unit] parse :: [Word8] -> Either String [Unit]
parse [] = Right [] parse [] = Right []
parse code = do parse code = do
@@ -35,45 +37,47 @@ parse code = do
rest <- parse (drop (noParams + 1) code) rest <- parse (drop (noParams + 1) code)
return $ [Instr instr] ++ paramBytes ++ rest return $ [Instr instr] ++ paramBytes ++ rest
interpret :: VM -> [Unit] -> ExceptT String IO VM interpret :: [Unit] -> ExceptT String Machine ()
interpret vm@VM { _halt = True} _ = except $ Right $ vm interpret units = do
interpret vm units = do halted <- lift isHalted
vm' <- interpretUnit vm units if halted
interpret vm' units then return ()
else do
interpretUnit units
interpret units
interpretUnit :: VM -> [Unit] -> ExceptT String IO VM interpretUnit :: [Unit] -> ExceptT String Machine ()
interpretUnit _ [] = except $ Left "Nothing to interpret" interpretUnit [] = throwError "Nothing to interpret"
interpretUnit vm units interpretUnit units = do
| pc >= progSize = except $ Left $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")" pc <- lift getPc
| otherwise = case unit of let progSize = length units
(Instr instr) -> dispatchInstr vm units instr if pc < progSize
(Byte _) -> except $ Left $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction" then case units !! pc of
where (Instr instr) -> dispatchInstr units instr
pc = _pc vm (Byte _) -> throwError $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction"
progSize = length units else throwError $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")"
unit = units !! pc
dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM dispatchInstr :: [Unit] -> Instruction -> ExceptT String Machine ()
dispatchInstr vm units instr = do dispatchInstr units instr = do
liftIO $ debugPrint vm instr units debug <- lift isDebug
if debug
then lift $ do
vm <- get
pc <- getPc
let noParams = _noParams instr
let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) $ units
liftIO $ putStrLn $ show vm
liftIO $ putStrLn $ (show pc) ++ ": " ++ (show $ _op instr) ++ " " ++ params
return ()
else return ()
case instr of case instr of
Simple {} -> except $ interpretSimple vm units instr Simple {} -> interpretSimple units instr
Complex {} -> interpretComplex vm units instr Complex {} -> interpretComplex units instr
debugPrint :: VM -> Instruction -> [Unit] -> IO () interpretSimple :: [Unit] -> Instruction -> ExceptT String Machine ()
debugPrint vm instr units = if _debug vm interpretSimple units instr = do
then do
let pc = _pc vm
let noParams = _noParams instr
let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) $ units
putStrLn $ show vm
putStrLn $ (show pc) ++ ": " ++ (show $ _op instr) ++ " " ++ params
return ()
else return ()
interpretSimple :: VM -> [Unit] -> Instruction -> Either String VM
interpretSimple vm units instr = flip evalState vm $ runExceptT $ do
pc <- lift getPc pc <- lift getPc
let noParams = _noParams instr let noParams = _noParams instr
let noPops = _noPops instr let noPops = _noPops instr
@@ -82,31 +86,26 @@ interpretSimple vm units instr = flip evalState vm $ runExceptT $ do
let action = _sAction instr let action = _sAction instr
pops <- lift $ pop noPops pops <- lift $ pop noPops
if length pops == noPops if length pops == noPops
then do then lift $ do
let pushes = action params pops let pushes = action params pops
lift $ pushS pushes pushS pushes
lift $ forward $ noParams + 1 forward $ noParams + 1
vm' <- lift get return ()
return vm'
else throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops) else throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops)
interpretComplex :: VM -> [Unit] -> Instruction -> ExceptT String IO VM interpretComplex :: [Unit] -> Instruction -> ExceptT String Machine ()
interpretComplex vm units instr = if length pops == noPops interpretComplex units instr = do
then action vm' params pops pc <- lift 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 = _cAction instr
pops <- lift $ pop noPops
if length pops == noPops
then do action params pops
else throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops) else throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops)
where
pc = _pc vm
noParams = _noParams instr
noPops = _noPops instr
paramBytes = take noParams $ drop (pc + 1) $ units run :: VM -> B.ByteString -> IO (Either String VM)
params = map (fromIntegral . _byte) paramBytes run vm input = evalStateT (runExceptT machine) vm
(pops, vm') = runState (pop noPops) vm where machine = (return input) >>= (return .B.unpack) >>= (except . parse) >>= interpret >> (lift get)
action = _cAction instr
run :: VM -> B.ByteString -> ExceptT String IO VM
run vm code = (return $ B.unpack code) >>= (except . parse) >>= interpret vm
runEmpty :: B.ByteString -> ExceptT String IO VM
runEmpty = run empty

86
app/VirtualMachine/VM.hs
View File

@@ -1,8 +1,11 @@
module VirtualMachine.VM where module VirtualMachine.VM where
import Data.Foldable (toList) import Data.Foldable (toList)
import Control.Monad.State (State, get, put) import Control.Monad.Trans (lift)
import Control.Monad.Trans.Except (ExceptT, except) import Control.Monad.State (get, put)
import Control.Monad.Except (throwError)
import Control.Monad.Trans.State (StateT)
import Control.Monad.Trans.Except (ExceptT)
import qualified Data.Sequence as S import qualified Data.Sequence as S
@@ -40,6 +43,8 @@ data Op = Nop -- 0x00
| Clr -- 0x18 | Clr -- 0x18
deriving (Eq, Ord, Enum, Show, Read, Bounded) deriving (Eq, Ord, Enum, Show, Read, Bounded)
type Machine = StateT VM IO
empty :: VM empty :: VM
empty = VM { _pc = 0 empty = VM { _pc = 0
, _fp = -1 , _fp = -1
@@ -50,50 +55,61 @@ empty = VM { _pc = 0
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
push :: [Int] -> State VM () getPc :: Machine Int
push = pushS . S.fromList getPc = get >>= (return . _pc)
pushS :: S.Seq Int -> State VM () getFp :: Machine Int
pushS numbers = do getFp = get >>= (return . _fp)
isHalted :: Machine Bool
isHalted = get >>= (return . _halt)
isDebug :: Machine Bool
isDebug = get >>= (return . _debug)
getAt :: Int -> String -> ExceptT String Machine Int
getAt index err = do
vm <- lift $ get
let stack = _stack vm
case (stack S.!? index) of
(Just i) -> return i
Nothing -> throwError err
getStackSize :: Machine Int
getStackSize = get >>= (return . length . _stack)
setPc :: Int -> Machine ()
setPc pc = do
vm <- get vm <- get
put vm { _stack = numbers <> _stack vm } put vm { _pc = pc }
return ()
pop :: Int -> State VM [Int] setFp :: Int -> Machine ()
setFp fp = do
vm <- get
put vm { _fp = fp }
setHalt :: Bool -> Machine ()
setHalt halt = do
vm <- get
put vm { _halt = halt }
pop :: Int -> Machine [Int]
pop count = do pop count = do
vm <- get vm <- get
let stack = _stack vm let stack = _stack vm
put vm { _stack = S.drop count $ stack } put vm { _stack = S.drop count $ stack }
return $ toList $ S.take count $ stack return $ toList $ S.take count $ stack
getAt :: Int -> String -> ExceptT String (State VM) Int push :: [Int] -> Machine ()
getAt index err = do push = pushS . S.fromList
pushS :: S.Seq Int -> Machine ()
pushS numbers = do
vm <- get vm <- get
let stack = _stack vm put vm { _stack = numbers <> _stack vm }
case (stack S.!? index) of return ()
(Just i) -> return i
Nothing -> except $ Left err
getPc :: State VM Int forward :: Int -> Machine ()
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 forward offset = do
vm <- get vm <- get
put vm { _pc = _pc vm + offset } put vm { _pc = _pc vm + offset }