module SubHask.Algebra.Parallel
( parallel
, disableMultithreading
, Partitionable (..)
, law_Partitionable_length
, law_Partitionable_monoid
, parallelBlockedN
, parallelBlocked
, unsafeParallelInterleavedN
, unsafeParallelInterleaved
, parallelInterleaved
)
where
import SubHask.Algebra
import SubHask.Category
import SubHask.Internal.Prelude
import Control.Monad
import qualified Prelude as P
import Control.Concurrent
import Control.Parallel
import Control.Parallel.Strategies
import System.IO.Unsafe
parallel ::
( Partitionable domain
, Monoid range
, NFData range
) => (domain -> range)
-> (domain -> range)
parallel = parallelBlocked
parallelN ::
( Partitionable domain
, Monoid range
, NFData range
) => Int
-> (domain -> range)
-> (domain -> range)
parallelN=parallelBlockedN
parallelBlockedN ::
( Partitionable domain
, Monoid range
, NFData range
) => Int
-> (domain -> range)
-> (domain -> range)
parallelBlockedN n f = parfoldtree1 . parMap rdeepseq f . partition n
parallelBlocked ::
( Partitionable domain
, Monoid range
, NFData range
) => (domain -> range)
-> (domain -> range)
parallelBlocked = if dopar
then parallelBlockedN numproc
else id
where
numproc = unsafePerformIO getNumCapabilities
dopar = numproc > 1
unsafeParallelInterleavedN ::
( Partitionable domain
, Monoid range
, NFData range
) => Int
-> (domain -> range)
-> (domain -> range)
unsafeParallelInterleavedN n f = parfoldtree1 . parMap rdeepseq f . partitionInterleaved n
unsafeParallelInterleaved ::
( Partitionable domain
, Monoid range
, NFData range
) => (domain -> range)
-> (domain -> range)
unsafeParallelInterleaved = if dopar
then unsafeParallelInterleavedN numproc
else id
where
numproc = unsafePerformIO getNumCapabilities
dopar = numproc > 1
parallelInterleaved ::
( Partitionable domain
, Abelian range
, Monoid range
, NFData range
) => (domain -> range)
-> (domain -> range)
parallelInterleaved = unsafeParallelInterleaved
disableMultithreading :: IO a -> IO a
disableMultithreading a = do
n <- getNumCapabilities
setNumCapabilities 1
a' <- a
setNumCapabilities n
return a'
class (Monoid t, Foldable t, Constructible t) => Partitionable t where
partition :: Int -> t -> [t]
partition i t = map (\(x:xs) -> fromList1 x xs) $ partitionBlocked_list i $ toList t
partitionInterleaved :: Int -> t -> [t]
partitionInterleaved i t = map (\(x:xs) -> fromList1 x xs) $ partitionInterleaved_list i $ toList t
law_Partitionable_length :: (ClassicalLogic t, Partitionable t) => Int -> t -> Bool
law_Partitionable_length n t
| n > 0 = length (partition n t) <= n
| otherwise = True
law_Partitionable_monoid :: (ClassicalLogic t, Eq_ t, Partitionable t) => Int -> t -> Bool
law_Partitionable_monoid n t
| n > 0 = sum (partition n t) == t
| otherwise = True
parfoldtree1 :: Monoid a => [a] -> a
parfoldtree1 as = case go as of
[] -> zero
[a] -> a
as -> parfoldtree1 as
where
go [] = []
go [a] = [a]
go (a1:a2:as) = par a12 $ a12:go as
where
a12=a1+a2
instance Partitionable [a] where
partition = partitionBlocked_list
partitionInterleaved = partitionInterleaved_list
partitionBlocked_list :: Int -> [a] -> [[a]]
partitionBlocked_list n xs = go xs
where
go [] = []
go xs = a:go b
where
(a,b) = P.splitAt len xs
size = length xs
len = size `div` n
+ if size `rem` n == 0 then 0 else 1
partitionInterleaved_list :: Int -> [a] -> [[a]]
partitionInterleaved_list n xs = [map snd $ P.filter (\(i,x)->i `mod` n==j) ixs | j<-[0..n1]]
where
ixs = addIndex 0 xs
addIndex i [] = []
addIndex i (x:xs) = (i,x):(addIndex (i+1) xs)