diff options
| -rw-r--r-- | Main.hs | 2 | ||||
| -rw-r--r-- | src/Control.hs | 1 | ||||
| -rw-r--r-- | src/Device.hs | 140 | ||||
| -rw-r--r-- | src/Machine.hs | 11 | ||||
| -rw-r--r-- | src/Suem.hs | 17 |
5 files changed, 146 insertions, 25 deletions
@@ -9,7 +9,7 @@ inet_socket :: String -> Parser ConfigSocket inet_socket sock = ConfigInet <$> strOption ( long ("i" ++ sock) <> metavar ("ADDR_" ++ sock) - <> help ("Address for internet socket " ++ sock) ) + <> help ("Port for internet socket " ++ sock) ) unix_socket :: String -> Parser ConfigSocket unix_socket sock = ConfigUnix <$> strOption diff --git a/src/Control.hs b/src/Control.hs index 65b3831..a6a6271 100644 --- a/src/Control.hs +++ b/src/Control.hs @@ -276,6 +276,7 @@ setByte :: Long -> Byte -> Emulator () setByte a b | a < 0x8 = return () | a < 0x7e0000 = with ram $ \ram -> VM.write ram (fromIntegral a) b + | a < 0x800000 = return () | otherwise = deviceSetByte a b -- TODO: only even addresses are allowed diff --git a/src/Device.hs b/src/Device.hs index 2e099dc..71e6943 100644 --- a/src/Device.hs +++ b/src/Device.hs @@ -1,8 +1,43 @@ +{-# LANGUAGE BinaryLiterals #-} module Device where import Prelude hiding (Word) import Data.Word (Word32, Word16, Word8) +import Data.IORef +import Data.Char +import Data.List +import Control.Monad.Reader (ask) +import Control.Monad.IO.Class (liftIO) +import System.IO +import Data.String +import Data.ByteString import Machine +import Network.Socket + + +getSock :: Long -> Emulator (Maybe Handle) +getSock a | a < 0x900000 = do { m <- ask; liftIO $ sock (c0 m) (s0 m) } + | a < 0xa00000 = do { m <- ask; liftIO $ sock (c1 m) (s1 m) } + | a < 0xb00000 = do { m <- ask; liftIO $ sock (c2 m) (s2 m) } + | a < 0xc00000 = do { m <- ask; liftIO $ sock (c3 m) (s3 m) } + | a < 0xd00000 = do { m <- ask; liftIO $ sock (c4 m) (s4 m) } + | a < 0xe00000 = do { m <- ask; liftIO $ sock (c5 m) (s5 m) } + | a < 0xf00000 = do { m <- ask; liftIO $ sock (c6 m) (s6 m) } + | otherwise = do { m <- ask; liftIO $ sock (c7 m) (s7 m) } + where + sock c (Just s) = do + cval <- readIORef c + case cval of + (Just val) -> return $ Just val + Nothing -> do + (newsock, _) <- accept s + handle <- socketToHandle newsock ReadWriteMode + writeIORef c $ Just handle + return $ Just handle + sock _ _ = return Nothing + + +toStr = Prelude.map (chr . fromEnum) . unpack ------------------------------------------------------------------------------- @@ -10,29 +45,66 @@ import Machine -- Protocol itself is simple, -- suem send commands to devices, they response. -- Example communication: --- s: h afebabe +-- s: h ababe -- d: o 07 --- s: W afebabe 1999 +-- s: W ababe 1999 -- d: o -- d: i --- s: l afebab3 +-- s: l abab3 -- 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_get_high_byte = "h" -- <5 hexes>; 2 hexes in response +device_get_low_byte = "l" -- <5 hexes>; 2 hexes in response +device_get_word = "w" -- <5 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> +device_set_high_byte = "H" -- <5 hexes> <2 hexes> +device_set_low_byte = "L" -- <5 hexes> <2 hexes> +device_set_word = "W" -- <5 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 =) +device_interrupt = "i" -- and nothing else +device_ok = "o" -- maybe number in response to get (with correct size) +device_bad = "x" -- and nothing else =) + + +toHex :: Long -> Int -> String +toHex _ 0 = "" +toHex num digits = toHex (div num 16) (digits - 1) + ++ ["0123456789abcdef" + !! fromIntegral (num `mod` fromIntegral 16)] + +fromHex :: String -> Int -> Long -> Long +fromHex _ 0 a = a +fromHex (d:ds) n a = fromHex ds (n - 1) + (a * (fromIntegral 16) + maybe (error "") fromIntegral + (Data.List.elemIndex d "0123456789abcdef")) + + +readOk :: Handle -> Emulator () +readOk h = do + line <- liftIO $ Data.ByteString.hGetLine h + if line == fromString device_ok + then return () + else if line == fromString device_bad + then error "Device sent BAD signal." + else if line == fromString device_interrupt + then readOk h -- doInterrupt + else error "Unknown Device Protocol Line." + +readOkWord :: Handle -> Emulator Word +readOkWord h = do + line <- liftIO $ Data.ByteString.hGetLine h + if fromString device_ok `Data.ByteString.isPrefixOf` line + then let (_:ltail) = Prelude.drop (Prelude.length device_ok) (toStr line) + in return $ fromIntegral $ fromHex ltail 4 (fromIntegral 0) + else if line == fromString device_bad + then error "Device sent BAD signal." + else if line == fromString device_interrupt + then readOkWord h -- doInterrupt + else error "Unknown Device Protocol Line." ------------------------------------------------------------------------------- @@ -43,15 +115,51 @@ deviceGetByte a | a `mod` 2 == 0 = return 0xFF | otherwise = return 0xFF deviceGetWord :: Long -> Emulator Word -deviceGetWord a = return 0xFFFF +deviceGetWord a = do + handle <- getSock a + if handle == Nothing + then return 0xffff + else do + let (Just h) = handle + liftIO $ hPut h $ fromString $ + device_get_word ++ " " ++ toHex a 5 ++"\n" + readOkWord h deviceSetByte :: Long -> Byte -> Emulator () -deviceSetByte a b | a `mod` 2 == 0 = return () - | otherwise = return () +deviceSetByte a b + | a `mod` 2 == 0 = do + handle <- getSock a + if handle == Nothing + then return () + else do + let (Just h) = handle + liftIO $ hPut h $ fromString $ + device_set_high_byte ++ " " ++ toHex a 5 ++ " " + ++ toHex (fromIntegral b) 2 ++"\n" + readOk h + | otherwise = do + handle <- getSock a + if handle == Nothing + then return () + else do + let (Just h) = handle + liftIO $ hPut h $ fromString $ + device_set_low_byte ++ " " ++ toHex a 5 ++ " " + ++ toHex (fromIntegral b) 2 ++"\n" + readOk h deviceSetWord :: Long -> Word -> Emulator () -deviceSetWord a w = return () +deviceSetWord a w = do + handle <- getSock a + if handle == Nothing + then return () + else do + let (Just h) = handle + liftIO $ hPut h $ fromString $ + device_set_word ++ " " ++ toHex a 5 ++ " " + ++ toHex (fromIntegral w) 4 ++"\n" + readOk h ------------------------------------------------------------------------------- diff --git a/src/Machine.hs b/src/Machine.hs index a1ea028..75ad877 100644 --- a/src/Machine.hs +++ b/src/Machine.hs @@ -12,6 +12,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (MonadReader, ReaderT, ask) import Control.Monad.Trans (MonadIO) import Network.Socket +import System.IO import Utils @@ -35,7 +36,15 @@ data Machine = Machine { s4 :: Maybe Socket, s5 :: Maybe Socket, s6 :: Maybe Socket, - s7 :: Maybe Socket + s7 :: Maybe Socket, + c0 :: IORef (Maybe Handle), + c1 :: IORef (Maybe Handle), + c2 :: IORef (Maybe Handle), + c3 :: IORef (Maybe Handle), + c4 :: IORef (Maybe Handle), + c5 :: IORef (Maybe Handle), + c6 :: IORef (Maybe Handle), + c7 :: IORef (Maybe Handle) } -- Emulator is a monad which contains Machine and allows easy change of it. diff --git a/src/Suem.hs b/src/Suem.hs index 6b2779a..7f55891 100644 --- a/src/Suem.hs +++ b/src/Suem.hs @@ -434,10 +434,6 @@ data Config = Config Int -- frequence (Maybe ConfigSocket) (Maybe ConfigSocket) -ipString :: String -> Word32 -ipString = fromIntegral . sum . map (\(n,o) -> toInteger o * 256 ^ n) - . zip [0..] . reverse . fromIPv4 . read - makeSocket :: Maybe ConfigSocket -> IO (Maybe Socket) makeSocket (Just (ConfigUnix a)) = do sock <- socket AF_UNIX Stream defaultProtocol @@ -446,9 +442,7 @@ makeSocket (Just (ConfigUnix a)) = do 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.bind sock $ SockAddrInet (read a) 0x0100007f Network.Socket.listen sock 1024 return $ Just sock makeSocket Nothing = return Nothing @@ -478,8 +472,17 @@ makeMachine ramData romData s0 s1 s2 s3 s4 s5 s6 s7 = do ms5 <- makeSocket s5 ms6 <- makeSocket s6 ms7 <- makeSocket s7 + mc0 <- newIORef Nothing + mc1 <- newIORef Nothing + mc2 <- newIORef Nothing + mc3 <- newIORef Nothing + mc4 <- newIORef Nothing + mc5 <- newIORef Nothing + mc6 <- newIORef Nothing + mc7 <- newIORef Nothing return $ Machine pc sr drs ars usp ssp ramData romData ms0 ms1 ms2 ms3 ms4 ms5 ms6 ms7 + mc0 mc1 mc2 mc3 mc4 mc5 mc6 mc7 where pcval = (fromIntegral $ romData V.! 4) * 256 * 256 * 256 + (fromIntegral $ romData V.! 5) * 256 * 256 + (fromIntegral $ romData V.! 6) * 256 + |