packages feed

yarr (empty) → 0.9.1

raw patch · 26 files changed

+4354/−0 lines, 26 filesdep +basedep +deepseqdep +fixed-vectorsetup-changed

Dependencies added: base, deepseq, fixed-vector, ghc-prim, missing-foreign, primitive, template-haskell

Files

+ Data/Yarr.hs view
@@ -0,0 +1,197 @@++{- | /Type system intro:/++    'Regular' is main type class in the library.+    Like @Source@ class in @repa@, it defines indexed type family: 'UArray'.+    Classes 'USource', for arrays which could be indexed, and 'UTarget',+    for mutable arrays, inherit from 'Regular'.++    As in @repa@, arrays in Yarr are type-indexed.+    'UArray' type family has 2 type indexes:++        * /representation index/ - the first type argument.++        * /load type index/ -+          the second argument of the type family. Pair of /load indexes/,+          from source and target array determines how arrays will be+          loaded one to another. Load index is mostly internal thing.+          See 'Load' class for details.++    Rest 2 'UArray' parameters generalize 'Shape' and element type.+++    'VecRegular', 'UVecSource', 'UVecTarget' are counterparts for arrays+    of fixed-sized vectors.+    These classes have 6 arguments: repr type index, /slice repr type index/,+    load type index, shape, vector type, vector element.+    +    /Note:/ in the docs \"vector\" always stands for+    fixed-size vector. Don't confuse with vector from @vector@ library.++    As in @repa@, there are several kinds of representations:++        * 'Manifest' representations: 'F'oreign and 'Data.Yarr.Repr.Boxed.B'oxed+          with 'Data.Yarr.Repr.Boxed.MB' (Mutable Boxed).+          The difference between 'Manifest' and 'UTarget' arrays is that+          'Manifest' arrays could be created (see 'new' function).+          For example, 'FS' (Foreign Slice) is a slice representation for 'F'.+          FS-arrays are mutable, but you can't create a slice,+          you should firstly allocate entire 'F' array.++        * /Delayed/, or /fused/ representations: 'D'elayed+          and 'Data.Yarr.Convolution.Repr.CV' (ConVoluted).+          Arrays of these types aren't really exist in memory.+          Finally they should be loaded to manifest arrays.++        * /View/ representations: 'DT' (Delayed Target) and 'FS'.+          Useful for advanced hand-controlled flow operations.++        * /Meta/ representations: 'SE'parate+          and 'Data.Yarr.Repr.Checked.CHK' (CHecKed).+          Thery are parameterized with another representation index.+          Arrays of meta types play almost like their prototypes.+          'SE' glues several arrays+          into one array of vectors (array types with 'SE' index are+          always instances of 'VecRegular' class).+          'CHK' is useful for debugging, it raises error on illegal indexing+          attempt. By default indexing is unchecked.++    +    /Representation choice:/++    'F'oreign is the main manifest representation.+    \"Unboxed\" arrays of tuples from @repa@ and @vector@ libraries+    may be emulated by @('SE' 'F')@ type index,+    but keep in mind that they are usually slower than vanilla foreign arrays,+    because the latter are memory-local.++    /How to load array into memory:/++    Currently there is only one option \"out of the box\" - to load image :)+    See "Data.Yarr.IO.Image" module in @yarr-image-io@ package.++    /How to map and zip arrays:/++    See 'DefaultFusion' class and functions in "Data.Yarr.Flow" module.++    Example:++    @let delayedVecLengths = 'Data.Yarr.Flow.zipElems' (\x y -> sqrt (x * x + y * y)) vecs@++    /How to compute an array:/+    +    See 'Load' class and its counterpart 'VecLoad', and 'compute' function.++    Typical use:++    @vecLengths <- 'Data.Yarr.Eval.compute' ('Data.Yarr.Eval.loadP' 'Data.Yarr.Shape.fill' 'Data.Yarr.Eval.caps') delayedVecLengths@++    [@Working examples@] <https://github.com/leventov/yarr/tree/master/tests>++    /How to write fast program:/++        1. Read corresponding section in @repa@ guide:+           <http://hackage.haskell.org/packages/archive/repa/3.2.3.1/doc/html/Data-Array-Repa.html>++        2. Write @INLINE@ pragmas to all functions, including curried shortcuts.+           For example in such case: @let {myIndex = 'index' arr} in ...@+           you should write: @let {\{\-\# INLINE myIndex \#\-\};@+           @myIndex = 'index' arr} in ...@++        3. Although the library is highly generalized, target programs+           should be as as precise in types as possible.+           Don't neglect writing signatures for functions.++        4. You shouldn't be very keen on bang patterns.+           They are more likey to harm than improve performance.+           However, in 95% of cases GHC ignores them.++        5. Compilation flags:+           @-Odph -rtsopts -threaded -fno-liberate-case -funbox-strict-fields@+           @-fexpose-all-unfoldings -funfolding-keeness-factor1000@+           @-fsimpl-tick-factor=500 -fllvm -optlo-O3@.+++    /Abbreviations across the library:/++    In names:++        * @U-@, @u-@, @unsafe-@ prefixes mean that:+          a) function parameters must conform special+          statically unchecked conditions, or b) it isn't OK just to call the function,+          you must do something else, call another function.+          All functions in type classes with @U-@ prefix+          ('USource', 'UTarget') are unsafe.++        * @d-@ prefix stands for \"default\". Typically function+          with @d-@ prefix is carried version of the one without prefix.++        * @f-@ prefix means \"fused\". Used for functions from 'Data.Yarr.Base.Fusion' class.++        * @-M@, as usual, is for monadic versions of functions.+          However, if there isn't non-monadic version+          (the most part of core functions), the suffix is omitted.++        * @-S@ and @-P@ are suffixes from @repa@, they indicate+          sequential and parallel versions of flow operation, respectively.++    In signatures:++        * @r@, @tr@, @mr@ - representation, target repr, manifest repr.+          For the first type index of 'UArray' family.++        * @slr@, @tslr@, @mslr@ - slice representation, respectively++        * @l@, @tl@ - load index, for the second argument of 'UArray'++        * @sh@ - array shape: 'Dim1', 'Dim2', or 'Dim3'++        * @v@, @v1@, @v2@ - 'Vector' type++        * @e@, @e2@ - vector element++        * @n@, @m@ - 'Arity' of vector+  +-}++module Data.Yarr (+    +    -- * Core type system+    module Data.Yarr.Base,++    -- ** Shapes+    Dim1, Dim2, Dim3,++    -- ** Fixed Vector+    Fun(..), Vector(..), VecList(VecList),+    N1, N2, N3, N4,+++    -- * Dataflow (fusion operations)+    module Data.Yarr.Flow,++    +    -- ** 'Load'ing and computing arrays+    module Data.Yarr.Eval,+    ++    -- * Common representations+    -- ** Foreign+    F, unsafeFromForeignPtr, toForeignPtr,+    +    -- ** Delayed+    D, UArray(LinearDelayed, ShapeDelayed), delay,++    -- ** Separate+    SE, fromSlices, unsafeMapSlices++) where++import Data.Yarr.Base hiding (Fusion(..))+import Data.Yarr.Eval+import Data.Yarr.Flow+import Data.Yarr.Shape+import Data.Yarr.Repr.Foreign+import Data.Yarr.Repr.Delayed+import Data.Yarr.Repr.Separate+import Data.Yarr.Utils.FixedVector as V
+ Data/Yarr/Base.hs view
@@ -0,0 +1,371 @@++-- | Core type system+module Data.Yarr.Base (++    -- * General Regular classes+    Regular(..), VecRegular(..),+    NFData(..), deepseq,++    -- * Shape class+    Shape,+    +    -- * Fixed vector +    Dim, Arity, Fun, Vector, VecList,+    +    -- * Source classes+    USource(..),+    UVecSource(..),++    -- * Fusion+    DefaultFusion(..), Fusion(..),++    -- * Manifest and Target classes+    UTarget(..), Manifest(..), UVecTarget(..)++) where++import Prelude as P++import Control.DeepSeq++import Data.Yarr.Shape as S+import Data.Yarr.Utils.FixedVector as V++import Data.Yarr.Utils.Primitive++-- | This class generalizes 'USource' and 'UTarget'.+--+-- Paramenters:+--+--  * @r@ - representation,+--+--  * @l@ - load type,+--+--  * @sh@ - shape,+--+--  * @a@ - element type.+--+-- Counterpart for arrays of vectors: 'VecRegular'.+class (NFData (UArray r l sh a), Shape sh) => Regular r l sh a where++    data UArray r l sh a++    -- | Returns the extent an the array.+    extent :: UArray r l sh a -> sh++    -- | Calling this function on foreign array ('Data.Yarr.Repr.Foreign.F')+    -- ensures it is still alive (GC haven't picked it).+    -- In other manifest representations, the function defined as @return ()@.+    -- 'touchArray' is lifted to top level in class hierarchy+    -- because in fact foreign representation is the heart of the library.+    touchArray :: UArray r l sh a -> IO ()++    -- | /O(1)/ Ensures that array /and all it's real manifest sources/+    -- are fully evaluated.+    -- This function is not for people, it is for GHC compiler.+    --+    -- Default implementation: @force arr = arr \`deepseq\` return ()@+    force :: UArray r l sh a -> IO ()+    force arr = arr `deepseq` return ()+    {-# INLINE force #-}++-- | Class for arrays of vectors.+--+-- Paramenters:+--+--  * @r@ - (entire) representation.+--    Associated array type for this class is @'UArray' r sh (v e)@.+--+--  * @slr@ - slice representation+--+--  * @l@ - load type+--+--  * @sh@ - shape+--+--  * @v@ - vector type+--+--  * @e@ - /vector/ (not array) element type.+--    Array element type is entire vector: @(v e)@.+--+-- Counterpart for \"simple\" arrays: 'Regular'.+class (Regular r l sh (v e), Regular slr l sh e, Vector v e) =>+        VecRegular r slr l sh v e | r -> slr where++    -- | /O(1)/ Array of vectors -> vector of arrays.+    -- Think about this function as shallow 'Prelude.unzip' from Prelude.+    -- Slices are /views/ of an underlying array.+    --+    -- Example:+    --+    -- @+    -- let css = slices coords+    --     xs = css 'V.!' 0+    --     ys = css 'V.!' 1+    -- @+    slices :: UArray r l sh (v e) -> VecList (Dim v) (UArray slr l sh e)++-- | Class for arrays which could be indexed.+-- +-- +-- It's functions are unsafe: you /must/ call 'touchArray' after the last call.+-- Fortunately, you will hardly ever need to call them manually.+--+-- Minimum complete defenition: 'index' or 'linearIndex'.+-- +-- Counterpart for arrays of vectors: 'UVecSource'+class Regular r l sh a => USource r l sh a where++    -- | Shape, genuine monadic indexing.+    --+    -- In Yarr arrays are always 'zero'-indexed and multidimensionally square.+    -- Maximum index is @(extent arr)@.+    --+    -- Default implementation:+    -- @index arr sh = linearIndex arr $ 'toLinear' ('extent' arr) sh@+    index :: UArray r l sh a -> sh -> IO a+    index arr sh = linearIndex arr $ toLinear (extent arr) sh+    +    -- | \"Surrogate\" linear index.+    -- For 'Dim1' arrays @index == linearIndex@.+    --+    -- Default implementation:+    -- @linearIndex arr i = index arr $ 'fromLinear' ('extent' arr) i@+    linearIndex :: UArray r l sh a -> Int -> IO a+    linearIndex arr i = index arr $ fromLinear (extent arr) i++    {-# INLINE index #-}+    {-# INLINE linearIndex #-}++-- | Class for arrays of vectors which could be indexed.+-- The class doesn't need to define functions, it just gathers it's dependencies.+--+-- Counterpart for \"simple\" arrays: 'USource'.+class (VecRegular r slr l sh v e, USource r l sh (v e), USource slr l sh e) =>+        UVecSource r slr l sh v e+++-- | Generalized, non-injective version of 'DefaultFusion'. Used internally.+--+-- Minimum complete defenition: 'fmapM', 'fzip2M', 'fzip3M' and 'fzipM'.+--+-- The class doesn't have vector counterpart, it's role play top-level functions+-- from "Data.Yarr.Repr.Separate" module.+class Fusion r fr l where+    fmap :: (USource r l sh a, USource fr l sh b)+         => (a -> b) -- ^ .+         -> UArray r l sh a -> UArray fr l sh b+    fmap f = fmapM (return . f)+    +    fmapM :: (USource r l sh a, USource fr l sh b)+          => (a -> IO b) -> UArray r l sh a -> UArray fr l sh b++    fzip2 :: (USource r l sh a, USource r l sh b, USource fr l sh c)+          => (a -> b -> c) -- ^ .+          -> UArray r l sh a+          -> UArray r l sh b+          -> UArray fr l sh c+    fzip2 f = fzip2M (\x y -> return (f x y))++    fzip2M :: (USource r l sh a, USource r l sh b, USource fr l sh c)+           => (a -> b -> IO c) -- ^ .+           -> UArray r l sh a+           -> UArray r l sh b+           -> UArray fr l sh c++    fzip3 :: (USource r l sh a, USource r l sh b, USource r l sh c,+              USource fr l sh d)+          => (a -> b -> c -> d) -- ^ .+          -> UArray r l sh a+          -> UArray r l sh b+          -> UArray r l sh c+          -> UArray fr l sh d+    fzip3 f = fzip3M (\x y z -> return (f x y z))++    fzip3M :: (USource r l sh a, USource r l sh b, USource r l sh c,+               USource fr l sh d)+           => (a -> b -> c -> IO d) -- ^ .+           -> UArray r l sh a+           -> UArray r l sh b+           -> UArray r l sh c+           -> UArray fr l sh d++    fzip :: (USource r l sh a, USource fr l sh b, Arity n, n ~ S n0)+         => Fun n a b -- ^ .+         -> VecList n (UArray r l sh a) -> UArray fr l sh b+    fzip fun arrs = let funM = P.fmap return fun in fzipM funM arrs++    fzipM :: (USource r l sh a, USource fr l sh b, Arity n, n ~ S n0)+          => Fun n a (IO b) -- ^ .+          -> VecList n (UArray r l sh a) -> UArray fr l sh b++    {-# INLINE fmap #-}+    {-# INLINE fzip2 #-}+    {-# INLINE fzip3 #-}+    {-# INLINE fzip #-}+++-- | This class abstracts pair of array types, which could be (preferably should be)+-- mapped /(fused)/ one to another. Injective version of 'Fusion' class.+-- +-- Parameters:+--+--  * @r@ - source array representation. It determines result representation.+--+--  * @fr@ (fused repr) - result (fused) array representation. Result array+--    isn't indeed presented in memory, finally it should be+--    'Data.Yarr.Eval.compute'd or 'Data.Yarr.Eval.Load'ed to 'Manifest'+--    representation.+--+--  * @l@ - load type, common for source and fused arrays+--+-- All functions are already defined, using non-injective versions from 'Fusion' class.+--+-- The class doesn't have vector counterpart, it's role play top-level functions+-- from "Data.Yarr.Repr.Separate" module.+class Fusion r fr l => DefaultFusion r fr l | r -> fr where+    -- | /O(1)/ Pure element mapping.+    --+    -- Main basic \"map\" in Yarr.+    dmap :: (USource r l sh a, USource fr l sh b)+         => (a -> b)         -- ^ Element mapper function+         -> UArray r l sh a  -- ^ Source array+         -> UArray fr l sh b -- ^ Result array+    dmap = Data.Yarr.Base.fmap+    +    -- | /O(1)/ Monadic element mapping.+    dmapM :: (USource r l sh a, USource fr l sh b)+          => (a -> IO b)      -- ^ Monadic element mapper function+          -> UArray r l sh a  -- ^ Source array+          -> UArray fr l sh b -- ^ Result array+    dmapM = fmapM++    -- | /O(1)/ Zipping 2 arrays of the same type indexes and shapes.+    -- +    -- Example:+    -- +    -- @+    -- let productArr = dzip2 (*) arr1 arr2+    -- @+    dzip2 :: (USource r l sh a, USource r l sh b, USource fr l sh c)+          => (a -> b -> c)     -- ^ Pure element zipper function+          -> UArray r l sh a   -- ^ 1st source array+          -> UArray r l sh b   -- ^ 2nd source array+          -> UArray fr l sh c  -- ^ Fused result array+    dzip2 = fzip2++    -- | /O(1)/ Monadic version of 'dzip2' function.+    dzip2M :: (USource r l sh a, USource r l sh b, USource fr l sh c)+           => (a -> b -> IO c) -- ^ Monadic element zipper function+           -> UArray r l sh a  -- ^ 1st source array+           -> UArray r l sh b  -- ^ 2nd source array+           -> UArray fr l sh c -- ^ Result array+    dzip2M = fzip2M++    -- | /O(1)/ Zipping 3 arrays of the same type indexes and shapes.+    dzip3 :: (USource r l sh a, USource r l sh b, USource r l sh c,+              USource fr l sh d)+          => (a -> b -> c -> d) -- ^ Pure element zipper function+          -> UArray r l sh a    -- ^ 1st source array+          -> UArray r l sh b    -- ^ 2nd source array+          -> UArray r l sh c    -- ^ 3rd source array+          -> UArray fr l sh d   -- ^ Result array+    dzip3 = fzip3++    -- | /O(1)/ Monadic version of 'dzip3' function.+    dzip3M :: (USource r l sh a, USource r l sh b, USource r l sh c,+               USource fr l sh d)+           => (a -> b -> c -> IO d) -- ^ Monadic element zipper function+           -> UArray r l sh a       -- ^ 1st source array+           -> UArray r l sh b       -- ^ 2nd source array+           -> UArray r l sh c       -- ^ 3rd source array+           -> UArray fr l sh d      -- ^ Fused result array+    dzip3M = fzip3M++    -- | /O(1)/ Generalized element zipping with pure function.+    -- Zipper function is wrapped in 'Fun' for injectivity.+    dzip :: (USource r l sh a, USource fr l sh b, Arity n, n ~ S n0)+         => Fun n a b                   -- ^ Wrapped function positionally+                                        -- accepts elements from source arrays+                                        -- and emits element for fused array+         -> VecList n (UArray r l sh a) -- ^ Source arrays+         -> UArray fr l sh b            -- ^ Result array+    dzip = fzip++    -- | /O(1)/ Monadic version of 'dzip' function.+    dzipM :: (USource r l sh a, USource fr l sh b, Arity n, n ~ S n0)+          => Fun n a (IO b)              -- ^ Wrapped monadic zipper+          -> VecList n (UArray r l sh a) -- ^ Source arrays+          -> UArray fr l sh b            -- ^ Result array+    dzipM = fzipM++    {-# INLINE dmap #-}+    {-# INLINE dmapM #-}+    {-# INLINE dzip2 #-}+    {-# INLINE dzip2M #-}+    {-# INLINE dzip3 #-}+    {-# INLINE dzip3M #-}+    {-# INLINE dzip #-}+    {-# INLINE dzipM #-}+++-- | Class for mutable arrays.+--+-- Just like for 'USource', it's function are unsafe+-- and require calling 'touchArray' after the last call.+--+-- Minimum complete defenition: 'write' or 'linearWrite'.+--+-- Counterpart for arrays of vectors: 'UVecTarget'+class Regular tr tl sh a => UTarget tr tl sh a where+    -- | Shape, genuine monadic writing.+    --+    -- Default implementation:+    -- @write tarr sh = linearWrite tarr $ 'toLinear' ('extent' tarr) sh@+    write :: UArray tr tl sh a -> sh -> a -> IO ()+    write tarr sh = linearWrite tarr $ toLinear (extent tarr) sh+    +    -- | Fast (usually), linear indexing. Intented to be used internally.+    --+    -- Default implementation:+    -- @linearWrite tarr i = write tarr $ 'fromLinear' ('extent' tarr) i@+    linearWrite :: UArray tr tl sh a -> Int -> a -> IO ()+    linearWrite tarr i = write tarr $ fromLinear (extent tarr) i+    +    {-# INLINE write #-}+    {-# INLINE linearWrite #-}++-- | Class for arrays which could be created.+-- It combines a pair of representations: freezed and mutable (raw).+-- This segregation is lifted from Boxed representation+-- and, in the final, from GHC system of primitive arrays.+-- +-- Parameters:+--+--  * @r@ - freezed array representation.+--+--  * @mr@ - mutable, raw array representation+--+--  * @l@ - load type index, common for both representations+--+--  * @sh@ - shape of arrays+--+--  * @a@ - element type+class (USource r l sh a, UTarget mr l sh a) =>+        Manifest r mr l sh a | r -> mr, mr -> r where++    -- | /O(1)/ Creates and returns mutable array of the given shape.+    new :: sh -> IO (UArray mr l sh a)++    -- | /O(1)/ Freezes mutable array and returns array which could be indexed.+    freeze :: UArray mr l sh a -> IO (UArray r l sh a)++    -- | /O(1)/ Thaws freezed array and returns mutable version.+    thaw :: UArray r l sh a -> IO (UArray mr l sh a)++-- | Class for mutable arrays of vectors.+-- The class doesn't need to define functions, it just gathers it's dependencies.+--+-- Counterpart for \"simple\" arrays: 'UTarget'.+class (VecRegular tr tslr tl sh v e,+       UTarget tr tl sh (v e), UTarget tslr tl sh e) =>+        UVecTarget tr tslr tl sh v e
+ Data/Yarr/Convolution.hs view
@@ -0,0 +1,12 @@++module Data.Yarr.Convolution (+    -- * Convoluted representation+    module Data.Yarr.Convolution.Repr,+    module Data.Yarr.Convolution.Eval,+    -- * Static stencils+    module Data.Yarr.Convolution.StaticStencils+) where++import Data.Yarr.Convolution.Repr+import Data.Yarr.Convolution.Eval+import Data.Yarr.Convolution.StaticStencils
+ Data/Yarr/Convolution/Eval.hs view
@@ -0,0 +1,253 @@++module Data.Yarr.Convolution.Eval () where++import Data.Yarr.Base+import Data.Yarr.Eval+import Data.Yarr.Shape as S+import Data.Yarr.Convolution.Repr+import Data.Yarr.Repr.Separate++import Data.Yarr.Utils.FixedVector as V+import Data.Yarr.Utils.Fork+import Data.Yarr.Utils.Parallel+import Data.Yarr.Utils.Split+++instance (BlockShape sh, UTarget tr tl sh a) =>+        Load CV CVL tr tl sh a where+    type LoadIndex CVL tl sh = sh+    loadP fill threads arr tarr =+        cvLoadP fill threads arr tarr zero (entire arr tarr)+    loadS fill arr tarr = cvLoadS fill arr tarr zero (entire arr tarr)+    {-# INLINE loadP #-}+    {-# INLINE loadS #-}+++instance (BlockShape sh, UTarget tr tl sh a) =>+        RangeLoad CV CVL tr tl sh a where+    rangeLoadP = cvLoadP+    rangeLoadS = cvLoadS+    {-# INLINE rangeLoadP #-}+    {-# INLINE rangeLoadS #-}++cvLoadP+    :: forall sh a tr tl. (BlockShape sh, UTarget tr tl sh a)+    => Fill sh a+    -> Threads+    -> UArray CV CVL sh a+    -> UArray tr tl sh a+    -> sh -> sh+    -> IO ()+{-# INLINE cvLoadP #-}+cvLoadP fill threads arr@(Convoluted _ _ _ bget center cget) tarr start end = do+    force arr+    force tarr+    !ts <- threads++    let loadRange = (start, end)+        loadCenter@(cs, ce) = intersectBlocks (vl_2 center loadRange)++        {-# INLINE appFill #-}+        appFill = fill cget (write tarr)+        {-# INLINE centerWork #-}+        centerWork = makeFork ts cs ce appFill++        {-# INLINE borderFill #-}+        borderFill = S.fill bget (write tarr)++        !bordersCount = arity (undefined :: (BorderCount sh))+        {-# INLINE bordersSplit #-}+        bordersSplit = makeSplitIndex ts 0 bordersCount++        borders = clipBlock loadRange loadCenter++        {-# INLINE borderWork #-}+        borderWork !t =+            let !startBorder = bordersSplit t+                !endBorder = bordersSplit (t + 1)+                {-# INLINE go #-}+                go !b | b >= endBorder = return ()+                      | otherwise      = do+                            let (bs, be) = borders V.! b+                            borderFill bs be+                            go (b + 1)+            in go startBorder++        {-# INLINE threadWork #-}+        threadWork !t = do+            centerWork t+            borderWork t+                                    +    parallel_ ts threadWork++    touchArray arr+    touchArray tarr++cvLoadS+    :: (BlockShape sh, UTarget tr tl sh a)+    => Fill sh a+    -> UArray CV CVL sh a+    -> UArray tr tl sh a+    -> sh -> sh+    -> IO ()+{-# INLINE cvLoadS #-}+cvLoadS fill arr@(Convoluted _ _ _ bget center cget) tarr start end = do+    force arr+    force tarr++    let loadRange = (start, end)+        loadCenter@(cs, ce) = intersectBlocks (vl_2 center loadRange)+    fill cget (write tarr) cs ce++    let borders = clipBlock loadRange loadCenter+    V.mapM_ (\(bs, be) -> S.fill bget (write tarr) bs be) borders++    touchArray arr+    touchArray tarr+++instance (BlockShape sh, Vector v e,+          UVecTarget tr tslr tl sh v2 e, Dim v ~ Dim v2) =>+        VecLoad (SE CV) CV CVL tr tslr tl sh v v2 e where+    +    -- These functions aren't inlined propely with any first argument,+    -- different from Shape.fill (vanilla not unrolled fill),+    -- for an unknown reason++    loadSlicesP fill threads arr tarr =+        cvLoadSlicesP fill threads arr tarr zero (entire arr tarr)+    loadSlicesS fill arr tarr =+        cvLoadSlicesS fill arr tarr zero (entire arr tarr)+    {-# INLINE loadSlicesP #-}+    {-# INLINE loadSlicesS #-}++instance (BlockShape sh, Vector v e,+          UVecTarget tr tslr tl sh v2 e, Dim v ~ Dim v2) =>+        RangeVecLoad (SE CV) CV CVL tr tslr tl sh v v2 e where+    rangeLoadSlicesP = cvLoadSlicesP+    rangeLoadSlicesS = cvLoadSlicesS+    {-# INLINE rangeLoadSlicesP #-}+    {-# INLINE rangeLoadSlicesS #-}+++cvLoadSlicesP+    :: forall sh v e tr tslr tl v2.+       (BlockShape sh, UVecTarget tr tslr tl sh v2 e,+        Vector v e, Dim v ~ Dim v2)+    => Fill sh e+    -> Threads+    -> UArray (SE CV) CVL sh (v e)+    -> UArray tr tl sh (v2 e)+    -> sh -> sh+    -> IO ()+{-# INLINE cvLoadSlicesP #-}+cvLoadSlicesP fill threads arr tarr start end = do+    force arr+    force tarr+    !ts <- threads++    let loadRange = (start, end)+        sls = slices arr++        centers = V.map center sls++        loadCenters = V.map (\c -> intersectBlocks (vl_2 c loadRange)) centers+        writes = V.map write (slices tarr)+        borderGets = V.map borderGet sls+        borderFills = V.zipWith S.fill borderGets writes++        centerGets = V.map centerGet sls+        centerFills = V.zipWith fill centerGets writes++        {-# INLINE centerWork #-}+        centerWork = makeForkSlicesOnce ts loadCenters centerFills++        !slsCount = arity (undefined :: (Dim v))+        !bordersPerSlice = arity (undefined :: (BorderCount sh))+        !allBorders = slsCount * bordersPerSlice+        +        {-# INLINE bordersSplit #-}+        bordersSplit = makeSplitIndex ts 0 allBorders++        borders = V.map (clipBlock loadRange) loadCenters+        fillsAndBorders = V.zipWith (,) borderFills borders++        {-# INLINE bordersWork #-}+        bordersWork !t =+            let !startChunk = bordersSplit t+                !endChunk = (bordersSplit (t + 1)) - 1+                (!startSlice, !startBorder) =+                    startChunk `quotRem` bordersPerSlice+                (!endSlice, !endBorder) =+                    endChunk `quotRem` bordersPerSlice+                {-# INLINE go #-}+                go sl b | sl > endSlice = return ()+                        | otherwise     =+                            let e = if sl == endSlice+                                        then endBorder+                                        else (bordersPerSlice - 1)+                                (bfill, borders) = fillsAndBorders V.! sl+                            in do goSl bfill borders b e+                                  go (sl + 1) 0++                {-# INLINE goSl #-}+                goSl bfill borders c e+                    | c > e     = return ()+                    | otherwise =+                        let (bs, be) = borders V.! c+                        in bfill bs be >> goSl bfill borders (c + 1) e+            in go startSlice startBorder+++        {-# INLINE threadWork #-}+        threadWork !t = do+            centerWork t+            bordersWork t++    parallel_ ts threadWork++    touchArray arr+    touchArray tarr+++cvLoadSlicesS+    :: (BlockShape sh, UVecTarget tr tslr tl sh v2 e,+        Vector v e, Dim v ~ Dim v2)+    => Fill sh e+    -> UArray (SE CV) CVL sh (v e)+    -> UArray tr tl sh (v2 e)+    -> sh -> sh+    -> IO ()+{-# INLINE cvLoadSlicesS #-}+cvLoadSlicesS fill arr tarr start end = do+    force arr+    force tarr+    +    let sls = slices arr+        borderGets = V.map borderGet sls+        centers = V.map center sls++        centerGets = V.map centerGet sls+        writes = V.map write (slices tarr)+        centerFills = V.zipWith fill centerGets writes++        loadRange = (start, end)+        loadCenters = V.map (\c -> intersectBlocks (vl_2 c loadRange)) centers++    V.zipWithM_+        (\centerFill (cs, ce) -> centerFill cs ce)+        centerFills loadCenters++    let borders = V.map (clipBlock loadRange) loadCenters+        borderFills = V.zipWith S.fill borderGets writes+    V.zipWithM_+        (\bfill borders -> V.mapM_ (\(bs, be) -> bfill bs be) borders)+        borderFills borders++    touchArray arr+    touchArray tarr++    -- This version is not inlined propely for an unknown reason++    --V.zipWithM_ (\sl tsl -> rangeLoadS fill sl tsl start end)+    --            (slices arr) (slices tarr)
+ Data/Yarr/Convolution/Repr.hs view
@@ -0,0 +1,164 @@++module Data.Yarr.Convolution.Repr (+    CV, CVL, UArray(..), justCenter,+) where++import Prelude as P+import Control.Monad++import Data.Yarr.Base+import Data.Yarr.Shape+import Data.Yarr.Repr.Delayed++import Data.Yarr.Utils.FixedVector as V++-- | Convolution fused representation internally keeps 2 element getters:+--+--  * slow /border get/, which checks every index from applied stencil+--    to lay inside extent of underlying source array.+--+--  * fast /center get/, which don't worries about bound checks+--+-- and 'center' 'Block'.+data CV++-- | ConVolution 'Data.Yarr.Eval.Load' type is specialized to load convoluted arrays.+--+-- It loads 'center' with 'centerGet' and borders outside the center with+-- 'borderGet' separately.+--+-- It is even able to distribute quite expensive border loads evenly between+-- available threads while parallel load.+--+-- /TODO:/ element-wise Loading convoluted arrays isn't inlined propely+-- with unrolled 'Fill'ing ('unrolledFill', 'dim2BlockFill').+-- However, with simple 'fill' performance is OK.+--+-- For details see+-- <http://stackoverflow.com/questions/14748900/ghc-doesnt-perform-2-stage-partial-application-inlining>+data CVL++instance Shape sh => Regular CV CVL sh a where++    data UArray CV CVL sh a =+        Convoluted {+            getExtent      :: !sh,+            getTouch       :: IO (),+            inheritedForce :: IO (),+            borderGet      :: sh -> IO a,+            center         :: !(sh, sh),+            centerGet      :: sh -> IO a+        }++    extent = getExtent+    touchArray = getTouch+    force (Convoluted sh _ iforce _ center _) = do+        sh `deepseq` return ()+        center `deepseq` return ()+        iforce++    {-# INLINE extent #-}+    {-# INLINE touchArray #-}++-- | Retreives fast center get from convoluted array+-- and wraps it into 'D'elayed array.+--+-- Remember that array indexing in Yarr is always zero-based,+-- so indices in result array are shifted by top-level corner offset+-- of given convoluted array.+justCenter :: Shape sh => UArray CV CVL sh a -> UArray D SH sh a+{-# INLINE justCenter #-}+justCenter (Convoluted sh tch iforce _ (tl, br) cget) =+    ShapeDelayed (tl `offset` br) tch iforce (cget . (`plus` tl)) ++instance Shape sh => NFData (UArray CV CVL sh a) where+    rnf (Convoluted sh tch iforce bget center cget) =+        sh `deepseq` tch `seq` iforce `seq`+            bget `seq` center `deepseq` cget `seq` ()+    {-# INLINE rnf #-}+++instance Shape sh => USource CV CVL sh a where+    index (Convoluted _ _ _ bget center cget) sh =+        if insideBlock center sh+            then cget sh+            else bget sh++    {-# INLINE index #-}+++instance Fusion CV CV CVL where+    fmapM f (Convoluted sh tch iforce bget center cget) =+        Convoluted sh tch iforce (f <=< bget) center (f <=< cget)++    fzip2M f arr1 arr2 =+        let sh = intersect (vl_2 (extent arr1) (extent arr2))+            ctr = intersectBlocks (vl_2 (center arr1) (center arr2))+            tch = touchArray arr1 >> touchArray arr2+            iforce = force arr1 >> force arr2++            {-# INLINE bget #-}+            bget sh = do+                v1 <- borderGet arr1 sh+                v2 <- borderGet arr2 sh+                f v1 v2++            {-# INLINE cget #-}+            cget sh = do+                v1 <- centerGet arr1 sh+                v2 <- centerGet arr2 sh+                f v1 v2++        in Convoluted sh tch iforce bget ctr cget++    fzip3M f arr1 arr2 arr3 =+        let sh = intersect (vl_3 (extent arr1) (extent arr2) (extent arr3))+            ctr = intersectBlocks (vl_3 (center arr1) (center arr2) (center arr3))+            tch = touchArray arr1 >> touchArray arr2 >> touchArray arr3+            iforce = force arr1 >> force arr2 >> force arr3++            {-# INLINE bget #-}+            bget sh = do+                v1 <- borderGet arr1 sh+                v2 <- borderGet arr2 sh+                v3 <- borderGet arr3 sh+                f v1 v2 v3++            {-# INLINE cget #-}+            cget sh = do+                v1 <- centerGet arr1 sh+                v2 <- centerGet arr2 sh+                v3 <- centerGet arr3 sh+                f v1 v2 v3++        in Convoluted sh tch iforce bget ctr cget++    fzipM fun arrs =+        let sh = intersect $ V.map extent arrs++            ctr = intersectBlocks $ V.map center arrs++            tch = V.mapM_ touchArray arrs++            iforce = V.mapM_ force arrs++            bgets = V.map borderGet arrs+            {-# INLINE bget #-}+            bget sh = do+                v <- V.mapM ($ sh) bgets+                inspect v fun++            cgets = V.map centerGet arrs+            {-# INLINE cget #-}+            cget sh = do+                v <- V.mapM ($ sh) cgets+                inspect v fun++        in Convoluted sh tch iforce bget ctr cget++    {-# INLINE fmapM #-}+    {-# INLINE fzip2M #-}+    {-# INLINE fzip3M #-}+    {-# INLINE fzipM #-}++instance DefaultFusion CV CV CVL
+ Data/Yarr/Convolution/StaticStencils.hs view
@@ -0,0 +1,366 @@++module Data.Yarr.Convolution.StaticStencils (+    -- ** Dim1 stencils+    Dim1Stencil(..), dim1St,+    dConvolveDim1WithStaticStencil, convolveDim1WithStaticStencil,++    -- ** Dim2 stencils+    Dim2Stencil(..), dim2St,+    dConvolveShDim2WithStaticStencil, convolveShDim2WithStaticStencil,+    dConvolveLinearDim2WithStaticStencil, convolveLinearDim2WithStaticStencil+) where++import Prelude as P+import Control.Monad+import Data.Char (isSpace)++import Language.Haskell.TH hiding (Arity)+import Language.Haskell.TH.Quote++import Data.Yarr.Base+import Data.Yarr.Shape+import Data.Yarr.Repr.Delayed+import Data.Yarr.Convolution.Repr+import Data.Yarr.Utils.FixedVector as V+import Data.Yarr.Utils.Primitive++-- | Generalized static 'Dim1' stencil.+data Dim1Stencil size a b c =+    Dim1Stencil {+        dim1StencilSize   :: size,+        dim1StencilValues :: (VecList size b),+        dim1StencilReduce :: (c -> a -> b -> IO c), -- ^ Generalized reduce function+        dim1StencilZero   :: c                      -- ^ Reduce zero+    }++-- | QuasiQuoter for producing typical numeric convolving 'Dim1' stencil,+-- which effectively skips unnecessary multiplications.+--+-- @[dim1St| 1 4 6 4 1 |]@+--+-- Produces+--+-- @+--'Dim1Stencil'+--    'n5'+--    ('VecList'+--       [\ acc a -> return (acc + a),+--        \ acc a -> (return $ (acc + (4 * a))),+--        \ acc a -> (return $ (acc + (6 * a))),+--        \ acc a -> (return $ (acc + (4 * a))),+--        \ acc a -> return (acc + a)])+--    (\ acc a reduce -> reduce acc a)+--    0+-- @+dim1St :: QuasiQuoter+dim1St = QuasiQuoter parseDim1Stencil undefined undefined undefined++parseDim1Stencil s =+    let values :: [Integer]+        values = P.map read (words s)+        size = P.length values    +        sizeType = P.foldr appT [t|Z|] (P.replicate size [t|S|])+        sz = [| undefined :: $sizeType |]+        vecList = [| VecList |] `appE` (listE (P.map justNonZero values))+    in [| Dim1Stencil $sz $vecList (\acc a reduce -> reduce acc a) 0 |]+++-- | Generalized static 'Dim2' stencil.+data Dim2Stencil sx sy a b c =+    Dim2Stencil {+        dim2StencilSizeX :: sx,+        dim2StencilSizeY :: sy,+        dim2StencilValues :: (VecList sy (VecList sx b)), -- ^ Stencil values, packed in nested vectors+        dim2StencilReduce :: (c -> a -> b -> IO c),       -- ^ Generalized reduce function+        dim2StencilZero :: c                              -- ^ Reduce zero+    }++-- | Most useful 'Dim2' stencil producer.+--+-- Typing+--+-- @+-- [dim2St| 1   2   1+--          0   0   0+--         -1  -2  -1 |]+-- @+--+-- Results to+--+-- @+-- 'Dim2Stencil'+--  'n3'+--  'n3'+--  ('VecList'+--     ['VecList'+--        [\ acc a -> return (acc + a),+--         \ acc a -> (return $ (acc + (2 * a))),+--         \ acc a -> return (acc + a)],+--      'VecList'+--        [\ acc _ -> return acc,+--         \ acc _ -> return acc,+--         \ acc _ -> return acc],+--      'VecList'+--        [\ acc a -> return (acc - a),+--         \ acc a -> (return $ (acc + (-2 * a))),+--         \ acc a -> return (acc - a)]])+--  (\ acc a reduce -> reducej acc a)+--  0+-- @+dim2St :: QuasiQuoter+dim2St = QuasiQuoter parseDim2Stencil undefined undefined undefined++parseDim2Stencil s =+    let ls = filter (not . P.all isSpace) (lines s)+        values :: [[Integer]]+        values = P.map (P.map read . words) ls++        sizeX = P.length (P.head values)+        sizeTypeX = P.foldr appT [t|Z|] (P.replicate sizeX [t|S|])+        sx = [| undefined :: $sizeTypeX |]+        +        sizeY = P.length values+        sizeTypeY = P.foldr appT [t|Z|] (P.replicate sizeY [t|S|])+        sy = [| undefined :: $sizeTypeY |]++        vl = [| VecList |]+        innerLists =+            P.map (\vs -> vl `appE` (listE (P.map justNonZero vs))) values+        outerList = vl `appE` (listE innerLists)++    in [| Dim2Stencil $sx $sy $outerList (\acc a reduce -> reduce acc a) 0 |]+++justNonZero :: Integer -> Q Exp+justNonZero v+    | v == 0    = [| \acc _ -> return acc |]+    | v == 1    = [| \acc a -> return (acc + a) |]+    | v == -1   = [| \acc a -> return (acc - a) |]+    | otherwise = [| \acc a -> return $ acc + $(litE (integerL v)) * a |]+++-- | Curried version of 'convolveDim1WithStaticStencil'+-- with border get clamping indices out of bounds to+-- @0@ or @('extent' source)@.+dConvolveDim1WithStaticStencil+    :: (StencilOffsets s so eo, USource r l Dim1 a)+    => Dim1Stencil s a b c  -- ^ Convolution stencil+    -> UArray r l Dim1 a    -- ^ Source array+    -> UArray CV CVL Dim1 c -- ^ Fused convolved result array+{-# INLINE dConvolveDim1WithStaticStencil #-}+dConvolveDim1WithStaticStencil =+    convolveDim1WithStaticStencil+        (\arr len ->+            let !maxI = len - 1+            in linearIndex arr <=< (clampM' 0 maxI))++-- | Convolves 'Dim1' array with static stencil.+convolveDim1WithStaticStencil+    :: forall r l s so eo a b c.+       (USource r l Dim1 a, StencilOffsets s so eo)+    => (UArray r l Dim1 a -> Dim1 -> Dim1 -> IO a)+                             -- ^ (Source array -> Extent of this array ->+                             --   Index (may be out of bounds) -> Result value):+                             --   Border index (to treat indices near to bounds)+    -> Dim1Stencil s a b c   -- ^ Convolution stencil+    -> UArray r l Dim1 a     -- ^ Source array+    -> UArray CV CVL Dim1 c  -- ^ Fused convolved result array+{-# INLINE convolveDim1WithStaticStencil #-}+convolveDim1WithStaticStencil+        borderIndex (Dim1Stencil _ stencil reduce z) arr =++    let !startOff = arity (undefined :: so)+        !endOff = arity (undefined :: eo)++        {-# INLINE sget #-}+        sget get =+            \ix -> V.iifoldM+                    (-startOff)+                    succ+                    (\acc i b -> do+                        a <- get (ix + i)+                        reduce acc a b)+                    z+                    stencil++        !len = extent arr+    in Convoluted+        len (touchArray arr) (force arr)+        (sget (borderIndex arr len))+        (startOff, len - endOff) (sget (linearIndex arr))+++-- | Clamps 'Dim2' index out of bounds to the nearest one inside bounds.+dim2OutClamp+    :: USource r l Dim2 a+    => UArray r l Dim2 a+    -> Dim2 -> Dim2+    -> IO a+{-# INLINE dim2OutClamp #-}+dim2OutClamp arr (shY, shX) =+    let !maxY = shY - 1+        !maxX = shX - 1+    in \(y, x) -> do+            y' <- clampM' 0 maxY y+            x' <- clampM' 0 maxX x+            index arr (y', x')++-- | Defined as+-- @dConvolveShDim2WithStaticStencil = 'convolveShDim2WithStaticStencil' 'dim2OutClamp'@+--+-- Example:+--+-- @+--let gradientX =+--        dConvolveLinearDim2WithStaticStencil+--            ['dim2St'| -1  0  1+--                     -2  0  2+--                     -1  0  1 |]+--            image+-- @+dConvolveShDim2WithStaticStencil+    :: (StencilOffsets sx sox eox, StencilOffsets sy soy eoy,+        USource r SH Dim2 a)+    => Dim2Stencil sx sy a b c  -- ^ Convolution stencil+    -> UArray r SH Dim2 a       -- ^ Source array+    -> UArray CV CVL Dim2 c     -- ^ Fused convolved result array+{-# INLINE dConvolveShDim2WithStaticStencil #-}+dConvolveShDim2WithStaticStencil =+    convolveShDim2WithStaticStencil dim2OutClamp++-- | Convolves 'Dim2' array with 'SH'aped load type with static stencil.+convolveShDim2WithStaticStencil+    :: forall r sx sox eox sy soy eoy a b c.+       (USource r SH Dim2 a,+        StencilOffsets sx sox eox, StencilOffsets sy soy eoy)+    => (UArray r SH Dim2 a -> Dim2 -> Dim2 -> IO a)+                               -- ^ (Source array -> Extent of this array ->+                               --   Index (may be out of bounds) -> Result value):+                               --   Border index (to treat indices near to bounds)+    -> Dim2Stencil sx sy a b c -- ^ Convolution stencil+    -> UArray r SH Dim2 a      -- ^ Source array+    -> UArray CV CVL Dim2 c    -- ^ Fused convolved result array+{-# INLINE convolveShDim2WithStaticStencil #-}+convolveShDim2WithStaticStencil+        borderIndex (Dim2Stencil _ _ stencil reduce z) arr =++    let !startOffX = arity (undefined :: sox)+        !endOffX = arity (undefined :: eox)+        +        !startOffY = arity (undefined :: soy)+        !endOffY = arity (undefined :: eoy)++        {-# INLINE sget #-}+        sget get =+            \ (y, x) ->+                V.iifoldM+                    (-startOffY)+                    succ+                    (\acc iy xv ->+                        V.iifoldM+                            (-startOffX)+                            succ+                            (\acc ix b -> do+                                a <- get (y + iy, x + ix)+                                reduce acc a b)+                            acc+                            xv)+                    z+                    stencil++        !sh@(shY, shX) = extent arr+        tl = (startOffY, startOffX)+        br = (shY - endOffY, shX - endOffX)++    in Convoluted+        sh (touchArray arr) (force arr)+        (sget (borderIndex arr sh)) (tl, br) (sget (index arr))++-- | Analog of 'dConvolveShDim2WithStaticStencil'+-- to convolve arrays with 'L'inear load index.+dConvolveLinearDim2WithStaticStencil+    :: (StencilOffsets sx sox eox, StencilOffsets sy soy eoy,+        USource r L Dim2 a)+    => Dim2Stencil sx sy a b c  -- ^ Convolution stencil+    -> UArray r L Dim2 a        -- ^ Source array+    -> UArray CV CVL Dim2 c     -- ^ Fused convolved result array+{-# INLINE dConvolveLinearDim2WithStaticStencil #-}+dConvolveLinearDim2WithStaticStencil =+    convolveLinearDim2WithStaticStencil dim2OutClamp++-- | Analog of 'convolveShDim2WithStaticStencil'+-- to conv+convolveLinearDim2WithStaticStencil+    :: forall r sx sox eox sy soy eoy a b c.+       (StencilOffsets sx sox eox, StencilOffsets sy soy eoy,+        USource r L Dim2 a)+    => (UArray r L Dim2 a -> Dim2 -> Dim2 -> IO a)+                               -- ^ (Source array -> Extent of this array ->+                               --   Index (may be out of bounds) -> Result value):+                               --   Border index (to treat indices near to bounds)+    -> Dim2Stencil sx sy a b c -- ^ Convolution stencil+    -> UArray r L Dim2 a       -- ^ Source array+    -> UArray CV CVL Dim2 c    -- ^ Fused convolved result array+{-# INLINE convolveLinearDim2WithStaticStencil #-}+convolveLinearDim2WithStaticStencil+        borderIndex (Dim2Stencil _ _ stencil reduce z) arr =++    let !startOffX = arity (undefined :: sox)+        !endOffX = arity (undefined :: eox)+        +        !startOffY = arity (undefined :: soy)+        !endOffY = arity (undefined :: eoy)++        {-# INLINE sget #-}+        sget get =+            \ (y, x) ->+                V.iifoldM+                    (-startOffY)+                    succ+                    (\acc iy xv ->+                        V.iifoldM+                            (-startOffX)+                            succ+                            (\acc ix b -> do+                                a <- get (y + iy, x + ix)+                                reduce acc a b)+                            acc+                            xv)+                    z+                    stencil++        !sh@(shY, shX) = extent arr++        {-# INLINE slget #-}+        slget !(!y, !x) =+            V.iifoldM+                (-startOffY)+                succ+                (\acc iy xv ->+                    let lbase = toLinear sh (y + iy, x)+                    in V.iifoldM+                        (-startOffX)+                        succ+                        (\acc ix b -> do+                            a <- linearIndex arr (lbase + ix)+                            reduce acc a b)+                        acc+                        xv)+                z+                stencil++        tl = (startOffY, startOffX)+        br = (shY - endOffY, shX - endOffX)++    in Convoluted+        sh (touchArray arr) (force arr)+        (sget (borderIndex arr sh)) (tl, br) slget+++class (Arity n, Arity so, Arity eo) =>+        StencilOffsets n so eo | n -> so eo, so eo -> n++instance StencilOffsets N1 Z Z+instance StencilOffsets N2 Z N1+instance (StencilOffsets (S n0) s0 e0) =>+        StencilOffsets (S (S (S n0))) (S s0) (S e0)
+ Data/Yarr/Eval.hs view
@@ -0,0 +1,454 @@++-- | 'Load'ing and computing arrays+module Data.Yarr.Eval (+    -- * Aliases for common parameters+    Threads, caps, threads,+    Fill,++    -- * Load classes+    Load(..), RangeLoad(..),+    VecLoad(..), RangeVecLoad(..),+    compute,++    -- * Common load types+    L, SH,++    -- * Utility+    entire++) where++import GHC.Conc++import Data.Yarr.Base as B+import Data.Yarr.Shape as S++import Data.Yarr.Utils.FixedVector as V+import Data.Yarr.Utils.Fork+import Data.Yarr.Utils.Parallel+import Data.Yarr.Utils.Primitive as P++-- | There are 2 common ways to parameterize+-- parallelism: a) to say \"split this work between @n@ threads\"+-- or b) to say \"split this work between maximum reasonable+-- number of threads\", that is /capabilities/. Since+-- 'GHC.Conc.getNumCapabilities' function is monadic, we need always pass+-- @IO Int@ as thread number parameter in order not to multiply+-- number of functions in this module (there are already too many).+type Threads = IO Int++-- | Alias to 'GHC.Conc.getNumCapabilities'.+caps :: Threads+caps = getNumCapabilities++-- | Alias to 'return'.+threads :: Int -> Threads+{-# INLINE threads #-}+threads = return++-- | This class abstracts pair of array types,+-- which could be loaded one to another.+--+-- Parameters:+--+--  * @r@ - source representation. Instance of 'USource' class.+--          Typically one of fused representations:+--          'Data.Yarr.D', @('Data.Yarr.SE' 'Data.Yarr.D')@ or+--          'Data.Yarr.Convolution.Repr.CV'.+--+--  * @l@ - source load type+--+--  * @tr@ - target representation. Instance of 'UTarget' class.+--+--  * @tl@ - target load type+--+--  * @sh@ - shape of arrays+--+--  * @a@ - array element type+--+-- Counterpart for arrays of vectors: 'VecLoad'.+--+-- /TODO:/ this class seems to be overengineered, normally+-- it should have only 3 parameters: @Load l tl sh@.+-- But Convoluted ('Data.Yarr.Convolution.Repr.CV') representation is+-- tightly connected with it's load type.+class (USource r l sh a, UTarget tr tl sh a) =>+        Load r l tr tl sh a where+    -- | Used in @fill@ parameter function.+    -- There are two options for this type to be: @sh@ itself or @Int@.+    -- Don't confuse this type with /load type indexes/: @r@ and @l@.+    -- There are 2 different meanings of word \"index\": data type index+    -- (haskell term) and array index (linear, shape).+    type LoadIndex l tl sh++    -- | /O(n)/ Entirely loads source to target in parallel.+    --+    -- First parameter is used to parameterize loop+    -- unrolling to maximize performance.+    -- Default choice is 'S.fill' -- vanilla not unrolled looping.+    -- +    -- Examples:+    --+    -- @+    -- tarr <- 'B.new' ('extent' arr)+    -- loadP 'S.fill' 'caps' arr tarr+    -- loadP ('S.dim2BlockFill' 'n2' 'n2' 'P.touch') ('threads' 2) arr tarr+    -- @+    loadP :: Fill (LoadIndex l tl sh) a -- ^ Filling (real worker) function+          -> Threads                    -- ^ Number of threads to parallelize loading on+          -> UArray r l sh a            -- ^ Source array+          -> UArray tr tl sh a          -- ^ Target array+          -> IO ()++    -- | /O(n)/ Sequential analog of 'loadP' function.+    -- Loads source to target 'entire'ly.+    -- +    -- Example:+    --+    -- @loadS ('S.unrolledFill' 'n4' 'noTouch') 'caps' arr tarr@+    loadS :: Fill (LoadIndex l tl sh) a -- ^ Filling (real worker) function+          -> UArray r l sh a            -- ^ Source array+          -> UArray tr tl sh a          -- ^ Target array+          -> IO ()++-- | Class abstracts pair of arrays which could be loaded in+-- just specified range of indices.+--+-- \"Range\" is a multidimensional+-- segment: segment for 'Dim1' arrays, square for 'Dim2' arrays and+-- cube for 'Dim3'. Thus, it is specified by pair of indices:+-- \"top-left\" (minimum is 'zero') and \"bottom-right\" (maximum is+-- @('entire' arr tarr)@) corners.+class (Load r l tr tl sh a, LoadIndex l tl sh ~ sh) =>+        RangeLoad r l tr tl sh a where++    -- | /O(n)/ Loads elements from source to target in specified range+    -- in parallel.+    -- +    -- Example:+    --+    -- @+    -- let ext = extent convolved+    -- res <- new ext+    -- rangeLoadP 'fill' 'caps' convolved res (5, 5) (ext \`minus\` (5, 5))+    -- @+    rangeLoadP+        :: Fill sh a         -- ^ Filling (real worker) function+        -> Threads           -- ^ Number of threads to parallelize loading on+        -> UArray r l sh a   -- ^ Source array+        -> UArray tr tl sh a -- ^ Target array+        -> sh                -- ^ Top-left +        -> sh                -- ^ and bottom-right corners of range to load+        -> IO ()++    -- | /O(n)/ Sequentially loads elements from source to target in specified range.+    rangeLoadS+        :: Fill sh a         -- ^ Filling (real worker) function+        -> UArray r l sh a   -- ^ Source array+        -> UArray tr tl sh a -- ^ Target array+        -> sh                -- ^ Top-left+        -> sh                -- ^ and bottom-right corners of range to load+        -> IO ()+++-- | Class abstracts /separated in time and space/ loading 'slices' of one array type+-- to another. Result of running functions with @-Slices-@ infix+-- /is always identical/ to result of running corresponding function from+-- 'Load' class. 'VecLoad' and 'RangeVecLoad' are just about performance.+-- If target representation is separate (ex. @('Data.Yarr.SE' 'Data.Yarr.F')@),+-- using 'loadSlicesP' may be faster than 'loadP' because of per-thread memory+-- locality.+--+-- Parameters:+--+--  * @r@ - source representation+--+--  * @slr@ - source slice representation+--+--  * @l@ - source load type +--+--  * @tr@ - target representation+--+--  * @tslr@ - target slice representation+--+--  * @tl@ - target load type+--+--  * @sh@ - shape of arrays+--+--  * @v@ - source vector type+--+--  * @v2@ - target vector type+--+--  * @e@ - vector element type, common for source and target arrays+--+class (UVecSource r slr l sh v e, UVecTarget tr tslr tl sh v2 e,+       Load slr l tslr tl sh e, Dim v ~ Dim v2) =>+        VecLoad r slr l tr tslr tl sh v v2 e where++    -- | /O(n)/ Entirely, slice-wise loads vectors from source to target +    -- in parallel.+    -- +    -- Example:+    --+    -- @+    -- -- blurred and delayedBlurred are arrays of color components.+    -- loadSlicesP 'fill' 'caps' delayedBlurred blurred+    -- @+    loadSlicesP+        :: Fill (LoadIndex l tl sh) e -- ^ Fill function to work /on slices/+        -> Threads                    -- ^ Number of threads to parallelize loading on+        -> UArray r l sh (v e)        -- ^ Source array of vectors+        -> UArray tr tl sh (v2 e)     -- ^ Target array of vectors+        -> IO ()++    -- | /O(n)/ Sequentially loads vectors from source to target, slice by slice.+    loadSlicesS+        :: Fill (LoadIndex l tl sh) e -- ^ Fill function to work /on slices/+        -> UArray r l sh (v e)        -- ^ Source array of vectors+        -> UArray tr tl sh (v2 e)     -- ^ Target array of vectors+        -> IO ()++-- | This class extends 'VecLoad' just like 'RangeLoad' extends 'Load'.+-- It abstracts slice-wise loading from one array type to+-- another in specified range.+class (VecLoad r slr l tr tslr tl sh v v2 e, LoadIndex l tl sh ~ sh) =>+        RangeVecLoad r slr l tr tslr tl sh v v2 e where++    -- | /O(n)/ Loads vectors from source to target in specified range, slice-wise,+    -- in parallel.+    rangeLoadSlicesP+        :: Fill sh e              -- ^ Fill function to work /on slices/+        -> Threads                -- ^ Number of threads to parallelize loading on+        -> UArray r l sh (v e)    -- ^ Source array of vectors+        -> UArray tr tl sh (v2 e) -- ^ Target array of vectors+        -> sh                     -- ^ Top-left+        -> sh                     -- ^ and bottom-right corners of range to load+        -> IO ()++    -- | /O(n)/ Sequentially loads vector elements from source to target+    -- in specified range, slice by slice.+    rangeLoadSlicesS+        :: Fill sh e              -- ^ Fill function to work /on slices/+        -> UArray r l sh (v e)    -- ^ Source array of vectors+        -> UArray tr tl sh (v2 e) -- ^ Target array of vectors+        -> sh                     -- ^ Top-left+        -> sh                     -- ^ and bottom-right corners of range to load+        -> IO ()++-- | /O(n)/ This function simplifies the most common way of loading+-- arrays.+--+-- Instead of+--+-- @+-- mTarget <- 'new' (extent source)+-- 'loadP' 'fill' 'caps' source mTarget+-- target <- 'freeze' mTarget+-- @+--+-- You can write just+--+-- @target <- compute ('loadP' 'fill' 'caps') source@+compute+    :: (USource r l sh a, Manifest tr mtr tl sh b)+    => (UArray r l sh a ->+        UArray mtr tl sh b ->+        IO ())                -- ^ Loading function+    -> UArray r l sh a        -- ^ Source array+    -> IO (UArray tr tl sh b) -- ^ Entirely loaded from the source,+                              -- 'freeze'd manifest target array+{-# INLINE compute #-}+compute load arr = do+    marr <- new (extent arr)+    load arr marr+    freeze marr++-- | Determines maximum common range of 2 arrays -+-- 'intersect'ion of their 'extent's.+entire :: (Regular r l sh a, Regular r2 l2 sh b)+       => UArray r l sh a -> UArray r2 l2 sh b -> sh+{-# INLINE entire #-}+entire arr tarr = intersect (vl_2 (extent arr) (extent tarr))++-- | Linear load type index. 'UArray's with 'L' load type index+-- define 'linearIndex' and 'linearWrite' and leave 'index' and 'write'+-- functions defined by default.+data L++instance (USource r L sh a, UTarget tr L sh a) => Load r L tr L sh a where++    type LoadIndex L L sh = Int+    +    loadP lfill threads arr tarr = do+        force arr+        force tarr+        !ts <- threads+        parallel_ ts $+            makeFork ts 0 (size (extent arr))+                     (lfill (linearIndex arr) (linearWrite tarr))+        touchArray arr+        touchArray tarr++    loadS lfill arr tarr = do+        force arr+        force tarr+        lfill (linearIndex arr) (linearWrite tarr) 0 (size (extent arr))+        touchArray arr+        touchArray tarr++    {-# INLINE loadP #-}+    {-# INLINE loadS #-}++instance (UVecSource r slr L sh v e, UVecTarget tr tslr L sh v2 e,+          Load slr L tslr L sh e, Dim v ~ Dim v2) =>+        VecLoad r slr L tr tslr L sh v v2 e where+    loadSlicesP lfill threads arr tarr = do+        force arr+        force tarr+        !ts <- threads+        parallel_ ts $+            makeForkSlicesOnce+                ts (V.replicate (0, size (extent arr)))+                (V.zipWith+                    (\sl tsl -> lfill (linearIndex sl) (linearWrite tsl))+                    (slices arr) (slices tarr))+        touchArray arr+        touchArray tarr++    loadSlicesS lfill arr tarr = do+        force arr+        force tarr+        V.zipWithM_ (loadS lfill) (slices arr) (slices tarr)+        touchArray arr+        touchArray tarr++    {-# INLINE loadSlicesP #-}+    {-# INLINE loadSlicesS #-}++-- | General shape load type index. 'UArray's with 'SH' load type index+-- specialize 'index' and 'write' and leave 'linearIndex' and 'linearWrite'+-- functions defined by default.+-- +-- Type-level distinction between 'L'inear and 'SH'aped arrays+-- is aimed to avoid integral division operations while looping+-- through composite ('Dim2', 'Dim3') indices.+--+-- Integral division is very expensive operation even on modern CPUs.+data SH++#define SH_LOAD_INST(l,tl)                                               \+instance (USource r l sh a, UTarget tr tl sh a) =>                       \+        Load r l tr tl sh a where {                                      \+    type LoadIndex l tl sh = sh;                                         \+    loadP fill threads arr tarr =                                        \+        shRangeLoadP fill threads arr tarr zero (entire arr tarr);       \+    loadS fill arr tarr =                                                \+        shRangeLoadS fill arr tarr zero (entire arr tarr);               \+    {-# INLINE loadP #-};                                                \+    {-# INLINE loadS #-};                                                \+};                                                                       \+instance (USource r l sh a, UTarget tr tl sh a) =>                       \+        RangeLoad r l tr tl sh a where {                                 \+    rangeLoadP = shRangeLoadP;                                           \+    rangeLoadS = shRangeLoadS;                                           \+    {-# INLINE rangeLoadP #-};                                           \+    {-# INLINE rangeLoadS #-};                                           \+};                                                                       \+instance (UVecSource r slr l sh v e, UVecTarget tr tslr tl sh v2 e,      \+          Load slr l tslr tl sh e, Dim v ~ Dim v2) =>                    \+        VecLoad r slr l tr tslr tl sh v v2 e where {                     \+    loadSlicesP fill threads arr tarr =                                  \+        shRangeLoadSlicesP fill threads arr tarr zero (entire arr tarr); \+    loadSlicesS fill arr tarr =                                          \+        shRangeLoadSlicesS fill arr tarr zero (entire arr tarr);         \+    {-# INLINE loadSlicesP #-};                                          \+    {-# INLINE loadSlicesS #-};                                          \+};                                                                       \+instance (UVecSource r slr l sh v e, UVecTarget tr tslr tl sh v2 e,      \+          Load slr l tslr tl sh e, Dim v ~ Dim v2) =>                    \+        RangeVecLoad r slr l tr tslr tl sh v v2 e where {                \+    rangeLoadSlicesP = shRangeLoadSlicesP;                               \+    rangeLoadSlicesS = shRangeLoadSlicesS;                               \+    {-# INLINE rangeLoadSlicesP #-};                                     \+    {-# INLINE rangeLoadSlicesS #-};                                     \+}++SH_LOAD_INST(SH,L)+SH_LOAD_INST(L,SH)+SH_LOAD_INST(SH,SH)+++shRangeLoadP+    :: (USource r l sh a, UTarget tr tl sh a)+    => Fill sh a+    -> Threads+    -> UArray r l sh a+    -> UArray tr tl sh a+    -> sh -> sh+    -> IO ()+{-# INLINE shRangeLoadP #-}+shRangeLoadP fill threads arr tarr start end = do+    force arr+    force tarr+    !ts <- threads+    parallel_ ts $+        makeFork ts start end (fill (index arr) (write tarr))+    touchArray arr+    touchArray tarr++shRangeLoadS+    :: (USource r l sh a, UTarget tr tl sh a)+    => Fill sh a+    -> UArray r l sh a+    -> UArray tr tl sh a+    -> sh -> sh+    -> IO ()+{-# INLINE shRangeLoadS #-}+shRangeLoadS fill arr tarr start end = do+    force arr+    force tarr+    fill (index arr) (write tarr) start end+    touchArray arr+    touchArray tarr+++shRangeLoadSlicesP+    :: (UVecSource r slr l sh v e, UVecTarget tr tslr tl sh v2 e,+        Dim v ~ Dim v2)+    => Fill sh e+    -> Threads+    -> UArray r l sh (v e)+    -> UArray tr tl sh (v2 e)+    -> sh -> sh+    -> IO ()+{-# INLINE shRangeLoadSlicesP #-}+shRangeLoadSlicesP fill threads arr tarr start end = do+    force arr+    force tarr+    !ts <- threads+    parallel_ ts $+        makeForkSlicesOnce+            ts (V.replicate (start, end))+            (V.zipWith+                (\sl tsl -> fill (index sl) (write tsl))+                (slices arr) (slices tarr))+    touchArray arr+    touchArray tarr++shRangeLoadSlicesS+    :: (UVecSource r slr l sh v e, UVecTarget tr tslr tl sh v2 e,+        Dim v ~ Dim v2)+    => Fill sh e+    -> UArray r l sh (v e)+    -> UArray tr tl sh (v2 e)+    -> sh -> sh+    -> IO ()+{-# INLINE shRangeLoadSlicesS #-}+shRangeLoadSlicesS fill arr tarr start end = do+    force arr+    force tarr+    V.zipWithM_+        (\sl tsl -> shRangeLoadS fill sl tsl start end)+        (slices arr) (slices tarr)+    touchArray arr+    touchArray tarr
+ Data/Yarr/Flow.hs view
@@ -0,0 +1,130 @@++-- | Dataflow (fusion operations)+module Data.Yarr.Flow (+    -- * Basic fusion+    DefaultFusion(..),++    -- ** 'D'elayed flow and zipping shortcuts+    dzipWith, dzipWith3, D, delay,++    -- * Vector fusion+    SE, dmapElems, dmapElemsM,+    dzipElems2, dzipElems2M, dzipElems3, dzipElems3M,+    dzipElems, dzipElemsM,++    -- * High level shortcuts+    traverse, zipElems, mapElems, mapElemsM+) where++import Data.Yarr.Base+import Data.Yarr.Repr.Delayed+import Data.Yarr.Repr.Separate+import Data.Yarr.Utils.FixedVector as V++-- | /O(1)/ Function from @repa@.+traverse+    :: (USource r l sh a, Shape sh')+    => (sh -> sh')         -- ^ Function to produce result extent+                           -- from source extent.+    -> ((sh -> IO a) -> sh' -> IO b)+                           -- ^ Function to produce elements of result array.+                           -- Passed a lookup function+                           -- to get elements of the source.+    -> UArray r l sh a     -- ^ Source array itself+    -> UArray D SH sh' b   -- ^ Result array+{-# INLINE traverse #-}+traverse transformShape newElem arr =+    ShapeDelayed+        (transformShape (extent arr))+        (touchArray arr) (force arr)+        (newElem (index arr))++-- | /O(1)/ Function for in-place zipping vector elements.+-- +-- Always true:+--+-- @zipElems f arr == 'dzip' ('Fun' f) ('slices' arr)@+--+-- Example:+--+-- @let φs = zipElems ('flip' 'atan2') coords@+zipElems+    :: (Vector v a,+        USource r l sh (v a), USource fr l sh b, DefaultFusion r fr l)+    => Fn (Dim v) a b      -- ^ Unwrapped @n@-ary zipper function+    -> UArray r l sh (v a) -- ^ Source array of vectors+    -> UArray fr l sh b    -- ^ Result array+{-# INLINE zipElems #-}+zipElems fn arr = dmap (\v -> inspect v (Fun fn)) arr++-- | /O(1)/ Maps elements of vectors in array uniformly.+-- Don't confuse with 'dmapElems', which accepts a vector of mapper+-- for each slice.+-- +-- Typical use case -- type conversion:+--+-- @+-- let floatImage :: UArray F Dim2 Float+--     floatImage = mapElems 'fromIntegral' word8Image+-- @+mapElems+    :: (VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, DefaultFusion slr fslr l,+        Vector v b)+    => (a -> b)                     -- ^ Mapper function for all elements+    -> UArray r l sh (v a)          -- ^ Source array of vectors+    -> UArray (SE fslr) l sh (v b)  -- ^ Fused array of vectors+{-# INLINE mapElems #-}+mapElems f = dmapElems (V.replicate f)++-- | /O(1)/ Monadic version of 'mapElems' function.+-- Don't confuse with 'dmapElemsM'.+--+-- Example:+--+-- @let domained = mapElemsM ('Data.Yarr.Utils.Primitive.clampM' 0.0 1.0) floatImage@+mapElemsM+    :: (VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, DefaultFusion slr fslr l,+        Vector v b)+    => (a -> IO b)                 -- ^ Monadic mapper for all vector elements+    -> UArray r l sh (v a)         -- ^ Source array of vectors+    -> UArray (SE fslr) l sh (v b) -- ^ Fused array of vectors+{-# INLINE mapElemsM #-}+mapElemsM f = dmapElemsM (V.replicate f)++-- | /O(1)/ Generalized zipping of 2 arrays.+--+-- Main basic \"zipWith\" in Yarr.+--+-- Although sighature of this function has extremely big predicate,+-- it is more permissible than 'dzip2' counterpart, because source arrays+-- shouldn't be of the same type.+--+-- Implemented by means of 'delay' function (source arrays are simply+-- delayed before zipping).+dzipWith+    :: (USource r1 l sh a, DefaultFusion r1 D l, USource D l sh a,+        USource r2 l sh b, DefaultFusion r2 D l, USource D l sh b,+        USource D l sh c, DefaultFusion D D l)+    => (a -> b -> c)    -- ^ Pure zipping function+    -> UArray r1 l sh a -- ^ 1st source array+    -> UArray r2 l sh b -- ^ 2nd source array+    -> UArray D l sh c  -- ^ Fused result array+{-# INLINE dzipWith #-}+dzipWith f arr1 arr2 = dzip2 f (delay arr1) (delay arr2)++-- | /O(1)/ Generalized zipping of 3 arrays, which shouldn't be+-- of the same representation type.+dzipWith3+    :: (USource r1 l sh a, DefaultFusion r1 D l, USource D l sh a,+        USource r2 l sh b, DefaultFusion r2 D l, USource D l sh b,+        USource r3 l sh c, DefaultFusion r3 D l, USource D l sh c,+        USource D l sh d, DefaultFusion D D l)+    => (a -> b -> c -> d) -- ^ Pure zipping function+    -> UArray r1 l sh a   -- ^ 1st source array+    -> UArray r2 l sh b   -- ^ 2nd source array+    -> UArray r3 l sh c   -- ^ 3rd source array+    -> UArray D l sh d    -- ^ Result array+{-# INLINE dzipWith3 #-}+dzipWith3 f arr1 arr2 arr3 = dzip3 f (delay arr1) (delay arr2) (delay arr3)
+ Data/Yarr/Repr/Boxed.hs view
@@ -0,0 +1,78 @@++module Data.Yarr.Repr.Boxed where++import Control.Monad.ST (RealWorld)+import Data.Primitive.Array++import Data.Yarr.Base hiding (fmap)+import Data.Yarr.Shape+import Data.Yarr.Repr.Delayed+import Data.Yarr.Repr.Separate++-- | 'B'oxed representation is a wrapper for 'Data.Primitive.Array.Array'+-- from @primitive@ package. It may be used to operate with arrays+-- of variable-lengths or multiconstructor ADTs, for example, lists.+-- +-- For 'Foreign.Storable' element types you would better use+-- 'Data.Yarr.Repr.Foreign.F'oreign arrays.+--+-- /TODO:/ test this representation at least one time...+data B++instance (Shape sh, NFData a) => Regular B L sh a where++    data UArray B L sh a = Boxed !sh !(Array a)++    extent (Boxed sh _) = sh+    touchArray _ = return ()++    {-# INLINE extent #-}+    {-# INLINE touchArray #-}++instance (Shape sh, NFData a) => NFData (UArray B L sh a) where+    rnf (Boxed sh !arr) = sh `deepseq` arr `seq` ()++instance (Shape sh, NFData a) => USource B L sh a where+    linearIndex (Boxed _ arr) = indexArrayM arr+    {-# INLINE linearIndex #-}++instance DefaultFusion B D L++instance (Shape sh, Vector v e, NFData e) => UVecSource (SE B) B L sh v e++-- | Mutable Boxed is a wrapper for 'Data.Primitive.Array.MutableArray'.+data MB++instance (Shape sh, NFData a) => Regular MB L sh a where++    data UArray MB L sh a = MutableBoxed !sh !(MutableArray RealWorld a)++    extent (MutableBoxed sh _) = sh+    touchArray _ = return ()++    {-# INLINE extent #-}+    {-# INLINE touchArray #-}++instance (Shape sh, NFData a) => NFData (UArray MB L sh a) where+    rnf (MutableBoxed sh !marr) = sh `deepseq` marr `seq` ()++instance (Shape sh, NFData a) => USource MB L sh a where+    linearIndex (MutableBoxed _ marr) = readArray marr+    {-# INLINE linearIndex #-}++instance DefaultFusion MB D L++instance (Shape sh, Vector v e, NFData e) => UVecSource (SE MB) MB L sh v e++instance (Shape sh, NFData a) => UTarget MB L sh a where+    linearWrite (MutableBoxed _ marr) i x = do+        x `deepseq` return ()+        writeArray marr i x+    {-# INLINE linearWrite #-}++instance (Shape sh, NFData a) => Manifest B MB L sh a where+    new sh = fmap (MutableBoxed sh) (newArray (size sh) uninitialized)+    freeze (MutableBoxed sh marr) = fmap (Boxed sh) (unsafeFreezeArray marr)+    thaw (Boxed sh arr) = fmap (MutableBoxed sh) (unsafeThawArray arr)++uninitialized = error "Yarr! Uninitialized element in the boxed array"
+ Data/Yarr/Repr/Checked.hs view
@@ -0,0 +1,79 @@++module Data.Yarr.Repr.Checked where++import Text.Printf++import Data.Yarr.Base hiding (fmap)+import Data.Yarr.Shape+import Data.Yarr.Utils.FixedVector as V+++data CHK r++instance Regular r l sh a => Regular (CHK r) l sh a where+    newtype UArray (CHK r) l sh a = Checked { unchecked :: UArray r l sh a }++    extent = extent . unchecked+    touchArray = touchArray . unchecked++    {-# INLINE extent #-}+    {-# INLINE touchArray #-}++instance NFData (UArray r l sh a) => NFData (UArray (CHK r) l sh a) where+    rnf = rnf . unchecked+    {-# INLINE rnf #-}++instance VecRegular r slr l sh v e =>+        VecRegular (CHK r) (CHK slr) l sh v e where+    slices = V.map Checked . slices . unchecked+    {-# INLINE slices #-}+++instance USource r l sh a => USource (CHK r) l sh a where+    index (Checked arr) sh =+        let ext = extent arr+        in if not (insideBlock (zero, ext) sh)+            then error $ printf+                            "Yarr! Index %s is out of extent - %s"+                            (show sh) (show ext)+            else index arr sh++    linearIndex (Checked arr) i =+        let sz = size (extent arr)+        in if not (insideBlock (0, sz) i)+            then error $ printf "Yarr! Linear index %d is out of size - %d" i sz+            else linearIndex arr i++    {-# INLINE index #-}+    {-# INLINE linearIndex #-}++instance UVecSource r slr l sh v e =>+        UVecSource (CHK r) (CHK slr) l sh v e where+++instance UTarget tr tl sh a => UTarget (CHK tr) tl sh a where+    write (Checked arr) sh =+        let ext = extent arr+        in if not (insideBlock (zero, ext) sh)+            then error $ printf+                            "Yarr! Writing: index %s is out of extent - %s"+                            (show sh) (show ext)+            else write arr sh++    linearWrite (Checked arr) i =+        let sz = size (extent arr)+        in if not (insideBlock (0, sz) i)+            then error $ printf "Yarr! Writing: linear index %d is out of size - %d" i sz+            else linearWrite arr i+    {-# INLINE write #-}+    {-# INLINE linearWrite #-}++instance Manifest r mr l sh a => Manifest (CHK r) (CHK mr) l sh a where+    new sh = fmap Checked (new sh)+    freeze (Checked marr) = fmap Checked (freeze marr)+    thaw (Checked arr) = fmap Checked (thaw arr)+    {-# INLINE new #-}+    {-# INLINE freeze #-}+    {-# INLINE thaw #-}++instance UVecTarget tr tslr l sh v e => UVecTarget (CHK tr) (CHK tslr) l sh v e
+ Data/Yarr/Repr/Delayed.hs view
@@ -0,0 +1,261 @@++module Data.Yarr.Repr.Delayed (+    -- * Delayed source+    D,+    Regular,+    UArray(LinearDelayed, ShapeDelayed, ShapeDelayedTarget),+    L, SH, delay, delayShaped,+    -- * Delayed target+    DT,++    +) where++import Prelude as P+import Control.Monad++import Data.Yarr.Base as B+import Data.Yarr.Eval+import Data.Yarr.Shape+import Data.Yarr.Utils.FixedVector as V++-- | Delayed representation is a wrapper for arbitrary indexing function.+--+-- @'UArray' D 'L' sh a@ instance holds linear getter (@(Int -> IO a)@),+-- and @'UArray' D 'SH' sh a@ - shaped, \"true\" @(sh -> IO a)@ index, respectively.+--+-- @D@elayed arrays are most common recipients for fusion operations.+data D++instance Shape sh => Regular D L sh a where++    data UArray D L sh a =+        LinearDelayed+            !sh           -- Extent+            (IO ())       -- Array touch+            (IO ())       -- Inherited force+            (Int -> IO a) -- Linear get++    extent (LinearDelayed sh _ _ _) = sh+    touchArray (LinearDelayed _ tch _ _) = tch+    force (LinearDelayed sh _ iforce _) =+        (sh `deepseq` return ()) >> iforce++    {-# INLINE extent #-}+    {-# INLINE touchArray #-}+    {-# INLINE force #-}++instance Shape sh => NFData (UArray D L sh a) where+    rnf (LinearDelayed sh tch iforce lget) =+        sh `deepseq` tch `seq` iforce `seq` lget `seq` ()+    {-# INLINE rnf #-}++instance Shape sh => USource D L sh a where+    linearIndex (LinearDelayed _ _ _ lget) = lget+    {-# INLINE linearIndex #-}+++instance (Shape sh, Vector v e) => VecRegular D D L sh v e where+    slices (LinearDelayed sh tch iforce lget) =+        V.generate+            (\i -> LinearDelayed sh tch iforce ((return . (V.! i)) <=< lget))+    {-# INLINE slices #-}++instance (Shape sh, Vector v e) => UVecSource D D L sh v e++instance Fusion r D L where+    fmapM f arr =+        LinearDelayed+            (extent arr) (touchArray arr) (force arr) (f <=< linearIndex arr)++    fzip2M f arr1 arr2 =+        let sh = intersect (vl_2 (extent arr1) (extent arr2))+            tch = touchArray arr1 >> touchArray arr2+            iforce = force arr1 >> force arr2++            {-# INLINE lget #-}+            lget i = do+                v1 <- linearIndex arr1 i+                v2 <- linearIndex arr2 i+                f v1 v2++        in LinearDelayed sh tch iforce lget++    fzip3M f arr1 arr2 arr3 =+        let sh = intersect (vl_3 (extent arr1) (extent arr2) (extent arr3))+            tch = touchArray arr1 >> touchArray arr2 >> touchArray arr3+            iforce = force arr1 >> force arr2 >> force arr3++            {-# INLINE lget #-}+            lget i = do+                v1 <- linearIndex arr1 i+                v2 <- linearIndex arr2 i+                v3 <- linearIndex arr3 i+                f v1 v2 v3++        in LinearDelayed sh tch iforce lget++    fzipM fun arrs =+        let shapes = V.map extent arrs+            sh = V.head shapes++            tch = V.mapM_ touchArray arrs++            iforce = V.mapM_ force arrs++            lgets = V.map linearIndex arrs+            {-# INLINE lget #-}+            lget i = do+                v <- V.mapM ($ i) lgets+                inspect v fun++        in if V.all (== sh) shapes+                then LinearDelayed sh tch iforce lget+                else error ("Yarr! All arrays in linear zip " +++                            "must be of the same extent")++    {-# INLINE fmapM #-}+    {-# INLINE fzip2M #-}+    {-# INLINE fzip3M #-}+    {-# INLINE fzipM #-}++instance DefaultFusion D D L++++instance Shape sh => Regular D SH sh a where++    data UArray D SH sh a =+        ShapeDelayed+            !sh           -- Extent+            (IO ())       -- Array touch+            (IO ())       -- Inherited force+            (sh -> IO a)  -- Shape get++    extent (ShapeDelayed sh _ _ _) = sh+    touchArray (ShapeDelayed _ tch _ _) = tch+    force (ShapeDelayed sh _ iforce _) = (sh `deepseq` return ()) >> iforce++    {-# INLINE extent #-}+    {-# INLINE touchArray #-}+    {-# INLINE force #-}++instance Shape sh => NFData (UArray D SH sh a) where+    rnf (ShapeDelayed sh tch iforce get) =+        sh `deepseq` tch `seq` iforce `seq` get `seq` ()+    {-# INLINE rnf #-}++instance Shape sh => USource D SH sh a where+    index (ShapeDelayed _ _ _ get) = get+    {-# INLINE index #-}+++instance (Shape sh, Vector v e) => VecRegular D D SH sh v e where+    slices (ShapeDelayed sh tch iforce get) =+        V.generate+            (\i -> ShapeDelayed sh tch iforce ((return . (V.! i)) <=< get))+    {-# INLINE slices #-}++instance (Shape sh, Vector v e) => UVecSource D D SH sh v e++instance Fusion r D SH where+    fmapM f arr =+        ShapeDelayed+            (extent arr) (touchArray arr) (force arr) (f <=< index arr)++    fzip2M f arr1 arr2 =+        let sh = intersect (vl_2 (extent arr1) (extent arr2))+            tch = touchArray arr1 >> touchArray arr2+            iforce = force arr1 >> force arr2++            {-# INLINE get #-}+            get sh = do+                v1 <- index arr1 sh+                v2 <- index arr2 sh+                f v1 v2++        in ShapeDelayed sh tch iforce get++    fzip3M f arr1 arr2 arr3 =+        let sh = intersect (vl_3 (extent arr1) (extent arr2) (extent arr3))+            tch = touchArray arr1 >> touchArray arr2 >> touchArray arr3+            iforce = force arr1 >> force arr2 >> force arr3++            {-# INLINE get #-}+            get sh = do+                v1 <- index arr1 sh+                v2 <- index arr2 sh+                v3 <- index arr3 sh+                f v1 v2 v3++        in ShapeDelayed sh tch iforce get++    fzipM fun arrs =+        let shapes = V.map extent arrs+            sh = intersect shapes++            tch = V.mapM_ touchArray arrs++            iforce = V.mapM_ force arrs++            gets = V.map index arrs+            {-# INLINE get #-}+            get sh = do+                v <- V.mapM ($ sh) gets+                inspect v fun++        in ShapeDelayed sh tch iforce get++    {-# INLINE fmapM #-}+    {-# INLINE fzip2M #-}+    {-# INLINE fzip3M #-}+    {-# INLINE fzipM #-}++instance DefaultFusion D D SH++-- | Load type preserving wrapping arbirtary array into 'D'elayed representation.+delay :: (USource r l sh a, USource D l sh a, Fusion r D l)+      => UArray r l sh a -> UArray D l sh a+{-# INLINE delay #-}+delay = B.fmap id++-- | Wraps @('index' arr)@ into Delayed representation. Normally you shouldn't need+-- to use this function. It may be dangerous for performance, because+-- preferred 'Data.Yarr.Eval.Load'ing type of source array is ignored.+delayShaped :: USource r l sh a => UArray r l sh a -> UArray D SH sh a+{-# INLINE delayShaped #-}+delayShaped arr =+    ShapeDelayed (extent arr) (touchArray arr) (force arr) (index arr)++-- | In opposite to 'D'elayed (source) Delayed Target holds abstract /writing/+-- function: @(sh -> a -> IO ())@. It may be used to perform arbitrarily tricky+-- things, because no one obliges you to indeed write+-- an element inside wrapped function.+data DT++instance Shape sh => Regular DT SH sh a where++    data UArray DT SH sh a =+        ShapeDelayedTarget+            !sh                -- Extent+            (IO ())            -- Array touch+            (IO ())            -- Inherited force+            (sh -> a -> IO ()) -- Shape write++    extent (ShapeDelayedTarget sh _ _ _) = sh+    touchArray (ShapeDelayedTarget _ tch _ _) = tch+    force (ShapeDelayedTarget sh _ iforce _) =+        (sh `deepseq` return ()) >> iforce++    {-# INLINE extent #-}+    {-# INLINE touchArray #-}+    {-# INLINE force #-}++instance Shape sh => NFData (UArray DT SH sh a) where+    rnf (ShapeDelayedTarget sh tch iforce wr) =+        sh `deepseq` tch `seq` iforce `seq` wr `seq` ()+    {-# INLINE rnf #-}++instance Shape sh => UTarget DT SH sh a where+    write (ShapeDelayedTarget _ _ _ wr) = wr+    {-# INLINE write #-}
+ Data/Yarr/Repr/Foreign.hs view
@@ -0,0 +1,199 @@++module Data.Yarr.Repr.Foreign (+    F, Storable, L,+    newEmpty,+    toForeignPtr, unsafeFromForeignPtr,+    FS,+) where++import Foreign+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Marshal.MissingAlloc++import Data.Yarr.Base as B+import Data.Yarr.Repr.Delayed+import Data.Yarr.Repr.Separate+import Data.Yarr.Shape++import Data.Yarr.Utils.Storable+import Data.Yarr.Utils.FixedVector as V++-- | Foreign representation is the heart of Yarr framework.+--+-- Internally it holds raw pointer ('Ptr'), which makes indexing+-- foreign arrays not slower than GHC's built-in primitive arrays,+-- but without freeze/thaw boilerplate.+--+-- Foreign arrays are very permissible, for example you can easily+-- use them as source and target of 'Data.Yarr.Eval.Load'ing operation simultaneously,+-- achieving old good in-place @C-@style array modifying:+--+-- @'Data.Yarr.Eval.loadS' 'fill' ('dmap' 'sqrt' arr) arr@+--+-- Foreign arrays are intented to hold all 'Storable' types and+-- vectors of them (because there is a conditional instance of 'Storalbe'+-- class for 'Vector's of 'Storable's too).+data F++instance Shape sh => Regular F L sh a where++    data UArray F L sh a =+        ForeignArray+            !sh              -- Extent+            {-# NOUNPACK #-}+            !(ForeignPtr a)  -- Foreign ptr for GC+            !(Ptr a)         -- Plain ptr for fast memory access+    +    extent (ForeignArray sh _ _) = sh+    touchArray (ForeignArray _ fptr _) = touchForeignPtr fptr+    +    {-# INLINE extent #-}+    {-# INLINE touchArray #-}    ++instance Shape sh => NFData (UArray F L sh a) where+    rnf (ForeignArray sh fptr ptr) = sh `deepseq` fptr `seq` ptr `seq` ()++instance (Shape sh, Storable a) => USource F L sh a where+    linearIndex (ForeignArray _ _ ptr) i = peekElemOff ptr i+    {-# INLINE linearIndex #-}++instance DefaultFusion F D L++-- | Foreign Slice representation, /view/ slice representation+-- for 'F'oreign arrays.+--+-- To understand Foreign Slices,+-- suppose you have standard @image@ array of+-- @'UArray' 'F' 'Dim2' ('VecList' 'N3' Word8)@ type.+--+-- It's layout in memory (with array indices):+--+-- @+--  r g b | r g b | r g b | ...+-- (0, 0)  (0, 1)  (0, 2)   ...+-- @+--+-- @+-- let (VecList [reds, greens, blues]) = 'slices' image+-- -- reds, greens, blues :: UArray FS Dim2 Word8+-- @+--+-- Now @blues@ just indexes each third byte on the same underlying+-- memory block:+--+-- @+-- ... b | ... b | ... b | ...+--   (0, 0)  (0, 1)  (0, 2)...+-- @+data FS++instance Shape sh => Regular FS L sh e where++    data UArray FS L sh e =+        ForeignSlice+            !sh              -- Extent+            !Int             -- Size of a vector in the parent array (in bytes)+            {-# NOUNPACK #-}+            !(ForeignPtr e)  -- Foreign ptr for GC+            !(Ptr e)         -- Plain ptr for fast memory access+    +    extent (ForeignSlice sh _ _ _) = sh+    touchArray (ForeignSlice _ _ fptr _) = touchForeignPtr fptr+    +    {-# INLINE extent #-}+    {-# INLINE touchArray #-}++instance Shape sh => NFData (UArray FS L sh e) where+    rnf (ForeignSlice sh vsize fptr ptr) =+        sh `deepseq` vsize `seq` fptr `seq` ptr `seq` ()++instance (Shape sh, Storable e) => USource FS L sh e where+    linearIndex (ForeignSlice _ vsize _ ptr) i = peekByteOff ptr (i * vsize)+    {-# INLINE linearIndex #-}++instance DefaultFusion FS D L+++instance (Shape sh, Vector v e, Storable e) => VecRegular F FS L sh v e where+    slices (ForeignArray sh fptr ptr) =+        let esize = sizeOf (undefined :: e)+            vsize = sizeOf (undefined :: (v e))+            eptr = castPtr ptr+            feptr = castForeignPtr fptr+        in V.generate $ \i ->+            ForeignSlice sh vsize feptr (eptr `plusPtr` (i * esize))+    {-# INLINE slices #-}++instance (Shape sh, Vector v e, Storable e) => UVecSource F FS L sh v e++instance (Shape sh, Vector v e, Storable e) => UVecSource (SE F) F L sh v e+++instance (Shape sh, Storable a) => UTarget F L sh a where+    linearWrite (ForeignArray _ _ ptr) i x = pokeElemOff ptr i x+    {-# INLINE linearWrite #-}++instance (Shape sh, Storable a) => Manifest F F L sh a where+    new sh = do+        arr <- internalNew mallocBytes sh+        arr `deepseq` return ()+        return arr++    freeze = return+    thaw = return+    +    {-# INLINE new #-}+    {-# INLINE freeze #-}+    {-# INLINE thaw #-}++-- | /O(1)/ allocates zero-initialized foreign array.+-- +-- Needed because common 'new' function allocates array with garbage.+newEmpty :: (Shape sh, Storable a, Integral a) => sh -> IO (UArray F L sh a)+{-# INLINE newEmpty #-}+newEmpty sh = do+    arr <- internalNew callocBytes sh+    arr `deepseq` return ()+    return arr++internalNew+    :: forall sh a. (Shape sh, Storable a)+    => (Int -> IO (Ptr a)) -> sh -> IO (UArray F L sh a)+{-# NOINLINE internalNew #-}+internalNew allocBytes sh = do+    let len = size sh+    ptr <- allocBytes (len * sizeOf (undefined :: a))+    fptr <- newForeignPtr finalizerFree (castPtr ptr)+    return $ ForeignArray sh fptr ptr+++instance (Shape sh, Storable e) => UTarget FS L sh e where+    linearWrite (ForeignSlice _ vsize _ ptr) i x =+        pokeByteOff ptr (i * vsize) x+    {-# INLINE linearWrite #-}++instance (Shape sh, Vector v e, Storable e) => UVecTarget F FS L sh v e++-- | /O(1)/ Returns pointer to memory block used by the given foreign+-- array.+--+-- May be useful to reuse memory if you don't longer need the given array+-- in the program:+--+-- @+-- brandNewData <-+--    'unsafeFromForeignPtr' ext ('castForeignPtr' (toForeignPtr arr))+-- @+toForeignPtr :: Shape sh => UArray F L sh a -> ForeignPtr a+{-# INLINE toForeignPtr #-}+toForeignPtr (ForeignArray _ fptr _) = fptr++-- | /O(1)/ Wraps foreign ptr into foreign array.+-- +-- The function is unsafe because it simply don't (and can't)+-- check anything about correctness of produced array.+unsafeFromForeignPtr :: Shape sh => sh -> ForeignPtr a -> IO (UArray F L sh a)+{-# INLINE unsafeFromForeignPtr #-}+unsafeFromForeignPtr sh fptr =+    withForeignPtr fptr (\ptr -> return $ ForeignArray sh fptr ptr)
+ Data/Yarr/Repr/Separate.hs view
@@ -0,0 +1,384 @@++module Data.Yarr.Repr.Separate (+    -- * Separate representation+    SE, fromSlices, unsafeMapSlices,+    Data.Yarr.Repr.Separate.convert,++    -- * Element-wise fusion for arrays of vectors+    dmapElems, dmapElemsM,+    dzipElems2, dzipElems2M, dzipElems3, dzipElems3M,+    dzipElems, dzipElemsM,++    -- * Non-injective element-wise fusion+    fmapElems, fmapElemsM,+    fzipElems2, fzipElems2M, fzipElems3, fzipElems3M,+    fzipElems, fzipElemsM+) where++import Prelude as P+import Data.Functor ((<$>))++import Data.Yarr.Base as B+import Data.Yarr.Shape+import Data.Yarr.Repr.Delayed+import Data.Yarr.Utils.FixedVector as V++-- | SEparate meta array representation. Internally SEparate arrays+-- hold vector of it's slices (so, 'slices' is just getter for them).+--+-- Mostly useful for:+--+--  * Separate in memory manifest 'Data.Yarr.F'oreign arrays (\"Unboxed\" arrays+--    in @vector@/@repa@ libraries terms).+-- +--  * Element-wise vector array fusion (see group of 'dmapElems' functions).+data SE r++instance (Regular r l sh e, Vector v e) => Regular (SE r) l sh (v e) where++    data UArray (SE r) l sh (v e) =+        Separate !sh (VecList (Dim v) (UArray r l sh e))++    extent (Separate sh _) = sh+    touchArray (Separate _ slices) = V.mapM_ touchArray slices+    force (Separate sh slices) = do+        sh `deepseq` return ()+        V.mapM_ force slices++    {-# INLINE extent #-}+    {-# INLINE touchArray #-}+    {-# INLINE force #-}++instance (NFData (UArray r l sh e), Shape sh, Vector v e) =>+        NFData (UArray (SE r) l sh (v e)) where+    rnf (Separate sh slices) = sh `deepseq` slices `deepseq` ()++instance (Regular r l sh e, Shape sh, Vector v e) =>+        VecRegular (SE r) r l sh v e where+    slices (Separate _ slices) = slices+    {-# INLINE slices #-}+++instance (USource r l sh e, Vector v e) => USource (SE r) l sh (v e) where+    index (Separate _ slices) sh =+        V.convert <$> V.mapM (\el -> index el sh) slices+    linearIndex (Separate _ slices) i =+        V.convert <$> V.mapM (\el -> linearIndex el i) slices+    {-# INLINE index #-}+    {-# INLINE linearIndex #-}++instance (USource r l sh e, Vector v e) => UVecSource (SE r) r l sh v e++instance (DefaultFusion r D l, Fusion (SE r) D l) => DefaultFusion (SE r) D l+++-- | Group of @f-...-Elems-@ functions is used internally to define+-- @d-...-Elems-@ functions.+fmapElems+    :: (VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, Fusion slr fslr l,+        Vector v2 b, Dim v ~ Dim v2)+    => VecList (Dim v) (a -> b) -- ^ .+    -> UArray r l sh (v a)+    -> UArray (SE fslr) l sh (v2 b)+fmapElems fs = fmapElemsM $ V.map (return .) fs++fmapElemsM+    :: (VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, Fusion slr fslr l,+        Vector v2 b, Dim v ~ Dim v2)+    => VecList (Dim v) (a -> IO b) -- ^ .+    -> UArray r l sh (v a)+    -> UArray (SE fslr) l sh (v2 b)+fmapElemsM fs arr = Separate (extent arr) $ V.zipWith fmapM fs (slices arr)+++fzipElems2+    :: (VecRegular r slr l sh v a, USource slr l sh a,+        VecRegular r slr l sh v b, USource slr l sh b,+        USource fslr l sh c, Fusion slr fslr l, Vector v c)+    => VecList (Dim v) (a -> b -> c) -- ^ .+    -> UArray r l sh (v a)+    -> UArray r l sh (v b)+    -> UArray (SE fslr) l sh (v c)+fzipElems2 fs arr1 arr2 =+    let fMs = V.map (\f -> \x y -> return (f x y)) fs+    in fzipElems2M fMs arr1 arr2++fzipElems2M+    :: (VecRegular r slr l sh v a, USource slr l sh a,+        VecRegular r slr l sh v b, USource slr l sh b,+        USource fslr l sh c, Fusion slr fslr l, Vector v c)+    => VecList (Dim v) (a -> b -> IO c) -- ^ .+    -> UArray r l sh (v a)+    -> UArray r l sh (v b)+    -> UArray (SE fslr) l sh (v c)+fzipElems2M fs arr1 arr2 =+    let sh = intersect (vl_2 (extent arr1) (extent arr2))+        slices1 = slices arr1+        slices2 = slices arr2+        {-# INLINE makeSlice #-}+        makeSlice i f =+            let sl1 = slices1 V.! i+                sl2 = slices2 V.! i+            in fzip2M f sl1 sl2+    in Separate sh $ V.imap makeSlice fs++fzipElems3+    :: (VecRegular r slr l sh v a, USource slr l sh a,+        VecRegular r slr l sh v b, USource slr l sh b,+        VecRegular r slr l sh v c, USource slr l sh c,+        USource fslr l sh d, Fusion slr fslr l, Vector v d)+    => VecList (Dim v) (a -> b -> c -> d) -- ^ .+    -> UArray r l sh (v a)+    -> UArray r l sh (v b)+    -> UArray r l sh (v c)+    -> UArray (SE fslr) l sh (v d)+fzipElems3 fs arr1 arr2 arr3 =+    let fMs = V.map (\f -> \x y z -> return (f x y z)) fs+    in fzipElems3M fMs arr1 arr2 arr3++fzipElems3M+    :: (VecRegular r slr l sh v a, USource slr l sh a,+        VecRegular r slr l sh v b, USource slr l sh b,+        VecRegular r slr l sh v c, USource slr l sh c,+        USource fslr l sh d, Fusion slr fslr l, Vector v d)+    => VecList (Dim v) (a -> b -> c -> IO d) -- ^ .+    -> UArray r l sh (v a)+    -> UArray r l sh (v b)+    -> UArray r l sh (v c)+    -> UArray (SE fslr) l sh (v d)+fzipElems3M fs arr1 arr2 arr3 =+    let sh = intersect (vl_3 (extent arr1) (extent arr2) (extent arr3))+        slices1 = slices arr1+        slices2 = slices arr2+        slices3 = slices arr3+        {-# INLINE makeSlice #-}+        makeSlice i f =+            let sl1 = slices1 V.! i+                sl2 = slices2 V.! i+                sl3 = slices3 V.! i+            in fzip3M f sl1 sl2 sl3+    in Separate sh $ V.imap makeSlice fs+++fzipElems+    :: (Vector v2 b, Arity m, m ~ S m0,+        VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, Fusion slr fslr l)+    => VecList (Dim v2) (Fun m a b) -- ^ .+    -> VecList m (UArray r l sh (v a))+    -> UArray (SE fslr) l sh (v2 b)+fzipElems funs arrs =+    let funMs = V.map (P.fmap return) funs+    in fzipElemsM funMs arrs++fzipElemsM+    :: (Vector v2 b, Arity m, m ~ S m0,+        VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, Fusion slr fslr l)+    => VecList (Dim v2) (Fun m a (IO b)) -- ^ .+    -> VecList m (UArray r l sh (v a))+    -> UArray (SE fslr) l sh (v2 b)+fzipElemsM funs arrs =+    let sh = intersect $ V.map extent arrs+        !allSlices = V.map slices arrs+        {-# INLINE makeSlice #-}+        makeSlice i fun =+            let slices = V.map (V.! i) allSlices+            in fzipM fun slices+    in Separate sh $ V.imap makeSlice funs++{-# INLINE fmapElems #-}+{-# INLINE fmapElemsM #-}+{-# INLINE fzipElems2 #-}+{-# INLINE fzipElems2M #-}+{-# INLINE fzipElems3 #-}+{-# INLINE fzipElems3M #-}+{-# INLINE fzipElems #-}+{-# INLINE fzipElemsM #-}++-- | /O(1)/ Injective element-wise fusion (mapping).+--+-- Example:+--+-- @+-- let domainHSVImage =+--         dmapElems ('vl_3' (* 360) (* 100) (* 100))+--                   normedHSVImage+-- @+--+-- Also, used internally to define 'Data.Yarr.Flow.mapElems' function.+dmapElems+    :: (VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, DefaultFusion slr fslr l,+        Vector v2 b, Dim v ~ Dim v2)+    => VecList (Dim v) (a -> b)     -- ^ Vector of mapper functions+    -> UArray r l sh (v a)          -- ^ Source array of vectors+    -> UArray (SE fslr) l sh (v2 b) -- ^ Fused array+dmapElems = fmapElems++-- | /O(1)/ Monadic vesion of 'dmapElems' function.+dmapElemsM+    :: (VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, DefaultFusion slr fslr l,+        Vector v2 b, Dim v ~ Dim v2)+    => VecList (Dim v) (a -> IO b)  -- ^ Elemen-wise vector of monadic mappers+    -> UArray r l sh (v a)          -- ^ Source array of vectors+    -> UArray (SE fslr) l sh (v2 b) -- ^ Result array+dmapElemsM = fmapElemsM+++dzipElems2+    :: (VecRegular r slr l sh v a, USource slr l sh a,+        VecRegular r slr l sh v b, USource slr l sh b,+        USource fslr l sh c, DefaultFusion slr fslr l, Vector v c)+    => VecList (Dim v) (a -> b -> c) -- ^ .+    -> UArray r l sh (v a)+    -> UArray r l sh (v b)+    -> UArray (SE fslr) l sh (v c)+dzipElems2 = fzipElems2++dzipElems2M+    :: (VecRegular r slr l sh v a, USource slr l sh a,+        VecRegular r slr l sh v b, USource slr l sh b,+        USource fslr l sh c, DefaultFusion slr fslr l, Vector v c)+    => VecList (Dim v) (a -> b -> IO c) -- ^ .+    -> UArray r l sh (v a)+    -> UArray r l sh (v b)+    -> UArray (SE fslr) l sh (v c)+dzipElems2M = fzipElems2M++dzipElems3+    :: (VecRegular r slr l sh v a, USource slr l sh a,+        VecRegular r slr l sh v b, USource slr l sh b,+        VecRegular r slr l sh v c, USource slr l sh c,+        USource fslr l sh d, DefaultFusion slr fslr l, Vector v d)+    => VecList (Dim v) (a -> b -> c -> d) -- ^ .+    -> UArray r l sh (v a)+    -> UArray r l sh (v b)+    -> UArray r l sh (v c)+    -> UArray (SE fslr) l sh (v d)+dzipElems3 = fzipElems3++dzipElems3M+    :: (VecRegular r slr l sh v a, USource slr l sh a,+        VecRegular r slr l sh v b, USource slr l sh b,+        VecRegular r slr l sh v c, USource slr l sh c,+        USource fslr l sh d, DefaultFusion slr fslr l, Vector v d)+    => VecList (Dim v) (a -> b -> c -> IO d) -- ^ .+    -> UArray r l sh (v a)+    -> UArray r l sh (v b)+    -> UArray r l sh (v c)+    -> UArray (SE fslr) l sh (v d)+dzipElems3M = fzipElems3M++++-- | /O(1)/ Generalized element-wise zipping of several arrays of vectors.+dzipElems+    :: (Vector v2 b, Arity m, m ~ S m0,+        VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, DefaultFusion slr fslr l)+    => VecList (Dim v2) (Fun m a b)    -- ^ Vector of wrapped @m-@ary element-wise zippers+    -> VecList m (UArray r l sh (v a)) -- ^ Vector of source arrays of vectors+    -> UArray (SE fslr) l sh (v2 b)    -- ^ Fused result array+dzipElems = fzipElems++-- | /O(1)/ Generalized monadic element-wise zipping of several arrays of vectors+dzipElemsM+    :: (Vector v2 b, Arity m, m ~ S m0,+        VecRegular r slr l sh v a,+        USource slr l sh a, USource fslr l sh b, DefaultFusion slr fslr l)+    => VecList (Dim v2) (Fun m a (IO b)) -- ^ Vector of wrapped @m-@ary+                                         -- element-wise monadic zippers+    -> VecList m (UArray r l sh (v a))   -- ^ Vector of source arrays of vectors+    -> UArray (SE fslr) l sh (v2 b)      -- ^ Result array+dzipElemsM = fzipElemsM++{-# INLINE dmapElems #-}+{-# INLINE dmapElemsM #-}+{-# INLINE dzipElems2 #-}+{-# INLINE dzipElems2M #-}+{-# INLINE dzipElems3 #-}+{-# INLINE dzipElems3M #-}+{-# INLINE dzipElems #-}+{-# INLINE dzipElemsM #-}+++++instance (UTarget tr tl sh e, Vector v e) => UTarget (SE tr) tl sh (v e) where+    write (Separate _ slices) sh v =+        V.zipWithM_ (\el x -> write el sh x) slices (V.convert v)+    linearWrite (Separate _ slices) i v =+        V.zipWithM_ (\el x -> linearWrite el i x) slices (V.convert v)+    {-# INLINE write #-}+    {-# INLINE linearWrite #-}++instance (Manifest r mr l sh e, Vector v e) =>+        Manifest (SE r) (SE mr) l sh (v e) where+    new sh = P.fmap (Separate sh) (V.replicateM (B.new sh))+    freeze (Separate sh mslices) = P.fmap (Separate sh) (V.mapM freeze mslices)+    thaw (Separate sh slices) = P.fmap (Separate sh) (V.mapM thaw slices)+    {-# INLINE new #-}+    {-# INLINE freeze #-}+    {-# INLINE thaw #-}++instance (UTarget tr tl sh e, Vector v e) => UVecTarget (SE tr) tr tl sh v e++-- | /O(1)/ Glues several arrays of the same type+-- into one separate array of vectors.+-- All source arrays must be of the same extent.+--+-- Example:+--+-- @let separateCoords = fromSlices ('vl_3' xs ys zs)@+fromSlices+    :: (Regular r l sh e, Vector v e, Dim v ~ S n0)+    => VecList (Dim v) (UArray r l sh e)+    -> UArray (SE r) l sh (v e)+{-# INLINE fromSlices #-}+fromSlices slices =+    let shapes = V.map extent slices+        sh0 = V.head shapes+    in if V.any (/= sh0) shapes+            then error "Separate Repr: all slices must be of the same extent"+            else Separate sh0 slices++-- | /O(depends on mapper function)/+-- Maps slices of separate array \"entirely\".+-- +-- This function is useful when operation over slices is not+-- element-wise (in that case you should use 'Data.Yarr.Flow.mapElems'):+--+-- @let blurredImage = unsafeMapSlices blur image@+--+-- The function is unsafe because it doesn't check that slice mapper+-- translates extents uniformly (though it is pure).+unsafeMapSlices+    :: (USource r l sh a, Vector v a,+        USource r2 l2 sh2 b, Vector v b, Dim v ~ S n0)+    => (UArray r l sh a -> UArray r2 l2 sh2 b)+        -- ^ Slice mapper without restrictions+    -> UArray (SE r) l sh (v a)    -- ^ Source separate array+    -> UArray (SE r2) l2 sh2 (v b) -- ^ Result separate array+{-# INLINE unsafeMapSlices #-}+unsafeMapSlices f (Separate sh slices) =+    let slices' = V.map f slices+    in Separate (extent (V.head slices')) slices'++-- | /O(0)/ Converts separate vector between vector types of the same arity.+--+-- Example:+--+-- @+-- -- floatPairs :: 'UArray' ('SE' 'Data.Yarr.F') 'Dim1' ('VecList' 'N2' Float)+-- let cs :: 'UArray' ('SE' 'Data.Yarr.F') 'Dim1' ('Data.Complex.Complex' Float)+--     cs = convert floatPairs+-- @+convert+    :: (Regular r l sh e, Vector v e, Vector v2 e, Dim v ~ Dim v2)+    => UArray (SE r) l sh (v e) -> UArray (SE r) l sh (v2 e)+{-# INLINE convert #-}+convert (Separate sh slices) = Separate sh slices
+ Data/Yarr/Shape.hs view
@@ -0,0 +1,584 @@+{-# LANGUAGE InstanceSigs #-}++module Data.Yarr.Shape where++import Prelude as P hiding (foldl, foldr)+import GHC.Exts++import Control.DeepSeq++import Data.Yarr.Utils.FixedVector as V hiding (foldl, foldr)+import Data.Yarr.Utils.LowLevelFlow+import Data.Yarr.Utils.Primitive+import Data.Yarr.Utils.Split++-- | Alias to frequently used get-write-from-to arguments combo.+--+-- Passed as 1st parameter of all 'Data.Yarr.Eval.Load'ing functions+-- from "Data.Yarr.Eval" module.+type Fill sh a =+    (sh -> IO a)          -- ^ Get+    -> (sh -> a -> IO ()) -- ^ Write+    -> sh                 -- ^ Start+    -> sh                 -- ^ End+    -> IO ()++-- | Mainly for internal use.+-- Abstracts top-left -- bottom-right pair of indices.+type Block sh = (sh, sh)++-- | Class for column-major, regular composite array indices.+class (Eq sh, Bounded sh, Show sh, NFData sh) => Shape sh where+    -- | @0@, @(0, 0)@, @(0, 0, 0)@+    zero :: sh+    -- | 'Dim1' @size@ is 'id', @size (3, 5) == 15@+    size :: sh -> Int+    -- | @(1, 2, 3) \`plus\` (0, 0, 1) == (1, 2, 4)@+    plus :: sh -> sh -> sh+    -- | @(1, 2) \`minus\` (1, 0) == (0, 2)@ +    minus :: sh -> sh -> sh+    minus = flip offset+    -- | @offset == 'flip' 'minus'@+    offset :: sh -> sh -> sh++    -- | Converts linear, memory index of shaped array to shape index+    -- without bound checks.+    -- +    -- @fromLinear (3, 4) 5 == (1, 1)@+    fromLinear+        :: sh  -- ^ Extent of array+        -> Int -- ^ Linear index+        -> sh  -- ^ Shape index++    -- | Opposite to 'fromLinear', converts composite array index+    -- to linear, \"memory\" index without bounds checks.+    --+    -- 'id' for 'Dim1' shapes.+    --+    -- @toLinear (5, 5) (3, 0) == 15@+    toLinear+        :: sh  -- ^ Extent of array+        -> sh  -- ^ Shape index+        -> Int -- ^ Linear index+    +    -- | Component-wise minimum, returns maximum legal index+    -- for all given array extents+    intersect+        :: (Arity n, n ~ S n0)+        => VecList n sh -- ^ Several array extents+        -> sh           -- ^ Maximum common shape index++    -- | Component-wise maximum, used in "Data.Yarr.Convolution" implementation.+    complement :: (Arity n, n ~ S n0) => VecList n sh -> sh++    intersectBlocks :: (Arity n, n ~ S n0) => VecList n (Block sh) -> Block sh+    intersectBlocks blocks =+        let ss = V.map fst blocks+            es = V.map snd blocks+        in (complement ss, intersect es)++    blockSize :: Block sh -> Int+    insideBlock :: Block sh -> sh -> Bool++    makeChunkRange :: Int -> sh -> sh -> (Int -> Block sh)++    -- | Following 6 functions shouldn't be called directly,+    -- they are intented to be passed as first argument+    -- to 'Data.Yarr.Eval.Load' and not currently existring+    -- @Fold@ functions.+    foldl :: (b -> sh -> a -> IO b) -- ^ Generalized reduce+          -> b                      -- ^ Zero+          -> (sh -> IO a)           -- ^ Get+          -> sh                     -- ^ Start+          -> sh                     -- ^ End+          -> IO b                   -- ^ Result++    unrolledFoldl+        :: forall a b uf. Arity uf+        => uf                     -- ^ Unroll factor+        -> (a -> IO ())           -- ^ 'touch' or 'noTouch'+        -> (b -> sh -> a -> IO b) -- ^ Generalized reduce+        -> b                      -- ^ Zero+        -> (sh -> IO a)           -- ^ Get+        -> sh                     -- ^ Start+        -> sh                     -- ^ End+        -> IO b                   -- ^ Result++    foldr :: (sh -> a -> b -> IO b) -- ^ Generalized reduce+          -> b                      -- ^ Zero+          -> (sh -> IO a)           -- ^ Get+          -> sh                     -- ^ Start+          -> sh                     -- ^ End+          -> IO b                   -- ^ Result++    unrolledFoldr+        :: forall a b uf. Arity uf+        => uf                     -- ^ Unroll factor+        -> (a -> IO ())           -- ^ 'touch' or 'noTouch'+        -> (sh -> a -> b -> IO b) -- ^ Generalized reduce+        -> b                      -- ^ Zero+        -> (sh -> IO a)           -- ^ Get+        -> sh                     -- ^ Start+        -> sh                     -- ^ End+        -> IO b                   -- ^ Result++    -- | Standard fill without unrolling.+    -- To avoid premature optimization just type @fill@+    -- each time you want to 'Data.Yarr.Eval.Load' array+    -- to manifest representation.+    fill :: Fill sh a++    unrolledFill+        :: forall a uf. Arity uf+        => uf                 -- ^ Unroll factor+        -> (a -> IO ())       -- ^ 'touch' or 'noTouch'+        -> Fill sh a          -- ^ Result curried function+                              --   to pass to loading functions.++    {-# INLINE minus #-}+    {-# INLINE intersectBlocks #-}++-- | For internal use.+--+-- /TODO:/ implement for 'Dim3' and merge with 'Shape' class+class (Shape sh, Arity (BorderCount sh)) => BlockShape sh where+    type BorderCount sh+    clipBlock+        :: Block sh                            -- ^ Outer block+        -> Block sh                            -- ^ Inner block+        -> VecList (BorderCount sh) (Block sh) -- ^ Shavings++++type Dim1 = Int++instance Shape Dim1 where+    zero = 0+    size = id+    plus = (+)+    offset off i = i - off+    fromLinear _ i = i+    toLinear _ i = i+    intersect = V.minimum+    complement = V.maximum++    blockSize (s, e) = e - s+    insideBlock (s, e) i = i >= s && i < e++    makeChunkRange chunks start end =+        let {-# INLINE split #-}+            split = makeSplitIndex chunks start end+        in \ !c -> (split c, split (c + 1))++    fill get write = \ (I# start#) (I# end#) -> fill# get write start# end#+    unrolledFill uf tch =+        \get write ->+        \ (I# start#) (I# end#) -> unrolledFill# uf tch get write start# end#++    foldl reduce z get =+        \ (I# start#) (I# end#) -> foldl# reduce z get start# end#++    unrolledFoldl unrollFactor tch reduce z get =+        \ (I# start#) (I# end#) ->+            unrolledFoldl# unrollFactor tch reduce z get start# end#++    foldr reduce z get =+        \ (I# start#) (I# end#) -> foldr# reduce z get start# end#++    unrolledFoldr unrollFactor tch reduce z get =+        \ (I# start#) (I# end#) ->+            unrolledFoldr# unrollFactor tch reduce z get start# end# ++    {-# INLINE zero #-}+    {-# INLINE size #-}+    {-# INLINE plus #-}+    {-# INLINE offset #-}+    {-# INLINE fromLinear #-}+    {-# INLINE toLinear #-}+    {-# INLINE intersect #-}+    {-# INLINE complement #-}+    {-# INLINE blockSize #-}+    {-# INLINE insideBlock #-}+    {-# INLINE makeChunkRange #-}++    {-# INLINE fill #-}+    {-# INLINE unrolledFill #-}++    {-# INLINE foldl #-}+    {-# INLINE unrolledFoldl #-}+    {-# INLINE foldr #-}+    {-# INLINE unrolledFoldr #-}+++instance BlockShape Dim1 where+    type BorderCount Dim1 = N2+    clipBlock outer@(os, oe) inner =+        let intersection@(is, ie) = intersectBlocks (vl_2 inner outer)+        in (vl_2 (os, is) (ie, oe))++    {-# INLINE clipBlock #-}+++++type Dim2 = (Int, Int)++instance Shape Dim2 where+    zero = (0, 0)+    size (h, w) = h * w+    plus (y1, x1) (y2, x2) = (y1 + y2, x1 + x2)+    offset (offY, offX) (y, x) = (y - offY, x - offX)+    fromLinear (_, w) i = i `quotRem` w+    toLinear (_, w) (y, x) = y * w + x+    +    intersect shapes =+        let hs = V.map fst shapes+            ws = V.map snd shapes+        in (V.minimum hs, V.minimum ws)++    complement shapes =+        let hs = V.map fst shapes+            ws = V.map snd shapes+        in (V.maximum hs, V.maximum ws)++    blockSize ((sy, sx), (ey, ex)) = (ey - sy) * (ex - sx)++    insideBlock ((sy, sx), (ey, ex)) (iy, ix) =+        (iy >= sy && iy < ey) && (ix >= sx && ix < ex)++    makeChunkRange chunks (sy, sx) (ey, ex) =+        let {-# INLINE range #-}+            range = makeChunkRange chunks sy ey+        in \c -> let (csy, cey) = range c in ((csy, sx), (cey, ex))++    fill get write =+        \ (!sy, !sx) (!ey, !ex) ->+            let {-# INLINE go #-}+                go y | y >= ey   = return ()+                     | otherwise = do+                        fill (\x -> get (y, x))+                             (\x a -> write (y, x) a)+                             sx ex+                        go (y + 1)+            in go sy++    unrolledFill+        :: forall a uf. Arity uf+        => uf                 -- Unroll factor+        -> (a -> IO ())       -- Touch+        -> Fill Dim2 a+    unrolledFill unrollFactor tch =+        let !(I# uf#) = arity unrollFactor+        in \get write ->+            \ ((I# sy#), (I# sx#)) ((I# ey#), (I# ex#)) ->+                let limX# = ex# -# uf#+                    {-# INLINE goY# #-}+                    goY# y#+                        | y# >=# ey#   = return ()+                        | otherwise    = do+                            let y = I# y#+                                {-# INLINE goX# #-}+                                goX# x#+                                    | x# ># limX# =+                                        fill#+                                            (\x -> get (y, x))+                                            (\x a -> write (y, x) a)+                                            x# ex#+                                    | otherwise   = do+                                        let x = I# x#+                                            is :: VecList uf (Int, Int)+                                            is = V.generate (\i -> (y, i + x))+                                        as <- V.mapM get is+                                        V.mapM_ tch as+                                        V.zipWithM_ write is as+                                        goX# (x# +# uf#)+                            goX# sx#+                            goY# (y# +# 1#)+                in goY# sy#++    foldl reduce z get =+        \ (!sy, !sx) (!ey, !ex) ->+            let {-# INLINE go #-}+                go y b+                    | y >= ey   = return b+                    | otherwise = do+                        b' <- foldl (\b x a -> reduce b (y, x) a) b+                                    (\x -> get (y, x))+                                    sx ex+                        go (y + 1) b'+            in go sy z++    unrolledFoldl unrollFactor tch reduce z get =+        \ (!sy, !sx) (!ey, !ex) ->+            let {-# INLINE go #-}+                go y b+                    | y >= ey   = return b+                    | otherwise = do+                        b' <- unrolledFoldl+                                unrollFactor tch+                                (\b x a -> reduce b (y, x) a) b+                                (\x -> get (y, x))+                                sx ex+                        go (y + 1) b'+            in go sy z+++    foldr reduce z get =+        \ (!sy, !sx) (!ey, !ex) ->+            let {-# INLINE go #-}+                go y b+                    | y < sy    = return b+                    | otherwise = do+                        b' <- foldr (\x a b -> reduce (y, x) a b) b+                                    (\x -> get (y, x))+                                    sx ex+                        go (y - 1) b'+            in go (ey - 1) z++    unrolledFoldr unrollFactor tch reduce z get =+        \ (!sy, !sx) (!ey, !ex) ->+            let {-# INLINE go #-}+                go y b+                    | y < sy    = return b+                    | otherwise = do+                        b' <- unrolledFoldr+                                unrollFactor tch+                                (\x a b -> reduce (y, x) a b)+                                b+                                (\x -> get (y, x))+                                sx ex+                        go (y - 1) b'+            in go (ey - 1) z++    {-# INLINE zero #-}+    {-# INLINE size #-}+    {-# INLINE plus #-}+    {-# INLINE offset #-}+    {-# INLINE fromLinear #-}+    {-# INLINE toLinear #-}+    {-# INLINE intersect #-}+    {-# INLINE complement #-}+    {-# INLINE blockSize #-}+    {-# INLINE insideBlock #-}+    {-# INLINE makeChunkRange #-}++    {-# INLINE fill #-}+    {-# INLINE unrolledFill #-}++    {-# INLINE foldl #-}+    {-# INLINE unrolledFoldl #-}+    {-# INLINE foldr #-}+    {-# INLINE unrolledFoldr #-}+++instance BlockShape Dim2 where+    type BorderCount Dim2 = N4+    clipBlock outer@((osy, osx), (oey, oex)) inner =+        let intersection@((isy, isx), (iey, iex)) =+                intersectBlocks (vl_2 inner outer)+        in (vl_4 ((osy, isx), (isy, oex))+                 ((isy, iex), (oey, oex))+                 ((iey, osx), (oey, iex))+                 ((osy, osx), (iey, isx)))++    {-# INLINE clipBlock #-}++-- | 2D-unrolling to maximize profit from+-- \"Global value numbering\" LLVM optimization.+--+-- Example:+--+-- @blurred <- 'Data.Yarr.Eval.compute' ('Data.Yarr.Eval.loadP' (dim2BlockFill 'n1' 'n4' 'touch')) delayedBlurred@+dim2BlockFill+    :: forall a bsx bsy. (Arity bsx, Arity bsy)+    => bsx                  -- ^ Block size by x. Use 'n1'-'n8' values.+    -> bsy                  -- ^ Block size by y+    -> (a -> IO ())         -- ^ 'touch' or 'noTouch'+    -> Fill Dim2 a          -- ^ Result curried function+                            --   to pass to loading functions.+{-# INLINE dim2BlockFill #-}+dim2BlockFill blockSizeX blockSizeY tch =+    \get write ->+    \ ((I# sy#), sx@(I# sx#)) end@((I# ey#), ex@(I# ex#)) ->+        let !(I# bx#) = arity blockSizeX+            limX# = ex# -# bx#++            !(I# by#) = arity blockSizeY+            limY# = ey# -# by#++            {-# INLINE goY# #-}+            goY# y# | y# ># limY# = fill get write ((I# y#), sx) end+                   | otherwise    = do+                        let y = I# y#+                            ys :: VecList bsy Int+                            ys = V.generate (+ y)++                            {-# INLINE go# #-}+                            go# x#+                                | x# ># limX# =+                                    fill get write+                                         (y, (I# x#)) (I# (y# +# by#), ex)+                                | otherwise   = do+                                    let xs :: VecList bsx Int+                                        xs = V.generate (+ (I# x#))+                                        is = V.map (\y -> V.map (\x -> (y, x)) xs) ys++                                    as <- V.mapM (V.mapM get) is+                                    V.mapM_ (V.mapM_ tch) as+                                    V.zipWithM_ (V.zipWithM_ write) is as++                                    go# (x# +# bx#)+                        go# sx#+                        goY# (y# +# by#)++        in goY# sy#+++++type Dim3 = (Int, Int, Int)++instance Shape Dim3 where+    zero = (0, 0, 0)+    size (d, h, w) = d * h * w+    plus (z1, y1, x1) (z2, y2, x2) = (z1 + z2, y1 + y2, x1 + x2)+    offset (offZ, offY, offX) (z, y, x) = (z - offZ, y - offY, x - offX)+    fromLinear (_, h, w) i =+        let (i', x) = i `quotRem` w+            (z, y) = i' `quotRem` h+        in (z, y, x)++    toLinear (_, h, w) (z, y, x) = z * (h * w) + y * w + x++    intersect shapes =+        let ds = V.map (\(d, _, _) -> d) shapes+            hs = V.map (\(_, h, _) -> h) shapes+            ws = V.map (\(_, _, w) -> w) shapes+        in (V.minimum ds, V.minimum hs, V.minimum ws)++    complement shapes =+        let ds = V.map (\(d, _, _) -> d) shapes+            hs = V.map (\(_, h, _) -> h) shapes+            ws = V.map (\(_, _, w) -> w) shapes+        in (V.maximum ds, V.maximum hs, V.maximum ws)++    blockSize ((sz, sy, sx), (ez, ey, ex)) =+        (ez - sz) * (ey - sy) * (ex - sx)++    insideBlock ((sz, sy, sx), (ez, ey, ex)) (iz, iy, ix) =+        (iz >= sz && iz < ez) &&+        (iy >= sy && iy < ey) &&+        (ix >= sx && ix < ex)++    makeChunkRange chunks (sz, sy, sx) (ez, ey, ex) =+        let {-# INLINE range #-}+            range = makeChunkRange chunks sz ez+        in \c -> let (csz, cez) = range c+                 in ((csz, sy, sx), (cez, ey, ex))+++    fill get write =+        \ (!sz, !sy, !sx) (!ez, !ey, !ex) ->+            let {-# INLINE go #-}+                go z | z >= ez   = return ()+                     | otherwise = do+                        fill+                             (\(y, x) -> get (z, y, x))+                             (\(y, x) a -> write (z, y, x) a)+                             (sy, sx) (ey, ex)+                        go (z + 1)+            in go sz++    unrolledFill unrollFactor tch =+        let !uf = arity unrollFactor+            {-# INLINE actualFill #-}+            actualFill _ get write =+                \ (!sz, !sy, !sx) (!ez, !ey, !ex) ->+                    let {-# INLINE go #-}+                        go z | z >= ez   = return ()+                             | otherwise = do+                                unrolledFill+                                    unrollFactor tch+                                    (\(y, x) -> get (z, y, x))+                                    (\(y, x) a -> write (z, y, x) a)+                                    (sy, sx) (ey, ex)+                                go (z + 1)+                    in go sz+        in actualFill uf++    foldl reduce zero get =+        \ (!sz, !sy, !sx) (!ez, !ey, !ex) ->+            let {-# INLINE go #-}+                go z b+                    | z >= ez   = return b+                    | otherwise = do+                        b' <- foldl+                                (\b (y, x) a -> reduce b (z, y, x) a) b+                                (\(y, x) -> get (z, y, x))+                                (sy, sx) (ey, ex)+                        go (z + 1) b'+            in go sz zero++    unrolledFoldl unrollFactor tch reduce zero get =+        \ (!sz, !sy, !sx) (!ez, !ey, !ex) ->+            let {-# INLINE go #-}+                go z b+                    | z >= ez   = return b+                    | otherwise = do+                        b' <- unrolledFoldl+                                unrollFactor tch+                                (\b (y, x) a -> reduce b (z, y, x) a) b+                                (\(y, x) -> get (z, y, x))+                                (sy, sx) (ey, ex)+                        go (z + 1) b'+            in go sz zero+++    foldr reduce zero get =+        \ (!sz, !sy, !sx) (!ez, !ey, !ex) ->+            let {-# INLINE go #-}+                go z b+                    | z < sz    = return b+                    | otherwise = do+                        b' <- foldr+                                (\(y, x) a b -> reduce (z, y, x) a b) b+                                (\(y, x) -> get (z, y, x))+                                (sy, sx) (ey, ex)+                        go (z - 1) b'+            in go (ez - 1) zero++    unrolledFoldr unrollFactor tch reduce zero get =+        \ (!sz, !sy, !sx) (!ez, !ey, !ex) ->+            let {-# INLINE go #-}+                go z b+                    | z < sz    = return b+                    | otherwise = do+                        b' <- unrolledFoldr+                                unrollFactor tch+                                (\(y, x) a b -> reduce (z, y, x) a b) b+                                (\(y, x) -> get (z, y, x))+                                (sy, sx) (ey, ex)+                        go (z - 1) b'+            in go (ez - 1) zero++    {-# INLINE zero #-}+    {-# INLINE size #-}+    {-# INLINE plus #-}+    {-# INLINE offset #-}+    {-# INLINE fromLinear #-}+    {-# INLINE toLinear #-}+    {-# INLINE intersect #-}+    {-# INLINE complement #-}+    {-# INLINE blockSize #-}+    {-# INLINE insideBlock #-}+    {-# INLINE makeChunkRange #-}++    {-# INLINE fill #-}+    {-# INLINE unrolledFill #-}++    {-# INLINE foldl #-}+    {-# INLINE unrolledFoldl #-}+    {-# INLINE foldr #-}+    {-# INLINE unrolledFoldr #-}++
+ Data/Yarr/Utils/FixedVector.hs view
@@ -0,0 +1,142 @@++module Data.Yarr.Utils.FixedVector (+    -- * Fixed Vector  +    module Data.Vector.Fixed,+    Fn, arity,+    +    -- * Missed utility+    zipWith3, zipWithM_, apply, all, any,+    iifoldl, iifoldM,++    -- * Aliases and shortcuts+    -- ** Arity+    N7, N8,+    -- | Arity \"instances\" -- aliases to 'undefined'.+    n1, n2, n3, n4, n5, n6, n7, n8,+    +    -- ** VecList makers+    vl_1, vl_2, vl_3, vl_4,++    -- * VecTuple+    VecTuple(..),+    module Data.Yarr.Utils.VecTupleInstances,+    makeVecTupleInstance,++) where++import Prelude hiding (foldl, zipWith, zipWith3, all, any, sequence_)++import Control.DeepSeq++import Data.Vector.Fixed+import Data.Vector.Fixed.Internal hiding (apply)++import Data.Yarr.Utils.VecTuple+import Data.Yarr.Utils.VecTupleInstances++n1 :: N1+n1 = undefined++n2 :: N2+n2 = undefined++n3 :: N3+n3 = undefined++n4 :: N4+n4 = undefined++n5 :: N5+n5 = undefined++n6 :: N6+n6 = undefined+++n7 :: N7+n7 = undefined+++n8 :: N8+n8 = undefined++vl_1 :: a -> VecList N1 a+{-# INLINE vl_1 #-}+vl_1 a = VecList [a]++vl_2 :: a -> a -> VecList N2 a+{-# INLINE vl_2 #-}+vl_2 a b = VecList [a, b]++vl_3 :: a -> a -> a -> VecList N3 a+{-# INLINE vl_3 #-}+vl_3 a b c = VecList [a, b, c]++vl_4 :: a -> a -> a -> a -> VecList N4 a+{-# INLINE vl_4 #-}+vl_4 a b c d = VecList [a, b, c, d]+++instance (Arity n, NFData e) => NFData (VecList n e) where+    rnf = Data.Vector.Fixed.foldl (\r e -> r `seq` rnf e) ()+    {-# INLINE rnf #-}++    +zipWith3+  :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v (b, c))+  => (a -> b -> c -> d)+  -> v a -> v b -> v c+  -> v d+{-# INLINE zipWith3 #-}+zipWith3 f v1 v2 v3 = zipWith (\a (b, c) -> f a b c) v1 (zipWith (,) v2 v3)++zipWithM_+  :: (Vector v a, Vector v b, Vector v c, Monad m, Vector v (m c))+  => (a -> b -> m c) -> v a -> v b -> m ()+{-# INLINE zipWithM_ #-}+zipWithM_ f xs ys = sequence_ (zipWith f xs ys)+++apply :: (Vector v a, Vector v (a -> b), Vector v b)+    => v (a -> b) -> v a -> v b+{-# INLINE apply #-}+apply = zipWith ($)++all :: Vector v a => (a -> Bool) -> v a -> Bool+{-# INLINE all #-}+all p = foldl (\a x -> a && (p x)) True++any :: Vector v a => (a -> Bool) -> v a -> Bool+{-# INLINE any #-}+any p = foldl (\a x -> a || (p x)) False+++iifoldl+    :: Vector v a+    => ix -> (ix -> ix)+    -> (b -> ix -> a -> b) -> b -> v a -> b+{-# INLINE iifoldl #-}+iifoldl st sc f z v = inspectV v $ gifoldlF st sc f z++iifoldM+    :: (Vector v a, Monad m)+    => ix -> (ix -> ix)+    -> (b -> ix -> a -> m b) -> b -> v a -> m b+{-# INLINE iifoldM #-}+iifoldM st sc f x v =+    let go m i a = do+            b <- m+            f b i a+    in iifoldl st sc go (return x) v++data T_ifoldl ix b n = T_ifoldl ix b++gifoldlF+    :: forall n ix a b. Arity n+    => ix -> (ix -> ix)+    -> (b -> ix -> a -> b) -> b -> Fun n a b+{-# INLINE gifoldlF #-}+gifoldlF st sc f b = Fun $+    accum (\(T_ifoldl i r) a -> T_ifoldl (sc i) (f r i a))+          (\(T_ifoldl _ r) -> r)+          (T_ifoldl st b :: T_ifoldl ix b n)
+ Data/Yarr/Utils/Fork.hs view
@@ -0,0 +1,85 @@++module Data.Yarr.Utils.Fork where++import Prelude as P++import Data.Yarr.Shape+import Data.Yarr.Utils.FixedVector as V hiding (generate)+import Data.Yarr.Utils.Parallel as Par+++makeForkEachSlice+    :: (Shape sh, Arity n, v ~ VecList n)+    => Int+    -> sh -> sh+    -> v (sh -> sh -> IO a)+    -> (Int -> IO (v a))+{-# INLINE makeForkEachSlice #-}+makeForkEachSlice threads start end rangeWorks =+    let {-# INLINE etWork #-}+        etWork = makeFork threads start end+    in \ !t -> V.sequence $ V.map (\work -> etWork work t) rangeWorks+++makeForkSlicesOnce+    :: (Shape sh, Arity n)+    => Int+    -> VecList n (sh, sh)+    -> VecList n (sh -> sh -> IO a)+    -> (Int -> IO [(Int, a)])+{-# INLINE makeForkSlicesOnce #-}+makeForkSlicesOnce !threads ranges rangeWorks =+    let !slices = V.length rangeWorks+        !allChunks = lcm threads slices+        !chunksPerSlice = allChunks `quot` slices+        !chunksPerThread = allChunks `quot` threads++        rangeMakers =+            V.map (\(s, e) -> makeChunkRange chunksPerSlice s e) ranges++        {-# INLINE threadWork #-}+        threadWork startSlice startPos !endSlice !endPos =+            let {-# INLINE elemWork #-}+                elemWork !currSlice !currPos results =+                    let (start, end) = ranges V.! currSlice+                    in if (currSlice > endSlice) ||+                          (currSlice == endSlice && endPos == start)+                        then return $ reverse results+                        else+                            let endInSl = if currSlice == endSlice+                                                then endPos+                                                else end+                            in do+                                r <- (rangeWorks V.! currSlice) currPos endInSl+                                elemWork+                                    (currSlice + 1)+                                    start+                                    ((currSlice, r):results)++            in elemWork startSlice startPos []++    in \ !t ->+            let startChunk = t * chunksPerThread+                (startSlice, stChunkInSl) = startChunk `quotRem` chunksPerSlice+                (startPos, _) = (rangeMakers V.! startSlice) stChunkInSl++                endChunk = (t + 1) * chunksPerThread - 1+                (endSlice, endChunkInSl) = endChunk `quotRem` chunksPerSlice+                (_, endPos) = (rangeMakers V.! endSlice) endChunkInSl++            in threadWork startSlice startPos endSlice endPos+++makeFork+    :: Shape sh+    => Int+    -> sh -> sh+    -> ((sh -> sh -> IO a) -> (Int -> IO a))+{-# INLINE makeFork #-}+makeFork chunks start end =+    let {-# INLINE chunkRange #-}+        chunkRange = makeChunkRange chunks start end+    in \rangeWork ->+            \c ->+                let (cs, ce) = chunkRange c+                in rangeWork cs ce
+ Data/Yarr/Utils/LowLevelFlow.hs view
@@ -0,0 +1,162 @@++module Data.Yarr.Utils.LowLevelFlow where++import GHC.Exts+import Data.Yarr.Utils.FixedVector as V+++fill# :: (Int -> IO a)+      -> (Int -> a -> IO ())+      -> Int# -> Int#+      -> IO ()+{-# INLINE fill# #-}+fill# get write start# end# =+    let {-# INLINE go# #-}+        go# i#+            | i# >=# end# = return ()+            | otherwise   = do+                let i = (I# i#)+                a <- get i+                write i a+                go# (i# +# 1#)+    in go# start#+    +unrolledFill#+    :: forall a uf. Arity uf+    => uf+    -> (a -> IO ())+    -> (Int -> IO a)+    -> (Int -> a -> IO ())+    -> Int# -> Int#+    -> IO ()+{-# INLINE unrolledFill# #-}+unrolledFill# unrollFactor tch get write start# end# =+    let !(I# uf#) = arity unrollFactor+        lim# = end# -# uf#+        {-# INLINE go# #-}+        go# i#+            | i# ># lim# = fill# get write i# end#+            | otherwise  = do+                let is :: VecList uf Int+                    is = V.generate (+ (I# i#))+                as <- V.mapM get is+                V.mapM_ tch as+                V.zipWithM_ write is as+                go# (i# +# uf#)+                +    in go# start#+++foldl#+    :: (b -> Int -> a -> IO b)+    -> b+    -> (Int -> IO a)+    -> Int# -> Int#+    -> IO b+{-# INLINE foldl# #-}+foldl# reduce z get start# end# =+    let {-# INLINE go# #-}+        go# i# b+            | i# >=# end# = return b+            | otherwise   = do+                let i = (I# i#)+                a <- get i+                b' <- reduce b i a+                go# (i# +# 1#) b'+    in go# start# z++unrolledFoldl#+    :: forall a b uf. Arity uf+    => uf+    -> (a -> IO ())+    -> (b -> Int -> a -> IO b)+    -> b+    -> (Int -> IO a)+    -> Int# -> Int#+    -> IO b+{-# INLINE unrolledFoldl# #-}+unrolledFoldl# unrollFactor tch reduce z get start# end# =+    let !(I# uf#) = arity unrollFactor+        lim# = end# -# uf#+        {-# INLINE go# #-}+        go# i# b+            | i# ># lim# = rest# i# b+            | otherwise  = do+                let is :: VecList uf Int+                    is = V.generate (+ (I# i#))+                as <- V.mapM get is+                V.mapM_ tch as+                b' <- V.foldM+                        (\b (i, a) -> reduce b i a) b+                        (V.zipWith (,) is as)+                go# (i# +# uf#) b'++        {-# INLINE rest# #-}+        rest# i# b+            | i# >=# end# = return b+            | otherwise   = do+                let i = (I# i#)+                a <- get i+                tch a+                b' <- reduce b i a+                rest# (i# +# 1#) b'++    in go# start# z+++foldr#+    :: (Int -> a -> b -> IO b)+    -> b+    -> (Int -> IO a)+    -> Int# -> Int#+    -> IO b+{-# INLINE foldr# #-}+foldr# reduce z get start# end# =+    let {-# INLINE go# #-}+        go# i# b+            | i# <# start# = return b+            | otherwise    = do+                let i = (I# i#)+                a <- get i+                b' <- reduce i a b+                go# (i# -# 1#) b'+    in go# (end# -# 1#) z++unrolledFoldr#+    :: forall a b uf. Arity uf+    => uf+    -> (a -> IO ())+    -> (Int -> a -> b -> IO b)+    -> b+    -> (Int -> IO a)+    -> Int# -> Int#+    -> IO b+{-# INLINE unrolledFoldr# #-}+unrolledFoldr# unrollFactor tch reduce z get start# end# =+    let !(I# uf#) = arity unrollFactor+        lim# = start# +# uf# -# 1#+        {-# INLINE go# #-}+        go# i# b+            | i# <# lim# = rest# i# b+            | otherwise  = do+                let is :: VecList uf Int+                    is = V.generate ((I# i#) -)+                as <- V.mapM get is+                V.mapM_ tch as+                b' <- V.foldM+                        (\b (i, a) -> reduce i a b) b+                        (V.zipWith (,) is as)+                go# (i# -# uf#) b'++        {-# INLINE rest# #-}+        rest# i# b+            | i# <# start# = return b+            | otherwise    = do+                let i = (I# i#)+                a <- get i+                tch a+                b' <- reduce i a b+                rest# (i# -# 1#) b'++    in go# (end# -# 1#) z+
+ Data/Yarr/Utils/Parallel.hs view
@@ -0,0 +1,30 @@++module Data.Yarr.Utils.Parallel where++import Control.Monad+import GHC.Conc+import Control.Concurrent.MVar++parallel+    :: Int           -- ^ Number of threads to parallelize work on+    -> (Int -> IO a) -- ^ Per-thread work producer, passed+                     --   thread number @[0..threads-1]@+    -> IO [a]        -- ^ Results+{-# INLINE parallel #-}+parallel !threads makeWork = do+    rvars <- sequence $ replicate threads newEmptyMVar+    let {-# INLINE work #-}+        work t var = do+            r <- makeWork t+            putMVar var r+    zipWithM_ forkOn [0..] $ zipWith work [0..threads-1] rvars+    mapM takeMVar rvars++-- | Version of 'parallel' which discards results.+parallel_+    :: Int           -- ^ Number of threads to parallelize work on+    -> (Int -> IO a) -- ^ Per-thread work producer, passed+                     --   thread number @[0..threads-1]@+    -> IO ()+{-# INLINE parallel_ #-}+parallel_ threads makeWork = parallel threads makeWork >> return ()
+ Data/Yarr/Utils/Primitive.hs view
@@ -0,0 +1,122 @@++module Data.Yarr.Utils.Primitive where++import GHC.Prim+import GHC.Exts+import GHC.Types+import GHC.Word+import GHC.Int++import Data.Yarr.Utils.FixedVector as V+++-- | Mainly used to fight against GHC simplifier, which gives+-- no chance to LLVM to perform Global Value Numbering optimization.+--+-- Copied from @repa@, see+-- <http://hackage.haskell.org/packages/archive/repa/3.2.3.1/doc/html/Data-Array-Repa-Eval.html>+class Touchable a where+    -- | The function intented to be passed as 3rd parameter+    -- to @unrolled-@ functions in 'Data.Yarr.Shape.Shape' class+    -- and 'Data.Yarr.Shape.dim2BlockFill'.+    --+    -- If your loading operation is strictly local by elements+    -- (in most cases), use 'noTouch' instead of this function.+    touch :: a -> IO ()++instance Touchable Bool where+    touch b = IO (\s -> case touch# b s of s' -> (# s', () #))+    {-# INLINE touch #-}++#define TOUCHABLE_INST(ty,con)                                          \+instance Touchable ty where {                                           \+    touch (con x#) = IO (\s -> case touch# x# s of s' -> (# s', () #)); \+    {-# INLINE touch #-};                                               \+}++TOUCHABLE_INST(Int, I#)+TOUCHABLE_INST(Int8, I8#)+TOUCHABLE_INST(Int16, I16#)+TOUCHABLE_INST(Int32, I32#)+TOUCHABLE_INST(Int64, I64#)+TOUCHABLE_INST(Word, W#)+TOUCHABLE_INST(Word8, W8#)+TOUCHABLE_INST(Word16, W16#)+TOUCHABLE_INST(Word32, W32#)+TOUCHABLE_INST(Word64, W64#)+TOUCHABLE_INST(Float, F#)+TOUCHABLE_INST(Double, D#)++instance (Vector v e, Touchable e) => Touchable (v e) where+    touch = V.mapM_ touch+    {-# INLINE touch #-}++-- | Alias to @(\_ -> return ())@.+noTouch :: a -> IO ()+{-# INLINE noTouch #-}+noTouch _ = return ()++-- | GHC simplifier tends to float numeric comparsions+-- as high in execution graph as possible, which in conjunction+-- with loop unrolling sometimes leads to dramatic code bloat.+--+-- I'm not sure @-M@ functions work at all,+-- but strict versions defenitely keep comparsions unfloated.+class PrimitiveOrd a where+    -- | Maybe sequential 'min'.+    minM :: a -> a -> IO a+    -- | Definetely sequential 'min'.+    minM' :: a -> a -> IO a+    -- | Maybe sequential 'max'.+    maxM :: a -> a -> IO a+    -- | Definetely sequential 'max'.+    maxM' :: a -> a -> IO a+    -- | Maybe sequential clamp.+    clampM+        :: a    -- ^ Min bound+        -> a    -- ^ Max bound+        -> a    -- ^ Value to clamp+        -> IO a -- ^ Value in bounds+    -- | Definetely sequential clamp.+    clampM'+        :: a    -- ^ Min bound+        -> a    -- ^ Max bound+        -> a    -- ^ Value to clamp+        -> IO a -- ^ Value in bounds++#define PRIM_COMP_INST(ty,con,le,ge)                                 \+instance PrimitiveOrd ty where {                                     \+    minM (con a#) (con b#) =                                         \+        IO (\s -> seq# (con (if le a# b# then a# else b#)) s);       \+    minM' (con a#) (con b#) =                                        \+        IO (\s ->                                                    \+            let r# = if le a# b# then a# else b#                     \+            in case touch# r# s of s' -> (# s', (con r#) #));        \+    maxM (con a#) (con b#) =                                         \+        IO (\s -> seq# (con (if ge a# b# then a# else b#)) s);       \+    maxM' (con a#) (con b#) =                                        \+        IO (\s ->                                                    \+            let r# = if ge a# b# then a# else b#                     \+            in case touch# r# s of s' -> (# s', (con r#) #));        \+    clampM (con mn#) (con mx#) (con x#) =                            \+        IO (\s -> seq# (con (if le x# mx#                            \+                                then (if ge x# mn# then x# else mn#) \+                                else mx#)) s);                       \+    clampM' (con mn#) (con mx#) (con x#) =                           \+        IO (\s -> let r# = if le x# mx#                              \+                                then (if ge x# mn# then x# else mn#) \+                                else mx#                             \+                  in case touch# r# s of s' -> (# s', (con r#) #));  \+    {-# INLINE minM #-};                                             \+    {-# INLINE minM' #-};                                            \+    {-# INLINE maxM #-};                                             \+    {-# INLINE maxM' #-};                                            \+    {-# INLINE clampM #-};                                           \+    {-# INLINE clampM' #-};                                          \+}++PRIM_COMP_INST(Int, I#, (<=#), (>=#))+PRIM_COMP_INST(Char, C#, leChar#, geChar#)+PRIM_COMP_INST(Word, W#, leWord#, geWord#)+PRIM_COMP_INST(Double, D#, (<=##), (>=##))+PRIM_COMP_INST(Float, F#, leFloat#, geFloat#)
+ Data/Yarr/Utils/Split.hs view
@@ -0,0 +1,28 @@++module Data.Yarr.Utils.Split where++makeSplitIndex+    :: Int+    -> Int -> Int+    -> (Int -> Int)+{-# INLINE makeSplitIndex #-}+makeSplitIndex chunks start end =+    let !len = end - start+    in if len < chunks+            then \c -> start + (min c len)+            else let (chunkLen, chunkLeftover) = len `quotRem` chunks+                 in \c -> if c < chunkLeftover+                        then start + c * (chunkLen + 1)+                        else start + c * chunkLen + chunkLeftover++evenChunks :: [a] -> Int -> [[a]]+{-# INLINE evenChunks #-}+evenChunks xs n =+    let len = length xs+        {-# INLINE splitIndex #-}+        splitIndex = makeSplitIndex n 0 len+        chunk i =+            let s = splitIndex i+                e = splitIndex (i + 1)+            in take (e - s) (drop s xs)+    in map chunk [0..n-1]
+ Data/Yarr/Utils/Storable.hs view
@@ -0,0 +1,26 @@++module Data.Yarr.Utils.Storable where++import Foreign+import Data.Yarr.Utils.FixedVector as V++instance (Storable e, Vector v e) => Storable (v e) where+    sizeOf _ =+        let esize = sizeOf (undefined :: e)+            n = arity (undefined :: (Dim v))+        in n * esize++    alignment _ = alignment (undefined :: e)++    peek ptr =+        let eptr = castPtr ptr+        in V.generateM (\i -> peekElemOff eptr i)++    poke ptr v =+        let eptr = castPtr ptr+        in imapM_ (\i e -> pokeElemOff eptr i e) v++    {-# INLINE sizeOf #-}+    {-# INLINE alignment #-}+    {-# INLINE peek #-}+    {-# INLINE poke #-}
+ Data/Yarr/Utils/VecTuple.hs view
@@ -0,0 +1,85 @@++module Data.Yarr.Utils.VecTuple (+    VecTuple(..), makeVecTupleInstance+) where++import Language.Haskell.TH++import Data.Vector.Fixed (Dim(..), Arity(..), Fun(..), Vector(..))+import Data.Vector.Fixed.Internal (arity)+++data family VecTuple n e++funD' name cs =+    let fd = funD name cs+        inline = pragInlD name Inline ConLike AllPhases+    in [fd, inline]++makeVecTupleInstance arityType a = do++    let n = arity a+        ns = show n+        mkN name = mkName $ name ++ "_" ++ ns+        +        vtConName = mkN "VT"+        vtCon = conE vtConName++        e = varT $ mkName "e"+        tupleType = foldl appT (tupleT n) $ replicate n e++    familyInst <-+        newtypeInstD+            (cxt [])+            ''VecTuple+            [arityType, e]+            (recC vtConName+                  [varStrictType+                    (mkN "toTuple")+                    (strictType notStrict tupleType)])+            []++    let vn = (conT ''VecTuple) `appT` arityType+        vt = vn `appT` e++    dimInst <- tySynInstD ''Dim [vn] arityType+        +    let as = [mkName $ "a" ++ (show i) | i <- [1..n]]+        pas = fmap varP as+        eas = fmap varE as++        constructF = funD'+            (mkName "construct")+            [clause+                []+                (normalB $ appE (conE 'Fun) $ parensE $+                    lamE pas (appE vtCon (tupE eas)))+                []]++        instP = conP vtConName [tupP pas]+        fn = mkName "f"+        inspectF = funD'+            (mkName "inspect")+            [clause+                [instP, conP 'Fun [varP fn]]+                (normalB $ foldl appE (varE fn) eas)+                []]++    vectorInst <-+        instanceD+            (cxt [])+            ((conT ''Vector) `appT` vn `appT` e)+            (constructF ++ inspectF)+++    let selectNames =+            [mkName $ "sel_" ++ ns ++ "_" ++ (show i) | i <- [1..n]]+        makeSelect i = funD'+            (selectNames !! (i - 1))+            [clause [instP] (normalB $ eas !! (i - 1)) []]++    selectDs <- sequence $ concat $ map makeSelect [1..n]+++    return $ [familyInst, dimInst, vectorInst] ++ selectDs+
+ Data/Yarr/Utils/VecTupleInstances.hs view
@@ -0,0 +1,23 @@++module Data.Yarr.Utils.VecTupleInstances where++import Data.Vector.Fixed+import Data.Yarr.Utils.VecTuple++type N7 = S N6+type N8 = S N7++#define DERIV(n,clas) deriving instance clas e => clas (VecTuple (n) e)++#define VEC_TUPLE_INST(N,con,tup)               \+makeVecTupleInstance [t|N|] (undefined :: N);   \+DERIV(N, Eq); DERIV(N, Ord); DERIV(N, Bounded); \+DERIV(N, Read); DERIV(N, Show)++VEC_TUPLE_INST(N2,VT_2,(e, e))+VEC_TUPLE_INST(N3,VT_3,(e, e, e))+VEC_TUPLE_INST(N4,VT_4,(e, e, e, e))+VEC_TUPLE_INST(N5,VT_5,(e, e, e, e, e))+VEC_TUPLE_INST(N6,VT_6,(e, e, e, e, e, e))+VEC_TUPLE_INST(N7,VT_7,(e, e, e, e, e, e, e))+VEC_TUPLE_INST(N8,VT_8,(e, e, e, e, e, e, e, e))
+ LICENSE view
@@ -0,0 +1,21 @@+Copyright 2013 Roman Leventov <http://www.leventov.ru>+Based on Repa library, copyright 2010-2012, University of New South Wales.++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ yarr.cabal view
@@ -0,0 +1,96 @@+Name:                yarr+Version:             0.9.1+Synopsis:            Yet another array library+Description:+    Yarr is a new blazing fast dataflow framework (array library),+    mainly intented to process @Storable@s (including all \"primitive\" numeric types)+    and @fixed-vector@s of them, for example coordinates,+    color components, complex numbers.+    .+    Yarr framework is inspired by @repa@ library and inherits its features,+    including shape-polymorphism and auto-parallelism.+    Additionaly, the framework is polymorphic over type and arity+    of fixed-size vectors and supports neat flow operations over them.+    For example, you can convert colored image to greyscale like this:+    .+    > let greyImage = zipElems (\r g b -> 0.21 * r + 0.71 * g + 0.07 * b) image+    .+    The library is considerably faster than @repa@.+    Canny edge detector on Yarr is 40% (on 5 threads)+    and 55% (in sequential mode) faster then on @repa@.+    .+    Shortcoming by design: lack of pure indexing interface.+    .+    /Work ahead:/+    .+        * Safe fold wrappers+    .+        * Unresolved issues with parameterized unrolling in slice-wise loading+    .+    To start with, read documentation in the root module: "Data.Yarr".+    .+    [@Yarr!@] ++License:             MIT+License-file:        LICENSE+Author:              Roman Leventov+Maintainer:          Roman Leventov <leventov@ya.ru>+Bug-reports:         https://github.com/leventov/yarr/issues+Category:            Data Structures, Data Flow, Graphics+Build-type:          Simple+Cabal-version:       >= 1.8++source-repository head+    type:     git+    location: https://github.com/leventov/yarr.git+    subdir:   yarr++Library+    build-depends:+        base             == 4.6.*,+        ghc-prim         == 0.3.*,+        deepseq          == 1.3.*,+        fixed-vector     == 0.1.2.1,+        primitive        >= 0.2,+        template-haskell == 2.8.*,+        missing-foreign  == 0.1.1++    extensions:+        TypeFamilies, MultiParamTypeClasses, FunctionalDependencies,+        FlexibleContexts,+        EmptyDataDecls,+        FlexibleInstances, TypeSynonymInstances, UndecidableInstances,+        GeneralizedNewtypeDeriving, StandaloneDeriving,+        RankNTypes, ScopedTypeVariables,+        MagicHash, BangPatterns, UnboxedTuples,+        TemplateHaskell, CPP++    exposed-modules:+        Data.Yarr+        Data.Yarr.Base+        Data.Yarr.Eval+        Data.Yarr.Flow+        Data.Yarr.Shape+        Data.Yarr.Repr.Foreign+        Data.Yarr.Repr.Boxed+        Data.Yarr.Repr.Delayed+        Data.Yarr.Repr.Separate+        Data.Yarr.Repr.Checked+        Data.Yarr.Convolution+        Data.Yarr.Utils.FixedVector+        Data.Yarr.Utils.Fork+        Data.Yarr.Utils.Parallel+        Data.Yarr.Utils.Split+        Data.Yarr.Utils.Storable+        Data.Yarr.Utils.Primitive+        Data.Yarr.Utils.LowLevelFlow++    other-modules:+        -- re-exported in Utils.FixedVector+        Data.Yarr.Utils.VecTuple+        Data.Yarr.Utils.VecTupleInstances++        -- re-exported in Data.Yarr.Convolution+        Data.Yarr.Convolution.Repr+        Data.Yarr.Convolution.Eval+        Data.Yarr.Convolution.StaticStencils