diff --git a/Data/Array/Parallel/PArray.hs b/Data/Array/Parallel/PArray.hs deleted file mode 100644 --- a/Data/Array/Parallel/PArray.hs +++ /dev/null @@ -1,400 +0,0 @@ - --- | Reference implementation of operators on unvectorised parallel arrays. --- --- * In this module we just used boxed vectors as the array representation. --- This won't be fast, but it means we can write the operators without --- needing type class dictionaries such as PA. This makes them --- much easier to use as reference code. --- --- * The operators should also all do bounds checks, sanity checks, and --- give nice error messages if something is wrong. The ideas is that --- this code can be run side-by-side production code during debugging. ---- --- TODO: check lengths properly in functions like zip, extracts --- -module Data.Array.Parallel.PArray - ( PArray - , valid - , nf - - -- * Constructors - , empty - , singleton, singletonl - , replicate, replicatel, replicates, replicates' - , append, appendl - , concat, concatl - , unconcat - , nestUSegd - - -- * Projections - , length, lengthl - , index, indexl - , extract, extracts, extracts' - , slice, slicel - , takeUSegd - - -- * Pack and Combine - , pack, packl - , packByTag - , combine2 - - -- * Enumerations - , enumFromTo, enumFromTol - - -- * Tuples - , zip, zipl - , unzip, unzipl - - -- * Conversions - , fromVector, toVector - , fromList, toList - , fromUArray, toUArray - , fromUArray2) -where -import Data.Array.Parallel.Base (Tag) -import Data.Vector (Vector) -import qualified Data.Array.Parallel.Unlifted as U -import qualified Data.Vector as V -import qualified Prelude as P -import Control.Monad -import GHC.Exts -import Prelude hiding - ( replicate, length, concat - , enumFromTo - , zip, unzip) - -------------------------------------------------------------------------------- -here :: String -> String -here str = "Data.Array.Parallel.PArray." ++ str - -die :: String -> String -> a -die fn str = error (here $ fn ++ " " ++ str) - --- Array Type ----------------------------------------------------------------- -type PArray a - = Vector a - --- | Lift a unary array operator. -lift1 :: (a -> b) -> PArray a -> PArray b -lift1 f vec - = V.map f vec - - --- | Lift a binary array operator. -lift2 :: (a -> b -> c) -> PArray a -> PArray b -> PArray c -lift2 f vec1 vec2 - | V.length vec1 /= V.length vec2 - = die "lift2" "length mismatch" - - | otherwise - = V.zipWith f vec1 vec2 - - --- | Lift a trinary array operator -lift3 :: (a -> b -> c -> d) -> PArray a -> PArray b -> PArray c -> PArray d -lift3 f vec1 vec2 vec3 - | V.length vec1 /= V.length vec2 - || V.length vec1 /= V.length vec3 - = die "lift3" "length mismatch" - - | otherwise - = V.zipWith3 f vec1 vec2 vec3 - - --- Basics --------------------------------------------------------------------- --- | Check that an array has a valid internal representation. -valid :: PArray a -> Bool -valid _ = True - --- | Force an array to normal form. -nf :: PArray a -> () -nf _ = () - - --- Constructors ---------------------------------------------------------------- --- | O(1). An empty array. -empty :: PArray a -empty = V.empty - - --- | O(1). Produce an array containing a single element. -singleton :: a -> PArray a -singleton = V.singleton - - --- | O(n). Produce an array of singleton arrays. -singletonl :: PArray a -> PArray (PArray a) -singletonl = lift1 singleton - - --- | O(n). Define an array of the given size, that maps all elements to the same value. -replicate :: Int -> a -> PArray a -replicate = V.replicate - - --- | O(sum lengths). Lifted replicate. -replicatel :: PArray Int -> PArray a -> PArray (PArray a) -replicatel = lift2 replicate - - --- | O(sum lengths). Segmented replicate. -replicates :: U.Segd -> PArray a -> PArray a -replicates segd vec - | V.length vec /= U.lengthSegd segd - = die "replicates" $ unlines - [ "segd length mismatch" - , " segd length = " ++ (show $ U.lengthSegd segd) - , " array length = " ++ (show $ V.length vec)] - - | otherwise - = join - $ V.zipWith V.replicate - (V.convert $ U.lengthsSegd segd) - vec - - --- | O(sum lengths). Wrapper for segmented replicate that takes replication counts --- and uses them to build the `U.Segd`. -replicates' :: PArray Int -> PArray a -> PArray a -replicates' reps arr - = replicates (U.lengthsToSegd $ V.convert $ reps) arr - - --- | Append two arrays. -append :: PArray a -> PArray a -> PArray a -append = (V.++) - - --- | Lifted append. -appendl :: PArray (PArray a) -> PArray (PArray a) -> PArray (PArray a) -appendl = lift2 append - - --- | Concatenation -concat :: PArray (PArray a) -> PArray a -concat = join - - --- | Lifted concatenation. -concatl :: PArray (PArray (PArray a)) -> PArray (PArray a) -concatl = lift1 concat - - --- | Impose a nesting structure on a flat array -unconcat :: PArray (PArray a) -> PArray b -> PArray (PArray b) -unconcat arr1 arr2 - = nestUSegd (takeUSegd arr1) arr2 - - --- | Create a nested array from a segment descriptor and some flat data. --- The segment descriptor must represent as many elements as present --- in the flat data array, else `error` -nestUSegd :: U.Segd -> PArray a -> PArray (PArray a) -nestUSegd segd vec - | U.elementsSegd segd == V.length vec - = V.zipWith - (\start len -> V.slice start len vec) - (V.convert $ U.indicesSegd segd) - (V.convert $ U.lengthsSegd segd) - - | otherwise - = error $ unlines - [ "Data.Array.Parallel.PArray.nestSegd: number of elements defined by " - ++ "segment descriptor and data array do not match" - , " length of segment desciptor = " ++ (show $ U.elementsSegd segd) - , " length of data array = " ++ (show $ V.length vec)] -{-# NOINLINE nestUSegd #-} - - --- Projections ---------------------------------------------------------------- --- | Take the length of an array -length :: PArray a -> Int -length = V.length - - --- | Take the length of some arrays. -lengthl :: PArray (PArray a) -> PArray Int -lengthl = lift1 length - - --- | Lookup a single element from the source array. -index :: PArray a -> Int -> a -index = (V.!) - - --- | Lookup a several elements from several source arrays. -indexl :: PArray (PArray a) -> PArray Int -> PArray a -indexl = lift2 index - - --- | Extract a range of elements from an array. -extract :: PArray a -> Int -> Int -> PArray a -extract vec start len - = V.slice start len vec - - --- | Segmented extract. -extracts :: Vector (PArray a) -> U.SSegd -> PArray a -extracts arrs ssegd - = join - $ V.zipWith3 - (\src start len -> extract (arrs V.! src) start len) - (V.convert $ U.sourcesOfSSegd ssegd) - (V.convert $ U.startsOfSSegd ssegd) - (V.convert $ U.lengthsOfSSegd ssegd) - - --- | Wrapper for `extracts` that takes arrays of sources, starts and lengths of --- the segments, and uses these to build the `U.SSegd`. -extracts' - :: Vector (PArray a) - -> PArray Int -- ^ id of source array for each segment. - -> PArray Int -- ^ starting index of each segment in its source array. - -> PArray Int -- ^ length of each segment. - -> PArray a -extracts' arrs sources starts lengths - = let segd = U.lengthsToSegd $ V.convert lengths - ssegd = U.mkSSegd - (V.convert $ starts) - (V.convert $ sources) - segd - in extracts arrs ssegd - - --- | Extract a range of elements from an arrary. --- Like `extract` but with the parameters in a different order. -slice :: Int -> Int -> PArray a -> PArray a -slice start len arr - = extract arr start len - - --- | Extract some slices from some arrays. --- The arrays of starting indices and lengths must themselves --- have the same length. -slicel :: PArray Int -> PArray Int -> PArray (PArray a) -> PArray (PArray a) -slicel = lift3 slice - - --- | Take the segment descriptor from a nested array. This can cause index space --- overflow if the number of elements in the result does not can not be --- represented by a single machine word. -takeUSegd :: PArray (PArray a) -> U.Segd -takeUSegd vec - = U.lengthsToSegd - $ V.convert - $ V.map length vec - - --- Pack and Combine ----------------------------------------------------------- --- | Select the elements of an array that have their tag set to True. -pack :: PArray a -> PArray Bool -> PArray a -pack xs bs - | V.length xs /= V.length bs - = die "pack" $ unlines - [ "array length mismatch" - , " data length = " ++ (show $ V.length xs) - , " flags length = " ++ (show $ V.length bs) ] - - | otherwise - = V.ifilter (\i _ -> bs V.! i) xs - - --- | Lifted pack. -packl :: PArray (PArray a) -> PArray (PArray Bool) -> PArray (PArray a) -packl = lift2 pack - - --- | Filter an array based on some tags. -packByTag :: PArray a -> U.Array Tag -> Tag -> PArray a -packByTag xs tags tag - | V.length xs /= U.length tags - = die "packByTag" $ unlines - [ "array length mismatch" - , " data length = " ++ (show $ V.length xs) - , " flags length = " ++ (show $ U.length tags) ] - - | otherwise - = V.ifilter (\i _ -> U.index (here "packByTag") tags i == tag) xs - - --- | Combine two arrays based on a selector. -combine2 :: U.Sel2 -> PArray a -> PArray a -> PArray a -combine2 tags vec1 vec2 - = let go [] [] [] = [] - go (0 : bs) (x : xs) ys = x : go bs xs ys - go (1 : bs) xs (y : ys) = y : go bs xs ys - go _ _ _ = error "Data.Array.Parallel.PArray.combine: length mismatch" - - in V.fromList - $ go (V.toList $ V.convert $ U.tagsSel2 tags) - (V.toList vec1) - (V.toList vec2) - - --- Enumerations --------------------------------------------------------------- --- | Construct a range of integers -enumFromTo :: Int -> Int -> PArray Int -enumFromTo = V.enumFromTo - - --- | Lifted enumeration -enumFromTol :: PArray Int -> PArray Int -> PArray (PArray Int) -enumFromTol = lift2 enumFromTo - - --- Tuples --------------------------------------------------------------------- --- | O(n). Zip a pair of arrays into an array of pairs. -zip :: PArray a -> PArray b -> PArray (a, b) -zip = V.zip - - --- | Lifted zip -zipl :: PArray (PArray a) -> PArray (PArray b) -> PArray (PArray (a, b)) -zipl = lift2 zip - - --- | O(n). Unzip an array of pairs into a pair of arrays. -unzip :: PArray (a, b) -> (PArray a, PArray b) -unzip = V.unzip - - --- | Lifted unzip -unzipl :: PArray (PArray (a, b)) -> PArray (PArray a, PArray b) -unzipl = lift1 unzip - - --- Conversions ---------------------------------------------------------------- --- | Convert a `Vector` to a `PArray` -fromVector :: Vector a -> PArray a -fromVector = id - - --- | Convert a `PArray` to a `Vector` -toVector :: PArray a -> Vector a -toVector = id - --- | Convert a list to a `PArray`. -fromList :: [a] -> PArray a -fromList = V.fromList - --- | Convert a `PArray` to a list. -toList :: PArray a -> [a] -toList = V.toList - - --- | Convert a `U.Array` to a `PArray` -fromUArray :: U.Elt a => U.Array a -> PArray a -fromUArray = V.convert - - --- | Convert a `PArray` to a `U.Array` -toUArray :: U.Elt a => PArray a -> U.Array a -toUArray = V.convert - - --- | Convert a `U.Array` of tuples to a `PArray` -fromUArray2 - :: (U.Elt a, U.Elt b) - => U.Array (a, b) -> PArray (a, b) - -fromUArray2 = V.convert diff --git a/Data/Array/Parallel/PArray/Reference.hs b/Data/Array/Parallel/PArray/Reference.hs --- a/Data/Array/Parallel/PArray/Reference.hs +++ b/Data/Array/Parallel/PArray/Reference.hs @@ -1,170 +1,400 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS -fno-warn-missing-signatures #-} --- | During testing, we compare the output of each invocation of the lifted --- combinators in "Data.Array.Parallel.PArray" with the reference implementations. --- --- This module helps convert the to and from the array representation --- used by the reference implementation. --- TODO: we could use this to trace the lengths of the vectors being used, --- as well as the types that each opeartor is being called at. +-- | Reference implementation of operators on unvectorised parallel arrays. -- +-- * In this module we just used boxed vectors as the array representation. +-- This won't be fast, but it means we can write the operators without +-- needing type class dictionaries such as PA. This makes them +-- much easier to use as reference code. +-- +-- * The operators should also all do bounds checks, sanity checks, and +-- give nice error messages if something is wrong. The ideas is that +-- this code can be run side-by-side production code during debugging. +--- +-- TODO: check lengths properly in functions like zip, extracts +-- module Data.Array.Parallel.PArray.Reference - ( Similar(..), PprPhysical1 (..) - , withRef1, withRef2 - , toRef1, toRef2, toRef3) + ( PArray + , valid + , nf + + -- * Constructors + , empty + , singleton, singletonl + , replicate, replicatel, replicates, replicates' + , append, appendl + , concat, concatl + , unconcat + , nestUSegd + + -- * Projections + , length, lengthl + , index, indexl + , extract, extracts, extracts' + , slice, slicel + , takeUSegd + + -- * Pack and Combine + , pack, packl + , packByTag + , combine2 + + -- * Enumerations + , enumFromTo, enumFromTol + + -- * Tuples + , zip, zipl + , unzip, unzipl + + -- * Conversions + , fromVector, toVector + , fromList, toList + , fromUArray, toUArray + , fromUArray2) where -import Data.Array.Parallel.Pretty -import qualified Data.Array.Parallel.Array as A -import qualified Data.Vector as V +import Data.Array.Parallel.Base (Tag) import Data.Vector (Vector) -import Prelude hiding (length) -import System.IO -import System.IO.Unsafe +import qualified Data.Array.Parallel.Unlifted as U +import qualified Data.Vector as V +import qualified Prelude as P import Control.Monad +import GHC.Exts +import Prelude hiding + ( replicate, length, concat + , enumFromTo + , zip, unzip) --- Config --------------------------------------------------------------------- -debugLiftedTrace :: Bool -debugLiftedTrace = False +------------------------------------------------------------------------------- +here :: String -> String +here str = "Data.Array.Parallel.PArray." ++ str -debugLiftedCompare :: Bool -debugLiftedCompare = False +die :: String -> String -> a +die fn str = error (here $ fn ++ " " ++ str) -class Similar a where - similar :: a -> a -> Bool +-- Array Type ----------------------------------------------------------------- +type PArray a + = Vector a + +-- | Lift a unary array operator. +lift1 :: (a -> b) -> PArray a -> PArray b +lift1 f vec + = V.map f vec -class PprPhysical1 a where - pprp1 :: a -> Doc - pprp1v :: Vector a -> Doc - pprp1v vec - = brackets - $ hcat - $ punctuate (text ", ") - $ V.toList $ V.map pprp1 vec - +-- | Lift a binary array operator. +lift2 :: (a -> b -> c) -> PArray a -> PArray b -> PArray c +lift2 f vec1 vec2 + | V.length vec1 /= V.length vec2 + = die "lift2" "length mismatch" + + | otherwise + = V.zipWith f vec1 vec2 --- withRef -------------------------------------------------------------------- --- | Compare the result of some array operator against a reference. --- Careful: --- * We don't want to inline the whole body of this function into --- every use site, or we'll get code explosion. When debugging is off we --- want this wrapper to be inlined and eliminated as cheaply as possible. --- * We also do this with 'unsafePerformIO' instead of trace, because --- with trace, if the computation contructing the string throws an exception --- then we get no output. For debugging we want to see what function was --- entered before we try to print the result (which might be badly formed), --- -withRef1 :: ( A.Array r a - , A.Array c a, PprPhysical1 (c a) - , Similar a, PprPhysical1 a) - => String -- name of operator - -> r a -- result using reference implementation - -> c a -- result using vseg implementation - -> c a +-- | Lift a trinary array operator +lift3 :: (a -> b -> c -> d) -> PArray a -> PArray b -> PArray c -> PArray d +lift3 f vec1 vec2 vec3 + | V.length vec1 /= V.length vec2 + || V.length vec1 /= V.length vec3 + = die "lift3" "length mismatch" + + | otherwise + = V.zipWith3 f vec1 vec2 vec3 -{-# INLINE withRef1 #-} -withRef1 name arrRef arrImpl - = if debugLiftedCompare || debugLiftedTrace - then withRef1' name arrRef arrImpl - else arrImpl - -{-# NOINLINE withRef1' #-} -withRef1' name arrRef arrImpl - = unsafePerformIO - $ do when debugLiftedTrace - $ do putStrLn $ "* " ++ name - putStrLn $ render (nest 4 $ pprp1 arrImpl) - hFlush stdout + +-- Basics --------------------------------------------------------------------- +-- | Check that an array has a valid internal representation. +valid :: PArray a -> Bool +valid _ = True + +-- | Force an array to normal form. +nf :: PArray a -> () +nf _ = () + + +-- Constructors ---------------------------------------------------------------- +-- | O(1). An empty array. +empty :: PArray a +empty = V.empty + + +-- | O(1). Produce an array containing a single element. +singleton :: a -> PArray a +singleton = V.singleton + + +-- | O(n). Produce an array of singleton arrays. +singletonl :: PArray a -> PArray (PArray a) +singletonl = lift1 singleton + + +-- | O(n). Define an array of the given size, that maps all elements to the same value. +replicate :: Int -> a -> PArray a +replicate = V.replicate + + +-- | O(sum lengths). Lifted replicate. +replicatel :: PArray Int -> PArray a -> PArray (PArray a) +replicatel = lift2 replicate + + +-- | O(sum lengths). Segmented replicate. +replicates :: U.Segd -> PArray a -> PArray a +replicates segd vec + | V.length vec /= U.lengthSegd segd + = die "replicates" $ unlines + [ "segd length mismatch" + , " segd length = " ++ (show $ U.lengthSegd segd) + , " array length = " ++ (show $ V.length vec)] + + | otherwise + = join + $ V.zipWith V.replicate + (V.convert $ U.lengthsSegd segd) + vec + + +-- | O(sum lengths). Wrapper for segmented replicate that takes replication counts +-- and uses them to build the `U.Segd`. +replicates' :: PArray Int -> PArray a -> PArray a +replicates' reps arr + = replicates (U.lengthsToSegd $ V.convert $ reps) arr + + +-- | Append two arrays. +append :: PArray a -> PArray a -> PArray a +append = (V.++) + + +-- | Lifted append. +appendl :: PArray (PArray a) -> PArray (PArray a) -> PArray (PArray a) +appendl = lift2 append + + +-- | Concatenation +concat :: PArray (PArray a) -> PArray a +concat = join + + +-- | Lifted concatenation. +concatl :: PArray (PArray (PArray a)) -> PArray (PArray a) +concatl = lift1 concat + + +-- | Impose a nesting structure on a flat array +unconcat :: PArray (PArray a) -> PArray b -> PArray (PArray b) +unconcat arr1 arr2 + = nestUSegd (takeUSegd arr1) arr2 + + +-- | Create a nested array from a segment descriptor and some flat data. +-- The segment descriptor must represent as many elements as present +-- in the flat data array, else `error` +nestUSegd :: U.Segd -> PArray a -> PArray (PArray a) +nestUSegd segd vec + | U.elementsSegd segd == V.length vec + = V.zipWith + (\start len -> V.slice start len vec) + (V.convert $ U.indicesSegd segd) + (V.convert $ U.lengthsSegd segd) + + | otherwise + = error $ unlines + [ "Data.Array.Parallel.PArray.nestSegd: number of elements defined by " + ++ "segment descriptor and data array do not match" + , " length of segment desciptor = " ++ (show $ U.elementsSegd segd) + , " length of data array = " ++ (show $ V.length vec)] +{-# NOINLINE nestUSegd #-} + + +-- Projections ---------------------------------------------------------------- +-- | Take the length of an array +length :: PArray a -> Int +length = V.length + + +-- | Take the length of some arrays. +lengthl :: PArray (PArray a) -> PArray Int +lengthl = lift1 length + + +-- | Lookup a single element from the source array. +index :: PArray a -> Int -> a +index = (V.!) + + +-- | Lookup a several elements from several source arrays. +indexl :: PArray (PArray a) -> PArray Int -> PArray a +indexl = lift2 index + + +-- | Extract a range of elements from an array. +extract :: PArray a -> Int -> Int -> PArray a +extract vec start len + = V.slice start len vec + + +-- | Segmented extract. +extracts :: Vector (PArray a) -> U.SSegd -> PArray a +extracts arrs ssegd + = join + $ V.zipWith3 + (\src start len -> extract (arrs V.! src) start len) + (V.convert $ U.sourcesOfSSegd ssegd) + (V.convert $ U.startsOfSSegd ssegd) + (V.convert $ U.lengthsOfSSegd ssegd) + + +-- | Wrapper for `extracts` that takes arrays of sources, starts and lengths of +-- the segments, and uses these to build the `U.SSegd`. +extracts' + :: Vector (PArray a) + -> PArray Int -- ^ id of source array for each segment. + -> PArray Int -- ^ starting index of each segment in its source array. + -> PArray Int -- ^ length of each segment. + -> PArray a +extracts' arrs sources starts lengths + = let segd = U.lengthsToSegd $ V.convert lengths + ssegd = U.mkSSegd + (V.convert $ starts) + (V.convert $ sources) + segd + in extracts arrs ssegd + + +-- | Extract a range of elements from an arrary. +-- Like `extract` but with the parameters in a different order. +slice :: Int -> Int -> PArray a -> PArray a +slice start len arr + = extract arr start len + + +-- | Extract some slices from some arrays. +-- The arrays of starting indices and lengths must themselves +-- have the same length. +slicel :: PArray Int -> PArray Int -> PArray (PArray a) -> PArray (PArray a) +slicel = lift3 slice + + +-- | Take the segment descriptor from a nested array. This can cause index space +-- overflow if the number of elements in the result does not can not be +-- represented by a single machine word. +takeUSegd :: PArray (PArray a) -> U.Segd +takeUSegd vec + = U.lengthsToSegd + $ V.convert + $ V.map length vec - when ( debugLiftedCompare - && or [ not $ A.valid arrImpl - , not $ A.length arrRef == A.length arrImpl - , not $ V.and $ V.zipWith similar - (A.toVectors1 arrRef) - (A.toVectors1 arrImpl)]) - $ error $ render $ vcat - [ text "withRef1: failure " <> text name - , nest 4 $ pprp1v $ A.toVectors1 arrRef - , nest 4 $ pprp1 $ arrImpl ] - return arrImpl +-- Pack and Combine ----------------------------------------------------------- +-- | Select the elements of an array that have their tag set to True. +pack :: PArray a -> PArray Bool -> PArray a +pack xs bs + | V.length xs /= V.length bs + = die "pack" $ unlines + [ "array length mismatch" + , " data length = " ++ (show $ V.length xs) + , " flags length = " ++ (show $ V.length bs) ] + | otherwise + = V.ifilter (\i _ -> bs V.! i) xs --- | Compare the nested result of some array operator against a reference. -withRef2 :: ( A.Array r (r a) - , A.Array r a - , A.Array c (c a), PprPhysical1 (c (c a)) - , A.Array c a, PprPhysical1 (c a) - , Similar a, PprPhysical1 a) - => String -- name of operator. - -> r (r a) -- result using reference implementaiton. - -> c (c a) -- result using vseg implementation. - -> c (c a) -{-# INLINE withRef2 #-} -withRef2 name arrRef arrImpl - = if debugLiftedCompare || debugLiftedTrace - then withRef2' name arrRef arrImpl - else arrImpl +-- | Lifted pack. +packl :: PArray (PArray a) -> PArray (PArray Bool) -> PArray (PArray a) +packl = lift2 pack -{-# NOINLINE withRef2' #-} -withRef2' name arrRef arrImpl - = unsafePerformIO - $ do when debugLiftedTrace - $ do putStrLn $ "* " ++ name - putStrLn $ render (nest 4 $ pprp1 arrImpl) - hFlush stdout - when ( debugLiftedCompare - && or [ not $ A.valid arrImpl - , not $ A.length arrRef == A.length arrImpl - , not $ V.and $ V.zipWith - (\xs ys -> V.and $ V.zipWith similar xs ys) - (A.toVectors2 arrRef) - (A.toVectors2 arrImpl) ]) - $ error $ render $ vcat - [ text "withRef2: failure " <> text name - , nest 4 $ pprp1 arrImpl ] +-- | Filter an array based on some tags. +packByTag :: PArray a -> U.Array Tag -> Tag -> PArray a +packByTag xs tags tag + | V.length xs /= U.length tags + = die "packByTag" $ unlines + [ "array length mismatch" + , " data length = " ++ (show $ V.length xs) + , " flags length = " ++ (show $ U.length tags) ] - return arrImpl + | otherwise + = V.ifilter (\i _ -> U.index (here "packByTag") tags i == tag) xs --- toRef ---------------------------------------------------------------------- --- | Convert an array to the reference version. -toRef1 :: ( A.Array c a - , A.Array r a) - => c a -> r a +-- | Combine two arrays based on a selector. +combine2 :: U.Sel2 -> PArray a -> PArray a -> PArray a +combine2 tags vec1 vec2 + = let go [] [] [] = [] + go (0 : bs) (x : xs) ys = x : go bs xs ys + go (1 : bs) xs (y : ys) = y : go bs xs ys + go _ _ _ = error "Data.Array.Parallel.PArray.combine: length mismatch" + + in V.fromList + $ go (V.toList $ V.convert $ U.tagsSel2 tags) + (V.toList vec1) + (V.toList vec2) -toRef1 = A.fromVectors1 . A.toVectors1 -{-# NOINLINE toRef1 #-} --- NOINLINE because it's only for debugging. +-- Enumerations --------------------------------------------------------------- +-- | Construct a range of integers +enumFromTo :: Int -> Int -> PArray Int +enumFromTo = V.enumFromTo --- | Convert a nested array to the reference version. -toRef2 :: ( A.Array c (c a) - , A.Array c a - , A.Array r (r a) - , A.Array r a) - => c (c a) - -> r (r a) -toRef2 = A.fromVectors2 . A.toVectors2 -{-# NOINLINE toRef2 #-} --- NOINLINE because it's only for debugging. +-- | Lifted enumeration +enumFromTol :: PArray Int -> PArray Int -> PArray (PArray Int) +enumFromTol = lift2 enumFromTo --- | Convert a doubly nested array to the reference version. -toRef3 :: ( A.Array c (c (c a)) - , A.Array c (c a) - , A.Array c a - , A.Array r (r (r a)) - , A.Array r (r a) - , A.Array r a) - => c (c (c a)) - -> r (r (r a)) +-- Tuples --------------------------------------------------------------------- +-- | O(n). Zip a pair of arrays into an array of pairs. +zip :: PArray a -> PArray b -> PArray (a, b) +zip = V.zip -toRef3 = A.fromVectors3 . A.toVectors3 -{-# NOINLINE toRef3 #-} --- NOINLINE because it's only for debugging. + +-- | Lifted zip +zipl :: PArray (PArray a) -> PArray (PArray b) -> PArray (PArray (a, b)) +zipl = lift2 zip + + +-- | O(n). Unzip an array of pairs into a pair of arrays. +unzip :: PArray (a, b) -> (PArray a, PArray b) +unzip = V.unzip + + +-- | Lifted unzip +unzipl :: PArray (PArray (a, b)) -> PArray (PArray a, PArray b) +unzipl = lift1 unzip + + +-- Conversions ---------------------------------------------------------------- +-- | Convert a `Vector` to a `PArray` +fromVector :: Vector a -> PArray a +fromVector = id + + +-- | Convert a `PArray` to a `Vector` +toVector :: PArray a -> Vector a +toVector = id + +-- | Convert a list to a `PArray`. +fromList :: [a] -> PArray a +fromList = V.fromList + +-- | Convert a `PArray` to a list. +toList :: PArray a -> [a] +toList = V.toList + + +-- | Convert a `U.Array` to a `PArray` +fromUArray :: U.Elt a => U.Array a -> PArray a +fromUArray = V.convert + + +-- | Convert a `PArray` to a `U.Array` +toUArray :: U.Elt a => PArray a -> U.Array a +toUArray = V.convert + + +-- | Convert a `U.Array` of tuples to a `PArray` +fromUArray2 + :: (U.Elt a, U.Elt b) + => U.Array (a, b) -> PArray (a, b) + +fromUArray2 = V.convert diff --git a/Data/Array/Parallel/PArray/Reference/Convert.hs b/Data/Array/Parallel/PArray/Reference/Convert.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/Reference/Convert.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS -fno-warn-missing-signatures #-} +-- | During testing, we compare the output of each invocation of the lifted +-- combinators in "Data.Array.Parallel.PArray" with the reference implementations. +-- +-- This module helps convert the to and from the array representation +-- used by the reference implementation. + +-- TODO: we could use this to trace the lengths of the vectors being used, +-- as well as the types that each opeartor is being called at. +-- +module Data.Array.Parallel.PArray.Reference.Convert + ( Similar(..), PprPhysical1 (..) + , withRef1, withRef2 + , toRef1, toRef2, toRef3) +where +import Data.Array.Parallel.Pretty +import qualified Data.Array.Parallel.Array as A +import qualified Data.Vector as V +import Data.Vector (Vector) +import Prelude hiding (length) +import System.IO +import System.IO.Unsafe +import Control.Monad + +-- Config --------------------------------------------------------------------- +debugLiftedTrace :: Bool +debugLiftedTrace = False + +debugLiftedCompare :: Bool +debugLiftedCompare = False + +class Similar a where + similar :: a -> a -> Bool + +class PprPhysical1 a where + pprp1 :: a -> Doc + + pprp1v :: Vector a -> Doc + pprp1v vec + = brackets + $ hcat + $ punctuate (text ", ") + $ V.toList $ V.map pprp1 vec + + +-- withRef -------------------------------------------------------------------- +-- | Compare the result of some array operator against a reference. + +-- Careful: +-- * We don't want to inline the whole body of this function into +-- every use site, or we'll get code explosion. When debugging is off we +-- want this wrapper to be inlined and eliminated as cheaply as possible. +-- * We also do this with 'unsafePerformIO' instead of trace, because +-- with trace, if the computation contructing the string throws an exception +-- then we get no output. For debugging we want to see what function was +-- entered before we try to print the result (which might be badly formed), +-- +withRef1 :: ( A.Array r a + , A.Array c a, PprPhysical1 (c a) + , Similar a, PprPhysical1 a) + => String -- name of operator + -> r a -- result using reference implementation + -> c a -- result using vseg implementation + -> c a + +{-# INLINE withRef1 #-} +withRef1 name arrRef arrImpl + = if debugLiftedCompare || debugLiftedTrace + then withRef1' name arrRef arrImpl + else arrImpl + +{-# NOINLINE withRef1' #-} +withRef1' name arrRef arrImpl + = unsafePerformIO + $ do when debugLiftedTrace + $ do putStrLn $ "* " ++ name + putStrLn $ render (nest 4 $ pprp1 arrImpl) + hFlush stdout + + when ( debugLiftedCompare + && or [ not $ A.valid arrImpl + , not $ A.length arrRef == A.length arrImpl + , not $ V.and $ V.zipWith similar + (A.toVectors1 arrRef) + (A.toVectors1 arrImpl)]) + $ error $ render $ vcat + [ text "withRef1: failure " <> text name + , nest 4 $ pprp1v $ A.toVectors1 arrRef + , nest 4 $ pprp1 $ arrImpl ] + + return arrImpl + + +-- | Compare the nested result of some array operator against a reference. +withRef2 :: ( A.Array r (r a) + , A.Array r a + , A.Array c (c a), PprPhysical1 (c (c a)) + , A.Array c a, PprPhysical1 (c a) + , Similar a, PprPhysical1 a) + => String -- name of operator. + -> r (r a) -- result using reference implementaiton. + -> c (c a) -- result using vseg implementation. + -> c (c a) + +{-# INLINE withRef2 #-} +withRef2 name arrRef arrImpl + = if debugLiftedCompare || debugLiftedTrace + then withRef2' name arrRef arrImpl + else arrImpl + +{-# NOINLINE withRef2' #-} +withRef2' name arrRef arrImpl + = unsafePerformIO + $ do when debugLiftedTrace + $ do putStrLn $ "* " ++ name + putStrLn $ render (nest 4 $ pprp1 arrImpl) + hFlush stdout + + when ( debugLiftedCompare + && or [ not $ A.valid arrImpl + , not $ A.length arrRef == A.length arrImpl + , not $ V.and $ V.zipWith + (\xs ys -> V.and $ V.zipWith similar xs ys) + (A.toVectors2 arrRef) + (A.toVectors2 arrImpl) ]) + $ error $ render $ vcat + [ text "withRef2: failure " <> text name + , nest 4 $ pprp1 arrImpl ] + + return arrImpl + + +-- toRef ---------------------------------------------------------------------- +-- | Convert an array to the reference version. +toRef1 :: ( A.Array c a + , A.Array r a) + => c a -> r a + +toRef1 = A.fromVectors1 . A.toVectors1 +{-# NOINLINE toRef1 #-} +-- NOINLINE because it's only for debugging. + + +-- | Convert a nested array to the reference version. +toRef2 :: ( A.Array c (c a) + , A.Array c a + , A.Array r (r a) + , A.Array r a) + => c (c a) + -> r (r a) + +toRef2 = A.fromVectors2 . A.toVectors2 +{-# NOINLINE toRef2 #-} +-- NOINLINE because it's only for debugging. + + +-- | Convert a doubly nested array to the reference version. +toRef3 :: ( A.Array c (c (c a)) + , A.Array c (c a) + , A.Array c a + , A.Array r (r (r a)) + , A.Array r (r a) + , A.Array r a) + => c (c (c a)) + -> r (r (r a)) + +toRef3 = A.fromVectors3 . A.toVectors3 +{-# NOINLINE toRef3 #-} +-- NOINLINE because it's only for debugging. diff --git a/Data/Array/Parallel/PArray/Types.hs b/Data/Array/Parallel/PArray/Types.hs --- a/Data/Array/Parallel/PArray/Types.hs +++ b/Data/Array/Parallel/PArray/Types.hs @@ -27,6 +27,7 @@ where import Data.Array.Parallel.Base (Tag) import Data.Array.Parallel.Pretty +import Data.Typeable -- Void ----------------------------------------------------------------------- @@ -37,6 +38,8 @@ -- data Void +deriving instance Typeable Void + -- | A 'value' with the void type. Used as a placholder like `undefined`. -- Forcing this yields `error`. void :: Void @@ -60,6 +63,9 @@ data Sum2 a b = Alt2_1 a | Alt2_2 b +deriving instance Typeable2 Sum2 + + tagOfSum2 :: Sum2 a b -> Tag tagOfSum2 ss = case ss of @@ -80,6 +86,9 @@ data Sum3 a b c = Alt3_1 a | Alt3_2 b | Alt3_3 c +deriving instance Typeable3 Sum3 + + tagOfSum3 :: Sum3 a b c -> Tag tagOfSum3 ss = case ss of @@ -114,3 +123,4 @@ -- newtype Wrap a = Wrap { unWrap :: a } +deriving instance Typeable1 Wrap diff --git a/dph-lifted-base.cabal b/dph-lifted-base.cabal --- a/dph-lifted-base.cabal +++ b/dph-lifted-base.cabal @@ -1,5 +1,5 @@ Name: dph-lifted-base -Version: 0.6.1.1 +Version: 0.7.0.1 License: BSD3 License-File: LICENSE Author: The DPH Team @@ -15,7 +15,7 @@ Exposed-Modules: Data.Array.Parallel.PArray.Types Data.Array.Parallel.PArray.Reference - Data.Array.Parallel.PArray + Data.Array.Parallel.PArray.Reference.Convert Data.Array.Parallel.PArr Exposed: @@ -43,7 +43,7 @@ ExistentialQuantification, ScopedTypeVariables, PatternGuards, - PackageImports + DeriveDataTypeable GHC-Options: -Odph @@ -53,13 +53,13 @@ -fno-warn-orphans Build-Depends: - base == 4.5.*, + base == 4.6.*, ghc == 7.*, array == 0.4.*, random == 1.0.*, - template-haskell == 2.7.*, - vector == 0.9.*, + template-haskell == 2.8.*, + dph-base == 0.7.*, + dph-prim-par == 0.7.*, + vector == 0.10.*, pretty == 1.1.*, - containers == 0.4.*, - dph-base == 0.6.1.*, - dph-prim-par == 0.6.1.* + containers == 0.5.*