dph-base 0.5.1.1 → 0.6.0.1

raw patch · 13 files changed

+433/−660 lines, 13 filesdep +prettydep ~arraydep ~basedep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: pretty

Dependency ranges changed: array, base, vector

API changes (from Hackage documentation)

Files

• Data/Array/Parallel/Array.hs +121/−0
• Data/Array/Parallel/Base.hs +13/−20
• Data/Array/Parallel/Base/Config.hs +7/−8
• Data/Array/Parallel/Base/Debug.hs +84/−34
• Data/Array/Parallel/Base/Tag.hs +41/−0
• Data/Array/Parallel/Base/Text.hs +15/−11
• Data/Array/Parallel/Base/TracePrim.hs +9/−5
• Data/Array/Parallel/Base/Util.hs +0/−37
• Data/Array/Parallel/Pretty.hs +57/−0
• Data/Array/Parallel/Stream.hs +0/−525
• LICENSE +1/−2
• dph-base.cabal +18/−10
• include/fusion-phases.h +67/−8

@@ -0,0 +1,121 @@++-- | Generic array class.+--   This is used as a compatability layer during testing and debugging.+module Data.Array.Parallel.Array +        ( Array(..)+        , fromList, toList+        , toVectors1,   toVectors2,   toVectors3+        , fromVectors1, fromVectors2, fromVectors3)+where   +import Control.Monad+import Data.Vector              (Vector)+import qualified Data.Vector    as V+import qualified Prelude        as P+import Prelude                  hiding (length)+++class Array a e where+ -- | Check whether an array has a valid internal representation.+ valid      :: a e -> Bool++ -- | Yield an array with just a single element.+ singleton  :: e   -> a e++ -- | Append two arrays.+ append     :: a e -> a e -> a e++ -- | Yield the length of an array.+ length     :: a e -> Int++ -- | Retrieve the element at the given index. + index      :: a e -> Int -> e++ -- | Convert an array to a vector.+ toVector   :: a e -> Vector e++ -- | Convert a vector to an array.+ fromVector :: Vector e -> a e+ ++instance Array [] e where+ valid          = const True+ singleton x    = [x]+ length         = P.length+ index          = (P.!!)+ append         = (P.++)+ toVector       = V.fromList+ fromVector     = V.toList+ ++instance Array Vector e where+ valid          = const True+ singleton      = V.singleton+ length         = V.length+ index          = (V.!)+ append         = (V.++)+ toVector       = id+ fromVector     = id+++-- | Convert a list to an array.+fromList :: Array a e => [e] -> a e+fromList = fromVector . V.fromList+++-- | Convert an array to a list.+toList   :: Array a e => a e -> [e]+toList   = V.toList . toVector+++-- | Convert the outer level of an array to vectors.+toVectors1 +        :: Array a e+        => a e -> Vector e++toVectors1 arr+        = toVector arr+        +        +-- | Convert the outer two levels of an array to vectors.+toVectors2 +        :: (Array a1 (a2 e), Array a2 e)+        => a1 (a2 e) -> Vector (Vector e)++toVectors2 = V.map toVector . toVector+        ++-- | Convert the outer three levels of an array to vectors.+toVectors3+        :: (Array a1 (a2 (a3 e)), Array a2 (a3 e), Array a3 e)+        => a1 (a2 (a3 e)) -> Vector (Vector (Vector e))++toVectors3 = V.map (V.map toVector) . V.map toVector . toVector +        ++-- | Convert some vectors to an array.+fromVectors1 +        :: Array a e+        => Vector e -> a e++fromVectors1 vec+        = fromVector vec+        ++-- | Convert some vectors to a nested array+fromVectors2 +        :: (Array a1 (a2 e), Array a2 e)+        => Vector (Vector e) -> a1 (a2 e)++fromVectors2+        = fromVector . V.map fromVector+++-- | Convert some vectors to a triply nested array+fromVectors3 +        :: (Array a1 (a2 (a3 e)), Array a2 (a3 e), Array a3 e)+        => Vector (Vector (Vector e)) -> a1 (a2 (a3 e))++fromVectors3+        = fromVector . V.map fromVector . V.map (V.map fromVector)++   

