slave-thread 1.0.2.5 → 1.0.2.6
raw patch · 3 files changed
+51/−30 lines, 3 filesdep −mmorphdep −partial-handlerPVP ok
version bump matches the API change (PVP)
Dependencies removed: mmorph, partial-handler
API changes (from Hackage documentation)
Files
- library/SlaveThread.hs +33/−23
- slave-thread.cabal +2/−4
- test/Main.hs +16/−3
library/SlaveThread.hs view
@@ -45,14 +45,12 @@ import Control.Concurrent hiding (forkFinally) import Control.Exception import Control.Monad-import Control.Monad.Morph 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 qualified DeferredFolds.UnfoldlM as UnfoldlM-import qualified PartialHandler import qualified StmContainers.Multimap as Multimap import qualified Control.Foldl as Foldl @@ -82,30 +80,42 @@ {-# INLINABLE forkFinally #-} forkFinally :: IO a -> IO b -> IO ThreadId forkFinally finalizer computation =- mask_ $ do+ uninterruptibleMask_ $ do masterThread <- myThreadId -- Ensures that the thread gets registered before being unregistered registrationGate <- newEmptyMVar- slaveThread <-- forkIOWithUnmaskWithoutHandler $ \unmask -> do- slaveThread <- myThreadId- catch- (unmask (void computation))- (PartialHandler.totalizeRethrowingTo_ masterThread- (PartialHandler.onThreadKilled (return ())))- -- Context management:- catch- (do- killSlaves slaveThread- waitForSlavesToDie slaveThread)- (PartialHandler.totalizeRethrowingTo_ masterThread mempty)- -- Finalization:- catch (void finalizer) $- PartialHandler.totalizeRethrowingTo_ masterThread $ mempty- -- Unregister from the global state,- -- thus informing the master of this thread's death:- takeMVar registrationGate- atomically $ Multimap.delete slaveThread masterThread slaves+ slaveThread <- forkIOWithUnmaskWithoutHandler $ \ unmask -> do++ slaveThread <- myThreadId++ -- Execute the main computation:+ catch (unmask (void computation)) $ \ e ->+ case fromException e of+ Just ThreadKilled -> return ()+ _ -> throwTo masterThread e++ -- 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)++ -- Finalize:+ finalizerResult <- try @SomeException (void finalizer)++ -- 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.insert slaveThread masterThread slaves putMVar registrationGate () return slaveThread
slave-thread.cabal view
@@ -1,5 +1,5 @@ name: slave-thread-version: 1.0.2.5+version: 1.0.2.6 synopsis: A fundamental solution to ghost threads and silent exceptions description: Vanilla thread management in Haskell is low level and @@ -51,15 +51,13 @@ 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, TypeFamilies, TypeOperators, UnboxedTuples+ 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 build-depends: base >=4.9 && <5, deferred-folds >=0.9 && <0.10, foldl >=1 && <2,- mmorph >=1.0.4 && <2,- partial-handler >=1 && <2, stm-containers >=1.1 && <1.2, transformers >=0.5 && <0.6
test/Main.hs view
@@ -29,11 +29,11 @@ S.forkFinally finalizer1 $ do S.forkFinally finalizer2 $ threadDelay 100 threadDelay (10^4)- assertEqual "" "Left user error (finalizer2 failed)" (show result) finalizer2Called <- atomically (readTVar finalizer2CalledVar) finalizer1Called <- atomically (readTVar finalizer1CalledVar)- assertEqual "" True finalizer2Called- assertEqual "" True finalizer1Called+ assertEqual "finalizer2 not called" True finalizer2Called+ assertEqual "finalizer1 not called" True finalizer1Called+ assertEqual "Invalid result" "Left user error (finalizer2 failed)" (show result) , testCase "Forked threads run fine" $ do replicateM_ 100000 $ do@@ -128,6 +128,19 @@ var <- newEmptyMVar mask_ (S.fork (getMaskingState >>= putMVar var)) assertEqual "" Unmasked =<< takeMVar var+ ,+ testCase "Slave thread finalizer is not interrupted by its own death (#11)" $ do+ ref <- newIORef True+ done <- newEmptyMVar+ S.forkFinally (putMVar done ()) $ do+ ready <- newEmptyMVar+ S.forkFinally (catch @SomeException (threadDelay (10^6)) (\_ -> writeIORef ref False)) $ do+ takeMVar ready+ throwIO (userError "")+ catch @SomeException+ (putMVar ready () >> threadDelay (10^6)) (\_ -> return ())+ takeMVar done+ assertBool "Slave thread finalizer interrupted" =<< readIORef ref ] forkWait :: IO a -> IO (IO ())