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

Add support for IO in VirtualMachine

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-08 21:39:55 +01:00
parent df1f8262dc
commit e2800fe69f
3 changed files with 36 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
MVM.cabal
View File

@@ -40,7 +40,8 @@ executable MVM
base ^>=4.15.0.0, base ^>=4.15.0.0,
bytestring ^>=0.11.0.0, bytestring ^>=0.11.0.0,
containers ^>=0.6.4.1, containers ^>=0.6.4.1,
mtl ^>=2.2.2 mtl ^>=2.2.2,
transformers ^>=0.5.6.2
hs-source-dirs: app hs-source-dirs: app
default-language: Haskell2010 default-language: Haskell2010
@@ -57,6 +58,7 @@ test-suite spec
bytestring ^>=0.11.0.0, bytestring ^>=0.11.0.0,
containers ^>=0.6.4.1, containers ^>=0.6.4.1,
mtl ^>=2.2.2, mtl ^>=2.2.2,
transformers ^>=0.5.6.2,
hspec ==2.* hspec ==2.*
other-modules: other-modules:
Assembler.TokenizerSpec Assembler.TokenizerSpec

4
app/Main.hs
View File

@@ -6,10 +6,12 @@ import qualified VirtualMachine as VM
import Assembler.Compiler (compile) import Assembler.Compiler (compile)
import Control.Monad.Trans.Except
run :: String -> IO () run :: String -> IO ()
run input = case compile input of run input = case compile input of
(Right bytes) -> print $ VM.run VM.empty (B.pack bytes) (Right bytes) -> runExceptT (VM.run VM.empty (B.pack bytes)) >>= print >> return ()
(Left err) -> putStrLn err (Left err) -> putStrLn err
main :: IO () main :: IO ()

48
app/VirtualMachine.hs
View File