@@ -1,25 +1,18 @@--- | 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,+-- | Common config and debugging functions. Imported by most modules.+module Data.Array.Parallel.Base +        ( -- * Debugging infrastructure+          module Data.Array.Parallel.Base.Config+        , module Data.Array.Parallel.Base.Debug -  -- * Utils for defining Read\/Show instances.-  module Data.Array.Parallel.Base.Text,+          -- * Data constructor rags+        , module Data.Array.Parallel.Base.Tag -  -- * Tracing infrastructure-  module Data.Array.Parallel.Base.DTrace,-  module Data.Array.Parallel.Base.TracePrim,-  -  -- * ST monad re-exported from GHC-  ST(..), runST-) where+          -- * 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 Data.Array.Parallel.Base.Config+import Data.Array.Parallel.Base.Tag import GHC.ST (ST(..), runST) 

@@ -1,11 +1,10 @@ -- | 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-+module Data.Array.Parallel.Base.Config+        ( debugCritical+        , debug+        , tracePrimEnabled)+where  -- | Enable internal consistency checks for operations that could --   corrupt the heap.@@ -20,8 +19,8 @@ debug                   = False  --- | Print tracing information for each DPH primitive to console.---   The tracing hooks are in dph-prim-par/D/A/P/Unlifted.hs+-- | Print tracing information for each flat array primitive to console.+--   The tracing hooks are in `dph-prim-par:Data.Array.Parallel.Unlifted` tracePrimEnabled        :: Bool tracePrimEnabled        = False 

