aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorAleksey Veresov <aleksey@veresov.pro>2021-02-16 13:11:37 +0300
committerAleksey Veresov <aleksey@veresov.pro>2021-02-16 13:11:37 +0300
commit7f59fd16534fc4fe417640130c415107008a638c (patch)
treeb1dd2f6954f6590c3cd546c5548b26ab3ec1f105 /src
parent97bbb430e4f1460858b2f1baaffc2ef804c63086 (diff)
downloadsuem-7f59fd16534fc4fe417640130c415107008a638c.tar
suem-7f59fd16534fc4fe417640130c415107008a638c.tar.xz
suem-7f59fd16534fc4fe417640130c415107008a638c.zip
Now Machine is in Emulator which is a monad. =)
Diffstat (limited to 'src')
-rw-r--r--src/Commands.hs99
-rw-r--r--src/Machine.hs210
-rw-r--r--src/Suem.hs83
-rw-r--r--src/Utils.hs44
4 files changed, 317 insertions, 119 deletions
diff --git a/src/Commands.hs b/src/Commands.hs
index 6d99b00..e22981e 100644
--- a/src/Commands.hs
+++ b/src/Commands.hs
@@ -1,74 +1,69 @@
+-- This module describes the semantics of machine commands.
module Commands where
-import Control.Lens
+import Prelude hiding (Word)
import Machine
import Utils
+import Data.IORef
-doNothing :: Machine -> Machine
-doNothing m = Machine (Registers (pc r + 2) (sr r) (drs r)
- (ars r) (usp r) (ssp r))
- (ram m) (rom m)
- where r = regs m
-_doUnlink :: Int -> Machine -> Machine
-_doUnlink 7 m = let r = regs m in if isSupervisor m
- then Machine (Registers (pc r + 2) (sr r) (drs r) (ars r)
- (usp r) (getLong m (fromIntegral $ ssp r) + 4))
- (ram m) (rom m)
- else Machine (Registers (pc r + 2) (sr r) (drs r) (ars r)
- (getLong m (fromIntegral $ usp r) + 4) (ssp r))
- (ram m) (rom m)
-_doUnlink a m = let
- r = regs m
- av = getLong m (fromIntegral (ars r !! a))
- newars = ars r & element (fromIntegral a) .~ av
- in if isSupervisor m
- then Machine (Registers (pc r + 2) (sr r) (drs r)
- newars (usp r) (av + 4))
- (ram m) (rom m)
- else Machine (Registers (pc r + 2) (sr r) (drs r)
- newars (av + 4) (ssp r))
- (ram m) (rom m)
-doUnlink :: [Int] -> Machine -> Machine
+doNothing :: Emulator ()
+doNothing = with pc $ \pc -> do
+ pcval <- readIORef pc
+ writeIORef pc (pcval + 2)
+
+_doUnlink :: Int -> Emulator ()
+_doUnlink a = do
+ addr <- readA a
+ val <- getLong addr
+ with pc $ \pc -> do
+ pcval <- readIORef pc
+ writeIORef pc (pcval + 2)
+ isSupervisor >>= \sup -> if sup
+ then with ssp $ \sp -> do
+ writeIORef sp (val + 4)
+ else with usp $ \sp -> do
+ writeIORef sp (val + 4)
+doUnlink :: [Int] -> Emulator ()
doUnlink = _doUnlink . fromBits
-doReset :: Machine -> Machine
-doReset = id
+doReset :: Emulator ()
+doReset = return ()
-doStop :: Machine -> Machine
-doStop = id
+doStop :: Emulator ()
+doStop = return ()
-doRTE :: Machine -> Machine
-doRTE = id
+doRTE :: Emulator ()
+doRTE = return ()
-doRTS :: Machine -> Machine
-doRTS = id
+doRTS :: Emulator ()
+doRTS = return ()
-doTrapV :: Machine -> Machine
-doTrapV = id
+doTrapV :: Emulator ()
+doTrapV = return ()
-doRTR :: Machine -> Machine
-doRTR = id
+doRTR :: Emulator ()
+doRTR = return ()
-doIllegal :: Machine -> Machine
-doIllegal = id
+doIllegal :: Emulator ()
+doIllegal = return ()
-_doTAS :: Int -> Int -> Machine -> Machine
-_doTAS _ _ = id
-doTAS :: [Int] -> [Int] -> Machine -> Machine
+_doTAS :: Int -> Int -> Emulator ()
+_doTAS _ _ = return ()
+doTAS :: [Int] -> [Int] -> Emulator ()
doTAS = args2 _doTAS
-_doTST :: Int -> Int -> Int -> Machine -> Machine
-_doTST _ _ _ = id
-doTST :: [Int] -> [Int] -> [Int] -> Machine -> Machine
+_doTST :: Int -> Int -> Int -> Emulator ()
+_doTST _ _ _ = return ()
+doTST :: [Int] -> [Int] -> [Int] -> Emulator ()
doTST = args3 _doTST
-_doTrap :: Int -> Machine -> Machine
-_doTrap _ = id
-doTrap :: [Int] -> Machine -> Machine
+_doTrap :: Int -> Emulator ()
+_doTrap _ = return ()
+doTrap :: [Int] -> Emulator ()
doTrap = _doTrap . fromBits
-_doLink :: Int -> Machine -> Machine
-_doLink _ = id
-doLink :: [Int] -> Machine -> Machine
+_doLink :: Int -> Emulator ()
+_doLink _ = return ()
+doLink :: [Int] -> Emulator ()
doLink = _doLink . fromBits
diff --git a/src/Machine.hs b/src/Machine.hs
index 5e6256f..06860bf 100644
--- a/src/Machine.hs
+++ b/src/Machine.hs
@@ -1,38 +1,192 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- This module describes the basic types and operations for our machine.
module Machine where
import qualified Data.Vector.Unboxed as V
-import Data.Word
-import Data.Bits
-
-data Registers = Registers {
- pc :: Word32,
- sr :: Word16,
- drs :: [Word32], -- d0 to d7
- ars :: [Word32], -- a0 to a6
- usp :: Word32, -- this is a7 in user mode
- ssp :: Word32 -- this is a7 in supermode
-}
+import qualified Data.Vector.Unboxed.Mutable as VM
+import Prelude hiding (Word)
+import Data.Word (Word32, Word16, Word8)
+import Data.Bits (testBit)
+import Data.IORef
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Reader (MonadReader, ReaderT, ask)
+import Control.Monad.Trans (MonadIO)
+import Utils
+
+
+-------------------------------------------------------------------------------
+-- Base Types
+
+type Long = Word32
+type Word = Word16
+type Byte = Word8
data Machine = Machine {
- regs :: Registers,
- ram :: V.Vector Word8,
- rom :: V.Vector Word8
+ pc :: IORef Long,
+ sr :: IORef Word,
+ drs :: IORef (Long, Long, Long, Long, Long, Long, Long, Long),
+ ars :: IORef (Long, Long, Long, Long, Long, Long, Long),
+ usp :: IORef Long, -- this is a7 in user mode
+ ssp :: IORef Long, -- this is a7 in supermode
+ ram :: VM.IOVector Byte,
+ rom :: V.Vector Byte
}
-isSupervisor :: Machine -> Bool
-isSupervisor m = testBit (sr $ regs m) 2
+-- Emulator is a monad which contains Machine and allows easy change of it.
+newtype Emulator a = Emulator (ReaderT Machine IO a)
+ deriving (Monad, Applicative, Functor, MonadIO, MonadReader Machine)
+
+with :: (Machine -> b) -> (b -> IO a) -> Emulator a
+with field f = do
+ m <- ask
+ liftIO $ f (field m)
+
+
+-------------------------------------------------------------------------------
+-- Data and Address Registers Access
+
+readD :: Int -> Emulator Long
+readD 0 = with drs $ \rs -> do
+ (r,_,_,_,_,_,_,_) <- readIORef rs
+ return r
+readD 1 = with drs $ \rs -> do
+ (_,r,_,_,_,_,_,_) <- readIORef rs
+ return r
+readD 2 = with drs $ \rs -> do
+ (_,_,r,_,_,_,_,_) <- readIORef rs
+ return r
+readD 3 = with drs $ \rs -> do
+ (_,_,_,r,_,_,_,_) <- readIORef rs
+ return r
+readD 4 = with drs $ \rs -> do
+ (_,_,_,_,r,_,_,_) <- readIORef rs
+ return r
+readD 5 = with drs $ \rs -> do
+ (_,_,_,_,_,r,_,_) <- readIORef rs
+ return r
+readD 6 = with drs $ \rs -> do
+ (_,_,_,_,_,_,r,_) <- readIORef rs
+ return r
+readD 7 = with drs $ \rs -> do
+ (_,_,_,_,_,_,_,r) <- readIORef rs
+ return r
+readD _ = return $ error "Incorrect Data register read"
+
+readA :: Int -> Emulator Long
+readA 0 = with ars $ \rs -> do
+ (r,_,_,_,_,_,_) <- readIORef rs
+ return r
+readA 1 = with ars $ \rs -> do
+ (_,r,_,_,_,_,_) <- readIORef rs
+ return r
+readA 2 = with ars $ \rs -> do
+ (_,_,r,_,_,_,_) <- readIORef rs
+ return r
+readA 3 = with ars $ \rs -> do
+ (_,_,_,r,_,_,_) <- readIORef rs
+ return r
+readA 4 = with ars $ \rs -> do
+ (_,_,_,_,r,_,_) <- readIORef rs
+ return r
+readA 5 = with ars $ \rs -> do
+ (_,_,_,_,_,r,_) <- readIORef rs
+ return r
+readA 6 = with ars $ \rs -> do
+ (_,_,_,_,_,_,r) <- readIORef rs
+ return r
+readA 7 = isSupervisor >>= \sup -> if sup
+ then with ssp $ \sp -> readIORef sp
+ else with usp $ \sp -> readIORef sp
+readA _ = return $ error "Incorrect Address register read"
+
+
+-------------------------------------------------------------------------------
+-- Status Register Access
+
+isTracing :: Emulator Bool
+isTracing = with sr $ \sr -> do
+ sr <- readIORef sr
+ return $ testBit sr 0
+
+isSupervisor :: Emulator Bool
+isSupervisor = with sr $ \sr -> do
+ sr <- readIORef sr
+ return $ testBit sr 2
+
+interruptLevel :: Emulator Int
+interruptLevel = with sr $ \sr -> do
+ sr <- readIORef sr
+ return $ extractBits sr [5, 6, 7]
+
+isExtend :: Emulator Bool
+isExtend = with sr $ \sr -> do
+ sr <- readIORef sr
+ return $ testBit sr 11
+
+isNegative :: Emulator Bool
+isNegative = with sr $ \sr -> do
+ sr <- readIORef sr
+ return $ testBit sr 12
+
+isZero :: Emulator Bool
+isZero = with sr $ \sr -> do
+ sr <- readIORef sr
+ return $ testBit sr 13
+
+isOverflow :: Emulator Bool
+isOverflow = with sr $ \sr -> do
+ sr <- readIORef sr
+ return $ testBit sr 14
+
+isCarry :: Emulator Bool
+isCarry = with sr $ \sr -> do
+ sr <- readIORef sr
+ return $ testBit sr 15
+
+
+-------------------------------------------------------------------------------
+-- Memmory Access
+
+getByte :: Long -> Emulator Byte
+getByte a | a < 0x8 = with rom $ \rom -> return $ rom V.! fromIntegral a
+ | a < 0x7e0000 = with ram $ \ram ->
+ if VM.length ram >= fromIntegral a
+ then VM.unsafeRead ram (fromIntegral a)
+ else return 0xff
+ | a < 0x800000 = with rom $ \rom ->
+ return $ rom V.! (fromIntegral a - 0x7e0000)
+ | otherwise = return 0xff
+
+ -- TODO: only even addresses are allowed
+getWord :: Long -> Emulator Word
+getWord a = do
+ g <- getByte a
+ l <- getByte (a + 1)
+ return $ (fromIntegral g) * 256 + (fromIntegral l)
+
+ -- TODO: only even addresses are allowed
+getLong :: Long -> Emulator Long
+getLong a = do
+ g <- getWord a
+ l <- getWord (a + 2)
+ return $ (fromIntegral g) * 256 * 256 + (fromIntegral l)
+
-getByte :: Machine -> Int -> Word8
-getByte m a | a < 0x8 = rom m V.! a
- | a < 0x7e0000 = if V.length (ram m) >= a then ram m V.! a
- else 0xff
- | a < 0x800000 = rom m V.! (a - 0x7e0000)
- | otherwise = 0xff
+setByte :: Long -> Byte -> Emulator ()
+setByte a b | a < 0x8 = return ()
+ | a < 0x7e0000 = with ram $ \ram ->
+ VM.write ram (fromIntegral a) b
+ | otherwise = return ()
-getWord :: Machine -> Int -> Word16 -- TODO: only even addresses are allowed
-getWord m a = (fromIntegral $ getByte m a) * 256 +
- (fromIntegral $ getByte m (a + 1))
+ -- TODO: only even addresses are allowed
+setWord :: Long -> Word -> Emulator ()
+setWord a w = do
+ setByte a (fromIntegral (rem (fromIntegral w) 256))
+ setByte (a + 1) (fromIntegral (div (fromIntegral w) 256))
-getLong :: Machine -> Int -> Word32 -- TODO: only even addresses are allowed
-getLong m a = (fromIntegral $ getWord m a) * 256 * 256 +
- (fromIntegral $ getWord m (a + 2))
+ -- TODO: only even addresses are allowed
+setLong :: Long -> Long -> Emulator ()
+setLong a l = do
+ setWord a (fromIntegral (rem (fromIntegral l) 256 * 256))
+ setWord (a + 2) (fromIntegral (div (fromIntegral l) 256 * 256))
diff --git a/src/Suem.hs b/src/Suem.hs
index fe73a1e..0207a91 100644
--- a/src/Suem.hs
+++ b/src/Suem.hs
@@ -1,28 +1,23 @@
+-- This module organizes Emulator execution.
module Suem (Config(..), ConfigSocket(..), suem) where
import qualified Data.Vector.Unboxed as V
+import qualified Data.Vector.Unboxed.Mutable as VM
import qualified Data.ByteString as B
+import Prelude hiding (Word)
import Data.Word
+import Data.IORef
+import Data.Foldable
+import Control.Monad.Reader (runReaderT)
import Machine
import Commands
import Utils
-data ConfigSocket = ConfigInet String | ConfigUnix String
+-------------------------------------------------------------------------------
+-- Main loop and command deciphering.
-data Config = Config Int -- frequence
- Int -- size of RAM
- FilePath -- path to ROM
- (Maybe ConfigSocket)
- (Maybe ConfigSocket)
- (Maybe ConfigSocket)
- (Maybe ConfigSocket)
- (Maybe ConfigSocket)
- (Maybe ConfigSocket)
- (Maybe ConfigSocket)
- (Maybe ConfigSocket)
-
-doCommand :: [Int] -> Machine -> Machine
+doCommand :: [Int] -> Emulator ()
doCommand [0,1,0,0,1,1,1,0, 0,1,1,0,0,0,0,0] = doReset
doCommand [0,1,0,0,1,1,1,0, 0,1,1,0,0,0,0,1] = doNothing
doCommand [0,1,0,0,1,1,1,0, 0,1,1,0,0,0,1,0] = doStop
@@ -38,18 +33,58 @@ doCommand [0,1,0,0,1,0,1,0, 0,1,0,1,1,a,b,c] = doUnlink [a,b,c]
doCommand [0,1,0,0,1,0,1,0, a,b,c,d,e,f,g,h] = doTST [a,b] [c,d,e] [f,g,h]
doCommand _ = error "Bad command."
-runMachine :: Machine -> IO ()
-runMachine m = do
- runMachine $ doCommand (toBits $ getWord m $ fromIntegral $ pc $ regs m) m
+runMachine :: Emulator ()
+runMachine = forM_ [0..] $ \_ -> do
+ pc <- with pc $ \pc -> readIORef pc
+ cmd <- getWord $ fromIntegral pc
+ doCommand (toBitsWhole cmd)
+
+
+-------------------------------------------------------------------------------
+-- Config and start of execution based on the config.
+
+data ConfigSocket = ConfigInet String | ConfigUnix String
+
+data Config = Config Int -- frequence
+ Int -- size of RAM
+ FilePath -- path to ROM
+ (Maybe ConfigSocket)
+ (Maybe ConfigSocket)
+ (Maybe ConfigSocket)
+ (Maybe ConfigSocket)
+ (Maybe ConfigSocket)
+ (Maybe ConfigSocket)
+ (Maybe ConfigSocket)
+ (Maybe ConfigSocket)
+
+makeMachine :: VM.IOVector Byte -> V.Vector Byte -> IO Machine
+makeMachine ramData romData = do
+ pc <- newIORef pcval
+ sr <- newIORef 0x2700
+ drs <- newIORef (fromIntegral 0, fromIntegral 0, fromIntegral 0,
+ fromIntegral 0, fromIntegral 0, fromIntegral 0,
+ fromIntegral 0, fromIntegral 0)
+ ars <- newIORef (fromIntegral 0, fromIntegral 0, fromIntegral 0,
+ fromIntegral 0, fromIntegral 0, fromIntegral 0,
+ fromIntegral 0)
+ usp <- newIORef 0
+ ssp <- newIORef sspval
+ return $ Machine pc sr drs ars usp ssp ramData romData
+ where pcval = (fromIntegral $ romData V.! 4) * 256 * 256 * 256 +
+ (fromIntegral $ romData V.! 5) * 256 * 256 +
+ (fromIntegral $ romData V.! 6) * 256 +
+ (fromIntegral $ romData V.! 7)
+ sspval = (fromIntegral $ romData V.! 0) * 256 * 256 * 256 +
+ (fromIntegral $ romData V.! 1) * 256 * 256 +
+ (fromIntegral $ romData V.! 2) * 256 +
+ (fromIntegral $ romData V.! 3)
-makeMachine :: V.Vector Word8 -> Int -> Machine
-makeMachine romData ramSize = Machine rs rd romData
- where rd = V.replicate ramSize 0
- rs = Registers (getLong m 0x7e0004) 0x2700 (replicate 8 0)
- (replicate 7 0) 0 (getLong m 0x7e0000)
- m = Machine (Registers 0 0 [] [] 0 0) V.empty romData
+runEmulator :: Emulator a -> Machine -> IO a
+runEmulator (Emulator reader) m = runReaderT reader m
suem :: Config -> IO ()
suem (Config _ ramSize romPath _ _ _ _ _ _ _ _) = do
romData <- B.readFile romPath
- runMachine (makeMachine (V.fromList $ B.unpack $ romData) ramSize)
+ ram <- VM.replicate ramSize 0
+ m <- makeMachine ram (V.fromList $ B.unpack $ romData)
+ runEmulator runMachine m
diff --git a/src/Utils.hs b/src/Utils.hs
index 345b085..475821a 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -1,32 +1,46 @@
+-- This module describes utility functions.
module Utils where
-import Data.Word
+import Prelude hiding (Word)
import Data.Bits
-import Machine
-boolToInt :: Bool -> Int
-boolToInt True = 1
-boolToInt False = 0
-toBits :: Word16 -> [Int]
-toBits x = map (boolToInt . testBit x) [0..(finiteBitSize x-1)]
+-------------------------------------------------------------------------------
+-- Bitwork
+
+toBit :: Bool -> Int
+toBit True = 1
+toBit False = 0
+
+toBits :: Bits a => a -> [Int] -> [Int]
+toBits x r = map (toBit . testBit x) r
+
+toBitsWhole :: FiniteBits a => a -> [Int]
+toBitsWhole x = toBits x [0..(finiteBitSize x - 1)]
fromBits :: [Int] -> Int
fromBits = foldl (\a b -> 2 * a + b) 0 . reverse
-args2 :: (Int -> Int -> Machine -> Machine) ->
- [Int] -> [Int] -> Machine -> Machine
+extractBits :: Bits a => a -> [Int] -> Int
+extractBits x r = fromBits $ toBits x r
+
+
+-------------------------------------------------------------------------------
+-- Transformers for commands arguments
+
+args2 :: (Int -> Int -> t) ->
+ [Int] -> [Int] -> t
args2 f a b = f (fromBits a) (fromBits b)
-args3 :: (Int -> Int -> Int -> Machine -> Machine) ->
- [Int] -> [Int] -> [Int] -> Machine -> Machine
+args3 :: (Int -> Int -> Int -> t) ->
+ [Int] -> [Int] -> [Int] -> t
args3 f a b c = f (fromBits a) (fromBits b) (fromBits c)
-args4 :: (Int -> Int -> Int -> Int -> Machine -> Machine) ->
- [Int] -> [Int] -> [Int] -> [Int] -> Machine -> Machine
+args4 :: (Int -> Int -> Int -> Int -> t) ->
+ [Int] -> [Int] -> [Int] -> [Int] -> t
args4 f a b c d = f (fromBits a) (fromBits b) (fromBits c) (fromBits d)
-args5 :: (Int -> Int -> Int -> Int -> Int -> Machine -> Machine) ->
- [Int] -> [Int] -> [Int] -> [Int] -> [Int] -> Machine -> Machine
+args5 :: (Int -> Int -> Int -> Int -> Int -> t) ->
+ [Int] -> [Int] -> [Int] -> [Int] -> [Int] -> t
args5 f a b c d e = f (fromBits a) (fromBits b) (fromBits c)
(fromBits d) (fromBits e)