Update VM to work on State monad
This commit is contained in:
@@ -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)
|
||||
Reference in New Issue
Block a user