├── .gitignore ├── .travis.yml ├── Control └── Concurrent │ ├── Raw.hs │ ├── Thread.hs │ └── Thread │ └── Group.hs ├── LICENSE ├── README.markdown ├── default.nix ├── test └── test.hs ├── threads.cabal └── threads.nix /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /dist-newstyle/ 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.18 GHCVER=7.2.2 17 | compiler: ": #GHC 7.2.2" 18 | addons: {apt: {packages: [cabal-install-1.18,ghc-7.2.2], sources: [hvr-ghc]}} 19 | - env: CABALVER=1.18 GHCVER=7.4.2 20 | compiler: ": #GHC 7.4.2" 21 | addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}} 22 | - env: CABALVER=1.18 GHCVER=7.6.3 23 | compiler: ": #GHC 7.6.3" 24 | addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}} 25 | - env: CABALVER=1.18 GHCVER=7.8.4 26 | compiler: ": #GHC 7.8.4" 27 | addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} 28 | - env: CABALVER=1.22 GHCVER=7.10.3 29 | compiler: ": #GHC 7.10.3" 30 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} 31 | - env: CABALVER=1.24 GHCVER=8.0.1 32 | compiler: ": #GHC 8.0.1" 33 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} 34 | 35 | before_install: 36 | - unset CC 37 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 38 | 39 | install: 40 | - cabal --version 41 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 42 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 43 | then 44 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 45 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 46 | fi 47 | - travis_retry cabal update -v 48 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 49 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 50 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 51 | 52 | # check whether current requested install-plan matches cached package-db snapshot 53 | - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; 54 | then 55 | echo "cabal build-cache HIT"; 56 | rm -rfv .ghc; 57 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 58 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 59 | else 60 | echo "cabal build-cache MISS"; 61 | rm -rf $HOME/.cabsnap; 62 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 63 | cabal install --only-dependencies --enable-tests --enable-benchmarks; 64 | fi 65 | 66 | # snapshot package-db on cache miss 67 | - if [ ! -d $HOME/.cabsnap ]; 68 | then 69 | echo "snapshotting package-db to build-cache"; 70 | mkdir $HOME/.cabsnap; 71 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 72 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 73 | fi 74 | 75 | # Here starts the actual work to be performed for the package under test; 76 | # any command which exits with a non-zero exit code causes the build to fail. 77 | script: 78 | - if [ -f configure.ac ]; then autoreconf -i; fi 79 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 80 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 81 | - cabal test 82 | - cabal check 83 | - cabal sdist # tests that a source-distribution can be generated 84 | 85 | # Check that the resulting source distribution can be built & installed. 86 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 87 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 88 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 89 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 90 | 91 | # EOF 92 | -------------------------------------------------------------------------------- /Control/Concurrent/Raw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} 2 | 3 | module Control.Concurrent.Raw ( rawForkIO, rawForkOn ) where 4 | 5 | import Data.Function ( ($) ) 6 | import GHC.IO ( IO(IO) ) 7 | import GHC.Exts ( Int(I#), fork#, forkOn# ) 8 | import GHC.Conc ( ThreadId(ThreadId) ) 9 | 10 | -- A version of forkIO that does not include the outer exception 11 | -- handler: saves a bit of time when we will be installing our own 12 | -- exception handler. 13 | {-# INLINE rawForkIO #-} 14 | rawForkIO :: IO () -> IO ThreadId 15 | #if MIN_VERSION_base(4,17,0) 16 | rawForkIO (IO action) = IO $ \s -> 17 | #else 18 | rawForkIO action = IO $ \s -> 19 | #endif 20 | case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #) 21 | 22 | {-# INLINE rawForkOn #-} 23 | rawForkOn :: Int -> IO () -> IO ThreadId 24 | #if MIN_VERSION_base(4,17,0) 25 | rawForkOn (I# cpu) (IO action) = IO $ \s -> 26 | #else 27 | rawForkOn (I# cpu) action = IO $ \s -> 28 | #endif 29 | case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #) 30 | -------------------------------------------------------------------------------- /Control/Concurrent/Thread.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, NoImplicitPrelude, RankNTypes, ImpredicativeTypes #-} 2 | 3 | #if __GLASGOW_HASKELL__ >= 701 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | 7 | -------------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Control.Concurrent.Thread 10 | -- Copyright : (c) 2010-2012 Bas van Dijk & Roel van Dijk 11 | -- License : BSD3 (see the file LICENSE) 12 | -- Maintainer : Bas van Dijk 13 | -- , Roel van Dijk 14 | -- 15 | -- Standard threads extended with the ability to /wait/ for their return value. 16 | -- 17 | -- This module exports equivalently named functions from @Control.Concurrent@ 18 | -- (and @GHC.Conc@). Avoid ambiguities by importing this module qualified. May 19 | -- we suggest: 20 | -- 21 | -- @ 22 | -- import qualified Control.Concurrent.Thread as Thread ( ... ) 23 | -- @ 24 | -- 25 | -- The following is an example how to use this module: 26 | -- 27 | -- @ 28 | -- 29 | -- import qualified Control.Concurrent.Thread as Thread ( 'forkIO', 'result' ) 30 | -- 31 | -- main = do (tid, wait) <- Thread.'forkIO' $ do x <- someExpensiveComputation 32 | -- return x 33 | -- doSomethingElse 34 | -- x <- Thread.'result' =<< 'wait' 35 | -- doSomethingWithResult x 36 | -- @ 37 | -- 38 | -------------------------------------------------------------------------------- 39 | 40 | module Control.Concurrent.Thread 41 | ( -- * Forking threads 42 | forkIO 43 | , forkOS 44 | , forkOn 45 | , forkIOWithUnmask 46 | , forkOnWithUnmask 47 | 48 | -- * Results 49 | , Result 50 | , result 51 | ) where 52 | 53 | 54 | -------------------------------------------------------------------------------- 55 | -- Imports 56 | -------------------------------------------------------------------------------- 57 | 58 | -- from base: 59 | import qualified Control.Concurrent ( forkOS 60 | , forkIOWithUnmask 61 | , forkOnWithUnmask 62 | ) 63 | import Control.Concurrent ( ThreadId ) 64 | import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar ) 65 | import Control.Exception ( SomeException, try, throwIO, mask ) 66 | import Control.Monad ( return, (>>=) ) 67 | import Data.Either ( Either(..), either ) 68 | import Data.Function ( (.), ($) ) 69 | import Data.Int ( Int ) 70 | import System.IO ( IO ) 71 | 72 | -- from threads: 73 | import Control.Concurrent.Raw ( rawForkIO, rawForkOn ) 74 | 75 | 76 | -------------------------------------------------------------------------------- 77 | -- * Forking threads 78 | -------------------------------------------------------------------------------- 79 | 80 | -- | Like @Control.Concurrent.'Control.Concurrent.forkIO'@ but returns 81 | -- a computation that when executed blocks until the thread terminates 82 | -- then returns the final value of the thread. 83 | forkIO :: IO a -> IO (ThreadId, IO (Result a)) 84 | forkIO = fork rawForkIO 85 | 86 | -- | Like @Control.Concurrent.'Control.Concurrent.forkOS'@ but returns 87 | -- a computation that when executed blocks until the thread terminates 88 | -- then returns the final value of the thread. 89 | forkOS :: IO a -> IO (ThreadId, IO (Result a)) 90 | forkOS = fork Control.Concurrent.forkOS 91 | 92 | -- | Like @Control.Concurrent.'Control.Concurrent.forkOn'@ but returns 93 | -- a computation that when executed blocks until the thread terminates 94 | -- then returns the final value of the thread. 95 | forkOn :: Int -> IO a -> IO (ThreadId, IO (Result a)) 96 | forkOn = fork . rawForkOn 97 | 98 | -- | Like @Control.Concurrent.'Control.Concurrent.forkIOWithUnmask'@ but returns 99 | -- a computation that when executed blocks until the thread terminates 100 | -- then returns the final value of the thread. 101 | forkIOWithUnmask 102 | :: ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) 103 | forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask 104 | 105 | -- | Like @Control.Concurrent.'Control.Concurrent.forkOnWithUnmask'@ but returns 106 | -- a computation that when executed blocks until the thread terminates 107 | -- then returns the final value of the thread. 108 | forkOnWithUnmask 109 | :: Int -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) 110 | forkOnWithUnmask = forkWithUnmask . Control.Concurrent.forkOnWithUnmask 111 | 112 | 113 | -------------------------------------------------------------------------------- 114 | -- Utils 115 | -------------------------------------------------------------------------------- 116 | 117 | fork :: (IO () -> IO ThreadId) -> (IO a -> IO (ThreadId, IO (Result a))) 118 | fork doFork = \a -> do 119 | res <- newEmptyMVar 120 | tid <- mask $ \restore -> doFork $ try (restore a) >>= putMVar res 121 | return (tid, readMVar res) 122 | 123 | forkWithUnmask 124 | :: (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId) 125 | -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) 126 | forkWithUnmask doForkWithUnmask = \f -> do 127 | res <- newEmptyMVar 128 | tid <- mask $ \restore -> 129 | doForkWithUnmask $ \unmask -> 130 | try (restore $ f unmask) >>= putMVar res 131 | return (tid, readMVar res) 132 | 133 | 134 | -------------------------------------------------------------------------------- 135 | -- Results 136 | -------------------------------------------------------------------------------- 137 | 138 | -- | A result of a thread is either some exception that was thrown in the thread 139 | -- and wasn't catched or the actual value that was returned by the thread. 140 | type Result a = Either SomeException a 141 | 142 | -- | Retrieve the actual value from the result. 143 | -- 144 | -- When the result is 'SomeException' the exception is thrown. 145 | result :: Result a -> IO a 146 | result = either throwIO return 147 | -------------------------------------------------------------------------------- /Control/Concurrent/Thread/Group.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP 2 | , DeriveDataTypeable 3 | , NoImplicitPrelude 4 | , ImpredicativeTypes 5 | , RankNTypes #-} 6 | 7 | #if __GLASGOW_HASKELL__ >= 701 8 | {-# LANGUAGE Trustworthy #-} 9 | #endif 10 | 11 | -------------------------------------------------------------------------------- 12 | -- | 13 | -- Module : Control.Concurrent.Thread.Group 14 | -- Copyright : (c) 2010-2012 Bas van Dijk & Roel van Dijk 15 | -- License : BSD3 (see the file LICENSE) 16 | -- Maintainer : Bas van Dijk 17 | -- , Roel van Dijk 18 | -- 19 | -- This module extends @Control.Concurrent.Thread@ with the ability to wait for 20 | -- a group of threads to terminate. 21 | -- 22 | -- This module exports equivalently named functions from @Control.Concurrent@, 23 | -- (@GHC.Conc@), and @Control.Concurrent.Thread@. Avoid ambiguities by importing 24 | -- this module qualified. May we suggest: 25 | -- 26 | -- @ 27 | -- import Control.Concurrent.Thread.Group ( ThreadGroup ) 28 | -- import qualified Control.Concurrent.Thread.Group as ThreadGroup ( ... ) 29 | -- @ 30 | -- 31 | -------------------------------------------------------------------------------- 32 | 33 | module Control.Concurrent.Thread.Group 34 | ( ThreadGroup 35 | , new 36 | , nrOfRunning 37 | , wait 38 | , waitN 39 | 40 | -- * Forking threads 41 | , forkIO 42 | , forkOS 43 | , forkOn 44 | , forkIOWithUnmask 45 | , forkOnWithUnmask 46 | ) where 47 | 48 | 49 | -------------------------------------------------------------------------------- 50 | -- Imports 51 | -------------------------------------------------------------------------------- 52 | 53 | -- from base: 54 | import qualified Control.Concurrent ( forkOS 55 | , forkIOWithUnmask 56 | , forkOnWithUnmask 57 | ) 58 | import Control.Concurrent ( ThreadId ) 59 | import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar ) 60 | import Control.Exception ( try, mask ) 61 | import Control.Monad ( return, (>>=), when ) 62 | import Data.Function ( (.), ($) ) 63 | import Data.Functor ( fmap ) 64 | import Data.Eq ( Eq ) 65 | import Data.Ord ( (>=) ) 66 | import Data.Int ( Int ) 67 | import Data.Typeable ( Typeable ) 68 | import Prelude ( ($!), (+), subtract ) 69 | import System.IO ( IO ) 70 | 71 | -- from stm: 72 | import Control.Concurrent.STM.TVar ( TVar, newTVarIO, readTVar, writeTVar ) 73 | import Control.Concurrent.STM ( STM, atomically, retry ) 74 | 75 | -- from threads: 76 | import Control.Concurrent.Thread ( Result ) 77 | import Control.Concurrent.Raw ( rawForkIO, rawForkOn ) 78 | #ifdef __HADDOCK_VERSION__ 79 | import qualified Control.Concurrent.Thread as Thread ( forkIO 80 | , forkOS 81 | , forkOn 82 | , forkIOWithUnmask 83 | , forkOnWithUnmask 84 | ) 85 | #endif 86 | 87 | 88 | -------------------------------------------------------------------------------- 89 | -- * Thread groups 90 | -------------------------------------------------------------------------------- 91 | 92 | {-| A @ThreadGroup@ can be understood as a counter which counts the number of 93 | threads that were added to the group minus the ones that have terminated. 94 | 95 | More formally a @ThreadGroup@ has the following semantics: 96 | 97 | * 'new' initializes the counter to 0. 98 | 99 | * Forking a thread increments the counter. 100 | 101 | * When a forked thread terminates, whether normally or by raising an exception, 102 | the counter is decremented. 103 | 104 | * 'nrOfRunning' yields a transaction that returns the counter. 105 | 106 | * 'wait' blocks as long as the counter is greater than 0. 107 | 108 | * 'waitN' blocks as long as the counter is greater or equal to the 109 | specified number. 110 | -} 111 | newtype ThreadGroup = ThreadGroup (TVar Int) deriving (Eq, Typeable) 112 | 113 | -- | Create an empty group of threads. 114 | new :: IO ThreadGroup 115 | new = fmap ThreadGroup $ newTVarIO 0 116 | 117 | {-| Yield a transaction that returns the number of running threads in the 118 | group. 119 | 120 | Note that because this function yields a 'STM' computation, the returned number 121 | is guaranteed to be consistent inside the transaction. 122 | -} 123 | nrOfRunning :: ThreadGroup -> STM Int 124 | nrOfRunning (ThreadGroup numThreadsTV) = readTVar numThreadsTV 125 | 126 | -- | Block until all threads in the group have terminated. 127 | -- 128 | -- Note that: @wait = 'waitN' 1@. 129 | wait :: ThreadGroup -> IO () 130 | wait = waitN 1 131 | 132 | -- | Block until there are fewer than @N@ running threads in the group. 133 | waitN :: Int -> ThreadGroup -> IO () 134 | waitN i tg = atomically $ nrOfRunning tg >>= \n -> when (n >= i) retry 135 | 136 | 137 | -------------------------------------------------------------------------------- 138 | -- * Forking threads 139 | -------------------------------------------------------------------------------- 140 | 141 | -- | Same as @Control.Concurrent.Thread.'Thread.forkIO'@ but additionaly adds 142 | -- the thread to the group. 143 | forkIO :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) 144 | forkIO = fork rawForkIO 145 | 146 | -- | Same as @Control.Concurrent.Thread.'Thread.forkOS'@ but additionaly adds 147 | -- the thread to the group. 148 | forkOS :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) 149 | forkOS = fork Control.Concurrent.forkOS 150 | 151 | -- | Same as @Control.Concurrent.Thread.'Thread.forkOn'@ but 152 | -- additionaly adds the thread to the group. 153 | forkOn :: Int -> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) 154 | forkOn = fork . rawForkOn 155 | 156 | -- | Same as @Control.Concurrent.Thread.'Thread.forkIOWithUnmask'@ but 157 | -- additionaly adds the thread to the group. 158 | forkIOWithUnmask 159 | :: ThreadGroup 160 | -> ((forall b. IO b -> IO b) -> IO a) 161 | -> IO (ThreadId, IO (Result a)) 162 | forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask 163 | 164 | -- | Like @Control.Concurrent.Thread.'Thread.forkOnWithUnmask'@ but 165 | -- additionaly adds the thread to the group. 166 | forkOnWithUnmask 167 | :: Int 168 | -> ThreadGroup 169 | -> ((forall b. IO b -> IO b) -> IO a) 170 | -> IO (ThreadId, IO (Result a)) 171 | forkOnWithUnmask = forkWithUnmask . Control.Concurrent.forkOnWithUnmask 172 | 173 | 174 | -------------------------------------------------------------------------------- 175 | -- Utils 176 | -------------------------------------------------------------------------------- 177 | 178 | fork :: (IO () -> IO ThreadId) 179 | -> ThreadGroup 180 | -> IO a 181 | -> IO (ThreadId, IO (Result a)) 182 | fork doFork (ThreadGroup numThreadsTV) a = do 183 | res <- newEmptyMVar 184 | tid <- mask $ \restore -> do 185 | atomically $ modifyTVar numThreadsTV (+ 1) 186 | doFork $ do 187 | try (restore a) >>= putMVar res 188 | atomically $ modifyTVar numThreadsTV (subtract 1) 189 | return (tid, readMVar res) 190 | 191 | forkWithUnmask 192 | :: (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId) 193 | -> ThreadGroup 194 | -> ((forall b. IO b -> IO b) -> IO a) 195 | -> IO (ThreadId, IO (Result a)) 196 | forkWithUnmask doForkWithUnmask = \(ThreadGroup numThreadsTV) f -> do 197 | res <- newEmptyMVar 198 | tid <- mask $ \restore -> do 199 | atomically $ modifyTVar numThreadsTV (+ 1) 200 | doForkWithUnmask $ \unmask -> do 201 | try (restore $ f unmask) >>= putMVar res 202 | atomically $ modifyTVar numThreadsTV (subtract 1) 203 | return (tid, readMVar res) 204 | 205 | -- | Strictly modify the contents of a 'TVar'. 206 | modifyTVar :: TVar a -> (a -> a) -> STM () 207 | modifyTVar tv f = readTVar tv >>= writeTVar tv .! f 208 | 209 | -- | Strict function composition 210 | (.!) :: (b -> c) -> (a -> b) -> (a -> c) 211 | f .! g = \x -> f $! g x 212 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010-2012 Bas van Dijk & Roel van Dijk 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * The names of Bas van Dijk, Roel van Dijk and the names of 18 | contributors may NOT be used to endorse or promote products 19 | derived from this software without specific prior written 20 | permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 26 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 30 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 31 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 32 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | [![Hackage](https://img.shields.io/hackage/v/threads.svg)](https://hackage.haskell.org/package/threads) 2 | [![Build Status](https://travis-ci.org/basvandijk/threads.svg)](https://travis-ci.org/basvandijk/threads) 3 | 4 | This package provides functions to fork threads and wait for their 5 | result, whether it's an exception or a normal value. 6 | 7 | Besides waiting for the termination of a single thread this packages 8 | also provides functions to wait for a group of threads to terminate. 9 | 10 | This package is similar to the [threadmanager], [async] and [spawn] 11 | packages. The advantages of this package are: 12 | 13 | * Simpler API. 14 | 15 | * More efficient in both space and time. 16 | 17 | * No space-leak when forking a large number of threads. 18 | 19 | * Correct handling of asynchronous exceptions. 20 | 21 | * GHC specific functionality like [forkOnIO] and [forkIOUnmasked]. 22 | 23 | [threadmanager]: http://hackage.haskell.org/package/threadmanager 24 | [async]: http://hackage.haskell.org/package/async 25 | [spawn]: http://hackage.haskell.org/package/spawn 26 | [forkOnIO]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/GHC-Conc-Sync.html#v:forkOnIO 27 | [forkIOUnmasked]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/GHC-Conc-Sync.html#v:forkOnIOUnmasked 28 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "default" }: 2 | 3 | let 4 | 5 | inherit (nixpkgs) pkgs; 6 | 7 | haskellPackages = if compiler == "default" 8 | then pkgs.haskellPackages 9 | else pkgs.haskell.packages.${compiler}; 10 | 11 | drv = haskellPackages.callPackage (import ./threads.nix) {}; 12 | 13 | in 14 | 15 | if pkgs.lib.inNixShell then drv.env else drv 16 | -------------------------------------------------------------------------------- /test/test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, ImpredicativeTypes #-} 2 | 3 | module Main where 4 | 5 | -------------------------------------------------------------------------------- 6 | -- Imports 7 | -------------------------------------------------------------------------------- 8 | 9 | -- from base: 10 | import Control.Concurrent ( ThreadId, threadDelay, throwTo, killThread ) 11 | import Control.Exception ( Exception, fromException 12 | , AsyncException(ThreadKilled) 13 | , throwIO, mask_ 14 | , getMaskingState, MaskingState(MaskedInterruptible) 15 | ) 16 | import Control.Monad ( return, (>>=), replicateM_ ) 17 | import Data.Bool ( Bool(False, True) ) 18 | import Data.Eq ( Eq, (==) ) 19 | import Data.Either ( either ) 20 | import Data.Function ( (.), ($), id, const, flip ) 21 | import Data.Functor ( Functor(fmap), (<$>) ) 22 | import Data.Int ( Int ) 23 | import Data.Maybe ( Maybe, maybe ) 24 | import Data.IORef ( newIORef, readIORef, writeIORef ) 25 | import Data.Typeable ( Typeable ) 26 | import System.Timeout ( timeout ) 27 | import System.IO ( IO ) 28 | import Text.Show ( Show ) 29 | import Prelude ( (*) ) 30 | 31 | -- from concurrent-extra: 32 | import qualified Control.Concurrent.Lock as Lock 33 | 34 | -- from stm: 35 | import Control.Concurrent.STM ( atomically ) 36 | 37 | -- from HUnit: 38 | import Test.HUnit ( Assertion, assert ) 39 | 40 | -- from test-framework: 41 | import Test.Framework ( Test, defaultMain, testGroup ) 42 | 43 | -- from test-framework-hunit: 44 | import Test.Framework.Providers.HUnit ( testCase ) 45 | 46 | -- from threads: 47 | import Control.Concurrent.Thread ( Result, result ) 48 | import Control.Concurrent.Thread.Group ( ThreadGroup ) 49 | 50 | import qualified Control.Concurrent.Thread as Thread 51 | import qualified Control.Concurrent.Thread.Group as ThreadGroup 52 | 53 | 54 | -------------------------------------------------------------------------------- 55 | -- Tests 56 | -------------------------------------------------------------------------------- 57 | 58 | main :: IO () 59 | main = defaultMain tests 60 | 61 | tests :: [Test] 62 | tests = [ testGroup "Thread" $ 63 | [ testGroup "forkIO" $ 64 | [ testCase "wait" $ test_wait Thread.forkIO 65 | , testCase "maskingState" $ test_maskingState Thread.forkIO 66 | , testCase "sync exception" $ test_sync_exception Thread.forkIO 67 | , testCase "async exception" $ test_async_exception Thread.forkIO 68 | ] 69 | , testGroup "forkOS" $ 70 | [ testCase "wait" $ test_wait Thread.forkOS 71 | , testCase "maskingState" $ test_maskingState Thread.forkOS 72 | , testCase "sync exception" $ test_sync_exception Thread.forkOS 73 | , testCase "async exception" $ test_async_exception Thread.forkOS 74 | ] 75 | , testGroup "forkOn 0" $ 76 | [ testCase "wait" $ test_wait $ Thread.forkOn 0 77 | , testCase "maskingState" $ test_maskingState $ Thread.forkOn 0 78 | , testCase "sync exception" $ test_sync_exception $ Thread.forkOn 0 79 | , testCase "async exception" $ test_async_exception $ Thread.forkOn 0 80 | ] 81 | , testGroup "forkIOWithUnmask" $ 82 | [ testCase "wait" $ test_wait $ wrapUnmask Thread.forkIOWithUnmask 83 | , testCase "sync exception" $ test_sync_exception $ wrapUnmask Thread.forkIOWithUnmask 84 | , testCase "async exception" $ test_async_exception $ wrapUnmask Thread.forkIOWithUnmask 85 | ] 86 | , testGroup "forkOnWithUnmask 0" $ 87 | [ testCase "wait" $ test_wait $ wrapUnmask $ Thread.forkOnWithUnmask 0 88 | , testCase "sync exception" $ test_sync_exception $ wrapUnmask $ Thread.forkOnWithUnmask 0 89 | , testCase "async exception" $ test_async_exception $ wrapUnmask $ Thread.forkOnWithUnmask 0 90 | ] 91 | ] 92 | , testGroup "ThreadGroup" $ 93 | [ testGroup "forkIO" $ 94 | [ testCase "wait" $ wrapIO test_wait 95 | , testCase "maskingState" $ wrapIO test_maskingState 96 | , testCase "sync exception" $ wrapIO test_sync_exception 97 | , testCase "async exception" $ wrapIO test_async_exception 98 | 99 | , testCase "group single wait" $ test_group_single_wait ThreadGroup.forkIO 100 | , testCase "group nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkIO 101 | ] 102 | , testGroup "forkOS" $ 103 | [ testCase "wait" $ wrapOS test_wait 104 | , testCase "maskingState" $ wrapOS test_maskingState 105 | , testCase "sync exception" $ wrapOS test_sync_exception 106 | , testCase "async exception" $ wrapOS test_async_exception 107 | 108 | , testCase "group single wait" $ test_group_single_wait ThreadGroup.forkOS 109 | , testCase "group nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkOS 110 | ] 111 | , testGroup "forkOn 0" $ 112 | [ testCase "wait" $ wrapOn_0 test_wait 113 | , testCase "maskingState" $ wrapOn_0 test_maskingState 114 | , testCase "sync exception" $ wrapOn_0 test_sync_exception 115 | , testCase "async exception" $ wrapOn_0 test_async_exception 116 | 117 | , testCase "group single wait" $ test_group_single_wait $ ThreadGroup.forkOn 0 118 | , testCase "group nrOfRunning" $ test_group_nrOfRunning $ ThreadGroup.forkOn 0 119 | ] 120 | , testGroup "forkIOWithUnmask" $ 121 | [ testCase "wait" $ wrapIOWithUnmask test_wait 122 | , testCase "sync exception" $ wrapIOWithUnmask test_sync_exception 123 | , testCase "async exception" $ wrapIOWithUnmask test_async_exception 124 | 125 | , testCase "group single wait" $ test_group_single_wait $ wrapUnmask . ThreadGroup.forkIOWithUnmask 126 | , testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask . ThreadGroup.forkIOWithUnmask 127 | ] 128 | , testGroup "forkOnWithUnmask 0" $ 129 | [ testCase "wait" $ wrapOnWithUnmask test_wait 130 | , testCase "sync exception" $ wrapOnWithUnmask test_sync_exception 131 | , testCase "async exception" $ wrapOnWithUnmask test_async_exception 132 | 133 | , testCase "group single wait" $ test_group_single_wait $ wrapUnmask . ThreadGroup.forkOnWithUnmask 0 134 | , testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask . ThreadGroup.forkOnWithUnmask 0 135 | ] 136 | ] 137 | ] 138 | 139 | -- Exactly 1 moment. Currently equal to 0.005 seconds. 140 | a_moment :: Int 141 | a_moment = 5000 142 | 143 | 144 | -------------------------------------------------------------------------------- 145 | -- General properties 146 | -------------------------------------------------------------------------------- 147 | 148 | type Fork a = IO a -> IO (ThreadId, IO (Result a)) 149 | 150 | wrapUnmask :: ((b -> a) -> t) -> a -> t 151 | wrapUnmask forkWithUnmask = \m -> forkWithUnmask $ const m 152 | 153 | test_wait :: Fork () -> Assertion 154 | test_wait fork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do 155 | r <- newIORef False 156 | (_, wait) <- fork $ do 157 | threadDelay $ 2 * a_moment 158 | writeIORef r True 159 | _ <- wait 160 | readIORef r 161 | 162 | test_maskingState :: Fork Bool -> Assertion 163 | test_maskingState fork = do (_, wait) <- mask_ $ fork $ 164 | (MaskedInterruptible ==) <$> getMaskingState 165 | wait >>= result >>= assert 166 | 167 | test_sync_exception :: Fork () -> Assertion 168 | test_sync_exception fork = assert $ do 169 | (_, wait) <- fork $ throwIO MyException 170 | waitForException MyException wait 171 | 172 | waitForException :: (Exception e, Eq e) => e -> IO (Result a) -> IO Bool 173 | waitForException e wait = wait <&> either (justEq e . fromException) 174 | (const False) 175 | 176 | test_async_exception :: Fork () -> Assertion 177 | test_async_exception fork = assert $ do 178 | l <- Lock.newAcquired 179 | (tid, wait) <- fork $ Lock.acquire l 180 | throwTo tid MyException 181 | waitForException MyException wait 182 | 183 | data MyException = MyException deriving (Show, Eq, Typeable) 184 | instance Exception MyException 185 | 186 | test_killThread :: Fork () -> Assertion 187 | test_killThread fork = assert $ do 188 | l <- Lock.newAcquired 189 | (tid, wait) <- fork $ Lock.acquire l 190 | killThread tid 191 | waitForException ThreadKilled wait 192 | 193 | 194 | -------------------------------------------------------------------------------- 195 | -- ThreadGroup 196 | -------------------------------------------------------------------------------- 197 | 198 | wrapIO :: (Fork a -> IO b) -> IO b 199 | wrapIO = wrap ThreadGroup.forkIO 200 | 201 | wrapOS :: (Fork a -> IO b) -> IO b 202 | wrapOS = wrap ThreadGroup.forkOS 203 | 204 | wrapOn_0 :: (Fork a -> IO b) -> IO b 205 | wrapOn_0 = wrap $ ThreadGroup.forkOn 0 206 | 207 | wrapIOWithUnmask :: (Fork a -> IO b) -> IO b 208 | wrapIOWithUnmask = wrap $ \tg m -> ThreadGroup.forkIOWithUnmask tg (\_ -> m) 209 | 210 | wrapOnWithUnmask :: (Fork a -> IO b) -> IO b 211 | wrapOnWithUnmask = wrap $ \tg m -> ThreadGroup.forkOnWithUnmask 0 tg (\_ -> m) 212 | 213 | wrap :: (ThreadGroup -> Fork a) -> (Fork a -> IO b) -> IO b 214 | wrap doFork test = ThreadGroup.new >>= test . doFork 215 | 216 | test_group_single_wait :: (ThreadGroup -> Fork ()) -> Assertion 217 | test_group_single_wait doFork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do 218 | tg <- ThreadGroup.new 219 | r <- newIORef False 220 | _ <- doFork tg $ do 221 | threadDelay $ 2 * a_moment 222 | writeIORef r True 223 | _ <- ThreadGroup.wait tg 224 | readIORef r 225 | 226 | test_group_nrOfRunning :: (ThreadGroup -> Fork ()) -> Assertion 227 | test_group_nrOfRunning doFork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do 228 | tg <- ThreadGroup.new 229 | l <- Lock.newAcquired 230 | replicateM_ n $ doFork tg $ Lock.acquire l 231 | true <- fmap (== n) $ (atomically $ ThreadGroup.nrOfRunning tg :: IO Int) 232 | Lock.release l 233 | return true 234 | where 235 | -- Don't set this number too big otherwise forkOS might throw an exception 236 | -- indicating that too many OS threads have been created: 237 | n :: Int 238 | n = 100 239 | 240 | 241 | -------------------------------------------------------------------------------- 242 | -- Utils 243 | -------------------------------------------------------------------------------- 244 | 245 | -- | Check if the given value equals 'Just' 'True'. 246 | isJustTrue :: Maybe Bool -> Bool 247 | isJustTrue = maybe False id 248 | 249 | -- | Check if the given value in the 'Maybe' equals the given reference value. 250 | justEq :: Eq a => a -> Maybe a -> Bool 251 | justEq = maybe False . (==) 252 | 253 | -- | A flipped '<$>'. 254 | (<&>) :: (Functor f) => f a -> (a -> b) -> f b 255 | (<&>) = flip (<$>) 256 | -------------------------------------------------------------------------------- /threads.cabal: -------------------------------------------------------------------------------- 1 | name: threads 2 | version: 0.5.1.8 3 | cabal-version: 1.20 4 | build-type: Simple 5 | stability: experimental 6 | author: Bas van Dijk 7 | Roel van Dijk 8 | maintainer: Bas van Dijk 9 | Roel van Dijk 10 | copyright: 2010–2012 Bas van Dijk & Roel van Dijk 11 | license: BSD3 12 | license-file: LICENSE 13 | homepage: https://github.com/basvandijk/threads 14 | bug-reports: https://github.com/basvandijk/threads/issues 15 | category: Concurrency 16 | synopsis: Fork threads and wait for their result 17 | description: This package provides functions to fork threads and 18 | wait for their result, whether it's an exception or a 19 | normal value. 20 | . 21 | Besides waiting for the termination of a single thread 22 | this packages also provides functions to wait for a 23 | group of threads to terminate. 24 | . 25 | This package is similar to the 26 | @threadmanager@, @async@ and @spawn@ packages. 27 | The advantages of this package are: 28 | . 29 | * Simpler API. 30 | . 31 | * More efficient in both space and time. 32 | . 33 | * No space-leak when forking a large number of threads. 34 | . 35 | * Correct handling of asynchronous exceptions. 36 | . 37 | * GHC specific functionality like @forkOn@ and @forkIOWithUnmask@. 38 | 39 | extra-source-files: README.markdown 40 | 41 | tested-with: 42 | GHC==7.2.2, 43 | GHC==7.4.2, 44 | GHC==7.6.3, 45 | GHC==7.8.4, 46 | GHC==7.10.2, 47 | GHC==8.0.1, 48 | GHC==9.4.1 49 | 50 | source-repository head 51 | Type: git 52 | Location: git://github.com/basvandijk/threads.git 53 | 54 | ------------------------------------------------------------------------------- 55 | 56 | library 57 | default-language: Haskell2010 58 | build-depends: base >= 4.4 && < 5 59 | , stm >= 2.1 60 | exposed-modules: Control.Concurrent.Thread 61 | , Control.Concurrent.Thread.Group 62 | other-modules: Control.Concurrent.Raw 63 | ghc-options: -Wall 64 | 65 | ------------------------------------------------------------------------------- 66 | 67 | test-suite test-threads 68 | default-language: Haskell2010 69 | type: exitcode-stdio-1.0 70 | hs-source-dirs: test 71 | main-is: test.hs 72 | ghc-options: -Wall -threaded 73 | 74 | build-depends: threads 75 | , base >= 4.4 && < 5 76 | , stm >= 2.1 77 | , concurrent-extra >= 0.5.1 78 | , HUnit >= 1.2.2 79 | , test-framework >= 0.2.4 80 | , test-framework-hunit >= 0.2.4 81 | -------------------------------------------------------------------------------- /threads.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, concurrent-extra, HUnit, stdenv, stm 2 | , test-framework, test-framework-hunit 3 | }: 4 | mkDerivation { 5 | pname = "threads"; 6 | version = "HEAD"; 7 | src = ./.; 8 | libraryHaskellDepends = [ base stm ]; 9 | testHaskellDepends = [ 10 | base concurrent-extra HUnit stm test-framework test-framework-hunit 11 | ]; 12 | homepage = "https://github.com/basvandijk/threads"; 13 | description = "Fork threads and wait for their result"; 14 | license = stdenv.lib.licenses.bsd3; 15 | } 16 | --------------------------------------------------------------------------------