commit 7494d418a991eb60b4644169310026336068d634 Author: David Kaloper david@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