aboutsummaryrefslogtreecommitdiff
path: root/src/Device.hs
blob: d67daabadcc1af33d1fc120fcb0d7caea6f9ab21 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
{-# 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


-------------------------------------------------------------------------------
-- Protocol Constants
-- Protocol itself is simple,
-- suem send commands to devices, they response.
-- Example communication:
-- s: h ababe
-- d: o 07
-- s: W ababe 1999
-- d: o
-- d: i
-- 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" -- <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" -- <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 =)


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 do
                  m <- ask
                  interruptLevel <- getFnInterruptLevel m
                  if interruptLevel == 0
                  then do
                      getFnDoInterrupt m
                      readOk h
                  else readOk h
              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 do
                  m <- ask
                  interruptLevel <- getFnInterruptLevel m
                  if interruptLevel == 0
                  then do
                      getFnDoInterrupt m
                      readOkWord h
                  else readOkWord h
              else error "Unknown Device Protocol Line."

readOkByte :: Handle -> Emulator Byte
readOkByte 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 2 (fromIntegral 0)
    else if line == fromString device_bad
         then error "Device sent BAD signal."
         else if line == fromString device_interrupt
              then do
                  m <- ask
                  interruptLevel <- getFnInterruptLevel m
                  if interruptLevel == 0
                  then do
                      getFnDoInterrupt m
                      readOkByte h
                  else readOkByte h
              else error "Unknown Device Protocol Line."


-------------------------------------------------------------------------------
-- Memory

deviceGetByte :: Long -> Emulator Byte
deviceGetByte a
    | a `mod` 2 == 0 = do
        handle <- getSock a
        if handle == Nothing
        then return 0xff
        else do
            let (Just h) = handle
            liftIO $ hPut h $ fromString $
                device_get_high_byte ++ " " ++ toHex a 5 ++ "\n"
            readOkByte h
    | otherwise = do
        handle <- getSock a
        if handle == Nothing
        then return 0xff
        else do
            let (Just h) = handle
            liftIO $ hPut h $ fromString $
                device_get_low_byte ++ " " ++ toHex a 5 ++ "\n"
            readOkByte h

deviceGetWord :: Long -> Emulator Word
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 = 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 = 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


-------------------------------------------------------------------------------
-- Interrupts

checkInteruptsFromDevices :: Emulator ()
checkInteruptsFromDevices = return ()