Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'ghc12-compile'

  • Loading branch information...
commit 750fc713b1a0a43d12021f24aea047f5d79bdf58 2 parents 23d156d + a45d503
@jlouis authored
Showing with 41 additions and 25 deletions.
  1. +7 −24 src/ChokeMgrP.hs
  2. +34 −1 src/Process.hs
View
31 src/ChokeMgrP.hs
@@ -243,6 +243,7 @@ selectPeers uploadSlots downPeers seedPeers = S.union downPids seedPids
downPids = S.fromList $ map fst $ take nDownSlots $ sortLeech downPeers
seedPids = S.fromList $ map fst $ take nSeedSlots $ sortSeeds seedPeers
+
-- | This function carries out the choking and unchoking of peers in a round.
performChokingUnchoking :: S.Set PeerPid -> [RechokeData] -> IO ()
performChokingUnchoking elected peers =
@@ -255,10 +256,8 @@ performChokingUnchoking elected peers =
-- If we block on the sync, it means that the process in the other end must
-- be dead. Thus we can just skip it. We will eventually receive this knowledge
-- through another channel.
- unchoke pi = unchokePeer (pChannel pi)
- `catch` (\BlockedOnDeadMVar -> return ())
- choke pi = chokePeer (pChannel pi)
- `catch` (\BlockedOnDeadMVar -> return ())
+ unchoke pi = catchIgnoreBlock $ unchokePeer (pChannel pi)
+ choke pi = catchIgnoreBlock $ chokePeer (pChannel pi)
-- If we have k optimistic slots, @optChoke k peers@ will unchoke the first @k@ interested
-- in us. The rest will either be unchoked if they are not interested (ensuring fast start
-- should they become interested); or they will be choked to avoid TCP/IP congestion.
@@ -298,18 +297,13 @@ rechoke = do
liftIO $ performChokingUnchoking electedPeers peers
+
informDone :: PieceNum -> ChokeMgrProcess ()
informDone pn = do
T.mapM sendDone =<< gets peerMap
return ()
where
- sendDone pi = do
- st <- get
- c <- ask
- (a, s') <- liftIO $ runP c st (proc pi) `catches`
- [ Handler (\BlockedOnDeadMVar -> return ((), st)) ] -- Peer dead, ignore it
- put s'
- return a
+ sendDone pi = ignoreProcessBlock () (proc pi)
proc pi = do
(sendP (pChannel pi) $ PieceCompleted pn) >>= syncP
@@ -318,13 +312,7 @@ informBlockComplete pn blk = do
T.mapM sendComp =<< gets peerMap
return ()
where
- sendComp pi = do
- st <- get
- c <- ask
- (a, s') <- liftIO $ runP c st (proc pi) `catches`
- [ Handler (\BlockedOnDeadMVar -> return ((), st)) ] -- Peer dead, ignore it
- put s'
- return a
+ sendComp pi = ignoreProcessBlock () (proc pi)
proc pi = do
(sendP (pChannel pi) $ CancelBlock pn blk) >>= syncP
@@ -336,12 +324,7 @@ updateDB = do
gatherRate pi = do
ch <- liftIO $ channel
-- The following should be refactored to the Process module
- st <- get
- c <- ask
- (a, s') <- liftIO $ runP c st (proc ch pi) `catches`
- [ Handler (\BlockedOnDeadMVar -> return (pi, st)) ] -- Peer Dead, ignore it
- put s'
- return a
+ ignoreProcessBlock pi (proc ch pi)
proc ch pi = do
t <- liftIO getCurrentTime
(sendP (pChannel pi) $ PeerStats t ch) >>= syncP
View
35 src/Process.hs
@@ -23,7 +23,9 @@ module Process (
, recvWrapPC
, wrapP
, stopP
- -- * Interface
+ , catchIgnoreBlock -- This and ignoreProcessBlock ought to be renamed
+ , ignoreProcessBlock
+ -- * Log Interface
, logInfo
, logDebug
, logWarn
@@ -147,6 +149,37 @@ recvWrapPC sel p = do
chooseP :: [Process a b (Event (c, b))] -> Process a b (Event (c, b))
chooseP events = (sequence events) >>= (return . choose)
+-- VERSION SPECIFIC PROCESS ORIENTED FUNCTIONS
+
+-- | @ignoreProcessBlock err thnk@ runs a process action, ignoring blocks on dead
+-- MVars. If the MVar is blocked, return the default value @err@.
+ignoreProcessBlock :: c -> Process a b c -> Process a b c
+ignoreProcessBlock err thnk = do
+ st <- get
+ c <- ask
+ (a, s') <- liftIO $ runP c st thnk `catches`
+ -- Peer dead, ignore
+#if (__GLASGOW_HASKELL__ == 610)
+ [ Handler (\BlockedOnDeadMVar -> return (err, st)) ]
+#elif (__GLASGOW_HASKELL__ == 612)
+ [ Handler (\BlockedIndefinitelyOnMVar -> return (err, st)) ]
+#else
+#error Unknown GHC version
+#endif
+ put s'
+ return a
+
+-- | Run an IO-action for side effect and catch eventual blocks on Dead MVars
+catchIgnoreBlock :: IO () -> IO ()
+catchIgnoreBlock thnk =
+ thnk `catch`
+#if (__GLASGOW_HASKELL__ == 610)
+ (\BlockedOnDeadMVar -> return ())
+#elif (__GLASGOW_HASKELL__ == 612)
+ (\BlockedIndefinitelyOnMVar -> return ())
+#else
+#error Unknown GHC revision
+#endif
------ LOGGING
-- | If a process has access to a logging channel, it is able to log messages to the world
Please sign in to comment.
Something went wrong with that request. Please try again.