@@ -1,31 +1,48 @@ -- | Debugging infrastructure for the parallel arrays library.-module Data.Array.Parallel.Base.Debug (-    check-  , checkCritical-  , checkLen-  , checkEq-  , checkNotEmpty-  , uninitialised-) where+module Data.Array.Parallel.Base.Debug +        ( check+        , checkCritical+        , checkLen+        , checkSlice+        , 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 ++ ")" +-- | Throw an index-out-of-bounds error.+errorOfBounds :: String -> Int -> Int -> a+errorOfBounds loc n i +        =  error $ loc ++ ": Out of bounds "+                ++ "(vector length = "  ++ show n +                ++ "; index = "         ++ show i ++ ")"+++-- | Throw a bad slice error.+errorBadSlice :: String -> Int -> Int -> Int -> a+errorBadSlice loc vecLen sliceStart sliceLen+        = error $ loc ++ ": Bad slice "+                ++ "(vecLen = "         ++ show vecLen+                ++ "; sliceStart = "    ++ show sliceStart+                ++ "; sliceLen = "     ++ show sliceLen ++ ")"++ -- | 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`.+--   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+  | debug      +  = if i >= 0 && i < n+        then v +        else errorOfBounds 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'...)+{-# INLINE check #-}   -- | Bounds check, enabled when `debugCritical` = `True`.@@ -33,14 +50,18 @@ --   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`.+--   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+  | debugCritical +  = if i >= 0 && i < n+        then v +        else errorOfBounds loc n i+   | otherwise     = v+{-# INLINE checkCritical #-}   -- | Length check, enabled when `debug` = `True`.@@ -49,42 +70,71 @@ --   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+  | debug      +  = if i >= 0 && i <= n +        then v +        else errorOfBounds loc n i+   | otherwise  = v+{-# INLINE checkLen #-}  +-- | Slice check, enable when `debug` = `True`.+--+--   The vector must contain at least `sliceStart` + `sliceLen` elements.+-- +checkSlice :: String -> Int -> Int -> Int -> a -> a+checkSlice loc vecLen sliceStart sliceLen v+  | debug        +  = if   (  sliceStart >= 0             && sliceStart            <= vecLen+         && sliceStart + sliceLen >= 0  && sliceStart + sliceLen <= vecLen )+        then v+        else errorBadSlice loc vecLen sliceStart sliceLen++  | otherwise    = v+{-# INLINE checkSlice #-}++ -- | 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.+--   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+  | debug     +  = if x == y +        then v +        else error $ loc ++ ": " ++ msg                   ++ " (first = " ++ show x                   ++ "; second = " ++ show y ++ ")" +  | otherwise = v+{-# INLINE checkEq #-} + -- | 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+  | debug     +  = if n /= 0 +        then v +        else error $ loc ++ ": Empty array"+   | otherwise = v-  where-    err = error $ loc ++ ": Empty array"+{-# INLINE checkNotEmpty #-}   -- | 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.+--   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"+uninitialised loc +        = error $ loc ++ ": Touched an uninitialised value" 

@@ -0,0 +1,41 @@++-- | Data constructor tags.+module Data.Array.Parallel.Base.Tag +        ( Tag+        , tagToInt, intToTag+        , fromBool, toBool)+where+++-- | Given a value of an algebraic type, the tag tells us what+--   data constructor was used to create it.+type Tag = Int+++-- | Convert a `Tag` to an `Int`. This is identity at the value level.+tagToInt :: Tag -> Int+tagToInt = id+{-# INLINE tagToInt #-}+++-- | Convert an `Int` to a `Tag`. This is identity at the value level.+intToTag :: Int -> Tag+intToTag = id+{-# INLINE intToTag #-}+++-- | Get the `Tag` of a `Bool` value. `False` is 0, `True` is 1.+fromBool :: Bool -> Tag+fromBool False = 0+fromBool True  = 1+{-# INLINE fromBool #-}+++-- | Convert a `Tag` to a `Bool` value.+toBool :: Tag -> Bool+toBool n | n == 0    = False+         | otherwise = True+{-# INLINE toBool #-}+++

@@ -1,20 +1,24 @@ -- | Utilities for defining Read\/Show instances.-module Data.Array.Parallel.Base.Text (-  showsApp, readApp, readsApp,-  Read(..)-) where+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)+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-  )+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

@@ -1,5 +1,5 @@--- | 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.+-- | When `tracePrimEnabled`, DPH programs will print out what flat array+--   primitives they're using at runtime. See `tracePrim` for details. module Data.Array.Parallel.Base.TracePrim         ( tracePrim         , TracePrim(..))@@ -7,12 +7,13 @@ 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`,+--    Tracing is only enabled when `tracePrimEnabled` is `True`. --    otherwise it's a no-op. --    tracePrim :: TracePrim -> a -> a@@ -21,10 +22,13 @@  | otherwise            = x   --- | Records information about the use of a primitive operator.+-- | Records information about the use of a flat array primitive. -- --    These are the operator names that the vectoriser introduces.---    The actual implementation of each operator varies depending on what DPH backend we're using.+--+--    The actual implementation of each operator varies depending on what+--    DPH primitive library is being used.+-- --    We only trace operators that are at least O(n) in complexity.  data TracePrim         = TraceReplicate   { traceCount      :: Int}

@@ -1,37 +0,0 @@---- | 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-

@@ -0,0 +1,57 @@++-- | Pretty printer classes+module Data.Array.Parallel.Pretty+        ( module Text.PrettyPrint+        , PprPhysical(..)+        , PprVirtual (..))+where+import Text.PrettyPrint+import qualified Data.Vector            as V+import Data.Vector                      (Vector)+++-- | Pretty print the physical structure of data.+class PprPhysical a where+ pprp :: a -> Doc++instance PprPhysical Bool where+ pprp = text . show++instance PprPhysical Int where+ pprp = text . show + +instance PprPhysical Double where+ pprp = text . show + + +-- | Pretty print virtual \/ logical structure of data.+class PprVirtual a where+ pprv :: a -> Doc++instance PprVirtual Bool where+ pprv = text . show++instance PprVirtual Int where+ pprv = text . show + +instance PprVirtual Double where+ pprv = text . show +++-- Instances ------------------------------------------------------------------ +instance (PprPhysical a, PprPhysical b)+        => PprPhysical (a, b) where+ pprp (x, y)+  = vcat+        [ text "Tuple2"+        , nest 4 $ pprp x+        , nest 4 $ pprp y]++instance PprPhysical a+        => PprPhysical (Vector a) where+ pprp vec+        = brackets +        $ hcat+        $ punctuate (text ", ") +        $ V.toList $ V.map pprp vec+

@@ -1,525 +0,0 @@--- | 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)-

@@ -1,5 +1,4 @@-Copyright (c) 2001-2011, The DPH Team-All rights reserved.+Copyright (c) 2001-2012, The DPH Team  The DPH Team is:   Manuel M T Chakravarty

