diff --git a/Data/Yarr.hs b/Data/Yarr.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr.hs @@ -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@] + + /How to write fast program:/ + + 1. Read corresponding section in @repa@ guide: + + + 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 diff --git a/Data/Yarr/Base.hs b/Data/Yarr/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Base.hs @@ -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 diff --git a/Data/Yarr/Convolution.hs b/Data/Yarr/Convolution.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Convolution.hs @@ -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 diff --git a/Data/Yarr/Convolution/Eval.hs b/Data/Yarr/Convolution/Eval.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Convolution/Eval.hs @@ -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) diff --git a/Data/Yarr/Convolution/Repr.hs b/Data/Yarr/Convolution/Repr.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Convolution/Repr.hs @@ -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 +-- +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 diff --git a/Data/Yarr/Convolution/StaticStencils.hs b/Data/Yarr/Convolution/StaticStencils.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Convolution/StaticStencils.hs @@ -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) diff --git a/Data/Yarr/Eval.hs b/Data/Yarr/Eval.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Eval.hs @@ -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 diff --git a/Data/Yarr/Flow.hs b/Data/Yarr/Flow.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Flow.hs @@ -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) diff --git a/Data/Yarr/Repr/Boxed.hs b/Data/Yarr/Repr/Boxed.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Repr/Boxed.hs @@ -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" diff --git a/Data/Yarr/Repr/Checked.hs b/Data/Yarr/Repr/Checked.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Repr/Checked.hs @@ -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 diff --git a/Data/Yarr/Repr/Delayed.hs b/Data/Yarr/Repr/Delayed.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Repr/Delayed.hs @@ -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 #-} diff --git a/Data/Yarr/Repr/Foreign.hs b/Data/Yarr/Repr/Foreign.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Repr/Foreign.hs @@ -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) diff --git a/Data/Yarr/Repr/Separate.hs b/Data/Yarr/Repr/Separate.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Repr/Separate.hs @@ -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 diff --git a/Data/Yarr/Shape.hs b/Data/Yarr/Shape.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Shape.hs @@ -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 #-} + + diff --git a/Data/Yarr/Utils/FixedVector.hs b/Data/Yarr/Utils/FixedVector.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/FixedVector.hs @@ -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) diff --git a/Data/Yarr/Utils/Fork.hs b/Data/Yarr/Utils/Fork.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/Fork.hs @@ -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 diff --git a/Data/Yarr/Utils/LowLevelFlow.hs b/Data/Yarr/Utils/LowLevelFlow.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/LowLevelFlow.hs @@ -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 + diff --git a/Data/Yarr/Utils/Parallel.hs b/Data/Yarr/Utils/Parallel.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/Parallel.hs @@ -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 () diff --git a/Data/Yarr/Utils/Primitive.hs b/Data/Yarr/Utils/Primitive.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/Primitive.hs @@ -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 +-- +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#) diff --git a/Data/Yarr/Utils/Split.hs b/Data/Yarr/Utils/Split.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/Split.hs @@ -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] diff --git a/Data/Yarr/Utils/Storable.hs b/Data/Yarr/Utils/Storable.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/Storable.hs @@ -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 #-} diff --git a/Data/Yarr/Utils/VecTuple.hs b/Data/Yarr/Utils/VecTuple.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/VecTuple.hs @@ -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 + diff --git a/Data/Yarr/Utils/VecTupleInstances.hs b/Data/Yarr/Utils/VecTupleInstances.hs new file mode 100644 --- /dev/null +++ b/Data/Yarr/Utils/VecTupleInstances.hs @@ -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)) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright 2013 Roman Leventov +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/yarr.cabal b/yarr.cabal new file mode 100644 --- /dev/null +++ b/yarr.cabal @@ -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 +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