diff --git a/Data/Array/Parallel/Base.hs b/Data/Array/Parallel/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Base.hs @@ -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) + diff --git a/Data/Array/Parallel/Base/Config.hs b/Data/Array/Parallel/Base/Config.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Base/Config.hs @@ -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 + diff --git a/Data/Array/Parallel/Base/DTrace.hs b/Data/Array/Parallel/Base/DTrace.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Base/DTrace.hs @@ -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 + diff --git a/Data/Array/Parallel/Base/Debug.hs b/Data/Array/Parallel/Base/Debug.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Base/Debug.hs @@ -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" + diff --git a/Data/Array/Parallel/Base/Text.hs b/Data/Array/Parallel/Base/Text.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Base/Text.hs @@ -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 + diff --git a/Data/Array/Parallel/Base/TracePrim.hs b/Data/Array/Parallel/Base/TracePrim.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Base/TracePrim.hs @@ -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 + + + diff --git a/Data/Array/Parallel/Base/Util.hs b/Data/Array/Parallel/Base/Util.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Base/Util.hs @@ -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 + diff --git a/Data/Array/Parallel/Stream.hs b/Data/Array/Parallel/Stream.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Stream.hs @@ -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) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/dph-base.cabal b/dph-base.cabal new file mode 100644 --- /dev/null +++ b/dph-base.cabal @@ -0,0 +1,51 @@ +Name: dph-base +Version: 0.5.1.1 +License: BSD3 +License-File: LICENSE +Author: The DPH Team +Maintainer: Ben Lippmeier +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.* + diff --git a/include/fusion-phases.h b/include/fusion-phases.h new file mode 100644 --- /dev/null +++ b/include/fusion-phases.h @@ -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] +