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 @@ -34,7 +34,13 @@ -- Constructors --------------------------------------------------------------- empty = U.empty (+:+) = (U.++) -append_s _ = appendSU +append_s _ xd xs yd ys = appendSU xd xs yd ys +append_vs _ xd xs yd ys = appendSU xd' xs' yd' ys' + where xd' = unsafeDemoteToSegdOfVSegd xd + yd' = unsafeDemoteToSegdOfVSegd yd + xs' = extractsFromVectorsUVSegd xd xs + ys' = extractsFromVectorsUVSegd yd ys + replicate = U.replicate replicate_s = replicateSU replicate_rs = replicateRSU diff --git a/Data/Array/Parallel/Unlifted/Sequential/Extracts.hs b/Data/Array/Parallel/Unlifted/Sequential/Extracts.hs --- a/Data/Array/Parallel/Unlifted/Sequential/Extracts.hs +++ b/Data/Array/Parallel/Unlifted/Sequential/Extracts.hs @@ -10,7 +10,8 @@ -- * Scattered extracts , extractsFromNestedUSSegd , extractsFromVectorsUSSegd - , extractsFromVectorsUVSegd) + , extractsFromVectorsUVSegd + , extractsFromVectorsUSSegdSegmap) where import Data.Array.Parallel.Unlifted.Stream as US import Data.Array.Parallel.Unlifted.Vectors as US @@ -76,3 +77,16 @@ extractsFromVectorsUVSegd uvsegd vectors = U.unstream $ US.streamSegsFromVectorsUVSegd vectors uvsegd {-# INLINE_U extractsFromVectorsUVSegd #-} + + +-- | Copy segments defined by a segmap and `USSegd` into a new array. +extractsFromVectorsUSSegdSegmap + :: (Unbox a, US.Unboxes a) + => USSegd + -> Vector Int + -> Vectors a + -> Vector a + +extractsFromVectorsUSSegdSegmap ussegd segmap vectors + = U.unstream $ US.streamSegsFromVectorsUSSegdSegmap vectors ussegd segmap + diff --git a/Data/Array/Parallel/Unlifted/Sequential/USSegd.hs b/Data/Array/Parallel/Unlifted/Sequential/USSegd.hs --- a/Data/Array/Parallel/Unlifted/Sequential/USSegd.hs +++ b/Data/Array/Parallel/Unlifted/Sequential/USSegd.hs @@ -36,6 +36,7 @@ import Prelude hiding (length) import qualified Data.Array.Parallel.Unlifted.Sequential.USegd as USegd import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as U +import Debug.Trace here :: String -> String here s = "Data.Array.Parallel.Unlifted.Sequential.USSegd." ++ s @@ -215,10 +216,13 @@ 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) + = traceEvent + ( "dph-prim-seq: USSegd.appendWith." + ++ " length(result) = " ++ show (U.length starts1 + U.length starts2)) + $ 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. @@ -230,7 +234,10 @@ 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. + traceEvent + ( "dph-prim-seq: USSegd.cullOnVSegids." + ++ " length(segmap) = " ++ show (U.length vsegids)) + $ 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 @@ -239,7 +246,7 @@ -- => psegids_used: [1 1 0 1 0 1 1] -- -- Note that psegids '2' and '4' are not in vsegids_packed. - psegids_used + !psegids_used = U.bpermuteDft (USegd.length usegd) (const False) (U.zip vsegids (U.replicate (U.length vsegids) True)) @@ -247,7 +254,7 @@ -- 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 + !psegids_packed = U.pack (U.enumFromTo 0 (U.length psegids_used)) psegids_used -- Produce an array that maps psegids in the source array onto @@ -260,7 +267,7 @@ -- eg psegids_packed: [0 1 3 5 6] -- [0 1 2 3 4] -- psegids_map: [0 1 -1 2 -1 3 4] - psegids_map + !psegids_map = U.bpermuteDft (USegd.length usegd) (const (-1)) (U.zip psegids_packed (U.enumFromTo 0 (U.length psegids_packed - 1))) @@ -273,18 +280,18 @@ -- -- vsegids': [0 1 1 2 3 3 4 4] -- - vsegids' = U.map (U.index (here "cullOnVSegids") psegids_map) vsegids + !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 + !starts' = U.pack starts psegids_used + !sources' = U.pack sources psegids_used - lengths' = U.pack (USegd.takeLengths usegd) psegids_used - usegd' = USegd.fromLengths lengths' + !lengths' = U.pack (USegd.takeLengths usegd) psegids_used + !usegd' = USegd.fromLengths lengths' - ussegd' = USSegd False starts' sources' usegd' + !ussegd' = USSegd False starts' sources' usegd' - in (vsegids', ussegd') + in (vsegids', ussegd') {-# NOINLINE cullOnVSegids #-} -- NOINLINE because it's complicated and won't fuse with anything diff --git a/Data/Array/Parallel/Unlifted/Sequential/USegd.hs b/Data/Array/Parallel/Unlifted/Sequential/USegd.hs --- a/Data/Array/Parallel/Unlifted/Sequential/USegd.hs +++ b/Data/Array/Parallel/Unlifted/Sequential/USegd.hs @@ -27,6 +27,7 @@ import Data.Array.Parallel.Unlifted.Sequential.Vector (Vector) import Data.Array.Parallel.Pretty hiding (empty) import Prelude hiding (length) +import Debug.Trace here :: String -> String here s = "Data.Array.Parallel.Unlifted.Sequential.USegd." ++ s @@ -138,11 +139,12 @@ -- two arrays. append :: USegd -> USegd -> USegd append (USegd lengths1 indices1 elems1) - (USegd lengths2 indices2 elems2) - = USegd (lengths1 U.++ lengths2) + (USegd lengths2 indices2 elems2) + = traceEvent ("dph-prim-seq: USegd.append") + $ USegd (lengths1 U.++ lengths2) (indices1 U.++ U.map (+ elems1) indices2) (elems1 + elems2) -{-# INLINE_U append #-} +{-# NOINLINE append #-} -- | O(segs) Extract a slice of a segment descriptor, avoiding copying where possible. diff --git a/Data/Array/Parallel/Unlifted/Sequential/UVSegd.hs b/Data/Array/Parallel/Unlifted/Sequential/UVSegd.hs --- a/Data/Array/Parallel/Unlifted/Sequential/UVSegd.hs +++ b/Data/Array/Parallel/Unlifted/Sequential/UVSegd.hs @@ -49,6 +49,7 @@ 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 +import Debug.Trace here :: String -> String here s = "Data.Array.Parallel.Unlifted.Sequential.UVSegd." ++ s @@ -307,9 +308,13 @@ -- unsafeDemoteToUSSegd :: UVSegd -> USSegd unsafeDemoteToUSSegd uvsegd - | uvsegd_manifest uvsegd = uvsegd_ussegd_culled uvsegd -- TODO: take the redundant ones - | otherwise - = let vsegids = uvsegd_vsegids_culled uvsegd + = traceEvent + ( "dph-prim-seq: UVSegd.unsafeDemoteToUSSSegd" + ++ " length(segmap) = " ++ show (U.length $ takeVSegids uvsegd)) + $ if uvsegd_manifest uvsegd + then uvsegd_ussegd_culled uvsegd -- TODO: take the redundant ones + else 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 @@ -333,7 +338,10 @@ -- unsafeDemoteToUSegd :: UVSegd -> USegd unsafeDemoteToUSegd (UVSegd _ _ vsegids _ ussegd) - = USegd.fromLengths + = traceEvent + ( "dph-prim-seq: UVSegd.unsafeDemoteToUSegd" + ++ " length(segmap) = " ++ show (U.length vsegids)) + $ USegd.fromLengths $ U.bpermute (USSegd.takeLengths ussegd) vsegids {-# NOINLINE unsafeDemoteToUSegd #-} -- NOINLINE because it won't fuse with anything. @@ -433,7 +441,11 @@ (UVSegd _ _ vsegids1 _ ussegd1) pdatas1 (UVSegd _ _ vsegids2 _ ussegd2) pdatas2 - = let -- vsegids releative to appended psegs + = traceEvent + ( "dph-prim-seq: UVSegd.appendWith" + ++ "length(result) = " ++ (show $ U.length vsegids1 + U.length vsegids2)) + $ let + -- vsegids releative to appended psegs vsegids1' = vsegids1 vsegids2' = U.map (+ USSegd.length ussegd1) vsegids2 @@ -446,7 +458,7 @@ ussegd2 pdatas2 in UVSegd False vsegids' vsegids' ussegd' ussegd' -{-# INLINE_U appendWith #-} +{-# NOINLINE appendWith #-} -- combine -------------------------------------------------------------------- @@ -484,16 +496,20 @@ combine2 :: USel2 -- ^ Selector for the combine operation. -> UVSegd -- ^ Descriptor of first array. - -> Int -- ^ Number of flat physical arrays for first descriptor. + -> Int -- ^ Number of flat physical arrays for first descriptor. -> UVSegd -- ^ Descriptor of second array. - -> Int -- ^ Number of flat physical arrays for second descriptor. + -> 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 + = traceEvent + ( "dph-prim-seq: UVSegd.combine2" + ++ "length(result) = " ++ show (U.length $ tagsUSel2 usel2)) + $ let + -- vsegids relative to combined psegs vsegids1' = vsegids1 vsegids2' = U.map (+ (U.length vsegids1)) vsegids2 @@ -507,4 +523,5 @@ ussegd2 pdatas2 in UVSegd False vsegids' vsegids' ussegd' ussegd' -{-# INLINE_U combine2 #-} +{-# NOINLINE 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 @@ -186,13 +186,14 @@ 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 + $ V.unsafeSlice i n xs {-# INLINE_U slice #-} -- 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 +unsafeSlice xs i n + = V.unsafeSlice i n xs {-# INLINE_U unsafeSlice #-} @@ -205,9 +206,10 @@ -- Copy out a subrange of a vector. extract :: Unbox a => Vector a -> Int -> Int -> Vector a +extract xs i n + = B.checkSlice "extract" (V.length xs) i n + $ force (V.unsafeSlice i n xs) {-# INLINE_U extract #-} -extract xs i n - = force (V.slice i n xs) -- Copy out a subrange of a vector, without bounds checks. @@ -478,7 +480,9 @@ mslice :: Unbox a => Int -> Int -> MVector s a -> MVector s a -mslice = M.slice +mslice i n xs + = B.checkSlice "mslice" (M.length xs) i n + $ M.unsafeSlice i n xs {-# INLINE mslice #-} diff --git a/Data/Array/Parallel/Unlifted/Stream/Segments.hs b/Data/Array/Parallel/Unlifted/Stream/Segments.hs --- a/Data/Array/Parallel/Unlifted/Stream/Segments.hs +++ b/Data/Array/Parallel/Unlifted/Stream/Segments.hs @@ -3,19 +3,21 @@ module Data.Array.Parallel.Unlifted.Stream.Segments ( streamSegsFromNestedUSSegd , streamSegsFromVectorsUSSegd - , streamSegsFromVectorsUVSegd) + , streamSegsFromVectorsUVSegd + , streamSegsFromVectorsUSSegdSegmap + , streamSegsFromVectorsUSSegd_split) 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.USegd (USegd(..)) 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.Array.Parallel.Unlifted.Sequential.Vector as U import qualified Data.Vector as V import qualified Data.Primitive.ByteArray as P import System.IO.Unsafe @@ -55,7 +57,7 @@ = return $ Done -- Current pseg is done - | ix >= pseglens `U.unsafeIndex` pseg + | ix >= U.index here pseglens pseg = return $ Skip (pseg + 1, 0) -- Stream an element from this pseg @@ -164,14 +166,29 @@ streamSegsFromVectorsUVSegd vectors - uvsegd@(UVSegd _ _ vsegids _ (USSegd _ segStarts segSources usegd) ) - = segStarts `seq` segSources `seq` uvsegd `seq` vectors `seq` + (UVSegd _ _ segmap _ ussegd) + = streamSegsFromVectorsUSSegdSegmap vectors ussegd segmap +{-# INLINE_STREAM streamSegsFromVectorsUVSegd #-} + + +streamSegsFromVectorsUSSegdSegmap + :: (Unboxes a, Monad m) + => Vectors a -- ^ Vectors holding source data. + -> USSegd -- ^ Scattered segment descriptor + -> Vector Int -- ^ Segmap + -> Stream m a + +streamSegsFromVectorsUSSegdSegmap + vectors ussegd@(USSegd _ segStarts segSources usegd) segmap + = segStarts `seq` segSources `seq` usegd `seq` segmap `seq` let here = "stremSegsFromVectorsUVSegd" - !elemsTotal = U.sum $ UVSegd.takeLengths uvsegd + -- Total number of elements to be streamed + !lengths = USSegd.takeLengths ussegd + !elemsTotal = U.sum $ U.map (U.index here lengths) segmap -- Total number of segments. - !segsTotal = UVSegd.length uvsegd + !segsTotal = U.length segmap -- Length of each physical segment. !segLens = USegd.takeLengths usegd @@ -188,7 +205,7 @@ -- Move to the next seg. else let ixSeg' = ixSeg + 1 - ixPSeg = index here vsegids ixSeg' + ixPSeg = index here segmap ixSeg' sourceSeg = index here segSources ixPSeg startSeg = index here segStarts ixPSeg lenSeg = index here segLens ixPSeg @@ -217,6 +234,83 @@ -- 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 #-} +{-# INLINE_STREAM streamSegsFromVectorsUSSegdSegmap #-} + + + +streamSegsFromVectorsUSSegd_split + :: (Unboxes a, Monad m) + => Vectors a -- ^ Vectors holding source data. + -> USSegd -- ^ Scattered segment descriptor + -> Vector Int -- ^ Virtual segment ids + -> ((USegd,Int),Int) -- ^ Segmap + -> Stream m a + +streamSegsFromVectorsUSSegd_split + !vectors !ussegd + !vsegids ((!segd,!seg_off),!el_off) + = let here = "streamSegsFromVectorsUSSegd_split" + + -- Total number of elements to be streamed + !lengths = USegd.takeLengths segd + !elemsTotal = U.sum lengths + + -- Total number of segments. + !segsTotal = U.length lengths + + !segStarts = USSegd.takeStarts ussegd + !segSources = USSegd.takeSources ussegd + + vsegid seg = index here vsegids (seg + seg_off) + {-# INLINE vsegid #-} + source pseg = index here segSources pseg + {-# INLINE source #-} + start pseg = index here segStarts pseg + {-# INLINE start #-} + len seg = index here lengths seg + {-# INLINE len #-} + + -- seg, ix of that seg in usegd, length of seg, elem in seg + {-# INLINE_INNER fnSeg #-} + fnSeg (!ixSeg, !baSeg, !ixEnd, !ixElem) + = 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 = vsegid ixSeg' + sourceSeg = source ixPSeg + startSeg = start ixPSeg + lenSeg = len ixSeg' + el_off' = if ixSeg' == 0 then el_off else 0 + (arr, startArr, _) + = US.unsafeIndexUnpack vectors sourceSeg + in return $ Skip + ( ixSeg' + , arr + , startArr + startSeg + el_off' + lenSeg + , startArr + startSeg + el_off') + + -- 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 streamSegsFromVectorsUSSegd_split #-} diff --git a/Data/Array/Parallel/Unlifted/Vectors.hs b/Data/Array/Parallel/Unlifted/Vectors.hs --- a/Data/Array/Parallel/Unlifted/Vectors.hs +++ b/Data/Array/Parallel/Unlifted/Vectors.hs @@ -16,6 +16,8 @@ , empty , singleton , length + , index + , index2 , unsafeIndex , unsafeIndex2 , unsafeIndexUnpack @@ -23,6 +25,7 @@ , fromVector , toVector) where +import qualified Data.Array.Parallel.Base as B import qualified Data.Array.Parallel.Unlifted.ArrayArray as AA import qualified Data.Primitive.ByteArray as P import qualified Data.Primitive.Types as P @@ -116,13 +119,33 @@ R.unsafeFreeze mvec {-# INLINE_U unsafeIndex #-} +-- | Take one of the outer vectors from a `Vectors`, with bounds checking +index :: (Unboxes a, Unbox a) + => String -- ^ source position + -> Vectors a -> Int -> U.Vector a +index here vec ix + = B.check here (length vec) ix + $ unsafeIndex vec ix +{-# INLINE_U index #-} + -- | 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 a single element from a `Vectors`, +-- given the outer and inner indices, with bounds checking. +index2 :: Unboxes a + => String -- ^ source position + -> Vectors a -> Int -> Int -> a +index2 here vec@(Vectors _ _ lens _) ix1 ix2 + = B.check (here++"(index2.ix1)") (length vec) ix1 + $ B.check (here++"(index2.ix2)") (lens `P.indexByteArray` ix1) ix2 + $ unsafeIndex2 vec ix1 ix2 +{-# INLINE_U index2 #-} -- | Retrieve an inner array from a `Vectors`, returning the array data, diff --git a/dph-prim-seq.cabal b/dph-prim-seq.cabal --- a/dph-prim-seq.cabal +++ b/dph-prim-seq.cabal @@ -1,5 +1,5 @@ Name: dph-prim-seq -Version: 0.6.1.1 +Version: 0.7.0.1 License: BSD3 License-File: LICENSE Author: The DPH Team @@ -48,10 +48,10 @@ -funbox-strict-fields -fcpr-off Build-Depends: - base == 4.5.*, + base == 4.6.*, random == 1.0.*, - vector == 0.9.*, - primitive == 0.4.*, - ghc-prim == 0.2.*, - dph-base == 0.6.1.*, - dph-prim-interface == 0.6.1.* + vector == 0.10.*, + primitive == 0.5.*, + ghc-prim == 0.3.*, + dph-base == 0.7.*, + dph-prim-interface == 0.7.*