├── .ghci ├── .gitignore ├── Control └── Concurrent │ ├── ParallelIO.hs │ └── ParallelIO │ ├── Benchmark.hs │ ├── Compat.hs │ ├── Fuzz.hs │ ├── Global.hs │ ├── Local.hs │ └── Tests.hs ├── LICENSE ├── README ├── Setup.lhs ├── parallel-io.cabal └── release /.ghci: -------------------------------------------------------------------------------- 1 | :set -Wall 2 | :l "Control/Concurrent/ParallelIO/Tests.hs" 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Cabal temporary stuff 2 | dist/ 3 | dist-newstyle/ 4 | *.o 5 | *.hi 6 | 7 | -------------------------------------------------------------------------------- /Control/Concurrent/ParallelIO.hs: -------------------------------------------------------------------------------- 1 | -- | Combinators for executing IO actions in parallel on a thread pool. 2 | -- 3 | -- This module just reexports "Control.Concurrent.ParallelIO.Global": this contains versions of 4 | -- the combinators that make use of a single global thread pool with as many threads as there are 5 | -- capabilities. 6 | -- 7 | -- For finer-grained control, you can use "Control.Concurrent.ParallelIO.Local" instead, which 8 | -- gives you control over the creation of the pool. 9 | module Control.Concurrent.ParallelIO ( 10 | module Control.Concurrent.ParallelIO.Global 11 | ) where 12 | 13 | -- By default, just export the user-friendly Global interface. 14 | -- Those who want more power can import Local explicitly. 15 | import Control.Concurrent.ParallelIO.Global 16 | -------------------------------------------------------------------------------- /Control/Concurrent/ParallelIO/Benchmark.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.IORef 4 | import Data.Time.Clock 5 | 6 | import Control.Concurrent.ParallelIO.Global 7 | 8 | 9 | n :: Int 10 | n = 1000000 11 | 12 | main :: IO () 13 | main = do 14 | r <- newIORef (0 :: Int) 15 | let incRef = atomicModifyIORef r (\a -> (a, a)) 16 | time $ parallel_ $ replicate n $ incRef 17 | v <- readIORef r 18 | stopGlobalPool 19 | print v 20 | 21 | time :: IO a -> IO a 22 | time action = do 23 | start <- getCurrentTime 24 | result <- action 25 | stop <- getCurrentTime 26 | print $ stop `diffUTCTime` start 27 | return result -------------------------------------------------------------------------------- /Control/Concurrent/ParallelIO/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Control.Concurrent.ParallelIO.Compat ( 3 | mask, mask_ 4 | ) where 5 | 6 | #if MIN_VERSION_base(4,3,0) 7 | import Control.Exception ( mask, mask_ ) 8 | #else 9 | import Control.Exception ( blocked, block, unblock ) 10 | 11 | mask :: ((IO a -> IO a) -> IO b) -> IO b 12 | mask io = blocked >>= \b -> if b then io id else block $ io unblock 13 | 14 | mask_ :: IO a -> IO a 15 | mask_ io = mask $ \_ -> io 16 | #endif 17 | -------------------------------------------------------------------------------- /Control/Concurrent/ParallelIO/Fuzz.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.IORef 4 | import qualified Numeric 5 | 6 | import System.Random 7 | 8 | import Control.Concurrent 9 | import Control.Concurrent.ParallelIO.Local 10 | 11 | import Control.Monad 12 | 13 | 14 | -- | Range for number of threads to spawn 15 | sPAWN_RANGE = (0, 100) 16 | 17 | -- | Delay range in microseconds 18 | dELAY_RANGE = (0, 1000000) 19 | 20 | -- | Out of 100 parallel actions, how many should recursively spawn? 21 | sPAWN_PERCENTAGE :: Int 22 | sPAWN_PERCENTAGE = 2 23 | 24 | -- | Number of threads to have processing work items 25 | mAX_WORKERS = 3 26 | 27 | 28 | showFloat :: RealFloat a => a -> String 29 | showFloat x = Numeric.showFFloat (Just 2) x "" 30 | 31 | 32 | expected :: Fractional b => (Int, Int) -> b 33 | expected (top, bottom) = fromIntegral (top + bottom) / 2 34 | 35 | main :: IO () 36 | main = do 37 | -- Birth rate is the rate at which new work items enter the queue 38 | putStrLn $ "Expected birth rate: " ++ showFloat ((expected sPAWN_RANGE * (fromIntegral sPAWN_PERCENTAGE / 100) * fromIntegral mAX_WORKERS) / (expected dELAY_RANGE / 1000000) :: Double) ++ " items/second" 39 | -- Service rate is the rate at which work items are removed from the pool 40 | putStrLn $ "Expected service rate: " ++ showFloat (fromIntegral mAX_WORKERS / (expected dELAY_RANGE / 1000000) :: Double) ++ " items/second" 41 | -- We are balanced on average if birth rate == service rate, i.e. expected sPAWN_RANGE * (fromIntegral sPAWN_PERCENTAGE / 100) == 1 42 | putStrLn $ "Balance factor (should be 1): " ++ showFloat (expected sPAWN_RANGE * (fromIntegral sPAWN_PERCENTAGE / 100) :: Double) 43 | withPool mAX_WORKERS $ \pool -> forever (fuzz pool) 44 | 45 | fuzz pool = do 46 | n <- randomRIO sPAWN_RANGE 47 | tid <- myThreadId 48 | putStrLn $ show tid ++ ":\t" ++ show n 49 | parallel_ pool $ flip map [1..n] $ \i -> do 50 | should_spawn <- fmap (<= sPAWN_PERCENTAGE) $ randomRIO (1, 100) 51 | nested_tid <- myThreadId 52 | 53 | putStrLn $ show nested_tid ++ ":\trunning " ++ show i ++ if should_spawn then " (recursing)" else "" 54 | 55 | randomRIO dELAY_RANGE >>= threadDelay 56 | 57 | putStrLn $ show nested_tid ++ ":\twoke up" 58 | 59 | when should_spawn $ fuzz pool 60 | -------------------------------------------------------------------------------- /Control/Concurrent/ParallelIO/Global.hs: -------------------------------------------------------------------------------- 1 | -- | Parallelism combinators with an implicit global thread-pool. 2 | -- 3 | -- The most basic example of usage is: 4 | -- 5 | -- > main = parallel_ [putStrLn "Echo", putStrLn " in parallel"] >> stopGlobalPool 6 | -- 7 | -- Make sure that you compile with @-threaded@ and supply @+RTS -N2 -RTS@ 8 | -- to the generated Haskell executable, or you won't get any parallelism. 9 | -- 10 | -- If you plan to allow your worker items to block, then you should read the documentation for 'extraWorkerWhileBlocked'. 11 | -- 12 | -- The "Control.Concurrent.ParallelIO.Local" module provides a more general 13 | -- interface which allows explicit passing of pools and control of their size. 14 | -- This module is implemented on top of that one by maintaining a shared global thread 15 | -- pool with one thread per capability. 16 | module Control.Concurrent.ParallelIO.Global ( 17 | -- * Executing actions 18 | parallel_, parallelE_, parallel, parallelE, 19 | parallelInterleaved, parallelInterleavedE, 20 | parallelFirst, parallelFirstE, 21 | 22 | -- * Global pool management 23 | globalPool, stopGlobalPool, 24 | extraWorkerWhileBlocked, 25 | 26 | -- * Advanced global pool management 27 | spawnPoolWorker, killPoolWorker 28 | ) where 29 | 30 | import GHC.Conc 31 | 32 | import Control.Exception 33 | 34 | import System.IO.Unsafe 35 | 36 | import qualified Control.Concurrent.ParallelIO.Local as L 37 | 38 | -- | The global thread pool. Contains as many threads as there are capabilities. 39 | -- 40 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 41 | {-# NOINLINE globalPool #-} 42 | globalPool :: L.Pool 43 | globalPool = unsafePerformIO $ L.startPool numCapabilities 44 | 45 | -- | In order to reliably make use of the global parallelism combinators, 46 | -- you must invoke this function after all calls to those combinators have 47 | -- finished. A good choice might be at the end of 'main'. 48 | -- 49 | -- See also 'L.stopPool'. 50 | stopGlobalPool :: IO () 51 | stopGlobalPool = L.stopPool globalPool 52 | -- TODO: could I lift the requirement to call this function with a touchPool function after the parallel combinators? 53 | 54 | -- | Wrap any IO action used from your worker threads that may block with this method: 55 | -- it temporarily spawns another worker thread to make up for the loss of the old blocked 56 | -- worker. 57 | -- 58 | -- See also 'L.extraWorkerWhileBlocked'. 59 | extraWorkerWhileBlocked :: IO a -> IO a 60 | extraWorkerWhileBlocked = L.extraWorkerWhileBlocked globalPool 61 | 62 | -- | Internal method for adding extra unblocked threads to a pool if one of the current 63 | -- worker threads is going to be temporarily blocked. Unrestricted use of this is unsafe, 64 | -- so we reccomend that you use the 'extraWorkerWhileBlocked' function instead if possible. 65 | -- 66 | -- See also 'L.spawnPoolWorkerFor'. 67 | spawnPoolWorker :: IO () 68 | spawnPoolWorker = L.spawnPoolWorkerFor globalPool 69 | 70 | -- | Internal method for removing threads from a pool after one of the threads on the pool 71 | -- becomes newly unblocked. Unrestricted use of this is unsafe, so we reccomend that you use 72 | -- the 'extraWorkerWhileBlocked' function instead if possible. 73 | -- 74 | -- See also 'L.killPoolWorkerFor'. 75 | killPoolWorker :: IO () 76 | killPoolWorker = L.killPoolWorkerFor globalPool 77 | 78 | -- | Execute the given actions in parallel on the global thread pool. 79 | -- 80 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 81 | -- 82 | -- See also 'L.parallel_'. 83 | parallel_ :: [IO a] -> IO () 84 | parallel_ = L.parallel_ globalPool 85 | 86 | -- | Execute the given actions in parallel on the global thread pool, reporting exceptions explicitly. 87 | -- 88 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 89 | -- 90 | -- See also 'L.parallelE_'. 91 | parallelE_ :: [IO a] -> IO [Maybe SomeException] 92 | parallelE_ = L.parallelE_ globalPool 93 | 94 | -- | Execute the given actions in parallel on the global thread pool, 95 | -- returning the results in the same order as the corresponding actions. 96 | -- 97 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 98 | -- 99 | -- See also 'L.parallel'. 100 | parallel :: [IO a] -> IO [a] 101 | parallel = L.parallel globalPool 102 | 103 | -- | Execute the given actions in parallel on the global thread pool, 104 | -- returning the results in the same order as the corresponding actions and reporting exceptions explicitly. 105 | -- 106 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 107 | -- 108 | -- See also 'L.parallelE'. 109 | parallelE :: [IO a] -> IO [Either SomeException a] 110 | parallelE = L.parallelE globalPool 111 | 112 | -- | Execute the given actions in parallel on the global thread pool, 113 | -- returning the results in the approximate order of completion. 114 | -- 115 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 116 | -- 117 | -- See also 'L.parallelInterleaved'. 118 | parallelInterleaved :: [IO a] -> IO [a] 119 | parallelInterleaved = L.parallelInterleaved globalPool 120 | 121 | -- | Execute the given actions in parallel on the global thread pool, 122 | -- returning the results in the approximate order of completion and reporting exceptions explicitly. 123 | -- 124 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 125 | -- 126 | -- See also 'L.parallelInterleavedE'. 127 | parallelInterleavedE :: [IO a] -> IO [Either SomeException a] 128 | parallelInterleavedE = L.parallelInterleavedE globalPool 129 | 130 | -- | Run the list of computations in parallel, returning the result of the first 131 | -- thread that completes with (Just x), if any. 132 | -- 133 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 134 | -- 135 | -- See also 'L.parallelFirst'. 136 | parallelFirst :: [IO (Maybe a)] -> IO (Maybe a) 137 | parallelFirst = L.parallelFirst globalPool 138 | 139 | -- | Run the list of computations in parallel, returning the result of the first 140 | -- thread that completes with (Just x), if any, and reporting any exception explicitly. 141 | -- 142 | -- Users of the global pool must call 'stopGlobalPool' from the main thread at the end of their program. 143 | -- 144 | -- See also 'L.parallelFirstE'. 145 | parallelFirstE :: [IO (Maybe a)] -> IO (Maybe (Either SomeException a)) 146 | parallelFirstE = L.parallelFirstE globalPool -------------------------------------------------------------------------------- /Control/Concurrent/ParallelIO/Local.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | -- | Parallelism combinators with explicit thread-pool creation and 3 | -- passing. 4 | -- 5 | -- The most basic example of usage is: 6 | -- 7 | -- > main = withPool 2 $ \pool -> parallel_ pool [putStrLn "Echo", putStrLn " in parallel"] 8 | -- 9 | -- Make sure that you compile with @-threaded@ and supply @+RTS -N2 -RTS@ 10 | -- to the generated Haskell executable, or you won't get any parallelism. 11 | -- 12 | -- If you plan to allow your worker items to block, then you should read the documentation for 'extraWorkerWhileBlocked'. 13 | -- 14 | -- The "Control.Concurrent.ParallelIO.Global" module is implemented 15 | -- on top of this one by maintaining a shared global thread pool 16 | -- with one thread per capability. 17 | module Control.Concurrent.ParallelIO.Local ( 18 | -- * Executing actions 19 | parallel_, parallelE_, parallel, parallelE, 20 | parallelInterleaved, parallelInterleavedE, 21 | parallelFirst, parallelFirstE, 22 | 23 | -- * Pool management 24 | Pool, withPool, startPool, stopPool, 25 | extraWorkerWhileBlocked, 26 | 27 | -- * Advanced pool management 28 | spawnPoolWorkerFor, killPoolWorkerFor 29 | ) where 30 | 31 | import Control.Concurrent.ParallelIO.Compat 32 | 33 | import Control.Concurrent 34 | import Control.Exception 35 | import qualified Control.Exception as E 36 | import Control.Monad 37 | 38 | import System.IO 39 | 40 | 41 | catchNonThreadKilled :: IO a -> (SomeException -> IO a) -> IO a 42 | catchNonThreadKilled act handler = act `E.catch` \e -> case fromException e of Just ThreadKilled -> throwIO e; _ -> handler e 43 | 44 | onNonThreadKilledException :: IO a -> IO b -> IO a 45 | onNonThreadKilledException act handler = catchNonThreadKilled act (\e -> handler >> throwIO e) 46 | 47 | reflectExceptionsTo :: ThreadId -> IO () -> IO () 48 | reflectExceptionsTo tid act = catchNonThreadKilled act (throwTo tid) 49 | 50 | 51 | -- | A thread pool, containing a maximum number of threads. The best way to 52 | -- construct one of these is using 'withPool'. 53 | data Pool = Pool { 54 | pool_threadcount :: Int, 55 | pool_sem :: QSem 56 | } 57 | 58 | -- | A slightly unsafe way to construct a pool. Make a pool from the maximum 59 | -- number of threads you wish it to execute (including the main thread 60 | -- in the count). 61 | -- 62 | -- If you use this variant then ensure that you insert a call to 'stopPool' 63 | -- somewhere in your program after all users of that pool have finished. 64 | -- 65 | -- A better alternative is to see if you can use the 'withPool' variant. 66 | startPool :: Int -> IO Pool 67 | startPool threadcount 68 | | threadcount < 1 = error $ "startPool: thread count must be strictly positive (was " ++ show threadcount ++ ")" 69 | | otherwise = fmap (Pool threadcount) $ newQSem (threadcount - 1) 70 | 71 | -- | Clean up a thread pool. If you don't call this from the main thread then no one holds the queue, 72 | -- the queue gets GC'd, the threads find themselves blocked indefinitely, and you get exceptions. 73 | -- 74 | -- This cleanly shuts down the threads so the queue isn't important and you don't get 75 | -- exceptions. 76 | -- 77 | -- Only call this /after/ all users of the pool have completed, or your program may 78 | -- block indefinitely. 79 | stopPool :: Pool -> IO () 80 | stopPool pool = replicateM_ (pool_threadcount pool - 1) $ killPoolWorkerFor pool 81 | 82 | -- | A safe wrapper around 'startPool' and 'stopPool'. Executes an 'IO' action using a newly-created 83 | -- pool with the specified number of threads and cleans it up at the end. 84 | withPool :: Int -> (Pool -> IO a) -> IO a 85 | withPool threadcount = bracket (startPool threadcount) stopPool 86 | 87 | 88 | -- | You should wrap any IO action used from your worker threads that may block with this method. 89 | -- It temporarily spawns another worker thread to make up for the loss of the old blocked 90 | -- worker. 91 | -- 92 | -- This is particularly important if the unblocking is dependent on worker threads actually doing 93 | -- work. If you have this situation, and you don't use this method to wrap blocking actions, then 94 | -- you may get a deadlock if all your worker threads get blocked on work that they assume will be 95 | -- done by other worker threads. 96 | -- 97 | -- An example where something goes wrong if you don't use this to wrap blocking actions is the following example: 98 | -- 99 | -- > newEmptyMVar >>= \mvar -> parallel_ pool [readMVar mvar, putMVar mvar ()] 100 | -- 101 | -- If we only have one thread, we will sometimes get a schedule where the 'readMVar' action is run 102 | -- before the 'putMVar'. Unless we wrap the read with 'extraWorkerWhileBlocked', if the pool has a 103 | -- single thread our program to deadlock, because the worker will become blocked and no other thread 104 | -- will be available to execute the 'putMVar'. 105 | -- 106 | -- The correct code is: 107 | -- 108 | -- > newEmptyMVar >>= \mvar -> parallel_ pool [extraWorkerWhileBlocked pool (readMVar mvar), putMVar mvar ()] 109 | extraWorkerWhileBlocked :: Pool -> IO a -> IO a 110 | extraWorkerWhileBlocked pool = bracket_ (spawnPoolWorkerFor pool) (killPoolWorkerFor pool) 111 | 112 | -- | Internal method for adding extra unblocked threads to a pool if one of the current 113 | -- worker threads is going to be temporarily blocked. Unrestricted use of this is unsafe, 114 | -- so we recommend that you use the 'extraWorkerWhileBlocked' function instead if possible. 115 | spawnPoolWorkerFor :: Pool -> IO () 116 | spawnPoolWorkerFor pool = signalQSem (pool_sem pool) 117 | 118 | -- | Internal method for removing threads from a pool after one of the threads on the pool 119 | -- becomes newly unblocked. Unrestricted use of this is unsafe, so we reccomend that you use 120 | -- the 'extraWorkerWhileBlocked' function instead if possible. 121 | killPoolWorkerFor :: Pool -> IO () 122 | killPoolWorkerFor pool = waitQSem (pool_sem pool) 123 | 124 | 125 | -- | Run the list of computations in parallel. 126 | -- 127 | -- Has the following properties: 128 | -- 129 | -- 1. Never creates more or less unblocked threads than are specified to 130 | -- live in the pool. NB: this count includes the thread executing 'parallel_'. 131 | -- This should minimize contention and hence pre-emption, while also preventing 132 | -- starvation. 133 | -- 134 | -- 2. On return all actions have been performed. 135 | -- 136 | -- 3. The function returns in a timely manner as soon as all actions have 137 | -- been performed. 138 | -- 139 | -- 4. The above properties are true even if 'parallel_' is used by an 140 | -- action which is itself being executed by one of the parallel combinators. 141 | -- 142 | -- 5. If any of the IO actions throws an exception this does not prevent any of the 143 | -- other actions from being performed. 144 | -- 145 | -- 6. If any of the IO actions throws an exception, the exception thrown by the first 146 | -- failing action in the input list will be thrown by 'parallel_'. Importantly, at the 147 | -- time the exception is thrown there is no guarantee that the other parallel actions 148 | -- have completed. 149 | -- 150 | -- The motivation for this choice is that waiting for the all threads to either return 151 | -- or throw before throwing the first exception will almost always cause GHC to show the 152 | -- "Blocked indefinitely in MVar operation" exception rather than the exception you care about. 153 | -- 154 | -- The reason for this behaviour can be seen by considering this machine state: 155 | -- 156 | -- 1. The main thread has used the parallel combinators to spawn two threads, thread 1 and thread 2. 157 | -- It is blocked on both of them waiting for them to return either a result or an exception via an MVar. 158 | -- 159 | -- 2. Thread 1 and thread 2 share another (empty) MVar, the "wait handle". Thread 2 is waiting on the handle, 160 | -- while thread 2 will eventually put into the handle. 161 | -- 162 | -- Consider what happens when thread 1 is buggy and throws an exception before putting into the handle. Now 163 | -- thread 2 is blocked indefinitely, and so the main thread is also blocked indefinetly waiting for the result 164 | -- of thread 2. GHC has no choice but to throw the uninformative exception. However, what we really wanted to 165 | -- see was the original exception thrown in thread 1! 166 | -- 167 | -- By having the main thread abandon its wait for the results of the spawned threads as soon as the first exception 168 | -- comes in, we give this exception a chance to actually be displayed. 169 | parallel_ :: Pool -> [IO a] -> IO () 170 | parallel_ pool xs = parallel pool xs >> return () 171 | 172 | -- | As 'parallel_', but instead of throwing exceptions that are thrown by subcomputations, 173 | -- they are returned in a data structure. 174 | -- 175 | -- As a result, property 6 of 'parallel_' is not preserved, and therefore if your IO actions can depend on each other 176 | -- and may throw exceptions your program may die with "blocked indefinitely" exceptions rather than informative messages. 177 | parallelE_ :: Pool -> [IO a] -> IO [Maybe SomeException] 178 | parallelE_ pool = fmap (map (either Just (\_ -> Nothing))) . parallelE pool 179 | 180 | -- | Run the list of computations in parallel, returning the results in the 181 | -- same order as the corresponding actions. 182 | -- 183 | -- Has the following properties: 184 | -- 185 | -- 1. Never creates more or less unblocked threads than are specified to 186 | -- live in the pool. NB: this count includes the thread executing 'parallel'. 187 | -- This should minimize contention and hence pre-emption, while also preventing 188 | -- starvation. 189 | -- 190 | -- 2. On return all actions have been performed. 191 | -- 192 | -- 3. The function returns in a timely manner as soon as all actions have 193 | -- been performed. 194 | -- 195 | -- 4. The above properties are true even if 'parallel' is used by an 196 | -- action which is itself being executed by one of the parallel combinators. 197 | -- 198 | -- 5. If any of the IO actions throws an exception this does not prevent any of the 199 | -- other actions from being performed. 200 | -- 201 | -- 6. If any of the IO actions throws an exception, the exception thrown by the first 202 | -- failing action in the input list will be thrown by 'parallel'. Importantly, at the 203 | -- time the exception is thrown there is no guarantee that the other parallel actions 204 | -- have completed. 205 | -- 206 | -- The motivation for this choice is that waiting for the all threads to either return 207 | -- or throw before throwing the first exception will almost always cause GHC to show the 208 | -- "Blocked indefinitely in MVar operation" exception rather than the exception you care about. 209 | -- 210 | -- The reason for this behaviour can be seen by considering this machine state: 211 | -- 212 | -- 1. The main thread has used the parallel combinators to spawn two threads, thread 1 and thread 2. 213 | -- It is blocked on both of them waiting for them to return either a result or an exception via an MVar. 214 | -- 215 | -- 2. Thread 1 and thread 2 share another (empty) MVar, the "wait handle". Thread 2 is waiting on the handle, 216 | -- while thread 2 will eventually put into the handle. 217 | -- 218 | -- Consider what happens when thread 1 is buggy and throws an exception before putting into the handle. Now 219 | -- thread 2 is blocked indefinitely, and so the main thread is also blocked indefinetly waiting for the result 220 | -- of thread 2. GHC has no choice but to throw the uninformative exception. However, what we really wanted to 221 | -- see was the original exception thrown in thread 1! 222 | -- 223 | -- By having the main thread abandon its wait for the results of the spawned threads as soon as the first exception 224 | -- comes in, we give this exception a chance to actually be displayed. 225 | parallel :: Pool -> [IO a] -> IO [a] 226 | parallel pool acts = mask $ \restore -> do 227 | main_tid <- myThreadId 228 | resultvars <- forM acts $ \act -> do 229 | resultvar <- newEmptyMVar 230 | _tid <- forkIO $ bracket_ (killPoolWorkerFor pool) (spawnPoolWorkerFor pool) $ reflectExceptionsTo main_tid $ do 231 | res <- restore act 232 | -- Use tryPutMVar instead of putMVar so we get an exception if my brain has failed 233 | True <- tryPutMVar resultvar res 234 | return () 235 | return resultvar 236 | extraWorkerWhileBlocked pool (mapM takeMVar resultvars) 237 | 238 | -- | As 'parallel', but instead of throwing exceptions that are thrown by subcomputations, 239 | -- they are returned in a data structure. 240 | -- 241 | -- As a result, property 6 of 'parallel' is not preserved, and therefore if your IO actions can depend on each other 242 | -- and may throw exceptions your program may die with "blocked indefinitely" exceptions rather than informative messages. 243 | parallelE :: Pool -> [IO a] -> IO [Either SomeException a] 244 | parallelE pool acts = mask $ \restore -> do 245 | resultvars <- forM acts $ \act -> do 246 | resultvar <- newEmptyMVar 247 | _tid <- forkIO $ bracket_ (killPoolWorkerFor pool) (spawnPoolWorkerFor pool) $ do 248 | ei_e_res <- try (restore act) 249 | -- Use tryPutMVar instead of putMVar so we get an exception if my brain has failed 250 | True <- tryPutMVar resultvar ei_e_res 251 | return () 252 | return resultvar 253 | extraWorkerWhileBlocked pool (mapM takeMVar resultvars) 254 | 255 | -- | Run the list of computations in parallel, returning the results in the 256 | -- approximate order of completion. 257 | -- 258 | -- Has the following properties: 259 | -- 260 | -- 1. Never creates more or less unblocked threads than are specified to 261 | -- live in the pool. NB: this count includes the thread executing 'parallelInterleaved'. 262 | -- This should minimize contention and hence pre-emption, while also preventing 263 | -- starvation. 264 | -- 265 | -- 2. On return all actions have been performed. 266 | -- 267 | -- 3. The result of running actions appear in the list in undefined order, but which 268 | -- is likely to be very similar to the order of completion. 269 | -- 270 | -- 4. The above properties are true even if 'parallelInterleaved' is used by an 271 | -- action which is itself being executed by one of the parallel combinators. 272 | -- 273 | -- 5. If any of the IO actions throws an exception this does not prevent any of the 274 | -- other actions from being performed. 275 | -- 276 | -- 6. If any of the IO actions throws an exception, the exception thrown by the first 277 | -- failing action in the input list will be thrown by 'parallelInterleaved'. Importantly, at the 278 | -- time the exception is thrown there is no guarantee that the other parallel actions 279 | -- have completed. 280 | -- 281 | -- The motivation for this choice is that waiting for the all threads to either return 282 | -- or throw before throwing the first exception will almost always cause GHC to show the 283 | -- "Blocked indefinitely in MVar operation" exception rather than the exception you care about. 284 | -- 285 | -- The reason for this behaviour can be seen by considering this machine state: 286 | -- 287 | -- 1. The main thread has used the parallel combinators to spawn two threads, thread 1 and thread 2. 288 | -- It is blocked on both of them waiting for them to return either a result or an exception via an MVar. 289 | -- 290 | -- 2. Thread 1 and thread 2 share another (empty) MVar, the "wait handle". Thread 2 is waiting on the handle, 291 | -- while thread 1 will eventually put into the handle. 292 | -- 293 | -- Consider what happens when thread 1 is buggy and throws an exception before putting into the handle. Now 294 | -- thread 2 is blocked indefinitely, and so the main thread is also blocked indefinetly waiting for the result 295 | -- of thread 2. GHC has no choice but to throw the uninformative exception. However, what we really wanted to 296 | -- see was the original exception thrown in thread 1! 297 | -- 298 | -- By having the main thread abandon its wait for the results of the spawned threads as soon as the first exception 299 | -- comes in, we give this exception a chance to actually be displayed. 300 | parallelInterleaved :: Pool -> [IO a] -> IO [a] 301 | parallelInterleaved pool acts = mask $ \restore -> do 302 | main_tid <- myThreadId 303 | resultchan <- newChan 304 | forM_ acts $ \act -> do 305 | _tid <- forkIO $ bracket_ (killPoolWorkerFor pool) (spawnPoolWorkerFor pool) $ reflectExceptionsTo main_tid $ do 306 | res <- restore act 307 | writeChan resultchan res 308 | return () 309 | extraWorkerWhileBlocked pool (mapM (\_act -> readChan resultchan) acts) 310 | 311 | -- | As 'parallelInterleaved', but instead of throwing exceptions that are thrown by subcomputations, 312 | -- they are returned in a data structure. 313 | -- 314 | -- As a result, property 6 of 'parallelInterleaved' is not preserved, and therefore if your IO actions can depend on each other 315 | -- and may throw exceptions your program may die with "blocked indefinitely" exceptions rather than informative messages. 316 | parallelInterleavedE :: Pool -> [IO a] -> IO [Either SomeException a] 317 | parallelInterleavedE pool acts = mask $ \restore -> do 318 | resultchan <- newChan 319 | forM_ acts $ \act -> do 320 | _tid <- forkIO $ bracket_ (killPoolWorkerFor pool) (spawnPoolWorkerFor pool) $ do 321 | ei_e_res <- try (restore act) 322 | writeChan resultchan ei_e_res 323 | return () 324 | extraWorkerWhileBlocked pool (mapM (\_act -> readChan resultchan) acts) 325 | 326 | -- | Run the list of computations in parallel, returning the result of the first 327 | -- thread that completes with (Just x), if any 328 | -- 329 | -- Has the following properties: 330 | -- 331 | -- 1. Never creates more or less unblocked threads than are specified to 332 | -- live in the pool. NB: this count includes the thread executing 'parallelInterleaved'. 333 | -- This should minimize contention and hence pre-emption, while also preventing 334 | -- starvation. 335 | -- 336 | -- 2. On return all actions have either been performed or cancelled (with ThreadKilled exceptions). 337 | -- 338 | -- 3. The above properties are true even if 'parallelFirst' is used by an 339 | -- action which is itself being executed by one of the parallel combinators. 340 | -- 341 | -- 4. If any of the IO actions throws an exception, the exception thrown by the first 342 | -- throwing action in the input list will be thrown by 'parallelFirst'. Importantly, at the 343 | -- time the exception is thrown there is no guarantee that the other parallel actions 344 | -- have been completed or cancelled. 345 | -- 346 | -- The motivation for this choice is that waiting for the all threads to either return 347 | -- or throw before throwing the first exception will almost always cause GHC to show the 348 | -- "Blocked indefinitely in MVar operation" exception rather than the exception you care about. 349 | -- 350 | -- The reason for this behaviour can be seen by considering this machine state: 351 | -- 352 | -- 1. The main thread has used the parallel combinators to spawn two threads, thread 1 and thread 2. 353 | -- It is blocked on both of them waiting for them to return either a result or an exception via an MVar. 354 | -- 355 | -- 2. Thread 1 and thread 2 share another (empty) MVar, the "wait handle". Thread 2 is waiting on the handle, 356 | -- while thread 1 will eventually put into the handle. 357 | -- 358 | -- Consider what happens when thread 1 is buggy and throws an exception before putting into the handle. Now 359 | -- thread 2 is blocked indefinitely, and so the main thread is also blocked indefinetly waiting for the result 360 | -- of thread 2. GHC has no choice but to throw the uninformative exception. However, what we really wanted to 361 | -- see was the original exception thrown in thread 1! 362 | -- 363 | -- By having the main thread abandon its wait for the results of the spawned threads as soon as the first exception 364 | -- comes in, we give this exception a chance to actually be displayed. 365 | parallelFirst :: Pool -> [IO (Maybe a)] -> IO (Maybe a) 366 | parallelFirst pool acts = mask $ \restore -> do 367 | main_tid <- myThreadId 368 | resultvar <- newEmptyMVar 369 | (tids, waits) <- liftM unzip $ forM acts $ \act -> do 370 | wait_var <- newEmptyMVar 371 | tid <- forkIO $ flip onNonThreadKilledException (tryPutMVar resultvar Nothing) $ -- If we throw an exception, unblock 372 | bracket_ (killPoolWorkerFor pool) (spawnPoolWorkerFor pool >> putMVar wait_var ()) $ -- the main thread so it can rethrow it 373 | reflectExceptionsTo main_tid $ do 374 | mb_res <- restore act 375 | case mb_res of 376 | Nothing -> return () 377 | Just res -> tryPutMVar resultvar (Just res) >> return () 378 | return (tid, wait_var) 379 | forkIO $ mapM_ takeMVar waits >> tryPutMVar resultvar Nothing >> return () 380 | mb_res <- extraWorkerWhileBlocked pool (takeMVar resultvar) 381 | mapM_ killThread tids 382 | return mb_res 383 | 384 | -- | As 'parallelFirst', but instead of throwing exceptions that are thrown by subcomputations, 385 | -- they are returned in a data structure. 386 | -- 387 | -- As a result, property 4 of 'parallelFirst' is not preserved, and therefore if your IO actions can depend on each other 388 | -- and may throw exceptions your program may die with "blocked indefinitely" exceptions rather than informative messages. 389 | parallelFirstE :: Pool -> [IO (Maybe a)] -> IO (Maybe (Either SomeException a)) 390 | parallelFirstE pool acts = mask $ \restore -> do 391 | main_tid <- myThreadId 392 | resultvar <- newEmptyMVar 393 | (tids, waits) <- liftM unzip $ forM acts $ \act -> do 394 | wait_var <- newEmptyMVar 395 | tid <- forkIO $ bracket_ (killPoolWorkerFor pool) (spawnPoolWorkerFor pool >> putMVar wait_var ()) $ do 396 | ei_mb_res <- try (restore act) 397 | case ei_mb_res of 398 | -- NB: we aren't in danger of putting a "thread killed" exception into the MVar 399 | -- since we only kill the spawned threads *after* we have already taken from resultvar 400 | Left e -> tryPutMVar resultvar (Just (Left e)) >> return () 401 | Right Nothing -> return () 402 | Right (Just res) -> tryPutMVar resultvar (Just (Right res)) >> return () 403 | return (tid, wait_var) 404 | forkIO $ mapM_ takeMVar waits >> tryPutMVar resultvar Nothing >> return () 405 | mb_res <- extraWorkerWhileBlocked pool (takeMVar resultvar) 406 | mapM_ killThread tids 407 | return mb_res 408 | -------------------------------------------------------------------------------- /Control/Concurrent/ParallelIO/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | module Main where 3 | 4 | import Data.IORef 5 | import Data.List 6 | 7 | import Test.Framework 8 | import Test.Framework.Providers.HUnit 9 | import Test.HUnit ((@?)) 10 | 11 | import GHC.Conc 12 | 13 | import Control.Monad 14 | 15 | import Control.Concurrent.MVar 16 | import qualified Control.Concurrent.ParallelIO.Global as Global 17 | import Control.Concurrent.ParallelIO.Local 18 | 19 | 20 | main :: IO () 21 | main = do 22 | defaultMain tests 23 | Global.stopGlobalPool 24 | 25 | tests :: [Test] 26 | tests = [ 27 | testCase "parallel_ executes correct number of actions" $ repeatTest parallel__execution_count_correct 28 | , testCase "parallel_ doesn't spawn too many threads" $ repeatTest parallel__doesnt_spawn_too_many_threads 29 | , testCase "parallel executes correct actions" $ repeatTest parallel_executes_correct_actions 30 | , testCase "parallel doesn't spawn too many threads" $ repeatTest parallel_doesnt_spawn_too_many_threads 31 | , testCase "parallelInterleaved executes correct actions" $ repeatTest parallelInterleaved_executes_correct_actions 32 | , testCase "parallelInterleaved doesn't spawn too many threads" $ repeatTest parallelInterleaved_doesnt_spawn_too_many_threads 33 | , testCase "parallel with one worker can be blocked" $ parallel_with_one_worker_can_be_blocked 34 | , testCase "parallel_ with one worker can be blocked" $ parallel__with_one_worker_can_be_blocked 35 | ] 36 | 37 | parallel__execution_count_correct n = do 38 | ref <- newIORef 0 39 | Global.parallel_ (replicate n (atomicModifyIORef_ ref (+ 1))) 40 | fmap (==n) $ readIORef ref 41 | 42 | parallel_executes_correct_actions n = fmap (expected ==) actual 43 | where actual = Global.parallel (map (return . (+1)) [0..n]) 44 | expected = [(1 :: Int)..n + 1] 45 | 46 | parallelInterleaved_executes_correct_actions n = fmap ((expected ==) . sort) actual 47 | where actual = Global.parallelInterleaved (map (return . (+1)) [0..n]) 48 | expected = [(1 :: Int)..n + 1] 49 | 50 | parallel__doesnt_spawn_too_many_threads = doesnt_spawn_too_many_threads parallel_ 51 | parallel_doesnt_spawn_too_many_threads = doesnt_spawn_too_many_threads parallel 52 | parallelInterleaved_doesnt_spawn_too_many_threads = doesnt_spawn_too_many_threads parallelInterleaved 53 | 54 | doesnt_spawn_too_many_threads the_parallel n = do 55 | threadcountref <- newIORef 0 56 | maxref <- newIORef 0 57 | -- NB: we use a local pool rather than the global one because otherwise we get interference effects 58 | -- when we run the testsuite in parallel 59 | withPool numCapabilities $ \pool -> do 60 | _ <- the_parallel pool $ replicate n $ do 61 | tc' <- atomicModifyIORef_ threadcountref (+ 1) 62 | _ <- atomicModifyIORef_ maxref (`max` tc') 63 | -- This delay and 'yield' combination was experimentally determined. The test 64 | -- can and does still nondeterministically fail with a non-zero probability 65 | -- dependening on runtime scheduling behaviour. It seems that the first instance 66 | -- of this test to run in the process is especially vulnerable. 67 | yield 68 | threadDelay 20000 69 | yield 70 | atomicModifyIORef_ threadcountref (\tc -> tc - 1) 71 | seenmax <- readIORef maxref 72 | let expected_max_concurrent_threads = numCapabilities `min` n 73 | if expected_max_concurrent_threads == seenmax 74 | then return True 75 | else putStrLn ("Expected at most " ++ show expected_max_concurrent_threads ++ ", got " ++ show seenmax) >> return False 76 | 77 | parallel_with_one_worker_can_be_blocked = with_one_worker_can_be_blocked parallel 78 | parallel__with_one_worker_can_be_blocked = with_one_worker_can_be_blocked parallel_ 79 | 80 | -- This test is based on a specific bug I observed in the library. The problem was that I was special casing 81 | -- pools with thread counts <= 1 to just use sequence/sequence_, but that doesn't give the right semantics if 82 | -- the user is able to call extraWorkerWhileBlocked! 83 | with_one_worker_can_be_blocked the_parallel = withPool 1 $ \pool -> do 84 | wait <- newEmptyMVar 85 | the_parallel pool [extraWorkerWhileBlocked pool (takeMVar wait), putMVar wait ()] 86 | return () 87 | 88 | atomicModifyIORef_ :: IORef a -> (a -> a) -> IO a 89 | atomicModifyIORef_ ref f = atomicModifyIORef ref (\x -> let x' = f x in x' `seq` (x', x')) 90 | 91 | repeatTest :: (Int -> IO Bool) -> IO () 92 | repeatTest testcase = forM_ [0..100] $ \n -> testcase n @? "n=" ++ show n 93 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Apparently the [async](http://hackage.haskell.org/package/async) package might be a more modern alternative to this package. -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /parallel-io.cabal: -------------------------------------------------------------------------------- 1 | Name: parallel-io 2 | Version: 0.3.4 3 | Cabal-Version: >= 1.10 4 | Category: Concurrency 5 | Synopsis: Combinators for executing IO actions in parallel on a thread pool. 6 | Description: This package provides combinators for sequencing IO actions onto a thread pool. The 7 | thread pool is guaranteed to contain no more unblocked threads than a user-specified upper limit, thus 8 | minimizing contention. 9 | . 10 | Furthermore, the parallel combinators can be used reentrantly - your parallel 11 | actions can spawn more parallel actions - without violating this property of the thread pool. 12 | . 13 | The package is inspired by the thread . 14 | Thanks to Neil Mitchell and Bulat Ziganshin for some of the code this package is based on. 15 | License: BSD3 16 | License-File: LICENSE 17 | Homepage: http://batterseapower.github.com/parallel-io 18 | Author: Max Bolingbroke , 19 | Neil Mitchell , 20 | Bulat Ziganshin 21 | Maintainer: Max Bolingbroke 22 | Build-Type: Simple 23 | 24 | 25 | Flag Benchmark 26 | Description: Build the benchmarking tool 27 | Default: False 28 | 29 | Flag Fuzz 30 | Description: Build the fuzzing tool for discovering deadlocks 31 | Default: False 32 | 33 | Flag Tests 34 | Description: Build the test runner 35 | Default: False 36 | 37 | Library 38 | Default-Language: Haskell98 39 | Exposed-Modules: 40 | Control.Concurrent.ParallelIO 41 | Control.Concurrent.ParallelIO.Global 42 | Control.Concurrent.ParallelIO.Local 43 | Other-Modules: 44 | Control.Concurrent.ParallelIO.Compat 45 | 46 | Build-Depends: base >= 4 && < 5, extensible-exceptions > 0.1.0.1, containers >= 0.2 && < 0.6, random >= 1.0 && < 1.3 47 | 48 | Executable benchmark 49 | Default-Language: Haskell98 50 | Main-Is: Control/Concurrent/ParallelIO/Benchmark.hs 51 | 52 | if !flag(benchmark) 53 | Buildable: False 54 | else 55 | Build-Depends: base >= 4 && < 5, extensible-exceptions > 0.1.0.1, containers >= 0.2 && < 0.6, random >= 1.0 && < 1.3, 56 | time >= 1 57 | 58 | Ghc-Options: -threaded 59 | 60 | Executable tests 61 | Default-Language: Haskell98 62 | Main-Is: Control/Concurrent/ParallelIO/Tests.hs 63 | 64 | if !flag(tests) 65 | Buildable: False 66 | else 67 | Build-Depends: base >= 4 && < 5, extensible-exceptions > 0.1.0.1, containers >= 0.2 && < 0.6, random >= 1.0 && < 1.3, 68 | test-framework >= 0.1.1, test-framework-hunit >= 0.1.1, HUnit >= 1.2 && < 2 69 | 70 | Ghc-Options: -threaded -rtsopts 71 | 72 | Executable fuzz 73 | Default-Language: Haskell98 74 | Main-Is: Control/Concurrent/ParallelIO/Fuzz.hs 75 | 76 | if !flag(fuzz) 77 | Buildable: False 78 | else 79 | Build-Depends: base >= 4 && < 5, extensible-exceptions > 0.1.0.1, containers >= 0.2 && < 0.6, random >= 1.0 && < 1.3 80 | 81 | Ghc-Options: -threaded -rtsopts 82 | 83 | Executable fuzz-seq 84 | Default-Language: Haskell98 85 | Main-Is: Control/Concurrent/ParallelIO/Fuzz.hs 86 | 87 | if !flag(fuzz) 88 | Buildable: False 89 | else 90 | Build-Depends: base >= 4 && < 5, extensible-exceptions > 0.1.0.1, containers >= 0.2 && < 0.6, random >= 1.0 && < 1.3 91 | -------------------------------------------------------------------------------- /release: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | 4 | echo "Have you updated the version number? Type 'yes' if you have!" 5 | read version_response 6 | 7 | if [ "$version_response" != "yes" ]; then 8 | echo "Go and update the version number" 9 | exit 1 10 | fi 11 | 12 | sdist_output=`runghc Setup.lhs sdist` 13 | 14 | if [ "$?" != "0" ]; then 15 | echo "Cabal sdist failed, aborting" 16 | exit 1 17 | fi 18 | 19 | # Want to find a line like: 20 | # Source tarball created: dist/ansi-terminal-0.1.tar.gz 21 | 22 | # Test this with: 23 | # runghc Setup.lhs sdist | grep ... 24 | filename=`echo $sdist_output | sed 's/.*Source tarball created: \([^ ]*\).*/\1/'` 25 | echo "Filename: $filename" 26 | 27 | if [ "$filename" = "$sdist_output" ]; then 28 | echo "Could not find filename, aborting" 29 | exit 1 30 | fi 31 | 32 | # Test this with: 33 | # echo dist/ansi-terminal-0.1.tar.gz | sed ... 34 | version=`echo $filename | sed 's/^[^0-9]*\([0-9\.]*\).tar.gz$/\1/'` 35 | echo "Version: $version" 36 | 37 | if [ "$version" = "$filename" ]; then 38 | echo "Could not find version, aborting" 39 | exit 1 40 | fi 41 | 42 | echo "This is your last chance to abort! I'm going to upload in 10 seconds" 43 | sleep 10 44 | 45 | git tag "v$version" 46 | 47 | if [ "$?" != "0" ]; then 48 | echo "Git tag failed, aborting" 49 | exit 1 50 | fi 51 | 52 | # You need to have stored your Hackage username and password as directed by cabal-upload 53 | # I use -v3 because otherwise the error messages can be cryptic :-) 54 | cabal upload --publish -v3 $filename 55 | 56 | if [ "$?" != "0" ]; then 57 | echo "Hackage upload failed, aborting" 58 | exit 1 59 | fi 60 | 61 | # Success! 62 | exit 0 --------------------------------------------------------------------------------