diff --git a/library/SlaveThread.hs b/library/SlaveThread.hs --- a/library/SlaveThread.hs +++ b/library/SlaveThread.hs @@ -1,3 +1,36 @@ +-- | +-- Vanilla thread management in Haskell is low level and +-- it does not approach the problems related to thread deaths. +-- When it's used naively the following typical problems arise: +-- +-- * When a forked thread dies due to an uncaught exception, +-- the exception does not get raised in the main thread, +-- which is why the program continues to run as if nothing happened, +-- i.e., with the presumption that the already dead thread is running normally. +-- Naturally this may very well bring your program to a chaotic state. +-- +-- * Another issue is that one thread dying does not +-- affect any of the threads forked from it. +-- That's why your program may be accumulating ghost threads. +-- +-- * Ever dealt with your program ignoring the \ strikes? +-- +-- This library solves all the issues above with a concept of a slave thread. +-- A slave thread has the following properties: +-- +-- 1. When it dies for whatever reason (exception or finishing normally) +-- it kills all the slave threads that were forked from it. +-- This protects you from ghost threads. +-- +-- 2. It waits for all slaves to die and execute their finalizers +-- before executing its own finalizer and getting released itself. +-- This gives you hierarchical releasing of resources. +-- +-- 3. When a slave thread dies with an uncaught exception +-- it reraises it in the master thread. +-- This protects you from silent exceptions +-- and lets you be sure of getting informed +-- if your program gets brought to an erroneous state. module SlaveThread ( fork, @@ -15,12 +48,14 @@ -- | -- A global registry of all slave threads by their masters. +{-# NOINLINE slaves #-} slaves :: Multimap.Multimap ThreadId ThreadId slaves = - unsafePerformIO $ Multimap.newIO + unsafePerformIO Multimap.newIO -- | -- Fork a slave thread to run a computation on. +{-# INLINABLE fork #-} fork :: IO a -> IO ThreadId fork main = forkFinally (return ()) main @@ -31,7 +66,9 @@ -- due to being killed or an uncaught exception, or a normal termination. -- -- Note the order of arguments: +-- -- >forkFinally finalizer computation +{-# INLINABLE forkFinally #-} forkFinally :: IO a -> IO b -> IO ThreadId forkFinally finalizer computation = do diff --git a/slave-thread.cabal b/slave-thread.cabal --- a/slave-thread.cabal +++ b/slave-thread.cabal @@ -1,7 +1,7 @@ name: slave-thread version: - 0.1.0 + 0.1.1 synopsis: A solution to ghost threads and silent exceptions description: @@ -13,8 +13,7 @@ the exception does not get raised in the main thread, which is why the program continues to run as if nothing happened, i.e., with the presumption that the already dead thread is running normally. - It does not need an explanation - that this may bring your program to a chaotic state. + Naturally this may very well bring your program to a chaotic state. . * Another issue is that one thread dying does not affect any of the threads forked from it. @@ -34,10 +33,10 @@ This gives you hierarchical releasing of resources. . 3. When a slave thread dies with an uncaught exception - it reraises it in the parent thread. - This protects you from silent exceptions. - If your program is brought to an erroneous state - you can be sure of getting informed. + it reraises it in the master thread. + 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: @@ -106,7 +105,8 @@ quickcheck-instances == 0.3.*, QuickCheck == 2.7.*, HUnit == 1.2.*, - -- data: + -- general: + SafeSemaphore == 0.10.*, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8 ghc-options: diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -5,6 +5,7 @@ import Test.Framework import Test.QuickCheck.Instances import qualified SlaveThread as S +import qualified Control.Concurrent.SSem as SSem main = @@ -15,55 +16,61 @@ replicateM 100 $ do var <- newIORef 0 let increment = modifyIORef var (+1) + semaphore <- SSem.new 0 S.fork $ do increment + semaphore' <- SSem.new (-1) S.fork $ do increment + SSem.signal semaphore' S.fork $ do increment - threadDelay $ 10^5 - threadDelay $ 20 * 10^3 + SSem.signal semaphore' + SSem.wait semaphore' + SSem.signal semaphore + SSem.wait semaphore assertEqual 3 =<< readIORef var test_killingAThreadKillsDeepSlaves = - replicateM 1000 $ do + replicateM 100 $ do var <- newIORef 0 let increment = modifyIORef var (+1) + semaphore <- SSem.new 0 thread <- - S.fork $ do - S.fork $ do - S.fork $ do - threadDelay $ 10^5 - increment - S.fork $ do + S.forkFinally (SSem.signal semaphore) $ do + w <- forkWait $ do + w <- forkWait $ do + threadDelay $ 20*10^3 increment - threadDelay $ 10^6 - threadDelay $ 10^6 - threadDelay $ 10^4 + w + w killThread thread - assertEqual 1 =<< readIORef var + SSem.wait semaphore + assertEqual 0 =<< readIORef var test_dyingNormallyKillsSlaves = replicateM 100 $ do var <- newIORef 0 let increment = modifyIORef var (+1) - S.fork $ do + semaphore <- SSem.new 0 + S.forkFinally (SSem.signal semaphore) $ do S.fork $ do threadDelay $ 10^4 increment S.fork $ do threadDelay $ 10^4 increment - threadDelay $ 10^5 + SSem.wait semaphore assertEqual 0 =<< readIORef var test_finalizationOrder = replicateM 1000 $ do var <- newIORef 0 - S.forkFinally (modifyIORef var (*2)) $ do + semaphore <- SSem.new 0 + S.forkFinally (modifyIORef var (*2) >> SSem.signal semaphore) $ do S.forkFinally (modifyIORef var (+1)) $ return () S.forkFinally (modifyIORef var (+1)) $ return () - threadDelay $ 10^4 + SSem.wait semaphore assertEqual 4 =<< readIORef var test_exceptionsDontGetLost = @@ -75,3 +82,12 @@ threadDelay $ 10^4 threadDelay $ 10^4 +forkWait :: IO a -> IO (IO ()) +forkWait io = + do + v <- newEmptyMVar + S.fork $ do + r <- try io + putMVar v () + either (throwIO :: SomeException -> IO a) return r + return $ takeMVar v