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
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Except (runExceptT, except)
import qualified Data.ByteString as B
@@ -14,4 +16,4 @@ runDebug :: String -> IO (Either String VM)
runDebug = exec empty { _debug = True }
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.Word (Word8)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Except (ExceptT, except, runExceptT)
import Control.Monad.State (execState, evalState)
import Control.Monad.Except (throwError)
import Control.Monad.Trans (lift, liftIO)
import Control.Monad.Trans.Except (ExceptT, except)
import qualified Data.Map as M
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 Pops = [Int]
type Pushes = S.Seq Int
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 }
data Instruction = Simple { _op :: Op, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes }
| Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: Params -> Pops -> ExceptT String Machine () }
instance Show Instruction where
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 = 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]) }
, 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 = 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 = Jne, _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.fromList $ map (\i -> (_op i, i)) instructions
call :: VM -> Params -> Pops -> ExceptT String IO VM
call vm (addr:_) _ = except $ return $ flip execState vm $ do
halt :: Params -> Pops -> ExceptT String Machine ()
halt _ _ = lift $ do
setHalt True
return ()
call :: Params -> Pops -> ExceptT String Machine ()
call (addr:_) _ = lift $ do
fp <- getFp
fp' <- getStackSize
retAddr <- getPc >>= return . (+2)
retAddr <- getPc >>= return . (+2)
push [retAddr, fp]
setPc addr
setFp fp'
return ()
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
call [] _ = throwError "Address excepted"
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
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"
fp' <- getAt (stackSize - fp - 1) "Cannot determine previous frame pointer (fp)"
retAddr <- getAt (stackSize - fp - 2) "Cannot determine return address"
output :: VM -> Params -> Pops -> ExceptT String IO VM
output vm _ (char:_) = do
if stackSize - fp == 2
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]
return (execState (forward 1) vm)
output _ _ [] = except $ Left $ "Empty stack - nothing to output"
forward 1
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
load _ [] _ = except $ Left $ "Local parameter index expected"
niy :: Op -> Params -> Pops -> ExceptT String Machine ()
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
niy op vm _ _ = except $ Left $ "Instruction '" ++ (show op) ++ "' ("++ (show $ _pc vm) ++") is not implemented yet"
clear :: VM -> Params -> Pops -> ExceptT String IO VM
clear vm (count:_) _ = except $ return $ flip execState vm $ do
clear :: Params -> Pops -> ExceptT String Machine ()
clear (count:_) _ = lift $ do
top <- pop 1
_ <- pop count
push top
forward 2
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.List (intercalate)
import Control.Monad.Trans.State (get, evalStateT)
import Control.Monad.Trans.Except (ExceptT, except, runExceptT)
import Control.Monad.Trans (lift)
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.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)
@@ -25,7 +28,6 @@ parseInstr (opCode:rest) = do
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
@@ -35,78 +37,75 @@ parse code = do
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
interpret :: [Unit] -> ExceptT String Machine ()
interpret units = do
halted <- lift isHalted
if halted
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
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 :: [Unit] -> Instruction -> ExceptT String Machine ()
dispatchInstr units instr = do
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 ()
dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM
dispatchInstr vm units instr = do
liftIO $ debugPrint vm instr units
case instr of
Simple {} -> interpretSimple units instr
Complex {} -> interpretComplex units instr
case instr of
Simple {} -> except $ interpretSimple vm units instr
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
interpretSimple :: [Unit] -> Instruction -> ExceptT String Machine ()
interpretSimple units instr = do
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 = _sAction instr
pops <- lift $ pop noPops
pops <- lift $ pop noPops
if length pops == noPops
then do
then lift $ do
let pushes = action params pops
lift $ pushS pushes
lift $ forward $ noParams + 1
vm' <- lift get
return vm'
pushS pushes
forward $ noParams + 1
return ()
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 vm units instr = if length pops == noPops
then action vm' params 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
params = map (fromIntegral . _byte) paramBytes
(pops, vm') = runState (pop noPops) vm
interpretComplex :: [Unit] -> Instruction -> ExceptT String Machine ()
interpretComplex units instr = do
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)
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
run :: VM -> B.ByteString -> IO (Either String VM)
run vm input = evalStateT (runExceptT machine) vm
where machine = (return input) >>= (return .B.unpack) >>= (except . parse) >>= interpret >> (lift get)

88
app/VirtualMachine/VM.hs
View File

@@ -1,8 +1,11 @@
module VirtualMachine.VM where
import Data.Foldable (toList)
import Control.Monad.State (State, get, put)
import Control.Monad.Trans.Except (ExceptT, except)
import Control.Monad.Trans (lift)
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
@@ -40,6 +43,8 @@ data Op = Nop -- 0x00
| Clr -- 0x18
deriving (Eq, Ord, Enum, Show, Read, Bounded)
type Machine = StateT VM IO
empty :: VM
empty = VM { _pc = 0
, _fp = -1
@@ -50,51 +55,62 @@ empty = VM { _pc = 0
-------------------------------------------------------------------------------
push :: [Int] -> State VM ()
push = pushS . S.fromList
getPc :: Machine Int
getPc = get >>= (return . _pc)
pushS :: S.Seq Int -> State VM ()
pushS numbers = do
getFp :: Machine Int
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
put vm { _stack = numbers <> _stack vm }
return ()
put vm { _pc = pc }
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
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
push :: [Int] -> Machine ()
push = pushS . S.fromList
pushS :: S.Seq Int -> Machine ()
pushS numbers = do
vm <- get
let stack = _stack vm
case (stack S.!? index) of
(Just i) -> return i
Nothing -> except $ Left err
put vm { _stack = numbers <> _stack vm }
return ()
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 :: Int -> Machine ()
forward offset = do
vm <- get
put vm { _pc = _pc vm + offset }
return ()
return ()