diff --git a/Data/Repa/Array.hs b/Data/Repa/Array.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array.hs @@ -0,0 +1,343 @@ +-- +-- | NOTE: This is an ALPHA version of Repa 4. The API is not yet complete with +-- respect to Repa 3. Some important functions are still missing, and the +-- docs may not be up-to-date. +-- +-- A Repa array is a wrapper around an underlying container structure that +-- holds the array elements. +-- +-- In the type (`Array` @l@ @a@), the @l@ specifies the `Layout` of data, +-- which includes the type of the underlying container, as well as how +-- the elements should be arranged in that container. The @a@ specifies +-- the element type. +-- +-- === Material layouts +-- +-- Material layouts hold real data and are defined in "Data.Repa.Array.Material". +-- +-- For performance reasons, random access indexing into these layouts +-- is not bounds checked. However, all bulk operators like @map@ and @concat@ +-- are guaranteed to be safe. +-- +-- * `B` -- Boxed vectors. +-- +-- * `U` -- Adaptive unboxed vectors. +-- +-- * `F` -- Foreign memory buffers. +-- +-- * `N` -- Nested arrays. +-- +-- +-- === Delayed layouts +-- +-- Delayed layouts represent the elements of an array by a function that +-- computes those elements on demand. +-- +-- * `D` -- Functions from indices to elements. +-- +-- === Index-space layouts +-- +-- Index-space produce the corresponding index for each element of the array, +-- rather than real data. They can be used to define an array shape +-- without needing to provide element data. +-- +-- * `L` -- Linear spaces. +-- +-- * `RW` -- RowWise spaces. +-- +-- === Meta layouts +-- +-- Meta layouts combine existing layouts into new ones. +-- +-- * `W` -- Windowed arrays. +-- +-- * `E` -- Dense arrays. +-- +-- * `T2` -- Tupled arrays. +-- +-- === Array fusion +-- +-- Array fusion is achieved via the delayed (`D`) layout +-- and the `computeS` function. For example: +-- +-- @ +-- > import Data.Repa.Array +-- > computeS U $ A.map (+ 1) $ A.map (* 2) $ fromList U [1 .. 100 :: Int] +-- @ +-- +-- Lets look at the result of the first `map`: +-- +-- @ +-- > :type A.map (* 2) $ fromList U [1 .. 100 :: Int] +-- A.map (* 2) $ fromList U [1 .. 100 :: Int] +-- :: Array (D U) Int +-- @ +-- +-- In the type @Array (D U) Int@, the outer `D` indicates that the array +-- is represented as a function that computes each element on demand. +-- +-- Applying a second `map` layers another element-producing function on top: +-- +-- @ +-- > :type A.map (+ 1) $ A.map (* 2) $ fromList U [1 .. 100 :: Int] +-- A.map (+ 1) $ A.map (* 2) $ fromList U [1 .. 100 :: Int] +-- :: Array (D (D U)) Int +-- @ +-- +-- At runtime, indexing into an array of the above type involves calling +-- the outer @D@-elayed function, which calls the inner @D@-elayed function, +-- which retrieves source data from the inner @U@-nboxed array. Although +-- this works, indexing into a deep stack of delayed arrays can be quite +-- expensive. +-- +-- To fully evaluate a delayed array, use the `computeS` function, +-- which computes each element of the array sequentially. We pass @computeS@ +-- the name of the desired result layout, in this case we use `U` to indicate +-- an unboxed array of values: +-- +-- @ +-- > :type computeS U $ A.map (+ 1) $ A.map (* 2) $ fromList U [1 .. 100 :: Int] +-- computeS U $ A.map (+ 1) $ A.map (* 2) $ fromList U [1 .. 100 :: Int] +-- :: Array U Int +-- @ +-- +-- At runtime, each element of the result will be computed by first reading +-- the source element, applying @(*2)@ to it, then applying @(+1)@ to it, +-- then writing to the result array. Array \"fusion\" is achieved by the fact +-- that result of applying @(*2)@ to an element is used directly, without +-- writing it to an intermediate buffer. +-- +-- An added bonus is that during compilation, the GHC simplifier will inline +-- the definitions of `map` and `computeS`, then eliminate the intermediate +-- function calls. In the compiled code all intermediate values will be stored +-- unboxed in registers, without any overhead due to boxing or laziness. +-- +-- When used correctly, array fusion allows Repa programs to run as fast as +-- equivalents in C or Fortran. However, without fusion the programs typically +-- run 10-20x slower (so remember apply `computeS` to delayed arrays). +-- +-- === How to write fast code +-- +-- 1. Add @INLINE@ pragmas to all leaf-functions in your code, expecially ones +-- that compute numeric results. Non-inlined lazy function calls can cost +-- upwards of 50 cycles each, while each numeric operator only costs one +-- (or less). Inlining leaf functions also ensures they are specialised at +-- the appropriate numeric types. +-- +-- 2. Add bang patterns to all function arguments, and all fields of your data +-- types. In a high-performance Haskell program, the cost of lazy evaluation +-- can easily dominate the run time if not handled correctly. You don't want +-- to rely on the strictness analyser in numeric code because if it does not +-- return a perfect result then the performance of your program will be +-- awful. This is less of a problem for general Haskell code, and in a different +-- context relying on strictness analysis is fine. +-- +-- 3. Compile your program with @ghc -O2 -fllvm -optlo-O3@. The LLVM compiler +-- produces better object code that GHC's internal native code generator. +-- +module Data.Repa.Array + ( module Data.Repa.Array.Index + + , Name (..) + , Bulk (..), BulkI + , (!) + , length + + -- * Index arrays + -- | Index arrays define an index space but do not contain concrete + -- element values. Indexing into any point in the array produces + -- the index at that point. Index arrays are typically used to + -- provide an array shape to other array operators. + + -- ** Linear spaces + , L(..) + , linear + + -- ** RowWise spaces + , RW(..) + , rowWise + + -- * Meta arrays + + -- ** Delayed arrays + , D(..) + , fromFunction + , toFunction + , delay + + , D2(..) + , delay2 + + -- ** Windowed arrays + , W(..) + , Windowable (..) + , windowed + , entire + + -- ** Tupled arrays + , T2(..) + , tup2 + , untup2 + + -- * Material arrays + -- | Material arrays are represented as concrete data in memory + -- and are defined in "Data.Repa.Array.Material". Indexing into these + -- arrays is not bounds checked, so you may want to use them in + -- conjunction with a @C@hecked layout. + , Material + + -- ** Dense arrays + , E (..) + , vector + , matrix + , cube + + -- * Conversion + , fromList, fromListInto + , toList + + + -- * Computation + , Load + , Target + , computeS, computeIntoS + + -- * Operators + -- ** Index space + -- | Index space transforms view the elements of an array in a different + -- order, but do not compute new elements. They are all constant time + -- operations as the location of the required element in the source + -- array is computed on demand. + , reverse + + -- ** Mapping + , map, map2 + , mapS, map2S + + -- ** Filtering + , filter + + -- ** Searching + , findIndex + + -- ** Sloshing + -- | Sloshing operators copy array elements into a different arrangement, + -- but do not create new element values. + , concat + , concatWith, unlines + , intercalate + , ConcatDict + + , partition + , partitionBy + , partitionByIx + + -- ** Grouping + , groups + , groupsWith + , GroupsDict + + -- ** Folding + , foldl + , folds + , foldsWith + , Folds(..) + , FoldsDict) +where +import Data.Repa.Array.Index +import Data.Repa.Array.Linear as A +import Data.Repa.Array.Dense as A +import Data.Repa.Array.RowWise as A +import Data.Repa.Array.Delayed as A +import Data.Repa.Array.Delayed2 as A +import Data.Repa.Array.Window as A +import Data.Repa.Array.Tuple as A +import Data.Repa.Eval.Array as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Operator.Concat as A +import Data.Repa.Array.Internals.Operator.Group as A +import Data.Repa.Array.Internals.Operator.Fold as A +import Data.Repa.Array.Internals.Operator.Partition as A +import Data.Repa.Array.Internals.Operator.Reduce as A +import Data.Repa.Array.Internals.Operator.Filter as A +import qualified Data.Vector.Fusion.Stream.Monadic as V +import Control.Monad +import Prelude + hiding (reverse, length, map, zipWith, concat, unlines, foldl, filter) +#include "repa-array.h" + + +-- | Classes supported by all material representations. +-- +-- We can index them in a random-access manner, +-- window them in constant time, +-- and use them as targets for a computation. +-- +-- In particular, delayed arrays are not material as we cannot use them +-- as targets for a computation. +-- +type Material l a + = (Bulk l a, Windowable l a, Target l a) + + +-- | O(1). View the elements of a vector in reverse order. +-- +-- @ +-- > toList $ reverse $ fromList U [0..10 :: Int] +-- [10,9,8,7,6,5,4,3,2,1,0] +-- @ +reverse :: BulkI l a + => Array l a -> Array (D l) a + +reverse !arr + = let !len = size (extent $ layout arr) + get ix = arr `index` (len - ix - 1) + in fromFunction (layout arr) get +{-# INLINE_ARRAY reverse #-} + + +-- | O(len src) Yield `Just` the index of the first element matching the predicate +-- or `Nothing` if no such element exists. +findIndex :: BulkI l a + => (a -> Bool) -> Array l a -> Maybe Int + +findIndex p !arr + = loop_findIndex V.SPEC 0 + where + !len = size (extent $ layout arr) + + loop_findIndex !sPEC !ix + | ix >= len = Nothing + | otherwise + = let !x = arr `index` ix + in if p x then Just ix + else loop_findIndex sPEC (ix + 1) + {-# INLINE_INNER loop_findIndex #-} +{-# INLINE_ARRAY findIndex #-} + + +-- | Like `A.map`, but immediately `computeS` the result. +mapS :: (Bulk lSrc a, Target lDst b, Index lSrc ~ Index lDst) + => Name lDst -- ^ Name of destination layout. + -> (a -> b) -- ^ Worker function. + -> Array lSrc a -- ^ Source array. + -> Array lDst b +mapS l f !xs = computeS l $! A.map f xs +{-# INLINE mapS #-} + + +-- | Like `A.map2`, but immediately `computeS` the result. +map2S :: (Bulk lSrc1 a, Bulk lSrc2 b, Target lDst c + , Index lSrc1 ~ Index lDst + , Index lSrc2 ~ Index lDst) + => Name lDst -- ^ Name of destination layout. + -> (a -> b -> c ) -- ^ Worker function. + -> Array lSrc1 a -- ^ Source array. + -> Array lSrc2 b -- ^ Source array + -> Maybe (Array lDst c) +map2S l f xs ys + = liftM (computeS l) $! A.map2 f xs ys +{-# INLINE map2S #-} + + diff --git a/Data/Repa/Array/Delayed.hs b/Data/Repa/Array/Delayed.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Delayed.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Delayed + ( D(..), Array(..) + , fromFunction, toFunction + , delay + , map) +where +import Data.Repa.Array.Index +import Data.Repa.Array.Internals.Bulk +import Data.Repa.Array.Internals.Load +import Data.Repa.Array.Internals.Target +import Debug.Trace +import GHC.Exts +import qualified Data.Repa.Eval.Generic.Par as Par +import qualified Data.Repa.Eval.Generic.Seq as Seq +import Prelude hiding (map, zipWith) +#include "repa-array.h" + + +------------------------------------------------------------------------------- +-- | Delayed arrays wrap functions from an index to element value. +-- The index space is specified by an inner layout, @l@. +-- +-- Every time you index into a delayed array the element at that position +-- is recomputed. +data D l + = Delayed + { delayedLayout :: l } + +deriving instance Eq l => Eq (D l) +deriving instance Show l => Show (D l) + + +------------------------------------------------------------------------------- +-- | Delayed arrays. +instance Layout l => Layout (D l) where + data Name (D l) = D (Name l) + type Index (D l) = Index l + name = D name + create (D n) len = Delayed (create n len) + extent (Delayed l) = extent l + toIndex (Delayed l) ix = toIndex l ix + fromIndex (Delayed l) i = fromIndex l i + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance Eq (Name l) => Eq (Name (D l)) +deriving instance Show (Name l) => Show (Name (D l)) + + +------------------------------------------------------------------------------- +-- | Delayed arrays. +instance Layout l => Bulk (D l) a where + data Array (D l) a + = ADelayed !l (Index l -> a) + + layout (ADelayed l _) = Delayed l + index (ADelayed _l f) ix = f ix + {-# INLINE_ARRAY index #-} + {-# INLINE_ARRAY layout #-} + + +-- Load ----------------------------------------------------------------------- +instance (Layout l1, Target l2 a) + => Load (D l1) l2 a where + loadS (ADelayed l1 get) !buf + = do let !(I# len) = size (extent l1) + + let write ix x = unsafeWriteBuffer buf (I# ix) x + get' ix = get $ fromIndex l1 (I# ix) + {-# INLINE write #-} + {-# INLINE get' #-} + + Seq.fillLinear write get' len + touchBuffer buf + {-# INLINE_ARRAY loadS #-} + + loadP gang (ADelayed l1 get) !buf + = do traceEventIO "Repa.loadP[Delayed]: start" + let !(I# len) = size (extent l1) + + let write ix x = unsafeWriteBuffer buf (I# ix) x + get' ix = get $ fromIndex l1 (I# ix) + {-# INLINE write #-} + {-# INLINE get' #-} + + Par.fillChunked gang write get' len + touchBuffer buf + traceEventIO "Repa.loadP[Delayed]: end" + {-# INLINE_ARRAY loadP #-} + + +-- Conversions ---------------------------------------------------------------- +-- | Wrap a function as a delayed array. +-- +-- @> toList $ fromFunction (Linear 10) (* 2) +-- = [0, 2, 4, 6, 8, 10, 12, 14, 16, 18]@ +-- +fromFunction :: l -> (Index l -> a) -> Array (D l) a +fromFunction l f + = ADelayed l f +{-# INLINE_ARRAY fromFunction #-} + + +-- | Produce the extent of an array, and a function to retrieve an +-- arbitrary element. +toFunction :: Bulk l a + => Array (D l) a -> (l, Index l -> a) +toFunction (ADelayed l f) = (l, f) +{-# INLINE_ARRAY toFunction #-} + + +-- Operators ------------------------------------------------------------------ +-- | Wrap an existing array in a delayed one. +delay :: Bulk l a + => Array l a -> Array (D l) a +delay arr = map id arr +{-# INLINE delay #-} + + +-- | Apply a worker function to each element of an array, +-- yielding a new array with the same extent. +-- +-- The resulting array is delayed, meaning every time you index into +-- it the element at that index is recomputed. +-- +map :: Bulk l a + => (a -> b) -> Array l a -> Array (D l) b +map f arr + = ADelayed (layout arr) (f . index arr) +{-# INLINE_ARRAY map #-} diff --git a/Data/Repa/Array/Delayed2.hs b/Data/Repa/Array/Delayed2.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Delayed2.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Delayed2 + ( D2(..), Array(..) + , delay2 + , map2) +where +import Data.Repa.Array.Index +import Data.Repa.Array.Internals.Bulk +import Data.Repa.Array.Internals.Load +import Data.Repa.Array.Internals.Target +import Debug.Trace +import GHC.Exts +import qualified Data.Repa.Eval.Generic.Par as Par +import qualified Data.Repa.Eval.Generic.Seq as Seq +#include "repa-array.h" + + +------------------------------------------------------------------------------- +-- | A delayed array formed from two source arrays. +-- The source arrays can have different layouts but must +-- have the same extent. +data D2 l1 l2 + = Delayed2 + { delayed2Layout1 :: l1 + , delayed2Layout2 :: l2 } + +deriving instance (Eq l1, Eq l2) => Eq (D2 l1 l2) +deriving instance (Show l1, Show l2) => Show (D2 l1 l2) + + +------------------------------------------------------------------------------- +-- | Delayed arrays. +instance (Layout l1, Layout l2, Index l1 ~ Index l2) + => Layout (D2 l1 l2) where + data Name (D2 l1 l2) = D2 (Name l1) (Name l2) + type Index (D2 l1 l2) = Index l1 + name = D2 name name + create (D2 n1 n2) len = Delayed2 (create n1 len) (create n2 len) + extent (Delayed2 l1 _l2) = extent l1 + toIndex (Delayed2 l1 _l2) ix = toIndex l1 ix + fromIndex (Delayed2 l1 _l2) i = fromIndex l1 i + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance + (Eq (Name l1), Eq (Name l2)) + => Eq (Name (D2 l1 l2)) + +deriving instance + (Show (Name l1), Show (Name l2)) + => Show (Name (D2 l1 l2)) + + +------------------------------------------------------------------------------- +-- | Delayed arrays. +instance (Layout l1, Layout l2, Index l1 ~ Index l2) + => Bulk (D2 l1 l2) a where + + data Array (D2 l1 l2) a + = ADelayed2 !l1 !l2 (Index l1 -> a) + + layout (ADelayed2 l1 l2 _) = Delayed2 l1 l2 + index (ADelayed2 _ _ f) ix = f ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + + +-- Load ----------------------------------------------------------------------- +instance ( Layout lSrc1, Layout lSrc2, Target lDst a + , Index lSrc1 ~ Index lSrc2) + => Load (D2 lSrc1 lSrc2) lDst a where + + loadS (ADelayed2 lSrc1 _lSrc2 get) !buf + = do let !(I# len) = size (extent lSrc1) + + let write ix x = unsafeWriteBuffer buf (I# ix) x + get' ix = get (fromIndex lSrc1 (I# ix)) + {-# INLINE write #-} + {-# INLINE get' #-} + + Seq.fillLinear write get' len + touchBuffer buf + {-# INLINE_ARRAY loadS #-} + + loadP gang (ADelayed2 lSrc1 _lSrc2 get) !buf + = do traceEventIO "Repa.loadP[Delayed2]: start" + let !(I# len) = size (extent lSrc1) + + let write ix x = unsafeWriteBuffer buf (I# ix) x + get' ix = get (fromIndex lSrc1 (I# ix)) + {-# INLINE write #-} + {-# INLINE get' #-} + + Par.fillChunked gang write get' len + touchBuffer buf + traceEventIO "Repa.loadP[Delayed2]: end" + {-# INLINE_ARRAY loadP #-} + + +-- Operators ------------------------------------------------------------------ +-- | Wrap two existing arrays in a delayed array. +delay2 :: (Bulk l1 a, Bulk l2 b, Index l1 ~ Index l2) + => Array l1 a -> Array l2 b -> Maybe (Array (D2 l1 l2) (a, b)) +delay2 arr1 arr2 = map2 (,) arr1 arr2 +{-# INLINE delay2 #-} + + +-- | Combine two arrays element-wise using the given worker function. +-- +-- The two source arrays must have the same extent, else `Nothing`. +map2 :: (Bulk l1 a, Bulk l2 b, Index l1 ~ Index l2) + => (a -> b -> c) + -> Array l1 a -> Array l2 b + -> Maybe (Array (D2 l1 l2) c) + +map2 f arr1 arr2 + | extent (layout arr1) == extent (layout arr2) + = let get_map2 ix = f (index arr1 ix) (index arr2 ix) + {-# INLINE get_map2 #-} + in Just $ ADelayed2 (layout arr1) (layout arr2) get_map2 + + | otherwise + = Nothing +{-# INLINE_ARRAY map2 #-} + + diff --git a/Data/Repa/Array/Dense.hs b/Data/Repa/Array/Dense.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Dense.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Dense + ( E (..) + , Name (..) + , Array (..) + , Buffer (..) + + -- * Common layouts + , vector + , matrix + , cube) +where +import Data.Repa.Array.Index +import Data.Repa.Array.RowWise +import Data.Repa.Array.Internals.Bulk +import Data.Repa.Array.Internals.Target +import Data.Repa.Fusion.Unpack +import Control.Monad +import Prelude as P + + +-- | The Dense layout maps a higher-ranked index space to some underlying +-- linear index space. +-- +-- For example, we can create a dense 2D row-wise array where the elements are +-- stored in a flat unboxed vector: +-- +-- @ +-- > import Data.Repa.Array.Material +-- > let Just arr = fromListInto (matrix U 10 10) [1000..1099 :: Float] +-- +-- > :type arr +-- arr :: Array (E U (RW DIM2) Float +-- +-- > arr ! (Z :. 5 :. 4) +-- > 1054.0 +-- @ +-- +data E r l + = Dense r l + +deriving instance (Eq r, Eq l) => Eq (E r l) +deriving instance (Show r, Show l) => Show (E r l) + + +------------------------------------------------------------------------------- +-- | Dense arrays. +instance (Index r ~ Int, Layout r, Layout l) + => Layout (E r l) where + + data Name (E r l) = E (Name r) (Name l) + type Index (E r l) = Index l + + name = E name name + + create (E nR nL) ix + = Dense (create nR (size ix)) (create nL ix) + + extent (Dense _ l) = extent l + toIndex (Dense _ l) ix = toIndex l ix + fromIndex (Dense _ l) n = fromIndex l n + {-# INLINE name #-} + {-# INLINE create #-} + {-# INLINE extent #-} + {-# INLINE toIndex #-} + {-# INLINE fromIndex #-} + +deriving instance (Eq (Name r), Eq (Name l)) => Eq (Name (E r l)) +deriving instance (Show (Name r), Show (Name l)) => Show (Name (E r l)) + + +------------------------------------------------------------------------------- +-- | Dense arrays. +instance (Index r ~ Int, Layout l, Bulk r a) + => Bulk (E r l) a where + + data Array (E r l) a = Array l (Array r a) + layout (Array l inner) = Dense (layout inner) l + index (Array l inner) ix = index inner (toIndex l ix) + {-# INLINE layout #-} + {-# INLINE index #-} + + +------------------------------------------------------------------------------- +-- | Dense buffers. +instance (Layout l, Index r ~ Int, Target r a) + => Target (E r l) a where + + data Buffer s (E r l) a + = EBuffer !l !(Buffer s r a) + + unsafeNewBuffer (Dense r l) + = do buf <- unsafeNewBuffer r + return $ EBuffer l buf + + unsafeReadBuffer (EBuffer _ buf) ix + = unsafeReadBuffer buf ix + + unsafeWriteBuffer (EBuffer _ buf) ix x + = unsafeWriteBuffer buf ix x + + unsafeGrowBuffer (EBuffer l buf) ix + = do buf' <- unsafeGrowBuffer buf ix + return $ EBuffer l buf' + + unsafeSliceBuffer _st _sz _buf + = error "repa-array: dense sliceBuffer, can't window inner" + + unsafeFreezeBuffer (EBuffer l buf) + = do inner <- unsafeFreezeBuffer buf + return $ Array l inner + + unsafeThawBuffer (Array l inner) + = EBuffer l `liftM` unsafeThawBuffer inner + + touchBuffer (EBuffer _ buf) + = touchBuffer buf + + bufferLayout (EBuffer l buf) + = Dense (bufferLayout buf) l + + {-# INLINE unsafeNewBuffer #-} + {-# INLINE unsafeWriteBuffer #-} + {-# INLINE unsafeGrowBuffer #-} + {-# INLINE unsafeSliceBuffer #-} + {-# INLINE unsafeFreezeBuffer #-} + {-# INLINE touchBuffer #-} + {-# INLINE bufferLayout #-} + + +instance Unpack (Buffer s r a) tBuf + => Unpack (Buffer s (E r l) a) (l, tBuf) where + + unpack (EBuffer l buf) = (l, unpack buf) + repack (EBuffer _ buf) (l, ubuf) = EBuffer l (repack buf ubuf) + {-# INLINE unpack #-} + {-# INLINE repack #-} + + +------------------------------------------------------------------------------- +-- | Yield a layout for a dense vector of the given length. +-- +-- The first argument is the name of the underlying linear layout +-- which stores the elements. +vector :: LayoutI l + => Name l -> Int -> E l DIM1 +vector n len + = create (E n (RC RZ)) (Z :. len) + + +-- | Yield a layout for a matrix with the given number of +-- rows and columns. +matrix :: LayoutI l + => Name l -> Int -> Int -> E l DIM2 +matrix n rows cols + = create (E n (RC (RC RZ))) (Z :. rows :. cols) + + +-- | Yield a layout for a cube with the given number of +-- planes, rows, and columns. +cube :: LayoutI l + => Name l -> Int -> Int -> Int -> E l DIM3 +cube n planes rows cols + = create (E n (RC (RC (RC RZ)))) (Z :. planes :. rows :. cols) + diff --git a/Data/Repa/Array/Index.hs b/Data/Repa/Array/Index.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Index.hs @@ -0,0 +1,23 @@ + +-- | Shapes and Indices +module Data.Repa.Array.Index + ( -- * Shapes + Shape (..) + , inShape + , showShape + + -- ** Polymorphic Shapes + , Z (..) + , (:.) (..) + + -- | Synonyms for common layouts. + , SH0, SH1, SH2, SH3, SH4, SH5 + + -- | Helpers that constrain the coordinates to be @Int@s. + , ish0, ish1, ish2, ish3, ish4, ish5 + + -- * Layouts + , Layout(..), LayoutI) +where +import Data.Repa.Array.Internals.Shape +import Data.Repa.Array.Internals.Layout diff --git a/Data/Repa/Array/Index/Slice.hs b/Data/Repa/Array/Index/Slice.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Index/Slice.hs @@ -0,0 +1,82 @@ + +-- | Index space transformation between arrays and slices. +module Data.Repa.Array.Index.Slice + ( All (..) + , Any (..) + , FullShape + , SliceShape + , Slice (..)) +where +import Data.Repa.Array.Index +import Prelude hiding (replicate, drop) +#include "repa-array.h" + + +-- | Select all indices at a certain position. +data All = All + + +-- | Place holder for any possible shape. +data Any sh = Any + + +-- | Map a type of the index in the full shape, to the type of the index in the slice. +type family FullShape ss +type instance FullShape Z = Z +type instance FullShape (Any sh) = sh +type instance FullShape (sl :. Int) = FullShape sl :. Int +type instance FullShape (sl :. All) = FullShape sl :. Int + + +-- | Map the type of an index in the slice, to the type of the index in the full shape. +type family SliceShape ss +type instance SliceShape Z = Z +type instance SliceShape (Any sh) = sh +type instance SliceShape (sl :. Int) = SliceShape sl +type instance SliceShape (sl :. All) = SliceShape sl :. Int + + +-- | Class of index types that can map to slices. +class Slice ss where + -- | Map an index of a full shape onto an index of some slice. + sliceOfFull :: ss -> FullShape ss -> SliceShape ss + + -- | Map an index of a slice onto an index of the full shape. + fullOfSlice :: ss -> SliceShape ss -> FullShape ss + + +instance Slice Z where + sliceOfFull _ _ = Z + {-# INLINE sliceOfFull #-} + + fullOfSlice _ _ = Z + {-# INLINE fullOfSlice #-} + + +instance Slice (Any sh) where + sliceOfFull _ sh = sh + {-# INLINE sliceOfFull #-} + + fullOfSlice _ sh = sh + {-# INLINE fullOfSlice #-} + + +instance Slice sl => Slice (sl :. Int) where + sliceOfFull (fsl :. _) (ssl :. _) + = sliceOfFull fsl ssl + {-# INLINE sliceOfFull #-} + + fullOfSlice (fsl :. n) ssl + = fullOfSlice fsl ssl :. n + {-# INLINE fullOfSlice #-} + + +instance Slice sl => Slice (sl :. All) where + sliceOfFull (fsl :. All) (ssl :. s) + = sliceOfFull fsl ssl :. s + {-# INLINE sliceOfFull #-} + + fullOfSlice (fsl :. All) (ssl :. s) + = fullOfSlice fsl ssl :. s + {-# INLINE fullOfSlice #-} + diff --git a/Data/Repa/Array/Internals/Bulk.hs b/Data/Repa/Array/Internals/Bulk.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Bulk.hs @@ -0,0 +1,88 @@ + +module Data.Repa.Array.Internals.Bulk + ( Bulk (..), BulkI + , (!) + , length + , toList + , toLists + , toListss) +where +import Data.Repa.Array.Internals.Shape +import Data.Repa.Array.Internals.Layout +import Prelude hiding (length) +#include "repa-array.h" + + +-- Bulk ----------------------------------------------------------------------- +-- | Class of array representations that we can read elements from in a +-- random-access manner. +class Layout l => Bulk l a where + + -- | An Array supplies an element of type @a@ to each position in the + -- index space associated with layout @l@. + data Array l a + + -- | O(1). Get the layout of an array. + layout :: Array l a -> l + + -- | O(1). Get an element from an array. + -- If the provided index is outside the extent of the array then the + -- result depends on the layout. + index :: Array l a -> Index l -> a + + +-- | Constraint synonym that requires an integer index space. +type BulkI l a = (Bulk l a, Index l ~ Int) + + +-- | O(1). Alias for `index`. +(!) :: Bulk l a => Array l a -> Index l -> a +(!) = index +{-# INLINE (!) #-} + + +-- | O(1). Get the number of elements in an array. +length :: Bulk l a + => Array l a -> Int +length !arr = size (extent (layout arr)) +{-# INLINE_ARRAY length #-} + + +-- Conversion ----------------------------------------------------------------- +-- | Convert an array to a list. +toList :: Bulk l a + => Array l a -> [a] +toList !arr + = loop_fromList [] 0 + where !lo = layout arr + !len = length arr + loop_fromList !acc !ix + | ix >= len = reverse acc + | otherwise + = let !x = arr `index` (fromIndex lo ix) + in loop_fromList (x : acc) (ix + 1) +{-# INLINE_ARRAY toList #-} + + +-- | Convert a nested array to some lists. +toLists :: ( Bulk l1 (Array l2 a) + , Bulk l2 a) + => Array l1 (Array l2 a) -- ^ Source array. + -> [[a]] -- ^ Result list. +toLists arr + = let !ll' = toList arr + in map toList ll' +{-# INLINE_ARRAY toLists #-} + + +-- | Convert a triply nested array to a triply nested list. +toListss :: ( Bulk l1 (Array l2 (Array l3 a)) + , Bulk l2 (Array l3 a) + , Bulk l3 a) + => Array l1 (Array l2 (Array l3 a)) -- ^ Source array. + -> [[[a]]] -- ^ Result list. +toListss arr + = let !ll' = toLists arr + in map (map toList) ll' +{-# INLINE_ARRAY toListss #-} + diff --git a/Data/Repa/Array/Internals/Check.hs b/Data/Repa/Array/Internals/Check.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Check.hs @@ -0,0 +1,27 @@ + +module Data.Repa.Array.Internals.Check + ( Check (..) + , Safe (..) + , Unsafe (..)) +where +import Data.Repa.Array.Index + + +class Check m where + method :: m + check :: Shape sh => m -> sh -> sh -> Bool + + +data Safe = Safe + +instance Check Safe where + method = Safe + check _ _ _ = True -- TODO: bounds checks + + +data Unsafe = Unsafe + +instance Check Unsafe where + method = Unsafe + check _ _ _ = True + diff --git a/Data/Repa/Array/Internals/Layout.hs b/Data/Repa/Array/Internals/Layout.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Layout.hs @@ -0,0 +1,39 @@ + +module Data.Repa.Array.Internals.Layout + (Layout (..), LayoutI) +where +import Data.Repa.Array.Internals.Shape + + +-- | A layout provides a total order on the elements of an index space. +-- +-- We can talk about the n-th element of an array, independent of its +-- shape and dimensionality. +-- +class Shape (Index l) => Layout l where + + -- | Short name for a layout which does not include details of + -- the exact extent. + data Name l + + -- | Type used to index into this array layout. + type Index l + + -- | O(1). Proxy for the layout name. + name :: Name l + + -- | O(1). Create a default layout of the given extent. + create :: Name l -> Index l -> l + + -- | O(1). Yield the extent of the layout. + extent :: l -> Index l + + -- | O(1). Convert a polymorphic index to a linear one. + toIndex :: l -> Index l -> Int + + -- | O(1). Convert a linear index to a polymorphic one. + fromIndex :: l -> Int -> Index l + + +type LayoutI l = (Layout l, Index l ~ Int) + diff --git a/Data/Repa/Array/Internals/Load.hs b/Data/Repa/Array/Internals/Load.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Load.hs @@ -0,0 +1,25 @@ + +module Data.Repa.Array.Internals.Load + (Load (..)) +where +import Data.Repa.Array.Internals.Target +import Data.Repa.Array.Internals.Bulk +import Data.Repa.Eval.Gang + + +-- | Compute all elements defined by a delayed array and write them to a +-- manifest target representation. +-- +-- The instances of this class require that the source array has a delayed +-- representation. If you want to use a pre-existing manifest array as the +-- source then `delay` it first. +-- +class (Bulk l1 a, Target l2 a) => Load l1 l2 a where + + -- | Fill an entire array sequentially. + loadS :: Array l1 a -> IOBuffer l2 a -> IO () + + -- | Fill an entire array in parallel. + loadP :: Gang + -> Array l1 a -> IOBuffer l2 a -> IO () + diff --git a/Data/Repa/Array/Internals/Operator/Concat.hs b/Data/Repa/Array/Internals/Operator/Concat.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Operator/Concat.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE CPP #-} + +-- | Concatenation operators on arrays. +module Data.Repa.Array.Internals.Operator.Concat + ( concat + , concatWith + , unlines + , intercalate + , ConcatDict) +where +import Data.Repa.Array.Material as A +import Data.Repa.Array.Delayed as A +import Data.Repa.Array.Index as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Eval.Array as A +import Data.Repa.Fusion.Unpack as A +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Fusion.Stream.Monadic as V +import System.IO.Unsafe +import GHC.Exts hiding (fromList, toList) +import Prelude hiding (reverse, length, map, zipWith, concat, unlines) +#include "repa-array.h" + + +-- | Dictionaries needed to perform a concatenation. +type ConcatDict lOut lIn tIn lDst a + = ( BulkI lOut (Array lIn a) + , BulkI lIn a + , TargetI lDst a + , Unpack (Array lIn a) tIn) + + +--------------------------------------------------------------------------------------------------- +-- | O(len result) Concatenate nested arrays. +-- +-- @ +-- > import Data.Repa.Array.Material +-- > let arrs = fromList B [fromList U [1, 2, 3], fromList U [5, 6, 7 :: Int]] +-- > toList $ concat U arrs +-- [1,2,3,5,6,7] +-- @ +-- +concat :: ConcatDict lOut lIn tIn lDst a + => Name lDst -- ^ Layout for destination. + -> Array lOut (Array lIn a) -- ^ Arrays to concatenate. + -> Array lDst a +concat nDst vs + | A.length vs == 0 + = A.fromList nDst [] + + | otherwise + = unsafePerformIO + $ do let !lens = toUnboxed $ computeS U $ A.map A.length vs + let !len = U.sum lens + !buf_ <- unsafeNewBuffer (create nDst 0) + !buf <- unsafeGrowBuffer buf_ len + let !iLenY = U.length lens + + let loop_concat !iO !iY !row !iX !iLenX + | iX >= iLenX + = if iY >= iLenY - 1 + then return () + else let iY' = iY + 1 + row' = vs `index` iY' + iLenX' = A.length row' + in loop_concat iO iY' row' 0 iLenX' + + | otherwise + = do let x = row `index` iX + unsafeWriteBuffer buf iO x + loop_concat (iO + 1) iY row (iX + 1) iLenX + {-# INLINE_INNER loop_concat #-} + + let !row0 = vs `index` 0 + let !iLenX0 = A.length row0 + loop_concat 0 0 row0 0 iLenX0 + + unsafeFreezeBuffer buf +{-# INLINE_ARRAY concat #-} + + +--------------------------------------------------------------------------------------------------- +-- | O(len result) Concatenate the elements of some nested vector, +-- inserting a copy of the provided separator array between each element. +-- +-- @ +-- > import Data.Repa.Array.Material +-- > let sep = fromList U [0, 0, 0] +-- > let arrs = fromList B [fromList U [1, 2, 3], fromList U [5, 6, 7 :: Int]] +-- > toList $ concatWith U sep arrs +-- [1,2,3,0,0,0,5,6,7,0,0,0] +-- @ +-- +concatWith + :: ( ConcatDict lOut lIn tIn lDst a + , BulkI lSep a) + => Name lDst -- ^ Result representation. + -> Array lSep a -- ^ Separator array. + -> Array lOut (Array lIn a) -- ^ Arrays to concatenate. + -> Array lDst a + +concatWith nDst !is !vs + | A.length vs == 0 + = A.fromList nDst [] + + | otherwise + = unsafePerformIO + $ do + -- Lengths of the source vectors. + let !lens = toUnboxed $ computeS U $ A.map A.length vs + + -- Length of the final result vector. + let !(I# len) = U.sum lens + + U.length lens * A.length is + + -- New buffer for the result vector. + !buf_ <- unsafeNewBuffer (create nDst 0) + !buf <- unsafeGrowBuffer buf_ (I# len) + + -- We checked that vs > 0 at the start, so this is safe. + let !row0 = vs `index` 0 + + -- Number of columns. + let !(I# iLenY) = U.length lens + + -- Length of separator array. + let !(I# iLenS) = A.length is + + let -- Source from column, + loop_concatWith !sPEC !mode !iO !iY !row !iX !iLenX !iS + = case mode of + + -- Source from row + 0# + -- We've finished one of the source rows, + -- so injet the separator array. + | 1# <- iX >=# iLenX + -> loop_concatWith sPEC 1# iO iY row iX iLenX 0# + + -- Keep copying the source row. + | otherwise + -> do let !x = (repack row0 row) `index` (I# iX) + unsafeWriteBuffer buf (I# iO) x + loop_concatWith sPEC 0# (iO +# 1#) iY row (iX +# 1#) iLenX iS + + -- Source from separator array + _ + -- We've finished the separator array. + | 1# <- iS >=# iLenS + -> case iY >=# (iLenY -# 1#) of + + -- We've also finished all the rows, so we're done. + 1# -> return () + + -- Move to the next row. + _ -> do + let !iY' = iY +# 1# + let !row' = vs `index` (I# iY') + let !(I# iLenX') = A.length row' + loop_concatWith sPEC 0# iO iY' (unpack row') 0# iLenX' 0# + + -- Keep copying from the separator array. + | otherwise + -> do let !x = is `index` (I# iS) + unsafeWriteBuffer buf (I# iO) x + loop_concatWith sPEC 1# (iO +# 1#) iY row iX iLenX (iS +# 1#) + + -- First row. + let !(I# iLenX0) = A.length row0 + loop_concatWith V.SPEC 0# 0# 0# (unpack row0) 0# iLenX0 0# + unsafeFreezeBuffer buf +{-# INLINE_ARRAY concatWith #-} + + +-- | Perform a `concatWith`, adding a newline character to the end of each +-- inner array. +unlines :: ( ConcatDict lOut lIn tIn lDst Char) + => Name lDst -- ^ Result representation. + -> Array lOut (Array lIn Char) -- ^ Arrays to concatenate. + -> Array lDst Char + +unlines nDst arrs + = let !fl = A.fromList F ['\n'] + in concatWith nDst fl arrs +{-# INLINE unlines #-} + + +-- Intercalate ------------------------------------------------------------------------------------ +-- | O(len result) Insert a copy of the separator array between the elements of +-- the second and concatenate the result. +-- +-- @ +-- > import Data.Repa.Array.Material +-- > let sep = fromList U [0, 0, 0] +-- > let arrs = fromList B [fromList U [1, 2, 3], fromList U [5, 6, 7 :: Int]] +-- > toList $ intercalate U sep arrs +-- [1,2,3,0,0,0,5,6,7] +-- @ +-- +intercalate + :: ( ConcatDict lOut lIn tIn lDst a + , BulkI lSep a) + => Name lDst -- ^ Result representation. + -> Array lSep a -- ^ Separator array. + -> Array lOut (Array lIn a) -- ^ Arrays to concatenate. + -> Array lDst a + +intercalate nDst !is !vs + | A.length vs == 0 + = A.fromList nDst [] + + | otherwise + = unsafePerformIO + $ do + -- Lengths of the source vectors. + let !lens = toUnboxed $ computeS U $ A.map A.length vs + + -- Length of the final result vector. + let !(I# len) = U.sum lens + + (U.length lens - 1) * A.length is + + -- New buffer for the result vector. + !buf_ <- unsafeNewBuffer (create nDst 0) + !buf <- unsafeGrowBuffer buf_ (I# len) + let !(I# iLenY) = U.length lens + let !(I# iLenI) = A.length is + let !row0 = vs `index` 0 + + let loop_intercalate !sPEC !iO !iY !row !iX !iLenX + -- We've finished copying one of the source elements. + | 1# <- iX >=# iLenX + = case iY >=# iLenY -# 1# of + + -- We've finished all of the source elements. + 1# -> return () + + -- We've finished one of the source elements, but it wasn't + -- the last one. Inject the separator array then copy the + -- next element. + _ -> do + + -- TODO: We're probably getting an unboxing an reboxing + -- here. Check the fused code. + I# iO' <- loop_intercalate_inject sPEC iO 0# + let !iY' = iY +# 1# + let !row' = vs `index` (I# iY') + let !(I# iLenX') = A.length row' + loop_intercalate sPEC iO' iY' (unpack row') 0# iLenX' + + -- Keep copying a source element. + | otherwise + = do let x = (repack row0 row) `index` (I# iX) + unsafeWriteBuffer buf (I# iO) x + loop_intercalate sPEC (iO +# 1#) iY row (iX +# 1#) iLenX + {-# INLINE_INNER loop_intercalate #-} + + -- Inject the separator array. + loop_intercalate_inject !sPEC !iO !n + | 1# <- n >=# iLenI = return (I# iO) + | otherwise + = do let x = is `index` (I# n) + unsafeWriteBuffer buf (I# iO) x + loop_intercalate_inject sPEC (iO +# 1#) (n +# 1#) + {-# INLINE_INNER loop_intercalate_inject #-} + + let !(I# iLenX0) = A.length row0 + loop_intercalate V.SPEC 0# 0# (unpack row0) 0# iLenX0 + unsafeFreezeBuffer buf +{-# INLINE_ARRAY intercalate #-} + diff --git a/Data/Repa/Array/Internals/Operator/Filter.hs b/Data/Repa/Array/Internals/Operator/Filter.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Operator/Filter.hs @@ -0,0 +1,43 @@ +-- | Filtering operators on arrays. +module Data.Repa.Array.Internals.Operator.Filter + ( filter) +where +import Data.Repa.Array.Material as A +import Data.Repa.Array.Index as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Bulk as A +import System.IO.Unsafe +import Prelude as P hiding (filter) +#include "repa-array.h" + + +-- | Keep the elements of an array that match the given predicate. +filter :: (BulkI lSrc a, TargetI lDst a) + => Name lDst -> (a -> Bool) -> Array lSrc a -> Array lDst a + +filter nDst p arr + = unsafePerformIO + $ do + let !len = A.length arr + !buf <- unsafeNewBuffer (create nDst len) + + let loop_filter !ixSrc !ixDst + | ixSrc >= len + = return ixDst + + | otherwise + = do let !x = arr `index` ixSrc + case p x of + False + -> do loop_filter (ixSrc + 1) ixDst + + True + -> do unsafeWriteBuffer buf ixDst x + loop_filter (ixSrc + 1) (ixDst + 1) + + lenDst <- loop_filter 0 0 + + buf' <- unsafeSliceBuffer 0 lenDst buf + unsafeFreezeBuffer buf' +{-# INLINE filter #-} + diff --git a/Data/Repa/Array/Internals/Operator/Fold.hs b/Data/Repa/Array/Internals/Operator/Fold.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Operator/Fold.hs @@ -0,0 +1,98 @@ + +module Data.Repa.Array.Internals.Operator.Fold + ( folds + , foldsWith + , C.Folds(..), FoldsDict) +where +import Data.Repa.Array.Index as A +import Data.Repa.Array.Tuple as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Eval.Chain as A +import Data.Repa.Fusion.Unpack as A +import qualified Data.Repa.Chain as C +import Data.Repa.Fusion.Option +import System.IO.Unsafe +#include "repa-array.h" + + +-- | Segmented fold over vectors of segment lengths and input values. +-- +-- * The total lengths of all segments need not match the length of the +-- input elements vector. The returned `C.Folds` state can be inspected +-- to determine whether all segments were completely folded, or the +-- vector of segment lengths or elements was too short relative to the +-- other. +-- +-- @ +-- > import Data.Repa.Array.Material +-- > import Data.Repa.Nice +-- > let segs = fromList B [("red", 3), ("green", 5)] +-- > let vals = fromList U [0..100 :: Int] +-- > nice $ fst $ folds B U (+) 0 segs vals +-- [("red",3),("green",25)] +-- @ +-- +folds :: FoldsDict lSeg lElt lGrp tGrp lRes tRes n a b + => Name lGrp -- ^ Layout for group names. + -> Name lRes -- ^ Layout for fold results. + -> (a -> b -> b) -- ^ Worker function. + -> b -- ^ Initial state when folding segments. + -> Array lSeg (n, Int) -- ^ Segment names and lengths. + -> Array lElt a -- ^ Elements. + -> (Array (T2 lGrp lRes) (n, b), C.Folds Int Int n a b) + +folds nGrp nRes f z vLens vVals + = foldsWith nGrp nRes f z Nothing vLens vVals +{-# INLINE folds #-} + + +-- | Like `folds`, but take an initial state for the first segment. +-- +-- @ +-- > import Data.Repa.Array.Material +-- > import Data.Repa.Nice +-- > let state = Just ("white", 4, 100) +-- > let segs = fromList B [("red", 3), ("green", 5)] +-- > let vals = fromList U [0..100 :: Int] +-- > nice $ fst $ foldsWith B U (+) 0 state segs vals +-- [("white",106),("red",15),("green",45)] +-- @ +-- +foldsWith + :: FoldsDict lSeg lElt lGrp tGrp lRes tRes n a b + => Name lGrp -- ^ Layout for group names. + -> Name lRes -- ^ Layout for fold results. + -> (a -> b -> b) -- ^ Worker function. + -> b -- ^ Initial state when folding segments. + -> Maybe (n, Int, b) -- ^ Name, length and initial state for first segment. + -> Array lSeg (n, Int) -- ^ Segment names and lengths. + -> Array lElt a -- ^ Elements. + -> (Array (T2 lGrp lRes) (n, b), C.Folds Int Int n a b) + +foldsWith nGrp nRes f z s0 vLens vVals + = unsafePerformIO + $ do + let f' !x !y = return $ f x y + {-# INLINE f' #-} + + let !s0' = case s0 of + Nothing -> None3 + Just (a1, a2, a3) -> Some3 a1 a2 a3 + + A.unchainToArrayIO (T2 nGrp nRes) + $ C.foldsC f' z s0' + (A.chainOfArray vLens) + (A.chainOfArray vVals) +{-# INLINE_ARRAY foldsWith #-} + + +-- | Dictionaries need to perform a segmented fold. +type FoldsDict lSeg lElt lGrp tGrp lRes tRes n a b + = ( Bulk lSeg (n, Int) + , Bulk lElt a + , Target lGrp n + , Target lRes b + , Index lGrp ~ Index lRes + , Unpack (IOBuffer lGrp n) tGrp + , Unpack (IOBuffer lRes b) tRes) diff --git a/Data/Repa/Array/Internals/Operator/Group.hs b/Data/Repa/Array/Internals/Operator/Group.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Operator/Group.hs @@ -0,0 +1,81 @@ + +module Data.Repa.Array.Internals.Operator.Group + ( groups + , groupsWith + , GroupsDict) +where +import Data.Repa.Array.Index as A +import Data.Repa.Array.Tuple as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Fusion.Unpack as A +import Data.Repa.Eval.Chain as A +import qualified Data.Repa.Chain as C +#include "repa-array.h" + + +-- | From a stream of values which has consecutive runs of idential values, +-- produce a stream of the lengths of these runs. +-- +-- @ +-- > import Data.Repa.Array.Material +-- > import Data.Repa.Nice +-- > nice $ groups U U (fromList U "waaabllle") +-- ([('w',1),('a',3),('b',1),('l',3)],Just ('e',1)) +-- @ +-- +groups :: (GroupsDict lElt lGrp tGrp lLen tLen n, Eq n) + => Name lGrp -- ^ Layout for group names. + -> Name lLen -- ^ Layout gor group lengths. + -> Array lElt n -- ^ Input elements. + -> (Array (T2 lGrp lLen) (n, Int), Maybe (n, Int)) + +groups nGrp nLen arr + = groupsWith nGrp nLen (==) Nothing arr +{-# INLINE groups #-} + + +-- | Like `groups`, but use the given function to determine whether two +-- consecutive elements should be in the same group. Also take +-- an initial starting group and count. +-- +-- @ +-- > import Data.Repa.Array.Material +-- > import Data.Repa.Nice +-- > nice $ groupsWith U U (==) (Just ('w', 5)) (fromList U "waaabllle") +-- ([('w',6),('a',3),('b',1),('l',3)],Just ('e',1)) +-- @ +-- +groupsWith + :: GroupsDict lElt lGrp tGrp lLen tLen n + => Name lGrp -- ^ Layout for group names. + -> Name lLen -- ^ Layour for group lengths. + -> (n -> n -> Bool) -- ^ Comparison function. + -> Maybe (n, Int) -- ^ Starting element and count. + -> Array lElt n -- ^ Input elements. + -> (Array (T2 lGrp lLen) (n, Int), Maybe (n, Int)) + +groupsWith nGrp nLen f !c !vec0 + = (vec1, snd k1) + where + f' x y = return $ f x y + {-# INLINE f' #-} + + (vec1, k1) + = A.unchainToArray (T2 nGrp nLen) + $ C.liftChain + $ C.groupsByC f' c + $ A.chainOfArray vec0 +{-# INLINE_ARRAY groupsWith #-} + + +-- | Dictionaries need to perform a grouping. +type GroupsDict lElt lGrp tGrp lLen tLen n + = ( Bulk lElt n + , Target lGrp n + , Target lLen Int + , Index lGrp ~ Index lLen + , Unpack (IOBuffer lLen Int) tLen + , Unpack (IOBuffer lGrp n) tGrp) + + diff --git a/Data/Repa/Array/Internals/Operator/Partition.hs b/Data/Repa/Array/Internals/Operator/Partition.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Operator/Partition.hs @@ -0,0 +1,138 @@ + +module Data.Repa.Array.Internals.Operator.Partition + ( partition + , partitionBy + , partitionByIx) +where +import Data.Repa.Array.Tuple as A +import Data.Repa.Array.Linear as A +import Data.Repa.Array.Delayed as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Layout as A +import Data.Repa.Array.Material.Nested as A +import Data.Repa.Eval.Elt as A +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as UM +import System.IO.Unsafe +#include "repa-array.h" + + +-- | Take a desired number of segments, and array of key value pairs where +-- the key is the segment number. Partition the values into the stated +-- number of segments, discarding values where the key falls outside +-- the given range. +-- +-- * This function operates by first allocating a buffer of size +-- (segs * len src) and filling it with a default value. Both the +-- worst case runtime and memory use will be poor for a large +-- number of destination segments. +-- +-- TODO: we need the pre-init because otherwise unused values in the elems +-- array are undefined. We could avoid this by copying out the used elements +-- after the partition loop finishes. Use a segmented extract function. +-- This would also remove the dependency on the `Elt` class. + +partition + :: (BulkI lSrc (Int, a), Target lDst a, Index lDst ~ Int, Elt a) + => Name lDst -- ^ Name of destination layout. + -> Int -- ^ Total number of segments. + -> Array lSrc (Int, a) -- ^ Segment numbers and values. + -> Array N (Array lDst a) -- ^ Result array + +partition nDst iSegs aSrc + | iSegs <= 0 + = A.fromLists nDst [] + + | otherwise + = unsafePerformIO + $ do + -- Length of source array. + let !len = A.length aSrc + + -- Segment start positions and lengths. + let !vStarts = U.prescanl (+) 0 $ U.replicate iSegs len + !mLens <- UM.replicate iSegs 0 + + -- Elements of result array. + let !lenDst = iSegs * len + !buf <- unsafeNewBuffer (A.create nDst lenDst) + + let loop_partition_init !iDst + | iDst >= lenDst = return () + | otherwise + = do unsafeWriteBuffer buf iDst zero + loop_partition_init (iDst + 1) + {-# INLINE_INNER loop_partition_init #-} + + loop_partition_init 0 + + + let loop_partition !iSrc + | iSrc >= len = return () + | otherwise + = do let !(k, v) = aSrc `A.index` iSrc + + if k >= iSegs + then loop_partition (iSrc + 1) + else do + -- Current start length of this segment. + let !s = U.unsafeIndex vStarts k + !o <- UM.unsafeRead mLens k + + -- Write element into the result. + unsafeWriteBuffer buf (s + o) v + + -- Update segment length. + UM.unsafeWrite mLens k (o + 1) + + loop_partition (iSrc + 1) + {-# INLINE_INNER loop_partition #-} + + loop_partition 0 + + vLens <- U.unsafeFreeze mLens + aElems <- unsafeFreezeBuffer buf + + return $ NArray vStarts vLens aElems +{-# INLINE_ARRAY partition #-} + + +-- | Like `partition` but use the provided function to compute the segment +-- number for each element. +partitionBy + :: (BulkI lSrc a, Target lDst a, Index lDst ~ Int, Elt a) + => Name lDst -- ^ Name of destination layout. + -> Int -- ^ Total number of Segments. + -> (a -> Int) -- ^ Get the segment number for this element. + -> Array lSrc a -- ^ Source values. + -> Array N (Array lDst a) + +partitionBy nDst iSeg fSeg aSrc + = partition nDst iSeg + $ tup2 (A.map fSeg aSrc) aSrc +{-# INLINE partitionBy #-} + + +-- | Like `partition` but use the provided function to compute the segment +-- number for each element. The function is given the index of the each +-- element, along with the element itself. +partitionByIx + :: (BulkI lSrc a, Target lDst a, Index lDst ~ Int, Elt a) + => Name lDst -- ^ Name of destination layout. + -> Int -- ^ Total number of Segments. + -> (Int -> a -> Int) -- ^ Get the segment number for this element. + -> Array lSrc a -- ^ Source values. + -> Array N (Array lDst a) + +partitionByIx nDst iSeg fSeg aSrc + = partition nDst iSeg + $ tup2 aSegVals aSrc + where + fSeg' (ix, x) = fSeg ix x + {-# INLINE fSeg' #-} + + aIxSrc = tup2 (linear $ A.length aSrc) aSrc + aSegVals = A.map fSeg' aIxSrc +{-# INLINE partitionByIx #-} + diff --git a/Data/Repa/Array/Internals/Operator/Reduce.hs b/Data/Repa/Array/Internals/Operator/Reduce.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Operator/Reduce.hs @@ -0,0 +1,20 @@ + +module Data.Repa.Array.Internals.Operator.Reduce + (foldl) +where +import Data.Repa.Array.Index as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Eval.Stream as A +import qualified Data.Vector.Fusion.Stream as S +import Prelude as P hiding (foldl) +#include "repa-array.h" + + +-- | Left fold of all elements in an array, sequentially. +foldl :: (Bulk l b, Index l ~ Int) + => (a -> b -> a) -> a -> Array l b -> a + +foldl f z arr + = S.foldl f z + $ streamOfArray arr +{-# INLINE foldl #-} diff --git a/Data/Repa/Array/Internals/Shape.hs b/Data/Repa/Array/Internals/Shape.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Shape.hs @@ -0,0 +1,202 @@ + +-- | Class of types that can be used as array shapes and indices. +module Data.Repa.Array.Internals.Shape + ( -- * Shapes + Shape(..) + + -- * Shape operators + , inShape + , showShape + + -- * Polymorphic shapes + , Z (..) + , (:.) (..) + , SH0, SH1, SH2, SH3, SH4, SH5 + , ish0, ish1, ish2, ish3, ish4, ish5) +where +#include "repa-array.h" + + +-- | Class of types that can be used as array shapes and indices. +class Eq sh => Shape sh where + + -- | Get the number of dimensions in a shape. + rank :: sh -> Int + + -- | The shape of an array of size zero, with a particular + -- dimensionality. + zeroDim :: sh + + -- | The shape of an array with size one, + -- with a particular dimensionality. + unitDim :: sh + + -- | Compute the intersection of two shapes. + intersectDim :: sh -> sh -> sh + + -- | Add the coordinates of two shapes componentwise + addDim :: sh -> sh -> sh + + -- | Get the total number of elements in an array with this shape. + size :: sh -> Int + + -- | Given a starting and ending index, check if some index is with + -- that range. + inShapeRange :: sh -> sh -> sh -> Bool + + -- | Convert a shape into its list of dimensions. + listOfShape :: sh -> [Int] + + -- | Convert a list of dimensions to a shape + shapeOfList :: [Int] -> Maybe sh + + +------------------------------------------------------------------------------- +-- | Given an array shape and index, check whether the index is in the shape. +inShape :: Shape sh => sh -> sh -> Bool +inShape sh ix + = inShapeRange zeroDim sh ix +{-# INLINE_ARRAY inShape #-} + + +-- | Nicely format a shape as a string +showShape :: Shape sh => sh -> String +showShape = foldr (\sh str -> str ++ " :. " ++ show sh) "Z" . listOfShape +{-# NOINLINE showShape #-} + + +------------------------------------------------------------------------------- +instance Shape Int where + rank _ = 1 + zeroDim = 0 + unitDim = 1 + intersectDim s1 s2 = max s1 s2 + addDim s1 s2 = s1 + s2 + size s = s + inShapeRange i1 i2 i = i >= i1 && i <= i2 + listOfShape i = [i] + shapeOfList [i] = Just i + shapeOfList _ = Nothing + {-# INLINE rank #-} + {-# INLINE zeroDim #-} + {-# INLINE unitDim #-} + {-# INLINE intersectDim #-} + {-# INLINE addDim #-} + {-# INLINE size #-} + {-# INLINE inShapeRange #-} + {-# INLINE listOfShape #-} + {-# INLINE shapeOfList #-} + + +------------------------------------------------------------------------------- +-- | An index of dimension zero +data Z = Z + deriving (Show, Read, Eq, Ord) + + +-- | Our index type, used for both shapes and indices. +infixl 3 :. +data tail :. head + = !tail :. !head + deriving (Show, Read, Eq, Ord) + + +instance Shape Z where + rank _ = 0 + {-# INLINE rank #-} + + zeroDim = Z + {-# INLINE zeroDim #-} + + unitDim = Z + {-# INLINE unitDim #-} + + intersectDim _ _ = Z + {-# INLINE intersectDim #-} + + addDim _ _ = Z + {-# INLINE addDim #-} + + size _ = 1 + {-# INLINE size #-} + + inShapeRange Z Z Z = True + {-# INLINE inShapeRange #-} + + listOfShape _ = [] + {-# NOINLINE listOfShape #-} + + shapeOfList [] = Just Z + shapeOfList _ = Nothing + {-# NOINLINE shapeOfList #-} + + + +instance Shape sh => Shape (sh :. Int) where + rank (sh :. _) + = rank sh + 1 + {-# INLINE rank #-} + + zeroDim = zeroDim :. 0 + {-# INLINE zeroDim #-} + + unitDim = unitDim :. 1 + {-# INLINE unitDim #-} + + intersectDim (sh1 :. n1) (sh2 :. n2) + = (intersectDim sh1 sh2 :. (min n1 n2)) + {-# INLINE intersectDim #-} + + addDim (sh1 :. n1) (sh2 :. n2) + = addDim sh1 sh2 :. (n1 + n2) + {-# INLINE addDim #-} + + size (sh1 :. n) + = size sh1 * n + {-# INLINE size #-} + + inShapeRange (zs :. z) (sh1 :. n1) (sh2 :. n2) + = (n2 >= z) && (n2 < n1) && (inShapeRange zs sh1 sh2) + {-# INLINE inShapeRange #-} + + listOfShape (sh :. n) + = n : listOfShape sh + {-# NOINLINE listOfShape #-} + + shapeOfList xx + = case xx of + [] -> Nothing + x : xs -> do ss <- shapeOfList xs + return $ ss :. x + {-# NOINLINE shapeOfList #-} + + +------------------------------------------------------------------------------- +-- Common shapes +type SH0 = Z +type SH1 = SH0 :. Int +type SH2 = SH1 :. Int +type SH3 = SH2 :. Int +type SH4 = SH3 :. Int +type SH5 = SH4 :. Int + + +ish0 :: SH0 +ish0 = Z + +ish1 :: Int -> SH1 +ish1 x1 = Z :. x1 + +ish2 :: Int -> Int -> SH2 +ish2 x2 x1 = Z :. x2 :. x1 + +ish3 :: Int -> Int -> Int -> SH3 +ish3 x3 x2 x1 = Z :. x3 :. x2 :. x1 + +ish4 :: Int -> Int -> Int -> Int -> SH4 +ish4 x4 x3 x2 x1 = Z :. x4 :. x3 :. x2 :. x1 + + +ish5 :: Int -> Int -> Int -> Int -> Int -> SH5 +ish5 x5 x4 x3 x2 x1 = Z :. x5 :. x4 :. x3 :. x2 :. x1 + diff --git a/Data/Repa/Array/Internals/Target.hs b/Data/Repa/Array/Internals/Target.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Target.hs @@ -0,0 +1,109 @@ + +module Data.Repa.Array.Internals.Target + ( Target (..), IOBuffer, TargetI + , fromList, fromListInto) +where +import Data.Repa.Array.Index as A +import Data.Repa.Array.Internals.Bulk as A +import System.IO.Unsafe +import Control.Monad +import Control.Monad.Primitive +import Prelude as P + + +-- Target --------------------------------------------------------------------- +-- | Class of manifest array representations that can be constructed +-- in a random-access manner. +-- +--- +-- TODO: generalise to work with higher ranked indices. +class Layout l => Target l a where + + -- | Mutable buffer for some array representation. + data Buffer s l a + + -- | Allocate a new mutable buffer for the given layout. + -- + -- UNSAFE: The integer must be positive, but this is not checked. + unsafeNewBuffer :: PrimMonad m => l -> m (Buffer (PrimState m) l a) + + -- | Read an element from the mutable buffer. + -- + -- UNSAFE: The index bounds are not checked. + unsafeReadBuffer :: PrimMonad m => Buffer (PrimState m) l a -> Int -> m a + + -- | Write an element into the mutable buffer. + -- + -- UNSAFE: The index bounds are not checked. + unsafeWriteBuffer :: PrimMonad m => Buffer (PrimState m) l a -> Int -> a -> m () + + -- | O(n). Copy the contents of a buffer that is larger by the given + -- number of elements. + -- + -- UNSAFE: The integer must be positive, but this is not checked. + unsafeGrowBuffer :: PrimMonad m => Buffer (PrimState m) l a -> Int + -> m (Buffer (PrimState m) l a) + + -- | O(1). Yield a slice of the buffer without copying. + -- + -- UNSAFE: The given starting position and length must be within the bounds + -- of the of the source buffer, but this is not checked. + unsafeSliceBuffer :: PrimMonad m => Int -> Int -> Buffer (PrimState m) l a + -> m (Buffer (PrimState m) l a) + + -- | O(1). Freeze a mutable buffer into an immutable Repa array. + -- + -- UNSAFE: If the buffer is mutated further then the result of reading from + -- the returned array will be non-deterministic. + unsafeFreezeBuffer :: PrimMonad m => Buffer (PrimState m) l a -> m (Array l a) + + -- | O(1). Thaw an Array into a mutable buffer. + -- + -- UNSAFE: The Array is no longer safe to use. + unsafeThawBuffer :: PrimMonad m => Array l a -> m (Buffer (PrimState m) l a) + + -- | Ensure the array is still live at this point. + -- Sometimes needed when the mutable buffer is a ForeignPtr with a finalizer. + touchBuffer :: PrimMonad m => Buffer (PrimState m) l a -> m () + + -- | O(1). Get the layout from a Buffer. + bufferLayout :: Buffer s l a -> l + +type IOBuffer = Buffer RealWorld + +-- | Constraint synonym that requires an integer index space. +type TargetI l a = (Target l a, Index l ~ Int) + + +------------------------------------------------------------------------------- +-- | O(length src). Construct a linear array from a list of elements. +fromList :: TargetI l a + => Name l -> [a] -> Array l a +fromList nDst xx + = let len = P.length xx + lDst = create nDst len + Just arr = fromListInto lDst xx + in arr +{-# NOINLINE fromList #-} + + +-- | O(length src). Construct an array from a list of elements, +-- and give it the provided layout. +-- +-- The `length` of the provided shape must match the length of the list, +-- else `Nothing`. +-- +fromListInto :: Target l a + => l -> [a] -> Maybe (Array l a) +fromListInto lDst xx + = unsafePerformIO + $ do let !len = P.length xx + if len /= size (extent lDst) + then return Nothing + else do + buf <- unsafeNewBuffer lDst + zipWithM_ (unsafeWriteBuffer buf) [0..] xx + arr <- unsafeFreezeBuffer buf + return $ Just arr +{-# NOINLINE fromListInto #-} + diff --git a/Data/Repa/Array/Linear.hs b/Data/Repa/Array/Linear.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Linear.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Linear + ( L(..) + , Name (..) + , Array (..) + , linear) +where +import Data.Repa.Array.Index +import Data.Repa.Array.Internals.Bulk +#include "repa-array.h" + + +-- | A linear layout with the elements indexed by integers. +-- +-- * Indexing is not bounds checked. Indexing outside the extent +-- yields the corresponding index. +-- +data L = Linear + { linearLength :: Int } + +deriving instance Eq L +deriving instance Show L + + +-- | Linear layout. +instance Layout L where + data Name L = L + type Index L = Int + name = L + create L len = Linear len + extent (Linear len) = len + toIndex _ ix = ix + fromIndex _ ix = ix + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance Eq (Name L) +deriving instance Show (Name L) + + +-- | Linear arrays. +instance Bulk L Int where + data Array L Int = LArray Int + layout (LArray len) = Linear len + index (LArray _) ix = ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + + +-- | Construct a linear array that produces the corresponding index +-- for every element. +-- +-- @> toList $ linear 10 +-- [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]@ +-- +linear :: Int -> Array L Int +linear len = LArray len +{-# INLINE linear #-} + diff --git a/Data/Repa/Array/Material.hs b/Data/Repa/Array/Material.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material.hs @@ -0,0 +1,60 @@ + +module Data.Repa.Array.Material + ( Name (..) + , Array (..) + + -- * Boxed arrays + , B (..) + , fromBoxed, toBoxed + , decimate + + -- * Unboxed arrays + , U (..) + , Unbox + , fromUnboxed, toUnboxed + + -- * Foreign arrays + , F (..) + , fromForeignPtr, toForeignPtr + , fromByteString, toByteString + , fromStorableVector, toStorableVector + + + -- * Nested arrays + , N (..) + + -- ** Conversion + , fromLists + , fromListss + + -- ** Mapping + , mapElems + + -- ** Slicing + , slices + + -- ** Concatenation + , concats + + -- ** Splitting + , segment + , segmentOn + + , dice + , diceSep + + -- ** Trimming + , trims + , trimEnds + , trimStarts + + -- ** Transpose + , ragspose3) +where +import Data.Repa.Array.Material.Boxed +import Data.Repa.Array.Material.Unboxed +import Data.Repa.Array.Material.Foreign +import Data.Repa.Array.Material.Nested + + + diff --git a/Data/Repa/Array/Material/Boxed.hs b/Data/Repa/Array/Material/Boxed.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Boxed.hs @@ -0,0 +1,168 @@ + +module Data.Repa.Array.Material.Boxed + ( B (..) + , Name (..) + , Array (..) + , Buffer (..) + + -- * Conversions + , fromBoxed, toBoxed + + -- * Utils + , decimate) +where +import Data.Repa.Array.Window as A +import Data.Repa.Array.Index as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Fusion.Unpack +import Data.Word +import Control.Monad +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +#include "repa-array.h" + + +-- | Layout an array as flat vector of boxed elements. +-- +-- UNSAFE: Indexing into raw material arrays is not bounds checked. +-- You may want to wrap this with a Checked layout as well. +-- +data B = Boxed { boxedLength :: !Int } + deriving (Show, Eq) + +------------------------------------------------------------------------------ +-- | Boxed arrays. +instance Layout B where + data Name B = B + type Index B = Int + name = B + create B len = Boxed len + extent (Boxed len) = len + toIndex _ ix = ix + fromIndex _ ix = ix + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance Eq (Name B) +deriving instance Show (Name B) + + +------------------------------------------------------------------------------ +-- | Boxed arrays. +instance Bulk B a where + data Array B a = BArray !(V.Vector a) + layout (BArray vec) = Boxed (V.length vec) + index (BArray vec) ix = V.unsafeIndex vec ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + +deriving instance Show a => Show (Array B a) + + +------------------------------------------------------------------------------- +-- | Boxed windows. +instance Windowable B a where + window st len (BArray vec) + = BArray (V.slice st len vec) + {-# INLINE_ARRAY window #-} + + +------------------------------------------------------------------------------- +-- | Boxed buffers. +instance Target B a where + data Buffer s B a + = BBuffer !(VM.MVector s a) + + unsafeNewBuffer (Boxed len) + = liftM BBuffer (VM.unsafeNew len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (BBuffer mvec) ix + = VM.unsafeRead mvec ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (BBuffer mvec) ix + = VM.unsafeWrite mvec ix + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (BBuffer mvec) bump + = liftM BBuffer (VM.unsafeGrow mvec bump) + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (BBuffer mvec) + = liftM BArray (V.unsafeFreeze mvec) + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (BArray vec) + = liftM BBuffer (V.unsafeThaw vec) + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer start len (BBuffer mvec) + = let mvec' = VM.unsafeSlice start len mvec + in return $ BBuffer mvec' + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer _ + = return () + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (BBuffer mvec) + = Boxed (VM.length mvec) + {-# INLINE_ARRAY bufferLayout #-} + + {-# SPECIALIZE instance Target B Int #-} + {-# SPECIALIZE instance Target B Float #-} + {-# SPECIALIZE instance Target B Double #-} + {-# SPECIALIZE instance Target B Word8 #-} + {-# SPECIALIZE instance Target B Word16 #-} + {-# SPECIALIZE instance Target B Word32 #-} + {-# SPECIALIZE instance Target B Word64 #-} + + +instance Unpack (Buffer s B a) (VM.MVector s a) where + unpack (BBuffer vec) = vec + repack _ vec = BBuffer vec + {-# INLINE_ARRAY unpack #-} + {-# INLINE_ARRAY repack #-} + + +------------------------------------------------------------------------------- +-- | O(1). Wrap a boxed vector as an array. +fromBoxed :: V.Vector a -> Array B a +fromBoxed vec = BArray vec +{-# INLINE_ARRAY fromBoxed #-} + + +-- | O(1). Unwrap a boxed vector from an array. +toBoxed :: Array B a -> V.Vector a +toBoxed (BArray vec) = vec +{-# INLINE_ARRAY toBoxed #-} + + + +-- | Scan through an array from front to back. +-- For pairs of successive elements, drop the second one when the given +-- predicate returns true. +-- +-- This function can be used to remove duplicates from a sorted array. +-- +-- TODO: generalise to other array types. +decimate + :: (a -> a -> Bool) + -> Array B a -> Array B a + +decimate f arr + | A.length arr == 0 + = A.fromList B [] + + | otherwise + = fromBoxed + $ V.cons (arr `A.index` 0) + (V.map snd + $ V.filter (\(prev, here) -> not $ f prev here) + $ V.zip (toBoxed arr) (V.tail $ toBoxed arr)) + diff --git a/Data/Repa/Array/Material/Foreign.hs b/Data/Repa/Array/Material/Foreign.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Foreign.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE ViewPatterns #-} +module Data.Repa.Array.Material.Foreign + ( F (..) + , Name (..) + , Array (..) + , Buffer (..) + + -- * Conversions + , fromForeignPtr, toForeignPtr + , fromStorableVector, toStorableVector + , fromByteString, toByteString) +where +import Data.Repa.Array.Delayed +import Data.Repa.Array.Window +import Data.Repa.Array.Index +import Data.Repa.Array.Internals.Target +import Data.Repa.Array.Internals.Bulk +import Data.Word +import Foreign.ForeignPtr +import Foreign.Storable +import Data.Repa.Fusion.Unpack +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import Control.Monad + +import qualified Data.Vector.Storable as S +import qualified Data.Vector.Storable.Mutable as M + +import Control.Monad.Primitive + +#include "repa-array.h" + + +-- | Layout for Foreign arrays. +-- +-- UNSAFE: Indexing into raw material arrays is not bounds checked. +-- You may want to wrap this with a Checked layout as well. +-- +data F = Foreign { foreignLength :: Int } + deriving (Show, Eq) + +------------------------------------------------------------------------------ +-- | Foreign arrays. +instance Layout F where + data Name F = F + type Index F = Int + name = F + create F len = Foreign len + extent (Foreign len) = len + toIndex _ ix = ix + fromIndex _ ix = ix + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance Eq (Name F) +deriving instance Show (Name F) + +------------------------------------------------------------------------------- +-- | Foreign arrays. +instance Storable a => Bulk F a where + data Array F a = FArray !(S.Vector a) + layout (FArray v) = Foreign (S.length v) + index (FArray v) i = S.unsafeIndex v i + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + {-# SPECIALIZE instance Bulk F Char #-} + {-# SPECIALIZE instance Bulk F Int #-} + {-# SPECIALIZE instance Bulk F Float #-} + {-# SPECIALIZE instance Bulk F Double #-} + {-# SPECIALIZE instance Bulk F Word8 #-} + {-# SPECIALIZE instance Bulk F Word16 #-} + {-# SPECIALIZE instance Bulk F Word32 #-} + {-# SPECIALIZE instance Bulk F Word64 #-} + +deriving instance (S.Storable a, Show a) => Show (Array F a) + +instance Unpack (Array F a) (S.Vector a) where + unpack (FArray v) = v + repack _ v = FArray v + {-# INLINE_ARRAY unpack #-} + {-# INLINE_ARRAY repack #-} + +------------------------------------------------------------------------------- +-- | Windowing Foreign arrays. +instance Storable a => Windowable F a where + window st len (FArray vec) + = FArray (S.slice st len vec) + {-# INLINE_ARRAY window #-} + {-# SPECIALIZE instance Windowable F Char #-} + {-# SPECIALIZE instance Windowable F Int #-} + {-# SPECIALIZE instance Windowable F Float #-} + {-# SPECIALIZE instance Windowable F Double #-} + {-# SPECIALIZE instance Windowable F Word8 #-} + {-# SPECIALIZE instance Windowable F Word16 #-} + {-# SPECIALIZE instance Windowable F Word32 #-} + {-# SPECIALIZE instance Windowable F Word64 #-} + + +------------------------------------------------------------------------------- +-- | Foreign buffers + +instance Storable a => Target F a where + data Buffer s F a = FBuffer !(M.MVector s a) + + unsafeNewBuffer (Foreign n) = FBuffer `liftM` M.unsafeNew n + unsafeReadBuffer (FBuffer mv) i = M.unsafeRead mv i + unsafeWriteBuffer (FBuffer mv) i a = M.unsafeWrite mv i a + unsafeGrowBuffer (FBuffer mv) x = FBuffer `liftM` M.unsafeGrow mv x + unsafeThawBuffer (FArray v) = FBuffer `liftM` S.unsafeThaw v + unsafeFreezeBuffer (FBuffer mv) = FArray `liftM` S.unsafeFreeze mv + unsafeSliceBuffer i n (FBuffer mv) = return $ FBuffer (M.unsafeSlice i n mv) + touchBuffer (FBuffer (M.MVector _ p)) = unsafePrimToPrim $ touchForeignPtr p + bufferLayout (FBuffer mv) = Foreign $ M.length mv + {-# INLINE unsafeNewBuffer #-} + {-# INLINE unsafeWriteBuffer #-} + {-# INLINE unsafeReadBuffer #-} + {-# INLINE unsafeGrowBuffer #-} + {-# INLINE unsafeThawBuffer #-} + {-# INLINE unsafeFreezeBuffer #-} + {-# INLINE unsafeSliceBuffer #-} + {-# INLINE touchBuffer #-} + {-# INLINE bufferLayout #-} + +-- | Unpack Foreign buffers +instance Unpack (Buffer s F a) (M.MVector s a) where + unpack (FBuffer mv) = mv + repack _ mv = FBuffer mv + {-# INLINE_ARRAY unpack #-} + {-# INLINE_ARRAY repack #-} + +------------------------------------------------------------------------------- +-- | O(1). Wrap a `ForeignPtr` as an array. +fromForeignPtr :: Storable a => Int -> ForeignPtr a -> Array F a +fromForeignPtr n p = FArray $ S.unsafeFromForeignPtr p 0 n +{-# INLINE_ARRAY fromForeignPtr #-} + + +toForeignPtr :: Storable a => Array F a -> (Int, Int, ForeignPtr a) +toForeignPtr (FArray (S.unsafeToForeignPtr -> (p,i,n))) = (i,n,p) +{-# INLINE_ARRAY toForeignPtr #-} + + +-- | O(1). Convert a foreign array to a storable `Vector`. +toStorableVector :: Array F a -> S.Vector a +toStorableVector (FArray vec) = vec +{-# INLINE_ARRAY toStorableVector #-} + + +-- | O(1). Convert a storable `Vector` to a foreign `Array` +fromStorableVector :: S.Vector a -> Array F a +fromStorableVector vec = FArray vec +{-# INLINE_ARRAY fromStorableVector #-} + + +-- | O(1). Convert a foreign 'Vector' to a `ByteString`. +toByteString :: Array F Word8 -> ByteString +toByteString (FArray (S.unsafeToForeignPtr -> (p,i,n))) + = BS.PS p i n +{-# INLINE_ARRAY toByteString #-} + + +-- | O(1). Convert a `ByteString` to an foreign `Array`. +fromByteString :: ByteString -> Array F Word8 +fromByteString (BS.PS p i n) + = FArray (S.unsafeFromForeignPtr p i n) +{-# INLINE_ARRAY fromByteString #-} + + + +instance (Eq a, Storable a) => Eq (Array F a) where + (FArray a1) == (FArray a2) = a1 == a2 + {-# INLINE_ARRAY (==) #-} + diff --git a/Data/Repa/Array/Material/Nested.hs b/Data/Repa/Array/Material/Nested.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Nested.hs @@ -0,0 +1,423 @@ + +module Data.Repa.Array.Material.Nested + ( N (..) + , Name (..) + , Array (..) + , U.Unbox + + -- * Conversion + , fromLists + , fromListss + + -- * Mapping + , mapElems + + -- * Slicing + , slices + + -- * Concatenation + , concats + + -- * Splitting + , segment + , segmentOn + + , dice + , diceSep + + -- * Trimming + , trims + , trimEnds + , trimStarts + + -- * Transpose + , ragspose3) +where +import Data.Repa.Array.Delayed +import Data.Repa.Array.Window +import Data.Repa.Array.Index +import Data.Repa.Array.Material.Unboxed as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Eval.Stream as A +import Data.Repa.Stream as S +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Fusion.Stream as S +import qualified Data.Repa.Vector.Generic as G +import qualified Data.Repa.Vector.Unboxed as U +import Control.Monad.ST +import Prelude as P +import Prelude hiding (concat) +#include "repa-array.h" + + +-- | Nested array represented as a flat array of elements, and a segment +-- descriptor that describes how the elements are partitioned into +-- the sub-arrays. Using this representation for multidimentional arrays +-- is significantly more efficient than using a boxed array of arrays, +-- as there is no need to allocate the sub-arrays individually in the heap. +-- +-- With a nested type like: +-- @Array N (Array N (Array U Int))@, the concrete representation consists +-- of five flat unboxed vectors: two for each of the segment descriptors +-- associated with each level of nesting, and one unboxed vector to hold +-- all the integer elements. +-- +-- UNSAFE: Indexing into raw material arrays is not bounds checked. +-- You may want to wrap this with a Checked layout as well. +-- +data N = Nested + { nestedLength :: !Int } + +deriving instance Eq N +deriving instance Show N + + +------------------------------------------------------------------------------- +-- | Nested arrays. +instance Layout N where + data Name N = N + type Index N = Int + name = N + create N len = Nested len + extent (Nested len) = len + toIndex _ ix = ix + fromIndex _ ix = ix + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance Eq (Name N) +deriving instance Show (Name N) + + +------------------------------------------------------------------------------- +-- | Nested arrays. +instance (BulkI l a, Windowable l a) + => Bulk N (Array l a) where + + data Array N (Array l a) + = NArray !(U.Vector Int) -- segment start positions. + !(U.Vector Int) -- segment lengths. + !(Array l a) -- data values + + layout (NArray starts _lengths _elems) + = Nested (U.length starts) + {-# INLINE_ARRAY layout #-} + + index (NArray starts lengths elems) ix + = window (starts `U.unsafeIndex` ix) + (lengths `U.unsafeIndex` ix) + elems + {-# INLINE_ARRAY index #-} + + +deriving instance Show (Array l a) => Show (Array N (Array l a)) + + +------------------------------------------------------------------------------- +-- | Windowing Nested arrays. +instance (BulkI l a, Windowable l a) + => Windowable N (Array l a) where + window start len (NArray starts lengths elems) + = NArray (U.unsafeSlice start len starts) + (U.unsafeSlice start len lengths) + elems + {-# INLINE_ARRAY window #-} + + +------------------------------------------------------------------------------- +-- | O(size src) Convert some lists to a nested array. +fromLists + :: TargetI l a + => Name l -> [[a]] -> Array N (Array l a) +fromLists nDst xss + = let xs = concat xss + elems = fromList nDst xs + lengths = U.fromList $ P.map P.length xss + starts = U.unsafeInit $ U.scanl (+) 0 lengths + in NArray starts lengths elems +{-# INLINE_ARRAY fromLists #-} + + +-- | O(size src) Convert a triply nested list to a triply nested array. +fromListss + :: TargetI l a + => Name l -> [[[a]]] -> Array N (Array N (Array l a)) +fromListss nDst xs + = let xs1 = concat xs + xs2 = concat xs1 + elems = fromList nDst xs2 + + lengths1 = U.fromList $ P.map P.length xs + starts1 = U.unsafeInit $ U.scanl (+) 0 lengths1 + + lengths2 = U.fromList $ P.map P.length xs1 + starts2 = U.unsafeInit $ U.scanl (+) 0 lengths2 + + in NArray starts1 lengths1 + $ NArray starts2 lengths2 + $ elems +{-# INLINE_ARRAY fromListss #-} + + +------------------------------------------------------------------------------- +-- | Apply a function to all the elements of a doubly nested array, +-- preserving the nesting structure. +mapElems :: (Array l1 a -> Array l2 b) + -> Array N (Array l1 a) + -> Array N (Array l2 b) + +mapElems f (NArray starts lengths elems) + = NArray starts lengths (f elems) +{-# INLINE_ARRAY mapElems #-} + + +------------------------------------------------------------------------------- +-- | O(1). Produce a nested array by taking slices from some array of elements. +-- +-- This is a constant time operation, as the representation for nested +-- vectors just wraps the starts, lengths and elements vectors. +-- +slices :: Array U Int -- ^ Segment starting positions. + -> Array U Int -- ^ Segment lengths. + -> Array l a -- ^ Array elements. + -> Array N (Array l a) + +slices (UArray starts) (UArray lens) !elems + = NArray starts lens elems +{-# INLINE_ARRAY slices #-} + + +------------------------------------------------------------------------------- +-- | Segmented concatenation. +-- Concatenate triply nested vector, producing a doubly nested vector. +-- +-- * Unlike the plain `concat` function, this operation is performed entirely +-- on the segment descriptors of the nested arrays, and does not require +-- the inner array elements to be copied. +-- +-- @ +-- > import Data.Repa.Nice +-- > nice $ concats $ fromListss U [["red", "green", "blue"], ["grey", "white"], [], ["black"]] +-- ["red","green","blue","grey","white","black"] +-- @ +-- +concats :: Array N (Array N (Array l a)) + -> Array N (Array l a) + +concats (NArray starts1 lengths1 (NArray starts2 lengths2 elems)) + = let + !starts2' = U.extract (U.unsafeIndex starts2) + $ U.zip starts1 lengths1 + + !lengths2' = U.extract (U.unsafeIndex lengths2) + $ U.zip starts1 lengths1 + + in NArray starts2' lengths2' elems +{-# INLINE_ARRAY concats #-} + + +------------------------------------------------------------------------------- +-- | O(len src). Given predicates which detect the start and end of a segment, +-- split an vector into the indicated segments. +segment :: (BulkI l a, U.Unbox a) + => (a -> Bool) -- ^ Detect the start of a segment. + -> (a -> Bool) -- ^ Detect the end of a segment. + -> Array l a -- ^ Vector to segment. + -> Array N (Array l a) + +segment pStart pEnd !elems + = let len = size (extent $ layout elems) + (starts, lens) + = U.findSegments pStart pEnd + $ U.generate len (\ix -> index elems ix) + + in NArray starts lens elems +{-# INLINE_ARRAY segment #-} + + +-- | O(len src). Given a terminating value, split an vector into segments. +-- +-- The result segments do not include the terminator. +-- +-- @ +-- > import Data.Repa.Nice +-- > nice $ segmentOn (== ' ') (fromList U "fresh fried fish ") +-- ["fresh "," "," ","fried ","fish "," "] +-- @ +-- +segmentOn + :: (BulkI l a, Eq a, U.Unbox a) + => (a -> Bool) -- ^ Detect the end of a segment. + -> Array l a -- ^ Vector to segment. + -> Array N (Array l a) + +segmentOn !pEnd !arr + = segment (const True) pEnd arr +{-# INLINE_ARRAY segmentOn #-} + + +------------------------------------------------------------------------------- +-- | O(len src). Like `segment`, but cut the source array twice. +dice :: (BulkI l a, Windowable l a, U.Unbox a) + => (a -> Bool) -- ^ Detect the start of an inner segment. + -> (a -> Bool) -- ^ Detect the end of an inner segment. + -> (a -> Bool) -- ^ Detect the start of an outer segment. + -> (a -> Bool) -- ^ Detect the end of an outer segment. + -> Array l a -- ^ Array to dice. + -> Array N (Array N (Array l a)) + +dice pStart1 pEnd1 pStart2 pEnd2 !arr + = let lenArr = size (extent $ layout arr) + + -- Do the inner segmentation. + (starts1, lens1) = U.findSegments pStart1 pEnd1 + $ U.generate lenArr (index arr) + + -- To do the outer segmentation we want to check if the first + -- and last characters in each of the inner segments match + -- the predicates. + pStart2' arr' + = pStart2 $ index arr' 0 + + pEnd2' arr' + = pEnd2 $ index arr' (size (extent $ layout arr') - 1) + + -- Do the outer segmentation. + !lenArrInner = U.length starts1 + !arrInner = NArray starts1 lens1 arr + (starts2, lens2) = U.findSegmentsFrom pStart2' pEnd2' + lenArrInner (index arrInner) + + in NArray starts2 lens2 arrInner +{-# INLINE_ARRAY dice #-} + + +-- | O(len src). Given field and row terminating values, +-- split an array into rows and fields. +-- +diceSep :: (BulkI l a, Windowable l a, U.Unbox a, Eq a) + => a -- ^ Terminating element for inner segments. + -> a -- ^ Terminating element for outer segments. + -> Array l a -- ^ Vector to dice. + -> Array N (Array N (Array l a)) + +diceSep !xEndCol !xEndRow !arr + = let (startsLensCol, startsLensRow) + = runST + $ G.unstreamToVector2 + $ S.diceSepS (== xEndCol) (== xEndRow) + $ S.liftStream + $ streamOfArray arr + + (startsCol, endsCol) = U.unzip startsLensCol + (startsRow, endsRow) = U.unzip startsLensRow + + in NArray startsRow endsRow $ NArray startsCol endsCol arr +{-# INLINE_ARRAY diceSep #-} + + +------------------------------------------------------------------------------- +-- | For each segment of a nested vector, trim elements off the start +-- and end of the segment that match the given predicate. +trims :: BulkI l a + => (a -> Bool) + -> Array N (Array l a) + -> Array N (Array l a) + +trims pTrim (NArray starts lengths elems) + = let + loop_trimEnds !start !len + | len == 0 = (start, len) + | pTrim (elems `index` (start + len - 1)) + = loop_trimEnds start (len - 1) + | otherwise = loop_trimStarts start len + {-# INLINE_INNER loop_trimEnds #-} + + loop_trimStarts !start !len + | len == 0 = (start, len) + | pTrim (elems `index` (start + len - 1)) + = loop_trimStarts (start + 1) (len - 1) + | otherwise = (start, len) + {-# INLINE_INNER loop_trimStarts #-} + + (starts', lengths') + = U.unzip $ U.zipWith loop_trimEnds starts lengths + + in NArray starts' lengths' elems +{-# INLINE_ARRAY trims #-} + + +-- | For each segment of a nested vector, trim elements off the end of +-- the segment that match the given predicate. +trimEnds :: BulkI l a + => (a -> Bool) + -> Array N (Array l a) + -> Array N (Array l a) + +trimEnds pTrim (NArray starts lengths elems) + = let + loop_trimEnds !start !len + | len == 0 = 0 + | pTrim (elems `index` (start + len - 1)) + = loop_trimEnds start (len - 1) + | otherwise = len + {-# INLINE_INNER loop_trimEnds #-} + + lengths' = U.zipWith loop_trimEnds starts lengths + + in NArray starts lengths' elems +{-# INLINE_ARRAY trimEnds #-} + + +-- | For each segment of a nested vector, trim elements off the start of +-- the segment that match the given predicate. +trimStarts :: BulkI l a + => (a -> Bool) + -> Array N (Array l a) + -> Array N (Array l a) + +trimStarts pTrim (NArray starts lengths elems) + = let + loop_trimStarts !start !len + | len == 0 = (start, len) + | pTrim (elems `index` (start + len - 1)) + = loop_trimStarts (start + 1) (len - 1) + | otherwise = (start, len) + {-# INLINE_INNER loop_trimStarts #-} + + (starts', lengths') + = U.unzip $ U.zipWith loop_trimStarts starts lengths + + in NArray starts' lengths' elems +{-# INLINE_ARRAY trimStarts #-} + + +------------------------------------------------------------------------------- +-- | Ragged transpose of a triply nested array. +-- +-- * This operation is performed entirely on the segment descriptors +-- of the nested arrays, and does not require the inner array elements +-- to be copied. +-- +ragspose3 :: Array N (Array N (Array l a)) + -> Array N (Array N (Array l a)) + +ragspose3 (NArray starts1 lengths1 (NArray starts2 lengths2 elems)) + = let + startStops1 = U.zipWith (\s l -> (s, s + l)) starts1 lengths1 + (ixs', lengths1') = U.ratchet startStops1 + + starts2' = U.map (U.unsafeIndex starts2) ixs' + lengths2' = U.map (U.unsafeIndex lengths2) ixs' + + starts1' = U.unsafeInit $ U.scanl (+) 0 lengths1' + + in NArray starts1' lengths1' (NArray starts2' lengths2' elems) +{-# INLINE_ARRAY ragspose3 #-} +-- NOINLINE Because the operation is entirely on the segment descriptor. +-- This function won't fuse with anything externally, +-- and it does not need to be specialiased. + diff --git a/Data/Repa/Array/Material/Unboxed.hs b/Data/Repa/Array/Material/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Unboxed.hs @@ -0,0 +1,176 @@ + +module Data.Repa.Array.Material.Unboxed + ( U (..) + , Name (..) + , Array (..) + , Buffer (..) + , U.Unbox + + -- * Conversions + , fromUnboxed, toUnboxed) +where +import Data.Repa.Array.Window +import Data.Repa.Array.Delayed +import Data.Repa.Array.Index +import Data.Repa.Array.Internals.Bulk +import Data.Repa.Array.Internals.Target +import Data.Repa.Fusion.Unpack +import Control.Monad +import Data.Word +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as UM +#include "repa-array.h" + + +-- | Layout an array as a flat vector of unboxed elements. +-- +-- This is the most efficient representation for numerical data. +-- +-- The implementation uses @Data.Vector.Unboxed@ which picks an efficient, +-- specialised representation for every element type. In particular, +-- unboxed vectors of pairs are represented as pairs of unboxed vectors. +-- +-- UNSAFE: Indexing into raw material arrays is not bounds checked. +-- You may want to wrap this with a Checked layout as well. +-- +data U = Unboxed { unboxedLength :: !Int } + deriving (Show, Eq) + +------------------------------------------------------------------------------- +-- | Unboxed arrays. +instance Layout U where + data Name U = U + type Index U = Int + name = U + create U len = Unboxed len + extent (Unboxed len) = len + toIndex _ ix = ix + fromIndex _ ix = ix + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance Eq (Name U) +deriving instance Show (Name U) + + +------------------------------------------------------------------------------- +-- | Unboxed arrays. +instance U.Unbox a => Bulk U a where + data Array U a = UArray !(U.Vector a) + layout (UArray vec) = Unboxed (U.length vec) + index (UArray vec) ix = U.unsafeIndex vec ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + {-# SPECIALIZE instance Bulk U () #-} + {-# SPECIALIZE instance Bulk U Bool #-} + {-# SPECIALIZE instance Bulk U Char #-} + {-# SPECIALIZE instance Bulk U Int #-} + {-# SPECIALIZE instance Bulk U Float #-} + {-# SPECIALIZE instance Bulk U Double #-} + {-# SPECIALIZE instance Bulk U Word8 #-} + {-# SPECIALIZE instance Bulk U Word16 #-} + {-# SPECIALIZE instance Bulk U Word32 #-} + {-# SPECIALIZE instance Bulk U Word64 #-} + +deriving instance (Show a, U.Unbox a) => Show (Array U a) + + +instance Unpack (Array U a) (U.Vector a) where + unpack (UArray vec) = vec + repack !_ !vec = UArray vec + {-# INLINE_ARRAY unpack #-} + {-# INLINE_ARRAY repack #-} + + +------------------------------------------------------------------------------- +-- | Windowing Unboxed arrays. +instance U.Unbox a => Windowable U a where + window st len (UArray vec) + = UArray (U.slice st len vec) + {-# INLINE_ARRAY window #-} + {-# SPECIALIZE instance Windowable U Int #-} + {-# SPECIALIZE instance Windowable U Float #-} + {-# SPECIALIZE instance Windowable U Double #-} + {-# SPECIALIZE instance Windowable U Word8 #-} + {-# SPECIALIZE instance Windowable U Word16 #-} + {-# SPECIALIZE instance Windowable U Word32 #-} + {-# SPECIALIZE instance Windowable U Word64 #-} + + +------------------------------------------------------------------------------- +-- | Unboxed buffers. +instance U.Unbox a => Target U a where + data Buffer s U a + = UBuffer !(UM.MVector s a) + + unsafeNewBuffer (Unboxed len) + = liftM UBuffer (UM.unsafeNew len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (UBuffer mvec) ix + = UM.unsafeRead mvec ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (UBuffer mvec) ix + = UM.unsafeWrite mvec ix + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (UBuffer mvec) bump + = do mvec' <- UM.unsafeGrow mvec bump + return $ UBuffer mvec' + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (UBuffer mvec) + = do vec <- U.unsafeFreeze mvec + return $ UArray vec + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (UArray mvec) + = liftM UBuffer (U.unsafeThaw mvec) + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (UBuffer mvec) + = do let mvec' = UM.unsafeSlice st len mvec + return $ UBuffer mvec' + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer _ + = return () + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (UBuffer mvec) + = Unboxed (UM.length mvec) + + {-# SPECIALIZE instance Target U Int #-} + {-# SPECIALIZE instance Target U Float #-} + {-# SPECIALIZE instance Target U Double #-} + {-# SPECIALIZE instance Target U Word8 #-} + {-# SPECIALIZE instance Target U Word16 #-} + {-# SPECIALIZE instance Target U Word32 #-} + {-# SPECIALIZE instance Target U Word64 #-} + + +instance Unpack (Buffer s U a) (UM.MVector s a) where + unpack (UBuffer vec) = vec `seq` vec + repack !_ !vec = UBuffer vec + {-# INLINE_ARRAY unpack #-} + {-# INLINE_ARRAY repack #-} + + +------------------------------------------------------------------------------- +-- | O(1). Wrap an unboxed vector as an array. +fromUnboxed :: U.Unbox a + => U.Vector a -> Array U a +fromUnboxed vec = UArray vec +{-# INLINE_ARRAY fromUnboxed #-} + + +-- | O(1). Unwrap an unboxed vector from an array. +toUnboxed :: U.Unbox a + => Array U a -> U.Vector a +toUnboxed (UArray vec) = vec +{-# INLINE_ARRAY toUnboxed #-} + diff --git a/Data/Repa/Array/RowWise.hs b/Data/Repa/Array/RowWise.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/RowWise.hs @@ -0,0 +1,189 @@ + +module Data.Repa.Array.RowWise + ( RW (..) + , Name (..) + , Array (..) + , rowWise + + -- | Synonyms for common layouts. + , DIM1, DIM2, DIM3, DIM4, DIM5 + + -- | Helpers that contrain the coordinates to be @Ints@. + , ix1, ix2, ix3, ix4, ix5) +where +import Data.Repa.Array.Internals.Shape +import Data.Repa.Array.Internals.Layout +import Data.Repa.Array.Internals.Bulk +import Control.Monad +import GHC.Base (quotInt, remInt) +#include "repa-array.h" + + +-- | A row-wise layout that maps higher rank indices to linear ones in a +-- row-major order. +-- +-- Indices are ordered so the inner-most coordinate varies most frequently: +-- +-- @> Prelude.map (fromIndex (RowWise (ish2 2 3))) [0..5] +-- [(Z :. 0) :. 0, (Z :. 0) :. 1, (Z :. 0) :. 2, +-- (Z :. 1) :. 0, (Z :. 1) :. 1, (Z :. 1) :. 2]@ +-- +-- * Indexing is not bounds checked. Indexing outside the extent +-- yields the corresponding index. +-- +data RW sh + = RowWise + { rowWiseShape :: !sh } + +deriving instance Eq sh => Eq (RW sh) +deriving instance Show sh => Show (RW sh) + + +------------------------------------------------------------------------------- +instance Shape sh + => Shape (RW sh) where + + rank (RowWise sh) + = rank sh + {-# INLINE rank #-} + + zeroDim = RowWise zeroDim + {-# INLINE zeroDim #-} + + unitDim = RowWise unitDim + {-# INLINE unitDim #-} + + intersectDim (RowWise sh1) (RowWise sh2) + = RowWise (intersectDim sh1 sh2) + {-# INLINE intersectDim #-} + + addDim (RowWise sh1) (RowWise sh2) + = RowWise (addDim sh1 sh2) + {-# INLINE addDim #-} + + size (RowWise sh) + = size sh + {-# INLINE size #-} + + inShapeRange (RowWise sh1) (RowWise sh2) (RowWise sh3) + = inShapeRange sh1 sh2 sh3 + {-# INLINE inShapeRange #-} + + listOfShape (RowWise sh) + = listOfShape sh + {-# INLINE listOfShape #-} + + shapeOfList xx + = liftM RowWise $ shapeOfList xx + {-# INLINE shapeOfList #-} + + +------------------------------------------------------------------------------- +instance Layout (RW Z) where + data Name (RW Z) = RZ + type Index (RW Z) = Z + name = RZ + create RZ Z = RowWise Z + extent _ = Z + toIndex _ _ = 0 + fromIndex _ _ = Z + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance Eq (Name (RW Z)) +deriving instance Show (Name (RW Z)) + + +------------------------------------------------------------------------------- +instance ( Layout (RW sh) + , Index (RW sh) ~ sh) + => Layout (RW (sh :. Int)) where + + data Name (RW (sh :. Int)) = RC (Name (RW sh)) + type Index (RW (sh :. Int)) = sh :. Int + + name = RC name + + create (RC nSh) (sh :. i) + = let RowWise iSh = create nSh sh + in RowWise (iSh :. i) + + extent (RowWise sh) = sh + + toIndex (RowWise (sh1 :. sh2)) (sh1' :. sh2') + = toIndex (RowWise sh1) sh1' * sh2 + sh2' + + fromIndex (RowWise (ds :. d)) n + = fromIndex (RowWise ds) (n `quotInt` d) :. r + -- If we assume that the index is in range, there is no point + -- in computing the remainder for the highest dimension since + -- n < d must hold. This saves one remInt per element access + -- which is quite a big deal. + where r | rank ds == 0 = n + | otherwise = n `remInt` d + + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY fromIndex #-} + +deriving instance Eq (Name (RW sh)) => Eq (Name (RW (sh :. Int))) +deriving instance Show (Name (RW sh)) => Show (Name (RW (sh :. Int))) + + +------------------------------------------------------------------------------- +-- | Row-wise arrays. +instance (Layout (RW sh), Index (RW sh) ~ sh) + => Bulk (RW sh) sh where + data Array (RW sh) sh = RArray sh + layout (RArray sh) = RowWise sh + index (RArray _) ix = ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + + +-- | Construct a rowWise array that produces the corresponding index +-- for every element. +-- +-- @> toList $ rowWise (ish2 3 2) +-- [(Z :. 0) :. 0, (Z :. 0) :. 1, +-- (Z :. 1) :. 0, (Z :. 1) :. 1, +-- (Z :. 2) :. 0, (Z :. 2) :. 1]@ +-- +rowWise :: sh -> Array (RW sh) sh +rowWise sh = RArray sh +{-# INLINE_ARRAY rowWise #-} + + +------------------------------------------------------------------------------- +type DIM1 = RW SH1 +type DIM2 = RW SH2 +type DIM3 = RW SH3 +type DIM4 = RW SH4 +type DIM5 = RW SH5 + + +ix1 :: Int -> DIM1 +ix1 x = RowWise (Z :. x) +{-# INLINE ix1 #-} + +ix2 :: Int -> Int -> DIM2 +ix2 y x = RowWise (Z :. y :. x) +{-# INLINE ix2 #-} + +ix3 :: Int -> Int -> Int -> DIM3 +ix3 z y x = RowWise (Z :. z :. y :. x) +{-# INLINE ix3 #-} + +ix4 :: Int -> Int -> Int -> Int -> DIM4 +ix4 a z y x = RowWise (Z :. a :. z :. y :. x) +{-# INLINE ix4 #-} + +ix5 :: Int -> Int -> Int -> Int -> Int -> DIM5 +ix5 b a z y x = RowWise (Z :. b :. a :. z :. y :. x) +{-# INLINE ix5 #-} + diff --git a/Data/Repa/Array/Tuple.hs b/Data/Repa/Array/Tuple.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Tuple.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Tuple + ( T2 (..) + , Name (..) + , Array (..) + , Buffer (..) + , tup2, untup2) +where +import Data.Repa.Array.Window +import Data.Repa.Array.Index +import Data.Repa.Array.Internals.Bulk +import Data.Repa.Array.Internals.Target +import Data.Repa.Fusion.Unpack +import Control.Monad +import Prelude hiding (zip, unzip) +#include "repa-array.h" + + +-- | Tupled arrays where the components are unpacked and can have +-- separate representations. +data T2 l1 l2 + = Tup2 !l1 !l2 + + +deriving instance (Eq l1, Eq l2) => Eq (T2 l1 l2) +deriving instance (Show l1, Show l2) => Show (T2 l1 l2) + + +------------------------------------------------------------------------------- +instance ( Index l1 ~ Index l2 + , Layout l1, Layout l2) + => Layout (T2 l1 l2) where + + data Name (T2 l1 l2) = T2 !(Name l1) !(Name l2) + type Index (T2 l1 l2) = Index l1 + name = T2 name name + create (T2 n1 n2) ix = Tup2 (create n1 ix) (create n2 ix) + extent (Tup2 l1 l2) = intersectDim (extent l1) (extent l2) + toIndex (Tup2 l1 _l2) ix = toIndex l1 ix + fromIndex (Tup2 l1 _l2) ix = fromIndex l1 ix + -- TODO: using just l1 will be wrong for load functions if + -- the two layouts have different extents. + {-# INLINE name #-} + {-# INLINE create #-} + {-# INLINE extent #-} + {-# INLINE toIndex #-} + {-# INLINE fromIndex #-} + + +deriving instance + (Eq (Name l1), Eq (Name l2)) + => Eq (Name (T2 l1 l2)) + +deriving instance + (Show (Name l1), Show (Name l2)) + => Show (Name (T2 l1 l2)) + + +------------------------------------------------------------------------------- +-- | Tupled arrays. +instance (Bulk l1 a, Bulk l2 b, Index l1 ~ Index l2) + => Bulk (T2 l1 l2) (a, b) where + + data Array (T2 l1 l2) (a, b) + = T2Array !(Array l1 a) !(Array l2 b) + + layout (T2Array arr1 arr2) = Tup2 (layout arr1) (layout arr2) + index (T2Array arr1 arr2) ix = (index arr1 ix, index arr2 ix) + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + + +deriving instance + (Show (Array l1 a), Show (Array l2 b)) + => Show (Array (T2 l1 l2) (a, b)) + + +------------------------------------------------------------------------------- +-- | Tupled windows. +instance (Windowable l1 a, Windowable l2 b, Index l1 ~ Index l2) + => Windowable (T2 l1 l2) (a, b) where + window st sz (T2Array arr1 arr2) + = T2Array (window st sz arr1) (window st sz arr2) + {-# INLINE_ARRAY window #-} + + +------------------------------------------------------------------------------- +-- | Tupled buffers. +instance ( Target l1 a, Target l2 b + , Index l1 ~ Index l2) + => Target (T2 l1 l2) (a, b) where + + data Buffer s (T2 l1 l2) (a, b) + = T2Buffer !(Buffer s l1 a) !(Buffer s l2 b) + + unsafeNewBuffer (Tup2 l1 l2) + = liftM2 T2Buffer (unsafeNewBuffer l1) (unsafeNewBuffer l2) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (T2Buffer buf1 buf2) ix + = do a <- unsafeReadBuffer buf1 ix + b <- unsafeReadBuffer buf2 ix + return (a,b) + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (T2Buffer buf1 buf2) ix (x1, x2) + = do unsafeWriteBuffer buf1 ix x1 + unsafeWriteBuffer buf2 ix x2 + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (T2Buffer buf1 buf2) bump + = do buf1' <- unsafeGrowBuffer buf1 bump + buf2' <- unsafeGrowBuffer buf2 bump + return $ T2Buffer buf1' buf2' + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (T2Buffer buf1 buf2) + = do arr1 <- unsafeFreezeBuffer buf1 + arr2 <- unsafeFreezeBuffer buf2 + return $ T2Array arr1 arr2 + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (T2Array arr1 arr2) + = do buf1 <- unsafeThawBuffer arr1 + buf2 <- unsafeThawBuffer arr2 + return $ T2Buffer buf1 buf2 + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer start len (T2Buffer buf1 buf2) + = do buf1' <- unsafeSliceBuffer start len buf1 + buf2' <- unsafeSliceBuffer start len buf2 + return $ T2Buffer buf1' buf2' + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (T2Buffer buf1 buf2) + = do touchBuffer buf1 + touchBuffer buf2 + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (T2Buffer buf1 buf2) + = Tup2 (bufferLayout buf1) (bufferLayout buf2) + +instance (Unpack (Buffer s r1 a) t1, Unpack (Buffer s r2 b) t2) + => Unpack (Buffer s (T2 r1 r2) (a, b)) (t1, t2) where + unpack (T2Buffer buf1 buf2) + = buf1 `seq` buf2 `seq` (unpack buf1, unpack buf2) + {-# INLINE_ARRAY unpack #-} + + repack !(T2Buffer x1 x2) (buf1, buf2) + = buf1 `seq` buf2 `seq` (T2Buffer (repack x1 buf1) (repack x2 buf2)) + {-# INLINE_ARRAY repack #-} + + +------------------------------------------------------------------------------- +-- | Tuple two arrays into an array of pairs. +-- +-- The two argument arrays must have the same index type, but can have +-- different extents. The extent of the result is the intersection +-- of the extents of the two argument arrays. +-- +tup2 :: (Bulk l1 a, Bulk l2 b, Index l1 ~ Index l2) + => Array l1 a -> Array l2 b + -> Array (T2 l1 l2) (a, b) +tup2 arr1 arr2 + = T2Array arr1 arr2 +{-# INLINE_ARRAY tup2 #-} + + +-- | Untuple an array of tuples in to a tuple of arrays. +-- +-- * The two returned components may have different extents, though they are +-- guaranteed to be at least as big as the argument array. This is the +-- key property that makes `untup2` different from `unzip`. +-- +untup2 :: Array (T2 l1 l2) (a, b) + -> (Array l1 a, Array l2 b) + +untup2 (T2Array arr1 arr2) + = (arr1, arr2) +{-# INLINE_ARRAY untup2 #-} + + diff --git a/Data/Repa/Array/Window.hs b/Data/Repa/Array/Window.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Window.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Window + ( W (..) + , Array (..) + , Windowable (..) + , windowed + , entire) +where +import Data.Repa.Array.Index +import Data.Repa.Array.Internals.Bulk +#include "repa-array.h" + + +-- Windows -------------------------------------------------------------------- +data W l + = Window + { windowStart :: Index l + , windowSize :: Index l + , windowInner :: l } + +deriving instance (Show l, Show (Index l)) => Show (W l) +deriving instance (Eq l, Eq (Index l)) => Eq (W l) + + +------------------------------------------------------------------------------- +-- | Windowed arrays. +instance Layout l => Layout (W l) where + data Name (W l) = W (Name l) + type Index (W l) = Index l + + name = W name + + create (W n) len + = let inner = create n len + in Window zeroDim (extent inner) inner + + extent (Window _ sz _) + = sz + + toIndex (Window _st _sz inner) ix + = toIndex inner ix -- TODO: wrong, use offsets + + fromIndex (Window _st _sz inner) ix -- TODO: wrong, use offsets + = fromIndex inner ix + + {-# INLINE_ARRAY name #-} + {-# INLINE_ARRAY create #-} + {-# INLINE_ARRAY toIndex #-} + {-# INLINE_ARRAY extent #-} + {-# INLINE_ARRAY fromIndex #-} + + +deriving instance Eq (Name l) => Eq (Name (W l)) +deriving instance Show (Name l) => Show (Name (W l)) + + +------------------------------------------------------------------------------- +-- | Windowed arrays. +instance Bulk l a => Bulk (W l) a where + data Array (W l) a = WArray !(Index l) !(Index l) !(Array l a) + layout (WArray st sz inner) = Window st sz (layout inner) + index (WArray st _ inner) ix = index inner (addDim st ix) + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + + +-- | Wrap a window around an exiting array. +windowed :: Index l -> Index l -> Array l a -> Array (W l) a +windowed start shape arr + = WArray start shape arr +{-# INLINE_ARRAY windowed #-} + + +-- | Wrap a window around an existing array that encompases the entire array. +entire :: Bulk l a => Array l a -> Array (W l) a +entire arr + = WArray zeroDim (extent $ layout arr) arr +{-# INLINE_ARRAY entire #-} + + +------------------------------------------------------------------------------- +-- | Class of array representations that can be windowed directly. +-- +-- The underlying representation can encode the window, +-- without needing to add a wrapper to the existing layout. +-- +class Bulk l a => Windowable l a where + window :: Index l -> Index l -> Array l a -> Array l a + +-- | Windows are windowable. +instance Bulk l a => Windowable (W l) a where + window start _shape (WArray wStart wShape arr) + = WArray (addDim wStart start) wShape arr + {-# INLINE_ARRAY window #-} + + diff --git a/Data/Repa/Bits/Date32.hs b/Data/Repa/Bits/Date32.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Bits/Date32.hs @@ -0,0 +1,142 @@ + +module Data.Repa.Bits.Date32 + ( Date32 + , pack, unpack + , next + , range + , readYYYYsMMsDD) +where +import Data.Repa.Array.Material.Foreign as A +import Data.Repa.Array.Material.Unboxed as A +import Data.Repa.Array as A +import Data.Repa.Eval.Array as A +import Data.Word +import Data.Bits +import GHC.Exts +import GHC.Word +import Prelude as P + + +-- | A date packed into a 32-bit word. +-- +-- The bitwise format is: +-- +-- @ +-- 32 16 8 0 +-- | year | month | day | +-- @ +-- +-- Pros: Packing and unpacking a Date32 is simpler than using other formats +-- that represent dates as a number of days from some epoch. We can also +-- avoid worrying about what the epoch should be, and the representation +-- will not overflow until year 65536. +-- +-- Cons: Computing a range of dates is slower than with representations +-- using an epoch, as we cannot simply add one to get to the next valid date. +-- +type Date32 + = Word32 + + +-- | Pack a year, month and day into a `Word32`. +-- +-- If any components of the date are out-of-range then they will be bit-wise +-- truncated so they fit in their destination fields. +-- +pack :: (Word, Word, Word) -> Date32 +pack (yy, mm, dd) + = ((fromIntegral yy .&. 0x0ffff) `shiftL` 16) + .|. ((fromIntegral mm .&. 0x0ff) `shiftL` 8) + .|. (fromIntegral dd .&. 0x0ff) +{-# INLINE pack #-} + + +-- | Inverse of `pack`. +-- +-- This function does a simple bit-wise unpacking of the given `Word32`, +-- and does not guarantee that the returned fields are within a valid +-- range for the given calendar date. +-- +unpack :: Date32 -> (Word, Word, Word) +unpack date + = ( fromIntegral $ (date `shiftR` 16) .&. 0x0ffff + , fromIntegral $ (date `shiftR` 8) .&. 0x0ff + , fromIntegral $ date .&. 0x0ff) +{-# INLINE unpack #-} + + +-- | Yield the next date in the series. +-- +-- This assumes leap years occur every four years, +-- which is valid after year 1900 and before year 2100. +-- +next :: Date32 -> Date32 +next (W32# date) + = W32# (next' date) +{-# INLINE next #-} + +next' :: Word# -> Word# +next' !date + | (yy, mm, dd) <- unpack (W32# date) + , (yy', mm', dd') + <- case mm of + 1 -> if dd >= 31 then (yy, 2, 1) else (yy, mm, dd + 1) -- Jan + + 2 -> if yy `mod` 4 == 0 -- Feb + then if dd >= 29 + then (yy, 3, 1) + else (yy, mm, dd + 1) + else if dd >= 28 + then (yy, 3, 1) + else (yy, mm, dd + 1) + + 3 -> if dd >= 31 then (yy, 4, 1) else (yy, mm, dd + 1) -- Mar + 4 -> if dd >= 30 then (yy, 5, 1) else (yy, mm, dd + 1) -- Apr + 5 -> if dd >= 31 then (yy, 6, 1) else (yy, mm, dd + 1) -- May + 6 -> if dd >= 30 then (yy, 7, 1) else (yy, mm, dd + 1) -- Jun + 7 -> if dd >= 31 then (yy, 8, 1) else (yy, mm, dd + 1) -- Jul + 8 -> if dd >= 31 then (yy, 9, 1) else (yy, mm, dd + 1) -- Aug + 9 -> if dd >= 30 then (yy, 10, 1) else (yy, mm, dd + 1) -- Sep + 10 -> if dd >= 31 then (yy, 11, 1) else (yy, mm, dd + 1) -- Oct + 11 -> if dd >= 30 then (yy, 12, 1) else (yy, mm, dd + 1) -- Nov + 12 -> if dd >= 31 then (yy + 1, 1, 1) else (yy, mm, dd + 1) -- Dec + _ -> (0, 0, 0) + = case pack (yy', mm', dd') of + W32# w -> w +{-# NOINLINE next' #-} + + +-- | Yield an array containing a range of dates, inclusive of the end points. +--- +-- TODO: avoid going via lists. +-- +range :: TargetI l Date32 + => Name l -> Date32 -> Date32 -> Array l Date32 + +range n from to + | to < from = A.fromList n [] + | otherwise = A.fromList n $ go [] from + where + go !acc !d + | d > to = P.reverse acc + | otherwise = go (d : acc) (next d) +{-# NOINLINE range #-} + + +-- | Read a `Date32` in ASCII YYYYsMMsDD format, using the given separator +-- character 's'. +--- +-- TODO: avoid going via lists. +-- +readYYYYsMMsDD + :: BulkI l Char + => Char -> Array l Char -> Maybe Date32 + +readYYYYsMMsDD sep arr + = case words + $ A.toList + $ A.mapS U (\c -> if c == sep then ' ' else c) arr of + [yy, mm, dd] -> Just $ pack (read yy, read mm, read dd) + _ -> Nothing +{-# INLINE readYYYYsMMsDD #-} + diff --git a/Data/Repa/Eval/Array.hs b/Data/Repa/Eval/Array.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Eval/Array.hs @@ -0,0 +1,54 @@ + +module Data.Repa.Eval.Array + ( -- * Array Targets + Target (..), TargetI + , IOBuffer + + -- * Array Loading + , Load (..) + + , computeS + , computeIntoS) +where +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Load as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Index as A +import System.IO.Unsafe +#include "repa-array.h" + + +-- | Sequential computation of delayed array elements. +-- +-- Elements of the source array are computed sequentially and +-- written to a new array of the specified layout. +-- +computeS :: (Load lSrc lDst a, Index lSrc ~ Index lDst) + => Name lDst -> Array lSrc a -> Array lDst a +computeS !nDst !aSrc + = let !lDst = create nDst (extent $ layout aSrc) + Just aDst = computeIntoS lDst aSrc + in aDst `seq` aDst +{-# INLINE computeS #-} + + +-- | Like `computeS` but use the provided desination layout. +-- +-- The size of the destination layout must match the size of the source +-- array, else `Nothing`. +-- +computeIntoS :: Load lSrc lDst a + => lDst -> Array lSrc a -> Maybe (Array lDst a) +computeIntoS !lDst !aSrc + | (A.size $ A.extent lDst) == A.length aSrc + = unsafePerformIO + $ do !buf <- unsafeNewBuffer lDst + loadS aSrc buf + !arr <- unsafeFreezeBuffer buf + return $ Just arr + + | otherwise + = Nothing +{-# INLINE_ARRAY computeIntoS #-} + + diff --git a/Data/Repa/Eval/Chain.hs b/Data/Repa/Eval/Chain.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Eval/Chain.hs @@ -0,0 +1,167 @@ + +-- | Interface with chain fusion. +module Data.Repa.Eval.Chain + ( chainOfArray + , unchainToArray + , unchainToArrayIO) +where +import Data.Repa.Fusion.Unpack +import Data.Repa.Chain (Chain(..), Step(..)) +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Index as A +import qualified Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Fusion.Stream.Size as S +import qualified Data.Vector.Fusion.Util as S +import System.IO.Unsafe +#include "repa-array.h" + + +------------------------------------------------------------------------------- +-- | Produce a `Chain` for the elements of the given array. +-- The order in which the elements appear in the chain is +-- determined by the layout of the array. +chainOfArray + :: (Monad m, Bulk l a) + => Array l a -> Chain m Int a + +chainOfArray !arr + = Chain (S.Exact len) 0 step + where + !len = A.length arr + + step !i + | i >= len = return $ Done i + | otherwise + = return $ Yield (A.index arr $ A.fromIndex (A.layout arr) i) (i + 1) + {-# INLINE_INNER step #-} +{-# INLINE_STREAM chainOfArray #-} + + +-- | Lift a pure chain to a monadic chain. +liftChain :: Monad m => Chain S.Id s a -> Chain m s a +liftChain (Chain sz s step) + = Chain sz s (return . S.unId . step) +{-# INLINE_STREAM liftChain #-} + + +------------------------------------------------------------------------------- +-- | Compute the elements of a pure `Chain`, +-- writing them into a new array `Array`. +unchainToArray + :: (Target l a, Unpack (IOBuffer l a) t) + => Name l -> Chain S.Id s a -> (Array l a, s) +unchainToArray nDst c + = unsafePerformIO + $ unchainToArrayIO nDst + $ liftChain c +{-# INLINE_STREAM unchainToArray #-} + + +-- | Compute the elements of an `IO` `Chain`, +-- writing them to a new `Array`. +unchainToArrayIO + :: (Target l a, Unpack (IOBuffer l a) t) + => Name l -> Chain IO s a -> IO (Array l a, s) + +unchainToArrayIO nDst (Chain sz s0 step) + = case sz of + S.Exact i -> unchainToArrayIO_max i + S.Max i -> unchainToArrayIO_max i + S.Unknown -> unchainToArrayIO_unknown 32 + + -- unchain when we known the maximum size of the vector. + where unchainToArrayIO_max !nMax + = do !vec0 <- unsafeNewBuffer (create nDst zeroDim) + !vec <- unsafeGrowBuffer vec0 nMax + + let go_unchainIO_max !sPEC !i !s + = step s >>= \m + -> case m of + Yield e s' + -> do unsafeWriteBuffer vec i e + go_unchainIO_max sPEC (i + 1) s' + + Skip s' + -> go_unchainIO_max sPEC i s' + + Done s' + -> do buf' <- unsafeSliceBuffer 0 i vec + arr <- unsafeFreezeBuffer buf' + return (arr, s') + {-# INLINE_INNER go_unchainIO_max #-} + + go_unchainIO_max S.SPEC 0 s0 + {-# INLINE_INNER unchainToArrayIO_max #-} + + -- unchain when we don't know the maximum size of the vector. + unchainToArrayIO_unknown !nStart + = do !vec0 <- unsafeNewBuffer (create nDst zeroDim) + !vec1 <- unsafeGrowBuffer vec0 nStart + + let go_unchainIO_unknown !sPEC !uvec !i !n !s + = go_unchainIO_unknown1 (repack vec0 uvec) i n s + (\vec' i' n' s' -> go_unchainIO_unknown sPEC (unpack vec') i' n' s') + (\result -> return result) + + go_unchainIO_unknown1 !vec !i !n !s cont done + = step s >>= \r + -> case r of + Yield e s' + -> do (vec', n') + <- if i >= n + then do vec' <- unsafeGrowBuffer vec n + return (vec', n + n) + else return (vec, n) + unsafeWriteBuffer vec' i e + cont vec' (i + 1) n' s' + + Skip s' + -> cont vec i n s' + + Done s' + -> do + vec' <- unsafeSliceBuffer 0 i vec + arr <- unsafeFreezeBuffer vec' + done (arr, s') + + go_unchainIO_unknown S.SPEC (unpack vec1) 0 nStart s0 + {-# INLINE_INNER unchainToArrayIO_unknown #-} +{-# INLINE_STREAM unchainToArrayIO #-} + + + +{- + -- This consuming function has been desugared so that the recursion + -- is via RealWorld, rather than using a function of type IO. + -- If the recursion is at IO then GHC tries to coerce to and from + -- IO at every recursive call, which messes up SpecConstr. + let go_unchainIO_unknown + :: Unpack (Buffer r a) t + => S.SPEC -> t -> Int -> Int -> s + -> State# RealWorld -> (# State# RealWorld, (Array r DIM1 a, s) #) + + go_unchainIO_unknown !sPEC !uvec !i !n !s !w0 + = case unIO (step s) w0 of + (# w1, Yield e s' #) + | (# w2, (uvec', i', n') #) + <- unIO (do (vec', n') + <- if i >= n + then do vec' <- unsafeGrowBuffer (repack vec0 uvec) n + return (vec', n + n) + else return (repack vec0 uvec, n) + unsafeWriteBuffer vec' i e + return (unpack vec', i + 1, n')) + w1 + -> (go_unchainIO_unknown sPEC uvec' i' n' s') w2 + + (# w1, Skip s' #) + -> (go_unchainIO_unknown sPEC uvec i n s') w1 + + (# w1, Done s' #) + -> (unIO $ do + vec' <- unsafeSliceBuffer 0 i (repack vec0 uvec) + arr <- unsafeFreezeBuffer (Z :. i) vec' + return (arr, s')) w1 + {-# INLINE go_unchainIO_unknown #-} +-} diff --git a/Data/Repa/Eval/Stream.hs b/Data/Repa/Eval/Stream.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Eval/Stream.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +-- | Interface with stream fusion. +module Data.Repa.Eval.Stream + (streamOfArray) +where +import Data.Repa.Array.Index as A +import Data.Repa.Array.Internals.Bulk as A +import qualified Data.Vector.Fusion.Stream.Monadic as S +#include "repa-array.h" + + +-- | Produce a `Stream` for the elements of the given array. +streamOfArray + :: (Monad m, Bulk l a, Index l ~ Int) + => A.Array l a + -> S.Stream m a + +streamOfArray vec + = S.generate (A.length vec) + (\i -> A.index vec i) +{-# INLINE_STREAM streamOfArray #-} diff --git a/Data/Repa/Fusion/Unpack.hs b/Data/Repa/Fusion/Unpack.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Fusion/Unpack.hs @@ -0,0 +1,15 @@ + +module Data.Repa.Fusion.Unpack + (Unpack (..)) +where + + +-- | Unpack the pieces of a structure into a tuple. +-- +-- This is used in a low-level fusion optimisation to ensure that +-- intermediate values are unboxed. +-- +class Unpack a t | a -> t where + unpack :: a -> t + repack :: a -> t -> a + diff --git a/Data/Repa/IO/Array.hs b/Data/Repa/IO/Array.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/IO/Array.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE ViewPatterns #-} + +module Data.Repa.IO.Array + ( hGetArray, hGetArrayPre + , hPutArray + , hGetArrayFromCSV + , hPutArrayAsCSV) +where +import Data.Repa.Fusion.Unpack +import Data.Repa.Array.Material.Foreign +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Material.Nested as A +import Data.Repa.Array as A +import qualified Foreign.Ptr as F +import qualified Foreign.ForeignPtr as F +import qualified Foreign.Marshal.Alloc as F +import qualified Foreign.Marshal.Utils as F +import System.IO +import Data.Word +import Data.Char + + +-- | Get data from a file, up to the given number of bytes. +-- +-- * Data is read into foreign memory without copying it through the GHC heap. +-- +hGetArray :: Handle -> Int -> IO (Array F Word8) +hGetArray h len + = do + buf :: F.Ptr Word8 <- F.mallocBytes len + bytesRead <- hGetBuf h buf len + fptr <- F.newForeignPtr F.finalizerFree buf + return $ fromForeignPtr bytesRead fptr +{-# NOINLINE hGetArray #-} + + +-- | Get data from a file, up to the given number of bytes, also +-- copying the given data to the front of the new buffer. +-- +-- * Data is read into foreign memory without copying it through the GHC heap. +-- +hGetArrayPre :: Handle -> Int -> Array F Word8 -> IO (Array F Word8) +hGetArrayPre h len (toForeignPtr -> (offset,lenPre,fptrPre)) + = F.withForeignPtr fptrPre + $ \ptrPre' -> do + let ptrPre = F.plusPtr ptrPre' offset + ptrBuf :: F.Ptr Word8 <- F.mallocBytes (lenPre + len) + F.copyBytes ptrBuf ptrPre lenPre + lenRead <- hGetBuf h (F.plusPtr ptrBuf lenPre) len + let bytesTotal = lenPre + lenRead + fptrBuf <- F.newForeignPtr F.finalizerFree ptrBuf + return $ fromForeignPtr bytesTotal fptrBuf +{-# NOINLINE hGetArrayPre #-} + + +-- | Write data into a file. +-- +-- * Data is written to file directly from foreign memory, +-- without copying it through the GHC heap. +-- +hPutArray :: Handle -> Array F Word8 -> IO () +hPutArray h (toForeignPtr -> (offset,lenPre,fptr)) + = F.withForeignPtr fptr + $ \ptr' -> do + let ptr = F.plusPtr ptr' offset + hPutBuf h ptr lenPre +{-# NOINLINE hPutArray #-} + + +-- | Read a CSV file as a nested array. +-- We get an array of rows:fields:characters. +-- +hGetArrayFromCSV + :: Handle + -> IO (Array N (Array N (Array F Char))) + +hGetArrayFromCSV !hIn + = do + -- Find out how much data there is remaining in the file. + start <- hTell hIn + hSeek hIn SeekFromEnd 0 + end <- hTell hIn + let !len = end - start + hSeek hIn AbsoluteSeek start + + -- Read array as Word8s. + !arr8 <- hGetArray hIn (fromIntegral len) + + -- Rows are separated by new lines, fields are separated by commas. + let !nc = fromIntegral $ ord ',' + let !nl = fromIntegral $ ord '\n' + + let !arrSep = A.diceSep nc nl arr8 + + -- Split CSV file into rows and fields. + -- Convert element data from Word8 to Char. + -- Chars take 4 bytes each, but are standard Haskell and pretty + -- print properly. We've done the dicing on the smaller Word8 + -- version, and now map across the elements vector in the array + -- to do the conversion. + let !arrChar + = A.mapElems + (A.mapElems (A.computeS F . A.map (chr . fromIntegral))) + arrSep + + return arrChar + + +-- | Write a nested array as a CSV file. +-- The array contains rows:fields:characters. +-- +hPutArrayAsCSV + :: ( BulkI l1 (Array l2 (Array l3 Char)) + , BulkI l2 (Array l3 Char) + , BulkI l3 Char + , Unpack (Array l3 Char) t) + => Handle + -> Array l1 (Array l2 (Array l3 Char)) + -> IO () + +hPutArrayAsCSV !hOut !arrChar + = do + -- Concat result back into Word8s + let !arrC = A.fromList U [','] + let !arrNL = A.fromList U ['\n'] + + let !arrOut + = A.mapS F (fromIntegral . ord) + $ A.concat U + $ A.mapS B (\arrFields + -> A.concat U $ A.fromList B + [ A.intercalate U arrC arrFields, arrNL]) + $ arrChar + + hPutArray hOut arrOut +{-# INLINE hPutArrayAsCSV #-} + diff --git a/Data/Repa/IO/Convert.hs b/Data/Repa/IO/Convert.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/IO/Convert.hs @@ -0,0 +1,89 @@ + +module Data.Repa.IO.Convert + ( -- * Conversion + -- | Read and Show `Double`s for a reasonable runtime cost. + readDouble, readDoubleFromBytes + , showDouble, showDoubleAsBytes + , showDoubleFixed, showDoubleFixedAsBytes) +where +import Data.Repa.Array.Material.Foreign as A +import Data.Repa.Array as A +import System.IO.Unsafe +import Data.Word +import Data.Char +import GHC.Ptr +import qualified Foreign.ForeignPtr as F +import qualified Foreign.Storable as F +import qualified Foreign.Marshal.Alloc as F +import qualified Foreign.Marshal.Utils as F +import qualified Data.Double.Conversion.ByteString as DC + + +-- | Convert a foreign vector of characters to a Double. +-- +-- * The standard Haskell `Char` type is four bytes in length. +-- If you already have a vector of `Word8` then use `readDoubleFromBytes` +-- instead to avoid the conversion. +-- +readDouble :: Array F Char -> Double +readDouble vec + = readDoubleFromBytes + $ A.computeS F $ A.map (fromIntegral . ord) vec +{-# INLINE readDouble #-} + + +-- | Convert a foreign vector of bytes to a Double. +readDoubleFromBytes :: Array F Word8 -> Double +readDoubleFromBytes (toForeignPtr -> (start,len,fptr)) + = unsafePerformIO + $ F.allocaBytes (len + 1) $ \pBuf -> + F.alloca $ \pRes -> + F.withForeignPtr fptr $ \pIn -> + do + -- Copy the data to our new buffer. + F.copyBytes pBuf (pIn `plusPtr` start) (fromIntegral len) + + -- Poke a 0 on the end to ensure it's null terminated. + F.pokeByteOff pBuf len (0 :: Word8) + + -- Call the C strtod function + let !d = strtod pBuf pRes + + return d +{-# NOINLINE readDoubleFromBytes #-} + +foreign import ccall unsafe + strtod :: Ptr Word8 -> Ptr (Ptr Word8) -> Double + + +-- | Convert a `Double` to ASCII text packed into a foreign `Vector`. +showDouble :: Double -> Array F Char +showDouble !d + = A.computeS F $ A.map (chr . fromIntegral) + $ showDoubleAsBytes d +{-# INLINE showDouble #-} + + +-- | Convert a `Double` to ASCII text packed into a foreign `Vector`. +showDoubleAsBytes :: Double -> Array F Word8 +showDoubleAsBytes !d + = fromByteString $ DC.toShortest d +{-# INLINE showDoubleAsBytes #-} + + +-- | Like `showDouble`, but use a fixed number of digits after +-- the decimal point. +showDoubleFixed :: Int -> Double -> Array F Char +showDoubleFixed !prec !d + = A.computeS F $ A.map (chr . fromIntegral) + $ showDoubleFixedAsBytes prec d +{-# INLINE showDoubleFixed #-} + + +-- | Like `showDoubleAsBytes`, but use a fixed number of digits after +-- the decimal point. +showDoubleFixedAsBytes :: Int -> Double -> Array F Word8 +showDoubleFixedAsBytes !prec !d + = fromByteString $ DC.toFixed prec d +{-# INLINE showDoubleFixedAsBytes #-} + diff --git a/Data/Repa/Nice.hs b/Data/Repa/Nice.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Nice.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Nice + ( Nicer (..) + , Str (..) + , Tok (..)) +where +import Data.Repa.Array as A +import Control.Monad +import Data.Word +import Prelude as P + + +-- | Wrapper to indicate a list of characters should be printed as a string, +-- including double quotes. +data Str = Str [Char] + +instance Show Str where + show (Str xs) = show xs + + +-- | Wrapper to indicate a list of characters should be printed as a string, +-- without double quotes. +data Tok = Tok [Char] + +instance Show Tok where + show (Tok xs) = xs + + +-- | Convert some value to a nice form. +-- +-- In particular: +-- +-- * Nested Arrays are converted to nested lists, so that they are easier +-- to work with on the ghci console. +-- +-- * Lists of characters are wrapped into the `Str` data type, so that +-- they can be pretty printed differently by follow-on processing. +-- +-- As ghci automatically pretty prints lists, using @nice@ is more +-- fun than trying to @show@ the raw Repa array representations. +-- +class Nicer a where + type Nice a + nice :: a -> Nice a + + +-- Atomic --------------------------------------------------------------------- +instance Nicer () where + type Nice () = () + nice x = x + +instance Nicer Int where + type Nice Int = Int + nice x = x + +instance Nicer Float where + type Nice Float = Float + nice x = x + +instance Nicer Double where + type Nice Double = Double + nice x = x + +instance Nicer Char where + type Nice Char = Char + nice x = x + +instance Nicer Word8 where + type Nice Word8 = Word8 + nice x = x + +instance Nicer Word16 where + type Nice Word16 = Word16 + nice x = x + +instance Nicer Word32 where + type Nice Word32 = Word32 + nice x = x + +instance Nicer Word64 where + type Nice Word64 = Word64 + nice x = x + + +-- Lists ---------------------------------------------------------------------- +-- instance (Nicer a) => Nicer [a] where +-- type Nice [a] = [Nice a] +-- nice xs = P.map nice xs + +-- Special case instance for lists of chars to pretty print them +-- without the [,] list syntax. +instance Nicer [Char] where + type Nice [Char] = Str + nice xs = Str xs + +instance Nicer [Int] where + type Nice [Int] = [Int] + nice xs = xs + +instance Nicer [Float] where + type Nice [Float] = [Float] + nice xs = xs + +instance Nicer [Double] where + type Nice [Double] = [Double] + nice xs = xs + +instance Nicer [Word8] where + type Nice [Word8] = [Word8] + nice xs = xs + +instance Nicer [Word16] where + type Nice [Word16] = [Word16] + nice xs = xs + +instance Nicer [Word32] where + type Nice [Word32] = [Word32] + nice xs = xs + +instance Nicer [Word64] where + type Nice [Word64] = [Word64] + nice xs = xs + + +-- Parametric ----------------------------------------------------------------- +instance Nicer a + => Nicer (Maybe a) where + type Nice (Maybe a) = Maybe (Nice a) + nice x = liftM nice x + +instance (Nicer a, Nicer b) + => Nicer (a, b) where + type Nice (a, b) = (Nice a, Nice b) + nice (x, y) = (nice x, nice y) + +instance (Bulk l a, Nicer [a]) + => Nicer (Array l a) where + type Nice (Array l a) = Nice [a] + nice vec = nice $ toList vec + +instance Nicer a + => Nicer [Maybe a] where + type Nice [Maybe a] = [Nice (Maybe a)] + nice xs = P.map nice xs + +instance (Nicer a, Nicer b) + => Nicer [(a, b)] where + type Nice [(a, b)] = [Nice (a, b)] + nice xs = P.map nice xs + +instance (Bulk l a, Nicer [a]) + => Nicer [(Array l a)] where + type Nice [Array l a] = [Nice [a]] + nice xs = P.map (nice . toList) xs + +instance Nicer [a] + => Nicer [[a]] where + type Nice [[a]] = [Nice [a]] + nice xs = P.map nice xs + diff --git a/Data/Repa/Nice/Display.hs b/Data/Repa/Nice/Display.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Nice/Display.hs @@ -0,0 +1,71 @@ + +module Data.Repa.Nice.Display + ( Display (..) + , Format (..) + , display + , takeDisplay + , padL + , padR) +where +import Data.Monoid +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T + +-- | How a given value should be displayed. +data Display + = Display Format Int + deriving (Eq, Show) + + +-- | Common display formats. +data Format + = FormatNumeric + | FormatText + deriving (Eq, Show) + + +instance Monoid Display where + mempty = Display FormatNumeric 0 + + mappend (Display m1 len1) (Display m2 len2) + | m1 == FormatNumeric && m2 == FormatNumeric + = Display FormatNumeric (max len1 len2) + + | otherwise + = Display FormatText (max len1 len2) + + +-- | Display a string with the given mode. +display :: Display -> Text -> Text +display (Display FormatNumeric width) str + = padR width str + +display (Display FormatText width) str + = padL width str + + +-- | Examine a string to decide how we should display it. +takeDisplay :: Text -> Display +takeDisplay str + | all (\c -> isDigit c || c == '.') $ T.unpack str + = Display FormatNumeric (T.length str) + + | otherwise + = Display FormatText (T.length str) + + +-- | Left justify some text in a column of the given width. +padL n xs + = let len = T.length xs + in if len >= n + then xs + else xs <> T.replicate (n - len) (T.pack " ") + + +-- | Right justify some text in a column of the given width. +padR n xs + = let len = T.length xs + in if len >= n + then xs + else T.replicate (n - len) (T.pack " ") <> xs diff --git a/Data/Repa/Nice/Present.hs b/Data/Repa/Nice/Present.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Nice/Present.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-} +module Data.Repa.Nice.Present + ( Presentable (..) + , Present (..) + , Str (..) + , Tok (..) + , depth + , strip1 + , strip2 + , flatten) +where +import Data.Monoid +import Data.Word +import Data.Text (Text) +import qualified Data.Text as T +import Data.Repa.Nice (Str(..), Tok(..)) + +-- | A value, wrapped up nicely. +data Present + -- | An atomic thing. + = Atom Text + + -- | Many of the same thing, to display with list brackets @[.. , ..]@ + | Many [Present] + + -- | Some different things, to display with tuple brackets @(.. , ..)@ + | Some [Present] + deriving (Eq, Show) + + +-- | Yield the nesting depth of a `Present` +depth :: Present -> Int +depth pp + = case pp of + Atom{} -> 0 + Many ps -> 1 + (case ps of + [] -> 0 + _ -> maximum $ map depth ps) + Some _ -> 0 + + +-- | Strip the top two layers of nesting into lists. +strip2 :: Present -> Maybe [[Present]] +strip2 (Many xs) = mapM strip1 xs +strip2 _ = Nothing + + +-- | Strip the top layer of nesting into a list. +strip1 :: Present -> Maybe [Present] +strip1 (Many xs) = Just xs +strip1 _ = Nothing + + +-- | Flatten a present into text +flatten :: Present -> Text +flatten (Atom str) = str +flatten (Many ps) + = T.pack "[" <> (T.intercalate (T.pack ",") $ map flatten ps) <> T.pack "]" + +flatten (Some ps) + = T.pack "(" <> (T.intercalate (T.pack ",") $ map flatten ps) <> T.pack ")" + + +-- | Convert some value to a form presentable to the user. +-- +-- Like `show` but we allow the nesting structure to be preserved +-- so it can be displayed in tabular format. +-- +class Presentable a where + present :: a -> Present + +instance Presentable Char where + present = Atom . T.pack . show + +instance Presentable Int where + present = Atom . T.pack . show + +instance Presentable Float where + present = Atom . T.pack . show + +instance Presentable Double where + present = Atom . T.pack . show + +instance Presentable Word8 where + present = Atom . T.pack . show + +instance Presentable Word16 where + present = Atom . T.pack . show + +instance Presentable Word32 where + present = Atom . T.pack . show + +instance Presentable Word64 where + present = Atom . T.pack . show + +instance Presentable Str where + present (Str xs) = Atom $ T.pack (show xs) + +instance Presentable Tok where + present (Tok xs) = Atom $ T.pack xs + +instance Presentable a + => Presentable [a] where + present xs = Many $ map present xs + +instance (Presentable a, Presentable b) + => Presentable (a, b) where + present (a, b) + = Some [present a, present b] + +instance (Presentable a, Presentable b, Presentable c) + => Presentable (a, b, c) where + present (a, b, c) + = Some [present a, present b, present c] + +instance (Presentable a, Presentable b, Presentable c, Presentable d) + => Presentable (a, b, c, d) where + present (a, b, c, d) + = Some [present a, present b, present c, present d] + +instance (Presentable a, Presentable b, Presentable c, Presentable d, Presentable e) + => Presentable (a, b, c, d, e) where + present (a, b, c, d, e) + = Some [present a, present b, present c, present d, present e] + diff --git a/Data/Repa/Nice/Tabulate.hs b/Data/Repa/Nice/Tabulate.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Nice/Tabulate.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE UndecidableInstances, OverlappingInstances #-} +module Data.Repa.Nice.Tabulate + ( tab + , tabulate + , Str (..) + , Tok (..)) +where +import Data.Repa.Nice.Present as A +import Data.Repa.Nice.Display as A +import Data.List as L +import qualified Data.Text as T +import Data.Text (Text) +import Data.Monoid +import Data.Maybe + + +-- | Print a nested value to the console in tabular form. +-- +-- The first two layers of nesting are displayed as rows and columns. +-- Numeric data is right-justified, while the rest is left-justified. +-- +-- @ +-- > tab [[10, 20, 302], [40, 50], [60, 7001, 80, 90 :: Int]] +-- 10 20 302 +-- 40 50 +-- 60 7001 80 90 +-- @ +-- +-- Deeper layers of nesting are preserved in the output: +-- +-- @ +-- > tab [[[10], [20, 21]], [[30, 31], [40, 41, 41], [50 :: Int]]] +-- [10] [20,21] +-- [30,31] [40,41,41] [50] +-- @ +-- +-- By default, strings are printed as lists of characters: +-- +-- @ +-- > tab [[("red", 10), ("green", 20), ("blue", 30)], [("grey", 40), ("white", 50 :: Int)]] +-- ([\'r\',\'e\',\'d\'],10) ([\'g\',\'r\',\'e\',\'e\',\'n\'],20) ([\'b\',\'l\',\'u\',\'e\'],30) +-- ([\'g\',\'r\',\'e\',\'y\'],40) ([\'w\',\'h\',\'i\',\'t\',\'e\'],50) +-- @ +-- +-- If you want double-quotes then wrap the strings with a @Str@ constructor: +-- +-- @ +-- > tab [[(Str "red", 10), (Str "green", 20), (Str "blue", 30)], [(Str "grey", 40), (Str "white", 50 :: Int)]] +-- ("red",10) ("green",20) ("blue",30) +-- ("grey",40) ("white",50) +-- @ +-- +-- If you don't want any quotes then wrap them with a @Tok@ constructor: +-- +-- @ +-- > tab [[(Tok "red", 10), (Tok "green", 20), (Tok "blue", 30)], [(Tok "grey", 40), (Tok "white", 50 :: Int)]] +-- (red,10) (green,20) (blue,30) +-- (grey,40) (white,50) +-- @ +-- +tab :: Presentable a => a -> IO () +tab val + = putStrLn $ T.unpack $ tabulate val + + +-- | Display a nested value in tabular form. +-- +tabulate :: Presentable a => a -> Text +tabulate xx + = let pp = present xx + in case depth pp of + 0 -> flatten pp + + 1 -> let Just pss = strip1 pp + in tabulate1 $ map flatten pss + + _ -> let Just pss = strip2 pp + in tabulate2 $ map (map flatten) pss + +tabulate1 :: [Text] -> Text +tabulate1 strs + = let d = mconcat $ map takeDisplay strs + in T.intercalate (T.pack "\n") + $ L.map (display d) strs + + +tabulate2 :: [[Text]] -> Text +tabulate2 strss + = let + -- Decide how to display a single column. + displayOfCol c + = mconcat + $ mapMaybe (\line -> if c >= length line + then Nothing + else Just (takeDisplay (line !! c))) + $ strss + + -- How many columns we have. + nCols = maximum $ L.map L.length strss + + -- Decide how to display all the columns. + displays = L.map displayOfCol [0.. nCols - 1] + + makeLine line + = T.intercalate (T.pack " ") + $ L.zipWith display displays line + + in T.intercalate (T.pack "\n") + $ L.map makeLine strss + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2014-2015, The Repa Development Team + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +- 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. + +- The names of the copyright holders may not be used to endorse or promote + products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED "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 +COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/include/repa-array.h b/include/repa-array.h new file mode 100644 --- /dev/null +++ b/include/repa-array.h @@ -0,0 +1,10 @@ + +#define PHASE_FLOW [3] +#define PHASE_ARRAY [2] +#define PHASE_STREAM [1] +#define PHASE_INNER [0] + +#define INLINE_FLOW INLINE PHASE_FLOW +#define INLINE_ARRAY INLINE PHASE_ARRAY +#define INLINE_STREAM INLINE PHASE_STREAM +#define INLINE_INNER INLINE PHASE_INNER diff --git a/repa-array.cabal b/repa-array.cabal new file mode 100644 --- /dev/null +++ b/repa-array.cabal @@ -0,0 +1,120 @@ +Name: repa-array +Version: 4.0.0.1 +License: BSD3 +License-file: LICENSE +Author: The Repa Development Team +Maintainer: Ben Lippmeier +Build-Type: Simple +Cabal-Version: >=1.6 +Stability: experimental +Category: Data Structures +Homepage: http://repa.ouroborus.net +Bug-reports: repa@ouroborus.net +Description: + NOTE: This is an ALPHA version of Repa 4. The API is not yet complete with + respect to Repa 3. Some important functions are still missing, and the docs + may not be up-to-date. + +Synopsis: + Bulk array representations and operators. + +source-repository head + type: git + location: https://github.com/DDCSF/repa.git + +Library + build-Depends: + base == 4.7.*, + primitive == 0.5.*, + vector == 0.10.*, + bytestring == 0.10.*, + mtl == 2.2.*, + double-conversion == 2.0.*, + text == 1.2.*, + repa-eval == 4.0.0.0, + repa-stream == 4.0.0.0 + + + exposed-modules: + Data.Repa.Array.Index.Slice + + Data.Repa.Array.Material.Boxed + Data.Repa.Array.Material.Foreign + Data.Repa.Array.Material.Nested + Data.Repa.Array.Material.Unboxed + + Data.Repa.Array.Dense + Data.Repa.Array.Delayed + Data.Repa.Array.Delayed2 + Data.Repa.Array.Index + Data.Repa.Array.Tuple + Data.Repa.Array.Window + Data.Repa.Array.Material + Data.Repa.Array.RowWise + Data.Repa.Array.Linear + + Data.Repa.Bits.Date32 + + Data.Repa.Eval.Array + Data.Repa.Eval.Chain + Data.Repa.Eval.Stream + + Data.Repa.Fusion.Unpack + + Data.Repa.IO.Array + Data.Repa.IO.Convert + + Data.Repa.Nice.Display + Data.Repa.Nice.Tabulate + Data.Repa.Nice.Present + + Data.Repa.Array + Data.Repa.Nice + + other-modules: + Data.Repa.Array.Internals.Operator.Concat + Data.Repa.Array.Internals.Operator.Fold + Data.Repa.Array.Internals.Operator.Group + Data.Repa.Array.Internals.Operator.Partition + Data.Repa.Array.Internals.Operator.Reduce + Data.Repa.Array.Internals.Operator.Filter + Data.Repa.Array.Internals.Bulk + Data.Repa.Array.Internals.Check + Data.Repa.Array.Internals.Layout + Data.Repa.Array.Internals.Load + Data.Repa.Array.Internals.Shape + Data.Repa.Array.Internals.Target + + include-dirs: + include + + install-includes: + repa-array.h + + ghc-options: + -Wall -fno-warn-missing-signatures + -O2 + + extensions: + CPP + BangPatterns + NoMonomorphismRestriction + RankNTypes + MagicHash + UnboxedTuples + ScopedTypeVariables + PatternGuards + FlexibleInstances + FlexibleContexts + TypeOperators + TypeFamilies + DefaultSignatures + MultiParamTypeClasses + EmptyDataDecls + StandaloneDeriving + FunctionalDependencies + ConstraintKinds + ForeignFunctionInterface + ViewPatterns + +