diff --git a/library/SlaveThread.hs b/library/SlaveThread.hs --- a/library/SlaveThread.hs +++ b/library/SlaveThread.hs @@ -38,18 +38,8 @@ ) where -import Prelude -import Data.Foldable -import Data.Traversable -import Control.Applicative -import Control.Concurrent hiding (forkFinally) -import Control.Exception -import Control.Monad -import Control.Monad.Trans.Reader -import GHC.Conc -import GHC.Exts (Int(I#), fork#, forkOn#) -import GHC.IO (IO(IO), unsafeUnmask) -import System.IO.Unsafe +import SlaveThread.Prelude +import SlaveThread.Util.LowLevelForking import qualified DeferredFolds.UnfoldlM as UnfoldlM import qualified StmContainers.Multimap as Multimap import qualified Control.Foldl as Foldl @@ -57,9 +47,9 @@ -- | -- A global registry of all slave threads by their masters. -{-# NOINLINE slaves #-} -slaves :: Multimap.Multimap ThreadId ThreadId -slaves = +{-# NOINLINE slaveRegistry #-} +slaveRegistry :: Multimap.Multimap ThreadId ThreadId +slaveRegistry = unsafePerformIO Multimap.newIO -- | @@ -89,52 +79,50 @@ slaveThread <- myThreadId -- Execute the main computation: - catch (unmask (void computation)) $ \ e -> - case fromException e of - Just ThreadKilled -> return () - _ -> throwTo masterThread e + computationExceptions <- catch (unmask computation $> empty) (return . pure) -- Kill the slaves and wait for them to die: - catch - (unmask $ do - killSlaves slaveThread - waitForSlavesToDie slaveThread) - (\ e -> case fromException e of - Just ThreadKilled -> return () - _ -> throwTo masterThread e) + slavesDyingExceptions <- let + loop !exceptions = + catch + (unmask $ do + killSlaves slaveThread + waitForSlavesToDie slaveThread + return exceptions) + (\ !exception -> loop (exception : exceptions)) + in loop [] -- Finalize: - finalizerResult <- try @SomeException (void finalizer) + finalizerExceptions <- catch (finalizer $> empty) (return . pure) + -- Rethrow the exceptions: + let + handler e = do + case fromException e of + Just ThreadKilled -> return () + _ -> throwTo masterThread e + in do + forM_ @Maybe computationExceptions handler + forM_ slavesDyingExceptions handler + forM_ @Maybe finalizerExceptions handler + -- Unregister from the global state, -- thus informing the master of this thread's death: takeMVar registrationGate - atomically $ Multimap.delete slaveThread masterThread slaves - - -- - case finalizerResult of - Left e -> throwTo masterThread e - _ -> return () + atomically $ Multimap.delete slaveThread masterThread slaveRegistry - atomically $ Multimap.insert slaveThread masterThread slaves + atomically $ Multimap.insert slaveThread masterThread slaveRegistry putMVar registrationGate () + return slaveThread killSlaves :: ThreadId -> IO () killSlaves thread = do - threads <- atomically (UnfoldlM.foldM (Foldl.generalize Foldl.revList) (Multimap.unfoldMByKey thread slaves)) + threads <- atomically (UnfoldlM.foldM (Foldl.generalize Foldl.revList) (Multimap.unfoldMByKey thread slaveRegistry)) traverse_ killThread threads waitForSlavesToDie :: ThreadId -> IO () waitForSlavesToDie thread = atomically $ do - null <- UnfoldlM.null $ Multimap.unfoldMByKey thread slaves + null <- UnfoldlM.null $ Multimap.unfoldMByKey thread slaveRegistry unless null retry - --- | --- A more efficient version of 'forkIOWithUnmask', --- which does not install a default exception handler on the forked thread. -{-# INLINE forkIOWithUnmaskWithoutHandler #-} -forkIOWithUnmaskWithoutHandler :: ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId -forkIOWithUnmaskWithoutHandler action = - IO $ \s -> case (fork# (action unsafeUnmask) s) of (# s', tid #) -> (# s', ThreadId tid #) diff --git a/library/SlaveThread/Prelude.hs b/library/SlaveThread/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/SlaveThread/Prelude.hs @@ -0,0 +1,72 @@ +module SlaveThread.Prelude +( + module Exports, +) +where + +-- base +------------------------- +import Control.Applicative as Exports +import Control.Arrow as Exports +import Control.Category as Exports +import Control.Concurrent as Exports hiding (forkFinally) +import Control.Exception as Exports +import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Monad.IO.Class as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.ST as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports hiding (toList) +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports +import Data.Functor.Identity as Exports +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (Last(..), First(..), (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.Semigroup as Exports +import Data.STRef as Exports +import Data.String as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding (sizeOf, alignment) +import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) +import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(..), Int(I#), fork#, forkOn#) +import GHC.Generics as Exports (Generic) +import GHC.IO as Exports (IO(IO), unsafeUnmask) +import GHC.IO.Exception as Exports +import Numeric as Exports +import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) +import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) +import Text.Printf as Exports (printf, hPrintf) +import Text.Read as Exports (Read(..), readMaybe, readEither) +import Unsafe.Coerce as Exports diff --git a/library/SlaveThread/Util/LowLevelForking.hs b/library/SlaveThread/Util/LowLevelForking.hs new file mode 100644 --- /dev/null +++ b/library/SlaveThread/Util/LowLevelForking.hs @@ -0,0 +1,20 @@ +module SlaveThread.Util.LowLevelForking where + +import SlaveThread.Prelude + + +-- | +-- A more efficient version of 'forkIO', +-- which does not install a default exception handler on the forked thread. +{-# INLINE forkIOWithoutHandler #-} +forkIOWithoutHandler :: IO () -> IO ThreadId +forkIOWithoutHandler action = + IO $ \s -> case (fork# action s) of (# s', tid #) -> (# s', ThreadId tid #) + +-- | +-- A more efficient version of 'forkIOWithUnmask', +-- which does not install a default exception handler on the forked thread. +{-# INLINE forkIOWithUnmaskWithoutHandler #-} +forkIOWithUnmaskWithoutHandler :: ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId +forkIOWithUnmaskWithoutHandler action = + forkIOWithoutHandler (action unsafeUnmask) diff --git a/slave-thread.cabal b/slave-thread.cabal --- a/slave-thread.cabal +++ b/slave-thread.cabal @@ -1,5 +1,5 @@ name: slave-thread -version: 1.0.2.6 +version: 1.0.2.7 synopsis: A fundamental solution to ghost threads and silent exceptions description: Vanilla thread management in Haskell is low level and @@ -54,12 +54,14 @@ default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 exposed-modules: SlaveThread + other-modules: + SlaveThread.Prelude + SlaveThread.Util.LowLevelForking build-depends: base >=4.9 && <5, deferred-folds >=0.9 && <0.10, foldl >=1 && <2, - stm-containers >=1.1 && <1.2, - transformers >=0.5 && <0.6 + stm-containers >=1.1 && <1.2 test-suite test type: exitcode-stdio-1.0 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -130,17 +130,61 @@ assertEqual "" Unmasked =<< takeMVar var , testCase "Slave thread finalizer is not interrupted by its own death (#11)" $ do + -- Set up the ref that should be written to by thread 2's finalizer, + -- otherwise there's a bug. ref <- newIORef True + + -- Let the main thread know when it should check the above IORef. done <- newEmptyMVar + + -- The gist of the test below: assert that, when a thread fails (here, the + -- inner thread), its finalizer is not interrupted by a ThreadKilled + -- thrown by the parent, which was originally triggered by its own death. + S.forkFinally (putMVar done ()) $ do + + -- Let thread 2 know when it should die, with thread 1's exception + -- handler in place. ready <- newEmptyMVar - S.forkFinally (catch @SomeException (threadDelay (10^6)) (\_ -> writeIORef ref False)) $ do + + S.forkFinally + (catch @SomeException (threadDelay (10^5)) (\_ -> writeIORef ref False)) $ do + + -- Wait until thread 1 is ready for us to die. takeMVar ready + + -- Die. throwIO (userError "") + catch @SomeException - (putMVar ready () >> threadDelay (10^6)) (\_ -> return ()) + ( -- Tell thread 2 we're ready for it to die + putMVar ready () >> + + -- Sleep until thread 2 kills us. + threadDelay (10^5*2) + ) + -- Ignore thread 2's exception, so we don't propagate it up to the + -- main thread. + (\ _ -> return ()) + takeMVar done assertBool "Slave thread finalizer interrupted" =<< readIORef ref + , + testCase "Master kills all slaves, even if it is thrown an exception during (#13)" $ do + survived <- newEmptyTMVarIO + ready <- newEmptyMVar + done <- newEmptyMVar + thread <- + S.fork $ do + S.forkFinally (atomically (tryPutTMVar survived True)) $ do + uninterruptibleMask_ (putMVar ready () >> threadDelay (10^6)) + atomically (putTMVar survived False) + takeMVar ready + putMVar done () + takeMVar done + threadDelay $ 10^5 -- be reasonably sure it's trying to kill its child + killThread thread + assertBool "Slave thread not killed by master" =<< atomically (takeTMVar survived) ] forkWait :: IO a -> IO (IO ())