dph-base (empty) → 0.5.1.1
raw patch · 12 files changed
+1007/−0 lines, 12 filesdep +arraydep +basedep +ghc-primsetup-changed
Dependencies added: array, base, ghc-prim, random, vector
Files
- Data/Array/Parallel/Base.hs +25/−0
- Data/Array/Parallel/Base/Config.hs +27/−0
- Data/Array/Parallel/Base/DTrace.hs +90/−0
- Data/Array/Parallel/Base/Debug.hs +90/−0
- Data/Array/Parallel/Base/Text.hs +21/−0
- Data/Array/Parallel/Base/TracePrim.hs +85/−0
- Data/Array/Parallel/Base/Util.hs +37/−0
- Data/Array/Parallel/Stream.hs +525/−0
- LICENSE +37/−0
- Setup.hs +3/−0
- dph-base.cabal +51/−0
- include/fusion-phases.h +16/−0
+ Data/Array/Parallel/Base.hs view
@@ -0,0 +1,25 @@+-- | Basic functionality, imported by most modules.+module Data.Array.Parallel.Base (+ -- * Debugging infrastructure+ module Data.Array.Parallel.Base.Debug,++ -- * Data constructor tags+ module Data.Array.Parallel.Base.Util,++ -- * Utils for defining Read\/Show instances.+ module Data.Array.Parallel.Base.Text,++ -- * Tracing infrastructure+ module Data.Array.Parallel.Base.DTrace,+ module Data.Array.Parallel.Base.TracePrim,+ + -- * ST monad re-exported from GHC+ ST(..), runST+) where+import Data.Array.Parallel.Base.Debug+import Data.Array.Parallel.Base.Util+import Data.Array.Parallel.Base.Text+import Data.Array.Parallel.Base.DTrace+import Data.Array.Parallel.Base.TracePrim+import GHC.ST (ST(..), runST)+
+ Data/Array/Parallel/Base/Config.hs view
@@ -0,0 +1,27 @@+-- | Top level hard-wired configuration flags.+-- TODO: This should be generated by the make system+module Data.Array.Parallel.Base.Config (+ debug+ , debugCritical+ , tracePrimEnabled+) where+++-- | Enable internal consistency checks for operations that could+-- corrupt the heap.+debugCritical :: Bool+debugCritical = False+++-- | Enable internal consistency checks.+-- This is NOT implied by `debugCritical` above. If you want both+-- you need to set both to `True.`+debug :: Bool+debug = False+++-- | Print tracing information for each DPH primitive to console.+-- The tracing hooks are in dph-prim-par/D/A/P/Unlifted.hs+tracePrimEnabled :: Bool+tracePrimEnabled = False+
+ Data/Array/Parallel/Base/DTrace.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ForeignFunctionInterface, CPP #-}++-- | Harness for DTrace.+module Data.Array.Parallel.Base.DTrace (+ traceLoopEntry, traceLoopExit,++ traceLoopST, traceLoopEntryST, traceLoopExitST,+ traceLoopIO, traceLoopEntryIO, traceLoopExitIO,++ traceFn, traceArg, traceF+) where++#ifdef DPH_ENABLE_DTRACE+import Foreign+import Foreign.C.Types+import Foreign.C.String+#endif++import GHC.ST ( ST )+import GHC.IO ( unsafeIOToST )++import Debug.Trace ( trace )++traceLoopST :: String -> ST s a -> ST s a+{-# INLINE traceLoopST #-}+traceLoopST s p = do+ traceLoopEntryST s+ x <- p+ traceLoopExitST s+ return x++traceLoopIO :: String -> IO a -> IO a+{-# INLINE traceLoopIO #-}+traceLoopIO s p = do+ traceLoopEntryIO s+ x <- p+ traceLoopExitIO s+ return x+++traceLoopEntryST :: String -> ST s ()+traceLoopExitST :: String -> ST s ()++traceLoopEntryIO :: String -> IO ()+traceLoopExitIO :: String -> IO ()++traceLoopEntry :: String -> a -> a+traceLoopExit :: String -> a -> a++#ifdef DPH_ENABLE_DTRACE++traceLoopEntry s x = unsafePerformIO (traceLoopEntryIO s >> return x)+traceLoopExit s x = unsafePerformIO (traceLoopExitIO s >> return x)++traceLoopEntryST s = unsafeIOToST (traceLoopEntryIO s)+traceLoopExitST s = unsafeIOToST (traceLoopExitIO s)++traceLoopEntryIO s = withCString s dph_loop_entry+traceLoopExitIO s = withCString s dph_loop_exit++foreign import ccall safe dph_loop_entry :: Ptr CChar -> IO ()+foreign import ccall safe dph_loop_exit :: Ptr CChar -> IO () ++#else++traceLoopEntry s x = x+traceLoopExit s x = x++traceLoopEntryST s = return ()+traceLoopExitST s = return ()++traceLoopEntryIO s = return ()+traceLoopExitIO s = return ()++#endif+++-- FIXME: make these use DTrace as well+traceFn :: String -> String -> a -> a+-- traceFn fn ty x = trace (fn ++ "<" ++ ty ++ ">") x `seq` trace ("DONE " ++ fn ++ "<" ++ ty ++ ">") x+traceFn _ _ x = x++traceArg :: Show a => String -> a -> b -> b+-- traceArg name arg x = trace (" " ++ name ++ " = " ++ show arg) x+traceArg _ _ x = x++traceF :: String -> a -> a+-- traceF f x = trace f x `seq` trace ("DONE " ++ f) x+traceF _ x = x+
+ Data/Array/Parallel/Base/Debug.hs view
@@ -0,0 +1,90 @@+-- | Debugging infrastructure for the parallel arrays library.+module Data.Array.Parallel.Base.Debug (+ check+ , checkCritical+ , checkLen+ , checkEq+ , checkNotEmpty+ , uninitialised+) where+import Data.Array.Parallel.Base.Config (debug, debugCritical)++outOfBounds :: String -> Int -> Int -> a+outOfBounds loc n i = error $ loc ++ ": Out of bounds (size = "+ ++ show n ++ "; index = " ++ show i ++ ")"++-- | Bounds check, enabled when `debug` = `True`.+-- +-- The first integer is the length of the array, and the second+-- is the index. The second must be greater or equal to '0' and less than the+-- first integer. If the not then `error` with the `String`.+--+check :: String -> Int -> Int -> a -> a+{-# INLINE check #-}+check loc n i v + | debug = if (i >= 0 && i < n) then v else outOfBounds loc n i+ | otherwise = v+-- FIXME: Interestingly, ghc seems not to be able to optimise this if we test+-- for `not debug' (it doesn't inline the `not'...)+++-- | Bounds check, enabled when `debugCritical` = `True`.+--+-- This version is used to check operations that could corrupt the heap.+-- +-- The first integer is the length of the array, and the second+-- is the index. The second must be greater or equal to '0' and less than the+-- first integer. If the not then `error` with the `String`.+--+checkCritical :: String -> Int -> Int -> a -> a+{-# INLINE checkCritical #-}+checkCritical loc n i v + | debugCritical = if (i >= 0 && i < n) then v else outOfBounds loc n i+ | otherwise = v+++-- | Length check, enabled when `debug` = `True`.+-- +-- Check that the second integer is greater or equal to `0' and less or equal+-- than the first integer. If the not then `error` with the `String`.+--+checkLen :: String -> Int -> Int -> a -> a+{-# INLINE checkLen #-}+checkLen loc n i v + | debug = if (i >= 0 && i <= n) then v else outOfBounds loc n i+ | otherwise = v+++-- | Equality check, enabled when `debug` = `True`.+-- +-- The two `a` values must be equal, else `error`.+--+-- The first `String` gives the location of the error, and the second some helpful message.+--+checkEq :: (Eq a, Show a) => String -> String -> a -> a -> b -> b+checkEq loc msg x y v+ | debug = if x == y then v else err+ | otherwise = v+ where+ err = error $ loc ++ ": " ++ msg+ ++ " (first = " ++ show x+ ++ "; second = " ++ show y ++ ")"+++-- | Given an array length, check it is not zero.+checkNotEmpty :: String -> Int -> a -> a+checkNotEmpty loc n v+ | debug = if n /= 0 then v else err+ | otherwise = v+ where+ err = error $ loc ++ ": Empty array"+++-- | Throw an error saying something was not intitialised.+-- +-- The `String` must contain a helpful message saying what module the error occured in, +-- and the possible reasons for it. If not then a puppy dies at compile time.+--+uninitialised :: String -> a+uninitialised loc = error $ loc ++ ": Touched an uninitialised value"+
+ Data/Array/Parallel/Base/Text.hs view
@@ -0,0 +1,21 @@+-- | Utilities for defining Read\/Show instances.+module Data.Array.Parallel.Base.Text (+ showsApp, readApp, readsApp,+ Read(..)+) where+import Text.Read++showsApp :: Show a => Int -> String -> a -> ShowS+showsApp k fn arg = showParen (k>10) + (showString fn . showChar ' ' . showsPrec 11 arg)++readApp :: Read a => String -> ReadPrec a+readApp fn = parens (prec 10 $+ do+ Ident ide <- lexP+ if ide /= fn then pfail else step readPrec+ )++readsApp :: Read a => Int -> String -> ReadS a+readsApp k fn = readPrec_to_S (readApp fn) k+
+ Data/Array/Parallel/Base/TracePrim.hs view
@@ -0,0 +1,85 @@+-- | When `tracePrimEnabled` in "Data.Array.Parallel.Config" is @True@, DPH programs will print+-- out what array primitives they're using at runtime. See `tracePrim` for details.+module Data.Array.Parallel.Base.TracePrim+ ( tracePrim+ , TracePrim(..))+where+import Data.Array.Parallel.Base.Config+import qualified Debug.Trace++-- | Print tracing information to console.+--+-- This function is used to wrap the calls to DPH primitives defined+-- in @dph-prim-par@:"Data.Array.Parallel.Unlifted"+--+-- Tracing is only enabled when `tracePrimEnabled` in "Data.Array.Parallel.Base.Config" is `True`,+-- otherwise it's a no-op.+-- +tracePrim :: TracePrim -> a -> a+tracePrim tr x+ | tracePrimEnabled = Debug.Trace.trace (Prelude.show tr) x+ | otherwise = x+ ++-- | Records information about the use of a primitive operator.+--+-- These are the operator names that the vectoriser introduces.+-- The actual implementation of each operator varies depending on what DPH backend we're using.+-- We only trace operators that are at least O(n) in complexity. +data TracePrim+ = TraceReplicate { traceCount :: Int}+ | TraceRepeat { traceCount :: Int, traceSrcLength :: Int }+ | TraceIndex { traceIndex :: Int, traceSrcLength :: Int }+ | TraceExtract { traceStart :: Int, traceSliceLength :: Int, traceSrcLength :: Int }+ | TraceDrop { traceCount :: Int, traceSrcLength :: Int }+ | TracePermute { traceSrcLength :: Int }+ | TraceBPermuteDft { traceSrcLength :: Int }+ | TraceBPermute { traceSrcLength :: Int }+ | TraceMBPermute { traceSrcLength :: Int }+ | TraceUpdate { traceSrcLength :: Int, traceModLength :: Int }+ | TraceAppend { traceDstLength :: Int }+ | TraceInterleave { traceDstLength :: Int }+ | TracePack { traceSrcLength :: Int }+ | TraceCombine { traceSrcLength :: Int }+ | TraceCombine2 { traceSrcLength :: Int }+ | TraceMap { traceSrcLength :: Int }+ | TraceFilter { traceSrcLength :: Int, traceDstLength :: Int }+ | TraceZipWith { traceSrc1Length :: Int, traceSrc2Length :: Int }+ | TraceFold { traceSrcLength :: Int }+ | TraceFold1 { traceSrcLength :: Int }+ | TraceAnd { traceSrcLength :: Int }+ | TraceSum { traceSrcLength :: Int }+ | TraceScan { traceSrcLength :: Int }+ | TraceIndexed { traceSrcLength :: Int }++ -- Enumerations.+ | TraceEnumFromTo { traceDstLength :: Int }+ | TraceEnumFromThenTo { traceDstLength :: Int }+ | TraceEnumFromStepLen { traceDstLength :: Int }+ | TraceEnumFromStepLenEach { traceDstLength :: Int }++ -- Selectors.+ | TraceMkSel2 { traceSrcLength :: Int }+ | TraceTagsSel2 { traceDstLength :: Int }+ | TraceIndicesSel2 { traceDstLength :: Int }+ | TraceElementsSel2_0 { traceSrcLength :: Int }+ | TraceElementsSel2_1 { traceSrcLength :: Int }++ | TraceMkSelRep2 { traceSrcLength :: Int }+ | TraceIndicesSelRep2 { traceSrcLength :: Int }+ | TraceElementsSelRep2_0 { traceSrcLength :: Int }+ | TraceElementsSelRep2_1 { traceSrcLength :: Int }+ + -- Operations on segmented arrays.+ | TraceReplicate_s { traceSrcLength :: Int }+ | TraceReplicate_rs { traceCount :: Int, traceSrcLength :: Int }+ | TraceAppend_s { traceDstLength :: Int }+ | TraceFold_s { traceSrcLength :: Int }+ | TraceFold1_s { traceSrcLength :: Int }+ | TraceFold_r { traceSrcLength :: Int }+ | TraceSum_r { traceSrcLength :: Int }+ | TraceIndices_s { traceDstLength :: Int }+ deriving Prelude.Show+++
+ Data/Array/Parallel/Base/Util.hs view
@@ -0,0 +1,37 @@++-- | Constructor tags.+module Data.Array.Parallel.Base.Util (+ Tag, fromBool, toBool, tagToInt, intToTag+) where+import Data.Word ( Word8 )+++-- | Given a value of an algebraic type, the tag tells us what+-- data constructor was used to create it.+type Tag = Int+++-- | Get the `Tag` of a `Bool` value. `False` is 0, `True` is 1.+{-# INLINE fromBool #-}+fromBool :: Bool -> Tag+fromBool False = 0+fromBool True = 1+++-- | Convert a `Tag` to a `Bool` value.+{-# INLINE toBool #-}+toBool :: Tag -> Bool+toBool n | n == 0 = False+ | otherwise = True+++-- | Convert a `Tag` to an `Int`. This is identity at the value level.+{-# INLINE tagToInt #-}+tagToInt :: Tag -> Int+tagToInt = id++-- | Convert an `Int` to a `Tag`. This is identity at the value level.+{-# INLINE intToTag #-}+intToTag :: Int -> Tag+intToTag = id+
+ Data/Array/Parallel/Stream.hs view
@@ -0,0 +1,525 @@+-- | Stream functions not implemented in @Data.Vector@+#include "fusion-phases.h"++module Data.Array.Parallel.Stream (++ -- * Flat stream operators+ indexedS, replicateEachS, replicateEachRS,+ interleaveS, combine2ByTagS,+ enumFromToEachS, enumFromStepLenEachS,+ + -- * Segmented stream operators+ foldSS, fold1SS, combineSS, appendSS,+ foldValuesR,+ indicesSS+) where+import Data.Array.Parallel.Base ( Tag )+import qualified Data.Vector.Fusion.Stream as S+import Data.Vector.Fusion.Stream.Monadic ( Stream(..), Step(..) )+import Data.Vector.Fusion.Stream.Size ( Size(..) )++-- TODO: The use of INLINE pragmas in some of these function isn't consistent.+-- for indexedS and combine2ByTagS, there is an INLINE_INNER on the 'next'+-- function, but replicateEachS uses a plain INLINE and fold1SS uses+-- a hard INLINE [0]. Can we make a rule that all top-level stream functions+-- in this module have INLINE_STREAM, and all 'next' functions have+-- INLINE_INNER? If not we should document the reasons for the special cases.+--+--+-- Note: [NEVER ENTERED]+-- ~~~~~~~~~~~~~~~~~~~~~+-- Cases marked NEVER ENTERED should be unreachable, assuming there are no +-- bugs elsewhere in the library. We used to throw an error when these+-- branches were entered, but this was confusing the simplifier. It would be +-- better if we could put the errors back, but we'll need to check that +-- performance does not regress when we do so.+--++-- | Tag each element of an stream with its index in that stream.+--+-- @+-- indexed [42,93,13]+-- = [(0,42), (1,93), (2,13)]+-- @+indexedS :: S.Stream a -> S.Stream (Int,a)+{-# INLINE_STREAM indexedS #-}+indexedS (Stream next s n) = Stream next' (0,s) n+ where+ {-# INLINE_INNER next' #-}+ next' (i,s) = do+ r <- next s+ case r of+ Yield x s' -> return $ Yield (i,x) (i+1,s')+ Skip s' -> return $ Skip (i,s')+ Done -> return Done+++-- | Given a stream of pairs containing a count an an element,+-- replicate element the number of times given by the count.+--+-- The first parameter sets the size hint of the resulting stream.+-- +-- @+-- replicateEach 10 [(2,10), (5,20), (3,30)]+-- = [10,10,20,20,20,20,20,30,30,30]+-- @+replicateEachS :: Int -> S.Stream (Int,a) -> S.Stream a+{-# INLINE_STREAM replicateEachS #-}+replicateEachS n (Stream next s _) =+ Stream next' (0,Nothing,s) (Exact n)+ where+ {-# INLINE next' #-}+ next' (0, _, s) =+ do+ r <- next s+ case r of+ Done -> return Done+ Skip s' -> return $ Skip (0, Nothing, s')+ Yield (k,x) s' -> return $ Skip (k, Just x,s')+ next' (k,Nothing,s) = return Done -- NEVER ENTERED (See Note)+ next' (k,Just x,s) = return $ Yield x (k-1,Just x,s)+++-- | Repeat each element in the stream the given number of times.+--+-- @+-- replicateEach 2 [10,20,30]+-- = [10,10,20,20,30,30]+-- @+--+replicateEachRS :: Int -> S.Stream a -> S.Stream a+{-# INLINE_STREAM replicateEachRS #-}+replicateEachRS !n (Stream next s sz)+ = Stream next' (0,Nothing,s) (sz `multSize` n)+ where+ next' (0,_,s) =+ do+ r <- next s+ case r of+ Done -> return Done+ Skip s' -> return $ Skip (0,Nothing,s')+ Yield x s' -> return $ Skip (n,Just x,s')+ next' (i,Nothing,s) = return Done -- NEVER ENTERED (See Note)+ next' (i,Just x,s) = return $ Yield x (i-1,Just x,s)+++-- | Multiply a size hint by a scalar.+multSize :: Size -> Int -> Size+multSize (Exact n) k = Exact (n*k)+multSize (Max n) k = Max (n*k)+multSize Unknown _ = Unknown+++-- | Interleave the elements of two streams. We alternate between the first+-- and second streams, stopping when we can't find a matching element.+--+-- @+-- interleave [2,3,4] [10,20,30] = [2,10,3,20,4,30]+-- interleave [2,3] [10,20,30] = [2,10,3,20]+-- interleave [2,3,4] [10,20] = [2,10,3,20,4]+-- @+--+interleaveS :: S.Stream a -> S.Stream a -> S.Stream a+{-# INLINE_STREAM interleaveS #-}+interleaveS (Stream next1 s1 n1) (Stream next2 s2 n2)+ = Stream next (False,s1,s2) (n1+n2)+ where+ {-# INLINE next #-}+ next (False,s1,s2) =+ do+ r <- next1 s1+ case r of+ Yield x s1' -> return $ Yield x (True ,s1',s2)+ Skip s1' -> return $ Skip (False,s1',s2)+ Done -> return Done++ next (True,s1,s2) =+ do+ r <- next2 s2+ case r of+ Yield x s2' -> return $ Yield x (False,s1,s2')+ Skip s2' -> return $ Skip (True ,s1,s2')+ Done -> return Done -- NEVER ENTERED (See Note)+++-- | Combine two streams, using a tag stream to tell us which of the data+-- streams to take the next element from.+--+-- If there are insufficient elements in the data strams for the provided+-- tag stream then `error`.+-- +-- @+-- combine2ByTag [0,1,1,0,0,1] [1,2,3] [4,5,6]+-- = [1,4,5,2,3,6]+-- @+--+combine2ByTagS :: S.Stream Tag -> S.Stream a -> S.Stream a -> S.Stream a+{-# INLINE_STREAM combine2ByTagS #-}+combine2ByTagS (Stream next_tag s m) (Stream next0 s0 _)+ (Stream next1 s1 _)+ = Stream next (Nothing,s,s0,s1) m+ where+ {-# INLINE_INNER next #-}+ next (Nothing,s,s0,s1)+ = do+ r <- next_tag s+ case r of+ Done -> return Done+ Skip s' -> return $ Skip (Nothing,s',s0,s1)+ Yield t s' -> return $ Skip (Just t, s',s0,s1)++ next (Just 0,s,s0,s1)+ = do+ r <- next0 s0+ case r of+ Done -> error "combine2ByTagS: stream 1 too short"+ Skip s0' -> return $ Skip (Just 0, s,s0',s1)+ Yield x s0' -> return $ Yield x (Nothing,s,s0',s1)++ next (Just t,s,s0,s1)+ = do+ r <- next1 s1+ case r of+ Done -> error "combine2ByTagS: stream 2 too short"+ Skip s1' -> return $ Skip (Just t, s,s0,s1')+ Yield x s1' -> return $ Yield x (Nothing,s,s0,s1')+++-- | Create a stream of integer ranges. The pairs in the input stream+-- give the first and last value of each range.+--+-- The first parameter gives the size hint for the resulting stream.+-- +-- @+-- enumFromToEach 11 [(2,5), (10,16), (20,22)]+-- = [2,3,4,5,10,11,12,13,14,15,16,20,21,22]+-- @+--+enumFromToEachS :: Int -> S.Stream (Int,Int) -> S.Stream Int+{-# INLINE_STREAM enumFromToEachS #-}+enumFromToEachS n (Stream next s _) + = Stream next' (Nothing,s) (Exact n)+ where+ {-# INLINE_INNER next' #-}+ next' (Nothing,s)+ = do+ r <- next s+ case r of+ Yield (k,m) s' -> return $ Skip (Just (k,m),s')+ Skip s' -> return $ Skip (Nothing, s')+ Done -> return Done++ next' (Just (k,m),s)+ | k > m = return $ Skip (Nothing, s)+ | otherwise = return $ Yield k (Just (k+1,m),s)+++-- | Create a stream of integer ranges. The triples in the input stream+-- give the first value, increment, length of each range.+--+-- The first parameter gives the size hint for the resulting stream.+--+-- @+-- enumFromStepLenEach [(1,1,5), (10,2,4), (20,3,5)]+-- = [1,2,3,4,5,10,12,14,16,20,23,26,29,32]+-- @+-- +enumFromStepLenEachS :: Int -> S.Stream (Int,Int,Int) -> S.Stream Int +{-# INLINE_STREAM enumFromStepLenEachS #-}+enumFromStepLenEachS len (Stream next s _)+ = Stream next' (Nothing,s) (Exact len)+ where+ {-# INLINE_INNER next' #-}+ next' (Nothing,s) + = do+ r <- next s+ case r of+ Yield (from,step,len) s' -> return $ Skip (Just (from,step,len),s')+ Skip s' -> return $ Skip (Nothing,s')+ Done -> return Done++ next' (Just (from,step,0),s) = return $ Skip (Nothing,s)+ next' (Just (from,step,n),s)+ = return $ Yield from (Just (from+step,step,n-1),s)+++-- | Segmented Stream fold. Take segments from the given stream and fold each+-- using the supplied function and initial element. +--+-- @+-- foldSS (+) 0 [2, 3, 2] [10, 20, 30, 40, 50, 60, 70]+-- = [30,120,130]+-- @+--+foldSS :: (a -> b -> a) -- ^ function to perform the fold+ -> a -- ^ initial element of each fold+ -> S.Stream Int -- ^ stream of segment lengths+ -> S.Stream b -- ^ stream of input data+ -> S.Stream a -- ^ stream of fold results+ +{-# INLINE_STREAM foldSS #-}+foldSS f z (Stream nexts ss sz) (Stream nextv vs _) =+ Stream next (Nothing,z,ss,vs) sz+ where+ {-# INLINE next #-}+ next (Nothing,x,ss,vs) =+ do+ r <- nexts ss+ case r of+ Done -> return Done+ Skip ss' -> return $ Skip (Nothing,x, ss', vs)+ Yield n ss' -> return $ Skip (Just n, z, ss', vs)++ next (Just 0,x,ss,vs) =+ return $ Yield x (Nothing,z,ss,vs)+ next (Just n,x,ss,vs) =+ do+ r <- nextv vs+ case r of+ Done -> return Done -- NEVER ENTERED (See Note)+ Skip vs' -> return $ Skip (Just n,x,ss,vs')+ Yield y vs' -> let r = f x y+ in r `seq` return (Skip (Just (n-1), r, ss, vs'))+++-- | Like `foldSS`, but use the first member of each chunk as the initial+-- element for the fold.+fold1SS :: (a -> a -> a) -> S.Stream Int -> S.Stream a -> S.Stream a+{-# INLINE_STREAM fold1SS #-}+fold1SS f (Stream nexts ss sz) (Stream nextv vs _) =+ Stream next (Nothing,Nothing,ss,vs) sz+ where+ {-# INLINE [0] next #-}+ next (Nothing,Nothing,ss,vs) =+ do+ r <- nexts ss+ case r of+ Done -> return Done+ Skip ss' -> return $ Skip (Nothing,Nothing,ss',vs)+ Yield n ss' -> return $ Skip (Just n ,Nothing,ss',vs)++ next (Just !n,Nothing,ss,vs) =+ do+ r <- nextv vs+ case r of+ Done -> return Done -- NEVER ENTERED (See Note)+ Skip vs' -> return $ Skip (Just n, Nothing,ss,vs')+ Yield x vs' -> return $ Skip (Just (n-1),Just x, ss,vs')++ next (Just 0,Just x,ss,vs) =+ return $ Yield x (Nothing,Nothing,ss,vs)++ next (Just n,Just x,ss,vs) =+ do+ r <- nextv vs+ case r of+ Done -> return Done -- NEVER ENTERED (See Note)+ Skip vs' -> return $ Skip (Just n ,Just x ,ss,vs')+ Yield y vs' -> let r = f x y+ in r `seq` return (Skip (Just (n-1),Just r,ss,vs'))+++-- | Segmented Stream combine. Like `combine2ByTagS`, except that the tags select+-- entire segments of each data stream, instead of selecting one element at a time.+--+-- @+-- combineSS [True, True, False, True, False, False]+-- [2,1,3] [10,20,30,40,50,60]+-- [1,2,3] [11,22,33,44,55,66]+-- = [10,20,30,11,40,50,60,22,33,44,55,66]+-- @+--+-- This says take two elements from the first stream, then another one element +-- from the first stream, then one element from the second stream, then three+-- elements from the first stream...+--+combineSS + :: S.Stream Bool -- ^ tag values+ -> S.Stream Int -- ^ segment lengths for first data stream+ -> S.Stream a -- ^ first data stream+ -> S.Stream Int -- ^ segment lengths for second data stream+ -> S.Stream a -- ^ second data stream+ -> S.Stream a++{-# INLINE_STREAM combineSS #-}+combineSS (Stream nextf sf _) + (Stream nexts1 ss1 _) (Stream nextv1 vs1 nv1)+ (Stream nexts2 ss2 _) (Stream nextv2 vs2 nv2)+ = Stream next (Nothing,True,sf,ss1,vs1,ss2,vs2)+ (nv1+nv2)+ where+ {-# INLINE next #-}+ next (Nothing,f,sf,ss1,vs1,ss2,vs2) =+ do+ r <- nextf sf+ case r of+ Done -> return Done+ Skip sf' -> return $ Skip (Nothing,f,sf',ss1,vs1,ss2,vs2) + Yield c sf'+ | c ->+ do+ r <- nexts1 ss1+ case r of+ Done -> return Done+ Skip ss1' -> return $ Skip (Nothing,f,sf,ss1',vs1,ss2,vs2) + Yield n ss1' -> return $ Skip (Just n,c,sf',ss1',vs1,ss2,vs2) ++ | otherwise ->+ do+ r <- nexts2 ss2+ case r of+ Done -> return Done+ Skip ss2' -> return $ Skip (Nothing,f,sf,ss1,vs1,ss2',vs2) + Yield n ss2' -> return $ Skip (Just n,c,sf',ss1,vs1,ss2',vs2)++ next (Just 0,_,sf,ss1,vs1,ss2,vs2) =+ return $ Skip (Nothing,True,sf,ss1,vs1,ss2,vs2)++ next (Just n,True,sf,ss1,vs1,ss2,vs2) =+ do+ r <- nextv1 vs1+ case r of+ Done -> return Done+ Skip vs1' -> return $ Skip (Just n,True,sf,ss1,vs1',ss2,vs2) + Yield x vs1' -> return $ Yield x (Just (n-1),True,sf,ss1,vs1',ss2,vs2)++ next (Just n,False,sf,ss1,vs1,ss2,vs2) =+ do+ r <- nextv2 vs2+ case r of+ Done -> return Done+ Skip vs2' -> return $ Skip (Just n,False,sf,ss1,vs1,ss2,vs2') + Yield x vs2' -> return $ Yield x (Just (n-1),False,sf,ss1,vs1,ss2,vs2')+++-- | Segmented Strem append. Append corresponding segments from each stream.+--+-- @+-- appendSS [2, 1, 3] [10, 20, 30, 40, 50, 60]+-- [1, 3, 2] [11, 22, 33, 44, 55, 66]+-- = [10,20,11,30,22,33,44,40,50,60,55,66]+-- @+--+appendSS+ :: S.Stream Int -- ^ segment lengths for first data stream+ -> S.Stream a -- ^ first data stream+ -> S.Stream Int -- ^ segment lengths for second data stream+ -> S.Stream a -- ^ second data stream+ -> S.Stream a++{-# INLINE_STREAM appendSS #-}+appendSS (Stream nexts1 ss1 ns1) (Stream nextv1 sv1 nv1)+ (Stream nexts2 ss2 ns2) (Stream nextv2 sv2 nv2)+ = Stream next (True,Nothing,ss1,sv1,ss2,sv2) (nv1 + nv2)+ where+ {-# INLINE next #-}+ next (True,Nothing,ss1,sv1,ss2,sv2) =+ do+ r <- nexts1 ss1+ case r of+ Done -> return $ Done+ Skip ss1' -> return $ Skip (True,Nothing,ss1',sv1,ss2,sv2)+ Yield n ss1' -> return $ Skip (True,Just n ,ss1',sv1,ss2,sv2)++ next (True,Just 0,ss1,sv1,ss2,sv2)+ = return $ Skip (False,Nothing,ss1,sv1,ss2,sv2)++ next (True,Just n,ss1,sv1,ss2,sv2) =+ do+ r <- nextv1 sv1+ case r of+ Done -> return Done -- NEVER ENTERED (See Note)+ Skip sv1' -> return $ Skip (True,Just n,ss1,sv1',ss2,sv2)+ Yield x sv1' -> return $ Yield x (True,Just (n-1),ss1,sv1',ss2,sv2)++ next (False,Nothing,ss1,sv1,ss2,sv2) =+ do+ r <- nexts2 ss2+ case r of+ Done -> return Done -- NEVER ENTERED (See Note)+ Skip ss2' -> return $ Skip (False,Nothing,ss1,sv1,ss2',sv2)+ Yield n ss2' -> return $ Skip (False,Just n,ss1,sv1,ss2',sv2)++ next (False,Just 0,ss1,sv1,ss2,sv2)+ = return $ Skip (True,Nothing,ss1,sv1,ss2,sv2)++ next (False,Just n,ss1,sv1,ss2,sv2) =+ do+ r <- nextv2 sv2+ case r of+ Done -> return Done -- NEVER ENTERED (See Note)+ Skip sv2' -> return $ Skip (False,Just n,ss1,sv1,ss2,sv2')+ Yield x sv2' -> return $ Yield x (False,Just (n-1),ss1,sv1,ss2,sv2')+++-- | Segmented Stream fold, with a fixed segment length.+-- +-- Like `foldSS` but use a fixed length for each segment.+--+foldValuesR + :: (a -> b -> a) -- ^ function to perform the fold+ -> a -- ^ initial element for fold+ -> Int -- ^ length of each segment+ -> S.Stream b -- ^ data stream+ -> S.Stream a++{-# INLINE_STREAM foldValuesR #-}+foldValuesR f z segSize (Stream nextv vs nv) =+ Stream next (segSize,z,vs) (nv `divSize` segSize)+ where+ {-# INLINE next #-} + next (0,x,vs) = return $ Yield x (segSize,z,vs)++ next (n,x,vs) =+ do+ r <- nextv vs+ case r of+ Done -> return Done+ Skip vs' -> return $ Skip (n,x,vs')+ Yield y vs' -> let r = f x y+ in r `seq` return (Skip ((n-1),r,vs'))+++-- | Divide a size hint by a scalar.+divSize :: Size -> Int -> Size+divSize (Exact n) k = Exact (n `div` k)+divSize (Max n) k = Max (n `div` k)+divSize Unknown _ = Unknown+++-- | Segmented Stream indices.+-- +-- @+-- indicesSS 15 4 [3, 5, 7]+-- = [4,5,6,0,1,2,3,4,0,1,2,3,4,5,6]+-- @+--+-- Note that we can set the starting value of the first segment independently+-- via the second argument of indicesSS. We use this when distributing arrays+-- across worker threads, as a thread's chunk may not start exactly at a +-- segment boundary, so the index of a thread's first data element may not be+-- zero.+--+indicesSS + :: Int+ -> Int+ -> S.Stream Int+ -> S.Stream Int++{-# INLINE_STREAM indicesSS #-}+indicesSS n i (Stream next s _) =+ Stream next' (i,Nothing,s) (Exact n)+ where+ {-# INLINE next' #-}+ next' (i,Nothing,s) =+ do+ r <- next s+ case r of+ Done -> return Done+ Skip s' -> return $ Skip (i,Nothing,s')+ Yield k s' -> return $ Skip (i,Just k,s')++ next' (i,Just k,s)+ | k > 0 = return $ Yield i (i+1,Just (k-1),s)+ | otherwise = return $ Skip (0 ,Nothing ,s)+
+ LICENSE view
@@ -0,0 +1,37 @@+Copyright (c) 2001-2011, The DPH Team+All rights reserved.++The DPH Team is:+ Manuel M T Chakravarty+ Gabriele Keller+ Roman Leshchinskiy+ Ben Lippmeier+ George Roldugin++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.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "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+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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,3 @@+import Distribution.Simple+main = defaultMain+
+ dph-base.cabal view
@@ -0,0 +1,51 @@+Name: dph-base+Version: 0.5.1.1+License: BSD3+License-File: LICENSE+Author: The DPH Team+Maintainer: Ben Lippmeier <benl@cse.unsw.edu.au>+Homepage: http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell+Category: Data Structures+Synopsis: Common utilities and config for Data Parallel Haskell++Cabal-Version: >= 1.6+Build-Type: Simple++Flag DTrace+ Description: Enable experimental support for dtrace-based profiling+ Default: False++Library+ Exposed-Modules:+ Data.Array.Parallel.Base+ Data.Array.Parallel.Stream+ Data.Array.Parallel.Base.DTrace+ Data.Array.Parallel.Base.TracePrim++ Other-Modules:+ Data.Array.Parallel.Base.Config+ Data.Array.Parallel.Base.Debug+ Data.Array.Parallel.Base.Util+ Data.Array.Parallel.Base.Text++ Include-Dirs:+ include++ Install-Includes:+ fusion-phases.h++ Exposed: True++ Extensions: + TypeFamilies, GADTs, RankNTypes,+ BangPatterns, MagicHash, UnboxedTuples, TypeOperators, CPP++ GHC-Options: -Odph -funbox-strict-fields -fcpr-off ++ Build-Depends: + base == 4.4.*,+ ghc-prim == 0.2.*,+ array == 0.3.*,+ random == 1.0.*,+ vector == 0.7.*+
+ include/fusion-phases.h view
@@ -0,0 +1,16 @@+#define INLINE_U INLINE+#define INLINE_UP INLINE+#define INLINE_STREAM INLINE [1]+#define INLINE_DIST INLINE [1]+#define INLINE_PA INLINE+#define INLINE_BACKEND INLINE [2]+#define INLINE_INNER INLINE [0]++#define PHASE_PA+#define PHASE_BACKEND [2]+#define PHASE_DIST [1]+#define PHASE_STREAM [1]+#define PHASE_INNER [0]++#define UNTIL_PHASE_BACKEND [~2]+