module Control.Parallel.HdpH.Strategies
(
Strategy,
using,
r0,
rseq,
rdeepseq,
forceC,
forceCC,
ForceCC(
locForceCC
),
StaticForceCC,
staticForceCC,
ProtoStrategy,
sparkClosure,
pushClosure,
evalList,
evalClosureListClosure,
parClosureList,
pushClosureList,
pushRandClosureList,
parClosureListClusterBy,
parClosureListChunked,
parClosureListSliced,
parMap,
parMapNF,
parMapChunked,
parMapChunkedNF,
parMapSliced,
parMapSlicedNF,
parClosureMapM,
parMapM,
parMapM_,
pushMap,
pushMapNF,
pushClosureMapM,
pushMapM,
pushMapM_,
pushRandClosureMapM,
pushRandMapM,
pushRandMapM_,
divideAndConquer,
parDivideAndConquer,
pushDivideAndConquer,
declareStatic
) where
import Prelude
import Control.DeepSeq (NFData, deepseq)
import Control.Monad (zipWithM, zipWithM_)
import Data.Functor ((<$>))
import Data.List (transpose)
import Data.Monoid (mconcat)
import System.Random (randomRIO)
import Control.Parallel.HdpH
(Par, io, fork, pushTo, spark, new, get, glob, rput,
NodeId, IVar, GIVar,
Env, LocT, here,
Closure, unClosure, mkClosure, mkClosureLoc, apC, compC,
ToClosure(locToClosure), toClosure, forceClosure,
StaticToClosure, staticToClosure,
Static, static, static_, staticLoc_,
StaticDecl, declare)
import qualified Control.Parallel.HdpH as HdpH (declareStatic)
instance ToClosure [Closure a] where locToClosure = $(here)
instance ForceCC (Closure a) where locForceCC = $(here)
declareStatic :: StaticDecl
declareStatic =
mconcat
[HdpH.declareStatic,
declare (staticToClosure :: forall a . StaticToClosure [Closure a]),
declare (staticForceCC :: forall a . StaticForceCC (Closure a)),
declare $(static 'sparkClosure_abs),
declare $(static 'pushClosure_abs),
declare $(static_ 'evalClosureListClosure),
declare $(static 'parClosureMapM_abs),
declare $(static 'parMapM_abs),
declare $(static_ 'constReturnUnit),
declare $(static 'parDivideAndConquer_abs),
declare $(static 'pushDivideAndConquer_abs)]
type Strategy a = a -> Par a
using :: a -> Strategy a -> Par a
using = flip ($)
r0 :: Strategy a
r0 = return
rseq :: Strategy a
rseq x = x `seq` return x
rdeepseq :: (NFData a) => Strategy a
rdeepseq x = x `deepseq` return x
forceC :: (NFData a, ToClosure a) => Strategy (Closure a)
forceC clo = return $! forceClosure clo
forceCC :: (ForceCC a) => Closure (Strategy (Closure a))
forceCC = $(mkClosureLoc [| forceC |]) locForceCC
class (NFData a, ToClosure a) => ForceCC a where
locForceCC :: LocT (Strategy (Closure a))
type StaticForceCC a = Static (Env -> Strategy (Closure a))
staticForceCC :: (ForceCC a) => StaticForceCC a
staticForceCC = $(staticLoc_ 'forceC) locForceCC
type ProtoStrategy a = a -> Par (IVar a)
sparkClosure :: Closure (Strategy (Closure a)) ->
ProtoStrategy (Closure a)
sparkClosure clo_strat clo = do
v <- new
gv <- glob v
spark $(mkClosure [| sparkClosure_abs (clo, clo_strat, gv) |])
return v
sparkClosure_abs :: (Closure a,
Closure (Strategy (Closure a)),
GIVar (Closure a))
-> Par ()
sparkClosure_abs (clo, clo_strat, gv) =
(clo `using` unClosure clo_strat) >>= rput gv
pushClosure :: Closure (Strategy (Closure a)) -> NodeId ->
ProtoStrategy (Closure a)
pushClosure clo_strat node clo = do
v <- new
gv <- glob v
pushTo $(mkClosure [| pushClosure_abs (clo, clo_strat, gv) |]) node
return v
pushClosure_abs :: (Closure a,
Closure (Strategy (Closure a)),
GIVar (Closure a))
-> Par ()
pushClosure_abs (clo, clo_strat, gv) =
fork $ (clo `using` unClosure clo_strat) >>= rput gv
evalList :: Strategy a -> Strategy [a]
evalList _strat [] = return []
evalList strat (x:xs) = do x' <- strat x
xs' <- evalList strat xs
return (x':xs')
evalClosureListClosure :: Strategy (Closure a) -> Strategy (Closure [Closure a])
evalClosureListClosure strat clo =
toClosure <$> (unClosure clo `using` evalList strat)
parClosureList :: Closure (Strategy (Closure a)) -> Strategy [Closure a]
parClosureList clo_strat xs = mapM (sparkClosure clo_strat) xs >>=
mapM get
pushClosureList :: Closure (Strategy (Closure a))
-> [NodeId]
-> Strategy [Closure a]
pushClosureList clo_strat nodes xs =
zipWithM (pushClosure clo_strat) (cycle nodes) xs >>=
mapM get
pushRandClosureList :: Closure (Strategy (Closure a))
-> [NodeId]
-> Strategy [Closure a]
pushRandClosureList clo_strat nodes xs =
mapM (\ x -> do { node <- rand; pushClosure clo_strat node x}) xs >>=
mapM get
where
rand :: Par NodeId
rand = (nodes !!) <$> io (randomRIO (0, length nodes 1))
evalClusterBy :: (a -> b) -> (b -> a) -> Strategy b -> Strategy a
evalClusterBy cluster uncluster strat x =
uncluster <$> (cluster x `using` strat)
parClosureListClusterBy :: ([Closure a] -> [[Closure a]])
-> ([[Closure a]] -> [Closure a])
-> Closure (Strategy (Closure a))
-> Strategy [Closure a]
parClosureListClusterBy cluster uncluster clo_strat =
evalClusterBy cluster' uncluster' strat'
where cluster' = map toClosure . cluster
uncluster' = uncluster . map unClosure
strat' = parClosureList clo_strat''
clo_strat'' =
$(mkClosure [| evalClosureListClosure |]) `apC` clo_strat
parClosureListChunked :: Int
-> Closure (Strategy (Closure a))
-> Strategy [Closure a]
parClosureListChunked n = parClosureListClusterBy (chunk n) unchunk
parClosureListSliced :: Int
-> Closure (Strategy (Closure a))
-> Strategy [Closure a]
parClosureListSliced n = parClosureListClusterBy (slice n) unslice
chunk :: Int -> [a] -> [[a]]
chunk n | n <= 0 = chunk 1
| otherwise = go
where
go [] = []
go xs = ys : go zs where (ys,zs) = splitAt n xs
unchunk :: [[a]] -> [a]
unchunk = concat
slice :: Int -> [a] -> [[a]]
slice n = transpose . chunk n
unslice :: [[a]] -> [a]
unslice = concat . transpose
parMap :: (ToClosure a)
=> Closure (Strategy (Closure b))
-> Closure (a -> b)
-> [a]
-> Par [b]
parMap clo_strat clo_f xs =
do clo_ys <- map f clo_xs `using` parClosureList clo_strat
return $ map unClosure clo_ys
where f = apC clo_f
clo_xs = map toClosure xs
parMapNF :: (ToClosure a, ForceCC b)
=> Closure (a -> b)
-> [a]
-> Par [b]
parMapNF = parMap forceCC
parMapChunked :: (ToClosure a)
=> Int
-> Closure (Strategy (Closure b))
-> Closure (a -> b)
-> [a]
-> Par [b]
parMapChunked n clo_strat clo_f xs =
do clo_ys <- map f clo_xs `using` parClosureListChunked n clo_strat
return $ map unClosure clo_ys
where f = apC clo_f
clo_xs = map toClosure xs
parMapChunkedNF :: (ToClosure a, ForceCC b)
=> Int
-> Closure (a -> b)
-> [a]
-> Par [b]
parMapChunkedNF n = parMapChunked n forceCC
parMapSliced :: (ToClosure a)
=> Int
-> Closure (Strategy (Closure b))
-> Closure (a -> b)
-> [a]
-> Par [b]
parMapSliced n clo_strat clo_f xs =
do clo_ys <- map f clo_xs `using` parClosureListSliced n clo_strat
return $ map unClosure clo_ys
where f = apC clo_f
clo_xs = map toClosure xs
parMapSlicedNF :: (ToClosure a, ForceCC b)
=> Int
-> Closure (a -> b)
-> [a]
-> Par [b]
parMapSlicedNF n = parMapSliced n forceCC
parClosureMapM :: Closure (Closure a -> Par (Closure b))
-> [Closure a]
-> Par [Closure b]
parClosureMapM clo_f clo_xs =
do vs <- mapM spawn clo_xs
mapM get vs
where
spawn clo_x = do
v <- new
gv <- glob v
spark $(mkClosure [| parClosureMapM_abs (clo_f, clo_x, gv) |])
return v
parClosureMapM_abs :: (Closure (Closure a -> Par (Closure b)),
Closure a,
GIVar (Closure b))
-> Par ()
parClosureMapM_abs (clo_f, clo_x, gv) = unClosure clo_f clo_x >>= rput gv
parMapM :: (ToClosure a)
=> Closure (a -> Par (Closure b))
-> [a]
-> Par [b]
parMapM clo_f xs =
do vs <- mapM spawn xs
mapM (\ v -> unClosure <$> get v) vs
where
spawn x = do
let clo_x = toClosure x
v <- new
gv <- glob v
spark $(mkClosure [| parMapM_abs (clo_f, clo_x, gv) |])
return v
parMapM_abs :: (Closure (a -> Par (Closure b)),
Closure a,
GIVar (Closure b))
-> Par ()
parMapM_abs (clo_f, clo_x, gv) = unClosure (clo_f `apC` clo_x) >>= rput gv
parMapM_ :: (ToClosure a)
=> Closure (a -> Par b)
-> [a]
-> Par ()
parMapM_ clo_f xs = mapM_ (spark . apC (termParC `compC` clo_f) . toClosure) xs
termParC :: Closure (a -> Par ())
termParC = $(mkClosure [| constReturnUnit |])
constReturnUnit :: a -> Par ()
constReturnUnit = const (return ())
pushMap :: (ToClosure a)
=> Closure (Strategy (Closure b))
-> [NodeId]
-> Closure (a -> b)
-> [a]
-> Par [b]
pushMap clo_strat nodes clo_f xs =
do clo_ys <- map f clo_xs `using` pushClosureList clo_strat nodes
return $ map unClosure clo_ys
where f = apC clo_f
clo_xs = map toClosure xs
pushMapNF :: (ToClosure a, ForceCC b)
=> [NodeId]
-> Closure (a -> b)
-> [a]
-> Par [b]
pushMapNF = pushMap forceCC
pushClosureMapM :: [NodeId]
-> Closure (Closure a -> Par (Closure b))
-> [Closure a]
-> Par [Closure b]
pushClosureMapM nodes clo_f clo_xs =
do vs <- zipWithM spawn (cycle nodes) clo_xs
mapM get vs
where
spawn node clo_x = do
v <- new
gv <- glob v
pushTo $(mkClosure [| parClosureMapM_abs (clo_f, clo_x, gv) |]) node
return v
pushMapM :: (ToClosure a)
=> [NodeId]
-> Closure (a -> Par (Closure b))
-> [a]
-> Par [b]
pushMapM nodes clo_f xs =
do vs <- zipWithM spawn (cycle nodes) xs
mapM (\ v -> unClosure <$> get v) vs
where
spawn node x = do
let clo_x = toClosure x
v <- new
gv <- glob v
pushTo $(mkClosure [| parMapM_abs (clo_f, clo_x, gv) |]) node
return v
pushMapM_ :: (ToClosure a)
=> [NodeId]
-> Closure (a -> Par b)
-> [a]
-> Par ()
pushMapM_ nodes clo_f xs =
zipWithM_
(\ node x -> pushTo (compC termParC clo_f `apC` toClosure x) node)
(cycle nodes)
xs
pushRandClosureMapM :: [NodeId]
-> Closure (Closure a -> Par (Closure b))
-> [Closure a]
-> Par [Closure b]
pushRandClosureMapM nodes clo_f clo_xs =
do vs <- mapM spawn clo_xs
mapM get vs
where
rand = (nodes !!) <$> io (randomRIO (0, length nodes 1))
spawn clo_x = do
v <- new
gv <- glob v
node <- rand
pushTo $(mkClosure [| parClosureMapM_abs (clo_f, clo_x, gv) |]) node
return v
pushRandMapM :: (ToClosure a)
=> [NodeId]
-> Closure (a -> Par (Closure b))
-> [a]
-> Par [b]
pushRandMapM nodes clo_f xs =
do vs <- mapM spawn xs
mapM (\ v -> unClosure <$> get v) vs
where
rand = (nodes !!) <$> io (randomRIO (0, length nodes 1))
spawn x = do
let clo_x = toClosure x
v <- new
gv <- glob v
node <- rand
pushTo $(mkClosure [| parMapM_abs (clo_f, clo_x, gv) |]) node
return v
pushRandMapM_ :: (ToClosure a)
=> [NodeId]
-> Closure (a -> Par b)
-> [a]
-> Par ()
pushRandMapM_ nodes clo_f xs =
mapM_ spawn xs
where
rand = (nodes !!) <$> io (randomRIO (0, length nodes 1))
spawn x = do
node <- rand
pushTo (compC termParC clo_f `apC` toClosure x) node
divideAndConquer :: (a -> Bool)
-> (a -> [a])
-> (a -> [b] -> b)
-> (a -> b)
-> a
-> b
divideAndConquer trivial decompose combine f x
| trivial x = f x
| otherwise = combine x $ map solveRec (decompose x)
where
solveRec = divideAndConquer trivial decompose combine f
parDivideAndConquer :: Closure (Closure a -> Bool)
-> Closure (Closure a -> [Closure a])
-> Closure (Closure a -> [Closure b] -> Closure b)
-> Closure (Closure a -> Par (Closure b))
-> Closure a
-> Par (Closure b)
parDivideAndConquer trivial_clo decompose_clo combine_clo f_clo x
| trivial x = f x
| otherwise = combine x <$> parClosureMapM solveRec_clo (decompose x)
where
trivial = unClosure trivial_clo
decompose = unClosure decompose_clo
combine = unClosure combine_clo
f = unClosure f_clo
solveRec_clo =
$(mkClosure [| parDivideAndConquer_abs
(trivial_clo, decompose_clo, combine_clo, f_clo) |])
parDivideAndConquer_abs :: (Closure (Closure a -> Bool),
Closure (Closure a -> [Closure a]),
Closure (Closure a -> [Closure b] -> Closure b),
Closure (Closure a -> Par (Closure b)))
-> Closure a -> Par (Closure b)
parDivideAndConquer_abs (trivial_clo, decompose_clo, combine_clo, f_clo) =
parDivideAndConquer trivial_clo decompose_clo combine_clo f_clo
pushDivideAndConquer :: [NodeId]
-> Closure (Closure a -> Bool)
-> Closure (Closure a -> [Closure a])
-> Closure (Closure a -> [Closure b] -> Closure b)
-> Closure (Closure a -> Par (Closure b))
-> Closure a
-> Par (Closure b)
pushDivideAndConquer ns trivial_clo decompose_clo combine_clo f_clo x
| trivial x = f x
| otherwise = combine x <$> pushRandClosureMapM ns solveRec_clo (decompose x)
where
trivial = unClosure trivial_clo
decompose = unClosure decompose_clo
combine = unClosure combine_clo
f = unClosure f_clo
solveRec_clo =
$(mkClosure [| pushDivideAndConquer_abs
(ns,trivial_clo,decompose_clo,combine_clo,f_clo) |])
pushDivideAndConquer_abs :: ([NodeId],
Closure (Closure a -> Bool),
Closure (Closure a -> [Closure a]),
Closure (Closure a -> [Closure b] -> Closure b),
Closure (Closure a -> Par (Closure b)))
-> Closure a -> Par (Closure b)
pushDivideAndConquer_abs (ns, trivial_clo, decompose_clo, combine_clo, f_clo) =
pushDivideAndConquer ns trivial_clo decompose_clo combine_clo f_clo