diff --git a/Data/Array/Vector.hs b/Data/Array/Vector.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector.hs @@ -0,0 +1,191 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector +-- Copyright : (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy +-- (c) 2008 Don Stewart + +-- License : see LICENSE +-- +-- Maintainer : Don Stewart +-- Portability : See .cabal file +-- +-- Description --------------------------------------------------------------- +-- +-- The top level interface to operations on strict, non-nested, fusible arrays. +-- +-- + +module Data.Array.Vector ( + + -- * Array classes + UA, + + -- * The pure and mutable array types + UArr, MUArr, + + -- * Streaming pure arrays + streamU, unstreamU, + + -- * Conversions to\/from lists + toU, fromU, + + -- * Basic operations on pure arrays + -- ** Introducing and eliminating UArrs + emptyU, + singletonU, + + -- ** Basic interface + consU, + snocU, + -- uncons + appendU, + headU, + lastU, + tailU, + initU, + nullU, + unitsU, + lengthU, + + -- * Transforming UArrs + mapU, + + -- * Reducing 'UArr's (folds) + foldU, + fold1U, + fold1MaybeU, + + foldlU, + foldl1U, + foldl1MaybeU, + + -- ** Logical operations + andU, + orU, + anyU, + allU, + + -- * Arithmetic operations + sumU, productU, + maximumU, minimumU, + maximumByU, minimumByU, +-- maximumIndexU, minimumIndexU, +-- maximumIndexByU, minimumIndexByU, + + -- * Building UArrs + -- ** Scans + scanlU, + scanl1U, + {-scanrU, scanr1U,-} + scanU, + scan1U, + scanResU, + + -- ** Accumulating UArrs + mapAccumLU, + + -- ** Generating UArrs + replicateU, + replicateEachU, + + -- * Subarrays + + -- ** Breaking arrays + sliceU, +-- extractU, + takeU, + dropU, + splitAtU, + takeWhileU, + dropWhileU, + {- spanU, breakU,-} + + -- * Searching Arrays + + -- ** Searching by equality + elemU, + notElemU, + + -- ** Searching with a predicate + filterU, + findU, + + -- * Indexing UArr + indexU, + findIndexU, + lookupU, + + -- * Zipping and unzipping + zipU, zip3U, + unzipU, unzip3U, + zipWithU, + zipWith3U, + fstU, + sndU, + + -- * Enumerations + enumFromToU, + enumFromToFracU, + enumFromThenToU, + enumFromStepLenU, + enumFromToEachU, + + -- * Low level conversions + + -- * Low level conversions + -- ** Copying arrays + -- ** Packing 'CString's and pointers + -- ** Using UArrs as 'CString's + -- * I\/O with 'UArr's + + -- creating them, generating new arrays from old ones. + +------------------------------------------------------------------------ + + combineU, + packU, + indexedU, + repeatU, + + -- * Permutations + -- permuteU, bpermuteU, bpermuteDftU, reverseU, updateU, + + -- * Searching + {- indexOfU,-} + + -- * Arrays of pairs + {-crossU,-} + + -- * Random arrays + -- randomU, randomRU, + + unfoldU, + + -- * I\/O + UIO(..), + + -- * Operations on mutable arrays + newU, lengthMU, newMU, readMU, writeMU, unsafeFreezeMU, unsafeFreezeAllMU, + copyMU, permuteMU, atomicUpdateMU, unstreamMU, + + module Data.Array.Vector.Prim.Hyperstrict + + ) where + +import Data.Array.Vector.UArr ( + UA, UArr, MUArr, + newU, lengthMU, newMU, readMU, writeMU, copyMU, + unsafeFreezeMU, unsafeFreezeAllMU) + +import Data.Array.Vector.Prim.Hyperstrict +import Data.Array.Vector.UArr hiding (lengthU, indexU) + +import Data.Array.Vector.Strict.Stream +import Data.Array.Vector.Strict.Basics +import Data.Array.Vector.Strict.Enum +import Data.Array.Vector.Strict.Sums +import Data.Array.Vector.Strict.Permute +import Data.Array.Vector.Strict.Text () + + diff --git a/Data/Array/Vector/Prim/BUArr.hs b/Data/Array/Vector/Prim/BUArr.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Prim/BUArr.hs @@ -0,0 +1,883 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +#include "MachDeps.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Arr.BUArr +-- Copyright : (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- (c) [2006..2007] Manuel M T Chakravarty & Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : non-portable (unboxed values and GHC libraries) +-- +-- Description --------------------------------------------------------------- +-- +-- This module define our own infrastructure for unboxed arrays, but recycle +-- some of the existing abstractions for boxed arrays. It's more important to +-- have precise control over the implementation of unboxed arrays, because +-- they are more performance critical. All arrays defined here are +-- `Int'-indexed without H98 `Ix' support. +-- +-- So far, we only support Char, Int, Float, and Double in unboxed arrays +-- (adding more is merely a matter of tedious typing). +-- +-- Todo ---------------------------------------------------------------------- +-- +-- * For some not understood reason, `checkCritical' prevents the write +-- operations to be inlined. Instead, a specialised version of them is +-- called. Interestingly, this doesn't seem to affect runtime negatively +-- (as opposed to still checking, but inlining everything). Nevertheless, +-- bounds checks cost performance. (Checking only the writes in SMVM costs +-- about a factor of two for the fully fused version and about 50% for the +-- partially fused version.) +-- +-- We could check only check some of the writes (eg, in permutations) as we +-- know for others that they can never be out of bounds (provided this +-- library is correct). +-- +-- * There is no proper block copy support yet. It would be helpful for +-- extracting and copying. But do we need extracting if we have slicing? +-- (Slicing instead of extracting may introduce space leaks..) +-- +-- * If during freezing it becomes clear that the array is much smaller than +-- originally allocated, it might be worthwhile to copy the data into a new, +-- smaller array. + + +module Data.Array.Vector.Prim.BUArr ( + -- * Unboxed primitive arrays (both immutable and mutable) + BUArr(..), MBUArr, + + -- * Class of elements of such arrays + UAE(..), + + -- * Operations on mutable arrays + lengthMBU, newMBU, extractMBU, copyMBU, + unsafeFreezeMBU, unsafeFreezeAllMBU, + + -- * Basic operations + lengthBU, emptyBU, replicateBU, sliceBU, extractBU, + + -- * Streaming + streamBU, unstreamBU, + + -- * Higher-order operations + mapBU, foldlBU, foldBU, scanlBU, scanBU, + + -- * Arithmetic operations + sumBU, + + -- * Conversions to\/from lists + toBU, fromBU, + + -- * I\/O + hPutBU, hGetBU + + -- * Re-exporting some of GHC's internals that higher-level modules need +-- Char#, Int#, Float#, Double#, Char(..), Int(..), Float(..), Double(..), ST, +-- runST +) where + +-- GHC-internal definitions +import GHC.Prim ( + Char#, Int#, Float#, Double#, Word#, + + ByteArray#, MutableByteArray#, RealWorld, + newByteArray#, unsafeFreezeArray#, unsafeThawArray#, unsafeCoerce#, + + (+#), (*#), and#, or#, xor#, neWord#, word2Int#, int2Word#, + uncheckedIShiftRA#, uncheckedShiftL#, + + indexWideCharArray#, readWideCharArray#, writeWideCharArray#, + indexIntArray#, readIntArray#, writeIntArray#, + indexWordArray#, readWordArray#, writeWordArray#, + + indexWord8Array#, readWord8Array#, writeWord8Array#, + indexWord16Array#, readWord16Array#, writeWord16Array#, + indexWord32Array#, readWord32Array#, writeWord32Array#, + indexWord64Array#, readWord64Array#, writeWord64Array#, + + indexInt8Array#, readInt8Array#, writeInt8Array#, + indexInt16Array#, readInt16Array#, writeInt16Array#, + indexInt32Array#, readInt32Array#, writeInt32Array#, + indexInt64Array#, readInt64Array#, writeInt64Array#, + + indexFloatArray#, readFloatArray#, writeFloatArray#, + indexDoubleArray#, readDoubleArray#, writeDoubleArray#) + +import GHC.Base ( + Char(..), Int(..)) +import GHC.Float ( + Float(..), Double(..)) +import GHC.Word ( + Word(..), Word8(..), Word16(..), Word32(..), Word64(..)) +import GHC.Int ( + Int8(..), Int16(..), Int32(..), Int64(..)) +import GHC.ST +import GHC.IO + +import System.IO +import Foreign +import Foreign.C (CSize) + +import GHC.Handle +import GHC.IOBase +import GHC.Ptr + +import Foreign.C.Types + +-- NDP library +import Data.Array.Vector.Prim.Hyperstrict +import Data.Array.Vector.Prim.Debug +import Data.Array.Vector.Stream + +infixl 9 `indexBU`, `readMBU` + +here s = "Arr.BUArr." ++ s + +-- |Unboxed arrays +-- --------------- + +-- Unboxed arrays of primitive element types arrays constructed from an +-- explicit length and a byte array in both an immutable and a mutable variant +-- +data BUArr e = BUArr !Int !Int ByteArray# +data MBUArr s e = MBUArr !Int (MutableByteArray# s) + +-- instance HS e => HS (BUArr e) +-- instance HS e => HS (MBUArr s e) + +-- |Number of elements of an immutable unboxed array +-- +lengthBU :: BUArr e -> Int +lengthBU (BUArr _ n _) = n + +-- |Number of elements of a mutable unboxed array +-- +lengthMBU :: MBUArr s e -> Int +lengthMBU (MBUArr n _) = n + +-- |The basic operations on unboxed arrays are overloaded +-- +class UAE e where + sizeBU :: Int -> e -> Int -- size of an array with n elements + indexBU :: BUArr e -> Int -> e + readMBU :: MBUArr s e -> Int -> ST s e + writeMBU :: MBUArr s e -> Int -> e -> ST s () + +-- |Empty array +-- +emptyBU :: UAE e => BUArr e +emptyBU = runST (do + a <- newMBU 0 + unsafeFreezeMBU a 0 + ) + +-- |Produces an array that consists of a subrange of the original one without +-- copying any elements. +-- +sliceBU :: BUArr e -> Int -> Int -> BUArr e +sliceBU (BUArr start len arr) newStart newLen = + let start' = start + newStart + in + BUArr start' ((len - newStart) `min` newLen) arr + +-- |Allocate an uninitialised unboxed array +-- +newMBU :: forall s e. UAE e => Int -> ST s (MBUArr s e) +{-# INLINE newMBU #-} +newMBU n = ST $ \s1# -> + case sizeBU n (undefined::e) of {I# len# -> + case newByteArray# len# s1# of {(# s2#, marr# #) -> + (# s2#, MBUArr n marr# #) }} + +-- |Turn a mutable into an immutable array WITHOUT copying its contents, which +-- implies that the mutable array must not be mutated anymore after this +-- operation has been executed. +-- +-- * The explicit size parameter supports partially filled arrays (and must be +-- less than or equal the size used when allocating the mutable array) +-- +unsafeFreezeMBU :: MBUArr s e -> Int -> ST s (BUArr e) +{-# INLINE unsafeFreezeMBU #-} +unsafeFreezeMBU (MBUArr m mba#) n = + checkLen (here "unsafeFreezeMBU") m n $ ST $ \s# -> + (# s#, BUArr 0 n (unsafeCoerce# mba#) #) + +-- |Turn a mutable into an immutable array WITHOUT copying its contents, which +-- implies that the mutable array must not be mutated anymore after this +-- operation has been executed. +-- +-- * In contrast to 'unsafeFreezeMBU', this operation always freezes the +-- entire array. +-- +unsafeFreezeAllMBU :: MBUArr s e -> ST s (BUArr e) +{-# INLINE unsafeFreezeAllMBU #-} +unsafeFreezeAllMBU (MBUArr m mba#) = + ST $ \s# -> (# s#, BUArr 0 m (unsafeCoerce# mba#) #) + + +-- |Instances of unboxed arrays +-- - + +-- This is useful to define loops that act as generators cheaply (see the +-- ``Functional Array Fusion'' paper) +-- +instance UAE () where + sizeBU _ _ = 0 + + {-# INLINE indexBU #-} + indexBU (BUArr _ _ _) (I# _) = () + + {-# INLINE readMBU #-} + readMBU (MBUArr _ _) (I# _) = ST $ \s# -> + (# s#, () #) + + {-# INLINE writeMBU #-} + writeMBU (MBUArr _ _) (I# _) () = ST $ \s# -> + (# s#, () #) + +{- +instance UAE Bool where + sizeBU (I# n#) _ = I# n# + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Bool]") n i $ + (indexWord8Array# ba# (s# +# i#) `neWord#` int2Word# 0#) + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Bool]") n i $ + ST $ \s# -> + case readWord8Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, r# `neWord#` int2Word# 0# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) e# = + checkCritical (here "writeMBU[Bool]") n i $ + ST $ \s# -> + case writeWord8Array# mba# i# b# s# of {s2# -> + (# s2#, () #)} + where + b# = int2Word# (if e# then 1# else 0#) +-} + +instance UAE Bool where + sizeBU (I# n#) _ = I# (bOOL_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Bool]") n i $ + (indexWordArray# ba# (bOOL_INDEX (s# +# i#)) `and#` bOOL_BIT (s# +# i#)) + `neWord#` int2Word# 0# + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Bool]") n i $ ST $ \s# -> + case readWordArray# mba# (bOOL_INDEX i#) s# of {(# s2#, r# #) -> + (# s2#, (r# `and#` bOOL_BIT i#) `neWord#` int2Word# 0# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) e# = + checkCritical (here "writeMBU[Bool]") n i $ ST $ \s# -> + case bOOL_INDEX i# of {j# -> + case readWordArray# mba# j# s# of {(# s2#, v# #) -> + case if e# then v# `or#` bOOL_BIT i# + else v# `and#` bOOL_NOT_BIT i# of {v'# -> + case writeWordArray# mba# j# v'# s2# of {s3# -> + (# s3#, () #)}}}} + +instance UAE Char where + sizeBU (I# n#) _ = I# (cHAR_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Char]") n i $ + case indexWideCharArray# ba# (s# +# i#) of {r# -> + (C# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Char]") n i $ + ST $ \s# -> + case readWideCharArray# mba# i# s# of {(# s2#, r# #) -> + (# s2#, C# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (C# e#) = + checkCritical (here "writeMBU[Char]") n i $ + ST $ \s# -> + case writeWideCharArray# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Int where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Int]") n i $ + case indexIntArray# ba# (s# +# i#) of {r# -> + (I# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Int]") n i $ + ST $ \s# -> + case readIntArray# mba# i# s# of {(# s2#, r# #) -> + (# s2#, I# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (I# e#) = + checkCritical (here "writeMBU[Int]") n i $ + ST $ \s# -> + case writeIntArray# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Word where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Word]") n i $ + case indexWordArray# ba# (s# +# i#) of {r# -> + (W# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Word]") n i $ + ST $ \s# -> + case readWordArray# mba# i# s# of {(# s2#, r# #) -> + (# s2#, W# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (W# e#) = + checkCritical (here "writeMBU[Word]") n i $ + ST $ \s# -> + case writeWordArray# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Float where + sizeBU (I# n#) _ = I# (fLOAT_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Float]") n i $ + case indexFloatArray# ba# (s# +# i#) of {r# -> + (F# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Float]") n i $ + ST $ \s# -> + case readFloatArray# mba# i# s# of {(# s2#, r# #) -> + (# s2#, F# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (F# e#) = + checkCritical (here "writeMBU[Float]") n i $ + ST $ \s# -> + case writeFloatArray# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Double where + sizeBU (I# n#) _ = I# (dOUBLE_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Double]") n i $ + case indexDoubleArray# ba# (s# +# i#) of {r# -> + (D# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Double]") n i $ + ST $ \s# -> + case readDoubleArray# mba# i# s# of {(# s2#, r# #) -> + (# s2#, D# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (D# e#) = + checkCritical (here "writeMBU[Double]") n i $ + ST $ \s# -> + case writeDoubleArray# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Word8 where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Word8]") n i $ + case indexWord8Array# ba# (s# +# i#) of {r# -> + (W8# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Word8]") n i $ + ST $ \s# -> + case readWord8Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, W8# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (W8# e#) = + checkCritical (here "writeMBU[Word8]") n i $ + ST $ \s# -> + case writeWord8Array# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Word16 where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Word16]") n i $ + case indexWord16Array# ba# (s# +# i#) of {r# -> + (W16# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Word16]") n i $ + ST $ \s# -> + case readWord16Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, W16# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (W16# e#) = + checkCritical (here "writeMBU[Word16]") n i $ + ST $ \s# -> + case writeWord16Array# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Word32 where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Word32]") n i $ + case indexWord32Array# ba# (s# +# i#) of {r# -> + (W32# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Word32]") n i $ + ST $ \s# -> + case readWord32Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, W32# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (W32# e#) = + checkCritical (here "writeMBU[Word32]") n i $ + ST $ \s# -> + case writeWord32Array# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Word64 where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Word64]") n i $ + case indexWord64Array# ba# (s# +# i#) of {r# -> + (W64# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Word64]") n i $ + ST $ \s# -> + case readWord64Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, W64# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (W64# e#) = + checkCritical (here "writeMBU[Word64]") n i $ + ST $ \s# -> + case writeWord64Array# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Int8 where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Int8]") n i $ + case indexInt8Array# ba# (s# +# i#) of {r# -> + (I8# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Int8]") n i $ + ST $ \s# -> + case readInt8Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, I8# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (I8# e#) = + checkCritical (here "writeMBU[Int8]") n i $ + ST $ \s# -> + case writeInt8Array# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Int16 where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Int16]") n i $ + case indexInt16Array# ba# (s# +# i#) of {r# -> + (I16# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Int16]") n i $ + ST $ \s# -> + case readInt16Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, I16# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (I16# e#) = + checkCritical (here "writeMBU[Int16]") n i $ + ST $ \s# -> + case writeInt16Array# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Int32 where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Int32]") n i $ + case indexInt32Array# ba# (s# +# i#) of {r# -> + (I32# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Int32]") n i $ + ST $ \s# -> + case readInt32Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, I32# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (I32# e#) = + checkCritical (here "writeMBU[Int32]") n i $ + ST $ \s# -> + case writeInt32Array# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +instance UAE Int64 where + sizeBU (I# n#) _ = I# (wORD_SCALE n#) + + {-# INLINE indexBU #-} + indexBU (BUArr (I# s#) n ba#) i@(I# i#) = + check (here "indexBU[Int64]") n i $ + case indexInt64Array# ba# (s# +# i#) of {r# -> + (I64# r#)} + + {-# INLINE readMBU #-} + readMBU (MBUArr n mba#) i@(I# i#) = + check (here "readMBU[Int64]") n i $ + ST $ \s# -> + case readInt64Array# mba# i# s# of {(# s2#, r# #) -> + (# s2#, I64# r# #)} + + {-# INLINE writeMBU #-} + writeMBU (MBUArr n mba#) i@(I# i#) (I64# e#) = + checkCritical (here "writeMBU[Int64]") n i $ + ST $ \s# -> + case writeInt64Array# mba# i# e# s# of {s2# -> + (# s2#, () #)} + +------------------------------------------------------------------------ + +-- |Stream of unboxed arrays +-- ------------------------- + +-- | Generate a stream from an array, from left to right +-- +streamBU :: UAE e => BUArr e -> Stream e +{-# INLINE [1] streamBU #-} +streamBU arr = Stream next 0 (lengthBU arr) + where + n = lengthBU arr + -- + next i | i == n = Done + | otherwise = Yield (arr `indexBU` i) (i+1) + +-- | Construct an array from a stream, filling it from left to right +-- +unstreamBU :: UAE e => Stream e -> BUArr e +{-# INLINE [1] unstreamBU #-} +unstreamBU (Stream next s n) = + runST (do + marr <- newMBU n + n' <- fill0 marr + unsafeFreezeMBU marr n' + ) + where + fill0 marr = fill s 0 + where + fill s i = i `seq` + case next s of + Done -> return i + Skip s' -> fill s' i + Yield x s' -> do + writeMBU marr i x + fill s' (i+1) + +-- Fusion rules for unboxed arrays + +{-# RULES -- -} (for font-locking) + +"streamBU/unstreamBU" forall s. + streamBU (unstreamBU s) = s + + #-} + + +-- |Combinators for unboxed arrays +-- - + +-- |Replicate combinator for unboxed arrays +-- +replicateBU :: UAE e => Int -> e -> BUArr e +{-# INLINE replicateBU #-} +replicateBU n = unstreamBU . replicateS n + + +-- |Extract a slice from an array (given by its start index and length) +-- +extractBU :: UAE e => BUArr e -> Int -> Int -> BUArr e +{-# INLINE extractBU #-} +extractBU arr i n = + runST (do + ma <- newMBU n + copy0 ma + unsafeFreezeMBU ma n + ) + where + fence = n `min` (lengthBU arr - i) + copy0 ma = copy 0 + where + copy off | off == fence = return () + | otherwise = do + writeMBU ma off (arr `indexBU` (i + off)) + copy (off + 1) +-- NB: If we had a bounded version of loopBU, we could express extractBU in +-- terms of that loop combinator. The problem is that this makes fusion +-- more awkward; in particular, when the second loopBU in a +-- "loopBU/loopBU" situation has restricted bounds. On the other hand +-- sometimes fusing the extraction of a slice with the following +-- computation on that slice is very useful. +-- FIXME: If we leave it as it, we should at least use a block copy operation. +-- (What we really want is to represent extractBU as a loop when we can +-- fuse it with a following loop on the computed slice and, otherwise, +-- when there is no opportunity for fusion, we want to use a block copy +-- routine.) +-- FIXME: The above comments no longer apply as we've switched to stream-based +-- fusion. Moreover, slicing gives us bounded iteration for free. + +-- |Map a function over an unboxed array +-- +mapBU :: (UAE a, UAE b) => (a -> b) -> BUArr a -> BUArr b +{-# INLINE mapBU #-} +mapBU f = unstreamBU . mapS f . streamBU + +-- |Reduce an unboxed array +-- +foldlBU :: UAE b => (a -> b -> a) -> a -> BUArr b -> a +{-# INLINE foldlBU #-} +foldlBU f z = foldS f z . streamBU + +-- |Reduce an unboxed array using an *associative* combining operator +-- +foldBU :: UAE a => (a -> a -> a) -> a -> BUArr a -> a +{-# INLINE foldBU #-} +foldBU = foldlBU + +-- |Summation of an unboxed array +-- +sumBU :: (UAE a, Num a) => BUArr a -> a +{-# INLINE sumBU #-} +sumBU = foldBU (+) 0 + +-- |Prefix reduction of an unboxed array +-- +scanlBU :: (UAE a, UAE b) => (a -> b -> a) -> a -> BUArr b -> BUArr a +{-# INLINE scanBU #-} +scanlBU f z = unstreamBU . scanS f z . streamBU + +-- |Prefix reduction of an unboxed array using an *associative* combining +-- operator +-- +scanBU :: UAE a => (a -> a -> a) -> a -> BUArr a -> BUArr a +scanBU = scanlBU + +-- |Extract a slice from a mutable array (the slice is immutable) +-- +extractMBU :: UAE e => MBUArr s e -> Int -> Int -> ST s (BUArr e) +{-# INLINE extractMBU #-} +extractMBU arr i n = do + arr' <- unsafeFreezeMBU arr (i + n) + return $ extractBU arr' i n + +-- |Copy a the contents of an immutable array into a mutable array from the +-- specified position on +-- +copyMBU :: UAE e => MBUArr s e -> Int -> BUArr e -> ST s () +{-# SPECIALIZE + copyMBU :: MBUArr s Int -> Int -> BUArr Int -> ST s () #-} +copyMBU marr i arr = ins i 0 + where + n = lengthBU arr + -- + ins i j | j == n = return () + | otherwise = do + writeMBU marr i (arr `indexBU` j) + ins (i + 1) (j + 1) + +-- Eq instance +-- +instance (Eq e, UAE e) => Eq (BUArr e) where + arr == brr = n == lengthBU brr && eq 0 + where + n = lengthBU arr + eq i | i == n = True + | otherwise = (arr `indexBU` i) == (brr `indexBU` i) + && eq (i+1) + +-- Show instance +-- +instance (Show e, UAE e) => Show (BUArr e) where + showsPrec _ a = showString "toBU " + . showList [a `indexBU` i | i <- [0..lengthBU a - 1]] + +------------------------------------------------------------------------ + +-- Auxilliary functions +-- -------------------- + +-- |Convert a list to an array +-- +toBU :: UAE e => [e] -> BUArr e +toBU = unstreamBU . toStream + +-- |Convert an array to a list +-- +fromBU :: UAE e => BUArr e -> [e] +fromBU a = map (a `indexBU`) [0 .. lengthBU a - 1] + +------------------------------------------------------------------------ +-- To and from ByteStrings + +{- +toBS :: forall e . UAE e => BUArr e -> ByteString +toBS arr@(BUArr off len addr#) = unsafePerformIO $ do + p <- newForeignPtr_ (Ptr (unsafeCoerce# addr#)) + return $ PS p off_bytes len_bytes + where + len_bytes = sizeBU len (undefined :: e) + off_bytes = sizeBU off (undefined :: e) +-} + +------------------------------------------------------------------------ +-- IO +-- -- + +-- host order , uninterpreted IO for BUArrays + +hGetBU :: forall e. UAE e => Handle -> IO (BUArr e) +hGetBU h = + alloca $ \iptr -> + do + hGetBuf h iptr (sizeOf (undefined :: Int)) + n <- peek iptr + marr@(MBUArr _ marr#) <- stToIO (newMBU n) + let bytes = sizeBU n (undefined :: e) + wantReadableHandle "hGetBU" h $ + \handle@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do + buf@Buffer { bufBuf = raw, bufWPtr = w, bufRPtr = r } <- readIORef ref + let copied = bytes `min` (w - r) + remaining = bytes - copied + newr = r + copied + newbuf | newr == w = buf{ bufRPtr = 0, bufWPtr = 0 } + | otherwise = buf{ bufRPtr = newr } + --memcpy_ba_baoff marr# raw (fromIntegral r) (fromIntegral copied) + memcpy_ba_baoff marr# raw (fromIntegral r) (fromIntegral copied) + writeIORef ref newbuf + readChunkBU fd is_stream marr# copied remaining + stToIO (unsafeFreezeAllMBU marr) + +readChunkBU :: FD -> Bool -> MutableByteArray# RealWorld -> Int -> Int -> IO () +readChunkBU fd is_stream marr# off bytes = loop off bytes + where + loop off bytes | bytes <= 0 = return () + loop off bytes = do + r' <- readRawBuffer "readChunkBU" (fromIntegral fd) is_stream marr# + (fromIntegral off) (fromIntegral bytes) + let r = fromIntegral r' + if r == 0 + then error "readChunkBU: can't read" + else loop (off + r) (bytes - r) + +hPutBU :: forall e. UAE e => Handle -> BUArr e -> IO () +hPutBU h arr@(BUArr i n arr#) = + alloca $ \iptr -> + do + poke iptr n + hPutBuf h iptr (sizeOf n) + wantWritableHandle "hPutBU" h $ + \handle@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do + old_buf <- readIORef ref + flushed_buf <- flushWriteBuffer fd stream old_buf + writeIORef ref flushed_buf + let this_buf = Buffer { bufBuf = unsafeCoerce# arr# + , bufState = WriteBuffer + , bufRPtr = off + , bufWPtr = off + size + , bufSize = size + } + flushWriteBuffer fd stream this_buf + return () + where + off = sizeBU i (undefined :: e) + size = sizeBU n (undefined :: e) + +----------------------------------------------------------------------------- +-- Translation between elements and bytes +-- Duplicated here from Data.Array.Base to avoid build dependency + +cHAR_SCALE, wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int# +cHAR_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSCHAR +wORD_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSWORD +dOUBLE_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSDOUBLE +fLOAT_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSFLOAT + +wORD16_SCALE, wORD32_SCALE, wORD64_SCALE :: Int# -> Int# +wORD16_SCALE n# = scale# *# n# where I# scale# = SIZEOF_WORD16 +wORD32_SCALE n# = scale# *# n# where I# scale# = SIZEOF_WORD32 +wORD64_SCALE n# = scale# *# n# where I# scale# = SIZEOF_WORD64 + +bOOL_SCALE, bOOL_WORD_SCALE :: Int# -> Int# +bOOL_SCALE n# = (n# +# last#) `uncheckedIShiftRA#` 3# + where I# last# = SIZEOF_HSWORD * 8 - 1 +bOOL_WORD_SCALE n# = bOOL_INDEX (n# +# last#) + where I# last# = SIZEOF_HSWORD * 8 - 1 + +bOOL_INDEX :: Int# -> Int# +#if SIZEOF_HSWORD == 4 +bOOL_INDEX i# = i# `uncheckedIShiftRA#` 5# +#elif SIZEOF_HSWORD == 8 +bOOL_INDEX i# = i# `uncheckedIShiftRA#` 6# +#endif + +bOOL_BIT, bOOL_NOT_BIT :: Int# -> Word# +bOOL_BIT n# = int2Word# 1# `uncheckedShiftL#` (word2Int# (int2Word# n# `and#` mask#)) + where W# mask# = SIZEOF_HSWORD * 8 - 1 +bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# where W# mb# = maxBound diff --git a/Data/Array/Vector/Prim/Debug.hs b/Data/Array/Vector/Prim/Debug.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Prim/Debug.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Stream +-- Copyright : (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- (c) [2006..2007] Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : portable +-- +--- Description --------------------------------------------------------------- +-- +-- Debugging infrastructure for the parallel arrays library + +module Data.Array.Vector.Prim.Debug ( + check + , checkCritical + , checkLen + , checkEq + , checkNotEmpty + , uninitialised +) where + +-- +-- Set -fsafe at compile time to compile in bounds checks +-- We rely on the optimiser to clean this up for us. + +#if defined(SAFE) +debug = True +debugCritical = True +#else +debug = False +debugCritical = False +#endif + +outOfBounds :: String -> Int -> Int -> a +outOfBounds loc n i = error $ loc ++ ": Out of bounds (size = " + ++ show n ++ "; index = " ++ show i ++ ")" + +-- Check that the second integer is greater or equal to `0' and less than the +-- first integer +-- +check :: String -> Int -> Int -> a -> a +{-# INLINE check #-} +check loc n i v + | debug = if (i >= 0 && i < n) then v else outOfBounds loc n i + | otherwise = v +-- FIXME: Interestingly, ghc seems not to be able to optimise this if we test +-- for `not debug' (it doesn't inline the `not'...) + +-- Check that the second integer is greater or equal to `0' and less than the +-- first integer; this version is used to check operations that could corrupt +-- the heap +-- +checkCritical :: String -> Int -> Int -> a -> a +{-# INLINE checkCritical #-} +checkCritical loc n i v + | debugCritical = if (i >= 0 && i < n) then v else outOfBounds loc n i + | otherwise = v + +-- Check that the second integer is greater or equal to `0' and less or equal +-- than the first integer +-- +checkLen :: String -> Int -> Int -> a -> a +{-# INLINE checkLen #-} +checkLen loc n i v + | debug = if (i >= 0 && i <= n) then v else outOfBounds loc n i + | otherwise = v + +checkEq :: (Eq a, Show a) => String -> String -> a -> a -> b -> b +checkEq loc msg x y v + | debug = if x == y then v else err + | otherwise = v + where + err = error $ loc ++ ": " ++ msg + ++ " (first = " ++ show x + ++ "; second = " ++ show y ++ ")" + +checkNotEmpty :: String -> Int -> a -> a +checkNotEmpty loc n v + | debug = if n /= 0 then v else err + | otherwise = v + where + err = error $ loc ++ ": Empty array" + +uninitialised :: String -> a +uninitialised loc = error $ loc ++ ": Touched an uninitialised value" + diff --git a/Data/Array/Vector/Prim/Hyperstrict.hs b/Data/Array/Vector/Prim/Hyperstrict.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Prim/Hyperstrict.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Prim.Hyperstrict +-- Copyright : (c) 2006 Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : experimental +-- Portability : portable +-- +-- Hyperstrict types. +-- +-- --------------------------------------------------------------------------- + +module Data.Array.Vector.Prim.Hyperstrict ( + + -- * Strict pairs and sums + (:*:)(..), EitherS(..), + + -- * Injection and projection functions + fstS, sndS, pairS, unpairS, unsafe_pairS, unsafe_unpairS, + + -- * Currying + curryS, uncurryS, + + -- * Strict Maybe + MaybeS(..), maybeS, fromMaybeS, + + -- * Lazy wrapper +-- Lazy(..), + + -- * Class of hyperstrict types +-- HS +) where + +infixl 2 :*: + +-- |Strict pair +data (:*:) a b = !a :*: !b deriving(Eq,Ord,Show,Read) + +fstS :: a :*: b -> a +fstS (x :*: _) = x +{-# INLINE fstS #-} + +sndS :: a :*: b -> b +sndS (_ :*: y) = y + +pairS :: (a,b) -> a :*: b +pairS = uncurry (:*:) + +unpairS :: a :*: b -> (a,b) +unpairS (x :*: y) = (x,y) + +curryS :: (a :*: b -> c) -> a -> b -> c +curryS f x y = f (x :*: y) +{-# INLINE curryS #-} + +uncurryS :: (a -> b -> c) -> a :*: b -> c +uncurryS f (x :*: y) = f x y +{-# INLINE uncurryS #-} + +unsafe_pairS :: (a,b) -> a :*: b +{-# INLINE [1] unsafe_pairS #-} +unsafe_pairS (a,b) = a :*: b + +unsafe_unpairS :: a :*: b -> (a,b) +{-# INLINE [1] unsafe_unpairS #-} +unsafe_unpairS (x :*: y) = (x,y) + +{-# RULES + +"unsafe_unpairS/unsafe_pairS" forall p. + unsafe_unpairS (unsafe_pairS p) = p + #-} + +-- |Strict sum +data EitherS a b = LeftS !a | RightS !b + +-- |Strict Maybe +data MaybeS a = NothingS | JustS !a + +instance Functor MaybeS where + fmap f (JustS x) = JustS (f x) + fmap f NothingS = NothingS + +-- MaybeS doesn't seem to be a proper monad. With the obvious definition we'd +-- get: +-- +-- return _|_ >>= const Nothing = _|_ /= const Nothing _|_ + +maybeS :: b -> (a -> b) -> MaybeS a -> b +maybeS b f (JustS a) = f a +maybeS b f NothingS = b + +fromMaybeS :: a -> MaybeS a -> a +fromMaybeS x (JustS y) = y +fromMaybeS x NothingS = x + +{- +data Lazy a = Lazy a deriving(Eq, Ord, Show, Read) + +instance Functor Lazy where + fmap f (Lazy x) = Lazy (f x) +-} + +{- +-- | The class of hyperstrict types. These are those types for which weak +-- head-normal form and normal form are the same. +-- That is, once they are evaluated to WHNF, they are guaranteed to +-- contain no thunks +class HS a + +instance HS () +instance HS Bool +instance HS Char +instance HS Int +instance HS Float +instance HS Double + +instance (HS a, HS b) => HS (a :*: b) +instance (HS a, HS b) => HS (EitherS a b) +instance HS a => HS (MaybeS a) +-} + + diff --git a/Data/Array/Vector/Prim/Text.hs b/Data/Array/Vector/Prim/Text.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Prim/Text.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Prim.Text +-- Copyright : (c) 2006 Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : experimental +-- Portability : portable +-- +-- Utilities for defining Read\/Show instances. +-- +-- --------------------------------------------------------------------------- + +module Data.Array.Vector.Prim.Text ( + showsApp, readApp, readsApp, + + Read(..) +) where + +import Text.Read + +showsApp :: Show a => Int -> String -> a -> ShowS +showsApp k fn arg = showParen (k>10) + (showString fn . showChar ' ' . showsPrec 11 arg) + +readApp :: Read a => String -> ReadPrec a +readApp fn = parens (prec 10 $ + do + Ident ide <- lexP + if ide /= fn then pfail else step readPrec + ) + +readsApp :: Read a => Int -> String -> ReadS a +readsApp k fn = readPrec_to_S (readApp fn) k + diff --git a/Data/Array/Vector/Stream.hs b/Data/Array/Vector/Stream.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Stream.hs @@ -0,0 +1,655 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} + +#include "fusion-phases.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Stream.Flat.Stream +-- Copyright : (c) 2006 Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : non-portable (existentials) +-- +-- Description --------------------------------------------------------------- +-- +-- Basic types for stream-based fusion +-- + +module Data.Array.Vector.Stream where + +import Debug.Trace +import Data.Array.Vector.Prim.Hyperstrict + +data Step s a = Done + | Skip !s + | Yield !a !s + +instance Functor (Step s) where + fmap f Done = Done + fmap f (Skip s) = Skip s + fmap f (Yield x s) = Yield (f x) s + +data Stream a = forall s. Stream (s -> Step s a) !s Int + +newtype Box a = Box a -- is this still even needed for SpecConstr? + +------------------------------------------------------------------------ + +-- | Empty stream +-- +emptyS :: Stream a +emptyS = Stream (const Done) () 0 + +-- null +nullS :: Stream a -> Bool +nullS (Stream next s0 _) = loop_null s0 + where + loop_null s = case next s of + Done -> True + Yield _ _ -> False + Skip s' -> s' `seq` loop_null s' +{-# INLINE_STREAM nullS #-} + +-- | Singleton stream +-- +singletonS :: a -> Stream a +{-# INLINE_STREAM singletonS #-} +singletonS x = Stream next True 1 + where + {-# INLINE next #-} + next True = Yield x False + next False = Done + +-- | Construction +-- +consS :: a -> Stream a -> Stream a +{-# INLINE_STREAM consS #-} +consS x (Stream next s n) = Stream next' (JustS (Box x) :*: s) (n+1) + where + {-# INLINE next' #-} + next' (JustS (Box x) :*: s) = Yield x (NothingS :*: s) + next' (NothingS :*: s) = case next s of + Yield y s' -> Yield y (NothingS :*: s') + Skip s' -> Skip (NothingS :*: s') + Done -> Done + +snocS :: Stream a -> a -> Stream a +{-# INLINE_STREAM snocS #-} +snocS (Stream next s n) x = Stream next' (JustS s) (n+1) + where + {-# INLINE next' #-} + next' (JustS s) = case next s of + Yield y s' -> Yield y (JustS s') + Skip s' -> Skip (JustS s') + Done -> Yield x NothingS + next' NothingS = Done + +-- | Replication +-- + +replicateS :: Int -> a -> Stream a +{-# INLINE_STREAM replicateS #-} +replicateS n x = Stream next 0 n + where + {-# INLINE next #-} + next i | i == n = Done + | otherwise = Yield x (i+1) + +-- | Given a stream of (length,value) pairs and the sum of the lengths, +-- replicate each value to the given length. +-- +-- FIXME: This should probably produce a segmented stream but since we want to +-- get rid of them anyway... +-- +replicateEachS :: Int -> Stream (Int :*: a) -> Stream a +{-# INLINE_STREAM replicateEachS #-} +replicateEachS n (Stream next s _) = + Stream next' (0 :*: NothingS :*: s) n + where + {-# INLINE next' #-} + next' (0 :*: _ :*: s) = + case next s of + Done -> Done + Skip s' -> Skip (0 :*: NothingS :*: s') + Yield (k :*: x) s' -> Skip (k :*: JustS (Box x) :*: s') + next' (k :*: NothingS :*: s) = Done -- FIXME: unreachable + next' (k :*: JustS (Box x) :*: s) = + Yield x (k-1 :*: JustS (Box x) :*: s) + +{- +-- +-- repeat a stream a given number of times +-- Duplicates work. +-- +repeatS :: Int -> Stream e -> Stream e +{-# INLINE_STREAM repeatS #-} +repeatS k (Stream next0 s0 n) = Stream next (k :*: s0) (max 0 (n*k)) + where + {-# INLINE next #-} + next (0 :*: _) = Done + next (k :*: s) = case next0 s of + Done -> Skip (k-1 :*: s0) -- reset iteration state + Skip s' -> Skip (k :*: s') + Yield y s' -> Yield y (k :*: s') +-} + +-- | Concatenation +-- +(+++) :: Stream a -> Stream a -> Stream a +{-# INLINE_STREAM (+++) #-} +Stream next1 s1 n1 +++ Stream next2 s2 n2 = Stream next (LeftS s1) (n1 + n2) + where + {-# INLINE next #-} + next (LeftS s1) = + case next1 s1 of + Done -> Skip (RightS s2) + Skip s1' -> Skip (LeftS s1') + Yield x s1' -> Yield x (LeftS s1') + + next (RightS s2) = + case next2 s2 of + Done -> Done + Skip s2' -> Skip (RightS s2') + Yield x s2' -> Yield x (RightS s2') + +-- | Indexing +-- ---------- + +indexS :: Stream a -> Int -> a +{-# INLINE_STREAM indexS #-} +indexS (Stream next s0 _) n0 + | n0 < 0 = error "Data.Array.Vector.Stream.indexS: negative index" + | otherwise = loop_index n0 s0 + where + loop_index n s = case next s of + Yield x s' | n == 0 -> x + | otherwise -> s' `seq` loop_index (n-1) s' + Skip s' -> s' `seq` loop_index n s' + Done -> error "Data.Array.Vector.Stream.indexS: index too large" + +-- | Indexing +-- ---------- + +-- | Associate each element in the 'Stream' with its index +-- +indexedS :: Stream a -> Stream (Int :*: a) +{-# INLINE_STREAM indexedS #-} +indexedS (Stream next s n) = Stream next' (0 :*: s) n + where + {-# INLINE next' #-} + next' (i :*: s) = case next s of + Yield x s' -> Yield (i :*: x) ((i+1) :*: s') + Skip s' -> Skip (i :*: s') + Done -> Done + +-- | Substreams +-- ------------ + +headS :: Stream a -> a +{-# INLINE_STREAM headS #-} +headS (Stream next s0 _) = loop_head s0 + where + loop_head s = case next s of + Yield x _ -> x + Skip s' -> s' `seq` loop_head s' + Done -> errorEmptyStream "head" + +-- | Yield the tail of a stream +-- +tailS :: Stream a -> Stream a +{-# INLINE_STREAM tailS #-} +tailS (Stream next s n) = Stream next' (False :*: s) (n-1) + where + {-# INLINE next' #-} + next' (False :*: s) = case next s of + Yield x s' -> Skip (True :*: s') + Skip s' -> Skip (False :*: s') + Done -> error "Stream.tailS: empty stream" + next' (True :*: s) = case next s of + Yield x s' -> Yield x (True :*: s') + Skip s' -> Skip (True :*: s') + Done -> Done + +-- | Conversion to\/from lists +-- -------------------------- + +-- | Convert a list to a 'Stream' +-- +toStream :: [a] -> Stream a +{-# INLINE_STREAM toStream #-} +toStream xs = Stream gen (Box xs) (length xs) + where + {-# INLINE gen #-} + gen (Box []) = Done + gen (Box (x:xs)) = Yield x (Box xs) + +-- | Generate a list from a 'Stream' +-- +fromStream :: Stream a -> [a] +{-# INLINE_STREAM fromStream #-} +fromStream (Stream next s _) = gen s + where + gen s = case next s of + Done -> [] + Skip s' -> gen s' + Yield x s' -> x : gen s' + + +------------------------------------------------------------------------ + + +-- XXX Box is left behind. Spec constr fail? Looks like consS though +initS :: Stream a -> Stream a +{-# INLINE_STREAM initS #-} +initS (Stream next0 s0 n) = Stream next' (NothingS :*: s0) (n-1) + where + {-# INLINE next' #-} + next' (NothingS :*: s) = case next0 s of + Yield x s' -> Skip (JustS (Box x) :*: s') + Skip s' -> Skip (NothingS :*: s') + Done -> errorEmptyStream "init" + + next' (JustS (Box x) :*: s) = case next0 s of + Yield x' s' -> Yield x (JustS (Box x') :*: s') + Skip s' -> Skip (JustS (Box x) :*: s') + Done -> Done + +-- * Substreams +-- ** Extracting substreams + +takeS :: Int -> Stream a -> Stream a +{-# INLINE_STREAM takeS #-} +takeS n0 (Stream next0 s0 _) = Stream next' (n0 :*: s0) (max 0 n0) + where + {-# INLINE next' #-} + next' (n :*: s) + | n <= 0 = Done + | otherwise = case next0 s of + Yield x s' -> Yield x ((n-1) :*: s') + Skip s' -> Skip ( n :*: s') + Done -> Done + +dropS :: Int -> Stream a -> Stream a +{-# INLINE_STREAM dropS #-} +dropS n0 (Stream next0 s0 n) = Stream next' (JustS (max 0 n0) :*: s0) (max 0 (n - n0)) + where + {-# INLINE next' #-} + next' (JustS n :*: s) + | n == 0 = Skip (NothingS :*: s) + | otherwise = case next0 s of + Yield _ s' -> Skip (JustS (n-1) :*: s') + Skip s' -> Skip (JustS n :*: s') + Done -> Done + + next' (NothingS :*: s) = case next0 s of + Yield x s' -> Yield x (NothingS :*: s') + Skip s' -> Skip (NothingS :*: s') + Done -> Done + +elemS :: Eq a => a -> Stream a -> Bool +{-# INLINE_STREAM elemS #-} +elemS x (Stream next s0 _) = loop_elem s0 + where + loop_elem s = case next s of + Yield y s' + | x == y -> True + | otherwise -> s' `seq` loop_elem s' + Skip s' -> s' `seq` loop_elem s' + Done -> False + +lookupS :: Eq a => a -> Stream (a :*: b) -> Maybe b +{-# INLINE_STREAM lookupS #-} +lookupS key (Stream next s0 _) = loop_lookup s0 + where + loop_lookup s = case next s of + Yield (x :*: y) s' + | key == x -> Just y + | otherwise -> s' `seq` loop_lookup s' + Skip s' -> s' `seq` loop_lookup s' + Done -> Nothing + +------------------------------------------------------------------------ + +-- | Mapping +-- +mapS :: (a -> b) -> Stream a -> Stream b +{-# INLINE_STREAM mapS #-} +mapS f (Stream next s n) = Stream next' s n + where + {-# INLINE next' #-} + next' s = case next s of + Done -> Done + Skip s' -> Skip s' + Yield x s' -> Yield (f x) s' + +-- | Filtering +-- +filterS :: (a -> Bool) -> Stream a -> Stream a +{-# INLINE_STREAM filterS #-} +filterS f (Stream next s n) = Stream next' s n + where + {-# INLINE next' #-} + next' s = case next s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | f x -> Yield x s' + | otherwise -> Skip s' + +-- | Folding +-- +foldS :: (b -> a -> b) -> b -> Stream a -> b +{-# INLINE_STREAM foldS #-} +foldS f z (Stream next s _) = fold z s + where + fold z s = z `seq` case next s of -- needs to be strict! + Yield x s' -> s' `seq` fold (f z x) s' + Skip s' -> s' `seq` fold z s' + Done -> z + +foldl1S :: (a -> a -> a) -> Stream a -> a +{-# INLINE_STREAM foldl1S #-} +foldl1S f (Stream next s0 _) = loop0_foldl1' s0 + where + loop0_foldl1' s = case next s of + Yield x s' -> s' `seq` loop_foldl1' x s' + Skip s' -> s' `seq` loop0_foldl1' s' + Done -> errorEmptyStream "foldl1" + + loop_foldl1' z s = z `seq` case next s of + Yield x s' -> s' `seq` loop_foldl1' (f z x) s' + Skip s' -> s' `seq` loop_foldl1' z s' + Done -> z + +fold1MaybeS :: (a -> a -> a) -> Stream a -> MaybeS a +{-# INLINE_STREAM fold1MaybeS #-} +fold1MaybeS f (Stream next s _) = fold0 s + where + fold0 s = case next s of + Done -> NothingS + Skip s' -> s' `seq` fold0 s' + Yield x s' -> s' `seq` fold1 x s' + fold1 z s = z `seq` case next s of + Done -> JustS z + Skip s' -> s' `seq` fold1 z s' + Yield x s' -> s' `seq` fold1 (f z x) s' + +-- | Scanning +-- +scanS :: (b -> a -> b) -> b -> Stream a -> Stream b +{-# INLINE_STREAM scanS #-} +scanS f z (Stream next s n) = Stream next' (Box z :*: s) n + where + {-# INLINE next' #-} + next' (Box z :*: s) = case next s of + Done -> Done + Skip s' -> Skip (Box z :*: s') + Yield x s' -> Yield z (Box (f z x) :*: s') + +scan1S :: (a -> a -> a) -> Stream a -> Stream a +{-# INLINE_STREAM scan1S #-} +scan1S f (Stream next s n) = Stream next' (NothingS :*: s) n + where + {-# INLINE next' #-} + next' (NothingS :*: s) = + case next s of + Yield x s' -> Yield x (JustS (Box x) :*: s') + Skip s' -> Skip (NothingS :*: s') + Done -> Done + + next' (JustS (Box z) :*: s) = + case next s of + Yield x s' -> let y = f z x + in + Yield y (JustS (Box y) :*: s') + Skip s' -> Skip (JustS (Box z) :*: s) + Done -> Done + +mapAccumS :: (acc -> a -> acc :*: b) -> acc -> Stream a -> Stream b +{-# INLINE_STREAM mapAccumS #-} +mapAccumS f acc (Stream step s n) = Stream step' (s :*: Box acc) n + where + step' (s :*: Box acc) = case step s of + Done -> Done + Skip s' -> Skip (s' :*: Box acc) + Yield x s' -> let acc' :*: y = f acc x + in + Yield y (s' :*: Box acc') + + +combineS:: Stream Bool -> Stream a -> Stream a -> Stream a +{-# INLINE_STREAM combineS #-} +combineS (Stream next1 s m) (Stream nextS1 t1 n1) (Stream nextS2 t2 n2) = + Stream next (s :*: t1 :*: t2) m + where + {-# INLINE next #-} + next (s :*: t1 :*: t2) = + case next1 s of + Done -> Done + Skip s' -> Skip (s' :*: t1 :*: t2 ) + Yield c s' -> if trace ("\n\t\tstream: " ++ (show c) ++ "\n") c + then case nextS1 t1 of + Done -> error "combineS: stream 1 terminated unexpectedly" + Skip t1' -> Skip (s :*: t1' :*: t2) + Yield x t1' -> Yield x (s' :*: t1' :*: t2) + else case nextS2 t2 of + Done -> error "combineS: stream 2 terminated unexpectedly" + Skip t2' -> Skip (s :*: t1 :*: t2') + Yield x t2' -> Yield x (s' :*: t1 :*: t2') + +-- | Zipping +-- +-- FIXME: The definition below duplicates work if the second stream produces +-- Skips. Unfortunately, GHC tends to introduce join points which break +-- SpecConstr with the correct definition. +-- +zipWithS :: (a -> b -> c) -> Stream a -> Stream b -> Stream c +{-# INLINE_STREAM zipWithS #-} +zipWithS f (Stream next1 s m) (Stream next2 t n) = + Stream next (s :*: t) m + where + {-# INLINE next #-} + next (s :*: t) = + case next1 s of + Done -> Done + Skip s' -> Skip (s' :*: t) + Yield x s' -> case next2 t of + Done -> Done + Skip t' -> Skip (s :*: t') + Yield y t' -> Yield (f x y) (s' :*: t') + +{- Stream next (NothingS :*: s :*: t) m + where + {-# INLINE next #-} + next (NothingS :*: s :*: t) = + t `seq` + case next1 s of + Done -> Done + Skip s' -> Skip (NothingS :*: s' :*: t) + Yield x s' -> -- Skip (JustS x :*: s' :*: t) + case next2 t of + Done -> Done + Skip t' -> Skip (JustS (Box x) :*: s' :*: t') + Yield y t' -> Yield (f x y) (NothingS :*: s' :*: t') + next (JustS (Box x) :*: s :*: t) = + s `seq` + case next2 t of + Done -> Done + Skip t' -> Skip (JustS (Box x) :*: s :*: t') + Yield y t' -> Yield (f x y) (NothingS :*: s :*: t') +-} + +zipWith3S :: (a -> b -> c -> d) -> Stream a -> Stream b -> Stream c -> Stream d +{-# INLINE_STREAM zipWith3S #-} +zipWith3S f (Stream next1 s1 n) (Stream next2 s2 _) (Stream next3 s3 _) = + Stream next (s1 :*: s2 :*: s3) n + where + {-# INLINE next #-} + next (s1 :*: s2 :*: s3) = + case next1 s1 of + Done -> Done + Skip s1' -> Skip (s1' :*: s2 :*: s3) + Yield x s1' -> + case next2 s2 of + Done -> Done + Skip s2' -> Skip (s1 :*: s2' :*: s3) + Yield y s2' -> + case next3 s3 of + Done -> Done + Skip s3' -> Skip (s1 :*: s2 :*: s3') + Yield z s3' -> Yield (f x y z) (s1' :*: s2' :*: s3') + +zipS :: Stream a -> Stream b -> Stream (a :*: b) +{-# INLINE zipS #-} +zipS = zipWithS (:*:) + +------------------------------------------------------------------------ + +-- | Yield an enumerated stream +-- +-- FIXME: Can this be implemented polymorphically? We could just use +-- enumFromThenTo here, but this won't really work for parallel arrays. +-- Perhaps we have to introduce an EnumP class? +-- + +enumFromToFracS :: (Ord a, RealFrac a) => a -> a -> Stream a +{-# INLINE_STREAM enumFromToFracS #-} +enumFromToFracS n m = Stream next n (truncate (m - n)) + where + lim = m + 1/2 -- important to float this out. + + {-# INLINE next #-} + next s | s > lim = Done -- from GHC.Real.numericEnumFromTo + | otherwise = Yield s (s+1) + +enumFromToS :: (Integral a, Ord a) => a -> a -> Stream a +{-# INLINE_STREAM enumFromToS #-} +enumFromToS start end + = Stream step start (max 0 (fromIntegral (end - start + 1))) + where + {-# INLINE step #-} + step s | s > end = Done + | otherwise = Yield s (s+1) + +-- | Yield an enumerated stream using a specific step +-- +-- +enumFromThenToS :: Int -> Int -> Int -> Stream Int +{-# INLINE enumFromThenToS #-} +enumFromThenToS start next end + = enumFromStepLenS start delta len + where + delta = next - start + diff = end - start + + len | start < next && start <= end = ((end-start) `div` delta) + 1 + | start > next && start >= end = ((start-end) `div` (start-next)) + 1 + | otherwise = 0 + +enumFromStepLenS :: Int -> Int -> Int -> Stream Int +{-# INLINE_STREAM enumFromStepLenS #-} +enumFromStepLenS s d n = Stream step (s :*: n) n + where + step (s :*: 0) = Done + step (s :*: n) = Yield s ((s+d) :*: (n-1)) + +-- enumFromToEachS [k1 :*: m1, ..., kn :*: mn] = [k1,...,m1,...,kn,...,mn] +-- +-- FIXME: monomorphic for now because we need Rebox a otherwise! +-- +enumFromToEachS :: Int -> Stream (Int :*: Int) -> Stream Int +{-# INLINE_STREAM enumFromToEachS #-} +enumFromToEachS n (Stream next s _) = Stream next' (NothingS :*: s) n + where + {-# INLINE next' #-} + next' (NothingS :*: s) + = case next s of + Yield (k :*: m) s' -> Skip (JustS (k :*: m) :*: s') + Skip s' -> Skip (NothingS :*: s') + Done -> Done + + next' (JustS (k :*: m) :*: s) + | k > m = Skip (NothingS :*: s) + | otherwise = Yield k (JustS (k+1 :*: m) :*: s) + +------------------------------------------------------------------------ + +findS :: (a -> Bool) -> Stream a -> Maybe a +{-# INLINE_STREAM findS #-} +findS p (Stream next s _) = go s + where + go s = case next s of + Yield x s' | p x -> Just x + | otherwise -> go s' + Skip s' -> go s' + Done -> Nothing + +findIndexS :: (a -> Bool) -> Stream a -> Maybe Int +{-# INLINE_STREAM findIndexS #-} +findIndexS p (Stream next s _) = go 0 s + where + go i s = case next s of + Yield x s' | p x -> Just i + | otherwise -> go (i+1) s' + Skip s' -> go i s' + Done -> Nothing + +------------------------------------------------------------------------ + +takeWhileS :: (a -> Bool) -> Stream a -> Stream a +{-# INLINE_STREAM takeWhileS #-} +takeWhileS p (Stream next0 s0 n) = Stream next s0 n + where + {-# INLINE next #-} + next s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Done + +dropWhileS :: (a -> Bool) -> Stream a -> Stream a +{-# INLINE_STREAM dropWhileS #-} +dropWhileS p (Stream next0 s0 n) = Stream next (True :*: s0) n + where + {-# INLINE next #-} + next (True :*: s) = case next0 s of + Done -> Done + Skip s' -> Skip (True :*: s') + Yield x s' | p x -> Skip (True :*: s') + | otherwise -> Yield x (False :*: s') + + next (False :*: s) = case next0 s of + Done -> Done + Skip s' -> Skip (False :*: s') + Yield x s' -> Yield x (False :*: s') + +------------------------------------------------------------------------ + +unfoldS :: Int -> (b -> MaybeS (a :*: b)) -> b -> Stream a +{-# INLINE_STREAM unfoldS #-} +unfoldS n f s0 = Stream next (JustS (0 :*: s0)) n + where + {-# INLINE next #-} + next (JustS (i :*: s)) = case f s of + NothingS -> Done + JustS (w :*: s') + | n == i -> Yield w NothingS + | otherwise -> Yield w (JustS (i+1 :*: s')) + next _ = Done + +------------------------------------------------------------------------ + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptyStream :: String -> a +errorEmptyStream fun = moduleError fun "empty vector" +{-# NOINLINE errorEmptyStream #-} + +moduleError :: String -> String -> a +moduleError fun msg = error ("Data.Array.Vector.Stream." ++ fun ++ ':':' ':msg) +{-# NOINLINE moduleError #-} + + diff --git a/Data/Array/Vector/Strict/Basics.hs b/Data/Array/Vector/Strict/Basics.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Strict/Basics.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Strict.Basics +-- Copyright : (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : portable +-- +-- Description --------------------------------------------------------------- +-- +-- Basic operations on flat unlifted arrays. +-- +-- Todo ---------------------------------------------------------------------- +-- + + +#include "fusion-phases.h" + +module Data.Array.Vector.Strict.Basics where + +import Data.Array.Vector.Stream +import Data.Array.Vector.UArr hiding (lengthU, indexU) +import qualified Data.Array.Vector.UArr as Prim (lengthU, indexU) + +import Data.Array.Vector.Strict.Stream + +import Data.Array.Vector.Prim.Debug +import Data.Array.Vector.Prim.Hyperstrict +import GHC.ST + +import Debug.Trace + +------------------------------------------------------------------------ + +instance (Eq e, UA e) => Eq (UArr e) where (==) = eqU + -- not really fusible + +{-# INLINE_U eqU #-} +eqU :: (Eq e, UA e) => UArr e -> UArr e -> Bool +eqU a1 a2 = lengthU a1 == lengthU a2 && foldlU cmp True (zipU a1 a2) + where + cmp r (e1 :*: e2) = e1 == e2 && r + +------------------------------------------------------------------------ + +-- XXX general rule: +-- If we have direct implementations with better complexity than streams: +-- +-- length, index, take, drop +-- +-- Then use the direct version + + +-- | /O(1)/, 'length' returns the length of a UArr as an 'Int'. +lengthU :: UA e => UArr e -> Int +lengthU = foldlU (const . (+1)) 0 +-- lengthU = Prim.lengthU +{-# INLINE_U lengthU #-} + +{- + +Unfused version: + +$ time ./length +100000000 +./length 1.10s user 1.13s system 91% cpu 2.433 total + +Fusible version: + +100000000 +./length 0.31s user 0.00s system 97% cpu 0.318 total + +-} + +-- lengthU_stream :: UA e => UArr e -> Int +-- {-# INLINE lengthU_stream #-} + +-- lengthU is reexported from UArr + +-- |Test whether the given array is empty +-- +nullU :: UA e => UArr e -> Bool +nullU = nullS . streamU -- better code if we short circuit +{-# INLINE_U nullU #-} +-- nullU = (== 0) . lengthU + +-- |Yield an empty array +-- +emptyU :: UA e => UArr e +emptyU = unstreamU emptyS +{-# INLINE_U emptyU #-} + +-- emptyU = newU 0 (const $ return ()) + +-- |Yield a singleton array +-- +singletonU :: UA e => e -> UArr e +{-# INLINE_U singletonU #-} +singletonU = unstreamU . singletonS + +-- |Prepend an element to an array +-- +consU :: UA e => e -> UArr e -> UArr e +{-# INLINE_U consU #-} +consU x = unstreamU . consS x . streamU + +-- |Append an element to an array +-- +snocU :: UA e => UArr e -> e -> UArr e +{-# INLINE_U snocU #-} +snocU s x = unstreamU (snocS (streamU s) x) + +-- unitsU is reexported from Loop + +-- |Yield an array where all elements contain the same value +-- +replicateU :: UA e => Int -> e -> UArr e +{-# INLINE_U replicateU #-} +replicateU n e = unstreamU (replicateS n e) + +replicateEachU :: UA e => Int -> UArr Int -> UArr e -> UArr e +{-# INLINE_U replicateEachU #-} +replicateEachU n ns es = unstreamU + . replicateEachS n + $ zipS (streamU ns) (streamU es) + +-- |Array indexing +-- +indexU :: UA e => UArr e -> Int -> e +indexU arr n = indexS (streamU arr) n +{-# INLINE_U indexU #-} + +headU :: UA e => UArr e -> e +headU = headS . streamU +{-# INLINE_U headU #-} + +lastU :: UA e => UArr e -> e +lastU = foldl1U (flip const) +{-# INLINE lastU #-} + +-- |Concatenate two arrays +-- +appendU :: UA e => UArr e -> UArr e -> UArr e +{-# INLINE_U appendU #-} +a1 `appendU` a2 = unstreamU (streamU a1 +++ streamU a2) + +initU :: UA e => UArr e -> UArr e -- not unboxing +initU = unstreamU . initS . streamU +{-# INLINE initU #-} + +-- |Repeat an array @n@ times +-- +repeatU :: UA e => Int -> UArr e -> UArr e +repeatU n = unstreamU . repS n +{-# INLINE_U repeatU #-} + +-- No work duplicated +repS :: UA e => Int -> UArr e -> Stream e +{-# INLINE_STREAM repS #-} +repS k xs = Stream next (0 :*: k) (k*n) + where + n = lengthU xs + + {-# INLINE next #-} + next (i :*: 0) = Done + next (i :*: k) | i == n = Skip (0 :*: k-1) + | otherwise = Yield (xs `Prim.indexU` i) (i+1 :*: k) + +-- |Indexing +-- --------- + +-- |Associate each element of the array with its index +-- +indexedU :: UA e => UArr e -> UArr (Int :*: e) +{-# INLINE_U indexedU #-} +indexedU = unstreamU . indexedS . streamU + +-- |Conversion +-- ----------- + +-- |Turn a list into a parallel array +-- +toU :: UA e => [e] -> UArr e +{-# INLINE_U toU #-} +toU = unstreamU . toStream + +-- |Collect the elements of a parallel array in a list +-- +fromU :: UA e => UArr e -> [e] +{-# INLINE_U fromU #-} +fromU a = [a `Prim.indexU` i | i <- [0..lengthU a - 1]] + +------------------------------------------------------------------------ + + +here s = "Data.Array.Vector.Strict.Combinators." ++ s + +-- |Map a function over an array +-- +mapU :: (UA e, UA e') => (e -> e') -> UArr e -> UArr e' +{-# INLINE_U mapU #-} +mapU f = unstreamU . mapS f . streamU + +-- |Extract all elements from an array that meet the given predicate +-- +filterU :: UA e => (e -> Bool) -> UArr e -> UArr e +{-# INLINE_U filterU #-} +filterU p = unstreamU . filterS p . streamU + +-- |Extract all elements from an array according to a given flag array +-- +packU:: UA e => UArr e -> UArr Bool -> UArr e +{-# INLINE_U packU #-} +packU xs = fstU . filterU sndS . zipU xs + + + +-- |Array reduction proceeding from the left +-- +foldlU :: UA a => (b -> a -> b) -> b -> UArr a -> b +{-# INLINE_U foldlU #-} +foldlU f z = foldS f z . streamU + +-- |Array reduction proceeding from the left for non-empty arrays +-- +-- FIXME: Rewrite for 'Stream's. +-- +-- foldl1U :: UA a => (a -> a -> a) -> UArr a -> a +-- {-# INLINE_U foldl1U #-} +-- foldl1U f arr = checkNotEmpty (here "foldl1U") (lengthU arr) $ +-- foldlU f (arr `Prim.indexU` 0) (sliceU arr 1 (lengthU arr - 1)) + +foldl1U :: UA a => (a -> a -> a) -> UArr a -> a +foldl1U f = foldl1S f . streamU +{-# INLINE foldl1U #-} + +foldl1MaybeU :: UA a => (a -> a -> a) -> UArr a -> MaybeS a +{-# INLINE_U foldl1MaybeU #-} +foldl1MaybeU f = fold1MaybeS f . streamU + +-- |Array reduction that requires an associative combination function with its +-- unit +-- +foldU :: UA a => (a -> a -> a) -> a -> UArr a -> a +{-# INLINE_U foldU #-} +foldU = foldlU + +fold1MaybeU :: UA a => (a -> a -> a) -> UArr a -> MaybeS a +{-# INLINE_U fold1MaybeU #-} +fold1MaybeU = foldl1MaybeU + +-- |Reduction of a non-empty array which requires an associative combination +-- function +-- +fold1U :: UA a => (a -> a -> a) -> UArr a -> a +{-# INLINE_U fold1U #-} +fold1U = foldl1U + +-- |Prefix scan proceedings from left to right +-- +scanlU :: (UA a, UA b) => (b -> a -> b) -> b -> UArr a -> UArr b +{-# INLINE_U scanlU #-} +scanlU f z = unstreamU . scanS f z . streamU + +-- |Prefix scan of a non-empty array proceeding from left to right +-- +scanl1U :: UA a => (a -> a -> a) -> UArr a -> UArr a +{-# INLINE_U scanl1U #-} +scanl1U f arr = checkNotEmpty (here "scanl1U") (lengthU arr) $ + unstreamU (scan1S f (streamU arr)) + +-- |Prefix scan proceeding from left to right that needs an associative +-- combination function with its unit +-- +scanU :: UA a => (a -> a -> a) -> a -> UArr a -> UArr a +{-# INLINE_U scanU #-} +scanU = scanlU + +-- |Prefix scan of a non-empty array proceeding from left to right that needs +-- an associative combination function +-- +scan1U :: UA a => (a -> a -> a) -> UArr a -> UArr a +{-# INLINE_U scan1U #-} +scan1U = scanl1U + +scanResU :: UA a => (a -> a -> a) -> a -> UArr a -> UArr a :*: a +{-# INLINE_U scanResU #-} +scanResU f z = unstreamScan f z . streamU + +unstreamScan :: UA a => (a -> a -> a) -> a -> Stream a -> UArr a :*: a +{-# INLINE_STREAM unstreamScan #-} +unstreamScan f z st@(Stream _ _ n) + = newDynResU n (\marr -> unstreamScanM marr f z st) + +unstreamScanM :: UA a => MUArr a s -> (a -> a -> a) -> a -> Stream a + -> ST s (Int :*: a) +{-# INLINE_U unstreamScanM #-} +unstreamScanM marr f z (Stream next s n) = fill s z 0 + where + fill s !z !i = case next s of + Done -> return (i :*: z) + Skip s' -> s' `seq` fill s' z i + Yield x s' -> s' `seq` + do + writeMU marr i z + fill s' (f z x) (i+1) + +-- |Accumulating map from left to right. Does not return the accumulator. +-- +-- FIXME: Naming inconsistent with lists. +-- +mapAccumLU :: (UA a, UA b) => (c -> a -> c :*: b) -> c -> UArr a -> UArr b +{-# INLINE_U mapAccumLU #-} +mapAccumLU f z = unstreamU . mapAccumS f z . streamU + +-- zipU is re-exported from UArr + +-- | +-- +zip3U :: (UA e1, UA e2, UA e3) + => UArr e1 -> UArr e2 -> UArr e3 -> UArr (e1 :*: e2 :*: e3) +{-# INLINE_U zip3U #-} +zip3U a1 a2 a3 = (a1 `zipU` a2) `zipU` a3 + +-- | +zipWithU :: (UA a, UA b, UA c) + => (a -> b -> c) -> UArr a -> UArr b -> UArr c +{-# INLINE_U zipWithU #-} +zipWithU f a1 a2 = unstreamU (zipWithS f (streamU a1) (streamU a2)) + +-- | +zipWith3U :: (UA a, UA b, UA c, UA d) + => (a -> b -> c -> d) -> UArr a -> UArr b -> UArr c -> UArr d +{-# INLINE_U zipWith3U #-} +zipWith3U f a1 a2 a3 = unstreamU (zipWith3S f (streamU a1) + (streamU a2) + (streamU a3)) + +-- unzipU is re-exported from UArr + +-- | +unzip3U :: (UA e1, UA e2, UA e3) + => UArr (e1 :*: e2 :*: e3) -> (UArr e1 :*: UArr e2 :*: UArr e3) +{-# INLINE_U unzip3U #-} +unzip3U a = let (a12 :*: a3) = unzipU a + (a1 :*: a2) = unzipU a12 + in + (a1 :*: a2 :*: a3) + +-- fstU and sndU reexported from UArr +-- | +combineU :: UA a + => UArr Bool -> UArr a -> UArr a -> UArr a +{-# INLINE_U combineU #-} +combineU f a1 a2 = checkEq (here "combineU") + ("flag length not equal to sum of arg length") + (lengthU f) (lengthU a1 + lengthU a2) $ + trace ("combineU:\n\t" ++ show (lengthU f) ++ "\n\t" ++ show (lengthU a1) ++ "\n\t" ++ show (lengthU a2) ++ "\n") + unstreamU (combineS (streamU f) (streamU a1) (streamU a2)) + +------------------------------------------------------------------------ + +-- sliceU reexported from UArr + +-- {-# INLINE_U extractU #-} +-- extractU :: UA a => UArr a -> Int -> Int -> UArr a +-- extractU arr i n = newU n $ \marr -> copyMU marr 0 (sliceU arr i n) + +tailU :: UA e => UArr e -> UArr e +tailU = unstreamU . tailS . streamU +{-# INLINE_U tailU #-} + +dropU :: UA e=> Int -> UArr e -> UArr e +dropU n = unstreamU . dropS n . streamU +{-# INLINE dropU #-} + +takeU :: UA e=> Int -> UArr e -> UArr e +takeU n = unstreamU . takeS n . streamU +{-# INLINE takeU #-} + +-- |Split an array into two halves at the given index +-- +splitAtU :: UA e => Int -> UArr e -> (UArr e, UArr e) +splitAtU n a = (takeU n a, dropU n a) +{-# INLINE splitAtU #-} + +{- +-- |Yield the tail of an array +-- +tailU :: UA e => UArr e -> UArr e +{-# INLINE_U tailU #-} +tailU = unstreamU . tailS . streamU + +-- |Extract a prefix of an array +-- +takeU :: UA e=> Int -> UArr e -> UArr e +{-# INLINE_U takeU #-} +takeU n a = extractU a 0 n + +-- |Extract a suffix of an array +-- +dropU :: UA e => Int -> UArr e -> UArr e +{-# INLINE_U dropU #-} +dropU n a = let len = lengthU a + in + extractU a n (len - n) + +-- |Split an array into two halves at the given index +-- +splitAtU :: UA e => Int -> UArr e -> (UArr e, UArr e) +{-# INLINE_U splitAtU #-} +splitAtU n a = (takeU n a, dropU n a) + +-} + +------------------------------------------------------------------------ + +-- | 'takeWhile', applied to a predicate @p@ and a UArr @xs@, +-- returns the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@. +-- +takeWhileU :: UA e => (e -> Bool) -> UArr e -> UArr e +takeWhileU f = unstreamU . takeWhileS f . streamU +{-# INLINE_U takeWhileU #-} + +-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. +dropWhileU :: UA e => (e -> Bool) -> UArr e -> UArr e +dropWhileU f = unstreamU . dropWhileS f . streamU +{-# INLINE_U dropWhileU #-} + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +-- | /O(n)/,/fusion/. The 'find' function takes a predicate and an array +-- and returns the first element in the list matching the predicate, or +-- 'Nothing' if there is no such element. +findU :: UA a => (a -> Bool) -> UArr a -> Maybe a +{-# INLINE_U findU #-} +findU p = findS p . streamU + +-- | /O(n)/, /fusion/, The 'findIndex' function takes a predicate and an array and returns +-- the index of the first element in the array satisfying the predicate, +-- or 'Nothing' if there is no such element. +-- +findIndexU :: UA a => (a -> Bool) -> UArr a -> Maybe Int +{-# INLINE_U findIndexU #-} +findIndexU p = findIndexS p . streamU + +-- | /O(n)/,/fusion/. 'lookup' @key assocs@ looks up a key in an array +-- of pairs treated as an association table. +-- +lookupU :: (Eq a, UA a, UA b) => a -> UArr (a :*: b) -> Maybe b +{-# INLINE_U lookupU #-} +lookupU p = lookupS p . streamU + +------------------------------------------------------------------------ + +unfoldU :: UA a => Int -> (b -> MaybeS (a :*: b)) -> b -> UArr a +{-# INLINE_U unfoldU #-} +unfoldU n f z = unstreamU (unfoldS n f z) + diff --git a/Data/Array/Vector/Strict/Enum.hs b/Data/Array/Vector/Strict/Enum.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Strict/Enum.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Strict.Enum +-- Copyright : (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : portable +-- +-- Description --------------------------------------------------------------- +-- +-- Enum-related operations on flat unlifted arrays. +-- +-- Todo ---------------------------------------------------------------------- +-- + +{-# LANGUAGE CPP #-} + +#include "fusion-phases.h" + +module Data.Array.Vector.Strict.Enum ( + enumFromToU, enumFromToFracU, + enumFromThenToU, enumFromStepLenU, enumFromToEachU +) where + +import Data.Array.Vector.Stream +import Data.Array.Vector.UArr +import Data.Array.Vector.Prim.Hyperstrict +import Data.Array.Vector.Strict.Stream + +-- |Yield an enumerated array +-- +-- FIXME: See comments about enumFromThenToS +enumFromToU :: (UA a, Integral a) => a -> a -> UArr a +{-# INLINE_U enumFromToU #-} +enumFromToU start end = unstreamU (enumFromToS start end) + +enumFromToFracU :: (UA a, RealFrac a) => a -> a -> UArr a +{-# INLINE_U enumFromToFracU #-} +enumFromToFracU start end = unstreamU (enumFromToFracS start end) + +-- |Yield an enumerated array using a specific step +-- +-- FIXME: See comments about enumFromThenToS +enumFromThenToU :: Int -> Int -> Int -> UArr Int +{-# INLINE_U enumFromThenToU #-} +enumFromThenToU start next end = unstreamU (enumFromThenToS start next end) + +enumFromStepLenU :: Int -> Int -> Int -> UArr Int +{-# INLINE_U enumFromStepLenU #-} +enumFromStepLenU s d n = unstreamU (enumFromStepLenS s d n) + +enumFromToEachU :: Int -> UArr (Int :*: Int) -> UArr Int +{-# INLINE_U enumFromToEachU #-} +enumFromToEachU n = unstreamU . enumFromToEachS n . streamU + diff --git a/Data/Array/Vector/Strict/Permute.hs b/Data/Array/Vector/Strict/Permute.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Strict/Permute.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +---------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Strict.Permute +-- Copyright : (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : experimental +-- Portability : portable +-- +-- Description --------------------------------------------------------------- +-- +-- Permutations on flat unlifted arrays. +-- +-- Todo ---------------------------------------------------------------------- +-- + + +#include "fusion-phases.h" + +module Data.Array.Vector.Strict.Permute ( + permuteU, permuteMU, bpermuteU, bpermuteDftU, reverseU, updateU, + atomicUpdateMU +) where + +import Data.Array.Vector.Prim.Hyperstrict ( + (:*:)(..)) +import GHC.ST (ST, runST) +import Data.Array.Vector.Stream ( + Step(..), Stream(..)) +import Data.Array.Vector.UArr ( + UA, UArr, MUArr, + lengthU, newU, newDynU, newMU, unsafeFreezeAllMU, writeMU, + sliceU) +import qualified Data.Array.Vector.UArr as Prim (indexU) +import Data.Array.Vector.Strict.Stream ( + streamU, unstreamMU) +import Data.Array.Vector.Strict.Basics ( + mapU) +import Data.Array.Vector.Strict.Enum ( + enumFromToU) + +-- |Permutations +-- ------------- + +permuteMU :: UA e => MUArr e s -> UArr e -> UArr Int -> ST s () +permuteMU mpa arr is = permute 0 + where + n = lengthU arr + permute i + | i == n = return () + | otherwise = writeMU mpa (is `Prim.indexU` i) (arr `Prim.indexU` i) >> permute (i + 1) + + +-- |Standard permutation +-- +permuteU :: UA e => UArr e -> UArr Int -> UArr e +{-# INLINE_U permuteU #-} +permuteU arr is = newU (lengthU arr) $ \mpa -> permuteMU mpa arr is + +-- |Back permutation operation (ie, the permutation vector determines for each +-- position in the result array its origin in the input array) +-- +bpermuteU :: UA e => UArr e -> UArr Int -> UArr e +{-# INLINE_U bpermuteU #-} +bpermuteU !a = mapU (a `Prim.indexU`) + +-- |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. +-- +-- * All positions not covered by the index-value pairs will have the value +-- determined by the initialiser function for that index position. +-- +bpermuteDftU :: UA e + => Int -- ^ length of result array + -> (Int -> e) -- ^ initialiser function + -> UArr (Int :*: e) -- ^ index-value pairs + -> UArr e +{-# INLINE_U bpermuteDftU #-} +bpermuteDftU n init = updateU (mapU init . enumFromToU 0 $ n-1) + +atomicUpdateMU :: UA e => MUArr e s -> UArr (Int :*: e) -> ST s () +{-# INLINE_U atomicUpdateMU #-} +atomicUpdateMU marr upd = updateM writeMU marr (streamU upd) + +updateM :: UA e => (MUArr e s -> Int -> e -> ST s ()) + -> MUArr e s -> Stream (Int :*: e) -> ST s () +{-# INLINE_STREAM updateM #-} +updateM write marr (Stream next s _) = upd s + where + upd s = case next s of + Done -> return () + Skip s' -> upd s' + Yield (i :*: x) s' -> do + write marr i x + upd s' + +-- | Yield an array constructed by updating the first array by the +-- associations from the second array (which contains index\/value pairs). +-- +updateU :: UA e => UArr e -> UArr (Int :*: e) -> UArr e +{-# INLINE_U updateU #-} +updateU arr upd = update (streamU arr) (streamU upd) + +update :: UA e => Stream e -> Stream (Int :*: e) -> UArr e +{-# INLINE_STREAM update #-} +update s1@(Stream _ _ n) !s2 = newDynU n (\marr -> + do + i <- unstreamMU marr s1 + updateM writeMU marr s2 + return i + ) + +-- |Reverse the order of elements in an array +-- +reverseU :: UA e => UArr e -> UArr e +{-# INLINE_U reverseU #-} +--reverseU a = mapU (a!:) . enumFromToU 0 $ lengthU a - 1 +reverseU = rev . streamU + +rev :: UA e => Stream e -> UArr e +{-# INLINE_STREAM rev #-} +rev (Stream next s n) = + runST (do + marr <- newMU n + i <- fill marr + a <- unsafeFreezeAllMU marr + return $ sliceU a i (n-i) + ) + where + fill marr = fill0 s n + where + fill0 s !i = case next s of + Done -> return i + Skip s' -> s' `seq` fill0 s' i + Yield x s' -> s' `seq` + let i' = i-1 + in + do + writeMU marr i' x + fill0 s' i' + diff --git a/Data/Array/Vector/Strict/Stream.hs b/Data/Array/Vector/Strict/Stream.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Strict/Stream.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Strict.Stream +-- Copyright : (c) 2006 Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : non-portable (existentials) +-- +-- Description --------------------------------------------------------------- +-- +-- Stream combinators and fusion rules for flat unboxed arrays. +-- + + +#include "fusion-phases.h" + +module Data.Array.Vector.Strict.Stream ( + streamU, unstreamU, unstreamMU +) where + +import Data.Array.Vector.Prim.Hyperstrict ( + (:*:)(..), fstS, sndS) +import GHC.ST (ST) +import Data.Array.Vector.Stream ( + Step(..), Stream(..), mapS, zipWithS) +import Data.Array.Vector.UArr ( + UArr, MUArr, UA, indexU, lengthU, zipU, fstU, sndU, newDynU, writeMU) + +-- | Generate a stream from an array, from left to right +-- +streamU :: UA a => UArr a -> Stream a +{-# INLINE_STREAM streamU #-} +streamU !arr = Stream next 0 n + where + n = lengthU arr + {-# INLINE next #-} + next i | i == n = Done + | otherwise = Yield (arr `indexU` i) (i+1) + +-- | Create an array from a stream, filling it from left to right +-- +unstreamU :: UA a => Stream a -> UArr a +{-# INLINE_STREAM unstreamU #-} +unstreamU st@(Stream next s n) = newDynU n (\marr -> unstreamMU marr st) + +-- | Fill a mutable array from a stream from left to right and yield +-- the number of elements written. +-- +unstreamMU :: UA a => MUArr a s -> Stream a -> ST s Int +{-# INLINE_U unstreamMU #-} +unstreamMU marr (Stream next s n) = fill s 0 + where + fill s i = i `seq` + case next s of + Done -> return i + Skip s' -> s' `seq` fill s' i + Yield x s' -> s' `seq` + do + writeMU marr i x + fill s' (i+1) + + + + +-- | Fusion rules +-- -------------- + +-- The main fusion rule + +{-# RULES + +"streamU/unstreamU" forall s. + streamU (unstreamU s) = s + + #-} + +-- Zip fusion +-- +-- NB: We do not separate rules for zip3U etc. because these are implemented +-- in terms of zipU + +{-# RULES + +"streamU/zipU" forall a1 a2. + streamU (zipU a1 a2) = zipWithS (:*:) (streamU a1) (streamU a2) + +"fstU/unstreamU" forall s. + fstU (unstreamU s) = unstreamU (mapS fstS s) +"sndU/unstreamU" forall s. + sndU (unstreamU s) = unstreamU (mapS sndS s) + + #-} + diff --git a/Data/Array/Vector/Strict/Sums.hs b/Data/Array/Vector/Strict/Sums.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Strict/Sums.hs @@ -0,0 +1,142 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Strict.Sums +-- Copyright : (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy +-- License : see libraries/rl/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : portable +-- +-- Description --------------------------------------------------------------- +-- +-- Various sum-like combinators for flat unlifted arrays. +-- +-- Todo ---------------------------------------------------------------------- +-- + +module Data.Array.Vector.Strict.Sums where + +import Data.Array.Vector.Prim.Hyperstrict ( + (:*:)(..), fstS) +import Data.Array.Vector.UArr ( + UA, UArr) +import Data.Array.Vector.Strict.Basics ( + indexedU, mapU, foldU, fold1U, foldlU) +import Data.Array.Vector.Strict.Stream (streamU) + +import Data.Array.Vector.Stream (elemS) + +infix 4 `elemU`, `notElemU` + +-- | +andU :: UArr Bool -> Bool +{-# INLINE andU #-} +andU = foldU (&&) True + +-- | +orU :: UArr Bool -> Bool +{-# INLINE orU #-} +orU = foldU (||) False + +-- | +allU :: UA e => (e -> Bool) -> UArr e -> Bool +{-# INLINE allU #-} +allU p = andU . mapU p + +-- | +anyU :: UA e => (e -> Bool) -> UArr e -> Bool +{-# INLINE anyU #-} +anyU p = orU . mapU p + +-- |Compute the sum of an array of numerals +-- +sumU :: (Num e, UA e) => UArr e -> e +{-# INLINE sumU #-} +sumU = foldU (+) 0 + +-- |Compute the product of an array of numerals +-- +productU :: (Num e, UA e) => UArr e -> e +{-# INLINE productU #-} +productU = foldU (*) 1 + +-- |Determine the maximum element in an array +-- +maximumU :: (Ord e, UA e) => UArr e -> e +{-# INLINE maximumU #-} +maximumU = fold1U max + +-- |Determine the maximum element in an array under the given ordering +-- +maximumByU :: UA e => (e -> e -> Ordering) -> UArr e -> e +{-# INLINE maximumByU #-} +maximumByU = fold1U . maxBy + where + maxBy compare x y = case x `compare` y of + LT -> y + _ -> x + +{- +-- |Determine the index of the maximum element in an array +-- +maximumIndexU :: (Ord e, UA e) => UArr e -> Int +{-# INLINE maximumIndexU #-} +maximumIndexU = maximumIndexByU compare + +-- |Determine the index of the maximum element in an array under the given +-- ordering +-- +maximumIndexByU :: UA e => (e -> e -> Ordering) -> UArr e -> Int +{-# INLINE maximumIndexByU #-} +maximumIndexByU cmp = fstS . maximumByU cmp' . indexedU + where + cmp' (_ :*: x) (_ :*: y) = cmp x y +-} + +-- |Determine the minimum element in an array +-- +minimumU :: (Ord e, UA e) => UArr e -> e +{-# INLINE minimumU #-} +minimumU = fold1U min + +-- |Determine the minimum element in an array under the given ordering +-- +minimumByU :: UA e => (e -> e -> Ordering) -> UArr e -> e +{-# INLINE minimumByU #-} +minimumByU = fold1U . minBy + where + minBy compare x y = case x `compare` y of + GT -> y + _ -> x + +{- +-- |Determine the index of the minimum element in an array +-- +minimumIndexU :: (Ord e, UA e) => UArr e -> Int +{-# INLINE minimumIndexU #-} +minimumIndexU = minimumIndexByU compare + +-- |Determine the index of the minimum element in an array under the given +-- ordering +-- +minimumIndexByU :: UA e => (e -> e -> Ordering) -> UArr e -> Int +{-# INLINE minimumIndexByU #-} +minimumIndexByU cmp = fstS . minimumByU cmp' . indexedU + where + cmp' (_ :*: x) (_ :*: y) = cmp x y +-} + +-- |Determine whether the given element is in an array +-- +elemU :: (Eq e, UA e) => e -> UArr e -> Bool +elemU e = elemS e . streamU -- anyU (== e) (better code) +{-# INLINE elemU #-} + +-- |Negation of `elemU' +-- +notElemU :: (Eq e, UA e) => e -> UArr e -> Bool +notElemU e = allU (/= e) +{-# INLINE notElemU #-} + diff --git a/Data/Array/Vector/Strict/Text.hs b/Data/Array/Vector/Strict/Text.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/Strict/Text.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.Strict.Text +-- Copyright : (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : portable +-- +-- Description --------------------------------------------------------------- +-- +-- Read\/Show instances for flat unlifted arrays. +-- +-- Todo ---------------------------------------------------------------------- +-- + +module Data.Array.Vector.Strict.Text ({- instances -}) where + +import Data.Array.Vector.UArr +import Data.Array.Vector.Strict.Basics +import Data.Array.Vector.Prim.Text + +instance (Show e, UA e) => Show (UArr e) where + showsPrec k = showsApp k "toU" . fromU + +instance (Read e, UA e) => Read (UArr e) where + readPrec = fmap toU (readApp "toU") + diff --git a/Data/Array/Vector/UArr.hs b/Data/Array/Vector/UArr.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Vector/UArr.hs @@ -0,0 +1,787 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.Vector.UArr +-- Copyright : (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy +-- License : see libraries/ndp/LICENSE +-- +-- Maintainer : Roman Leshchinskiy +-- Stability : internal +-- Portability : non-portable (GADTS) +-- +-- Description --------------------------------------------------------------- +-- +-- This module defines unlifted arrays generically as a GADT. +-- +-- Slicing is implemented by each `BUArr' having the slicing information. A +-- possible alternative design would be to maintain this information in +-- `UArr', but not in the representations, but at the root. This may seem +-- attractive at first, but seems to be more disruptive without any real +-- benefits _ this is essentially, because we then need the slicing +-- information at each level; ie, also at the leafs where it is sufficient +-- using the current implementation. +-- +-- Todo ---------------------------------------------------------------------- +-- + +#include "fusion-phases.h" + +module Data.Array.Vector.UArr ( + + -- * Array types and classes containing the admissable elements types + UA, UArr, MUArr, UPrim(..), + + -- * Basic operations on parallel arrays + lengthU, indexU, sliceU, {-extractU,-} unitsU, zipU, unzipU, fstU, sndU, + newU, newDynU, newDynResU, + lengthMU, newMU, readMU, writeMU, copyMU, unsafeFreezeMU, unsafeFreezeAllMU, + + -- * I\/O + UIO(..) + +) where + +-- standard libraries +import Control.Monad (liftM, liftM2) + +-- For instances: +import Data.Complex +import GHC.Real + +-- friends +import Data.Array.Vector.Prim.BUArr ( + BUArr, MBUArr, UAE, + lengthBU, indexBU, sliceBU, hGetBU, hPutBU, + lengthMBU, newMBU, readMBU, writeMBU, copyMBU, unsafeFreezeMBU) + +import System.IO +import GHC.ST +import Data.Word +import Data.Int +import Data.Array.Vector.Prim.Debug +import Data.Array.Vector.Prim.Hyperstrict + +infixl 9 `indexU`, `readMU` + + +-- |Basic operations on representation types +-- ----------------------------------------- + +-- |This type class determines the types that can be elements immutable +-- unboxed arrays. The representation type of these arrays is defined by way +-- of an associated type. All representation-dependent functions are methods +-- of this class. +-- +class UA e where + data UArr e + data MUArr e :: * -> * + + -- |Yield the length of an unboxed array + lengthU :: UArr e -> Int + + -- |Extract an element out of an immutable unboxed array + indexU :: UArr e -> Int -> e + + -- |Restrict access to a subrange of the original array (no copying) + sliceU :: UArr e -> Int -> Int -> UArr e + + ------------------------------------------------------------------------ + + -- |Yield the length of a mutable unboxed array + lengthMU :: MUArr e s -> Int + + -- |Allocate a mutable unboxed array + newMU :: Int -> ST s (MUArr e s) + + -- |Read an element from a mutable unboxed array + readMU :: MUArr e s -> Int -> ST s e + + -- |Update an element in a mutable unboxed array + writeMU :: MUArr e s -> Int -> e -> ST s () + + ------------------------------------------------------------------------ + + -- |Copy the contents of an immutable unboxed array into a mutable one + -- from the specified position on + copyMU :: MUArr e s -> Int -> UArr e -> ST s () + + -- |Convert a mutable into an immutable unboxed array + unsafeFreezeMU :: MUArr e s -> Int -> ST s (UArr e) + +-- instance HS e => HS (UArr e) +-- instance HS e => HS (MUArr e s) + +class UAE e => UPrim e where + mkUAPrim :: BUArr e -> UArr e + unUAPrim :: UArr e -> BUArr e + + mkMUAPrim :: MBUArr s e -> MUArr e s + unMUAPrim :: MUArr e s -> MBUArr s e + +unsafeFreezeAllMU :: UA e => MUArr e s -> ST s (UArr e) +unsafeFreezeAllMU marr = unsafeFreezeMU marr (lengthMU marr) + +-- |Creating unboxed arrays +-- ------------------------ + +newU :: UA e => Int -> (forall s. MUArr e s -> ST s ()) -> UArr e +{-# INLINE_U newU #-} +newU n init = newDynU n (\ma -> init ma >> return n) + +newDynU :: UA e => Int -> (forall s. MUArr e s -> ST s Int) -> UArr e +{-# INLINE_U newDynU #-} +newDynU n init = + runST (do + ma <- newMU n + n' <- init ma + unsafeFreezeMU ma n' + ) + +newDynResU :: UA e + => Int -> (forall s. MUArr e s -> ST s (Int :*: r)) -> UArr e :*: r +{-# INLINE_U newDynResU #-} +newDynResU n init = + runST (do + ma <- newMU n + n' :*: r <- init ma + arr <- unsafeFreezeMU ma n' + return (arr :*: r) + ) + +-- |Basic operations on unboxed arrays +-- ----------------------------------- + +-- |Yield an array of units +-- +unitsU :: Int -> UArr () +{-# INLINE_STREAM unitsU #-} +unitsU = UAUnit + +-- |Elementwise pairing of array elements. +-- +zipU :: (UA a, UA b) => UArr a -> UArr b -> UArr (a :*: b) +{-# INLINE_STREAM zipU #-} +zipU = UAProd + +-- |Elementwise unpairing of array elements. +-- +unzipU :: (UA a, UA b) => UArr (a :*: b) -> (UArr a :*: UArr b) +{-# INLINE_STREAM unzipU #-} +unzipU (UAProd l r) = (l :*: r) + +-- |Yield the first components of an array of pairs. +-- +fstU :: (UA a, UA b) => UArr (a :*: b) -> UArr a +{-# INLINE_STREAM fstU #-} +fstU (UAProd l r) = l + +-- |Yield the second components of an array of pairs. +-- +sndU :: (UA a, UA b) => UArr (a :*: b) -> UArr b +{-# INLINE_STREAM sndU #-} +sndU (UAProd l r) = r + +-- |Family of representation types +-- ------------------------------- + +-- |Array operations on the unit representation. +-- +instance UA () where + newtype UArr () = UAUnit Int + newtype MUArr () s = MUAUnit Int + + lengthU (UAUnit n) = n + indexU (UAUnit _) _ = () + sliceU (UAUnit _) _ n = UAUnit n + + lengthMU (MUAUnit n) = n + newMU n = return $ MUAUnit n + readMU (MUAUnit _) _ = return () + writeMU (MUAUnit _) _ _ = return () + copyMU (MUAUnit _) _ (UAUnit _) = return () + unsafeFreezeMU (MUAUnit _) n = return $ UAUnit n + +-- |Array operations on the pair representation. +-- +instance (UA a, UA b) => UA (a :*: b) where + data UArr (a :*: b) = UAProd !(UArr a) !(UArr b) + data MUArr (a :*: b) s = MUAProd !(MUArr a s) !(MUArr b s) + + -- TODO: changed from (lengthU l), as this causes problems when the length is used to + -- limit the index + lengthU (UAProd l r) = checkEq "lengthU" "lengths of zipped arrays differ" (lengthU l) (lengthU r) + (lengthU l) + {-# INLINE_U indexU #-} + indexU (UAProd l r) i = indexU l i :*: indexU r i + {-# INLINE_U sliceU #-} + sliceU (UAProd l r) i n = UAProd (sliceU l i n) (sliceU r i n) + + {-# INLINE_U lengthMU #-} + lengthMU (MUAProd l r) = lengthMU l + + {-# INLINE_U newMU #-} + newMU n = + do + a <- newMU n + b <- newMU n + return $ MUAProd a b + {-# INLINE_U readMU #-} + readMU (MUAProd a b) i = liftM2 (:*:) (a `readMU` i) (b `readMU` i) + {-# INLINE_U writeMU #-} + writeMU (MUAProd a b) i (x :*: y) = + do + writeMU a i x + writeMU b i y + {-# INLINE_U copyMU #-} + copyMU (MUAProd ma mb) i (UAProd a b) = + do + copyMU ma i a + copyMU mb i b + {-# INLINE_U unsafeFreezeMU #-} + unsafeFreezeMU (MUAProd a b) n = + do + a' <- unsafeFreezeMU a n + b' <- unsafeFreezeMU b n + return $ UAProd a' b' + +{- +-- |Selector for immutable arrays of sums +-- +data USel = USel { + selUS :: !(BUArr Bool), -- selector (False => left) + lidxUS :: !(BUArr Int), -- left indices + ridxUS :: !(BUArr Int) -- right indices + } + +--instance HS USel + +-- |Selector for mutable arrays of sums +-- +data MUSel s = MUSel { + selMUS :: !(MBUArr s Bool), -- selector (False => left) + lidxMUS :: !(MBUArr s Int), -- left indices + ridxMUS :: !(MBUArr s Int) -- right indices + } + +--instance HS (MUSel s) + +-- |Array operations on the sum representation +-- +instance (UA a, UA b) => UA (a :+: b) where + lengthU (UASum sel _ _) = lengthBU (selUS sel) + {-# INLINE_U indexU #-} + indexU (UASum sel l r) i = if (selUS sel)`indexBU`i then Inr $ indexU r i + else Inl $ indexU l i + {-# INLINE_U sliceU #-} + sliceU (UASum sel l r) i n = + let + sel' = sliceBU (selUS sel) i n + li = lidxUS sel`indexBU`i + ri = ridxUS sel`indexBU`i + lidx = mapBU (subtract li) $ sliceBU (lidxUS sel) i n + ridx = mapBU (subtract ri) $ sliceBU (ridxUS sel) i n + (ln :*: rn) = if n == 0 then (0 :*: 0) else (lidx`indexBU`(n - 1) :*: + ridx`indexBU`(n - 1)) + in + UASum (USel sel' lidx ridx) (sliceU l li ln) (sliceU r ri rn) + {-# INLINE_U extractU #-} + extractU (UASum sel l r) i n = + let + sel' = extractBU (selUS sel) i n + li = lidxUS sel`indexBU`i + ri = ridxUS sel`indexBU`i + lidx = mapBU (subtract li) $ sliceBU (lidxUS sel) i n + ridx = mapBU (subtract ri) $ sliceBU (ridxUS sel) i n + (ln :*: rn) = if n == 0 then (0 :*: 0) else (lidx`indexBU`(n - 1) :*: + ridx`indexBU`(n - 1)) + in + UASum (USel sel' lidx ridx) (extractU l li ln) (extractU r ri rn) + +instance (MUA a, MUA b) => MUA (a :+: b) where + {-# INLINE_U newMU #-} + newMU n = do + sel <- newMBU n + lidx <- newMBU n + ridx <- newMBU n + a <- newMU n + b <- newMU n + return $ MUASum (MUSel sel lidx ridx) a b + {-# INLINE_U writeMU #-} + writeMU (MUASum sel l r) i (Inl x) = + do + let lidx = lidxMUS sel + ridx = ridxMUS sel + writeMBU (selMUS sel) i False + li <- if i == 0 then return 0 else liftM (+ 1) $ lidx`readMBU`(i - 1) + ri <- if i == 0 then return 0 else ridx`readMBU`(i - 1) + writeMBU lidx i li + writeMBU ridx i ri + writeMU l li x + writeMU (MUASum sel l r) i (Inr x) = + do + let lidx = lidxMUS sel + ridx = ridxMUS sel + writeMBU (selMUS sel) i True + li <- if i == 0 then return 0 else lidx`readMBU`(i - 1) + ri <- if i == 0 then return 0 else liftM (+ 1) $ ridx`readMBU`(i - 1) + writeMBU lidx i li + writeMBU ridx i ri + writeMU r ri x + --FIXME: that works only when the array is constructed left to right, but + --not for something like permutations + {-# INLINE_U unsafeFreezeMU #-} + unsafeFreezeMU (MUASum sel l r) n = + do + sel' <- unsafeFreezeMBU (selMUS sel) n + lidx <- unsafeFreezeMBU (lidxMUS sel) n + ridx <- unsafeFreezeMBU (ridxMUS sel) n + let ln = if n == 0 then 0 else lidx`indexBU`(n - 1) + rn = if n == 0 then 0 else ridx`indexBU`(n - 1) + l' <- unsafeFreezeMU l ln + r' <- unsafeFreezeMU r rn + return $ UASum (USel sel' lidx ridx) l' r' +-} + +-- |Array operations on unboxed arrays +-- - +-- +-- NB: We use instances for all possible unboxed types instead of re-using the +-- overloading provided by UAE to avoid having to store the UAE dictionary +-- in `UAPrimU'. + +primLengthU :: UPrim e => UArr e -> Int +{-# INLINE_U primLengthU #-} +primLengthU = lengthBU . unUAPrim + +primIndexU :: UPrim e => UArr e -> Int -> e +{-# INLINE_U primIndexU #-} +primIndexU = indexBU . unUAPrim + +primSliceU :: UPrim e => UArr e -> Int -> Int -> UArr e +{-# INLINE_U primSliceU #-} +primSliceU arr i = mkUAPrim . sliceBU (unUAPrim arr) i + +primLengthMU :: UPrim e => MUArr e s -> Int +{-# INLINE_U primLengthMU #-} +primLengthMU = lengthMBU . unMUAPrim + +primNewMU :: UPrim e => Int -> ST s (MUArr e s) +{-# INLINE_U primNewMU #-} +primNewMU = liftM mkMUAPrim . newMBU + +primReadMU :: UPrim e => MUArr e s -> Int -> ST s e +{-# INLINE_U primReadMU #-} +primReadMU = readMBU . unMUAPrim + +primWriteMU :: UPrim e => MUArr e s -> Int -> e -> ST s () +{-# INLINE_U primWriteMU #-} +primWriteMU = writeMBU . unMUAPrim + +primCopyMU :: UPrim e => MUArr e s -> Int -> UArr e -> ST s () +{-# INLINE_U primCopyMU #-} +primCopyMU ma i = copyMBU (unMUAPrim ma) i . unUAPrim + +primUnsafeFreezeMU :: UPrim e => MUArr e s -> Int -> ST s (UArr e) +{-# INLINE_U primUnsafeFreezeMU #-} +primUnsafeFreezeMU ma = liftM mkUAPrim . unsafeFreezeMBU (unMUAPrim ma) + +instance UPrim Bool where + mkUAPrim = UABool + unUAPrim (UABool arr) = arr + + mkMUAPrim = MUABool + unMUAPrim (MUABool arr) = arr + +instance UA Bool where + newtype UArr Bool = UABool (BUArr Bool) + newtype MUArr Bool s = MUABool (MBUArr s Bool) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Char where + mkUAPrim = UAChar + unUAPrim (UAChar arr) = arr + + mkMUAPrim = MUAChar + unMUAPrim (MUAChar arr) = arr + +instance UA Char where + newtype UArr Char = UAChar !(BUArr Char) + newtype MUArr Char s = MUAChar !(MBUArr s Char) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Int where + mkUAPrim = UAInt + unUAPrim (UAInt arr) = arr + + mkMUAPrim = MUAInt + unMUAPrim (MUAInt arr) = arr + +instance UA Int where + newtype UArr Int = UAInt !(BUArr Int) + newtype MUArr Int s = MUAInt !(MBUArr s Int) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + + -- FIXME: For now, we assume that Int writes are atomic but we should really + -- configure this. + +instance UPrim Word where + mkUAPrim = UAWord + unUAPrim (UAWord arr) = arr + mkMUAPrim = MUAWord + unMUAPrim (MUAWord arr) = arr + +instance UA Word where + newtype UArr Word = UAWord !(BUArr Word) + newtype MUArr Word s = MUAWord !(MBUArr s Word) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + -- FIXME: For now, we assume that Word writes are atomic but we should really + -- configure this. + +instance UPrim Float where + mkUAPrim = UAFloat + unUAPrim (UAFloat arr) = arr + + mkMUAPrim = MUAFloat + unMUAPrim (MUAFloat arr) = arr + +instance UA Float where + newtype UArr Float = UAFloat !(BUArr Float) + newtype MUArr Float s = MUAFloat !(MBUArr s Float) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Double where + mkUAPrim = UADouble + unUAPrim (UADouble arr) = arr + + mkMUAPrim = MUADouble + unMUAPrim (MUADouble arr) = arr + +instance UA Double where + newtype UArr Double = UADouble !(BUArr Double) + newtype MUArr Double s = MUADouble !(MBUArr s Double) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Word8 where + mkUAPrim = UAWord8 + unUAPrim (UAWord8 arr) = arr + mkMUAPrim = MUAWord8 + unMUAPrim (MUAWord8 arr) = arr + +instance UA Word8 where + newtype UArr Word8 = UAWord8 !(BUArr Word8) + newtype MUArr Word8 s = MUAWord8 !(MBUArr s Word8) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + -- FIXME: For now, we assume that Word8 writes are atomic but we should really + -- configure this. + +instance UPrim Word16 where + mkUAPrim = UAWord16 + unUAPrim (UAWord16 arr) = arr + mkMUAPrim = MUAWord16 + unMUAPrim (MUAWord16 arr) = arr + +instance UA Word16 where + newtype UArr Word16 = UAWord16 !(BUArr Word16) + newtype MUArr Word16 s = MUAWord16 !(MBUArr s Word16) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Word32 where + mkUAPrim = UAWord32 + unUAPrim (UAWord32 arr) = arr + mkMUAPrim = MUAWord32 + unMUAPrim (MUAWord32 arr) = arr + +instance UA Word32 where + newtype UArr Word32 = UAWord32 !(BUArr Word32) + newtype MUArr Word32 s = MUAWord32 !(MBUArr s Word32) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Word64 where + mkUAPrim = UAWord64 + unUAPrim (UAWord64 arr) = arr + mkMUAPrim = MUAWord64 + unMUAPrim (MUAWord64 arr) = arr + +instance UA Word64 where + newtype UArr Word64 = UAWord64 !(BUArr Word64) + newtype MUArr Word64 s = MUAWord64 !(MBUArr s Word64) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Int8 where + mkUAPrim = UAInt8 + unUAPrim (UAInt8 arr) = arr + mkMUAPrim = MUAInt8 + unMUAPrim (MUAInt8 arr) = arr + +instance UA Int8 where + newtype UArr Int8 = UAInt8 !(BUArr Int8) + newtype MUArr Int8 s = MUAInt8 !(MBUArr s Int8) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + -- FIXME: For now, we assume that Int8 writes are atomic but we should really + -- configure this. + +instance UPrim Int16 where + mkUAPrim = UAInt16 + unUAPrim (UAInt16 arr) = arr + mkMUAPrim = MUAInt16 + unMUAPrim (MUAInt16 arr) = arr + +instance UA Int16 where + newtype UArr Int16 = UAInt16 !(BUArr Int16) + newtype MUArr Int16 s = MUAInt16 !(MBUArr s Int16) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Int32 where + mkUAPrim = UAInt32 + unUAPrim (UAInt32 arr) = arr + mkMUAPrim = MUAInt32 + unMUAPrim (MUAInt32 arr) = arr + +instance UA Int32 where + newtype UArr Int32 = UAInt32 !(BUArr Int32) + newtype MUArr Int32 s = MUAInt32 !(MBUArr s Int32) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +instance UPrim Int64 where + mkUAPrim = UAInt64 + unUAPrim (UAInt64 arr) = arr + mkMUAPrim = MUAInt64 + unMUAPrim (MUAInt64 arr) = arr + +instance UA Int64 where + newtype UArr Int64 = UAInt64 !(BUArr Int64) + newtype MUArr Int64 s = MUAInt64 !(MBUArr s Int64) + + lengthU = primLengthU + indexU = primIndexU + sliceU = primSliceU + lengthMU = primLengthMU + newMU = primNewMU + readMU = primReadMU + writeMU = primWriteMU + copyMU = primCopyMU + unsafeFreezeMU = primUnsafeFreezeMU + +------------------------------------------------------------------------ + +-- TODO could use a single array of 'a', doubly packed + +instance (RealFloat a, UA a) => UA (Complex a) where + + newtype UArr (Complex a) = UAComplex !(UArr (a :*: a)) + newtype MUArr (Complex a) s = MUAComplex !(MUArr (a :*: a) s) + + lengthU (UAComplex arr) = lengthU arr + + indexU (UAComplex arr) i = case indexU arr i of (a :*: b) -> a :+ b + + sliceU (UAComplex arr) i n = UAComplex (sliceU arr i n) + + lengthMU (MUAComplex arr) = lengthMU arr + + newMU n = return . MUAComplex =<< newMU n + + readMU (MUAComplex arr) n = do (a :*: b) <- readMU arr n; return (a :+ b) + + writeMU (MUAComplex arr) i (x :+ y) = writeMU arr i (x :*: y) + + copyMU (MUAComplex mua) n (UAComplex ua) = copyMU mua n ua + + unsafeFreezeMU (MUAComplex arr) n = do arr' <- unsafeFreezeMU arr n; return (UAComplex arr') + + + +instance (Integral a, UA a) => UA (Ratio a) where + newtype UArr (Ratio a) = UARatio !(UArr (a :*: a)) + newtype MUArr (Ratio a) s = MUARatio !(MUArr (a :*: a) s) + + lengthU (UARatio arr) = lengthU arr + indexU (UARatio arr) i = case indexU arr i of (a :*: b) -> a % b + sliceU (UARatio arr) i n = UARatio (sliceU arr i n) + + lengthMU (MUARatio arr) = lengthMU arr + newMU n = return . MUARatio =<< newMU n + readMU (MUARatio arr) n = do (a :*: b) <- readMU arr n; return (a % b) + writeMU (MUARatio arr) i (n :% d) = writeMU arr i (n :*: d) + copyMU (MUARatio mua) n (UARatio ua) = copyMU mua n ua + unsafeFreezeMU (MUARatio arr) n = do arr' <- unsafeFreezeMU arr n; return (UARatio arr') + +------------------------------------------------------------------------ + +-- * I\/O +-- ----- + +class UA a => UIO a where + hPutU :: Handle -> UArr a -> IO () + hGetU :: Handle -> IO (UArr a) + +primPutU :: UPrim a => Handle -> UArr a -> IO () +primPutU h = hPutBU h . unUAPrim + +primGetU :: UPrim a => Handle -> IO (UArr a) +primGetU = liftM mkUAPrim . hGetBU + +------------------------------------------------------------------------ + +instance UIO Bool where hPutU = primPutU; hGetU = primGetU +instance UIO Char where hPutU = primPutU; hGetU = primGetU +instance UIO Int where hPutU = primPutU; hGetU = primGetU +instance UIO Word where hPutU = primPutU; hGetU = primGetU +instance UIO Float where hPutU = primPutU; hGetU = primGetU +instance UIO Double where hPutU = primPutU; hGetU = primGetU + +instance UIO Word8 where hPutU = primPutU; hGetU = primGetU +instance UIO Word16 where hPutU = primPutU; hGetU = primGetU +instance UIO Word32 where hPutU = primPutU; hGetU = primGetU +instance UIO Word64 where hPutU = primPutU; hGetU = primGetU + +instance UIO Int8 where hPutU = primPutU; hGetU = primGetU +instance UIO Int16 where hPutU = primPutU; hGetU = primGetU +instance UIO Int32 where hPutU = primPutU; hGetU = primGetU +instance UIO Int64 where hPutU = primPutU; hGetU = primGetU + +------------------------------------------------------------------------ + +instance (UIO a, UIO b) => UIO (a :*: b) where + hPutU h (UAProd xs ys) = do hPutU h xs + hPutU h ys + hGetU h = do xs <- hGetU h + ys <- hGetU h + return (UAProd xs ys) + +instance (RealFloat a, UIO a) => UIO (Complex a) where + hPutU h (UAComplex arr) = hPutU h arr + hGetU h = do arr <- hGetU h + return (UAComplex arr) + +instance (Integral a, UIO a) => UIO (Ratio a) where + hPutU h (UARatio arr) = hPutU h arr + hGetU h = do arr <- hGetU h + return (UARatio arr) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (c) 2008 Don Stewart +Copyright (c) 2001-2002, Manuel M T Chakravarty & Gabriele Keller +Copyright (c) 2006-2007, Manuel M T Chakravarty & Roman Leshchinskiy + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,11 @@ +The uvector library is a polished up version of the basic flat, unlifted +arrays from the Data Parallel Haskell project. These arrays use +aggressive fusion optimisations, low level unboxed representations, and +a list-like interface, to provide convenient access to fast arrays in +pure Haskell. + +As this is all about speed, the library is only available for GHC. + +------------------------------------------------------------------------ + +When to fuse: don't duplicate work. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,54 @@ + +Direction: + * Fill out API + * Complete coverage + -- ensure we can enumerate all primitives types, and fuse them. + + * Direct implementation of fusible operations too + -- substrings, length in O(1) + + * concat/concatMap ? (need lifted arrays?) + + * IO introduction + - Data.Binary/bytestring + - Array interface? + - Binary? + + * A good strategy for user defined loops (pure, impure) + * A good strategy for user defined packing + + * Organisation: + Vector -- stream version + Strict -- strict data types and ops + Vector.Array -- direct implementation + Vector.Mutable -- mutable ops + + Prim/* + Stream/* + + Mutable: + new + length + read, write copy, + stream, unstream + + * To and from ByteStrings. + +See the operators in the OCaml library, + + http://caml.inria.fr/pub/docs/manual-ocaml/libref/Bigarray.Array1.html + +Beware: + * combining modules can break fusion in 6.8.2 + +Documentation: + * State that -O2 is *required* for unboxing of stream state components with SpecConstr +otherwise, -O -fspec-constr + * Examples of high and low level use + * haddocks + +Performance: + * Need performance benchmarks + +Possibles: + * Maybe provide ST interface for low level things? diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,22 @@ +TESTDIR=. +include $(TESTDIR)/mk/test.mk + +SUBDIRS = concomp dotp primes smvm qsort + +.PHONY: all bench clean + +all: bench + for i in $(SUBDIRS) ; do \ + $(MAKE) -C $$i ; \ + done + +bench: + $(MAKE) -C lib + +clean: + for i in $(SUBDIRS) ; do \ + $(MAKE) -C $$i clean ; \ + done + $(MAKE) -C lib clean + + diff --git a/examples/README b/examples/README new file mode 100644 --- /dev/null +++ b/examples/README @@ -0,0 +1,59 @@ +NDP benchmarks +============== + +This directory contains several NDP benchmarks: + +concomp - connected components in undirected graphs +dotp - dot product of two vectors +primes - sieve of Eratosthenes +smvm - sparse matrix/vector multiplication + +Options +------- + +The following options are common to all benchmarks: + + --runs=N Repeat each benchmark N times + -r N + + --threads=N Use N threads + -t N + + --seq=N Simulate N threads + -s N + + --algo=ALGORITHM Use the specified algorithm (if the benchmark + -a ALGORITHM implements multiple algorithms) + + --verbose=N Set the verbosity level + -v N + + --help Show a help screen + +Running benchmarks +------------------ + +For parallel benchmarks, you usually want to use + + benchmark --threads= --runs= +RTS -N + +Here, N is the number of threads to use and R the number of times the +benchmark should be repeated (you probably want something between 3 and 10). + +The output will look as follows: + + ....: wall_best/cpu_best wall_avg/cpu_avg wall_worst/cpu_worst + +Here, wall_{best|avg|worst} is the best, average and worst wall-clock time, +respectively; cpu_{best|avg|worst} is the CPU time. Note that for parallel +benchmarks on a multiprocessor, the wall-clock time will typically decrease +with more threads whereas the CPU time will slightly increase. + +For sequential benchmarks, the number of threads does not have to be +specified, i.e., --threads and +RTS -N can be omitted. + +At higher verbosity levels, more information (in particular, the timings of +the individual runs) will be displayed. + + + diff --git a/examples/barhesHut/BarnesHut.hs b/examples/barhesHut/BarnesHut.hs new file mode 100644 --- /dev/null +++ b/examples/barhesHut/BarnesHut.hs @@ -0,0 +1,101 @@ +module Main where +import BarnesHutSeq +import BarnesHutPar +import qualified BarnesHutVect as V +import BarnesHutGen + +import Control.Exception (evaluate) +import System.Console.GetOpt + +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Parallel + +import Bench.Benchmark +import Bench.Options +import Data.Array.Parallel.Prelude (toUArrPA, fromUArrPA_3') + +import Debug.Trace + + + +algs = [("seqSimple", bhStepSeq), ("parSimple", bhStepPar), ("vect", bhStepVect)] + +bhStepSeq (dx, dy, particles) = trace (showBHTree bhtree) accs + where + accs = calcAccel bhtree (flattenSU particles) + bhtree = splitPointsL (singletonU ((0.0 :*: 0.0) :*: (dx :*: dy))) particles + +bhStepPar (dx, dy, particles) = trace (showBHTree bhTree) accs + where + accs = calcAccel bhTree (flattenSU particles) + bhTree = splitPointsLPar (singletonU ((0.0 :*: 0.0) :*: (dx :*: dy))) + particles + +bhStepVect (dx, dy, particles) = trace (show accs) accs + where + accs = zipU (toUArrPA xs) (toUArrPA ys) + (xs, ys) = V.oneStep 0.0 0.0 dx dy particles' + particles' = (fromUArrPA_3' $ flattenSU particles) + + + +mapData:: IO (Bench.Benchmark.Point (UArr Double)) +mapData = do + evaluate testData + return $ ("N = " ) `mkPoint` testData + where + testData:: UArr Double + testData = toU $ map fromIntegral [0..10000000] + + + +-- simpleTest:: +simpleTest:: [Int] -> Double -> Double -> IO (Bench.Benchmark.Point (Double, Double, SUArr MassPoint)) +simpleTest _ _ _= + do + evaluate testData + return $ ("N = " ) `mkPoint` testData + where + testData = (1.0, 1.0, singletonSU testParticles) + -- particles in the bounding box 0.0 0.0 1.0 1.0 + testParticles:: UArr MassPoint + testParticles = toU [ + 0.3 :*: 0.2 :*: 5.0, +{- +-- 0.2 :*: 0.1 :*: 5.0, +-- 0.1 :*: 0.2 :*: 5.0, +-- 0.8 :*: 0.8 :*: 5.0, + 0.7 :*: 0.9 :*: 5.0, + 0.8 :*: 0.9 :*: 5.0, + 0.6 :*: 0.6 :*: 5.0, + 0.7 :*: 0.7 :*: 5.0, + 0.8 :*: 0.7 :*: 5.0, -} + 0.9 :*: 0.9 :*: 5.0] + + +randomDistTest n dx dy = + do + testParticles <- randomMassPointsIO dx dy + let testData = (singletonU testBox, singletonSU $ toU $ take n testParticles) + evaluate testData + return $ ("N = " ) `mkPoint` testData + + where + testBox = (0.0 :*: 0.0) :*: (dx :*: dy) + + +main = ndpMain "BarnesHut" + "[OPTION] ... SIZES ..." + run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") + "use the specified algorithm"] + "seq" + +run opts alg sizes = + case lookup alg algs of + Nothing -> failWith ["Unknown algorithm"] + Just f -> case map read sizes of + [] -> failWith ["No sizes specified"] + szs -> do + benchmark opts f [simpleTest szs 0 0] show + return () + diff --git a/examples/barhesHut/BarnesHutGen.hs b/examples/barhesHut/BarnesHutGen.hs new file mode 100644 --- /dev/null +++ b/examples/barhesHut/BarnesHutGen.hs @@ -0,0 +1,266 @@ +module BarnesHutGen where + +import Monad (liftM) + +import List (nubBy) +import IO +import System (ExitCode(..), getArgs, exitWith) +import Random (Random, RandomGen, getStdGen, randoms, randomRs) +import Data.Array.Parallel.Unlifted + +type Vector = (Double :*: Double) + +type Point = Vector +type Accel = Vector +type Velocity = Vector +type MassPoint = Point :*: Double +type Particle = MassPoint :*: Velocity + +type BoundingBox = Point :*: Point + +type BHTree = [BHTreeLevel] +type BHTreeLevel = (UArr MassPoint, UArr Int) -- centroids + +epsilon = 0.05 +eClose = 0.5 + +-- particle generation +-- ------------------- + +randomTo, randomFrom :: Integer +randomTo = 2^30 +randomFrom = - randomTo + +randomRIOs :: Random a => (a, a) -> IO [a] +randomRIOs range = liftM (randomRs range) getStdGen + +randomIOs :: Random a => IO [a] +randomIOs = liftM randoms getStdGen + +-- generate a stream of random numbers in [0, 1) +-- +randomDoubleIO :: IO [Double] +randomDoubleIO = randomIOs + +-- generate an infinite list of random mass points located with a homogeneous +-- distribution around the origin within the given bounds +-- +randomMassPointsIO :: Double -> Double -> IO [MassPoint] +randomMassPointsIO dx dy = do + rs <- randomRIOs (randomFrom, randomTo) + return (massPnts rs) + where + to = fromIntegral randomTo + from = fromIntegral randomFrom + xmin = - (dx / 2.0) + ymin = - (dy / 2.0) + xfrac = (to - from) / dx + yfrac = (to - from) / dy + + massPnts :: [Integer] -> [MassPoint] + massPnts (xb:yb:mb:rs) = + ((x :*: y) :*: m) : massPnts rs + where + m = (fromInteger . abs) mb + epsilon + x = xmin + (fromInteger xb) / xfrac + y = ymin + (fromInteger yb) / yfrac + +-- The mass of the generated particle cloud is standardized to about +-- 5.0e7 g/m^2. The mass of individual particles may deviate by a factor of +-- ten from the average. +-- +smoothMass :: Double -> Double -> [MassPoint] -> [MassPoint] +smoothMass dx dy mps = let + avmass = 5.0e7 + area = dx * dy + middle = avmass * area / fromIntegral (length mps) + range = fromIntegral (randomTo - randomFrom) + factor = (middle * 10 - middle / 10) / range + + adjust (xy :*: m) = + xy :*: (middle + factor * m) + in + map adjust mps + +-- Given the number of particles to generate and the horizontal and vertical +-- extensions of the area where the generated particles should occur, generate +-- a particle set according to a function specific strategy. +-- +asymTwinParticles, + sphereParticles, + plummerParticles, + homParticles :: Int -> Double -> Double -> IO ([Particle]) + +asymTwinParticles n dx dy = error "asymTwinPrticles not implemented yet\n" + +sphereParticles n dx dy = + do + let rad = dx `min` dy + mps <- randomMassPointsIO dx dy + return (( map (\mp -> mp :*: (0.0 :*: 0.0)) + . smoothMass dx dy + . head + . filter ((== n) . length) + . map fst + . iterate refine + ) ([], filter (inside rad) mps) + ) + where + -- + -- move suitable mass points from the second list to the first (i.e., those + -- not conflicting with points that are already in the first list) + -- + refine :: ([MassPoint], [MassPoint]) -> ([MassPoint], [MassPoint]) + refine (ds, rs) = let + (ns, rs') = splitAt (n - length ds) rs + in + (nubMassPoints (ds ++ ns), rs') + + -- check whether inside the given radius + -- + inside :: Double -> MassPoint -> Bool + inside rad ((dx :*: dy) :*: _) = dx * dx + dy * dy <= rad * rad + +plummerParticles n _ _ = + do + rs <- randomDoubleIO + return (( normalize + . head + . filter ((== n) . length) + . map fst + . iterate refine + ) ([], particles rs) + ) + where + particles (w:preY:rs') = let + s_i = rsc * r_i + rsc = (3 * pi) / 16 + r_i = sqrt' ((0.999 * w)`power`(-2/3) - 1) + -- + u_i = vsc * v_i + vsc = 1 / sqrt rsc + v_i = (x * sqrt 2) / (1 + r_i^2)**(1/4) + -- + (pos :*: rs''' ) = rndVec s_i rs'' + (vel :*: rs'''') = rndVec u_i rs''' + in + ((pos :*: m) :*: vel) : particles rs'''' + where + y = preY / 101 + -- !!!should be 10, but then + -- !!!findX gets problems + (x, rs'') = findX y rs' + -- + m = 1 / fromIntegral n + -- + x`power`y | x == 0.0 = 0.0 + | otherwise = x**y + sqrt' x | x < 0 = 0 + | otherwise = sqrt x + + findX :: Double -> [Double] -> (Double, [Double]) + findX y (x:rs) | y <= x^2 * (1 - x^2)**(7/2) = (x, rs) + | otherwise = findX y rs + + rndVec len (x:y:rs) = let r = len / sqrt (x^2 + y^2) + in + ((r * x :*: r * y) :*: rs) + + -- move suitable mass points from the second list to the first (i.e., those + -- not conflicting with points that are already in the first list) + -- + refine :: ([Particle], [Particle]) -> ([Particle], [Particle]) + refine (ds, rs) = let + (ns, rs') = splitAt (n - length ds) rs + in + (nubParticles (ds ++ ns), rs') + + -- translate positions and velocities such that they are at the origin + -- + normalize :: [Particle] -> [Particle] + normalize ps = + let (dx :*: dy) :*: _ = centroid [mp | mp :*: _ <- ps] + ((dvx:*: dvy) :*: _) = totalMomentum ps + in + (map (translateVel (-dvx :*: -dvy)) . map (translate (-dx :*: -dy))) ps + + +homParticles n dx dy = + do + mps <- randomMassPointsIO dx dy + return (( map (\mp -> mp :*: (0.0 :*: 0.0)) + . smoothMass dx dy + . head + . filter ((== n) . length) + . map fst + . iterate refine + ) ([], mps) + ) + where + -- + -- move suitable mass points from the second list to the first (i.e., those + -- not conflicting with points that are already in the first list) + -- + refine :: ([MassPoint], [MassPoint]) -> ([MassPoint], [MassPoint]) + refine (ds, rs) = let + (ns, rs') = splitAt (n - length ds) rs + in + (nubMassPoints (ds ++ ns), rs') + + +-- Drop all mass points that are too close to another. +-- +nubMassPoints :: [MassPoint] -> [MassPoint] +nubMassPoints = nubBy (\(p1 :*: _) (p2 :*: _) -> epsilonEqual p1 p2) + +-- Same for particles. +-- +nubParticles :: [Particle] -> [Particle] +nubParticles = nubBy (\((p1 :*: _) :*: _) -> + \((p2 :*: _) :*: _) -> epsilonEqual p1 p2) + + +-- Test whether the Manhattan distance between two points is smaller than +-- `epsilon'. +-- +epsilonEqual :: Point -> Point -> Bool +epsilonEqual (x1 :*: y1) (x2 :*: y2) = abs (x1 - x2) + abs (y1 - y2) < epsilon + + +-- Calculates the centroid of a list of mass points. +-- +centroid :: [MassPoint] -> MassPoint +centroid mps = let + m = sum [m | _ :*: m <- mps] + (wxs, wys) = unzip [(m * x, m * y) | (x :*: y) :*: m <- mps] + in + ((sum wxs / m) :*: (sum wys / m)) :*: m +-- Calculates the total momentum. +-- +totalMomentum :: [Particle] -> (Point :*: Double) +totalMomentum ps = + let + m = sum [m | ((_ :*: m) :*: _) <- ps] + (wxs, wys) = unzip [(m * x, m * y) | (_ :*: m) :*: (x:*: y) <- ps] + in + ((sum wxs / m :*: sum wys / m) :*: m) + +-- translate a particle +-- +translate :: Point -> Particle -> Particle +translate (dx :*: dy) (((x :*: y) :*: m) :*: vxy) = + ((x + dx :*: y + dy) :*: m) :*: vxy + +-- translate the velocity of particle +-- +translateVel :: Point -> Particle -> Particle +translateVel (dvx :*: dvy) (mp :*: (vx :*: vy)) = + mp :*: (vx + dvx :*: vy + dvy) + + + +showBHTree:: BHTree -> String +showBHTree treeLevels = "Tree:" ++ concat (map showBHTreeLevel treeLevels) + +showBHTreeLevel (massPnts, cents) = "\t" ++ show massPnts ++ "\n\t" ++ + show cents ++ "\n" ++ "\t\t|\n\t\t|\n" diff --git a/examples/barhesHut/BarnesHutSeq.hs b/examples/barhesHut/BarnesHutSeq.hs new file mode 100644 --- /dev/null +++ b/examples/barhesHut/BarnesHutSeq.hs @@ -0,0 +1,196 @@ +{-# GHC_OPTIONS -fglasgow-exts #-} +module BarnesHutSeq + +where +import Data.Array.Parallel.Unlifted +import BarnesHutGen + + + + + +-- Phase 1: building the tree +-- +{- +-- Split massPoints according to their locations in the quadrants +-- +splitPoints:: BoundingBox -> UArr MassPoint -> SUArr MassPoint +splitPoints (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) particles + | noOfPoints == 0 = singletonSU particles + | otherwise = singletonSU lls +:+^ singletonSU lus +:+^ singletonSU rus +:+^ singletonSU rls + where + noOfPoints = lengthU particles + lls = filterU (inBox (ll :*: mid)) particles + lus = filterU (inBox ((llx :*: midy) :*: (midx :*: ruy ))) particles + rus = filterU (inBox (mid :*: ru )) particles + rls = filterU (inBox ((midx :*: lly) :*: (rux :*: midy))) particles + + mid@(midx :*: midy) = ((llx + rux)/2.0) :*: ((lly + ruy)/2.0) + + +-} + +splitPointsL:: UArr BoundingBox -> SUArr MassPoint -> BHTree +splitPointsL bboxes particless + | lengthSU multiparticles == 0 = [(centroids, toU [])] + | otherwise = (centroids, lengthsSU multiparticles) : + (splitPointsL newBoxes multiparticles) + where + -- calculate centroid of each segment + centroids = + calcCentroids $ segmentArrU nonEmptySegd $ flattenSU particless + + -- remove empty segments + multiPointFlags = mapU ((>1)) $ lengthsSU particless + multiparticles = (splitPointsL' llbb lubb rubb rlbb) $ + packCU multiPointFlags particless + bboxes' = packU bboxes multiPointFlags + + nonEmptySegd = filterU ((>0)) $ lengthsSU particless + + -- split each box in four sub-boxes + newBoxes = merge4 llbb lubb rubb rlbb + + llbb = mapU makells bboxes' + lubb = mapU makelus bboxes' + rubb = mapU makerus bboxes' + rlbb = mapU makerls bboxes' + + makells (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) = + ll :*: (((llx + rux)/2.0) :*: (((lly + ruy)/2.0))) + makelus (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) = + (llx :*: ((lly + ruy)/2.0)) :*: (((llx + rux)/2.0) :*: ruy ) + makerus (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) = + (((llx + rux)/2.0) :*: ((lly + ruy)/2.0)) :*: ru + makerls (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) = + ((((llx + rux)/2.0) :*: lly) :*: (rux :*: ((lly + ruy)/2.0))) + +splitPointsL':: UArr BoundingBox -> + UArr BoundingBox -> + UArr BoundingBox -> + UArr BoundingBox -> + SUArr MassPoint -> + SUArr MassPoint +splitPointsL' llbb lubb rubb rlbb particless + | particlessLen == 0 = particless + | otherwise = orderedPoints + where + + -- each segment split into four subsegments with particles located in + -- the four quadrants + orderedPoints = + segmentArrU newLengths $ + flattenSU $ llsPs ^+:+^ lusPs ^+:+^ rusPs ^+:+^ rlsPs + particlessLen = lengthSU particless + pssLens = lengthsSU particless + lls = replicateSU pssLens llbb + lus = replicateSU pssLens lubb + rus = replicateSU pssLens rubb + rls = replicateSU pssLens rlbb + + + llsPs = mapSU sndS $ filterSU (uncurryS inBox) + (zipSU (replicateSU pssLens llbb) particless) + lusPs = mapSU sndS $ filterSU (uncurryS inBox) + (zipSU (replicateSU pssLens lubb) particless) + rusPs = mapSU sndS $ filterSU (uncurryS inBox) + (zipSU (replicateSU pssLens rubb) particless) + rlsPs = mapSU sndS $ filterSU (uncurryS inBox) + (zipSU (replicateSU pssLens rlbb) particless) + + newLengths = + merge4 (lengthsSU llsPs) (lengthsSU lusPs) + (lengthsSU rusPs) (lengthsSU rlsPs) + + +-- Calculate centroid of each subarray +-- +calcCentroids:: SUArr MassPoint -> UArr MassPoint +calcCentroids orderedPoints = centroids + where + ms = foldSU (+) 0.0 $ sndSU orderedPoints + centroids = zipWithU div' ms $ + foldSU pairP (0.0 :*: 0.0) $ + zipWithSU multCoor orderedPoints + (replicateSU (lengthsSU orderedPoints) ms) + div' m (x :*: y) = ((x/m :*: y/m) :*: m) + multCoor ((x :*: y) :*: _) m = (m * x :*: m * y) + + pairP (x1 :*: y1) (x2 :*: y2) = ((x1+x2) :*: (y1 + y2)) + + + +-- phase 2: +-- calculating the velocities + +calcAccel:: BHTree -> UArr MassPoint -> UArr (Double :*: Double) +calcAccel [] particles + | lengthU particles == 0 = emptyU + | otherwise = error $ "calcVelocity: reached empty tree" ++ (show particles) +calcAccel ((centroids, segd) :trees) particles = closeAccel + where + + closeAccel = splitApplyU particlesClose + ((calcAccel trees) . sndU ) + calcFarAccel + (zipU + (flattenSU $ replicateCU (lengthU particles) centroids) + (flattenSU $ replicateSU segd particles)) + particlesClose (((x1 :*: y1):*: _) :*: ((x2 :*: y2) :*: _)) = + (x1-x2)^2 + (y1-y2)^2 < eClose + +calcFarAccel:: UArr (MassPoint :*: MassPoint) -> UArr Accel +calcFarAccel = mapU accel + +-- +-- +accel:: MassPoint :*: MassPoint -> Accel +accel (((x1:*: y1) :*: m) :*: + ((x2:*: y2) :*: _)) | r < epsilon = (0.0 :*: 0.0) + | otherwise = (aabs * dx / r :*: aabs * dy / r) + where + rsqr = (dx * dx) + (dy * dy) + r = sqrt rsqr + dx = x1 - x2 + dy = y1 - y2 + aabs = m / rsqr + + + + + +-- assumes all arr have the same length +-- result [a11, a21, a31, a41, a12, a22....] +merge4:: UA a => + UArr a ->UArr a ->UArr a ->UArr a ->UArr a +merge4 a1 a2 a3 a4 = + combineU flags3 (combineU flags2 (combineU flags1 a1 a2) a3) a4 + where + flags1 = mapU even $ enumFromToU 0 (2 * len-1) + flags2 = mapU (\x -> mod x 3 /= 2) $ enumFromToU 0 (3 * len-1) + flags3 = mapU (\x -> mod x 4 /= 3) $ enumFromToU 0 (4 * len-1) + len = lengthU a1 + +-- checks if particle is in box (excluding left and lower border) +inBox:: BoundingBox -> MassPoint -> Bool +inBox ((ll@(llx :*: lly) :*: ru@(rux :*: ruy))) ((px :*: py) :*: _) = + (px > llx) && (px <= rux) && (py > lly) && (py <= ruy) + + +splitApplyU:: (UA e, UA e') => (e -> Bool) -> (UArr e -> UArr e') -> (UArr e -> UArr e') -> UArr e -> UArr e' +splitApplyU p f1 f2 xsArr = combineU (mapU p xsArr) res1 res2 + where + res1 = f1 $ filterU p xsArr + res2 = f2 $ filterU (not . p) xsArr + +splitApplySU:: (UA e, UA e') => UArr Bool -> (SUArr e -> SUArr e') -> (SUArr e -> SUArr e') -> SUArr e -> SUArr e' +{-# INLINE splitApplySU #-} +splitApplySU flags f1 f2 xssArr = combineCU flags res1 res2 + where + res1 = f1 $ packCU flags xssArr + res2 = f2 $ packCU (mapU not flags) xssArr + + + + + diff --git a/examples/concomp/AwShU.hs b/examples/concomp/AwShU.hs new file mode 100644 --- /dev/null +++ b/examples/concomp/AwShU.hs @@ -0,0 +1,45 @@ +module AwShU ( aw_connected_components ) +where + +import Data.Array.Parallel.Unlifted + +starCheck :: UArr Int -> UArr Bool +starCheck ds = + let gs = bpermuteU ds ds + st = zipWithU (==) ds gs + st' = updateU st . filterU (not . sndS) + $ zipU gs st + in + bpermuteU st' gs + +conComp :: UArr Int -> UArr (Int :*: Int) -> Int :*: UArr Int +conComp ds es = + let es1 :*: es2 = unzipU es + ds' = updateU ds + . mapU (\(di :*: dj :*: gi) -> (di :*: dj)) + . filterU (\(di :*: dj :*: gi) -> gi == di && di > dj) + $ zip3U (bpermuteU ds es1) + (bpermuteU ds es2) + (bpermuteU ds (bpermuteU ds es1)) + ds'' = updateU ds' + . mapU (\(di :*: dj :*: st) -> (di :*: dj)) + . filterU (\(di :*: dj :*: st) -> st && di /= dj) + $ zip3U (bpermuteU ds' es1) + (bpermuteU ds' es2) + (bpermuteU (starCheck ds') es1) + in + if andU (starCheck ds'') + then 1 :*: ds'' + else rec $ conComp (bpermuteU ds'' ds'') es + where + rec (n :*: arr) = n+1 :*: arr + +aw_connected_components :: UArr (Int :*: Int) -> Int -> Int :*: UArr Int +{-# NOINLINE aw_connected_components #-} +aw_connected_components es n = + let ds = enumFromToU 0 (n-1) +:+ enumFromToU 0 (n-1) + es' = es +:+ mapU (\(j :*: i) -> i :*: j) es + r :*: cs = conComp ds es' + in + r :*: cs + diff --git a/examples/concomp/AwShUP.hs b/examples/concomp/AwShUP.hs new file mode 100644 --- /dev/null +++ b/examples/concomp/AwShUP.hs @@ -0,0 +1,46 @@ +module AwShUP ( aw_connected_components ) +where + +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Parallel + +starCheck :: UArr Int -> UArr Bool +starCheck ds = + let gs = bpermuteUP ds ds + st = zipWithUP (==) ds gs + st' = updateUP st . filterUP (not . sndS) + $ zipU gs st + in + bpermuteUP st' gs + +conComp :: UArr Int -> UArr (Int :*: Int) -> Int :*: UArr Int +conComp ds es = + let es1 :*: es2 = unzipU es + ds' = updateUP ds + . mapUP (\(di :*: dj :*: gi) -> (di :*: dj)) + . filterUP (\(di :*: dj :*: gi) -> gi == di && di > dj) + $ zip3U (bpermuteUP ds es1) + (bpermuteUP ds es2) + (bpermuteUP ds (bpermuteUP ds es1)) + ds'' = updateUP ds' + . mapUP (\(di :*: dj :*: st) -> (di :*: dj)) + . filterUP (\(di :*: dj :*: st) -> st && di /= dj) + $ zip3U (bpermuteUP ds' es1) + (bpermuteUP ds' es2) + (bpermuteUP (starCheck ds') es1) + in + if andUP (starCheck ds'') + then 1 :*: ds'' + else rec $ conComp (bpermuteUP ds'' ds'') es + where + rec (n :*: arr) = n+1 :*: arr + +aw_connected_components :: UArr (Int :*: Int) -> Int -> Int :*: UArr Int +{-# NOINLINE aw_connected_components #-} +aw_connected_components es n = + let ds = enumFromToU 0 (n-1) +:+ enumFromToU 0 (n-1) + es' = es +:+ mapU (\(j :*: i) -> i :*: j) es + r :*: cs = conComp ds es' + in + r :*: cs + diff --git a/examples/concomp/Graph.hs b/examples/concomp/Graph.hs new file mode 100644 --- /dev/null +++ b/examples/concomp/Graph.hs @@ -0,0 +1,41 @@ +module Graph +where + +import Data.Array.Parallel.Unlifted + +import System.IO +import Foreign + +data Graph = Graph { nodeCount :: Int + , edgeCount :: Int + , edges :: UArr (Int :*: Int) + } + deriving(Read,Show) + +hPutGraph :: Handle -> Graph -> IO () +hPutGraph h (Graph { nodeCount = n, edgeCount = e, edges = edges }) + = alloca $ \iptr -> + do + poke iptr n + hPutBuf h iptr (sizeOf n) + poke iptr e + hPutBuf h iptr (sizeOf e) + hPutU h edges + +hGetGraph :: Handle -> IO Graph +hGetGraph h + = alloca $ \iptr -> + do + hGetBuf h iptr (sizeOf (undefined :: Int)) + n <- peek iptr + hGetBuf h iptr (sizeOf (undefined :: Int)) + e <- peek iptr + edges <- hGetU h + return $ Graph { nodeCount = n, edgeCount = e, edges = edges } + +storeGraph :: FilePath -> Graph -> IO () +storeGraph file g = withBinaryFile file WriteMode (`hPutGraph` g) + +loadGraph :: FilePath -> IO Graph +loadGraph file = withBinaryFile file ReadMode hGetGraph + diff --git a/examples/concomp/HybU.hs b/examples/concomp/HybU.hs new file mode 100644 --- /dev/null +++ b/examples/concomp/HybU.hs @@ -0,0 +1,49 @@ +module HybU ( hybrid_connected_components ) +where + +import Data.Array.Parallel.Unlifted + +enumerate :: UArr Bool -> UArr Int +{-# INLINE enumerate #-} +enumerate = scanU (+) 0 . mapU (\b -> if b then 1 else 0) + +pack_index :: UArr Bool -> UArr Int +{-# INLINE pack_index #-} +pack_index bs = mapU fstS . filterU sndS $ zipU (enumFromToU 0 (lengthU bs - 1)) + bs + +shortcut_all :: UArr Int -> UArr Int +shortcut_all p = let pp = bpermuteU p p + in if p == pp then pp else shortcut_all pp + +compress_graph :: UArr Int -> UArr (Int :*: Int) + -> UArr (Int :*: Int) :*: UArr Int +compress_graph p e = + let e1 :*: e2 = unzipU e + e' = zipU (bpermuteU p e1) (bpermuteU p e2) + e'' = mapU (\(i :*: j) -> if i > j then j :*: i else i :*: j) + . filterU (\(i :*: j) -> i /= j) + $ e' + + roots = zipWithU (==) p (enumFromToU 0 (lengthU p - 1)) + labels = enumerate roots + e1'' :*: e2'' = unzipU e'' + e''' = zipU (bpermuteU labels e1'') (bpermuteU labels e2'') + in + e''' :*: pack_index roots + +hybrid_connected_components :: UArr (Int :*: Int) -> Int -> Int :*: UArr Int +{-# NOINLINE hybrid_connected_components #-} +hybrid_connected_components e n + | nullU e = 0 :*: enumFromToU 0 (n-1) + | otherwise = let p = shortcut_all + $ updateU (enumFromToU 0 (n-1)) e + e' :*: i = compress_graph p e + k :*: r = hybrid_connected_components e' (lengthU i) + ins = updateU p + . zipU i + $ bpermuteU i r + in + k+1 :*: bpermuteU ins ins + + diff --git a/examples/concomp/HybUP.hs b/examples/concomp/HybUP.hs new file mode 100644 --- /dev/null +++ b/examples/concomp/HybUP.hs @@ -0,0 +1,51 @@ +module HybUP ( hybrid_connected_components ) +where + +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Parallel + +enumerate :: UArr Bool -> UArr Int +{-# INLINE enumerate #-} +enumerate = scanUP (+) 0 . mapUP (\b -> if b then 1 else 0) + +pack_index :: UArr Bool -> UArr Int +{-# INLINE pack_index #-} +pack_index bs = mapUP fstS + . filterUP sndS + $ zipU (enumFromToUP 0 (lengthU bs - 1)) + bs + +shortcut_all :: UArr Int -> UArr Int +shortcut_all p = let pp = bpermuteUP p p + in if p == pp then pp else shortcut_all pp + +compress_graph :: UArr Int -> UArr (Int :*: Int) + -> UArr (Int :*: Int) :*: UArr Int +compress_graph p e = + let e1 :*: e2 = unzipU e + e' = zipU (bpermuteUP p e1) (bpermuteUP p e2) + e'' = mapUP (\(i :*: j) -> if i > j then j :*: i else i :*: j) + . filterUP (\(i :*: j) -> i /= j) + $ e' + + roots = zipWithUP (==) p (enumFromToUP 0 (lengthU p - 1)) + labels = enumerate roots + e1'' :*: e2'' = unzipU e'' + e''' = zipU (bpermuteUP labels e1'') (bpermuteUP labels e2'') + in + e''' :*: pack_index roots + +hybrid_connected_components :: UArr (Int :*: Int) -> Int -> Int :*: UArr Int +{-# NOINLINE hybrid_connected_components #-} +hybrid_connected_components e n + | nullU e = 0 :*: enumFromToUP 0 (n-1) + | otherwise = let p = shortcut_all + $ updateUP (enumFromToUP 0 (n-1)) e + e' :*: i = compress_graph p e + k :*: r = hybrid_connected_components e' (lengthU i) + ins = updateUP p + . zipU i + $ bpermuteUP i r + in + k+1 :*: bpermuteUP ins ins + diff --git a/examples/concomp/Makefile b/examples/concomp/Makefile new file mode 100644 --- /dev/null +++ b/examples/concomp/Makefile @@ -0,0 +1,12 @@ +TESTDIR = .. +PROGS = mkg concomp +include $(TESTDIR)/mk/test.mk + +ALGS = AwShU.hs AwShUP.hs HybU.hs HybUP.hs + +mkg.o: Graph.hi +mkg: Graph.o + +concomp.o: Graph.hi $(ALGS:.hs=.hi) +concomp: Graph.o $(ALGS:.hs=.o) + diff --git a/examples/concomp/README b/examples/concomp/README new file mode 100644 --- /dev/null +++ b/examples/concomp/README @@ -0,0 +1,26 @@ +Connected components in undirected graphs +========================================= + +This benchmark implements the Awerbuch-Shiloach and Hybrid algorithms for +finding connected components in undirected graphs from +http://www.cs.cmu.edu/~scandal/nesl/algorithms.html#concomp + +Generating test data +-------------------- + +The utility mkg generates random test graphs. Call it with + + mkg NODES EDGES > FILE + +where NODES and EDGES determine the number of nodes and edges, respectively. + +Running the benchmark +--------------------- + +concomp --help displays the available options. + +The following algorithms are supported: + + awshu, awshup - Awerbuch-Shiloach (sequential and parallel version) + hybu, hybup - Hybrid (sequential and parallel version) + diff --git a/examples/concomp/concomp.hs b/examples/concomp/concomp.hs new file mode 100644 --- /dev/null +++ b/examples/concomp/concomp.hs @@ -0,0 +1,57 @@ +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Distributed +import Graph +import qualified AwShU +import qualified AwShUP +import qualified HybU +import qualified HybUP + +import System.Console.GetOpt +import System.IO +import Control.Exception (evaluate) + +import Bench.Benchmark +import Bench.Options + + +type Alg = UArr (Int :*: Int) -> Int -> Int :*: UArr Int + +algs = [("awshu", AwShU.aw_connected_components) + ,("awshup", AwShUP.aw_connected_components) + ,("hybu", HybU.hybrid_connected_components) + ,("hybup", HybUP.hybrid_connected_components) + ] + +main = ndpMain "Connected components" + "[OPTION] ... FILES ..." + run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") + "use the specified algorithm"] + "" + +run opts alg files = + case lookup alg algs of + Just f -> procFiles opts f files + Nothing -> failWith ["Unknown algorithm " ++ alg] + +procFiles :: Options -> Alg -> [String] -> IO () +procFiles opts alg fs = + do + benchmark opts (uncurry alg) + (map load $ files fs) + showRes + return () + where + files [] = [""] + files fs = fs + + showRes (r :*: _) = "d=" ++ show r + +load :: String -> IO (Point (UArr (Int :*: Int), Int)) +load fname = + do + g <- loadGraph fname + evaluate (edges g) + return $ mkPoint ( "n=" ++ show (nodeCount g) ++ ", " + ++ "e=" ++ show (edgeCount g)) + (edges g, nodeCount g) + diff --git a/examples/concomp/mkg.hs b/examples/concomp/mkg.hs new file mode 100644 --- /dev/null +++ b/examples/concomp/mkg.hs @@ -0,0 +1,55 @@ +import Data.Array.ST +import Data.Array +import System.Random +import System.IO +import System.Exit +import System.Environment + +import Data.Array.Parallel.Unlifted +import Graph + +randomG :: RandomGen g => g -> Int -> Int -> Graph +randomG g n e = Graph n e ues + where + aes = runSTArray (do + arr <- newArray (0,n-1) [] + fill arr (randomRs (0,n-1) g) e + ) + + fill arr _ 0 = return arr + fill arr (m:n:rs) e = + let lo = min m n + hi = max m n + in + do + ns <- readArray arr lo + if lo == hi || hi `elem` ns + then fill arr rs e + else do + writeArray arr lo (hi : ns) + fill arr rs (e-1) + + + ues = toU $ concat [map (m :*:) ns | (m,ns) <- assocs aes] + +main = do + args <- getArgs + (n,e,file) <- parseArgs args + g <- newStdGen + storeGraph file $ randomG g n e + where + parseArgs [nodes,edges,file] = + do + n <- parseInt nodes + e <- parseInt edges + return (n,e,file) + parseArgs _ = do + hPutStrLn stderr "Invalid arguments" + exitFailure + + parseInt s = case reads s of + ((n,_) : _) -> return n + _ -> do + hPutStrLn stderr $ "Invalid argument " ++ s + exitFailure + diff --git a/examples/dotp/DotPPar.hs b/examples/dotp/DotPPar.hs new file mode 100644 --- /dev/null +++ b/examples/dotp/DotPPar.hs @@ -0,0 +1,9 @@ +module DotPPar where + +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Parallel + +dotp :: UArr Double -> UArr Double -> Double +{-# NOINLINE dotp #-} +dotp v w = sumUP (zipWithUP (*) v w) + diff --git a/examples/dotp/DotPSeq.hs b/examples/dotp/DotPSeq.hs new file mode 100644 --- /dev/null +++ b/examples/dotp/DotPSeq.hs @@ -0,0 +1,8 @@ +module DotPSeq where + +import Data.Array.Parallel.Unlifted + +dotp :: UArr Double -> UArr Double -> Double +{-# NOINLINE dotp #-} +dotp v w = sumU (zipWithU (*) v w) + diff --git a/examples/dotp/DotPVect.hs b/examples/dotp/DotPVect.hs new file mode 100644 --- /dev/null +++ b/examples/dotp/DotPVect.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PArr #-} +{-# OPTIONS -fvectorise #-} +module DotPVect where + +import Data.Array.Parallel.Prelude +import Data.Array.Parallel.Prelude.Double + +import qualified Prelude + +dotp :: PArray Double -> PArray Double -> Double +{-# NOINLINE dotp #-} +dotp v w = dotp' (fromPArrayP v) (fromPArrayP w) + +dotp' :: [:Double:] -> [:Double:] -> Double +dotp' v w = sumP (zipWithP (*) v w) + diff --git a/examples/dotp/Makefile b/examples/dotp/Makefile new file mode 100644 --- /dev/null +++ b/examples/dotp/Makefile @@ -0,0 +1,8 @@ +TESTDIR = .. +PROGS = dotp +include $(TESTDIR)/mk/test.mk + +dotp.o: DotPSeq.hi DotPPar.hi DotPVect.hi + +dotp: DotPSeq.o DotPPar.o DotPVect.o $(BENCHLIB) + diff --git a/examples/dotp/README b/examples/dotp/README new file mode 100644 --- /dev/null +++ b/examples/dotp/README @@ -0,0 +1,11 @@ +Dot product +=========== + +dotp --help displays the available options. + +The following algorithms are supported: + + seq - sequential implementation + par - parallel implementation + vect - vectorised implementation + diff --git a/examples/dotp/dotp.hs b/examples/dotp/dotp.hs new file mode 100644 --- /dev/null +++ b/examples/dotp/dotp.hs @@ -0,0 +1,65 @@ +import qualified DotPSeq +import qualified DotPPar +import qualified DotPVect + +import Control.Exception (evaluate) +import System.Console.GetOpt +import System.Random + +import Data.Array.Parallel.Prelude (fromUArrPA') +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Distributed + +import Bench.Benchmark +import Bench.Options + +algs = [("par", DotPPar.dotp) + ,("seq", DotPSeq.dotp) + ,("list", dotp_list) + ,("vect", dotp_vect)] + +type Vector = UArr Double + +dotp_vect :: Vector -> Vector -> Double +dotp_vect xs ys = DotPVect.dotp (fromUArrPA' xs) (fromUArrPA' ys) + + +dotp_list:: Vector -> Vector -> Double +dotp_list xs ys = sum $ zipWith (*) (fromU xs) (fromU ys) +-- generates a random vector of the given length in NF +-- +generateVector :: Int -> IO Vector +generateVector n = + do + rg <- newStdGen + let fs = take n $ randomRs (-100, 100) rg + vec = toU fs + evaluate vec + return vec + +generateVectors :: Int -> IO (Point (Vector, Vector)) +generateVectors n = + do + v <- generateVector n + w <- generateVector n + return $ ("N = " ++ show n) `mkPoint` (v,w) + + +main = ndpMain "Dot product" + "[OPTION] ... SIZES ..." + run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") + "use the specified algorithm"] + "par" + +run opts alg sizes = + case lookup alg algs of + Nothing -> failWith ["Unknown algorithm"] + Just f -> case map read sizes of + [] -> failWith ["No sizes specified"] + szs -> do + benchmark opts (uncurry f) + (map generateVectors szs) + show + return () + + diff --git a/examples/fusion/DotP.hs b/examples/fusion/DotP.hs new file mode 100644 --- /dev/null +++ b/examples/fusion/DotP.hs @@ -0,0 +1,8 @@ +module DotP where +import Data.Array.Vector + +-- > 1 loopU/loopU + +dotp :: UArr Double -> UArr Double -> Double +dotp v w = sumU (zipWithU (*) v w) + diff --git a/examples/fusion/Map_Map.hs b/examples/fusion/Map_Map.hs new file mode 100644 --- /dev/null +++ b/examples/fusion/Map_Map.hs @@ -0,0 +1,8 @@ +module Map_Map where +import Data.Array.Vector + +-- > 1 loopU/loopU + +map_map :: (Int -> Int) -> (Int -> Int) -> UArr Int -> UArr Int +map_map f g = mapU f . mapU g + diff --git a/examples/fusion/Map_Map_Replicate.hs b/examples/fusion/Map_Map_Replicate.hs new file mode 100644 --- /dev/null +++ b/examples/fusion/Map_Map_Replicate.hs @@ -0,0 +1,9 @@ +module Map_Map_Replicate where +import Data.Array.Vector + +-- > 2 loopU/loopU + +map_map_replicate :: (UA a, UA b, UA c) + => (b -> c) -> (a -> b) -> Int -> a -> UArr c +map_map_replicate f g n = mapU f . mapU g . replicateU n + diff --git a/examples/fusion/Map_Replicate.hs b/examples/fusion/Map_Replicate.hs new file mode 100644 --- /dev/null +++ b/examples/fusion/Map_Replicate.hs @@ -0,0 +1,8 @@ +module Map_Replicate where +import Data.Array.Vector + +-- > 1 loopU/loopU + +map_replicate :: (UA a, UA b) => (a -> b) -> Int -> a -> UArr b +map_replicate f n = mapU f . replicateU n + diff --git a/examples/fusion/runtst.sh b/examples/fusion/runtst.sh new file mode 100644 --- /dev/null +++ b/examples/fusion/runtst.sh @@ -0,0 +1,52 @@ +#! /bin/bash + +GHC=ghc +OPTS="--make\ + -fglasgow-exts -O2 -funbox-strict-fields\ + -fliberate-case-threshold100 -fno-method-sharing" + +verbose=yes +tests= + +exec 6> /dev/null + +for arg +do + case $arg in + --verbose|-v) exec 6>&1 + ;; + *) tests="$tests $arg" + ;; + esac +done + +tests=${tests:=`ls *.hs`} + +for file in $tests +do + echo Testing $file >&6 + rules=`sed -n 's/-- >[[:space:]]*\([0-9]\+\)[[:space:]]\+\([^[:space:]]\+\)/\1 \2/p' $file` + log=`echo $file | sed 's/\.hs$/.log/'` + echo "$GHC $OPTS -c $file -ddump-simpl-stats" >&6 + if $GHC $OPTS -c $file -ddump-simpl-stats > $log + then + oldIFS=$IFS + IFS=' +' + for rule in `sed -n 's/-- >[[:space:]]*\([0-9]\+\)[[:space:]]\+\([^[:space:]]\+\)/\1 \2/p' $file` + do + if ! grep "$rule" $log > /dev/null 2>&1 + then + echo "FAIL: $file ($rule)" + break + else + echo "OK" + fi + done + IFS=$oldIFS + else + echo FAIL: $file - compiler error + fi +done +rm -f *.hi *.o + diff --git a/examples/lib/Bench/Benchmark.hs b/examples/lib/Bench/Benchmark.hs new file mode 100644 --- /dev/null +++ b/examples/lib/Bench/Benchmark.hs @@ -0,0 +1,114 @@ +module Bench.Benchmark +where + +import Bench.Time (Time, getTime) +import qualified Bench.Time as T + +import Bench.Options (Options(..)) + +import System.IO +import System.Mem (performGC) + +newtype Timing a = Timing [(a, Time)] + +time :: IO a -> IO (a, Time) +{-# NOINLINE time #-} +time p = do + start <- getTime + x <- p + end <- getTime + return (x, end `T.minus` start) + +time_ :: IO a -> IO Time +time_ = fmap snd . time + +timeFn :: (a -> b) -> a -> IO (b, Time) +{-# NOINLINE timeFn #-} +timeFn f x = time (return $! f x) + +timeFn_ :: (a -> b) -> a -> IO Time +timeFn_ f = fmap snd . timeFn f + +showTime :: Time -> String +showTime t = (show $ T.wallTime T.milliseconds t) + ++ "/" + ++ (show $ T.cpuTime T.milliseconds t) + +showTimes :: [Time] -> String +showTimes ts = unwords [ showTime (T.minimum ts) + , showTime (T.average ts) + , showTime (T.maximum ts) + ] + +type Msg a = a -> [(Int -> Bool, IO ())] + +say :: String -> IO () +say s = do + hPutStr stdout s + hFlush stdout + +sayLn :: String -> IO () +sayLn s = do + hPutStrLn stdout s + hFlush stdout + +msgRun :: Msg Int +msgRun n = [((==2), say ".") + ,((>2), say $ " run " ++ show n ++ ": ")] + +msgResult :: Msg (Time, String) +msgResult (t,s) = [((==3), sayLn $ showTime t) + ,((>3), sayLn $ showTime t ++ " (" ++ s ++ ")")] + +msgPoint :: Msg String +msgPoint s = [((==1), say $ s ++ ": ") + ,((==2), say $ s ++ " ") + ,((>2), sayLn $ s ++ " ...")] + +msgTiming :: Msg String +msgTiming s = [((==1), sayLn s) + ,((==2), sayLn $ " " ++ s) + ,((>2), sayLn $ "... " ++ s)] + +message :: Msg a -> Options -> a -> IO () +message msg opts x = case [p | (f,p) <- msg x, f (optVerbosity opts)] of + [] -> return () + (p:_) -> p + +benchmark' :: Options -> (a -> b) -> a -> (b -> String) -> IO [Time] +benchmark' opts f x outp = sequence $ map bench1 [1 .. optRuns opts] + where + bench1 n = + do + message msgRun opts n + performGC + (x, t) <- timeFn f x + message msgResult opts (t, outp x) + return t + +data Point a = Point String a + +point :: Show a => a -> Point a +point = labelPoint show + +labelPoint :: (a -> String) -> a -> Point a +labelPoint f x = Point (f x) x + +mkPoint :: String -> a -> Point a +mkPoint s x = Point s x + +benchmark :: Options + -> (a -> b) + -> [IO (Point a)] + -> (b -> String) + -> IO [[Time]] +benchmark o f ps outp = mapM bench1 ps + where + bench1 p = + do + Point s x <- p + message msgPoint o s + ts <- benchmark' o f x outp + message msgTiming o $ showTimes ts + return ts + diff --git a/examples/lib/Bench/Options.hs b/examples/lib/Bench/Options.hs new file mode 100644 --- /dev/null +++ b/examples/lib/Bench/Options.hs @@ -0,0 +1,84 @@ +module Bench.Options ( + Options(..), + ndpMain, failWith +) where + +import System.Console.GetOpt +import System.IO +import System.Exit +import System.Environment + +import Data.Array.Parallel.Unlifted.Distributed + +data Options = Options { optRuns :: Int + , optVerbosity :: Int + , optSetGang :: IO () + , optHelp :: Bool + } + +defaultVerbosity :: Int +defaultVerbosity = 1 + +defaultOptions :: Options +defaultOptions = Options { optRuns = 1 + , optVerbosity = defaultVerbosity + , optSetGang = setSequentialGang 1 + , optHelp = False + } + +options = [Option ['r'] ["runs"] + (ReqArg (\s o -> o { optRuns = read s }) "N") + "repeat each benchmark N times" + ,Option ['v'] ["verbose"] + (OptArg (\r o -> o { optVerbosity = maybe defaultVerbosity read r }) + "N") + "verbosity level" + ,Option ['t'] ["threads"] + (ReqArg (\s o -> o { optSetGang = setGang (read s)}) "N") + "use N threads" + ,Option ['s'] ["seq"] + (OptArg (\r o -> o { optSetGang = setSequentialGang + (maybe 1 read r) }) "N") + "simulate N threads (default 1)" + ,Option ['h'] ["help"] + (NoArg (\o -> o { optHelp = True })) + "show help screen" + ] + +instance Functor OptDescr where + fmap f (Option c s d h) = Option c s (fmap f d) h + +instance Functor ArgDescr where + fmap f (NoArg x) = NoArg (f x) + fmap f (ReqArg g s) = ReqArg (f . g) s + fmap f (OptArg g s) = OptArg (f . g) s + +ndpMain :: String -> String + -> (Options -> a -> [String] -> IO ()) + -> [OptDescr (a -> a)] -> a + -> IO () +ndpMain descr hdr run options' dft = + do + args <- getArgs + case getOpt Permute opts args of + (fs, files, []) -> + let (os, os') = foldr ($) (defaultOptions, dft) fs + in + if optHelp os + then do + s <- getProgName + putStrLn $ usageInfo ("Usage: " ++ s ++ " " ++ hdr ++ "\n" + ++ descr ++ "\n") opts + else do + optSetGang os + run os os' files + (_, _, errs) -> failWith errs + where + opts = [fmap (\f (r,s) -> (f r, s)) d | d <- options] + ++ [fmap (\f (r,s) -> (r, f s)) d | d <- options'] + +failWith :: [String] -> IO a +failWith errs = do + mapM_ (hPutStrLn stderr) errs + exitFailure + diff --git a/examples/lib/Bench/Time.hs b/examples/lib/Bench/Time.hs new file mode 100644 --- /dev/null +++ b/examples/lib/Bench/Time.hs @@ -0,0 +1,96 @@ +module Bench.Time ( + Time, + getTime, + wallTime, cpuTime, + picoseconds, milliseconds, seconds, + + minus, plus, div, + min, max, avg, + sum, minimum, maximum, average +) where + +import System.CPUTime +import System.Time + +import Prelude hiding( div, min, max, sum, minimum, maximum ) +import qualified Prelude as P + +infixl 6 `plus`, `minus` +infixl 7 `div` + +data Time = Time { cpu_time :: Integer + , wall_time :: Integer + } + +type TimeUnit = Integer -> Integer + +picoseconds :: TimeUnit +picoseconds = id + +milliseconds :: TimeUnit +milliseconds n = n `P.div` 1000000000 + +seconds :: TimeUnit +seconds n = n `P.div` 1000000000000 + +cpuTime :: TimeUnit -> Time -> Integer +cpuTime f = f . cpu_time + +wallTime :: TimeUnit -> Time -> Integer +wallTime f = f . wall_time + +getTime :: IO Time +getTime = + do + cpu <- getCPUTime + TOD sec pico <- getClockTime + return $ Time cpu (pico + sec * 1000000000000) + +{- +timeIO :: IO a -> IO (a, Time) +timeIO p = do + start <- getTime + x <- p + end <- getTime + return (x, end `minusT` start) + +timeIO_ :: IO () -> IO Time +timeIO_ = fmap snd . timeIO +-} + +zipT :: (Integer -> Integer -> Integer) -> Time -> Time -> Time +zipT f (Time cpu1 wall1) (Time cpu2 wall2) = + Time (f cpu1 cpu2) (f wall1 wall2) + +minus :: Time -> Time -> Time +minus = zipT (-) + +plus :: Time -> Time -> Time +plus = zipT (+) + +div :: Time -> Int -> Time +div (Time cpu clock) n = Time (cpu `P.div` n') (clock `P.div` n') + where + n' = toInteger n + +min :: Time -> Time -> Time +min = zipT P.min + +max :: Time -> Time -> Time +max = zipT P.max + +avg :: Time -> Time -> Time +avg t1 t2 = (t1 `plus` t2) `div` 2 + +sum :: [Time] -> Time +sum = foldr1 plus + +minimum :: [Time] -> Time +minimum = foldr1 min + +maximum :: [Time] -> Time +maximum = foldr1 max + +average :: [Time] -> Time +average ts = sum ts `div` length ts + diff --git a/examples/lib/Makefile b/examples/lib/Makefile new file mode 100644 --- /dev/null +++ b/examples/lib/Makefile @@ -0,0 +1,25 @@ +TESTDIR=.. +include $(TESTDIR)/mk/common.mk + +HCFLAGS = -O -package ndp + +.PHONY: clean all + +all: libNDPBench.a + +clean: + -$(RM) Bench/*.o Bench/*.hi libNDPBench.a + +libNDPBench.a: Bench/Benchmark.o Bench/Time.o Bench/Options.o + $(RM) $@ + $(AR) q $@ $^ + +%.o: %.hs + $(HC) -c $< $(HCFLAGS) $(FLAGS) + +%.hi: %.o + @: + +Bench/Benchmark.o: Bench/Time.hi Bench/Options.hi + + diff --git a/examples/mk/common.mk b/examples/mk/common.mk new file mode 100644 --- /dev/null +++ b/examples/mk/common.mk @@ -0,0 +1,10 @@ +NDPDIR = $(TESTDIR)/.. +NDPVERSION = 0.1 +BENCHDIR = $(TESTDIR)/lib + +NDPLIB = $(NDPDIR)/dist/build/libHSndp-$(NDPVERSION).a +BENCHLIB = $(BENCHDIR)/libNDPBench.a +HC = $(NDPDIR)/../../compiler/ghc-inplace + +include $(NDPDIR)/ndp.mk + diff --git a/examples/mk/test.mk b/examples/mk/test.mk new file mode 100644 --- /dev/null +++ b/examples/mk/test.mk @@ -0,0 +1,29 @@ +include $(TESTDIR)/mk/common.mk +HCFLAGS = $(NDPFLAGS) $(TESTFLAGS) -package ndp -no-recomp -i$(BENCHDIR) +HLDFLAGS += -L$(BENCHDIR) -lNDPBench + +.PHONY: clean all bench + +all: bench $(PROGS) + +clean: + -$(RM) *.hi *.o $(PROGS) + +%.o: %.hs $(NDPLIB) $(BENCHLIB) + $(HC) -c $< $(HCFLAGS) $(FLAGS) + +%.o: %.c + $(HC) -c $< $(HCCFLAGS) $(FLAGS) + +%: %.c + $(HC) -o $@ $(HCCFLAGS) $^ $(HLDFLAGS) + +%: %.o + $(HC) -o $@ $(HCFLAGS) $^ $(HLDFLAGS) + +%.hi: %.o + @: + +bench: + cd $(BENCHDIR) && $(MAKE) + diff --git a/examples/primes/H98.hs b/examples/primes/H98.hs new file mode 100644 --- /dev/null +++ b/examples/primes/H98.hs @@ -0,0 +1,19 @@ +module H98 +where + +import Data.Array + +primes :: Int -> [Int] +{-# NOINLINE primes #-} +primes n + | n <= 2 = [] + | otherwise = + let + sqrPrimes = primes (ceiling (sqrt (fromIntegral n))) + sieves = concat + [[2 * p, 3 * p..n - 1] | p <- sqrPrimes] + sieves' = zip sieves (repeat False) + flags = accumArray (&&) True (0, n - 1) sieves' + in + drop 2 (filter (flags!) [0..n - 1]) + diff --git a/examples/primes/Makefile b/examples/primes/Makefile new file mode 100644 --- /dev/null +++ b/examples/primes/Makefile @@ -0,0 +1,8 @@ +TESTDIR = .. +PROGS = primes +include $(TESTDIR)/mk/test.mk + +primes.o: H98.hi PrimSeq.hi PrimPar.hi + +primes: H98.o PrimSeq.o PrimPar.o + diff --git a/examples/primes/PrimPar.hs b/examples/primes/PrimPar.hs new file mode 100644 --- /dev/null +++ b/examples/primes/PrimPar.hs @@ -0,0 +1,32 @@ +module PrimPar +-- +-- TODO: +-- bpermuteDftU which does most of the work is still sequential + +where + +import Data.Array.Parallel.Unlifted.Distributed +import Data.Array.Parallel.Unlifted.Parallel +import Data.Array.Parallel.Unlifted + + +import Debug.Trace +primes :: Int -> UArr Int +{-# NOINLINE primes #-} +primes n + | n <= 2 = emptyU + | otherwise = + let + sqrPrimes = primes (ceiling (sqrt (fromIntegral n))) + sieves = concatSU $ + enumFromThenToSUP + (mapUP (*2) sqrPrimes) + (mapUP (*3) sqrPrimes) + (replicateUP (lengthU sqrPrimes) (n - 1)) + sieves' = zipU sieves (replicateUP (lengthU sieves) False) + flags = bpermuteDftU n (const True) sieves' + arg = flags `seq` (filterUP (flags!:) (enumFromToUP 0 (n - 1))) + in + dropUP 2 arg + + diff --git a/examples/primes/PrimSeq.hs b/examples/primes/PrimSeq.hs new file mode 100644 --- /dev/null +++ b/examples/primes/PrimSeq.hs @@ -0,0 +1,22 @@ +module PrimSeq +where + +import Data.Array.Parallel.Unlifted + +primes :: Int -> UArr Int +{-# NOINLINE primes #-} +primes n + | n <= 2 = emptyU + | otherwise = + let + sqrPrimes = primes (ceiling (sqrt (fromIntegral n))) + sieves = concatSU $ + enumFromThenToSU + (mapU (*2) sqrPrimes) + (mapU (*3) sqrPrimes) + (replicateU (lengthU sqrPrimes) (n - 1)) + sieves' = zipU sieves (replicateU (lengthU sieves) False) + flags = bpermuteDftU n (const True) sieves' + in + dropU 2 (filterU (flags!:) (enumFromToU 0 (n - 1))) + diff --git a/examples/primes/README b/examples/primes/README new file mode 100644 --- /dev/null +++ b/examples/primes/README @@ -0,0 +1,13 @@ +Sieve of Eratosthenes +===================== + +primes --help displays the available options. + +The following algorithms are supported: + + h98 - implementation based on standard Haskell arrays + seq - sequential implementation with UArrs + +No parallel implementation is available yet as the library is missing +functionality. + diff --git a/examples/primes/primes.hs b/examples/primes/primes.hs new file mode 100644 --- /dev/null +++ b/examples/primes/primes.hs @@ -0,0 +1,42 @@ +import Control.Exception (evaluate) +import System.Console.GetOpt + +import Data.Array.Parallel.Unlifted + +import Bench.Benchmark +import Bench.Options + +import qualified H98 +import qualified PrimSeq +import qualified PrimPar + +type Alg = Int -> () + +seqList :: [Int] -> () +seqList [] = () +seqList (x:xs) = x `seq` seqList xs + +algs = [("h98", seqList . H98.primes) + ,("seq", \n -> PrimSeq.primes n `seq` ()) + ,("par", \n -> PrimPar.primes n `seq` ()) + ] + +main = ndpMain "Sieve of Eratosthenes" + "[OPTION] ... N ..." + run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") + "use the specified algorithm"] + "seq" + +run opts alg sizes = + case lookup alg algs of + Nothing -> failWith ["Unknown algorithm " ++ alg] + Just f -> case map read sizes of + [] -> failWith ["No sizes specified"] + ns -> do + benchmark opts f + (map (return . labelPoint showN) ns) + (const "") + return () + where + showN n = "N=" ++ show n + diff --git a/examples/primespj/Primes.hs b/examples/primespj/Primes.hs new file mode 100644 --- /dev/null +++ b/examples/primespj/Primes.hs @@ -0,0 +1,63 @@ +module Main where + + +import Control.Exception (evaluate) +import System.Console.GetOpt + +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Parallel + +import Bench.Benchmark +import Bench.Options +import Data.Array.Parallel.Prelude (toUArrPA, fromUArrPA_3') + + +import PrimesVect (primesVect) +import Debug.Trace + + +algs = [("list", primesList), ("vect", primesVect')] + +primesList:: Int -> UArr Int +primesList n = trace (show res) res + where + res = toU $ primesList' n + +primesList' :: Int -> [Int] +primesList' 1 = [] +primesList' n = sps ++ [ i | i <- [sq+1..n], multiple sps i ] + where + sps = primesList' sq + sq = floor $ sqrt $ fromIntegral n + + multiple :: [Int] -> Int -> Bool + multiple ps i = and [i `mod` p /= 0 | p <- ps] + +primesVect':: Int -> UArr Int +primesVect' n = toUArrPA (primesVect n) + + +simpleTest:: Int -> IO (Bench.Benchmark.Point ( Int)) +simpleTest n = + do + evaluate testData + return $ ("N = " ) `mkPoint` testData + where + testData:: Int + testData = n + +main = ndpMain "Primes" + "[OPTION] ... SIZES ..." + run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") + "use the specified algorithm"] + "list" + + +run opts alg sizes = + case lookup alg algs of + Nothing -> failWith ["Unknown algorithm"] + Just f -> case map read sizes of + [] -> failWith ["No sizes specified"] + ([szs]::[Int]) -> do + benchmark opts f [simpleTest szs] show + return () diff --git a/examples/primespj/PrimesVect.hs b/examples/primespj/PrimesVect.hs new file mode 100644 --- /dev/null +++ b/examples/primespj/PrimesVect.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PArr #-} +{-# GHC_OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fvectorise #-} +{-# OPTIONS -fno-spec-constr-count #-} +module PrimesVect (primesVect) + +where +import Data.Array.Parallel.Prelude +import Data.Array.Parallel.Prelude.Int +import qualified Prelude + + +primesVect:: Int -> PArray Int +primesVect n = toPArrayP (primesVect' n) + +primesVect':: Int -> [:Int:] +primesVect' n + | n == 1 = emptyP + | n == 2 = singletonP 2 + | otherwise = sps +:+ [: i | i <- enumFromToP (sq+1) n, notMultiple sps i :] + where + sps = primesVect' sq + sq = intSquareRoot n + + notMultiple :: [:Int:] -> Int -> Bool + notMultiple ps i = andP [: mod i p /= 0 | p <- ps:] diff --git a/examples/qsort/Makefile b/examples/qsort/Makefile new file mode 100644 --- /dev/null +++ b/examples/qsort/Makefile @@ -0,0 +1,8 @@ +TESTDIR = .. +PROGS = QSort +HCCFLAGS = -optc-O3 +include $(TESTDIR)/mk/test.mk + +QSort.o: QSortPar.hi QSortSeq.hi QSortVect.hi + +QSort: QSort.o QSortPar.o QSortSeq.o QSortVect.o diff --git a/examples/qsort/QSort.hs b/examples/qsort/QSort.hs new file mode 100644 --- /dev/null +++ b/examples/qsort/QSort.hs @@ -0,0 +1,52 @@ +{-# OPTIONS -fno-spec-constr-count #-} +module Main where +import QSortSeq +import QSortPar +import QSortVect + +import Control.Exception (evaluate ) +import System.Console.GetOpt + +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Parallel +import Data.Array.Parallel.Prelude (toUArrPA, fromUArrPA') + +import Bench.Benchmark +import Bench.Options + +import Debug.Trace + +algs = [("seq", qsortSeq), ("par", qsortPar), ("list", toU. qsortList . fromU), ("vect", qsortVect')] + + + +qsortVect':: UArr Double -> UArr Double +qsortVect' xs = -- trace (show res) + res + where + res = toUArrPA $ qsortVect $ fromUArrPA' xs + + +generateVector :: Int -> IO (Point (UArr Double)) +generateVector n = + do + evaluate vec + return $ ("N = " ++ show n) `mkPoint` vec + where + vec = toU (reverse [1..fromInteger (toInteger n)]) + +main = ndpMain "QSort" + "[OPTION] ... SIZES ..." + run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") + "use the specified algorithm"] + "seq" + +run opts alg sizes = + case lookup alg algs of + Nothing -> failWith ["Unknown algorithm"] + Just f -> case map read sizes of + [] -> failWith ["No sizes specified"] + szs -> do + benchmark opts f (map generateVector szs) show + return () + diff --git a/examples/qsort/QSortPar.hs b/examples/qsort/QSortPar.hs new file mode 100644 --- /dev/null +++ b/examples/qsort/QSortPar.hs @@ -0,0 +1,64 @@ +{-# GHC_OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fno-spec-constr-count #-} +-- +-- TODO: +-- permute operations, which are fairly important for this algorithm, are currently +-- all sequential + +module QSortPar (qsortPar) +where + +import Data.Array.Parallel.Unlifted.Distributed +import Data.Array.Parallel.Unlifted.Parallel +import Data.Array.Parallel.Unlifted +import Debug.Trace + +-- I'm lazy here and use the lifted qsort instead of writing a flat version +qsortPar :: UArr Double -> UArr Double +{-# NOINLINE qsortPar #-} +qsortPar = concatSU . qsortLifted . singletonSU + + +-- Remove the trivially sorted segments +qsortLifted:: SUArr Double -> SUArr Double +qsortLifted xssArr = + splitApplySUP flags qsortLifted' id xssArr + where + flags = mapUP ((> 1)) $ lengthsSU xssArr + +-- Actual sorting +qsortLifted' xssarr = + if (xssLen == 0) + then xssarr + else (takeCU xssLen sorted) ^+:+^ equal ^+:+^ (dropCU xssLen sorted) + + where + + xssLen = lengthSU xssarr + xsLens = lengthsSU xssarr + pivots = xssarr !:^ mapUP (flip div 2) xsLens + pivotss = replicateSUP xsLens pivots + xarrLens = zipSU xssarr pivotss + sorted = qsortLifted (smaller +:+^ greater) + smaller = fstSU $ filterSUP (uncurryS (<)) xarrLens + greater = fstSU $ filterSUP (uncurryS (>)) xarrLens + equal = fstSU $ filterSUP (uncurryS (==)) xarrLens + + + +splitApplySUP:: (UA e, UA e', Show e, Show e') => + UArr Bool -> (SUArr e -> SUArr e') -> (SUArr e -> SUArr e') -> SUArr e -> SUArr e' +{-# INLINE splitApplySUP #-} +splitApplySUP flags f1 f2 xssArr = + if (lengthSU xssArr == 0) + then segmentArrU emptyU emptyU + else combineCU flags res1 res2 + + where + res1 = f1 $ packCUP flags xssArr + res2 = f2 $ packCUP (mapUP not flags) xssArr + + + + + diff --git a/examples/qsort/QSortSeq.hs b/examples/qsort/QSortSeq.hs new file mode 100644 --- /dev/null +++ b/examples/qsort/QSortSeq.hs @@ -0,0 +1,56 @@ +{-# GHC_OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fno-spec-constr-count #-} +-- + +module QSortSeq (qsortSeq, qsortList) +where + +import Data.Array.Parallel.Unlifted +import Debug.Trace + + +qsortSeq :: UArr Double -> UArr Double +qsortSeq xs = -- trace (show res) + res + where + res = concatSU $ qsortLifted $ singletonSU xs + +qsortLifted:: SUArr Double -> SUArr Double +qsortLifted xssArr = splitApplySU flags qsortLifted' id xssArr + where + flags = mapU ((>=1)) $ lengthsSU xssArr + +qsortLifted' xssarr = + if (xssLen == 0) + then xssarr + else (takeCU xssLen sorted) ^+:+^ equal ^+:+^ (dropCU xssLen sorted) + where + xssLen = lengthSU xssarr + xsLens = lengthsSU xssarr + xarrLens = zipSU xssarr $ replicateSU xsLens $ xssarr !:^ mapU (flip div 2) xsLens + sorted = qsortLifted $ (mapSU fstS $ filterSU (uncurryS (<)) xarrLens) + +:+^ + (mapSU fstS $ filterSU (uncurryS (>)) xarrLens) + equal = mapSU fstS $ filterSU (uncurryS (==)) xarrLens + + +splitApplySU:: (UA e, UA e', Show e, Show e') => UArr Bool -> (SUArr e -> SUArr e') -> (SUArr e -> SUArr e') -> SUArr e -> SUArr e' +{-# INLINE splitApplySU #-} +splitApplySU flags f1 f2 xssArr = res + + where + res = combineCU flags res1 res2 + res1 = f1 $ packCU flags xssArr + res2 = f2 $ packCU (mapU not flags) xssArr + + +qsortList:: [Double] -> [Double] +qsortList = qsortList' + +qsortList' [] = [] +qsortList' xs = (qsortList' smaller) ++ equal ++ (qsortList' greater) + where + p = xs !! (length xs `div` 2) + smaller = [x | x <- xs, x < p] + equal = [x | x <- xs, x == p] + greater = [x | x <- xs, x > p] diff --git a/examples/qsort/QSortVect.hs b/examples/qsort/QSortVect.hs new file mode 100644 --- /dev/null +++ b/examples/qsort/QSortVect.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE PArr #-} +{-# OPTIONS -fvectorise #-} +{-# OPTIONS -fno-spec-constr-count #-} +module QSortVect (qsortVect) where + +import Data.Array.Parallel.Prelude +import Data.Array.Parallel.Prelude.Double +import qualified Data.Array.Parallel.Prelude.Int as I + +import qualified Prelude + +qsortVect:: PArray Double -> PArray Double +qsortVect xs = toPArrayP (qsortVect' (fromPArrayP xs)) + +qsortVect':: [: Double :] -> [: Double :] +qsortVect' xs | lengthP xs I.<= 1 = xs + | otherwise = qsortVect' [:x | x <- xs, x < p:] +:+ + [:x | x <- xs, x == p:] +:+ + qsortVect' [:x | x <- xs, x > p:] + where p = (xs !: (lengthP xs `I.div` 2)) diff --git a/examples/quickcheck/Makefile b/examples/quickcheck/Makefile new file mode 100644 --- /dev/null +++ b/examples/quickcheck/Makefile @@ -0,0 +1,68 @@ +GHC = ../../../../../../../compiler/stage2/ghc-inplace +NDPDIR = ../../../../.. +NDPLIB = $(NDPDIR)/libHSndp.a + +HC = $(GHC) +HCFLAGS = -fglasgow-exts -package QuickCheck -package template-haskell \ + -i$(NDPDIR) -v0 +OPTFLAGS = -O2 -funbox-strict-fields \ + -fliberate-case-threshold100 -fno-method-sharing + + +TESTSUITE = Testsuite/Utils.hs \ + Testsuite/Testcase.hs \ + Testsuite/Preproc.hs \ + Testsuite.hs + +TESTSUITE_OBJS = $(TESTSUITE:.hs=.o) + +TESTS = $(wildcard tests/*.hs) +TEST_MODS = $(notdir $(TESTS)) +OPT = $(TEST_MODS:.hs=-opt) +UNOPT = $(TEST_MODS:.hs=-unopt) +# we want the tests to be run in the right order +ALL = $(TEST_MODS:.hs=-all) + +TESTMAIN = 'System.Environment.withArgs (words "$(run)") main' + +.PHONY: default unopt opt all testsuite + +default: unopt + +all: $(ALL) + +unopt: $(UNOPT) + +opt: $(OPT) + +testsuite: $(TESTSUITE_OBJS) + +Testsuite.o: $(filter-out Testsuite.o,$(TESTSUITE_OBJS)) + +%.o : %.hs $(NDPLIB) + $(HC) -c $< $(HCFLAGS) + +%-opt.o: %.hs $(NDPLIB) testsuite + $(HC) -o $@ -c $< $(HCFLAGS) $(OPTFLAGS) + +%.hi: %.o + @: + +$(TEST_OBJS) : testsuite + +%-all: %-unopt %-opt + @: + +%-unopt: + @echo "======== Testing $(patsubst %-unopt,%,$@) (interpreted) ========" + @$(HC) -e $(TESTMAIN) $(patsubst %-unopt,tests/%.hs,$@) $(HCFLAGS) \ + | tee $@.log | { grep -v '\.\.\. pass' || true; } + @echo "======== Finished $(patsubst %-unopt,%,$@) (interpreted) ========" + +%-opt: tests/%-opt.o + @$(HC) -o tst $(HCFLAGS) $< $(TESTSUITE_OBJS) $(NDPLIB) + @echo "======== Testing $(patsubst %-opt,%,$@) (optimised) ========" + @./tst | tee $@ | { grep -v '\.\.\. pass' || true; } + @echo "======== Finished $(patsubst %-opt,%,$@) (optimised) ========" + @rm -f tst $< + diff --git a/examples/quickcheck/Testsuite.hs b/examples/quickcheck/Testsuite.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/Testsuite.hs @@ -0,0 +1,15 @@ +module Testsuite ( + module Testsuite.Preproc, + module Testsuite.Testcase, + module Testsuite.Utils, + + module Test.QuickCheck +) where + +import Testsuite.Preproc +import Testsuite.Testcase +import Testsuite.Utils + +import Test.QuickCheck + + diff --git a/examples/quickcheck/Testsuite/Preproc.hs b/examples/quickcheck/Testsuite/Preproc.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/Testsuite/Preproc.hs @@ -0,0 +1,104 @@ +module Testsuite.Preproc ( testcases, (<@) ) +where + +import Language.Haskell.TH +import Data.List +import Data.Maybe (fromJust) +import Monad (liftM) + +data Prop = Prop { propName :: Name + , propTyvars :: [Name] + , propType :: Type + } + +data Inst = Inst { instName :: Name + , instSubsts :: [(Name, Type)] + , instExp :: Exp + } + +(<@) :: String -> Q Type -> Q (String, Type) +pfx <@ qty = liftM ((,) pfx) qty + +type Domain = [(String, [Type])] + +testcases :: [Q (String, Type)] -> Q [Dec] -> Q [Dec] +testcases qdom qdecs = + do + dom <- liftM domain $ sequence qdom + decs <- qdecs + let props = embed . generate dom $ properties decs + rn = AppE (VarE (mkName "runTests")) + props + main = ValD (VarP (mkName "main")) + (NormalB rn) [] + return (decs ++ [main]) + +domain :: [(String, Type)] -> Domain +domain ps = sortBy cmpPfx + . zip (map fst ps) + . map types + $ map snd ps + where + cmpPfx (s,_) (s',_) = length s' `compare` length s + +types :: Type -> [Type] +types ty = case unAppT ty of + (TupleT _ : tys) -> tys + _ -> [ty] + where + unAppT (AppT t u) = unAppT t ++ [u] + unAppT t = [t] + + +instid :: Inst -> String +instid inst = name inst ++ env inst + where + name (Inst { instName = nm }) = + let s = nameBase nm + in + if "prop_" `isPrefixOf` s then drop 5 s else s + + env (Inst { instSubsts = substs }) + | null substs = "" + | otherwise = let ss = [nameBase tv ++ " = " ++ pprint ty + | (tv, ty) <- substs] + in "[" ++ head ss ++ concatMap (", " ++) (tail ss) ++ "]" + +properties :: [Dec] -> [Prop] +properties decs = [mkProp nm ty | SigD nm ty <- decs] + where + mkProp nm (ForallT vars _ ty) = Prop nm vars ty + mkProp nm ty = Prop nm [] ty + +embed :: [Inst] -> Exp +embed insts = ListE [((VarE $ mkName "mkTest") `AppE` + (LitE . StringL $ instid i)) `AppE` + instExp i + | i <- insts ] + +generate :: Domain -> [Prop] -> [Inst] +generate dom = concatMap gen + where + gen prop@(Prop { propName = name + , propTyvars = [] + , propType = ty }) = + [Inst name [] (VarE name `SigE` ty)] + gen prop@(Prop { propName = name + , propTyvars = tvs + , propType = ty }) = + [Inst name env (VarE name `SigE` subst env ty) + | env <- combinations tvs dom] + +subst :: [(Name, Type)] -> Type -> Type +subst env (VarT nm) = case lookup nm env of + Just ty -> ty +subst env (AppT t u) = AppT (subst env t) (subst env u) +subst env t = t + +combinations :: [Name] -> [(String, [Type])] -> [[(Name, Type)]] +combinations [] _ = [[]] +combinations (n:ns) dom = [(n,t) : ps | t <- ts, ps <- combinations ns dom] + where + s = nameBase n + ts = snd . fromJust $ find ((`isPrefixOf` s) . fst) dom + diff --git a/examples/quickcheck/Testsuite/Testcase.hs b/examples/quickcheck/Testsuite/Testcase.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/Testsuite/Testcase.hs @@ -0,0 +1,55 @@ +module Testsuite.Testcase ( + Test(..), mkTest, runTests +) where + +import Test.QuickCheck +import Test.QuickCheck.Batch (TestResult(..), run, defOpt) + +import Text.Regex.Base + +import System.Environment (getArgs) + +import Data.Maybe (isJust) + +import IO + +data Test = Test { testName :: String + , testProperty :: Property + } + +mkTest :: Testable a => String -> a -> Test +mkTest name = Test name . property + +runTests :: [Test] -> IO () +runTests tests = + do + args <- getArgs + mapM_ chk $ pick args tests + where + chk (Test { testName = name, testProperty = prop }) = + do + putStr $ name ++ spaces (60 - length name) ++ "... " + hFlush stdout + res <- run prop defOpt + case res of + TestOk _ n _ -> putStrLn $ "pass (" ++ show n ++ ")" + TestExausted _ n _ -> putStrLn $ "EXHAUSTED (" ++ show n ++ ")" + TestFailed s n -> + do + putStrLn $ "FAIL (" ++ show n ++ ")" + mapM_ putStrLn $ map (" " ++) s + TestAborted e -> + do + putStrLn $ "ABORTED" + putStrLn $ " " ++ show e + hFlush stdout + spaces n | n <= 0 = "" + | otherwise = replicate n ' ' + +pick :: [String] -> [Test] -> [Test] +pick [] = id +pick ss = filter (match (map mkRegex ss)) + where + match :: [Regex] -> Test -> Bool + match rs tst = any (\r -> isJust . matchRegex r $ testName tst) rs + diff --git a/examples/quickcheck/Testsuite/Utils.hs b/examples/quickcheck/Testsuite/Utils.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/Testsuite/Utils.hs @@ -0,0 +1,74 @@ +module Testsuite.Utils ( + Len(..), EFL, + + gvector, gdist, gtype, vtype +) where + +import Test.QuickCheck +import Test.QuickCheck.Batch + +import Text.Show.Functions + +import Data.Array.Parallel.Base.Hyperstrict +import Data.Array.Parallel.Base.Fusion (EFL) +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Distributed + +import Data.Char +import Monad (liftM) + +-- infix 4 === + +newtype Len = Len Int deriving(Eq,Ord,Enum,Show,Num) + +instance Arbitrary Char where + arbitrary = fmap chr . sized $ \n -> choose (0,n) + coarbitrary = coarbitrary . ord + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a :*: b) where + arbitrary = liftM (uncurry (:*:)) arbitrary + coarbitrary (a :*: b) = coarbitrary (a,b) + +instance Arbitrary Len where + arbitrary = sized $ \n -> Len `fmap` choose (0,n) + coarbitrary (Len n) = coarbitrary n + +instance Arbitrary a => Arbitrary (MaybeS a) where + arbitrary = frequency [(1, return NothingS), (3, liftM JustS arbitrary)] + coarbitrary NothingS = variant 0 + coarbitrary (JustS x) = variant 1 . coarbitrary x + +instance (UA a, Arbitrary a) => Arbitrary (UArr a) where + arbitrary = fmap toU arbitrary + coarbitrary = coarbitrary . fromU + +instance (UA a, Arbitrary a) => Arbitrary (SUArr a) where + arbitrary = fmap toSU arbitrary + coarbitrary = coarbitrary . fromSU + +instance Arbitrary Gang where + arbitrary = sized $ \n -> sequentialGang `fmap` choose (1,n+1) + coarbitrary = coarbitrary . gangSize + +gvector :: Arbitrary a => Gang -> Gen [a] +gvector = vector . gangSize + +gdist :: (Arbitrary a, DT a) => Gang -> Gen (Dist a) +gdist g = sized $ \n -> resize (n `div` gangSize g + 1) $ toD g `fmap` gvector g + +vtype :: Gen [a] -> a -> Gen [a] +vtype = const + +gtype :: Gen (Dist a) -> a -> Gen (Dist a) +gtype = const + +{- +class Eq a => SemEq a where + (===) :: a -> a -> Bool + +instance Eq a => SemEq a where + x === y | isBottom x = isBottom y + | isBottom y = False + | otherwise = x == y +-} + diff --git a/examples/quickcheck/tests/BUArr.hs b/examples/quickcheck/tests/BUArr.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/BUArr.hs @@ -0,0 +1,116 @@ +import Testsuite + +import Data.Array.Parallel.Arr.BUArr +import Data.Array.Parallel.Base.Hyperstrict + +instance (UAE a, Arbitrary a) => Arbitrary (BUArr a) where + arbitrary = fmap toBU arbitrary + coarbitrary = coarbitrary . fromBU + +$(testcases [ "" <@ [t| ( (), Bool, Char, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + ] + [d| + -- if this doesn't work nothing else will, so run this first + prop_fromBU_toBU :: (Eq a, UAE a) => [a] -> Bool + prop_fromBU_toBU xs = fromBU (toBU xs) == xs + + -- Basic operations + -- ---------------- + + prop_lengthBU :: UAE a => BUArr a -> Bool + prop_lengthBU arr = lengthBU arr == length (fromBU arr) + + prop_emptyBU :: (Eq a, UAE a) => a -> Bool + prop_emptyBU x = fromBU emptyBU == tail [x] + + prop_unitsBU :: Len -> Bool + prop_unitsBU (Len n) = + fromBU (unitsBU n) == replicate n () + + prop_replicateBU :: (Eq a, UAE a) => Len -> a -> Bool + prop_replicateBU (Len n) x = + fromBU (replicateBU n x) == replicate n x + + prop_indexBU :: (Eq a, UAE a) => BUArr a -> Len -> Property + prop_indexBU arr (Len i) = + i < lengthBU arr + ==> (arr `indexBU` i) == (fromBU arr !! i) + + prop_sliceBU :: (Eq a, UAE a) => BUArr a -> Len -> Len -> Property + prop_sliceBU arr (Len i) (Len n) = + i <= lengthBU arr && n <= lengthBU arr - i + ==> fromBU (sliceBU arr i n) == take n (drop i $ fromBU arr) + + prop_extractBU :: (Eq a, UAE a) => BUArr a -> Len -> Len -> Property + prop_extractBU arr (Len i) (Len n) = + i <= lengthBU arr && n <= lengthBU arr - i + ==> fromBU (extractBU arr i n) == take n (drop i $ fromBU arr) + + -- Higher-order operations + -- ----------------------- + + prop_mapBU :: (Eq b, UAE a, UAE b) => (a -> b) -> BUArr a -> Bool + prop_mapBU f arr = + fromBU (mapBU f arr) == map f (fromBU arr) + + prop_foldlBU :: (Eq a, UAE b) => (a -> b -> a) -> a -> BUArr b -> Bool + prop_foldlBU f z arr = + foldlBU f z arr == foldl f z (fromBU arr) + + -- missing: foldBU + + + prop_scanlBU :: (Eq a, UAE a, UAE b) => (a -> b -> a) -> a -> BUArr b -> Bool + prop_scanlBU f z arr = + fromBU (scanlBU f z arr) == init (scanl f z (fromBU arr)) + + -- missing: scanBU + -- missing: loopBU + + -- Arithmetic operations + -- --------------------- + + prop_sumBU :: (Eq num, UAE num, Num num) => BUArr num -> Bool + prop_sumBU arr = + sumBU arr == sum (fromBU arr) + + -- Equality + -- -------- + + prop_eqBU_1 :: (Eq a, UAE a) => BUArr a -> Bool + prop_eqBU_1 arr = arr == arr + + prop_eqBU_2 :: (Eq a, UAE a) => BUArr a -> BUArr a -> Bool + prop_eqBU_2 arr brr = (arr == brr) == (fromBU arr == fromBU brr) + + -- Fusion + -- ------ + + prop_loopBU_replicateBU + :: (UAE e, Eq acc, Eq e', UAE e') + => EFL acc e e' -> acc -> Len -> e -> Bool + prop_loopBU_replicateBU mf start (Len n) v = + loopBU mf start (replicateBU n v) + == loopBU (\a _ -> mf a v) start (unitsBU n) + + {- FIXME: disabled - too many type variables + prop_fusion2 :: (Eq acc2, Eq e3, UAE e1, UAE e2, UAE e3) + => LoopFn acc1 e1 e2 + -> LoopFn acc2 e2 e3 + -> acc1 -> acc2 -> BUArr e1 -> Bool + prop_fusion2 mf1 mf2 start1 start2 arr = + loopBU mf2 start2 (loopArr (loopBU mf1 start1 arr)) == + let + mf (acc1 :*: acc2) e = + case mf1 acc1 e of + (acc1' :*: Nothing) -> ((acc1' :*: acc2) :*: Nothing) + (acc1' :*: Just e') -> + case mf2 acc2 e' of + (acc2' :*: res) -> ((acc1' :*: acc2') :*: res) + in + loopSndAcc (loopBU mf (start1 :*: start2) arr) + -} + |]) + diff --git a/examples/quickcheck/tests/Distributed.hs b/examples/quickcheck/tests/Distributed.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/Distributed.hs @@ -0,0 +1,163 @@ +{-# OPTIONS -fallow-undecidable-instances #-} + +import Testsuite + +import Data.Array.Parallel.Unlifted.Distributed +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Base.Hyperstrict + +class (Eq a, DT a, Arbitrary a, Show a) => D a +instance (Eq a, DT a, Arbitrary a, Show a) => D a + +class (Eq a, UA a, Arbitrary a, Show a) => U a +instance (Eq a, UA a, Arbitrary a, Show a) => U a + +$(testcases [ "" <@ [t| ( (), Bool, Char, Int, UArr (), UArr Int ) |] + , "sc" <@ [t| ( (), Bool, Char, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + , "pq" <@ [t| ( (), Int ) |] + ] + [d| + -- if this doesn't work nothing else will, so run this first + prop_fromD_toD :: D a => Gang -> a -> Property + prop_fromD_toD g a = + forAll (gvector g `vtype` a) $ \xs -> + fromD g (toD g xs) == xs + + -- Equality + -- -------- + + prop_eqD_1 :: D a => Gang -> a -> Property + prop_eqD_1 g a = + forAll (gdist g `gtype` a) $ \d -> + eqD g d d + + prop_eqD_2 :: D a => Gang -> a -> Property + prop_eqD_2 g a = + forAll (gdist g `gtype` a) $ \dx -> + forAll (gdist g `gtype` a) $ \dy -> + eqD g dx dy == (fromD g dx == fromD g dy) + + prop_neqD_1 :: D a => Gang -> a -> Property + prop_neqD_1 g a = + forAll (gdist g `gtype` a) $ \d -> + not (neqD g d d) + + prop_neqD_eqD :: D a => Gang -> a -> Property + prop_neqD_eqD g a = + forAll (gdist g `gtype` a) $ \dx -> + forAll (gdist g `gtype` a) $ \dy -> + eqD g dx dy == not (neqD g dx dy) + + -- Higher-order combinators + -- ------------------------ + + prop_mapD :: (D a, D b) => Gang -> (a -> b) -> Property + prop_mapD g f = + forAll (gdist g) $ \d -> + fromD g (mapD g f d) == map f (fromD g d) + + prop_zipWithD :: (D a, D b, D c) => Gang -> (a -> b -> c) -> Property + prop_zipWithD g f = + forAll (gdist g) $ \dx -> + forAll (gdist g) $ \dy -> + fromD g (zipWithD g f dx dy) == zipWith f (fromD g dx) (fromD g dy) + + prop_foldD :: D a => Gang -> (a -> a -> a) -> Property + prop_foldD g f = + forAll (gdist g) $ \d -> + foldD g f d == foldl1 f (fromD g d) + + prop_scanD :: D a => Gang -> (a -> a -> a) -> a -> Property + prop_scanD g f z = + forAll (gdist g) $ \d -> + let (d' :*: r) = scanD g f z d + in fromD g d' ++ [r] == scanl f z (fromD g d) + + -- Distributed scalars + -- ------------------- + + prop_scalarD :: D sc => Gang -> sc -> Bool + prop_scalarD g x = + fromD g (scalarD g x) == replicate (gangSize g) x + + prop_andD :: Gang -> Property + prop_andD g = + forAll (gdist g) $ \d -> + andD g d == and (fromD g d) + + prop_orD :: Gang -> Property + prop_orD g = + forAll (gdist g) $ \d -> + orD g d == or (fromD g d) + + prop_sumD :: (D num, Num num) => Gang -> num -> Property + prop_sumD g num = + forAll (gdist g `gtype` num) $ \d -> + sumD g d == sum (fromD g d) + + -- Distributed pairs + -- ----------------- + + prop_zipD :: (D pq1, D pq2) => Gang -> pq1 -> pq2 -> Property + prop_zipD g pq1 pq2 = + forAll (gdist g `gtype` pq1) $ \dx -> + forAll (gdist g `gtype` pq2) $ \dy -> + fromD g (zipD dx dy) == zipWith (:*:) (fromD g dx) (fromD g dy) + + prop_unzipD :: (D pq1, D pq2) => Gang -> pq1 -> pq2 -> Property + prop_unzipD g pq1 pq2 = + forAll (gdist g `gtype` (pq1 :*: pq2)) $ \d -> + let (dx :*: dy) = unzipD d + in + (fromD g dx, fromD g dy) == unzip (map unpairS (fromD g d)) + + prop_fstD :: (D pq1, D pq2) => Gang -> pq1 -> pq2 -> Property + prop_fstD g pq1 pq2 = + forAll (gdist g `gtype` (pq1 :*: pq2)) $ \d -> + fromD g (fstD d) == map fstS (fromD g d) + + prop_sndD :: (D pq1, D pq2) => Gang -> pq1 -> pq2 -> Property + prop_sndD g pq1 pq2 = + forAll (gdist g `gtype` (pq1 :*: pq2)) $ \d -> + fromD g (sndD d) == map sndS (fromD g d) + + -- Distributed arrays + -- ------------------ + + prop_splitLengthD_1 :: U sc => Gang -> UArr sc -> Bool + prop_splitLengthD_1 g arr = + sumD g (splitLengthD g arr) == lengthU arr + + -- check that the distribution is [k+1,k+1,k+1,...,k,k,k,...] + prop_splitLengthD_2 :: U sc => Gang -> UArr sc -> Bool + prop_splitLengthD_2 g arr = + chk (fromD g (splitLengthD g arr)) + where + chk (l:ls) = let ns = dropWhile (==l) ls + in + null ns + || (all (== head ns) ns + && head ns == l - 1) + + prop_lengthD :: U sc => Gang -> sc -> Property + prop_lengthD g x = + forAll (gdist g `gtype` replicateU 0 x) $ \darr -> + eqD g (lengthD darr) (mapD g lengthU darr) + + prop_splitD :: (UA sc, Eq sc) => Gang -> UArr sc -> Bool + prop_splitD g arr = + foldr1 (+:+) (fromD g (splitD g arr)) == arr + + prop_joinD :: U sc => Gang -> sc -> Property + prop_joinD g x = + forAll (gdist g `gtype` replicateU 0 x) $ \darr -> + joinD g darr == foldr1 (+:+) (fromD g darr) + + prop_joinD_splitD :: (UA sc, Eq sc) => Gang -> UArr sc -> Bool + prop_joinD_splitD g arr = + joinD g (splitD g arr) == arr + + |]) + diff --git a/examples/quickcheck/tests/UnliftedSU.hs b/examples/quickcheck/tests/UnliftedSU.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/UnliftedSU.hs @@ -0,0 +1,72 @@ +{-# OPTIONS -fallow-undecidable-instances #-} + +import Testsuite + +import Data.Array.Parallel.Unlifted + +class (Eq a, UA a) => U a +instance (Eq a, UA a) => U a + + + +$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + , "ord" <@ [t| ( (), Char, Bool, Int ) |] + , "enum" <@ [t| ( (), Char, Bool, Int ) |] + ] + [d| + -- if this doesn't work nothing else will, so run this first + prop_fromSU_toSU :: U a => [[a]] -> Bool + prop_fromSU_toSU xss = fromSU (toSU xss) == xss + + prop_concatSU :: U a => SUArr a -> SUArr a -> Bool + prop_concatSU xss yss = + (concatSU xss == concatSU yss) + == (concat (fromSU xss) == concat (fromSU yss)) + + prop_flattenSU :: U a => SUArr a -> SUArr a -> Bool + prop_flattenSU xss yss = + (xss == yss) == (flattenSU xss == flattenSU yss) + + -- missing: (>:) + -- missing: segmentU + + prop_replicateSU :: U a => UArr (Int :*: a) -> Bool + prop_replicateSU ps = let (ms :*: xs) = unzipU ps + ns = mapU abs ms + in + fromSU (replicateSU ns xs) == zipWith replicate (fromU ns) (fromU xs) + + prop_foldlSU :: (U a, U b) => (a -> b -> a) -> a -> SUArr b -> Bool + prop_foldlSU f z xss = + fromU (foldlSU f z xss) == map (foldl f z) (fromSU xss) + + -- missing: foldSU + -- missing: loopSU + + prop_andSU :: SUArr Bool -> Bool + prop_andSU bss = + fromU (andSU bss) == map and (fromSU bss) + + prop_orSU :: SUArr Bool -> Bool + prop_orSU bss = + fromU (orSU bss) == map or (fromSU bss) + + prop_sumSU :: (U num, Num num) => SUArr num -> Bool + prop_sumSU nss = + fromU (sumSU nss) == map sum (fromSU nss) + + prop_productSU :: (U num, Num num) => SUArr num -> Bool + prop_productSU nss = + fromU (productSU nss) == map product (fromSU nss) + + -- missing: maximumSU + -- missing: minimumSU + + -- missing: enumFromToSU + -- missing: enumFromThenToSU + + -- missing: fusion rules + |]) + diff --git a/examples/quickcheck/tests/Unlifted_Basics.hs b/examples/quickcheck/tests/Unlifted_Basics.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/Unlifted_Basics.hs @@ -0,0 +1,51 @@ +import Testsuite + +import Data.Array.Parallel.Unlifted + +$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + , "ord" <@ [t| ( (), Char, Bool, Int ) |] + , "enum" <@ [t| ( (), Char, Bool, Int ) |] + ] + [d| + -- if this doesn't work nothing else will, so run this first + prop_fromU_toU :: (Eq a, UA a) => [a] -> Bool + prop_fromU_toU xs = fromU (toU xs) == xs + + prop_lengthU :: UA a => UArr a -> Bool + prop_lengthU arr = lengthU arr == length (fromU arr) + + prop_nullU :: UA a => UArr a -> Bool + prop_nullU arr = nullU arr == (lengthU arr == 0) + + prop_emptyU :: (Eq a, UA a) => a -> Bool + prop_emptyU x = fromU emptyU == tail [x] + + prop_unitsU :: Len -> Bool + prop_unitsU (Len n) = + fromU (unitsU n) == replicate n () + + prop_replicateU :: (Eq a, UA a) => Len -> a -> Bool + prop_replicateU (Len n) x = + fromU (replicateU n x) == replicate n x + + prop_indexU :: (Eq a, UA a) => UArr a -> Len -> Property + prop_indexU arr (Len i) = + i < lengthU arr + ==> (arr !: i) == (fromU arr !! i) + + prop_appendU :: (Eq a, UA a) => UArr a -> UArr a -> Bool + prop_appendU arr brr = + fromU (arr +:+ brr) == fromU arr ++ fromU brr + + -- Equality + -- -------- + + prop_eqU_1 :: (Eq a, UA a) => UArr a -> Bool + prop_eqU_1 arr = arr == arr + + prop_eqU_2 :: (Eq a, UA a) => UArr a -> UArr a -> Bool + prop_eqU_2 arr brr = (arr == brr) == (fromU arr == fromU brr) + |]) + diff --git a/examples/quickcheck/tests/Unlifted_Combinators.hs b/examples/quickcheck/tests/Unlifted_Combinators.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/Unlifted_Combinators.hs @@ -0,0 +1,48 @@ +import Testsuite + +import Data.Array.Parallel.Unlifted + +$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + , "ord" <@ [t| ( (), Char, Bool, Int ) |] + , "enum" <@ [t| ( (), Char, Bool, Int ) |] + ] + [d| + prop_mapU :: (UA a, Eq b, UA b) => (a -> b) -> UArr a -> Bool + prop_mapU f arr = + fromU (mapU f arr) == map f (fromU arr) + + -- missing: zipWithU + -- missing: zipWith3U + + prop_filterU :: (Eq a, UA a) => (a -> Bool) -> UArr a -> Bool + prop_filterU f arr = + fromU (filterU f arr) == filter f (fromU arr) + + prop_foldlU :: (UA a, Eq b) => (b -> a -> b) -> b -> UArr a -> Bool + prop_foldlU f z arr = + foldlU f z arr == foldl f z (fromU arr) + + prop_foldl1U :: (UA a, Eq a) => (a -> a -> a) -> UArr a -> Property + prop_foldl1U f arr = + not (nullU arr) + ==> foldl1U f arr == foldl1 f (fromU arr) + + -- missing: foldU + -- missing: fold1U + + prop_scanlU :: (UA a, UA b, Eq b) => (b -> a -> b) -> b -> UArr a -> Bool + prop_scanlU f z arr = + fromU (scanlU f z arr) == init (scanl f z (fromU arr)) + + prop_scanl1U :: (UA a, Eq a) => (a -> a -> a) -> UArr a -> Property + prop_scanl1U f arr = + not (nullU arr) + ==> fromU (scanl1U f arr) == init (scanl1 f (fromU arr)) + + -- missing: scanU + -- missing: scan1U + -- missing: loopU + |]) + diff --git a/examples/quickcheck/tests/Unlifted_Fusion.hs b/examples/quickcheck/tests/Unlifted_Fusion.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/Unlifted_Fusion.hs @@ -0,0 +1,38 @@ +import Testsuite + +import Data.Array.Parallel.Unlifted + +$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + , "ord" <@ [t| ( (), Char, Bool, Int ) |] + , "enum" <@ [t| ( (), Char, Bool, Int ) |] + ] + [d| + prop_loopU_replicateU :: (UA e, Eq acc, Eq e', UA e') + => EFL acc e e' -> acc -> Len -> e -> Bool + prop_loopU_replicateU em start (Len n) v = + loopU em start (replicateU n v) == + loopU (\a _ -> em a v) start (unitsU n) + + {- FIXME: disabled - too many type variables + prop_fusion2 :: (Eq acc1, Eq acc2, Eq e1, Eq e2, Eq e3, + UA e1, UA e2, UA e3) + => LoopFn acc1 e1 e2 -> LoopFn acc2 e2 e3 + -> acc1 -> acc2 -> UArr e1 -> Bool + prop_fusion2 em1 em2 start1 start2 arr = + loopU em2 start2 (loopArr (loopU em1 start1 arr)) == + let + em (acc1 :*: acc2) e = + case em1 acc1 e of + (acc1' :*: Nothing) -> ((acc1' :*: acc2) :*: Nothing) + (acc1' :*: Just e') -> + case em2 acc2 e' of + (acc2' :*: res) -> ((acc1' :*: acc2') :*: res) + in + loopSndAcc (loopU em (start1 :*: start2) arr) + -} + + -- missing: segmented operations + |]) + diff --git a/examples/quickcheck/tests/Unlifted_Permutes.hs b/examples/quickcheck/tests/Unlifted_Permutes.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/Unlifted_Permutes.hs @@ -0,0 +1,20 @@ +import Testsuite + +import Data.Array.Parallel.Unlifted + +$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + , "ord" <@ [t| ( (), Char, Bool, Int ) |] + , "enum" <@ [t| ( (), Char, Bool, Int ) |] + ] + [d| + -- missing: permuteU + -- missing: bpermuteU + -- missing: bpermuteDftU + + prop_reverseU :: (Eq a, UA a) => UArr a -> Bool + prop_reverseU arr = + fromU (reverseU arr) == reverse (fromU arr) + |]) + diff --git a/examples/quickcheck/tests/Unlifted_Subarrays.hs b/examples/quickcheck/tests/Unlifted_Subarrays.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/Unlifted_Subarrays.hs @@ -0,0 +1,38 @@ +import Testsuite + +import Data.Array.Parallel.Unlifted + +$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + , "ord" <@ [t| ( (), Char, Bool, Int ) |] + , "enum" <@ [t| ( (), Char, Bool, Int ) |] + ] + [d| + prop_sliceU :: (Eq a, UA a) => UArr a -> Len -> Len -> Property + prop_sliceU arr (Len i) (Len n) = + i <= lengthU arr && n <= lengthU arr - i + ==> fromU (sliceU arr i n) == take n (drop i $ fromU arr) + + prop_extractU :: (Eq a, UA a) => UArr a -> Len -> Len -> Property + prop_extractU arr (Len i) (Len n) = + i <= lengthU arr && n <= lengthU arr - i + ==> fromU (extractU arr i n) == take n (drop i $ fromU arr) + + prop_takeU :: (Eq a, UA a) => Len -> UArr a -> Property + prop_takeU (Len n) arr = + n <= lengthU arr + ==> fromU (takeU n arr) == take n (fromU arr) + + prop_dropU :: (Eq a, UA a) => Len -> UArr a -> Property + prop_dropU (Len n) arr = + n <= lengthU arr + ==> fromU (dropU n arr) == drop n (fromU arr) + + prop_splitAtU :: (Eq a, UA a) => Len -> UArr a -> Property + prop_splitAtU (Len n) arr = + n <= lengthU arr + ==> let (brr, crr) = splitAtU n arr + in (fromU brr, fromU crr) == splitAt n (fromU arr) + |]) + diff --git a/examples/quickcheck/tests/Unlifted_Sums.hs b/examples/quickcheck/tests/Unlifted_Sums.hs new file mode 100644 --- /dev/null +++ b/examples/quickcheck/tests/Unlifted_Sums.hs @@ -0,0 +1,62 @@ +import Testsuite + +import Data.Array.Parallel.Unlifted + +$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] + , "acc" <@ [t| ( (), Int ) |] + , "num" <@ [t| ( Int ) |] + , "ord" <@ [t| ( (), Char, Bool, Int ) |] + , "enum" <@ [t| ( (), Char, Bool, Int ) |] + ] + [d| + -- Searching + -- --------- + prop_elemU :: (Eq e, UA e) => e -> UArr e -> Bool + prop_elemU x arr = + elemU x arr == elem x (fromU arr) + + prop_notElemU :: (Eq e, UA e) => e -> UArr e -> Bool + prop_notElemU x arr = + notElemU x arr == notElem x (fromU arr) + + -- Logic operations + -- ---------------- + + prop_andU :: UArr Bool -> Bool + prop_andU arr = + andU arr == and (fromU arr) + + prop_orU :: UArr Bool -> Bool + prop_orU arr = + orU arr == or (fromU arr) + + prop_anyU :: UA e => (e -> Bool) -> UArr e -> Bool + prop_anyU f arr = + anyU f arr == any f (fromU arr) + + prop_allU :: UA e => (e -> Bool) -> UArr e -> Bool + prop_allU f arr = + allU f arr == all f (fromU arr) + + -- Arithmetic operations + -- --------------------- + + prop_sumU :: (Eq num, UA num, Num num) => UArr num -> Bool + prop_sumU arr = + sumU arr == sum (fromU arr) + + prop_productU :: (Eq num, UA num, Num num) => UArr num -> Bool + prop_productU arr = + productU arr == product (fromU arr) + + prop_maximumU :: (Ord ord, UA ord) => UArr ord -> Property + prop_maximumU arr = + not (nullU arr) + ==> maximumU arr == maximum (fromU arr) + + prop_minimumU :: (Ord ord, UA ord) => UArr ord -> Property + prop_minimumU arr = + not (nullU arr) + ==> minimumU arr == minimum (fromU arr) + |]) + diff --git a/examples/quickhull/Makefile b/examples/quickhull/Makefile new file mode 100644 --- /dev/null +++ b/examples/quickhull/Makefile @@ -0,0 +1,10 @@ +TESTDIR = .. +PROGS = quickhull +HCCFLAGS = -optc-O3 +include $(TESTDIR)/mk/test.mk + +quickhull.o: Types.hi QH.hi +QH.o: Types.hi + +quickhull: quickhull.o QH.o Types.o + diff --git a/examples/quickhull/QH.hs b/examples/quickhull/QH.hs new file mode 100644 --- /dev/null +++ b/examples/quickhull/QH.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE PArr #-} +{-# OPTIONS -fvectorise #-} + +module QH (quickHull) where + +import Types + +import Data.Array.Parallel.Prelude +import Data.Array.Parallel.Prelude.Double +import qualified Data.Array.Parallel.Prelude.Int as Int + +import qualified Prelude + +distance :: Point -> Line -> Double +distance (Point xo yo) (Line (Point x1 y1) (Point x2 y2)) + = (x1-xo) * (y2 - yo) - (y1 - yo) * (x2 - xo) + +hsplit points line@(Line p1 p2) + | lengthP packed Int.< 2 = singletonP p1 +:+ packed + | otherwise + = concatP [: hsplit packed ends + | ends <- singletonP (Line p1 pm) +:+ singletonP (Line pm p2) :] + where + cross = [: distance p line | p <- points :] + packed = [: p | (p,c) <- zipP points cross, c > 0.0 :] + + pm = points !: maxIndexP cross + +quickHull' points + = concatP [: hsplit points ends + | ends <- singletonP (Line minx maxx) + +:+ singletonP (Line maxx minx) :] + where + xs = [: x | Point x y <- points :] + minx = points !: minIndexP xs + maxx = points !: maxIndexP xs + +quickHull :: PArray Point -> PArray Point +quickHull ps = toPArrayP (quickHull' (fromPArrayP ps)) + diff --git a/examples/quickhull/Types.hs b/examples/quickhull/Types.hs new file mode 100644 --- /dev/null +++ b/examples/quickhull/Types.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE PArr #-} +{-# OPTIONS -fvectorise #-} + +module Types ( Point(..), Line(..), points, xsOf, ysOf) where + +import Data.Array.Parallel.Prelude + +data Point = Point Double Double +data Line = Line Point Point + +points' :: [:Double:] -> [:Double:] -> [:Point:] +points' xs ys = zipWithP Point xs ys + +points :: PArray Double -> PArray Double -> PArray Point +points xs ys = toPArrayP (points' (fromPArrayP xs) (fromPArrayP ys)) + +xsOf' :: [:Point:] -> [:Double:] +xsOf' ps = [: x | Point x _ <- ps :] + +xsOf :: PArray Point -> PArray Double +xsOf ps = toPArrayP (xsOf' (fromPArrayP ps)) + +ysOf' :: [:Point:] -> [:Double:] +ysOf' ps = [: y | Point _ y <- ps :] + +ysOf :: PArray Point -> PArray Double +ysOf ps = toPArrayP (ysOf' (fromPArrayP ps)) + + diff --git a/examples/quickhull/quickhull.hs b/examples/quickhull/quickhull.hs new file mode 100644 --- /dev/null +++ b/examples/quickhull/quickhull.hs @@ -0,0 +1,18 @@ +import Types +import QH + +import Data.Array.Parallel.Lifted +import Data.Array.Parallel.Unlifted + +pts = points (fromUArrPA' (toU (map fst coords))) + (fromUArrPA' (toU (map snd coords))) + where + coords = [(3,3),(2,7),(0,0),(8,5), (4,6),(5,3),(9,6),(10,0)] + +result = zip (fromU (toUArrPA (xsOf ps))) + (fromU (toUArrPA (ysOf ps))) + where + ps = quickHull pts + +main = print result + diff --git a/examples/ref/DotProd.hs b/examples/ref/DotProd.hs new file mode 100644 --- /dev/null +++ b/examples/ref/DotProd.hs @@ -0,0 +1,254 @@ +-- Simple computation of the dot product in Haskell (using various array +-- implementations) +-- +-- Compile and run with +-- +-- ghc -ffi -O2 -fliberate-case-threshold100 -o dotprod DotProd.hs dotprod.o\ +-- && ./dotprod +RTS -K10M + +-- standard libraries +import CPUTime +import Random + +-- FFI +import Foreign +import Foreign.C + +-- GHC libraries +import Data.Array +import Data.Array.Unboxed (UArray) +import qualified + Data.Array.Unboxed as U +import Control.Exception (evaluate) +import System.Mem (performGC) + + +-- arrays types +-- +type Vector = Array Int Float +type UVector = UArray Int Float +type CVector = Ptr Float + +-- generates a random vector of the given length in NF +-- +generateVector :: Int -> IO Vector +generateVector n = + do + rg <- newStdGen + let fs = take n $ randomRs (-100, 100) rg + arr = listArray (0, n - 1) fs + evaluate $ sum (elems arr) -- make sure it is brought in NF + return arr + +-- convert a vector into an UVector in NF +-- +vectorToUVector :: Vector -> IO UVector +vectorToUVector v = + do + let uv = U.listArray (bounds v) . elems $ v + evaluate $ sum (U.elems uv) + return uv + +-- convert a vector into a CVector in NF +-- +vectorToCVector :: Vector -> IO CVector +vectorToCVector v = newArray (elems v) + +-- compute the dot product +-- + +-- vanilla +vectorDP1a :: Vector -> Vector -> IO Float +{-# NOINLINE vectorDP1a #-} +vectorDP1a v1 v2 = do + let r = sum [x * y | x <- elems v1 | y <- elems v2] + evaluate r + +-- vanilla +vectorDP1b :: Vector -> Vector -> IO Float +{-# NOINLINE vectorDP1b #-} +vectorDP1b v1 v2 = do + let r = sum [v1!i * v2!i | i <- indices v1] + evaluate r + +-- array combinators +vectorDP2 :: Vector -> Vector -> IO Float +{-# NOINLINE vectorDP2 #-} +vectorDP2 v1 v2 = do + let r = sumA (zipWithA (*) v1 v2) + evaluate r + where + zipWithA f v1 v2 = listArray (0, n1) (loop 0) + where + n1 = snd (U.bounds v1) + loop i | i > n1 = [] + | otherwise = f (v1!i) (v2!i) : loop (i + 1) + -- + sumA v = loop 0 + where + n1 = snd (U.bounds v) + loop i | i > n1 = 0 + | otherwise = v!i + loop (i + 1) + +-- explicit loop +vectorDP3 :: Vector -> Vector -> IO Float +{-# NOINLINE vectorDP3 #-} +vectorDP3 v1 v2 = + do + let n1 = snd (U.bounds v1) + r = loop 0 + where + loop i | i > n1 = 0 + | otherwise = v1!i * v2!i + loop (i + 1) + evaluate r + +-- explicit loop w/ acc +vectorDP4 :: Vector -> Vector -> IO Float +{-# NOINLINE vectorDP4 #-} +vectorDP4 v1 v2 = + do + let n1 = snd (U.bounds v1) + r = loop 0 0 + where + loop i a | i > n1 = a + | otherwise = loop (i + 1) (v1!i * v2!i + a) + evaluate r + +-- vanilla +uvectorDP1a :: UVector -> UVector -> IO Float +{-# NOINLINE uvectorDP1a #-} +uvectorDP1a v1 v2 = do + let r = sum $ zipWith (*) (U.elems v1) (U.elems v2) + evaluate r + +-- vanilla +uvectorDP1b :: UVector -> UVector -> IO Float +{-# NOINLINE uvectorDP1b #-} +uvectorDP1b v1 v2 = do + let r = sum [v1 U.!i * v2 U.!i | i <- U.indices v1] + evaluate r + +-- array combinators +uvectorDP2 :: UVector -> UVector -> IO Float +{-# NOINLINE uvectorDP2 #-} +uvectorDP2 v1 v2 = do + let r = sumA (zipWithA (*) v1 v2) + evaluate r + where + zipWithA :: (Float -> Float -> Float) -> UVector -> UVector -> UVector + zipWithA f v1 v2 = U.listArray (0, n1) (loop 0) + where + n1 = snd (U.bounds v1) + loop i | i > n1 = [] + | otherwise = f (v1 U.!i) (v2 U.!i) : loop (i + 1) + -- + sumA v = loop 0 + where + n1 = snd (U.bounds v) + loop i | i > n1 = 0 + | otherwise = v U.!i + loop (i + 1) + +-- explicit loop +uvectorDP3 :: UVector -> UVector -> IO Float +{-# NOINLINE uvectorDP3 #-} +uvectorDP3 v1 v2 = + do + let n1 = snd (U.bounds v1) + r = loop 0 + where + loop i | i > n1 = 0 + | otherwise = v1 U.!i * v2 U.!i + loop (i + 1) + evaluate r + -- NB: main difference in Core to vectorDP3 is that here the compiler + -- decided to first go into the recursion and then do the indexing of v1 + -- and v2, whereas in vectorDP3 it's the other way around + +-- explicit loop w/ acc +uvectorDP4 :: UVector -> UVector -> IO Float +{-# NOINLINE uvectorDP4 #-} +uvectorDP4 v1 v2 = + do + let n1 = snd (U.bounds v1) + r = loop 0 0 + where + loop i a | i > n1 = a + | otherwise = loop (i + 1) (v1 U.!i * v2 U.!i + a) + evaluate r + -- NB: this generates perfect code + +-- merciless C code +foreign import ccall "dotprod.h" + cvectorDP :: CVector -> CVector -> Int -> IO Float + +-- execute a function and print the result and execution time +-- +execAndTime :: String -- description + -> IO Float -- benchmarked computation + -> IO () +execAndTime desc comp = + do + putStrLn $ "\n*** " ++ desc + performGC + start <- getCPUTime + result <- comp + end <- getCPUTime + let duration = (end - start) `div` 1000000000 + putStrLn $ "Result : " ++ show result + putStrLn $ "Running time: " ++ show duration ++ "ms" + +main :: IO () +main = do + putStrLn "Dot product benchmark" + putStrLn "=====================" + putStrLn $ "[time resolution: " ++ show (cpuTimePrecision `div` 1000000000)++ + "ms]" + -- + v1 <- generateVector 10000 + v2 <- generateVector 10000 + execAndTime "H98 arrays (ind'd compr) [n = 10000]" (vectorDP1b v1 v2) + -- + v1 <- generateVector 20000 + v2 <- generateVector 20000 + execAndTime "H98 arrays (ind'd compr) [n = 20000]" (vectorDP1b v1 v2) + -- + v1 <- generateVector 50000 + v2 <- generateVector 50000 + execAndTime "H98 arrays (par compr) [n = 50000]" (vectorDP1a v1 v2) + execAndTime "H98 arrays (ind'd compr) [n = 50000]" (vectorDP1b v1 v2) + execAndTime "H98 arrays (combinator-based) [n = 50000]" (vectorDP2 v1 v2) + execAndTime "H98 arrays (explicit loop) [n = 50000]" (vectorDP3 v1 v2) + execAndTime "H98 arrays (explicit loop w/ acc) [n = 50000]" (vectorDP4 v1 v2) + uv1 <- vectorToUVector v1 + uv2 <- vectorToUVector v2 + execAndTime "UArray (par compr) [n = 50000]" (uvectorDP1a uv1 uv2) + execAndTime "UArray (ind'd compr) [n = 50000]" (uvectorDP1b uv1 uv2) + execAndTime "UArray (combinator-based) [n = 50000]" (uvectorDP2 uv1 uv2) + execAndTime "UArray (explicit loop) [n = 50000]" (uvectorDP3 uv1 uv2) + execAndTime "UArray (explicit loop w/ acc) [n = 50000]" (uvectorDP4 uv1 uv2) + -- + v1 <- generateVector 100000 + v2 <- generateVector 100000 + execAndTime "H98 arrays (par compr) [n = 100000]" (vectorDP1a v1 v2) + execAndTime "H98 arrays (ind'd compr) [n = 100000]" (vectorDP1b v1 v2) + execAndTime "H98 arrays (combinator-based) [n = 100000]" (vectorDP2 v1 v2) + execAndTime "H98 arrays (explicit loop) [n = 100000]" (vectorDP3 v1 v2) + execAndTime "H98 arrays (explicit loop w/ acc) [n = 100000]"(vectorDP4 v1 v2) + uv1 <- vectorToUVector v1 + uv2 <- vectorToUVector v2 + execAndTime "UArray (par compr) [n = 100000]" (uvectorDP1a uv1 uv2) + execAndTime "UArray (ind'd compr) [n = 100000]" (uvectorDP1b uv1 uv2) + execAndTime "UArray (combinator-based) [n = 100000]" (uvectorDP2 uv1 uv2) + execAndTime "UArray (explicit loop) [n = 100000]" (uvectorDP3 uv1 uv2) + execAndTime "UArray (explicit loop w/ acc) [n = 100000]" (uvectorDP4 uv1 uv2) + cv1 <- vectorToCVector v1 + cv2 <- vectorToCVector v2 + execAndTime "C [n = 100000]" (cvectorDP cv1 cv2 100000) + -- + v1 <- generateVector 500000 + v2 <- generateVector 500000 + uv1 <- vectorToUVector v1 + uv2 <- vectorToUVector v2 + execAndTime "UArray (explicit loop w/ acc) [n = 500000]" (uvectorDP4 uv1 uv2) + cv1 <- vectorToCVector v1 + cv2 <- vectorToCVector v2 + execAndTime "C [n = 500000]" (cvectorDP cv1 cv2 500000) diff --git a/examples/ref/MatVecMul.hs b/examples/ref/MatVecMul.hs new file mode 100644 --- /dev/null +++ b/examples/ref/MatVecMul.hs @@ -0,0 +1,303 @@ +-- Matrix vector multiplication in Haskell (using various array +-- implementations) +-- +-- NB: To be precise, we measure the computation of the vector sum of the +-- result vector of the matrix vector multiplication. +-- +-- Compile and run with +-- +-- ghc -ffi -O2 -fliberate-case-threshold100 -o matvecmul MatVecMul.hs\ +-- matvecmul.o && ./matvecmul +RTS -K30M + +-- standard libraries +import CPUTime +import Monad +import Random + +-- FFI +import Foreign +import Foreign.C + +-- GHC libraries +import Data.Array +import Data.Array.IArray (IArray) +import Data.Array.Unboxed (UArray) +import qualified + Data.Array.Unboxed as U +import Data.Array.MArray (newArray_, unsafeFreeze, writeArray) +import Data.Array.ST (STUArray) +import Control.Monad.ST (ST, runST) +import Control.Exception (evaluate) +import System.Mem (performGC) + +import Data.Array.Base (unsafeAt) +import GHC.Arr (unsafeIndex) + + +-- arrays types +-- +type Vector = Array Int Float +type Matrix = Array (Int, Int) Float +type UVector = UArray Int Float +type UMatrix = UArray (Int, Int) Float +type CVector = Ptr Float +type CMatrix = Ptr Float + + +-- generates a random vector of the given length in NF +-- +generateVector :: Int -> IO Vector +generateVector n = + do + rg <- newStdGen + let fs = take n $ randomRs (-100, 100) rg + arr = listArray (0, n - 1) fs + evaluate $ sum (elems arr) -- make sure it is brought in NF + return arr + +-- generates a random square matrix in NF +-- +generateMatrix :: Int -> IO Matrix +generateMatrix n = + do + rg <- newStdGen + let fs = take (n * n) $ randomRs (-100, 100) rg + arr = listArray ((0, 0), (n - 1, n - 1)) fs + evaluate $ sum (elems arr) -- make sure it is brought in NF + return arr + +-- convert a standard Haskell array into an unboxed array in NF +-- +arrayToIArray :: (Ix i, IArray arr e, Num e) => Array i e -> IO (arr i e) +arrayToIArray a = + do + let ia = U.listArray (bounds a) . elems $ a + evaluate $ sum (U.elems ia) + return ia + +-- convert a vector into a CVector in NF +-- +arrayToCArray :: (Ix i, Storable e) => Array i e -> IO (Ptr e) +arrayToCArray a = newArray (elems a) + +-- compute the dot product +-- + +-- vanilla +mvm1 :: Matrix -> Vector -> IO (Vector, Float) +{-# NOINLINE mvm1 #-} +mvm1 a v = do + let (n, m) = snd (bounds a) + r = listArray (0, n) + [sum [a!(i,j) * v!j| j <- [0..m]] + | i <- [0..n]] + s <- evaluate $ sum (elems r) + return (r, s) -- returning both guarantees that the sum can't be + -- fused into the main computations + +-- explicit inner loop +mvm3 :: Matrix -> Vector -> IO (Vector, Float) +{-# NOINLINE mvm3 #-} +mvm3 a v = do + let (n, m) = snd (bounds a) + r = listArray (0, n) [loop i 0 | i <- [0..n]] + where + loop i j | j > m = 0 + | otherwise = a!(i,j) * v!j + loop i (j + 1) + s <- evaluate $ sum (elems r) + return (r, s) -- returning both guarantees that the sum can't be + -- fused into the main computations + +-- explicit inner loop w/ acc +mvm4 :: Matrix -> Vector -> IO (Vector, Float) +{-# NOINLINE mvm4 #-} +mvm4 a v = do + let (n, m) = snd (bounds a) + r = listArray (0, n) [loop i 0 0 | i <- [0..n]] + where + loop i j acc + | j > m = acc + | otherwise = loop i (j + 1) (acc + a!(i,j) * v!j) + s <- evaluate $ sum (elems r) + return (r, s) -- returning both guarantees that the sum can't be + -- fused into the main computations + +-- vanilla +umvm1 :: UMatrix -> UVector -> IO (UVector, Float) +{-# NOINLINE umvm1 #-} +umvm1 a v = do + let (n, m) = snd (U.bounds a) + r = U.listArray (0, n) + [sum [a U.!(i,j) * v U.!j | j <- [0..m]] + | i <- [0..n]] + s <- evaluate $ sum (U.elems r) + return (r, s) -- returning both guarantees that the sum can't be + -- fused into the main computations + +-- explicit inner loop +umvm3 :: UMatrix -> UVector -> IO (UVector, Float) +{-# NOINLINE umvm3 #-} +umvm3 a v = do + let (n, m) = snd (U.bounds a) + r = U.listArray (0, n) [loop i 0 | i <- [0..n]] + where + loop i j | j > m = 0 + | otherwise = a U.!(i,j) * v U.!j + + loop i (j + 1) + s <- evaluate $ sum (U.elems r) + return (r, s) -- returning both guarantees that the sum can't be + -- fused into the main computations + +-- explicit inner loop w/ acc +umvm4a :: UMatrix -> UVector -> IO (UVector, Float) +{-# NOINLINE umvm4a #-} +umvm4a a v = do + let (n, m) = snd (U.bounds a) + r = U.listArray (0, n) [loop i 0 0 | i <- [0..n]] + where + loop i j acc + | j > m = acc + | otherwise = loop i (j + 1) + (acc + a U.!(i,j) * v U.!j) + s <- evaluate $ sum (U.elems r) + return (r, s) -- returning both guarantees that the sum can't be + -- fused into the main computations + +-- explicit inner loop w/ acc forcing inlining +umvm4b :: UMatrix -> UVector -> IO (UVector, Float) +{-# NOINLINE umvm4b #-} +umvm4b a v = do + let (n, m) = snd (U.bounds a) + r = U.listArray (0, n) [loop i 0 0 | i <- [0..n]] + where + loop i j acc + | j > m = acc + | otherwise = loop i (j + 1) + (acc + a !!!(i,j) * v !!!j) + s <- evaluate $ sum (U.elems r) + return (r, s) -- returning both guarantees that the sum can't be + -- fused into the main computations + +-- ST monad for array creation +umvm5 :: UMatrix -> UVector -> IO (UVector, Float) +{-# NOINLINE umvm5 #-} +umvm5 a v = do + let (n, m) = snd (U.bounds a) + r = runST (do + ma <- newArray_ (0, n) + outerLoop ma 0 + unsafeFreeze ma + ) + where + outerLoop :: STUArray s Int Float -> Int -> ST s () + outerLoop ma i + | i > n = return () + | otherwise = do + writeArray ma i (loop i 0 0) + outerLoop ma (i + 1) + loop i j acc + | j > m = acc + | otherwise = loop i (j + 1) +-- (acc + a U.!(i,j) * v U.!j) + (acc + a !!!(i,j) * v !!!j) + s <- evaluate $ sum (U.elems r) + return (r, s) -- returning both guarantees that the sum can't be + -- fused into the main computations + +-- Forcing the inlining of indexing +(!!!) :: (IArray a e, Ix i) => a i e -> i -> e +{-# INLINE (!!!) #-} +arr !!! i | (l,u) <- U.bounds arr = unsafeAt arr (unsafeIndex (l,u) i) +--arr !!! i | (l,u) <- U.bounds arr = unsafeAt arr (index (l,u) i) + where + index b i | U.inRange b i = unsafeIndex b i + | otherwise = error "Error in array index" + + +-- merciless C code +foreign import ccall "matvecmul.h" + cmvm :: CMatrix -> CVector -> Int -> IO Float + -- returns sum only as the C compiler won't fuse the sum in to the loop + -- anyway + +-- execute a function and print the result and execution time +-- +execAndTime :: String -- description + -> IO Float -- benchmarked computation + -> IO () +execAndTime desc comp = + do + putStrLn $ "\n*** " ++ desc + performGC + start <- getCPUTime + result <- comp + end <- getCPUTime + let duration = (end - start) `div` 1000000000 + putStrLn $ "Result sum : " ++ show result + putStrLn $ "Running time: " ++ show duration ++ "ms" + +main :: IO () +main = do + putStrLn "Matrix vector multiplication benchmark" + putStrLn "======================================" + putStrLn $ "[time resolution: " ++ show (cpuTimePrecision `div` 1000000000)++ + "ms]" + -- + m <- generateMatrix 100 + v <- generateVector 100 + execAndTime "H98 arrays (compr) [n = 100]" (liftM snd $ mvm1 m v) + -- + m <- generateMatrix 200 + v <- generateVector 200 + execAndTime "H98 arrays (compr) [n = 200]" (liftM snd $ mvm1 m v) + execAndTime "H98 arrays (explicit inner loop) [n = 200]" + (liftM snd $ mvm3 m v) + execAndTime "H98 arrays (explicit inner loop w/ acc) [n = 200]" + (liftM snd $ mvm4 m v) + -- + m <- generateMatrix 400 + v <- generateVector 400 + execAndTime "H98 arrays (compr) [n = 400]" (liftM snd $ mvm1 m v) + execAndTime "H98 arrays (explicit inner loop) [n = 400]" + (liftM snd $ mvm3 m v) + execAndTime "H98 arrays (explicit inner loop w/ acc) [n = 400]" + (liftM snd $ mvm4 m v) + um <- arrayToIArray m + uv <- arrayToIArray v + execAndTime "UArray (compr) [n = 400]" (liftM snd $ umvm1 um uv) + execAndTime "UArray (explicit inner loop) [n = 400]" + (liftM snd $ umvm3 um uv) + execAndTime "UArray (explicit inner loop w/ acc) [n = 400]" + (liftM snd $ umvm4a um uv) + execAndTime "UArray (explicit inner loop w/ acc & inlining) [n = 400]" + (liftM snd $ umvm4b um uv) + execAndTime "UArray (ST monad and loop) [n = 400]" + (liftM snd $ umvm5 um uv) + -- + m <- generateMatrix 800 + v <- generateVector 800 + execAndTime "H98 arrays (compr) [n = 800]" (liftM snd $ mvm1 m v) + execAndTime "H98 arrays (explicit inner loop) [n = 800]" + (liftM snd $ mvm3 m v) + execAndTime "H98 arrays (explicit inner loop w/ acc) [n = 800]" + (liftM snd $ mvm4 m v) + um <- arrayToIArray m + uv <- arrayToIArray v + execAndTime "UArray (compr) [n = 800]" (liftM snd $ umvm1 um uv) + execAndTime "UArray (explicit inner loop) [n = 800]" + (liftM snd $ umvm3 um uv) + execAndTime "UArray (explicit inner loop w/ acc) [n = 800]" + (liftM snd $ umvm4a um uv) + execAndTime "UArray (explicit inner loop w/ acc & inlining) [n = 800]" + (liftM snd $ umvm4b um uv) + execAndTime "UArray (ST monad and loop) [n = 800]" + (liftM snd $ umvm5 um uv) + cm <- arrayToCArray m + cv <- arrayToCArray v + execAndTime "C [n = 800]" (cmvm cm cv 800) + -- + m <- generateMatrix 1000 + v <- generateVector 1000 + cm <- arrayToCArray m + cv <- arrayToCArray v + execAndTime "C [n = 1000]" (cmvm cm cv 1000) diff --git a/examples/ref/README b/examples/ref/README new file mode 100644 --- /dev/null +++ b/examples/ref/README @@ -0,0 +1,2 @@ +These are reference implementations of dot product and matrix-vector +multiplication for comparison purposes. They don't use parallel arrays. diff --git a/examples/ref/dotprod.c b/examples/ref/dotprod.c new file mode 100644 --- /dev/null +++ b/examples/ref/dotprod.c @@ -0,0 +1,11 @@ +// gcc -c -O6 dotprod.c + +float cvectorDP (float *v1, float *v2, int n) +{ + int i; + float sum = 0; + + for (i = 0; i < n; i++) + sum += v1[i] * v2[i]; + return sum; +} diff --git a/examples/ref/dotprod.h b/examples/ref/dotprod.h new file mode 100644 --- /dev/null +++ b/examples/ref/dotprod.h @@ -0,0 +1,6 @@ +#ifndef DOTPROD_H +#define DOTPROD_H + +float cvectorDP (float *v1, float *v2, int n); + +#endif diff --git a/examples/ref/matvecmul.c b/examples/ref/matvecmul.c new file mode 100644 --- /dev/null +++ b/examples/ref/matvecmul.c @@ -0,0 +1,23 @@ +// gcc -c -O2 matvecmul.c + +#include + +float cmvm (float *m, float *v, int n) +{ + int i, j; + float *result, sum; + + result = (float*) malloc (n * sizeof (float)); + for (i = 0; i < n; i++) { + sum = 0; + for (j = 0; j < n; j++) + sum += m[i * n + j] * v[j]; + result[i] = sum; + } + + sum = 0; + for (i = 0; i < n; i++) + sum += result[i]; + + return sum; +} diff --git a/examples/ref/matvecmul.h b/examples/ref/matvecmul.h new file mode 100644 --- /dev/null +++ b/examples/ref/matvecmul.h @@ -0,0 +1,6 @@ +#ifndef MATVECMUL_H +#define MATVECMUL_H + +float cmvm (float *v1, float *v2, int n); + +#endif diff --git a/examples/simple/DotProd.hs b/examples/simple/DotProd.hs new file mode 100644 --- /dev/null +++ b/examples/simple/DotProd.hs @@ -0,0 +1,46 @@ +module DotProd +where + +import Data.Array.Parallel.Unlifted + +test :: UArr Float -> UArr Float -> Float +test v w = loopAcc + . loopU (\a (x:*:y) -> (a + x * y :*: (Nothing::Maybe ()))) 0 + $ zipU v w + + +{- Inner loop: + + poly_$wtrans_s15C :: forall s1_aZb. + GHC.Prim.Int# + -> GHC.Base.Int + -> GHC.Prim.Float# + -> GHC.Prim.State# s1_aZb + -> (# GHC.Prim.State# s1_aZb, (GHC.Float.Float, GHC.Base.Int) #) + [Arity 4] + poly_$wtrans_s15C = + \ (@ s1_X10d) + (ww_X164 :: GHC.Prim.Int#) + (w1_X167 :: GHC.Base.Int) + (ww1_X16b :: GHC.Prim.Float#) + (w2_X16e :: GHC.Prim.State# s1_X10d) -> + case GHC.Prim.==# ww_X164 wild2_B1 of wild4_XVx { + GHC.Base.False -> + poly_$wtrans_s15C + @ s1_X10d + (GHC.Prim.+# ww_X164 1) + w1_X167 + (GHC.Prim.plusFloat# + ww1_X16b + (GHC.Prim.timesFloat# + (GHC.Prim.indexFloatArray# rb2_aXC (GHC.Prim.+# rb_aXx ww_X164)) + (GHC.Prim.indexFloatArray# rb21_X11Y (GHC.Prim.+# rb11_X11T ww_X164)))) + w2_X16e; + GHC.Base.True -> + case w1_X167 of tpl_aZj { GHC.Base.I# a1_aZk -> + (# w2_X16e, ((GHC.Float.F# ww1_X16b), tpl_aZj) #) + } + }; + } in + +-} diff --git a/examples/simple/MapInc.hs b/examples/simple/MapInc.hs new file mode 100644 --- /dev/null +++ b/examples/simple/MapInc.hs @@ -0,0 +1,34 @@ +module MapInc +where + +import Data.Array.Parallel.Unlifted + +test :: UArr Int -> UArr Int +test = loopArr . loopU (\_ x -> (() :*: (Just $ x + 1 :: Maybe Int))) () + + +{- Inner loop: + + $wtrans_sVe = + \ (ww_sUI :: GHC.Prim.Int#) + (ww1_sUM :: GHC.Prim.Int#) + (w_sUO :: ()) + (w1_sUP :: GHC.Prim.State# s_aIR) -> + case GHC.Prim.==# ww_sUI rb1_aUd of wild12_aHq { + GHC.Base.False -> + case GHC.Prim.writeIntArray# + @ s_aIR + marr#_aOV + ww1_sUM + (GHC.Prim.+# (GHC.Prim.indexIntArray# rb2_aUe (GHC.Prim.+# rb_aL4 ww_sUI)) 1) + w1_sUP + of s2#1_aRq { __DEFAULT -> + $wtrans_sVe (GHC.Prim.+# ww_sUI 1) (GHC.Prim.+# ww1_sUM 1) GHC.Base.() s2#1_aRq + }; + GHC.Base.True -> + case w_sUO of tpl1_aJ1 { () -> + (# w1_sUP, (GHC.Base.(), (GHC.Base.I# ww1_sUM)) #) + } + }; + +-} diff --git a/examples/simple/PrefixSum.hs b/examples/simple/PrefixSum.hs new file mode 100644 --- /dev/null +++ b/examples/simple/PrefixSum.hs @@ -0,0 +1,38 @@ +module PrefixSum +where + +import Data.Array.Parallel.Unlifted + +test :: UArr Int -> UArr Int +test = loopArr . loopU (\a x -> (a + x :*: Just a)) 0 + + +{- Inner loop: + + $wtrans_sV2 :: GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.State# s_aIq + -> (# GHC.Prim.State# s_aIq, (GHC.Base.Int, GHC.Base.Int) #) + [Arity 4 + Str: DmdType LLLL] + $wtrans_sV2 = + \ (ww_sUt :: GHC.Prim.Int#) + (ww1_sUx :: GHC.Prim.Int#) + (ww2_sUB :: GHC.Prim.Int#) + (w_sUD :: GHC.Prim.State# s_aIq) -> + case GHC.Prim.==# ww_sUt rb1_aU1 of wild12_aH7 { + GHC.Base.False -> + case GHC.Prim.writeIntArray# @ s_aIq marr#_aOv ww1_sUx ww2_sUB w_sUD + of s2#1_aRd { __DEFAULT -> + $wtrans_sV2 + (GHC.Prim.+# ww_sUt 1) + (GHC.Prim.+# ww1_sUx 1) + (GHC.Prim.+# + ww2_sUB (GHC.Prim.indexIntArray# rb2_aU2 (GHC.Prim.+# rb_aKE ww_sUt))) + s2#1_aRd + }; + GHC.Base.True -> (# w_sUD, ((GHC.Base.I# ww2_sUB), (GHC.Base.I# ww1_sUx)) #) + }; + +-} diff --git a/examples/simple/SegPrefixSum.hs b/examples/simple/SegPrefixSum.hs new file mode 100644 --- /dev/null +++ b/examples/simple/SegPrefixSum.hs @@ -0,0 +1,106 @@ +module SegPrefixSum +where + +import Data.Array.Parallel.Unlifted + +test :: SUArr Int -> SUArr Int +test = fstS + . loopArr + . loopSU (\a x -> ((a + x::Int) :*: Just a)) + (\a i -> (a :*: (Nothing :: Maybe ()))) 0 + + +{- Inner loop: + + $wtrans_s1aH :: GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.State# s_aLt + -> (# GHC.Prim.State# s_aLt, (GHC.Base.Int, GHC.Base.Int) #) + [Arity 6 + Str: DmdType LLLLLL] + $wtrans_s1aH = + \ (ww7_s19k :: GHC.Prim.Int#) + (ww8_s19o :: GHC.Prim.Int#) + (ww9_s19s :: GHC.Prim.Int#) + (ww10_s19w :: GHC.Prim.Int#) + (ww11_s19A :: GHC.Prim.Int#) + (w_s19C :: GHC.Prim.State# s_aLt) -> + case ww8_s19o of wild14_X1X { + __DEFAULT -> + case GHC.Prim.readIntArray# @ s_aLt marr#1_XQl ww9_s19s w_s19C + of wild2_aVH { (# s2#3_aVJ, r#_aVK #) -> + case GHC.Prim.readIntArray# @ s_aLt marr#_aPk ww9_s19s s2#3_aVJ + of wild21_XXy { (# s2#4_XXB, r#1_XXD #) -> + case GHC.Prim.writeIntArray# + @ s_aLt marr#2_XQt (GHC.Prim.+# r#_aVK r#1_XXD) ww11_s19A s2#4_XXB + of s2#5_aWC { __DEFAULT -> + case GHC.Prim.writeIntArray# + @ s_aLt marr#_aPk ww9_s19s (GHC.Prim.+# r#1_XXD 1) s2#5_aWC + of s2#6_XZ5 { __DEFAULT -> + $wtrans_s1aH + (GHC.Prim.+# ww7_s19k 1) + (GHC.Prim.-# wild14_X1X 1) + ww9_s19s + ww10_s19w + (GHC.Prim.+# + ww11_s19A (GHC.Prim.indexIntArray# rb2_aOg (GHC.Prim.+# rb_aOd ww7_s19k))) + s2#6_XZ5 + } + } + } + }; + 0 -> + let { + a_s10T [Just L] :: GHC.Prim.Int# + [Str: DmdType] + a_s10T = GHC.Prim.+# ww9_s19s 1 + } in + case GHC.Prim.==# a_s10T ww1_s19O of wild3_aLw { + GHC.Base.False -> + case a_s10T of wild2_X3e { + __DEFAULT -> + case GHC.Prim.readIntArray# @ s_aLt marr#1_XQl (GHC.Prim.-# wild2_X3e 1) w_s19C + of wild21_aVH { (# s2#3_aVJ, r#_aVK #) -> + case GHC.Prim.readIntArray# @ s_aLt marr#_aPk (GHC.Prim.-# wild2_X3e 1) s2#3_aVJ + of wild22_XXY { (# s2#4_XY1, r#1_XY3 #) -> + case GHC.Prim.writeIntArray# + @ s_aLt marr#1_XQl wild2_X3e (GHC.Prim.+# r#_aVK r#1_XY3) s2#4_XY1 + of s2#5_aWC { __DEFAULT -> + case GHC.Prim.writeIntArray# @ s_aLt marr#_aPk wild2_X3e 0 s2#5_aWC + of s2#6_XYN { __DEFAULT -> + $wtrans_s1aH + ww7_s19k + (GHC.Prim.indexIntArray# ww2_s19P (GHC.Prim.+# ww_s19N wild2_X3e)) + wild2_X3e + ww10_s19w + ww11_s19A + s2#6_XYN + } + } + } + }; + 0 -> + case GHC.Prim.writeIntArray# @ s_aLt marr#1_XQl 0 0 w_s19C + of s2#3_aWC { __DEFAULT -> + case GHC.Prim.writeIntArray# @ s_aLt marr#_aPk 0 0 s2#3_aWC + of s2#4_XYN { __DEFAULT -> + $wtrans_s1aH + ww7_s19k + (GHC.Prim.indexIntArray# ww2_s19P ww_s19N) + 0 + ww10_s19w + ww11_s19A + s2#4_XYN + } + } + }; + GHC.Base.True -> + (# w_s19C, ((GHC.Base.I# ww10_s19w), (GHC.Base.I# ww11_s19A)) #) + } + }; + } in + +-} diff --git a/examples/simple/SegSum.hs b/examples/simple/SegSum.hs new file mode 100644 --- /dev/null +++ b/examples/simple/SegSum.hs @@ -0,0 +1,129 @@ +module SegSum +where + +import Data.Array.Parallel.Unlifted + +test :: SUArr Int -> UArr Int +test = sndS + . loopArr + . loopSU (\a x -> ((a + x::Int) :*: (Nothing::Maybe ()))) + (\a i -> (a :*: Just a)) 0 + +{- Inner loop: + + $wtrans_s19S :: GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.Int# + -> GHC.Prim.State# s_aLn + -> (# GHC.Prim.State# s_aLn, (GHC.Base.Int, GHC.Base.Int) #) + [Arity 6 + Str: DmdType LLLLLL] + $wtrans_s19S = + \ (ww_s18Y :: GHC.Prim.Int#) + (ww1_s192 :: GHC.Prim.Int#) + (ww2_s196 :: GHC.Prim.Int#) + (ww3_s19a :: GHC.Prim.Int#) + (ww4_s19e :: GHC.Prim.Int#) + (w_s19g :: GHC.Prim.State# s_aLn) -> + case ww1_s192 of wild2_X1p { + __DEFAULT -> + $wtrans_s19S + (GHC.Prim.+# ww_s18Y 1) + (GHC.Prim.-# wild2_X1p 1) + ww2_s196 + ww3_s19a + (GHC.Prim.+# + ww4_s19e (GHC.Prim.indexIntArray# rb21_aO7 (GHC.Prim.+# rb11_aO4 ww_s18Y))) + w_s19g; + 0 -> + let { + $w$j_s19W :: GHC.Prim.State# s_aLn + -> GHC.Prim.Int# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# s_aLn, (GHC.Base.Int, GHC.Base.Int) #) + [Arity 3 + Str: DmdType LLL] + $w$j_s19W = + \ (w1_s18H :: GHC.Prim.State# s_aLn) + (ww5_s18M :: GHC.Prim.Int#) + (ww6_s18Q :: GHC.Prim.Int#) -> + let { + a_s104 [Just L] :: GHC.Prim.Int# + [Str: DmdType] + a_s104 = GHC.Prim.+# ww2_s196 1 + } in + case GHC.Prim.==# a_s104 rb1_aJe of wild3_aLq { + GHC.Base.False -> + case a_s104 of wild31_X2J { + __DEFAULT -> + case GHC.Prim.readIntArray# + @ s_aLn marr#1_XPR (GHC.Prim.-# wild31_X2J 1) w1_s18H + of wild21_aXE { (# s2#3_aXG, r#_aXH #) -> + case GHC.Prim.readIntArray# + @ s_aLn marr#_aOP (GHC.Prim.-# wild31_X2J 1) s2#3_aXG + of wild22_XZY { (# s2#4_X101, r#1_X103 #) -> + case GHC.Prim.writeIntArray# + @ s_aLn marr#1_XPR wild31_X2J (GHC.Prim.+# r#_aXH r#1_X103) s2#4_X101 + of s2#5_aVX { __DEFAULT -> + case GHC.Prim.writeIntArray# @ s_aLn marr#_aOP wild31_X2J 0 s2#5_aVX + of s2#6_XYb { __DEFAULT -> + $wtrans_s19S + ww_s18Y + (GHC.Prim.indexIntArray# rb2_aJf (GHC.Prim.+# rb_aIC wild31_X2J)) + wild31_X2J + ww5_s18M + ww6_s18Q + s2#6_XYb + } + } + } + }; + 0 -> + case GHC.Prim.writeIntArray# @ s_aLn marr#1_XPR 0 0 w1_s18H + of s2#3_aVX { __DEFAULT -> + case GHC.Prim.writeIntArray# @ s_aLn marr#_aOP 0 0 s2#3_aVX + of s2#4_XYb { __DEFAULT -> + $wtrans_s19S + ww_s18Y + (GHC.Prim.indexIntArray# rb2_aJf rb_aIC) + 0 + ww5_s18M + ww6_s18Q + s2#4_XYb + } + } + }; + GHC.Base.True -> (# w1_s18H, ((GHC.Base.I# ww5_s18M), (GHC.Base.I# ww6_s18Q)) #) + } + } in + case ww2_s196 of wild3_X1P { + __DEFAULT -> + case GHC.Prim.writeIntArray# @ s_aLn marr#2_XQ3 ww3_s19a ww4_s19e w_s19g + of s2#3_aVX { __DEFAULT -> + $w$j_s19W s2#3_aVX (GHC.Prim.+# ww3_s19a 1) ww4_s19e + }; + (-1) -> $w$j_s19W w_s19g ww3_s19a ww4_s19e + } + }; + + +The matching C routine: + +void test (int arr[], int segd[], int n, int m, int out[], int *len) +{ + int acc = 0; + int arr_i, segd_i, seg_cnt; + + arr_i = 0; + for (segd_i = 0; segd_i < m; segd_i++) { + acc = 0; + for (seg_cnt = segd[segd_i]; seg_cnt == 0; seg_cnt--) + acc += arr[arr_i++]; + out[segd_i] = acc; + } + *len = m; +} + +-} diff --git a/examples/simple/Sum.hs b/examples/simple/Sum.hs new file mode 100644 --- /dev/null +++ b/examples/simple/Sum.hs @@ -0,0 +1,40 @@ +module Sum +where + +import Data.Array.Parallel.Unlifted + +test :: UArr Int -> Int +test = loopAcc . loopU (\a x -> (a + x :*: (Nothing::Maybe ()))) 0 + + +{- Inner loop: + + poly_$wtrans_sPp :: forall s1_aIm. + GHC.Prim.Int# + -> GHC.Base.Int + -> GHC.Prim.Int# + -> GHC.Prim.State# s1_aIm + -> (# GHC.Prim.State# s1_aIm, (GHC.Base.Int, GHC.Base.Int) #) + [Arity 4] + poly_$wtrans_sPp = + \ (@ s1_XJ3) + (ww_XPz :: GHC.Prim.Int#) + (w_XPC :: GHC.Base.Int) + (ww1_XPG :: GHC.Prim.Int#) + (w1_XPJ :: GHC.Prim.State# s1_XJ3) -> + case GHC.Prim.==# ww_XPz wild11_B1 of wild2_XHP { + GHC.Base.False -> + poly_$wtrans_sPp + @ s1_XJ3 + (GHC.Prim.+# ww_XPz 1) + w_XPC + (GHC.Prim.+# + ww1_XPG (GHC.Prim.indexIntArray# rb2_aPT (GHC.Prim.+# rb_aKA ww_XPz))) + w1_XPJ; + GHC.Base.True -> + case w_XPC of tpl_aIu { GHC.Base.I# a1_aIv -> + (# w1_XPJ, ((GHC.Base.I# ww1_XPG), tpl_aIu) #) + } + }; + +-} diff --git a/examples/smvm/Makefile b/examples/smvm/Makefile new file mode 100644 --- /dev/null +++ b/examples/smvm/Makefile @@ -0,0 +1,9 @@ +TESTDIR = .. +PROGS = mksm smvm-c smvm +HCCFLAGS = -optc-O3 +include $(TESTDIR)/mk/test.mk + +smvm.o: SMVMPar.hi SMVMSeq.hi SMVMVect.hi + +smvm: smvm.o SMVMPar.o SMVMSeq.o SMVMVect.o + diff --git a/examples/smvm/README b/examples/smvm/README new file mode 100644 --- /dev/null +++ b/examples/smvm/README @@ -0,0 +1,43 @@ +Mutliplication of a sparse matrix with a dense vector +===================================================== + +This is the algorithm discussed in "Data Parallel Haskell: a status report" +(http://www.cse.unsw.edu.au/~chak/papers/CLPKM07.html). See also +http://www.cs.cmu.edu/~scandal/nesl/alg-numerical.html#mvmult. + +smvm --help displays the available options. + +Generating test data +-------------------- + +mksm COLS ROWS RATION FILE + +generates a test matrix with COLS columns and ROWS rows and writes it to FILE. +RATIO determines the fill ration; e.g., 0.1 here generates a matrix with 9 out +10 of elements being zero. + +WARNING: The generated files can be quite large. For instance, a 10000x10000 +matrix with a fill ratio of 0.1 (i.e. with approx. 10 millions non-zero +elements) is over 150MB on my computer. Also, the files binary, i.e., they +have to be regenerated for every new architecture. Matrix generation can take +quite a long time as it is not optimised at all. + +Sequential C benchmark +---------------------- + +smvm-c FILE + +Benchmark +--------- + +smvm --help displays the available options. + +The following algorithms are supported: + + smvms - sequential implementation + smvmp - parallel implementation + + +No parallel implementation is available yet as the library is missing +functionality. + diff --git a/examples/smvm/SMVMPar.hs b/examples/smvm/SMVMPar.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/SMVMPar.hs @@ -0,0 +1,13 @@ +module SMVMPar +where + +import Data.Array.Parallel.Unlifted.Parallel +import Data.Array.Parallel.Unlifted + +type SparseMatrix = SUArr (Int :*: Double) +type SparseVector = UArr (Int :*: Double) +type Vector = UArr Double + +smvm :: SparseMatrix -> Vector -> Vector +smvm sm v = sumSUP (zipWithSUP (*) (bpermuteSUP' v (fstSU sm)) (sndSU sm)) + diff --git a/examples/smvm/SMVMSeq.hs b/examples/smvm/SMVMSeq.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/SMVMSeq.hs @@ -0,0 +1,12 @@ +module SMVMSeq +where + +import Data.Array.Parallel.Unlifted + +type SparseMatrix = SUArr (Int :*: Double) +type SparseVector = UArr (Int :*: Double) +type Vector = UArr Double + +smvm :: SparseMatrix -> Vector -> Vector +smvm sm v = sumSU (zipWithSU (*) (bpermuteSU' v (fstSU sm)) (sndSU sm)) + diff --git a/examples/smvm/SMVMVect.hs b/examples/smvm/SMVMVect.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/SMVMVect.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PArr #-} +{-# OPTIONS -fvectorise #-} +module SMVMVect (smvm) where + +import Data.Array.Parallel.Prelude +import Data.Array.Parallel.Prelude.Double +import Data.Array.Parallel.Prelude.Int (Int) + +import qualified Prelude + +smvm :: PArray (PArray (Int, Double)) -> PArray Double -> PArray Double +{-# NOINLINE smvm #-} +smvm m v = toPArrayP (smvm' (fromNestedPArrayP m) (fromPArrayP v)) + +smvm' :: [:[: (Int, Double) :]:] -> [:Double:] -> [:Double:] +smvm' m v = [: sumP [: x * (v !: i) | (i,x) <- row :] | row <- m :] + diff --git a/examples/smvm/mksm.c b/examples/smvm/mksm.c new file mode 100644 --- /dev/null +++ b/examples/smvm/mksm.c @@ -0,0 +1,187 @@ +#include +#include +#include +#include +#include +#include + +#include + +HsInt cols; +HsInt rows; +double ratio; + +HsInt *lengths; +HsInt *indices; + +enum { FLOAT, DOUBLE } type; + +HsDouble gen_doubles( int file, HsInt n ) +{ + HsDouble d; + HsDouble sum = 0; + + int a, b; + + while( n != 0 ) + { + a = random() % 1000; + b = random() % 1000; + if (a == 0 || b == 0) + d = 0.1; + else + d = ((HsDouble)a) / ((HsDouble)b); + + write( file, &d, sizeof(HsDouble) ); + sum += d; + --n; + } + return sum; +} + +HsFloat gen_floats( int file, HsInt n ) +{ + HsFloat d; + HsFloat sum = 0; + + int a, b; + + while( n != 0 ) + { + a = random() % 1000; + b = random() % 1000; + if (a == 0 || b == 0) + d = 0.1; + else + d = ((HsFloat)a) / ((HsFloat)b); + + write( file, &d, sizeof(HsFloat) ); + sum += d; + --n; + } + return sum; +} + + +HsInt gen_lengths() +{ + HsInt i; + HsInt n = 0; + + int range = ((double)cols * 2) * ratio; + + for( i = 0; i < rows; ++i ) { + lengths[i] = random() % range; + n += lengths[i]; + } + + return n; +} + +int find_index( int from, int to, HsInt idx ) +{ + while( from != to ) { + if( indices[from] == idx ) return 1; + ++from; + } + return 0; +} + +int cmp_HsInt( const void *p, const void *q ) +{ + HsInt x = *(HsInt *)p; + HsInt y = *(HsInt *)q; + + if( x < y ) return -1; + if( x > y ) return 1; + return 0; +} + +void gen_indices( int file ) +{ + HsInt i, j, k; + + k = 0; + for( i = 0; i < rows; ++i ) { + for( j = 0; j < lengths[i]; ++j ) { + do { + indices[j] = random() % cols; + } while( find_index( 0, j, indices[j] ) ); + } + qsort( indices, j, sizeof(HsInt), cmp_HsInt ); + write( file, indices, sizeof(HsInt) * j ); + } +} + +int usage() +{ + puts( "mksm [float|double] COLS ROWS RATIO FILE" ); + exit(1); +} + +int main( int argc, char *argv[] ) +{ + HsInt n; + + int file; + int arg; + + HsDouble sum1,sum2; + + if( argc == 1 || argc < 5 ) + usage(); + + if( isdigit( argv[1][0] ) ) + { + arg = 1; + type = DOUBLE; + } + else + { + arg = 2; + if( !strcmp( argv[1], "float" ) ) + type = FLOAT; + else if( !strcmp( argv[1], "double" ) ) + type = DOUBLE; + else + { + fputs( "Invalid type\n", stderr ); + usage(); + } + } + + cols = atoi( argv[arg++] ); + rows = atoi( argv[arg++] ); + ratio = atof( argv[arg++] ); + + lengths = (HsInt *)malloc( rows * sizeof(HsInt) ); + indices = (HsInt *)malloc( cols * sizeof(HsInt) ); + + if( arg >= argc ) + usage(); + + file = creat( argv[arg], 0666 ); + + n = gen_lengths(); + write( file, &rows, sizeof(rows) ); + write( file, lengths, sizeof(HsInt) * rows ); + write( file, &n, sizeof(n) ); + gen_indices( file ); + write( file, &n, sizeof(n) ); + if( type == DOUBLE ) + sum1 = gen_doubles(file, n); + else + sum1 = (HsDouble)gen_floats(file, n); + write( file, &cols, sizeof(cols) ); + if( type == DOUBLE ) + sum2 = gen_doubles(file, cols); + else + sum2 = (HsDouble)gen_floats(file, n); + close(file); + + printf( "columns = %d; rows = %d; elements = %d (%d)\n", cols, rows, n, + (int)(type == FLOAT ? sizeof(HsFloat) : sizeof(HsDouble)) ); + printf( "%Lf %Lf\n", (long double)sum1, (long double)sum2 ); + return 0; +} + diff --git a/examples/smvm/smvm-c.c b/examples/smvm/smvm-c.c new file mode 100644 --- /dev/null +++ b/examples/smvm/smvm-c.c @@ -0,0 +1,89 @@ +#include +#include +#include +#include +#include + +#include + +int rows; +int cols; + +typedef struct { + HsInt size; + void *data; +} Array; + +Array vector; +Array lengths; +Array indices; +Array values; +Array result; + +#define DATA(arr,i,t) (((t *)(arr).data)[i]) + +void new( HsInt size, Array * arr, int el_size ) +{ + arr->size = size; + arr->data = malloc( el_size * size ); +} + +void load( int file, Array * arr, int el_size ) +{ + read( file, &(arr->size), sizeof(HsInt) ); + arr->data = malloc( el_size * arr->size ); + read( file, arr->data, arr->size*el_size ); +} + +void compute() +{ + HsInt row, el, idx; + HsDouble sum; + + el = 0; + idx = 0; + for( row = 0; row < lengths.size; ++row ) { + sum = 0; + for( el = 0; el < DATA(lengths,row,HsInt); ++el ) { + sum += DATA(values, idx, HsDouble) + * DATA(vector, DATA(indices, idx, HsInt), HsDouble); + ++idx; + } + DATA(result, row, HsDouble) = sum; + } +} + +HsDouble checksum( Array * arr ) +{ + HsDouble sum = 0; + int i; + + for( i = 0; i < arr->size; ++i ) + sum += DATA((*arr), i, HsDouble); + return sum; +} + +int main( int argc, char * argv[] ) +{ + int file; + clock_t start, finish; + + file = open( argv[1], O_RDONLY ); + load( file, &lengths, sizeof(HsInt) ); + load( file, &indices, sizeof(HsInt) ); + load( file, &values, sizeof(HsDouble) ); + load( file, &vector, sizeof(HsDouble) ); + close(file); + new( lengths.size, &result, sizeof(HsDouble) ); + + printf( "rows = %ld; colums = %ld; elements = %ld\n", (long)lengths.size + , (long)vector.size + , (long)values.size ); + start = clock(); + compute(); + finish = clock(); + + printf( "%ld %Lf\n", (long int)((finish-start) / (CLOCKS_PER_SEC/1000)), + (long double)(checksum(&result)) ); +} + diff --git a/examples/smvm/smvm.hs b/examples/smvm/smvm.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/smvm.hs @@ -0,0 +1,84 @@ +import Data.Array.Parallel.Unlifted +import Data.Array.Parallel.Unlifted.Distributed +import Data.Array.Parallel.Prelude +import qualified SMVMPar +import qualified SMVMSeq +import qualified SMVMVect +--import Timing + +import System.Console.GetOpt +import System.IO +{- +import System.Exit +import System.Environment (getArgs) +-} +import Control.Exception (evaluate) +{- +import System.Mem (performGC) +-} + +import Bench.Benchmark +import Bench.Options + +type Alg = SUArr (Int :*: Double) -> UArr Double -> UArr Double + +algs = [("smvmp", SMVMPar.smvm) + ,("smvms", SMVMSeq.smvm) + ,("smvmv", smvm_vect) + ] + +smvm_vect m v = toUArrPA (SMVMVect.smvm (fromSUArrPA_2' m) (fromUArrPA' v)) + +main = ndpMain "Sparse matrix/vector multiplication" + "[OPTION] ... FILE ..." + run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") + "use the specified algorithm"] + "smvmp" + +run opts alg files = + case lookup alg algs of + Just f -> procFiles opts f files + Nothing -> failWith ["Unknown algorithm " ++ alg] + +procFiles :: Options -> Alg -> [String] -> IO () +procFiles opts alg fs = + do + benchmark opts + (uncurry alg) + (map loadSM fs) + showRes + return () + where + arg s = (cols, rows, ratio) + where + ((cols,('x':s')):_) = reads s + ((rows,('@':s'')):_) = reads s' + ratio = read s'' + + showRes arr = "sum=" ++ show (sumU arr) + +loadSM :: String -> IO (Point (SUArr (Int :*: Double), UArr Double)) +loadSM s@('(' : _) = + case reads s of + [((lm,lv), "")] -> return $ mkPoint "input" (toSU lm, toU lv) + _ -> failWith ["Invalid data " ++ s] +loadSM fname = + do + h <- openBinaryFile fname ReadMode + lengths <- hGetU h + indices <- hGetU h + values <- hGetU h + dv <- hGetU h + let sm = lengthsToUSegd lengths >: zipU indices values + return (sm, values) + evaluate lengths + evaluate indices + evaluate values + evaluate dv + -- print (sumU values) + -- print (sumU dv) + return $ mkPoint ( "cols=" ++ show (lengthU dv) ++ ", " + ++ "rows=" ++ show (lengthSU sm) ++ ", " + ++ "elems=" ++ show (lengthU (concatSU sm))) + (sm,dv) + diff --git a/examples/spec-constr/Makefile b/examples/spec-constr/Makefile new file mode 100644 --- /dev/null +++ b/examples/spec-constr/Makefile @@ -0,0 +1,8 @@ +TESTDIR = .. +PROGS = spec-constr +include $(TESTDIR)/mk/test.mk + +spec-constr.o: Pipelines.hi + +spec-constr: Pipelines.o $(BENCHLIB) + diff --git a/examples/spec-constr/Pipelines.hs b/examples/spec-constr/Pipelines.hs new file mode 100644 --- /dev/null +++ b/examples/spec-constr/Pipelines.hs @@ -0,0 +1,24 @@ +module Pipelines where + +import Data.Array.Parallel.Unlifted + +pipe1 :: UArr Int -> UArr Int -> UArr Int +pipe1 xs ys = mapU (+1) (xs +:+ ys) +{-# NOINLINE pipe1 #-} + +pipe2 :: UArr Int -> UArr Int +pipe2 = mapU (+1) . tailU +{-# NOINLINE pipe2 #-} + +pipe3 :: UArr Int -> Int +pipe3 = maximumU . scan1U (+) +{-# NOINLINE pipe3 #-} + +pipe4 :: SUArr Int -> Int +pipe4 = maximumU . sumSU +{-# NOINLINE pipe4 #-} + +pipe5 :: UArr Int -> UArr Int +{-# NOINLINE pipe5 #-} +pipe5 xs = sumSU (replicateSU (replicateU (lengthU xs) 5) xs) + diff --git a/examples/spec-constr/spec-constr.hs b/examples/spec-constr/spec-constr.hs new file mode 100644 --- /dev/null +++ b/examples/spec-constr/spec-constr.hs @@ -0,0 +1,69 @@ +import Data.Array.Parallel.Unlifted + +import Bench.Benchmark +import Bench.Options + +import System.Random +import System.Console.GetOpt + +import Pipelines as P + +type Gen a = forall g. RandomGen g => Int -> g -> IO a + +data Algo = forall a b. Algo (a -> b) (Gen a) + +algs :: [(String, Algo)] +algs = [("pipe1", Algo (uncurry pipe1) (uarr >< uarr)) + ,("pipe2", Algo pipe2 uarr) + ,("pipe3", Algo pipe3 uarr) + ,("pipe4", Algo pipe4 suarr) + ,("pipe5", Algo pipe5 uarr) + ] + +uarr :: (UA a, Random a) => Gen (UArr a) +uarr n g = return $! randomU n g + +suarr :: (UA a, Random a) => Gen (SUArr a) +suarr n g = + do let lens = replicateU (n `div` 10) (10 :: Int) + segd = lengthsToUSegd lens + n' = (n `div` 10) * 10 + arr = randomU n' g + segd `seq` arr `seq` return (segd >: arr) + +(><) :: Gen a -> Gen b -> Gen (a,b) +(h1 >< h2) n g = let (g1,g2) = split g + in + do x <- h1 n g1 + y <- h2 n g2 + return (x,y) + +randomGens :: RandomGen g => Int -> g -> [g] +randomGens 0 g = [] +randomGens n g = let (g1,g2) = split g + in g1 : randomGens (n-1) g2 + +main = ndpMain "SpecConstr test" + "[OPTION] ... SIZE" + run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") + "use the selected algorithm"] + "" + +run opts alg sizes = + case lookup alg algs of + Nothing -> failWith ["Unknown algorithm"] + Just (Algo f gen) -> + case map read sizes of + [] -> failWith ["No sizes specified"] + szs -> do + g <- getStdGen + let gs = randomGens (length szs) g + benchmark opts f + (zipWith (mk gen) szs gs) + (const "") + return () + where + mk gen n g = do + x <- gen n g + return $ ("N = " ++ show n) `mkPoint` x + diff --git a/examples/sumsq/SumSq.hs b/examples/sumsq/SumSq.hs new file mode 100644 --- /dev/null +++ b/examples/sumsq/SumSq.hs @@ -0,0 +1,14 @@ +-- the infamous sum square fusion example + +module Main (main) +where + +import Data.Array.Parallel.Unlifted + +sumSq :: Int -> Int +{-# NOINLINE sumSq #-} +--sumSq = sumP . mapP (\x -> x * x) . enumFromToP 1 +sumSq n = sumU (mapU (\x -> x * x) (enumFromToU 1 n)) + +main = print $ sumSq 100 + diff --git a/examples/unit/TestBUArr.hs b/examples/unit/TestBUArr.hs new file mode 100644 --- /dev/null +++ b/examples/unit/TestBUArr.hs @@ -0,0 +1,19 @@ +import Data.Array.Parallel.Arr.BUArr + +replicateBU_test :: UAE e => Int -> e -> BUArr e +replicateBU_test n e = + runST (do + arr <- newMBU n + fill arr n + unsafeFreezeMBU arr n + ) + where + fill arr 0 = return () + fill arr i = + do + let i' = i - 1 + writeMBU arr i' e + fill arr i' + + +main = print $ sumBU (replicateBU_test 5 (10 :: Int)) diff --git a/examples/unit/TestUArr.hs b/examples/unit/TestUArr.hs new file mode 100644 --- /dev/null +++ b/examples/unit/TestUArr.hs @@ -0,0 +1,30 @@ +import Data.Array.Parallel.Base.BUArr (ST, runST) +import Data.Array.Parallel.Monadic.UArr + +replicateU :: UA e => Int -> e -> UArr e +replicateU n e = + runST (do + arr <- newMU n + fill arr n + unsafeFreezeMU arr n + ) + where + fill arr 0 = return () + fill arr i = + do + let i' = i - 1 + writeMU arr i' e + fill arr i' + +sumU :: (Num e, UA e) => UArr e -> e +sumU arr = sumUp (lengthU arr) 0 + where + sumUp 0 acc = acc + sumUp i acc = + let + i' = i - 1 + acc' = acc + arr `indexU` i' + in + acc' `seq` sumUp i' acc' + +main = print $ sumU (replicateU 5 (10 :: Int)) diff --git a/include/fusion-phases.h b/include/fusion-phases.h new file mode 100644 --- /dev/null +++ b/include/fusion-phases.h @@ -0,0 +1,5 @@ +#define INLINE_U INLINE +#define INLINE_STREAM INLINE [1] +#define INLINE_DIST INLINE [1] +#define INLINE_PA INLINE [2] + diff --git a/tests/Examples/Test.hs b/tests/Examples/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/Test.hs @@ -0,0 +1,145 @@ + +import System.Process +import System.Exit +import System.IO +import Data.List +import Data.Maybe +import System.Directory + +import Control.Monad +import Control.Concurrent +import qualified Control.Exception as C +import Text.Printf + +import Text.Regex.PCRE.Light.Char8 + +------------------------------------------------------------------------ + +flags= [["-O","-fspec-constr"] + ,["-O2"] + ] + +tests = + [(Just 4, "prod", flags ) -- expect 2 fusions, with -O2 and -O + ,(Just 2, "fuse", flags ) + ,(Just 4, "real2Frac", flags ) + ] + +------------------------------------------------------------------------ + +main = do + printf "Running %d fusion tests.\n" (length tests) + vs <- forM tests $ \x -> do v <- run x + putChar '\n' + return v + printf "\nDone.\n" + if not (and vs) + then exitWith (ExitFailure 1) + else return () + +run :: (Maybe Int, String, [[String]]) -> IO Bool +run (n, name, args) = do + printf "%10s: " name >> hFlush stdout + v <- forM args $ \opt -> do + putChar '.' >> hFlush stdout + (cmd,ex,fusion) <- compile_program name opt + if ex /= n + then do + printf "\n%s failed to trigger fusion. Expected %s, Actual %s.\n" + name (show n) (show ex) + printf "Command line: %s\n" (show $ intercalate " " cmd) + return False + else + if isJust fusion + then do + printf "\n%s failed to remove all vectors.\n" name + printf "Remnants: %s\n" (show fusion) + printf "Command line: %s\n" (show $ intercalate " " cmd) + return False + else return True + return (and v) + +------------------------------------------------------------------------ + +compile_program s opt = do + + let command = [(s ++ ".hs"), "-ddump-simpl","-ddump-simpl-stats","-no-recomp","--make"] ++ opt + x <- readProcess "ghc" command [] + removeFile s + case x of + Left (err,str) -> do + print str + printf "GHC failed to compile %s\n" s + exitWith (ExitFailure 1) -- fatal + + Right str -> do + return $ case match fusion_regex str [] of + Nothing -> (command,Nothing,Nothing) + Just xs -> + let fusion_result = (read $ last xs) + in case match left_over_vector str [] of + Nothing -> (command, Just fusion_result, Nothing) + Just n -> (command, Just fusion_result, Just n) + +------------------------------------------------------------------------ + +-- Fusion happened +fusion_regex = compile "(\\d+).*streamU/unstreamU" [] + +-- Data.Array.Vector.Strict.Prim.UVec +-- UVectors were left behind +left_over_vector = compile "Data\\.Array\\.Vector\\.Unlifted\\.UArr\\.UArr|Data\\.Array\\.Vector\\.Base\\.Rebox\\.Box" [] + +------------------------------------------------------------------------ + +-- Also, bytestring input/output, since we're strict +-- Document that this isn't for interactive + +-- +-- | readProcess forks an external process, reads its standard output +-- strictly, blocking until the process terminates, and returns either the output +-- string, or, in the case of non-zero exit status, an error code, and +-- any output. +-- +-- Output is returned strictly, so this is not suitable for +-- interactive applications. +-- +-- Users of this library should compile with -threaded if they +-- want other Haskell threads to keep running while waiting on +-- the result of readProcess. +-- +-- > > readProcess "date" [] [] +-- > Right "Thu Feb 7 10:03:39 PST 2008\n" +-- +-- The argumenst are: +-- +-- * The command to run, which must be in the $PATH, or an absolute path +-- +-- * A list of separate command line arguments to the program +-- +-- * A string to pass on the standard input to the program. +-- +readProcess :: FilePath -- ^ command to run + -> [String] -- ^ any arguments + -> String -- ^ standard input + -> IO (Either (ExitCode,String) String) -- ^ either the stdout, or an exitcode and any output + +readProcess cmd args input = C.handle (return . handler) $ do + (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing + output <- hGetContents outh + outMVar <- newEmptyMVar + forkIO $ (C.evaluate (length output) >> putMVar outMVar ()) + when (not (null input)) $ hPutStr inh input + takeMVar outMVar + ex <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess) + hClose outh + hClose inh -- done with stdin + hClose errh -- ignore stderr + + return $ case ex of + ExitSuccess -> Right output + ExitFailure _ -> Left (ex, output) + + where + handler (C.ExitException e) = Left (e,"") + handler e = Left (ExitFailure 1, show e) diff --git a/tests/Examples/fuse.hs b/tests/Examples/fuse.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/fuse.hs @@ -0,0 +1,18 @@ +import Data.Array.Vector +import Data.Char +import Data.Bits + +main = do-- print . toList . mapU (^(2::Int)) $ replicateU 100 (1::Int) -- enumFromToU 1 100 + -- print . sumU . mapU (^(2::Int)) $ replicateU 100 (1::Int) -- enumFromToU 1 100 + + -- print . sumU . mapU (^(2::Int)) . replicateU 100000000 $ (1::Int) + + -- print . sum . map f . replicate (100000000::Int) $ (8 :: Int) + print . sumU . mapU f . replicateU (100000000::Int) $ (8 :: Int) + + -- print . nullU . mapU f . enumFromToU 1 $ 100000000 + + -- print . sumU . (\e -> consU 0xdeadbeef e) . replicateU (100000000::Int) $ (8::Int) + +f x = x ^ (2::Int) + diff --git a/tests/Examples/prod.hs b/tests/Examples/prod.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/prod.hs @@ -0,0 +1,33 @@ + +{- +main = do putStrLn (show (stupid_mul 100)) + putStrLn "100 multiplications done" + +stupid_mul 0 = [] +stupid_mul it = (s_mul it) : stupid_mul (it-1) -- without "it" after s_mul only one multiplication is executed +s_mul it = mul (replicate 4000 [0..3999]) (replicate 4000 2) + +mul :: [[Double]] -> [Double] -> [Double] +mul [] _ = [] +mul (b:bs) c | sp==0 = sp : (mul bs c) -- always false, force evaluation + + | otherwise = (mul bs c) + + where sp = (scalar b c) + +scalar :: [Double] -> [Double] -> Double +scalar _ [] = 0 +scalar [] _ = 0 +scalar (v:vs) (w:ws) = (v*w) + (scalar vs ws) +-} + +import Data.Array.Vector + +n :: Int +n = 4000 + +main = print (sumU (zipWithU (*) a b)) + where + a = replicateU n (2::Double) + b = mapU (realToFrac::Int->Double) $ enumFromToU 0 (n-1) + diff --git a/tests/Examples/raw.hs b/tests/Examples/raw.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/raw.hs @@ -0,0 +1,42 @@ +{-# OPTIONS -O2 -optc-O -fbang-patterns -fglasgow-exts -optc-march=pentium4 #-} +-- +-- The Computer Language Shootout +-- http://shootout.alioth.debian.org/ +-- +-- Contributed by Don Stewart +-- nsieve over an ST monad Bool array +-- + +import Control.Monad.ST +--import Data.Array.ST +--import Data.Array.Base +import System +import Control.Monad +import Data.Bits +import Text.Printf +import Data.Array.Vector.ST + +import GHC.ST + +main = do + n <- getArgs >>= readIO . head :: IO Int + mapM_ (\i -> sieve (10000 `shiftL` (n-i))) [0, 1, 2] + +sieve n = do + let r = runST (do t <- new n True + go t n 2 0) + printf "Primes up to %8d %8d\n" (n::Int) (r::Int) :: IO () + +go !a !m !n !c + | n == m = return c + | otherwise = do + e <- get a n + if e then let loop j + | j < m = do + x <- get a j + when x $ set a j False + loop (j+n) + | otherwise = go a m (n+1) (c+1) + in loop (n `shiftL` 1) + else go a m (n+1) c + diff --git a/tests/Examples/real2Frac.hs b/tests/Examples/real2Frac.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/real2Frac.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS -fglasgow-exts #-} + +import Data.Array.Vector +import Data.Word +import GHC.Prim +import GHC.Base (Int(..)) +import GHC.Float(Double(..),Float(..)) + +n = 40000000 + +main = do + let c = replicateU n (2::Word) + a = mapU fromIntegral (enumFromToU 0 (n-1) ) :: UArr Word + print (sumU (zipWithU (*) c a)) + + -- realToFrac here misses are rule with 6.8.2 diff --git a/tests/Fusion/Test.hs b/tests/Fusion/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/Test.hs @@ -0,0 +1,195 @@ + +import System.Process +import System.Exit +import System.IO +import Data.List +import Data.Maybe +import System.Directory + +import Control.Monad +import Control.Concurrent +import qualified Control.Exception as C +import Text.Printf + +import Text.Regex.PCRE.Light.Char8 + +------------------------------------------------------------------------ + +flags= [["-O","-fspec-constr"] + ,["-O2"] + ] + +tests = + [(Just 2, "cons", flags ) -- expect 2 fusions, with -O2 and -O + ,(Just 2, "snoc", flags ) + ,(Just 2, "empty", flags ) +-- ,(Just 1, "from-to", flags ) + ,(Just 2, "singleton", flags ) + ,(Just 4, "map", flags ) + ,(Just 5, "filter", flags ) + ,(Just 2, "replicate", flags ) + ,(Just 2, "takeWhile", flags ) + ,(Just 2, "index", flags ) + ,(Just 3, "null", flags ) + ,(Just 1, "length", flags ) + ,(Just 1, "length-bool", flags ) + ,(Just 1, "length-unit", flags ) + ,(Just 1, "length-char", flags ) + ,(Just 1, "length-word", flags ) + + ,(Just 1, "length-word8", flags ) + ,(Just 1, "length-word16", flags ) + ,(Just 1, "length-word32", flags ) + ,(Just 1, "length-word64", flags ) + + ,(Just 1, "length-int8", flags ) + ,(Just 1, "length-int16", flags ) + ,(Just 1, "length-int32", flags ) + ,(Just 1, "length-int64", flags ) + + ,(Just 1, "length-double", flags ) + ,(Just 1, "length-float", flags ) + ,(Just 2, "head", flags ) + ,(Just 4, "append", flags ) + ,(Just 3, "sum", flags ) + ,(Just 3, "product", flags ) + ,(Just 1, "and", flags ) + ,(Just 1, "or", flags ) + ,(Just 2, "elem", flags ) + ,(Just 2, "tail", flags ) + ,(Just 2, "find", flags ) + ,(Just 2, "findIndex", flags ) + ,(Just 2, "init", flags ) + ,(Just 2, "last", flags ) + ,(Just 3, "foldl1", flags ) + ,(Just 3, "minimum", flags ) + ,(Just 3, "maximum", flags ) + ,(Just 3, "maximumBy", flags ) + ,(Just 3, "minimumBy", flags ) + ,(Just 2, "take", flags ) + ,(Just 2, "drop", flags ) + ,(Just 4, "zipwith", flags ) + ,(Just 4, "zipwith3", flags ) + ,(Just 3, "zip", flags ) -- expect zipU fusion + ,(Just 3, "indexed", flags ) -- failing + ,(Just 1, "unfold", flags ) -- failing + ] + +------------------------------------------------------------------------ + +main = do + printf "Running %d fusion tests.\n" (length tests) + vs <- forM tests $ \x -> do v <- run x + putChar '\n' + return v + printf "\nDone.\n" + if not (and vs) + then exitWith (ExitFailure 1) + else return () + +run :: (Maybe Int, String, [[String]]) -> IO Bool +run (n, name, args) = do + printf "%20s: " name >> hFlush stdout + v <- forM args $ \opt -> do + putChar '.' >> hFlush stdout + (cmd,ex,fusion) <- compile_program name opt + if ex /= n + then do + printf "\n%s failed to trigger fusion. Expected %s, Actual %s.\n" + name (show n) (show ex) + printf "Command line: %s\n" (show $ intercalate " " cmd) + return False + else + if isJust fusion + then do + printf "\n%s failed to remove all vectors.\n" name + printf "Remnants: %s\n" (show fusion) + printf "Command line: %s\n" (show $ intercalate " " cmd) + return False + else return True + return (and v) + +------------------------------------------------------------------------ + +compile_program s opt = do + + let command = [(s ++ ".hs"), "-ddump-simpl","-ddump-simpl-stats","-no-recomp","--make"] ++ opt + x <- readProcess "ghc" command [] + removeFile s + case x of + Left (err,str) -> do + print str + printf "GHC failed to compile %s\n" s + exitWith (ExitFailure 1) -- fatal + + Right str -> do + return $ case match fusion_regex str [] of + Nothing -> (command,Nothing,Nothing) + Just xs -> + let fusion_result = (read $ last xs) + in case match left_over_vector str [] of + Nothing -> (command, Just fusion_result, Nothing) + Just n -> (command, Just fusion_result, Just n) + +------------------------------------------------------------------------ + +-- Fusion happened +fusion_regex = compile "(\\d+).*streamU/unstreamU" [] + +-- Data.Array.Vector.Strict.Prim.UVec +-- UVectors were left behind +left_over_vector = compile "Data\\.Array\\.Vector\\.Unlifted\\.UArr\\.UArr|Data\\.Array\\.Vector\\.Base\\.Rebox\\.Box" [] + +------------------------------------------------------------------------ + +-- Also, bytestring input/output, since we're strict +-- Document that this isn't for interactive + +-- +-- | readProcess forks an external process, reads its standard output +-- strictly, blocking until the process terminates, and returns either the output +-- string, or, in the case of non-zero exit status, an error code, and +-- any output. +-- +-- Output is returned strictly, so this is not suitable for +-- interactive applications. +-- +-- Users of this library should compile with -threaded if they +-- want other Haskell threads to keep running while waiting on +-- the result of readProcess. +-- +-- > > readProcess "date" [] [] +-- > Right "Thu Feb 7 10:03:39 PST 2008\n" +-- +-- The argumenst are: +-- +-- * The command to run, which must be in the $PATH, or an absolute path +-- +-- * A list of separate command line arguments to the program +-- +-- * A string to pass on the standard input to the program. +-- +readProcess :: FilePath -- ^ command to run + -> [String] -- ^ any arguments + -> String -- ^ standard input + -> IO (Either (ExitCode,String) String) -- ^ either the stdout, or an exitcode and any output + +readProcess cmd args input = C.handle (return . handler) $ do + (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing + output <- hGetContents outh + outMVar <- newEmptyMVar + forkIO $ (C.evaluate (length output) >> putMVar outMVar ()) + when (not (null input)) $ hPutStr inh input + takeMVar outMVar + ex <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess) + hClose outh + hClose inh -- done with stdin + hClose errh -- ignore stderr + + return $ case ex of + ExitSuccess -> Right output + ExitFailure _ -> Left (ex, output) + + where + handler (C.ExitException e) = Left (e,"") + handler e = Left (ExitFailure 1, show e) diff --git a/tests/Fusion/and.hs b/tests/Fusion/and.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/and.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print (andU (replicateU 100 True)) + diff --git a/tests/Fusion/append.hs b/tests/Fusion/append.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/append.hs @@ -0,0 +1,5 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU . mapU (`shiftL` 2) $ + appendU (replicateU 10000000 (1::Int)) + (replicateU 10000000 (7::Int)) diff --git a/tests/Fusion/cons.hs b/tests/Fusion/cons.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/cons.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print . sumU . consU 0xdeadbeef . replicateU (100000000::Int) $ (8::Int) + diff --git a/tests/Fusion/drop.hs b/tests/Fusion/drop.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/drop.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . lengthU . dropU 100000 . replicateU 1000000 $ (7 :: Int) + diff --git a/tests/Fusion/elem.hs b/tests/Fusion/elem.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/elem.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . elemU 100 . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int) + diff --git a/tests/Fusion/empty.hs b/tests/Fusion/empty.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/empty.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print . sumU $ consU (0xdeadbeef::Int) emptyU + diff --git a/tests/Fusion/eq.hs b/tests/Fusion/eq.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/eq.hs @@ -0,0 +1,6 @@ + +import Data.Array.Vector +main = print (eqU (replicateU 100000000 True) + (replicateU 100000000 True)) + + diff --git a/tests/Fusion/filter.hs b/tests/Fusion/filter.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/filter.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU . mapU (`shiftL` 1) . filterU (<20). mapU (*2) . mapU (+1) . replicateU (100000000::Int) $ (8::Int) + diff --git a/tests/Fusion/find.hs b/tests/Fusion/find.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/find.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . findU (==100) . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int) + diff --git a/tests/Fusion/findIndex.hs b/tests/Fusion/findIndex.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/findIndex.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . findIndexU (==100) . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int) + diff --git a/tests/Fusion/foldl1.hs b/tests/Fusion/foldl1.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/foldl1.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . foldl1U (+) . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) + diff --git a/tests/Fusion/from-to.hs b/tests/Fusion/from-to.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/from-to.hs @@ -0,0 +1,2 @@ +import Data.Array.Vector +main = print . head . toList . fromList $ replicate 1 (7::Int) diff --git a/tests/Fusion/head.hs b/tests/Fusion/head.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/head.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . headU . mapU (`shiftL` 1) . replicateU 1000000000 $ (7 :: Int) + diff --git a/tests/Fusion/index.hs b/tests/Fusion/index.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/index.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print . (\arr -> arr `indexU` 42) . mapU (subtract 6) . replicateU 10000000 $ (7 :: Int) + diff --git a/tests/Fusion/indexed.hs b/tests/Fusion/indexed.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/indexed.hs @@ -0,0 +1,7 @@ +-- only fuses with ghc 6.9 + +import Data.Array.Vector +import Data.Bits + +main = print . sumU . mapU fstS . indexedU . enumFromToU 1 $ (100000000 :: Int) + diff --git a/tests/Fusion/init.hs b/tests/Fusion/init.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/init.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . lengthU . initU . replicateU 1000000 $ (7 :: Int) + diff --git a/tests/Fusion/last.hs b/tests/Fusion/last.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/last.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . lastU . mapU (`shiftL` 1) . replicateU 1000000000 $ (7 :: Int) + diff --git a/tests/Fusion/length-bool.hs b/tests/Fusion/length-bool.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-bool.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print (lengthU (replicateU 1 True)) + diff --git a/tests/Fusion/length-char.hs b/tests/Fusion/length-char.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-char.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print (lengthU (replicateU 1 'x')) + diff --git a/tests/Fusion/length-double.hs b/tests/Fusion/length-double.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-double.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print (lengthU (replicateU 1 (pi :: Double))) + diff --git a/tests/Fusion/length-float.hs b/tests/Fusion/length-float.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-float.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print (lengthU (replicateU 1 (pi :: Float))) + diff --git a/tests/Fusion/length-int16.hs b/tests/Fusion/length-int16.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-int16.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Int +main = print (lengthU (replicateU 1 (7 :: Int16))) + diff --git a/tests/Fusion/length-int32.hs b/tests/Fusion/length-int32.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-int32.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Int +main = print (lengthU (replicateU 1 (7 :: Int32))) + diff --git a/tests/Fusion/length-int64.hs b/tests/Fusion/length-int64.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-int64.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Int +main = print (lengthU (replicateU 1 (7 :: Int64))) + diff --git a/tests/Fusion/length-int8.hs b/tests/Fusion/length-int8.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-int8.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Int +main = print (lengthU (replicateU 1 (7 :: Int8))) + diff --git a/tests/Fusion/length-unit.hs b/tests/Fusion/length-unit.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-unit.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print (lengthU (replicateU 1 ())) + diff --git a/tests/Fusion/length-word.hs b/tests/Fusion/length-word.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-word.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Word +main = print (lengthU (replicateU 1 (7 :: Word))) + diff --git a/tests/Fusion/length-word16.hs b/tests/Fusion/length-word16.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-word16.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Word +main = print (lengthU (replicateU 1 (7 :: Word16))) + diff --git a/tests/Fusion/length-word32.hs b/tests/Fusion/length-word32.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-word32.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Word +main = print (lengthU (replicateU 1 (7 :: Word32))) + diff --git a/tests/Fusion/length-word64.hs b/tests/Fusion/length-word64.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-word64.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Word +main = print (lengthU (replicateU 1 (7 :: Word64))) + diff --git a/tests/Fusion/length-word8.hs b/tests/Fusion/length-word8.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length-word8.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Word +main = print (lengthU (replicateU 1 (7 :: Word8))) + diff --git a/tests/Fusion/length.hs b/tests/Fusion/length.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/length.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print . lengthU . enumFromToU 1 $ (100000000 :: Int) + diff --git a/tests/Fusion/lookup.hs b/tests/Fusion/lookup.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/lookup.hs @@ -0,0 +1,5 @@ +import Data.Array.Vector +import Data.Bits +main = print . lookupU 10000 + . zipU (enumFromToU 1 (10000000 :: Int)) $ + (replicateU (10000000 :: Int) (42::Int)) diff --git a/tests/Fusion/map.hs b/tests/Fusion/map.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/map.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU . mapU (`shiftL` 1) . mapU (*2) . mapU (+1) . replicateU (100000000::Int) $ (8::Int) + diff --git a/tests/Fusion/maximum.hs b/tests/Fusion/maximum.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/maximum.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . maximumU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) + diff --git a/tests/Fusion/maximumBy.hs b/tests/Fusion/maximumBy.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/maximumBy.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . maximumByU (\x y -> GT) . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) + diff --git a/tests/Fusion/minimum.hs b/tests/Fusion/minimum.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/minimum.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . minimumU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) + diff --git a/tests/Fusion/minimumBy.hs b/tests/Fusion/minimumBy.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/minimumBy.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . minimumByU (\x y -> GT) . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) + diff --git a/tests/Fusion/null-ndp b/tests/Fusion/null-ndp new file mode 100644 # file too large to diff: tests/Fusion/null-ndp diff --git a/tests/Fusion/null-ndp.hs b/tests/Fusion/null-ndp.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/null-ndp.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector -- Parallel.Unlifted +main = print . sumU . mapU fstS . indexedU . enumFromToU 1 $ (100000000 :: Int) + diff --git a/tests/Fusion/null.hs b/tests/Fusion/null.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/null.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print . nullU . filterU (>10) . mapU (subtract 6) . enumFromToU 1 $ (100000000 :: Int) + diff --git a/tests/Fusion/or.hs b/tests/Fusion/or.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/or.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print (orU (replicateU 100 True)) + diff --git a/tests/Fusion/product.hs b/tests/Fusion/product.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/product.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . productU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) + diff --git a/tests/Fusion/repeat.hs b/tests/Fusion/repeat.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/repeat.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU . repeatU 10 $ replicateU (10000000 :: Int) (5::Int) + diff --git a/tests/Fusion/replicate.hs b/tests/Fusion/replicate.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/replicate.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print . sumU . mapU (subtract 7) . replicateU 10000000 $ (7 :: Int) + diff --git a/tests/Fusion/singleton.hs b/tests/Fusion/singleton.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/singleton.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print . sumU $ consU (10::Int) (singletonU 2) + diff --git a/tests/Fusion/snoc.hs b/tests/Fusion/snoc.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/snoc.hs @@ -0,0 +1,3 @@ +import Data.Array.Vector +main = print . sumU . (\e -> snocU e 0xdeadbeef) . replicateU (100000000::Int) $ (8::Int) + diff --git a/tests/Fusion/sum-complex.hs b/tests/Fusion/sum-complex.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/sum-complex.hs @@ -0,0 +1,5 @@ +import Data.Array.Vector +import Data.Complex + +main = print . sumU $ replicateU (100000000 :: Int) (1 :+ 1 ::Complex Double) + diff --git a/tests/Fusion/sum-ratio.hs b/tests/Fusion/sum-ratio.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/sum-ratio.hs @@ -0,0 +1,5 @@ +import Data.Array.Vector +import Data.Ratio + +main = print . sumU $ replicateU (100000000 :: Int) (1 % 2 :: Rational) + diff --git a/tests/Fusion/sum.hs b/tests/Fusion/sum.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/sum.hs @@ -0,0 +1,8 @@ +import Data.Array.Vector +import Data.Bits + +main = print . sumU + . mapU (*2) + . mapU (`shiftL` 2) + $ replicateU (100000000 :: Int) (5::Int) + diff --git a/tests/Fusion/tail.hs b/tests/Fusion/tail.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/tail.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . lengthU . tailU . replicateU 1000000 $ (7 :: Int) + diff --git a/tests/Fusion/take.hs b/tests/Fusion/take.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/take.hs @@ -0,0 +1,4 @@ +import Data.Array.Vector +import Data.Bits +main = print . lengthU . takeU 100000 . replicateU 1000000 $ (7 :: Int) + diff --git a/tests/Fusion/takeWhile.hs b/tests/Fusion/takeWhile.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/takeWhile.hs @@ -0,0 +1,7 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU . takeWhileU (< (7::Int)). enumFromToU 1 $ 10000000 + + -- replicateU 1000000 $ (7 :: Int) + + -- gets removed entirely! diff --git a/tests/Fusion/unfold.hs b/tests/Fusion/unfold.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/unfold.hs @@ -0,0 +1,5 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU $ unfoldU 10000 k (0::Int) + where + k b = JustS (b :*: b+1) -- enumFromTo diff --git a/tests/Fusion/zip.hs b/tests/Fusion/zip.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/zip.hs @@ -0,0 +1,6 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU . mapU fstS $ zipU + (enumFromToU 1 (100000000 :: Int)) + (enumFromToU 2 (100000001 :: Int)) + diff --git a/tests/Fusion/zipwith.hs b/tests/Fusion/zipwith.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/zipwith.hs @@ -0,0 +1,6 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU . mapU (`shiftL` 1) $ zipWithU (*) + (enumFromToU 1 (100000000 :: Int)) + (replicateU (100000000 :: Int) 42) + diff --git a/tests/Fusion/zipwith3.hs b/tests/Fusion/zipwith3.hs new file mode 100644 --- /dev/null +++ b/tests/Fusion/zipwith3.hs @@ -0,0 +1,7 @@ +import Data.Array.Vector +import Data.Bits +main = print . sumU $ zipWith3U (\x y z -> x * y * z) + (enumFromToU 1 (100000000 :: Int)) + (enumFromToU 2 (100000001 :: Int)) + (enumFromToU 7 (100000008 :: Int)) + diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,25 @@ +all: hpc fusion + +FLAGS=-fglasgow-exts -O2 -funbox-strict-fields -fdicts-cheap -fno-method-sharing -fmax-simplifier-iterations10 -fcpr-off -DSAFE -cpp -I../include +hpc: + rm -f run.tix + ghc ${FLAGS} -no-recomp --make Properties/Test.hs -i.. -fhpc -o run + time ./run + hpc markup run --exclude=Properties.Utils --exclude=Properties.Monomorphic.Base --exclude=Properties.Monomorphic.UVector + +fusion: + ( cd Fusion && ghc -O --make Test.hs && ./Test ) + ( cd Examples && ghc -O --make Test.hs && ./Test ) + +clean: + rm -f *.html + find . -name '*~' -exec rm {} \; + find . -name '*.hi' -exec rm {} \; + find . -name '*.o' -exec rm {} \; + find . -name '*.log' -exec rm {} \; + find ../Data -name '*~' -exec rm {} \; + find ../Data -name '*.hi' -exec rm {} \; + find ../Data -name '*.o' -exec rm {} \; + rm -f fuse raw run Performance Fusion/Test Examples/Test + rm -f *.tix + rm -rf .hpc diff --git a/tests/Performance.hs b/tests/Performance.hs new file mode 100644 --- /dev/null +++ b/tests/Performance.hs @@ -0,0 +1,118 @@ +{-# OPTIONS -O2 -optc-O -fglasgow-exts -optc-march=pentium4 #-} +{-# LANGUAGE BangPatterns #-} + +import Text.Printf +import Control.Exception +import System.CPUTime +import System.IO + +import Control.Monad.ST +import System +import Control.Monad +import Data.Bits +import Text.Printf +import Data.Array.Vector.ST + +import Data.Array.Base +import GHC.Exts +import GHC.ST + +------------------------------------------------------------------------ + +time :: IO t -> IO Double +time a = do + start <- getCPUTime + !v <- a + end <- getCPUTime + let diff = (fromIntegral (end - start)) / (10^12) + return diff + +main = do + putStrLn "Starting..." + mapM_ run + [ ("nsieve-bits", time_nsieve 12) + + ] + putStrLn "Done." + +run (s, a) = do + putStr (s++": ") >> hFlush stdout + t <- a + if t then do putStrLn "Ok." + else do putStrLn "Fail! New code was slower." + exitWith (ExitFailure 1) + +------------------------------------------------------------------------ +-- bitwise prime sive + +time_nsieve n = do + !x <- (time (nsieve1 n)) + !y <- (time (nsieve2 n)) + return (x < y) + + where + + ------------------------------------------------------------------------ + -- PROGRAM 1 + + nsieve1 n = mapM_ (\i -> sieve1 (10000 `shiftL` (n-i))) [0, 1, 2] + + sieve1 n = do + let r = runST (do t <- new n True + go t n 2 0) + n `seq` r `seq` return () + + go !a !m !n !c + | n == m = return c + | otherwise = do + e <- get a n + if e then let loop j + | j < m = do + x <- get a j + when x $ set a j False + loop (j+n) + | otherwise = go a m (n+1) (c+1) + in loop (n `shiftL` 1) + else go a m (n+1) c + +{- + {-# INLINE newArrayT #-} + newArrayT n@(I# n#) t = ST $ \s1# -> + case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) -> + case bOOL_WORD_SCALE n# of { n'# -> + let loop i# s3# | i# ==# n'# = s3# + | otherwise = + case writeWordArray# marr# i# e# s3# of { s4# -> + loop (i# +# 1#) s4# } in + case loop 0# s2# of { s3# -> + (# s3#, STUVector n marr# #) }}} + where + W# e# = if t then maxBound else 0 -- True +-} + + ------------------------------------------------------------------------ + -- PROGRAM 2 + + nsieve2 n = mapM_ (\i -> sieve2 (10000 `shiftL` (n-i))) [0, 1, 2] + + sieve2 n = do + let r = runST (do a <- newArray (2,n) True :: ST s (STUArray s Int Bool) + go2 a n 2 0) + n `seq` r `seq` return () + + go2 !a !m !n !c + | n == m = return c + | otherwise = do + e <- unsafeRead a n + if e then let loop j + | j < m = do + x <- unsafeRead a j + when x $ unsafeWrite a j False + loop (j+n) + + | otherwise = go2 a m (n+1) (c+1) + in loop (n `shiftL` 1) + else go2 a m (n+1) c + + +------------------------------------------------------------------------ diff --git a/tests/Properties/Monomorphic/Base.hs b/tests/Properties/Monomorphic/Base.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Monomorphic/Base.hs @@ -0,0 +1,325 @@ +-- +-- The Data.List api +-- +module Properties.Monomorphic.Base where + +import Properties.Utils + +import qualified Data.List as Spec + +-- * Basic interface +cons :: A -> [A] -> [A] +empty :: [A] +(++) :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +index :: [A] -> Int -> A +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndex :: (A -> Bool) -> [A] -> Maybe Int +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +unzip :: [(A, B)] -> ([A], [B]) +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) + +-- * Special lists +-- ** Functions on strings +lines :: String -> [String] +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericSplitAt :: I -> [A] -> ([A], [A]) +genericIndex :: [A] -> I -> A +genericReplicate :: I -> A -> [A] + + + +-- * Basic interface +cons = (:) +empty = [] +(++) = (Spec.++) +head = Spec.head +last = Spec.last +tail = Spec.tail +init = Spec.init +null = Spec.null +length = Spec.length + +-- * List transformations +map = Spec.map +reverse = Spec.reverse +intersperse = Spec.intersperse + +-- intercalate = -- Spec.intercalate +intercalate xs xss = Spec.concat (Spec.intersperse xs xss) + +transpose = Spec.transpose + +-- * Reducing lists (folds) +foldl = Spec.foldl +foldl' = Spec.foldl' +foldl1 = Spec.foldl1 +foldl1' = Spec.foldl1' +foldr = Spec.foldr +foldr1 = Spec.foldr1 + +-- ** Special folds +concat = Spec.concat +concatMap = Spec.concatMap +and = Spec.and +or = Spec.or +any = Spec.any +all = Spec.all +sum = Spec.sum +product = Spec.product +maximum = Spec.maximum +minimum = Spec.minimum + +-- * Building lists +-- ** Scans +scanl = Spec.scanl +scanl1 = Spec.scanl1 +scanr = Spec.scanr +scanr1 = Spec.scanr1 + +-- ** Accumulating maps +mapAccumL = Spec.mapAccumL +mapAccumR = Spec.mapAccumR + +-- ** Infinite lists +iterate = Spec.iterate +repeat = Spec.repeat +replicate = Spec.replicate +cycle = Spec.cycle + +-- ** Unfolding +unfoldr = Spec.unfoldr + +-- * Sublists +-- ** Extracting sublists +take = Spec.take +drop = Spec.drop +splitAt = Spec.splitAt +takeWhile = Spec.takeWhile +dropWhile = Spec.dropWhile +span = Spec.span +break = Spec.break +group = Spec.group +inits = Spec.inits +tails = Spec.tails + +-- * Predicates +isPrefixOf = Spec.isPrefixOf +isSuffixOf = Spec.isSuffixOf +isInfixOf = Spec.isInfixOf + +-- * Searching lists +-- ** Searching by equality +elem = Spec.elem +notElem = Spec.notElem +lookup = Spec.lookup + +-- ** Searching with a predicate +find = Spec.find +filter = Spec.filter +partition = Spec.partition + +-- * Indexing lists +index = (Spec.!!) +elemIndex = Spec.elemIndex +elemIndices = Spec.elemIndices +findIndex = Spec.findIndex +findIndices = Spec.findIndices + +-- * Zipping and unzipping lists +zip = Spec.zip +zip3 = Spec.zip3 +zip4 = Spec.zip4 +zip5 = Spec.zip5 +zip6 = Spec.zip6 +zip7 = Spec.zip7 +zipWith = Spec.zipWith +zipWith3 = Spec.zipWith3 +zipWith4 = Spec.zipWith4 +zipWith5 = Spec.zipWith5 +zipWith6 = Spec.zipWith6 +zipWith7 = Spec.zipWith7 +unzip = Spec.unzip +unzip3 = Spec.unzip3 +unzip4 = Spec.unzip4 +unzip5 = Spec.unzip5 +unzip6 = Spec.unzip6 +unzip7 = Spec.unzip7 + +-- * Special lists +-- ** Functions on strings +lines = Spec.lines +words = Spec.words +unlines = Spec.unlines +unwords = Spec.unwords + +-- ** \"Set\" operations +nub = Spec.nub +delete = Spec.delete +(\\) = (Spec.\\) +union = Spec.union +intersect = Spec.intersect + +-- ** Ordered lists +sort = Spec.sort +insert = Spec.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Spec.nubBy +deleteBy = Spec.deleteBy +deleteFirstsBy = Spec.deleteFirstsBy +unionBy = Spec.unionBy +intersectBy = Spec.intersectBy +groupBy = Spec.groupBy + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = Spec.sortBy +insertBy = Spec.insertBy +maximumBy = Spec.maximumBy +minimumBy = Spec.minimumBy + +-- * The \"generic\" operations +genericLength = Spec.genericLength +genericTake = Spec.genericTake +genericDrop = Spec.genericDrop +genericSplitAt = Spec.genericSplitAt +genericIndex = Spec.genericIndex +genericReplicate = Spec.genericReplicate diff --git a/tests/Properties/Monomorphic/UVector.hs b/tests/Properties/Monomorphic/UVector.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Monomorphic/UVector.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE TypeOperators #-} +module Properties.Monomorphic.UVector where + +-- +-- just test the List api +-- + +import Properties.Utils + +import qualified Data.Array.Vector as List +import Data.Array.Vector (UArr, (:*:)) + +-- * Basic interface +cons :: A -> UArr A -> UArr A +snoc :: UArr A -> A -> UArr A +empty :: UArr A +singleton :: A -> UArr A +head :: UArr A -> A +length :: UArr A -> Int +append :: UArr A -> UArr A -> UArr A +tail :: UArr A -> UArr A +null :: UArr A -> Bool +init :: UArr A -> UArr A +last :: UArr A -> A + +-- * List transformations +map :: (A -> B) -> UArr A -> UArr B + +{- +reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +-} +foldl :: (B -> A -> B) -> B -> UArr A -> B +foldl1 :: (A -> A -> A) -> UArr A -> A +{- +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +-} +and :: UArr Bool -> Bool +or :: UArr Bool -> Bool +any :: (A -> Bool) -> UArr A -> Bool +all :: (A -> Bool) -> UArr A -> Bool +sum :: UArr N -> N +product :: UArr N -> N +maximum :: UArr OrdA -> OrdA +minimum :: UArr OrdA -> OrdA + +-- * Building lists +-- ** Scans + +scanl :: (A -> B -> A) -> A -> UArr B -> UArr A +{- +scanl1 :: (A -> A -> A) -> [A] -> [A] +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] +-} + +-- ** Accumulating maps +{- +mapAccumL :: (C -> A -> (C, B)) -> C -> UArr A -> UArr B +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +-} +replicate :: Int -> A -> UArr A +{- +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-} + +-- * Sublists +-- ** Extracting sublists +take :: Int -> UArr A -> UArr A +drop :: Int -> UArr A -> UArr A +splitAt :: Int -> UArr A -> (UArr A, UArr A) +takeWhile :: (A -> Bool) -> UArr A -> UArr A +dropWhile :: (A -> Bool) -> UArr A -> UArr A +{- +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool + +-} + +-- * Searching lists +-- ** Searching by equality +elem :: A -> UArr A -> Bool +notElem :: A -> UArr A -> Bool +lookup :: A -> UArr (A :*: B) -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> UArr A -> Maybe A +filter :: (A -> Bool) -> UArr A -> UArr A +{- +partition :: (A -> Bool) -> [A] -> ([A], [A]) +-} + +-- * Indexing lists +index :: UArr A -> Int -> A +{- +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndex :: (A -> Bool) -> [A] -> Maybe Int +findIndices :: (A -> Bool) -> [A] -> [Int] +-} + +-- * Zipping and unzipping lists +zip :: UArr A -> UArr B -> UArr (A :*: B) +zip3 :: UArr A -> UArr B -> UArr C -> UArr (A :*: B :*: C) + +{- +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +-} + +zipWith :: (A -> B -> C) -> UArr A -> UArr B -> UArr C +zipWith3 :: (A -> B -> C -> D) -> UArr A -> UArr B -> UArr C -> UArr D + +{- +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +-} +-- unzip :: [(A, B)] -> ([A], [B]) +{- +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) +-} + +{- +-- * Special lists +-- ** Functions on strings +lines :: String -> [String] +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +-} +maximumBy :: (A -> A -> Ordering) -> UArr A -> A +minimumBy :: (A -> A -> Ordering) -> UArr A -> A + +{- +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericSplitAt :: I -> [A] -> ([A], [A]) +genericIndex :: [A] -> I -> A +genericReplicate :: I -> A -> [A] +-} + + +-- * Basic interface +cons = List.consU +empty = List.emptyU +snoc = List.snocU +singleton = List.singletonU +head = List.headU +length = List.lengthU +append = List.appendU +tail = List.tailU +null = List.nullU +init = List.initU +last = List.lastU + +-- * List transformations +map = List.mapU + +{- +reverse = List.reverse +intersperse = List.intersperse +intercalate = List.intercalate +transpose = List.transpose +-} + +-- * Reducing lists (folds) +foldl = List.foldlU +foldl1 = List.foldl1U + +{- +foldl' = List.foldl' +foldl1' = List.foldl1' +foldr = List.foldr +foldr1 = List.foldr1 +-} + +-- ** Special folds +{- +concat = List.concat +concatMap = List.concatMap +-} +and = List.andU +or = List.orU +any = List.anyU +all = List.allU +sum = List.sumU +product = List.productU +maximum = List.maximumU +minimum = List.minimumU + +-- * Building lists +-- ** Scans + +scanl = List.scanlU +{- +scanl1 = List.scanl1 +scanr = List.scanr +scanr1 = List.scanr1 + +-- ** Accumulating maps +mapAccumL = List.mapAccumL +mapAccumR = List.mapAccumR + +-- ** Infinite lists +iterate = List.iterate +repeat = List.repeat +-} +replicate = List.replicateU +{- +cycle = List.cycle + +-- ** Unfolding +unfoldr = List.unfoldr + +-} +-- * Sublists +-- ** Extracting sublists +take = List.takeU +drop = List.dropU +splitAt = List.splitAtU +takeWhile = List.takeWhileU +dropWhile = List.dropWhileU +{- +span = List.span +break = List.break +group = List.group +inits = List.inits +tails = List.tails + +-- * Predicates +isPrefixOf = List.isPrefixOf +isSuffixOf = List.isSuffixOf +isInfixOf = List.isInfixOf +-} + +-- * Searching lists +-- ** Searching by equality +elem = List.elemU +notElem = List.notElemU +lookup = List.lookupU + +-- ** Searching with a predicate +find = List.findU +filter = List.filterU +{- +partition = List.partition +-} + +-- * Indexing lists +index = List.indexU +{- +elemIndex = List.elemIndex +elemIndices = List.elemIndices +findIndex = List.findIndex +findIndices = List.findIndices +-} + +-- * Zipping and unzipping lists +zip = List.zipU +zip3 = List.zip3U +{- +zip4 = List.zip4 +zip5 = List.zip5 +zip6 = List.zip6 +zip7 = List.zip7 +-} +zipWith = List.zipWithU +zipWith3 = List.zipWith3U +{- +zipWith4 = List.zipWith4 +zipWith5 = List.zipWith5 +zipWith6 = List.zipWith6 +zipWith7 = List.zipWith7 +-} +--unzip = List.unzipU +{- +unzip3 = List.unzip3 +unzip4 = List.unzip4 +unzip5 = List.unzip5 +unzip6 = List.unzip6 +unzip7 = List.unzip7 +-} + +{- +-- * Special lists +-- ** Functions on strings +lines = List.lines +words = List.words +unlines = List.unlines +unwords = List.unwords + +-- ** \"Set\" operations +nub = List.nub +delete = List.delete +(\\) = (List.\\) +union = List.union +intersect = List.intersect + +-- ** Ordered lists +sort = List.sort +insert = List.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = List.nubBy +deleteBy = List.deleteBy +deleteFirstsBy = List.deleteFirstsBy +unionBy = List.unionBy +intersectBy = List.intersectBy +groupBy = List.groupBy + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = List.sortBy +insertBy = List.insertBy +-} +maximumBy = List.maximumByU +minimumBy = List.minimumByU + +{- +-- * The \"generic\" operations +genericLength = List.genericLength +genericTake = List.genericTake +genericDrop = List.genericDrop +genericSplitAt = List.genericSplitAt +genericIndex = List.genericIndex +genericReplicate = List.genericReplicate +-} diff --git a/tests/Properties/Test.hs b/tests/Properties/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Test.hs @@ -0,0 +1,507 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeOperators #-} + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +import System.IO +import System.Environment +import Properties.Utils + +import qualified Data.Array.Vector as Test +import qualified Properties.Monomorphic.UVector as Test -- stream functions +import qualified Properties.Monomorphic.Base as Spec -- Data.List + +import Data.Array.Vector.Stream +import Data.Array.Vector.Prim.Hyperstrict +import Data.Array.Vector + + + +-- +-- Data.Stream <=> Data.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_cons = Test.cons `eq2` (Spec.cons) +prop_snoc = Test.snoc `eq2` (\xs x -> xs Spec.++ [x]) +prop_empty = Test.empty `eq0` (Spec.empty) +prop_singleton = Test.singleton `eq1` (\x -> Spec.cons x []) +prop_head = Test.head `eqnotnull1` Spec.head +prop_append = Test.append `eq2` (Spec.++) +prop_tail = Test.tail `eqnotnull1` Spec.tail +prop_null = Test.null `eq1` Spec.null +prop_init = Test.init `eqnotnull1` Spec.init +prop_last = Test.last `eqnotnull1` Spec.last +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map + +{- +-- prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `eq2` Spec.intersperse +prop_intercalate = Test.intercalate `eq2` Spec.intercalate +-- prop_transpose = Test.transpose `eq1` Spec.transpose +-} + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl + +prop_foldl1 = Test.foldl1 `eqnotnull2` Spec.foldl1 -- n.b. + +{- +prop_foldl' = Test.foldl' `eq3` Spec.foldl' +prop_foldl1' = Test.foldl1' `eqnotnull2` Spec.foldl1' -- n.b. + +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eqnotnull2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +-- prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +-} +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eqnotnull1` Spec.maximum +prop_minimum = Test.minimum `eqnotnull1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +-- prop_scanl = (\f x xs -> Test.snoc (Test.scanl f x xs) x) `eq3` Spec.scanl +{- +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +-- prop_scanr = Test.scanr `eq3` Spec.scanr + +{- +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 +-} + +------------------------------------------------------------------------ +-- ** Accumulating maps + +{- +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR +-} + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +-} +prop_replicate = \x -> x >= 0 ==> Test.replicate x `eq1` Spec.replicate x +{- +prop_cycle = \x -> not (null x) ==> + (Test.cycle `eqfinite1` Spec.cycle) x + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr +-} + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile + +{- +{- +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails +-} + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +{- +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf +-} + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality +-} + +prop_elem = Test.elem `eq2` Spec.elem +prop_notElem = Test.notElem `eq2` Spec.notElem -- no specific implementation + +{- +prop_lookup = Test.lookup `eq2` Spec.lookup +-} + +------------------------------------------------------------------------ +-- ** Searching with a predicate + + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter + +{- +-- prop_partition = Test.partition `eq2` Spec.partition +-} + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = \xs n -> n >= 0 && n < Test.length xs ==> + (Test.index `eq2` Spec.index) xs n + +{- +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndices = Test.findIndices `eq2` Spec.findIndices +-} + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +-- prop_zip = Test.zip `eq2` Spec.zip +-- prop_zip3 = Test.zip3 `eq3` Spec.zip3 + +-- prop_zipWith = Test.zipWith `eq3` Spec.zipWith +-- prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 + +{- +prop_zip4 = Test.zip4 `eq4` Spec.zip4 +prop_zip5 = Test.zip5 `eq5` Spec.zip5 +prop_zip6 = Test.zip6 `eq6` Spec.zip6 +prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 +-} + +------------------------------------------------------------------------ + +-- prop_unzip = Test.unzip `eq1` Spec.unzip + +{- +prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 +-} + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings +-- prop_unlines = Test.unlines `eq1` Spec.unlines +-- prop_lines = Test.lines `eq1` Spec.lines + +{- +prop_words = Test.words `eq1` Spec.words +prop_unwords = Test.unwords `eq1` Spec.unwords +-} + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +{- +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect +-} + +------------------------------------------------------------------------ +-- ** Ordered lists + +{- +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert +-} + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +{- +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy +-} + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +{- +prop_sortBy = Test.sortBy `eq2` Spec.sortBy +-} +{- +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +-} + + + +prop_maximumBy = Test.maximumBy `eqnotnull2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eqnotnull2` Spec.minimumBy + + +{- +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = \i -> i >= I 0 ==> + (Test.genericTake `eq2` Spec.genericTake) i +prop_genericDrop = \i -> i >= I 0 ==> + (Test.genericDrop `eq2` Spec.genericDrop) i +prop_genericIndex = \xs i -> i >= I 0 && i < Spec.genericLength xs ==> + (Test.genericIndex `eq2` Spec.genericIndex) xs i +prop_genericSplitAt = \i -> i >= I 0 ==> + (Test.genericSplitAt `eq2` Spec.genericSplitAt) i +prop_genericReplicate = \i -> i >= I 0 ==> + (Test.genericReplicate `eq2` Spec.genericReplicate) i +-} + +------------------------------------------------------------------------ + + +main = do + x <- getArgs + let opts' = case x of + [n] -> opts { no_of_tests = read n } + _ -> opts + + hSetBuffering stdout NoBuffering + putStrLn "Testing: Data.Stream <=> Data.List" + putStrLn "==================================\n" + + runTests "Extras" opts' + [-- run prop_repeatU_model + ] + + runTests "Basic interface" opts' + [run prop_cons + ,run prop_snoc + ,run prop_empty + ,run prop_singleton + ,run prop_head + ,run prop_append + ,run prop_tail + ,run prop_null + ,run prop_init + ,run prop_last + ,run prop_length + ] + + runTests "List transformations" opts' + [run prop_map + {- +-- ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate +-- ,run prop_transpose +-} + ] + + runTests "Reducing lists (folds)" opts' + [run prop_foldl +-- ,run prop_foldr + + ,run prop_foldl1 +-- ,run prop_foldl' +-- ,run prop_foldl1' +-- ,run prop_foldr1 + ] + + runTests "Special folds" opts' + [ +-- run prop_concat, +-- run prop_concatMap + run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts' + [-- run prop_scanl +-- ,run prop_scanl1 +-- ,run prop_scanr +-- ,run prop_scanr1 + ] + +{- + runTests "Accumulating maps" opts' + [run prop_mapAccumL + ,run prop_mapAccumR + ] +-} + + runTests "Infinite lists" opts' + [-- run prop_iterate + --,run prop_repeat + run prop_replicate + -- ,run prop_cycle + ] + +{- + runTests "Unfolding" opts' + [run prop_unfoldr + ] +-} + + runTests "Extracting sublists" opts' + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile +-- ,run prop_span +-- ,run prop_break +-- ,run prop_group +-- ,run prop_inits +-- ,run prop_tails + ] + +{- + runTests "Predicates" opts' + [run prop_isPrefixOf + ,run prop_isSuffixOf + ,run prop_isInfixOf + ] +-} + + runTests "Searching by equality" opts' + [run prop_elem + ,run prop_notElem-- no specific implementation +-- ,run prop_lookup + ] + + runTests "Searching by a predicate" opts' + [run prop_filter + ,run prop_find +-- ,run prop_partition + ] + + runTests "Indexing lists" opts' + [run prop_index +-- ,run prop_findIndex +-- ,run prop_elemIndex +-- ,run prop_elemIndices +-- ,run prop_findIndices + ] + + runTests "Zipping" opts' + [ +-- run prop_zip +-- ,run prop_zip3 +-- ,run prop_zip4 +-- ,run prop_zip5 +-- ,run prop_zip6 +-- ,run prop_zip7 +-- ,run prop_zipWith +-- ,run prop_zipWith3 +-- ,run prop_zipWith4 +-- ,run prop_zipWith5 +-- ,run prop_zipWith6 +-- ,run prop_zipWith7 + ] + + runTests "Unzipping" opts' + [-- run prop_unzip +-- ,run prop_unzip3 +-- ,run prop_unzip4 +-- ,run prop_unzip5 +-- ,run prop_unzip6 +-- ,run prop_unzip7 + ] + +{- + runTests "Functions on strings" opts' + [run prop_unlines + ,run prop_lines + ,run prop_words + ,run prop_unwords + ] +-} + +{- + runTests "\"Set\" operations" opts' + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] +-} + +{- + runTests "Ordered lists" opts' + [run prop_sort + ,run prop_insert + ] +-} + +{- + runTests "Eq style \"By\" operations" opts' + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] +-} + + runTests "Ord style \"By\" operations" opts' + [ +-- ,run prop_insertBy +-- ,run prop_sortBy -- note issue here. + run prop_maximumBy + ,run prop_minimumBy + ] + +{- + runTests "The \"generic\" operations" opts' + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericIndex + ,run prop_genericSplitAt + ,run prop_genericReplicate + ] +-} diff --git a/tests/Properties/Utils.hs b/tests/Properties/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Utils.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE IncoherentInstances #-} + +module Properties.Utils ( + module Properties.Utils, + module Test.QuickCheck, + module Test.QuickCheck.Batch, + ) where + +import Test.QuickCheck +import Test.QuickCheck.Batch +import Text.Show.Functions +import Control.Monad.Instances + +import Control.Monad (liftM,liftM5) + +import qualified Data.Array.Vector as S +import Data.Array.Vector ((:*:)(..)) + +opts = TestOptions { + no_of_tests = 500, + length_of_tests = 0, + debug_tests = False + } + +eq0 f g = property $ + model f == g +eq1 f g = \x -> property $ + model (f x) == g (model x) +eq2 f g = \x y -> property $ + model (f x y) == g (model x) (model y) +eq3 f g = \x y z -> property $ + model (f x y z) == g (model x) (model y) (model z) +eq4 f g = \x y z a -> property $ + model (f x y z a) == g (model x) (model y) (model z) (model a) +eq5 f g = \x y z a b -> property $ + model (f x y z a b) == g (model x) (model y) (model z) (model a) (model b) +eq6 f g = \x y z a b c -> property $ + model (f x y z a b c) == g (model x) (model y) (model z) (model a) (model b) (model c) +eq7 f g = \x y z a b c d -> property $ + model (f x y z a b c d) == g (model x) (model y) (model z) (model a) (model b) (model c) (model d) +eq8 f g = \x y z a b c d e -> property $ + model (f x y z a b c d e) == g (model x) (model y) (model z) (model a) (model b) (model c) (model d) (model e) + +eqnotnull1 f g = \x -> (not (S.nullU x)) ==> eq1 f g x +eqnotnull2 f g = \x y -> (not (S.nullU y)) ==> eq2 f g x y +eqnotnull3 f g = \x y z -> (not (S.nullU z)) ==> eq3 f g x y z + +{- +eqfinite1 f g = \x -> forAll arbitrary $ \n -> Prelude.take n (f x) == Prelude.take n (g x) +eqfinite2 f g = \x y -> forAll arbitrary $ \n -> Prelude.take n (f x y) == Prelude.take n (g x y) +eqfinite3 f g = \x y z -> forAll arbitrary $ \n -> Prelude.take n (f x y z) == Prelude.take n (g x y z) +-} + +newtype A = A Int deriving (Eq, Show, Arbitrary, S.UA) +newtype B = B Int deriving (Eq, Show, Arbitrary, S.UA) +newtype C = C Int deriving (Eq, Show, Arbitrary, S.UA) +type D = A +type E = B +type F = C +type G = A +type H = B + +newtype OrdA = OrdA Int deriving (Eq, Ord, Show, Arbitrary, S.UA) + +newtype N = N Int deriving (Eq, Ord, Num, Show, Arbitrary, S.UA) +newtype I = I Int deriving (Eq, Ord, Num, Enum, Real, Integral, Show, Arbitrary, S.UA) + +instance Arbitrary Char where + arbitrary = elements ([' ', '\n', '\0'] ++ ['a'..'h']) + coarbitrary c = variant (fromEnum c `rem` 4) + +instance Arbitrary Ordering where + arbitrary = elements [LT, EQ, GT] + coarbitrary LT = variant 0 + coarbitrary EQ = variant 1 + coarbitrary GT = variant 2 + +{- +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = frequency [ (1, return Nothing) + , (3, liftM Just arbitrary) ] + coarbitrary Nothing = variant 0 + coarbitrary (Just a) = variant 1 . coarbitrary a + -} + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a :*: b) where + arbitrary = do x <- arbitrary + y <- arbitrary + return ( x :*: y ) + coarbitrary (a:*:b) = coarbitrary a . coarbitrary b + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) + => Arbitrary (a, b, c, d ,e ) + where + arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary + coarbitrary (a, b, c, d, e) = + coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) + => Arbitrary (a, b, c, d, e, f) + where + arbitrary = liftM6 (,,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary + coarbitrary (a, b, c, d, e, f) = + coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e . coarbitrary f + +liftM6 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m r +liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) } + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f, Arbitrary g) + => Arbitrary (a, b, c, d, e, f, g) + where + arbitrary = liftM7 (,,,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary + coarbitrary (a, b, c, d, e, f, g) = + coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e . coarbitrary f . coarbitrary g + +liftM7 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m r +liftM7 f m1 m2 m3 m4 m5 m6 m7 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7 ; return (f x1 x2 x3 x4 x5 x6 x7) } + + +------------------------------------------------------------------------ +-- Arbitrary instance for Stream + +instance (S.UA a, Arbitrary a) => Arbitrary (S.UArr a) where + arbitrary = do xs <- arbitrary + return $ S.toU xs + coarbitrary = undefined + +{- +instance (Arbitrary a, Arbitrary s) => Arbitrary (S.Step a s) where + arbitrary = do x <- arbitrary + a <- arbitrary + s <- arbitrary + return $ case x of + LT -> S.Yield a s + EQ -> S.Skip s + GT -> S.Done + coarbitrary = error "No coarbitrary for Step a s" +-} + +-- existential state type +{- +instance (Arbitrary a) => Arbitrary (S.Stream a) where + coarbitrary = error "No coarbitrary for Streams" + arbitrary = do xs <- arbitrary :: Gen [a] + skips <- arbitrary :: Gen [Bool] -- random Skips + return (stream' (zip xs skips)) + where + -- | Construct an abstract stream from a list, with Steps in it. + stream' :: [(a,Bool)] -> S.Stream a + stream' xs0 = S.Stream next (S.L xs0) + where + next (S.L []) = S.Done + next (S.L ((x,True ):xs)) = S.Yield x (S.L xs) + next (S.L ((_,False):xs)) = S.Skip (S.L xs) + +instance Show a => Show (S.Stream a) where + show = show . S.unstream + +instance Eq a => Eq (S.Stream a) where + xs == ys = S.unstream xs == S.unstream ys +-} + +------------------------------------------------------------------------ + +class Model a b where + model :: a -> b -- get the abstract vale from a concrete value + +instance S.UA a => Model (S.UArr a) [a] where model = S.fromU + +instance S.UA a => Model (S.UArr a) (S.UArr a) where model = id +instance Model A A where model = id +instance Model B B where model = id +instance Model Bool Bool where model = id +instance Model Int Int where model = id +instance Model N N where model = id +instance Model OrdA OrdA where model = id +instance Model Ordering Ordering where model = id + +instance (Model a a , Model b b) => Model (a:*:b) (a,b) where + model (x:*:y) = (model x, model y) + +-- not really moral +instance Functor ((:*:) a) where + fmap f (x:*:y) = (x :*: f y) + +-- More structured types are modeled recursively, using the NatTrans class from Gofer. +class (Functor f, Functor g) => NatTrans f g where + eta :: f a -> g a + +instance NatTrans [] [] where eta = id +instance NatTrans Maybe Maybe where eta = id + +instance NatTrans ((->) A) ((->) A) where eta = id +instance NatTrans ((->) B) ((->) B) where eta = id +instance NatTrans ((->) N) ((->) N) where eta = id +instance NatTrans ((->) C) ((->) C) where eta = id + +instance Model f g => NatTrans ((,) f) ((,) g) + where eta (f,a) = (model f, a) +instance Model f g => NatTrans ((:*:) f) ((:*:) g) + where eta (f:*:a) = (model f:*: a) + +instance (NatTrans m n, Model a b) => Model (m a) (n b) + where model x = fmap model (eta x) diff --git a/tests/notes b/tests/notes new file mode 100644 --- /dev/null +++ b/tests/notes @@ -0,0 +1,46 @@ + import Data.Array.Vector + + main = print . sumU $ zipWithU (*) + (enumFromToU 1 (100000000 :: Int)) + (enumFromToU 2 (100000001 :: Int)) + +A subset of the NDP arrays library. After stream fusion kicks in, +this compiles to the following (very nice!) core: + + {-# LANGUAGE MagicHash #-} + + import GHC.Prim + import GHC.Base + + go :: Int# -> Int# -> Int# -> Int# + go a b c = + case b ># 100000000# of + False -> + case a ># 100000001# of + False -> + go ((+#) a 1#) + ((+#) b 1#) + ((+#) c ((*#) b a)) + True -> c + True -> c + + main = print (I# (go 2# 1# 0#)) + +Which is exactly what we want, and much the same as this C: + +Which shows up some differences between the native code generator and the +C backend: + + -fvia-C -O2 -optc-O: + + $ time ./T_c + 677921401802298880 + ./T_c 0.21s user 0.00s system 98% cpu 0.213 total + + -fasm -O2 + + $ time ./T_asm + 677921401802298880 + ./T_c 0.26s user 0.00s system 94% cpu 0.276 total + +And now diff --git a/tests/type-correct.hs b/tests/type-correct.hs new file mode 100644 --- /dev/null +++ b/tests/type-correct.hs @@ -0,0 +1,18 @@ +#!/bin/sh + +echo "Checking type correctness ... " + +f=`mktemp` + +for i in Data/Array/Vector.hs ; do + ghci -cpp -Iinclude -v0 $i < /dev/null +done > $f 2>&1 + +if cmp -s $f /dev/null ; then + echo "Passed" + true +else + echo "Failed" + cat $f + false +fi diff --git a/uvector.cabal b/uvector.cabal new file mode 100644 --- /dev/null +++ b/uvector.cabal @@ -0,0 +1,77 @@ +name: uvector +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Manuel Chakravarty, Gabriele Keller, Roman Leshchinskiy, Don Stewart +maintainer: Don Stewart +homepage: http://code.haskell.org/~dons/code/uvector +category: Data +synopsis: Fast unboxed arrays with a flexible interface +description: Fast unboxed arrays with a flexible interface. + The library is built of fusible combinators, as + described in the paper /Stream Fusion: From Lists to + Streams to Nothing at All/. + . + For best results, compile with your user programs + with -O2 -fvia-C -optc-O2. +build-type: Simple +stability: experimental +cabal-version: >= 1.2 +extra-source-files: include/fusion-phases.h README TODO + +flag safe + description: Compile the library with read/write bound checking enabled. + default: False + +library + build-depends: base + + exposed-modules: + Data.Array.Vector + + other-modules: + Data.Array.Vector.Prim.BUArr + Data.Array.Vector.Prim.Debug + Data.Array.Vector.Prim.Hyperstrict + Data.Array.Vector.Prim.Text + + Data.Array.Vector.Stream + Data.Array.Vector.UArr + + Data.Array.Vector.Strict.Stream + Data.Array.Vector.Strict.Basics + Data.Array.Vector.Strict.Enum + Data.Array.Vector.Strict.Sums + Data.Array.Vector.Strict.Permute + Data.Array.Vector.Strict.Text + + include-dirs: include + + extensions: + MagicHash, + UnboxedTuples, + CPP, + BangPatterns, + ExistentialQuantification, + ScopedTypeVariables, + TypeOperators, + Rank2Types, + TypeFamilies + + ghc-options: + -fglasgow-exts + -O2 + -fvia-C -optc-O2 + -fspec-constr + -funbox-strict-fields + -fdicts-cheap + -fno-method-sharing + -fmax-simplifier-iterations10 + -fliberate-case-threshold100 + + if flag(safe) + cpp-options: -DSAFE + + if impl(ghc > 6.8.2) + build-depends: ghc-prim + ghc-options: -fno-spec-constr-threshold