@@ -1,13 +1,15 @@ Name:           dph-base-Version:        0.5.1.1+Version:        0.6.0.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+Synopsis:       Data Parallel Haskell common config and debugging functions.+Description:    Common configuration, debugging and utilities. + Cabal-Version:  >= 1.6 Build-Type:     Simple @@ -18,15 +20,16 @@ Library   Exposed-Modules:         Data.Array.Parallel.Base-        Data.Array.Parallel.Stream+        Data.Array.Parallel.Base.Text         Data.Array.Parallel.Base.DTrace         Data.Array.Parallel.Base.TracePrim+        Data.Array.Parallel.Pretty+        Data.Array.Parallel.Array    Other-Modules:         Data.Array.Parallel.Base.Config         Data.Array.Parallel.Base.Debug-        Data.Array.Parallel.Base.Util-        Data.Array.Parallel.Base.Text+        Data.Array.Parallel.Base.Tag    Include-Dirs:         include@@ -38,14 +41,19 @@    Extensions:           TypeFamilies, GADTs, RankNTypes,-         BangPatterns, MagicHash, UnboxedTuples, TypeOperators, CPP+         BangPatterns, MagicHash, UnboxedTuples, TypeOperators, CPP,+         MultiParamTypeClasses, FlexibleInstances -  GHC-Options: -Odph -funbox-strict-fields -fcpr-off +  GHC-Options:+        -Odph+        -funbox-strict-fields -fcpr-off     Build-Depends:  -        base     == 4.4.*,+        base     == 4.5.*,         ghc-prim == 0.2.*,-        array    == 0.3.*,+        array    == 0.4.*,         random   == 1.0.*,-        vector   == 0.7.*+        vector   == 0.9.*,+        pretty   == 1.1.*+           

@@ -1,16 +1,75 @@-#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]+-------------------------------------------------------------------------------+-- These are the main simplifier phases used in DPH.+--  The phase is numbered after the set of bindings that are inlined in that+--  phase. We start from the "outermost" combinators produced by the+--  vectoriser and work our way down to the Data.Vector streams.+-- -#define PHASE_PA+-- Inline bindings in user code, and closure functions.+-- This is dph-common-vseg:D.A.P.Lifted.Closure+#define PHASE_USER      [4]++-- Inline combinators that work on PArray and PData.+-- This is dph-common-vseg:D.A.P.PArray+#define PHASE_PA        [3]++-- Inline combinators from the unlifted backends+-- This is dph-prim-par:D.A.P.Unlifted.Parallel+--     and dph-prim-par:D.A.P.Unlifted.Sequential #define PHASE_BACKEND   [2]++-- Inline combinators for distributed arrays.+-- This is dph-prim-par:D.A.P.Unlifted.Distributed #define PHASE_DIST      [1]++-- Inline combinators for Data.Vector #define PHASE_STREAM    [1]++-- Inline stuff in inner loops. #define PHASE_INNER     [0] + #define UNTIL_PHASE_BACKEND [~2]+++-------------------------------------------------------------------------------+-- More fine-grained inliner pragmas that we use to annotate the actual+-- bindings. When debugging it's useful to control exactly what gets inlined.++-- Bindings in hand-crafted example code.+#define INLINE_USER    INLINE PHASE_USER++-- Closure combinators produced by the vectoriser.+-- dph-common-vseg:D.A.P.Lifted.Closure+#define INLINE_CLOSURE INLINE PHASE_USER++-- Stuff that works on PArrays+-- dph-common-vseg:D.A.P.Lifted.Combinators+-- dph-common-vseg:D.A.P.PArray+#define INLINE_PA      INLINE PHASE_USER++-- dph-common-vseg:D.A.P.PArray.PData+#define INLINE_PDATA   INLINE PHASE_PA++-- Generic stuff in the unlifted backend.+#define INLINE_BACKEND INLINE PHASE_BACKEND++-- Unlifted parallel array combinators.+-- dph-prim-par:D.A.P.Unlifted.Parallel+#define INLINE_UP      INLINE PHASE_BACKEND++-- Unlifted sequential array combinators.+-- dph-prim-seq:D.A.P.Unlifted.Sequential+#define INLINE_U       INLINE PHASE_BACKEND++-- dph-prim-par:D.A.P.Unlifted.Distributed+#define INLINE_DIST    INLINE PHASE_DIST++-- dph-prim-seq:D.A.P.Unlifted.Sequential.Vector+#define INLINE_STREAM  INLINE PHASE_STREAM+++#define INLINE_INNER   INLINE PHASE_INNER++