{-# OPTIONS #-}
-- ------------------------------------------------------------
{- |
Module : Control.Concurrent.MapFold
Copyright : Copyright (C) 2010 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
Stability : experimental
Portability: none portable
A map-fold function for performing list folds in parallel.
-}
-- ------------------------------------------------------------
module Control.Concurrent.MapFold
( mapFold )
where
import Control.Concurrent
import Control.DeepSeq
-- ------------------------------------------------------------
mapFold :: (NFData b) => Int -> (a -> IO b) -> (b -> b -> IO b) -> [a] -> IO b
mapFold n m f xs@(_:_) = do
c <- newChan
p <- newQSem n
mapFold' p c m f xs
mapFold _ _ _ [] = error "mapFold: empty list of arguments"
mapFold' :: (NFData b) => QSem -> Chan b -> (a -> IO b) -> (b -> b -> IO b) -> [a] -> IO b
mapFold' p c m f xs = do
mapM_ (forkWorker m) xs
foldResults (length xs)
where
forkWorker m' x = forkIO process
>> return ()
where
process = do
waitQSem p -- request processor
res <- m' x -- work
rnf res `seq` -- force complete elvaluation
writeChan c res -- deliver result
signalQSem p -- release processor
foldResults n
| n == 1 = readChan c -- get final result
| otherwise = do
r1 <- readChan c -- get 1. arg
r2 <- readChan c -- get 2. arg
forkWorker (uncurry f) (r1, r2)
-- combine args and put result back into chanel
foldResults (n - 1) -- continue
-- ------------------------------------------------------------