packages feed

yarr 0.9.1 → 0.9.2

raw patch · 26 files changed

+765/−379 lines, 26 files

Files

Data/Yarr.hs view
@@ -47,14 +47,15 @@           Useful for advanced hand-controlled flow operations.          * /Meta/ representations: 'SE'parate-          and 'Data.Yarr.Repr.Checked.CHK' (CHecKed).+          and 'Debug.Yarr.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.+          'Debug.Yarr.CHK' is useful for debugging,+          it raises error on illegal indexing attempt.+          By default indexing is unchecked.           /Representation choice:/
Data/Yarr/Convolution.hs view
@@ -2,6 +2,12 @@ module Data.Yarr.Convolution (     -- * Convoluted representation     module Data.Yarr.Convolution.Repr,+    -- | There is also @Convoluted@ 'UArray' family constructor,+    -- which isn't presented in the docs because Haddock+    -- doesn't support associated family constructors.+    --+    -- See source of "Data.Yarr.Convolution.Repr" module.+     module Data.Yarr.Convolution.Eval,     -- * Static stencils     module Data.Yarr.Convolution.StaticStencils
Data/Yarr/Convolution/Eval.hs view
@@ -107,7 +107,8 @@   instance (BlockShape sh, Vector v e,-          UVecTarget tr tslr tl sh v2 e, Dim v ~ Dim v2) =>+          UVecTarget tr tslr tl sh v2 e, Dim v ~ Dim v2,+          InlinableArity (Dim v)) =>         VecLoad (SE CV) CV CVL tr tslr tl sh v v2 e where          -- These functions aren't inlined propely with any first argument,@@ -122,7 +123,8 @@     {-# INLINE loadSlicesS #-}  instance (BlockShape sh, Vector v e,-          UVecTarget tr tslr tl sh v2 e, Dim v ~ Dim v2) =>+          UVecTarget tr tslr tl sh v2 e, Dim v ~ Dim v2,+          InlinableArity (Dim v)) =>         RangeVecLoad (SE CV) CV CVL tr tslr tl sh v v2 e where     rangeLoadSlicesP = cvLoadSlicesP     rangeLoadSlicesS = cvLoadSlicesS@@ -133,7 +135,7 @@ 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)+        Vector v e, Dim v ~ Dim v2, InlinableArity (Dim v))     => Fill sh e     -> Threads     -> UArray (SE CV) CVL sh (v e)@@ -141,7 +143,7 @@     -> sh -> sh     -> IO () {-# INLINE cvLoadSlicesP #-}-cvLoadSlicesP fill threads arr tarr start end = do+cvLoadSlicesP fill threads = \arr tarr start end -> do     force arr     force tarr     !ts <- threads@@ -151,14 +153,16 @@          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+        loadCenters =+            V.inlinableMap (\c -> intersectBlocks (vl_2 c loadRange)) centers+        writes = V.inlinableMap write (slices tarr)+        borderGets = V.inlinableMap borderGet sls+        borderFills = V.inlinableZipWith S.fill borderGets writes -        centerGets = V.map centerGet sls-        centerFills = V.zipWith fill centerGets writes+        centerGets = V.inlinableMap centerGet sls +        centerFills = V.inlinableZipWith fill centerGets writes+         {-# INLINE centerWork #-}         centerWork = makeForkSlicesOnce ts loadCenters centerFills @@ -212,7 +216,7 @@  cvLoadSlicesS     :: (BlockShape sh, UVecTarget tr tslr tl sh v2 e,-        Vector v e, Dim v ~ Dim v2)+        Vector v e, Dim v ~ Dim v2, InlinableArity (Dim v))     => Fill sh e     -> UArray (SE CV) CVL sh (v e)     -> UArray tr tl sh (v2 e)@@ -224,12 +228,12 @@     force tarr          let sls = slices arr-        borderGets = V.map borderGet sls+        borderGets = V.inlinableMap borderGet sls         centers = V.map center sls -        centerGets = V.map centerGet sls-        writes = V.map write (slices tarr)-        centerFills = V.zipWith fill centerGets writes+        centerGets = V.inlinableMap centerGet sls+        writes = V.inlinableMap write (slices tarr)+        centerFills = V.inlinableZipWith fill centerGets writes          loadRange = (start, end)         loadCenters = V.map (\c -> intersectBlocks (vl_2 c loadRange)) centers@@ -239,15 +243,10 @@         centerFills loadCenters      let borders = V.map (clipBlock loadRange) loadCenters-        borderFills = V.zipWith S.fill borderGets writes+        borderFills = V.inlinableZipWith 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
@@ -1,6 +1,8 @@  module Data.Yarr.Convolution.Repr (-    CV, CVL, UArray(..), justCenter,+    CV, CVL,+    UArray(..),+    justCenter, ) where  import Prelude as P@@ -17,7 +19,7 @@ --  * 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+--  * fast /center get/, which doesn't worry about bound checks -- -- and 'center' 'Block'. data CV@@ -30,12 +32,16 @@ -- 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+-- Element-wise Loading convoluted arrays wasn't inlined propely -- with unrolled 'Fill'ing ('unrolledFill', 'dim2BlockFill').--- However, with simple 'fill' performance is OK.+-- However, with simple 'fill' performance was OK. -- -- For details see -- <http://stackoverflow.com/questions/14748900/ghc-doesnt-perform-2-stage-partial-application-inlining>+--+-- /ALMOST SOLVED:/ you just need to support unrolled filling function with @INLINE@ pragma,+-- see <https://github.com/leventov/yarr/blob/master/tests/blur.hs>,+-- @ffill@ function. data CVL  instance Shape sh => Regular CV CVL sh a where
Data/Yarr/Convolution/StaticStencils.hs view
@@ -5,7 +5,7 @@     dConvolveDim1WithStaticStencil, convolveDim1WithStaticStencil,      -- ** Dim2 stencils-    Dim2Stencil(..), dim2St,+    Dim2Stencil(..), dim2St, dim2OutClamp,     dConvolveShDim2WithStaticStencil, convolveShDim2WithStaticStencil,     dConvolveLinearDim2WithStaticStencil, convolveLinearDim2WithStaticStencil ) where@@ -29,8 +29,8 @@     Dim1Stencil {         dim1StencilSize   :: size,         dim1StencilValues :: (VecList size b),-        dim1StencilReduce :: (c -> a -> b -> IO c), -- ^ Generalized reduce function-        dim1StencilZero   :: c                      -- ^ Reduce zero+        dim1StencilReduce :: c -> a -> b -> IO c, -- ^ Generalized reduce function+        dim1StencilZero   :: IO c                 -- ^ Reduce zero     }  -- | QuasiQuoter for producing typical numeric convolving 'Dim1' stencil,@@ -44,13 +44,13 @@ --'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+--       [\\ 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)+--    (return 0) -- @ dim1St :: QuasiQuoter dim1St = QuasiQuoter parseDim1Stencil undefined undefined undefined@@ -62,7 +62,7 @@         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 |]+    in [| Dim1Stencil $sz $vecList (\acc a reduce -> reduce acc a) (return 0) |]   -- | Generalized static 'Dim2' stencil.@@ -70,9 +70,9 @@     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+        dim2StencilValues :: VecList sy (VecList sx b), -- ^ Stencil values, packed in nested vectors+        dim2StencilReduce :: c -> a -> b -> IO c,       -- ^ Generalized reduce function+        dim2StencilZero :: IO c                         -- ^ Reduce zero     }  -- | Most useful 'Dim2' stencil producer.@@ -93,19 +93,19 @@ --  'n3' --  ('VecList' --     ['VecList'---        [\ acc a -> return (acc + a),---         \ acc a -> (return $ (acc + (2 * a))),---         \ acc a -> return (acc + a)],+--        [\\ 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],+--        [\\ 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+--        [\\ acc a -> return (acc - a),+--         \\ acc a -> (return $ (acc + (-2 * a))),+--         \\ acc a -> return (acc - a)]])+--  (\\ acc a reduce -> reducej acc a)+--  (return 0) -- @ dim2St :: QuasiQuoter dim2St = QuasiQuoter parseDim2Stencil undefined undefined undefined@@ -128,7 +128,7 @@             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 |]+    in [| Dim2Stencil $sx $sy $outerList (\acc a reduce -> reduce acc a) (return 0) |]   justNonZero :: Integer -> Q Exp@@ -167,14 +167,16 @@     -> UArray CV CVL Dim1 c  -- ^ Fused convolved result array {-# INLINE convolveDim1WithStaticStencil #-} convolveDim1WithStaticStencil-        borderIndex (Dim1Stencil _ stencil reduce z) arr =+        borderIndex (Dim1Stencil _ stencil reduce mz) arr =      let !startOff = arity (undefined :: so)         !endOff = arity (undefined :: eo)          {-# INLINE sget #-}         sget get =-            \ix -> V.iifoldM+            \ix -> do+                z <- mz+                V.iifoldM                     (-startOff)                     succ                     (\acc i b -> do@@ -242,7 +244,7 @@     -> UArray CV CVL Dim2 c    -- ^ Fused convolved result array {-# INLINE convolveShDim2WithStaticStencil #-} convolveShDim2WithStaticStencil-        borderIndex (Dim2Stencil _ _ stencil reduce z) arr =+        borderIndex (Dim2Stencil _ _ stencil reduce mz) arr =      let !startOffX = arity (undefined :: sox)         !endOffX = arity (undefined :: eox)@@ -252,7 +254,8 @@          {-# INLINE sget #-}         sget get =-            \ (y, x) ->+            \ (y, x) -> do+                z <- mz                 V.iifoldM                     (-startOffY)                     succ@@ -289,7 +292,7 @@     convolveLinearDim2WithStaticStencil dim2OutClamp  -- | Analog of 'convolveShDim2WithStaticStencil'--- to conv+-- to convolve arrays with 'L'inear load index. convolveLinearDim2WithStaticStencil     :: forall r sx sox eox sy soy eoy a b c.        (StencilOffsets sx sox eox, StencilOffsets sy soy eoy,@@ -303,7 +306,7 @@     -> UArray CV CVL Dim2 c    -- ^ Fused convolved result array {-# INLINE convolveLinearDim2WithStaticStencil #-} convolveLinearDim2WithStaticStencil-        borderIndex (Dim2Stencil _ _ stencil reduce z) arr =+        borderIndex (Dim2Stencil _ _ stencil reduce mz) arr =      let !startOffX = arity (undefined :: sox)         !endOffX = arity (undefined :: eox)@@ -313,7 +316,8 @@          {-# INLINE sget #-}         sget get =-            \ (y, x) ->+            \ (y, x) -> do+                z <- mz                 V.iifoldM                     (-startOffY)                     succ@@ -332,7 +336,8 @@         !sh@(shY, shX) = extent arr          {-# INLINE slget #-}-        slget !(!y, !x) =+        slget !(!y, !x) = do+            z <- mz             V.iifoldM                 (-startOffY)                 succ
Data/Yarr/Eval.hs view
@@ -9,6 +9,7 @@     Load(..), RangeLoad(..),     VecLoad(..), RangeVecLoad(..),     compute,+    dComputeP, dComputeS,      -- * Common load types     L, SH,@@ -72,7 +73,7 @@ -- 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) =>+class (USource r l sh a, UTarget tr tl sh a, Shape (LoadIndex l tl sh)) =>         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@.@@ -182,7 +183,8 @@ --  * @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) =>+       Load slr l tslr tl sh e, Shape (LoadIndex l tl sh),+       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 @@ -258,10 +260,26 @@     -> IO (UArray tr tl sh b) -- ^ Entirely loaded from the source,                               -- 'freeze'd manifest target array {-# INLINE compute #-}-compute load arr = do+compute load = \arr -> do     marr <- new (extent arr)     load arr marr     freeze marr++dComputeP+    :: (USource r l sh a, Manifest tr mtr tl sh a,+        Load r l mtr tl sh a)+    => UArray r l sh a +    -> IO (UArray tr tl sh a)+{-# INLINE dComputeP #-}+dComputeP = compute (loadP fill caps)++dComputeS+    :: (USource r l sh a, Manifest tr mtr tl sh a,+        Load r l mtr tl sh a)+    => UArray r l sh a +    -> IO (UArray tr tl sh a)+{-# INLINE dComputeS #-}+dComputeS = compute (loadS fill)  -- | Determines maximum common range of 2 arrays - -- 'intersect'ion of their 'extent's.
Data/Yarr/Flow.hs view
@@ -68,9 +68,8 @@ --     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)+    :: (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@@ -84,9 +83,8 @@ -- -- @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)+    :: (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
+ Data/Yarr/Fold.hs view
@@ -0,0 +1,190 @@++module Data.Yarr.Fold (+    -- * Fold support+    Fold,+    reduceL, reduceLeftM,+    reduceR, reduceRightM,++    -- * Fold runners+    runFold, runFoldP,+    runFoldSlicesSeparate, runFoldSlicesSeparateP,++    -- * Shortcuts+    toList,+) where++import Prelude as P+import Control.Monad as M+import Data.List (groupBy)+import Data.Function (on)++import Data.Yarr.Base+import Data.Yarr.Shape as S+import Data.Yarr.Eval+import Data.Yarr.Convolution++import Data.Yarr.Utils.FixedVector as V hiding (toList)+import Data.Yarr.Utils.Fork+import Data.Yarr.Utils.Parallel+++class Shape fsh => Reduce l ash fsh | l ash -> fsh where+    getIndex :: USource r l ash a => UArray r l ash a -> (fsh -> IO a)+    getSize :: USource r l ash a => UArray r l ash a -> fsh++#define SH_GET_INDEX(l,sh)      \+instance Reduce l sh sh where { \+    getIndex = index;           \+    getSize = extent;           \+    {-# INLINE getIndex #-};    \+    {-# INLINE getSize #-};     \+}++SH_GET_INDEX(SH, Dim1)+SH_GET_INDEX(SH, Dim2)+SH_GET_INDEX(SH, Dim3)++SH_GET_INDEX(CVL, Dim1)+SH_GET_INDEX(CVL, Dim2)+SH_GET_INDEX(CVL, Dim3)+++#define LINEAR_GET_INDEX(l,sh)   \+instance Reduce l sh Int where { \+    getIndex = linearIndex;      \+    getSize = size . extent;     \+    {-# INLINE getIndex #-};     \+    {-# INLINE getSize #-};      \+}++LINEAR_GET_INDEX(L, Dim1)+LINEAR_GET_INDEX(L, Dim2)+LINEAR_GET_INDEX(L, Dim3)+++-- | Curried 'Foldl' or 'Foldr'.+-- Generalizes both partially applied left and right folds.+--+-- See source of following 4 functions to construct more similar ones,+-- if you need.+type Fold sh a b = +       IO b         -- ^ Zero+    -> (sh -> IO a) -- ^ Get+    -> sh           -- ^ Start+    -> sh           -- ^ End+    -> IO b         -- ^ Result++-- | /O(0)/+reduceLeftM+    :: Foldl sh a b     -- ^ 'S.foldl' or curried 'S.unrolledFoldl'+    -> (b -> a -> IO b) -- ^ Monaric left reduce+    -> Fold sh a b      -- ^ Curried fold to be passed to 'runFold' functions.+{-# INLINE reduceLeftM #-}+reduceLeftM foldl rf = foldl (\b _ a -> rf b a)++-- | /O(0)/+reduceL+    :: Foldl sh a b  -- ^ 'S.foldl' or curried 'S.unrolledFoldl'+    -> (b -> a -> b) -- ^ Pure left reduce+    -> Fold sh a b   -- ^ Curried fold to be passed to 'runFold' functions.+{-# INLINE reduceL #-}+reduceL foldl rf = foldl (\b _ a -> return $ rf b a)++-- | /O(0)/+reduceRightM+    :: Foldr sh a b     -- ^ 'S.foldr' or curried 'S.unrolledFoldr'+    -> (a -> b -> IO b) -- ^ Monaric right reduce+    -> Fold sh a b      -- ^ Curried fold to be passed to 'runFold' functions.+{-# INLINE reduceRightM #-}+reduceRightM foldr rf = foldr (\_ a b -> rf a b)++-- | /O(0)/+reduceR+    :: Foldr sh a b  -- ^ 'S.foldr' or curried 'S.unrolledFoldr'+    -> (a -> b -> b) -- ^ Pure right reduce+    -> Fold sh a b   -- ^ Curried fold to be passed to 'runFold' functions.+{-# INLINE reduceR #-}+reduceR foldr rf = foldr (\_ a b -> return $ rf a b)+++-- | /O(n)/+--+-- Example:+--+-- @'toList' = runFold ('reduceR' 'S.foldr' (:)) (return [])@+runFold+    :: (USource r l sh a, Reduce l sh fsh)+    => Fold fsh a b     -- ^ Curried folding worker function+    -> IO b             -- ^ Monadic fold zero. Wrap pure zero in 'return'.+    -> UArray r l sh a  -- ^ Source array +    -> IO b             -- ^ Fold result+{-# INLINE runFold #-}+runFold fold mz arr = do+    force arr+    res <- fold mz (getIndex arr) zero (getSize arr)+    touchArray arr+    return res++-- | /O(n)/ Run associative fold in parallel.+--+-- Example -- associative image histogram filling in the test:+-- <https://github.com/leventov/yarr/blob/master/tests/lum-equalization.hs>+runFoldP+    :: (USource r l sh a, Reduce l sh fsh)+    => Threads          -- ^ Number of threads to parallelize folding on+    -> Fold fsh a b     -- ^ Curried folding worker function+    -> IO b             -- ^ Monadic fold zero. Wrap pure zero in 'return'.+    -> (b -> b -> IO b) -- ^ Associative monadic result joining function+    -> UArray r l sh a  -- ^ Source array+    -> IO b             -- ^ Fold result+{-# INLINE runFoldP #-}+runFoldP threads fold mz join arr = do+    force arr+    ts <- threads+    (r:rs) <- parallel ts $+                makeFork ts zero (getSize arr) (fold mz (getIndex arr))+    touchArray arr++    M.foldM join r rs++-- | /O(n)/ +runFoldSlicesSeparate+    :: (UVecSource r slr l sh v e, Reduce l sh fsh)+    => Fold fsh e b           -- ^ Curried folding function to work on slices+    -> IO b                   -- ^ Monadic fold zero. Wrap pure zero in 'return'.+    -> UArray r l sh (v e)    -- ^ Source array of vectors+    -> IO (VecList (Dim v) b) -- ^ Vector of fold results+{-# INLINE runFoldSlicesSeparate #-}+runFoldSlicesSeparate fold mz arr =+    V.mapM (\sl -> runFold fold mz sl) (slices arr)++-- | /O(n)/ Run associative fold over slices of array of vectors in parallel.+runFoldSlicesSeparateP+    :: (UVecSource r slr l sh v e, Reduce l sh fsh)+    => Threads                -- ^ Number of threads to parallelize folding on+    -> Fold fsh e b           -- ^ Curried folding function to work on slices+    -> IO b                   -- ^ Monadic fold zero. Wrap pure zero in 'return'.+    -> (b -> b -> IO b)       -- ^ Associative monadic result joining function+    -> UArray r l sh (v e)    -- ^ Source array of vectors+    -> IO (VecList (Dim v) b) -- ^ Vector of fold results+{-# INLINE runFoldSlicesSeparateP #-}+runFoldSlicesSeparateP threads fold mz join arr = do+    force arr+    ts <- threads+    trs <- parallel ts $+            makeForkSlicesOnce+                ts+                (V.replicate (zero, getSize arr))+                (V.map (\sl -> fold mz (getIndex sl)) (slices arr))+    touchArray arr++    let rsBySlices = P.map (P.map snd) $ groupBy ((==) `on` fst) $ concat trs+    rs <- M.mapM (\(r:rs) -> M.foldM join r rs) rsBySlices+    return (VecList rs)++-- | /O(n)/ Covert array to list.+toList+    :: (USource r l sh a, Reduce l sh fsh)+    => UArray r l sh a+    -> IO [a]+toList = runFold (reduceR S.foldr (:)) (return [])
Data/Yarr/Repr/Boxed.hs view
@@ -1,5 +1,14 @@ -module Data.Yarr.Repr.Boxed where+module Data.Yarr.Repr.Boxed (+    B, MB,+    -- | There are also @Boxed@  and @MutableBoxed@+    -- 'UArray' family constructors,+    -- which aren't presented in the docs because Haddock+    -- doesn't support associated family constructors.+    --+    -- See source of "Data.Yarr.Repr.Boxed" module.+    UArray(..)+) where  import Control.Monad.ST (RealWorld) import Data.Primitive.Array@@ -8,6 +17,7 @@ import Data.Yarr.Shape import Data.Yarr.Repr.Delayed import Data.Yarr.Repr.Separate+import Debug.Yarr  -- | 'B'oxed representation is a wrapper for 'Data.Primitive.Array.Array' -- from @primitive@ package. It may be used to operate with arrays@@ -75,4 +85,4 @@     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"+uninitialized = yerr "Uninitialized element in the boxed array"
− Data/Yarr/Repr/Checked.hs 
@@ -1,79 +0,0 @@--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
@@ -2,13 +2,18 @@ module Data.Yarr.Repr.Delayed (     -- * Delayed source     D,-    Regular,-    UArray(LinearDelayed, ShapeDelayed, ShapeDelayedTarget),-    L, SH, delay, delayShaped,     -- * Delayed target     DT,+    -- | There are also @LinearDelayed@, @ShapeDelayed@ and @ShapeDelayedTarget@+    -- 'UArray' family constructors,+    -- which aren't presented in the docs because Haddock+    -- doesn't support associated family constructors.+    --+    -- See source of "Data.Yarr.Repr.Delayed" module.+    UArray(..), -    +    -- * Misc+    L, SH, delay, delayShaped, ) where  import Prelude as P
Data/Yarr/Repr/Foreign.hs view
@@ -1,9 +1,17 @@  module Data.Yarr.Repr.Foreign (-    F, Storable, L,+    F, FS,+    -- | There are also @ForeignArray@  and @ForeignSlice@+    -- 'UArray' family constructors,+    -- which aren't presented in the docs because Haddock+    -- doesn't support associated family constructors.+    --+    -- See source of "Data.Yarr.Repr.Foreign" module.+    UArray(..),+    +    Storable, L,     newEmpty,     toForeignPtr, unsafeFromForeignPtr,-    FS, ) where  import Foreign
Data/Yarr/Repr/Separate.hs view
@@ -1,7 +1,15 @@  module Data.Yarr.Repr.Separate (-    -- * Separate representation-    SE, fromSlices, unsafeMapSlices,+    -- * @Separate@ representation+    SE,+    -- | There is also @Separate@ 'UArray' family constructor,+    -- which isn't presented in the docs because Haddock+    -- doesn't support associated family constructors.+    --+    -- See source of "Data.Yarr.Repr.Separate" module.+    UArray(..),+    +    fromSlices, unsafeMapSlices,     Data.Yarr.Repr.Separate.convert,      -- * Element-wise fusion for arrays of vectors
Data/Yarr/Shape.hs view
@@ -17,12 +17,28 @@ -- 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 -> IO a)       -- ^ Get     -> (sh -> a -> IO ()) -- ^ Write     -> sh                 -- ^ Start     -> sh                 -- ^ End     -> IO () +type Foldl sh a b =+       (b -> sh -> a -> IO b) -- ^ Generalized left reduce+    -> IO b                   -- ^ Zero+    -> (sh -> IO a)           -- ^ Get+    -> sh                     -- ^ Start+    -> sh                     -- ^ End+    -> IO b                   -- ^ Result++type Foldr sh a b =+       (sh -> a -> b -> IO b) -- ^ Generalized right reduce+    -> IO b                   -- ^ Zero+    -> (sh -> IO a)           -- ^ Get+    -> sh                     -- ^ Start+    -> sh                     -- ^ End+    -> IO b                   -- ^ Result+ -- | Mainly for internal use. -- Abstracts top-left -- bottom-right pair of indices. type Block sh = (sh, sh)@@ -80,47 +96,27 @@     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+    -- to 'Data.Yarr.Eval.Load' and functions from+    -- "Data.Yarr.Fold" module.+    makeChunkRange :: Int -> sh -> sh -> (Int -> Block sh) +    foldl :: Foldl sh a b+     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+        -> Foldl sh a b -    foldr :: (sh -> a -> b -> IO b) -- ^ Generalized reduce-          -> b                      -- ^ Zero-          -> (sh -> IO a)           -- ^ Get-          -> sh                     -- ^ Start-          -> sh                     -- ^ End-          -> IO b                   -- ^ Result+    foldr :: Foldr sh a b      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+        -> Foldr sh a b      -- | Standard fill without unrolling.     -- To avoid premature optimization just type @fill@@@ -175,19 +171,19 @@         \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#+    foldl reduce mz get =+        \ (I# start#) (I# end#) -> foldl# reduce mz get start# end# -    unrolledFoldl unrollFactor tch reduce z get =+    unrolledFoldl unrollFactor tch reduce mz get =         \ (I# start#) (I# end#) ->-            unrolledFoldl# unrollFactor tch reduce z get start# end#+            unrolledFoldl# unrollFactor tch reduce mz get start# end# -    foldr reduce z get =-        \ (I# start#) (I# end#) -> foldr# reduce z get start# end#+    foldr reduce mz get =+        \ (I# start#) (I# end#) -> foldr# reduce mz get start# end# -    unrolledFoldr unrollFactor tch reduce z get =+    unrolledFoldr unrollFactor tch reduce mz get =         \ (I# start#) (I# end#) ->-            unrolledFoldr# unrollFactor tch reduce z get start# end# +            unrolledFoldr# unrollFactor tch reduce mz get start# end#       {-# INLINE zero #-}     {-# INLINE size #-}@@ -296,19 +292,20 @@                             goY# (y# +# 1#)                 in goY# sy# -    foldl reduce z get =+    foldl reduce mz 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+                        b' <- foldl (\b x a -> reduce b (y, x) a)+                                    (return b)                                     (\x -> get (y, x))                                     sx ex                         go (y + 1) b'-            in go sy z+            in mz >>= go sy -    unrolledFoldl unrollFactor tch reduce z get =+    unrolledFoldl unrollFactor tch reduce mz get =         \ (!sy, !sx) (!ey, !ex) ->             let {-# INLINE go #-}                 go y b@@ -316,26 +313,28 @@                     | otherwise = do                         b' <- unrolledFoldl                                 unrollFactor tch-                                (\b x a -> reduce b (y, x) a) b+                                (\b x a -> reduce b (y, x) a)+                                (return b)                                 (\x -> get (y, x))                                 sx ex                         go (y + 1) b'-            in go sy z+            in mz >>= go sy  -    foldr reduce z get =+    foldr reduce mz 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+                        b' <- foldr (\x a b -> reduce (y, x) a b)+                                    (return b)                                     (\x -> get (y, x))                                     sx ex                         go (y - 1) b'-            in go (ey - 1) z+            in mz >>= go (ey - 1) -    unrolledFoldr unrollFactor tch reduce z get =+    unrolledFoldr unrollFactor tch reduce mz get =         \ (!sy, !sx) (!ey, !ex) ->             let {-# INLINE go #-}                 go y b@@ -344,11 +343,11 @@                         b' <- unrolledFoldr                                 unrollFactor tch                                 (\x a b -> reduce (y, x) a b)-                                b+                                (return b)                                 (\x -> get (y, x))                                 sx ex                         go (y - 1) b'-            in go (ey - 1) z+            in mz >>= go (ey - 1)      {-# INLINE zero #-}     {-# INLINE size #-}@@ -391,7 +390,7 @@ -- @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.+    => 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@@ -506,20 +505,21 @@                     in go sz         in actualFill uf -    foldl reduce zero get =+    foldl reduce mz 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+                                (\b (y, x) a -> reduce b (z, y, x) a)+                                (return b)                                 (\(y, x) -> get (z, y, x))                                 (sy, sx) (ey, ex)                         go (z + 1) b'-            in go sz zero+            in mz >>= go sz -    unrolledFoldl unrollFactor tch reduce zero get =+    unrolledFoldl unrollFactor tch reduce mz get =         \ (!sz, !sy, !sx) (!ez, !ey, !ex) ->             let {-# INLINE go #-}                 go z b@@ -527,27 +527,29 @@                     | otherwise = do                         b' <- unrolledFoldl                                 unrollFactor tch-                                (\b (y, x) a -> reduce b (z, y, x) a) b+                                (\b (y, x) a -> reduce b (z, y, x) a)+                                (return b)                                 (\(y, x) -> get (z, y, x))                                 (sy, sx) (ey, ex)                         go (z + 1) b'-            in go sz zero+            in mz >>= go sz  -    foldr reduce zero get =+    foldr reduce mz 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) a b -> reduce (z, y, x) a b)+                                (return b)                                 (\(y, x) -> get (z, y, x))                                 (sy, sx) (ey, ex)                         go (z - 1) b'-            in go (ez - 1) zero+            in mz >>= go (ez - 1) -    unrolledFoldr unrollFactor tch reduce zero get =+    unrolledFoldr unrollFactor tch reduce mz get =         \ (!sz, !sy, !sx) (!ez, !ey, !ex) ->             let {-# INLINE go #-}                 go z b@@ -555,11 +557,12 @@                     | otherwise = do                         b' <- unrolledFoldr                                 unrollFactor tch-                                (\(y, x) a b -> reduce (z, y, x) a b) b+                                (\(y, x) a b -> reduce (z, y, x) a b)+                                (return b)                                 (\(y, x) -> get (z, y, x))                                 (sy, sx) (ey, ex)                         go (z - 1) b'-            in go (ez - 1) zero+            in mz >>= go (ez - 1)      {-# INLINE zero #-}     {-# INLINE size #-}
Data/Yarr/Utils/FixedVector.hs view
@@ -19,9 +19,12 @@      -- * VecTuple     VecTuple(..),-    module Data.Yarr.Utils.VecTupleInstances,+    module Data.Yarr.Utils.FixedVector.VecTupleInstances,     makeVecTupleInstance, +    -- * InlinableArity+    InlinableArity(..), makeInlinableArityInstance,+ ) where  import Prelude hiding (foldl, zipWith, zipWith3, all, any, sequence_)@@ -31,34 +34,14 @@ 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-+import Data.Yarr.Utils.FixedVector.Arity -n7 :: N7-n7 = undefined+import Data.Yarr.Utils.FixedVector.VecTuple+import Data.Yarr.Utils.FixedVector.VecTupleInstances +import Data.Yarr.Utils.FixedVector.InlinableArity+import Data.Yarr.Utils.FixedVector.InlinableArityInstances -n8 :: N8-n8 = undefined  vl_1 :: a -> VecList N1 a {-# INLINE vl_1 #-}
+ Data/Yarr/Utils/FixedVector/Arity.hs view
@@ -0,0 +1,31 @@++module Data.Yarr.Utils.FixedVector.Arity where++import Data.Vector.Fixed++type N7 = S N6+type N8 = S N7++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
+ Data/Yarr/Utils/FixedVector/InlinableArity.hs view
@@ -0,0 +1,78 @@++module Data.Yarr.Utils.FixedVector.InlinableArity where++import Language.Haskell.TH hiding (Arity)++import Data.Vector.Fixed (Dim(..), Arity(..), Fun(..), Vector(..), (!), VecList(..), convert)+import Data.Vector.Fixed.Internal (arity)++-- | Workaround for slice-wise currined filling functions inlining issues.+-- See comment to 'Data.Yarr.Convolution.CVL' for details.+class Arity ar => InlinableArity ar where+    inlinableZipWith+        :: (Vector v a, Vector v b, Vector v c, Dim v ~ ar)+        => (a -> b -> c) -> v a -> v b -> v c++    inlinableMap+        :: (Vector v a, Vector v b, Dim v ~ ar)+        => (a -> b) -> v a -> v b+++makeInlinableArityInstance arityType a = do+    let n = fromIntegral $ arity a+        cfNames = map (\i -> mkName ("cf_" ++ (show i))) [1..n]+        cfs = map varE cfNames+        +        fN = mkName "f"+        fP = varP fN+        f = varE fN++        asN = mkName "as"+        asP = varP asN+        as = varE asN++        bsN = mkName "bs"+        bsP = varP bsN+        bs = varE bsN++        construct' vs =+            [| convert $ VecList $(listE vs) |]++        zipF = funD'+            'inlinableZipWith+            [clause+                [fP, asP, bsP]+                (normalB $+                    letE (concat $ zipWith+                            (\i cfN ->+                                let ie = litE (integerL i)+                                    ix l = [| (!) |] `appE` l `appE` ie+                                in funD' cfN [clause [] (normalB $ f `appE` (ix as) `appE` (ix bs)) []])+                            [0..n-1]+                            cfNames)+                         (construct' cfs))+                []]++        mapF = funD'+            'inlinableMap+            [clause+                [fP, asP]+                (normalB $+                    letE (concat $ zipWith+                            (\i cfN ->+                                let ie = litE (integerL i)+                                    ix l = [| (!) |] `appE` l `appE` ie+                                in funD' cfN [clause [] (normalB $ f `appE` (ix as)) []])+                            [0..n-1]+                            cfNames)+                         (construct' cfs))+                []]++    inst <- instanceD (cxt []) ((conT ''InlinableArity) `appT` arityType) (zipF ++ mapF)+    return [inst]+++funD' name cs =+    let fd = funD name cs+        inline = pragInlD name Inline ConLike AllPhases+    in [fd, inline]
+ Data/Yarr/Utils/FixedVector/InlinableArityInstances.hs view
@@ -0,0 +1,15 @@++module Data.Yarr.Utils.FixedVector.InlinableArityInstances where++import Data.Vector.Fixed+import Data.Yarr.Utils.FixedVector.Arity+import Data.Yarr.Utils.FixedVector.InlinableArity++makeInlinableArityInstance [t| N1 |] n1+makeInlinableArityInstance [t| N2 |] n2+makeInlinableArityInstance [t| N3 |] n3+makeInlinableArityInstance [t| N4 |] n4+makeInlinableArityInstance [t| N5 |] n5+makeInlinableArityInstance [t| N6 |] n6+makeInlinableArityInstance [t| N7 |] n7+makeInlinableArityInstance [t| N8 |] n8
+ Data/Yarr/Utils/FixedVector/VecTuple.hs view
@@ -0,0 +1,85 @@++module Data.Yarr.Utils.FixedVector.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'+            'construct+            [clause+                []+                (normalB $ appE (conE 'Fun) $ parensE $+                    lamE pas (appE vtCon (tupE eas)))+                []]++        instP = conP vtConName [tupP pas]+        fn = mkName "f"+        inspectF = funD'+            '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/FixedVector/VecTupleInstances.hs view
@@ -0,0 +1,21 @@++module Data.Yarr.Utils.FixedVector.VecTupleInstances where++import Data.Vector.Fixed+import Data.Yarr.Utils.FixedVector.Arity+import Data.Yarr.Utils.FixedVector.VecTuple++#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))
Data/Yarr/Utils/LowLevelFlow.hs view
@@ -49,12 +49,12 @@  foldl#     :: (b -> Int -> a -> IO b)-    -> b+    -> IO b     -> (Int -> IO a)     -> Int# -> Int#     -> IO b {-# INLINE foldl# #-}-foldl# reduce z get start# end# =+foldl# reduce mz get start# end# =     let {-# INLINE go# #-}         go# i# b             | i# >=# end# = return b@@ -63,19 +63,19 @@                 a <- get i                 b' <- reduce b i a                 go# (i# +# 1#) b'-    in go# start# z+    in mz >>= go# start#  unrolledFoldl#     :: forall a b uf. Arity uf     => uf     -> (a -> IO ())     -> (b -> Int -> a -> IO b)-    -> b+    -> IO b     -> (Int -> IO a)     -> Int# -> Int#     -> IO b {-# INLINE unrolledFoldl# #-}-unrolledFoldl# unrollFactor tch reduce z get start# end# =+unrolledFoldl# unrollFactor tch reduce mz get start# end# =     let !(I# uf#) = arity unrollFactor         lim# = end# -# uf#         {-# INLINE go# #-}@@ -101,17 +101,17 @@                 b' <- reduce b i a                 rest# (i# +# 1#) b' -    in go# start# z+    in mz >>= go# start#   foldr#     :: (Int -> a -> b -> IO b)-    -> b+    -> IO b     -> (Int -> IO a)     -> Int# -> Int#     -> IO b {-# INLINE foldr# #-}-foldr# reduce z get start# end# =+foldr# reduce mz get start# end# =     let {-# INLINE go# #-}         go# i# b             | i# <# start# = return b@@ -120,19 +120,19 @@                 a <- get i                 b' <- reduce i a b                 go# (i# -# 1#) b'-    in go# (end# -# 1#) z+    in mz >>= go# (end# -# 1#)  unrolledFoldr#     :: forall a b uf. Arity uf     => uf     -> (a -> IO ())     -> (Int -> a -> b -> IO b)-    -> b+    -> IO b     -> (Int -> IO a)     -> Int# -> Int#     -> IO b {-# INLINE unrolledFoldr# #-}-unrolledFoldr# unrollFactor tch reduce z get start# end# =+unrolledFoldr# unrollFactor tch reduce mz get start# end# =     let !(I# uf#) = arity unrollFactor         lim# = start# +# uf# -# 1#         {-# INLINE go# #-}@@ -158,5 +158,5 @@                 b' <- reduce i a b                 rest# (i# -# 1#) b' -    in go# (end# -# 1#) z+    in mz >>= go# (end# -# 1#)
Data/Yarr/Utils/Primitive.hs view
@@ -51,7 +51,7 @@     touch = V.mapM_ touch     {-# INLINE touch #-} --- | Alias to @(\_ -> return ())@.+-- | Alias to @(\\_ -> return ())@. noTouch :: a -> IO () {-# INLINE noTouch #-} noTouch _ = return ()@@ -77,6 +77,7 @@         -> a    -- ^ Max bound         -> a    -- ^ Value to clamp         -> IO a -- ^ Value in bounds+     -- | Definetely sequential clamp.     clampM'         :: a    -- ^ Min bound
− Data/Yarr/Utils/VecTuple.hs 
@@ -1,85 +0,0 @@--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 
@@ -1,23 +0,0 @@--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))
+ Debug/Yarr.hs view
@@ -0,0 +1,98 @@++module Debug.Yarr (+    -- * @Checked@ meta repr+    CHK,+    -- | There is also @Checked@ 'UArray' family constructor,+    -- which isn't presented in the docs because Haddock+    -- doesn't support associated family constructors.+    --+    -- See source of "Yarr.Debug" module.+    UArray(..),++    -- * Fun+    yarr, yerr+) where++import System.IO+import Text.Printf++import Data.Yarr.Base hiding (fmap)+import Data.Yarr.Shape+import Data.Yarr.Utils.FixedVector as V++-- | Yarr something to stderr.+yarr :: String -> IO ()+yarr smth = hPutStrLn stderr ("Yarr! " ++ smth)++-- | Yarr something as 'error' message.+yerr :: String -> a+yerr msg = error ("Yarr! " ++ msg)++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 yerr $ printf "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 yerr $ printf "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 yerr $ printf "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 yerr $ printf "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
yarr.cabal view
@@ -1,5 +1,5 @@ Name:                yarr-Version:             0.9.1+Version:             0.9.2 Synopsis:            Yet another array library Description:     Yarr is a new blazing fast dataflow framework (array library),@@ -16,16 +16,15 @@     > 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@.+    See benchmark results: <https://github.com/leventov/yarr/blob/master/tests/bench-results.md>     .     Shortcoming by design: lack of pure indexing interface.     .-    /Work ahead:/+    /Changes in version 0.9.2:/     .-        * Safe fold wrappers+        * Safe folds -- see "Data.Yarr.Fold"     .-        * Unresolved issues with parameterized unrolling in slice-wise loading+        * Issue with slice-wise loading with unrolled filling function solved     .     To start with, read documentation in the root module: "Data.Yarr".     .@@ -70,25 +69,30 @@         Data.Yarr.Base         Data.Yarr.Eval         Data.Yarr.Flow+        Data.Yarr.Fold         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+        Debug.Yarr      other-modules:+        Data.Yarr.Utils.Storable+         -- re-exported in Utils.FixedVector-        Data.Yarr.Utils.VecTuple-        Data.Yarr.Utils.VecTupleInstances+        Data.Yarr.Utils.FixedVector.Arity+        Data.Yarr.Utils.FixedVector.VecTuple+        Data.Yarr.Utils.FixedVector.VecTupleInstances+        Data.Yarr.Utils.FixedVector.InlinableArity+        Data.Yarr.Utils.FixedVector.InlinableArityInstances          -- re-exported in Data.Yarr.Convolution         Data.Yarr.Convolution.Repr