From 174af9536fe1321bb509b63063d33b33737dd39b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bart=C5=82omiej=20Przemys=C5=82aw=20Pluta?= Date: Tue, 9 Nov 2021 19:11:02 +0100 Subject: [PATCH] Create print-based VM debugger --- app/Main.hs | 4 ++-- app/VirtualMachine/Instruction.hs | 10 ++++------ app/VirtualMachine/Interpreter.hs | 30 ++++++++++++++++++++++++------ app/VirtualMachine/VM.hs | 9 +++++---- 4 files changed, 35 insertions(+), 18 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 76e384a..94f719b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,13 +3,13 @@ module Main where import System.Environment import Control.Monad.Trans.Except (runExceptT, except) -import VirtualMachine.VM (VM) +import VirtualMachine.VM (VM(..), empty) import VirtualMachine.Interpreter (run) import Assembler.Compiler (compile) import qualified Data.ByteString as B interpret :: String -> IO (Either String VM) -interpret input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= run +interpret input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= run empty { _debug = False } main :: IO () main = do diff --git a/app/VirtualMachine/Instruction.hs b/app/VirtualMachine/Instruction.hs index 206710d..83b06b1 100644 --- a/app/VirtualMachine/Instruction.hs +++ b/app/VirtualMachine/Instruction.hs @@ -48,8 +48,8 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\ , Complex { _op = Jl, _noParams = 1, _noPops = 1, _cAction = jumpIf (<) } , Complex { _op = Jge, _noParams = 1, _noPops = 1, _cAction = jumpIf (>=) } , Complex { _op = Jle, _noParams = 1, _noPops = 1, _cAction = jumpIf (<=) } + , Complex { _op = In, _noParams = 0, _noPops = 0, _cAction = niy In } , Complex { _op = Out, _noParams = 0, _noPops = 1, _cAction = output } - , Complex { _op = Dbg, _noParams = 0, _noPops = 0, _cAction = debug } ] instructionByOp :: M.Map Op Instruction @@ -81,11 +81,6 @@ ret vm _ _ = do return vm { _fp = fp', _pc = retAddr, _stack = stack' } -debug :: VM -> Params -> Pops -> ExceptT String IO VM -debug vm _ _ = do - liftIO $ print vm - return vm { _pc = _pc vm + 1 } - jumpIf :: (Int -> Int -> Bool) -> VM -> Params -> Pops -> ExceptT String IO VM jumpIf predicate vm (addr:_) (top:_) = except $ Right $ vm { _pc = pc } where pc = if top `predicate` 0 then addr else _pc vm + 2 @@ -97,3 +92,6 @@ output vm _ (char:_) = do liftIO $ putStr $ [chr char] return (execState (forward 1) vm) output _ _ [] = except $ Left $ "Empty stack - nothing to output" + +niy :: Op -> VM -> Params -> Pops -> ExceptT String IO VM +niy op vm _ _ = except $ Left $ "Instruction '" ++ (show op) ++ "' ("++ (show $ _pc vm) ++") is not implemented yet" \ No newline at end of file diff --git a/app/VirtualMachine/Interpreter.hs b/app/VirtualMachine/Interpreter.hs index cf5ac5d..1076fb5 100644 --- a/app/VirtualMachine/Interpreter.hs +++ b/app/VirtualMachine/Interpreter.hs @@ -1,8 +1,9 @@ module VirtualMachine.Interpreter where import Data.Word (Word8) +import Data.List (intercalate) import Control.Monad.Trans.Except (ExceptT, except) -import Control.Monad.State (runState, execState) +import Control.Monad.State (liftIO, runState, execState) import qualified Data.Map as M import qualified Data.ByteString as B @@ -52,9 +53,23 @@ interpretUnit vm units unit = units !! pc dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM -dispatchInstr vm units instr = case instr of - Simple {} -> except $ Right $ interpretSimple vm units instr - Complex {} -> interpretComplex vm units instr +dispatchInstr vm units instr = do + liftIO $ debugPrint vm instr units + + case instr of + Simple {} -> except $ Right $ 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 -> VM interpretSimple vm units instr = flip execState vm $ do @@ -84,5 +99,8 @@ interpretComplex vm units instr = action vm' params pops action = _cAction instr -run :: B.ByteString -> ExceptT String IO VM -run code = (return $ B.unpack code) >>= (except . parse) >>= interpret empty \ No newline at end of file +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 diff --git a/app/VirtualMachine/VM.hs b/app/VirtualMachine/VM.hs index bee612f..08746ed 100644 --- a/app/VirtualMachine/VM.hs +++ b/app/VirtualMachine/VM.hs @@ -6,10 +6,11 @@ import Control.Monad.Trans.Except (ExceptT, except) import qualified Data.Sequence as S -data VM = VM { _pc :: Int - , _fp :: Int +data VM = VM { _pc :: Int + , _fp :: Int , _stack :: S.Seq Int - , _halt :: Bool + , _halt :: Bool + , _debug :: Bool } deriving (Show, Eq) data Op = Nop -- 0x00 @@ -36,7 +37,6 @@ data Op = Nop -- 0x00 | Ld -- 0x15 | In -- 0x16 | Out -- 0x17 - | Dbg -- 0x18 deriving (Eq, Ord, Enum, Show, Read, Bounded) empty :: VM @@ -44,6 +44,7 @@ empty = VM { _pc = 0 , _fp = -1 , _stack = S.empty , _halt = False + , _debug = False } -------------------------------------------------------------------------------