diff options
| -rw-r--r-- | src/Control.hs | 389 | ||||
| -rw-r--r-- | src/Device.hs | 57 | ||||
| -rw-r--r-- | src/Instructions.hs | 1 | ||||
| -rw-r--r-- | src/Machine.hs | 381 | ||||
| -rw-r--r-- | src/Suem.hs | 3 |
5 files changed, 445 insertions, 386 deletions
diff --git a/src/Control.hs b/src/Control.hs new file mode 100644 index 0000000..65b3831 --- /dev/null +++ b/src/Control.hs @@ -0,0 +1,389 @@ +-- module describing control operations on machine +module Control where + +import Prelude hiding (Word) +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as VM +import Data.Bits (testBit, setBit, clearBit, (.&.), (.|.), shift) +import Data.IORef +import Control.Monad +import Machine +import Utils +import Device + + +------------------------------------------------------------------------------- +-- Data and Address Registers Access + +readD :: Int -> Int -> Emulator Long +readD 0 s = with drs $ \rs -> do + (r,_,_,_,_,_,_,_) <- readIORef rs + return $ convertLong r s +readD 1 s = with drs $ \rs -> do + (_,r,_,_,_,_,_,_) <- readIORef rs + return $ convertLong r s +readD 2 s = with drs $ \rs -> do + (_,_,r,_,_,_,_,_) <- readIORef rs + return $ convertLong r s +readD 3 s = with drs $ \rs -> do + (_,_,_,r,_,_,_,_) <- readIORef rs + return $ convertLong r s +readD 4 s = with drs $ \rs -> do + (_,_,_,_,r,_,_,_) <- readIORef rs + return $ convertLong r s +readD 5 s = with drs $ \rs -> do + (_,_,_,_,_,r,_,_) <- readIORef rs + return $ convertLong r s +readD 6 s = with drs $ \rs -> do + (_,_,_,_,_,_,r,_) <- readIORef rs + return $ convertLong r s +readD 7 s = with drs $ \rs -> do + (_,_,_,_,_,_,_,r) <- readIORef rs + return $ convertLong r s +readD _ _ = return $ error "Incorrect Data register read" + +readA :: Int -> Int -> Emulator Long +readA 0 s = with ars $ \rs -> do + (r,_,_,_,_,_,_) <- readIORef rs + return $ convertLong r s +readA 1 s = with ars $ \rs -> do + (_,r,_,_,_,_,_) <- readIORef rs + return $ convertLong r s +readA 2 s = with ars $ \rs -> do + (_,_,r,_,_,_,_) <- readIORef rs + return $ convertLong r s +readA 3 s = with ars $ \rs -> do + (_,_,_,r,_,_,_) <- readIORef rs + return $ convertLong r s +readA 4 s = with ars $ \rs -> do + (_,_,_,_,r,_,_) <- readIORef rs + return $ convertLong r s +readA 5 s = with ars $ \rs -> do + (_,_,_,_,_,r,_) <- readIORef rs + return $ convertLong r s +readA 6 s = with ars $ \rs -> do + (_,_,_,_,_,_,r) <- readIORef rs + return $ convertLong r s +readA 7 s = isSupervisor >>= \sup -> if sup + then with ssp $ \sp -> do + v <- readIORef sp + return $ convertLong v s + else with usp $ \sp -> do + v <- readIORef sp + return $ convertLong v s +readA _ _ = return $ error "Incorrect Address register read" + + +writeD :: Int -> Int -> Long -> Emulator () +writeD 0 s r = with drs $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs + writeIORef rs (combineLong r r0 s,r1,r2,r3,r4,r5,r6,r7) +writeD 1 s r = with drs $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs + writeIORef rs (r0,combineLong r r1 s,r2,r3,r4,r5,r6,r7) +writeD 2 s r = with drs $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs + writeIORef rs (r0,r1,combineLong r r2 s,r3,r4,r5,r6,r7) +writeD 3 s r = with drs $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs + writeIORef rs (r0,r1,r2,combineLong r r3 s,r4,r5,r6,r7) +writeD 4 s r = with drs $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs + writeIORef rs (r0,r1,r2,r3,combineLong r r4 s,r5,r6,r7) +writeD 5 s r = with drs $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs + writeIORef rs (r0,r0,r2,r3,r4,combineLong r r5 s,r6,r7) +writeD 6 s r = with drs $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs + writeIORef rs (r0,r1,r2,r3,r4,r5,combineLong r r6 s,r7) +writeD 7 s r = with drs $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs + writeIORef rs (r0,r1,r2,r3,r4,r5,r6,combineLong r r7 s) +writeD _ _ _ = return $ error "Incorrect Data register write" + +writeA :: Int -> Int -> Long -> Emulator () +writeA 0 s r = with ars $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs + writeIORef rs (combineLong r r0 s,r1,r2,r3,r4,r5,r6) +writeA 1 s r = with ars $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs + writeIORef rs (r0,combineLong r r1 s,r2,r3,r4,r5,r6) +writeA 2 s r = with ars $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs + writeIORef rs (r0,r1,combineLong r r2 s,r3,r4,r5,r6) +writeA 3 s r = with ars $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs + writeIORef rs (r0,r1,r2,combineLong r r3 s,r4,r5,r6) +writeA 4 s r = with ars $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs + writeIORef rs (r0,r1,r2,r3,combineLong r r4 s,r5,r6) +writeA 5 s r = with ars $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs + writeIORef rs (r0,r0,r2,r3,r4,combineLong r r5 s,r6) +writeA 6 s r = with ars $ \rs -> do + (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs + writeIORef rs (r0,r1,r2,r3,r4,r5,combineLong r r6 s) +writeA 7 s r = isSupervisor >>= \sup -> if sup + then with ssp $ \sp -> do + v <- readIORef sp + writeIORef sp $ combineLong r v s + else with usp $ \sp -> do + v <- readIORef sp + writeIORef sp $ combineLong r v s +writeA _ _ _ = return $ error "Incorrect Address register write" + + +------------------------------------------------------------------------------- +-- PC Register Access + +readPC = with pc $ \pc -> do + pc <- readIORef pc + return pc + +writePC r = with pc $ \pc -> do + writeIORef pc r + +incPC = with pc $ \pc -> do + pcval <- readIORef pc + writeIORef pc (pcval + 2) + + +------------------------------------------------------------------------------- +-- Status Register Access + +writeSR :: Word -> Emulator () +writeSR v = with sr $ \sr -> do + writeIORef sr v + +readSR :: Emulator Word +readSR = with sr $ \sr -> do + sr <- readIORef sr + return sr + + +isTracing :: Emulator Bool +isTracing = with sr $ \sr -> do + sr <- readIORef sr + return $ testBit sr 15 + +isSupervisor :: Emulator Bool +isSupervisor = with sr $ \sr -> do + sr <- readIORef sr + return $ testBit sr 13 + +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 4 + +isNegative :: Emulator Bool +isNegative = with sr $ \sr -> do + sr <- readIORef sr + return $ testBit sr 3 + +isZero :: Emulator Bool +isZero = with sr $ \sr -> do + sr <- readIORef sr + return $ testBit sr 2 + +isOverflow :: Emulator Bool +isOverflow = with sr $ \sr -> do + sr <- readIORef sr + return $ testBit sr 1 + +isCarry :: Emulator Bool +isCarry = with sr $ \sr -> do + sr <- readIORef sr + return $ testBit sr 0 + + +setTracing :: Bool -> Emulator () +setTracing b = with sr $ \sr -> do + srval <- readIORef sr + writeIORef sr $ (if b then setBit else clearBit) srval 15 + +setSupervisor :: Bool -> Emulator () +setSupervisor b = with sr $ \sr -> do + srval <- readIORef sr + writeIORef sr $ (if b then setBit else clearBit) srval 13 + +setInterruptLevel :: Int -> Emulator () +setInterruptLevel v = do + srv <- readSR + writeSR $ srv .&. fromIntegral 0xF8FF .|. fromIntegral (shift v 16) + +setExtend :: Bool -> Emulator () +setExtend b = with sr $ \sr -> do + srval <- readIORef sr + writeIORef sr $ (if b then setBit else clearBit) srval 4 + +setNegative :: Bool -> Emulator () +setNegative b = with sr $ \sr -> do + srval <- readIORef sr + writeIORef sr $ (if b then setBit else clearBit) srval 3 + +setZero :: Bool -> Emulator () +setZero b = with sr $ \sr -> do + srval <- readIORef sr + writeIORef sr $ (if b then setBit else clearBit) srval 2 + +setOverflow :: Bool -> Emulator () +setOverflow b = with sr $ \sr -> do + srval <- readIORef sr + writeIORef sr $ (if b then setBit else clearBit) srval 1 + +setCarry :: Bool -> Emulator () +setCarry b = with sr $ \sr -> do + srval <- readIORef sr + writeIORef sr $ (if b then setBit else clearBit) srval 0 + + +------------------------------------------------------------------------------- +-- 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 = deviceGetByte a + + -- TODO: only even addresses are allowed +getWord :: Long -> Emulator Word +getWord a | a < 0x800000 = do + g <- getByte a + l <- getByte (a + 1) + return $ (fromIntegral g) * 256 + (fromIntegral l) + | otherwise = deviceGetWord a + + -- 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) + + +setByte :: Long -> Byte -> Emulator () +setByte a b | a < 0x8 = return () + | a < 0x7e0000 = with ram $ \ram -> + VM.write ram (fromIntegral a) b + | otherwise = deviceSetByte a b + + -- TODO: only even addresses are allowed +setWord :: Long -> Word -> Emulator () +setWord a w | a < 0x800000 = do + setByte a (fromIntegral (div (fromIntegral w) 256)) + setByte (a + 1) (fromIntegral (rem (fromIntegral w) 256)) + | otherwise = deviceSetWord a w + + -- TODO: only even addresses are allowed +setLong :: Long -> Long -> Emulator () +setLong a l = do + setWord a (fromIntegral (div (fromIntegral l) (256 * 256))) + setWord (a + 2) (fromIntegral (rem (fromIntegral l) (256 * 256))) + + +getMemory :: Long -> Int -> Emulator Long +getMemory a 1 = do + val <- getByte a + return $ fromIntegral val +getMemory a 2 = do + val <- getWord a + return $ fromIntegral val +getMemory a 4 = do + val <- getLong a + return $ fromIntegral val +getMemory _ _ = error "Bad size of getMemory" + +setMemory :: Long -> Int -> Long -> Emulator () +setMemory a 1 v = setByte a $ fromIntegral v +setMemory a 2 v = setWord a $ fromIntegral v +setMemory a 4 v = setLong a $ fromIntegral v +setMemory _ _ _ = error "Bad size of setMemory" + + +------------------------------------------------------------------------------- +-- Operand Access + +skipOp :: Int -> Emulator () +skipOp 1 = incPC +skipOp 2 = incPC +skipOp 4 = do + incPC + incPC +skipOp _ = error "Bad skipOp" + +getOp :: Int -> Int -> Int + -> Emulator (Emulator Long, Long -> Emulator ()) +getOp 0 dr s = return (readD dr s, writeD dr s) +getOp 1 ar s = return (readA ar s, writeA ar s) +getOp 2 ar s = do + addr <- readA ar 4 + return (getMemory addr s, setMemory addr s) +getOp 3 ar s = do + addr <- readA ar 4 + writeA ar 4 (addr + (fromIntegral s)) + return (getMemory addr s, setMemory addr s) +getOp 4 ar s = do + addr <- readA ar 4 + let naddr = addr - (fromIntegral s) + writeA ar 4 addr + return (getMemory naddr s, setMemory naddr s) +getOp 5 ar s = do + pc <- readPC + skipOp 2 + disp <- getMemory pc 2 + addr <- readA ar 4 + let naddr = addr + disp + return (getMemory naddr s, setMemory naddr s) +getOp 6 ar s = do + pc <- readPC + skipOp 2 + prefix <- getMemory pc 1 + index <- (if testBit prefix 0 then readA else readD) + (extractBits prefix [1..3]) + ((extractBits prefix [4] + 1) * 2) + disp <- getMemory (pc + 1) 1 + addr <- readA ar 4 + let naddr = addr + index + disp + return (getMemory naddr s, setMemory naddr s) +getOp 7 2 s = do + addr <- readPC + skipOp 2 + disp <- getMemory addr 2 + let naddr = addr + disp + return (getMemory naddr s, setMemory naddr s) +getOp 7 3 s = do + addr <- readPC + skipOp 2 + prefix <- getMemory addr 1 + index <- (if testBit prefix 0 then readA else readD) + (extractBits prefix [1..3]) + ((extractBits prefix [4] + 1) * 2) + disp <- getMemory (addr + 1) 1 + let naddr = addr + index + disp + return (getMemory naddr s, setMemory naddr s) +getOp 7 0 s = do + pc <- readPC + skipOp 2 + addr <- getMemory pc 2 + return (getMemory addr s, setMemory addr s) +getOp 7 1 s = do + pc <- readPC + skipOp 4 + addr <- getLong pc + return (getMemory addr s, setMemory addr s) +getOp 7 4 s = do + addr <- readPC + skipOp s + let naddr = addr + if s == 1 then 1 else 0 + return (getMemory naddr s, setMemory naddr s) diff --git a/src/Device.hs b/src/Device.hs index 50fb3fc..2e099dc 100644 --- a/src/Device.hs +++ b/src/Device.hs @@ -5,12 +5,57 @@ import Data.Word (Word32, Word16, Word8) import Machine -data DeviceRequest = DeviceGetByte Long - | DeviceGetWord Long - | DeviceGetLong Long - | DeviceSetByte Long Byte - | DeviceSetWord Long Word - | DeviceSetLong Long Long +------------------------------------------------------------------------------- +-- Protocol Constants +-- Protocol itself is simple, +-- suem send commands to devices, they response. +-- Example communication: +-- s: h afebabe +-- d: o 07 +-- s: W afebabe 1999 +-- d: o +-- d: i +-- s: l afebab3 +-- d: x +-- All numbers are in hex and have correct length +-- (zeroes on the left are mandatory). + +-- requests +device_get_high_byte = 'h' -- <7 hexes>; 2 hexes in response +device_get_low_byte = 'l' -- <7 hexes>; 2 hexes in response +device_get_word = 'w' -- <7 hexes>; 4 hexes in response + +device_set_high_byte = 'H' -- <7 hexes> <2 hexes> +device_set_low_byte = 'L' -- <7 hexes> <2 hexes> +device_set_word = 'W' -- <7 hexes> <4 hexes> + +-- responses +device_interrupt = 'i' -- and nothing else +device_ok = 'o' -- maybe number in response to get (with correct size) +device_bad = 'x' -- and nothing else =) + + +------------------------------------------------------------------------------- +-- Memory + +deviceGetByte :: Long -> Emulator Byte +deviceGetByte a | a `mod` 2 == 0 = return 0xFF + | otherwise = return 0xFF + +deviceGetWord :: Long -> Emulator Word +deviceGetWord a = return 0xFFFF + + +deviceSetByte :: Long -> Byte -> Emulator () +deviceSetByte a b | a `mod` 2 == 0 = return () + | otherwise = return () + +deviceSetWord :: Long -> Word -> Emulator () +deviceSetWord a w = return () + + +------------------------------------------------------------------------------- +-- Interrupts checkInteruptsFromDevices :: Emulator () checkInteruptsFromDevices = return () diff --git a/src/Instructions.hs b/src/Instructions.hs index afdd818..2d84597 100644 --- a/src/Instructions.hs +++ b/src/Instructions.hs @@ -3,6 +3,7 @@ module Instructions where import Prelude hiding (Word) import Machine +import Control import Utils import Data.IORef diff --git a/src/Machine.hs b/src/Machine.hs index a16127f..a1ea028 100644 --- a/src/Machine.hs +++ b/src/Machine.hs @@ -1,12 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- This module describes the basic types and operations for our machine. +-- This module describes the basic types for our machine. module Machine where import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed.Mutable as VM import Prelude hiding (Word) import Data.Word (Word32, Word16, Word8) -import Data.Bits (testBit, setBit, clearBit, (.&.), (.|.), shift) import Data.IORef import Control.Monad import Control.Monad.IO.Class (liftIO) @@ -16,9 +15,6 @@ import Network.Socket import Utils -------------------------------------------------------------------------------- --- Base Types - type Long = Word32 type Word = Word16 type Byte = Word8 @@ -50,378 +46,3 @@ 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 -> Int -> Emulator Long -readD 0 s = with drs $ \rs -> do - (r,_,_,_,_,_,_,_) <- readIORef rs - return $ convertLong r s -readD 1 s = with drs $ \rs -> do - (_,r,_,_,_,_,_,_) <- readIORef rs - return $ convertLong r s -readD 2 s = with drs $ \rs -> do - (_,_,r,_,_,_,_,_) <- readIORef rs - return $ convertLong r s -readD 3 s = with drs $ \rs -> do - (_,_,_,r,_,_,_,_) <- readIORef rs - return $ convertLong r s -readD 4 s = with drs $ \rs -> do - (_,_,_,_,r,_,_,_) <- readIORef rs - return $ convertLong r s -readD 5 s = with drs $ \rs -> do - (_,_,_,_,_,r,_,_) <- readIORef rs - return $ convertLong r s -readD 6 s = with drs $ \rs -> do - (_,_,_,_,_,_,r,_) <- readIORef rs - return $ convertLong r s -readD 7 s = with drs $ \rs -> do - (_,_,_,_,_,_,_,r) <- readIORef rs - return $ convertLong r s -readD _ _ = return $ error "Incorrect Data register read" - -readA :: Int -> Int -> Emulator Long -readA 0 s = with ars $ \rs -> do - (r,_,_,_,_,_,_) <- readIORef rs - return $ convertLong r s -readA 1 s = with ars $ \rs -> do - (_,r,_,_,_,_,_) <- readIORef rs - return $ convertLong r s -readA 2 s = with ars $ \rs -> do - (_,_,r,_,_,_,_) <- readIORef rs - return $ convertLong r s -readA 3 s = with ars $ \rs -> do - (_,_,_,r,_,_,_) <- readIORef rs - return $ convertLong r s -readA 4 s = with ars $ \rs -> do - (_,_,_,_,r,_,_) <- readIORef rs - return $ convertLong r s -readA 5 s = with ars $ \rs -> do - (_,_,_,_,_,r,_) <- readIORef rs - return $ convertLong r s -readA 6 s = with ars $ \rs -> do - (_,_,_,_,_,_,r) <- readIORef rs - return $ convertLong r s -readA 7 s = isSupervisor >>= \sup -> if sup - then with ssp $ \sp -> do - v <- readIORef sp - return $ convertLong v s - else with usp $ \sp -> do - v <- readIORef sp - return $ convertLong v s -readA _ _ = return $ error "Incorrect Address register read" - - -writeD :: Int -> Int -> Long -> Emulator () -writeD 0 s r = with drs $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs - writeIORef rs (combineLong r r0 s,r1,r2,r3,r4,r5,r6,r7) -writeD 1 s r = with drs $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs - writeIORef rs (r0,combineLong r r1 s,r2,r3,r4,r5,r6,r7) -writeD 2 s r = with drs $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs - writeIORef rs (r0,r1,combineLong r r2 s,r3,r4,r5,r6,r7) -writeD 3 s r = with drs $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs - writeIORef rs (r0,r1,r2,combineLong r r3 s,r4,r5,r6,r7) -writeD 4 s r = with drs $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs - writeIORef rs (r0,r1,r2,r3,combineLong r r4 s,r5,r6,r7) -writeD 5 s r = with drs $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs - writeIORef rs (r0,r0,r2,r3,r4,combineLong r r5 s,r6,r7) -writeD 6 s r = with drs $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs - writeIORef rs (r0,r1,r2,r3,r4,r5,combineLong r r6 s,r7) -writeD 7 s r = with drs $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6,r7) <- readIORef rs - writeIORef rs (r0,r1,r2,r3,r4,r5,r6,combineLong r r7 s) -writeD _ _ _ = return $ error "Incorrect Data register write" - -writeA :: Int -> Int -> Long -> Emulator () -writeA 0 s r = with ars $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs - writeIORef rs (combineLong r r0 s,r1,r2,r3,r4,r5,r6) -writeA 1 s r = with ars $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs - writeIORef rs (r0,combineLong r r1 s,r2,r3,r4,r5,r6) -writeA 2 s r = with ars $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs - writeIORef rs (r0,r1,combineLong r r2 s,r3,r4,r5,r6) -writeA 3 s r = with ars $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs - writeIORef rs (r0,r1,r2,combineLong r r3 s,r4,r5,r6) -writeA 4 s r = with ars $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs - writeIORef rs (r0,r1,r2,r3,combineLong r r4 s,r5,r6) -writeA 5 s r = with ars $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs - writeIORef rs (r0,r0,r2,r3,r4,combineLong r r5 s,r6) -writeA 6 s r = with ars $ \rs -> do - (r0,r1,r2,r3,r4,r5,r6) <- readIORef rs - writeIORef rs (r0,r1,r2,r3,r4,r5,combineLong r r6 s) -writeA 7 s r = isSupervisor >>= \sup -> if sup - then with ssp $ \sp -> do - v <- readIORef sp - writeIORef sp $ combineLong r v s - else with usp $ \sp -> do - v <- readIORef sp - writeIORef sp $ combineLong r v s -writeA _ _ _ = return $ error "Incorrect Address register write" - - -------------------------------------------------------------------------------- --- PC Register Access - -readPC = with pc $ \pc -> do - pc <- readIORef pc - return pc - -writePC r = with pc $ \pc -> do - writeIORef pc r - -incPC = with pc $ \pc -> do - pcval <- readIORef pc - writeIORef pc (pcval + 2) - - -------------------------------------------------------------------------------- --- Status Register Access - -writeSR :: Word -> Emulator () -writeSR v = with sr $ \sr -> do - writeIORef sr v - -readSR :: Emulator Word -readSR = with sr $ \sr -> do - sr <- readIORef sr - return sr - - -isTracing :: Emulator Bool -isTracing = with sr $ \sr -> do - sr <- readIORef sr - return $ testBit sr 15 - -isSupervisor :: Emulator Bool -isSupervisor = with sr $ \sr -> do - sr <- readIORef sr - return $ testBit sr 13 - -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 4 - -isNegative :: Emulator Bool -isNegative = with sr $ \sr -> do - sr <- readIORef sr - return $ testBit sr 3 - -isZero :: Emulator Bool -isZero = with sr $ \sr -> do - sr <- readIORef sr - return $ testBit sr 2 - -isOverflow :: Emulator Bool -isOverflow = with sr $ \sr -> do - sr <- readIORef sr - return $ testBit sr 1 - -isCarry :: Emulator Bool -isCarry = with sr $ \sr -> do - sr <- readIORef sr - return $ testBit sr 0 - - -setTracing :: Bool -> Emulator () -setTracing b = with sr $ \sr -> do - srval <- readIORef sr - writeIORef sr $ (if b then setBit else clearBit) srval 15 - -setSupervisor :: Bool -> Emulator () -setSupervisor b = with sr $ \sr -> do - srval <- readIORef sr - writeIORef sr $ (if b then setBit else clearBit) srval 13 - -setInterruptLevel :: Int -> Emulator () -setInterruptLevel v = do - srv <- readSR - writeSR $ srv .&. fromIntegral 0xF8FF .|. fromIntegral (shift v 16) - -setExtend :: Bool -> Emulator () -setExtend b = with sr $ \sr -> do - srval <- readIORef sr - writeIORef sr $ (if b then setBit else clearBit) srval 4 - -setNegative :: Bool -> Emulator () -setNegative b = with sr $ \sr -> do - srval <- readIORef sr - writeIORef sr $ (if b then setBit else clearBit) srval 3 - -setZero :: Bool -> Emulator () -setZero b = with sr $ \sr -> do - srval <- readIORef sr - writeIORef sr $ (if b then setBit else clearBit) srval 2 - -setOverflow :: Bool -> Emulator () -setOverflow b = with sr $ \sr -> do - srval <- readIORef sr - writeIORef sr $ (if b then setBit else clearBit) srval 1 - -setCarry :: Bool -> Emulator () -setCarry b = with sr $ \sr -> do - srval <- readIORef sr - writeIORef sr $ (if b then setBit else clearBit) srval 0 - - -------------------------------------------------------------------------------- --- 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) - - -setByte :: Long -> Byte -> Emulator () -setByte a b | a < 0x8 = return () - | a < 0x7e0000 = with ram $ \ram -> - VM.write ram (fromIntegral a) b - | otherwise = return () - - -- TODO: only even addresses are allowed -setWord :: Long -> Word -> Emulator () -setWord a w = do - setByte a (fromIntegral (div (fromIntegral w) 256)) - setByte (a + 1) (fromIntegral (rem (fromIntegral w) 256)) - - -- TODO: only even addresses are allowed -setLong :: Long -> Long -> Emulator () -setLong a l = do - setWord a (fromIntegral (div (fromIntegral l) (256 * 256))) - setWord (a + 2) (fromIntegral (rem (fromIntegral l) (256 * 256))) - - -getMemory :: Long -> Int -> Emulator Long -getMemory a 1 = do - val <- getByte a - return $ fromIntegral val -getMemory a 2 = do - val <- getWord a - return $ fromIntegral val -getMemory a 4 = do - val <- getLong a - return $ fromIntegral val -getMemory _ _ = error "Bad size of getMemory" - -setMemory :: Long -> Int -> Long -> Emulator () -setMemory a 1 v = setByte a $ fromIntegral v -setMemory a 2 v = setWord a $ fromIntegral v -setMemory a 4 v = setLong a $ fromIntegral v -setMemory _ _ _ = error "Bad size of setMemory" - - -------------------------------------------------------------------------------- --- Operand Access - -skipOp :: Int -> Emulator () -skipOp 1 = incPC -skipOp 2 = incPC -skipOp 4 = do - incPC - incPC -skipOp _ = error "Bad skipOp" - -getOp :: Int -> Int -> Int - -> Emulator (Emulator Long, Long -> Emulator ()) -getOp 0 dr s = return (readD dr s, writeD dr s) -getOp 1 ar s = return (readA ar s, writeA ar s) -getOp 2 ar s = do - addr <- readA ar 4 - return (getMemory addr s, setMemory addr s) -getOp 3 ar s = do - addr <- readA ar 4 - writeA ar 4 (addr + (fromIntegral s)) - return (getMemory addr s, setMemory addr s) -getOp 4 ar s = do - addr <- readA ar 4 - let naddr = addr - (fromIntegral s) - writeA ar 4 addr - return (getMemory naddr s, setMemory naddr s) -getOp 5 ar s = do - pc <- readPC - skipOp 2 - disp <- getMemory pc 2 - addr <- readA ar 4 - let naddr = addr + disp - return (getMemory naddr s, setMemory naddr s) -getOp 6 ar s = do - pc <- readPC - skipOp 2 - prefix <- getMemory pc 1 - index <- (if testBit prefix 0 then readA else readD) - (extractBits prefix [1..3]) - ((extractBits prefix [4] + 1) * 2) - disp <- getMemory (pc + 1) 1 - addr <- readA ar 4 - let naddr = addr + index + disp - return (getMemory naddr s, setMemory naddr s) -getOp 7 2 s = do - addr <- readPC - skipOp 2 - disp <- getMemory addr 2 - let naddr = addr + disp - return (getMemory naddr s, setMemory naddr s) -getOp 7 3 s = do - addr <- readPC - skipOp 2 - prefix <- getMemory addr 1 - index <- (if testBit prefix 0 then readA else readD) - (extractBits prefix [1..3]) - ((extractBits prefix [4] + 1) * 2) - disp <- getMemory (addr + 1) 1 - let naddr = addr + index + disp - return (getMemory naddr s, setMemory naddr s) -getOp 7 0 s = do - pc <- readPC - skipOp 2 - addr <- getMemory pc 2 - return (getMemory addr s, setMemory addr s) -getOp 7 1 s = do - pc <- readPC - skipOp 4 - addr <- getLong pc - return (getMemory addr s, setMemory addr s) -getOp 7 4 s = do - addr <- readPC - skipOp s - let naddr = addr + if s == 1 then 1 else 0 - return (getMemory naddr s, setMemory naddr s) diff --git a/src/Suem.hs b/src/Suem.hs index eeb743d..6b2779a 100644 --- a/src/Suem.hs +++ b/src/Suem.hs @@ -14,6 +14,7 @@ import Data.IP import Network.Socket import Numeric import Machine +import Control import Instructions import Utils import Device @@ -441,12 +442,14 @@ makeSocket :: Maybe ConfigSocket -> IO (Maybe Socket) makeSocket (Just (ConfigUnix a)) = do sock <- socket AF_UNIX Stream defaultProtocol Network.Socket.bind sock $ SockAddrUnix a + Network.Socket.listen sock 1024 return $ Just sock makeSocket (Just (ConfigInet a)) = do sock <- socket AF_INET Stream defaultProtocol Network.Socket.bind sock $ SockAddrInet (read $ tail $ dropWhile (/= ':') a) (ipString $ takeWhile (/= ':') a) + Network.Socket.listen sock 1024 return $ Just sock makeSocket Nothing = return Nothing |