@@ -12,7 +12,10 @@ module VirtualMachine (
import Data.Word (Word8) import Data.Word (Word8)
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Char (toLower, toUpper) import Data.Char (chr, toLower, toUpper)
import Control.Monad.Trans (liftIO, lift)
import Control.Monad.Trans.Except (ExceptT(..), runExceptT, 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
@@ -49,6 +52,8 @@ data Op = Nop -- 0x00
| Jge -- 0x13 | Jge -- 0x13
| Jle -- 0x14 | Jle -- 0x14
| Ld -- 0x15 | Ld -- 0x15
| In -- 0x16
| Out -- 0x17
deriving (Eq, Ord, Enum, Show, Read, Bounded) deriving (Eq, Ord, Enum, Show, Read, Bounded)
type Args = [Int] type Args = [Int]
@@ -62,7 +67,7 @@ data Instruction = Simple { _op :: Op
} }
| Complex { _op :: Op | Complex { _op :: Op
, _noParams :: Int , _noParams :: Int
, _cAction :: VM -> Args -> Either String VM , _cAction :: VM -> Args -> ExceptT String IO VM
} }
data Command = Command { _instr :: Instruction data Command = Command { _instr :: Instruction
@@ -88,24 +93,31 @@ 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, _cAction = (\vm _ -> Right $ vm { _halt = True }) } , Complex { _op = Halt, _noParams = 0, _cAction = (\vm _ -> except $ Right $ vm { _halt = True }) }
, Complex { _op = Jmp, _noParams = 1, _cAction = (\vm [x] -> Right $ vm { _pc = x}) } , Complex { _op = Jmp, _noParams = 1, _cAction = (\vm [x] -> except $ Right $ vm { _pc = x}) }
, Complex { _op = Je, _noParams = 1, _cAction = jumpIf (==) } , Complex { _op = Je, _noParams = 1, _cAction = jumpIf (==) }
, Complex { _op = Jne, _noParams = 1, _cAction = jumpIf (/=) } , Complex { _op = Jne, _noParams = 1, _cAction = jumpIf (/=) }
, Complex { _op = Jg, _noParams = 1, _cAction = jumpIf (>) } , Complex { _op = Jg, _noParams = 1, _cAction = jumpIf (>) }
, Complex { _op = Jl, _noParams = 1, _cAction = jumpIf (<) } , Complex { _op = Jl, _noParams = 1, _cAction = jumpIf (<) }
, Complex { _op = Jge, _noParams = 1, _cAction = jumpIf (>=) } , Complex { _op = Jge, _noParams = 1, _cAction = jumpIf (>=) }
, Complex { _op = Jle, _noParams = 1, _cAction = jumpIf (<=) } , Complex { _op = Jle, _noParams = 1, _cAction = jumpIf (<=) }
, Complex { _op = Out, _noParams = 0, _cAction = output }
] ]
jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> Either String VM jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> ExceptT String IO VM
jumpIf _ _ [] = Left $ "Address expected" jumpIf _ _ [] = except $ Left $ "Address expected"
jumpIf _ _ (_:_:_) = Left $ "Multiple parameters are not supported by jmp* instructions" jumpIf _ _ (_:_:_) = except $ Left $ "Multiple parameters are not supported by jmp* instructions"
jumpIf predicate vm [addr] = Right $ vm { _pc = pc } jumpIf predicate vm [addr] = except $ Right $ vm { _pc = pc }
where where
(top:_) = toList . _stack $ vm (top:_) = toList . _stack $ vm
pc = if top `predicate` 0 then addr else _pc vm + 1 pc = if top `predicate` 0 then addr else _pc vm + 1
output :: VM -> Args -> ExceptT String IO VM
output vm _ = do
let char = map chr $ toList $ S.take 1 $ _stack vm
liftIO $ putStr char
return vm { _pc = _pc vm + 1, _stack = S.drop 1 $ _stack vm}
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
@@ -133,18 +145,18 @@ parseCommand (opByte:xs) = do
let params = map fromIntegral $ take paramsNumber xs :: [Int] let params = map fromIntegral $ take paramsNumber xs :: [Int]
return (Command instruction params, drop paramsNumber xs) return (Command instruction params, drop paramsNumber xs)
interpret :: [Command] -> VM -> Either String VM interpret :: [Command] -> VM -> ExceptT String IO VM
interpret _ vm@(VM _ _ _ True) = Right $ vm interpret _ vm@(VM _ _ _ True) = except $ Right $ vm
interpret cmds vm = do interpret cmds vm = do
vm' <- interpretCommand cmds vm vm' <- interpretCommand cmds vm
interpret cmds vm' interpret cmds vm'
interpretCommand :: [Command] -> VM -> Either String VM interpretCommand :: [Command] -> VM -> ExceptT String IO VM
interpretCommand [] _ = Left $ "Empty code" interpretCommand [] _ = except $ Left $ "Empty code"
interpretCommand cmds vm@(VM pc _ _ _) interpretCommand cmds vm@(VM pc _ _ _)
| pc >= length cmds = Right $ vm { _halt = True } | pc >= length cmds = except $ Right $ vm { _halt = True }
| otherwise = case instr of | otherwise = case instr of
(Simple _ _ _ _) -> interpretSimple vm cmd (Simple _ _ _ _) -> except $ interpretSimple vm cmd
(Complex _ _ _) -> interpretComplex vm cmd (Complex _ _ _) -> interpretComplex vm cmd
where cmd@(Command instr _) = cmds !! pc where cmd@(Command instr _) = cmds !! pc
@@ -158,9 +170,9 @@ interpretSimple vm (Command (Simple _ _ noPops operation) args) = vm'
}) })
interpretSimple _ _ = Left "Unknown operation" interpretSimple _ _ = Left "Unknown operation"
interpretComplex :: VM -> Command -> Either String VM interpretComplex :: VM -> Command -> ExceptT String IO VM
interpretComplex vm (Command (Complex _ _ operation) args) = operation vm args interpretComplex vm (Command (Complex _ _ operation) args) = operation vm args
interpretComplex _ _ = Left "Unknown operation" interpretComplex _ _ = except $ Left "Unknown operation"
run :: VM -> B.ByteString -> Either String VM run :: VM -> B.ByteString -> ExceptT String IO VM
run vm code = parse code >>= flip interpret vm run vm code = return code >>= (except . parse) >>= flip interpret vm