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

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"