diff options
author | James Crayne <jim.crayne@gmail.com> | 2018-05-29 21:08:01 +0000 |
---|---|---|
committer | James Crayne <jim.crayne@gmail.com> | 2018-05-29 21:08:01 +0000 |
commit | dc8d8588fab79fe7a0dcb04a0bb396c2a17d580d (patch) | |
tree | 6f617f51aefbf1fc6eb326e1f8b4b78d485291ee /src | |
parent | 201d2b6c883b269e03038bde25e07fefaec7f8e4 (diff) |
debug traces, remember to remove later
Diffstat (limited to 'src')
-rw-r--r-- | src/Data/PacketQueue.hs | 28 |
1 files changed, 19 insertions, 9 deletions
diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs index 4770d4a9..cb308bce 100644 --- a/src/Data/PacketQueue.hs +++ b/src/Data/PacketQueue.hs | |||
@@ -31,6 +31,7 @@ import Control.Applicative | |||
31 | import Data.Word | 31 | import Data.Word |
32 | import Data.Array.MArray | 32 | import Data.Array.MArray |
33 | import Data.Maybe | 33 | import Data.Maybe |
34 | import Debug.Trace | ||
34 | 35 | ||
35 | data PacketQueue a = PacketQueue | 36 | data PacketQueue a = PacketQueue |
36 | { pktq :: TArray Word32 (Maybe a) | 37 | { pktq :: TArray Word32 (Maybe a) |
@@ -190,28 +191,37 @@ readyOutGoing (PacketOutQueue {pktoToWireIO }) = pktoToWireIO | |||
190 | -- used for outgoing messages. (Note that ‘front‛ usually means the higher | 191 | -- used for outgoing messages. (Note that ‘front‛ usually means the higher |
191 | -- index in this implementation.) | 192 | -- index in this implementation.) |
192 | tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM OutGoingResult | 193 | tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM OutGoingResult |
193 | tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg = do | 194 | tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg |
195 | = trace "(tryAppendQueueOutgoing)" $ do | ||
194 | be <- readTVar (buffend pktoOutPQ) | 196 | be <- readTVar (buffend pktoOutPQ) |
195 | let i = be `mod` (qsize pktoOutPQ) | 197 | let i = be `mod` (qsize pktoOutPQ) |
196 | let arrayEmpty ar = do (lowB,highB) <- getBounds ar | 198 | let arrayEmpty :: MArray a e m => a Word32 e -> m Bool |
197 | return (lowB > highB ) | 199 | arrayEmpty ar = do (lowB,highB) <- getBounds ar |
200 | let result= lowB > highB | ||
201 | return $ trace ("arrayEmpty result=" ++ show result | ||
202 | ++ " lowB=" ++ show lowB | ||
203 | ++ " highB = " ++ show highB | ||
204 | ++ " i = " ++ show i) result | ||
198 | mbPkt <- do emp <- arrayEmpty (pktq pktoOutPQ) | 205 | mbPkt <- do emp <- arrayEmpty (pktq pktoOutPQ) |
199 | if emp then return Nothing | 206 | if emp then trace "(tryAppendQueueOutgoing empty)" $ return Nothing |
200 | else readArray (pktq pktoOutPQ) i | 207 | else trace "(tryAppendQueueOutgoing nonempty)" $ do |
208 | result <- readArray (pktq pktoOutPQ) i | ||
209 | return $ trace ("readArray (isJust result)==" ++ show (isJust result)) result | ||
201 | pktno <- readTVar pktoPacketNo | 210 | pktno <- readTVar pktoPacketNo |
202 | nextno <- readTVar (seqno pktoInPQ) | 211 | nextno <- readTVar (seqno pktoInPQ) |
203 | mbWire <- pktoToWire getExtra nextno be pktno msg | 212 | mbWire <- pktoToWire getExtra nextno be pktno msg |
204 | case mbWire of | 213 | case trace "(tryAppendQueueOutgoing mbWire)" mbWire of |
205 | Just (pkt,pktno') | 214 | Just (pkt,pktno') |
206 | -> case mbPkt of | 215 | -> trace "(tryAppendQueueOutgoing A)" |
216 | $ case mbPkt of | ||
207 | -- slot is free, insert element | 217 | -- slot is free, insert element |
208 | Nothing -> do | 218 | Nothing -> trace "(tryAppendQueueOutgoing Nothing case)" $ do |
209 | modifyTVar' (buffend pktoOutPQ) (+1) | 219 | modifyTVar' (buffend pktoOutPQ) (+1) |
210 | writeTVar pktoPacketNo $! pktno' | 220 | writeTVar pktoPacketNo $! pktno' |
211 | writeArray (pktq pktoOutPQ) i (Just (pktno,pkt)) | 221 | writeArray (pktq pktoOutPQ) i (Just (pktno,pkt)) |
212 | return OGSuccess | 222 | return OGSuccess |
213 | -- queue is full | 223 | -- queue is full |
214 | Just (n,_) -> do | 224 | Just (n,_) -> trace "tryAppendQueueOutgoing Just case)" $ do |
215 | nn <- getHighestHandledPacketPlus1 q | 225 | nn <- getHighestHandledPacketPlus1 q |
216 | if (n < nn) | 226 | if (n < nn) |
217 | -- but we can overwrite an old packet | 227 | -- but we can overwrite an old packet |