Now Machine is in Emulator which is a monad. =)

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)