repa-eval (empty) → 4.0.0.1
raw patch · 14 files changed
+1434/−0 lines, 14 filesdep +basedep +ghc-primsetup-changed
Dependencies added: base, ghc-prim
Files
- Data/Repa/Eval/Elt.hs +377/−0
- Data/Repa/Eval/Gang.hs +196/−0
- Data/Repa/Eval/Generic/Par.hs +18/−0
- Data/Repa/Eval/Generic/Par/Chunked.hs +111/−0
- Data/Repa/Eval/Generic/Par/Cursored.hs +131/−0
- Data/Repa/Eval/Generic/Par/Interleaved.hs +56/−0
- Data/Repa/Eval/Generic/Par/Reduction.hs +107/−0
- Data/Repa/Eval/Generic/Seq.hs +16/−0
- Data/Repa/Eval/Generic/Seq/Chunked.hs +71/−0
- Data/Repa/Eval/Generic/Seq/Cursored.hs +102/−0
- Data/Repa/Eval/Generic/Seq/Reduction.hs +166/−0
- LICENSE +25/−0
- Setup.hs +2/−0
- repa-eval.cabal +56/−0
+ Data/Repa/Eval/Elt.hs view
@@ -0,0 +1,377 @@++-- | Values that can be stored in Repa Arrays.+module Data.Repa.Eval.Elt+ (Elt (..))+where+import GHC.Prim+import GHC.Exts+import GHC.Types+import GHC.Word+import GHC.Int+import GHC.Generics+++-- Note that the touch# function is special because we can pass it boxed or unboxed+-- values. The argument type has kind ?, not just * or #.++-- | Element types that can be used with the blockwise filling functions.+--+-- This class is mainly used to define the `touch` method. This is used internally+-- in the imeplementation of Repa to prevent let-binding from being floated+-- inappropriately by the GHC simplifier. Doing a `seq` sometimes isn't enough,+-- because the GHC simplifier can erase these, and still move around the bindings.+--+-- This class supports the generic deriving mechanism, +-- use @deriving instance Elt (TYPE)@+--+class Elt a where++ -- | Place a demand on a value at a particular point in an IO computation.+ touch :: a -> IO ()++ default touch :: (Generic a, GElt (Rep a)) => a -> IO ()+ touch = gtouch . from+ {-# INLINE touch #-}++ -- | Generic zero value, helpful for debugging.+ zero :: a++ default zero :: (Generic a, GElt (Rep a)) => a+ zero = to gzero+ {-# INLINE zero #-}++ -- | Generic one value, helpful for debugging.+ one :: a++ default one :: (Generic a, GElt (Rep a)) => a+ one = to gone+ {-# INLINE one #-}++class GElt f where+ -- | Generic version of touch+ gtouch :: f a -> IO ()++ -- | Generic version of zero+ gzero :: f a++ -- | Generic version of gone+ gone :: f a+++-- Generic Definition ----------------------------------------------------------++instance GElt U1 where+ gtouch _ = return ()+ {-# INLINE gtouch #-}++ gzero = U1+ {-# INLINE gzero #-}++ gone = U1+ {-# INLINE gone #-}++instance (GElt a, GElt b) => GElt (a :*: b) where+ gtouch (x :*: y) = gtouch x >> gtouch y+ {-# INLINE gtouch #-}++ gzero = gzero :*: gzero+ {-# INLINE gzero #-}++ gone = gone :*: gone+ {-# INLINE gone #-}++instance (GElt a, GElt b) => GElt (a :+: b) where+ gtouch (L1 x) = gtouch x+ gtouch (R1 x) = gtouch x+ {-# INLINE gtouch #-}++ gzero = L1 gzero+ {-# INLINE gzero #-}++ gone = R1 gone+ {-# INLINE gone #-}++instance (GElt a) => GElt (M1 i c a) where+ gtouch (M1 x) = gtouch x+ {-# INLINE gtouch #-}++ gzero = M1 gzero+ {-# INLINE gzero #-}++ gone = M1 gone+ {-# INLINE gone #-}++instance (Elt a) => GElt (K1 i a) where+ gtouch (K1 x) = touch x+ {-# INLINE gtouch #-}++ gzero = K1 zero+ {-# INLINE gzero #-}++ gone = K1 one+ {-# INLINE gone #-}+++-- Bool -----------------------------------------------------------------------+instance Elt Bool where+ touch b+ = IO (\state -> case touch# b state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = False+ {-# INLINE zero #-}++ one = True+ {-# INLINE one #-}+++-- Char -----------------------------------------------------------------------+instance Elt Char where+ touch c+ = IO (\state -> case touch# c state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = '0'+ {-# INLINE zero #-}++ one = '1'+ {-# INLINE one #-}+++-- Floating -------------------------------------------------------------------+instance Elt Float where+ touch (F# f)+ = IO (\state -> case touch# f state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Double where+ touch (D# d)+ = IO (\state -> case touch# d state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++-- Int ------------------------------------------------------------------------+instance Elt Int where+ touch (I# i)+ = IO (\state -> case touch# i state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Int8 where+ touch (I8# w)+ = IO (\state -> case touch# w state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Int16 where+ touch (I16# w)+ = IO (\state -> case touch# w state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Int32 where+ touch (I32# w)+ = IO (\state -> case touch# w state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Int64 where+ touch (I64# w)+ = IO (\state -> case touch# w state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++-- Word -----------------------------------------------------------------------+instance Elt Word where+ touch (W# i)+ = IO (\state -> case touch# i state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Word8 where+ touch (W8# w)+ = IO (\state -> case touch# w state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Word16 where+ touch (W16# w)+ = IO (\state -> case touch# w state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Word32 where+ touch (W32# w)+ = IO (\state -> case touch# w state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++instance Elt Word64 where+ touch (W64# w)+ = IO (\state -> case touch# w state of+ state' -> (# state', () #))+ {-# INLINE touch #-}++ zero = 0+ {-# INLINE zero #-}++ one = 1+ {-# INLINE one #-}+++-- Tuple ----------------------------------------------------------------------+instance (Elt a, Elt b) => Elt (a, b) where+ touch (a, b)+ = do touch a+ touch b+ {-# INLINE touch #-}++ zero = (zero, zero)+ {-# INLINE zero #-}++ one = (one, one)+ {-# INLINE one #-}+++instance (Elt a, Elt b, Elt c) => Elt (a, b, c) where+ touch (a, b, c)+ = do touch a+ touch b+ touch c+ {-# INLINE touch #-}++ zero = (zero, zero, zero)+ {-# INLINE zero #-}++ one = (one, one, one)+ {-# INLINE one #-}+++instance (Elt a, Elt b, Elt c, Elt d) => Elt (a, b, c, d) where+ touch (a, b, c, d)+ = do touch a+ touch b+ touch c+ touch d+ {-# INLINE touch #-}++ zero = (zero, zero, zero, zero)+ {-# INLINE zero #-}++ one = (one, one, one, one)+ {-# INLINE one #-}+++instance (Elt a, Elt b, Elt c, Elt d, Elt e) => Elt (a, b, c, d, e) where+ touch (a, b, c, d, e)+ = do touch a+ touch b+ touch c+ touch d+ touch e+ {-# INLINE touch #-}++ zero = (zero, zero, zero, zero, zero)+ {-# INLINE zero #-}++ one = (one, one, one, one, one)+ {-# INLINE one #-}+++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) => Elt (a, b, c, d, e, f) where+ touch (a, b, c, d, e, f)+ = do touch a+ touch b+ touch c+ touch d+ touch e+ touch f+ {-# INLINE touch #-}++ zero = (zero, zero, zero, zero, zero, zero)+ {-# INLINE zero #-}++ one = (one, one, one, one, one, one)+ {-# INLINE one #-}++
+ Data/Repa/Eval/Gang.hs view
@@ -0,0 +1,196 @@++-- | Gang Primitives.+module Data.Repa.Eval.Gang+ (Gang, forkGang, gangSize, gangIO, gangST) +where+import GHC.IO+import GHC.ST+import GHC.Conc (forkOn)+import Control.Concurrent.MVar+import Control.Exception (assert)+import Control.Monad+import System.IO+import GHC.Exts+++-- Requests -------------------------------------------------------------------+-- | The 'Req' type encapsulates work requests for individual members of a gang.+data Req+ -- | Instruct the worker to run the given action.+ = ReqDo (Int# -> IO ())++ -- | Tell the worker that we're shutting the gang down.+ -- The worker should signal that it's receieved the request by+ -- writing to its result var before returning to the caller (forkGang).+ | ReqShutdown+++-- Gang -----------------------------------------------------------------------+-- | A 'Gang' is a group of threads that execute arbitrary work requests.+data Gang+ = Gang + { -- | Number of threads in the gang.+ _gangThreads :: Int#++ -- | Workers listen for requests on these vars.+ , _gangRequestVars :: [MVar Req] ++ -- | Workers put their results in these vars.+ , _gangResultVars :: [MVar ()] ++ -- | Indicates that the gang is busy.+ , _gangBusy :: MVar Bool+ } ++instance Show Gang where+ showsPrec p (Gang n _ _ _)+ = showString "<<"+ . showsPrec p (I# n)+ . showString " threads>>"+++-- | O(1). Yield the number of threads in the 'Gang'.+gangSize :: Gang -> Int#+gangSize (Gang n _ _ _) + = n+{-# NOINLINE gangSize #-}+++-- | Fork a 'Gang' with the given number of threads (at least 1).+forkGang :: Int -> IO Gang+forkGang !n@(I# n_)+ = assert (n > 0)+ $ do+ -- Create the vars we'll use to issue work requests.+ mvsRequest <- sequence $ replicate n $ newEmptyMVar++ -- Create the vars we'll use to signal that threads are done.+ mvsDone <- sequence $ replicate n $ newEmptyMVar++ -- Add finalisers so we can shut the workers down cleanly if they+ -- become unreachable.+ zipWithM_ (\varReq varDone + -> mkWeakMVar varReq (finaliseWorker varReq varDone)) + mvsRequest+ mvsDone++ -- Create all the worker threads+ zipWithM_ forkOn [0..]+ $ zipWith3 (\(I# i) -> gangWorker i)+ [0 .. n - 1] mvsRequest mvsDone++ -- The gang is currently idle.+ busy <- newMVar False++ return $ Gang n_ mvsRequest mvsDone busy+{-# NOINLINE forkGang #-}+++-- | The worker thread of a 'Gang'.+-- The threads blocks on the MVar waiting for a work request.+gangWorker :: Int# -> MVar Req -> MVar () -> IO ()+gangWorker threadId varRequest varDone+ = do + -- Wait for a request + req <- takeMVar varRequest++ case req of+ ReqDo action+ -> do -- Run the action we were given.+ action threadId++ -- Signal that the action is complete.+ putMVar varDone ()++ -- Wait for more requests.+ gangWorker threadId varRequest varDone++ ReqShutdown+ -> putMVar varDone ()+{-# NOINLINE gangWorker #-}+++-- | Finaliser for worker threads.+-- We want to shutdown the corresponding thread when it's MVar becomes+-- unreachable.+-- Without this Repa programs can complain about "Blocked indefinitely+-- on an MVar" because worker threads are still blocked on the request+-- MVars when the program ends. Whether the finalizer is called or not+-- is very racey. It happens about 1 in 10 runs when for the+-- repa-edgedetect benchmark, and less often with the others.+--+-- We're relying on the comment in System.Mem.Weak that says+-- "If there are no other threads to run, the runtime system will+-- check for runnablefinalizers before declaring the system to be+-- deadlocked."+--+-- If we were creating and destroying the gang cleanly we wouldn't need+-- this, but theGang is created with a top-level unsafePerformIO.+-- Hacks beget hacks beget hacks...+--+finaliseWorker :: MVar Req -> MVar () -> IO ()+finaliseWorker varReq varDone + = do putMVar varReq ReqShutdown+ takeMVar varDone+ return ()+{-# NOINLINE finaliseWorker #-}+++-- | Issue work requests for the 'Gang' and wait until they complete.+--+-- If the gang is already busy then print a warning to `stderr` and just+-- run the actions sequentially in the requesting thread.+gangIO :: Gang+ -> (Int# -> IO ())+ -> IO ()++gangIO gang@(Gang _ _ _ busy) action+ = do b <- swapMVar busy True+ if b+ then do+ seqIO gang action++ else do+ parIO gang action+ _ <- swapMVar busy False+ return ()+{-# NOINLINE gangIO #-}+++-- | Run an action on the gang sequentially.+seqIO :: Gang -> (Int# -> IO ()) -> IO ()+seqIO (Gang n _ _ _) action+ = do hPutStr stderr+ $ unlines+ [ "Data.Array.Repa.Bulk.Par: Performing nested parallel computation sequentially."+ , " Something is trying to run a compuation on a gang that is already busy. "+ , " You've probably used a Repa 'computeP', 'foldP' or similar function while "+ , " another instance was already running. This can happen if you've passed a "+ , " parallel worker function to a combinator like 'map', or some parallel "+ , " compuation was suspended via lazy evaluation. Try using `seq` to ensure that"+ , " each array is fully evaluated before computing the next one. "+ , "" ]++ mapM_ (\(I# i) -> action i) [0 .. (I# n) - 1]+{-# NOINLINE seqIO #-}+++-- | Run an action on the gang in parallel.+parIO :: Gang -> (Int# -> IO ()) -> IO ()+parIO (Gang _ mvsRequest mvsResult _) action+ = do + -- Send requests to all the threads.+ mapM_ (\v -> putMVar v (ReqDo action)) mvsRequest++ -- Wait for all the requests to complete.+ mapM_ takeMVar mvsResult+{-# NOINLINE parIO #-}+++-- | Same as 'gangIO' but in the 'ST' monad.+gangST :: Gang -> (Int# -> ST s ()) -> ST s ()+gangST g p + = unsafeIOToST $ gangIO g (\i -> unsafeSTToIO $ p i)+{-# NOINLINE gangST #-}++
+ Data/Repa/Eval/Generic/Par.hs view
@@ -0,0 +1,18 @@++-- | Generic parallel array computation operators.+module Data.Repa.Eval.Generic.Par+ ( -- * Filling+ fillChunked+ , fillChunkedIO+ , fillBlock2+ , fillInterleaved+ , fillCursoredBlock2++ -- * Reduction+ , foldAll+ , foldInner)+where+import Data.Repa.Eval.Generic.Par.Chunked+import Data.Repa.Eval.Generic.Par.Cursored+import Data.Repa.Eval.Generic.Par.Interleaved+import Data.Repa.Eval.Generic.Par.Reduction
+ Data/Repa/Eval/Generic/Par/Chunked.hs view
@@ -0,0 +1,111 @@++module Data.Repa.Eval.Generic.Par.Chunked+ ( fillChunked+ , fillChunkedIO)+where+import Data.Repa.Eval.Gang+import GHC.Exts+++-------------------------------------------------------------------------------+-- | Fill something in parallel.+-- +-- * The array is split into linear chunks,+-- and each thread linearly fills one chunk.+-- +fillChunked+ :: Gang -- ^ Gang to run the operation on.+ -> (Int# -> a -> IO ()) -- ^ Update function to write into result buffer.+ -> (Int# -> a) -- ^ Function to get the value at a given index.+ -> Int# -- ^ Number of elements.+ -> IO ()++fillChunked gang write getElem len+ = gangIO gang+ $ \thread -> + let !start = splitIx thread+ !end = splitIx (thread +# 1#)+ in fill start end++ where+ -- Decide now to split the work across the threads.+ -- If the length of the vector doesn't divide evenly among the threads,+ -- then the first few get an extra element.+ !threads = gangSize gang+ !chunkLen = len `quotInt#` threads+ !chunkLeftover = len `remInt#` threads++ splitIx thread+ | 1# <- thread <# chunkLeftover = thread *# (chunkLen +# 1#)+ | otherwise = thread *# chunkLen +# chunkLeftover+ {-# INLINE splitIx #-}++ -- Evaluate the elements of a single chunk.+ fill !ix !end+ | 1# <- ix >=# end = return ()+ | otherwise+ = do write ix (getElem ix)+ fill (ix +# 1#) end+ {-# INLINE fill #-}++{-# INLINE [0] fillChunked #-}+++-------------------------------------------------------------------------------+-- | Fill something in parallel, using a separate IO action for each thread.+--+-- * The array is split into linear chunks,+-- and each thread linearly fills one chunk.+--+fillChunkedIO+ :: Gang -- ^ Gang to run the operation on.+ -> (Int# -> a -> IO ()) + -- ^ Update function to write into result buffer.+ -> (Int# -> IO (Int# -> IO a)) + -- ^ Create a function to get the value at a given index.+ -- The first argument is the thread number, so you can do some+ -- per-thread initialisation.+ -> Int# -- ^ Number of elements.+ -> IO ()++fillChunkedIO gang write mkGetElem len+ = gangIO gang+ $ \thread -> + let !start = splitIx thread+ !end = splitIx (thread +# 1#)+ in fillChunk thread start end ++ where+ -- Decide now to split the work across the threads.+ -- If the length of the vector doesn't divide evenly among the threads,+ -- then the first few get an extra element.+ !threads = gangSize gang+ !chunkLen = len `quotInt#` threads+ !chunkLeftover = len `remInt#` threads++ splitIx thread+ | 1# <- thread <# chunkLeftover = thread *# (chunkLen +# 1#)+ | otherwise = thread *# chunkLen +# chunkLeftover+ {-# INLINE splitIx #-}++ -- Given the threadId, starting and ending indices. + -- Make a function to get each element for this chunk+ -- and call it for every index.+ fillChunk !thread !ixStart !ixEnd+ = do getElem <- mkGetElem thread+ fill getElem ixStart ixEnd+ {-# INLINE fillChunk #-}+ + -- Call the provided getElem function for every element+ -- in a chunk, and feed the result to the write function.+ fill !getElem !ix0 !end+ = go ix0 + where go !ix+ | 1# <- ix >=# end = return ()+ | otherwise+ = do x <- getElem ix+ write ix x+ go (ix +# 1#)+ {-# INLINE fill #-}++{-# INLINE [0] fillChunkedIO #-}
+ Data/Repa/Eval/Generic/Par/Cursored.hs view
@@ -0,0 +1,131 @@++module Data.Repa.Eval.Generic.Par.Cursored+ ( fillBlock2+ , fillCursoredBlock2)+where+import Data.Repa.Eval.Elt+import Data.Repa.Eval.Gang+import qualified Data.Repa.Eval.Generic.Seq.Cursored as Seq+import GHC.Exts+++-- Non-cursored interface -----------------------------------------------------+-- | Fill a block in a rank-2 array in parallel.+--+-- * Blockwise filling can be more cache-efficient than linear filling for+-- rank-2 arrays.+--+-- * Coordinates given are of the filled edges of the block.+-- +-- * We divide the block into columns, and give one column to each thread.+-- +-- * Each column is filled in row major order from top to bottom.+--+fillBlock2 + :: Elt a+ => Gang+ -> (Int# -> a -> IO ()) + -- ^ Update function to write into result buffer.+ -> (Int# -> Int# -> a) + -- ^ Function to evaluate the element at an (x, y) index.+ -> Int# -- ^ Width of the whole array.+ -> Int# -- ^ x0 lower left corner of block to fill+ -> Int# -- ^ y0 + -> Int# -- ^ w0 width of block to fill.+ -> Int# -- ^ h0 height of block to fill.+ -> IO ()++fillBlock2 gang write getElem !imageWidth !x0 !y0 !w0 h0+ = fillCursoredBlock2+ gang write+ makeCursor shiftCursor loadCursor+ imageWidth x0 y0 w0 h0++ where makeCursor x y+ = DIM2 x y+ {-# INLINE makeCursor #-}++ shiftCursor x' y' (DIM2 x y) + = DIM2 (x +# x') (y +# y')+ {-# INLINE shiftCursor #-}++ loadCursor (DIM2 x y)+ = getElem x y+ {-# INLINE loadCursor #-}++{-# INLINE [0] fillBlock2 #-}++data DIM2 + = DIM2 Int# Int#+++-- Block filling --------------------------------------------------------------+-- | Fill a block in a rank-2 array in parallel.+-- +-- * Blockwise filling can be more cache-efficient than linear filling for+-- rank-2 arrays.+--+-- * Using cursor functions can help to expose inter-element indexing+-- computations to the GHC and LLVM optimisers.+--+-- * Coordinates given are of the filled edges of the block.+--+-- * We divide the block into columns, and give one column to each thread.+-- +-- * We need the `Elt` constraint so that we can use its `touch` function+-- to provide an order of evaluation ammenable to the LLVM optimiser.+-- You should compile your Haskell program with @-fllvm -optlo-O3@ to+-- enable LLVM's Global Value Numbering optimisation.+--+fillCursoredBlock2+ :: Elt a+ => Gang -- ^ Gang to run the operation on.+ -> (Int# -> a -> IO ()) + -- ^ Update function to write into result buffer.+ -> (Int# -> Int# -> cursor) + -- ^ Make a cursor from an (x, y) index.+ -> (Int# -> Int# -> cursor -> cursor) + -- ^ Shift the cursor by an (x, y) offset.+ -> (cursor -> a) -- ^ Function to evaluate the element at an index.+ -> Int# -- ^ Width of the whole array.+ -> Int# -- ^ x0 lower left corner of block to fill+ -> Int# -- ^ y0+ -> Int# -- ^ w0 width of block to fill+ -> Int# -- ^ h0 height of block to fill+ -> IO ()++fillCursoredBlock2+ gang write+ makeCursorFCB shiftCursorFCB getElemFCB+ !imageWidth !x0 !y0 !w0 !h0+ = gangIO gang fillBlock+ where + !threads = gangSize gang++ -- All columns have at least this many pixels.+ !colChunkLen = w0 `quotInt#` threads++ -- Extra pixels that we have to divide between some of the threads.+ !colChunkSlack = w0 `remInt#` threads++ -- Get the starting pixel of a column in the image.+ colIx !ix+ | 1# <- ix <# colChunkSlack = x0 +# (ix *# (colChunkLen +# 1#))+ | otherwise = x0 +# (ix *# colChunkLen) +# colChunkSlack+ {-# INLINE colIx #-}++ -- Give one column to each thread+ fillBlock :: Int# -> IO ()+ fillBlock !ix+ = let !x0' = colIx ix+ !w0' = colIx (ix +# 1#) -# x0'+ !y0' = y0+ !h0' = h0+ in Seq.fillCursoredBlock2+ write+ makeCursorFCB shiftCursorFCB getElemFCB+ imageWidth x0' y0' w0' h0'+ {-# INLINE fillBlock #-}++{-# INLINE [0] fillCursoredBlock2 #-}+
+ Data/Repa/Eval/Generic/Par/Interleaved.hs view
@@ -0,0 +1,56 @@++module Data.Repa.Eval.Generic.Par.Interleaved+ (fillInterleaved)+where+import Data.Repa.Eval.Gang+import GHC.Exts+++-- | Fill something in parallel, using a round-robin order.+-- +-- * Threads handle elements in row major, round-robin order.+--+-- * Using this method helps even out unbalanced workloads.+--+fillInterleaved+ :: Gang -- ^ Gang to run the operation on.+ -> (Int# -> a -> IO ()) -- ^ Update function to write into result buffer.+ -> (Int# -> a) -- ^ Function to get the value at a given index.+ -> Int# -- ^ Number of elements.+ -> IO ()++fillInterleaved gang write getElem len + = gangIO gang+ $ \thread -> + let !step = threads+ !start = thread+ !count = elemsForThread thread+ in fill step start count++ where+ -- Decide now to split the work across the threads.+ !threads = gangSize gang++ -- All threads get this many elements.+ !chunkLenBase = len `quotInt#` threads++ -- Leftover elements to divide between first few threads.+ !chunkLenSlack = len `remInt#` threads++ -- How many elements to compute with this thread.+ elemsForThread thread+ | 1# <- thread <# chunkLenSlack = chunkLenBase +# 1#+ | otherwise = chunkLenBase+ {-# INLINE elemsForThread #-}++ -- Evaluate the elements of a single chunk.+ fill !step !ix0 !count0+ = go ix0 count0+ where+ go !ix !count+ | 1# <- count <=# 0# = return ()+ | otherwise+ = do write ix (getElem ix)+ go (ix +# step) (count -# 1#)+ {-# INLINE fill #-}+{-# INLINE [0] fillInterleaved #-}
+ Data/Repa/Eval/Generic/Par/Reduction.hs view
@@ -0,0 +1,107 @@++module Data.Repa.Eval.Generic.Par.Reduction+ ( foldAll+ , foldInner)+where+import Data.Repa.Eval.Gang+import GHC.Exts+import qualified Data.Repa.Eval.Generic.Seq.Reduction as Seq+import Data.IORef+++-- | Parallel tree reduction of an array to a single value. Each thread takes an+-- equally sized chunk of the data and computes a partial sum. The main thread+-- then reduces the array of partial sums to the final result.+--+-- We don't require that the initial value be a neutral element, so each thread+-- computes a fold1 on its chunk of the data, and the seed element is only+-- applied in the final reduction step.+--+foldAll :: Gang -- ^ Gang to run the operation on.+ -> (Int# -> a) -- ^ Function to get an element from the source.+ -> (a -> a -> a) -- ^ Binary associative combining function.+ -> a -- ^ Starting value.+ -> Int# -- ^ Number of elements.+ -> IO a++foldAll !gang f c !z !len+ | 1# <- len ==# 0# = return z+ | otherwise + = do result <- newIORef z++ gangIO gang+ $ \tid -> fill result (split tid) (split (tid +# 1#))++ readIORef result+ where+ !threads = gangSize gang+ !step = (len +# threads -# 1#) `quotInt#` threads++ split !ix = len `foldAll_min` (ix *# step)++ foldAll_min x y+ = case x <=# y of+ 1# -> x + _ -> y+ {-# NOINLINE foldAll_min #-}+ -- NOINLINE to hide the branch from the simplifier.++ foldAll_combine result x + = atomicModifyIORef result (\x' -> (c x x', ()))+ {-# NOINLINE foldAll_combine #-}+ -- NOINLINE because we want to keep the final use of the combining + -- function separate from the main use in 'fill'. If the combining+ -- function contains a branch then the combination of two instances+ -- can cause code explosion.++ fill !result !start !end+ | 1# <- start >=# end = return ()+ | otherwise + = let !x = Seq.foldRange f c (f start) (start +# 1#) end+ in foldAll_combine result x+ {-# INLINE fill #-}++{-# INLINE [1] foldAll #-}+++-- | Parallel reduction of a multidimensional array along the innermost dimension.+-- Each output value is computed by a single thread, with the output values+-- distributed evenly amongst the available threads.+foldInner + :: Gang -- ^ Gang to run the operation on.+ -> (Int# -> a -> IO ()) -- ^ Function to write into the result buffer.+ -> (Int# -> a) -- ^ Function to get an element from the source.+ -> (a -> a -> a) -- ^ Binary associative combination operator.+ -> a -- ^ Neutral starting value.+ -> Int# -- ^ Total length of source.+ -> Int# -- ^ Inner dimension (length to fold over).+ -> IO ()++foldInner gang write f c !r !len !n+ = gangIO gang+ $ \tid -> fill (split tid) (split (tid +# 1#))+ where+ !threads = gangSize gang+ !step = (len +# threads -# 1#) `quotInt#` threads++ split !ix + = let !ix' = ix *# step+ in case len <# ix' of+ 1# -> len+ _ -> ix'+ {-# INLINE split #-}++ fill !start !end + = iter start (start *# n)+ where+ iter !sh !sz + | 1# <- sh >=# end = return ()+ | otherwise + = do let !next = sz +# n+ write sh (Seq.foldRange f c r sz next)+ iter (sh +# 1#) next+ {-# INLINE iter #-}+ {-# INLINE fill #-}++{-# INLINE [1] foldInner #-}+
+ Data/Repa/Eval/Generic/Seq.hs view
@@ -0,0 +1,16 @@++-- | Generic sequential array computation operators.+module Data.Repa.Eval.Generic.Seq+ ( -- * Filling+ fillLinear+ , fillBlock2+ , fillCursoredBlock2++ -- * Reduction+ , foldAll+ , foldRange+ , foldInner)+where+import Data.Repa.Eval.Generic.Seq.Chunked+import Data.Repa.Eval.Generic.Seq.Cursored+import Data.Repa.Eval.Generic.Seq.Reduction
+ Data/Repa/Eval/Generic/Seq/Chunked.hs view
@@ -0,0 +1,71 @@++module Data.Repa.Eval.Generic.Seq.Chunked+ ( fillLinear+ , fillBlock2)+where+import GHC.Exts+++-------------------------------------------------------------------------------+-- | Fill something sequentially.+-- +-- * The array is filled linearly from start to finish. +-- +fillLinear+ :: (Int# -> a -> IO ()) -- ^ Update function to write into result buffer.+ -> (Int# -> a) -- ^ Function to get the value at a given index.+ -> Int# -- ^ Number of elements to fill.+ -> IO ()++fillLinear write getElem len+ = fill 0#+ where fill !ix+ | 1# <- ix >=# len = return ()+ | otherwise+ = do write ix (getElem ix)+ fill (ix +# 1#)+{-# INLINE [0] fillLinear #-}+++-------------------------------------------------------------------------------+-- | Fill a block in a rank-2 array, sequentially.+--+-- * Blockwise filling can be more cache-efficient than linear filling for+-- rank-2 arrays.+--+-- * The block is filled in row major order from top to bottom.+--+fillBlock2+ :: (Int# -> a -> IO ()) -- ^ Update function to write into result buffer.+ -> (Int# -> Int# -> a) -- ^ Function to get the value at an (x, y) index.+ -> Int# -- ^ Width of the whole array.+ -> Int# -- ^ x0 lower left corner of block to fill.+ -> Int# -- ^ y0+ -> Int# -- ^ w0 width of block to fill+ -> Int# -- ^ h0 height of block to fill+ -> IO ()++fillBlock2+ write getElem+ !imageWidth !x0 !y0 !w0 h0++ = do fillBlock y0 ix0+ where !x1 = x0 +# w0+ !y1 = y0 +# h0+ !ix0 = x0 +# (y0 *# imageWidth)++ {-# INLINE fillBlock #-}+ fillBlock !y !ix+ | 1# <- y >=# y1 = return ()+ | otherwise+ = do fillLine1 x0 ix+ fillBlock (y +# 1#) (ix +# imageWidth)++ where {-# INLINE fillLine1 #-}+ fillLine1 !x !ix'+ | 1# <- x >=# x1 = return ()+ | otherwise+ = do write ix' (getElem x y)+ fillLine1 (x +# 1#) (ix' +# 1#)++{-# INLINE [0] fillBlock2 #-}
+ Data/Repa/Eval/Generic/Seq/Cursored.hs view
@@ -0,0 +1,102 @@++module Data.Repa.Eval.Generic.Seq.Cursored+ (fillCursoredBlock2)+where+import Data.Repa.Eval.Elt+import GHC.Exts+++-- | Fill a block in a rank-2 array, sequentially.+--+-- * Blockwise filling can be more cache-efficient than linear filling for+-- rank-2 arrays.+--+-- * Using cursor functions can help to expose inter-element indexing+-- computations to the GHC and LLVM optimisers.+--+-- * Coordinates given are of the filled edges of the block.+--+-- * The block is filled in row major order from top to bottom.+-- +-- * We need the `Elt` constraint so that we can use its `touch` function+-- to provide an order of evaluation ammenable to the LLVM optimiser.+-- You should compile your Haskell program with @-fllvm -optlo-O3@ to+-- enable LLVM's Global Value Numbering optimisation.+--+fillCursoredBlock2+ :: Elt a+ => (Int# -> a -> IO ())+ -- ^ Update function to write into result buffer.+ -> (Int# -> Int# -> cursor)+ -- ^ Make a cursor to a particular element from an (x, y) index.+ -> (Int# -> Int# -> cursor -> cursor) + -- ^ Shift the cursor by an (x, y) offset.+ -> (cursor -> a) -- ^ Function to evaluate an element at the given index.+ -> Int# -- ^ Width of the whole array.+ -> Int# -- ^ x0 lower left corner of block to fill.+ -> Int# -- ^ y0+ -> Int# -- ^ w0 width of block to fill+ -> Int# -- ^ h0 height of block to fill+ -> IO ()++fillCursoredBlock2+ write+ makeCursor shiftCursor getElem+ !imageWidth !x0 !y0 !w0 h0++ = do fillBlock y0+ where !x1 = x0 +# w0+ !y1 = y0 +# h0++ fillBlock !y+ | 1# <- y >=# y1 = return ()+ | otherwise+ = do fillLine4 x0+ fillBlock (y +# 1#)++ where fillLine4 !x+ | 1# <- x +# 4# >=# x1 = fillLine1 x+ | otherwise+ = do -- Compute each source cursor based on the previous one+ -- so that the variable live ranges in the generated+ -- code are shorter.+ let srcCur0 = makeCursor x y + let srcCur1 = shiftCursor 1# 0# srcCur0+ let srcCur2 = shiftCursor 1# 0# srcCur1+ let srcCur3 = shiftCursor 1# 0# srcCur2++ -- Get the result value for each cursor.+ let val0 = getElem srcCur0+ let val1 = getElem srcCur1+ let val2 = getElem srcCur2+ let val3 = getElem srcCur3++ -- Ensure that we've computed each of the result values+ -- before we write into the array. If the backend code+ -- generator can't tell our destination array doesn't+ -- alias with the source then writing to it can prevent+ -- the sharing of intermediate computations.+ touch val0+ touch val1+ touch val2+ touch val3++ -- Compute row-major index into destination array.+ let !dstCur0 = x +# (y *# imageWidth)+ write dstCur0 val0+ write (dstCur0 +# 1#) val1+ write (dstCur0 +# 2#) val2+ write (dstCur0 +# 3#) val3+ fillLine4 (x +# 4#)+ {-# INLINE fillLine4 #-}+ + fillLine1 !x+ | 1# <- x >=# x1 = return ()+ | otherwise+ = do let val0 = getElem $ makeCursor x y+ write (x +# (y *# imageWidth)) val0+ fillLine1 (x +# 1#)+ {-# INLINE fillLine1 #-}+ {-# INLINE fillBlock #-}+{-# INLINE [0] fillCursoredBlock2 #-}+
+ Data/Repa/Eval/Generic/Seq/Reduction.hs view
@@ -0,0 +1,166 @@++module Data.Repa.Eval.Generic.Seq.Reduction+ ( foldAll+ , foldRange+ , foldInner)+where+import GHC.Exts+++-- | Sequential reduction of all the elements in an array.+foldAll :: (Int# -> a) -- ^ Function to get an element from the source.+ -> (a -> a -> a) -- ^ Binary associative combining function.+ -> a -- ^ Neutral starting value.+ -> Int# -- ^ Number of elements.+ -> a++foldAll get c !r !len+ = foldRange get c r 0# len +{-# INLINE [1] foldAll #-}+++-- | Sequential reduction of a multidimensional array along the innermost dimension.+foldInner + :: (Int# -> a -> IO ()) -- ^ Function to write into the result buffer.+ -> (Int# -> a) -- ^ Function to get an element from the source.+ -> (a -> a -> a) -- ^ Binary associative combination function.+ -> a -- ^ Neutral starting value.+ -> Int# -- ^ Total length of source.+ -> Int# -- ^ Inner dimension (length to fold over).+ -> IO ()++foldInner write get c !r !end !n+ = iter 0# 0#+ where+ iter !sh !sz + | 1# <- sh >=# end + = return ()++ | otherwise + = do let !next = sz +# n+ write sh (foldRange get c r sz next)+ iter (sh +# 1#) next+ {-# INLINE iter #-}+{-# INLINE [1] foldInner #-}+++-- Reduce ---------------------------------------------------------------------+-- | Sequentially reduce values between the given indices.+---+-- We use manual specialisations and rewrite rules to avoid the result+-- being boxed up in the final iteration.+foldRange+ :: (Int# -> a) -- ^ Function to get an element from the source.+ -> (a -> a -> a) -- ^ Binary associative combining function.+ -> a -- ^ Neutral starting value.+ -> Int# -- ^ Starting index.+ -> Int# -- ^ Ending index.+ -> a++foldRange f c !r !start !end + = iter start r+ where iter !i !z + | 1# <- i >=# end = z + | otherwise = iter (i +# 1#) (f i `c` z)+ {-# INLINE iter #-}+{-# INLINE [0] foldRange #-}+++foldRangeInt+ :: (Int# -> Int#)+ -> (Int# -> Int# -> Int#)+ -> Int# + -> Int# -> Int# + -> Int#++foldRangeInt f c !r !start !end + = iter start r+ where iter !i !z + | 1# <- i >=# end = z + | otherwise = iter (i +# 1#) (f i `c` z)+ {-# INLINE iter #-}+{-# INLINE [0] foldRangeInt #-}+++foldRangeFloat+ :: (Int# -> Float#) + -> (Float# -> Float# -> Float#)+ -> Float# + -> Int# -> Int# + -> Float#++foldRangeFloat f c !r !start !end + = iter start r+ where iter !i !z + | 1# <- i >=# end = z + | otherwise = iter (i +# 1#) (f i `c` z)+ {-# INLINE iter #-}+{-# INLINE [0] foldRangeFloat #-}+++foldRangeDouble+ :: (Int# -> Double#) + -> (Double# -> Double# -> Double#)+ -> Double# + -> Int# -> Int# + -> Double#++foldRangeDouble f c !r !start !end + = iter start r+ where iter !i !z + | 1# <- i >=# end = z + | otherwise = iter (i +# 1#) (f i `c` z)+ {-# INLINE iter #-}+{-# INLINE [0] foldRangeDouble #-}+++unboxInt :: Int -> Int#+unboxInt (I# i) = i+{-# INLINE unboxInt #-}+++unboxFloat :: Float -> Float#+unboxFloat (F# f) = f+{-# INLINE unboxFloat #-}+++unboxDouble :: Double -> Double#+unboxDouble (D# d) = d+{-# INLINE unboxDouble #-}+++{-# RULES "foldRangeInt" + forall (get :: Int# -> Int) f r start end+ . foldRange get f r start end + = I# (foldRangeInt+ (\i -> unboxInt (get i))+ (\d1 d2 -> unboxInt (f (I# d1) (I# d2)))+ (unboxInt r)+ start+ end)+ #-}+++{-# RULES "foldRangeFloat" + forall (get :: Int# -> Float) f r start end+ . foldRange get f r start end + = F# (foldRangeFloat+ (\i -> unboxFloat (get i))+ (\d1 d2 -> unboxFloat (f (F# d1) (F# d2)))+ (unboxFloat r)+ start+ end)+ #-}+++{-# RULES "foldRangeDouble" + forall (get :: Int# -> Double) f r start end+ . foldRange get f r start end + = D# (foldRangeDouble+ (\i -> unboxDouble (get i))+ (\d1 d2 -> unboxDouble (f (D# d1) (D# d2)))+ (unboxDouble r)+ start+ end)+ #-}+
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2014-2015, The Repa Development Team++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++- The names of the copyright holders may not be used to endorse or promote+ products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ repa-eval.cabal view
@@ -0,0 +1,56 @@+Name: repa-eval+Version: 4.0.0.1+License: BSD3+License-file: LICENSE+Author: The Repa Development Team+Maintainer: Ben Lippmeier <benl@ouroborus.net>+Build-Type: Simple+Cabal-Version: >=1.6+Stability: experimental+Category: Data Structures+Homepage: http://repa.ouroborus.net+Bug-reports: repa@ouroborus.net+Description: Low-level parallel operators on bulk random-accessble arrays.+Synopsis: Low-level parallel operators on bulk random-accessble arrays.++source-repository head+ type: git+ location: https://github.com/DDCSF/repa.git++Library+ Build-Depends: + base == 4.7.*,+ ghc-prim == 0.3.*++ Exposed-modules:+ Data.Repa.Eval.Elt+ Data.Repa.Eval.Gang+ Data.Repa.Eval.Generic.Seq+ Data.Repa.Eval.Generic.Par++ Other-modules:+ Data.Repa.Eval.Generic.Seq.Chunked+ Data.Repa.Eval.Generic.Seq.Cursored+ Data.Repa.Eval.Generic.Seq.Reduction++ Data.Repa.Eval.Generic.Par.Chunked+ Data.Repa.Eval.Generic.Par.Cursored+ Data.Repa.Eval.Generic.Par.Reduction+ Data.Repa.Eval.Generic.Par.Interleaved++ ghc-options:+ -Wall -fno-warn-missing-signatures+ -O2++ extensions:+ NoMonomorphismRestriction+ BangPatterns+ MagicHash+ UnboxedTuples+ ScopedTypeVariables+ PatternGuards+ FlexibleInstances+ TypeOperators+ FlexibleContexts+ DefaultSignatures+