slave-thread 1.0.2 → 1.0.2.1
raw patch · 4 files changed
+143/−145 lines, 4 filesdep +deferred-foldsdep +foldldep +rerebasedep −base-preludedep −list-tdep ~basedep ~partial-handlerdep ~stm-containersPVP ok
version bump matches the API change (PVP)
Dependencies added: deferred-folds, foldl, rerebase
Dependencies removed: base-prelude, list-t
Dependency ranges changed: base, partial-handler, stm-containers, transformers
API changes (from Hackage documentation)
Files
- library/SlaveThread.hs +18/−8
- slave-thread.cabal +28/−40
- test/Main.hs +97/−0
- tests/Main.hs +0/−97
library/SlaveThread.hs view
@@ -38,14 +38,23 @@ ) where -import BasePrelude hiding (forkFinally)-import Control.Monad.Trans.Reader+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.Morph-import GHC.IO (IO(IO))+import Control.Monad.Trans.Reader+import GHC.Conc import GHC.Exts (Int(I#), fork#, forkOn#)-import qualified STMContainers.Multimap as Multimap+import GHC.IO (IO(IO))+import System.IO.Unsafe+import qualified DeferredFolds.UnfoldM as UnfoldM import qualified PartialHandler-import qualified ListT+import qualified StmContainers.Multimap as Multimap+import qualified Control.Foldl as Foldl -- |@@ -98,13 +107,14 @@ return slaveThread killSlaves :: ThreadId -> IO ()-killSlaves thread =- ListT.traverse_ killThread $ hoist atomically $ Multimap.streamByKey thread slaves+killSlaves thread = do+ threads <- atomically (UnfoldM.foldM (Foldl.generalize Foldl.revList) (Multimap.unfoldMByKey thread slaves))+ traverse_ killThread threads waitForSlavesToDie :: ThreadId -> IO () waitForSlavesToDie thread = atomically $ do- null <- ListT.null $ Multimap.streamByKey thread slaves+ null <- UnfoldM.null $ Multimap.unfoldMByKey thread slaves unless null retry -- |
slave-thread.cabal view
@@ -1,9 +1,9 @@ name: slave-thread version:- 1.0.2+ 1.0.2.1 synopsis:- A principal solution to ghost threads and silent exceptions+ 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.@@ -58,61 +58,49 @@ cabal-version: >=1.10 - source-repository head type: git location: git://github.com/nikita-volkov/slave-thread.git - library hs-source-dirs: library- other-modules:- exposed-modules:- SlaveThread- build-depends:- -- data:- stm-containers >= 0.2 && < 0.3,- -- control:- partial-handler >= 0.1 && < 2,- list-t >= 0.2.4 && < 2,- mmorph >= 1.0.4 && < 2,- transformers >= 0.3 && < 0.6,- -- general:- base-prelude >= 0.1.19 && < 2,- base >= 4.6 && < 5- ghc-options:- -funbox-strict-fields 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, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ 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-language: Haskell2010-+ exposed-modules:+ SlaveThread+ build-depends:+ base >=4.6 && <5,+ deferred-folds >=0.6.7 && <0.7,+ foldl >=1 && <2,+ mmorph >=1.0.4 && <2,+ partial-handler >=1 && <2,+ stm-containers >=1 && <1.1,+ transformers >=0.5 && <0.6 -test-suite tests+test-suite test type: exitcode-stdio-1.0 hs-source-dirs: - tests- main-is: - Main.hs- build-depends:- slave-thread,- -- testing:- HTF == 0.13.*,- quickcheck-instances == 0.3.*,- QuickCheck >= 2.6 && < 3,- -- general:- SafeSemaphore == 0.10.*,- base-prelude,- base+ 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, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010 ghc-options: -threaded "-with-rtsopts=-N" -funbox-strict-fields- 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, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010+ main-is: + Main.hs+ build-depends:+ HTF ==0.13.*,+ QuickCheck >=2.6 && <3,+ quickcheck-instances ==0.3.*,+ rerebase >=1 && <2,+ SafeSemaphore ==0.10.*,+ slave-thread
+ test/Main.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import Prelude+import Test.Framework+import Test.QuickCheck.Instances+import qualified SlaveThread as S+import qualified Control.Concurrent.SSem as SSem+++main = + htfMain $ htf_thisModulesTests+++test_forkedThreadsRunFine = + 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++test_killingAThreadKillsDeepSlaves = + 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++test_dyingNormallyKillsSlaves = + 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++test_finalizationOrder = + 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++test_exceptionsDontGetLost = + replicateM 100000 $ do+ assertThrowsSomeIO $ do+ S.fork $ do+ S.fork $ do+ error "!"+ threadDelay $ 10^6+ threadDelay $ 10^6++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
− tests/Main.hs
@@ -1,97 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main where--import BasePrelude-import Test.Framework-import Test.QuickCheck.Instances-import qualified SlaveThread as S-import qualified Control.Concurrent.SSem as SSem---main = - htfMain $ htf_thisModulesTests---test_forkedThreadsRunFine = - 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--test_killingAThreadKillsDeepSlaves = - 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--test_dyingNormallyKillsSlaves = - 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--test_finalizationOrder = - 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--test_exceptionsDontGetLost = - replicateM 100000 $ do- assertThrowsSomeIO $ do- S.fork $ do- S.fork $ do- error "!"- threadDelay $ 10^6- threadDelay $ 10^6--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