diff --git a/Data/Array/Parallel/Unlifted.hs b/Data/Array/Parallel/Unlifted.hs --- a/Data/Array/Parallel/Unlifted.hs +++ b/Data/Array/Parallel/Unlifted.hs @@ -1,97 +1,209 @@ {-# LANGUAGE CPP #-} - --- | Primitive sequential combinators that work on flat, unlifted arrays. --- --- This set of combinators is used when the program is compiled with @-fdph-seq@. --- When compiling with @-fdph-par@, the ones in the @dph-prim-par package@ are used --- instead. The @dph-prim-par package@ exports the same names, but all combinators --- are implemented sequentially. +{-# OPTIONS -fno-warn-missing-signatures #-} +-- | Sequential implementation of the segmented array API defined in +-- @dph-prim-interface@. -- +-- There is a parallel implementation in @dph-prim-par@, +-- so you probably want that instead. + -- The API is defined in @DPH_Header.h@ and @DPH_Interface.h@ to ensure that both -- @dph-prim-par@ and @dph-prim-seq@ really do export the same symbols. - #include "DPH_Header.h" - -import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as V import Data.Array.Parallel.Unlifted.Sequential.USel -import Data.Array.Parallel.Unlifted.Sequential.Segmented - +import Data.Array.Parallel.Unlifted.Sequential +import qualified Data.Array.Parallel.Unlifted.Sequential.USegd as USegd +import qualified Data.Array.Parallel.Unlifted.Sequential.USSegd as USSegd +import qualified Data.Array.Parallel.Unlifted.Sequential.UVSegd as UVSegd +import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as U +import qualified Data.Array.Parallel.Unlifted.Vectors as US #include "DPH_Interface.h" -class V.Unbox a => Elt a -type Array = V.Vector -type Segd = USegd -type Sel2 = USel2 -type SelRep2 = () +-- NOTE: +-- See DPH_Interface.h for documentation. +-- The defs should appear in the same order as they are listed in DPH_Interface.h -length = V.length -empty = V.empty -replicate = V.replicate -repeat n _ = V.repeat n -(!:) = (V.!) -extract = V.extract -drop = V.drop -permute = V.permute -bpermute = V.bpermute -mbpermute = V.mbpermute -bpermuteDft = V.bpermuteDft -update = V.update -(+:+) = (V.++) -interleave = V.interleave -pack = V.pack -combine = V.combine -combine2 tags _ = V.combine2ByTag tags -map = V.map -filter = V.filter -zip = V.zip -unzip = V.unzip -fsts = V.fsts -snds = V.snds -zipWith = V.zipWith -fold = V.fold -fold1 = V.fold1 -and = V.and -sum = V.sum -scan = V.scan -indexed = V.indexed -enumFromTo = V.enumFromTo -enumFromThenTo = V.enumFromThenTo -enumFromStepLen = V.enumFromStepLen -enumFromStepLenEach = V.enumFromStepLenEach -mkSel2 tags idxs n0 n1 _ = mkUSel2 tags idxs n0 n1 -tagsSel2 = tagsUSel2 -indicesSel2 = indicesUSel2 -elementsSel2_0 = elementsUSel2_0 -elementsSel2_1 = elementsUSel2_1 -repSel2 _ = () +-- Basics --------------------------------------------------------------------- +class U.Unbox a => Elt a -mkSelRep2 tags = () -indicesSelRep2 tags _ = tagsToIndices2 tags -elementsSelRep2_0 tags _ = count tags 0 -elementsSelRep2_1 tags _ = count tags 1 +-- | Arrays are stored as unboxed vectors. +-- They have bulk-strict semantics, so demanding one element demands them all. +type Array = U.Vector -replicate_s = replicateSU -replicate_rs = replicateRSU -append_s _ = appendSU -fold_s = foldSU -fold1_s = fold1SU -fold_r = foldlRU -sum_r = sumRU -indices_s = indicesSU +-- Constructors --------------------------------------------------------------- +empty = U.empty +(+:+) = (U.++) +append_s _ = appendSU +replicate = U.replicate +replicate_s = replicateSU +replicate_rs = replicateRSU +repeat n _ = U.repeat n +indexed = U.indexed +indices_s = indicesSU +enumFromTo = U.enumFromTo +enumFromThenTo = U.enumFromThenTo +enumFromStepLen = U.enumFromStepLen +enumFromStepLenEach = U.enumFromStepLenEach -lengthSegd = lengthUSegd -lengthsSegd = lengthsUSegd -indicesSegd = indicesUSegd -elementsSegd = elementsUSegd -mkSegd = mkUSegd -randoms = V.random -randomRs = V.randomR -class V.UIO a => IOElt a -hPut = V.hPut -hGet = V.hGet -toList = V.toList -fromList = V.fromList +-- Projections ---------------------------------------------------------------- +length = U.length +index = U.index +indexs = indexsFromVector +indexs_avs = indexsFromVectorsUVSegd + +extract = U.extract +extracts_nss = extractsFromNestedUSSegd +extracts_ass = extractsFromVectorsUSSegd +extracts_avs = extractsFromVectorsUVSegd +drop = U.drop + + +-- Update --------------------------------------------------------------------- +update = U.update + + +-- Permutation ---------------------------------------------------------------- +permute = U.permute +bpermute = U.bpermute +mbpermute = U.mbpermute +bpermuteDft = U.bpermuteDft + + +-- Zipping and Unzipping ------------------------------------------------------ +zip = U.zip +zip3 = U.zip3 +unzip = U.unzip +unzip3 = U.unzip3 +fsts = U.fsts +snds = U.snds + + +-- Map and ZipWith ------------------------------------------------------------ +map = U.map +zipWith = U.zipWith + + +-- Scans and Folds ------------------------------------------------------------ +scan = U.scan +fold = U.fold +fold_s = foldSU +fold_ss = foldSSU +fold_r = foldlRU +fold1 = U.fold1 +fold1_s = fold1SU +fold1_ss = fold1SSU +sum = U.sum +sum_r = sumRU +and = U.and + + +-- Packing and Filter --------------------------------------------------------- +pack = U.pack +filter = U.filter + + +-- Combine and Interleave ----------------------------------------------------- +combine = U.combine +combine2 tags _ = U.combine2ByTag tags +interleave = U.interleave + + +-- Selectors ------------------------------------------------------------------ +type Sel2 = USel2 +mkSel2 tags idxs n0 n1 _ = mkUSel2 tags idxs n0 n1 +tagsSel2 = tagsUSel2 +indicesSel2 = indicesUSel2 +elementsSel2_0 = elementsUSel2_0 +elementsSel2_1 = elementsUSel2_1 +repSel2 _ = () + +type SelRep2 = () +mkSelRep2 _ = () +indicesSelRep2 tags _ = tagsToIndices2 tags +elementsSelRep2_0 tags _ = count tags 0 +elementsSelRep2_1 tags _ = count tags 1 + + +-- Segment Descriptors -------------------------------------------------------- +type Segd = USegd.USegd +mkSegd = USegd.mkUSegd +validSegd = USegd.valid +emptySegd = USegd.empty +singletonSegd = USegd.singleton +lengthSegd = USegd.length +lengthsSegd = USegd.takeLengths +indicesSegd = USegd.takeIndices +elementsSegd = USegd.takeElements + + +-- Slice Segment Descriptors -------------------------------------------------- +type SSegd = USSegd.USSegd +mkSSegd = USSegd.mkUSSegd +validSSegd = USSegd.valid +emptySSegd = USSegd.empty +singletonSSegd = USSegd.singleton +promoteSegdToSSegd = USSegd.fromUSegd +isContiguousSSegd = USSegd.isContiguous +lengthOfSSegd = USSegd.length +lengthsOfSSegd = USSegd.takeLengths +indicesOfSSegd = USSegd.takeIndices +startsOfSSegd = USSegd.takeStarts +sourcesOfSSegd = USSegd.takeSources +getSegOfSSegd = USSegd.getSeg +appendSSegd = USSegd.appendWith + + +-- Virtual Segment Descriptors ------------------------------------------------ +type VSegd = UVSegd.UVSegd +mkVSegd = UVSegd.mkUVSegd +validVSegd = UVSegd.valid +emptyVSegd = UVSegd.empty +singletonVSegd = UVSegd.singleton +replicatedVSegd = UVSegd.replicated +promoteSegdToVSegd = UVSegd.fromUSegd +promoteSSegdToVSegd = UVSegd.fromUSSegd +isManifestVSegd = UVSegd.isManifest +isContiguousVSegd = UVSegd.isContiguous +lengthOfVSegd = UVSegd.length +takeVSegidsOfVSegd = UVSegd.takeVSegids +takeVSegidsRedundantOfVSegd = UVSegd.takeVSegids +takeSSegdOfVSegd = UVSegd.takeUSSegd +takeSSegdRedundantOfVSegd = UVSegd.takeUSSegd +takeLengthsOfVSegd = UVSegd.takeLengths +getSegOfVSegd = UVSegd.getSeg +unsafeDemoteToSSegdOfVSegd = UVSegd.unsafeDemoteToUSSegd +unsafeDemoteToSegdOfVSegd = UVSegd.unsafeDemoteToUSegd +updateVSegsOfVSegd = UVSegd.updateVSegs +updateVSegsReachableOfVSegd = UVSegd.updateVSegsReachable +appendVSegd = UVSegd.appendWith +combine2VSegd = UVSegd.combine2 + + +-- Irregular 2D Arrays -------------------------------------------------------- +class US.Unboxes a => Elts a +type Arrays = US.Vectors +emptys = US.empty +lengths = US.length +singletons = US.singleton +unsafeIndexs = US.unsafeIndex +unsafeIndex2s = US.unsafeIndex2 +appends = US.append +fromVectors = US.fromVector +toVectors = US.toVector + + +-- Random Arrays -------------------------------------------------------------- +randoms = U.random +randomRs = U.randomR + + +-- Array IO ------------------------------------------------------------------- +class U.UIO a => IOElt a +hPut = U.hPut +hGet = U.hGet + +toList = U.toList +fromList = U.fromList diff --git a/Data/Array/Parallel/Unlifted/ArrayArray.hs b/Data/Array/Parallel/Unlifted/ArrayArray.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/ArrayArray.hs @@ -0,0 +1,115 @@ + +-- | Irregular 2D unboxed arrays. +-- +-- The difference between this type and something like +-- @Data.Vector (Data.Vector.Unboxed a)@ is that the inner arrays have kind +-- @#@ and cannot be bottom. This ensures that we can always lookup an element +-- from an `ArrayArray#` without performing unboxings or checking for thunks. +--- +-- TODO: move this into the Data.Primitive library. +module Data.Array.Parallel.Unlifted.ArrayArray + ( MutableArrayArray (..) + , ArrayArray(..) + , newArrayArray + , writeArrayArrayMut + , writeArrayArray + , readArrayArray + , indexArrayArray + , unsafeFreezeArrayArray + , unsafeDeepFreezeArrayArray + , copyArrayArray) +where +import GHC.Prim +import GHC.Base +import GHC.ST +import Data.Primitive.ByteArray + + +data MutableArrayArray s e + = MutableArrayArray (MutableArrayArray# s) + +data ArrayArray e + = ArrayArray ArrayArray# + + +-- | Create an `ArrayArray` with the given number of elements. +newArrayArray :: Int -> ST s (MutableArrayArray s e) +newArrayArray (I# n#) + = ST $ \s# -> case newArrayArray# n# s# of + (# s'#, arr# #) -> (# s'#, MutableArrayArray arr# #) +{-# INLINE newArrayArray #-} + + +-- | Write a `MutableByteArray` to an `MutableArrayArray`. +writeArrayArrayMut :: MutableArrayArray s (MutableByteArray s) -> Int -> MutableByteArray s -> ST s () +writeArrayArrayMut (MutableArrayArray arrs#) (I# i#) (MutableByteArray mba#) + = ST $ \s# -> case writeMutableByteArrayArray# arrs# i# mba# s# of + s'# -> (# s'#, () #) +{-# INLINE writeArrayArrayMut #-} + + +-- | Write a `ByteArray` to a `MutableArrayArray`. +writeArrayArray :: MutableArrayArray s ByteArray -> Int -> ByteArray -> ST s () +writeArrayArray (MutableArrayArray arrs#) (I# i#) (ByteArray ba#) + = ST $ \s# -> case writeByteArrayArray# arrs# i# ba# s# of + s'# -> (# s'#, () #) +{-# INLINE writeArrayArray #-} + + +-- | Read a `MutableByteArray` from a `MutableArrayArray`. +readArrayArray :: MutableArrayArray s (MutableByteArray s) -> Int -> ST s (MutableByteArray s) +readArrayArray (MutableArrayArray arrs#) (I# i#) + = ST $ \s# -> case readMutableByteArrayArray# arrs# i# s# of + (# s'#, mba# #) -> (# s'#, MutableByteArray mba# #) +{-# INLINE readArrayArray #-} + + +-- | Index an `ArrayArray` of `ByteArray`s. +indexArrayArray :: ArrayArray ByteArray -> Int -> ByteArray +indexArrayArray (ArrayArray arrs#) (I# i#) + = ByteArray (indexByteArrayArray# arrs# i#) +{-# INLINE indexArrayArray #-} + + +-- | Freeze a `MutableArrayArray` into a plain `ArrayArray`. +unsafeFreezeArrayArray :: MutableArrayArray s e -> ST s (ArrayArray e) +unsafeFreezeArrayArray (MutableArrayArray marrs#) + = ST $ \s# -> case unsafeFreezeArrayArray# marrs# s# of + (# s'#, arrs# #) -> (# s'#, ArrayArray arrs# #) +{-# INLINE unsafeFreezeArrayArray #-} + + +-- | Freeze a nested `MutableArrayArray` into an `ArrayArray`. +unsafeDeepFreezeArrayArray + :: forall s + . MutableArrayArray s (MutableByteArray s) + -> ST s (ArrayArray ByteArray) + +unsafeDeepFreezeArrayArray marrs@(MutableArrayArray marrs#) + = do let n = I# (sizeofMutableArrayArray# marrs#) + marrs_halfFrozen = MutableArrayArray marrs# -- :: MutableArrayArray s (ByteArray e) + mapM_ (freezeSubArray marrs_halfFrozen) [0..n - 1] + unsafeFreezeArrayArray marrs_halfFrozen + + where + freezeSubArray marrs_halfFrozen i + = do mba <- readArrayArray marrs i + ba <- unsafeFreezeByteArray mba + writeArrayArray marrs_halfFrozen i ba +{-# INLINE unsafeDeepFreezeArrayArray #-} + + +-- | Copy an ArrayArray +copyArrayArray + :: MutableArrayArray s ByteArray -> Int + -> ArrayArray ByteArray -> Int + -> Int -> ST s () + +copyArrayArray dst startDst src startSrc len + = loop startDst startSrc len + where loop !ixDst !ixSrc !len' + | len' <= 0 = return () + | otherwise + = do writeArrayArray dst ixDst $ indexArrayArray src ixSrc + loop (ixDst + 1) (ixSrc + 1) (len' - 1) + diff --git a/Data/Array/Parallel/Unlifted/Sequential.hs b/Data/Array/Parallel/Unlifted/Sequential.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Sequential.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +#include "fusion-phases.h" + +-- | Sequential operations on unlifted arrays. +-- +-- * This is an internal API and shouldn't need to be used directly. +-- Client programs should use "Data.Array.Parallel.Unlifted" +module Data.Array.Parallel.Unlifted.Sequential + ( -- * Constructors + replicateSU + , replicateRSU + , appendSU + , indicesSU, indicesSU' + + -- * Folds + , foldSU, foldSSU + , foldlSU, foldlSSU, foldlRU + , foldl1SU, foldl1SSU + , fold1SU, fold1SSU + + -- * Sums + , andSU + , orSU + , sumSU, sumRU + , productSU + , maximumSU + , minimumSU + + -- * Pack and Combine + , combineSU + + -- * Extracts and Indexing + , indexsFromVector + , indexsFromVectorsUVSegd + , extractsFromNestedUSSegd + , extractsFromVectorsUSSegd + , extractsFromVectorsUVSegd) +where +import Data.Array.Parallel.Unlifted.Sequential.Basics +import Data.Array.Parallel.Unlifted.Sequential.Combinators +import Data.Array.Parallel.Unlifted.Sequential.Sums +import Data.Array.Parallel.Unlifted.Sequential.Extracts +import Data.Array.Parallel.Unlifted.Sequential.USegd () +import Data.Array.Parallel.Unlifted.Sequential.USel () +import Data.Array.Parallel.Unlifted.Sequential.UVSegd () +import Prelude hiding (zip) diff --git a/Data/Array/Parallel/Unlifted/Sequential/Basics.hs b/Data/Array/Parallel/Unlifted/Sequential/Basics.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Sequential/Basics.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +#include "fusion-phases.h" + +-- | Basic segmented operations on unlifted arrays. +module Data.Array.Parallel.Unlifted.Sequential.Basics + ( replicateSU, replicateRSU + , appendSU + , indicesSU, indicesSU') +where +import Data.Array.Parallel.Unlifted.Stream +import Data.Array.Parallel.Unlifted.Sequential.Vector +import Data.Array.Parallel.Unlifted.Sequential.USegd (USegd) +import qualified Data.Array.Parallel.Unlifted.Sequential.USegd as USegd +import qualified Data.Vector.Fusion.Stream as S + + +-- | Segmented replicate of a vector based on the lengths of the segments +-- of the provided `USegd`. +replicateSU :: Unbox a => USegd -> Vector a -> Vector a +replicateSU segd xs + = unstream + (replicateEachS (USegd.takeElements segd) + (S.zip (stream (USegd.takeLengths segd)) (stream xs))) +{-# INLINE_U replicateSU #-} + + +-- | Regular sgemented replicate. +replicateRSU :: Unbox a => Int -> Vector a -> Vector a +replicateRSU n xs + = unstream + . replicateEachRS n + $ stream xs +{-# INLINE_U replicateRSU #-} + + +-- | Segmented append. +appendSU :: Unbox a + => USegd -> Vector a -- segd/data of first array + -> USegd -> Vector a -- segd/data of second array + -> Vector a +appendSU xd xs yd ys + = unstream + $ appendSS (stream (USegd.takeLengths xd)) (stream xs) + (stream (USegd.takeLengths yd)) (stream ys) +{-# INLINE_U appendSU #-} + + +-- | Segmented indices. +indicesSU :: USegd -> Vector Int +indicesSU = indicesSU' 0 +{-# INLINE_U indicesSU #-} + + +indicesSU' :: Int -> USegd -> Vector Int +indicesSU' i segd + = unstream + . indicesSS (USegd.takeElements segd) i + . stream + $ USegd.takeLengths segd +{-# INLINE_U indicesSU' #-} + diff --git a/Data/Array/Parallel/Unlifted/Sequential/Combinators.hs b/Data/Array/Parallel/Unlifted/Sequential/Combinators.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Sequential/Combinators.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE CPP #-} +#include "fusion-phases.h" + +-- | Standard combinators for segmented unlifted arrays. +module Data.Array.Parallel.Unlifted.Sequential.Combinators + ( foldlSU, foldlSSU + , foldSU, foldSSU + , foldl1SU, foldl1SSU + , fold1SU, fold1SSU + , foldlRU + , combineSU) +where +import Data.Array.Parallel.Unlifted.Stream +import Data.Array.Parallel.Unlifted.Vectors as US +import Data.Array.Parallel.Unlifted.Sequential.Vector as U +import Data.Array.Parallel.Unlifted.Sequential.USSegd (USSegd) +import Data.Array.Parallel.Unlifted.Sequential.USegd (USegd) +import qualified Data.Array.Parallel.Unlifted.Sequential.USSegd as USSegd +import qualified Data.Array.Parallel.Unlifted.Sequential.USegd as USegd + +-- NOTE: +-- Even though some of these functions are trivial aliases, we use INLINE_U +-- pragmas on them to delay inlining. This lets us see what functions are being +-- called from higher layers of the library when browsing the core IR. + + +-- foldl ---------------------------------------------------------------------- +-- | Segmented array reduction proceeding from the left +foldlSU :: (Unbox a, Unbox b) + => (b -> a -> b) -> b -> USegd -> Vector a -> Vector b +foldlSU f !z segd xs + = unstream + $ foldSS f z (stream (USegd.takeLengths segd)) + (stream xs) +{-# INLINE_U foldlSU #-} + + +-- | Segmented array reduction proceeding from the left. +-- For scattered segments. +foldlSSU :: (Unbox a, Unboxes a, Unbox b) + => (b -> a -> b) -> b -> USSegd -> Vectors a -> Vector b +foldlSSU f !z ssegd xss + = unstream + $ foldSS f z (stream (USSegd.takeLengths ssegd)) + (streamSegsFromVectorsUSSegd xss ssegd) +{-# INLINE_U foldlSSU #-} + + +-- fold ----------------------------------------------------------------------- +-- | Segmented array reduction that requires an associative combination +-- function with its unit +foldSU :: Unbox a + => (a -> a -> a) -> a -> USegd -> Vector a -> Vector a +foldSU = foldlSU +{-# INLINE_U foldSU #-} + + +-- | Segmented array reduction that requires an associative combination +-- function with its unit. For scattered segments. +foldSSU :: (Unbox a, Unboxes a) + => (a -> a -> a) -> a -> USSegd -> Vectors a -> Vector a +foldSSU = foldlSSU +{-# INLINE_U foldSSU #-} + + +-- foldl1 --------------------------------------------------------------------- +-- | Segmented array reduction from left to right with non-empty subarrays only +foldl1SU :: Unbox a + => (a -> a -> a) -> USegd -> Vector a -> Vector a +foldl1SU f segd xs + = unstream + $ fold1SS f (stream (USegd.takeLengths segd)) + (stream xs) +{-# INLINE_U foldl1SU #-} + + +-- | Segmented array reduction from left to right with non-empty subarrays only. +-- For scattered segments. +foldl1SSU :: (Unbox a, Unboxes a) + => (a -> a -> a) -> USSegd -> Vectors a -> Vector a +foldl1SSU f ssegd xxs + = unstream + $ fold1SS f (stream (USSegd.takeLengths ssegd)) + (streamSegsFromVectorsUSSegd xxs ssegd) +{-# INLINE_U foldl1SSU #-} + + +-- fold1 ---------------------------------------------------------------------- +-- | Segmented array reduction with non-empty subarrays and an associative +-- combination function. +fold1SU :: Unbox a + => (a -> a -> a) -> USegd -> Vector a -> Vector a +fold1SU = foldl1SU +{-# INLINE_U fold1SU #-} + + +-- | Segmented array reduction with non-empty subarrays and an associative +-- combination function. For scattered segments. +fold1SSU :: (Unbox a, Unboxes a) + => (a -> a -> a) -> USSegd -> Vectors a -> Vector a +fold1SSU = foldl1SSU +{-# INLINE_U fold1SSU #-} + + + +-- foldlR --------------------------------------------------------------------- +-- | Regular arrar reduction +foldlRU :: (Unbox a, Unbox b) => (b -> a -> b) -> b -> Int -> Vector a -> Vector b +foldlRU f !z segSize + = unstream . foldValuesR f z segSize . stream +{-# INLINE_U foldlRU #-} + + +-- | Merge two segmented arrays according to flag array +combineSU :: Unbox a => Vector Bool -> USegd -> Vector a -> USegd -> Vector a -> Vector a +combineSU bs xd xs yd ys + = unstream + $ combineSS (stream bs) + (stream (USegd.takeLengths xd)) (stream xs) + (stream (USegd.takeLengths yd)) (stream ys) +{-# INLINE_U combineSU #-} + + diff --git a/Data/Array/Parallel/Unlifted/Sequential/Extracts.hs b/Data/Array/Parallel/Unlifted/Sequential/Extracts.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Sequential/Extracts.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP #-} +#include "fusion-phases.h" + +-- | Standard combinators for segmented unlifted arrays. +module Data.Array.Parallel.Unlifted.Sequential.Extracts + ( -- * Scattered indexing. + indexsFromVector + , indexsFromVectorsUVSegd + + -- * Scattered extracts + , extractsFromNestedUSSegd + , extractsFromVectorsUSSegd + , extractsFromVectorsUVSegd) +where +import Data.Array.Parallel.Unlifted.Stream as US +import Data.Array.Parallel.Unlifted.Vectors as US +import Data.Array.Parallel.Unlifted.Sequential.Vector as U +import Data.Array.Parallel.Unlifted.Sequential.USSegd (USSegd) +import Data.Array.Parallel.Unlifted.Sequential.UVSegd (UVSegd) +import qualified Data.Vector as V + + +-- Indexs -------------------------------------------------------------------- +-- | Lookup elements from a `Vector`. +indexsFromVector + :: Unbox a + => Vector a -> Vector Int -> Vector a + +indexsFromVector vector ixs + = U.unstream + $ streamElemsFromVector vector + $ U.stream ixs +{-# INLINE_U indexsFromVector #-} + + +-- | Lookup elements from some `Vectors` through a `UPVSegd`. +indexsFromVectorsUVSegd + :: (Unbox a, US.Unboxes a) + => Vectors a -> UVSegd -> Vector (Int, Int) -> Vector a + +indexsFromVectorsUVSegd vectors uvsegd vsrcixs + = U.unstream + $ streamElemsFromVectorsVSegd vectors uvsegd + $ U.stream vsrcixs +{-# INLINE_U indexsFromVectorsUVSegd #-} + + +-- Extracts wrappers --------------------------------------------------------- +-- | Copy segments from a `Vectors`, concatenating them into a new array. +extractsFromNestedUSSegd + :: (U.Unbox a) + => USSegd -> V.Vector (Vector a) -> U.Vector a + +extractsFromNestedUSSegd ussegd vectors + = U.unstream $ streamSegsFromNestedUSSegd vectors ussegd +{-# INLINE_U extractsFromNestedUSSegd #-} + + +-- | Copy segments from a `Vectors`, concatenating them into a new array. +extractsFromVectorsUSSegd + :: (Unboxes a, U.Unbox a) + => USSegd -> Vectors a -> U.Vector a + +extractsFromVectorsUSSegd ussegd vectors + = U.unstream $ streamSegsFromVectorsUSSegd vectors ussegd +{-# INLINE_U extractsFromVectorsUSSegd #-} + + +-- | Copy segments from a `Vectors`, concatenating them into a new array. +extractsFromVectorsUVSegd + :: (Unbox a, US.Unboxes a) + => UVSegd + -> Vectors a + -> Vector a + +extractsFromVectorsUVSegd uvsegd vectors + = U.unstream $ US.streamSegsFromVectorsUVSegd vectors uvsegd +{-# INLINE_U extractsFromVectorsUVSegd #-} diff --git a/Data/Array/Parallel/Unlifted/Sequential/Segmented.hs b/Data/Array/Parallel/Unlifted/Sequential/Segmented.hs deleted file mode 100644 --- a/Data/Array/Parallel/Unlifted/Sequential/Segmented.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | Interface to operations on segmented unlifted arrays. -module Data.Array.Parallel.Unlifted.Sequential.Segmented ( - - replicateSU, replicateRSU, appendSU, indicesSU, indicesSU', - - foldlSU, foldSU, fold1SU, - foldlRU, - combineSU, - - -- * Logical operations - andSU, orSU, - - -- * Arithmetic operations - sumSU, productSU, maximumSU, minimumSU, - sumRU, - USegd, - - -- * Operations on segment descriptors - lengthUSegd, lengthsUSegd, indicesUSegd, elementsUSegd, - lengthsToUSegd, mkUSegd -) where -import Data.Array.Parallel.Unlifted.Sequential.Segmented.USegd -import Data.Array.Parallel.Unlifted.Sequential.Segmented.Basics -import Data.Array.Parallel.Unlifted.Sequential.Segmented.Combinators -import Data.Array.Parallel.Unlifted.Sequential.Segmented.Sums -import Data.Array.Parallel.Unlifted.Sequential.Segmented.Text () - diff --git a/Data/Array/Parallel/Unlifted/Sequential/Segmented/Basics.hs b/Data/Array/Parallel/Unlifted/Sequential/Segmented/Basics.hs deleted file mode 100644 --- a/Data/Array/Parallel/Unlifted/Sequential/Segmented/Basics.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE CPP #-} -#include "fusion-phases.h" - --- | Basic segmented operations on unlifted arrays. -module Data.Array.Parallel.Unlifted.Sequential.Segmented.Basics ( - replicateSU, replicateRSU, appendSU, indicesSU, indicesSU' -) where -import Data.Array.Parallel.Stream -import Data.Array.Parallel.Unlifted.Sequential.Vector -import Data.Array.Parallel.Unlifted.Sequential.Segmented.USegd -import qualified Data.Vector.Fusion.Stream as S - - -replicateSU :: Unbox a => USegd -> Vector a -> Vector a -{-# INLINE_U replicateSU #-} -replicateSU segd xs = unstream - (replicateEachS (elementsUSegd segd) - (S.zip (stream (lengthsUSegd segd)) (stream xs))) - - -replicateRSU :: Unbox a => Int -> Vector a -> Vector a -{-# INLINE_U replicateRSU #-} -replicateRSU n xs = unstream - . replicateEachRS n - $ stream xs - - -appendSU :: Unbox a => USegd -> Vector a -> USegd -> Vector a -> Vector a -{-# INLINE_U appendSU #-} -appendSU xd xs yd ys = unstream - $ appendSS (stream (lengthsUSegd xd)) - (stream xs) - (stream (lengthsUSegd yd)) - (stream ys) - - -indicesSU' :: Int -> USegd -> Vector Int -{-# INLINE_U indicesSU' #-} -indicesSU' i segd = unstream - . indicesSS (elementsUSegd segd) i - . stream - $ lengthsUSegd segd - - -indicesSU :: USegd -> Vector Int -{-# INLINE_U indicesSU #-} -indicesSU = indicesSU' 0 - diff --git a/Data/Array/Parallel/Unlifted/Sequential/Segmented/Combinators.hs b/Data/Array/Parallel/Unlifted/Sequential/Segmented/Combinators.hs deleted file mode 100644 --- a/Data/Array/Parallel/Unlifted/Sequential/Segmented/Combinators.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE CPP #-} -#include "fusion-phases.h" - --- | Standard combinators for segmented unlifted arrays. -module Data.Array.Parallel.Unlifted.Sequential.Segmented.Combinators ( - foldlSU, foldSU, foldl1SU, fold1SU, {-scanSU,-} {-scan1SU,-} - foldlRU, - combineSU -) where -import Data.Array.Parallel.Stream ( - foldSS, fold1SS, combineSS, foldValuesR ) -import Data.Array.Parallel.Unlifted.Sequential.Vector as V -import Data.Array.Parallel.Unlifted.Sequential.Segmented.USegd -import Debug.Trace - - --- | Segmented array reduction proceeding from the left -foldlSU :: (Unbox a, Unbox b) => (b -> a -> b) -> b -> USegd -> Vector a -> Vector b -{-# INLINE_U foldlSU #-} -foldlSU f z segd xs = unstream - $ foldSS f z (stream (lengthsUSegd segd)) (stream xs) - - --- | Segmented array reduction that requires an associative combination --- function with its unit -foldSU :: Unbox a => (a -> a -> a) -> a -> USegd -> Vector a -> Vector a -foldSU = foldlSU - - --- | Segmented array reduction from left to right with non-empty subarrays only -foldl1SU :: Unbox a => (a -> a -> a) -> USegd -> Vector a -> Vector a -{-# INLINE_U foldl1SU #-} -foldl1SU f segd xs = unstream - $ fold1SS f (stream (lengthsUSegd segd)) (stream xs) - - --- | Segmented array reduction with non-empty subarrays and an associative --- combination function -fold1SU :: Unbox a => (a -> a -> a) -> USegd -> Vector a -> Vector a -fold1SU = foldl1SU - - --- | Merge two segmented arrays according to flag array -combineSU :: Unbox a => Vector Bool -> USegd -> Vector a -> USegd -> Vector a -> Vector a -{-# INLINE_U combineSU #-} -combineSU bs xd xs yd ys = unstream - $ combineSS (stream bs) - (stream (lengthsUSegd xd)) (stream xs) - (stream (lengthsUSegd yd)) (stream ys) - - --- | Regular arrar reduction -foldlRU :: (Unbox a, Unbox b) => (b -> a -> b) -> b -> Int -> Vector a -> Vector b -{-# INLINE_U foldlRU #-} -foldlRU f z segSize = unstream . foldValuesR f z segSize . stream - diff --git a/Data/Array/Parallel/Unlifted/Sequential/Segmented/Sums.hs b/Data/Array/Parallel/Unlifted/Sequential/Segmented/Sums.hs deleted file mode 100644 --- a/Data/Array/Parallel/Unlifted/Sequential/Segmented/Sums.hs +++ /dev/null @@ -1,50 +0,0 @@ --- | Sum-like operations on segmented list-like combinators. -module Data.Array.Parallel.Unlifted.Sequential.Segmented.Sums ( - andSU, orSU, sumSU, productSU, maximumSU, minimumSU, - sumRU -) where -import Data.Array.Parallel.Unlifted.Sequential.Vector as V -import Data.Array.Parallel.Unlifted.Sequential.Segmented.USegd ( - USegd ) -import Data.Array.Parallel.Unlifted.Sequential.Segmented.Combinators ( - foldSU, fold1SU, foldlRU) - - --- | Compute the boolean AND of all segments in a segmented array. -andSU :: USegd -> Vector Bool -> Vector Bool -andSU = foldSU (&&) True - - --- | Compute the boolean OR of all segments in a segmented array. -orSU :: USegd -> Vector Bool -> Vector Bool -orSU = foldSU (||) False - - --- | Compute the segmented sum of an array of numerals -sumSU :: (Num e, Unbox e) => USegd -> Vector e -> Vector e -{-# INLINE sumSU #-} -sumSU = foldSU (+) 0 - - --- | Compute the segmented product of an array of numerals -productSU :: (Num e, Unbox e) => USegd -> Vector e -> Vector e -{-# INLINE productSU #-} -productSU = foldSU (*) 1 - - --- | Determine the maximum element in each subarray -maximumSU :: (Ord e, Unbox e) => USegd -> Vector e -> Vector e -{-# INLINE maximumSU #-} -maximumSU = fold1SU max - - --- | Determine the minimum element in each subarray -minimumSU :: (Ord e, Unbox e) => USegd -> Vector e -> Vector e -{-# INLINE minimumSU #-} -minimumSU = fold1SU min - - --- | Compute the segmented sum of an array of numerals -sumRU :: (Num e, Unbox e) => Int ->Vector e -> Vector e -{-# INLINE sumRU #-} -sumRU = foldlRU (+) 0 diff --git a/Data/Array/Parallel/Unlifted/Sequential/Segmented/Text.hs b/Data/Array/Parallel/Unlifted/Sequential/Segmented/Text.hs deleted file mode 100644 --- a/Data/Array/Parallel/Unlifted/Sequential/Segmented/Text.hs +++ /dev/null @@ -1,11 +0,0 @@ --- | Read\/Show instances for segmented unlifted arrays. -module Data.Array.Parallel.Unlifted.Sequential.Segmented.Text () -where -import Data.Array.Parallel.Base ( - Read(..), showsApp, readApp) -import Data.Array.Parallel.Unlifted.Sequential.Segmented.USegd ( - USegd, lengthsUSegd ) - -instance Show USegd where - showsPrec k = showsApp k "toUSegd" . lengthsUSegd - diff --git a/Data/Array/Parallel/Unlifted/Sequential/Segmented/USegd.hs b/Data/Array/Parallel/Unlifted/Sequential/Segmented/USegd.hs deleted file mode 100644 --- a/Data/Array/Parallel/Unlifted/Sequential/Segmented/USegd.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE CPP #-} -#include "fusion-phases.h" - --- | Segment Descriptors -module Data.Array.Parallel.Unlifted.Sequential.Segmented.USegd ( - -- * Types - USegd, - - -- * Constructors - mkUSegd, - emptyUSegd, singletonUSegd, lengthsToUSegd, - - -- * Projections - lengthUSegd, lengthsUSegd, indicesUSegd, elementsUSegd, - - -- * Operations - sliceUSegd, extractUSegd -) where -import Data.Array.Parallel.Unlifted.Sequential.Vector as V - --- | Segment descriptors represent the structure of nested arrays. --- For each segment, it stores the length and the starting index in the flat data array. --- --- Example: --- --- @ --- flat array data: [1, 2, 3, 4, 5, 6, 7, 8] --- (segmentation) ---- ------- - ---- --- segd lengths: [2, 3, 1, 2] --- indices: [0, 2, 5, 6] --- elements: 8 --- @ -data USegd - = USegd - { usegd_lengths :: !(Vector Int) -- ^ length of each segment - , usegd_indices :: !(Vector Int) -- ^ starting index of each segment in the flat array - , usegd_elements :: !Int -- ^ total number of elements in the flat array - } - - --- Constructors --------------------------------------------------------------- --- | O(1). Construct a new segment descriptor. -mkUSegd - :: Vector Int -- ^ length of each segment - -> Vector Int -- ^ starting index of each segment - -> Int -- ^ total number of elements in the flat array - -> USegd - -{-# INLINE mkUSegd #-} -mkUSegd = USegd - - --- | O(1). Yield an empty segment descriptor, with no elements or segments. -emptyUSegd :: USegd -{-# INLINE emptyUSegd #-} -emptyUSegd = USegd V.empty V.empty 0 - - --- | O(1). Yield a singleton segment descriptor. --- The single segment covers the given number of elements. -singletonUSegd :: Int -> USegd -{-# INLINE singletonUSegd #-} -singletonUSegd n = USegd (V.singleton n) (V.singleton 0) n - - --- | O(n). Convert a length array into a segment descriptor. --- --- The array contains the length of each segment, and we compute the --- indices from that. Runtime is O(n) in the number of segments. --- -lengthsToUSegd :: Vector Int -> USegd -{-# INLINE lengthsToUSegd #-} -lengthsToUSegd lens - = USegd lens (V.scanl (+) 0 lens) (V.sum lens) - - --- Projections ---------------------------------------------------------------- --- | O(1). Yield the overall number of segments. -lengthUSegd :: USegd -> Int -{-# INLINE lengthUSegd #-} -lengthUSegd = V.length . usegd_lengths - - --- | O(1). Yield the lengths of the individual segments. -lengthsUSegd :: USegd -> Vector Int -{-# INLINE lengthsUSegd #-} -lengthsUSegd = usegd_lengths - - --- | O(1). Yield the segment indices of a segment descriptor. -indicesUSegd :: USegd -> Vector Int -{-# INLINE indicesUSegd #-} -indicesUSegd = usegd_indices - - --- | O(1). Yield the number of data elements. -elementsUSegd :: USegd -> Int -{-# INLINE elementsUSegd #-} -elementsUSegd = usegd_elements - - --- | O(n). Extract a slice of a segment descriptor, avoiding copying where possible. --- --- We can share the segment lengths with the original segment descriptor, --- but still need to recompute the starting indices of each. Hence --- runtime is O(n) in the number of segments sliced out. --- --- NOTE: In the new segment descriptor, the starting index of the first --- segment will be 0. -sliceUSegd - :: USegd -- ^ source segment descriptor - -> Int -- ^ index of first segment - -> Int -- ^ number of segments to slice out - -> USegd - -{-# INLINE sliceUSegd #-} -sliceUSegd segd i n - = lengthsToUSegd $ V.slice (lengthsUSegd segd) i n - - --- | O(n). Extract a slice of a segment descriptor, copying everything. --- --- In contrast to `sliceUSegd`, this function copies the array of --- segment lengths as well as recomputing the starting indices of each. --- --- NOTE: In the new segment descriptor, the starting index of the first --- segment will be 0. -extractUSegd - :: USegd -- ^ source segment desciptor - -> Int -- ^ index of the first segment - -> Int -- ^ number of segments to extract out - -> USegd - -{-# INLINE extractUSegd #-} -extractUSegd segd i n - = lengthsToUSegd $ V.extract (lengthsUSegd segd) i n - diff --git a/Data/Array/Parallel/Unlifted/Sequential/Sums.hs b/Data/Array/Parallel/Unlifted/Sequential/Sums.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Sequential/Sums.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +#include "fusion-phases.h" + +-- | Sum-like operations on segmented list-like combinators. +module Data.Array.Parallel.Unlifted.Sequential.Sums + ( andSU, orSU + , sumSU, sumRU + , productSU + , maximumSU, minimumSU) +where +import Data.Array.Parallel.Unlifted.Sequential.Vector as V +import Data.Array.Parallel.Unlifted.Sequential.USegd +import Data.Array.Parallel.Unlifted.Sequential.Combinators + + +-- | Compute the boolean AND of all segments in a segmented array. +andSU :: USegd -> Vector Bool -> Vector Bool +andSU = foldSU (&&) True +{-# INLINE_U andSU #-} + + +-- | Compute the boolean OR of all segments in a segmented array. +orSU :: USegd -> Vector Bool -> Vector Bool +orSU = foldSU (||) False +{-# INLINE_U orSU #-} + + +-- | Compute the segmented sum of an array of numerals +sumSU :: (Num e, Unbox e) => USegd -> Vector e -> Vector e +sumSU = foldSU (+) 0 +{-# INLINE_U sumSU #-} + + +-- | Compute the segmented product of an array of numerals +productSU :: (Num e, Unbox e) => USegd -> Vector e -> Vector e +productSU = foldSU (*) 1 +{-# INLINE_U productSU #-} + + +-- | Determine the maximum element in each subarray +maximumSU :: (Ord e, Unbox e) => USegd -> Vector e -> Vector e +maximumSU = fold1SU max +{-# INLINE_U maximumSU #-} + + +-- | Determine the minimum element in each subarray +minimumSU :: (Ord e, Unbox e) => USegd -> Vector e -> Vector e +minimumSU = fold1SU min +{-# INLINE_U minimumSU #-} + + +-- | Compute the segmented sum of an array of numerals +sumRU :: (Num e, Unbox e) => Int ->Vector e -> Vector e +sumRU = foldlRU (+) 0 +{-# INLINE_U sumRU #-} diff --git a/Data/Array/Parallel/Unlifted/Sequential/USSegd.hs b/Data/Array/Parallel/Unlifted/Sequential/USSegd.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Sequential/USSegd.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -Wall -fno-warn-orphans #-} +#include "fusion-phases.h" + +-- | Scattered Segment Descriptors. +-- +-- See "Data.Array.Parallel.Unlifted" for how this works. +-- +module Data.Array.Parallel.Unlifted.Sequential.USSegd + ( -- * Types + USSegd(..) + , valid + + -- * Constructors + , mkUSSegd + , empty + , singleton + , fromUSegd + + -- * Predicates + , isContiguous + + -- * Projections + , length + , takeUSegd, takeLengths, takeIndices, takeElements + , takeSources, takeStarts + , getSeg + + -- * Operators + , appendWith + , cullOnVSegids) +where +import Data.Array.Parallel.Unlifted.Sequential.USegd (USegd) +import Data.Array.Parallel.Unlifted.Sequential.Vector (Vector) +import Data.Array.Parallel.Pretty hiding (empty) +import Prelude hiding (length) +import qualified Data.Array.Parallel.Unlifted.Sequential.USegd as USegd +import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as U + +here :: String -> String +here s = "Data.Array.Parallel.Unlifted.Sequential.USSegd." ++ s + + +-- USSegd --------------------------------------------------------------------- +-- | Scattered Segment Descriptor. +data USSegd + = USSegd + { ussegd_contiguous :: !Bool + -- ^ True when the starts are identical to the usegd indices field + -- and the sources are all 0's. + -- + -- In this case all the data elements are in one contiguous flat + -- array, and consumers can avoid looking at the real starts and + -- sources fields. + + , ussegd_starts :: Vector Int + -- ^ Starting index of each segment in its flat array. + -- + -- IMPORTANT: this field is lazy so we can avoid creating it when + -- the flat array is contiguous. + + , ussegd_sources :: Vector Int + -- ^ Which flat array to take each segment from. + -- + -- IMPORTANT: this field is lazy so we can avoid creating it when + -- the flat array is contiguous. + + , ussegd_usegd :: !USegd + -- ^ Segment descriptor relative to a contiguous index space. + -- This defines the length of each segment. + } + deriving (Show) + + +-- | Pretty print the physical representation of a `UVSegd` +instance PprPhysical USSegd where + pprp (USSegd _ starts sources ssegd) + = vcat + [ text "USSegd" + $$ (nest 7 $ vcat + [ text "starts: " <+> (text $ show $ U.toList starts) + , text "sources: " <+> (text $ show $ U.toList sources) ]) + , pprp ssegd ] + + +-- Constructors --------------------------------------------------------------- +-- | O(1). Construct a new scattered segment descriptor. +-- All the provided arrays must have the same lengths. +mkUSSegd + :: Vector Int -- ^ Starting index of each segment in its flat array. + -> Vector Int -- ^ Which array to take each segment from. + -> USegd -- ^ Contiguous segment descriptor. + -> USSegd + +mkUSSegd = USSegd False +{-# INLINE mkUSSegd #-} + + +-- | O(1). Check the internal consistency of a scattered segment descriptor. +valid :: USSegd -> Bool +valid (USSegd _ starts srcids usegd) + = (U.length starts == USegd.length usegd) + && (U.length srcids == USegd.length usegd) + +{-# NOINLINE valid #-} +-- NOINLINE because it's only enabled during debugging anyway. + + +-- | O(1). Construct an empty segment descriptor, with no elements or segments. +empty :: USSegd +empty = USSegd True U.empty U.empty USegd.empty +{-# INLINE_U empty #-} + + +-- | O(1). Construct a singleton segment descriptor. +-- The single segment covers the given number of elements in a flat array +-- with sourceid 0. +singleton :: Int -> USSegd +singleton n + = USSegd True (U.singleton 0) (U.singleton 0) (USegd.singleton n) +{-# INLINE_U singleton #-} + + +-- | O(segs). Promote a plain `USegd` to a `USSegd`. +-- All segments are assumed to come from a flat array with sourceid 0. +fromUSegd :: USegd -> USSegd +fromUSegd usegd + = USSegd True + (USegd.takeIndices usegd) + (U.replicate (USegd.length usegd) 0) + usegd +{-# INLINE_U fromUSegd #-} + + +-- Predicates ----------------------------------------------------------------- +-- INLINE trivial projections as they'll expand to a single record selector. +-- | O(1). True when the starts are identical to the usegd indices field and +-- the sources are all 0's. +-- +-- In this case all the data elements are in one contiguous flat +-- array, and consumers can avoid looking at the real starts and +-- sources fields. +-- +isContiguous :: USSegd -> Bool +isContiguous = ussegd_contiguous +{-# INLINE isContiguous #-} + + +-- Projections ---------------------------------------------------------------- +-- INLINE trivial projections as they'll expand to a single record selector. + +-- | O(1). Yield the overall number of segments. +length :: USSegd -> Int +length = USegd.length . ussegd_usegd +{-# INLINE length #-} + + +-- | O(1). Yield the `USegd` of a `USSegd`. +takeUSegd :: USSegd -> USegd +takeUSegd = ussegd_usegd +{-# INLINE takeUSegd #-} + + +-- | O(1). Yield the lengths of the segments of a `USSegd`. +takeLengths :: USSegd -> Vector Int +takeLengths = USegd.takeLengths . ussegd_usegd +{-# INLINE takeLengths #-} + + +-- | O(1). Yield the segment indices of a `USSegd`. +takeIndices :: USSegd -> Vector Int +takeIndices = USegd.takeIndices . ussegd_usegd +{-# INLINE takeIndices #-} + + +-- | O(1). Yield the total number of elements covered by a `USSegd`. +takeElements :: USSegd -> Int +takeElements = USegd.takeElements . ussegd_usegd +{-# INLINE takeElements #-} + + +-- | O(1). Yield the starting indices of a `USSegd`. +takeStarts :: USSegd -> Vector Int +takeStarts = ussegd_starts +{-# INLINE takeStarts #-} + + +-- | O(1). Yield the source ids of a `USSegd`. +takeSources :: USSegd -> Vector Int +takeSources = ussegd_sources +{-# INLINE takeSources #-} + + +-- | O(1). Get the length, segment index, starting index, and source id of a segment. +getSeg :: USSegd -> Int -> (Int, Int, Int, Int) +getSeg (USSegd _ starts sources usegd) ix + = let (len, ixl) = USegd.getSeg usegd ix + in ( len + , ixl + , U.index (here "getSeg") starts ix + , U.index (here "getSeg") sources ix) +{-# INLINE_U getSeg #-} + + +-- Operators ================================================================== + +-- | O(n). Produce a segment descriptor that describes the result of appending +-- two arrays. +appendWith + :: USSegd -- ^ Segment descriptor of first nested array. + -> Int -- ^ Number of flat data arrays used to represent first nested array. + -> USSegd -- ^ Segment descriptor of second nested array. + -> Int -- ^ Number of flat data arrays used to represent second nested array. + -> USSegd +appendWith + (USSegd _ starts1 srcs1 usegd1) pdatas1 + (USSegd _ starts2 srcs2 usegd2) _ + = USSegd False + (starts1 U.++ starts2) + (srcs1 U.++ U.map (+ pdatas1) srcs2) + (USegd.append usegd1 usegd2) +{-# NOINLINE appendWith #-} +-- NOINLINE because we're worried about code explosion. Might be useful though. + + +-- | Cull the segments of a `USSegd` down to only those reachable from an array +-- of @vsegids@, and also update the @vsegids@ to point to the same segments +-- in the result. +-- +cullOnVSegids :: Vector Int -> USSegd -> (Vector Int, USSegd) +cullOnVSegids vsegids (USSegd _ starts sources usegd) + = {-# SCC "cullOnVSegids" #-} + let -- Determine which of the psegs are still reachable from the vsegs. + -- This produces an array of flags, + -- with reachable psegs corresponding to 1 + -- and unreachable psegs corresponding to 0 + -- + -- eg vsegids: [0 1 1 3 5 5 6 6] + -- => psegids_used: [1 1 0 1 0 1 1] + -- + -- Note that psegids '2' and '4' are not in vsegids_packed. + psegids_used + = U.bpermuteDft (USegd.length usegd) + (const False) + (U.zip vsegids (U.replicate (U.length vsegids) True)) + + -- Produce an array of used psegs. + -- eg psegids_used: [1 1 0 1 0 1 1] + -- psegids_packed: [0 1 3 5 6] + psegids_packed + = U.pack (U.enumFromTo 0 (U.length psegids_used)) psegids_used + + -- Produce an array that maps psegids in the source array onto + -- psegids in the result array. If a particular pseg isn't present + -- in the result this maps onto -1. + + -- Note that if psegids_used has 0 in some position, then psegids_map + -- has -1 in the same position, corresponding to an unused pseg. + + -- eg psegids_packed: [0 1 3 5 6] + -- [0 1 2 3 4] + -- psegids_map: [0 1 -1 2 -1 3 4] + psegids_map + = U.bpermuteDft (USegd.length usegd) + (const (-1)) + (U.zip psegids_packed (U.enumFromTo 0 (U.length psegids_packed - 1))) + + -- Use the psegids_map to rewrite the packed vsegids to point to the + -- corresponding psegs in the result. + -- + -- eg vsegids: [0 1 1 3 5 5 6 6] + -- psegids_map: [0 1 -1 2 -1 3 4] + -- + -- vsegids': [0 1 1 2 3 3 4 4] + -- + vsegids' = U.map (U.index (here "cullOnVSegids") psegids_map) vsegids + + -- Rebuild the usegd. + starts' = U.pack starts psegids_used + sources' = U.pack sources psegids_used + + lengths' = U.pack (USegd.takeLengths usegd) psegids_used + usegd' = USegd.fromLengths lengths' + + ussegd' = USSegd False starts' sources' usegd' + + in (vsegids', ussegd') + +{-# NOINLINE cullOnVSegids #-} +-- NOINLINE because it's complicated and won't fuse with anything +-- This can also be expensive and we want to see the SCC in profiling builds. + + diff --git a/Data/Array/Parallel/Unlifted/Sequential/USegd.hs b/Data/Array/Parallel/Unlifted/Sequential/USegd.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Sequential/USegd.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -fno-warn-orphans #-} +#include "fusion-phases.h" + +-- | Segment Descriptors. +-- +-- See "Data.Array.Parallel.Unlifted" for how this works. +-- +module Data.Array.Parallel.Unlifted.Sequential.USegd + ( -- * Types + USegd(..) + + -- * Constructors + , mkUSegd, valid + , empty, singleton + , fromLengths + + -- * Projections + , length + , takeLengths, takeIndices, takeElements + , getSeg + + -- * Operations + , append, slice, extract) +where +import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as U +import Data.Array.Parallel.Unlifted.Sequential.Vector (Vector) +import Data.Array.Parallel.Pretty hiding (empty) +import Prelude hiding (length) + +here :: String -> String +here s = "Data.Array.Parallel.Unlifted.Sequential.USegd." ++ s + + +-- | Segment descriptor. +data USegd + = USegd + { usegd_lengths :: !(Vector Int) -- ^ Length of each segment. + , usegd_indices :: !(Vector Int) -- ^ Starting index of each segment. + , usegd_elements :: !Int -- ^ Total number of elements in the flat array. + } deriving (Show, Eq) + + +instance PprPhysical USegd where + pprp (USegd lengths indices elements) + = text "USegd" + $$ (nest 7 $ vcat + [ text "lengths: " <+> (text $ show $ U.toList lengths) + , text "indices: " <+> (text $ show $ U.toList indices) + , text "elements:" <+> (text $ show elements)]) + + +-- Constructors --------------------------------------------------------------- +-- | O(1). Construct a new segment descriptor. +mkUSegd + :: Vector Int -- ^ Length of each segment. + -> Vector Int -- ^ Starting index of each segment. + -> Int -- ^ Total number of elements in the flat array. + -> USegd + +mkUSegd = USegd +{-# INLINE_U mkUSegd #-} + + +-- | O(1). Check the internal consistency of a segment descriptor. +-- +-- As the indices and elemens field can be generated based on the segment +-- lengths, we check the consistency by rebuilding these fields and +-- comparing the rebuilt ones against the originals. +valid :: USegd -> Bool +valid usegd@(USegd lengths _ _) + = usegd == fromLengths lengths +{-# NOINLINE valid #-} +-- NOINLINE because it's only enabled during debugging anyway. + + +-- | O(1). Construct an empty segment descriptor, with no elements or segments. +empty :: USegd +empty = USegd U.empty U.empty 0 +{-# INLINE_U empty #-} + + +-- | O(1). Construct a singleton segment descriptor. +-- The single segment covers the given number of elements. +singleton :: Int -> USegd +singleton n + = USegd (U.singleton n) (U.singleton 0) n +{-# INLINE_U singleton #-} + + +-- | O(segs). Convert an array of segment lengths into a segment descriptor. +-- +-- The array contains the length of each segment, and we compute the +-- indices from that. +fromLengths :: Vector Int -> USegd +fromLengths lens + = USegd lens (U.scanl (+) 0 lens) (U.sum lens) +{-# INLINE_U fromLengths #-} + + +-- Projections ---------------------------------------------------------------- +-- INLINE trivial projections as they'll expand to a single record selector. + +-- | O(1). Yield the overall number of segments. +length :: USegd -> Int +length = U.length . usegd_lengths +{-# INLINE length #-} + + +-- | O(1). Yield the lengths of the individual segments. +takeLengths :: USegd -> Vector Int +takeLengths = usegd_lengths +{-# INLINE takeLengths #-} + + +-- | O(1). Yield the segment indices of a segment descriptor. +takeIndices :: USegd -> Vector Int +takeIndices = usegd_indices +{-# INLINE takeIndices #-} + + +-- | O(1). Yield the number of data elements. +takeElements :: USegd -> Int +takeElements = usegd_elements +{-# INLINE takeElements #-} + + +-- | O(1). Get the length and segment index of a segment +getSeg :: USegd -> Int -> (Int, Int) +getSeg (USegd lengths indices _ ) ix + = ( U.index (here "getSeg") lengths ix + , U.index (here "getSeg") indices ix) +{-# INLINE_U getSeg #-} + + +-- Operators ------------------------------------------------------------------ +-- | O(segs). Produce a segment descriptor that describes the result of appending +-- two arrays. +append :: USegd -> USegd -> USegd +append (USegd lengths1 indices1 elems1) + (USegd lengths2 indices2 elems2) + = USegd (lengths1 U.++ lengths2) + (indices1 U.++ U.map (+ elems1) indices2) + (elems1 + elems2) +{-# INLINE_U append #-} + + +-- | O(segs) Extract a slice of a segment descriptor, avoiding copying where possible. +-- +-- We can share the segment lengths with the original segment descriptor, +-- but still need to recompute the starting indices of each. Hence +-- runtime is O(segs) in the number of segments sliced out. + +-- NOTE: In the new segment descriptor, the starting index of the first +-- segment will be 0. +slice + :: USegd -- ^ Source segment descriptor. + -> Int -- ^ Index of first segment. + -> Int -- ^ Number of segments to slice out. + -> USegd +slice segd i n + = fromLengths $ U.unsafeSlice (takeLengths segd) i n +{-# INLINE_U slice #-} + + +-- | Extract a slice of a segment descriptor, copying everything. +-- +-- In contrast to `slice`, this function copies the array of +-- segment lengths as well as recomputing the starting indices of each. + +-- NOTE: In the new segment descriptor, the starting index of the first +-- segment will be 0. +extract + :: USegd -- ^ Source segment desciptor. + -> Int -- ^ Undex of the first segment. + -> Int -- ^ Number of segments to extract out. + -> USegd +extract segd i n + = fromLengths $ U.extract (takeLengths segd) i n +{-# INLINE_U extract #-} + diff --git a/Data/Array/Parallel/Unlifted/Sequential/USel.hs b/Data/Array/Parallel/Unlifted/Sequential/USel.hs --- a/Data/Array/Parallel/Unlifted/Sequential/USel.hs +++ b/Data/Array/Parallel/Unlifted/Sequential/USel.hs @@ -1,116 +1,94 @@ --- | A selector is a description of how to perform a `combine` operation. --- --- Suppose we are evaluating the following expression: --- --- @combine [F,F,T,F,T,T] [1,2,3] [4,5,6] = [4,5,1,6,2,3]@ --- --- This is difficult to parallelise. For each element in the result, the source --- array we get this element from depends on the tag values associated with --- all previous elements. --- --- However, if we going to perform several combines with the same tag array, we --- can precompute a selector that tells us where to get each element. The selector --- contains the original tags, as well as the source index telling us where to get --- each element for the result array. --- --- For example: --- --- @ --- tagsToIndices2 [F,F,T,F,T,T] -- tags --- = [0,1,0,2,1,2] -- indices --- @ --- --- This says get the first element from index 0 in the second array, then from index 1 in the second array, --- then index 0 in the first array ... --- --- The selector then consists of both the @tag@ and @indices@ arrays. --- {-# LANGUAGE CPP #-} - #include "fusion-phases.h" -module Data.Array.Parallel.Unlifted.Sequential.USel ( - -- * Types - USel2, +-- | Selectors. +-- +-- See "Data.Array.Parallel.Unlifted" for how this works. +-- +module Data.Array.Parallel.Unlifted.Sequential.USel + ( -- * Types + USel2(..) - -- * Operations on selectors - mkUSel2, - lengthUSel2, - tagsUSel2, indicesUSel2, elementsUSel2_0, elementsUSel2_1, - tagsToIndices2 -) where -import Data.Array.Parallel.Unlifted.Sequential.Vector as V -import qualified Data.Vector.Fusion.Stream as S -import Data.Vector.Fusion.Stream.Monadic ( Stream(..) ) -import Data.Array.Parallel.Base (Tag) + -- * Operations on selectors + , mkUSel2 + , lengthUSel2 + , tagsUSel2, indicesUSel2 + , elementsUSel2_0, elementsUSel2_1 + , tagsToIndices2) +where +import Data.Array.Parallel.Unlifted.Sequential.Vector as V +import qualified Data.Vector.Fusion.Stream as S +import Data.Vector.Fusion.Stream.Monadic ( Stream(..) ) +import Data.Array.Parallel.Base (Tag) --- | Abstract selector. --- Contains both the @tags@ and @indices@ arrays outlined above. +-- | Selector. data USel2 = USel2 { usel2_tags :: !(Vector Tag) , usel2_indices :: !(Vector Int) - , usel2_elements0 :: !Int -- ^ number of tags with value 0 - , usel2_elements1 :: !Int -- ^ number of tags with value 1 + , usel2_elements0 :: !Int -- ^ Number of tags with value 0. + , usel2_elements1 :: !Int -- ^ Number of tags with value 1. } -- | O(1). Construct a selector. -mkUSel2 :: Vector Tag -- ^ tags array - -> Vector Int -- ^ indices array - -> Int -- ^ number of elements taken from first array - -> Int -- ^ number of elements taken from second array +mkUSel2 :: Vector Tag -- ^ Tags array. + -> Vector Int -- ^ Indices array + -> Int -- ^ Number of elements taken from first array. + -> Int -- ^ Number of elements taken from second array. -> USel2 -{-# INLINE mkUSel2 #-} mkUSel2 = USel2 +{-# INLINE mkUSel2 #-} +-- Projections ---------------------------------------------------------------- +-- INLINE trivial projections as they'll expand to a single record selector. + -- | O(1). Get the number of elements represented by this selector. -- This is the length of the array returned by `combine`. lengthUSel2 :: USel2 -> Int +lengthUSel2 = V.length . usel2_tags {-# INLINE lengthUSel2 #-} -lengthUSel2 = V.length . usel2_tags -- | O(1). Get the tags array of a selector. tagsUSel2 :: USel2 -> Vector Tag {-# INLINE tagsUSel2 #-} -tagsUSel2 = usel2_tags +tagsUSel2 = usel2_tags -- | O(1). Get the indices array of a selector. indicesUSel2 :: USel2 -> Vector Int +indicesUSel2 = usel2_indices {-# INLINE indicesUSel2 #-} -indicesUSel2 = usel2_indices -- | O(1). Get the number of elements that will be taken from the first array. elementsUSel2_0 :: USel2 -> Int -{-# INLINE elementsUSel2_0 #-} elementsUSel2_0 = usel2_elements0 +{-# INLINE elementsUSel2_0 #-} -- | O(1). Get the number of elements that will be taken from the second array. elementsUSel2_1 :: USel2 -> Int -{-# INLINE elementsUSel2_1 #-} elementsUSel2_1 = usel2_elements1 +{-# INLINE elementsUSel2_1 #-} -- | O(n). Compute the source index for each element of the result array. tagsToIndices2 :: Vector Tag -> Vector Int -{-# INLINE tagsToIndices2 #-} tagsToIndices2 tags = unstream (mapAccumS add (0,0) (stream tags)) where add (i,j) 0 = ((i+1,j),i) add (i,j) _ = ((i,j+1),j) +{-# INLINE_STREAM tagsToIndices2 #-} mapAccumS :: (acc -> a -> (acc,b)) -> acc -> S.Stream a -> S.Stream b -{-# INLINE_STREAM mapAccumS #-} -mapAccumS f acc (Stream step s n) - = Stream step' (acc,s) n +mapAccumS f acc0 (Stream step s0 n) + = Stream step' (acc0,s0) n where {-# INLINE_INNER step' #-} step' (acc,s) @@ -120,3 +98,4 @@ in return $ S.Yield y (acc',s') S.Skip s' -> return $ S.Skip (acc,s') S.Done -> return S.Done +{-# INLINE_STREAM mapAccumS #-} diff --git a/Data/Array/Parallel/Unlifted/Sequential/UVSegd.hs b/Data/Array/Parallel/Unlifted/Sequential/UVSegd.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Sequential/UVSegd.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -Wall -fno-warn-orphans -fno-warn-missing-signatures #-} +#include "fusion-phases.h" + +-- | Virtual Segment Descriptors. +-- +-- See "Data.Array.Parallel.Unlifted" for how this works. +-- +module Data.Array.Parallel.Unlifted.Sequential.UVSegd + ( -- * Types + UVSegd(..) + + -- * Consistency check + , valid + + -- * Constructors + , mkUVSegd + , fromUSegd + , fromUSSegd + , empty + , singleton + , replicated + + -- * Predicates + , isManifest + , isContiguous + + -- * Projections + , length + , takeVSegids, takeVSegidsRedundant + , takeUSSegd, takeUSSegdRedundant + , takeLengths + , getSeg + + -- * Operators + , appendWith + , combine2 + , updateVSegs + , updateVSegsReachable + , unsafeDemoteToUSSegd + , unsafeDemoteToUSegd) +where +import Data.Array.Parallel.Unlifted.Sequential.USel +import Data.Array.Parallel.Unlifted.Sequential.USSegd (USSegd) +import Data.Array.Parallel.Unlifted.Sequential.USegd (USegd) +import Data.Array.Parallel.Unlifted.Sequential.Vector (Vector) +import Data.Array.Parallel.Pretty hiding (empty) +import Prelude hiding (length) +import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as U +import qualified Data.Array.Parallel.Unlifted.Sequential.USSegd as USSegd +import qualified Data.Array.Parallel.Unlifted.Sequential.USegd as USegd + +here :: String -> String +here s = "Data.Array.Parallel.Unlifted.Sequential.UVSegd." ++ s + + +-- UVSegd --------------------------------------------------------------------- +-- | Virtual segment descriptor. +---- +-- * TODO: It would probably be better to represent the vsegids as a lens (function) +-- instead of a vector of segids. Much of the time the vsegids are just @[0..n]@ +-- +data UVSegd + = UVSegd + { uvsegd_manifest :: !Bool + -- ^ When the vsegids field holds a lazy @(U.enumFromTo 0 (len - 1))@ + -- then this field is True. This lets us perform some operations like + -- `demoteToUPSSegd` without actually creating it. + + -- | Virtual segment identifiers that indicate what physical segment + -- to use for each virtual segment. + , uvsegd_vsegids_redundant :: Vector Int -- LAZY FIELD + , uvsegd_vsegids_culled :: Vector Int -- LAZY FIELD + + -- | Scattered segment descriptor that defines how physical segments + -- are layed out in memory. + , uvsegd_ussegd_redundant :: USSegd -- LAZY FIELD + , uvsegd_ussegd_culled :: USSegd -- LAZY FIELD + + -- IMPORTANT: + -- When vsegids are transformed due to a segmented replication operation, + -- if some of the segment lengths were zero, then we will end up with + -- physical segments that are unreachable from the vsegids. + -- + -- For some operations (like indexing) the fact that we have unreachable + -- psegids doesn't matter, but for others (like segmented fold) it does. + -- The problem is that we perform segmented fold by first folding all + -- the physical segments, then replicating the results according to the + -- vsegids. If no vsegids referenced a physical segment then we didn't + -- need to fold it. + -- + -- When vsegids are updated the version that may have unreachable psegs + -- is stored in the vsegids_redundant and upssegd_redundant. The _culled + -- versions are then set to a SUSPENDED call to callOnVSegids. If no + -- consumers every demand the culled version then we never need to compute + -- it. + -- + -- The vsegids_redundant field must also be lazy (no bang) because when it + -- has the value (V.enumFromTo 0 (len - 1)) we want to avoid building the + -- enumeration unless it's strictly demanded. + } + deriving (Show) + + +instance PprPhysical UVSegd where + pprp (UVSegd _ _ vsegids _ ussegd) + = vcat + [ text "UVSegd" $$ (nest 7 $ text "vsegids: " <+> (text $ show $ U.toList vsegids)) + , pprp ussegd ] + + + +-- | O(1). Check the internal consistency of a virutal segmentation descriptor. +--- +-- * TODO: check that all vsegs point to a valid pseg +valid :: UVSegd -> Bool +valid (UVSegd _ _ vsegids _ ussegd) + = U.length vsegids == USSegd.length ussegd +{-# NOINLINE valid #-} +-- NOINLINE because it's only enabled during debugging anyway. + + +-- Constructors --------------------------------------------------------------- +-- | O(1). Construct a new virtual segment descriptor. +-- All the provided arrays must have the same lengths. +mkUVSegd + :: Vector Int -- ^ (vsegids) Mapping from virtual to physical segments. + -> USSegd -- ^ Scattered Segment descriptor defining the + -- physical segments. + -> UVSegd + +mkUVSegd vsegids ussegd + = UVSegd False vsegids vsegids ussegd ussegd +{-# INLINE mkUVSegd #-} + + +-- | O(segs). Promote a plain `USegd` to a `UVSegd`. +-- +-- The result contains one virtual segment for every physical segment +-- the provided `Segd`. +fromUSSegd :: USSegd -> UVSegd +fromUSSegd ussegd + = let vsegids = U.enumFromTo 0 (USSegd.length ussegd - 1) + in UVSegd True vsegids vsegids ussegd ussegd +{-# INLINE_U fromUSSegd #-} + + +-- | O(segs). Promote a plain `Segd` to a `VSegd`. +-- +-- The result contains one virtual segment for every physical segment +-- the provided `SSegd`. +fromUSegd :: USegd -> UVSegd +fromUSegd + = fromUSSegd . USSegd.fromUSegd +{-# INLINE_U fromUSegd #-} + + +-- | O(1). Construct an empty segment descriptor, with no elements or segments. +empty :: UVSegd +empty + = let vsegids = U.empty + ssegd = USSegd.empty + in UVSegd True vsegids vsegids ssegd ssegd +{-# INLINE_U empty #-} + + +-- | O(1). Construct a singleton segment descriptor. +-- The single segment covers the given number of elements in a flat array +-- with sourceid 0. +singleton :: Int -> UVSegd +singleton n + = let vsegids = U.singleton 0 + ssegd = USSegd.singleton n + in UVSegd True vsegids vsegids ssegd ssegd +{-# INLINE_U singleton #-} + + +-- | O(1). Construct a `UVSegd` that describes an array created by replicating +-- a single segment several times. +--- +-- NOTE: This is a helpful target for rewrite rules, because when we +-- see a 'replicated' we know that all segments in the virtual array +-- point to the same data. +replicated + :: Int -- ^ Length of segment. + -> Int -- ^ Number of times replicated. + -> UVSegd + +replicated len reps + = let -- We have a single physical segment. + ssegd = USSegd.singleton len + + -- All virtual segments point to the same physical segment. + in mkUVSegd (U.replicate reps 0) ssegd +{-# INLINE_U replicated #-} + + +-- Predicates ----------------------------------------------------------------- +-- | O(1). Checks whether all the segments are manifest (unshared / non-virtual). +-- If this is the case, then the vsegids field will be [0..len-1]. +-- +-- Consumers can check this field, avoid demanding the vsegids field. +-- This can avoid the need for it to be generated in the first place, due to +-- lazy evaluation. +-- +isManifest :: UVSegd -> Bool +isManifest = uvsegd_manifest +{-# INLINE isManifest #-} + + +-- | O(1). Checks whether the starts are identical to the usegd indices field and +-- the sourceids are all 0's. +-- +-- In this case all the data elements are in one contiguous flat +-- array, and consumers can avoid looking at the real starts and +-- sources fields. +-- +isContiguous :: UVSegd -> Bool +isContiguous = USSegd.isContiguous . uvsegd_ussegd_culled +{-# INLINE isContiguous #-} + + +-- Projections ---------------------------------------------------------------- +-- INLINE trivial projections as they'll expand to a single record selector. + +-- | O(1). Yield the vsegids of a `UVSegd` +takeVSegids :: UVSegd -> Vector Int +takeVSegids = uvsegd_vsegids_culled +{-# INLINE takeVSegids #-} + + +-- | O(1). Take the vsegids of a `UVSegd`, but don't require that every physical +-- segment is referenced by some virtual segment. +-- +-- If you're just performing indexing and don't need the invariant that all +-- physical segments are reachable from some virtual segment, then use this +-- version as it's faster. This sidesteps the code that maintains the invariant. +-- +-- The stated O(1) complexity assumes that the array has already been fully +-- evalauted. If this is not the case then we can avoid demanding the result +-- of a prior computation on the vsegids, thus reducing the cost attributed +-- to that prior computation. +takeVSegidsRedundant :: UVSegd -> Vector Int +takeVSegidsRedundant = uvsegd_vsegids_redundant +{-# INLINE takeVSegidsRedundant #-} + + +-- | O(1). Yield the `USSegd` of a `UVSegd`. +takeUSSegd :: UVSegd -> USSegd +takeUSSegd = uvsegd_ussegd_culled +{-# INLINE takeUSSegd #-} + + +-- | O(1). Take the `UPSSegd` of a `UPVSegd`, but don't require that every physical +-- segment is referenced by some virtual segment. +-- +-- See the note in `takeVSegidsRedundant`. +takeUSSegdRedundant :: UVSegd -> USSegd +takeUSSegdRedundant = uvsegd_ussegd_redundant +{-# INLINE takeUSSegdRedundant #-} + + +-- | O(1). Yield the overall number of segments described by a `UVSegd`. +length :: UVSegd -> Int +length = U.length . uvsegd_vsegids_redundant +{-# INLINE length #-} + + +-- | O(segs). Yield the lengths of the segments described by a `UVSegd`. +takeLengths :: UVSegd -> Vector Int +takeLengths (UVSegd manifest _ vsegids _ ussegd) + | manifest = USSegd.takeLengths ussegd + | otherwise + = let !lengths = USSegd.takeLengths ussegd + in U.map (U.index (here "takeLengths") lengths) vsegids +{-# NOINLINE takeLengths #-} +-- NOINLINE because we don't want a case expression due to the test on the +-- manifest flag to appear in the core program. + + +-- | O(1). Get the length, starting index, and source id of a segment. + +-- NOTE: We don't return the segment index field from the USSegd as this refers +-- to the flat index relative to the SSegd array, rather than +-- relative to the UVSegd array. If we tried to promote the USSegd index +-- to a UVSegd index it could overflow. +-- +getSeg :: UVSegd -> Int -> (Int, Int, Int) +getSeg uvsegd ix + = let vsegids = uvsegd_vsegids_redundant uvsegd + ussegd = uvsegd_ussegd_redundant uvsegd + (len, _index, start, source) + = USSegd.getSeg ussegd (U.index (here "getSeg") vsegids ix) + in (len, start, source) +{-# INLINE_U getSeg #-} + + +-- Demotion ------------------------------------------------------------------- +-- | O(segs). Yield a `USSegd` that describes each segment of a `UVSegd` +-- individually. +-- +-- * By doing this we lose information about virtual segments corresponding +-- to the same physical segments. +-- +-- * This operation is used in concatPR as the first step in eliminating +-- segmentation from a nested array. +-- +unsafeDemoteToUSSegd :: UVSegd -> USSegd +unsafeDemoteToUSSegd uvsegd + | uvsegd_manifest uvsegd = uvsegd_ussegd_culled uvsegd -- TODO: take the redundant ones + | otherwise + = let vsegids = uvsegd_vsegids_culled uvsegd + ussegd = uvsegd_ussegd_culled uvsegd + starts' = U.bpermute (USSegd.takeStarts ussegd) vsegids + sources' = U.bpermute (USSegd.takeSources ussegd) vsegids + lengths' = U.bpermute (USSegd.takeLengths ussegd) vsegids + usegd' = USegd.fromLengths lengths' + in USSegd.mkUSSegd starts' sources' usegd' +{-# NOINLINE unsafeDemoteToUSSegd #-} +-- NOINLINE because it's complicated and won't fuse with anything. + + +-- | O(segs). Yield a `USegd` that describes each segment of a `UVSegd` +-- individually, assuming all segments have been concatenated to +-- remove scattering. +-- +-- /WARNING/: Trying to take the `UPSegd` of a nested array that has been +-- constructed with replication can cause index space overflow. This is +-- because the virtual size of the corresponding flat data can be larger +-- than physical memory. If this happens then indices fields and +-- element count in the result will be invalid. +-- +-- +unsafeDemoteToUSegd :: UVSegd -> USegd +unsafeDemoteToUSegd (UVSegd _ _ vsegids _ ussegd) + = USegd.fromLengths + $ U.bpermute (USSegd.takeLengths ussegd) vsegids +{-# NOINLINE unsafeDemoteToUSegd #-} +-- NOINLINE because it won't fuse with anything. + + + + +-- Operators ------------------------------------------------------------------ +-- | Update the vsegids of `UPVSegd`, and then cull the physical +-- segment descriptor so that all phsyical segments are reachable from +-- some virtual segment. +-- +-- This function lets you perform filtering operations on the virtual segments, +-- while maintaining the invariant that all physical segments are referenced +-- by some virtual segment. +-- +updateVSegs :: (Vector Int -> Vector Int) -> UVSegd -> UVSegd +updateVSegs fUpdate (UVSegd _ _ vsegids _ ussegd) + = let -- When we transform the vsegids, we don't know whether they all + -- made it into the result. + vsegids_redundant = fUpdate vsegids + + -- Cull the psegs down to just those reachable from the vsegids, + -- but do it lazilly so consumers can avoid demanding this + -- culled version and save creating it. + ( vsegids_culled + , ussegd_culled) = USSegd.cullOnVSegids vsegids_redundant ussegd + + in UVSegd False + vsegids_redundant vsegids_culled + ussegd ussegd_culled +{-# INLINE_U updateVSegs #-} +-- INLINE_UP because we want to inline the parameter function fUpdate. + + +-- | Update the vsegids of `UPVSegd`, where the result covers +-- all physical segments. +-- +-- * The resulting vsegids must cover all physical segments. +-- If they do not then there will be physical segments that are not +-- reachable from some virtual segment, and performing operations like +-- segmented fold will waste work. +-- +-- * Using this version saves performing the 'cull' operation which +-- discards unreachable physical segments. This is O(result segments), +-- but can be expensive in absolute terms. +-- +updateVSegsReachable :: (Vector Int -> Vector Int) -> UVSegd -> UVSegd +updateVSegsReachable fUpdate (UVSegd _ _ vsegids _ ssegd) + = let vsegids' = fUpdate vsegids + in UVSegd False vsegids' vsegids' ssegd ssegd +{-# INLINE_UP updateVSegsReachable #-} +-- INLINE_UP because we want to inline the parameter function fUpdate. + + + +-- append --------------------------------------------------------------------- +-- | O(n) +-- Produce a segment descriptor describing the result of appending two arrays. + +-- Note that the implementation of this is similar to `combine2UVSegd` +-- @ +-- source1 +-- VIRT1 [[0],[4,2],[5,6,7,8,9]] +-- PHYS1 UVSegd vsegids: [0,1,2] +-- USSegd pseglens: [1,2,5] +-- psegstarts: [0,1,3] +-- psegsrcs: [0,0,0] +-- PData PInt [0,4,2,5,6,7,8,9] +-- +-- source2 +-- VIRT2 [[1,2,3],[8,6,3],[9,3]] +-- PHYS2 UVSegd vsegids: [0,1,2] +-- USSegd pseglens: [3,3,2] +-- psegstarts: [0,3,6] +-- psegsrcs: [0,0,0] +-- PData PInt [1,2,3,8,6,3,9,3] +-- +-- appended +-- VIRT [[0],[4,2],[5,6,7,8,9],[1,2,3],[8,6,3],[9,3]] +-- UVSegd vsegids: [0,1,2,3,4,5] -- shift second half +-- USSegd pseglens: [1,2,5,3,3,2] -- appended +-- psegstarts: [0,1,3,0,3,6] -- appended +-- psegsrcs: [0,0,0,1,1,1] -- shift second half +-- PData PInt [0,4,2,5,6,7,8,9] -- both pdatas in result +-- PInt [1,2,3,8,6,3,9,3] -- ... +-- @ +-- +appendWith + :: UVSegd -- ^ Descriptor of first array. + -> Int -- ^ Number of flat physical arrays for first descriptor. + -> UVSegd -- ^ Descriptor of second array. + -> Int -- ^ Number of flat physical arrays for second descriptor. + -> UVSegd + +appendWith + (UVSegd _ _ vsegids1 _ ussegd1) pdatas1 + (UVSegd _ _ vsegids2 _ ussegd2) pdatas2 + + = let -- vsegids releative to appended psegs + vsegids1' = vsegids1 + vsegids2' = U.map (+ USSegd.length ussegd1) vsegids2 + + -- append the vsegids + vsegids' = vsegids1' U.++ vsegids2' + + -- All data from the source arrays goes into the result + ussegd' = USSegd.appendWith + ussegd1 pdatas1 + ussegd2 pdatas2 + + in UVSegd False vsegids' vsegids' ussegd' ussegd' +{-# INLINE_U appendWith #-} + + +-- combine -------------------------------------------------------------------- +-- | O(n). Combine two virtual segment descriptors. + + +-- Note that the implementation of this is similar to `appendUVSegd` +-- @ +-- source1 +-- VIRT1 [[0],[4,2],[5,6,7,8,9]] +-- PHYS1 UVSegd vsegids: [0,1,2] +-- USSegd pseglens: [1,2,5] +-- psegstarts: [0,1,3] +-- psegsrcs: [0,0,0] +-- PDATA PInt [0,4,2,5,6,7,8,9] +-- +-- source2 +-- VIRT2 [[1,2,3],[8,6,3],[9,3]] +-- PHYS2 UVSegd vsegids: [0,1,2] +-- USSegd pseglens: [3,3,2] +-- psegstarts: [0,3,6] +-- psegsrcs: [0,0,0] +-- PData PInt [1,2,3,8,6,3,9,3] +-- +-- combined with tags [1,0,0,1,0,1] +-- VIRT [[1,2,3],[0],[4,2],[8,6,3],[5,6,7,8,9],[9,3]] +-- PHYS VSSegd vsegids: [3,0,1,4,2,5] -- combine shifted vsegs +-- USSegd pseglens: [1,2,5,3,3,2] -- appended +-- psegstarts: [0,1,3,0,3,6] -- appended +-- psegsrcs: [0,0,0,1,1,1] -- shift second half +-- PData PInt [0,4,2,5,6,7,8,9] -- both pdatas in result +-- PInt [1,2,3,8,6,3,9,3] +-- @ +-- +combine2 + :: USel2 -- ^ Selector for the combine operation. + -> UVSegd -- ^ Descriptor of first array. + -> Int -- ^ Number of flat physical arrays for first descriptor. + -> UVSegd -- ^ Descriptor of second array. + -> Int -- ^ Number of flat physical arrays for second descriptor. + -> UVSegd + +combine2 usel2 + (UVSegd _ _ vsegids1 _ ussegd1) pdatas1 + (UVSegd _ _ vsegids2 _ ussegd2) pdatas2 + + = let -- vsegids relative to combined psegs + vsegids1' = vsegids1 + vsegids2' = U.map (+ (U.length vsegids1)) vsegids2 + + -- combine the vsegids + vsegids' = U.combine2ByTag (tagsUSel2 usel2) + vsegids1' vsegids2' + + -- All data from the source arrays goes into the result + ussegd' = USSegd.appendWith + ussegd1 pdatas1 + ussegd2 pdatas2 + + in UVSegd False vsegids' vsegids' ussegd' ussegd' +{-# INLINE_U combine2 #-} diff --git a/Data/Array/Parallel/Unlifted/Sequential/Vector.hs b/Data/Array/Parallel/Unlifted/Sequential/Vector.hs --- a/Data/Array/Parallel/Unlifted/Sequential/Vector.hs +++ b/Data/Array/Parallel/Unlifted/Sequential/Vector.hs @@ -1,8 +1,15 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns, CPP #-} - +{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, BangPatterns, CPP #-} +{-# OPTIONS -w #-} -- TODO: enable warnings #include "fusion-phases.h" --- | Wrappers for primitives defined in @Data.Vector@ +-- | Wrappers for primitives defined in @Data.Vector@. +-- +-- * This is an internal API and shouldn't need to be used directly. +-- Client programs should use "Data.Array.Parallel.Unlifted". +-- + +-- This module doesn't have docs because the bindings are mostly just +-- forwards for the Data.Vector functions. See there for details. module Data.Array.Parallel.Unlifted.Sequential.Vector ( -- * Array classes @@ -17,18 +24,22 @@ -- * Basic operations length, null, empty, singleton, cons, units, replicate, - -- replicateEachU, - (!), (++), + (++), index, interleave, indexed, repeat, repeatS, -- * Subarrays - slice, extract, + slice, unsafeSlice, + extract, unsafeExtract, tail, take, drop, splitAt, -- * Permutations - permute, bpermute, mbpermute, bpermuteDft, reverse, update, - + permute, + bpermute, + mbpermute, + bpermuteDft, + reverse, + update, -- * Higher-order operations map, zipWith, zipWith3, @@ -47,17 +58,22 @@ and, or, any, all, -- * Arithmetic operations - sum, product, - maximum, minimum, - maximumBy, minimumBy, - maxIndex, minIndex, + sum, product, + maximum, minimum, + maximumBy, minimumBy, + maxIndex, minIndex, maxIndexBy, minIndexBy, -- * Arrays of pairs - zip, unzip, fsts, snds, + zip, unzip, fsts, snds, + zip3, unzip3, -- * Enumerations - enumFromTo, enumFromThenTo, enumFromStepLen, enumFromToEach, enumFromStepLenEach, + enumFromTo, + enumFromThenTo, + enumFromStepLen, + enumFromToEach, + enumFromStepLenEach, -- * Searching find, findIndex, @@ -77,74 +93,81 @@ -- * I\/O UIO(..) +) +where +import Data.Array.Parallel.Unlifted.Stream.Segmented +import Data.Array.Parallel.Base ( Tag, checkEq, ST ) +import qualified Data.Array.Parallel.Base as B +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as M +import qualified Data.Vector.Unboxed.Base as VBase +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as MG +import qualified Data.Vector.Storable as Storable +import qualified Data.Vector.Storable.Mutable as MStorable +import qualified Data.Vector.Generic.New as New +import qualified Data.Vector.Fusion.Stream as S +import Data.Vector.Fusion.Stream.Monadic ( Stream(..), Step(..) ) +import Data.Vector.Fusion.Stream.Size ( Size(..) ) +import Data.Vector.Generic ( stream, unstream ) -) where +import Data.Vector.Unboxed + hiding ( slice, zip, unzip, zip3, unzip3, foldl, foldl1, scanl, scanl1, + unsafeSlice ) -import Data.Array.Parallel.Stream -import Data.Array.Parallel.Base ( Tag, checkEq, ST ) +import Prelude + hiding ( length, null, + replicate, (++), repeat, + tail, take, drop, splitAt, + reverse, + map, zipWith, zipWith3, filter, + foldl, foldl1, scanl, scanl1, + elem, notElem, + and, or, any, all, + sum, product, + maximum, minimum, + zip, unzip, zip3, unzip3, + enumFromTo, enumFromThenTo ) -import Data.Vector.Unboxed hiding ( slice, zip, unzip, foldl, foldl1, scanl, scanl1 ) -import qualified Data.Vector.Unboxed as V -import qualified Data.Vector.Unboxed.Mutable as M -import qualified Data.Vector.Unboxed.Base as VBase -import Data.Vector.Generic ( stream, unstream ) -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Generic.Mutable as MG -import qualified Data.Vector.Storable as Storable -import qualified Data.Vector.Storable.Mutable as MStorable -import qualified Data.Vector.Generic.New as New -import qualified Data.Vector.Fusion.Stream as S -import Data.Vector.Fusion.Stream.Monadic ( Stream(..), Step(..) ) -import Data.Vector.Fusion.Stream.Size ( Size(..) ) -import Prelude hiding ( length, null, - replicate, (++), repeat, - tail, take, drop, splitAt, - reverse, - map, zipWith, zipWith3, filter, - foldl, foldl1, scanl, scanl1, - elem, notElem, - and, or, any, all, - sum, product, - maximum, minimum, - zip, unzip, - enumFromTo, enumFromThenTo ) import qualified Prelude import qualified System.Random as R import Foreign hiding ( new ) import System.IO +import Control.Monad here s = "Data.Array.Parallel.Unlifted.Sequential.Flat." Prelude.++ s - +------------------------------------------------------------------------------- new :: Unbox a => Int -> (forall s. MVector s a -> ST s ()) -> Vector a +new n p + = V.create + $ do v <- M.new n + p v + return v {-# INLINE new #-} -new n p = V.create (do - v <- M.new n - p v - return v) newM :: Unbox a => Int -> ST s (MVector s a) -{-# INLINE newM #-} newM = M.new +{-# INLINE newM #-} --- | Yield an array of units +-- Yield an array of units units :: Int -> Vector () -{-# INLINE units #-} units n = replicate n () +{-# INLINE units #-} --- | Interleave the elements of two arrays +-- Interleave the elements of two arrays interleave :: Unbox e => Vector e -> Vector e -> Vector e -{-# INLINE_U interleave #-} interleave xs ys = unstream (interleaveS (stream xs) (stream ys)) +{-# INLINE_U interleave #-} --- | Repeat an array @n@ times +-- Repeat an array @n@ times repeat :: Unbox e => Int -> Vector e -> Vector e -{-# INLINE_U repeat #-} repeat n xs = unstream (repeatS n xs) +{-# INLINE_U repeat #-} repeatS :: Unbox e => Int -> Vector e -> S.Stream e @@ -159,55 +182,85 @@ | otherwise = return $ Yield (unsafeIndex xs i) (i+1,k) -slice :: Unbox a => Vector a -> Int -> Int -> Vector a +-- Take a sub-range of a vector, avoiding copying. +slice :: Unbox a => String -> Vector a -> Int -> Int -> Vector a +slice here xs i n + = B.checkSlice here (V.length xs) i n + $ V.slice i n xs {-# INLINE_U slice #-} -slice xs i n = V.slice i n xs +-- Take a sub-range of a vector, avoiding copying, without bounds checks. +unsafeSlice :: Unbox a => Vector a -> Int -> Int -> Vector a +unsafeSlice xs i n = V.unsafeSlice i n xs +{-# INLINE_U unsafeSlice #-} + + +index :: Unbox a => String -> Vector a -> Int -> a +index here vec ix + = B.check here (V.length vec) ix + $ V.unsafeIndex vec ix +{-# INLINE_U index #-} + + +-- Copy out a subrange of a vector. extract :: Unbox a => Vector a -> Int -> Int -> Vector a {-# INLINE_U extract #-} -extract xs i n = force (V.slice i n xs) +extract xs i n + = force (V.slice i n xs) +-- Copy out a subrange of a vector, without bounds checks. +unsafeExtract :: Unbox a => Vector a -> Int -> Int -> Vector a +unsafeExtract xs i n = force (V.unsafeSlice i n xs) +{-# INLINE_U unsafeExtract #-} + + mupdate :: Unbox e => MVector s e -> Vector (Int,e) -> ST s () +mupdate marr xs + = MG.update marr (stream xs) {-# INLINE_U mupdate #-} -mupdate marr xs = MG.update marr (stream xs) mpermute :: Unbox e => MVector s e -> Vector e -> Vector Int -> ST s () +mpermute marr xs is + = MG.update marr (stream (zip is xs)) {-# INLINE_U mpermute #-} -mpermute marr xs is = MG.update marr (stream (zip is xs)) permute :: Unbox e => Vector e -> Vector Int -> Vector e {-# INLINE_U permute #-} -permute xs is = create (do - v <- M.new (length xs) - mpermute v xs is - return v) +permute xs is + = create + $ do v <- M.new (length xs) + mpermute v xs is + return v bpermute :: Unbox e => Vector e -> Vector Int -> Vector e -{-# INLINE_U bpermute #-} bpermute = backpermute +{-# INLINE_U bpermute #-} mbpermute :: (Unbox e, Unbox d) => (e -> d) -> Vector e -> Vector Int -> Vector d +mbpermute f es is + = unstream (mbpermuteS f es (stream is)) {-# INLINE_STREAM mbpermute #-} -mbpermute f es is = unstream (mbpermuteS f es (stream is)) bpermuteS :: Unbox e => Vector e -> S.Stream Int -> S.Stream e +bpermuteS !a s + = S.map (a!) s {-# INLINE_STREAM bpermuteS #-} -bpermuteS !a s = S.map (a!) s mbpermuteS:: Unbox e => (e -> d) -> Vector e -> S.Stream Int -> S.Stream d +mbpermuteS f !a + = S.map (f . (a!)) {-# INLINE_STREAM mbpermuteS #-} -mbpermuteS f !a = S.map (f . (a!)) --- | Default back permute +-- Default back permute -- -- * The values of the index-value pairs are written into the position in the -- result array that is indicated by the corresponding index. @@ -216,125 +269,130 @@ -- determined by the initialiser function for that index position. -- bpermuteDft :: Unbox e - => Int -- ^ length of result array - -> (Int -> e) -- ^ initialiser function - -> Vector (Int,e) -- ^ index-value pairs + => Int -- length of result array + -> (Int -> e) -- initialiser function + -> Vector (Int,e) -- index-value pairs -> Vector e +bpermuteDft n init + = update (map init (enumFromN 0 n)) {-# INLINE_U bpermuteDft #-} -bpermuteDft n init = update (map init (enumFromN 0 n)) --- | Extract all elements from an array according to a given flag array +-- Extract all elements from an array according to a given flag array pack:: Unbox e => Vector e -> Vector Bool -> Vector e -{-# INLINE_U pack #-} pack xs = map fst . filter snd . zip xs +{-# INLINE_U pack #-} combine :: Unbox a => Vector Bool -> Vector a -> Vector a -> Vector a +combine bs + = combine2ByTag (map (\b -> if b then 0 else 1) bs) {-# INLINE combine #-} -combine bs = combine2ByTag (map (\b -> if b then 0 else 1) bs) combine2ByTag :: Unbox a => Vector Tag -> Vector a -> Vector a -> Vector a -{-# INLINE_U combine2ByTag #-} combine2ByTag ts xs ys = checkEq (here "combine2ByTag") ("tags length /= sum of args length") (length ts) (length xs + length ys) $ unstream (combine2ByTagS (stream ts) (stream xs) (stream ys)) +{-# INLINE_U combine2ByTag #-} --- | Array reduction proceeding from the left +-- Array reduction proceeding from the left foldl :: Unbox a => (b -> a -> b) -> b -> Vector a -> b -{-# INLINE_U foldl #-} foldl = foldl' +{-# INLINE_U foldl #-} --- | Array reduction proceeding from the left for non-empty arrays +-- Array reduction proceeding from the left for non-empty arrays foldl1 :: Unbox a => (a -> a -> a) -> Vector a -> a -{-# INLINE_U foldl1 #-} foldl1 = foldl1' +{-# INLINE_U foldl1 #-} --- | Array reduction that requires an associative combination function with its --- unit + +-- Array reduction that requires an associative combination function with its +-- unit fold :: Unbox a => (a -> a -> a) -> a -> Vector a -> a -{-# INLINE_U fold #-} fold = foldl +{-# INLINE_U fold #-} --- | Reduction of a non-empty array which requires an associative combination --- function +-- Reduction of a non-empty array which requires an associative combination +-- function fold1 :: Unbox a => (a -> a -> a) -> Vector a -> a -{-# INLINE_U fold1 #-} fold1 = foldl1 +{-# INLINE_U fold1 #-} foldl1Maybe :: Unbox a => (a -> a -> a) -> Vector a -> Maybe a -{-# INLINE_U foldl1Maybe #-} foldl1Maybe f xs = foldl' join Nothing xs where {-# INLINE join #-} join Nothing y = Just $! y join (Just x) y = Just $! f x y +{-# INLINE_U foldl1Maybe #-} fold1Maybe :: Unbox a => (a -> a -> a) -> Vector a -> Maybe a -{-# INLINE_U fold1Maybe #-} fold1Maybe = foldl1Maybe +{-# INLINE_U fold1Maybe #-} --- | Prefix scan proceedings from left to right + +-- Prefix scan proceedings from left to right scanl :: (Unbox a, Unbox b) => (b -> a -> b) -> b -> Vector a -> Vector b -{-# INLINE_U scanl #-} scanl = prescanl' +{-# INLINE_U scanl #-} --- | Prefix scan of a non-empty array proceeding from left to right +-- Prefix scan of a non-empty array proceeding from left to right scanl1 :: Unbox a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE_U scanl1 #-} scanl1 = scanl1' +{-# INLINE_U scanl1 #-} --- | Prefix scan proceeding from left to right that needs an associative --- combination function with its unit +-- Prefix scan proceeding from left to right that needs an associative +-- combination function with its unit scan :: Unbox a => (a -> a -> a) -> a -> Vector a -> Vector a -{-# INLINE_U scan #-} scan = scanl +{-# INLINE_U scan #-} --- | Prefix scan of a non-empty array proceeding from left to right that needs --- an associative combination function +-- Prefix scan of a non-empty array proceeding from left to right that needs +-- an associative combination function scan1 :: Unbox a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE_U scan1 #-} scan1 = scanl1 +{-# INLINE_U scan1 #-} scanRes :: Unbox a => (a -> a -> a) -> a -> Vector a -> (Vector a,a) +scanRes f z xs + = let ys = scanl' f z xs + in (unsafeInit ys, unsafeLast ys) {-# INLINE_U scanRes #-} -scanRes f z xs = let ys = scanl' f z xs - in - (unsafeInit ys, unsafeLast ys) fsts :: (Unbox a, Unbox b) => Vector (a,b) -> Vector a -{-# INLINE_STREAM fsts #-} fsts (VBase.V_2 _ xs ys) = xs +{-# INLINE_STREAM fsts #-} snds :: (Unbox a, Unbox b) => Vector (a,b) -> Vector b -{-# INLINE_STREAM snds #-} snds (VBase.V_2 _ xs ys) = ys +{-# INLINE_STREAM snds #-} zip :: (Unbox a, Unbox b) => Vector a -> Vector b -> Vector (a,b) -{-# INLINE_STREAM zip #-} zip !xs !ys = V.zip xs ys +{-# INLINE_STREAM zip #-} unzip :: (Unbox a, Unbox b) => Vector (a,b) -> (Vector a, Vector b) -{-# INLINE_STREAM unzip #-} unzip ps = V.unzip ps +{-# INLINE_STREAM unzip #-} + {-# RULES "fsts/new/unstream [dph-prim-seq]" forall xs. @@ -349,63 +407,85 @@ #-} +zip3 :: (Unbox a, Unbox b, Unbox c) + => Vector a -> Vector b -> Vector c -> Vector (a,b,c) +zip3 !xs !ys !zs + = V.zip3 xs ys zs +{-# INLINE_STREAM zip3 #-} + + +unzip3 :: (Unbox a, Unbox b, Unbox c) + => Vector (a,b,c) -> (Vector a, Vector b, Vector c) +unzip3 ps = V.unzip3 ps +{-# INLINE_STREAM unzip3 #-} + + enumFromStepLen :: Int -> Int -> Int -> Vector Int -{-# INLINE_U enumFromStepLen #-} enumFromStepLen = enumFromStepN +{-# INLINE_U enumFromStepLen #-} enumFromToEach :: Int -> Vector (Int,Int) -> Vector Int +enumFromToEach n + = unstream . enumFromToEachS n . stream {-# INLINE_U enumFromToEach #-} -enumFromToEach n = unstream . enumFromToEachS n . stream enumFromStepLenEach :: Int -> Vector Int -> Vector Int -> Vector Int -> Vector Int -{-# INLINE_U enumFromStepLenEach #-} enumFromStepLenEach len starts steps lens - = unstream $ enumFromStepLenEachS len $ stream $ V.zip3 starts steps lens + = unstream + $ enumFromStepLenEachS len + $ stream + $ V.zip3 starts steps lens +{-# INLINE_U enumFromStepLenEach #-} random :: (Unbox a, R.Random a, R.RandomGen g) => Int -> g -> Vector a -{-# INLINE_U random #-} random n = unstream . randomS n +{-# INLINE_U random #-} randomR :: (Unbox a, R.Random a, R.RandomGen g) => Int -> (a,a) -> g -> Vector a -{-# INLINE_U randomR #-} randomR n r = unstream . randomRS n r +{-# INLINE_U randomR #-} randomS :: (R.RandomGen g, R.Random a) => Int -> g -> S.Stream a -{-# INLINE_STREAM randomS #-} -randomS n g = Stream step (g,n) (Exact n) +randomS n g + = Stream step (g,n) (Exact n) where {-# INLINE step #-} step (g,0) = return Done step (g,n) = let (x,g') = R.random g in return $ Yield x (g',n-1) +{-# INLINE_STREAM randomS #-} randomRS :: (R.RandomGen g, R.Random a) => Int -> (a,a) -> g -> S.Stream a -{-# INLINE_STREAM randomRS #-} -randomRS n r g = Stream step (g,n) (Exact n) +randomRS n r g + = Stream step (g,n) (Exact n) where {-# INLINE step #-} step (g,0) = return Done step (g,n) = let (x,g') = R.randomR r g in return $ Yield x (g',n-1) +{-# INLINE_STREAM randomRS #-} mdrop :: Unbox a => Int -> MVector s a -> MVector s a -{-# INLINE mdrop #-} mdrop = M.drop +{-# INLINE mdrop #-} mslice :: Unbox a => Int -> Int -> MVector s a -> MVector s a -{-# INLINE mslice #-} mslice = M.slice +{-# INLINE mslice #-} -hGetStorable :: forall a. Storable a => Handle -> IO (Storable.Vector a) +-- IO Functions --------------------------------------------------------------- +hGetStorable + :: forall a. Storable a + => Handle -> IO (Storable.Vector a) hGetStorable h = alloca $ \iptr -> do @@ -417,7 +497,9 @@ Storable.unsafeFreeze (MStorable.take r v) -hPutStorable :: forall a. Storable a => Handle -> Storable.Vector a -> IO () +hPutStorable + :: forall a. Storable a + => Handle -> Storable.Vector a -> IO () hPutStorable h xs = alloca $ \iptr -> do @@ -430,24 +512,26 @@ where !n = Storable.length xs + class Unbox a => UIO a where hPut :: Handle -> Vector a -> IO () hGet :: Handle -> IO (Vector a) primPut :: (Unbox a, Storable a) => Handle -> Vector a -> IO () -{-# INLINE primPut #-} primPut h = hPutStorable h . Storable.convert +{-# INLINE primPut #-} primGet :: (Unbox a, Storable a) => Handle -> IO (Vector a) -{-# INLINE primGet #-} primGet = fmap convert . hGetStorable +{-# INLINE primGet #-} instance UIO Int where {-# INLINE hPut #-} hPut = primPut + {-# INLINE hGet #-} hGet = primGet @@ -455,6 +539,7 @@ instance UIO Double where {-# INLINE hPut #-} hPut = primPut + {-# INLINE hGet #-} hGet = primGet @@ -469,4 +554,106 @@ hGet h = do xs <- hGet h ys <- hGet h return (V.zip xs ys) + + +-- Additional Unbox instances ------------------------------------------------- +newtype instance MVector s Ordering = MV_Ordering (M.MVector s Word8) +newtype instance Vector Ordering = V_Ordering (V.Vector Word8) + +instance Unbox Ordering + +instance MG.MVector MVector Ordering where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeGrow #-} + basicLength (MV_Ordering v) + = MG.basicLength v + + basicUnsafeSlice i n (MV_Ordering v) + = MV_Ordering $ MG.basicUnsafeSlice i n v + + basicOverlaps (MV_Ordering v1) (MV_Ordering v2) + = MG.basicOverlaps v1 v2 + + basicUnsafeNew n + = MV_Ordering `liftM` MG.basicUnsafeNew n + + basicUnsafeReplicate n x + = MV_Ordering `liftM` MG.basicUnsafeReplicate n (fromOrdering x) + + basicUnsafeRead (MV_Ordering v) i + = toOrdering `liftM` MG.basicUnsafeRead v i + + basicUnsafeWrite (MV_Ordering v) i x + = MG.basicUnsafeWrite v i (fromOrdering x) + + basicClear (MV_Ordering v) + = MG.basicClear v + + basicSet (MV_Ordering v) x + = MG.basicSet v (fromOrdering x) + + basicUnsafeCopy (MV_Ordering v1) (MV_Ordering v2) + = MG.basicUnsafeCopy v1 v2 + + basicUnsafeMove (MV_Ordering v1) (MV_Ordering v2) + = MG.basicUnsafeMove v1 v2 + + basicUnsafeGrow (MV_Ordering v) n + = MV_Ordering `liftM` MG.basicUnsafeGrow v n + + +instance G.Vector Vector Ordering where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze (MV_Ordering v) + = V_Ordering `liftM` G.basicUnsafeFreeze v + + basicUnsafeThaw (V_Ordering v) + = MV_Ordering `liftM` G.basicUnsafeThaw v + + basicLength (V_Ordering v) + = G.basicLength v + + basicUnsafeSlice i n (V_Ordering v) + = V_Ordering $ G.basicUnsafeSlice i n v + + basicUnsafeIndexM (V_Ordering v) i + = toOrdering `liftM` G.basicUnsafeIndexM v i + + basicUnsafeCopy (MV_Ordering mv) (V_Ordering v) + = G.basicUnsafeCopy mv v + + elemseq _ = seq + + +fromOrdering :: Ordering -> Word8 +{-# INLINE fromOrdering #-} +fromOrdering LT = 0 +fromOrdering EQ = 1 +fromOrdering GT = 2 + +toOrdering :: Word8 -> Ordering +{-# INLINE toOrdering #-} +toOrdering 0 = LT +toOrdering 1 = EQ +toOrdering _ = GT + + +instance Unbox Integer +instance MG.MVector MVector Integer +instance G.Vector Vector Integer + diff --git a/Data/Array/Parallel/Unlifted/Stream.hs b/Data/Array/Parallel/Unlifted/Stream.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Stream.hs @@ -0,0 +1,18 @@ + +module Data.Array.Parallel.Unlifted.Stream + ( -- * Segmented streams + module Data.Array.Parallel.Unlifted.Stream.Segmented + + -- * Stream through segment descriptors + , module Data.Array.Parallel.Unlifted.Stream.Ixs + + -- * Streams of scattered elements + , module Data.Array.Parallel.Unlifted.Stream.Elems + + -- * Streams of scattered segments + , module Data.Array.Parallel.Unlifted.Stream.Segments) +where +import Data.Array.Parallel.Unlifted.Stream.Segmented +import Data.Array.Parallel.Unlifted.Stream.Ixs +import Data.Array.Parallel.Unlifted.Stream.Elems +import Data.Array.Parallel.Unlifted.Stream.Segments diff --git a/Data/Array/Parallel/Unlifted/Stream/Elems.hs b/Data/Array/Parallel/Unlifted/Stream/Elems.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Stream/Elems.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP, NoMonomorphismRestriction #-} +#include "fusion-phases.h" +module Data.Array.Parallel.Unlifted.Stream.Elems + ( streamElemsFromVector + , streamElemsFromVectors + , streamElemsFromVectorsVSegd) +where +import Data.Array.Parallel.Unlifted.Stream.Ixs +import Data.Vector.Fusion.Stream.Monadic +import Data.Array.Parallel.Unlifted.Sequential.Vector (Unbox, Vector) +import Data.Array.Parallel.Unlifted.Vectors (Unboxes, Vectors) +import Data.Array.Parallel.Unlifted.Sequential.UVSegd (UVSegd(..)) +import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as U +import qualified Data.Array.Parallel.Unlifted.Vectors as US +import qualified Data.Array.Parallel.Unlifted.Sequential.UVSegd as UVSegd + +-- | Take a stream of indices, +-- look them up from a vector, +-- and produce a stream of elements. +streamElemsFromVector + :: (Monad m, Unbox a) + => Vector a -> Stream m Int -> Stream m a + +streamElemsFromVector vector (Stream mkStep s0 size0) + = vector `seq` Stream mkStep' s0 size0 + where + {-# INLINE_INNER mkStep' #-} + mkStep' s + = do step <- mkStep s + case step of + Yield ix s' + -> let !result = U.index "streamElemsFromVector" vector ix + in return $ Yield result s' + + Skip s' -> return $ Skip s' + Done -> return Done +{-# INLINE_STREAM streamElemsFromVector #-} + + +-- | Take a stream of chunk and chunk element indices, +-- look them up from some vectors, +-- and produce a stream of elements. +streamElemsFromVectors + :: (Monad m, Unboxes a) + => Vectors a -> Stream m (Int, Int) -> Stream m a + +streamElemsFromVectors vectors (Stream mkStep s0 size0) + = vectors `seq` Stream mkStep' s0 size0 + where + {-# INLINE_INNER mkStep' #-} + mkStep' s + = do step <- mkStep s + case step of + Yield (ix1, ix2) s' + -> let !result = US.unsafeIndex2 vectors ix1 ix2 + in return $ Yield result s' + + Skip s' -> return $ Skip s' + Done -> return Done +{-# INLINE_STREAM streamElemsFromVectors #-} + + +-- | Take a stream of virtual segment ids and element indices, +-- pass them through a `UVSegd` to get physical segment and element indices, +-- and produce a stream of elements. +streamElemsFromVectorsVSegd + :: (Monad m, Unboxes a) + => Vectors a -> UVSegd -> Stream m (Int, Int) -> Stream m a + +streamElemsFromVectorsVSegd vectors uvsegd vsrcixs + = let -- Because we're just doing indexing here, we don't need the culled + -- vsegids or ussegd, and can just use the redundant version. + vsegids = UVSegd.takeVSegidsRedundant uvsegd + ussegd = UVSegd.takeUSSegdRedundant uvsegd + in streamElemsFromVectors vectors + $ streamSrcIxsThroughUSSegd ussegd + $ streamSrcIxsThroughVSegids vsegids + $ vsrcixs +{-# INLINE_STREAM streamElemsFromVectorsVSegd #-} diff --git a/Data/Array/Parallel/Unlifted/Stream/Ixs.hs b/Data/Array/Parallel/Unlifted/Stream/Ixs.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Stream/Ixs.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP, NoMonomorphismRestriction #-} +#include "fusion-phases.h" +module Data.Array.Parallel.Unlifted.Stream.Ixs + ( streamSrcIxsThroughVSegids + , streamSrcIxsThroughUSSegd) +where +import Data.Vector.Fusion.Stream.Monadic +import Data.Array.Parallel.Unlifted.Sequential.USSegd (USSegd(..)) +import qualified Data.Array.Parallel.Unlifted.Sequential.USSegd as USSegd +import qualified Data.Vector.Unboxed as U + + +-- VSegd Streamers ------------------------------------------------------------ +-- | Take a stream of virtual segment and segment element indices, +-- and convert it to a stream of physical segment and segment element indices. +streamSrcIxsThroughVSegids + :: Monad m + => U.Vector Int -> Stream m (Int, Int) -> Stream m (Int, Int) + +streamSrcIxsThroughVSegids vsegids (Stream mkStep s0 size0) + = vsegids `seq` Stream mkStep' s0 size0 + where + {-# INLINE_INNER mkStep' #-} + mkStep' s + = do step <- mkStep s + case step of + Yield (ix1, ix2) s' + -> let !pseg = U.unsafeIndex vsegids ix1 + in return $ Yield (pseg, ix2) s' + + Skip s' -> return $ Skip s' + Done -> return Done +{-# INLINE_STREAM streamSrcIxsThroughVSegids #-} + + +-- SSegd Streamers ------------------------------------------------------------ +-- | Take a stream of segment and segment element indices, +-- and convert it to a stream of chunk and chunk element indices. +streamSrcIxsThroughUSSegd + :: Monad m + => USSegd -> Stream m (Int, Int) -> Stream m (Int, Int) + +streamSrcIxsThroughUSSegd ussegd (Stream mkStep s0 size0) + = ussegd `seq` Stream mkStep' s0 size0 + where + !sources = USSegd.takeSources ussegd + !starts = USSegd.takeStarts ussegd + + {-# INLINE_INNER mkStep' #-} + mkStep' s + = do step <- mkStep s + case step of + Yield (ix1, ix2) s' + -> let !src = U.unsafeIndex sources ix1 + !start = U.unsafeIndex starts ix1 + in return $ Yield (src, start + ix2) s' + + Skip s' -> return $ Skip s' + Done -> return Done +{-# INLINE_STREAM streamSrcIxsThroughUSSegd #-} + diff --git a/Data/Array/Parallel/Unlifted/Stream/Segmented.hs b/Data/Array/Parallel/Unlifted/Stream/Segmented.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Stream/Segmented.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-incomplete-patterns #-} +#include "fusion-phases.h" + +-- 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. +-- +-- Fix warnings in this module. + +-- | Stream functions not implemented in @Data.Vector@ +module Data.Array.Parallel.Unlifted.Stream.Segmented + ( indexedS + , replicateEachS + , replicateEachRS + , interleaveS + , combine2ByTagS + , combineSS + , enumFromToEachS + , enumFromStepLenEachS + , foldSS + , fold1SS + , foldValuesR + , appendSS + , 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(..)) + + +-- Indexed -------------------------------------------------------------------- +-- | 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 + + +-- Replicate ------------------------------------------------------------------ +-- | 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 ----------------------------------------------------------------- +-- | 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 -------------------------------------------------------------------- +-- | 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') + + +-- | 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') + + +-- Enum ----------------------------------------------------------------------- +-- | 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) + + +-- Fold ----------------------------------------------------------------------- +-- | 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 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 + + +-- Append --------------------------------------------------------------------- +-- | 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') + + +-- Indices -------------------------------------------------------------------- +-- | 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) + + + +-- 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. diff --git a/Data/Array/Parallel/Unlifted/Stream/Segments.hs b/Data/Array/Parallel/Unlifted/Stream/Segments.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Stream/Segments.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE CPP, NoMonomorphismRestriction #-} +#include "fusion-phases.h" +module Data.Array.Parallel.Unlifted.Stream.Segments + ( streamSegsFromNestedUSSegd + , streamSegsFromVectorsUSSegd + , streamSegsFromVectorsUVSegd) +where +import Data.Vector.Fusion.Stream.Size +import Data.Vector.Fusion.Stream.Monadic +import Data.Array.Parallel.Unlifted.Sequential.Vector (Unbox, Vector, index) +import Data.Array.Parallel.Unlifted.Vectors (Unboxes, Vectors) +import Data.Array.Parallel.Unlifted.Sequential.USSegd (USSegd(..)) +import Data.Array.Parallel.Unlifted.Sequential.UVSegd (UVSegd(..)) +import qualified Data.Array.Parallel.Unlifted.Vectors as US +import qualified Data.Array.Parallel.Unlifted.Sequential.USegd as USegd +import qualified Data.Array.Parallel.Unlifted.Sequential.USSegd as USSegd +import qualified Data.Array.Parallel.Unlifted.Sequential.UVSegd as UVSegd +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import qualified Data.Primitive.ByteArray as P +import System.IO.Unsafe + + +-- Nested ----------------------------------------------------------------------------------------- +-- | Stream some physical segments from many data arrays. +--- +-- * TODO: make this more efficient, and fix fusion. +-- We should be able to eliminate a lot of the indexing happening in the +-- inner loop by being cleverer about the loop state. +-- +-- * TODO: If this is contiguous then we can stream the lot without worrying +-- about jumping between segments. EXCEPT that this information must be +-- statically visible else streamSegs won't fuse, so we can't have an +-- ifThenElse checking the manifest flag. +streamSegsFromNestedUSSegd + :: (Unbox a, Monad m) + => V.Vector (Vector a) -- ^ Source arrays. + -> USSegd -- ^ Segment descriptor defining segments base on source vectors. + -> Stream m a + +streamSegsFromNestedUSSegd + pdatas + ussegd@(USSegd _ starts sources usegd) + = let + here = "streamSegsFromNestedUSSegd" + + -- length of each segment + pseglens = USegd.takeLengths usegd + + -- We've finished streaming this pseg + {-# INLINE_INNER fn #-} + fn (pseg, ix) + -- All psegs are done. + | pseg >= USSegd.length ussegd + = return $ Done + + -- Current pseg is done + | ix >= pseglens `U.unsafeIndex` pseg + = return $ Skip (pseg + 1, 0) + + -- Stream an element from this pseg + | otherwise + = let !srcid = index here sources pseg + !pdata = pdatas `V.unsafeIndex` srcid + !start = index here starts pseg + !result = index here pdata (start + ix) + in return $ Yield result (pseg, ix + 1) + + in Stream fn (0, 0) Unknown +{-# INLINE_STREAM streamSegsFromNestedUSSegd #-} + + +-- Vectors ---------------------------------------------------------------------------------------- +-- | Stream segments from a `Vectors`. +-- +-- * There must be at least one segment in the `USSegd`, but this is not checked. +-- +-- * No bounds checking is done for the `USSegd`. +-- +streamSegsFromVectorsUSSegd + :: (Unboxes a, Monad m) + => Vectors a -- ^ Vectors holding source data. + -> USSegd -- ^ Scattered segment descriptor + -> Stream m a + +streamSegsFromVectorsUSSegd + vectors + ussegd@(USSegd _ segStarts segSources usegd) + = segStarts `seq` segSources `seq` usegd `seq` vectors `seq` + let here = "stremSegsFromVectorsUSSegd" + + -- Length of each segment + !segLens = USegd.takeLengths usegd + + -- Total number of segments. + !segsTotal = USSegd.length ussegd + + -- Total number of elements to stream. + !elements = USegd.takeElements usegd + + -- seg, ix of that seg in usegd, length of seg, elem in seg + {-# INLINE_INNER fnSeg #-} + fnSeg (ixSeg, baSeg, ixEnd, ixElem) + = ixSeg `seq` baSeg `seq` + if ixElem >= ixEnd -- Was that the last elem in the current seg? + then if ixSeg + 1 >= segsTotal -- Was that last seg? + + -- That was the last seg, we're done. + then return $ Done + + -- Move to the next seg. + else let ixSeg' = ixSeg + 1 + sourceSeg = index here segSources ixSeg' + startSeg = index here segStarts ixSeg' + lenSeg = index here segLens ixSeg' + (arr, startArr, _) + = US.unsafeIndexUnpack vectors sourceSeg + in return $ Skip + ( ixSeg' + , arr + , startArr + startSeg + lenSeg + , startArr + startSeg) + + -- Stream the next element from the segment. + else let !result = P.indexByteArray baSeg ixElem + in return $ Yield result (ixSeg, baSeg, ixEnd, ixElem + 1) + + -- Starting state of the stream. + -- CAREFUL: + -- The ussegd might not contain any segments, so we can't initialise the state + -- just by taking the first segment length etc from the ussegd. + -- On the other hand, we don't want to use an extra case expression to test for + -- this sitution, as that could break fusion. + -- Instead, start with a dummy state which forces the loop to grab the first + -- segment, if there are any. + !dummy = unsafePerformIO + $ P.newByteArray 0 >>= P.unsafeFreezeByteArray + + !initState + = ( -1 -- force fnSeg loop to load first seg + , dummy -- dummy array data to start with + , 0 -- force fnSeg loop to load first seg + , 0) + + -- It's important that we set the result stream size, so Data.Vector + -- doesn't need to add code to grow the result when it overflows. + in Stream fnSeg initState (Exact elements) +{-# INLINE_STREAM streamSegsFromVectorsUSSegd #-} + + + +-- Vectors ---------------------------------------------------------------------------------------- +-- | Stream segments from a `Vectors`. +-- +-- * There must be at least one segment in the `USSegd`, but this is not checked. +-- +-- * No bounds checking is done for the `USSegd`. +-- +streamSegsFromVectorsUVSegd + :: (Unboxes a, Monad m) + => Vectors a -- ^ Vectors holding source data. + -> UVSegd -- ^ Scattered segment descriptor + -> Stream m a + +streamSegsFromVectorsUVSegd + vectors + uvsegd@(UVSegd _ _ vsegids _ (USSegd _ segStarts segSources usegd) ) + = segStarts `seq` segSources `seq` uvsegd `seq` vectors `seq` + let here = "stremSegsFromVectorsUVSegd" + + !elemsTotal = U.sum $ UVSegd.takeLengths uvsegd + + -- Total number of segments. + !segsTotal = UVSegd.length uvsegd + + -- Length of each physical segment. + !segLens = USegd.takeLengths usegd + + -- seg, ix of that seg in usegd, length of seg, elem in seg + {-# INLINE_INNER fnSeg #-} + fnSeg (ixSeg, baSeg, ixEnd, ixElem) + = ixSeg `seq` baSeg `seq` + if ixElem >= ixEnd -- Was that the last elem in the current seg? + then if ixSeg + 1 >= segsTotal -- Was that last seg? + + -- That was the last seg, we're done. + then return $ Done + + -- Move to the next seg. + else let ixSeg' = ixSeg + 1 + ixPSeg = index here vsegids ixSeg' + sourceSeg = index here segSources ixPSeg + startSeg = index here segStarts ixPSeg + lenSeg = index here segLens ixPSeg + (arr, startArr, _) + = US.unsafeIndexUnpack vectors sourceSeg + in return $ Skip + ( ixSeg' + , arr + , startArr + startSeg + lenSeg + , startArr + startSeg) + + -- Stream the next element from the segment. + else let !result = P.indexByteArray baSeg ixElem + in return $ Yield result (ixSeg, baSeg, ixEnd, ixElem + 1) + + -- Starting state of the stream. + !dummy = unsafePerformIO + $ P.newByteArray 0 >>= P.unsafeFreezeByteArray + + !initState + = ( -1 -- force fnSeg loop to load first seg + , dummy -- dummy array data to start with + , 0 -- force fnSeg loop to load first seg + , 0) + + -- It's important that we set the result stream size, so Data.Vector + -- doesn't need to add code to grow the result when it overflows. + in Stream fnSeg initState (Exact elemsTotal) +{-# INLINE_STREAM streamSegsFromVectorsUVSegd #-} + + diff --git a/Data/Array/Parallel/Unlifted/Vectors.hs b/Data/Array/Parallel/Unlifted/Vectors.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Unlifted/Vectors.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE BangPatterns, FlexibleInstances, UndecidableInstances, CPP #-} +#include "fusion-phases.h" + +-- | Irregular two dimensional arrays. +--- +-- * TODO: The inner arrays should be unboxed so we don't get an unboxing overhead +-- for every call to unsafeIndex2. This might need an extension to the GHC +-- runtime if we alwo want to convert a U.Vector directly to this form. +-- +-- * TODO: We currently only allow primitive types to be in a Vectors, but +-- in future we'll want `Vectors` of tuples etc. +-- +module Data.Array.Parallel.Unlifted.Vectors + ( Vectors(..) + , Unboxes + , empty + , singleton + , length + , unsafeIndex + , unsafeIndex2 + , unsafeIndexUnpack + , append + , fromVector + , toVector) +where +import qualified Data.Array.Parallel.Unlifted.ArrayArray as AA +import qualified Data.Primitive.ByteArray as P +import qualified Data.Primitive.Types as P +import qualified Data.Primitive as P +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Primitive as R +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import Data.Vector.Unboxed (Unbox) +import Prelude hiding (length) +import Data.Word +import Control.Monad.ST + +-- | Class of element types that can be used in a `Vectors` +class R.Prim a => Unboxes a +instance Unboxes Int +instance Unboxes Word8 +instance Unboxes Float +instance Unboxes Double + + +-- | A 2-dimensional array, +-- where the inner arrays can all have different lengths. +data Vectors a + = Vectors + {-# UNPACK #-} !Int -- number of inner vectors + {-# UNPACK #-} !P.ByteArray -- starting index of each vector in its chunk + {-# UNPACK #-} !P.ByteArray -- lengths of each inner vector + {-# UNPACK #-} !(AA.ArrayArray P.ByteArray) -- chunks + + +instance (Unboxes a, Unbox a, Show a) => Show (Vectors a) where + show = show . toVector + {-# NOINLINE show #-} + + +-- | Construct an empty `Vectors` with no arrays of no elements. +empty :: Vectors a +empty + = runST + $ do mba <- P.newByteArray 0 + ba <- P.unsafeFreezeByteArray mba + + maa <- AA.newArrayArray 0 + AA.writeArrayArray maa 0 ba + aa <- AA.unsafeFreezeArrayArray maa + + return $ Vectors 0 ba ba aa +{-# INLINE_U empty #-} + + +-- | Construct a `Vectors` containing data from a single unboxed array. +singleton :: (Unboxes a, Unbox a) => U.Vector a -> Vectors a +singleton vec + = runST + $ do R.MVector start len mbaData <- R.unsafeThaw $ G.convert vec + baData <- P.unsafeFreezeByteArray mbaData + + mbaStarts <- P.newByteArray (P.sizeOf (undefined :: Int)) + P.writeByteArray mbaStarts 0 start + baStarts <- P.unsafeFreezeByteArray mbaStarts + + mbaLengths <- P.newByteArray (P.sizeOf (undefined :: Int)) + P.writeByteArray mbaLengths 0 len + baLengths <- P.unsafeFreezeByteArray mbaLengths + + maaChunks <- AA.newArrayArray 1 + AA.writeArrayArray maaChunks 0 baData + aaChunks <- AA.unsafeFreezeArrayArray maaChunks + + return $ Vectors 1 baStarts baLengths aaChunks +{-# INLINE_U singleton #-} + + +-- | Yield the number of vectors in a `Vectors`. +length :: Unboxes a => Vectors a -> Int +length (Vectors len _ _ _) = len +{-# INLINE_U length #-} + + +-- | Take one of the outer vectors from a `Vectors`. +unsafeIndex :: (Unboxes a, Unbox a) => Vectors a -> Int -> U.Vector a +unsafeIndex (Vectors _ starts lens arrs) ix + = G.convert + $ runST + $ do let start = P.indexByteArray starts ix + let len = P.indexByteArray lens ix + let arr = AA.indexArrayArray arrs ix + marr <- P.unsafeThawByteArray arr + let mvec = R.MVector start len marr + R.unsafeFreeze mvec +{-# INLINE_U unsafeIndex #-} + + +-- | Retrieve a single element from a `Vectors`, +-- given the outer and inner indices. +unsafeIndex2 :: Unboxes a => Vectors a -> Int -> Int -> a +unsafeIndex2 (Vectors _ starts _ arrs) ix1 ix2 + = (arrs `AA.indexArrayArray` ix1) `P.indexByteArray` ((starts `P.indexByteArray` ix1) + ix2) +{-# INLINE_U unsafeIndex2 #-} + + +-- | Retrieve an inner array from a `Vectors`, returning the array data, +-- starting index in the data, and vector length. +unsafeIndexUnpack :: Unboxes a => Vectors a -> Int -> (P.ByteArray, Int, Int) +unsafeIndexUnpack (Vectors _ starts lens arrs) ix + = ( arrs `AA.indexArrayArray` ix + , starts `P.indexByteArray` ix + , lens `P.indexByteArray` ix) +{-# INLINE_U unsafeIndexUnpack #-} + + +-- | Appending two `Vectors` uses work proportional to +-- the length of the outer arrays. +append :: (Unboxes a, Unbox a) => Vectors a -> Vectors a -> Vectors a +append (Vectors len1 starts1 lens1 chunks1) + (Vectors len2 starts2 lens2 chunks2) + = runST + $ do let len' = len1 + len2 + + -- append starts into result + let lenStarts1 = P.sizeofByteArray starts1 + let lenStarts2 = P.sizeofByteArray starts2 + maStarts <- P.newByteArray (lenStarts1 + lenStarts2) + P.copyByteArray maStarts 0 starts1 0 lenStarts1 + P.copyByteArray maStarts lenStarts1 starts2 0 lenStarts2 + starts' <- P.unsafeFreezeByteArray maStarts + + -- append lens into result + let lenLens1 = P.sizeofByteArray lens1 + let lenLens2 = P.sizeofByteArray lens2 + maLens <- P.newByteArray (lenLens1 + lenLens2) + P.copyByteArray maLens 0 lens1 0 lenLens1 + P.copyByteArray maLens lenStarts1 lens2 0 lenLens2 + lens' <- P.unsafeFreezeByteArray maLens + + -- append arrs into result + maChunks <- AA.newArrayArray len' + AA.copyArrayArray maChunks 0 chunks1 0 len1 + AA.copyArrayArray maChunks len1 chunks2 0 len2 + chunks' <- AA.unsafeFreezeArrayArray maChunks + + let result = Vectors len' starts' lens' chunks' + return $ result +{-# INLINE_U append #-} + + +-- | Convert a boxed vector of unboxed vectors to a `Vectors`. +fromVector :: (Unboxes a, Unbox a) => V.Vector (U.Vector a) -> Vectors a +fromVector vecs + = runST + $ do let len = V.length vecs + let (_, vstarts, vlens) = V.unzip3 $ V.map unpackUVector vecs + let (baStarts, _, _) = unpackUVector $ V.convert vstarts + let (baLens, _, _) = unpackUVector $ V.convert vlens + mchunks <- AA.newArrayArray len + V.zipWithM_ + (\i vec + -> let (ba, _, _) = unpackUVector vec + in AA.writeArrayArray mchunks i ba) + (V.enumFromN 0 len) + vecs + + chunks <- AA.unsafeFreezeArrayArray mchunks + return $ Vectors len baStarts baLens chunks +{-# INLINE_U fromVector #-} + + +-- | Convert a `Vectors` to a boxed vector of unboxed vectors. +toVector :: (Unboxes a, Unbox a) => Vectors a -> V.Vector (U.Vector a) +toVector vectors + = V.map (unsafeIndex vectors) + $ V.enumFromN 0 (length vectors) +{-# INLINE_U toVector #-} + + +-- | Unpack an unboxed vector into array data, starting index, and vector length. +unpackUVector :: (Unbox a, P.Prim a) => U.Vector a -> (P.ByteArray, Int, Int) +unpackUVector vec + = runST + $ do let pvec = V.convert vec + R.MVector start len mba <- R.unsafeThaw pvec + ba <- P.unsafeFreezeByteArray mba + return (ba, start, len) +{-# INLINE_U unpackUVector #-} + diff --git a/dph-prim-seq.cabal b/dph-prim-seq.cabal --- a/dph-prim-seq.cabal +++ b/dph-prim-seq.cabal @@ -1,38 +1,57 @@ Name: dph-prim-seq -Version: 0.5.1.1 +Version: 0.6.0.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: Sequential Primitives for Data-Parallel Haskell. +Synopsis: Data Parallel Haskell segmented arrays. (sequential implementation) +Description: Sequential array data type and stream fuctions, along with a + sequential reference implementation of the segmented array + API defined in @dph-prim-interface@. Cabal-Version: >= 1.6 Build-Type: Simple Library Exposed-Modules: - Data.Array.Parallel.Unlifted.Sequential.Segmented - Data.Array.Parallel.Unlifted.Sequential.Segmented.USegd - Data.Array.Parallel.Unlifted.Sequential.Vector Data.Array.Parallel.Unlifted.Sequential.USel + Data.Array.Parallel.Unlifted.Sequential.USegd + Data.Array.Parallel.Unlifted.Sequential.USSegd + Data.Array.Parallel.Unlifted.Sequential.UVSegd + Data.Array.Parallel.Unlifted.Sequential.Vector + Data.Array.Parallel.Unlifted.Sequential + Data.Array.Parallel.Unlifted.Stream + Data.Array.Parallel.Unlifted.Vectors + Data.Array.Parallel.Unlifted.ArrayArray Data.Array.Parallel.Unlifted + Other-Modules: - Data.Array.Parallel.Unlifted.Sequential.Segmented.Basics - Data.Array.Parallel.Unlifted.Sequential.Segmented.Combinators - Data.Array.Parallel.Unlifted.Sequential.Segmented.Sums - Data.Array.Parallel.Unlifted.Sequential.Segmented.Text + Data.Array.Parallel.Unlifted.Sequential.Basics + Data.Array.Parallel.Unlifted.Sequential.Combinators + Data.Array.Parallel.Unlifted.Sequential.Sums + Data.Array.Parallel.Unlifted.Sequential.Extracts + Data.Array.Parallel.Unlifted.Stream.Segmented + Data.Array.Parallel.Unlifted.Stream.Ixs + Data.Array.Parallel.Unlifted.Stream.Elems + Data.Array.Parallel.Unlifted.Stream.Segments + Exposed: False Extensions: TypeFamilies, GADTs, RankNTypes, - BangPatterns, MagicHash, UnboxedTuples, TypeOperators - GHC-Options: -Odph -funbox-strict-fields -fcpr-off + BangPatterns, MagicHash, UnboxedTuples, TypeOperators, + NoMonomorphismRestriction + GHC-Options: + -Odph -Wall + -funbox-strict-fields -fcpr-off Build-Depends: - base == 4.4.*, - random == 1.0.*, - vector == 0.7.*, - dph-base == 0.5.*, - dph-prim-interface == 0.5.* + base == 4.5.*, + random == 1.0.*, + vector == 0.9.*, + primitive == 0.4.*, + ghc-prim == 0.2.*, + dph-base == 0.6.*, + dph-prim-interface == 0.6.*