commit 7494d418a991eb60b4644169310026336068d634
Author: David Kaloper <david(a)numm.org>
Date: Mon Aug 26 04:10:27 2013 +0200
fix exceptions in TorDNSEL.Control.Concurrent
---
src/TorDNSEL/Control/Concurrent/Link.hs | 7 +-
src/TorDNSEL/Control/Concurrent/Link/Internals.hs | 168 ++++++++++++----------
src/TorDNSEL/Control/Concurrent/Util.hs | 47 +++---
3 files changed, 121 insertions(+), 101 deletions(-)
diff --git a/src/TorDNSEL/Control/Concurrent/Link.hs b/src/TorDNSEL/Control/Concurrent/Link.hs
index 98eda78..2c0a05f 100644
--- a/src/TorDNSEL/Control/Concurrent/Link.hs
+++ b/src/TorDNSEL/Control/Concurrent/Link.hs
@@ -30,15 +30,16 @@ module TorDNSEL.Control.Concurrent.Link (
, withMonitor
, exit
, throwTo
- , throwDynTo
, killThread
, setTrapExit
, unsetTrapExit
- , ExitReason
+ , ExitReason(..)
+ , exitReason
+ , isAbnormal
+ , throwAbnormal
, extractReason
, fromExitSignal
, LinkException(..)
- , showLinkException
) where
import TorDNSEL.Control.Concurrent.Link.Internals
diff --git a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs
index cf83cba..7b614b9 100644
--- a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs
+++ b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-ignore-asserts #-}
-----------------------------------------------------------------------------
@@ -24,15 +25,18 @@
-- #not-home
module TorDNSEL.Control.Concurrent.Link.Internals where
+import qualified Control.Exception as E
import qualified Control.Concurrent as C
import Control.Concurrent.MVar
(MVar, newMVar, withMVar, modifyMVar, modifyMVar_)
-import qualified Control.Exception as E
+import GHC.Conc (setUncaughtExceptionHandler)
+import System.Exit (ExitCode)
import Control.Monad (unless)
import qualified Data.Foldable as F
import qualified Data.Map as M
import qualified Data.Set as S
-import Data.Dynamic (Dynamic, fromDynamic, toDyn, Typeable)
+-- import Data.Dynamic (Dynamic, fromDynamic, toDyn, Typeable)
+import Data.Typeable (Typeable)
import Data.List (nub)
import Data.Unique (Unique, newUnique)
import System.IO (hPutStrLn, hFlush, stderr)
@@ -46,6 +50,9 @@ import TorDNSEL.Util
newtype ThreadId = Tid Unique
deriving (Eq, Ord)
+-- ( Else an orphaned Show Unique... )
+instance Show ThreadId where show _ = "#<thread>"
+
-- | Return the 'ThreadId' of the calling thread.
myThreadId :: IO ThreadId
myThreadId = do
@@ -74,11 +81,17 @@ threadMap :: MVar ThreadMap
{-# NOINLINE threadMap #-}
threadMap = unsafePerformIO . newMVar $ ThreadMap M.empty M.empty
+-- | Erase 'threadMap', making it possible to re-run 'withLinksDo'. For
+-- debugging only, as it loses track of threads.
+unsafeResetThreadMap :: IO ()
+unsafeResetThreadMap =
+ modifyMVar_ threadMap $ const . return $ ThreadMap M.empty M.empty
+
-- | Assert various invariants of the global link and monitor state, printing a
-- message to stdout if any assertions fail.
assertThreadMap :: ThreadMap -> IO ()
assertThreadMap tm =
- E.handleJust E.assertions (putStr . ("assertThreadMap: " ++)) $
+ E.handle (\(E.AssertionFailed msg) -> putStrLn $ "assertThreadMap: " ++ msg) $
E.assert (M.size (ids tm) > 0) $
E.assert (M.size (ids tm) == M.size (state tm)) $
E.assert (M.elems (ids tm) == nub (M.elems (ids tm))) $
@@ -100,36 +113,35 @@ assertThreadMap tm =
-- | An internal type used to transmit the originating 'ThreadId' in an
-- asynchronous exception to a linked thread.
data ExitSignal = ExitSignal !ThreadId !ExitReason
- deriving Typeable
-
--- | Extract the 'ExitReason' from an 'ExitSignal' contained within a
--- dynamically-typed exception. If the exception doesn't contain an
--- 'ExitSignal', tag it with 'Just'.
-extractReason :: E.Exception -> ExitReason
-extractReason (E.DynException dyn)
- | Just (ExitSignal _ e) <- fromDynamic dyn = e
-extractReason e = Just e
-
--- | Extract an exit signal from an 'E.Exception' if it has the right type.
-fromExitSignal :: Typeable a => E.Exception -> Maybe (ThreadId, a)
-fromExitSignal (E.DynException d)
- | Just (ExitSignal tid (Just (E.DynException d'))) <- fromDynamic d
- = (,) tid `fmap` fromDynamic d'
+ deriving (Show, Typeable)
+
+instance E.Exception ExitSignal
+
+-- | Extract the 'ExitReason' from an 'ExitSignal' contained within an
+-- exception. If the exception doesn't contain an 'ExitReason', it becomes the
+-- exit reason itself.
+extractReason :: E.SomeException -> ExitReason
+extractReason (E.fromException -> Just (ExitSignal _ e)) = e
+extractReason e = AbnormalExit e
+
+-- | Extract a particular exception type from an 'ExitSignal', if present.
+fromExitSignal :: E.Exception e => ExitSignal -> Maybe (ThreadId, e)
+fromExitSignal (ExitSignal tid (AbnormalExit e))
+ | Just e' <- E.fromException e = Just (tid, e')
fromExitSignal _ = Nothing
-- | The default action used to signal a thread. Abnormal 'ExitReason's are
-- sent to the thread and normal exits are ignored.
defaultSignal :: C.ThreadId -> ThreadId -> ExitReason -> IO ()
-defaultSignal dst src e@(Just _) = E.throwDynTo dst $ ExitSignal src e
-defaultSignal _ _ Nothing = return ()
-
--- | Initialize the state supporting links and monitors. Use the given function
--- to display an uncaught exception. It is an error to call this function
--- outside the main thread, or to call any other functions in this module
--- outside this function.
-withLinksDo :: (E.Exception -> String) -> IO a -> IO ()
-withLinksDo showE io = E.block $ do
- E.setUncaughtExceptionHandler . const . return $ ()
+defaultSignal dst src NormalExit = return ()
+defaultSignal dst src e = E.throwTo dst $ ExitSignal src e
+
+-- | Initialize the state supporting links and monitors. It is an error to call
+-- this function outside the main thread, or to call any other functions in this
+-- module outside this function.
+withLinksDo :: IO a -> IO ()
+withLinksDo io = E.mask $ \restore -> do
+ setUncaughtExceptionHandler . const . return $ ()
main <- C.myThreadId
mainId <- Tid `fmap` newUnique
let initialState = ThreadState
@@ -146,12 +158,13 @@ withLinksDo showE io = E.block $ do
, state = M.insert main initialState (state tm) }
-- Don't bother propagating signals from the main thread
-- since it's about to exit.
- (E.unblock io >> return ()) `E.catch` \e ->
+ (restore io >> return ()) `E.catch` \(e :: E.SomeException) ->
case extractReason e of
- Nothing -> return ()
- Just e'@(E.ExitException _) -> E.throwIO e'
- Just e' -> do
- hPutStrLn stderr ("*** Exception: " ++ showE e')
+ NormalExit -> return ()
+ AbnormalExit (E.fromException -> Just e') ->
+ E.throwIO (e' :: ExitCode)
+ AbnormalExit e' -> do
+ hPutStrLn stderr ("*** Exception: " ++ show e')
hFlush stderr
E.throwIO e'
@@ -169,15 +182,19 @@ forkLinkIO' shouldLink io = E.block $ do
parent <- C.myThreadId
childId <- Tid `fmap` newUnique
modifyMVar_ threadMap $ \tm -> do
- -- assertThreadMap tm
+#ifdef DEBUG
+ assertThreadMap tm
+#endif
child <- forkHandler $ do
child <- C.myThreadId
- e <- either extractReason (const Nothing) `fmap` E.try (E.unblock io)
+ e <- either extractReason (const NormalExit) `fmap` E.try (E.unblock io)
-- modifyMVar is interruptible (a misfeature in this case), so an async
-- exception could be delivered here. Forking an anonymous thread should
-- avoid this race since nobody can throwTo it.
forkHandler $ do
- -- withMVar threadMap assertThreadMap
+#ifdef DEBUG
+ withMVar threadMap assertThreadMap
+#endif
(signalAll,notifyAll) <- modifyMVar threadMap $ \tm1 ->
let s = state tm1 M.! child
unlinkAll = flip (F.foldl' (flip (child `unlinkFrom`))) (links s)
@@ -193,7 +210,9 @@ forkLinkIO' shouldLink io = E.block $ do
notifyAll ex = F.mapM_ (forkHandler . ($ ex) . fst) (monitors s)
tm1' = tm1 { ids = newIds, state = newState }
in tm1' `seq` return (tm1', (signalAll, notifyAll))
- -- withMVar threadMap assertThreadMap
+#ifdef DEBUG
+ withMVar threadMap assertThreadMap
+#endif
notifyAll e
signalAll e
@@ -211,11 +230,13 @@ forkLinkIO' shouldLink io = E.block $ do
tm { ids = M.insert childId child $ ids tm
, state = M.insert child initialState . linkToParent $ state tm }
- -- withMVar threadMap assertThreadMap
+#ifdef DEBUG
+ withMVar threadMap assertThreadMap
+#endif
return childId
where
forkHandler = C.forkIO . ignore . (>> return ()) . E.block
- ignore = E.handle . const . return $ ()
+ ignore = E.handle $ \(e :: E.SomeException) -> return ()
-- | Establish a bidirectional link between the calling thread and a given
-- thread. If either thread terminates, an exit signal will be sent to the other
@@ -225,16 +246,14 @@ forkLinkIO' shouldLink io = E.block $ do
linkThread :: ThreadId -> IO ()
linkThread tid = do
me <- C.myThreadId
- mbSignalSelf <- modifyMVar threadMap $ \tm ->
+ mbSignalSelf <- modifyMVar threadMap $ \tm -> return $!
case M.lookup tid (ids tm) of
Just tid'
- | tid' == me -> return (tm, Nothing)
- | otherwise -> let tm' = tm { state = linkTogether me tid' $ state tm }
- in tm' `seq` return (tm', Nothing)
- Nothing ->
- let s = state tm M.! me
- in return (tm, Just . signal s tid . Just . E.DynException .
- toDyn $ NonexistentThread)
+ | tid' == me -> (tm, Nothing)
+ | otherwise -> (tm', Nothing)
+ where !tm' = tm { state = linkTogether me tid' $ state tm }
+ Nothing -> (tm, Just . signal s tid $ exitReason NonexistentThread)
+ where s = state tm M.! me
whenJust mbSignalSelf id
where linkTogether x y = (x `linkTo` y) . (y `linkTo` x)
@@ -258,9 +277,22 @@ linkTo, unlinkFrom :: C.ThreadId -> C.ThreadId -> StateModifier
data Monitor = Monitor !ThreadId !Unique
deriving (Eq, Ord)
--- | The reason a thread was terminated. @Nothing@ means the thread exited
--- normally. @Just exception@ contains the reason for an abnormal exit.
-type ExitReason = Maybe E.Exception
+-- | The reason a thread was terminated.
+data ExitReason = NormalExit | AbnormalExit E.SomeException
+ deriving (Show)
+
+-- | Construct an 'ExitReason' from any 'E.Exception'.
+exitReason :: E.Exception e => e -> ExitReason
+exitReason = AbnormalExit . E.toException
+
+isAbnormal :: ExitReason -> Bool
+isAbnormal (AbnormalExit _) = True
+isAbnormal _ = False
+
+-- | Check the exit reason and re-throw it if it's an 'AbnormalExit'.
+throwAbnormal :: ExitReason -> IO ()
+throwAbnormal NormalExit = return ()
+throwAbnormal (AbnormalExit e) = E.throwIO e
-- | Start monitoring the given thread, invoking an 'IO' action with the
-- 'ExitReason' when the thread dies. Return a handle to the monitor, which can
@@ -271,20 +303,19 @@ monitorThread :: ThreadId -> (ExitReason -> IO ()) -> IO Monitor
monitorThread tid notify = do
me <- C.myThreadId
mon@(Monitor _ monId) <- Monitor tid `fmap` newUnique
- let cleanup tid' = adjust' (\ts ->
- ts { ownedMons = S.delete (tid', monId) (ownedMons ts) }) me
+ let cleanup tid' = flip adjust' me $ \ts ->
+ ts { ownedMons = S.delete (tid', monId) (ownedMons ts) }
addMon tid' ts = ts { monitors = M.insert monId (notify, cleanup tid')
(monitors ts) }
addOwned tid' ts = ts {ownedMons = S.insert (tid', monId) (ownedMons ts)}
- exists <- modifyMVar threadMap $ \tm ->
+ exists <- modifyMVar threadMap $ \tm -> return $!
case M.lookup tid (ids tm) of
- Nothing -> return (tm, False)
- Just tid' ->
- let tm' = tm { state = adjust' (addMon tid') tid' .
- adjust' (addOwned tid') me $ state tm }
- in tm' `seq` return (tm', True)
+ Nothing -> (tm, False)
+ Just tid' -> (tm', True)
+ where !tm' = tm { state = adjust' (addMon tid') tid' .
+ adjust' (addOwned tid') me $ state tm }
unless exists $
- notify . Just . E.DynException . toDyn $ NonexistentThread
+ notify $ exitReason NonexistentThread
return mon
-- | Cancel a monitor, if it is currently active.
@@ -310,10 +341,10 @@ withMonitor tid notify =
-- | Terminate the calling thread with the given 'ExitReason'.
exit :: ExitReason -> IO a
-exit e = E.throwDyn . flip ExitSignal e =<< myThreadId
+exit e = E.throwIO . (`ExitSignal` e) =<< myThreadId
-- | Send an exit signal with an 'ExitReason' to a thread. If the 'ExitReason'
--- is 'Nothing', the signal will be ignored unless the target thread is trapping
+-- is 'NormalExit', the signal will be ignored unless the target thread is trapping
-- signals. Otherwise, the target thread will either exit with the same
-- 'ExitReason' or be notified of the signal depending on whether it is trapping
-- signals. If the target thread doesn't exist, do nothing.
@@ -324,25 +355,20 @@ throwTo tid e = do
let me' = ident (state tm M.! me)
in if tid == me'
-- special case: an exception thrown to oneself is untrappable
- then E.throwDyn $ ExitSignal me' e
+ then E.throwIO $ ExitSignal me' e
else return $ do tid' <- M.lookup tid (ids tm)
return $ signal (state tm M.! tid') me'
-- since signal can block, we don't want to hold a lock on threadMap
whenJust mbSignal ($ e)
--- | A variant of 'throwTo' for dynamically typed 'ExitReason's.
-throwDynTo :: Typeable a => ThreadId -> a -> IO ()
-throwDynTo tid = throwTo tid . Just . E.DynException . toDyn
-
-- | Send an untrappable exit signal to a thread, if it exists.
killThread :: ThreadId -> IO ()
killThread tid = do
me <- C.myThreadId
mbSignal <- withMVar threadMap $ \tm -> return $ do
tid' <- M.lookup tid (ids tm)
- return .
- E.throwDynTo tid' $ ExitSignal (ident (state tm M.! me))
- (Just (E.AsyncException E.ThreadKilled))
+ return . E.throwTo tid' $ ExitSignal (ident (state tm M.! me))
+ (exitReason E.ThreadKilled)
whenJust mbSignal id
-- | Redirect exit signals destined for the calling thread to the given 'IO'
@@ -367,6 +393,4 @@ data LinkException = NonexistentThread -- ^
instance Show LinkException where
show NonexistentThread = "Attempt to link to nonexistent thread"
--- | Boilerplate conversion of a dynamically typed 'LinkException' to a string.
-showLinkException :: Dynamic -> Maybe String
-showLinkException = fmap (show :: LinkException -> String) . fromDynamic
+instance E.Exception LinkException
diff --git a/src/TorDNSEL/Control/Concurrent/Util.hs b/src/TorDNSEL/Control/Concurrent/Util.hs
index 1defc31..a7c2a65 100644
--- a/src/TorDNSEL/Control/Concurrent/Util.hs
+++ b/src/TorDNSEL/Control/Concurrent/Util.hs
@@ -13,7 +13,8 @@
module TorDNSEL.Control.Concurrent.Util where
import qualified Control.Exception as E
-import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, tryPutMVar)
+import Data.Functor ( (<$) )
+import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, tryPutMVar)
import Data.Dynamic (Dynamic)
import Data.Maybe (isJust)
import System.Timeout
@@ -51,10 +52,9 @@ terminateThread mbWait tid terminate = do
sendSyncMessage :: (IO () -> IO ()) -> ThreadId -> IO ()
sendSyncMessage sendMsg tid = do
err <- newEmptyMVar
- let putResponse = (>> return ()) . tryPutMVar err
- withMonitor tid putResponse $ do
- sendMsg $ putResponse Nothing
- takeMVar err >>= flip whenJust E.throwIO
+ withMonitor tid (tryPutMVar_ err) $ do
+ sendMsg $ tryPutMVar_ err NormalExit
+ takeMVar err >>= throwAbnormal
-- | Send a message parameterized by a reply action to @tid@, returning the
-- response value. If the thread exits before responding to the message, throw
@@ -62,19 +62,13 @@ sendSyncMessage sendMsg tid = do
call :: ((a -> IO ()) -> IO ()) -> ThreadId -> IO a
call sendMsg tid = do
mv <- newEmptyMVar
- let putResponse = (>> return ()) . tryPutMVar mv
- withMonitor tid (putResponse . Left) $ do
- sendMsg $ putResponse . Right
+ withMonitor tid (tryPutMVar_ mv . Left) $ do
+ sendMsg $ tryPutMVar_ mv . Right
response <- takeMVar mv
case response of
- Left Nothing -> E.throwDyn NonexistentThread
- Left (Just e) -> E.throwIO e
- Right r -> return r
-
--- | A wrapper for using 'showException' with 'ExitReason's.
-showExitReason :: [Dynamic -> Maybe String] -> ExitReason -> String
-showExitReason _ Nothing = "Normal exit"
-showExitReason fs (Just e) = showException (showLinkException:fs) e
+ Left NormalExit -> E.throwIO NonexistentThread
+ Left (AbnormalExit e) -> E.throwIO e
+ Right r -> return r
-- | Invoke the given 'IO' action in a new thread, passing it an action to
-- invoke when it has successfully started. Link the new thread to the calling
@@ -83,14 +77,13 @@ showExitReason fs (Just e) = showException (showLinkException:fs) e
startLink :: (IO () -> IO a) -> IO ThreadId
startLink io = do
sync <- newEmptyMVar
- err <- newEmptyMVar
- let putResponse = (>> return ()) . tryPutMVar err
+ err <- newEmptyMVar
tid <- forkLinkIO $ do
takeMVar sync
- io (putResponse Nothing)
- withMonitor tid putResponse $ do
+ io $ tryPutMVar_ err NormalExit
+ withMonitor tid (tryPutMVar_ err) $ do
putMVar sync ()
- takeMVar err >>= flip whenJust E.throwIO
+ takeMVar err >>= throwAbnormal
return tid
-- | Invoke the given 'IO' action in a temporary thread (linked to the calling
@@ -100,15 +93,17 @@ startLink io = do
tryForkLinkIO :: Thread a => IO a -> IO (Either ExitReason a, ThreadId)
tryForkLinkIO io = do
sync <- newEmptyMVar
- response <- newEmptyMVar
- let putResponse = (>> return ()) . tryPutMVar response
+ resp <- newEmptyMVar
intermediate <- forkLinkIO $ do
takeMVar sync
- io >>= putResponse . Right
- r <- withMonitor intermediate (putResponse . Left) $ do
+ io >>= tryPutMVar_ resp . Right
+ r <- withMonitor intermediate (tryPutMVar_ resp . Left) $ do
putMVar sync ()
E.block $ do
- r <- takeMVar response
+ r <- takeMVar resp
either (const $ return ()) (linkThread . threadId) r
return r
return (r, intermediate)
+
+tryPutMVar_ :: MVar a -> a -> IO ()
+tryPutMVar_ = ((() <$) .) . tryPutMVar
