aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAleksey Veresov <aleksey@veresov.pro>2021-04-12 01:01:22 +0300
committerAleksey Veresov <aleksey@veresov.pro>2021-04-12 01:01:22 +0300
commit21aa1d1f11c369323d8c3bf71648bd0a8321ca61 (patch)
tree68b29b89cb3bbb26167d990ac22dba580b9467a1
parent0be6a61d0a819b057b43848632928a261021ed25 (diff)
downloadsuem-21aa1d1f11c369323d8c3bf71648bd0a8321ca61.tar
suem-21aa1d1f11c369323d8c3bf71648bd0a8321ca61.tar.xz
suem-21aa1d1f11c369323d8c3bf71648bd0a8321ca61.zip
Device protocol is almost done!
-rw-r--r--Main.hs2
-rw-r--r--src/Control.hs1
-rw-r--r--src/Device.hs140
-rw-r--r--src/Machine.hs11
-rw-r--r--src/Suem.hs17
5 files changed, 146 insertions, 25 deletions
diff --git a/Main.hs b/Main.hs
index ca9c155..9f7af19 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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 +