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

129
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 :: VM -> Params -> Pops -> ExceptT String IO VM
ret vm _ _ = do
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
retAddr <- except $ evalState (runExceptT (getAt (stackSize - fp - 2) "Cannot determine return address" )) vm
return vm { _fp = fp', _pc = retAddr, _stack = stack' } ret :: Params -> Pops -> ExceptT String Machine ()
ret _ _ = do
fp <- lift getFp
stackSize <- lift getStackSize
jumpIf :: (Int -> Int -> Bool) -> VM -> Params -> Pops -> ExceptT String IO VM fp' <- getAt (stackSize - fp - 1) "Cannot determine previous frame pointer (fp)"
jumpIf predicate vm (addr:_) (top:_) = except $ return $ vm { _pc = pc } retAddr <- getAt (stackSize - fp - 2) "Cannot determine return address"
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 if stackSize - fp == 2
output vm _ (char:_) = do then lift $ do
_ <- pop $ stackSize - fp
return ()
else lift $ do
retVal <- pop 1
_ <- pop $ stackSize - fp - 1
push retVal
return ()
lift $ setFp fp'
lift $ setPc retAddr
return ()
jump :: Params -> Pops -> ExceptT String Machine ()
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"

127
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,78 +37,75 @@ 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 :: [Unit] -> ExceptT String Machine ()
interpretUnit [] = throwError "Nothing to interpret"
interpretUnit units = do
pc <- lift getPc
let progSize = length units
if pc < progSize
then case units !! pc of
(Instr instr) -> dispatchInstr units instr
(Byte _) -> throwError $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction"
else throwError $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")"
interpretUnit :: VM -> [Unit] -> ExceptT String IO VM dispatchInstr :: [Unit] -> Instruction -> ExceptT String Machine ()
interpretUnit _ [] = except $ Left "Nothing to interpret" dispatchInstr units instr = do
interpretUnit vm units debug <- lift isDebug
| pc >= progSize = except $ Left $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")"
| otherwise = case unit of if debug
(Instr instr) -> dispatchInstr vm units instr then lift $ do
(Byte _) -> except $ Left $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction" vm <- get
where pc <- getPc
pc = _pc vm let noParams = _noParams instr
progSize = length units let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) $ units
unit = units !! pc liftIO $ putStrLn $ show vm
liftIO $ putStrLn $ (show pc) ++ ": " ++ (show $ _op instr) ++ " " ++ params
return ()
else return ()
dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM case instr of
dispatchInstr vm units instr = do Simple {} -> interpretSimple units instr
liftIO $ debugPrint vm instr units Complex {} -> interpretComplex units instr
case instr of interpretSimple :: [Unit] -> Instruction -> ExceptT String Machine ()
Simple {} -> except $ interpretSimple vm units instr interpretSimple units instr = do
Complex {} -> interpretComplex vm units instr
debugPrint :: VM -> Instruction -> [Unit] -> IO ()
debugPrint vm instr units = if _debug vm
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
let paramBytes = take noParams $ drop (pc + 1) $ units let paramBytes = take noParams $ drop (pc + 1) $ units
let params = map (fromIntegral . _byte) paramBytes let params = map (fromIntegral . _byte) paramBytes
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
else throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops) let noParams = _noParams instr
where let noPops = _noPops instr
pc = _pc vm let paramBytes = take noParams $ drop (pc + 1) $ units
noParams = _noParams instr let params = map (fromIntegral . _byte) paramBytes
noPops = _noPops instr let action = _cAction instr
pops <- lift $ pop noPops
paramBytes = take noParams $ drop (pc + 1) $ units if length pops == noPops
params = map (fromIntegral . _byte) paramBytes then do action params pops
(pops, vm') = runState (pop noPops) vm else throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops)
action = _cAction instr run :: VM -> B.ByteString -> IO (Either String VM)
run vm input = evalStateT (runExceptT machine) vm
run :: VM -> B.ByteString -> ExceptT String IO VM where machine = (return input) >>= (return .B.unpack) >>= (except . parse) >>= interpret >> (lift get)
run vm code = (return $ B.unpack code) >>= (except . parse) >>= interpret vm
runEmpty :: B.ByteString -> ExceptT String IO VM
runEmpty = run empty

88
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,51 +55,62 @@ 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 }
return () return ()