diff --git a/library/SlaveThread.hs b/library/SlaveThread.hs --- a/library/SlaveThread.hs +++ b/library/SlaveThread.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- | -- Vanilla thread management in Haskell is low level and -- it does not approach the problems related to thread deaths. @@ -33,25 +32,24 @@ -- and lets you be sure of getting informed -- if your program gets brought to an erroneous state. module SlaveThread -( - fork, - forkWithUnmask, - forkFinally, - forkFinallyWithUnmask, - SlaveThreadCrashed(..) - -- * Notes - -- $note-unmask -) + ( fork, + forkWithUnmask, + forkFinally, + forkFinallyWithUnmask, + SlaveThreadCrashed (..), + + -- * Notes + -- $note-unmask + ) where +import qualified Control.Foldl as Foldl +import qualified DeferredFolds.UnfoldlM as UnfoldlM +import qualified Focus 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 -import qualified Focus - -- | -- A global registry of all slave threads by their masters. {-# NOINLINE slaveRegistry #-} @@ -61,7 +59,7 @@ -- | -- Fork a slave thread to run a computation on. -{-# INLINABLE fork #-} +{-# INLINEABLE fork #-} fork :: IO a -> IO ThreadId fork = forkFinally $ return () @@ -69,7 +67,7 @@ -- | -- Like 'fork', but provides the computation a function that unmasks -- asynchronous exceptions. See @Note [Unmask]@ at the bottom of this module. -{-# INLINABLE forkWithUnmask #-} +{-# INLINEABLE forkWithUnmask #-} forkWithUnmask :: ((forall x. IO x -> IO x) -> IO a) -> IO ThreadId forkWithUnmask = forkFinallyWithUnmask $ return () @@ -82,7 +80,7 @@ -- Note the order of arguments: -- -- >forkFinally finalizer computation -{-# INLINABLE forkFinally #-} +{-# INLINEABLE forkFinally #-} forkFinally :: IO a -> IO b -> IO ThreadId forkFinally finalizer computation = forkFinallyWithUnmask finalizer (\unmask -> unmask computation) @@ -90,44 +88,42 @@ -- | -- Like 'forkFinally', but provides the computation a function that unmasks -- asynchronous exceptions. See @Note [Unmask]@ at the bottom of this module. -{-# INLINABLE forkFinallyWithUnmask #-} +{-# INLINEABLE forkFinallyWithUnmask #-} forkFinallyWithUnmask :: IO a -> ((forall x. IO x -> IO x) -> IO b) -> IO ThreadId forkFinallyWithUnmask finalizer computation = uninterruptibleMask $ \unmask -> do - masterThread <- myThreadId slaveThread <- forkIOWithoutHandler $ do - slaveThread <- myThreadId -- Execute the main computation: computationExceptions <- catch (computation unmask $> empty) (return . pure) -- Kill the slaves and wait for them to die: - slavesDyingExceptions <- let - loop !exceptions = - catch - (unmask $ do - killSlaves slaveThread - waitForSlavesToDie slaveThread - return exceptions) - (\ !exception -> loop (exception : exceptions)) - in loop [] + slavesDyingExceptions <- + let loop !exceptions = + catch + ( unmask $ do + killSlaves slaveThread + waitForSlavesToDie slaveThread + return exceptions + ) + (\ !exception -> loop (exception : exceptions)) + in loop [] -- Finalize: finalizerExceptions <- catch (finalizer $> empty) (return . pure) -- Rethrow the exceptions: - let - handler e = do - case fromException e of - Just ThreadKilled -> return () - _ -> throwTo masterThread (SlaveThreadCrashed slaveThread e) - in do - forM_ @Maybe computationExceptions handler - forM_ slavesDyingExceptions handler - forM_ @Maybe finalizerExceptions handler + let handler e = do + case fromException e of + Just ThreadKilled -> return () + _ -> throwTo masterThread (SlaveThreadCrashed slaveThread 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. @@ -144,21 +140,13 @@ killSlaves :: ThreadId -> IO () killSlaves thread = do -#if MIN_VERSION_stm_containers(1,2,0) threads <- atomically (UnfoldlM.foldM (Foldl.generalize Foldl.revList) (Multimap.unfoldlMByKey thread slaveRegistry)) -#else - threads <- atomically (UnfoldlM.foldM (Foldl.generalize Foldl.revList) (Multimap.unfoldMByKey thread slaveRegistry)) -#endif traverse_ killThread threads waitForSlavesToDie :: ThreadId -> IO () waitForSlavesToDie thread = atomically $ do -#if MIN_VERSION_stm_containers(1,2,0) null <- UnfoldlM.null $ Multimap.unfoldlMByKey thread slaveRegistry -#else - null <- UnfoldlM.null $ Multimap.unfoldMByKey thread slaveRegistry -#endif unless null retry -- | A slave thread crashed. This exception is classified as /asynchronous/, diff --git a/library/SlaveThread/Prelude.hs b/library/SlaveThread/Prelude.hs --- a/library/SlaveThread/Prelude.hs +++ b/library/SlaveThread/Prelude.hs @@ -1,19 +1,16 @@ module SlaveThread.Prelude -( - module Exports, -) + ( 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 as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports import Data.Bits as Exports import Data.Bool as Exports @@ -26,19 +23,19 @@ 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 as Exports hiding (unzip) import Data.Functor.Identity as Exports -import Data.Int as Exports import Data.IORef as Exports +import Data.Int 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.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) import Data.Maybe as Exports -import Data.Monoid as Exports hiding (Last(..), First(..), (<>)) +import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) 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.Semigroup as Exports import Data.String as Exports import Data.Traversable as Exports import Data.Tuple as Exports @@ -49,14 +46,13 @@ 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 Foreign.Storable as Exports hiding (alignment, sizeOf) +import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (Int (I#), IsList (..), fork#, forkOn#, groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) -import GHC.IO as Exports (IO(IO), unsafeUnmask) +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 @@ -65,8 +61,7 @@ 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 Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) diff --git a/library/SlaveThread/Util/LowLevelForking.hs b/library/SlaveThread/Util/LowLevelForking.hs --- a/library/SlaveThread/Util/LowLevelForking.hs +++ b/library/SlaveThread/Util/LowLevelForking.hs @@ -2,7 +2,6 @@ import SlaveThread.Prelude - -- | -- A more efficient version of 'forkIO', -- which does not install a default exception handler on the forked thread. diff --git a/slave-thread.cabal b/slave-thread.cabal --- a/slave-thread.cabal +++ b/slave-thread.cabal @@ -1,6 +1,8 @@ -name: slave-thread -version: 1.1.0.2 -synopsis: A fundamental solution to ghost threads and silent exceptions +name: slave-thread +version: 1.1.0.3 +synopsis: + A fundamental solution to ghost threads and silent exceptions + description: Vanilla thread management in Haskell is low level and it does not approach the problems related to thread deaths. @@ -34,48 +36,127 @@ This protects you from silent exceptions and lets you be sure of getting informed if your program gets brought to an erroneous state. -category: Concurrency, Concurrent, Error Handling, Exceptions, Failure -homepage: https://github.com/nikita-volkov/slave-thread -bug-reports: https://github.com/nikita-volkov/slave-thread/issues -author: Nikita Volkov -maintainer: Nikita Volkov -copyright: (c) 2014, Nikita Volkov -license: MIT -license-file: LICENSE -build-type: Simple + +category: + Concurrency, Concurrent, Error Handling, Exceptions, Failure + +homepage: https://github.com/nikita-volkov/slave-thread +bug-reports: https://github.com/nikita-volkov/slave-thread/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2014, Nikita Volkov +license: MIT +license-file: LICENSE +build-type: Simple cabal-version: >=1.10 source-repository head - type: git + type: git location: git://github.com/nikita-volkov/slave-thread.git library - hs-source-dirs: library - 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 + hs-source-dirs: library + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + Arrows + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + 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, - focus >=1 && <1.1, - foldl >=1 && <2, - stm-containers >=1.1 && <1.3 + base >=4.9 && <5 + , deferred-folds >=0.9 && <0.10 + , focus >=1 && <1.1 + , foldl >=1 && <2 + , stm-containers >=1.2 && <1.3 test-suite test - type: exitcode-stdio-1.0 - hs-source-dirs: test - 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 - main-is: Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + Arrows + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + + default-language: Haskell2010 + main-is: Main.hs build-depends: - QuickCheck >=2.8.1 && <3, - quickcheck-instances >=0.3.11 && <0.4, - rerebase <2, - SafeSemaphore ==0.10.*, - slave-thread, - tasty >=0.12 && <2, - tasty-hunit >=0.9 && <0.11, - tasty-quickcheck >=0.9 && <0.11 + rerebase <2 + , SafeSemaphore >=0.10 && <0.11 + , slave-thread + , tasty >=0.12 && <2 + , tasty-hunit >=0.9 && <0.11 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,189 +1,175 @@ module Main where -import Prelude -import Data.List (isInfixOf) -import Data.Either (isLeft) -import Test.QuickCheck.Instances +import qualified Control.Concurrent.SSem as SSem +import qualified SlaveThread as S import Test.Tasty -import Test.Tasty.Runners import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import qualified Test.QuickCheck as QuickCheck -import qualified Test.QuickCheck.Property as QuickCheck -import qualified SlaveThread as S -import qualified Control.Concurrent.SSem as SSem - +import Prelude +main :: IO () main = - defaultMain $ - testGroup "All" $ [ - testCase "Failing in finalizer doesn't break everything" $ do - finalizer1CalledVar <- newTVarIO False - finalizer2CalledVar <- newTVarIO False - result <- let - finalizer1 = - atomically $ writeTVar finalizer1CalledVar True - finalizer2 = - do - atomically $ writeTVar finalizer2CalledVar True - throwIO (userError "finalizer2 failed") - in try @SomeException $ do - S.forkFinally finalizer1 $ do - S.forkFinally finalizer2 $ threadDelay 100 - threadDelay (10^4) - finalizer2Called <- atomically (readTVar finalizer2CalledVar) - finalizer1Called <- atomically (readTVar finalizer1CalledVar) - assertEqual "finalizer2 not called" True finalizer2Called - assertEqual "finalizer1 not called" True finalizer1Called - assertEqual "result is left" True (isLeft result) - assertEqual "Invalid result" True ("finalizer2 failed" `isInfixOf` show result) - , - testCase "Forked threads run fine" $ do - replicateM_ 100000 $ do - var <- newMVar 0 - let increment = modifyMVar_ var (return . succ) - semaphore <- SSem.new 0 - S.fork $ do - increment - semaphore' <- SSem.new (-1) - S.fork $ do - increment - SSem.signal semaphore' - S.fork $ do - increment - SSem.signal semaphore' - SSem.wait semaphore' - SSem.signal semaphore - SSem.wait semaphore - assertEqual "" 3 =<< readMVar var - , - testCase "Killing a thread kills deep slaves" $ do - replicateM_ 100000 $ do - var <- newMVar 0 - semaphore <- SSem.new 0 - thread <- - S.forkFinally (SSem.signal semaphore) $ do - join $ forkWait $ do - join $ forkWait $ do - w <- forkWait $ do - threadDelay $ 10^6 - modifyMVar_ var (return . succ) - threadDelay $ 10^6 - modifyMVar_ var (return . succ) - w - killThread thread - SSem.wait semaphore - assertEqual "" 0 =<< readMVar var - , - testCase "Dying normally kills slaves" $ do - replicateM_ 100000 $ do - var <- newIORef 0 - let increment = modifyIORef var (+1) - semaphore <- SSem.new 0 - S.forkFinally (SSem.signal semaphore) $ do - S.fork $ do - threadDelay $ 10^6 - increment - S.fork $ do - threadDelay $ 10^6 - increment - SSem.wait semaphore - assertEqual "" 0 =<< readIORef var - , - testCase "Finalization is in order" $ do - replicateM_ 100000 $ do - var <- newMVar [] - semaphore <- SSem.new 0 - S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (1:)) >> SSem.signal semaphore)) $ do - semaphore' <- SSem.new 0 - S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (2:)) >> SSem.signal semaphore')) $ do - S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3:)))) $ return () - S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3:)))) $ return () - SSem.wait semaphore' - SSem.wait semaphore - assertEqual "" [1,2,3,3] =<< readMVar var - , - testCase "Exceptions don't get lost" $ do - replicateM_ 100000 $ do - result <- try @SomeException $ do - S.fork $ do + defaultMain + $ testGroup "All" + $ [ testCase "Failing in finalizer doesn't break everything" $ do + finalizer1CalledVar <- newTVarIO False + finalizer2CalledVar <- newTVarIO False + result <- + let finalizer1 = + atomically $ writeTVar finalizer1CalledVar True + finalizer2 = + do + atomically $ writeTVar finalizer2CalledVar True + throwIO (userError "finalizer2 failed") + in try @SomeException $ do + S.forkFinally finalizer1 $ do + S.forkFinally finalizer2 $ threadDelay 100 + threadDelay (10 ^ 4) + finalizer2Called <- atomically (readTVar finalizer2CalledVar) + finalizer1Called <- atomically (readTVar finalizer1CalledVar) + assertEqual "finalizer2 not called" True finalizer2Called + assertEqual "finalizer1 not called" True finalizer1Called + assertEqual "result is left" True (isLeft result) + assertEqual "Invalid result" True ("finalizer2 failed" `isInfixOf` show result), + testCase "Forked threads run fine" $ do + replicateM_ 100000 $ do + var <- newMVar 0 + let increment = modifyMVar_ var (return . succ) + semaphore <- SSem.new 0 S.fork $ do - error "!" - threadDelay $ 10^6 - threadDelay $ 10^6 - assertBool "" (isLeft result) - , - testCase "Slaves are finalized before master" $ do - replicateM_ 100000 $ do - ready <- newEmptyMVar - var <- newEmptyTMVarIO - thread <- - S.forkFinally (atomically (tryPutTMVar var 1)) $ do - S.forkFinally (atomically (tryPutTMVar var 0)) $ - threadDelay $ 10^6 - putMVar ready () - threadDelay $ 10^6 - takeMVar ready - killThread thread - assertEqual "First finalizer is not slave" 0 =<< atomically (readTMVar 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 + increment + semaphore' <- SSem.new (-1) + S.fork $ do + increment + SSem.signal semaphore' + S.fork $ do + increment + SSem.signal semaphore' + SSem.wait semaphore' + SSem.signal semaphore + SSem.wait semaphore + assertEqual "" 3 =<< readMVar var, + testCase "Killing a thread kills deep slaves" $ do + replicateM_ 100000 $ do + var <- newMVar 0 + semaphore <- SSem.new 0 + thread <- + S.forkFinally (SSem.signal semaphore) $ do + join $ forkWait $ do + join $ forkWait $ do + w <- forkWait $ do + threadDelay $ 10 ^ 6 + modifyMVar_ var (return . succ) + threadDelay $ 10 ^ 6 + modifyMVar_ var (return . succ) + w + killThread thread + SSem.wait semaphore + assertEqual "" 0 =<< readMVar var, + testCase "Dying normally kills slaves" $ do + replicateM_ 100000 $ do + var <- newIORef 0 + let increment = modifyIORef var (+ 1) + semaphore <- SSem.new 0 + S.forkFinally (SSem.signal semaphore) $ do + S.fork $ do + threadDelay $ 10 ^ 6 + increment + S.fork $ do + threadDelay $ 10 ^ 6 + increment + SSem.wait semaphore + assertEqual "" 0 =<< readIORef var, + testCase "Finalization is in order" $ do + replicateM_ 100000 $ do + var <- newMVar [] + semaphore <- SSem.new 0 + S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (1 :)) >> SSem.signal semaphore)) $ do + semaphore' <- SSem.new 0 + S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (2 :)) >> SSem.signal semaphore')) $ do + S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3 :)))) $ return () + S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3 :)))) $ return () + SSem.wait semaphore' + SSem.wait semaphore + assertEqual "" [1, 2, 3, 3] =<< readMVar var, + testCase "Exceptions don't get lost" $ do + replicateM_ 100000 $ do + result <- try @SomeException $ do + S.fork $ do + S.fork $ do + error "!" + threadDelay $ 10 ^ 6 + threadDelay $ 10 ^ 6 + assertBool "" (isLeft result), + testCase "Slaves are finalized before master" $ do + replicateM_ 100000 $ do + ready <- newEmptyMVar + var <- newEmptyTMVarIO + thread <- + S.forkFinally (atomically (tryPutTMVar var 1)) $ do + S.forkFinally (atomically (tryPutTMVar var 0)) + $ threadDelay + $ 10 + ^ 6 + putMVar ready () + threadDelay $ 10 ^ 6 + takeMVar ready + killThread thread + assertEqual "First finalizer is not slave" 0 =<< atomically (readTMVar 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 thread 2 know when it should die, with thread 1's exception - -- handler in place. - ready <- newEmptyMVar + -- Let the main thread know when it should check the above IORef. + done <- newEmptyMVar - S.forkFinally - (catch @SomeException (threadDelay (10^5)) (\_ -> writeIORef ref False)) $ do + -- 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. - -- Wait until thread 1 is ready for us to die. - takeMVar ready + S.forkFinally (putMVar done ()) $ do + -- Let thread 2 know when it should die, with thread 1's exception + -- handler in place. + ready <- newEmptyMVar - -- Die. - throwIO (userError "") + S.forkFinally + (catch @SomeException (threadDelay (10 ^ 5)) (\_ -> writeIORef ref False)) + $ do + -- Wait until thread 1 is ready for us to die. + takeMVar ready - catch @SomeException - ( -- Tell thread 2 we're ready for it to die - putMVar ready () >> + -- Die. + throwIO (userError "") - -- 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 ()) + catch @SomeException + ( -- 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) - ] + 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 ()) forkWait io =