packages feed

uvector (empty) → 0.1

raw patch · 179 files changed

+10857/−0 lines, 179 filesdep +basedep +ghc-primsetup-changed

Dependencies added: base, ghc-prim

Files

+ Data/Array/Vector.hs view
@@ -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 ()++
+ Data/Array/Vector/Prim/BUArr.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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
+ Data/Array/Vector/Prim/Debug.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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"+
+ Data/Array/Vector/Prim/Hyperstrict.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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)+-}++
+ Data/Array/Vector/Prim/Text.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Array.Vector.Prim.Text+-- Copyright   :  (c) 2006 Roman Leshchinskiy+-- License     :  see libraries/ndp/LICENSE+-- +-- Maintainer  :  Roman Leshchinskiy <rl@cse.unsw.edu.au>+-- 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+
+ Data/Array/Vector/Stream.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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 #-}++
+ Data/Array/Vector/Strict/Basics.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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)+
+ Data/Array/Vector/Strict/Enum.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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+
+ Data/Array/Vector/Strict/Permute.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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'+
+ Data/Array/Vector/Strict/Stream.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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)++  #-}+
+ Data/Array/Vector/Strict/Sums.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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 #-}+
+ Data/Array/Vector/Strict/Text.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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")+
+ Data/Array/Vector/UArr.hs view
@@ -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 <rl@cse.unsw.edu.au>+-- 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)+
+ LICENSE view
@@ -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.
+ README view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ TODO view
@@ -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?
+ examples/Makefile view
@@ -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++
+ examples/README view
@@ -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=<N> --runs=<R> <INPUT> +RTS -N<T>++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.+++
+ examples/barhesHut/BarnesHut.hs view
@@ -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 ()+
+ examples/barhesHut/BarnesHutGen.hs view
@@ -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"
+ examples/barhesHut/BarnesHutSeq.hs view
@@ -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+++++
+ examples/concomp/AwShU.hs view
@@ -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+
+ examples/concomp/AwShUP.hs view
@@ -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+
+ examples/concomp/Graph.hs view
@@ -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+
+ examples/concomp/HybU.hs view
@@ -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++
+ examples/concomp/HybUP.hs view
@@ -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+
+ examples/concomp/Makefile view
@@ -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)+
+ examples/concomp/README view
@@ -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)+
+ examples/concomp/concomp.hs view
@@ -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"]+                   "<none>"++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)+
+ examples/concomp/mkg.hs view
@@ -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+
+ examples/dotp/DotPPar.hs view
@@ -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)+
+ examples/dotp/DotPSeq.hs view
@@ -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)+
+ examples/dotp/DotPVect.hs view
@@ -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)+
+ examples/dotp/Makefile view
@@ -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)+
+ examples/dotp/README view
@@ -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+
+ examples/dotp/dotp.hs view
@@ -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 ()+    +
+ examples/fusion/DotP.hs view
@@ -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)+
+ examples/fusion/Map_Map.hs view
@@ -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+
+ examples/fusion/Map_Map_Replicate.hs view
@@ -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+
+ examples/fusion/Map_Replicate.hs view
@@ -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+
+ examples/fusion/runtst.sh view
@@ -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+
+ examples/lib/Bench/Benchmark.hs view
@@ -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+
+ examples/lib/Bench/Options.hs view
@@ -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+
+ examples/lib/Bench/Time.hs view
@@ -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+
+ examples/lib/Makefile view
@@ -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++
+ examples/mk/common.mk view
@@ -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+
+ examples/mk/test.mk view
@@ -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)+
+ examples/primes/H98.hs view
@@ -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])+
+ examples/primes/Makefile view
@@ -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+
+ examples/primes/PrimPar.hs view
@@ -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 ++
+ examples/primes/PrimSeq.hs view
@@ -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)))+
+ examples/primes/README view
@@ -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.+
+ examples/primes/primes.hs view
@@ -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+
+ examples/primespj/Primes.hs view
@@ -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 ()
+ examples/primespj/PrimesVect.hs view
@@ -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:]
+ examples/qsort/Makefile view
@@ -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
+ examples/qsort/QSort.hs view
@@ -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 ()+
+ examples/qsort/QSortPar.hs view
@@ -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+   ++++
+ examples/qsort/QSortSeq.hs view
@@ -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]
+ examples/qsort/QSortVect.hs view
@@ -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))
+ examples/quickcheck/Makefile view
@@ -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 $<+
+ examples/quickcheck/Testsuite.hs view
@@ -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++
+ examples/quickcheck/Testsuite/Preproc.hs view
@@ -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+
+ examples/quickcheck/Testsuite/Testcase.hs view
@@ -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+
+ examples/quickcheck/Testsuite/Utils.hs view
@@ -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+-}+
+ examples/quickcheck/tests/BUArr.hs view
@@ -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)+  -}+  |])+
+ examples/quickcheck/tests/Distributed.hs view
@@ -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++  |])+
+ examples/quickcheck/tests/UnliftedSU.hs view
@@ -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+  |])+
+ examples/quickcheck/tests/Unlifted_Basics.hs view
@@ -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)+  |])+
+ examples/quickcheck/tests/Unlifted_Combinators.hs view
@@ -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+  |])+
+ examples/quickcheck/tests/Unlifted_Fusion.hs view
@@ -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+  |])+
+ examples/quickcheck/tests/Unlifted_Permutes.hs view
@@ -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)+ |])+
+ examples/quickcheck/tests/Unlifted_Subarrays.hs view
@@ -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)+  |])+
+ examples/quickcheck/tests/Unlifted_Sums.hs view
@@ -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)+ |])+
+ examples/quickhull/Makefile view
@@ -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+
+ examples/quickhull/QH.hs view
@@ -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))+
+ examples/quickhull/Types.hs view
@@ -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))++
+ examples/quickhull/quickhull.hs view
@@ -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+
+ examples/ref/DotProd.hs view
@@ -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)
+ examples/ref/MatVecMul.hs view
@@ -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)
+ examples/ref/README view
@@ -0,0 +1,2 @@+These are reference implementations of dot product and matrix-vector +multiplication for comparison purposes.  They don't use parallel arrays.
+ examples/ref/dotprod.c view
@@ -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;+}
+ examples/ref/dotprod.h view
@@ -0,0 +1,6 @@+#ifndef DOTPROD_H+#define DOTPROD_H++float cvectorDP (float *v1, float *v2, int n);++#endif
+ examples/ref/matvecmul.c view
@@ -0,0 +1,23 @@+// gcc -c -O2 matvecmul.c++#include <malloc.h>++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;+}
+ examples/ref/matvecmul.h view
@@ -0,0 +1,6 @@+#ifndef MATVECMUL_H+#define MATVECMUL_H++float cmvm (float *v1, float *v2, int n);++#endif
+ examples/simple/DotProd.hs view
@@ -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 ++-}
+ examples/simple/MapInc.hs view
@@ -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)) #)+	  }+      };++-}
+ examples/simple/PrefixSum.hs view
@@ -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)) #)+      };++-}
+ examples/simple/SegPrefixSum.hs view
@@ -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 ++-}
+ examples/simple/SegSum.hs view
@@ -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;+}++-}
+ examples/simple/Sum.hs view
@@ -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) #)+		}+	    };++-}
+ examples/smvm/Makefile view
@@ -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+
+ examples/smvm/README view
@@ -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.+
+ examples/smvm/SMVMPar.hs view
@@ -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))+
+ examples/smvm/SMVMSeq.hs view
@@ -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))+
+ examples/smvm/SMVMVect.hs view
@@ -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 :]+
+ examples/smvm/mksm.c view
@@ -0,0 +1,187 @@+#include <unistd.h>+#include <stdlib.h>+#include <stdio.h>+#include <fcntl.h>+#include <string.h>+#include <ctype.h>++#include <HsFFI.h>++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;+}+
+ examples/smvm/smvm-c.c view
@@ -0,0 +1,89 @@+#include <unistd.h>+#include <stdio.h>+#include <fcntl.h>+#include <stdlib.h>+#include <time.h>++#include <HsFFI.h>++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)) );+}+
+ examples/smvm/smvm.hs view
@@ -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)+
+ examples/spec-constr/Makefile view
@@ -0,0 +1,8 @@+TESTDIR = ..+PROGS = spec-constr+include $(TESTDIR)/mk/test.mk++spec-constr.o: Pipelines.hi++spec-constr: Pipelines.o $(BENCHLIB)+
+ examples/spec-constr/Pipelines.hs view
@@ -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)+
+ examples/spec-constr/spec-constr.hs view
@@ -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"]+                   "<none>"++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+
+ examples/sumsq/SumSq.hs view
@@ -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+
+ examples/unit/TestBUArr.hs view
@@ -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))
+ examples/unit/TestUArr.hs view
@@ -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))
+ include/fusion-phases.h view
@@ -0,0 +1,5 @@+#define INLINE_U       INLINE+#define INLINE_STREAM  INLINE [1]+#define INLINE_DIST    INLINE [1]+#define INLINE_PA      INLINE [2]+
+ tests/Examples/Test.hs view
@@ -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)
+ tests/Examples/fuse.hs view
@@ -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)+
+ tests/Examples/prod.hs view
@@ -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)+
+ tests/Examples/raw.hs view
@@ -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+
+ tests/Examples/real2Frac.hs view
@@ -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
+ tests/Fusion/Test.hs view
@@ -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)
+ tests/Fusion/and.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print (andU (replicateU 100 True))+
+ tests/Fusion/append.hs view
@@ -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))
+ tests/Fusion/cons.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print . sumU . consU 0xdeadbeef . replicateU (100000000::Int) $ (8::Int)+
+ tests/Fusion/drop.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . lengthU . dropU 100000 . replicateU 1000000 $ (7 :: Int)+
+ tests/Fusion/elem.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . elemU 100 . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int)+
+ tests/Fusion/empty.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print . sumU $ consU (0xdeadbeef::Int) emptyU+
+ tests/Fusion/eq.hs view
@@ -0,0 +1,6 @@++import Data.Array.Vector+main = print (eqU (replicateU 100000000 True)+                  (replicateU 100000000 True))++
+ tests/Fusion/filter.hs view
@@ -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)+
+ tests/Fusion/find.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . findU (==100) . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int)+
+ tests/Fusion/findIndex.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . findIndexU (==100) . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int)+
+ tests/Fusion/foldl1.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . foldl1U (+) . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int)+
+ tests/Fusion/from-to.hs view
@@ -0,0 +1,2 @@+import Data.Array.Vector+main = print . head . toList . fromList $ replicate 1 (7::Int)
+ tests/Fusion/head.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . headU . mapU (`shiftL` 1) . replicateU 1000000000 $ (7 :: Int)+
+ tests/Fusion/index.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print . (\arr -> arr `indexU` 42) . mapU (subtract 6) . replicateU 10000000 $ (7 :: Int)+
+ tests/Fusion/indexed.hs view
@@ -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)+
+ tests/Fusion/init.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . lengthU . initU . replicateU 1000000 $ (7 :: Int)+
+ tests/Fusion/last.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . lastU . mapU (`shiftL` 1) . replicateU 1000000000 $ (7 :: Int)+
+ tests/Fusion/length-bool.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print (lengthU (replicateU 1 True))+
+ tests/Fusion/length-char.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print (lengthU (replicateU 1 'x'))+
+ tests/Fusion/length-double.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print (lengthU (replicateU 1 (pi :: Double)))+
+ tests/Fusion/length-float.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print (lengthU (replicateU 1 (pi :: Float)))+
+ tests/Fusion/length-int16.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Int+main = print (lengthU (replicateU 1 (7 :: Int16)))+
+ tests/Fusion/length-int32.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Int+main = print (lengthU (replicateU 1 (7 :: Int32)))+
+ tests/Fusion/length-int64.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Int+main = print (lengthU (replicateU 1 (7 :: Int64)))+
+ tests/Fusion/length-int8.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Int+main = print (lengthU (replicateU 1 (7 :: Int8)))+
+ tests/Fusion/length-unit.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print (lengthU (replicateU 1 ()))+
+ tests/Fusion/length-word.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Word+main = print (lengthU (replicateU 1 (7 :: Word)))+
+ tests/Fusion/length-word16.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Word+main = print (lengthU (replicateU 1 (7 :: Word16)))+
+ tests/Fusion/length-word32.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Word+main = print (lengthU (replicateU 1 (7 :: Word32)))+
+ tests/Fusion/length-word64.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Word+main = print (lengthU (replicateU 1 (7 :: Word64)))+
+ tests/Fusion/length-word8.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Word+main = print (lengthU (replicateU 1 (7 :: Word8)))+
+ tests/Fusion/length.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print . lengthU . enumFromToU 1 $ (100000000 :: Int)+
+ tests/Fusion/lookup.hs view
@@ -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))
+ tests/Fusion/map.hs view
@@ -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)+
+ tests/Fusion/maximum.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . maximumU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int)+
+ tests/Fusion/maximumBy.hs view
@@ -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)+
+ tests/Fusion/minimum.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . minimumU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int)+
+ tests/Fusion/minimumBy.hs view
@@ -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)+
+ tests/Fusion/null-ndp view

