rewrote to not use forkProcess
That can make the threaded runtime stall.. But it can use threads now!
This commit is contained in:
parent
cf47bb3f50
commit
2edb5d145c
1 changed files with 18 additions and 7 deletions
|
@ -1,4 +1,4 @@
|
||||||
{- parallel processes
|
{- parallel processing via threads
|
||||||
-
|
-
|
||||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||||
-
|
-
|
||||||
|
@ -9,16 +9,27 @@ module Utility.Parallel where
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
|
|
||||||
import System.Posix.Process
|
import Control.Concurrent
|
||||||
|
import Control.Exception
|
||||||
|
|
||||||
{- Runs an action in parallel with a set of values.
|
{- Runs an action in parallel with a set of values, in a set of threads.
|
||||||
|
- In order for the actions to truely run in parallel, requires GHC's
|
||||||
|
- threaded runtime,
|
||||||
|
-
|
||||||
- Returns the values partitioned into ones with which the action succeeded,
|
- Returns the values partitioned into ones with which the action succeeded,
|
||||||
- and ones with which it failed. -}
|
- and ones with which it failed. -}
|
||||||
inParallel :: (v -> IO ()) -> [v] -> IO ([v], [v])
|
inParallel :: (v -> IO ()) -> [v] -> IO ([v], [v])
|
||||||
inParallel a l = do
|
inParallel a l = do
|
||||||
pids <- mapM (forkProcess . a) l
|
mvars <- mapM thread l
|
||||||
statuses <- mapM (getProcessStatus True False) pids
|
statuses <- mapM takeMVar mvars
|
||||||
return $ reduce $ partition (succeeded . snd) $ zip l statuses
|
return $ reduce $ partition snd $ zip l statuses
|
||||||
where
|
where
|
||||||
succeeded v = v == Just (Exited ExitSuccess)
|
|
||||||
reduce (x,y) = (map fst x, map fst y)
|
reduce (x,y) = (map fst x, map fst y)
|
||||||
|
thread v = do
|
||||||
|
mvar <- newEmptyMVar
|
||||||
|
_ <- forkIO $ do
|
||||||
|
r <- try (a v) :: IO (Either SomeException ())
|
||||||
|
case r of
|
||||||
|
Left _ -> putMVar mvar False
|
||||||
|
Right _ -> putMVar mvar True
|
||||||
|
return mvar
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue