From 7f59fd16534fc4fe417640130c415107008a638c Mon Sep 17 00:00:00 2001 From: Aleksey Veresov Date: Tue, 16 Feb 2021 13:11:37 +0300 Subject: Now Machine is in Emulator which is a monad. =) --- src/Commands.hs | 99 +++++++++++++------------- src/Machine.hs | 210 ++++++++++++++++++++++++++++++++++++++++++++++++-------- src/Suem.hs | 83 +++++++++++++++------- src/Utils.hs | 44 ++++++++---- 4 files changed, 317 insertions(+), 119 deletions(-) (limited to 'src') 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) -- cgit v1.2.3