file too large to diff

+ tests/Fusion/null-ndp.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector -- Parallel.Unlifted+main = print . sumU . mapU fstS . indexedU . enumFromToU 1 $ (100000000 :: Int)+
+ tests/Fusion/null.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print . nullU . filterU (>10) . mapU (subtract 6) . enumFromToU 1 $ (100000000 :: Int)+
+ tests/Fusion/or.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print (orU (replicateU 100 True))+
+ tests/Fusion/product.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . productU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int)+
+ tests/Fusion/repeat.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . sumU . repeatU 10 $ replicateU (10000000 :: Int) (5::Int) +
+ tests/Fusion/replicate.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print . sumU . mapU (subtract 7) . replicateU 10000000 $ (7 :: Int)+
+ tests/Fusion/singleton.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print . sumU $ consU (10::Int) (singletonU 2)+
+ tests/Fusion/snoc.hs view
@@ -0,0 +1,3 @@+import Data.Array.Vector+main = print . sumU . (\e -> snocU e 0xdeadbeef) . replicateU (100000000::Int) $ (8::Int)+
+ tests/Fusion/sum-complex.hs view
@@ -0,0 +1,5 @@+import Data.Array.Vector+import Data.Complex++main = print . sumU $ replicateU (100000000 :: Int) (1 :+ 1 ::Complex Double)+
+ tests/Fusion/sum-ratio.hs view
@@ -0,0 +1,5 @@+import Data.Array.Vector+import Data.Ratio++main = print . sumU $ replicateU (100000000 :: Int) (1 % 2 :: Rational)+
+ tests/Fusion/sum.hs view
@@ -0,0 +1,8 @@+import Data.Array.Vector+import Data.Bits++main = print . sumU+             . mapU (*2)+             . mapU (`shiftL` 2)+             $ replicateU (100000000 :: Int) (5::Int)+
+ tests/Fusion/tail.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . lengthU . tailU . replicateU 1000000 $ (7 :: Int)+
+ tests/Fusion/take.hs view
@@ -0,0 +1,4 @@+import Data.Array.Vector+import Data.Bits+main = print . lengthU . takeU 100000 . replicateU 1000000 $ (7 :: Int)+
+ tests/Fusion/takeWhile.hs view
@@ -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!
+ tests/Fusion/unfold.hs view
@@ -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
+ tests/Fusion/zip.hs view
@@ -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))+
+ tests/Fusion/zipwith.hs view
@@ -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)+
+ tests/Fusion/zipwith3.hs view
@@ -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))+
+ tests/Makefile view
@@ -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
+ tests/Performance.hs view
@@ -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+++------------------------------------------------------------------------
+ tests/Properties/Monomorphic/Base.hs view
@@ -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
+ tests/Properties/Monomorphic/UVector.hs view
@@ -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+-}
+ tests/Properties/Test.hs view
@@ -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+    ]+-}
+ tests/Properties/Utils.hs view
@@ -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)
+ tests/notes view
@@ -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
+ tests/type-correct.hs view
@@ -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
+ uvector.cabal view
@@ -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 <dons@galois.com>+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