diff --git a/Control/Parallel/Eden/Auxiliary.hs b/Control/Parallel/Eden/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/Control/Parallel/Eden/Auxiliary.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.Eden.Auxiliary +-- Copyright : (c) Philipps Universitaet Marburg 2009-2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : eden@mathematik.uni-marburg.de +-- Stability : beta +-- Portability : not portable +-- +-- This Haskell module defines auxiliary functions for +-- programming with the parallel functional language Eden. +-- +-- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. +-- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden +-- for a parallel build. +-- +-- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) + + +#if defined(NOT_PARALLEL) +#warning !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\ + Eden BUILD WITH CONCURRENT HASKELL SIMULATION OF PARALLEL PRIMITIVES, \ + DON'T EXPECT SPEEDUPS! USE THE EDEN VERSION OF GHC FROM \ + http://www.mathematik.uni-marburg.de/~eden \ + FOR A PARALLEL BUILD \ + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' +#endif +module Control.Parallel.Eden.Auxiliary ( + -- * Distribution and combine functions + -- | ... of form: @ Int -> [a] -> [[a]] @ / @ [[a]] -> [a] @ + unshuffle, shuffle, + splitIntoN, unSplit, + chunk, unchunk, + -- * Distribution function for workpools + distribute, + -- * Lazy functions + lazy, + lazy1ZipWith, lazy2ZipWith, + lazy1Zip, lazy2Zip, + lazyTranspose, + -- * other useful functions + takeEach, transposeRt, + -- * unLiftRDs + unLiftRD, unLiftRD2, unLiftRD3, unLiftRD4, + -- * More predefined Parallel Actions + spawnPss, fetch2, fetchRDss, mergeS + ) where + +import Data.List +import Data.Maybe(maybeToList,mapMaybe) +import Control.Concurrent +import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO) +#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) +import Control.Parallel.Eden +#else +import Control.Parallel.Eden.EdenConcHs +#endif + +-- | Round robin distribution - inverse to shuffle +-- +unshuffle :: Int -- ^number of sublists + -> [a] -- ^input list + -> [[a]] -- ^distributed output +unshuffle n xs = [takeEach n (drop i xs) | i <- [0..n-1]] + +takeEach :: Int -> [a] -> [a] +takeEach n [] = [] +takeEach n (x:xs) = x : takeEach n (drop (n-1) xs) + + +-- | Simple shuffling - inverse to round robin distribution +shuffle :: [[a]] -- ^ sublists + -> [a] -- ^ shuffled sublists +shuffle = concat . transpose + +-- | transpose for matrices of rectangular shape (rows of equal length). Top level list of the resulting matrix is defined as soon as the first row of the original matrix is closed. +transposeRt :: [[a]] -> [[a]] +transposeRt [] = [] +transposeRt ([] : xss) = [] -- originally transpose xss -- keeps top level list open until all rows are done +transposeRt ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transposeRt (xs : [ t | (_:t) <- xss]) + +-- | Block distribution, @ splitIntoN @ distributes one list on n lists with +-- equal distribution ((+-1) without precondition on length). +splitIntoN :: Int -- ^ number of blocks + -> [a] -- ^list to be split + -> [[a]] -- ^list of blocks +splitIntoN n xs = chunkBalance (l `div` n) (l `mod` n) xs where + l = length xs +-- | Inverse function to @ splitIntoN @ - alias for concat. +unSplit :: [[a]] -- ^list of blocks + -> [a] -- ^restored list +unSplit = concat + +-- | Creates a list of chunks of length @ d @. The first @ m @ chunks will +-- contain an extra element. +-- +-- Result: list of chunks (blocks) +chunkBalance :: Int -- ^@ d @: chunk-length + -> Int -- ^@ m @: number of bigger blocks + -> [a] -- ^list to be split + -> [[a]] -- ^list of chunks (blocks) +chunkBalance d = chunk' where + chunk' _ [] = [] + chunk' 0 xs = ys : chunk' 0 zs where + (ys,zs) = splitAt d xs + chunk' m xs = ys : chunk' (m-1) zs where + (ys,zs) = splitAt (d+1) xs + +-- | Creates a list of chunks of length @ d@ . +-- +-- Result: list of chunks (blocks) +chunk :: Int -- ^@ d @: chunk-length + -> [a] -- ^list to be split + -> [[a]] -- ^list of chunks (blocks) +chunk l = chunkBalance l 0 + +-- | Inverse function to @ chunk @ - alias for concat. +unchunk :: [[a]] -- ^list of chunks + -> [a] -- ^restored list +unchunk = concat + +-- | Task distribution according to worker requests. +-- +distribute :: Int -- ^number of workers + -> [Int] -- ^ request stream (worker IDs ranging from 0 to n-1) + -> [t] -- ^ task list + -> [[t]] -- ^ task distribution, each inner list for one worker +distribute np reqs tasks = [taskList reqs tasks n | n<-[0..np-1]] + where taskList (r:rs) (t:ts) pe + | pe == r = t:(taskList rs ts pe) + | otherwise = taskList rs ts pe + taskList _ _ _ = [] + + + + +----------------------------Lazy Functions---------------------------- +-- | A lazy list is an infinite stream +lazy :: [a] -> [a] +lazy ~(x:xs) = x : lazy xs + +-- |lazy in first argument +lazy1ZipWith :: (a->b->c) -> [a] -> [b] -> [c] +lazy1ZipWith f xs = zipWith f (lazy xs) + +-- |lazy in second argument +lazy2ZipWith :: (a->b->c) -> [a] -> [b] -> [c] +lazy2ZipWith f xs ys = zipWith f xs (lazy ys) + +-- |lazy in first argument +lazy1Zip :: [a] -> [b] -> [(a,b)] +lazy1Zip xs ys = zip (lazy xs) ys + +-- |lazy in second argument +lazy2Zip :: [a] -> [b] -> [(a,b)] +lazy2Zip xs ys = zip xs (lazy ys) + +-- |lazy in tail lists +lazyTranspose :: [[a]] -> [[a]] +lazyTranspose = foldr (lazy2ZipWith (:)) (repeat []) + +---------------------------unLiftRDs------------------------------ +unLiftRD :: (Trans a, Trans b) => + (RD a -> RD b) -- ^ Function to be unlifted + -> a -- ^ input + -> b -- ^ output +unLiftRD f = fetch . f . release + +-- | see @liftRD@ +unLiftRD2 :: (Trans a, Trans b, Trans c) + => (RD a -> RD b -> RD c) -- ^ Function to be unlifted + -> a -- ^ First input + -> b -- ^ Second input + -> c -- ^ output +unLiftRD2 f x = unLiftRD (f (release x)) + +-- | see @liftRD@ +unLiftRD3 :: (Trans a, Trans b, Trans c, Trans d) => (RD a -> RD b -> RD c -> RD d) -> a -> b -> c -> d +unLiftRD3 f x = unLiftRD2 (f (release x)) + +-- | see @liftRD@ +unLiftRD4 :: (Trans a, Trans b, Trans c, Trans d, Trans e) => (RD a -> RD b -> RD c -> RD d -> RD e) -> a -> b -> c -> d -> e +unLiftRD4 f x = unLiftRD3 (f (release x)) + +---------------------------Parallel Actions--------------------------------- +-- | Spawn a matrix of processes +spawnPss :: (Trans a, Trans b) => [[Process a b]] -> [[a]] -> [[b]] +spawnPss pss xss = runPA $ sequence $ zipWith3 (\is ps xs -> sequence (zipWith3 instantiateAt is ps xs)) iss pss xss where + iss = (unshuffle (length (zip pss xss)) [selfPe+1..]) + +-- | Fetch two Remote Data values +fetch2 :: (Trans a, Trans b) => RD a -> RD b -> (a,b) +fetch2 a b = runPA $ + do a' <- fetchPA a + b' <- fetchPA b + return (a',b') +-- | Fetch a matrix of Remote Data +fetchRDss :: Trans a => [[RD a]] -> [[a]] +fetchRDss rda = runPA $ mapM (mapM fetchPA) rda + +--------------------merge variant mergeS----------------- +-- | A variant of non-deterministic list merging, which applies a strategy to list elements prior to merging them and stops the additional merge thread (the suckIO_S thread) when only one input stream is left. +mergeS:: [[a]] -> Strategy a -> [a] +mergeS l st = unsafePerformIO (nmergeIO_S l st) + + +nmergeIO_S :: [[a]] -> Strategy a -> IO [a] +nmergeIO_S lss st + = let + len = length lss + in + newEmptyMVar >>= \ tail_node -> + newMVar tail_node >>= \ tail_list -> + newQSem max_buff_size >>= \ e -> + newMVar len >>= \ branches_running -> + let + buff = (tail_list,e) + in + mapIO (\ x -> forkIO (suckIO_S branches_running buff x st)) lss >> + takeMVar tail_node >>= \ val -> + signalQSem e >> + return val + where + mapIO f xs = sequence (map f xs) + + +suckIO_S :: MVar Int -> Buffer a -> [a] -> Strategy a -> IO () + +suckIO_S branches_running buff@(tail_list,e) vs st + = do count <- takeMVar branches_running + if count == 1 then + takeMVar tail_list >>= \ node -> + putMVar node vs >> + putMVar tail_list node + else putMVar branches_running count >> + case vs of + [] -> takeMVar branches_running >>= \ val -> + if val == 1 then + takeMVar tail_list >>= \ node -> + putMVar node [] >> + putMVar tail_list node + else + putMVar branches_running (val-1) + (x:xs) -> + (st x `seq` waitQSem e) >> + takeMVar tail_list >>= \ node -> + newEmptyMVar >>= \ next_node -> + unsafeInterleaveIO ( + takeMVar next_node >>= \ y -> + signalQSem e >> + return y) >>= \ next_node_val -> + putMVar node (x:next_node_val) >> + putMVar tail_list next_node >> + suckIO_S branches_running buff xs st + +type Buffer a + = (MVar (MVar [a]), QSem) + +max_buff_size :: Int +max_buff_size = 1 diff --git a/Control/Parallel/Eden/DivConq.hs b/Control/Parallel/Eden/DivConq.hs new file mode 100644 --- /dev/null +++ b/Control/Parallel/Eden/DivConq.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.Eden.DivConq +-- Copyright : (c) Philipps Universitaet Marburg 2009-2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : eden@mathematik.uni-marburg.de +-- Stability : beta +-- Portability : not portable +-- +-- This Haskell module defines divide-and-conquer skeletons for +-- the parallel functional language Eden. +-- +-- All divide-and-conquer algorithms are parameterised with control functions +-- which decide if a problem is trivial, how to solve a trivial problem, +-- how to split a non-trivial problem into smaller problems and how to combine solutions +-- of subproblems into a solution of the problem. +-- +-- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. +-- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden +-- for a parallel build. +-- +-- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) +-- + +module Control.Parallel.Eden.DivConq ( + -- * Divide-and-conquer scheme + DivideConquer, DivideConquerSimple, + -- * Sequential divide-and-conquer + dc, + -- * Distributed expansion divide-and-conquer skeletons + -- ** Straightforward implementation for arbitrary DC problems + parDC, + -- ** Divide-and-conquer skeleton for regular n-ary trees + disDC, offline_disDC, disDCdepth, disDCn, + -- * Flat expansion divide-and-conquer skeletons + flatDC, + + -- * Deprecated divide-and-conquer skeletons (legacy code) + -- ** Deprecated sequential divide-and-conquer + divConSeq, divConSeq_c, + -- ** Deprecated straightforward implementations for arbitrary DC problems + divCon, divCon_c, divConD, divConD_c, + -- ** Deprecated divide-and-conquer skeleton for regular n-ary trees + dcN, dcN_c, dcN', dcN_c', dcNTickets, dcNTickets_c, + -- ** Deprecated flat expansion divide-and-conquer skeletons + divConFlat, divConFlat_c + ) where +#if defined( __PARALLEL_HASKELL__ ) +import Control.Parallel.Eden +#else +import Control.Parallel.Eden.EdenConcHs +#endif +import Control.Parallel.Eden.Map +import Control.Parallel.Eden.Auxiliary + + + +-- Divide-and-conquer scheme +type DivideConquer a b + = (a -> Bool) -- ^ trivial? + -> (a -> b) -- ^ solve + -> (a -> [a]) -- ^ split + -> (a -> [b] -> b) -- ^ combine + -> a -- ^ input + -> b -- ^ result + +-- | Sequential Version. +dc :: DivideConquer a b +dc trivial solve split combine = rec_dc + where + rec_dc x = if trivial x then solve x + else combine x (map rec_dc (split x)) + + +-- | Simple parMap parallelisation with depth control but +-- no placement control. This variant allows to +-- give an additional depth parameter for the recursion, proceeding in a +-- sequential manner when @depth=0@. The process scheme unfolds the call +-- tree on processors chosen by the runtime environment. Round-Robin +-- distribution is unfavourable for this skeleton, better use RTS option +-- @+RTS -qrnd@ when using it. +parDC :: (Trans a, Trans b) + => Int -- ^ parallel depth + -> DivideConquer a b +parDC lv trivial solve split combine + = pdc lv + where + pdc lv x + | lv == 0 = dc trivial solve split combine x + | lv > 0 = if trivial x then solve x + else combine x (parMap (pdc (lv-1)) (split x)) + + +-- | Distributed-expansion divide-and-conquer skeleton +-- (tutorial version, similar to dcNTickets). +disDC :: (Trans a, Trans b) + => Int -- ^ branching degree + -> Places -- ^ tickets + -> DivideConquer a b +disDC k tickets trivial solve split combine x + = if null tickets then seqDC x + else recDC tickets x + where + seqDC = dc trivial solve split combine + recDC tickets x = + if trivial x then solve x + else childRes `pseq` -- explicit demand + rdeepseq myRes `pseq` -- control + combine x ( myRes:childRes ++ localRess ) + where + -- child process generation + childRes = spawnAt childTickets childProcs procIns + childProcs = map (process . recDC) theirTs + -- ticket distribution + (childTickets, restTickets) = splitAt (k-1) tickets + (myTs: theirTs) = unshuffle k restTickets + -- input splitting + (myIn:theirIn) = split x + (procIns, localIns) + = splitAt (length childTickets) theirIn + -- local computations + myRes = recDC myTs myIn + localRess = map seqDC localIns + +-- | offline distributed-expansion divide-and-conquer skeleton. +offline_disDC :: Trans b + => Int -- ^ branching degree + -> [Int] -- ^ tickets + -> DivideConquer a b +offline_disDC k ts triv solve split combine x + = snd (disDC k ts newtriv newsolve newsplit newcombine 0) + where + seqDC = dc triv solve split combine + newsplit = successors k + newtriv n = length ts <= k^(length (path k n)) + newsolve n = (flag, seqDC localx) + where (flag, localx) = select triv split x (path k n) + newcombine n bs@((flag,bs1):_) + = if flag then (True, combine localx (map snd bs)) + else (lab, bs1) + where (lab, localx) = select triv split x (path k n) + + +-- local selection function for offline distributed-expansion divide-and-conquer skeleton +select :: (a -> Bool) -> (a -> [a]) -- ^ trivial / split + -> a -> [Int] -> (Bool,a) +select trivial split x ys = go x ys + where go x [] = (True, x) + go x (y:ys) = if trivial x then (False, x) + else go (split x !! y) ys + +-- auxiliary functions for offline distributed-expansion divide-and-conquer skeleton +successors :: Int -> Int -> [Int] +successors k n = [nk + i | let nk = n*k, i <- [1..k]] + +path :: Int -> Int -> [Int] +path k n | n == 0 = [] + | otherwise = reverse (factors k n) + +factors :: Int -> Int -> [Int] +factors k n + | n <= 0 = [] + | otherwise = (n+k-1) `mod` k : factors k ((n-1) `div` k) + +-- | DC skeleton with fixed branching degree, parallel depth control and explicit process +-- placement (tree-shaped process creation, one task in each recursive step stays local). +disDCdepth :: (Trans a, Trans b) + => Int -- ^ branching degree + -> Int -- ^ parallel depth + -> DivideConquer a b +disDCdepth k depth trivial solve split combine x + | depth < 1 = dc trivial solve split combine x + | trivial x = solve x + | otherwise = childRs `seq` -- early demand on children list + combine x (myR : childRs) + where myself = disDCdepth k (depth - 1) trivial solve split combine + (mine:rest) = split x + myR = myself mine + childRs = parMapAt places myself rest + `using` seqList r0 -- ??? + -- placement with stride for next children, round-robin + places = map ((+1) . (`mod` noPe) . (+(-1))) shifts + shifts = map (selfPe +) [shift,2*shift..] + shift = k ^ (depth -1) + +-- | Like 'disDCdepth', but controls parallelism by limiting the number of processes instead of the parallel depth. +disDCn :: (Trans a, Trans b) + => Int -- ^ branching degree + -> Int -- ^ number of processes + -> DivideConquer a b +disDCn k n = disDCdepth n depth + where depth = logN k n + +-- rounding-up log approximation +logN n 1 = 0 +logN n k | k > 0 = 1 + logN n ((k + n-1) `div` n) -- round up + | otherwise = error "logN" + +-------------------------------Flat Expansion---------------------------------- +-- | DC Skeleton with flat expansion of upper DC-tree levels, takes custom map +-- skeletons to solve expanded tasks (a sequential map skeleton leads to a +-- sequential DC-skeleton). +flatDC :: (Trans a,Trans b) => + ((a->b)->[a]->[b]) -- ^custom map implementation + -> Int -- ^depth + -> DivideConquer a b +flatDC myMap depth trivial solve split combine x + = combineTopMaster combine levels results + where (tasks,levels) = generateTasks depth trivial split x + results = myMap(divConSeq_c trivial solve split combine) tasks + + + +combineTopMaster :: (NFData b) => + (a->[b]->b) -> (Tree a) -> [b] -> b +combineTopMaster c t bs = fst (combineTopRnf c t bs) + + +combineTopRnf :: (NFData b) => + (a->[b]->b) -> (Tree a) -> [b] -> (b,[b]) +combineTopRnf _ (Leaf a) (b:bs) = (b,bs) +combineTopRnf combine (Tree a ts) bs + = (rnf res `pseq` combine a res, bs') + where (bs',res) = foldl f (bs,[]) ts + f (olds,news) t = (remaining,news++[b]) + where (b,remaining) = combineTopRnf combine t olds + + +generateTasks :: Int -> (a->Bool) -> (a->[a]) -> a -> ([a],Tree a) +generateTasks 0 _ _ a = ([a],Leaf a) +generateTasks n trivial split a + | trivial a = ([a],Leaf a) + | otherwise = (concat ass,Tree a ts) + where assts = map (generateTasks (n-1) trivial split) (split a) + (ass,ts) = unzip assts + + +data Tree a = Tree a [Tree a] | Leaf a deriving Show +instance NFData a => NFData (Tree a) + where rnf (Tree a ls) = rnf a `seq` rnf ls + rnf (Leaf a) = rnf a + +-----------------------------------DEPRECATED-------------------------------- +-- | The simple interface (deprecated): combine function without input +type DivideConquerSimple a b + = (a -> Bool) -- ^ trivial? + -> (a -> b) -- ^ solve + -> (a -> [a]) -- ^ split + -> ([b] -> b) -- ^ combine (only uses sub-results, not the input) + -> a -- ^ input + -> b -- ^ result + + +-- | Like 'dc' but uses simple DC Interface. +{-# DEPRECATED divConSeq, divConSeq_c "better use dc instead" #-} +divConSeq :: (Trans a, Trans b) => DivideConquerSimple a b +divConSeq trivial solve split combine x + = dc trivial solve split (\_ parts -> combine parts) x + +-- | Tutorial version, same as 'dc' + +divConSeq_c :: (Trans a, Trans b) => DivideConquer a b +divConSeq_c = dc + + +-- | Straightforward implementation. +-- +-- The straightforward method to parallelise divide-and-conquer +-- algorithms is to unfold the call tree onto different +-- processors. The process scheme unfolds the call tree on processors chosen by the +-- runtime environment. Round-Robin distribution is unfavourable for this +-- skeleton, better use runtime option @-qrnd@ when using it. +{-# DEPRECATED divCon, divCon_c, divConD, divConD_c "better use parDC instead" #-} +divCon :: (Trans a, Trans b) => DivideConquerSimple a b +divCon trivial solve split combine x + = divCon_c trivial solve split (\_ parts -> combine parts) x + +-- | Like 'divCon' but with different combine signature (takes the original problem as additional input). +divCon_c :: (Trans a, Trans b) => DivideConquer a b +divCon_c trivial solve split combine x + | trivial x = solve x + | otherwise = combine x children + where children = parMap (divCon_c trivial solve split combine) (split x) + + +-- | Like 'parDC' but uses simple DC Interface. +divConD :: (Trans a, Trans b) + => Int -- ^parallel depth + -> DivideConquerSimple a b +divConD depth trivial solve split combine x + = parDC depth trivial solve split (\_ parts -> combine parts) x + +-- | Tutorial version, same as 'parDC'. +divConD_c :: (Trans a, Trans b) + => Int -- ^parallel depth + -> DivideConquer a b +divConD_c = parDC + +-- | Like 'disDCdepth' but uses simple DC Interface. +{-# DEPRECATED dcN, dcN_c "better use disDCdepth instead" #-} +dcN :: (Trans a, Trans b) + => Int -- ^ branching degree + -> Int -- ^ parallel depth + -> DivideConquerSimple a b +dcN n depth trivial solve split combine x + = disDCdepth n depth trivial solve split (\_ parts -> combine parts) x + +-- | Tutorial version, same as 'disDCdepth' +dcN_c :: (Trans a, Trans b) + => Int -- ^ branching degree + -> Int -- ^ parallel depth + -> DivideConquer a b +dcN_c = disDCdepth + +-- | Like 'disDCn' but uses simple DC Interface. +{-# DEPRECATED dcN', dcN_c' "better use disDCn instead" #-} +dcN' :: (Trans a, Trans b) + => Int -- ^ branching degree + -> Int -- ^ number of processes + -> DivideConquerSimple a b +dcN' n pes = dcN n depth + where depth = logN n pes + +-- | Tutorial version, same as 'disDCn'. +dcN_c' :: (Trans a, Trans b) + => Int -- ^ branching degree + -> Int -- ^ number of processes + -> DivideConquer a b +dcN_c' = disDCn + +--------------------------------------------------------------- +-- | Like 'disDC', but differs in demand control and uses simple DC Interface. +{-# DEPRECATED dcNTickets, dcNTickets_c "better use disDC instead" #-} +dcNTickets :: (Trans a, Trans b) => + Int -- ^ branching degree + -> Places -- ^ tickets (places to use) + -> DivideConquerSimple a b +dcNTickets k ts trivial solve split combine x + = dcNTickets_c k ts trivial solve split (\_ parts -> combine parts) x + +-- | Like 'disDC', but differs in demand control. +dcNTickets_c :: (Trans a, Trans b) + => Int -- ^ branching degree + -> Places -- ^ Tickets (places to use) + -> DivideConquer a b +dcNTickets_c k [] trivial solve split combine x + = divConSeq_c trivial solve split combine x +dcNTickets_c k tickets trivial solve split combine x + = if trivial x then solve x + else childRes `pseq` -- early demand on children list + rnf myRes `pseq` rnf localRess `pseq` + combine x (myRes:childRes ++ localRess ) + where + -- splitting computation into processes + (childTickets,restTickets) = splitAt (k-1) tickets --position of (children,further ancestors) + (myTs:theirTs)= unshuffle k restTickets + ticketF ts = dcNTickets_c k ts trivial solve split combine + insts = length childTickets + (procIns, localIns) = splitAt insts theirIn + childProcs = map (process . ticketF) theirTs + childRes = spawnAt childTickets childProcs procIns + + -- local computation: + myRes = ticketF myTs myIn + (myIn:theirIn) = split x + localRess = map (divConSeq_c trivial solve split combine) localIns + + + +-- | Like as 'flatDC' but uses simple DC Interface. +{-# DEPRECATED divConFlat, divConFlat_c "better use flatDC instead" #-} +divConFlat :: (Trans a,Trans b) => + ((a->b)->[a]->[b]) -- ^custom map implementation + -> Int -- ^depth + -> DivideConquerSimple a b +divConFlat myMap depth trivial solve split combine x + = divConFlat_c myMap depth trivial solve split (\_ parts -> combine parts) x + +-- | Tutorial version, same as 'flatDC'. +divConFlat_c :: (Trans a,Trans b) + => ((a->b)->[a]->[b]) -- ^ custom map implementation + -> Int -- ^ parallel depth + -> DivideConquer a b +divConFlat_c = flatDC diff --git a/Control/Parallel/Eden/EdenSkel/Auxiliary.hs b/Control/Parallel/Eden/EdenSkel/Auxiliary.hs deleted file mode 100644 --- a/Control/Parallel/Eden/EdenSkel/Auxiliary.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Parallel.Eden.EdenSkel.Auxiliary --- Copyright : (c) Philipps Universitaet Marburg 2009-2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : eden@mathematik.uni-marburg.de --- Stability : beta --- Portability : not portable --- --- This Haskell module defines auxiliary functions for --- programming with the parallel functional language Eden. --- --- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. --- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden --- for a parallel build. --- --- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) - - -#if defined(NOT_PARALLEL) -#warning !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\ - Eden BUILD WITH CONCURRENT HASKELL SIMULATION OF PARALLEL PRIMITIVES, \ - DON'T EXPECT BIG SPEEDUPS! USE THE EDEN VERSION OF GHC FROM \ - http://www.mathematik.uni-marburg.de/~eden \ - FOR A PARALLEL BUILD \ - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' -#endif -module Control.Parallel.Eden.EdenSkel.Auxiliary ( - -- * Distribution and combine functions - -- | ... of form: @ Int -> [a] -> [[a]] @ / @ [[a]] -> [a] @ - unshuffle, shuffle, - splitIntoN, unSplit, - chunk, unchunk, - -- * Distribution function for workpools - distribute, - -- * Lazy functions - lazy, - lazy1ZipWith, lazy2ZipWith, - lazy1Zip, lazy2Zip, - lazyTranspose, - -- * other useful functions - takeEach, transposeRt, - -- * unLiftRDs - unLiftRD, unLiftRD2, unLiftRD3, unLiftRD4, - -- * More predefined Parallel Actions - spawnPss, fetch2, fetchRDss, mergeS - ) where - -import Data.List -import Data.Maybe(maybeToList,mapMaybe) -import Control.Concurrent -import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO) -#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) -import Control.Parallel.Eden -#else -import Control.Parallel.Eden.EdenConcHs -#endif - --- | Round robin distribution - inverse to shuffle --- -unshuffle :: Int -- ^number of sublists - -> [a] -- ^input list - -> [[a]] -- ^distributed output -unshuffle n xs = [takeEach n (drop i xs) | i <- [0..n-1]] - -takeEach :: Int -> [a] -> [a] -takeEach n [] = [] -takeEach n (x:xs) = x : takeEach n (drop (n-1) xs) - - --- | Simple shuffling - inverse to round robin distribution -shuffle :: [[a]] -- ^ sublists - -> [a] -- ^ shuffled sublists -shuffle = concat . transpose - --- | transpose for matrices of rectangular shape (rows of equal length). Top level list of the resulting matrix is defined as soon as the first row of the original matrix is closed. -transposeRt :: [[a]] -> [[a]] -transposeRt [] = [] -transposeRt ([] : xss) = [] -- originally transpose xss -- keeps top level list open until all rows are done -transposeRt ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transposeRt (xs : [ t | (_:t) <- xss]) - --- | Block distribution, @ splitIntoN @ distributes one list on n lists with --- equal distribution ((+-1) without precondition on length). -splitIntoN :: Int -- ^ number of blocks - -> [a] -- ^list to be split - -> [[a]] -- ^list of blocks -splitIntoN n xs = chunkBalance (l `div` n) (l `mod` n) xs where - l = length xs --- | Inverse function to @ splitIntoN @ - alias for concat. -unSplit :: [[a]] -- ^list of blocks - -> [a] -- ^restored list -unSplit = concat - --- | Creates a list of chunks of length @ d @. The first @ m @ chunks will --- contain an extra element. --- --- Result: list of chunks (blocks) -chunkBalance :: Int -- ^@ d @: chunk-length - -> Int -- ^@ m @: number of bigger blocks - -> [a] -- ^list to be split - -> [[a]] -- ^list of chunks (blocks) -chunkBalance d = chunk' where - chunk' _ [] = [] - chunk' 0 xs = ys : chunk' 0 zs where - (ys,zs) = splitAt d xs - chunk' m xs = ys : chunk' (m-1) zs where - (ys,zs) = splitAt (d+1) xs - --- | Creates a list of chunks of length @ d@ . --- --- Result: list of chunks (blocks) -chunk :: Int -- ^@ d @: chunk-length - -> [a] -- ^list to be split - -> [[a]] -- ^list of chunks (blocks) -chunk l = chunkBalance l 0 - --- | Inverse function to @ chunk @ - alias for concat. -unchunk :: [[a]] -- ^list of chunks - -> [a] -- ^restored list -unchunk = concat - --- | Task distribution according to worker requests. --- -distribute :: Int -- ^number of workers - -> [Int] -- ^ request stream (worker IDs ranging from 0 to n-1) - -> [t] -- ^ task list - -> [[t]] -- ^ task distribution, each inner list for one worker -distribute np reqs tasks = [taskList reqs tasks n | n<-[0..np-1]] - where taskList (r:rs) (t:ts) pe - | pe == r = t:(taskList rs ts pe) - | otherwise = taskList rs ts pe - taskList _ _ _ = [] - - - - -----------------------------Lazy Functions---------------------------- --- | A lazy list is an infinite stream -lazy :: [a] -> [a] -lazy ~(x:xs) = x : lazy xs - --- |lazy in first argument -lazy1ZipWith :: (a->b->c) -> [a] -> [b] -> [c] -lazy1ZipWith f xs = zipWith f (lazy xs) - --- |lazy in second argument -lazy2ZipWith :: (a->b->c) -> [a] -> [b] -> [c] -lazy2ZipWith f xs ys = zipWith f xs (lazy ys) - --- |lazy in first argument -lazy1Zip :: [a] -> [b] -> [(a,b)] -lazy1Zip xs ys = zip (lazy xs) ys - --- |lazy in second argument -lazy2Zip :: [a] -> [b] -> [(a,b)] -lazy2Zip xs ys = zip xs (lazy ys) - --- |lazy in tail lists -lazyTranspose :: [[a]] -> [[a]] -lazyTranspose = foldr (lazy2ZipWith (:)) (repeat []) - ----------------------------unLiftRDs------------------------------ -unLiftRD :: (Trans a, Trans b) => - (RD a -> RD b) -- ^ Function to be unlifted - -> a -- ^ input - -> b -- ^ output -unLiftRD f = fetch . f . release - --- | see @liftRD@ -unLiftRD2 :: (Trans a, Trans b, Trans c) - => (RD a -> RD b -> RD c) -- ^ Function to be unlifted - -> a -- ^ First input - -> b -- ^ Second input - -> c -- ^ output -unLiftRD2 f x = unLiftRD (f (release x)) - --- | see @liftRD@ -unLiftRD3 :: (Trans a, Trans b, Trans c, Trans d) => (RD a -> RD b -> RD c -> RD d) -> a -> b -> c -> d -unLiftRD3 f x = unLiftRD2 (f (release x)) - --- | see @liftRD@ -unLiftRD4 :: (Trans a, Trans b, Trans c, Trans d, Trans e) => (RD a -> RD b -> RD c -> RD d -> RD e) -> a -> b -> c -> d -> e -unLiftRD4 f x = unLiftRD3 (f (release x)) - ----------------------------Parallel Actions--------------------------------- --- | Spawn a matrix of processes -spawnPss :: (Trans a, Trans b) => [[Process a b]] -> [[a]] -> [[b]] -spawnPss pss xss = runPA $ sequence $ zipWith3 (\is ps xs -> sequence (zipWith3 instantiateAt is ps xs)) iss pss xss where - iss = (unshuffle (length (zip pss xss)) [selfPe+1..]) - --- | Fetch two Remote Data values -fetch2 :: (Trans a, Trans b) => RD a -> RD b -> (a,b) -fetch2 a b = runPA $ - do a' <- fetchPA a - b' <- fetchPA b - return (a',b') --- | Fetch a matrix of Remote Data -fetchRDss :: Trans a => [[RD a]] -> [[a]] -fetchRDss rda = runPA $ mapM (mapM fetchPA) rda - ---------------------merge variant mergeS----------------- --- | A variant of non-deterministic list merging, which applies a strategy to list elements prior to merging them and stops the additional merge thread (the suckIO_S thread) when only one input stream is left. -mergeS:: [[a]] -> Strategy a -> [a] -mergeS l st = unsafePerformIO (nmergeIO_S l st) - - -nmergeIO_S :: [[a]] -> Strategy a -> IO [a] -nmergeIO_S lss st - = let - len = length lss - in - newEmptyMVar >>= \ tail_node -> - newMVar tail_node >>= \ tail_list -> - newQSem max_buff_size >>= \ e -> - newMVar len >>= \ branches_running -> - let - buff = (tail_list,e) - in - mapIO (\ x -> forkIO (suckIO_S branches_running buff x st)) lss >> - takeMVar tail_node >>= \ val -> - signalQSem e >> - return val - where - mapIO f xs = sequence (map f xs) - - -suckIO_S :: MVar Int -> Buffer a -> [a] -> Strategy a -> IO () - -suckIO_S branches_running buff@(tail_list,e) vs st - = do count <- takeMVar branches_running - if count == 1 then - takeMVar tail_list >>= \ node -> - putMVar node vs >> - putMVar tail_list node - else putMVar branches_running count >> - case vs of - [] -> takeMVar branches_running >>= \ val -> - if val == 1 then - takeMVar tail_list >>= \ node -> - putMVar node [] >> - putMVar tail_list node - else - putMVar branches_running (val-1) - (x:xs) -> - (st x `seq` waitQSem e) >> - takeMVar tail_list >>= \ node -> - newEmptyMVar >>= \ next_node -> - unsafeInterleaveIO ( - takeMVar next_node >>= \ y -> - signalQSem e >> - return y) >>= \ next_node_val -> - putMVar node (x:next_node_val) >> - putMVar tail_list next_node >> - suckIO_S branches_running buff xs st - -type Buffer a - = (MVar (MVar [a]), QSem) - -max_buff_size :: Int -max_buff_size = 1 diff --git a/Control/Parallel/Eden/EdenSkel/DCSkels.hs b/Control/Parallel/Eden/EdenSkel/DCSkels.hs deleted file mode 100644 --- a/Control/Parallel/Eden/EdenSkel/DCSkels.hs +++ /dev/null @@ -1,386 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Parallel.Eden.EdenSkel.DCSkels --- Copyright : (c) Philipps Universitaet Marburg 2009-2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : eden@mathematik.uni-marburg.de --- Stability : beta --- Portability : not portable --- --- This Haskell module defines divide-and-conquer skeletons for --- the parallel functional language Eden. --- --- All divide-and-conquer algorithms are parameterised with control functions --- which decide if a problem is trivial, how to solve a trivial problem, --- how to split a non-trivial problem into smaller problems and how to combine solutions --- of subproblems into a solution of the problem. --- --- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. --- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden --- for a parallel build. --- --- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) --- - -module Control.Parallel.Eden.EdenSkel.DCSkels ( - -- * Divide-and-conquer scheme - DivideConquer, DivideConquerSimple, - -- * Sequential divide-and-conquer - dc, - -- * Distributed expansion divide-and-conquer skeletons - -- ** Straightforward implementation for arbitrary DC problems - parDC, - -- ** Divide-and-conquer skeleton for regular n-ary trees - disDC, offline_disDC, disDCdepth, disDCn, - -- * Flat expansion divide-and-conquer skeletons - flatDC, - - -- * Deprecated divide-and-conquer skeletons (legacy code) - -- ** Deprecated sequential divide-and-conquer - divConSeq, divConSeq_c, - -- ** Deprecated straightforward implementations for arbitrary DC problems - divCon, divCon_c, divConD, divConD_c, - -- ** Deprecated divide-and-conquer skeleton for regular n-ary trees - dcN, dcN_c, dcN', dcN_c', dcNTickets, dcNTickets_c, - -- ** Deprecated flat expansion divide-and-conquer skeletons - divConFlat, divConFlat_c - ) where -#if defined( __PARALLEL_HASKELL__ ) -import Control.Parallel.Eden -#else -import Control.Parallel.Eden.EdenConcHs -#endif -import Control.Parallel.Eden.EdenSkel.MapSkels -import Control.Parallel.Eden.EdenSkel.Auxiliary - - - --- Divide-and-conquer scheme -type DivideConquer a b - = (a -> Bool) -- ^ trivial? - -> (a -> b) -- ^ solve - -> (a -> [a]) -- ^ split - -> (a -> [b] -> b) -- ^ combine - -> a -- ^ input - -> b -- ^ result - --- | Sequential Version. -dc :: DivideConquer a b -dc trivial solve split combine = rec_dc - where - rec_dc x = if trivial x then solve x - else combine x (map rec_dc (split x)) - - --- | Simple parMap parallelisation with depth control but --- no placement control. This variant allows to --- give an additional depth parameter for the recursion, proceeding in a --- sequential manner when @depth=0@. The process scheme unfolds the call --- tree on processors chosen by the runtime environment. Round-Robin --- distribution is unfavourable for this skeleton, better use RTS option --- @+RTS -qrnd@ when using it. -parDC :: (Trans a, Trans b) - => Int -- ^ parallel depth - -> DivideConquer a b -parDC lv trivial solve split combine - = pdc lv - where - pdc lv x - | lv == 0 = dc trivial solve split combine x - | lv > 0 = if trivial x then solve x - else combine x (parMap (pdc (lv-1)) (split x)) - - --- | Distributed-expansion divide-and-conquer skeleton --- (tutorial version, similar to dcNTickets). -disDC :: (Trans a, Trans b) - => Int -- ^ branching degree - -> Places -- ^ tickets - -> DivideConquer a b -disDC k tickets trivial solve split combine x - = if null tickets then seqDC x - else recDC tickets x - where - seqDC = dc trivial solve split combine - recDC tickets x = - if trivial x then solve x - else childRes `pseq` -- explicit demand - rdeepseq myRes `pseq` -- control - combine x ( myRes:childRes ++ localRess ) - where - -- child process generation - childRes = spawnAt childTickets childProcs procIns - childProcs = map (process . recDC) theirTs - -- ticket distribution - (childTickets, restTickets) = splitAt (k-1) tickets - (myTs: theirTs) = unshuffle k restTickets - -- input splitting - (myIn:theirIn) = split x - (procIns, localIns) - = splitAt (length childTickets) theirIn - -- local computations - myRes = recDC myTs myIn - localRess = map seqDC localIns - --- | offline distributed-expansion divide-and-conquer skeleton. -offline_disDC :: Trans b - => Int -- ^ branching degree - -> [Int] -- ^ tickets - -> DivideConquer a b -offline_disDC k ts triv solve split combine x - = snd (disDC k ts newtriv newsolve newsplit newcombine 0) - where - seqDC = dc triv solve split combine - newsplit = successors k - newtriv n = length ts <= k^(length (path k n)) - newsolve n = (flag, seqDC localx) - where (flag, localx) = select triv split x (path k n) - newcombine n bs@((flag,bs1):_) - = if flag then (True, combine localx (map snd bs)) - else (lab, bs1) - where (lab, localx) = select triv split x (path k n) - - --- local selection function for offline distributed-expansion divide-and-conquer skeleton -select :: (a -> Bool) -> (a -> [a]) -- ^ trivial / split - -> a -> [Int] -> (Bool,a) -select trivial split x ys = go x ys - where go x [] = (True, x) - go x (y:ys) = if trivial x then (False, x) - else go (split x !! y) ys - --- auxiliary functions for offline distributed-expansion divide-and-conquer skeleton -successors :: Int -> Int -> [Int] -successors k n = [nk + i | let nk = n*k, i <- [1..k]] - -path :: Int -> Int -> [Int] -path k n | n == 0 = [] - | otherwise = reverse (factors k n) - -factors :: Int -> Int -> [Int] -factors k n - | n <= 0 = [] - | otherwise = (n+k-1) `mod` k : factors k ((n-1) `div` k) - --- | DC skeleton with fixed branching degree, parallel depth control and explicit process --- placement (tree-shaped process creation, one task in each recursive step stays local). -disDCdepth :: (Trans a, Trans b) - => Int -- ^ branching degree - -> Int -- ^ parallel depth - -> DivideConquer a b -disDCdepth k depth trivial solve split combine x - | depth < 1 = dc trivial solve split combine x - | trivial x = solve x - | otherwise = childRs `seq` -- early demand on children list - combine x (myR : childRs) - where myself = disDCdepth k (depth - 1) trivial solve split combine - (mine:rest) = split x - myR = myself mine - childRs = parMapAt places myself rest - `using` seqList r0 -- ??? - -- placement with stride for next children, round-robin - places = map ((+1) . (`mod` noPe) . (+(-1))) shifts - shifts = map (selfPe +) [shift,2*shift..] - shift = k ^ (depth -1) - --- | Like 'disDCdepth', but controls parallelism by limiting the number of processes instead of the parallel depth. -disDCn :: (Trans a, Trans b) - => Int -- ^ branching degree - -> Int -- ^ number of processes - -> DivideConquer a b -disDCn k n = disDCdepth n depth - where depth = logN k n - --- rounding-up log approximation -logN n 1 = 0 -logN n k | k > 0 = 1 + logN n ((k + n-1) `div` n) -- round up - | otherwise = error "logN" - --------------------------------Flat Expansion---------------------------------- --- | DC Skeleton with flat expansion of upper DC-tree levels, takes custom map --- skeletons to solve expanded tasks (a sequential map skeleton leads to a --- sequential DC-skeleton). -flatDC :: (Trans a,Trans b) => - ((a->b)->[a]->[b]) -- ^custom map implementation - -> Int -- ^depth - -> DivideConquer a b -flatDC myMap depth trivial solve split combine x - = combineTopMaster combine levels results - where (tasks,levels) = generateTasks depth trivial split x - results = myMap(divConSeq_c trivial solve split combine) tasks - - - -combineTopMaster :: (NFData b) => - (a->[b]->b) -> (Tree a) -> [b] -> b -combineTopMaster c t bs = fst (combineTopRnf c t bs) - - -combineTopRnf :: (NFData b) => - (a->[b]->b) -> (Tree a) -> [b] -> (b,[b]) -combineTopRnf _ (Leaf a) (b:bs) = (b,bs) -combineTopRnf combine (Tree a ts) bs - = (rnf res `pseq` combine a res, bs') - where (bs',res) = foldl f (bs,[]) ts - f (olds,news) t = (remaining,news++[b]) - where (b,remaining) = combineTopRnf combine t olds - - -generateTasks :: Int -> (a->Bool) -> (a->[a]) -> a -> ([a],Tree a) -generateTasks 0 _ _ a = ([a],Leaf a) -generateTasks n trivial split a - | trivial a = ([a],Leaf a) - | otherwise = (concat ass,Tree a ts) - where assts = map (generateTasks (n-1) trivial split) (split a) - (ass,ts) = unzip assts - - -data Tree a = Tree a [Tree a] | Leaf a deriving Show -instance NFData a => NFData (Tree a) - where rnf (Tree a ls) = rnf a `seq` rnf ls - rnf (Leaf a) = rnf a - ------------------------------------DEPRECATED-------------------------------- --- | The simple interface (deprecated): combine function without input -type DivideConquerSimple a b - = (a -> Bool) -- ^ trivial? - -> (a -> b) -- ^ solve - -> (a -> [a]) -- ^ split - -> ([b] -> b) -- ^ combine (only uses sub-results, not the input) - -> a -- ^ input - -> b -- ^ result - - --- | Like 'dc' but uses simple DC Interface. -{-# DEPRECATED divConSeq, divConSeq_c "better use dc instead" #-} -divConSeq :: (Trans a, Trans b) => DivideConquerSimple a b -divConSeq trivial solve split combine x - = dc trivial solve split (\_ parts -> combine parts) x - --- | Same as 'dc' - -divConSeq_c :: (Trans a, Trans b) => DivideConquer a b -divConSeq_c = dc - - --- | Straightforward implementation. --- --- The straightforward method to parallelise divide-and-conquer --- algorithms is to unfold the call tree onto different --- processors. The process scheme unfolds the call tree on processors chosen by the --- runtime environment. Round-Robin distribution is unfavourable for this --- skeleton, better use runtime option @-qrnd@ when using it. -{-# DEPRECATED divCon, divCon_c, divConD, divConD_c "better use parDC instead" #-} -divCon :: (Trans a, Trans b) => DivideConquerSimple a b -divCon trivial solve split combine x - = divCon_c trivial solve split (\_ parts -> combine parts) x - --- | Like 'divCon' but with different combine signature (takes the original problem as additional input). -divCon_c :: (Trans a, Trans b) => DivideConquer a b -divCon_c trivial solve split combine x - | trivial x = solve x - | otherwise = combine x children - where children = parMap (divCon_c trivial solve split combine) (split x) - - --- | Like 'parDC' but uses simple DC Interface. -divConD :: (Trans a, Trans b) - => Int -- ^parallel depth - -> DivideConquerSimple a b -divConD depth trivial solve split combine x - = parDC depth trivial solve split (\_ parts -> combine parts) x - --- | Same as 'parDC'. -divConD_c :: (Trans a, Trans b) - => Int -- ^parallel depth - -> DivideConquer a b -divConD_c = parDC - --- | Like 'disDCdepth' but uses simple DC Interface. -{-# DEPRECATED dcN, dcN_c "better use disDCdepth instead" #-} -dcN :: (Trans a, Trans b) - => Int -- ^ branching degree - -> Int -- ^ parallel depth - -> DivideConquerSimple a b -dcN n depth trivial solve split combine x - = disDCdepth n depth trivial solve split (\_ parts -> combine parts) x - --- | Same as 'disDCdepth' -dcN_c :: (Trans a, Trans b) - => Int -- ^ branching degree - -> Int -- ^ parallel depth - -> DivideConquer a b -dcN_c = disDCdepth - --- | Like 'disDCn' but uses simple DC Interface. -{-# DEPRECATED dcN', dcN_c' "better use disDCn instead" #-} -dcN' :: (Trans a, Trans b) - => Int -- ^ branching degree - -> Int -- ^ number of processes - -> DivideConquerSimple a b -dcN' n pes = dcN n depth - where depth = logN n pes - --- | Same as 'disDCn'. -dcN_c' :: (Trans a, Trans b) - => Int -- ^ branching degree - -> Int -- ^ number of processes - -> DivideConquer a b -dcN_c' = disDCn - ---------------------------------------------------------------- --- | Like 'disDC', but differs in demand control and uses simple DC Interface. -{-# DEPRECATED dcNTickets, dcNTickets_c "better use disDC instead" #-} -dcNTickets :: (Trans a, Trans b) => - Int -- ^ branching degree - -> Places -- ^ tickets (places to use) - -> DivideConquerSimple a b -dcNTickets k ts trivial solve split combine x - = dcNTickets_c k ts trivial solve split (\_ parts -> combine parts) x - --- | Like 'disDC', but differs in demand control. -dcNTickets_c :: (Trans a, Trans b) - => Int -- ^ branching degree - -> Places -- ^ Tickets (places to use) - -> DivideConquer a b -dcNTickets_c k [] trivial solve split combine x - = divConSeq_c trivial solve split combine x -dcNTickets_c k tickets trivial solve split combine x - = if trivial x then solve x - else childRes `pseq` -- early demand on children list - rnf myRes `pseq` rnf localRess `pseq` - combine x (myRes:childRes ++ localRess ) - where - -- splitting computation into processes - (childTickets,restTickets) = splitAt (k-1) tickets --position of (children,further ancestors) - (myTs:theirTs)= unshuffle k restTickets - ticketF ts = dcNTickets_c k ts trivial solve split combine - insts = length childTickets - (procIns, localIns) = splitAt insts theirIn - childProcs = map (process . ticketF) theirTs - childRes = spawnAt childTickets childProcs procIns - - -- local computation: - myRes = ticketF myTs myIn - (myIn:theirIn) = split x - localRess = map (divConSeq_c trivial solve split combine) localIns - - - --- | Like as 'flatDC' but uses simple DC Interface. -{-# DEPRECATED divConFlat, divConFlat_c "better use flatDC instead" #-} -divConFlat :: (Trans a,Trans b) => - ((a->b)->[a]->[b]) -- ^custom map implementation - -> Int -- ^depth - -> DivideConquerSimple a b -divConFlat myMap depth trivial solve split combine x - = divConFlat_c myMap depth trivial solve split (\_ parts -> combine parts) x - --- | Tutorial version, same as 'flatDC'. -divConFlat_c :: (Trans a,Trans b) - => ((a->b)->[a]->[b]) -- ^ custom map implementation - -> Int -- ^ parallel depth - -> DivideConquer a b -divConFlat_c = flatDC diff --git a/Control/Parallel/Eden/EdenSkel/IterSkels.hs b/Control/Parallel/Eden/EdenSkel/IterSkels.hs deleted file mode 100644 --- a/Control/Parallel/Eden/EdenSkel/IterSkels.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Parallel.Eden.EdenSkel.MiscSkels --- Copyright : (c) Philipps Universitaet Marburg 2009-2010 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : eden@mathematik.uni-marburg.de --- Stability : beta --- Portability : not portable --- --- This Haskell module defines iteration skeletons for Eden. --- --- Depends on the Eden Compiler. --- --- Eden Project --- -module Control.Parallel.Eden.EdenSkel.IterSkels ( - -- * Iteration Skeletons - iterUntilAt, iterUntil - ) where -import Control.Parallel.Eden.EdenSkel.Auxiliary -import Control.Parallel.Eden.EdenSkel.MapSkels -#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) -import Control.Parallel.Eden -#else -import Control.Parallel.Eden.EdenConcHs -#endif - --- \cite{SkeletonBookChapter02}, code (c) Fernando Rubio --- | The iterUntil skeleton is an iterated map skeleton. Each worker --- function transforms one local worker state and one task per iteration. --- The result is the next local state and the iterations --- result, which is send back to the master. The master transforms the --- output of all tasks of one iteration and a local master state into --- the worker inputs of the next iteration and a new master state --- using the combine function (output: Right tasks masterState) or --- decides to terminate the iteration (output: Left result). The input --- transformation function generates all initial worker states and --- initial worker tasks and the initial master state from the skeleton. -iterUntil :: (Trans wl,Trans t, Trans sr) => - (inp -> ([wl],[t],ml)) -- ^input transformation function - -> (wl -> t -> (sr,wl)) -- ^worker function - -> (ml -> [sr] -> Either r ([t],ml)) -- ^combine function - -> inp -- ^input - -> r -- ^result -iterUntil = iterUntilAt [0] - --- | This is the basic implementation, using places for explicit process --- | placement of the worker processes. -iterUntilAt :: (Trans wl,Trans t, Trans sr) => - Places -- ^where to instatiate - -> (inp -> ([wl],[t],ml)) -- ^input transformation function - -> (wl -> t -> (sr,wl)) -- ^worker function - -> (ml -> [sr] -> Either r ([t],ml)) -- ^combine function - -> inp -- ^input - -> r -- ^result -iterUntilAt pids split wf comb x = result where - (result, moretaskss) = manager comb ml (lazyTranspose srss) - srss = parMapAt pids (worker wf) (zip wlocals taskss) - taskss = lazyTranspose (initials: moretaskss) - (wlocals,initials,ml)= split x - --- master/manager functionality of the iterUntil skeleton -manager :: (ml -> [sr] -> Either r ([t],ml)) -> - ml -> [[sr]] -> (r,[[t]]) -manager comb ml (srs:srss) = case comb ml srs of - Left res -> (res,[]) -- Left: stop iteration - Right (ts,ml') -> -- Right: proceed with new tasks (ts) and new state ml' - let (res',tss) = manager comb ml' srss - in (res', ts:tss) - ---worker functionality of the iterUntil skeleton -worker :: (wl -> t -> (sr,wl)) -> (wl,[t]) -> [sr] -worker wf (local,[]) = [] -worker wf (local, t:ts) = sr: worker wf (local',ts) where - (sr,local') = wf local t diff --git a/Control/Parallel/Eden/EdenSkel/MapRedSkels.hs b/Control/Parallel/Eden/EdenSkel/MapRedSkels.hs deleted file mode 100644 --- a/Control/Parallel/Eden/EdenSkel/MapRedSkels.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Parallel.Eden.EdenSkel.MapRedSkels --- Copyright : (c) Philipps Universitaet Marburg 2011-2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : eden@mathematik.uni-marburg.de --- Stability : beta --- Portability : not portable --- --- This Haskell module defines map-reduce skeletons for --- the parallel functional language Eden. --- --- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. --- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden --- for a parallel build. --- --- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) --- Depends on the Eden Compiler. - - -module Control.Parallel.Eden.EdenSkel.MapRedSkels ( - -- * Sequential map-reduce definitions - mapRedr, mapRedl, mapRedl', - -- * Simple map-reduce skeletons - parMapRedr, parMapRedl, parMapRedl', - -- * offline map-reduce skeletons - offlineParMapRedr, offlineParMapRedl, offlineParMapRedl', - -- Google map-reduce - ) where -#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) -import Control.Parallel.Eden -#else -import Control.Parallel.Eden.EdenConcHs -#endif -import Control.Parallel.Eden.EdenSkel.Auxiliary -import Control.Parallel.Eden.EdenSkel.MapSkels -import Data.List - -mapRedr :: (b -> c -> c) -- ^ reduce function - -> c -- ^ neutral for reduce function - -> (a -> b) -- ^ map function - -> [a] -- ^ input - -> c -- ^ result -mapRedr g e f = (foldr g e) . (map f) - -mapRedl :: (c -> b -> c) -- ^ reduce function - -> c -- ^ neutral for reduce function - -> (a -> b) -- ^ map function - -> [a] -- ^ input - -> c -- ^ result -mapRedl g e f = (foldl g e) . (map f) - -mapRedl' :: (c -> b -> c) -- ^ reduce function - -> c -- ^ neutral for reduce function - -> (a -> b) -- ^ map function - -> [a] -- ^ input - -> c -- ^ result -mapRedl' g e f = (foldl' g e) . (map f) - - - --- | Basic parMapRedr skeleton - as many processes as noPe. --- local pre-folding per PE and final folding of PE-results --- via different fold variants -parMapRedr :: (Trans a, Trans b) => - (b -> b -> b) -> b -> (a -> b) -> [a] -> b -parMapRedr g e f - = if noPe == 1 then mapRedr g e f else - (foldr g e) . (parMap (mapRedr g e f)) . (splitIntoN noPe) - --- | Basic parMapRedl skeleton - as many processes as noPe. --- local pre-folding per PE and final folding of PE-results --- via different fold variants -parMapRedl :: (Trans a, Trans b) => - (b -> b -> b) -> b -> (a -> b) -> [a] -> b -parMapRedl g e f - = if noPe == 1 then mapRedl g e f else - (foldl g e) . (parMap (mapRedl g e f)) . (splitIntoN noPe) - --- | Basic parMapRedl' skeleton - as many processes as noPe. --- local pre-folding per PE and final folding of PE-results --- via different fold variants -parMapRedl' :: (Trans a, Trans b) => - (b -> b -> b) -> b -> (a -> b) -> [a] -> b -parMapRedl' g e f - = if noPe == 1 then mapRedl' g e f else - (foldl' g e) . (parMap (mapRedl' g e f)) . (splitIntoN noPe) - - - --- | Offline parMapRedr skeleton - as many processes as noPe. --- local pre-folding per PE and final folding of PE-results --- via different fold variants, --- BUT local selection of input sub-list by worker processes -offlineParMapRedr :: (Trans a, Trans b) => - (b -> b -> b) -> b -> (a -> b) -> [a] -> b -offlineParMapRedr g e f xs - = if noPe == 1 then mapRedr g e f xs else - foldr g e (parMap worker [0..noPe-1]) - where worker i = mapRedr g e f ((splitIntoN noPe xs)!!i) - --- | Offline parMapRedl skeleton - as many processes as noPe. --- local pre-folding per PE and final folding of PE-results --- via different fold variants, --- BUT local selection of input sub-list by worker processes -offlineParMapRedl :: (Trans a, Trans b) => - (b -> b -> b) -> b -> (a -> b) -> [a] -> b -offlineParMapRedl g e f xs - = if noPe == 1 then mapRedl g e f xs else - foldr g e (parMap worker [0..noPe-1]) - where worker i = mapRedl g e f ((splitIntoN noPe xs)!!i) - --- | Offline parMapRedl' skeleton - as many processes as noPe. --- local pre-folding per PE and final folding of PE-results --- via different fold variants, --- BUT local selection of input sub-list by worker processes -offlineParMapRedl' :: (Trans a, Trans b) => - (b -> b -> b) -> b -> (a -> b) -> [a] -> b -offlineParMapRedl' g e f xs - = if noPe == 1 then mapRedl' g e f xs else - foldr g e (parMap worker [0..noPe-1]) - where worker i = mapRedl' g e f ((splitIntoN noPe xs)!!i) - - - diff --git a/Control/Parallel/Eden/EdenSkel/MapSkels.hs b/Control/Parallel/Eden/EdenSkel/MapSkels.hs deleted file mode 100644 --- a/Control/Parallel/Eden/EdenSkel/MapSkels.hs +++ /dev/null @@ -1,305 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Parallel.Eden.EdenSkel.MapSkels --- Copyright : (c) Philipps Universitaet Marburg 2009-2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : eden@mathematik.uni-marburg.de --- Stability : beta --- Portability : not portable --- --- This Haskell module defines map-like skeletons for --- the parallel functional language Eden. --- --- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. --- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden --- for a parallel build. --- --- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) - - -module Control.Parallel.Eden.EdenSkel.MapSkels ( - -- * Custom map skeletons - -- | These skeletons expose many parameters to the user and thus have varying types - parMap, ranch, - farm, farmS, farmB, - offlineFarm, offlineFarmS, offlineFarmB, - -- * Custom map skeletons with explicit placement - -- | Map skeleton versions with explicit placement - parMapAt, ranchAt, farmAt, offlineFarmAt, - -- * Simple map skeleton variants - -- | The map skeletons 'farm' and 'offlineFarm' can be used to define - -- skeletons with the simpler sequential map interface :: (a -> b) -> [a] -> [b] - mapFarmB, mapFarmS, mapOfflineFarmS, mapOfflineFarmB, - -- * Deprecated map skeletons - -- | These skeletons are included to keep old code alive. Use the skeletons above. - farmClassic, ssf, offline_farm, map_par, map_farm, map_offlineFarm, map_ssf - ) where -#if defined( __PARALLEL_HASKELL__ ) -import Control.Parallel.Eden -#else -import Control.Parallel.Eden.EdenConcHs -#endif -import Control.Parallel.Eden.EdenSkel.Auxiliary -import Data.List - - --- | Basic parMap Skeleton - one process for each list element. This version takes --- places for instantiation on particular PEs. -parMapAt :: (Trans a, Trans b) => - Places -- ^places for instantiation - -> (a -> b) -- ^worker function - -> [a] -- ^task list - -> [b] -- ^result list -parMapAt pos f tasks = spawnAt pos (repeat (process f)) tasks - - --- | Basic parMap Skeleton - one process for each list element -parMap :: (Trans a, Trans b) => - (a -> b) -- ^worker function - -> [a] -- ^task list - -> [b] -- ^result list -parMap = parMapAt [0] - - --- | A process ranch is a generalized (or super-) farm. This version takes --- places for instantiation. Arbitrary input is transformed into a list of inputs --- for the worker processes (one worker for each transformed value). The worker --- inputs are processed by the worker function. --- The results of the worker processes are then reduced using the reduction function. -ranchAt :: (Trans b, Trans c) => - Places -- ^places for instantiation - -> (a -> [b]) -- ^input transformation function - -> ([c] -> d) -- ^result reduction function - -> (b -> c) -- ^worker function - -> a -- ^input - -> d -- ^output -ranchAt pos transform reduce fs xs = - reduce $ spawnAt pos (repeat $ process fs) (transform xs) - --- | A process ranch is a generalized (or super-) farm. Arbitrary input --- is transformed into a list of inputs for the worker processes (one worker --- for each transformed value). The worker inputs are processed by the worker function. --- The results of the worker processes are then reduced using the reduction function. -ranch :: (Trans b, Trans c) => - (a -> [b]) -- ^input transformation function - -> ([c] -> d) -- ^result reduction function - -> (b -> c) -- ^worker function - -> a -- ^input - -> d -- ^output -ranch = ranchAt [0] - - --- | A farm distributes its input to a number of worker processes. --- This version takes places for instantiation. --- The distribution function divides the input list into --- sublists - each sublist is input to one worker process, the --- number of worker processes is determined by the number of --- sublists. The results of the worker processes are --- then combined using the combination function. --- --- Use 'map_farm' if you want a simpler interface. --- -farmAt :: (Trans a, Trans b) => - Places -- ^places for instantiation - -> ([a] -> [[a]]) -- ^input distribution function - -> ([[b]] -> [b]) -- ^result combination function - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output -farmAt pos distr combine f tasks = ranchAt pos distr combine (map f) tasks - --- | A farm distributes its input to a number of worker processes. --- The distribution function divides the input list into --- sublists - each sublist is input to one worker process, the --- number of worker processes is determined by the number of --- sublists. The results of the worker processes are --- then combined using the combination function. --- --- Use 'mapFarmS' or 'mapFarmB' if you want a simpler interface. --- -farm :: (Trans a, Trans b) => - ([a] -> [[a]]) -- ^input distribution function - -> ([[b]] -> [b]) -- ^result combination function - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output -farm = farmAt [0] - --- | Like the 'farm', but uses a fixed round-robin distribution of tasks. -farmS :: (Trans a, Trans b) - => Int -- ^number of processes - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output -farmS np = farm (unshuffle np) shuffle - --- | Like the 'farm', but uses a fixed block distribution of tasks. -farmB :: (Trans a, Trans b) - => Int -- ^number of processes - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output -farmB np = farm (splitIntoN np) concat - - - - --- | Offline farm with explicit placement (alias self-service farm or --- direct mapping): Like the farm, but tasks are evaluated inside the --- workers (less communication overhead). Tasks are mapped inside each --- generated process abstraction, avoiding evaluating and sending --- them. This often reduces the communication overhead because --- unevaluated data is usually much smaller than evaluated data. --- --- Use 'map_offlineFarm' if you want a simpler interface. --- --- Notice: The task lists structure has to be completely defined --- before process instantiation takes place. --- -offlineFarmAt :: Trans b => - Places -- ^places for instantiation - -> Int -- ^number of processes - -> ([a] -> [[a]]) -- ^input distribution function - -> ([[b]] -> [b]) -- ^result combination function - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output - -offlineFarmAt pos np distribute combine f xs - = combine $ spawnAt pos (map (rfi (map f)) [select i xs | i <- [0 .. np-1]]) - (repeat ()) - where select i xs = (distribute xs ++ repeat []) !! i - - - --- | Offline farm (alias direct mapping): Like the farm, but --- tasks are evaluated inside the workers (less communication --- overhead). Tasks are mapped inside each generated process --- abstraction avoiding evaluating and sending them. This often --- reduces the communication overhead because unevaluated data is --- usually much smaller than evaluated data. --- --- Use 'map_offlineFarm' if you want a simpler interface. --- --- Notice: The offline farm receives the number of processes to be created --- as its first parameter. --- The task lists structure has to be completely defined --- before process instantiation takes place. --- -offlineFarm :: Trans b => - Int -- ^number of processes - -> ([a] -> [[a]]) -- ^input distribution function - -> ([[b]] -> [b]) -- ^result combination function - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output - -offlineFarm = offlineFarmAt [0] - --- | Like the 'offlineFarm', but with fixed round-robin distribution of tasks. -offlineFarmS :: (Trans a, Trans b) - => Int -- ^number of processes - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output -offlineFarmS np = offlineFarm np (unshuffle np) shuffle - --- | Like the 'offlineFarm', but with fixed block distribution of tasks. -offlineFarmB :: (Trans a, Trans b) - => Int -- ^number of processes - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output -offlineFarmB np = offlineFarm np (splitIntoN np) concat - - ------------------------------------------------------------------------------------- -numProc = max (noPe-1) 1 - --- | Parallel map variant with map interface using (max (noPe-1) 1) worker processes. Skeletons ending on @S@ use round-robin distribution, skeletons ending on @B@ use block distribution of tasks. -mapFarmS, mapFarmB, mapOfflineFarmS, mapOfflineFarmB :: (Trans a , Trans b) => - (a -> b) -- ^worker function - -> [a] -- ^task list - -> [b] -- ^result list -mapFarmS = farmS numProc -mapFarmB = farmB numProc -mapOfflineFarmS = offlineFarmS numProc -mapOfflineFarmB = offlineFarmB numProc - ------------------------------DEPRECATED--------------------------------- - - --- | Deprecated, use the 'farm'; --- @farmClassic@ distributes its input to a number of worker processes. --- This is the Classic version as described in the Eden standard reference --- "Parallel Functional Programming in Eden". --- The distribution function is expected to divide the input list into --- the given number of sublists. In the new farm the number of sublists is --- determined only by the distribution function. --- --- Use 'map_farm' if you want a simpler interface. -{-# DEPRECATED farmClassic "better use farm instead" #-} -farmClassic :: (Trans a, Trans b) => - Int -- ^number of child processes - -> (Int -> [a] -> [[a]]) -- ^input distribution function - -> ([[b]] -> [b]) -- ^result combination function - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output - -farmClassic np distribute = farm $ distribute np - - --- | Deprecated, use 'offlineFarm'; --- Self service farm. Like the farm, but --- tasks are evaluated in the workers (less communication overhead). --- This is the classic version. The distribution function is expected --- to divide the input list into the given number of sublists. In the --- new self service farm the number of sublists is determined only by --- the distribution function. --- --- Use 'map_ssf' if you want a simpler interface. --- --- Notice: The task lists structure has to be completely defined --- before process instantiation takes place. -{-# DEPRECATED ssf "better use offlineFarm instead" #-} -ssf :: forall a b . Trans b => - Int -- ^number of child processes - -> (Int -> [a] -> [[a]]) -- ^input distribution function - -> ([[b]] -> [b]) -- ^result combination function - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output - -ssf np distribute = offlineFarm np (distribute np) - --- | Deprecated: Same as 'offlineFarm'. -{-# DEPRECATED offline_farm "better use offlineFarm instead" #-} -offline_farm :: Trans b => - Int -- ^number of processes - -> ([a] -> [[a]]) -- ^input distribution function - -> ([[b]] -> [b]) -- ^result combination function - -> (a -> b) -- ^mapped function - -> [a] -- ^input - -> [b] -- ^output -offline_farm = offlineFarm - --- | Deprecated: Same as 'parMap'. -{-# DEPRECATED map_par "better use parMap instead" #-} -map_par :: (Trans a , Trans b) => - (a -> b) -- ^worker function - -> [a] -- ^task list - -> [b] -- ^result list -map_par = parMap - --- | Deprecated: Parallel map variants with map interface using noPe worker processes. -{-# DEPRECATED map_farm, map_offlineFarm, map_ssf "better use mapFarmS or mapOfflineFarmS instead" #-} -map_farm, map_offlineFarm, map_ssf :: (Trans a , Trans b) => - (a -> b) -- ^worker function - -> [a] -- ^task list - -> [b] -- ^result list -map_farm = farmS noPe -map_offlineFarm = offlineFarmS noPe -map_ssf = map_offlineFarm diff --git a/Control/Parallel/Eden/EdenSkel/TopoSkels.hs b/Control/Parallel/Eden/EdenSkel/TopoSkels.hs deleted file mode 100644 --- a/Control/Parallel/Eden/EdenSkel/TopoSkels.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Parallel.Eden.EdenSkel.TopoSkels --- Copyright : (c) Philipps Universitaet Marburg 2009-2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : eden@mathematik.uni-marburg.de --- Stability : beta --- Portability : not portable --- --- This Haskell module defines topology skeletons for the parallel functional --- language Eden. Topology skeletons are skeletons that implement a network of --- processes interconnected by a characteristic communication topology. --- --- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. --- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden --- for a parallel build. --- --- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) - - -module Control.Parallel.Eden.EdenSkel.TopoSkels ( - -- * Skeletons that are primarily characterized by their topology. - - -- ** Pipeline skeletons - -- | - pipe, pipeRD - -- ** Ring skeletons - -- | - ,ringSimple, ring, ringFl, ringAt, ringFlAt - -- ** Torus skeleton - -- | - ,torus - -- ** The Hypercube skeleton - -- | - - -- ** The All-To-All skeleton - -- |The allToAll skeleton allows distributed data exchange and - -- transformation including data of all processes. Input and output - -- are provided as remote data. A typical application is the - -- distributed transposition of a distributed Martrix. - ,allToAllRDAt, allToAllRD, parTransposeRDAt, parTransposeRD, allGatherRDAt, allGatherRD - -- ** The All-Reduce skeleton - -- |The skeleton uses a butterfly topology to reduce the data of - -- participating processes P in log(|P|) communication stages. Input - -- and output are provided as remote data. - ,allReduceRDAt, allReduceRD, allGatherBuFlyRDAt, allGatherBuFlyRD - - ) where -#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) -import Control.Parallel.Eden -#else -import Control.Parallel.Eden.EdenConcHs -#endif -import Control.Parallel.Eden.EdenSkel.Auxiliary -import Control.Parallel.Eden.EdenSkel.MapSkels -import Data.List - - - --- |Simple pipe where the parent process creates all pipe processes. The processes communicate their results via the caller process. -pipe :: forall a . Trans a => - [a -> a] -- ^functions of the pipe - -> a -- ^input - -> a -- ^output -pipe fs = unLiftRD (pipeRD fs) - --- |Process pipe where the processes communicate their Remote Data handles via the caller process but fetch the actual data from their predecessor processes -pipeRD :: forall a . Trans a => - [a -> a] -- ^functions of the pipe - -> RD a -- ^remote input - -> RD a -- ^remote output -pipeRD fs xs = (last outs) where - outs = spawn ps $ lazy $ xs : outs - ps :: [Process (RD a) (RD a)] - ps = map (process . liftRD) fs - - --- | Simple ring skeleton (tutorial version) --- using remote data for providing direct inter-ring communication --- without input distribution and output combination -ringSimple :: (Trans i, Trans o, Trans r) => - (i -> r -> (o,r)) -- ^ ring process function - -> [i] -> [o] -- ^ input output mapping -ringSimple f is = os - where - (os,ringOuts) = unzip (parMap (toRD $ uncurry f) - (zip is $ lazy ringIns)) - ringIns = rightRotate ringOuts - -toRD :: (Trans i, Trans o, Trans r) => - ((i,r) -> (o,r)) -- ^ ring process function - -> ((i, RD r) -> (o, RD r)) -- ^ -- with remote data -toRD f (i, ringIn) = (o, release ringOut) - where (o, ringOut) = f (i, fetch ringIn) - -rightRotate :: [a] -> [a] -rightRotate [] = [] -rightRotate xs = last xs : init xs - --- | The ringFlAt establishes a ring topology, the ring process functions --- transform the initial input of a ring process and the input stream from the ring into the --- ring output stream and the ring processes' final result. Every ring process --- applies its individual function which e.g. allows to route individual offline input into the --- ring processes. This version uses explicit placement. -ringFlAt :: (Trans a,Trans b,Trans r) => - Places -- ^where to put workers - -> (i -> [a]) -- ^distribute input - -> ([b] -> o) -- ^combine output - -> [(a -> [r] -> (b,[r]))] -- ^ring process fcts - -> i -- ^ring input - -> o -- ^ring output -ringFlAt places distrib combine fs i = combine os where - (os, ringOuts) = unzip $ spawnFAt places (map (toRD . uncurry) fs) - (zip (distrib i) $ lazy ringIns) - ringIns = rightRotate ringOuts - --- | The ringFl establishes a ring topology, the ring process functions --- transform the initial input of a ring process and the input stream from the ring into the --- ring output stream and the ring processes' final result. Every ring process --- applies an individual function which e.g. allows to route individual offline input into the --- ring processes. Use ringFlAt if explicit placement is desired. -ringFl :: (Trans a,Trans b,Trans r) => - (i -> [a]) -- ^distribute input - -> ([b] -> o) -- ^combine output - -> [(a -> [r] -> (b,[r]))] -- ^ring process fcts - -> i -- ^ring input - -> o -- ^ring output -ringFl = ringFlAt [0] - --- | Skeleton @ringAt@ establishes a ring topology, the ring process function --- transforms the initial input of a ring process and the input stream from the ring into the --- ring output stream and the ring processes' final result. The --- same function is used by every ring process. Use ringFlAt --- if you need different functions in the processes. This version uses explicit placement. -ringAt :: (Trans a,Trans b,Trans r) => - Places -- ^where to put workers - -> (i -> [a]) -- ^distribute input - -> ([b] -> o) -- ^combine output - -> (a -> [r] -> (b,[r])) -- ^ring process fct - -> i -- ^ring input - -> o -- ^ring output -ringAt places distrib combine f i = - ringFlAt places distrib combine [f] i - --- | The ring establishes a ring topology, the ring process function --- transforms the initial input of a ring process and the input stream from the ring into the --- ring output stream and the ring processes final result. The --- same function is used by every ring process. Use ringFl --- if you need different functions in the processes. Use ringAt if --- explicit placement is desired. -ring :: (Trans a,Trans b,Trans r) => - (i -> [a]) -- ^distribute input - -> ([b] -> o) -- ^combine output - -> (a -> [r] -> (b,[r])) -- ^ring process fct - -> i -- ^ring input - -> o -- ^ring output -ring = ringAt [0] - - - --- | Parallel torus skeleton (tutorial version) with stream rotation in 2 directions: initial inputs for each torus element are given. The node function is used on each torus element to transform the initial input and a stream of inputs from each direction to a stream of outputs to each direction. Each torus input should have the same size in both dimensions, otherwise the smaller input will determine the size of the torus. -torus :: (Trans a, Trans b, Trans c, Trans d) => - (c -> [a] -> [b] -> (d,[a],[b])) -- ^ node function - -> [[c]] -> [[d]] -- ^ input-output mapping -torus f inss = outss - where - t_outss = spawnPss (repeat (repeat (ptorus f))) t_inss -- optimised - (outss,outssA,outssB) = unzip3 (map unzip3 t_outss) - inssA = map rightRotate outssA - inssB = rightRotate outssB - t_inss = zipWith3 lazyzip3 inss (lazy inssA) (lazy inssB) - lazyzip3 as bs cs = zip3 as (lazy bs) (lazy cs) - --- each individual process of the torus (tutorial version) -ptorus :: (Trans a, Trans b, Trans c, Trans d) => - (c -> [a] -> [b] -> (d,[a],[b])) -> - Process (c,RD [a],RD [b]) - (d,RD [a],RD [b]) -ptorus f - = process (\ (fromParent, inA, inB) -> - let (toParent, outA, outB) = f fromParent inA' inB' - (inA',inB') = fetch2 inA inB - in (toParent, release outA, release outB)) - --- | The skeleton creates as many processes as elements in the input list (@np@). --- The processes get all-to-all connected, each process input is transformed to --- @np@ intermediate values by the first parameter function, where the @i@-th value --- will be send to process @i@. The second transformation function combines the initial --- input and the @np@ received intermediate values to the final output. -allToAllRD :: forall a b i. (Trans a, Trans b, Trans i) - => (Int -> a -> [i]) -- ^transform before bcast (num procs, input, sync-data out) - -> (a -> [i] ->b) -- ^transform after bcast (input, sync-data in, output) - -> [RD a] -- ^remote input for each process - -> [RD b] -- ^remote output for each process -allToAllRD = allToAllRDAt [0] - --- | The skeleton creates as many processes as elements in the input list (@np@). --- The processes get all-to-all connected, each process input is transformed to --- @np@ intermediate values by the first parameter function, where the @i@-th value --- will be send to process @i@. The second transformation function combines the initial --- input and the @np@ received intermediate values to the final output. -allToAllRDAt :: forall a b i. (Trans a, Trans b, Trans i) - => Places -- ^where to instantiate - -> (Int -> a -> [i]) -- ^transform before bcast (num procs, input, sync-data out) - -> (a -> [i] ->b) -- ^transform after bcast (input, sync-data in, output) - -> [RD a] -- ^remote input for each process - -> [RD b] -- ^remote output for each process -allToAllRDAt places t1 t2 xs = res where - n = length xs --same amount of procs as #xs - (res,iss) = n `pseq` unzip $ parMapAt places (uncurry p) inp - inp = zip xs $ lazy $ transpose iss - - p :: RD a-> [RD i]-> (RD b,[RD i]) - p xRD theirIs = (resF theirIs, myIsF x) where - x = fetch xRD - myIsF = releaseAll . t1 n - resF = release . t2 x . fetchAll - --- works similar for splitIntoN and unsplit (concat)??? --- |Parallel transposition for matrizes which are row-wise round robin distributed among the machines, the transposed result matrix is also row-wise round robin distributed. -parTransposeRD :: Trans b - => [RD [[b]]] -- ^input list of remote partial matrizes - -> [RD [[b]]] -- ^output list of remote partial matrizes -parTransposeRD = parTransposeRDAt [0] - - --- works similar for splitIntoN and unsplit (concat)??? --- |Parallel transposition for matrizes which are row-wise round robin distributed among the machines, the transposed result matrix is also row-wise round robin distributed. -parTransposeRDAt :: Trans b - => Places - -> [RD [[b]]] -- ^input list of remote partial matrizes - -> [RD [[b]]] -- ^output list of remote partial matrizes -parTransposeRDAt places = allToAllRDAt places (\ n -> unshuffle n . transpose) - (\ _ -> map shuffle . transpose) - --- | Performs an all-gather using all to all comunication (based on allToAllRDAt). --- The initial transformation is applied in the processes to obtain the values that will be reduced. --- The final combine function is used to create a processes outputs from the initial input and the --- gathered values. -allGatherRD :: forall a b c. (Trans a, Trans b, Trans c) - => (a -> b) -- ^initial transform function - -> (a -> [b] -> c) -- ^final combine function - -> [RD a] -> [RD c] -allGatherRD = allGatherRDAt [0] - --- | Performs an all-gather using all to all comunication (based on allToAllRDAt). --- The initial transformation is applied in the processes to obtain the values that will be reduced. --- The final combine function is used to create a processes outputs from the initial input and the --- gathered values. -allGatherRDAt :: forall a b c. (Trans a, Trans b, Trans c) - => Places -- ^where to instantiate - -> (a -> b) -- ^initial transform function - -> (a -> [b] -> c) -- ^final combine function - -> [RD a] -> [RD c] -allGatherRDAt places t1 t2 = allToAllRDAt places t1' t2 where - t1' :: Int -> a -> [b] - t1' n x = replicate n (t1 x) - - --- | Performs an all-reduce with the reduce function using a butterfly scheme. --- The initial transformation is applied in the processes to obtain the values --- that will be reduced. The final combine function is used to create a processes outputs. --- result from the initial input and the reduced value. -allReduceRD :: forall a b c. (Trans a, Trans b, Trans c) - => (a -> b) -- ^initial transform function - -> (b -> b -> b) -- ^reduce function - -> (a -> b -> c) -- ^final combine function - -> [RD a] -> [RD c] -allReduceRD = allReduceRDAt [0] where - - --- | Performs an all-reduce with the reduce function using a butterfly scheme. --- The initial transformation is applied in the processes to obtain the values --- that will be reduced. The final combine function is used to create a processes output. --- result from the initial input and the reduced value. -allReduceRDAt :: forall a b c. (Trans a, Trans b, Trans c) - => Places -- ^where to instantiate - -> (a -> b) -- ^initial transform function - -> (b -> b -> b) -- ^reduce function - -> (a -> b -> c) -- ^final combine function - -> [RD a] -> [RD c] -allReduceRDAt places initF redF resF rdAs = rdCs where - steps = (ceiling . logBase 2 . fromIntegral . length) rdAs - (rdBss,rdCs) = steps `pseq` unzip $ parMapAt places (uncurry p) inp - inp = zip rdAs $ lazy $ buflyF $ transposeRt rdBss - buflyF = transposeRt . shiftFlipF steps . fillF steps - - p :: RD a -> [Maybe (Both (RD b))] -> ([RD b], RD c) - p rdA rdBs = (rdBs'', res) where - res = release $ resF a $ reduced !! steps - rdBs'' = (releaseAll . take steps . lazy) reduced - reduced = scanl redF' b toReduce - toReduce = fetchAll' rdBs' - rdBs' = zipWith (flip maybe Left') (map Right' rdBs'') rdBs - b = initF a - a = fetch rdA - - --List encoding: - -- Right': No Partner present, use value b without reduction - -- Left': RD value comes from partner, then inner encoding: - -- Right': Partner is positioned at the right hand side - -- Left': Partner is positioned at the left hand side - -- needed such that redF does not need to be commutativie - redF' :: b -> Either' (Both b) b -> b - redF' _ (Right' b) = b - redF' b (Left' (Right' b')) = redF b b' - redF' b (Left' (Left' b')) = redF b' b - -type Both a = Either' a a - ---custom fetchAll inside nested Eithers -fetchAll' :: Trans a => [Either' (Both (RD a)) (RD a)] -> [Either' (Both a) a] -fetchAll' = runPA . mapM fetchPA' where - fetchPA' (Left' (Left' rda)) = do a <- fetchPA rda - return $ Left' $ Left' a - fetchPA' (Left' (Right' rda)) = do a <- fetchPA rda - return $ Left' $ Right' a - fetchPA' (Right' rda) = do a <- fetchPA rda - return $ Right' a - ---Fill rows to the power of ldn with Nothing, map Just to the rest -fillF :: Int -> [[a]] -> [[Maybe a]] -fillF ldn ass = map fillRow ass where - n = 2 ^ ldn - fillRow as = take n $ (map Just as) ++ (repeat Nothing) - -shiftFlipF :: Int -> [[Maybe a]] -> [[Maybe (Both a)]] -shiftFlipF ldn rdBss = zipWith shiftFlipRow [1..ldn] rdBss where - shiftFlipRow ldi rdBs = (shuffle . flipAtHalfF . unshuffle i) rdBs where - i = 2 ^ ldi - flipAtHalfF xs = let (xs1, xs2) = splitAt (i`div`2) xs - in map (map (fmap Right')) xs2 ++ map (map (fmap Left')) xs1 - - --- | Performs an all-gather using a butterfly scheme (based on allReduceRDAt). --- The initial transformation is applied in the processes to obtain the values that will be reduced. --- The final combine function is used to create a processes outputs from the initial input and the --- gathered values. -allGatherBuFlyRD :: forall a b c. (Trans a, Trans b, Trans c) - => (a -> b) -- ^initial transform function - -> (a -> [b] -> c) -- ^final combine function - -> [RD a] -> [RD c] -allGatherBuFlyRD = allGatherBuFlyRDAt [0] - --- | Performs an all-gather using a butterfly scheme (based on allReduceRDAt). --- The initial transformation is applied in the processes to obtain the values that will be reduced. --- The final combine function is used to create a processes outputs from the initial input and the --- gathered values. -allGatherBuFlyRDAt :: forall a b c. (Trans a, Trans b, Trans c) - => Places -- ^where to instantiate - -> (a -> b) -- ^initial transform function - -> (a -> [b] -> c) -- ^final combine function - -> [RD a] -> [RD c] -allGatherBuFlyRDAt places t1 t2 = allReduceRDAt places t1' (++) t2 where - t1' :: a -> [b] - t1' a = [t1 a] - -data Either' a b = Left' a | Right' b - deriving (Eq) -instance (NFData a, NFData b) => NFData (Either' a b) where - rnf (Left' x) = rnf x - rnf (Right' y) = rnf y -instance (Trans a,Trans b) => Trans (Either' a b) diff --git a/Control/Parallel/Eden/EdenSkel/WPSkels.hs b/Control/Parallel/Eden/EdenSkel/WPSkels.hs deleted file mode 100644 --- a/Control/Parallel/Eden/EdenSkel/WPSkels.hs +++ /dev/null @@ -1,727 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Parallel.Eden.EdenSkel.WPSkels --- Copyright : (c) Philipps Universitaet Marburg 2009-2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : eden@mathematik.uni-marburg.de --- Stability : beta --- Portability : not portable --- --- This Haskell module defines workpool skeletons for dynamic task --- distribution for the parallel functional language Eden. --- --- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. --- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden --- for a parallel build. --- --- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) - - -module Control.Parallel.Eden.EdenSkel.WPSkels ( - -- * Workpool skeletons with a single master - -- ** Simple workpool skeletons - -- | The workpool skeletons use the non-deterministic merge function to achieve dynamic load balancing. - workpool, workpoolSorted, workpoolSortedNonBlock, workpoolReduce, - -- ** Simple workpool skeletons - versions using explicit placement - -- | The workpool skeletons use the non-deterministic merge function to achieve dynamic load balancing. - workpoolAt, workpoolSortedAt, workpoolSortedNonBlockAt, workpoolReduceAt, - workpoolAuxAt, - -- * Hierarchical workpool skeleton - -- |These skeletons can be nested with an arbitrary number of submaster - -- levels to unload the top master. - wpNested, - -- ** Hierarchical workpool skeleton with dynamic task creation - -- |The worker function is extended such that dynamic creation of - -- new tasks is possible. New tasks are added to the end of the - -- task list, thus tasks are traversed breath first (not strictly - -- because of the skeletons' nondeterminism). Furthermore, these - -- skeletons can be nested with an arbitrary number of submaster - -- levels to unload the top master. - wpDynNested, wpDNI, --- * Distributed workpool skeletons with state and dynamic task creation - distribWPAt, --- * Deprecated skeletons - masterWorker, mwNested, mwDynNested, mwDNI, - ) where -#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) -import Control.Parallel.Eden -#else -import Control.Parallel.Eden.EdenConcHs -#endif -import Control.Parallel.Eden.EdenSkel.Auxiliary -import Control.Parallel.Eden.EdenSkel.MapSkels -import Control.Parallel.Eden.EdenSkel.TopoSkels -import Data.List -import Data.Maybe(maybeToList,mapMaybe) - -import System.IO.Unsafe -import Control.Monad - -import Control.Concurrent - - --- | Simple workpool (result list in non-deterministic order) --- This version takes places for instantiation. --- --- Notice: Result list in non-deterministic order. -workpoolAt :: forall t r . (Trans t, Trans r) => - Places - -> Int -- ^number of child processes (workers) - -> Int -- ^prefetch of tasks (for workers) - -> (t -> r) -- ^worker function (mapped to tasks) - -> [t] -> [r] -- ^what to do -workpoolAt pos np prefetch wf tasks - = map snd fromWorkers - where - fromWorkers :: [(Int,r)] - fromWorkers = merge (tagWithPids (parMapAt pos worker taskss)) - taskss :: [[t]] - taskss = distribute np (initialReqs ++ newReqs) tasks - initialReqs, newReqs :: [Int] - initialReqs = concat (replicate prefetch [0..np-1]) - newReqs = map fst fromWorkers - worker = map wf - - --- | Tag each element of the inner list with the id of its inner list. -tagWithPids :: [[r]] -- ^untagged input - -> [[(Int,r)]] -- ^tagged output -tagWithPids rss = [ zip (repeat i) rs |(i,rs) <-zip [0..] rss] - - --- | Simple workpool (result list in non-deterministic order) --- --- Notice: Result list in non-deterministic order. -workpool :: (Trans t, Trans r) => - Int -- ^number of child processes (workers) - -> Int -- ^prefetch of tasks (for workers) - -> (t -> r) -- ^worker function (mapped to tasks) - -> [t] -> [r] -- ^what to do -workpool = workpoolAt [0] - - - --- | Workpool version with one result stream for each worker and meta --- information about the task distribution. --- This meta-skeleton can be used to define workpool-skeletons which --- can reestablish the result list order. --- --- Notice: Result list in non-deterministic order. -workpoolAuxAt :: (Trans t, Trans r) => - Places - -> Int -- ^number of child processes - -- (workers) - -> Int -- ^prefetch of tasks (for - -- workers) - -> (t -> r) -- ^worker function (tasks to - -- results mapping) - -> [t] -- ^tasks - -> ([Int],[[Int]],[[r]]) -- ^(input distribution (input i - -- is in sub-list distribs!i), - -- task positions (element i of - -- result-sub-list j was in the - -- input list at (poss!j)!i ), - -- result streams of workers) -workpoolAuxAt pos np prefetch wf tasks - = (reqs,poss,fromWorkers) - where fromWorkers = parMapAt pos (map wf) taskss - (taskss,poss) = distributeWithPos np reqs tasks - -- generate only as many reqs as there are tasks - reqs = map snd $ zip tasks $ initialReqs ++ newReqs - initialReqs = concat (replicate prefetch [0..np-1]) - newReqs = merge $ [ [ i | j<-rs] - | (i,rs) <-zip [0..] fromWorkers] - - --- | Task distribution according to worker requests. Returns additionally to @ distribute @ a nested list of the positions to indicate where the tasks have been located in the original list --- -distributeWithPos :: Int -- ^number of workers - -> [Int] -- ^ request stream (worker IDs ranging from 0 to n-1) - -> [t] -- ^ task list - -> ([[t]],[[Int]]) -- ^(task positions in original list, task distribution), each inner list for one worker. -distributeWithPos np reqs tasks - = unzip [unzip (taskList reqs tasks [0..] n) | n<-[0..np-1]] - where taskList (r:rs) (t:ts) (tag:tags) pe - | pe == r = (t,tag):(taskList rs ts tags pe) - | otherwise = taskList rs ts tags pe - taskList _ _ _ _ = [] - - --- | Sorted workpool (results in the order of the tasks). --- This version takes places for instantiation. -workpoolSortedAt :: (Trans t, Trans r) => - Places - -> Int -- ^number of child processes - -- (workers) - -> Int -- ^prefetch of tasks (for workers) - -> (t -> r) -- ^worker function - -> [t] -- ^tasks - -> [r] -- ^results -workpoolSortedAt pos np prefetch f tasks = res - where (_, poss, ress) = workpoolAuxAt pos np prefetch f tasks - res = map snd $ mergeByPos ress' - ress' = map (uncurry zip) (zip poss ress) - - --- | Join sorted lists into one sorted list. --- This function uses a balanced binary combination scheme to merge sublists. -mergeByPos :: [[(Int,r)]] -- ^ tagged input - -> [(Int,r)] -- ^ output sorted by tags -mergeByPos [] = [] -mergeByPos [wOut] = wOut -mergeByPos [w1,w2] = merge2ByTag w1 w2 -mergeByPos wOuts = merge2ByTag - (mergeHalf wOuts) - (mergeHalf (tail wOuts)) - where mergeHalf = mergeByPos . (takeEach 2) - -merge2ByTag [] w2 = w2 -merge2ByTag w1 [] = w1 -merge2ByTag w1@(r1@(i,_):w1s) w2@(r2@(j,_):w2s) - | i < j = r1: merge2ByTag w1s w2 - | i > j = r2: merge2ByTag w1 w2s - | otherwise = error "found tags i == j" - - - --- | Sorted workpool: Efficient implementation using a the --- distribution lookup list. --- --- Notice: Results in the order of the tasks. -workpoolSorted :: (Trans t, Trans r) => - Int -- ^number of child processes (workers) - -> Int -- ^prefetch of tasks (for workers) - -> (t -> r) -- ^worker function (mapped to tasks) - -> [t] -- ^tasks - -> [r] -- ^results -workpoolSorted = workpoolSortedAt [0] - --- | Non-blocking sorted workpool. Result list is structurally defined --- up to the position where tasks are distributed, independent of the --- received worker results. This version needs still performance --- testing. --- --- Notice: Results in the order of the tasks. -workpoolSortedNonBlockAt :: (Trans t, Trans r) => - Places - -> Int -- ^number of child processes (workers) - -> Int -- ^prefetch of tasks (for workers) - -> (t -> r) -- ^worker function (mapped to tasks) - -> [t] -> [r] -- ^what to do -workpoolSortedNonBlockAt pos np prefetch f tasks - = orderBy fromWorkers reqs - where (reqs, _ ,fromWorkers) = workpoolAuxAt pos np prefetch f tasks - - --- | Orders a nested list (sublist are ordered) by a given distribution (non-blocking on result elements of other sub lists) -orderBy :: forall idx r . Integral idx => - [[r]] -- ^ nested input list (@inputss@) - -> [idx] -- ^ distribution (result i is in sublist @inputss!(idxs!i)@) - -> [r] -- ^ ordered result list -orderBy _ [] = [] -orderBy [rs] is = rs -orderBy (xs:rss) is = fst $ foldl (f is) (xs,1) rss - where f :: [idx] -> ([r],idx) -> [r] -> ([r], idx) - f is (xs,a) ys = (m xs ys is, a+1) - where m :: [r] -> [r] -> [idx] -> [r] - m _ _ [] = [] - m xs ys (i:is) | i < a = head xs : m (tail xs) ys is - | i==a = head ys : m xs (tail ys) is - | otherwise = m xs ys is - - --- | orders a nested list by a given distribution (alternative code) -orderBy' :: Integral idx => - [[r]] -- ^ nested input list (@inputss@) - -> [idx] -- ^ distribution (result i is in sublist @inputss!(idxs!i)@) - -> [r] -- ^ ordered result list -orderBy' rss [] = [] -orderBy' rss (r:reqs) - = let (rss1,(rs2:rss2)) = splitAt (fromIntegral r) rss - in (head rs2): orderBy' (rss1 ++ ((tail rs2):rss2)) reqs - - --- | Non-blocking sorted workpool (results in the order of the --- tasks). Result list is structurally defined up to the position --- where tasks are distributed, independent of the received worker --- results. This version needs still performance testing. This --- version takes places for instantiation. --- --- Notice: Results in the order of the tasks. -workpoolSortedNonBlock :: (Trans t, Trans r) => - Int -- ^number of child processes (workers) - -> Int -- ^prefetch of tasks (for workers) - -> (t -> r) -- ^worker function (mapped to tasks) - -> [t] -> [r] -- ^what to do -workpoolSortedNonBlock = workpoolSortedNonBlockAt [0] - - - - - --- | Simple workpool with additional reduce function for worker outputs. --- This version takes places for instantiation. --- --- Notice: Result list in non-deterministic order. -workpoolReduceAt :: forall t r r' . (Trans t, Trans r, Trans r') => - Places - -> Int -- ^number of child processes (workers) - -> Int -- ^prefetch of tasks (for workers) - -> (r' -> r -> r) -- ^reduce function - -> r -- ^neutral for reduce function - -> (t -> r') -- ^worker function (mapped to tasks) - -> [t] -- ^tasks - -> [r] -- ^results (one from each worker) -workpoolReduceAt pos np prefetch rf e wf tasks - = map snd fromWorkers - where - fromWorkers :: [([Int],r)] - fromWorkers = spawnFAt pos (map worker [0..np-1]) taskss - taskss = distribute np (initialReqs ++ newReqs) tasks - initialReqs = concat (replicate prefetch [0..np-1]) - newReqs = merge (map fst fromWorkers) - worker i ts = (map (\r -> rnf r `seq` i) rs, foldr rf e rs) - where rs = map wf ts - - --- | Simple workpool with additional reduce function for worker outputs. --- This version takes places for instantiation. --- --- Notice: Result list in non-deterministic order. -workpoolReduce :: forall t r r' . (Trans t, Trans r, Trans r') => - Int -- ^number of child processes (workers) - -> Int -- ^prefetch of tasks (for workers) - -> (r' -> r -> r) -- ^reduce function - -> r -- ^neutral for reduce function - -> (t -> r') -- ^worker function (mapped to tasks) - -> [t] -- ^tasks - -> [r] -- ^results (one from each worker) -workpoolReduce = workpoolReduceAt [0] - --- |Hierachical WP-Skeleton. The worker --- function is mapped to the worker input stream (list type). A worker --- produces a result. The workers are located on the leaves of a --- WP-hierarchy, in the intermediate levels are submasters which unload --- the master by streaming 'result' streams of their child --- processes into a single result stream. --- --- Notice: Result list in non-deterministic order. -wpNested :: forall t r . (Trans t, Trans r) => - [Int] -- ^branching degrees: the i-th - -- element defines the branching - -- degree of for the i-th level of - -- the WP-hierarchy. Use a singleton - -- list for a flat MW-Skeleton. - -> [Int] -- ^Prefetches for the - -- sub-master/worker levels - -> (t -> r) -- ^worker function - -> [t] -- ^initial tasks - -> [r] -- ^results -wpNested ns pfs wf initTasks = wpDynNested ns pfs (\t -> (wf t,[])) initTasks - - --- |Simple interface for 'wpDynNested'. Parameters are the number of child processes, the first --- level branching degree, the nesting depth (use 1 for a --- single master), and the task prefetch amount for the worker level. --- All processes that are not needed for the submasters are --- used for the workers. If the number of submasters in the last level --- and the number of remaining child processes are prime to each --- other, then the next larger divisor is chosen for the number of --- workers. --- --- Notice: Result list in non-deterministic order. -wpDNI :: (Trans t, Trans r) => - Int -- ^number of processes (submasters and workers) - -> Int -- ^nesting depth - -> Int -- ^branching degree of the first submaster - -- level (further submaster levels are - -- branched binary) - -> Int -- ^task prefetch for the workers - -> (t -> (r,[t])) -- ^worker function - produces a tuple of - -- result and tasks for the processed task - -> [t] -- ^initial tasks - -> [r] -- ^results -wpDNI np levels l_1 pf f tasks - = let nesting = mkNesting np levels l_1 - in wpDynNested nesting (mkPFs pf nesting) f tasks - - --- |Hierachical WP-Skeleton with dynamic task creation. The worker --- function is mapped to the worker input stream (list type). A worker --- produces a tuple of result and dynamicly created tasks for each --- processed task. The workers are located on the leaves of a --- WP-hierarchy, in the intermediate levels are submasters which unload --- the master by streamlining 'result/newtask' streams of their child --- processes into a single result/newtask stream. Furthermore, the --- submasters retain locally half of the tasks which are --- dynamically created by the workers in their subtree. --- --- Notice: Result list in non-deterministic order. -wpDynNested :: forall t r . (Trans t, Trans r) => - [Int] -- ^branching degrees: the i-th - -- element defines the branching - -- degree of for the i-th level of - -- the MW-hierarchy. Use a singleton - -- list for a flat MW-Skeleton. - -> [Int] -- ^Prefetches for the - -- sub-master/worker levels - -> (t -> (r,[t])) -- ^worker function - produces a - -- tuple of result and new tasks for - -- the processed task - -> [t] -- ^initial tasks - -> [r] -- ^results -wpDynNested ns pfs wf initTasks - = topMasterStride strideTM (head ns) (head pfs) subWF initTasks - where subWF = foldr fld wf' (zip3 stds (tail ns) (tail pfs)) - wf' :: [Maybe t] -> [(r,[t],Int)] - -- explicit Nothing-Request after each result - wf' xs = map(\ (r,ts) -> (r,ts,0)) (map (wf)(inp xs)) - inp ((Just x):rest) = x:inp rest - inp (Nothing:_) = [] -- STOP!!! - -- placement: - (strideTM:stds) = scanr (\x y -> ((y*x)+1)) 1 (tail ns) - fld :: (Int, Int, Int) -> ([Maybe t] -> [(r,[t],Int)]) - -> [Maybe t] -> [(r,[t],Int)] - fld (stride,n,pf) wf = mwDynSubStride stride n pf wf - - - ---------------------------mwDynNested auxiliary--------------------------------- - -topMasterStride :: forall t r . (Trans t, Trans r) => - Int -> Int -> Int -> ([Maybe t] -> [(r,[t],Int)]) -> [t] -> [r] -topMasterStride stride branch prefetch wf initTasks = finalResults - where - -- identical to static task pool except for the type of workers - ress = merge (spawnAt places workers inputs) - places = nextPes branch stride - workers :: [Process [Maybe t] [(Int,(r,[t],Int))]] - workers = [process (zip [i,i..] . wf) | i <- [0..branch-1]] - inputs = distribute branch (initReqs ++ reqs) tasks - initReqs = concat (replicate prefetch [0..branch-1]) - -- additions for task queue management and - -- termination detection - tasks = (map Just initTasks) ++ newTasks - ----------------------------- - initNumTasks = length initTasks - -- => might lead to deadlock! - ----------------------------- - (finalResults, reqs, newTasks) - = tdetectTop ress initNumTasks - - -mwDynSubStride :: forall t r . (Trans t, Trans r) => - Int -> Int -> Int -> ([Maybe t] -> [(r,[t],Int)]) - -> [Maybe t] -> [(r,[t],Int)] -mwDynSubStride stride branch prefetch wf initTasks = finalResults where - fromWorkers = map flatten (spawnAt places workers inputs) - places = nextPes branch stride - workers :: [Process [Maybe t] [(Int,(r,[t],Int))]] - workers = [process (zip [i,i..] . wf) | i <- [0..branch-1]] - inputs = distribute branch (initReqs ++ reqs) tasks - initReqs = concat (replicate prefetch [0..branch-1]) - -- task queue management - controlInput = merge (map Right initTasks: map (map Left) fromWorkers) - (finalResults, tasks, reqs) - = tcontrol controlInput 0 0 (branch * (prefetch+1)) False - - --- task queue control for termination detection -tdetectTop :: [(Int,(r,[t],Int))] -> Int -> ([r], [Int], [Maybe t]) -tdetectTop ((req,(r,ts,subHoldsTs)):ress) numTs - | numTs == 1 && null ts && subHoldsTs == 0 - = ([r], [], repeat Nothing) -- final result - | subHoldsTs == 1 - = (r:moreRes, moreReqs, (map Just ts) ++ moreTs) - | otherwise - = (r:moreRes, req:moreReqs, (map Just ts) ++ moreTs) - where --localNumTaks is 0 or 1, if it's 1 -> no Request - -- -> numTs will not be decreased - (moreRes, moreReqs, moreTs) - = tdetectTop ress (numTs-1+length ts+subHoldsTs) - - -tcontrol :: [Either (Int,r,[t],Int) (Maybe t)] -> -- controlInput - Int -> Int -> -- task / hold counter - Int -> Bool -> -- prefetch, split mode - ([(r,[t],Int)],[Maybe t],[Int]) -- (results,tasks,requests) -tcontrol ((Right Nothing):_) 0 _ _ _ - = ([],repeat Nothing,[]) -- Final termination -tcontrol ((Right (Just t)):ress) numTs hldTs pf even -- task from above - = let (moreRes, moreTs, reqs) = tcontrol ress (numTs+1) hldTs pf even - in (moreRes, (Just t):moreTs, reqs) -tcontrol ((Left (i,r,ts,subHoldsTs)):ress) numTs hldTs pf even - = let (moreRes, moreTs, reqs) - = tcontrol ress (numTs + differ) (hldTs') pf evenAct - differ = length localTs + subHoldsTs - 1 - hldTs' = max (hldTs + differ) 0 - holdInf | (hldTs+differ+1 > 0) = 1 - | otherwise = 0 - (localTs,fatherTs,evenAct) - = split numTs pf ts even -- part of tasks to parent - newreqs | (subHoldsTs == 0) = i:reqs - | otherwise = reqs -- no tasks kept below? - in ((r,fatherTs,holdInf):moreRes, - (map Just localTs) ++ moreTs, newreqs) - --- error case, not shown in paper -tcontrol ((Right Nothing):_) n _ _ _ - = error "Received Stop signal, although not finished!" - - -flatten [] = [] -flatten ((i,(r,ts,n)):ps) = (i,r,ts,n) : flatten ps - -split :: Int -> Int -> [t] -> Bool ->([t],[t],Bool) -split num pf ts even-- = splitAt (2*pf - num) ts - | num >= 2*pf = ([],ts,False) - --no tasks or odd -> keep first - | ((not even)||(num == 1)) = oddEven ts - | otherwise = evenOdd ts - -- | num < pf `div` 2 = (ts,[]) - - -oddEven :: [t] -> ([t],[t],Bool) -oddEven [] = ([],[],False) -oddEven (x:xs) = (x:localT ,fatherT, even) - where (localT,fatherT,even) = evenOdd xs - -evenOdd :: [t] -> ([t],[t],Bool) -evenOdd [] = ([],[],True) -evenOdd (x:xs) = (localT, x:fatherT, even) - where (localT,fatherT,even) = oddEven xs - -nextPes :: Int -> Int -> [Int] -nextPes n stride | start > noPe = replicate n noPe - | otherwise = concat (replicate n ps) - where ps = cycle (takeWhile (<= noPe) [start,start+stride..]) - start = selfPe + 1 - -mkNesting :: Int -> Int -> Int -> [Int] -mkNesting np 1 _ = [np] -mkNesting np depth level1 = level1:(replicate (depth - 2) 2) ++ [numWs] - where -- leaves = np - #submasters - leaves = np - level1 * ( 2^(depth-1) - 1 ) - -- num of lowest submasters - numSubMs = level1 * 2^(depth - 2) - -- workers per branch (rounded up) - numWs = (leaves + numSubMs - 1) `div` numSubMs - -mkPFs :: Int -> -- prefetch value for worker processes - [Int] -> -- branching per level top-down - [Int] -- list of prefetches -mkPFs pf nesting - = [ factor * (pf+1) | factor <- scanr1 (*) (tail nesting) ] ++ [pf] - - - ----------------------------distributed workpool skeletons------------------------------------------- - --- | A distributed workpool skeleton that uses task generation and a global state (s) with a total order. --- Split and Detatch policy must give tasks away (may not produce empty lists), unless all tasks are pruned! -distribWPAt :: (Trans onT, Trans t, Trans r, Trans s, NFData r') => - Places -- ^ where to put workers - -> ((t,s) -> (Maybe (r',s),[t])) -- ^ worker function - -> (Maybe ofT -> Maybe onT -> [t]) -- ^ input transformation (e.g. (fetch . fromJust . snd) for online input of type [RD[t]]) - -> ([Maybe (r',s)] -> s -> r) -- ^ result transformation (prior to release results in the workers) - -> ([t]->[t]->s->[t]) -- ^ taskpool transform attach function - -> ([t]->s->([t],Maybe (t,s))) -- ^ taskpool transform detach function (local request) - -> ([t]->s->([t],[t])) -- ^ taskpool transform split function (remote request) - -> (s->s->Bool) -- ^ state comparison (checks if new state is better than old state) - -> s -- ^ initial state (offline input) - -> [ofT] -- ^ offline input (if non empty, outer list defines the number of workers, else the shorter list does) - -> [onT] -- ^ dynamic input (if non empty, outer list defines the number of workers, else the shorter list does) - -> [r] -- ^ results of workers -distribWPAt places wf inputT resT ttA ttD ttSplit sUpdate st ofTasks onTasks = res where - res = ringFlAt places id id workers onTasks' - workers = zipWith (worker) (True:(repeat False)) ofTasks' - -- length of ontasks and oftasks is adjusted such that the desired number of workers will be instantiated - (ofTasks',onTasks') | null ofTasks = (repeat Nothing , map Just onTasks) - | null onTasks = (map Just ofTasks, repeat Nothing ) - | otherwise = (map Just ofTasks, map Just onTasks) - -- worker functionality - worker isFirst ofTasks onTasks ringIn = (resT ress sFinal,init ringOut) where - ts = (inputT ofTasks onTasks) - (ress,ntssNtoMe) = unzip $ genResNReqs $ map wf ts' --seperate - reqList = Me : mergeS [ringIn, --merge external Requests - ntssNtoMe] rnf --and nf reduced local Requests - -- manage Taskpool & Requests - (ts',ringOut) = control ttA ttSplit ttD sUpdate reqList ts st isFirst - sFinal = getState $ last ringOut - - -control:: (Trans t, Trans s) => - ([t]->[t]->s->[t]) -> --Taskpool Transform Attach - ([t]->s->([t],[t])) -> --Split Policy (remote Req) - ([t]->s->([t],Maybe (t,s))) -> --tt Detach (local Req) - (s->s->Bool)-> --Checks if newState is better than oldState - [Req [t] s]->[t]->s->Bool-> --reqs,tasks,state,isFirstInRing - ([(t,s)],[Req [t] s]) --localTasks,RequestsToRing -control ttA ttSplit ttD sUpdate requests initTasks st isFirst - = distribWork requests initTasks Nothing st (0,0) - where - --until no tasks left: react on own and Others requests & add new Tasks - --distribWork :: Trans t => [Req [t] s] -> [t] -> $ - -- Maybe (ChanName (Req [t] s))->(Int,Int)-> ([t],[ReqS [t] s],s) - distribWork (TasksNMe nts:rs) tS replyCh st sNr --selfmade Tasks arrive - = distribWork (Me:rs) (ttA tS nts st) replyCh st sNr --add Tasks and MeReq - - distribWork (NewState st':rs) tS replyCh st sNr --Updated State arrives - | sUpdate st' st = let (tS',wReqs') =distribWork rs tS replyCh st' sNr - in (tS',(NewState st':wReqs')) --then check and send - | otherwise = distribWork rs tS replyCh st sNr --or discard - - distribWork (req@(Others tag tCh):rs) [] replyCh st sNr --Others Request & - | tag==None = (tS',req:wReqs') --no tasks left --> pass Request - | otherwise = (tS', Others Black tCh : wReqs') --I'm still working -> Black - where(tS',wReqs') = distribWork rs [] replyCh st sNr - - distribWork (Me:rs) [] replyCh st sNr = --last own Task solved and no new ones - new (\reqChan (newTS,replyChan) -> --gen new reqChan to get newTS & replyC - let (tS',wReqs) = passWhileReceive (mergeS [rs, --wait for fst newTask - newTS `pseq` [TasksNMe newTS]] r0) replyChan st sNr --to merge - tag | isFirst = Black --First Worker starts Black (For Termination) - | otherwise = None --normal Workers with None Tag - in(case replyCh of --First own Request into Ring- others dynamic - Nothing -> (tS', Others tag reqChan : wReqs) - Just replyCh' -> parfill replyCh' (Others tag reqChan) - (tS',wReqs))) - - distribWork (Me:rs) tS replyCh st sNr --local Request and Tasks present - = let (tS',tDetatch) = ttD tS st --TaskpoolTransform Detatch - (tsDetatch,wReqs) = case tDetatch of - Nothing -> distribWork (Me:rs) [] replyCh st sNr - Just t -> distribWork rs tS' replyCh st sNr - in ((maybeToList tDetatch)++tsDetatch,wReqs) --add Maybe one Task to wf - - distribWork reqs@(Others _ tCh :rs) tS replyCh st (s,r) --foreign Req & have Ts - = let (holdTs,sendTs) = ttSplit tS st --split ts to send and ts to hold - ((tS',wReqs'),replyReq) - = new (\replyChan replyReq' -> --gen ReplyC and send Tasks & new - parfill tCh (sendTs,Just replyChan) --ReplyC in Chan of the Req - ((distribWork rs holdTs replyCh st (s+1,r)),replyReq')) - in case sendTs of --ReplyReqToOutp - [] -> distribWork reqs [] replyCh st (s,r) --No tasks left - (_:_) -> (tS',mergeS [[replyReq],wReqs'] rnf) - --- Pass all until foreign Tasks arrive or Termination starts --- passWhileRecive :: Trans t => [ReqS [t] s] -> Maybe(ChanName (ReqS [t] s)) --- -> (Int,Int) -> ([t],[ReqS [t] s]) - passWhileReceive (NewState st':rs) replyCh st sNr --Updated State arrives - | sUpdate st' st =let (tS',wReqs')=passWhileReceive rs replyCh st' sNr - in (tS',(NewState st':wReqs')) --then check and send - | otherwise = passWhileReceive rs replyCh st sNr --or discard - - passWhileReceive (req@(Others None tCh):rs) replyCh st sNr --Req of normal - = let (tS',wReqs) = passWhileReceive rs replyCh st sNr --Worker -> pass it - in (tS',req:wReqs) - - passWhileReceive (req@(Others Black tCh ):rs) replyCh st (s,r) --Black Req - | (not isFirst) = (tS',req :wReqs) --normal Workers: pass it - | otherwise = (tS',req':wReqs) --First Worker: new Round starts White - where (tS',wReqs) = passWhileReceive rs replyCh st (s,r) - req'= Others (White s r 0 0) tCh --Start with own Counters - - passWhileReceive (Others (White s1 r1 s2 r2) tCh :rs) replyCh st (s,r) - | (not isFirst) = (tS',req':wReqs) --Normal Workers: add Counter and pass - --4 counters equal -> pass Black as end of reqs Symbol, start Termination - | otherwise = if terminate - then ([],Others Black tCh : (termRing rs ++ [NewState st])) - else (tS',req'':wReqs) --no Termination - where (tS',wReqs) = passWhileReceive rs replyCh st (s,r) - req' = Others (White (s1+s) (r1+r) s2 r2) tCh --add Counters - req'' = Others (White s r s1 r1) tCh --Move Counters->NewTurn - terminate = (s1==r1)&&(r1==s2)&&(s2==r2) --Check Termination - - passWhileReceive (TasksNMe newTS:rs) replyCh st (s,r) --Task List arrives - | null newTS = ([],(termRing rs) --got empty newTs -> begin Termination - ++ [NewState st]) --attach final State at the End - | otherwise = (distribWork (Me:rs) newTS replyCh st (s,r+1)) --have newTs - - -data Req t s = - Me | --Work Request of local Worker - Fuction - --Request of other Workers with Tag, and Chanel to Send Tasks and - Others { getTag :: Tag, - getReplyChan :: (ChanName (t,Maybe (ChanName(Req t s)))) - } | --Reply Chanel - TasksNMe { getTask :: t} | -- New Tasks and additional Me Request to add - NewState { getState :: s } - -instance (NFData t, NFData s) => NFData (Req t s) - where - rnf Me = () - rnf (Others t c) = rnf t `pseq` rnf c - rnf (TasksNMe t) = rnf t - rnf (NewState s) = rnf s - -instance (Trans t,Trans s) => Trans (Req t s) - -data Tag = Black | --no Termination Situation / Term Mode: Last Request in Ring - White Int Int Int Int | --check Termination Situation:(send&recv) - None --Request of normal Worker - -instance NFData Tag - where rnf Black = () - rnf None = () - rnf (White a b c d) = rnf (a,b,c,d) - -instance Eq Tag where - Black == Black = True - None == None = True - White a b c d == White a' b' c' d' = (a,b,c,d)==(a',b',c',d') - a == b = False - - ----------------------auxiliary----------------- -termRing :: (Trans t,Trans s) => [Req [t] s] -> [Req [t] s] -termRing [] = [] -- Predecessors tells no more reqs -termRing (Others Black tCh : _ ) = parfill tCh ([],Nothing) [] --reply last req -termRing (Others None tCh : rs) = parfill tCh ([],Nothing) termRing rs --reply -termRing (_ : rs) = termRing rs --ignore isFirsts reply - -genResNReqs :: (NFData t,NFData r',NFData s)=> - [(Maybe (r',s),[t])] -> [(Maybe (r',s),Req [t] s)] -genResNReqs [] = [] --No more tasks -genResNReqs ((res@(Nothing,nts)):ress) --No new State -> Attach new Tasks - = rnf res `pseq` (Nothing,TasksNMe nts): genResNReqs ress -genResNReqs ((res@(Just (r,st),nts)):ress) --New State found -> Attach - = rnf res `pseq` (Just (r,st),NewState st): genResNReqs ((Nothing,nts):ress) - - ------------------------------DEPRECATED--------------------------------- --- | Deprecated, same as 'workpoolSortedNonBlock' -{-# DEPRECATED masterWorker "better use workpoolSortedNonBlock instead" #-} -masterWorker :: (Trans a, Trans b) => - Int -> Int -> (a -> b) -> [a] -> [b] -masterWorker = workpoolSortedNonBlock - --- | Deprecated, same as 'wpNested' -{-# DEPRECATED mwNested "better use wpNested instead" #-} -mwNested :: forall t r . (Trans t, Trans r) => - [Int] -> [Int] -> (t -> r) -> [t] -> [r] -mwNested = wpNested - --- | Deprecated, same as 'wpDNI' -{-# DEPRECATED mwDNI "better use wpDNI instead" #-} -mwDNI :: (Trans t, Trans r) => - Int - -> Int - -> Int - -> Int - -> (t -> (r,[t])) - -> [t] - -> [r] -mwDNI = wpDNI - --- | Deprecated, same as 'wpDynNested' -{-# DEPRECATED mwDynNested "better use wpDynNested instead" #-} -mwDynNested :: forall t r . (Trans t, Trans r) => - [Int] - -> [Int] - -> (t -> (r,[t])) - -> [t] - -> [r] -mwDynNested = wpDynNested diff --git a/Control/Parallel/Eden/Iteration.hs b/Control/Parallel/Eden/Iteration.hs new file mode 100644 --- /dev/null +++ b/Control/Parallel/Eden/Iteration.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.Eden.Iteration +-- Copyright : (c) Philipps Universitaet Marburg 2009-2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : eden@mathematik.uni-marburg.de +-- Stability : beta +-- Portability : not portable +-- +-- This Haskell module defines iteration skeletons for Eden. +-- +-- Depends on the Eden Compiler. +-- +-- Eden Project +-- +module Control.Parallel.Eden.Iteration ( + -- * Iteration Skeletons + iterUntilAt, iterUntil + ) where +import Control.Parallel.Eden.Auxiliary +import Control.Parallel.Eden.Map +#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) +import Control.Parallel.Eden +#else +import Control.Parallel.Eden.EdenConcHs +#endif + +-- \cite{SkeletonBookChapter02}, code (c) Fernando Rubio +-- | The iterUntil skeleton is an iterated map skeleton. Each worker +-- function transforms one local worker state and one task per iteration. +-- The result is the next local state and the iterations +-- result, which is send back to the master. The master transforms the +-- output of all tasks of one iteration and a local master state into +-- the worker inputs of the next iteration and a new master state +-- using the combine function (output: Right tasks masterState) or +-- decides to terminate the iteration (output: Left result). The input +-- transformation function generates all initial worker states and +-- initial worker tasks and the initial master state from the skeleton. +iterUntil :: (Trans wl,Trans t, Trans sr) => + (inp -> ([wl],[t],ml)) -- ^input transformation function + -> (wl -> t -> (sr,wl)) -- ^worker function + -> (ml -> [sr] -> Either r ([t],ml)) -- ^combine function + -> inp -- ^input + -> r -- ^result +iterUntil = iterUntilAt [0] + +-- | This is the basic implementation, using places for explicit process +-- | placement of the worker processes. +iterUntilAt :: (Trans wl,Trans t, Trans sr) => + Places -- ^where to instatiate + -> (inp -> ([wl],[t],ml)) -- ^input transformation function + -> (wl -> t -> (sr,wl)) -- ^worker function + -> (ml -> [sr] -> Either r ([t],ml)) -- ^combine function + -> inp -- ^input + -> r -- ^result +iterUntilAt pids split wf comb x = result where + (result, moretaskss) = manager comb ml (lazyTranspose srss) + srss = parMapAt pids (worker wf) (zip wlocals taskss) + taskss = lazyTranspose (initials: moretaskss) + (wlocals,initials,ml)= split x + +-- master/manager functionality of the iterUntil skeleton +manager :: (ml -> [sr] -> Either r ([t],ml)) -> + ml -> [[sr]] -> (r,[[t]]) +manager comb ml (srs:srss) = case comb ml srs of + Left res -> (res,[]) -- Left: stop iteration + Right (ts,ml') -> -- Right: proceed with new tasks (ts) and new state ml' + let (res',tss) = manager comb ml' srss + in (res', ts:tss) + +--worker functionality of the iterUntil skeleton +worker :: (wl -> t -> (sr,wl)) -> (wl,[t]) -> [sr] +worker wf (local,[]) = [] +worker wf (local, t:ts) = sr: worker wf (local',ts) where + (sr,local') = wf local t diff --git a/Control/Parallel/Eden/Map.hs b/Control/Parallel/Eden/Map.hs new file mode 100644 --- /dev/null +++ b/Control/Parallel/Eden/Map.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.Eden.Map +-- Copyright : (c) Philipps Universitaet Marburg 2009-2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : eden@mathematik.uni-marburg.de +-- Stability : beta +-- Portability : not portable +-- +-- This Haskell module defines map-like skeletons for +-- the parallel functional language Eden. +-- +-- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. +-- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden +-- for a parallel build. +-- +-- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) + + +module Control.Parallel.Eden.Map ( + -- * Custom map skeletons + -- | These skeletons expose many parameters to the user and thus have varying types + parMap, ranch, + farm, farmS, farmB, + offlineFarm, offlineFarmS, offlineFarmB, + -- * Custom map skeletons with explicit placement + -- | Map skeleton versions with explicit placement + parMapAt, ranchAt, farmAt, offlineFarmAt, + -- * Simple map skeleton variants + -- | The map skeletons 'farm' and 'offlineFarm' can be used to define + -- skeletons with the simpler sequential map interface :: (a -> b) -> [a] -> [b] + mapFarmB, mapFarmS, mapOfflineFarmS, mapOfflineFarmB, + -- * Deprecated map skeletons + -- | These skeletons are included to keep old code alive. Use the skeletons above. + farmClassic, ssf, offline_farm, map_par, map_farm, map_offlineFarm, map_ssf + ) where +#if defined( __PARALLEL_HASKELL__ ) +import Control.Parallel.Eden +#else +import Control.Parallel.Eden.EdenConcHs +#endif +import Control.Parallel.Eden.Auxiliary +import Data.List + + +-- | Basic parMap Skeleton - one process for each list element. This version takes +-- places for instantiation on particular PEs. +parMapAt :: (Trans a, Trans b) => + Places -- ^places for instantiation + -> (a -> b) -- ^worker function + -> [a] -- ^task list + -> [b] -- ^result list +parMapAt pos f tasks = spawnAt pos (repeat (process f)) tasks + + +-- | Basic parMap Skeleton - one process for each list element +parMap :: (Trans a, Trans b) => + (a -> b) -- ^worker function + -> [a] -- ^task list + -> [b] -- ^result list +parMap = parMapAt [0] + + +-- | A process ranch is a generalized (or super-) farm. This version takes +-- places for instantiation. Arbitrary input is transformed into a list of inputs +-- for the worker processes (one worker for each transformed value). The worker +-- inputs are processed by the worker function. +-- The results of the worker processes are then reduced using the reduction function. +ranchAt :: (Trans b, Trans c) => + Places -- ^places for instantiation + -> (a -> [b]) -- ^input transformation function + -> ([c] -> d) -- ^result reduction function + -> (b -> c) -- ^worker function + -> a -- ^input + -> d -- ^output +ranchAt pos transform reduce fs xs = + reduce $ spawnAt pos (repeat $ process fs) (transform xs) + +-- | A process ranch is a generalized (or super-) farm. Arbitrary input +-- is transformed into a list of inputs for the worker processes (one worker +-- for each transformed value). The worker inputs are processed by the worker function. +-- The results of the worker processes are then reduced using the reduction function. +ranch :: (Trans b, Trans c) => + (a -> [b]) -- ^input transformation function + -> ([c] -> d) -- ^result reduction function + -> (b -> c) -- ^worker function + -> a -- ^input + -> d -- ^output +ranch = ranchAt [0] + + +-- | A farm distributes its input to a number of worker processes. +-- This version takes places for instantiation. +-- The distribution function divides the input list into +-- sublists - each sublist is input to one worker process, the +-- number of worker processes is determined by the number of +-- sublists. The results of the worker processes are +-- then combined using the combination function. +-- +-- Use 'map_farm' if you want a simpler interface. +-- +farmAt :: (Trans a, Trans b) => + Places -- ^places for instantiation + -> ([a] -> [[a]]) -- ^input distribution function + -> ([[b]] -> [b]) -- ^result combination function + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output +farmAt pos distr combine f tasks = ranchAt pos distr combine (map f) tasks + +-- | A farm distributes its input to a number of worker processes. +-- The distribution function divides the input list into +-- sublists - each sublist is input to one worker process, the +-- number of worker processes is determined by the number of +-- sublists. The results of the worker processes are +-- then combined using the combination function. +-- +-- Use 'mapFarmS' or 'mapFarmB' if you want a simpler interface. +-- +farm :: (Trans a, Trans b) => + ([a] -> [[a]]) -- ^input distribution function + -> ([[b]] -> [b]) -- ^result combination function + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output +farm = farmAt [0] + +-- | Like the 'farm', but uses a fixed round-robin distribution of tasks. +farmS :: (Trans a, Trans b) + => Int -- ^number of processes + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output +farmS np = farm (unshuffle np) shuffle + +-- | Like the 'farm', but uses a fixed block distribution of tasks. +farmB :: (Trans a, Trans b) + => Int -- ^number of processes + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output +farmB np = farm (splitIntoN np) concat + + + + +-- | Offline farm with explicit placement (alias self-service farm or +-- direct mapping): Like the farm, but tasks are evaluated inside the +-- workers (less communication overhead). Tasks are mapped inside each +-- generated process abstraction, avoiding evaluating and sending +-- them. This often reduces the communication overhead because +-- unevaluated data is usually much smaller than evaluated data. +-- +-- Use 'map_offlineFarm' if you want a simpler interface. +-- +-- Notice: The task lists structure has to be completely defined +-- before process instantiation takes place. +-- +offlineFarmAt :: Trans b => + Places -- ^places for instantiation + -> Int -- ^number of processes + -> ([a] -> [[a]]) -- ^input distribution function + -> ([[b]] -> [b]) -- ^result combination function + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output + +offlineFarmAt pos np distribute combine f xs + = combine $ spawnAt pos (map (rfi (map f)) [select i xs | i <- [0 .. np-1]]) + (repeat ()) + where select i xs = (distribute xs ++ repeat []) !! i + + + +-- | Offline farm (alias direct mapping): Like the farm, but +-- tasks are evaluated inside the workers (less communication +-- overhead). Tasks are mapped inside each generated process +-- abstraction avoiding evaluating and sending them. This often +-- reduces the communication overhead because unevaluated data is +-- usually much smaller than evaluated data. +-- +-- Use 'map_offlineFarm' if you want a simpler interface. +-- +-- Notice: The offline farm receives the number of processes to be created +-- as its first parameter. +-- The task lists structure has to be completely defined +-- before process instantiation takes place. +-- +offlineFarm :: Trans b => + Int -- ^number of processes + -> ([a] -> [[a]]) -- ^input distribution function + -> ([[b]] -> [b]) -- ^result combination function + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output + +offlineFarm = offlineFarmAt [0] + +-- | Like the 'offlineFarm', but with fixed round-robin distribution of tasks. +offlineFarmS :: (Trans a, Trans b) + => Int -- ^number of processes + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output +offlineFarmS np = offlineFarm np (unshuffle np) shuffle + +-- | Like the 'offlineFarm', but with fixed block distribution of tasks. +offlineFarmB :: (Trans a, Trans b) + => Int -- ^number of processes + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output +offlineFarmB np = offlineFarm np (splitIntoN np) concat + + +------------------------------------------------------------------------------------ +numProc = max (noPe-1) 1 + +-- | Parallel map variant with map interface using (max (noPe-1) 1) worker processes. Skeletons ending on @S@ use round-robin distribution, skeletons ending on @B@ use block distribution of tasks. +mapFarmS, mapFarmB, mapOfflineFarmS, mapOfflineFarmB :: (Trans a , Trans b) => + (a -> b) -- ^worker function + -> [a] -- ^task list + -> [b] -- ^result list +mapFarmS = farmS numProc +mapFarmB = farmB numProc +mapOfflineFarmS = offlineFarmS numProc +mapOfflineFarmB = offlineFarmB numProc + +-----------------------------DEPRECATED--------------------------------- + + +-- | Deprecated, use the 'farm'; +-- @farmClassic@ distributes its input to a number of worker processes. +-- This is the Classic version as described in the Eden standard reference +-- "Parallel Functional Programming in Eden". +-- The distribution function is expected to divide the input list into +-- the given number of sublists. In the new farm the number of sublists is +-- determined only by the distribution function. +-- +-- Use 'map_farm' if you want a simpler interface. +{-# DEPRECATED farmClassic "better use farm instead" #-} +farmClassic :: (Trans a, Trans b) => + Int -- ^number of child processes + -> (Int -> [a] -> [[a]]) -- ^input distribution function + -> ([[b]] -> [b]) -- ^result combination function + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output + +farmClassic np distribute = farm $ distribute np + + +-- | Deprecated, use 'offlineFarm'; +-- Self service farm. Like the farm, but +-- tasks are evaluated in the workers (less communication overhead). +-- This is the classic version. The distribution function is expected +-- to divide the input list into the given number of sublists. In the +-- new self service farm the number of sublists is determined only by +-- the distribution function. +-- +-- Use 'map_ssf' if you want a simpler interface. +-- +-- Notice: The task lists structure has to be completely defined +-- before process instantiation takes place. +{-# DEPRECATED ssf "better use offlineFarm instead" #-} +ssf :: forall a b . Trans b => + Int -- ^number of child processes + -> (Int -> [a] -> [[a]]) -- ^input distribution function + -> ([[b]] -> [b]) -- ^result combination function + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output + +ssf np distribute = offlineFarm np (distribute np) + +-- | Deprecated: Same as 'offlineFarm'. +{-# DEPRECATED offline_farm "better use offlineFarm instead" #-} +offline_farm :: Trans b => + Int -- ^number of processes + -> ([a] -> [[a]]) -- ^input distribution function + -> ([[b]] -> [b]) -- ^result combination function + -> (a -> b) -- ^mapped function + -> [a] -- ^input + -> [b] -- ^output +offline_farm = offlineFarm + +-- | Deprecated: Same as 'parMap'. +{-# DEPRECATED map_par "better use parMap instead" #-} +map_par :: (Trans a , Trans b) => + (a -> b) -- ^worker function + -> [a] -- ^task list + -> [b] -- ^result list +map_par = parMap + +-- | Deprecated: Parallel map variants with map interface using noPe worker processes. +{-# DEPRECATED map_farm, map_offlineFarm, map_ssf "better use mapFarmS or mapOfflineFarmS instead" #-} +map_farm, map_offlineFarm, map_ssf :: (Trans a , Trans b) => + (a -> b) -- ^worker function + -> [a] -- ^task list + -> [b] -- ^result list +map_farm = farmS noPe +map_offlineFarm = offlineFarmS noPe +map_ssf = map_offlineFarm diff --git a/Control/Parallel/Eden/MapReduce.hs b/Control/Parallel/Eden/MapReduce.hs new file mode 100644 --- /dev/null +++ b/Control/Parallel/Eden/MapReduce.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.Eden.MapReduce +-- Copyright : (c) Philipps Universitaet Marburg 2011-2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : eden@mathematik.uni-marburg.de +-- Stability : beta +-- Portability : not portable +-- +-- This Haskell module defines map-reduce skeletons for +-- the parallel functional language Eden. +-- +-- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. +-- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden +-- for a parallel build. +-- +-- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) +-- Depends on the Eden Compiler. + + +module Control.Parallel.Eden.MapReduce ( + -- * Sequential map-reduce definitions + mapRedr, mapRedl, mapRedl', + -- * Simple map-reduce skeletons + parMapRedr, parMapRedl, parMapRedl', + -- * offline map-reduce skeletons + offlineParMapRedr, offlineParMapRedl, offlineParMapRedl', + -- Google map-reduce + ) where +#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) +import Control.Parallel.Eden +#else +import Control.Parallel.Eden.EdenConcHs +#endif +import Control.Parallel.Eden.Auxiliary +import Control.Parallel.Eden.Map +import Data.List + +mapRedr :: (b -> c -> c) -- ^ reduce function + -> c -- ^ neutral for reduce function + -> (a -> b) -- ^ map function + -> [a] -- ^ input + -> c -- ^ result +mapRedr g e f = (foldr g e) . (map f) + +mapRedl :: (c -> b -> c) -- ^ reduce function + -> c -- ^ neutral for reduce function + -> (a -> b) -- ^ map function + -> [a] -- ^ input + -> c -- ^ result +mapRedl g e f = (foldl g e) . (map f) + +mapRedl' :: (c -> b -> c) -- ^ reduce function + -> c -- ^ neutral for reduce function + -> (a -> b) -- ^ map function + -> [a] -- ^ input + -> c -- ^ result +mapRedl' g e f = (foldl' g e) . (map f) + + + +-- | Basic parMapRedr skeleton - as many processes as noPe. +-- local pre-folding per PE and final folding of PE-results +-- via different fold variants +parMapRedr :: (Trans a, Trans b) => + (b -> b -> b) -> b -> (a -> b) -> [a] -> b +parMapRedr g e f + = if noPe == 1 then mapRedr g e f else + (foldr g e) . (parMap (mapRedr g e f)) . (splitIntoN noPe) + +-- | Basic parMapRedl skeleton - as many processes as noPe. +-- local pre-folding per PE and final folding of PE-results +-- via different fold variants +parMapRedl :: (Trans a, Trans b) => + (b -> b -> b) -> b -> (a -> b) -> [a] -> b +parMapRedl g e f + = if noPe == 1 then mapRedl g e f else + (foldl g e) . (parMap (mapRedl g e f)) . (splitIntoN noPe) + +-- | Basic parMapRedl' skeleton - as many processes as noPe. +-- local pre-folding per PE and final folding of PE-results +-- via different fold variants +parMapRedl' :: (Trans a, Trans b) => + (b -> b -> b) -> b -> (a -> b) -> [a] -> b +parMapRedl' g e f + = if noPe == 1 then mapRedl' g e f else + (foldl' g e) . (parMap (mapRedl' g e f)) . (splitIntoN noPe) + + + +-- | Offline parMapRedr skeleton - as many processes as noPe. +-- local pre-folding per PE and final folding of PE-results +-- via different fold variants, +-- BUT local selection of input sub-list by worker processes +offlineParMapRedr :: (Trans a, Trans b) => + (b -> b -> b) -> b -> (a -> b) -> [a] -> b +offlineParMapRedr g e f xs + = if noPe == 1 then mapRedr g e f xs else + foldr g e (parMap worker [0..noPe-1]) + where worker i = mapRedr g e f ((splitIntoN noPe xs)!!i) + +-- | Offline parMapRedl skeleton - as many processes as noPe. +-- local pre-folding per PE and final folding of PE-results +-- via different fold variants, +-- BUT local selection of input sub-list by worker processes +offlineParMapRedl :: (Trans a, Trans b) => + (b -> b -> b) -> b -> (a -> b) -> [a] -> b +offlineParMapRedl g e f xs + = if noPe == 1 then mapRedl g e f xs else + foldr g e (parMap worker [0..noPe-1]) + where worker i = mapRedl g e f ((splitIntoN noPe xs)!!i) + +-- | Offline parMapRedl' skeleton - as many processes as noPe. +-- local pre-folding per PE and final folding of PE-results +-- via different fold variants, +-- BUT local selection of input sub-list by worker processes +offlineParMapRedl' :: (Trans a, Trans b) => + (b -> b -> b) -> b -> (a -> b) -> [a] -> b +offlineParMapRedl' g e f xs + = if noPe == 1 then mapRedl' g e f xs else + foldr g e (parMap worker [0..noPe-1]) + where worker i = mapRedl' g e f ((splitIntoN noPe xs)!!i) + + + diff --git a/Control/Parallel/Eden/Topology.hs b/Control/Parallel/Eden/Topology.hs new file mode 100644 --- /dev/null +++ b/Control/Parallel/Eden/Topology.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.Eden.Topology +-- Copyright : (c) Philipps Universitaet Marburg 2009-2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : eden@mathematik.uni-marburg.de +-- Stability : beta +-- Portability : not portable +-- +-- This Haskell module defines topology skeletons for the parallel functional +-- language Eden. Topology skeletons are skeletons that implement a network of +-- processes interconnected by a characteristic communication topology. +-- +-- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. +-- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden +-- for a parallel build. +-- +-- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) + + +module Control.Parallel.Eden.Topology ( + -- * Skeletons that are primarily characterized by their topology. + + -- ** Pipeline skeletons + -- | + pipe, pipeRD + -- ** Ring skeletons + -- | + ,ringSimple, ring, ringFl, ringAt, ringFlAt + -- ** Torus skeleton + -- | + ,torus + -- ** The Hypercube skeleton + -- | + + -- ** The All-To-All skeleton + -- |The allToAll skeleton allows distributed data exchange and + -- transformation including data of all processes. Input and output + -- are provided as remote data. A typical application is the + -- distributed transposition of a distributed Martrix. + ,allToAllRDAt, allToAllRD, parTransposeRDAt, parTransposeRD, allGatherRDAt, allGatherRD + -- ** The All-Reduce skeleton + -- |The skeleton uses a butterfly topology to reduce the data of + -- participating processes P in log(|P|) communication stages. Input + -- and output are provided as remote data. + ,allReduceRDAt, allReduceRD, allGatherBuFlyRDAt, allGatherBuFlyRD + + ) where +#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) +import Control.Parallel.Eden +#else +import Control.Parallel.Eden.EdenConcHs +#endif +import Control.Parallel.Eden.Auxiliary +import Control.Parallel.Eden.Map +import Data.List + + + +-- |Simple pipe where the parent process creates all pipe processes. The processes communicate their results via the caller process. +pipe :: forall a . Trans a => + [a -> a] -- ^functions of the pipe + -> a -- ^input + -> a -- ^output +pipe fs = unLiftRD (pipeRD fs) + +-- |Process pipe where the processes communicate their Remote Data handles via the caller process but fetch the actual data from their predecessor processes +pipeRD :: forall a . Trans a => + [a -> a] -- ^functions of the pipe + -> RD a -- ^remote input + -> RD a -- ^remote output +pipeRD fs xs = (last outs) where + outs = spawn ps $ lazy $ xs : outs + ps :: [Process (RD a) (RD a)] + ps = map (process . liftRD) fs + + +-- | Simple ring skeleton (tutorial version) +-- using remote data for providing direct inter-ring communication +-- without input distribution and output combination +ringSimple :: (Trans i, Trans o, Trans r) => + (i -> r -> (o,r)) -- ^ ring process function + -> [i] -> [o] -- ^ input output mapping +ringSimple f is = os + where + (os,ringOuts) = unzip (parMap (toRD $ uncurry f) + (zip is $ lazy ringIns)) + ringIns = rightRotate ringOuts + +toRD :: (Trans i, Trans o, Trans r) => + ((i,r) -> (o,r)) -- ^ ring process function + -> ((i, RD r) -> (o, RD r)) -- ^ -- with remote data +toRD f (i, ringIn) = (o, release ringOut) + where (o, ringOut) = f (i, fetch ringIn) + +rightRotate :: [a] -> [a] +rightRotate [] = [] +rightRotate xs = last xs : init xs + +-- | The ringFlAt establishes a ring topology, the ring process functions +-- transform the initial input of a ring process and the input stream from the ring into the +-- ring output stream and the ring processes' final result. Every ring process +-- applies its individual function which e.g. allows to route individual offline input into the +-- ring processes. This version uses explicit placement. +ringFlAt :: (Trans a,Trans b,Trans r) => + Places -- ^where to put workers + -> (i -> [a]) -- ^distribute input + -> ([b] -> o) -- ^combine output + -> [(a -> [r] -> (b,[r]))] -- ^ring process fcts + -> i -- ^ring input + -> o -- ^ring output +ringFlAt places distrib combine fs i = combine os where + (os, ringOuts) = unzip $ spawnFAt places (map (toRD . uncurry) fs) + (zip (distrib i) $ lazy ringIns) + ringIns = rightRotate ringOuts + +-- | The ringFl establishes a ring topology, the ring process functions +-- transform the initial input of a ring process and the input stream from the ring into the +-- ring output stream and the ring processes' final result. Every ring process +-- applies an individual function which e.g. allows to route individual offline input into the +-- ring processes. Use ringFlAt if explicit placement is desired. +ringFl :: (Trans a,Trans b,Trans r) => + (i -> [a]) -- ^distribute input + -> ([b] -> o) -- ^combine output + -> [(a -> [r] -> (b,[r]))] -- ^ring process fcts + -> i -- ^ring input + -> o -- ^ring output +ringFl = ringFlAt [0] + +-- | Skeleton @ringAt@ establishes a ring topology, the ring process function +-- transforms the initial input of a ring process and the input stream from the ring into the +-- ring output stream and the ring processes' final result. The +-- same function is used by every ring process. Use ringFlAt +-- if you need different functions in the processes. This version uses explicit placement. +ringAt :: (Trans a,Trans b,Trans r) => + Places -- ^where to put workers + -> (i -> [a]) -- ^distribute input + -> ([b] -> o) -- ^combine output + -> (a -> [r] -> (b,[r])) -- ^ring process fct + -> i -- ^ring input + -> o -- ^ring output +ringAt places distrib combine f i = + ringFlAt places distrib combine [f] i + +-- | The ring establishes a ring topology, the ring process function +-- transforms the initial input of a ring process and the input stream from the ring into the +-- ring output stream and the ring processes final result. The +-- same function is used by every ring process. Use ringFl +-- if you need different functions in the processes. Use ringAt if +-- explicit placement is desired. +ring :: (Trans a,Trans b,Trans r) => + (i -> [a]) -- ^distribute input + -> ([b] -> o) -- ^combine output + -> (a -> [r] -> (b,[r])) -- ^ring process fct + -> i -- ^ring input + -> o -- ^ring output +ring = ringAt [0] + + + +-- | Parallel torus skeleton (tutorial version) with stream rotation in 2 directions: initial inputs for each torus element are given. The node function is used on each torus element to transform the initial input and a stream of inputs from each direction to a stream of outputs to each direction. Each torus input should have the same size in both dimensions, otherwise the smaller input will determine the size of the torus. +torus :: (Trans a, Trans b, Trans c, Trans d) => + (c -> [a] -> [b] -> (d,[a],[b])) -- ^ node function + -> [[c]] -> [[d]] -- ^ input-output mapping +torus f inss = outss + where + t_outss = spawnPss (repeat (repeat (ptorus f))) t_inss -- optimised + (outss,outssA,outssB) = unzip3 (map unzip3 t_outss) + inssA = map rightRotate outssA + inssB = rightRotate outssB + t_inss = zipWith3 lazyzip3 inss (lazy inssA) (lazy inssB) + lazyzip3 as bs cs = zip3 as (lazy bs) (lazy cs) + +-- each individual process of the torus (tutorial version) +ptorus :: (Trans a, Trans b, Trans c, Trans d) => + (c -> [a] -> [b] -> (d,[a],[b])) -> + Process (c,RD [a],RD [b]) + (d,RD [a],RD [b]) +ptorus f + = process (\ (fromParent, inA, inB) -> + let (toParent, outA, outB) = f fromParent inA' inB' + (inA',inB') = fetch2 inA inB + in (toParent, release outA, release outB)) + +-- | The skeleton creates as many processes as elements in the input list (@np@). +-- The processes get all-to-all connected, each process input is transformed to +-- @np@ intermediate values by the first parameter function, where the @i@-th value +-- will be send to process @i@. The second transformation function combines the initial +-- input and the @np@ received intermediate values to the final output. +allToAllRD :: forall a b i. (Trans a, Trans b, Trans i) + => (Int -> a -> [i]) -- ^transform before bcast (num procs, input, sync-data out) + -> (a -> [i] ->b) -- ^transform after bcast (input, sync-data in, output) + -> [RD a] -- ^remote input for each process + -> [RD b] -- ^remote output for each process +allToAllRD = allToAllRDAt [0] + +-- | The skeleton creates as many processes as elements in the input list (@np@). +-- The processes get all-to-all connected, each process input is transformed to +-- @np@ intermediate values by the first parameter function, where the @i@-th value +-- will be send to process @i@. The second transformation function combines the initial +-- input and the @np@ received intermediate values to the final output. +allToAllRDAt :: forall a b i. (Trans a, Trans b, Trans i) + => Places -- ^where to instantiate + -> (Int -> a -> [i]) -- ^transform before bcast (num procs, input, sync-data out) + -> (a -> [i] ->b) -- ^transform after bcast (input, sync-data in, output) + -> [RD a] -- ^remote input for each process + -> [RD b] -- ^remote output for each process +allToAllRDAt places t1 t2 xs = res where + n = length xs --same amount of procs as #xs + (res,iss) = n `pseq` unzip $ parMapAt places (uncurry p) inp + inp = zip xs $ lazy $ transpose iss + + p :: RD a-> [RD i]-> (RD b,[RD i]) + p xRD theirIs = (resF theirIs, myIsF x) where + x = fetch xRD + myIsF = releaseAll . t1 n + resF = release . t2 x . fetchAll + +-- works similar for splitIntoN and unsplit (concat)??? +-- |Parallel transposition for matrizes which are row-wise round robin distributed among the machines, the transposed result matrix is also row-wise round robin distributed. +parTransposeRD :: Trans b + => [RD [[b]]] -- ^input list of remote partial matrizes + -> [RD [[b]]] -- ^output list of remote partial matrizes +parTransposeRD = parTransposeRDAt [0] + + +-- works similar for splitIntoN and unsplit (concat)??? +-- |Parallel transposition for matrizes which are row-wise round robin distributed among the machines, the transposed result matrix is also row-wise round robin distributed. +parTransposeRDAt :: Trans b + => Places + -> [RD [[b]]] -- ^input list of remote partial matrizes + -> [RD [[b]]] -- ^output list of remote partial matrizes +parTransposeRDAt places = allToAllRDAt places (\ n -> unshuffle n . transpose) + (\ _ -> map shuffle . transpose) + +-- | Performs an all-gather using all to all comunication (based on allToAllRDAt). +-- The initial transformation is applied in the processes to obtain the values that will be reduced. +-- The final combine function is used to create a processes outputs from the initial input and the +-- gathered values. +allGatherRD :: forall a b c. (Trans a, Trans b, Trans c) + => (a -> b) -- ^initial transform function + -> (a -> [b] -> c) -- ^final combine function + -> [RD a] -> [RD c] +allGatherRD = allGatherRDAt [0] + +-- | Performs an all-gather using all to all comunication (based on allToAllRDAt). +-- The initial transformation is applied in the processes to obtain the values that will be reduced. +-- The final combine function is used to create a processes outputs from the initial input and the +-- gathered values. +allGatherRDAt :: forall a b c. (Trans a, Trans b, Trans c) + => Places -- ^where to instantiate + -> (a -> b) -- ^initial transform function + -> (a -> [b] -> c) -- ^final combine function + -> [RD a] -> [RD c] +allGatherRDAt places t1 t2 = allToAllRDAt places t1' t2 where + t1' :: Int -> a -> [b] + t1' n x = replicate n (t1 x) + + +-- | Performs an all-reduce with the reduce function using a butterfly scheme. +-- The initial transformation is applied in the processes to obtain the values +-- that will be reduced. The final combine function is used to create a processes outputs. +-- result from the initial input and the reduced value. +allReduceRD :: forall a b c. (Trans a, Trans b, Trans c) + => (a -> b) -- ^initial transform function + -> (b -> b -> b) -- ^reduce function + -> (a -> b -> c) -- ^final combine function + -> [RD a] -> [RD c] +allReduceRD = allReduceRDAt [0] where + + +-- | Performs an all-reduce with the reduce function using a butterfly scheme. +-- The initial transformation is applied in the processes to obtain the values +-- that will be reduced. The final combine function is used to create a processes output. +-- result from the initial input and the reduced value. +allReduceRDAt :: forall a b c. (Trans a, Trans b, Trans c) + => Places -- ^where to instantiate + -> (a -> b) -- ^initial transform function + -> (b -> b -> b) -- ^reduce function + -> (a -> b -> c) -- ^final combine function + -> [RD a] -> [RD c] +allReduceRDAt places initF redF resF rdAs = rdCs where + steps = (ceiling . logBase 2 . fromIntegral . length) rdAs + (rdBss,rdCs) = steps `pseq` unzip $ parMapAt places (uncurry p) inp + inp = zip rdAs $ lazy $ buflyF $ transposeRt rdBss + buflyF = transposeRt . shiftFlipF steps . fillF steps + + p :: RD a -> [Maybe (Both (RD b))] -> ([RD b], RD c) + p rdA rdBs = (rdBs'', res) where + res = release $ resF a $ reduced !! steps + rdBs'' = (releaseAll . take steps . lazy) reduced + reduced = scanl redF' b toReduce + toReduce = fetchAll' rdBs' + rdBs' = zipWith (flip maybe Left) (map Right rdBs'') rdBs + b = initF a + a = fetch rdA + + --List encoding: + -- Right: No Partner present, use value b without reduction + -- Left: RD value comes from partner, then inner encoding: + -- Right: Partner is positioned at the right hand side + -- Left: Partner is positioned at the left hand side + -- needed such that redF does not need to be commutativie + redF' :: b -> Either (Both b) b -> b + redF' _ (Right b) = b + redF' b (Left (Right b')) = redF b b' + redF' b (Left (Left b')) = redF b' b + +type Both a = Either a a + +--custom fetchAll inside nested Eithers +fetchAll' :: Trans a => [Either (Both (RD a)) (RD a)] -> [Either (Both a) a] +fetchAll' = runPA . mapM fetchPA' where + fetchPA' (Left (Left rda)) = do a <- fetchPA rda + return $ Left $ Left a + fetchPA' (Left (Right rda)) = do a <- fetchPA rda + return $ Left $ Right a + fetchPA' (Right rda) = do a <- fetchPA rda + return $ Right a + +--Fill rows to the power of ldn with Nothing, map Just to the rest +fillF :: Int -> [[a]] -> [[Maybe a]] +fillF ldn ass = map fillRow ass where + n = 2 ^ ldn + fillRow as = take n $ (map Just as) ++ (repeat Nothing) + +shiftFlipF :: Int -> [[Maybe a]] -> [[Maybe (Both a)]] +shiftFlipF ldn rdBss = zipWith shiftFlipRow [1..ldn] rdBss where + shiftFlipRow ldi rdBs = (shuffle . flipAtHalfF . unshuffle i) rdBs where + i = 2 ^ ldi + flipAtHalfF xs = let (xs1, xs2) = splitAt (i`div`2) xs + in map (map (fmap Right)) xs2 ++ map (map (fmap Left)) xs1 + + +-- | Performs an all-gather using a butterfly scheme (based on allReduceRDAt). +-- The initial transformation is applied in the processes to obtain the values that will be reduced. +-- The final combine function is used to create a processes outputs from the initial input and the +-- gathered values. +allGatherBuFlyRD :: forall a b c. (Trans a, Trans b, Trans c) + => (a -> b) -- ^initial transform function + -> (a -> [b] -> c) -- ^final combine function + -> [RD a] -> [RD c] +allGatherBuFlyRD = allGatherBuFlyRDAt [0] + +-- | Performs an all-gather using a butterfly scheme (based on allReduceRDAt). +-- The initial transformation is applied in the processes to obtain the values that will be reduced. +-- The final combine function is used to create a processes outputs from the initial input and the +-- gathered values. +allGatherBuFlyRDAt :: forall a b c. (Trans a, Trans b, Trans c) + => Places -- ^where to instantiate + -> (a -> b) -- ^initial transform function + -> (a -> [b] -> c) -- ^final combine function + -> [RD a] -> [RD c] +allGatherBuFlyRDAt places t1 t2 = allReduceRDAt places t1' (++) t2 where + t1' :: a -> [b] + t1' a = [t1 a] diff --git a/Control/Parallel/Eden/Workpool.hs b/Control/Parallel/Eden/Workpool.hs new file mode 100644 --- /dev/null +++ b/Control/Parallel/Eden/Workpool.hs @@ -0,0 +1,727 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.Eden.Workpool +-- Copyright : (c) Philipps Universitaet Marburg 2009-2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : eden@mathematik.uni-marburg.de +-- Stability : beta +-- Portability : not portable +-- +-- This Haskell module defines workpool skeletons for dynamic task +-- distribution for the parallel functional language Eden. +-- +-- Depends on GHC. Using standard GHC, you will get a threaded simulation of Eden. +-- Use the forked GHC-Eden compiler from http:\/\/www.mathematik.uni-marburg.de/~eden +-- for a parallel build. +-- +-- Eden Group ( http:\/\/www.mathematik.uni-marburg.de/~eden ) + + +module Control.Parallel.Eden.Workpool ( + -- * Workpool skeletons with a single master + -- ** Simple workpool skeletons + -- | The workpool skeletons use the non-deterministic merge function to achieve dynamic load balancing. + workpool, workpoolSorted, workpoolSortedNonBlock, workpoolReduce, + -- ** Simple workpool skeletons - versions using explicit placement + -- | The workpool skeletons use the non-deterministic merge function to achieve dynamic load balancing. + workpoolAt, workpoolSortedAt, workpoolSortedNonBlockAt, workpoolReduceAt, + workpoolAuxAt, + -- * Hierarchical workpool skeleton + -- |These skeletons can be nested with an arbitrary number of submaster + -- levels to unload the top master. + wpNested, + -- ** Hierarchical workpool skeleton with dynamic task creation + -- |The worker function is extended such that dynamic creation of + -- new tasks is possible. New tasks are added to the end of the + -- task list, thus tasks are traversed breath first (not strictly + -- because of the skeletons' nondeterminism). Furthermore, these + -- skeletons can be nested with an arbitrary number of submaster + -- levels to unload the top master. + wpDynNested, wpDNI, +-- * Distributed workpool skeletons with state and dynamic task creation + distribWPAt, +-- * Deprecated skeletons + masterWorker, mwNested, mwDynNested, mwDNI, + ) where +#if defined( __PARALLEL_HASKELL__ ) || defined (NOT_PARALLEL) +import Control.Parallel.Eden +#else +import Control.Parallel.Eden.EdenConcHs +#endif +import Control.Parallel.Eden.Auxiliary +import Control.Parallel.Eden.Map +import Control.Parallel.Eden.Topology +import Data.List +import Data.Maybe(maybeToList,mapMaybe) + +import System.IO.Unsafe +import Control.Monad + +import Control.Concurrent + + +-- | Simple workpool (result list in non-deterministic order) +-- This version takes places for instantiation. +-- +-- Notice: Result list in non-deterministic order. +workpoolAt :: forall t r . (Trans t, Trans r) => + Places + -> Int -- ^number of child processes (workers) + -> Int -- ^prefetch of tasks (for workers) + -> (t -> r) -- ^worker function (mapped to tasks) + -> [t] -> [r] -- ^what to do +workpoolAt pos np prefetch wf tasks + = map snd fromWorkers + where + fromWorkers :: [(Int,r)] + fromWorkers = merge (tagWithPids (parMapAt pos worker taskss)) + taskss :: [[t]] + taskss = distribute np (initialReqs ++ newReqs) tasks + initialReqs, newReqs :: [Int] + initialReqs = concat (replicate prefetch [0..np-1]) + newReqs = map fst fromWorkers + worker = map wf + + +-- | Tag each element of the inner list with the id of its inner list. +tagWithPids :: [[r]] -- ^untagged input + -> [[(Int,r)]] -- ^tagged output +tagWithPids rss = [ zip (repeat i) rs |(i,rs) <-zip [0..] rss] + + +-- | Simple workpool (result list in non-deterministic order) +-- +-- Notice: Result list in non-deterministic order. +workpool :: (Trans t, Trans r) => + Int -- ^number of child processes (workers) + -> Int -- ^prefetch of tasks (for workers) + -> (t -> r) -- ^worker function (mapped to tasks) + -> [t] -> [r] -- ^what to do +workpool = workpoolAt [0] + + + +-- | Workpool version with one result stream for each worker and meta +-- information about the task distribution. +-- This meta-skeleton can be used to define workpool-skeletons which +-- can reestablish the result list order. +-- +-- Notice: Result list in non-deterministic order. +workpoolAuxAt :: (Trans t, Trans r) => + Places + -> Int -- ^number of child processes + -- (workers) + -> Int -- ^prefetch of tasks (for + -- workers) + -> (t -> r) -- ^worker function (tasks to + -- results mapping) + -> [t] -- ^tasks + -> ([Int],[[Int]],[[r]]) -- ^(input distribution (input i + -- is in sub-list distribs!i), + -- task positions (element i of + -- result-sub-list j was in the + -- input list at (poss!j)!i ), + -- result streams of workers) +workpoolAuxAt pos np prefetch wf tasks + = (reqs,poss,fromWorkers) + where fromWorkers = parMapAt pos (map wf) taskss + (taskss,poss) = distributeWithPos np reqs tasks + -- generate only as many reqs as there are tasks + reqs = map snd $ zip tasks $ initialReqs ++ newReqs + initialReqs = concat (replicate prefetch [0..np-1]) + newReqs = merge $ [ [ i | j<-rs] + | (i,rs) <-zip [0..] fromWorkers] + + +-- | Task distribution according to worker requests. Returns additionally to @ distribute @ a nested list of the positions to indicate where the tasks have been located in the original list +-- +distributeWithPos :: Int -- ^number of workers + -> [Int] -- ^ request stream (worker IDs ranging from 0 to n-1) + -> [t] -- ^ task list + -> ([[t]],[[Int]]) -- ^(task positions in original list, task distribution), each inner list for one worker. +distributeWithPos np reqs tasks + = unzip [unzip (taskList reqs tasks [0..] n) | n<-[0..np-1]] + where taskList (r:rs) (t:ts) (tag:tags) pe + | pe == r = (t,tag):(taskList rs ts tags pe) + | otherwise = taskList rs ts tags pe + taskList _ _ _ _ = [] + + +-- | Sorted workpool (results in the order of the tasks). +-- This version takes places for instantiation. +workpoolSortedAt :: (Trans t, Trans r) => + Places + -> Int -- ^number of child processes + -- (workers) + -> Int -- ^prefetch of tasks (for workers) + -> (t -> r) -- ^worker function + -> [t] -- ^tasks + -> [r] -- ^results +workpoolSortedAt pos np prefetch f tasks = res + where (_, poss, ress) = workpoolAuxAt pos np prefetch f tasks + res = map snd $ mergeByPos ress' + ress' = map (uncurry zip) (zip poss ress) + + +-- | Join sorted lists into one sorted list. +-- This function uses a balanced binary combination scheme to merge sublists. +mergeByPos :: [[(Int,r)]] -- ^ tagged input + -> [(Int,r)] -- ^ output sorted by tags +mergeByPos [] = [] +mergeByPos [wOut] = wOut +mergeByPos [w1,w2] = merge2ByTag w1 w2 +mergeByPos wOuts = merge2ByTag + (mergeHalf wOuts) + (mergeHalf (tail wOuts)) + where mergeHalf = mergeByPos . (takeEach 2) + +merge2ByTag [] w2 = w2 +merge2ByTag w1 [] = w1 +merge2ByTag w1@(r1@(i,_):w1s) w2@(r2@(j,_):w2s) + | i < j = r1: merge2ByTag w1s w2 + | i > j = r2: merge2ByTag w1 w2s + | otherwise = error "found tags i == j" + + + +-- | Sorted workpool: Efficient implementation using a the +-- distribution lookup list. +-- +-- Notice: Results in the order of the tasks. +workpoolSorted :: (Trans t, Trans r) => + Int -- ^number of child processes (workers) + -> Int -- ^prefetch of tasks (for workers) + -> (t -> r) -- ^worker function (mapped to tasks) + -> [t] -- ^tasks + -> [r] -- ^results +workpoolSorted = workpoolSortedAt [0] + +-- | Non-blocking sorted workpool. Result list is structurally defined +-- up to the position where tasks are distributed, independent of the +-- received worker results. This version needs still performance +-- testing. +-- +-- Notice: Results in the order of the tasks. +workpoolSortedNonBlockAt :: (Trans t, Trans r) => + Places + -> Int -- ^number of child processes (workers) + -> Int -- ^prefetch of tasks (for workers) + -> (t -> r) -- ^worker function (mapped to tasks) + -> [t] -> [r] -- ^what to do +workpoolSortedNonBlockAt pos np prefetch f tasks + = orderBy fromWorkers reqs + where (reqs, _ ,fromWorkers) = workpoolAuxAt pos np prefetch f tasks + + +-- | Orders a nested list (sublist are ordered) by a given distribution (non-blocking on result elements of other sub lists) +orderBy :: forall idx r . Integral idx => + [[r]] -- ^ nested input list (@inputss@) + -> [idx] -- ^ distribution (result i is in sublist @inputss!(idxs!i)@) + -> [r] -- ^ ordered result list +orderBy _ [] = [] +orderBy [rs] is = rs +orderBy (xs:rss) is = fst $ foldl (f is) (xs,1) rss + where f :: [idx] -> ([r],idx) -> [r] -> ([r], idx) + f is (xs,a) ys = (m xs ys is, a+1) + where m :: [r] -> [r] -> [idx] -> [r] + m _ _ [] = [] + m xs ys (i:is) | i < a = head xs : m (tail xs) ys is + | i==a = head ys : m xs (tail ys) is + | otherwise = m xs ys is + + +-- | orders a nested list by a given distribution (alternative code) +orderBy' :: Integral idx => + [[r]] -- ^ nested input list (@inputss@) + -> [idx] -- ^ distribution (result i is in sublist @inputss!(idxs!i)@) + -> [r] -- ^ ordered result list +orderBy' rss [] = [] +orderBy' rss (r:reqs) + = let (rss1,(rs2:rss2)) = splitAt (fromIntegral r) rss + in (head rs2): orderBy' (rss1 ++ ((tail rs2):rss2)) reqs + + +-- | Non-blocking sorted workpool (results in the order of the +-- tasks). Result list is structurally defined up to the position +-- where tasks are distributed, independent of the received worker +-- results. This version needs still performance testing. This +-- version takes places for instantiation. +-- +-- Notice: Results in the order of the tasks. +workpoolSortedNonBlock :: (Trans t, Trans r) => + Int -- ^number of child processes (workers) + -> Int -- ^prefetch of tasks (for workers) + -> (t -> r) -- ^worker function (mapped to tasks) + -> [t] -> [r] -- ^what to do +workpoolSortedNonBlock = workpoolSortedNonBlockAt [0] + + + + + +-- | Simple workpool with additional reduce function for worker outputs. +-- This version takes places for instantiation. +-- +-- Notice: Result list in non-deterministic order. +workpoolReduceAt :: forall t r r' . (Trans t, Trans r, Trans r') => + Places + -> Int -- ^number of child processes (workers) + -> Int -- ^prefetch of tasks (for workers) + -> (r' -> r -> r) -- ^reduce function + -> r -- ^neutral for reduce function + -> (t -> r') -- ^worker function (mapped to tasks) + -> [t] -- ^tasks + -> [r] -- ^results (one from each worker) +workpoolReduceAt pos np prefetch rf e wf tasks + = map snd fromWorkers + where + fromWorkers :: [([Int],r)] + fromWorkers = spawnFAt pos (map worker [0..np-1]) taskss + taskss = distribute np (initialReqs ++ newReqs) tasks + initialReqs = concat (replicate prefetch [0..np-1]) + newReqs = merge (map fst fromWorkers) + worker i ts = (map (\r -> rnf r `seq` i) rs, foldr rf e rs) + where rs = map wf ts + + +-- | Simple workpool with additional reduce function for worker outputs. +-- This version takes places for instantiation. +-- +-- Notice: Result list in non-deterministic order. +workpoolReduce :: forall t r r' . (Trans t, Trans r, Trans r') => + Int -- ^number of child processes (workers) + -> Int -- ^prefetch of tasks (for workers) + -> (r' -> r -> r) -- ^reduce function + -> r -- ^neutral for reduce function + -> (t -> r') -- ^worker function (mapped to tasks) + -> [t] -- ^tasks + -> [r] -- ^results (one from each worker) +workpoolReduce = workpoolReduceAt [0] + +-- |Hierachical WP-Skeleton. The worker +-- function is mapped to the worker input stream (list type). A worker +-- produces a result. The workers are located on the leaves of a +-- WP-hierarchy, in the intermediate levels are submasters which unload +-- the master by streaming 'result' streams of their child +-- processes into a single result stream. +-- +-- Notice: Result list in non-deterministic order. +wpNested :: forall t r . (Trans t, Trans r) => + [Int] -- ^branching degrees: the i-th + -- element defines the branching + -- degree of for the i-th level of + -- the WP-hierarchy. Use a singleton + -- list for a flat MW-Skeleton. + -> [Int] -- ^Prefetches for the + -- sub-master/worker levels + -> (t -> r) -- ^worker function + -> [t] -- ^initial tasks + -> [r] -- ^results +wpNested ns pfs wf initTasks = wpDynNested ns pfs (\t -> (wf t,[])) initTasks + + +-- |Simple interface for 'wpDynNested'. Parameters are the number of child processes, the first +-- level branching degree, the nesting depth (use 1 for a +-- single master), and the task prefetch amount for the worker level. +-- All processes that are not needed for the submasters are +-- used for the workers. If the number of submasters in the last level +-- and the number of remaining child processes are prime to each +-- other, then the next larger divisor is chosen for the number of +-- workers. +-- +-- Notice: Result list in non-deterministic order. +wpDNI :: (Trans t, Trans r) => + Int -- ^number of processes (submasters and workers) + -> Int -- ^nesting depth + -> Int -- ^branching degree of the first submaster + -- level (further submaster levels are + -- branched binary) + -> Int -- ^task prefetch for the workers + -> (t -> (r,[t])) -- ^worker function - produces a tuple of + -- result and tasks for the processed task + -> [t] -- ^initial tasks + -> [r] -- ^results +wpDNI np levels l_1 pf f tasks + = let nesting = mkNesting np levels l_1 + in wpDynNested nesting (mkPFs pf nesting) f tasks + + +-- |Hierachical WP-Skeleton with dynamic task creation. The worker +-- function is mapped to the worker input stream (list type). A worker +-- produces a tuple of result and dynamicly created tasks for each +-- processed task. The workers are located on the leaves of a +-- WP-hierarchy, in the intermediate levels are submasters which unload +-- the master by streamlining 'result/newtask' streams of their child +-- processes into a single result/newtask stream. Furthermore, the +-- submasters retain locally half of the tasks which are +-- dynamically created by the workers in their subtree. +-- +-- Notice: Result list in non-deterministic order. +wpDynNested :: forall t r . (Trans t, Trans r) => + [Int] -- ^branching degrees: the i-th + -- element defines the branching + -- degree of for the i-th level of + -- the MW-hierarchy. Use a singleton + -- list for a flat MW-Skeleton. + -> [Int] -- ^Prefetches for the + -- sub-master/worker levels + -> (t -> (r,[t])) -- ^worker function - produces a + -- tuple of result and new tasks for + -- the processed task + -> [t] -- ^initial tasks + -> [r] -- ^results +wpDynNested ns pfs wf initTasks + = topMasterStride strideTM (head ns) (head pfs) subWF initTasks + where subWF = foldr fld wf' (zip3 stds (tail ns) (tail pfs)) + wf' :: [Maybe t] -> [(r,[t],Int)] + -- explicit Nothing-Request after each result + wf' xs = map(\ (r,ts) -> (r,ts,0)) (map (wf)(inp xs)) + inp ((Just x):rest) = x:inp rest + inp (Nothing:_) = [] -- STOP!!! + -- placement: + (strideTM:stds) = scanr (\x y -> ((y*x)+1)) 1 (tail ns) + fld :: (Int, Int, Int) -> ([Maybe t] -> [(r,[t],Int)]) + -> [Maybe t] -> [(r,[t],Int)] + fld (stride,n,pf) wf = mwDynSubStride stride n pf wf + + + +--------------------------mwDynNested auxiliary--------------------------------- + +topMasterStride :: forall t r . (Trans t, Trans r) => + Int -> Int -> Int -> ([Maybe t] -> [(r,[t],Int)]) -> [t] -> [r] +topMasterStride stride branch prefetch wf initTasks = finalResults + where + -- identical to static task pool except for the type of workers + ress = merge (spawnAt places workers inputs) + places = nextPes branch stride + workers :: [Process [Maybe t] [(Int,(r,[t],Int))]] + workers = [process (zip [i,i..] . wf) | i <- [0..branch-1]] + inputs = distribute branch (initReqs ++ reqs) tasks + initReqs = concat (replicate prefetch [0..branch-1]) + -- additions for task queue management and + -- termination detection + tasks = (map Just initTasks) ++ newTasks + ----------------------------- + initNumTasks = length initTasks + -- => might lead to deadlock! + ----------------------------- + (finalResults, reqs, newTasks) + = tdetectTop ress initNumTasks + + +mwDynSubStride :: forall t r . (Trans t, Trans r) => + Int -> Int -> Int -> ([Maybe t] -> [(r,[t],Int)]) + -> [Maybe t] -> [(r,[t],Int)] +mwDynSubStride stride branch prefetch wf initTasks = finalResults where + fromWorkers = map flatten (spawnAt places workers inputs) + places = nextPes branch stride + workers :: [Process [Maybe t] [(Int,(r,[t],Int))]] + workers = [process (zip [i,i..] . wf) | i <- [0..branch-1]] + inputs = distribute branch (initReqs ++ reqs) tasks + initReqs = concat (replicate prefetch [0..branch-1]) + -- task queue management + controlInput = merge (map Right initTasks: map (map Left) fromWorkers) + (finalResults, tasks, reqs) + = tcontrol controlInput 0 0 (branch * (prefetch+1)) False + + +-- task queue control for termination detection +tdetectTop :: [(Int,(r,[t],Int))] -> Int -> ([r], [Int], [Maybe t]) +tdetectTop ((req,(r,ts,subHoldsTs)):ress) numTs + | numTs == 1 && null ts && subHoldsTs == 0 + = ([r], [], repeat Nothing) -- final result + | subHoldsTs == 1 + = (r:moreRes, moreReqs, (map Just ts) ++ moreTs) + | otherwise + = (r:moreRes, req:moreReqs, (map Just ts) ++ moreTs) + where --localNumTaks is 0 or 1, if it's 1 -> no Request + -- -> numTs will not be decreased + (moreRes, moreReqs, moreTs) + = tdetectTop ress (numTs-1+length ts+subHoldsTs) + + +tcontrol :: [Either (Int,r,[t],Int) (Maybe t)] -> -- controlInput + Int -> Int -> -- task / hold counter + Int -> Bool -> -- prefetch, split mode + ([(r,[t],Int)],[Maybe t],[Int]) -- (results,tasks,requests) +tcontrol ((Right Nothing):_) 0 _ _ _ + = ([],repeat Nothing,[]) -- Final termination +tcontrol ((Right (Just t)):ress) numTs hldTs pf even -- task from above + = let (moreRes, moreTs, reqs) = tcontrol ress (numTs+1) hldTs pf even + in (moreRes, (Just t):moreTs, reqs) +tcontrol ((Left (i,r,ts,subHoldsTs)):ress) numTs hldTs pf even + = let (moreRes, moreTs, reqs) + = tcontrol ress (numTs + differ) (hldTs') pf evenAct + differ = length localTs + subHoldsTs - 1 + hldTs' = max (hldTs + differ) 0 + holdInf | (hldTs+differ+1 > 0) = 1 + | otherwise = 0 + (localTs,fatherTs,evenAct) + = split numTs pf ts even -- part of tasks to parent + newreqs | (subHoldsTs == 0) = i:reqs + | otherwise = reqs -- no tasks kept below? + in ((r,fatherTs,holdInf):moreRes, + (map Just localTs) ++ moreTs, newreqs) + +-- error case, not shown in paper +tcontrol ((Right Nothing):_) n _ _ _ + = error "Received Stop signal, although not finished!" + + +flatten [] = [] +flatten ((i,(r,ts,n)):ps) = (i,r,ts,n) : flatten ps + +split :: Int -> Int -> [t] -> Bool ->([t],[t],Bool) +split num pf ts even-- = splitAt (2*pf - num) ts + | num >= 2*pf = ([],ts,False) + --no tasks or odd -> keep first + | ((not even)||(num == 1)) = oddEven ts + | otherwise = evenOdd ts + -- | num < pf `div` 2 = (ts,[]) + + +oddEven :: [t] -> ([t],[t],Bool) +oddEven [] = ([],[],False) +oddEven (x:xs) = (x:localT ,fatherT, even) + where (localT,fatherT,even) = evenOdd xs + +evenOdd :: [t] -> ([t],[t],Bool) +evenOdd [] = ([],[],True) +evenOdd (x:xs) = (localT, x:fatherT, even) + where (localT,fatherT,even) = oddEven xs + +nextPes :: Int -> Int -> [Int] +nextPes n stride | start > noPe = replicate n noPe + | otherwise = concat (replicate n ps) + where ps = cycle (takeWhile (<= noPe) [start,start+stride..]) + start = selfPe + 1 + +mkNesting :: Int -> Int -> Int -> [Int] +mkNesting np 1 _ = [np] +mkNesting np depth level1 = level1:(replicate (depth - 2) 2) ++ [numWs] + where -- leaves = np - #submasters + leaves = np - level1 * ( 2^(depth-1) - 1 ) + -- num of lowest submasters + numSubMs = level1 * 2^(depth - 2) + -- workers per branch (rounded up) + numWs = (leaves + numSubMs - 1) `div` numSubMs + +mkPFs :: Int -> -- prefetch value for worker processes + [Int] -> -- branching per level top-down + [Int] -- list of prefetches +mkPFs pf nesting + = [ factor * (pf+1) | factor <- scanr1 (*) (tail nesting) ] ++ [pf] + + + +---------------------------distributed workpool skeletons------------------------------------------- + +-- | A distributed workpool skeleton that uses task generation and a global state (s) with a total order. +-- Split and Detatch policy must give tasks away (may not produce empty lists), unless all tasks are pruned! +distribWPAt :: (Trans onT, Trans t, Trans r, Trans s, NFData r') => + Places -- ^ where to put workers + -> ((t,s) -> (Maybe (r',s),[t])) -- ^ worker function + -> (Maybe ofT -> Maybe onT -> [t]) -- ^ input transformation (e.g. (fetch . fromJust . snd) for online input of type [RD[t]]) + -> ([Maybe (r',s)] -> s -> r) -- ^ result transformation (prior to release results in the workers) + -> ([t]->[t]->s->[t]) -- ^ taskpool transform attach function + -> ([t]->s->([t],Maybe (t,s))) -- ^ taskpool transform detach function (local request) + -> ([t]->s->([t],[t])) -- ^ taskpool transform split function (remote request) + -> (s->s->Bool) -- ^ state comparison (checks if new state is better than old state) + -> s -- ^ initial state (offline input) + -> [ofT] -- ^ offline input (if non empty, outer list defines the number of workers, else the shorter list does) + -> [onT] -- ^ dynamic input (if non empty, outer list defines the number of workers, else the shorter list does) + -> [r] -- ^ results of workers +distribWPAt places wf inputT resT ttA ttD ttSplit sUpdate st ofTasks onTasks = res where + res = ringFlAt places id id workers onTasks' + workers = zipWith (worker) (True:(repeat False)) ofTasks' + -- length of ontasks and oftasks is adjusted such that the desired number of workers will be instantiated + (ofTasks',onTasks') | null ofTasks = (repeat Nothing , map Just onTasks) + | null onTasks = (map Just ofTasks, repeat Nothing ) + | otherwise = (map Just ofTasks, map Just onTasks) + -- worker functionality + worker isFirst ofTasks onTasks ringIn = (resT ress sFinal,init ringOut) where + ts = (inputT ofTasks onTasks) + (ress,ntssNtoMe) = unzip $ genResNReqs $ map wf ts' --seperate + reqList = Me : mergeS [ringIn, --merge external Requests + ntssNtoMe] rnf --and nf reduced local Requests + -- manage Taskpool & Requests + (ts',ringOut) = control ttA ttSplit ttD sUpdate reqList ts st isFirst + sFinal = getState $ last ringOut + + +control:: (Trans t, Trans s) => + ([t]->[t]->s->[t]) -> --Taskpool Transform Attach + ([t]->s->([t],[t])) -> --Split Policy (remote Req) + ([t]->s->([t],Maybe (t,s))) -> --tt Detach (local Req) + (s->s->Bool)-> --Checks if newState is better than oldState + [Req [t] s]->[t]->s->Bool-> --reqs,tasks,state,isFirstInRing + ([(t,s)],[Req [t] s]) --localTasks,RequestsToRing +control ttA ttSplit ttD sUpdate requests initTasks st isFirst + = distribWork requests initTasks Nothing st (0,0) + where + --until no tasks left: react on own and Others requests & add new Tasks + --distribWork :: Trans t => [Req [t] s] -> [t] -> $ + -- Maybe (ChanName (Req [t] s))->(Int,Int)-> ([t],[ReqS [t] s],s) + distribWork (TasksNMe nts:rs) tS replyCh st sNr --selfmade Tasks arrive + = distribWork (Me:rs) (ttA tS nts st) replyCh st sNr --add Tasks and MeReq + + distribWork (NewState st':rs) tS replyCh st sNr --Updated State arrives + | sUpdate st' st = let (tS',wReqs') =distribWork rs tS replyCh st' sNr + in (tS',(NewState st':wReqs')) --then check and send + | otherwise = distribWork rs tS replyCh st sNr --or discard + + distribWork (req@(Others tag tCh):rs) [] replyCh st sNr --Others Request & + | tag==None = (tS',req:wReqs') --no tasks left --> pass Request + | otherwise = (tS', Others Black tCh : wReqs') --I'm still working -> Black + where(tS',wReqs') = distribWork rs [] replyCh st sNr + + distribWork (Me:rs) [] replyCh st sNr = --last own Task solved and no new ones + new (\reqChan (newTS,replyChan) -> --gen new reqChan to get newTS & replyC + let (tS',wReqs) = passWhileReceive (mergeS [rs, --wait for fst newTask + newTS `pseq` [TasksNMe newTS]] r0) replyChan st sNr --to merge + tag | isFirst = Black --First Worker starts Black (For Termination) + | otherwise = None --normal Workers with None Tag + in(case replyCh of --First own Request into Ring- others dynamic + Nothing -> (tS', Others tag reqChan : wReqs) + Just replyCh' -> parfill replyCh' (Others tag reqChan) + (tS',wReqs))) + + distribWork (Me:rs) tS replyCh st sNr --local Request and Tasks present + = let (tS',tDetatch) = ttD tS st --TaskpoolTransform Detatch + (tsDetatch,wReqs) = case tDetatch of + Nothing -> distribWork (Me:rs) [] replyCh st sNr + Just t -> distribWork rs tS' replyCh st sNr + in ((maybeToList tDetatch)++tsDetatch,wReqs) --add Maybe one Task to wf + + distribWork reqs@(Others _ tCh :rs) tS replyCh st (s,r) --foreign Req & have Ts + = let (holdTs,sendTs) = ttSplit tS st --split ts to send and ts to hold + ((tS',wReqs'),replyReq) + = new (\replyChan replyReq' -> --gen ReplyC and send Tasks & new + parfill tCh (sendTs,Just replyChan) --ReplyC in Chan of the Req + ((distribWork rs holdTs replyCh st (s+1,r)),replyReq')) + in case sendTs of --ReplyReqToOutp + [] -> distribWork reqs [] replyCh st (s,r) --No tasks left + (_:_) -> (tS',mergeS [[replyReq],wReqs'] rnf) + +-- Pass all until foreign Tasks arrive or Termination starts +-- passWhileRecive :: Trans t => [ReqS [t] s] -> Maybe(ChanName (ReqS [t] s)) +-- -> (Int,Int) -> ([t],[ReqS [t] s]) + passWhileReceive (NewState st':rs) replyCh st sNr --Updated State arrives + | sUpdate st' st =let (tS',wReqs')=passWhileReceive rs replyCh st' sNr + in (tS',(NewState st':wReqs')) --then check and send + | otherwise = passWhileReceive rs replyCh st sNr --or discard + + passWhileReceive (req@(Others None tCh):rs) replyCh st sNr --Req of normal + = let (tS',wReqs) = passWhileReceive rs replyCh st sNr --Worker -> pass it + in (tS',req:wReqs) + + passWhileReceive (req@(Others Black tCh ):rs) replyCh st (s,r) --Black Req + | (not isFirst) = (tS',req :wReqs) --normal Workers: pass it + | otherwise = (tS',req':wReqs) --First Worker: new Round starts White + where (tS',wReqs) = passWhileReceive rs replyCh st (s,r) + req'= Others (White s r 0 0) tCh --Start with own Counters + + passWhileReceive (Others (White s1 r1 s2 r2) tCh :rs) replyCh st (s,r) + | (not isFirst) = (tS',req':wReqs) --Normal Workers: add Counter and pass + --4 counters equal -> pass Black as end of reqs Symbol, start Termination + | otherwise = if terminate + then ([],Others Black tCh : (termRing rs ++ [NewState st])) + else (tS',req'':wReqs) --no Termination + where (tS',wReqs) = passWhileReceive rs replyCh st (s,r) + req' = Others (White (s1+s) (r1+r) s2 r2) tCh --add Counters + req'' = Others (White s r s1 r1) tCh --Move Counters->NewTurn + terminate = (s1==r1)&&(r1==s2)&&(s2==r2) --Check Termination + + passWhileReceive (TasksNMe newTS:rs) replyCh st (s,r) --Task List arrives + | null newTS = ([],(termRing rs) --got empty newTs -> begin Termination + ++ [NewState st]) --attach final State at the End + | otherwise = (distribWork (Me:rs) newTS replyCh st (s,r+1)) --have newTs + + +data Req t s = + Me | --Work Request of local Worker - Fuction + --Request of other Workers with Tag, and Chanel to Send Tasks and + Others { getTag :: Tag, + getReplyChan :: (ChanName (t,Maybe (ChanName(Req t s)))) + } | --Reply Chanel + TasksNMe { getTask :: t} | -- New Tasks and additional Me Request to add + NewState { getState :: s } + +instance (NFData t, NFData s) => NFData (Req t s) + where + rnf Me = () + rnf (Others t c) = rnf t `pseq` rnf c + rnf (TasksNMe t) = rnf t + rnf (NewState s) = rnf s + +instance (Trans t,Trans s) => Trans (Req t s) + +data Tag = Black | --no Termination Situation / Term Mode: Last Request in Ring + White Int Int Int Int | --check Termination Situation:(send&recv) + None --Request of normal Worker + +instance NFData Tag + where rnf Black = () + rnf None = () + rnf (White a b c d) = rnf (a,b,c,d) + +instance Eq Tag where + Black == Black = True + None == None = True + White a b c d == White a' b' c' d' = (a,b,c,d)==(a',b',c',d') + a == b = False + + +---------------------auxiliary----------------- +termRing :: (Trans t,Trans s) => [Req [t] s] -> [Req [t] s] +termRing [] = [] -- Predecessors tells no more reqs +termRing (Others Black tCh : _ ) = parfill tCh ([],Nothing) [] --reply last req +termRing (Others None tCh : rs) = parfill tCh ([],Nothing) termRing rs --reply +termRing (_ : rs) = termRing rs --ignore isFirsts reply + +genResNReqs :: (NFData t,NFData r',NFData s)=> + [(Maybe (r',s),[t])] -> [(Maybe (r',s),Req [t] s)] +genResNReqs [] = [] --No more tasks +genResNReqs ((res@(Nothing,nts)):ress) --No new State -> Attach new Tasks + = rnf res `pseq` (Nothing,TasksNMe nts): genResNReqs ress +genResNReqs ((res@(Just (r,st),nts)):ress) --New State found -> Attach + = rnf res `pseq` (Just (r,st),NewState st): genResNReqs ((Nothing,nts):ress) + + +-----------------------------DEPRECATED--------------------------------- +-- | Deprecated, same as 'workpoolSortedNonBlock' +{-# DEPRECATED masterWorker "better use workpoolSortedNonBlock instead" #-} +masterWorker :: (Trans a, Trans b) => + Int -> Int -> (a -> b) -> [a] -> [b] +masterWorker = workpoolSortedNonBlock + +-- | Deprecated, same as 'wpNested' +{-# DEPRECATED mwNested "better use wpNested instead" #-} +mwNested :: forall t r . (Trans t, Trans r) => + [Int] -> [Int] -> (t -> r) -> [t] -> [r] +mwNested = wpNested + +-- | Deprecated, same as 'wpDNI' +{-# DEPRECATED mwDNI "better use wpDNI instead" #-} +mwDNI :: (Trans t, Trans r) => + Int + -> Int + -> Int + -> Int + -> (t -> (r,[t])) + -> [t] + -> [r] +mwDNI = wpDNI + +-- | Deprecated, same as 'wpDynNested' +{-# DEPRECATED mwDynNested "better use wpDynNested instead" #-} +mwDynNested :: forall t r . (Trans t, Trans r) => + [Int] + -> [Int] + -> (t -> (r,[t])) + -> [t] + -> [r] +mwDynNested = wpDynNested diff --git a/edenskel.cabal b/edenskel.cabal --- a/edenskel.cabal +++ b/edenskel.cabal @@ -1,22 +1,12 @@ name: edenskel -version: 1.1.1.0 +version: 2.0.0.0 license: BSD3 license-file: LICENSE maintainer: eden@mathematik.uni-marburg.de -homepage: http://www.mathematik.uni-marburg.de/~eden synopsis: Semi-explicit parallel programming skeleton library description: This package provides a skeleton library for semi-explicit parallel programming with Eden. - - Eden and the skeleton library depend on GHC, and should normally use a GHC extension to support parallel execution using message passing. - This modified GHC-Eden compiler is available from - . - When built using a standard GHC, this package will use a - threaded simulation of Eden. - - The Eden homepage - provides more documentation and a tutorial. -category: Control, Distributed Computing, Eden, Parallelism +category: Control.Parallel.Eden build-type: Simple cabal-version: >=1.6 @@ -30,19 +20,19 @@ library { exposed-modules: - Control.Parallel.Eden.EdenSkel.Auxiliary - Control.Parallel.Eden.EdenSkel.IterSkels - Control.Parallel.Eden.EdenSkel.MapSkels - Control.Parallel.Eden.EdenSkel.MapRedSkels - Control.Parallel.Eden.EdenSkel.DCSkels - Control.Parallel.Eden.EdenSkel.WPSkels - Control.Parallel.Eden.EdenSkel.TopoSkels + Control.Parallel.Eden.Auxiliary + Control.Parallel.Eden.Map + Control.Parallel.Eden.MapReduce + Control.Parallel.Eden.DivConq + Control.Parallel.Eden.Workpool + Control.Parallel.Eden.Topology + Control.Parallel.Eden.Iteration extensions: CPP if flag(par) CPP-Options: -D__PARALLEL_HASKELL__ build-depends: base >= 4 && < 5, - edenmodules >= 1.1.0.1 && < 2, + edenmodules >= 1.2.0.0 && < 2, parallel >= 3.1 && <4 }