From e3bcebcece18ff42aaae198ed2e3e5c4607f92a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bart=C5=82omiej=20Przemys=C5=82aw=20Pluta?= Date: Fri, 12 Nov 2021 11:03:57 +0100 Subject: [PATCH] Update VM to work on State monad --- app/Runner.hs | 4 +- app/VirtualMachine/Instruction.hs | 129 +++++++++++++++++------------- app/VirtualMachine/Interpreter.hs | 127 +++++++++++++++-------------- app/VirtualMachine/VM.hs | 88 +++++++++++--------- 4 files changed, 191 insertions(+), 157 deletions(-) diff --git a/app/Runner.hs b/app/Runner.hs index 9e7a5c8..ca5605b 100644 --- a/app/Runner.hs +++ b/app/Runner.hs @@ -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 \ No newline at end of file +exec vm input = runExceptT $ return input >>= (except . compile) >>= (liftIO . VM.run vm . B.pack) >>= except >>= return \ No newline at end of file diff --git a/app/VirtualMachine/Instruction.hs b/app/VirtualMachine/Instruction.hs index a489c58..1bd3dd5 100644 --- a/app/VirtualMachine/Instruction.hs +++ b/app/VirtualMachine/Instruction.hs @@ -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" \ No newline at end of file +clear [] _ = except $ Left "Number of elements to be cleaned expected" \ No newline at end of file diff --git a/app/VirtualMachine/Interpreter.hs b/app/VirtualMachine/Interpreter.hs index 629f46d..9544aad 100644 --- a/app/VirtualMachine/Interpreter.hs +++ b/app/VirtualMachine/Interpreter.hs @@ -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 \ No newline at end of file +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) \ No newline at end of file diff --git a/app/VirtualMachine/VM.hs b/app/VirtualMachine/VM.hs index 687fd37..811a3b7 100644 --- a/app/VirtualMachine/VM.hs +++ b/app/VirtualMachine/VM.hs @@ -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 () \ No newline at end of file + return () \ No newline at end of file