diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,103 @@ +# Change Log + +Notable changes to the project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/) and the +project adheres to the [Haskell Package Versioning +Policy (PVP)](https://pvp.haskell.org) + +## [1.1.0.0] - 2017-09-21 +### Added + * Additional EKG monitoring hooks ([#340]) + * Operations from `RealFloat` + +### Changed + * Changed type of `scanl'`, `scanr'` to return an `Acc` tuple, rather than a + tuple of `Acc` arrays. + * Specialised folds `sum`, `product`, `minimum`, `maximum`, `and`, `or`, + `any`, `all` now reduce along the innermost dimension only, rather than + reducing all elements. You can recover the old behaviour by first + `flatten`-ing the input array. + * Add new stencil boundary condition `function`, to apply the given function + to out-of-bounds indices. + +### Fixed + * [#390]: Wrong number of arguments in printf + +## [1.0.0.0] - 2017-03-31 + * Many API and internal changes + * Bug fixes and other enhancements + +## [0.15.1.0] + * Fix type of `allocateArray` + +## [0.15.0.0] + * Bug fixes and performance improvements. + +## [0.14.0.0] + * New iteration constructs. + * Additional Prelude-like functions. + * Improved code generation and fusion optimisation. + * Concurrent kernel execution in the CUDA backend. + * Bug fixes. + +## [0.13.0.0] + * New array fusion optimisation. + * New foreign function interface for array and scalar expressions. + * Additional Prelude-like functions. + * New example programs. + * Bug fixes and performance improvements. + +## [0.12.0.0] + * Full sharing recovery in scalar expressions and array computations. + * Two new example applications in package `accelerate-examples` (both including a graphical frontend): + * A real-time Canny edge detection + * An interactive fluid flow simulator + * Bug fixes. + +## [0.11.0.0] + * New Prelude-like functions `zip*`, `unzip*`, `fill`, `enumFrom*`, `tail`, + `init`, `drop`, `take`, `slit`, `gather*`, `scatter*`, and `shapeSize`. + * New simplified AST (in package `accelerate-backend-kit`) for backend writers + who want to avoid the complexities of the type-safe AST. + +## [0.10.0.0] + * Complete sharing recovery for scalar expressions (but currently disabled by default). + * Also bug fixes in array sharing recovery and a few new convenience functions. + +## [0.9.0.0] + * Streaming computations + * Precompilation + * Repa-style array indices + * Additional collective operations supported by the CUDA backend: `stencil`s, + more `scan`s, rank-polymorphic `fold`, `generate`. + * Conversions to other array formats + * Bug fixes + +## 0.8.1.0 + * Bug fixes and some performance tweaks. + +## 0.8.0.0 + * More collective operations supported by the CUDA backend: `replicate`, + `slice` and `foldSeg`. Frontend and interpreter support for `stencil`. + * Bug fixes. + +## [0.7.1.0] + * Initial release of the CUDA backend + + +[1.1.0.0]: https://github.com/AccelerateHS/accelerate/compare/1.0.0.0...1.1.0.0 +[1.0.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.15.1.0...1.0.0.0 +[0.15.1.0]: https://github.com/AccelerateHS/accelerate/compare/0.15.0.0...0.15.1.0 +[0.15.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.14.0.0...0.15.0.0 +[0.14.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.13.0.0...0.14.0.0 +[0.13.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.12.0.0...0.13.0.0 +[0.12.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.11.0.0...0.12.0.0 +[0.11.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.10.0.0...0.11.0.0 +[0.10.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.9.0.0...0.10.0.0 +[0.9.0.0]: https://github.com/AccelerateHS/accelerate/compare/0_8_1_0...0.9.0.0 +[0.7.1.0]: https://github.com/AccelerateHS/accelerate/compare/0_6_0_0...0_7_1_0 + +[#340]: https://github.com/AccelerateHS/accelerate/issues/340 +[#390]: https://github.com/AccelerateHS/accelerate/issues/390 + diff --git a/Data/Array/Accelerate.hs b/Data/Array/Accelerate.hs --- a/Data/Array/Accelerate.hs +++ b/Data/Array/Accelerate.hs @@ -55,10 +55,6 @@ -- * : -- implementation supporting parallel execution on CUDA-capable NVIDIA GPUs. -- --- * : --- an older implementation supporting parallel execution on CUDA-capable --- NVIDIA GPUs. /__NOTE:__ This backend is being deprecated in favour of @accelerate-llvm-ptx@./ --- -- [/Examples:/] -- -- * The @@ -95,6 +91,9 @@ -- * : Fast -- Fourier transform, with FFI bindings to optimised implementations. -- +-- * : BLAS +-- and LAPACK operations, with FFI bindings to optimised implementations. +-- -- * : -- Fixed-width large integer arithmetic. -- @@ -261,7 +260,8 @@ stencil, stencil2, -- *** Stencil specification - Stencil, Boundary(..), + Stencil, Boundary, + clamp, mirror, wrap, function, -- *** Common stencil patterns Stencil3, Stencil5, Stencil7, Stencil9, diff --git a/Data/Array/Accelerate/AST.hs b/Data/Array/Accelerate/AST.hs --- a/Data/Array/Accelerate/AST.hs +++ b/Data/Array/Accelerate/AST.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -90,7 +91,7 @@ -- * Accelerated array expressions PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, - Stencil(..), StencilR(..), + PreBoundary(..), Boundary, Stencil(..), StencilR(..), -- * Accelerated sequences -- PreOpenSeq(..), Seq, @@ -104,21 +105,41 @@ NFDataAcc, rnfPreOpenAfun, rnfPreOpenAcc, rnfPreOpenFun, rnfPreOpenExp, + -- TemplateHaskell + LiftAcc, + liftIdx, liftTupleIdx, liftArrays, + liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, + liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, + -- debugging showPreAccOp, showPreExpOp, ) where --standard library +import Control.DeepSeq import Data.List import Data.Typeable -import Control.DeepSeq +import Foreign.ForeignPtr +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import GHC.Ptr ( Ptr(..) ) +import System.IO.Unsafe +import Language.Haskell.TH ( Q, TExp ) +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH +#if __GLASGOW_HASKELL__ <= 708 +import Instances.TH.Lift () -- Int8, Int16... +#endif -- friends -import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Representation ( SliceIndex(..), size ) +import Data.Array.Accelerate.Array.Sugar hiding ( size ) +import Data.Array.Accelerate.Array.Unique import Data.Array.Accelerate.Product -import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) -import Data.Array.Accelerate.Array.Sugar as Sugar +import Data.Array.Accelerate.Type #if __GLASGOW_HASKELL__ < 800 import Data.Array.Accelerate.Error #endif @@ -175,7 +196,7 @@ -- Projection of a value from a valuation of array elements using a de Bruijn index -- prjElt :: Idx env t -> ValElt env -> t -prjElt ZeroIdx (PushElt _ v) = Sugar.toElt v +prjElt ZeroIdx (PushElt _ v) = toElt v prjElt (SuccIdx idx) (PushElt val _) = prjElt idx val #if __GLASGOW_HASKELL__ < 800 prjElt _ _ = $internalError "prjElt" "inconsistent valuation" @@ -470,22 +491,19 @@ -- Map a stencil over an array. In contrast to 'map', the domain of a stencil function is an -- entire /neighbourhood/ of each array element. Stencil :: (Elt e, Elt e', Stencil sh e stencil) - => PreFun acc aenv (stencil -> e') -- stencil function - -> Boundary (EltRepr e) -- boundary condition - -> acc aenv (Array sh e) -- source array - -> PreOpenAcc acc aenv (Array sh e') + => PreFun acc aenv (stencil -> e') -- stencil function + -> PreBoundary acc aenv (Array sh e) -- boundary condition + -> acc aenv (Array sh e) -- source array + -> PreOpenAcc acc aenv (Array sh e') -- Map a binary stencil over an array. - Stencil2 :: (Elt e1, Elt e2, Elt e', - Stencil sh e1 stencil1, - Stencil sh e2 stencil2) - => PreFun acc aenv (stencil1 -> - stencil2 -> e') -- stencil function - -> Boundary (EltRepr e1) -- boundary condition #1 - -> acc aenv (Array sh e1) -- source array #1 - -> Boundary (EltRepr e2) -- boundary condition #2 - -> acc aenv (Array sh e2) -- source array #2 - -> PreOpenAcc acc aenv (Array sh e') + Stencil2 :: (Elt a, Elt b, Elt c, Stencil sh a stencil1, Stencil sh b stencil2) + => PreFun acc aenv (stencil1 -> stencil2 -> c) -- stencil function + -> PreBoundary acc aenv (Array sh a) -- boundary condition #1 + -> acc aenv (Array sh a) -- source array #1 + -> PreBoundary acc aenv (Array sh b) -- boundary condition #2 + -> acc aenv (Array sh b) -- source array #2 + -> PreOpenAcc acc aenv (Array sh c) -- A sequence of operations. -- Collect :: Arrays arrs @@ -610,28 +628,52 @@ --} --- |Operations on stencils. +-- | Vanilla stencil boundary condition -- +type Boundary = PreBoundary OpenAcc + +-- | Boundary condition specification for stencil operations +-- +data PreBoundary (acc :: * -> * -> *) aenv t where + -- Clamp coordinates to the extent of the array + Clamp :: PreBoundary acc aenv t + + -- Mirror coordinates beyond the array extent + Mirror :: PreBoundary acc aenv t + + -- Wrap coordinates around on each dimension + Wrap :: PreBoundary acc aenv t + + -- Use a constant value for outlying coordinates + Constant :: Elt e + => EltRepr e + -> PreBoundary acc aenv (Array sh e) + + -- Apply the given function to outlying coordinates + Function :: (Shape sh, Elt e) + => PreFun acc aenv (sh -> e) + -> PreBoundary acc aenv (Array sh e) + + +-- | Operations on stencils +-- class (Shape sh, Elt e, IsTuple stencil, Elt stencil) => Stencil sh e stencil where - stencil :: StencilR sh e stencil - stencilAccess :: (sh -> e) -> sh -> stencil + stencil :: StencilR sh e stencil --- |GADT reifying the 'Stencil' class. +-- | GADT reifying the 'Stencil' class -- data StencilR sh e pat where - StencilRunit3 :: (Elt e) - => StencilR DIM1 e (e,e,e) - StencilRunit5 :: (Elt e) - => StencilR DIM1 e (e,e,e,e,e) - StencilRunit7 :: (Elt e) - => StencilR DIM1 e (e,e,e,e,e,e,e) - StencilRunit9 :: (Elt e) - => StencilR DIM1 e (e,e,e,e,e,e,e,e,e) + StencilRunit3 :: Elt e => StencilR DIM1 e (e,e,e) + StencilRunit5 :: Elt e => StencilR DIM1 e (e,e,e,e,e) + StencilRunit7 :: Elt e => StencilR DIM1 e (e,e,e,e,e,e,e) + StencilRunit9 :: Elt e => StencilR DIM1 e (e,e,e,e,e,e,e,e,e) + StencilRtup3 :: (Shape sh, Elt e) => StencilR sh e pat1 -> StencilR sh e pat2 -> StencilR sh e pat3 -> StencilR (sh:.Int) e (pat1,pat2,pat3) + StencilRtup5 :: (Shape sh, Elt e) => StencilR sh e pat1 -> StencilR sh e pat2 @@ -639,6 +681,7 @@ -> StencilR sh e pat4 -> StencilR sh e pat5 -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5) + StencilRtup7 :: (Shape sh, Elt e) => StencilR sh e pat1 -> StencilR sh e pat2 @@ -648,6 +691,7 @@ -> StencilR sh e pat6 -> StencilR sh e pat7 -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7) + StencilRtup9 :: (Shape sh, Elt e) => StencilR sh e pat1 -> StencilR sh e pat2 @@ -661,91 +705,40 @@ -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7,pat8,pat9) --- NB: We cannot start with 'DIM0'. The 'IsTuple stencil' superclass would at 'DIM0' imply that --- the types of individual array elements are in 'IsTuple'. (That would only possible if we --- could have (degenerate) 1-tuple, but we can't as we can't distinguish between a 1-tuple of a --- pair and a simple pair.) Hence, we need to start from 'DIM1' and use 'sh:.Int:.Int' in the --- recursive case (to avoid overlapping instances). +-- Note: [Stencil reification class] +-- +-- We cannot start with 'DIM0'. The 'IsTuple stencil' superclass would at +-- 'DIM0' imply that the types of individual array elements are in 'IsTuple'. +-- (That would only possible if we could have (degenerate) 1-tuple, but we can't +-- as we can't distinguish between a 1-tuple of a pair and a simple pair.) +-- Hence, we need to start from 'DIM1' and use 'sh:.Int:.Int' in the recursive +-- case (to avoid overlapping instances). -- DIM1 instance Elt e => Stencil DIM1 e (e, e, e) where stencil = StencilRunit3 - stencilAccess rf (Z:.y) = (rf' (y - 1), - rf' y , - rf' (y + 1)) - where - rf' d = rf (Z:.d) instance Elt e => Stencil DIM1 e (e, e, e, e, e) where stencil = StencilRunit5 - stencilAccess rf (Z:.y) = (rf' (y - 2), - rf' (y - 1), - rf' y , - rf' (y + 1), - rf' (y + 2)) - where - rf' d = rf (Z:.d) + instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e) where stencil = StencilRunit7 - stencilAccess rf (Z:.y) = (rf' (y - 3), - rf' (y - 2), - rf' (y - 1), - rf' y , - rf' (y + 1), - rf' (y + 2), - rf' (y + 3)) - where - rf' d = rf (Z:.d) + instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e, e, e) where stencil = StencilRunit9 - stencilAccess rf (Z:.y) = (rf' (y - 4), - rf' (y - 3), - rf' (y - 2), - rf' (y - 1), - rf' y , - rf' (y + 1), - rf' (y + 2), - rf' (y + 3), - rf' (y + 4)) - where - rf' d = rf (Z:.d) --- DIM(n+1), where n>0 +-- DIM(n+1), where n>1 instance (Stencil (sh:.Int) a row1, Stencil (sh:.Int) a row2, Stencil (sh:.Int) a row3) => Stencil (sh:.Int:.Int) a (row1, row2, row3) where stencil = StencilRtup3 stencil stencil stencil - stencilAccess rf xi = (stencilAccess (rf' (i - 1)) ix, - stencilAccess (rf' i ) ix, - stencilAccess (rf' (i + 1)) ix) - where - -- Invert then re-invert to ensure each recursive step gets a shape in the - -- standard scoc (right-recursive) ordering - -- - ix' :. i = invertShape xi - ix = invertShape ix' - - -- Inject this dimension innermost - -- - rf' d ds = rf $ invertShape (invertShape ds :. d) - - instance (Stencil (sh:.Int) a row1, Stencil (sh:.Int) a row2, Stencil (sh:.Int) a row3, Stencil (sh:.Int) a row4, Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where stencil = StencilRtup5 stencil stencil stencil stencil stencil - stencilAccess rf xi = (stencilAccess (rf' (i - 2)) ix, - stencilAccess (rf' (i - 1)) ix, - stencilAccess (rf' i ) ix, - stencilAccess (rf' (i + 1)) ix, - stencilAccess (rf' (i + 2)) ix) - where - ix' :. i = invertShape xi - ix = invertShape ix' - rf' d ds = rf $ invertShape (invertShape ds :. d) instance (Stencil (sh:.Int) a row1, Stencil (sh:.Int) a row2, @@ -756,17 +749,6 @@ Stencil (sh:.Int) a row7) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where stencil = StencilRtup7 stencil stencil stencil stencil stencil stencil stencil - stencilAccess rf xi = (stencilAccess (rf' (i - 3)) ix, - stencilAccess (rf' (i - 2)) ix, - stencilAccess (rf' (i - 1)) ix, - stencilAccess (rf' i ) ix, - stencilAccess (rf' (i + 1)) ix, - stencilAccess (rf' (i + 2)) ix, - stencilAccess (rf' (i + 3)) ix) - where - ix' :. i = invertShape xi - ix = invertShape ix' - rf' d ds = rf $ invertShape (invertShape ds :. d) instance (Stencil (sh:.Int) a row1, Stencil (sh:.Int) a row2, @@ -779,39 +761,8 @@ Stencil (sh:.Int) a row9) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where stencil = StencilRtup9 stencil stencil stencil stencil stencil stencil stencil stencil stencil - stencilAccess rf xi = (stencilAccess (rf' (i - 4)) ix, - stencilAccess (rf' (i - 3)) ix, - stencilAccess (rf' (i - 2)) ix, - stencilAccess (rf' (i - 1)) ix, - stencilAccess (rf' i ) ix, - stencilAccess (rf' (i + 1)) ix, - stencilAccess (rf' (i + 2)) ix, - stencilAccess (rf' (i + 3)) ix, - stencilAccess (rf' (i + 4)) ix) - where - ix' :. i = invertShape xi - ix = invertShape ix' - rf' d ds = rf $ invertShape (invertShape ds :. d) --- For stencilAccess to match how the user draws the stencil in code as a series --- of nested tuples, we need to recurse from the left. That is, we desire the --- following 2D stencil to represent elements to the top, bottom, left, and --- right of the focus as follows: --- --- stencil2D ( (_, t, _) --- , (l, _, r) --- , (_, b, _) ) = ... --- --- This function is used to reverse all components of a shape so that the --- innermost component, now the head, can be picked off. --- --- ...but needing to go via lists is unfortunate. --- -invertShape :: Shape sh => sh -> sh -invertShape = listToShape . reverse . shapeToList - - -- Embedded expressions -- -------------------- @@ -1064,8 +1015,9 @@ -- PrimProperFraction :: FloatingType a -> IntegralType b -> PrimFun (a -> (b, a)) -- operators from RealFloat - PrimIsNaN :: FloatingType a -> PrimFun (a -> Bool) - PrimAtan2 :: FloatingType a -> PrimFun ((a, a) -> a) + PrimAtan2 :: FloatingType a -> PrimFun ((a, a) -> a) + PrimIsNaN :: FloatingType a -> PrimFun (a -> Bool) + PrimIsInfinite :: FloatingType a -> PrimFun (a -> Bool) -- PrimFloatRadix :: FloatingType a -> PrimFun (a -> Int) -- Integer? -- PrimFloatDigits :: FloatingType a -> PrimFun (a -> Int) -- PrimFloatRange :: FloatingType a -> PrimFun (a -> (Int, Int)) @@ -1074,7 +1026,6 @@ -- PrimExponent :: FloatingType a -> PrimFun (a -> Int) -- PrimSignificand :: FloatingType a -> PrimFun (a -> a) -- PrimScaleFloat :: FloatingType a -> PrimFun ((Int, a) -> a) - -- PrimIsInfinite :: FloatingType a -> PrimFun (a -> Bool) -- PrimIsDenormalized :: FloatingType a -> PrimFun (a -> Bool) -- PrimIsNegativeZero :: FloatingType a -> PrimFun (a -> Bool) -- PrimIsIEEE :: FloatingType a -> PrimFun (a -> Bool) @@ -1175,8 +1126,8 @@ -- rnfS :: PreOpenSeq acc aenv' senv' t' -> () -- rnfS = rnfPreOpenSeq rnfA - rnfB :: forall aenv' sh e. Elt e => acc aenv' (Array sh e) -> Boundary (EltRepr e) -> () - rnfB _ = rnfBoundary (eltType (undefined::e)) + rnfB :: PreBoundary acc aenv' (Array sh e) -> () + rnfB = rnfBoundary rnfA in case pacc of Alet bnd body -> rnfA bnd `seq` rnfA body @@ -1208,8 +1159,8 @@ Scanr' f z a -> rnfF f `seq` rnfE z `seq` rnfA a Permute f d p a -> rnfF f `seq` rnfA d `seq` rnfF p `seq` rnfA a Backpermute sh f a -> rnfE sh `seq` rnfF f `seq` rnfA a - Stencil f b a -> rnfF f `seq` rnfB a b `seq` rnfA a - Stencil2 f b1 a1 b2 a2 -> rnfF f `seq` rnfB a1 b1 `seq` rnfB a2 b2 `seq` rnfA a1 `seq` rnfA a2 + Stencil f b a -> rnfF f `seq` rnfB b `seq` rnfA a + Stencil2 f b1 a1 b2 a2 -> rnfF f `seq` rnfB b1 `seq` rnfB b2 `seq` rnfA a1 `seq` rnfA a2 -- Collect s -> rnfS s @@ -1222,11 +1173,12 @@ rnfArrays ArraysRarray arr = rnf arr rnfArrays (ArraysRpair ar1 ar2) (a1,a2) = rnfArrays ar1 a1 `seq` rnfArrays ar2 a2 -rnfBoundary :: TupleType t -> Boundary t -> () -rnfBoundary _ Clamp = () -rnfBoundary _ Mirror = () -rnfBoundary _ Wrap = () -rnfBoundary t (Constant c) = rnfConst t c +rnfBoundary :: forall acc aenv sh e. NFDataAcc acc -> PreBoundary acc aenv (Array sh e) -> () +rnfBoundary _ Clamp = () +rnfBoundary _ Mirror = () +rnfBoundary _ Wrap = () +rnfBoundary _ (Constant c) = rnfConst (eltType (undefined::e)) c +rnfBoundary rnfA (Function f) = rnfPreOpenFun rnfA f {-- @@ -1401,6 +1353,7 @@ rnfPrimFun (PrimFloor f i) = rnfFloatingType f `seq` rnfIntegralType i rnfPrimFun (PrimCeiling f i) = rnfFloatingType f `seq` rnfIntegralType i rnfPrimFun (PrimIsNaN t) = rnfFloatingType t +rnfPrimFun (PrimIsInfinite t) = rnfFloatingType t rnfPrimFun (PrimAtan2 t) = rnfFloatingType t rnfPrimFun (PrimLt t) = rnfScalarType t rnfPrimFun (PrimGt t) = rnfScalarType t @@ -1471,8 +1424,390 @@ rnfFloatingType (TypeCDouble FloatingDict) = () +-- Template Haskell +-- ================ + +type LiftAcc acc = forall aenv a. acc aenv a -> Q (TExp (acc aenv a)) + +liftIdx :: Idx env t -> Q (TExp (Idx env t)) +liftIdx ZeroIdx = [|| ZeroIdx ||] +liftIdx (SuccIdx ix) = [|| SuccIdx $$(liftIdx ix) ||] + +liftTupleIdx :: TupleIdx t e -> Q (TExp (TupleIdx t e)) +liftTupleIdx ZeroTupIdx = [|| ZeroTupIdx ||] +liftTupleIdx (SuccTupIdx tix) = [|| SuccTupIdx $$(liftTupleIdx tix) ||] + + +liftPreOpenAfun :: LiftAcc acc -> PreOpenAfun acc aenv t -> Q (TExp (PreOpenAfun acc aenv t)) +liftPreOpenAfun liftA (Alam f) = [|| Alam $$(liftPreOpenAfun liftA f) ||] +liftPreOpenAfun liftA (Abody b) = [|| Abody $$(liftA b) ||] + +liftPreOpenAcc + :: forall acc aenv a. + LiftAcc acc + -> PreOpenAcc acc aenv a + -> Q (TExp (PreOpenAcc acc aenv a)) +liftPreOpenAcc liftA pacc = + let + liftE :: PreOpenExp acc env aenv t -> Q (TExp (PreOpenExp acc env aenv t)) + liftE = liftPreOpenExp liftA + + liftF :: PreOpenFun acc env aenv t -> Q (TExp (PreOpenFun acc env aenv t)) + liftF = liftPreOpenFun liftA + + liftAF :: PreOpenAfun acc aenv f -> Q (TExp (PreOpenAfun acc aenv f)) + liftAF = liftPreOpenAfun liftA + + liftB :: PreBoundary acc aenv (Array sh e) -> Q (TExp (PreBoundary acc aenv (Array sh e))) + liftB = liftBoundary liftA + + liftAtuple :: Atuple (acc aenv) t -> Q (TExp (Atuple (acc aenv) t)) + liftAtuple NilAtup = [|| NilAtup ||] + liftAtuple (SnocAtup tup a) = [|| SnocAtup $$(liftAtuple tup) $$(liftA a) ||] + in + case pacc of + Alet bnd body -> [|| Alet $$(liftA bnd) $$(liftA body) ||] + Avar ix -> [|| Avar $$(liftIdx ix) ||] + Atuple tup -> [|| Atuple $$(liftAtuple tup) ||] + Aprj tix a -> [|| Aprj $$(liftTupleIdx tix) $$(liftA a) ||] + Apply f a -> [|| Apply $$(liftAF f) $$(liftA a) ||] + Aforeign asm f a -> [|| Aforeign $$(liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||] + Acond p t e -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||] + Awhile p f a -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||] + Use a -> [|| Use $$(liftArrays (arrays (undefined::a)) a) ||] + Unit e -> [|| Unit $$(liftE e) ||] + Reshape sh a -> [|| Reshape $$(liftE sh) $$(liftA a) ||] + Generate sh f -> [|| Generate $$(liftE sh) $$(liftF f) ||] + Transform sh p f a -> [|| Transform $$(liftE sh) $$(liftF p) $$(liftF f) $$(liftA a) ||] + Replicate slix sl a -> [|| Replicate $$(liftSliceIndex slix) $$(liftE sl) $$(liftA a) ||] + Slice slix a sh -> [|| Slice $$(liftSliceIndex slix) $$(liftA a) $$(liftE sh) ||] + Map f a -> [|| Map $$(liftF f) $$(liftA a) ||] + ZipWith f a b -> [|| ZipWith $$(liftF f) $$(liftA a) $$(liftA b) ||] + Fold f z a -> [|| Fold $$(liftF f) $$(liftE z) $$(liftA a) ||] + Fold1 f a -> [|| Fold1 $$(liftF f) $$(liftA a) ||] + FoldSeg f z a s -> [|| FoldSeg $$(liftF f) $$(liftE z) $$(liftA a) $$(liftA s) ||] + Fold1Seg f a s -> [|| Fold1Seg $$(liftF f) $$(liftA a) $$(liftA s) ||] + Scanl f z a -> [|| Scanl $$(liftF f) $$(liftE z) $$(liftA a) ||] + Scanl1 f a -> [|| Scanl1 $$(liftF f) $$(liftA a) ||] + Scanl' f z a -> [|| Scanl' $$(liftF f) $$(liftE z) $$(liftA a) ||] + Scanr f z a -> [|| Scanr $$(liftF f) $$(liftE z) $$(liftA a) ||] + Scanr1 f a -> [|| Scanr1 $$(liftF f) $$(liftA a) ||] + Scanr' f z a -> [|| Scanr' $$(liftF f) $$(liftE z) $$(liftA a) ||] + Permute f d p a -> [|| Permute $$(liftF f) $$(liftA d) $$(liftF p) $$(liftA a) ||] + Backpermute sh p a -> [|| Backpermute $$(liftE sh) $$(liftF p) $$(liftA a) ||] + Stencil f b a -> [|| Stencil $$(liftF f) $$(liftB b) $$(liftA a) ||] + Stencil2 f b1 a1 b2 a2 -> [|| Stencil2 $$(liftF f) $$(liftB b1) $$(liftA a1) $$(liftB b2) $$(liftA a2) ||] + + +liftPreOpenFun + :: LiftAcc acc + -> PreOpenFun acc env aenv t + -> Q (TExp (PreOpenFun acc env aenv t)) +liftPreOpenFun liftA (Lam f) = [|| Lam $$(liftPreOpenFun liftA f) ||] +liftPreOpenFun liftA (Body b) = [|| Body $$(liftPreOpenExp liftA b) ||] + +liftPreOpenExp + :: forall acc env aenv t. + LiftAcc acc + -> PreOpenExp acc env aenv t + -> Q (TExp (PreOpenExp acc env aenv t)) +liftPreOpenExp liftA pexp = + let + liftE :: PreOpenExp acc env aenv e -> Q (TExp (PreOpenExp acc env aenv e)) + liftE = liftPreOpenExp liftA + + liftF :: PreOpenFun acc env aenv f -> Q (TExp (PreOpenFun acc env aenv f)) + liftF = liftPreOpenFun liftA + + liftT :: Tuple (PreOpenExp acc env aenv) e -> Q (TExp (Tuple (PreOpenExp acc env aenv) e)) + liftT NilTup = [|| NilTup ||] + liftT (SnocTup tup e) = [|| SnocTup $$(liftT tup) $$(liftE e) ||] + in + case pexp of + Let bnd body -> [|| Let $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||] + Var ix -> [|| Var $$(liftIdx ix) ||] + Foreign asm f x -> [|| Foreign $$(liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||] + Const c -> [|| Const $$(liftConst (eltType (undefined::t)) c) ||] + Tuple tup -> [|| Tuple $$(liftT tup) ||] + Prj tix e -> [|| Prj $$(liftTupleIdx tix) $$(liftE e) ||] + IndexNil -> [|| IndexNil ||] + IndexCons sh sz -> [|| IndexCons $$(liftE sh) $$(liftE sz) ||] + IndexHead sh -> [|| IndexHead $$(liftE sh) ||] + IndexTail sh -> [|| IndexTail $$(liftE sh) ||] + IndexAny -> [|| IndexAny ||] + IndexSlice slice slix sh -> [|| IndexSlice $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sh) ||] + IndexFull slice slix sl -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||] + ToIndex sh ix -> [|| ToIndex $$(liftE sh) $$(liftE ix) ||] + FromIndex sh ix -> [|| FromIndex $$(liftE sh) $$(liftE ix) ||] + Cond p t e -> [|| Cond $$(liftE p) $$(liftE t) $$(liftE e) ||] + While p f x -> [|| While $$(liftF p) $$(liftF f) $$(liftE x) ||] + PrimConst t -> [|| PrimConst $$(liftPrimConst t) ||] + PrimApp f x -> [|| PrimApp $$(liftPrimFun f) $$(liftE x) ||] + Index a ix -> [|| Index $$(liftA a) $$(liftE ix) ||] + LinearIndex a ix -> [|| LinearIndex $$(liftA a) $$(liftE ix) ||] + Shape a -> [|| Shape $$(liftA a) ||] + ShapeSize ix -> [|| ShapeSize $$(liftE ix) ||] + Intersect sh1 sh2 -> [|| Intersect $$(liftE sh1) $$(liftE sh2) ||] + Union sh1 sh2 -> [|| Union $$(liftE sh1) $$(liftE sh2) ||] + + +liftArrays :: ArraysR arr -> arr -> Q (TExp arr) +liftArrays ArraysRunit () = [|| () ||] +liftArrays ArraysRarray arr = [|| $$(liftArray arr) ||] +liftArrays (ArraysRpair r1 r2) (a1,a2) = [|| ($$(liftArrays r1 a1), $$(liftArrays r2 a2)) ||] + +liftArray :: forall sh e. Array sh e -> Q (TExp (Array sh e)) +liftArray (Array sh adata) = + [|| Array $$(liftConst (eltType (undefined::sh)) sh) $$(go arrayElt adata) ||] `sigE` typeRepToType (typeOf (undefined::Array sh e)) + where + sz :: Int + sz = size sh + + sigE :: Q (TExp t) -> Q TH.Type -> Q (TExp t) + sigE e t = TH.unsafeTExpCoerce $ TH.sigE (TH.unTypeQ e) t + + typeRepToType :: TypeRep -> Q TH.Type + typeRepToType trep = do + let (con, args) = splitTyConApp trep + name = TH.Name (TH.OccName (tyConName con)) (TH.NameG TH.TcClsName (TH.PkgName (tyConPackage con)) (TH.ModName (tyConModule con))) + -- + appsT x [] = x + appsT x (y:xs) = appsT (TH.AppT x y) xs + -- + resultArgs <- mapM typeRepToType args + return (appsT (TH.ConT name) resultArgs) + + -- TODO: make sure that the resulting array is 16-byte aligned... + arr :: forall a. (ArrayElt a, Storable a) => UniqueArray a -> Q (TExp (UniqueArray a)) + arr ua = do + bytes <- TH.runIO $ peekArray (sizeOf (undefined::a) * sz) (castPtr (unsafeUniqueArrayPtr ua) :: Ptr Word8) + [|| unsafePerformIO $ do + fp <- newForeignPtr_ $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |] ) + ua' <- newUniqueArray (castForeignPtr fp) + return ua' + ||] + + go :: ArrayEltR e' -> ArrayData e' -> Q (TExp (ArrayData e')) + go ArrayEltRunit AD_Unit = [|| AD_Unit ||] + go ArrayEltRint (AD_Int ua) = [|| AD_Int $$(arr ua) ||] + go ArrayEltRint8 (AD_Int8 ua) = [|| AD_Int8 $$(arr ua) ||] + go ArrayEltRint16 (AD_Int16 ua) = [|| AD_Int16 $$(arr ua) ||] + go ArrayEltRint32 (AD_Int32 ua) = [|| AD_Int32 $$(arr ua) ||] + go ArrayEltRint64 (AD_Int64 ua) = [|| AD_Int64 $$(arr ua) ||] + go ArrayEltRword (AD_Word ua) = [|| AD_Word $$(arr ua) ||] + go ArrayEltRword8 (AD_Word8 ua) = [|| AD_Word8 $$(arr ua) ||] + go ArrayEltRword16 (AD_Word16 ua) = [|| AD_Word16 $$(arr ua) ||] + go ArrayEltRword32 (AD_Word32 ua) = [|| AD_Word32 $$(arr ua) ||] + go ArrayEltRword64 (AD_Word64 ua) = [|| AD_Word64 $$(arr ua) ||] + go ArrayEltRcshort (AD_CShort ua) = [|| AD_CShort $$(arr ua) ||] + go ArrayEltRcushort (AD_CUShort ua) = [|| AD_CUShort $$(arr ua) ||] + go ArrayEltRcint (AD_CInt ua) = [|| AD_CInt $$(arr ua) ||] + go ArrayEltRcuint (AD_CUInt ua) = [|| AD_CUInt $$(arr ua) ||] + go ArrayEltRclong (AD_CLong ua) = [|| AD_CLong $$(arr ua) ||] + go ArrayEltRculong (AD_CULong ua) = [|| AD_CULong $$(arr ua) ||] + go ArrayEltRcllong (AD_CLLong ua) = [|| AD_CLLong $$(arr ua) ||] + go ArrayEltRcullong (AD_CULLong ua) = [|| AD_CULLong $$(arr ua) ||] + go ArrayEltRfloat (AD_Float ua) = [|| AD_Float $$(arr ua) ||] + go ArrayEltRdouble (AD_Double ua) = [|| AD_Double $$(arr ua) ||] + go ArrayEltRcfloat (AD_CFloat ua) = [|| AD_CFloat $$(arr ua) ||] + go ArrayEltRcdouble (AD_CDouble ua) = [|| AD_CDouble $$(arr ua) ||] + go ArrayEltRbool (AD_Bool ua) = [|| AD_Bool $$(arr ua) ||] + go ArrayEltRchar (AD_Char ua) = [|| AD_Char $$(arr ua) ||] + go ArrayEltRcchar (AD_CChar ua) = [|| AD_CChar $$(arr ua) ||] + go ArrayEltRcschar (AD_CSChar ua) = [|| AD_CSChar $$(arr ua) ||] + go ArrayEltRcuchar (AD_CUChar ua) = [|| AD_CUChar $$(arr ua) ||] + go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = [|| AD_Pair $$(go r1 a1) $$(go r2 a2) ||] + + +liftBoundary + :: forall acc aenv sh e. + LiftAcc acc + -> PreBoundary acc aenv (Array sh e) + -> Q (TExp (PreBoundary acc aenv (Array sh e))) +liftBoundary _ Clamp = [|| Clamp ||] +liftBoundary _ Mirror = [|| Mirror ||] +liftBoundary _ Wrap = [|| Wrap ||] +liftBoundary _ (Constant v) = [|| Constant $$(liftConst (eltType (undefined::e)) v) ||] +liftBoundary liftA (Function f) = [|| Function $$(liftPreOpenFun liftA f) ||] + +liftSliceIndex :: SliceIndex ix slice coSlice sliceDim -> Q (TExp (SliceIndex ix slice coSlice sliceDim)) +liftSliceIndex SliceNil = [|| SliceNil ||] +liftSliceIndex (SliceAll rest) = [|| SliceAll $$(liftSliceIndex rest) ||] +liftSliceIndex (SliceFixed rest) = [|| SliceFixed $$(liftSliceIndex rest) ||] + +liftPrimConst :: PrimConst c -> Q (TExp (PrimConst c)) +liftPrimConst (PrimMinBound t) = [|| PrimMinBound $$(liftBoundedType t) ||] +liftPrimConst (PrimMaxBound t) = [|| PrimMaxBound $$(liftBoundedType t) ||] +liftPrimConst (PrimPi t) = [|| PrimPi $$(liftFloatingType t) ||] + +liftPrimFun :: PrimFun f -> Q (TExp (PrimFun f)) +liftPrimFun (PrimAdd t) = [|| PrimAdd $$(liftNumType t) ||] +liftPrimFun (PrimSub t) = [|| PrimSub $$(liftNumType t) ||] +liftPrimFun (PrimMul t) = [|| PrimMul $$(liftNumType t) ||] +liftPrimFun (PrimNeg t) = [|| PrimNeg $$(liftNumType t) ||] +liftPrimFun (PrimAbs t) = [|| PrimAbs $$(liftNumType t) ||] +liftPrimFun (PrimSig t) = [|| PrimSig $$(liftNumType t) ||] +liftPrimFun (PrimQuot t) = [|| PrimQuot $$(liftIntegralType t) ||] +liftPrimFun (PrimRem t) = [|| PrimRem $$(liftIntegralType t) ||] +liftPrimFun (PrimQuotRem t) = [|| PrimQuotRem $$(liftIntegralType t) ||] +liftPrimFun (PrimIDiv t) = [|| PrimIDiv $$(liftIntegralType t) ||] +liftPrimFun (PrimMod t) = [|| PrimMod $$(liftIntegralType t) ||] +liftPrimFun (PrimDivMod t) = [|| PrimDivMod $$(liftIntegralType t) ||] +liftPrimFun (PrimBAnd t) = [|| PrimBAnd $$(liftIntegralType t) ||] +liftPrimFun (PrimBOr t) = [|| PrimBOr $$(liftIntegralType t) ||] +liftPrimFun (PrimBXor t) = [|| PrimBXor $$(liftIntegralType t) ||] +liftPrimFun (PrimBNot t) = [|| PrimBNot $$(liftIntegralType t) ||] +liftPrimFun (PrimBShiftL t) = [|| PrimBShiftL $$(liftIntegralType t) ||] +liftPrimFun (PrimBShiftR t) = [|| PrimBShiftR $$(liftIntegralType t) ||] +liftPrimFun (PrimBRotateL t) = [|| PrimBRotateL $$(liftIntegralType t) ||] +liftPrimFun (PrimBRotateR t) = [|| PrimBRotateR $$(liftIntegralType t) ||] +liftPrimFun (PrimPopCount t) = [|| PrimPopCount $$(liftIntegralType t) ||] +liftPrimFun (PrimCountLeadingZeros t) = [|| PrimCountLeadingZeros $$(liftIntegralType t) ||] +liftPrimFun (PrimCountTrailingZeros t) = [|| PrimCountTrailingZeros $$(liftIntegralType t) ||] +liftPrimFun (PrimFDiv t) = [|| PrimFDiv $$(liftFloatingType t) ||] +liftPrimFun (PrimRecip t) = [|| PrimRecip $$(liftFloatingType t) ||] +liftPrimFun (PrimSin t) = [|| PrimSin $$(liftFloatingType t) ||] +liftPrimFun (PrimCos t) = [|| PrimCos $$(liftFloatingType t) ||] +liftPrimFun (PrimTan t) = [|| PrimTan $$(liftFloatingType t) ||] +liftPrimFun (PrimAsin t) = [|| PrimAsin $$(liftFloatingType t) ||] +liftPrimFun (PrimAcos t) = [|| PrimAcos $$(liftFloatingType t) ||] +liftPrimFun (PrimAtan t) = [|| PrimAtan $$(liftFloatingType t) ||] +liftPrimFun (PrimSinh t) = [|| PrimSinh $$(liftFloatingType t) ||] +liftPrimFun (PrimCosh t) = [|| PrimCosh $$(liftFloatingType t) ||] +liftPrimFun (PrimTanh t) = [|| PrimTanh $$(liftFloatingType t) ||] +liftPrimFun (PrimAsinh t) = [|| PrimAsinh $$(liftFloatingType t) ||] +liftPrimFun (PrimAcosh t) = [|| PrimAcosh $$(liftFloatingType t) ||] +liftPrimFun (PrimAtanh t) = [|| PrimAtanh $$(liftFloatingType t) ||] +liftPrimFun (PrimExpFloating t) = [|| PrimExpFloating $$(liftFloatingType t) ||] +liftPrimFun (PrimSqrt t) = [|| PrimSqrt $$(liftFloatingType t) ||] +liftPrimFun (PrimLog t) = [|| PrimLog $$(liftFloatingType t) ||] +liftPrimFun (PrimFPow t) = [|| PrimFPow $$(liftFloatingType t) ||] +liftPrimFun (PrimLogBase t) = [|| PrimLogBase $$(liftFloatingType t) ||] +liftPrimFun (PrimTruncate ta tb) = [|| PrimTruncate $$(liftFloatingType ta) $$(liftIntegralType tb) ||] +liftPrimFun (PrimRound ta tb) = [|| PrimRound $$(liftFloatingType ta) $$(liftIntegralType tb) ||] +liftPrimFun (PrimFloor ta tb) = [|| PrimFloor $$(liftFloatingType ta) $$(liftIntegralType tb) ||] +liftPrimFun (PrimCeiling ta tb) = [|| PrimCeiling $$(liftFloatingType ta) $$(liftIntegralType tb) ||] +liftPrimFun (PrimIsNaN t) = [|| PrimIsNaN $$(liftFloatingType t) ||] +liftPrimFun (PrimIsInfinite t) = [|| PrimIsInfinite $$(liftFloatingType t) ||] +liftPrimFun (PrimAtan2 t) = [|| PrimAtan2 $$(liftFloatingType t) ||] +liftPrimFun (PrimLt t) = [|| PrimLt $$(liftScalarType t) ||] +liftPrimFun (PrimGt t) = [|| PrimGt $$(liftScalarType t) ||] +liftPrimFun (PrimLtEq t) = [|| PrimLtEq $$(liftScalarType t) ||] +liftPrimFun (PrimGtEq t) = [|| PrimGtEq $$(liftScalarType t) ||] +liftPrimFun (PrimEq t) = [|| PrimEq $$(liftScalarType t) ||] +liftPrimFun (PrimNEq t) = [|| PrimNEq $$(liftScalarType t) ||] +liftPrimFun (PrimMax t) = [|| PrimMax $$(liftScalarType t) ||] +liftPrimFun (PrimMin t) = [|| PrimMin $$(liftScalarType t) ||] +liftPrimFun PrimLAnd = [|| PrimLAnd ||] +liftPrimFun PrimLOr = [|| PrimLOr ||] +liftPrimFun PrimLNot = [|| PrimLNot ||] +liftPrimFun PrimOrd = [|| PrimOrd ||] +liftPrimFun PrimChr = [|| PrimChr ||] +liftPrimFun PrimBoolToInt = [|| PrimBoolToInt ||] +liftPrimFun (PrimFromIntegral ta tb) = [|| PrimFromIntegral $$(liftIntegralType ta) $$(liftNumType tb) ||] +liftPrimFun (PrimToFloating ta tb) = [|| PrimToFloating $$(liftNumType ta) $$(liftFloatingType tb) ||] +liftPrimFun (PrimCoerce ta tb) = [|| PrimCoerce $$(liftScalarType ta) $$(liftScalarType tb) ||] + + +liftConst :: TupleType t -> t -> Q (TExp t) +liftConst UnitTuple () = [|| () ||] +liftConst (SingleTuple t) x = [|| $$(liftScalar t x) ||] +liftConst (PairTuple ta tb) (a,b) = [|| ($$(liftConst ta a), $$(liftConst tb b)) ||] + +liftScalar :: ScalarType t -> t -> Q (TExp t) +liftScalar (NumScalarType t) x = liftNum t x +liftScalar (NonNumScalarType t) x = liftNonNum t x + +liftNum :: NumType t -> t -> Q (TExp t) +liftNum (IntegralNumType t) x = liftIntegral t x +liftNum (FloatingNumType t) x = liftFloating t x + +liftNonNum :: NonNumType t -> t -> Q (TExp t) +liftNonNum TypeBool{} x = [|| x ||] +liftNonNum TypeChar{} x = [|| x ||] +liftNonNum TypeCChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftNonNum TypeCSChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftNonNum TypeCUChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) + +liftIntegral :: IntegralType t -> t -> Q (TExp t) +liftIntegral TypeInt{} x = [|| x ||] +liftIntegral TypeInt8{} x = [|| x ||] +liftIntegral TypeInt16{} x = [|| x ||] +liftIntegral TypeInt32{} x = [|| x ||] +liftIntegral TypeInt64{} x = [|| x ||] +#if __GLASGOW_HASKELL__ >= 710 +liftIntegral TypeWord{} x = [|| x ||] +#else +liftIntegral TypeWord{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +#endif +liftIntegral TypeWord8{} x = [|| x ||] +liftIntegral TypeWord16{} x = [|| x ||] +liftIntegral TypeWord32{} x = [|| x ||] +liftIntegral TypeWord64{} x = [|| x ||] +liftIntegral TypeCShort{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftIntegral TypeCUShort{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftIntegral TypeCInt{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftIntegral TypeCUInt{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftIntegral TypeCLong{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftIntegral TypeCULong{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftIntegral TypeCLLong{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) +liftIntegral TypeCULLong{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x)))) + +liftFloating :: FloatingType t -> t -> Q (TExp t) +liftFloating TypeFloat{} x = [|| x ||] +liftFloating TypeDouble{} x = [|| x ||] +liftFloating TypeCFloat{} x = return (TH.TExp (TH.LitE (TH.RationalL (toRational x)))) +liftFloating TypeCDouble{} x = return (TH.TExp (TH.LitE (TH.RationalL (toRational x)))) + + +liftIntegralType :: IntegralType t -> Q (TExp (IntegralType t)) +liftIntegralType TypeInt{} = [|| TypeInt IntegralDict ||] +liftIntegralType TypeInt8{} = [|| TypeInt8 IntegralDict ||] +liftIntegralType TypeInt16{} = [|| TypeInt16 IntegralDict ||] +liftIntegralType TypeInt32{} = [|| TypeInt32 IntegralDict ||] +liftIntegralType TypeInt64{} = [|| TypeInt64 IntegralDict ||] +liftIntegralType TypeWord{} = [|| TypeWord IntegralDict ||] +liftIntegralType TypeWord8{} = [|| TypeWord8 IntegralDict ||] +liftIntegralType TypeWord16{} = [|| TypeWord16 IntegralDict ||] +liftIntegralType TypeWord32{} = [|| TypeWord32 IntegralDict ||] +liftIntegralType TypeWord64{} = [|| TypeWord64 IntegralDict ||] +liftIntegralType TypeCShort{} = [|| TypeCShort IntegralDict ||] +liftIntegralType TypeCUShort{} = [|| TypeCUShort IntegralDict ||] +liftIntegralType TypeCInt{} = [|| TypeCInt IntegralDict ||] +liftIntegralType TypeCUInt{} = [|| TypeCUInt IntegralDict ||] +liftIntegralType TypeCLong{} = [|| TypeCLong IntegralDict ||] +liftIntegralType TypeCULong{} = [|| TypeCULong IntegralDict ||] +liftIntegralType TypeCLLong{} = [|| TypeCLLong IntegralDict ||] +liftIntegralType TypeCULLong{} = [|| TypeCULLong IntegralDict ||] + +liftFloatingType :: FloatingType t -> Q (TExp (FloatingType t)) +liftFloatingType TypeFloat{} = [|| TypeFloat FloatingDict ||] +liftFloatingType TypeDouble{} = [|| TypeDouble FloatingDict ||] +liftFloatingType TypeCFloat{} = [|| TypeCFloat FloatingDict ||] +liftFloatingType TypeCDouble{} = [|| TypeCDouble FloatingDict ||] + +liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t)) +liftNonNumType TypeBool{} = [|| TypeBool NonNumDict ||] +liftNonNumType TypeChar{} = [|| TypeChar NonNumDict ||] +liftNonNumType TypeCChar{} = [|| TypeCChar NonNumDict ||] +liftNonNumType TypeCSChar{} = [|| TypeCSChar NonNumDict ||] +liftNonNumType TypeCUChar{} = [|| TypeCUChar NonNumDict ||] + +liftNumType :: NumType t -> Q (TExp (NumType t)) +liftNumType (IntegralNumType t) = [|| IntegralNumType $$(liftIntegralType t) ||] +liftNumType (FloatingNumType t) = [|| FloatingNumType $$(liftFloatingType t) ||] + +liftBoundedType :: BoundedType t -> Q (TExp (BoundedType t)) +liftBoundedType (IntegralBoundedType t) = [|| IntegralBoundedType $$(liftIntegralType t) ||] +liftBoundedType (NonNumBoundedType t) = [|| NonNumBoundedType $$(liftNonNumType t) ||] + +liftScalarType :: ScalarType t -> Q (TExp (ScalarType t)) +liftScalarType (NumScalarType t) = [|| NumScalarType $$(liftNumType t) ||] +liftScalarType (NonNumScalarType t) = [|| NonNumScalarType $$(liftNonNumType t) ||] + + -- Debugging --- --------- +-- ========= showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String showPreAccOp Alet{} = "Alet" @@ -1525,7 +1860,7 @@ showShortendArr arr = show (take cutoff l) ++ if length l > cutoff then ".." else "" where - l = Sugar.toList arr + l = toList arr cutoff = 5 diff --git a/Data/Array/Accelerate/Analysis/Hash.hs b/Data/Array/Accelerate/Analysis/Hash.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Analysis/Hash.hs @@ -0,0 +1,506 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Analysis.Hash +-- Copyright : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Analysis.Hash ( + + -- hashing expressions + HashAcc, + hashPreOpenAcc, hashOpenAcc, + hashPreOpenExp, hashOpenExp, + hashPreOpenFun, + + -- auxiliary + hashQ, + commutes, + +) where + +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Analysis.Hash.TH +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Type + +import Data.Hashable +import Foreign.C.Types +import Data.Maybe ( fromMaybe ) +import System.Mem.StableName ( hashStableName, makeStableName ) +import System.IO.Unsafe ( unsafePerformIO ) +import Prelude hiding ( exp ) + + +-- Array computations +-- ------------------ + +type HashAcc acc = forall aenv a. acc aenv a -> Int + + +hashOpenAcc :: OpenAcc aenv arrs -> Int +hashOpenAcc (OpenAcc pacc) = hashPreOpenAcc hashOpenAcc pacc + +hashPreOpenAcc :: forall acc aenv arrs. HashAcc acc -> PreOpenAcc acc aenv arrs -> Int +hashPreOpenAcc hashAcc pacc = + let + hashA :: forall aenv' a. Arrays a => Int -> acc aenv' a -> Int + hashA salt + = hashWithSalt salt + . hashWithSalt (hashArraysType (arrays (undefined::a))) + . hashAcc + + hashE :: Int -> PreOpenExp acc env' aenv' e -> Int + hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc + + hashF :: Int -> PreOpenFun acc env' aenv' f -> Int + hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc + + hashB :: Int -> PreBoundary acc aenv' (Array sh e) -> Int + hashB salt = hashWithSalt salt . hashPreBoundary hashAcc + + -- hashS :: Int -> PreOpenSeq acc aenv senv arrs -> Int + -- hashS salt = hashWithSalt salt . hashPreOpenSeq hashAcc + + nacl :: Arrays arrs => Int + nacl = hashArraysType (arrays (undefined::arrs)) + + in case pacc of + Alet bnd body -> $(hashQ "Alet") `hashA` bnd `hashA` body + Avar v -> $(hashQ "Avar") `hashWithSalt` nacl `hashWithSalt` hashIdx v + Atuple t -> $(hashQ "Atuple") `hashWithSalt` nacl `hashWithSalt` hashAtuple hashAcc t + Aprj ix a -> $(hashQ "Aprj") `hashWithSalt` nacl `hashWithSalt` hashTupleIdx ix `hashA` a + Apply f a -> $(hashQ "Apply") `hashWithSalt` nacl `hashWithSalt` hashAfun hashAcc f `hashA` a + Aforeign _ f a -> $(hashQ "Aforeign") `hashWithSalt` nacl `hashWithSalt` hashAfun hashAcc f `hashA` a + Use a -> $(hashQ "Use") `hashWithSalt` hashArrays (arrays (undefined::arrs)) a + Awhile p f a -> $(hashQ "Awhile") `hashWithSalt` hashAfun hashAcc f `hashWithSalt` hashAfun hashAcc p `hashA` a + Unit e -> $(hashQ "Unit") `hashE` e + Generate e f -> $(hashQ "Generate") `hashE` e `hashF` f + Acond e a1 a2 -> $(hashQ "Acond") `hashE` e `hashA` a1 `hashA` a2 + Reshape sh a -> $(hashQ "Reshape") `hashE` sh `hashA` a + Transform sh f1 f2 a -> $(hashQ "Transform") `hashE` sh `hashF` f1 `hashF` f2 `hashA` a + Replicate spec ix a -> $(hashQ "Replicate") `hashE` ix `hashA` a `hashWithSalt` hashSliceIndex spec + Slice spec a ix -> $(hashQ "Slice") `hashE` ix `hashA` a `hashWithSalt` hashSliceIndex spec + Map f a -> $(hashQ "Map") `hashF` f `hashA` a + ZipWith f a1 a2 -> $(hashQ "ZipWith") `hashF` f `hashA` a1 `hashA` a2 + Fold f e a -> $(hashQ "Fold") `hashF` f `hashE` e `hashA` a + Fold1 f a -> $(hashQ "Fold1") `hashF` f `hashA` a + FoldSeg f e a s -> $(hashQ "FoldSeg") `hashF` f `hashE` e `hashA` a `hashA` s + Fold1Seg f a s -> $(hashQ "Fold1Seg") `hashF` f `hashA` a `hashA` s + Scanl f e a -> $(hashQ "Scanl") `hashF` f `hashE` e `hashA` a + Scanl' f e a -> $(hashQ "Scanl'") `hashF` f `hashE` e `hashA` a + Scanl1 f a -> $(hashQ "Scanl1") `hashF` f `hashA` a + Scanr f e a -> $(hashQ "Scanr") `hashF` f `hashE` e `hashA` a + Scanr' f e a -> $(hashQ "Scanr'") `hashF` f `hashE` e `hashA` a + Scanr1 f a -> $(hashQ "Scanr1") `hashF` f `hashA` a + Backpermute sh f a -> $(hashQ "Backpermute") `hashF` f `hashE` sh `hashA` a + Permute f1 a1 f2 a2 -> $(hashQ "Permute") `hashF` f1 `hashA` a1 `hashF` f2 `hashA` a2 + Stencil f b a -> $(hashQ "Stencil") `hashF` f `hashB` b `hashA` a + Stencil2 f b1 a1 b2 a2 -> $(hashQ "Stencil2") `hashF` f `hashB` b1 `hashA` a1 `hashB` b2 `hashA` a2 + +{-- +hashPreOpenSeq :: forall acc aenv senv arrs. HashAcc acc -> PreOpenSeq acc aenv senv arrs -> Int +hashPreOpenSeq hashAcc s = + let + hashA :: Int -> acc aenv' a -> Int + hashA salt = hashWithSalt salt . hashAcc + + hashE :: Int -> PreOpenExp acc env' aenv' e -> Int + hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc + + hashAF :: Int -> PreOpenAfun acc aenv' f -> Int + hashAF salt = hashWithSalt salt . hashAfun hashAcc + + hashF :: Int -> PreOpenFun acc env' aenv' f -> Int + hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc + + hashS :: Int -> PreOpenSeq acc aenv senv' arrs' -> Int + hashS salt = hashWithSalt salt . hashPreOpenSeq hashAcc + + hashVar :: Int -> Idx senv' a -> Int + hashVar salt = hashWithSalt salt . idxToInt + + hashP :: Int -> Producer acc aenv senv a -> Int + hashP salt p = + case p of + StreamIn arrs -> unsafePerformIO $! hashStableName `fmap` makeStableName arrs + ToSeq spec _ acc -> hashWithSalt salt "ToSeq" `hashA` acc `hashWithSalt` show spec + MapSeq f x -> hashWithSalt salt "MapSeq" `hashAF` f `hashVar` x + ChunkedMapSeq f x -> hashWithSalt salt "ChunkedMapSeq" `hashAF` f `hashVar` x + ZipWithSeq f x y -> hashWithSalt salt "ZipWithSeq" `hashAF` f `hashVar` x `hashVar` y + ScanSeq f e x -> hashWithSalt salt "ScanSeq" `hashF` f `hashE` e `hashVar` x + + hashC :: Int -> Consumer acc aenv senv' a -> Int + hashC salt c = + case c of + FoldSeq f e x -> hashWithSalt salt "FoldSeq" `hashF` f `hashE` e `hashVar` x + FoldSeqFlatten f acc x -> hashWithSalt salt "FoldSeqFlatten" `hashAF` f `hashA` acc `hashVar` x + Stuple t -> hash "Stuple" `hashWithSalt` hashAtuple (hashC salt) t + + in case s of + Producer p s' -> hash "Producer" `hashP` p `hashS` s' + Consumer c -> hash "Consumer" `hashC` c + Reify ix -> hash "Reify" `hashVar` ix +--} + + +hashIdx :: Idx env t -> Int +hashIdx = hash . idxToInt + +hashTupleIdx :: TupleIdx tup e -> Int +hashTupleIdx = hash . tupleIdxToInt + + +hashArrays :: ArraysR a -> a -> Int +hashArrays ArraysRunit () = hash () +hashArrays (ArraysRpair r1 r2) (a1, a2) = hash (hashArrays r1 a1, hashArrays r2 a2) +hashArrays ArraysRarray ad = unsafePerformIO $! hashStableName `fmap` makeStableName ad + +hashArraysType :: forall a. ArraysR a -> Int +hashArraysType ArraysRunit = $(hashQ "ArraysRunit") +hashArraysType (ArraysRpair r1 r2) = $(hashQ "ArraysRpair") `hashWithSalt` hashArraysType r1 `hashWithSalt` hashArraysType r2 +hashArraysType ArraysRarray = $(hashQ "ArraysRarray") `hashWithSalt` hashArrayType (undefined::a) + where + hashArrayType :: forall sh e. (Shape sh, Elt e) => Array sh e -> Int + hashArrayType _ = hashTupleType (eltType (undefined::sh)) `hashWithSalt` hashTupleType (eltType (undefined::e)) + +hashAtuple :: HashAcc acc -> Atuple (acc aenv) a -> Int +hashAtuple _ NilAtup = $(hashQ "NilAtup") +hashAtuple h (SnocAtup t a) = $(hashQ "SnocAtup") `hashWithSalt` hashAtuple h t `hashWithSalt` h a + +hashAfun :: forall acc aenv f. HashAcc acc -> PreOpenAfun acc aenv f -> Int +hashAfun hashAcc afun = + let + hashA :: forall aenv' a. Arrays a => Int -> acc aenv' a -> Int + hashA salt + = hashWithSalt salt + . hashWithSalt (hashArraysType (arrays (undefined::a))) + . hashAcc + + hashL :: forall aenv' a b. Arrays a => Int -> PreOpenAfun acc (aenv',a) b -> Int + hashL salt + = hashWithSalt salt + . hashWithSalt (hashArraysType (arrays (undefined::a))) + . hashAfun hashAcc + + in case afun of + Abody b -> $(hashQ "Abody") `hashA` b + Alam l -> $(hashQ "Alam") `hashL` l + + +hashPreBoundary :: forall acc aenv sh e. HashAcc acc -> PreBoundary acc aenv (Array sh e) -> Int +hashPreBoundary _ Wrap = $(hashQ "Wrap") +hashPreBoundary _ Clamp = $(hashQ "Clamp") +hashPreBoundary _ Mirror = $(hashQ "Mirror") +hashPreBoundary _ (Constant c) = $(hashQ "Constant") `hashWithSalt` hashConst (eltType (undefined::e)) c +hashPreBoundary h (Function f) = $(hashQ "Function") `hashWithSalt` hashPreOpenFun h f + +hashSliceIndex :: SliceIndex slix sl co sh -> Int +hashSliceIndex SliceNil = $(hashQ "SliceNil") +hashSliceIndex (SliceAll r) = $(hashQ "SliceAll") `hashWithSalt` hashSliceIndex r +hashSliceIndex (SliceFixed r) = $(hashQ "sliceFixed") `hashWithSalt` hashSliceIndex r + + +-- Scalar expressions +-- ------------------ + +hashOpenExp :: OpenExp env aenv exp -> Int +hashOpenExp = hashPreOpenExp hashOpenAcc + +hashPreOpenExp :: forall acc env aenv exp. HashAcc acc -> PreOpenExp acc env aenv exp -> Int +hashPreOpenExp hashAcc exp = + let + hashE :: forall env' aenv' e. Elt e => Int -> PreOpenExp acc env' aenv' e -> Int + hashE salt + = hashWithSalt salt + . hashWithSalt (hashTupleType (eltType (undefined::e))) + . hashPreOpenExp hashAcc + + hashA :: Int -> acc aenv' a -> Int + hashA salt = hashWithSalt salt . hashAcc + + hashF :: Int -> PreOpenFun acc env' aenv' f -> Int + hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc + + nacl :: Elt exp => Int + nacl = hashTupleType (eltType (undefined::exp)) + + in case exp of + Let bnd body -> $(hashQ "Let") `hashE` bnd `hashE` body + Const c -> $(hashQ "Const") `hashWithSalt` hashConst (eltType (undefined::exp)) c + Var ix -> $(hashQ "Var") `hashWithSalt` nacl `hashWithSalt` hashIdx ix + Tuple t -> $(hashQ "Tuple") `hashWithSalt` nacl `hashWithSalt` hashTuple hashAcc t + Prj i e -> $(hashQ "Prj") `hashWithSalt` nacl `hashWithSalt` hashTupleIdx i `hashE` e + IndexAny -> $(hashQ "IndexAny") `hashWithSalt` nacl + IndexNil -> $(hashQ "IndexNil") + IndexCons sl a -> $(hashQ "IndexCons") `hashE` sl `hashE` a + IndexHead sl -> $(hashQ "IndexHead") `hashE` sl + IndexTail sl -> $(hashQ "IndexTail") `hashE` sl + IndexSlice spec ix sh -> $(hashQ "IndexSlice") `hashE` ix `hashE` sh `hashWithSalt` hashSliceIndex spec + IndexFull spec ix sl -> $(hashQ "IndexFull") `hashE` ix `hashE` sl `hashWithSalt` hashSliceIndex spec + ToIndex sh i -> $(hashQ "ToIndex") `hashE` sh `hashE` i + FromIndex sh i -> $(hashQ "FromIndex") `hashE` sh `hashE` i + Cond c t e -> $(hashQ "Cond") `hashE` c `hashE` t `hashE` e + While p f x -> $(hashQ "While") `hashF` p `hashF` f `hashE` x + PrimApp f x -> $(hashQ "PrimApp") `hashWithSalt` hashPrimFun f `hashE` fromMaybe x (commutes hashAcc f x) + PrimConst c -> $(hashQ "PrimConst") `hashWithSalt` hashPrimConst c + Index a ix -> $(hashQ "Index") `hashA` a `hashE` ix + LinearIndex a ix -> $(hashQ "LinearIndex") `hashA` a `hashE` ix + Shape a -> $(hashQ "Shape") `hashA` a + ShapeSize sh -> $(hashQ "ShapeSize") `hashE` sh + Intersect sa sb -> $(hashQ "Intersect") `hashE` sa `hashE` sb + Union sa sb -> $(hashQ "Union") `hashE` sa `hashE` sb + Foreign _ f e -> $(hashQ "Foreign") `hashF` f `hashE` e + + +hashPreOpenFun :: forall acc env aenv f. HashAcc acc -> PreOpenFun acc env aenv f -> Int +hashPreOpenFun hashAcc fun = + let + hashE :: forall env' aenv' e. Elt e => Int -> PreOpenExp acc env' aenv' e -> Int + hashE salt + = hashWithSalt salt + . hashWithSalt (hashTupleType (eltType (undefined::e))) + . hashPreOpenExp hashAcc + + hashL :: forall env' aenv' a b. Elt a => Int -> PreOpenFun acc (env',a) aenv' b -> Int + hashL salt + = hashWithSalt salt + . hashWithSalt (hashTupleType (eltType (undefined::a))) + . hashPreOpenFun hashAcc + + in case fun of + Body b -> $(hashQ "Body") `hashE` b + Lam f -> $(hashQ "Lam") `hashL` f + + +hashTuple :: HashAcc acc -> Tuple (PreOpenExp acc env aenv) e -> Int +hashTuple _ NilTup = $(hashQ "NilTup") +hashTuple h (SnocTup t e) = $(hashQ "SnocTup") `hashWithSalt` hashTuple h t `hashWithSalt` hashPreOpenExp h e + + +hashConst :: TupleType t -> t -> Int +hashConst UnitTuple () = hash () +hashConst (PairTuple ta tb) (a,b) = hash (hashConst ta a, hashConst tb b) +hashConst (SingleTuple t) c = hashScalarConst t c + +hashScalarConst :: ScalarType t -> t -> Int +hashScalarConst (NumScalarType t) = hashNumConst t +hashScalarConst (NonNumScalarType t) = hashNonNumConst t + +hashNonNumConst :: NonNumType t -> t -> Int +hashNonNumConst TypeBool{} x = $(hashQ "Bool") `hashWithSalt` x +hashNonNumConst TypeChar{} x = $(hashQ "Char") `hashWithSalt` x +hashNonNumConst TypeCChar{} (CChar x) = $(hashQ "CChar") `hashWithSalt` x +hashNonNumConst TypeCSChar{} (CSChar x) = $(hashQ "CSChar") `hashWithSalt` x +hashNonNumConst TypeCUChar{} (CUChar x) = $(hashQ "CUChar") `hashWithSalt` x + +hashNumConst :: NumType t -> t -> Int +hashNumConst (IntegralNumType t) = hashIntegralConst t +hashNumConst (FloatingNumType t) = hashFloatingConst t + +hashIntegralConst :: IntegralType t -> t -> Int +hashIntegralConst TypeInt{} x = $(hashQ "Int") `hashWithSalt` x +hashIntegralConst TypeInt8{} x = $(hashQ "Int8") `hashWithSalt` x +hashIntegralConst TypeInt16{} x = $(hashQ "Int16") `hashWithSalt` x +hashIntegralConst TypeInt32{} x = $(hashQ "Int32") `hashWithSalt` x +hashIntegralConst TypeInt64{} x = $(hashQ "Int64") `hashWithSalt` x +hashIntegralConst TypeWord{} x = $(hashQ "Word") `hashWithSalt` x +hashIntegralConst TypeWord8{} x = $(hashQ "Word8") `hashWithSalt` x +hashIntegralConst TypeWord16{} x = $(hashQ "Word16") `hashWithSalt` x +hashIntegralConst TypeWord32{} x = $(hashQ "Word32") `hashWithSalt` x +hashIntegralConst TypeWord64{} x = $(hashQ "Word64") `hashWithSalt` x +hashIntegralConst TypeCShort{} (CShort x) = $(hashQ "CShort") `hashWithSalt` x +hashIntegralConst TypeCUShort{} (CUShort x) = $(hashQ "CUShort") `hashWithSalt` x +hashIntegralConst TypeCInt{} (CInt x) = $(hashQ "CInt") `hashWithSalt` x +hashIntegralConst TypeCUInt{} (CUInt x) = $(hashQ "CUInt") `hashWithSalt` x +hashIntegralConst TypeCLong{} (CLong x) = $(hashQ "CLong") `hashWithSalt` x +hashIntegralConst TypeCULong{} (CULong x) = $(hashQ "CULong") `hashWithSalt` x +hashIntegralConst TypeCLLong{} (CLLong x) = $(hashQ "CLLong") `hashWithSalt` x +hashIntegralConst TypeCULLong{} (CULLong x) = $(hashQ "CULLong") `hashWithSalt` x + +hashFloatingConst :: FloatingType t -> t -> Int +hashFloatingConst TypeFloat{} x = $(hashQ "Float") `hashWithSalt` x +hashFloatingConst TypeDouble{} x = $(hashQ "Double") `hashWithSalt` x +hashFloatingConst TypeCFloat{} (CFloat x) = $(hashQ "CFloat") `hashWithSalt` x +hashFloatingConst TypeCDouble{} (CDouble x) = $(hashQ "CDouble") `hashWithSalt` x + +hashPrimConst :: PrimConst c -> Int +hashPrimConst (PrimMinBound t) = $(hashQ "PrimMinBound") `hashWithSalt` hashBoundedType t +hashPrimConst (PrimMaxBound t) = $(hashQ "PrimMaxBound") `hashWithSalt` hashBoundedType t +hashPrimConst (PrimPi t) = $(hashQ "PrimPi") `hashWithSalt` hashFloatingType t + + +hashPrimFun :: PrimFun f -> Int +hashPrimFun (PrimAdd a) = $(hashQ "PrimAdd") `hashWithSalt` hashNumType a +hashPrimFun (PrimSub a) = $(hashQ "PrimSub") `hashWithSalt` hashNumType a +hashPrimFun (PrimMul a) = $(hashQ "PrimMul") `hashWithSalt` hashNumType a +hashPrimFun (PrimNeg a) = $(hashQ "PrimNeg") `hashWithSalt` hashNumType a +hashPrimFun (PrimAbs a) = $(hashQ "PrimAbs") `hashWithSalt` hashNumType a +hashPrimFun (PrimSig a) = $(hashQ "PrimSig") `hashWithSalt` hashNumType a +hashPrimFun (PrimQuot a) = $(hashQ "PrimQuot") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimRem a) = $(hashQ "PrimRem") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimQuotRem a) = $(hashQ "PrimQuotRem") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimIDiv a) = $(hashQ "PrimIDiv") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimMod a) = $(hashQ "PrimMod") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimDivMod a) = $(hashQ "PrimDivMod") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimBAnd a) = $(hashQ "PrimBAnd") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimBOr a) = $(hashQ "PrimBOr") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimBXor a) = $(hashQ "PrimBXor") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimBNot a) = $(hashQ "PrimBNot") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimBShiftL a) = $(hashQ "PrimBShiftL") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimBShiftR a) = $(hashQ "PrimBShiftR") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimBRotateL a) = $(hashQ "PrimBRotateL") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimBRotateR a) = $(hashQ "PrimBRotateR") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimPopCount a) = $(hashQ "PrimPopCount") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimCountLeadingZeros a) = $(hashQ "PrimCountLeadingZeros") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimCountTrailingZeros a) = $(hashQ "PrimCountTrailingZeros") `hashWithSalt` hashIntegralType a +hashPrimFun (PrimFDiv a) = $(hashQ "PrimFDiv") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimRecip a) = $(hashQ "PrimRecip") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimSin a) = $(hashQ "PrimSin") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimCos a) = $(hashQ "PrimCos") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimTan a) = $(hashQ "PrimTan") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimAsin a) = $(hashQ "PrimAsin") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimAcos a) = $(hashQ "PrimAcos") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimAtan a) = $(hashQ "PrimAtan") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimSinh a) = $(hashQ "PrimSinh") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimCosh a) = $(hashQ "PrimCosh") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimTanh a) = $(hashQ "PrimTanh") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimAsinh a) = $(hashQ "PrimAsinh") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimAcosh a) = $(hashQ "PrimAcosh") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimAtanh a) = $(hashQ "PrimAtanh") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimExpFloating a) = $(hashQ "PrimExpFloating") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimSqrt a) = $(hashQ "PrimSqrt") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimLog a) = $(hashQ "PrimLog") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimFPow a) = $(hashQ "PrimFPow") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimLogBase a) = $(hashQ "PrimLogBase") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimAtan2 a) = $(hashQ "PrimAtan2") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimTruncate a b) = $(hashQ "PrimTruncate") `hashWithSalt` hashFloatingType a `hashWithSalt` hashIntegralType b +hashPrimFun (PrimRound a b) = $(hashQ "PrimRound") `hashWithSalt` hashFloatingType a `hashWithSalt` hashIntegralType b +hashPrimFun (PrimFloor a b) = $(hashQ "PrimFloor") `hashWithSalt` hashFloatingType a `hashWithSalt` hashIntegralType b +hashPrimFun (PrimCeiling a b) = $(hashQ "PrimCeiling") `hashWithSalt` hashFloatingType a `hashWithSalt` hashIntegralType b +hashPrimFun (PrimIsNaN a) = $(hashQ "PrimIsNaN") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimIsInfinite a) = $(hashQ "PrimIsInfinite") `hashWithSalt` hashFloatingType a +hashPrimFun (PrimLt a) = $(hashQ "PrimLt") `hashWithSalt` hashScalarType a +hashPrimFun (PrimGt a) = $(hashQ "PrimGt") `hashWithSalt` hashScalarType a +hashPrimFun (PrimLtEq a) = $(hashQ "PrimLtEq") `hashWithSalt` hashScalarType a +hashPrimFun (PrimGtEq a) = $(hashQ "PrimGtEq") `hashWithSalt` hashScalarType a +hashPrimFun (PrimEq a) = $(hashQ "PrimEq") `hashWithSalt` hashScalarType a +hashPrimFun (PrimNEq a) = $(hashQ "PrimNEq") `hashWithSalt` hashScalarType a +hashPrimFun (PrimMax a) = $(hashQ "PrimMax") `hashWithSalt` hashScalarType a +hashPrimFun (PrimMin a) = $(hashQ "PrimMin") `hashWithSalt` hashScalarType a +hashPrimFun (PrimFromIntegral a b) = $(hashQ "PrimFromIntegral") `hashWithSalt` hashIntegralType a `hashWithSalt` hashNumType b +hashPrimFun (PrimToFloating a b) = $(hashQ "PrimToFloating") `hashWithSalt` hashNumType a `hashWithSalt` hashFloatingType b +hashPrimFun (PrimCoerce a b) = $(hashQ "PrimCoerce") `hashWithSalt` hashScalarType a `hashWithSalt` hashScalarType b +hashPrimFun PrimLAnd = $(hashQ "PrimLAnd") +hashPrimFun PrimLOr = $(hashQ "PrimLOr") +hashPrimFun PrimLNot = $(hashQ "PrimLNot") +hashPrimFun PrimOrd = $(hashQ "PrimOrd") +hashPrimFun PrimChr = $(hashQ "PrimChr") +hashPrimFun PrimBoolToInt = $(hashQ "PrimBoolToInt") + + +-- TLM: We need to include the depth of the branches in the pair case, otherwise +-- we are getting a collision at @hash t == hash (t,(t,t))@. +-- +hashTupleType :: TupleType t -> Int +hashTupleType UnitTuple = $(hashQ "UnitTuple") +hashTupleType (SingleTuple t) = $(hashQ "SingleTuple") `hashWithSalt` hashScalarType t +hashTupleType (PairTuple a b) = $(hashQ "PairTuple") `hashWithSalt` hashTupleType a `hashWithSalt` depthTupleType a + `hashWithSalt` hashTupleType b `hashWithSalt` depthTupleType b + +depthTupleType :: TupleType t -> Int +depthTupleType UnitTuple = 0 +depthTupleType SingleTuple{} = 1 +depthTupleType (PairTuple a b) = depthTupleType a + depthTupleType b + +hashScalarType :: ScalarType t -> Int +hashScalarType (NumScalarType t) = $(hashQ "NumScalarType") `hashWithSalt` hashNumType t +hashScalarType (NonNumScalarType t) = $(hashQ "NonNumScalarType") `hashWithSalt` hashNonNumType t + +hashBoundedType :: BoundedType t -> Int +hashBoundedType (IntegralBoundedType t) = $(hashQ "IntegralBoundedType") `hashWithSalt` hashIntegralType t +hashBoundedType (NonNumBoundedType t) = $(hashQ "NonNumBoundedType") `hashWithSalt` hashNonNumType t + +hashNonNumType :: NonNumType t -> Int +hashNonNumType TypeBool{} = $(hashQ "Bool") +hashNonNumType TypeChar{} = $(hashQ "Char") +hashNonNumType TypeCChar{} = $(hashQ "CChar") +hashNonNumType TypeCSChar{} = $(hashQ "CSChar") +hashNonNumType TypeCUChar{} = $(hashQ "CUChar") + +hashNumType :: NumType t -> Int +hashNumType (IntegralNumType t) = $(hashQ "IntegralNumType") `hashWithSalt` hashIntegralType t +hashNumType (FloatingNumType t) = $(hashQ "FloatingNumType") `hashWithSalt` hashFloatingType t + +hashIntegralType :: IntegralType t -> Int +hashIntegralType TypeInt{} = $(hashQ "Int") +hashIntegralType TypeInt8{} = $(hashQ "Int8") +hashIntegralType TypeInt16{} = $(hashQ "Int16") +hashIntegralType TypeInt32{} = $(hashQ "Int32") +hashIntegralType TypeInt64{} = $(hashQ "Int64") +hashIntegralType TypeWord{} = $(hashQ "Word") +hashIntegralType TypeWord8{} = $(hashQ "Word8") +hashIntegralType TypeWord16{} = $(hashQ "Word16") +hashIntegralType TypeWord32{} = $(hashQ "Word32") +hashIntegralType TypeWord64{} = $(hashQ "Word64") +hashIntegralType TypeCShort{} = $(hashQ "CShort") +hashIntegralType TypeCUShort{} = $(hashQ "CUShort") +hashIntegralType TypeCInt{} = $(hashQ "CInt") +hashIntegralType TypeCUInt{} = $(hashQ "CUInt") +hashIntegralType TypeCLong{} = $(hashQ "CLong") +hashIntegralType TypeCULong{} = $(hashQ "CULong") +hashIntegralType TypeCLLong{} = $(hashQ "CLLong") +hashIntegralType TypeCULLong{} = $(hashQ "CULLong") + +hashFloatingType :: FloatingType t -> Int +hashFloatingType TypeFloat{} = $(hashQ "Float") +hashFloatingType TypeDouble{} = $(hashQ "Double") +hashFloatingType TypeCFloat{} = $(hashQ "CFloat") +hashFloatingType TypeCDouble{} = $(hashQ "CDouble") + + +-- Auxiliary +-- --------- + +-- Discriminate binary functions that commute, and if so return the operands in +-- a stable ordering such that matching recognises expressions modulo +-- commutativity. +-- +commutes + :: forall acc env aenv a r. + HashAcc acc + -> PrimFun (a -> r) + -> PreOpenExp acc env aenv a + -> Maybe (PreOpenExp acc env aenv a) +commutes h f x = case f of + PrimAdd{} -> Just (swizzle x) + PrimMul{} -> Just (swizzle x) + PrimBAnd{} -> Just (swizzle x) + PrimBOr{} -> Just (swizzle x) + PrimBXor{} -> Just (swizzle x) + PrimEq{} -> Just (swizzle x) + PrimNEq{} -> Just (swizzle x) + PrimMax{} -> Just (swizzle x) + PrimMin{} -> Just (swizzle x) + PrimLAnd -> Just (swizzle x) + PrimLOr -> Just (swizzle x) + _ -> Nothing + where + swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') + swizzle exp + | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp + , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a) + -- + | otherwise = exp + diff --git a/Data/Array/Accelerate/Analysis/Hash/TH.hs b/Data/Array/Accelerate/Analysis/Hash/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Analysis/Hash/TH.hs @@ -0,0 +1,30 @@ +-- | +-- Module : Data.Array.Accelerate.Analysis.Hash.TH +-- Copyright : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Analysis.Hash.TH ( + + hashQ, + hashWithSaltQ, + +) where + +import Data.Hashable +import Language.Haskell.TH + + +hashQ :: Hashable a => a -> ExpQ +hashQ = intE . hash + +hashWithSaltQ :: Hashable a => Int -> a -> ExpQ +hashWithSaltQ s x = intE (hashWithSalt s x) + +intE :: Int -> ExpQ +intE = litE . integerL . fromIntegral + diff --git a/Data/Array/Accelerate/Analysis/Match.hs b/Data/Array/Accelerate/Analysis/Match.hs --- a/Data/Array/Accelerate/Analysis/Match.hs +++ b/Data/Array/Accelerate/Analysis/Match.hs @@ -2,7 +2,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -30,28 +29,22 @@ matchIdx, matchTupleType, matchIntegralType, matchFloatingType, matchNumType, matchScalarType, - -- hashing expressions - HashAcc, - hashPreOpenAcc, hashOpenAcc, - hashPreOpenExp, hashOpenExp, - hashPreOpenFun, - ) where -- standard library -import Prelude hiding ( exp ) import Data.Maybe import Data.Typeable -import Data.Hashable -import System.Mem.StableName import System.IO.Unsafe ( unsafePerformIO ) +import System.Mem.StableName +import Prelude hiding ( exp ) -- friends import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Analysis.Hash import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) +import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Type -- The type of matching array computations @@ -246,20 +239,18 @@ , Just Refl <- matchAcc a1 a2 = Just Refl - match (Stencil f1 b1 (a1 :: acc aenv (Array sh1 e1))) - (Stencil f2 b2 (a2 :: acc aenv (Array sh2 e2))) + match (Stencil f1 b1 a1) (Stencil f2 b2 a2) | Just Refl <- matchFun f1 f2 , Just Refl <- matchAcc a1 a2 - , matchBoundary (eltType (undefined::e1)) b1 b2 + , matchBoundary matchAcc hashAcc b1 b2 = Just Refl - match (Stencil2 f1 b1 (a1 :: acc aenv (Array sh1 e1 )) b2 (a2 :: acc aenv (Array sh2 e2 ))) - (Stencil2 f2 b1' (a1' :: acc aenv (Array sh1' e1')) b2' (a2':: acc aenv (Array sh2' e2'))) + match (Stencil2 f1 b1 a1 b2 a2) (Stencil2 f2 b1' a1' b2' a2') | Just Refl <- matchFun f1 f2 , Just Refl <- matchAcc a1 a1' , Just Refl <- matchAcc a2 a2' - , matchBoundary (eltType (undefined::e1)) b1 b1' - , matchBoundary (eltType (undefined::e2)) b2 b2' + , matchBoundary matchAcc hashAcc b1 b1' + , matchBoundary matchAcc hashAcc b2 b2' = Just Refl -- match (Collect s1) (Collect s2) @@ -313,12 +304,22 @@ -- Match stencil boundaries -- -matchBoundary :: TupleType e -> Boundary e -> Boundary e -> Bool -matchBoundary ty (Constant s) (Constant t) = matchConst ty s t -matchBoundary _ Wrap Wrap = True -matchBoundary _ Clamp Clamp = True -matchBoundary _ Mirror Mirror = True -matchBoundary _ _ _ = False +matchBoundary + :: forall acc aenv sh t. Elt t + => MatchAcc acc + -> HashAcc acc + -> PreBoundary acc aenv (Array sh t) + -> PreBoundary acc aenv (Array sh t) + -> Bool +matchBoundary _ _ Clamp Clamp = True +matchBoundary _ _ Mirror Mirror = True +matchBoundary _ _ Wrap Wrap = True +matchBoundary _ _ (Constant s) (Constant t) = matchConst (eltType (undefined::t)) s t +matchBoundary m h (Function f) (Function g) + | Just Refl <- matchPreOpenFun m h f g + = True +matchBoundary _ _ _ _ + = False {-- @@ -752,6 +753,7 @@ matchPrimFun (PrimFloor _ s) (PrimFloor _ t) = matchIntegralType s t matchPrimFun (PrimCeiling _ s) (PrimCeiling _ t) = matchIntegralType s t matchPrimFun (PrimIsNaN _) (PrimIsNaN _) = Just Refl +matchPrimFun (PrimIsInfinite _) (PrimIsInfinite _) = Just Refl matchPrimFun (PrimLt _) (PrimLt _) = Just Refl matchPrimFun (PrimGt _) (PrimGt _) = Just Refl matchPrimFun (PrimLtEq _) (PrimLtEq _) = Just Refl @@ -823,6 +825,7 @@ matchPrimFun' (PrimFloor s _) (PrimFloor t _) = matchFloatingType s t matchPrimFun' (PrimCeiling s _) (PrimCeiling t _) = matchFloatingType s t matchPrimFun' (PrimIsNaN s) (PrimIsNaN t) = matchFloatingType s t +matchPrimFun' (PrimIsInfinite s) (PrimIsInfinite t) = matchFloatingType s t matchPrimFun' (PrimMax _) (PrimMax _) = Just Refl matchPrimFun' (PrimMin _) (PrimMin _) = Just Refl matchPrimFun' (PrimFromIntegral s _) (PrimFromIntegral t _) = matchIntegralType s t @@ -928,296 +931,4 @@ matchNonNumType (TypeCSChar _) (TypeCSChar _) = Just Refl matchNonNumType (TypeCUChar _) (TypeCUChar _) = Just Refl matchNonNumType _ _ = Nothing - - --- Discriminate binary functions that commute, and if so return the operands in --- a stable ordering such that matching recognises expressions modulo --- commutativity. --- -commutes - :: forall acc env aenv a r. - HashAcc acc - -> PrimFun (a -> r) - -> PreOpenExp acc env aenv a - -> Maybe (PreOpenExp acc env aenv a) -commutes h f x = case f of - PrimAdd _ -> Just (swizzle x) - PrimMul _ -> Just (swizzle x) - PrimBAnd _ -> Just (swizzle x) - PrimBOr _ -> Just (swizzle x) - PrimBXor _ -> Just (swizzle x) - PrimEq _ -> Just (swizzle x) - PrimNEq _ -> Just (swizzle x) - PrimMax _ -> Just (swizzle x) - PrimMin _ -> Just (swizzle x) - PrimLAnd -> Just (swizzle x) - PrimLOr -> Just (swizzle x) - _ -> Nothing - where - swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') - swizzle exp - | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp - , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a) - -- - | otherwise = exp - - --- Hashing --- ======= - -hashIdx :: Idx env t -> Int -hashIdx = hash . idxToInt - -hashTupleIdx :: TupleIdx tup e -> Int -hashTupleIdx = hash . tupleIdxToInt - - --- Array computations --- ------------------ - -type HashAcc acc = forall aenv a. acc aenv a -> Int - - -hashOpenAcc :: OpenAcc aenv arrs -> Int -hashOpenAcc (OpenAcc pacc) = hashPreOpenAcc hashOpenAcc pacc - -{-- -hashPreOpenSeq :: forall acc aenv senv arrs. HashAcc acc -> PreOpenSeq acc aenv senv arrs -> Int -hashPreOpenSeq hashAcc s = - let - hashA :: Int -> acc aenv' a -> Int - hashA salt = hashWithSalt salt . hashAcc - - hashE :: Int -> PreOpenExp acc env' aenv' e -> Int - hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc - - hashAF :: Int -> PreOpenAfun acc aenv' f -> Int - hashAF salt = hashWithSalt salt . hashAfun hashAcc - - hashF :: Int -> PreOpenFun acc env' aenv' f -> Int - hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc - - hashS :: Int -> PreOpenSeq acc aenv senv' arrs' -> Int - hashS salt = hashWithSalt salt . hashPreOpenSeq hashAcc - - hashVar :: Int -> Idx senv' a -> Int - hashVar salt = hashWithSalt salt . idxToInt - - hashP :: Int -> Producer acc aenv senv a -> Int - hashP salt p = - case p of - StreamIn arrs -> unsafePerformIO $! hashStableName `fmap` makeStableName arrs - ToSeq spec _ acc -> hashWithSalt salt "ToSeq" `hashA` acc `hashWithSalt` show spec - MapSeq f x -> hashWithSalt salt "MapSeq" `hashAF` f `hashVar` x - ChunkedMapSeq f x -> hashWithSalt salt "ChunkedMapSeq" `hashAF` f `hashVar` x - ZipWithSeq f x y -> hashWithSalt salt "ZipWithSeq" `hashAF` f `hashVar` x `hashVar` y - ScanSeq f e x -> hashWithSalt salt "ScanSeq" `hashF` f `hashE` e `hashVar` x - - hashC :: Int -> Consumer acc aenv senv' a -> Int - hashC salt c = - case c of - FoldSeq f e x -> hashWithSalt salt "FoldSeq" `hashF` f `hashE` e `hashVar` x - FoldSeqFlatten f acc x -> hashWithSalt salt "FoldSeqFlatten" `hashAF` f `hashA` acc `hashVar` x - Stuple t -> hash "Stuple" `hashWithSalt` hashAtuple (hashC salt) t - - in case s of - Producer p s' -> hash "Producer" `hashP` p `hashS` s' - Consumer c -> hash "Consumer" `hashC` c - Reify ix -> hash "Reify" `hashVar` ix ---} - - -hashPreOpenAcc :: forall acc aenv arrs. HashAcc acc -> PreOpenAcc acc aenv arrs -> Int -hashPreOpenAcc hashAcc pacc = - let - hashA :: Int -> acc aenv' a -> Int - hashA salt = hashWithSalt salt . hashAcc - - hashE :: Int -> PreOpenExp acc env' aenv' e -> Int - hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc - - hashF :: Int -> PreOpenFun acc env' aenv' f -> Int - hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc - - -- hashS :: Int -> PreOpenSeq acc aenv senv arrs -> Int - -- hashS salt = hashWithSalt salt . hashPreOpenSeq hashAcc - - in case pacc of - Alet bnd body -> hash "Alet" `hashA` bnd `hashA` body - Avar v -> hash "Avar" `hashWithSalt` hashIdx v - Atuple t -> hash "Atuple" `hashWithSalt` hashAtuple hashAcc t - Aprj ix a -> hash "Aprj" `hashWithSalt` hashTupleIdx ix `hashA` a - Apply f a -> hash "Apply" `hashWithSalt` hashAfun hashAcc f `hashA` a - Aforeign _ f a -> hash "Aforeign" `hashWithSalt` hashAfun hashAcc f `hashA` a - Use a -> hash "Use" `hashWithSalt` hashArrays (arrays (undefined::arrs)) a - Awhile p f a -> hash "Awhile" `hashWithSalt` hashAfun hashAcc f `hashWithSalt` hashAfun hashAcc p `hashA` a - Unit e -> hash "Unit" `hashE` e - Generate e f -> hash "Generate" `hashE` e `hashF` f - Acond e a1 a2 -> hash "Acond" `hashE` e `hashA` a1 `hashA` a2 - Reshape sh a -> hash "Reshape" `hashE` sh `hashA` a - Transform sh f1 f2 a -> hash "Transform" `hashE` sh `hashF` f1 `hashF` f2 `hashA` a - Replicate spec ix a -> hash "Replicate" `hashE` ix `hashA` a `hashWithSalt` show spec - Slice spec a ix -> hash "Slice" `hashE` ix `hashA` a `hashWithSalt` show spec - Map f a -> hash "Map" `hashF` f `hashA` a - ZipWith f a1 a2 -> hash "ZipWith" `hashF` f `hashA` a1 `hashA` a2 - Fold f e a -> hash "Fold" `hashF` f `hashE` e `hashA` a - Fold1 f a -> hash "Fold1" `hashF` f `hashA` a - FoldSeg f e a s -> hash "FoldSeg" `hashF` f `hashE` e `hashA` a `hashA` s - Fold1Seg f a s -> hash "Fold1Seg" `hashF` f `hashA` a `hashA` s - Scanl f e a -> hash "Scanl" `hashF` f `hashE` e `hashA` a - Scanl' f e a -> hash "Scanl'" `hashF` f `hashE` e `hashA` a - Scanl1 f a -> hash "Scanl1" `hashF` f `hashA` a - Scanr f e a -> hash "Scanr" `hashF` f `hashE` e `hashA` a - Scanr' f e a -> hash "Scanr'" `hashF` f `hashE` e `hashA` a - Scanr1 f a -> hash "Scanr1" `hashF` f `hashA` a - Backpermute sh f a -> hash "Backpermute" `hashF` f `hashE` sh `hashA` a - Permute f1 a1 f2 a2 -> hash "Permute" `hashF` f1 `hashA` a1 `hashF` f2 `hashA` a2 - Stencil f b a -> hash "Stencil" `hashF` f `hashA` a `hashWithSalt` hashBoundary a b - Stencil2 f b1 a1 b2 a2 -> hash "Stencil2" `hashF` f `hashA` a1 `hashA` a2 `hashWithSalt` hashBoundary a1 b1 `hashWithSalt` hashBoundary a2 b2 - -- Collect s -> hash "Seq" `hashS` s - - -hashArrays :: ArraysR a -> a -> Int -hashArrays ArraysRunit () = hash () -hashArrays (ArraysRpair r1 r2) (a1, a2) = hash ( hashArrays r1 a1, hashArrays r2 a2) -hashArrays ArraysRarray ad = unsafePerformIO $! hashStableName `fmap` makeStableName ad - -hashAtuple :: HashAcc acc -> Atuple (acc aenv) a -> Int -hashAtuple _ NilAtup = hash "NilAtup" -hashAtuple h (SnocAtup t a) = hash "SnocAtup" `hashWithSalt` hashAtuple h t `hashWithSalt` h a - -hashAfun :: HashAcc acc -> PreOpenAfun acc aenv f -> Int -hashAfun h (Abody b) = hash "Abody" `hashWithSalt` h b -hashAfun h (Alam f) = hash "Alam" `hashWithSalt` hashAfun h f - -hashBoundary :: forall acc aenv sh e. Elt e => acc aenv (Array sh e) -> Boundary (EltRepr e) -> Int -hashBoundary _ Wrap = hash "Wrap" -hashBoundary _ Clamp = hash "Clamp" -hashBoundary _ Mirror = hash "Mirror" -hashBoundary _ (Constant c) = hash "Constant" `hashWithSalt` show (toElt c :: e) - - --- Scalar expressions --- ------------------ - -hashOpenExp :: OpenExp env aenv exp -> Int -hashOpenExp = hashPreOpenExp hashOpenAcc - -hashPreOpenExp :: forall acc env aenv exp. HashAcc acc -> PreOpenExp acc env aenv exp -> Int -hashPreOpenExp hashAcc exp = - let - hashA :: Int -> acc aenv' a -> Int - hashA salt = hashWithSalt salt . hashAcc - - hashE :: Int -> PreOpenExp acc env' aenv' e -> Int - hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc - - in case exp of - Let bnd body -> hash "Let" `hashE` bnd `hashE` body - Var ix -> hash "Var" `hashWithSalt` hashIdx ix - Const c -> hash "Const" `hashWithSalt` show (toElt c :: exp) - Tuple t -> hash "Tuple" `hashWithSalt` hashTuple hashAcc t - Prj i e -> hash "Prj" `hashWithSalt` hashTupleIdx i `hashE` e - IndexAny -> hash "IndexAny" - IndexNil -> hash "IndexNil" - IndexCons sl a -> hash "IndexCons" `hashE` sl `hashE` a - IndexHead sl -> hash "IndexHead" `hashE` sl - IndexTail sl -> hash "IndexTail" `hashE` sl - IndexSlice spec ix sh -> hash "IndexSlice" `hashE` ix `hashE` sh `hashWithSalt` show spec - IndexFull spec ix sl -> hash "IndexFull" `hashE` ix `hashE` sl `hashWithSalt` show spec - ToIndex sh i -> hash "ToIndex" `hashE` sh `hashE` i - FromIndex sh i -> hash "FromIndex" `hashE` sh `hashE` i - Cond c t e -> hash "Cond" `hashE` c `hashE` t `hashE` e - While p f x -> hash "While" `hashWithSalt` hashPreOpenFun hashAcc p `hashWithSalt` hashPreOpenFun hashAcc f `hashE` x - PrimApp f x -> hash "PrimApp" `hashWithSalt` hashPrimFun f `hashE` fromMaybe x (commutes hashAcc f x) - PrimConst c -> hash "PrimConst" `hashWithSalt` hashPrimConst c - Index a ix -> hash "Index" `hashA` a `hashE` ix - LinearIndex a ix -> hash "LinearIndex" `hashA` a `hashE` ix - Shape a -> hash "Shape" `hashA` a - ShapeSize sh -> hash "ShapeSize" `hashE` sh - Intersect sa sb -> hash "Intersect" `hashE` sa `hashE` sb - Union sa sb -> hash "Union" `hashE` sa `hashE` sb - Foreign _ f e -> hash "Foreign" `hashWithSalt` hashPreOpenFun hashAcc f `hashE` e - - -hashPreOpenFun :: HashAcc acc -> PreOpenFun acc env aenv f -> Int -hashPreOpenFun h (Body e) = hash "Body" `hashWithSalt` hashPreOpenExp h e -hashPreOpenFun h (Lam f) = hash "Lam" `hashWithSalt` hashPreOpenFun h f - -hashTuple :: HashAcc acc -> Tuple (PreOpenExp acc env aenv) e -> Int -hashTuple _ NilTup = hash "NilTup" -hashTuple h (SnocTup t e) = hash "SnocTup" `hashWithSalt` hashTuple h t `hashWithSalt` hashPreOpenExp h e - - -hashPrimConst :: PrimConst c -> Int -hashPrimConst PrimMinBound{} = hash "PrimMinBound" -hashPrimConst PrimMaxBound{} = hash "PrimMaxBound" -hashPrimConst PrimPi{} = hash "PrimPi" - -hashPrimFun :: PrimFun f -> Int -hashPrimFun PrimAdd{} = hash "PrimAdd" -hashPrimFun PrimSub{} = hash "PrimSub" -hashPrimFun PrimMul{} = hash "PrimMul" -hashPrimFun PrimNeg{} = hash "PrimNeg" -hashPrimFun PrimAbs{} = hash "PrimAbs" -hashPrimFun PrimSig{} = hash "PrimSig" -hashPrimFun PrimQuot{} = hash "PrimQuot" -hashPrimFun PrimRem{} = hash "PrimRem" -hashPrimFun PrimQuotRem{} = hash "PrimQuotRem" -hashPrimFun PrimIDiv{} = hash "PrimIDiv" -hashPrimFun PrimMod{} = hash "PrimMod" -hashPrimFun PrimDivMod{} = hash "PrimDivMod" -hashPrimFun PrimBAnd{} = hash "PrimBAnd" -hashPrimFun PrimBOr{} = hash "PrimBOr" -hashPrimFun PrimBXor{} = hash "PrimBXor" -hashPrimFun PrimBNot{} = hash "PrimBNot" -hashPrimFun PrimBShiftL{} = hash "PrimBShiftL" -hashPrimFun PrimBShiftR{} = hash "PrimBShiftR" -hashPrimFun PrimBRotateL{} = hash "PrimBRotateL" -hashPrimFun PrimBRotateR{} = hash "PrimBRotateR" -hashPrimFun PrimPopCount{} = hash "PrimPopCount" -hashPrimFun PrimCountLeadingZeros{} = hash "PrimCountLeadingZeros" -hashPrimFun PrimCountTrailingZeros{} = hash "PrimCountTrailingZeros" -hashPrimFun PrimFDiv{} = hash "PrimFDiv" -hashPrimFun PrimRecip{} = hash "PrimRecip" -hashPrimFun PrimSin{} = hash "PrimSin" -hashPrimFun PrimCos{} = hash "PrimCos" -hashPrimFun PrimTan{} = hash "PrimTan" -hashPrimFun PrimAsin{} = hash "PrimAsin" -hashPrimFun PrimAcos{} = hash "PrimAcos" -hashPrimFun PrimAtan{} = hash "PrimAtan" -hashPrimFun PrimSinh{} = hash "PrimSinh" -hashPrimFun PrimCosh{} = hash "PrimCosh" -hashPrimFun PrimTanh{} = hash "PrimTanh" -hashPrimFun PrimAsinh{} = hash "PrimAsinh" -hashPrimFun PrimAcosh{} = hash "PrimAcosh" -hashPrimFun PrimAtanh{} = hash "PrimAtanh" -hashPrimFun PrimExpFloating{} = hash "PrimExpFloating" -hashPrimFun PrimSqrt{} = hash "PrimSqrt" -hashPrimFun PrimLog{} = hash "PrimLog" -hashPrimFun PrimFPow{} = hash "PrimFPow" -hashPrimFun PrimLogBase{} = hash "PrimLogBase" -hashPrimFun PrimAtan2{} = hash "PrimAtan2" -hashPrimFun PrimTruncate{} = hash "PrimTruncate" -hashPrimFun PrimRound{} = hash "PrimRound" -hashPrimFun PrimFloor{} = hash "PrimFloor" -hashPrimFun PrimCeiling{} = hash "PrimCeiling" -hashPrimFun PrimIsNaN{} = hash "PrimIsNaN" -hashPrimFun PrimLt{} = hash "PrimLt" -hashPrimFun PrimGt{} = hash "PrimGt" -hashPrimFun PrimLtEq{} = hash "PrimLtEq" -hashPrimFun PrimGtEq{} = hash "PrimGtEq" -hashPrimFun PrimEq{} = hash "PrimEq" -hashPrimFun PrimNEq{} = hash "PrimNEq" -hashPrimFun PrimMax{} = hash "PrimMax" -hashPrimFun PrimMin{} = hash "PrimMin" -hashPrimFun PrimFromIntegral{} = hash "PrimFromIntegral" -hashPrimFun PrimToFloating{} = hash "PrimToFloating" -hashPrimFun PrimCoerce{} = hash "PrimCoerce" -hashPrimFun PrimLAnd = hash "PrimLAnd" -hashPrimFun PrimLOr = hash "PrimLOr" -hashPrimFun PrimLNot = hash "PrimLNot" -hashPrimFun PrimOrd = hash "PrimOrd" -hashPrimFun PrimChr = hash "PrimChr" -hashPrimFun PrimBoolToInt = hash "PrimBoolToInt" diff --git a/Data/Array/Accelerate/Array/Data.hs b/Data/Array/Accelerate/Array/Data.hs --- a/Data/Array/Accelerate/Array/Data.hs +++ b/Data/Array/Accelerate/Array/Data.hs @@ -46,6 +46,7 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Debug.Flags +import Data.Array.Accelerate.Debug.Monitoring import Data.Array.Accelerate.Debug.Trace -- standard libraries @@ -774,6 +775,7 @@ new <- readIORef __mallocForeignPtrBytes ptr <- new bytes traceIO dump_gc $ printf "gc: allocated new host array (size=%d, ptr=%s)" bytes (show ptr) + didAllocateBytesLocal (fromIntegral bytes) return (castForeignPtr ptr) -- | Register the given function as the callback to use to allocate new array @@ -800,6 +802,7 @@ -- to add a finaliser to the plain ForeignPtr. For our purposes this is fine, -- since in Accelerate finalisers are handled using Lifetime -- +{-# INLINE mallocPlainForeignPtrBytesAligned #-} mallocPlainForeignPtrBytesAligned :: Int -> IO (ForeignPtr a) mallocPlainForeignPtrBytesAligned (I# size) = IO $ \s -> case newAlignedPinnedByteArray# size 16# s of diff --git a/Data/Array/Accelerate/Array/Remote/LRU.hs b/Data/Array/Accelerate/Array/Remote/LRU.hs --- a/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -34,25 +34,26 @@ ) where -import Data.Functor -import Data.Maybe ( isNothing ) -import Data.Proxy +import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, mkWeakMVar ) import Control.Monad ( filterM ) import Control.Monad.Catch import Control.Monad.IO.Class ( MonadIO, liftIO ) -import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, mkWeakMVar ) +import Data.Functor +import Data.Int ( Int64 ) +import Data.Maybe ( isNothing ) +import Data.Proxy +import Foreign.Storable ( sizeOf ) import System.CPUTime import System.Mem.Weak ( Weak, deRefWeak, finalize ) import Prelude hiding ( lookup ) - import qualified Data.HashTable.IO as HT -import qualified Data.Array.Accelerate.Debug as D -import Data.Array.Accelerate.Error ( internalError ) import Data.Array.Accelerate.Array.Data ( ArrayData, touchArrayData ) import Data.Array.Accelerate.Array.Remote.Class import Data.Array.Accelerate.Array.Remote.Table ( StableArray, makeWeakArrayData ) +import Data.Array.Accelerate.Error ( internalError ) import qualified Data.Array.Accelerate.Array.Remote.Table as Basic +import qualified Data.Array.Accelerate.Debug as D -- We build cached memory tables on top of a basic memory table. @@ -185,13 +186,13 @@ -- This has similar behaviour to malloc in Data.Array.Accelerate.Array.Memory.Table -- but also will copy remote arrays back to main memory in order to make space. -- --- The third argument indicates that the array should be considered frozen. --- That is to say the array arrays contents will never change. In the event that --- the array has to be evicted from the remote memory, the copy already residing --- in host memory should be considered valid. +-- The third argument indicates that the array should be considered frozen. That +-- is to say that the array contents will never change. In the event that the +-- array has to be evicted from the remote memory, the copy already residing in +-- host memory should be considered valid. -- --- If malloc is called on an array that is already contained within the cache, --- it becomes a no-op. +-- If this function is called on an array that is already contained within the +-- cache, this is a no-op. -- -- On return, 'True' indicates that we allocated some remote memory, and 'False' -- indicates that we did not need to. @@ -199,9 +200,9 @@ malloc :: forall a e m task. (PrimElt e a, RemoteMemory m, MonadIO m, Task task) => MemoryTable (RemotePtr m) task -> ArrayData e - -> Bool -- ^True if host array is frozen. + -> Bool -- ^ True if host array is frozen. -> Int - -> m Bool + -> m Bool -- ^ Was the array allocated successfully? malloc (MemoryTable mt ref weak_utbl) !ad !frozen !n = do ts <- liftIO $ getCPUTime key <- Basic.makeStableArray ad @@ -234,7 +235,8 @@ case mp of Nothing -> do success <- evictLRU utbl mt - if success then malloc' else $internalError "malloc" "Remote memory exhausted" + if success then malloc' + else $internalError "malloc" "Remote memory exhausted" Just p -> liftIO $ do key <- Basic.makeStableArray ad HT.insert utbl key usage @@ -264,6 +266,7 @@ Just arr -> do message ("evictLRU/evicting " ++ show sa) copyIfNecessary status n arr + liftIO $ D.didEvictBytes (remoteBytes n weak_arr) liftIO $ Basic.freeStable (Proxy :: Proxy m) mt sa liftIO $ HT.insert utbl sa (Used ts Evicted count tasks n weak_arr) return True @@ -281,6 +284,9 @@ | Nothing <- prev -> return (Just (sa, used)) _ -> return prev eldest prev _ = return prev + + remoteBytes :: forall e a. PrimElt e a => Int -> Weak (ArrayData e) -> Int64 + remoteBytes n _ = fromIntegral n * fromIntegral (sizeOf (undefined::a)) evictable :: Status -> Bool evictable Clean = True diff --git a/Data/Array/Accelerate/Array/Remote/Nursery.hs b/Data/Array/Accelerate/Array/Remote/Nursery.hs --- a/Data/Array/Accelerate/Array/Remote/Nursery.hs +++ b/Data/Array/Accelerate/Array/Remote/Nursery.hs @@ -20,16 +20,16 @@ -- friends import Data.Array.Accelerate.Error -import qualified Data.Array.Accelerate.Debug as D +import qualified Data.Array.Accelerate.Debug as Debug -- libraries -import Prelude hiding ( lookup ) import Control.Concurrent.MVar import Data.Int import Data.IntMap ( IntMap ) import Data.Sequence ( Seq ) import Data.Word import System.Mem.Weak ( Weak ) +import Prelude hiding ( lookup ) import qualified Data.IntMap.Strict as IM import qualified Data.Sequence as Seq import qualified Data.Traversable as Seq @@ -79,8 +79,10 @@ else Just vs -- re-insert the tail in case fmap Seq.viewl mv of - Just (v Seq.:< _) -> return ( N nrs' (sz - fromIntegral key) , Just v ) - _ -> return ( nrs, Nothing ) + Just (v Seq.:< _) -> let sz' = sz - fromIntegral key in do + Debug.setCurrentBytesNursery sz' + return ( N nrs' sz', Just v ) + _ -> return ( nrs, Nothing ) -- | Add an entry to the nursery @@ -92,8 +94,10 @@ f Nothing = Just (Seq.singleton val) f (Just vs) = Just (vs Seq.|> val) in - modifyMVar_ ref $ \(N im sz) -> - return $! N (IM.alter f key im) (sz + fromIntegral key) + modifyMVar_ ref $ \(N im sz) -> do + let sz' = sz + fromIntegral key + Debug.setCurrentBytesNursery sz' + return $! N (IM.alter f key im) sz' -- | Delete all entries from the nursery @@ -103,6 +107,7 @@ cleanup delete !ref = do message "nursery cleanup" modifyMVar_ ref $ \(N nrs _) -> do mapM_ (Seq.mapM delete) (IM.elems nrs) + Debug.setCurrentBytesNursery 0 return ( N IM.empty 0 ) @@ -118,5 +123,5 @@ {-# INLINE message #-} message :: String -> IO () -message msg = D.traceIO D.dump_gc ("gc: " ++ msg) +message msg = Debug.traceIO Debug.dump_gc ("gc: " ++ msg) diff --git a/Data/Array/Accelerate/Array/Remote/Table.hs b/Data/Array/Accelerate/Array/Remote/Table.hs --- a/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/Data/Array/Accelerate/Array/Remote/Table.hs @@ -245,6 +245,7 @@ Just (RemoteArray _ !p !bytes) -> do message ("free/evict: " ++ show sa ++ " of " ++ showBytes bytes) N.insert bytes (castRemotePtr proxy p) nrs + D.decreaseCurrentBytesRemote (fromIntegral bytes) mt `HT.delete` sa @@ -261,6 +262,7 @@ key <- makeStableArray arr weak <- liftIO $ makeWeakArrayData arr () (Just $ freeStable (Proxy :: Proxy m) mt key) message $ "insert: " ++ show key + liftIO $ D.increaseCurrentBytesRemote (fromIntegral bytes) liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray weak ptr bytes) @@ -280,7 +282,7 @@ key <- makeStableArray arr weak <- liftIO $ makeWeakArrayData arr () (Just $ remoteFinalizer weak_ref key) message $ "insertUnmanaged: " ++ show key - liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray weak ptr 0) + liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray weak ptr 0) -- Removing entries @@ -297,6 +299,7 @@ -- that finalizers are often significantly delayed, it is worth our while -- traversing the table and explicitly freeing any dead entires. -- + D.didRemoteGC performGC yield mr <- deRefWeak weak_ref diff --git a/Data/Array/Accelerate/Array/Representation.hs b/Data/Array/Accelerate/Array/Representation.hs --- a/Data/Array/Accelerate/Array/Representation.hs +++ b/Data/Array/Accelerate/Array/Representation.hs @@ -32,7 +32,6 @@ -- friends import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Type -- standard library import GHC.Base ( quotInt, remInt ) @@ -56,8 +55,6 @@ toIndex :: sh -> sh -> Int -- yield the index position in a linear, row-major representation of -- the array (first argument is the shape) fromIndex :: sh -> Int -> sh -- inverse of `toIndex` - bound :: sh -> sh -> Boundary e -> Either e sh - -- apply a boundary condition to an index iter :: sh -> (sh -> a) -> (a -> a -> a) -> a -> a -- iterate through the entire shape, applying the function in the @@ -87,7 +84,6 @@ size () = 1 toIndex () () = 0 fromIndex () _ = () - bound () () _ = Right () iter () f _ _ = f () iter1 () f _ = f () @@ -119,6 +115,7 @@ r | rank sh == 0 = $indexCheck "fromIndex" i sz i | otherwise = i `remInt` sz +{-- bound (sh, sz) (ix, i) bndy | i < 0 = case bndy of Clamp -> next `addDim` 0 @@ -133,7 +130,7 @@ | otherwise = next `addDim` i where -- This function is quite difficult to optimize due to the deep recursion - -- that is can generate with high-dimensional arrays. If we let 'next' be + -- that it can generate with high-dimensional arrays. If we let 'next' be -- inlined into each alternative of the cases above the size of this -- function on an n-dimensional array will grow as 7^n. This quickly causes -- GHC's head to explode. See GHC Trac #10491 for more details. @@ -142,6 +139,7 @@ Right ds `addDim` d = Right (ds, d) Left e `addDim` _ = Left e +--} iter (sh, sz) f c r = iter sh (\ix -> iter' (ix,0)) c r where diff --git a/Data/Array/Accelerate/Array/Sugar.hs b/Data/Array/Accelerate/Array/Sugar.hs --- a/Data/Array/Accelerate/Array/Sugar.hs +++ b/Data/Array/Accelerate/Array/Sugar.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,6 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -63,14 +64,15 @@ import Control.DeepSeq import Data.List ( intercalate, transpose ) import Data.Typeable - import GHC.Exts ( IsList ) +import Language.Haskell.TH hiding ( Foreign ) import qualified GHC.Exts as GHC -- friends -import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Error import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Array.Representation as Repr @@ -552,7 +554,7 @@ => (EltRepr a -> EltRepr b -> EltRepr c) -> (a -> b -> c) {-# INLINE liftToElt2 #-} -liftToElt2 f = \x y -> toElt $ f (fromElt x) (fromElt y) +liftToElt2 f x y = toElt $ f (fromElt x) (fromElt y) sinkFromElt :: (Elt a, Elt b) => (a -> b) @@ -564,7 +566,7 @@ => (a -> b -> c) -> (EltRepr a -> EltRepr b -> EltRepr c) {-# INLINE sinkFromElt2 #-} -sinkFromElt2 f = \x y -> fromElt $ f (toElt x) (toElt y) +sinkFromElt2 f x y = fromElt $ f (toElt x) (toElt y) -- {-# RULES -- "fromElt/toElt" forall e. fromElt (toElt e) = e @@ -584,8 +586,14 @@ -- Backends should be able to produce a string representation of the foreign -- function for pretty printing, typically the name of the function. strForeign :: asm args -> String + strForeign _ = "" + -- Backends which want to support compile-time embedding must be able to lift + -- the foreign function into Template Haskell + liftForeign :: asm args -> Q (TExp (asm args)) + liftForeign _ = $internalError "liftForeign" "not supported by this backend" + -- Surface arrays -- -------------- @@ -943,6 +951,7 @@ go ArrayEltRcuchar (AD_CUChar ua) = rnf ua go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = go r1 a1 `seq` go r2 a2 `seq` () + -- |Scalars arrays hold a single element -- type Scalar e = Array DIM0 e @@ -1007,9 +1016,6 @@ -- |Inverse of 'toIndex'. fromIndex :: sh -> Int -> sh - -- |Apply a boundary condition to an index. - bound :: sh -> sh -> Boundary a -> Either a sh - -- |Iterate through the entire shape, applying the function; third argument -- combines results and fourth is returned in case of an empty iteration -- space; the index space is traversed in row-major order. @@ -1047,10 +1053,6 @@ union sh1 sh2 = toElt (Repr.union (fromElt sh1) (fromElt sh2)) fromIndex sh ix = toElt (Repr.fromIndex (fromElt sh) ix) toIndex sh ix = Repr.toIndex (fromElt sh) (fromElt ix) - - bound sh ix bndy = case Repr.bound (fromElt sh) (fromElt ix) bndy of - Left v -> Left v - Right ix' -> Right $ toElt ix' iter sh f c r = Repr.iter (fromElt sh) (f . toElt) c r iter1 sh f r = Repr.iter1 (fromElt sh) (f . toElt) r diff --git a/Data/Array/Accelerate/Array/Unique.hs b/Data/Array/Accelerate/Array/Unique.hs --- a/Data/Array/Accelerate/Array/Unique.hs +++ b/Data/Array/Accelerate/Array/Unique.hs @@ -57,6 +57,7 @@ -- | Create a new UniqueArray -- +{-# INLINE newUniqueArray #-} newUniqueArray :: ForeignPtr e -> IO (UniqueArray e) newUniqueArray fp = UniqueArray <$> newUnique <*> newLifetime fp @@ -67,6 +68,7 @@ -- the action and use it after the action completes. All uses of the pointer -- should be inside the bracketed function. -- +{-# INLINE withUniqueArrayPtr #-} withUniqueArrayPtr :: UniqueArray a -> (Ptr a -> IO b) -> IO b withUniqueArrayPtr ua go = withLifetime (uniqueArrayData ua) $ \fp -> withForeignPtr fp go @@ -80,6 +82,7 @@ -- -- See also: 'unsafeGetValue', 'unsafeForeignPtrToPtr'. -- +{-# INLINE unsafeUniqueArrayPtr #-} unsafeUniqueArrayPtr :: UniqueArray a -> Ptr a unsafeUniqueArrayPtr = unsafeForeignPtrToPtr . unsafeGetValue . uniqueArrayData @@ -89,6 +92,7 @@ -- -- See: [Unique array strictness] -- +{-# INLINE touchUniqueArray #-} touchUniqueArray :: UniqueArray a -> IO () touchUniqueArray = touchLifetime . uniqueArrayData diff --git a/Data/Array/Accelerate/Async.hs b/Data/Array/Accelerate/Async.hs --- a/Data/Array/Accelerate/Async.hs +++ b/Data/Array/Accelerate/Async.hs @@ -75,7 +75,7 @@ {-# INLINE poll #-} poll :: Async a -> IO (Maybe a) poll (Async _ var) = - maybe (return Nothing) (either throwIO (return . Just)) =<< tryTakeMVar var + maybe (return Nothing) (either throwIO (return . Just)) =<< tryReadMVar var -- | Cancel a running asynchronous computation. -- diff --git a/Data/Array/Accelerate/Classes/Enum.hs b/Data/Array/Accelerate/Classes/Enum.hs --- a/Data/Array/Accelerate/Classes/Enum.hs +++ b/Data/Array/Accelerate/Classes/Enum.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | diff --git a/Data/Array/Accelerate/Classes/FromIntegral.hs b/Data/Array/Accelerate/Classes/FromIntegral.hs --- a/Data/Array/Accelerate/Classes/FromIntegral.hs +++ b/Data/Array/Accelerate/Classes/FromIntegral.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -- | diff --git a/Data/Array/Accelerate/Classes/Integral.hs b/Data/Array/Accelerate/Classes/Integral.hs --- a/Data/Array/Accelerate/Classes/Integral.hs +++ b/Data/Array/Accelerate/Classes/Integral.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Integral diff --git a/Data/Array/Accelerate/Classes/Real.hs b/Data/Array/Accelerate/Classes/Real.hs --- a/Data/Array/Accelerate/Classes/Real.hs +++ b/Data/Array/Accelerate/Classes/Real.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Data/Array/Accelerate/Classes/RealFloat.hs b/Data/Array/Accelerate/Classes/RealFloat.hs --- a/Data/Array/Accelerate/Classes/RealFloat.hs +++ b/Data/Array/Accelerate/Classes/RealFloat.hs @@ -5,6 +5,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFloat @@ -26,11 +27,17 @@ import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Data.Bits + +import Data.Array.Accelerate.Classes.Eq import Data.Array.Accelerate.Classes.Floating +import Data.Array.Accelerate.Classes.FromIntegral +import Data.Array.Accelerate.Classes.Num +import Data.Array.Accelerate.Classes.Ord import Data.Array.Accelerate.Classes.RealFrac import Text.Printf -import Prelude ( String, error, undefined ) +import Prelude ( (.), ($), String, error, undefined, otherwise ) import qualified Prelude as P @@ -54,7 +61,7 @@ floatRange _ = let (m,n) = P.floatRange (undefined::a) in (constant m, constant n) - -- | Return the significand and an appropriately scaled exponent. if + -- | Return the significand and an appropriately scaled exponent. If -- @(m,n) = 'decodeFloat' x@ then @x = m*b^^n@, where @b@ is the -- floating-point radix ('floatRadix'). Furthermore, either @m@ and @n@ are -- both zero, or @b^(d-1) <= 'abs' m < b^d@, where @d = 'floatDigits' x@. @@ -62,15 +69,36 @@ -- | Inverse of 'decodeFloat' encodeFloat :: Exp Int64 -> Exp Int -> Exp a -- Integer + default encodeFloat :: (FromIntegral Int a, FromIntegral Int64 a) => Exp Int64 -> Exp Int -> Exp a + encodeFloat x e = fromIntegral x * (fromIntegral (floatRadix (undefined :: Exp a)) ** fromIntegral e) -- | Corresponds to the second component of 'decodeFloat' exponent :: Exp a -> Exp Int + exponent x = let (m,n) = decodeFloat x + in Exp $ Cond (m == 0) + 0 + (n + floatDigits x) -- | Corresponds to the first component of 'decodeFloat' significand :: Exp a -> Exp a + significand x = let (m,_) = decodeFloat x + in encodeFloat m (negate (floatDigits x)) -- | Multiply a floating point number by an integer power of the radix scaleFloat :: Exp Int -> Exp a -> Exp a + scaleFloat k x = + Exp $ Cond (k == 0 || isFix) x + $ encodeFloat m (n + clamp b) + where + isFix = x == 0 || isNaN x || isInfinite x + (m,n) = decodeFloat x + (l,h) = floatRange x + d = floatDigits x + b = h - l + 4*d + -- n+k may overflow, which would lead to incorrect results, hence we clamp + -- the scaling parameter. If (n+k) would be larger than h, (n + clamp b k) + -- must be too, similar for smaller than (l-d). + clamp bd = max (-bd) (min bd k) -- | 'True' if the argument is an IEEE \"not-a-number\" (NaN) value isNaN :: Exp a -> Exp Bool @@ -96,31 +124,40 @@ -- @'atan2' y x@ returns a value in the range [@-pi@, @pi@]. atan2 :: Exp a -> Exp a -> Exp a - decodeFloat = $internalError "RealFloat.decodeFloat" "Not implemented yet" - encodeFloat = $internalError "RealFloat.encodeFloat" "Not implemented yet" - exponent = $internalError "RealFloat.exponent" "Not implemented yet" - significand = $internalError "RealFloat.significand" "Not implemented yet" - scaleFloat = $internalError "RealFloat.scaleFloat" "Not implemented yet" - isInfinite = $internalError "RealFloat.isInfinite" "Not implemented yet" - isDenormalized = $internalError "RealFloat.isDenormalized" "Not implemented yet" - isNegativeZero = $internalError "RealFloat.isNegativeZero" "Not implemented yet" - instance RealFloat Float where - isNaN = mkIsNaN atan2 = mkAtan2 + isNaN = mkIsNaN + isInfinite = mkIsInfinite + isDenormalized = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkUnsafeCoerce) + isNegativeZero = ieee754 "isNegativeZero" (ieee754_f32_is_negative_zero . mkUnsafeCoerce) + decodeFloat = ieee754 "decodeFloat" (\x -> let (m,n) = untup2 $ ieee754_f32_decode (mkUnsafeCoerce x) + in (fromIntegral m, n)) instance RealFloat Double where - isNaN = mkIsNaN atan2 = mkAtan2 + isNaN = mkIsNaN + isInfinite = mkIsInfinite + isDenormalized = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkUnsafeCoerce) + isNegativeZero = ieee754 "isNegativeZero" (ieee754_f64_is_negative_zero . mkUnsafeCoerce) + decodeFloat = ieee754 "decodeFloat" (untup2 . ieee754_f64_decode . mkUnsafeCoerce) instance RealFloat CFloat where - isNaN = mkIsNaN atan2 = mkAtan2 + isNaN = mkIsNaN + isInfinite = mkIsInfinite + isDenormalized = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkUnsafeCoerce) + isNegativeZero = ieee754 "isNegativeZero" (ieee754_f32_is_negative_zero . mkUnsafeCoerce) + decodeFloat = ieee754 "decodeFloat" (\x -> let (m,n) = untup2 $ ieee754_f32_decode (mkUnsafeCoerce x) + in (fromIntegral m, n)) instance RealFloat CDouble where - isNaN = mkIsNaN atan2 = mkAtan2 + isNaN = mkIsNaN + isInfinite = mkIsInfinite + isDenormalized = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkUnsafeCoerce) + isNegativeZero = ieee754 "isNegativeZero" (ieee754_f64_is_negative_zero . mkUnsafeCoerce) + decodeFloat = ieee754 "decodeFloat" (untup2 . ieee754_f64_decode . mkUnsafeCoerce) -- To satisfy superclass constraints @@ -138,5 +175,154 @@ isIEEE = preludeError "isIEEE" preludeError :: String -> a -preludeError x = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x) +preludeError x = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x x) + + +ieee754 :: forall a b. P.RealFloat a => String -> (Exp a -> b) -> Exp a -> b +ieee754 name f x + | P.isIEEE (undefined::a) = f x + | otherwise = $internalError (printf "RealFloat.%s" name) "Not implemented for non-IEEE floating point" + +-- From: ghc/libraries/base/cbits/primFloat.c +-- ------------------------------------------ + +-- An IEEE754 number is denormalised iff: +-- * exponent is zero +-- * mantissa is non-zero. +-- * (don't care about setting of sign bit.) +-- +ieee754_f64_is_denormalized :: Exp Word64 -> Exp Bool +ieee754_f64_is_denormalized x = + ieee754_f64_mantissa x == 0 && + ieee754_f64_exponent x /= 0 + +ieee754_f32_is_denormalized :: Exp Word32 -> Exp Bool +ieee754_f32_is_denormalized x = + ieee754_f32_mantissa x == 0 && + ieee754_f32_exponent x /= 0 + +-- Negative zero if only the sign bit is set +-- +ieee754_f64_is_negative_zero :: Exp Word64 -> Exp Bool +ieee754_f64_is_negative_zero x = + ieee754_f64_negative x && + ieee754_f64_exponent x == 0 && + ieee754_f64_mantissa x == 0 + +ieee754_f32_is_negative_zero :: Exp Word32 -> Exp Bool +ieee754_f32_is_negative_zero x = + ieee754_f32_negative x && + ieee754_f32_exponent x == 0 && + ieee754_f32_mantissa x == 0 + + +-- Assume the host processor stores integers and floating point numbers in the +-- same endianness (true for modern processors). +-- +-- To recap, here's the representation of a double precision +-- IEEE floating point number: +-- +-- sign 63 sign bit (0==positive, 1==negative) +-- exponent 62-52 exponent (biased by 1023) +-- fraction 51-0 fraction (bits to right of binary point) +-- +ieee754_f64_mantissa :: Exp Word64 -> Exp Word64 +ieee754_f64_mantissa x = x .&. 0xFFFFFFFFFFFFF + +ieee754_f64_exponent :: Exp Word64 -> Exp Word16 +ieee754_f64_exponent x = fromIntegral (x `unsafeShiftR` 52) .&. 0x7FF + +ieee754_f64_negative :: Exp Word64 -> Exp Bool +ieee754_f64_negative x = testBit x 63 + +-- Representation of single precision IEEE floating point number: +-- +-- sign 31 sign bit (0==positive, 1==negative) +-- exponent 30-23 exponent (biased by 127) +-- fraction 22-0 fraction (bits to right of binary point) +-- +ieee754_f32_mantissa :: Exp Word32 -> Exp Word32 +ieee754_f32_mantissa x = x .&. 0x7FFFFF + +ieee754_f32_exponent :: Exp Word32 -> Exp Word8 +ieee754_f32_exponent x = fromIntegral (x `unsafeShiftR` 23) + +ieee754_f32_negative :: Exp Word32 -> Exp Bool +ieee754_f32_negative x = testBit x 31 + +-- From: ghc/rts/StgPrimFloat.c +-- ---------------------------- + +ieee754_f32_decode :: Exp Word32 -> Exp (Int32, Int) +ieee754_f32_decode i = + let + _FMSBIT = 0x80000000 + _FHIGHBIT = 0x00800000 + _FMINEXP = ((_FLT_MIN_EXP) - (_FLT_MANT_DIG) - 1) + _FLT_MANT_DIG = floatDigits (undefined::Exp Float) + (_FLT_MIN_EXP, _FLT_MAX_EXP) = floatRange (undefined::Exp Float) + + high1 = fromIntegral i + high2 = high1 .&. (_FHIGHBIT - 1) + + exp1 = ((fromIntegral high1 `unsafeShiftR` 23) .&. 0xFF) + _FMINEXP + exp2 = exp1 + 1 + + (high3, exp3) + = untup2 + $ Exp $ Cond (exp1 /= _FMINEXP) + -- don't add hidden bit to denorms + (tup2 (high2 .|. _FHIGHBIT, exp1)) + -- a denorm, normalise the mantissa + (Exp $ While (\(untup2 -> (h,_)) -> (h .&. _FHIGHBIT) /= 0 ) + (\(untup2 -> (h,e)) -> tup2 (h `unsafeShiftL` 1, e-1)) + (tup2 (high2, exp2))) + + high4 = Exp $ Cond (fromIntegral i < (0 :: Exp Int32)) (-high3) high3 + in + Exp $ Cond (high1 .&. complement _FMSBIT == 0) + (tup2 (0,0)) + (tup2 (high4, exp3)) + + +ieee754_f64_decode :: Exp Word64 -> Exp (Int64, Int) +ieee754_f64_decode i = + let (s,h,l,e) = untup4 $ ieee754_f64_decode2 i + in tup2 (fromIntegral s * (fromIntegral h `unsafeShiftL` 32 .|. fromIntegral l), e) + +ieee754_f64_decode2 :: Exp Word64 -> Exp (Int, Word32, Word32, Int) +ieee754_f64_decode2 i = + let + _DHIGHBIT = 0x00100000 + _DMSBIT = 0x80000000 + _DMINEXP = ((_DBL_MIN_EXP) - (_DBL_MANT_DIG) - 1) + _DBL_MANT_DIG = floatDigits (undefined::Exp Double) + (_DBL_MIN_EXP, _DBL_MAX_EXP) = floatRange (undefined::Exp Double) + + low = fromIntegral i + high = fromIntegral (i `unsafeShiftR` 32) + + iexp = (fromIntegral ((high `unsafeShiftR` 20) .&. 0x7FF) + _DMINEXP) + sign = Exp $ Cond (fromIntegral i < (0 :: Exp Int64)) (-1) 1 + + high2 = high .&. (_DHIGHBIT - 1) + iexp2 = iexp + 1 + + (hi,lo,ie) + = untup3 + $ Exp $ Cond (iexp2 /= _DMINEXP) + -- don't add hidden bit to denorms + (tup3 (high2 .|. _DHIGHBIT, low, iexp)) + -- a denorm, nermalise the mantissa + (Exp $ While (\(untup3 -> (h,_,_)) -> (h .&. _DHIGHBIT) /= 0) + (\(untup3 -> (h,l,e)) -> + let h1 = h `unsafeShiftL` 1 + h2 = Exp $ Cond ((l .&. _DMSBIT) /= 0) (h1+1) h1 + in tup3 (h2, l `unsafeShiftL` 1, e-1)) + (tup3 (high2, low, iexp2))) + + in + Exp $ Cond (low == 0 && (high .&. (complement _DMSBIT)) == 0) + (tup4 (1,0,0,0)) + (tup4 (sign,hi,lo,ie)) diff --git a/Data/Array/Accelerate/Classes/RealFrac.hs b/Data/Array/Accelerate/Classes/RealFrac.hs --- a/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/Data/Array/Accelerate/Classes/RealFrac.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -161,5 +162,5 @@ floor = preludeError "floor" preludeError :: String -> a -preludeError x = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x) +preludeError x = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x x) diff --git a/Data/Array/Accelerate/Debug/Flags.hs b/Data/Array/Accelerate/Debug/Flags.hs --- a/Data/Array/Accelerate/Debug/Flags.hs +++ b/Data/Array/Accelerate/Debug/Flags.hs @@ -27,13 +27,13 @@ module Data.Array.Accelerate.Debug.Flags ( Flags, Mode, - acc_sharing, exp_sharing, fusion, simplify, flush_cache, fast_math, verbose, + acc_sharing, exp_sharing, fusion, simplify, flush_cache, force_recomp, fast_math, verbose, dump_phases, dump_sharing, dump_simpl_stats, dump_simpl_iterations, dump_vectorisation, dump_dot, dump_simpl_dot, dump_gc, dump_gc_stats, debug_cc, dump_cc, dump_ld, dump_asm, dump_exec, dump_sched, accInit, - queryFlag, setFlag, setFlags, clearFlag, clearFlags, + queryFlag, setFlag, setFlag', setFlags, clearFlag, clearFlags, when, unless, ) where @@ -41,6 +41,7 @@ import Control.Monad.IO.Class import Data.IORef import Data.Label +import Data.Label.Derive import Data.List import System.Environment import System.IO.Unsafe @@ -59,80 +60,99 @@ data FlagSpec flag = Option String -- external form flag -- internal form +data OptKind f + = NoArg f + | IntArg (Int -> f) + + -- The runtime debug and control options supported by Accelerate. This is a bit -- awkward, as we process both frontend as well as backend option flags, but -- gives some control over error messages and overlapping options. -- -fclabels [d| - data Flags = Flags - { - -- Functionality and phase control - -- ------------------------------- - -- - -- These are Maybe types because they will only override the backend - -- options if the user specifies a value - -- - acc_sharing :: !(Maybe Bool) -- recover sharing of array computations - , exp_sharing :: !(Maybe Bool) -- recover sharing of scalar expressions - , fusion :: !(Maybe Bool) -- fuse array expressions - , simplify :: !(Maybe Bool) -- simplify scalar expressions --- , unfolding_use_threshold :: !(Maybe Int) -- the magic cut-off figure for inlining - , flush_cache :: !(Maybe Bool) -- delete persistent compilation cache(s) - , fast_math :: !(Maybe Bool) -- use faster, less precise math library operations +data Flags = Flags + { + -- Functionality and phase control + -- ------------------------------- + -- + -- These are Maybe types because they will only override the backend + -- options if the user specifies a value + -- + _acc_sharing :: !(Maybe Bool) -- recover sharing of array computations + , _exp_sharing :: !(Maybe Bool) -- recover sharing of scalar expressions + , _fusion :: !(Maybe Bool) -- fuse array expressions + , _simplify :: !(Maybe Bool) -- simplify scalar expressions + , _unfolding_use_threshold :: !(Maybe Int) -- the magic cut-off figure for inlining + , _flush_cache :: !(Maybe Bool) -- delete persistent compilation cache(s) + , _force_recomp :: !(Maybe Bool) -- force recompilation of array programs + , _fast_math :: !(Maybe Bool) -- use faster, less precise math library operations - -- Debug trace - -- ----------- - , verbose :: !Bool -- be very chatty + -- Debug trace + -- ----------- + , _verbose :: !Bool -- be very chatty - -- optimisation and simplification - , dump_phases :: !Bool -- print information about each phase of the compiler - , dump_sharing :: !Bool -- sharing recovery phase - , dump_simpl_stats :: !Bool -- statistics form fusion/simplification - , dump_simpl_iterations :: !Bool -- output from each simplifier iteration - , dump_vectorisation :: !Bool -- output from the vectoriser - , dump_dot :: !Bool -- generate dot output of the program - , dump_simpl_dot :: !Bool -- generate simplified dot output + -- optimisation and simplification + , _dump_phases :: !Bool -- print information about each phase of the compiler + , _dump_sharing :: !Bool -- sharing recovery phase + , _dump_simpl_stats :: !Bool -- statistics form fusion/simplification + , _dump_simpl_iterations :: !Bool -- output from each simplifier iteration + , _dump_vectorisation :: !Bool -- output from the vectoriser + , _dump_dot :: !Bool -- generate dot output of the program + , _dump_simpl_dot :: !Bool -- generate simplified dot output - -- garbage collection - , dump_gc :: !Bool -- trace garbage collector - , dump_gc_stats :: !Bool -- print final GC statistics + -- garbage collection + , _dump_gc :: !Bool -- trace garbage collector + , _dump_gc_stats :: !Bool -- print final GC statistics - -- code generation / compilation - , debug_cc :: !Bool -- compile with debug symbols - , dump_cc :: !Bool -- trace code generation & compilation - , dump_ld :: !Bool -- trace runtime linker - , dump_asm :: !Bool -- trace assembler + -- code generation / compilation + , _debug_cc :: !Bool -- compile with debug symbols + , _dump_cc :: !Bool -- trace code generation & compilation + , _dump_ld :: !Bool -- trace runtime linker + , _dump_asm :: !Bool -- trace assembler - -- execution - , dump_exec :: !Bool -- trace execution - , dump_sched :: !Bool -- trace scheduler - } - |] + -- execution + , _dump_exec :: !Bool -- trace execution + , _dump_sched :: !Bool -- trace scheduler + } +-- Generate labels with INLINE pragmas +$(mkLabelsWith defaultNaming True False False True ''Flags) -allFlags :: [FlagSpec (Flags -> Flags)] + +allFlags :: [FlagSpec (OptKind (Flags -> Flags))] allFlags - = map (enable 'd') dflags - ++ map (enable 'f') fflags ++ map (disable 'f') fflags + = map (enableB 'd') dflags + ++ map (enableB 'f') fflagsB ++ map (disableB 'f') fflagsB + ++ map (enableI 'f') fflagsI where - enable p (Option f go) = Option ('-':p:f) (go True) - disable p (Option f go) = Option ('-':p:"no-"++f) (go False) + enableI p (Option f go) = Option ('-':p:f) (IntArg go) + enableB p (Option f go) = Option ('-':p:f) (NoArg (go True)) + disableB p (Option f go) = Option ('-':p:"no-"++f) (NoArg (go False)) -- These @-f\@ phase control flags can be reversed with @-fno-\@ -- -fflags :: [FlagSpec (Bool -> Flags -> Flags)] -fflags = +fflagsB :: [FlagSpec (Bool -> Flags -> Flags)] +fflagsB = [ Option "acc-sharing" (set' acc_sharing) , Option "exp-sharing" (set' exp_sharing) , Option "fusion" (set' fusion) , Option "simplify" (set' simplify) , Option "flush-cache" (set' flush_cache) + , Option "force-recomp" (set' force_recomp) , Option "fast-math" (set' fast_math) ] where set' f v = set f (Just v) +-- These @-f\@ flags require an integer argument +-- +fflagsI :: [FlagSpec (Int -> Flags -> Flags)] +fflagsI = + [ Option "unfolding-use-threshold" (set' unfolding_use_threshold) + ] + where + set' f v = set f (Just v) + -- These debugging flags default to off and can be enable with @-d\@ -- dflags :: [FlagSpec (Bool -> Flags -> Flags)] @@ -197,17 +217,28 @@ env <- maybe [] words `fmap` lookupEnv "ACCELERATE_FLAGS" return $ parse (env ++ argv) where - defaults = Flags def def def def def def def def def def def def def def def def def def def def def def + defaults :: Flags + defaults = Flags def def def def def def def def def def def def def def def def def def def def def def def def - parse = foldl parse1 defaults - parse1 opts this = - case filter (\(Option flag _) -> this `isPrefixOf` flag) allFlags of - [Option _ go] -> go opts + parse :: [String] -> Flags + parse = foldl parse1 defaults + + parse1 :: Flags -> String -> Flags + parse1 opts this = + case filter (\(Option flag _) -> prefix `isPrefixOf` flag) allFlags of + [Option _ f] -> apply f [] -> trace unknown opts - alts -> case find (\(Option flag _) -> flag == this) alts of - Just (Option _ go) -> go opts + alts -> case find (\(Option flag _) -> flag == prefix) alts of + Just (Option _ f) -> apply f Nothing -> trace (ambiguous alts) opts where + apply :: OptKind (Flags -> Flags) -> Flags + apply (NoArg f) = f opts + apply (IntArg f) = f (read suffix) opts + + (prefix,rest) = break (== '=') this + suffix = if null rest then [] else tail rest + unknown = render $ text "Unknown option:" <+> quotes (text this) ambiguous alts = render $ vcat [ text "Ambiguous option:" <+> quotes (text this) @@ -262,6 +293,13 @@ setFlag, clearFlag :: Mode -> IO () setFlag f = setFlags [f] clearFlag f = clearFlags [f] + +setFlag' :: (Flags :-> a) -> a -> IO () +#ifdef ACCELERATE_DEBUG +setFlag' f v = modifyIORef _flags (set f v) +#else +setFlag' _ _ = return () +#endif setFlags, clearFlags :: [Mode] -> IO () #ifdef ACCELERATE_DEBUG diff --git a/Data/Array/Accelerate/Debug/Monitoring.hs b/Data/Array/Accelerate/Debug/Monitoring.hs --- a/Data/Array/Accelerate/Debug/Monitoring.hs +++ b/Data/Array/Accelerate/Debug/Monitoring.hs @@ -18,12 +18,18 @@ beginMonitoring, initAccMetrics, + -- Load monitoring Processor(..), withProcessor, addProcessorTime, - didAllocateBytes, - didEvictLRU, - didMajorGC, + -- GC subsystem monitoring + didAllocateBytesLocal, didAllocateBytesRemote, + didCopyBytesToRemote, didCopyBytesFromRemote, + increaseCurrentBytesRemote, decreaseCurrentBytesRemote, + setCurrentBytesNursery, + didRemoteGC, + didEvictBytes, + ) where #ifdef ACCELERATE_MONITORING @@ -87,6 +93,53 @@ -- > -- > ... -- +-- Note that aside from the processor load metrics, counters are shared between +-- all active backends. +-- +-- Registered rates: +-- +-- [@acc.load.llvm_native@] Current processor load (%) of the LLVM CPU backend. +-- This only includes time spent executing Accelerate functions; compare this to +-- the total processor load (e.g. via top) to estimate the productivity of the +-- Accelerate program. +-- +-- [@acc.load.llvm_ptx@] Current processor load (%) of the GPU in the LLVM PTX +-- backend. This only takes into account how much time the GPU spent executing +-- Accelerate code, and does not consider the number of active cores during that +-- time. +-- +-- Registered gauges: +-- +-- [@acc.gc.current_bytes_remote@] Total number of bytes currently considered +-- live in the remote address space. +-- +-- [@acc.gc.current_bytes_nursery@] Total number of bytes allocated in the +-- remote address space but not currently live (available for reallocation). +-- +-- Registered counters: +-- +-- [@acc.gc.bytes_allocated_local@] Total number of bytes allocated in the local +-- address space. +-- +-- [@acc.gc.bytes_allocated_remote@] Total number of bytes allocated in the +-- remote address space. +-- +-- [@acc.gc.bytes_copied_to_remote@] Total number of bytes copied from the host +-- to the remote address space (e.g. from the CPU to the GPU). +-- +-- [@acc.gc.bytes_copied_from_remote@] Total number of bytes copied from the +-- remote address space back to the host (e.g. from the GPU back to the CPU). +-- +-- [@acc.gc.bytes_evicted_from_remote@] Total number of bytes evicted from the +-- remote address space by the LRU memory manager, in order to make space for +-- new allocations. A subset of __acc.gc.bytes_copied_from_remote__. +-- +-- [@acc.gc.num_gcs@] Number of garbage collections of the remote address space +-- performed. +-- +-- [@acc.gc.num_lru_evict@] Total number of evictions from the remote address +-- space performed. +-- #ifndef ACCELERATE_MONITORING initAccMetrics :: IO a initAccMetrics = error "Data.Array.Accelerate: Monitoring is disabled. Reinstall package 'accelerate' with '-fekg' to enable it." @@ -95,16 +148,17 @@ initAccMetrics = do store <- newStore - registerRate "acc.load.llvm_native" (calculateProcessorLoad _active_ns_llvm_native) store - registerRate "acc.load.llvm_ptx" (calculateProcessorLoad _active_ns_llvm_ptx) store - registerRate "acc.load.cuda" (calculateProcessorLoad _active_ns_cuda) store - registerCounter "acc.gc.bytes_allocated" (Counter.read _bytesAllocated) store - registerCounter "acc.gc.bytes_copied_to_remote" (Counter.read _bytesCopiedToRemote) store - registerCounter "acc.gc.bytes_copied_from_remote" (Counter.read _bytesCopiedFromRemote) store - registerGauge "acc.gc.current_bytes_active" (Gauge.read _bytesActive) store - registerGauge "acc.gc.current_bytes_nursery" (Gauge.read _bytesNursery) store - registerCounter "acc.gc.num_gcs" (Counter.read _numMajorGC) store - registerCounter "acc.gc.num_lru_evict" (Counter.read _numEvictions) store + registerRate "acc.load.llvm_native" (estimateProcessorLoad _active_ns_llvm_native) store + registerRate "acc.load.llvm_ptx" (estimateProcessorLoad _active_ns_llvm_ptx) store + registerGauge "acc.gc.current_bytes_remote" (Gauge.read _current_bytes_remote) store + registerGauge "acc.gc.current_bytes_nursery" (Gauge.read _current_bytes_nursery) store + registerCounter "acc.gc.bytes_allocated_local" (Counter.read _total_bytes_allocated_local) store + registerCounter "acc.gc.bytes_allocated_remote" (Counter.read _total_bytes_allocated_remote) store + registerCounter "acc.gc.bytes_copied_to_remote" (Counter.read _total_bytes_copied_to_remote) store + registerCounter "acc.gc.bytes_copied_from_remote" (Counter.read _total_bytes_copied_from_remote) store + registerCounter "acc.gc.bytes_evicted_from_remote" (Counter.read _total_bytes_evicted_from_remote) store + registerCounter "acc.gc.num_gcs" (Counter.read _num_remote_gcs) store + registerCounter "acc.gc.num_lru_evict" (Counter.read _num_evictions) store return store @@ -122,7 +176,7 @@ -- Recording metrics -- ----------------- -data Processor = Native | PTX | CUDA +data Processor = Native | PTX -- | Execute the given action and assign the elapsed wall-clock time as active -- time for the given processing element. @@ -134,7 +188,6 @@ #else withProcessor Native = withProcessor' _active_ns_llvm_native withProcessor PTX = withProcessor' _active_ns_llvm_ptx -withProcessor CUDA = withProcessor' _active_ns_cuda withProcessor' :: Atomic -> IO a -> IO a withProcessor' var action = do @@ -155,7 +208,6 @@ #else addProcessorTime Native = addProcessorTime' _active_ns_llvm_native addProcessorTime PTX = addProcessorTime' _active_ns_llvm_ptx -addProcessorTime CUDA = addProcessorTime' _active_ns_cuda addProcessorTime' :: Atomic -> Double -> IO () addProcessorTime' var secs = @@ -164,27 +216,96 @@ #endif -didAllocateBytes :: Int64 -> IO () -didEvictLRU :: IO () -didMajorGC :: IO () +-- | Allocated the number of bytes in the local memory space +-- +didAllocateBytesLocal :: Int64 -> IO () +#ifndef ACCELERATE_MONITORING +didAllocateBytesLocal _ = return () +#else +didAllocateBytesLocal n = do + -- void $ Atomic.add _active_bytes_allocated_local n + Counter.add _total_bytes_allocated_local n +#endif +-- | Allocated the number of bytes of /new/ memory in the remote memory space +-- +didAllocateBytesRemote :: Int64 -> IO () #ifndef ACCELERATE_MONITORING -didAllocateBytes _ = return () -didEvictLRU = return () -didMajorGC = return () +didAllocateBytesRemote _ = return () #else -didAllocateBytes n = do - Counter.add _bytesAllocated n - Gauge.add _bytesActive n +didAllocateBytesRemote n = do + -- void $ Atomic.add _active_bytes_allocated_remote n + Counter.add _total_bytes_allocated_remote n +#endif -didEvictLRU = Counter.inc _numEvictions +{-# INLINE increaseCurrentBytesRemote #-} +increaseCurrentBytesRemote :: Int64 -> IO () +#ifndef ACCELERATE_MONITORING +increaseCurrentBytesRemote _ = return () +#else +increaseCurrentBytesRemote n = Gauge.add _current_bytes_remote n +#endif -didMajorGC = do - Counter.inc _numMajorGC - Gauge.set _bytesNursery 0 -- ??? +{-# INLINE decreaseCurrentBytesRemote #-} +decreaseCurrentBytesRemote :: Int64 -> IO () +#ifndef ACCELERATE_MONITORING +decreaseCurrentBytesRemote _ = return () +#else +decreaseCurrentBytesRemote n = Gauge.subtract _current_bytes_remote n #endif +-- | Copied data between the local and remote memory spaces +-- +didCopyBytesToRemote :: Int64 -> IO () +#ifndef ACCELERATE_MONITORING +didCopyBytesToRemote _ = return () +#else +didCopyBytesToRemote n = Counter.add _total_bytes_copied_to_remote n +#endif +didCopyBytesFromRemote :: Int64 -> IO () +#ifndef ACCELERATE_MONITORING +didCopyBytesFromRemote _ = return () +#else +didCopyBytesFromRemote n = Counter.add _total_bytes_copied_from_remote n +#endif + + +-- TLM: This is required for the 'cleanup' function (which deletes everything +-- from the nursery) and is somewhat useful for the add/remove functions, since +-- we keep track of the size anyway, but we do lose track of the number of +-- allocations/deletions to/from the nursery. +-- +{-# INLINE setCurrentBytesNursery #-} +setCurrentBytesNursery :: Int64 -> IO () +#ifndef ACCELERATE_MONITORING +setCurrentBytesNursery _ = return () +#else +setCurrentBytesNursery n = Gauge.set _current_bytes_nursery n +#endif + + +-- | Performed a major GC of the remote memory space +-- +didRemoteGC :: IO () +#ifndef ACCELERATE_MONITORING +didRemoteGC = return () +#else +didRemoteGC = Counter.inc _num_remote_gcs +#endif + +-- | Performed an eviction of a remote array of the given number of bytes +-- +didEvictBytes :: Int64 -> IO () +#ifndef ACCELERATE_MONITORING +didEvictBytes _ = return () +#else +didEvictBytes n = do + Counter.inc _num_evictions + Counter.add _total_bytes_evicted_from_remote n +#endif + + -- Implementation -- -------------- @@ -205,9 +326,10 @@ } -- Estimate the load on the processor as a moving exponential average +-- (weight of previous measurement = 0.2). -- -calculateProcessorLoad :: Atomic -> IORef EMAState -> IO Int64 -calculateProcessorLoad !var !ref = do +estimateProcessorLoad :: Atomic -> IORef EMAState -> IO Int64 +estimateProcessorLoad !var !ref = do ES{..} <- readIORef ref time <- getCurrentTime sample <- Atomic.and var 0 @@ -217,11 +339,11 @@ elapsed_s = realToFrac (diffUTCTime time old_time) elapsed_ns = 1.0E9 * elapsed_s -- - load_inst = 100 * (active_ns / elapsed_ns) -- instantaneous load - load_avg = ema 0.2 elapsed_s old_avg old_inst load_inst -- moving average load + new_inst = 100 * (active_ns / elapsed_ns) -- instantaneous load + new_avg = ema 0.2 elapsed_s old_avg old_inst new_inst -- moving average load -- - writeIORef ref (ES time load_inst load_avg) - return (round load_avg) + writeIORef ref (ES time new_inst new_avg) + return (round new_avg) {-- @@ -281,47 +403,57 @@ _active_ns_cuda :: Atomic _active_ns_cuda = unsafePerformIO (Atomic.new 0) --- Total number of bytes allocated in the remote address space (e.g. on the GPU) +-- Total number of bytes allocated in the local and remote (e.g. on the GPU) +-- address spaces -- -{-# NOINLINE _bytesAllocated #-} -_bytesAllocated :: Counter -_bytesAllocated = unsafePerformIO Counter.new +{-# NOINLINE _total_bytes_allocated_local #-} +_total_bytes_allocated_local :: Counter +_total_bytes_allocated_local = unsafePerformIO Counter.new --- Total number of bytes copied from the host to the remote memory space +{-# NOINLINE _total_bytes_allocated_remote #-} +_total_bytes_allocated_remote :: Counter +_total_bytes_allocated_remote = unsafePerformIO Counter.new + +-- Total number of bytes copied to and from the remote memory space -- -{-# NOINLINE _bytesCopiedToRemote #-} -_bytesCopiedToRemote :: Counter -_bytesCopiedToRemote = unsafePerformIO Counter.new +{-# NOINLINE _total_bytes_copied_to_remote #-} +_total_bytes_copied_to_remote :: Counter +_total_bytes_copied_to_remote = unsafePerformIO Counter.new --- Total number of bytes copied from the remote memory space back to the device +{-# NOINLINE _total_bytes_copied_from_remote #-} +_total_bytes_copied_from_remote :: Counter +_total_bytes_copied_from_remote = unsafePerformIO Counter.new + +-- Total number of bytes copied out of the remote memory space due to evictions. -- -{-# NOINLINE _bytesCopiedFromRemote #-} -_bytesCopiedFromRemote :: Counter -_bytesCopiedFromRemote = unsafePerformIO Counter.new +{-# NOINLINE _total_bytes_evicted_from_remote #-} +_total_bytes_evicted_from_remote :: Counter +_total_bytes_evicted_from_remote = unsafePerformIO Counter.new -- Current working remote memory size -- -{-# NOINLINE _bytesActive #-} -_bytesActive :: Gauge -_bytesActive = unsafePerformIO Gauge.new +{-# NOINLINE _current_bytes_remote #-} +_current_bytes_remote :: Gauge +_current_bytes_remote = unsafePerformIO Gauge.new -- Current size of the nursery -- -{-# NOINLINE _bytesNursery #-} -_bytesNursery :: Gauge -_bytesNursery = unsafePerformIO Gauge.new +{-# NOINLINE _current_bytes_nursery #-} +_current_bytes_nursery :: Gauge +_current_bytes_nursery = unsafePerformIO Gauge.new --- Number of times the nursery was flushed +-- Number of times the remote memory was forcibly garbage collected, and nursery +-- flushed. -- -{-# NOINLINE _numMajorGC #-} -_numMajorGC :: Counter -_numMajorGC = unsafePerformIO Counter.new +{-# NOINLINE _num_remote_gcs #-} +_num_remote_gcs :: Counter +_num_remote_gcs = unsafePerformIO Counter.new -- number of LRU eviction events -- -{-# NOINLINE _numEvictions #-} -_numEvictions :: Counter -_numEvictions = unsafePerformIO Counter.new +{-# NOINLINE _num_evictions #-} +_num_evictions :: Counter +_num_evictions = unsafePerformIO Counter.new #endif diff --git a/Data/Array/Accelerate/Debug/Timed.hs b/Data/Array/Accelerate/Debug/Timed.hs --- a/Data/Array/Accelerate/Debug/Timed.hs +++ b/Data/Array/Accelerate/Debug/Timed.hs @@ -25,7 +25,6 @@ #if ACCELERATE_DEBUG import Control.Applicative import Control.Monad.Trans ( liftIO ) -import Data.Int import Data.List import Data.Time.Clock import System.CPUTime @@ -46,7 +45,7 @@ enabled <- liftIO $ queryFlag mode if enabled then do - with_gc <- liftIO $ (&&) <$> getGCStatsEnabled <*> queryFlag verbose + with_gc <- liftIO $ (&&) <$> getRTSStatsEnabled <*> queryFlag verbose if with_gc then timed_gc fmt action else timed_simpl fmt action @@ -74,13 +73,20 @@ timed_gc :: MonadIO m => (Double -> Double -> String) -> m a -> m a timed_gc fmt action = do - gc0 <- liftIO getGCStats - res <- action - gc1 <- liftIO getGCStats +#if __GLASGOW_HASKELL__ < 802 + gc0 <- liftIO getGCStats + res <- action + gc1 <- liftIO getGCStats +#else + rts0 <- liftIO getRTSStats + res <- action + rts1 <- liftIO getRTSStats +#endif -- - let toDouble :: Int64 -> Double - toDouble = fromIntegral + let toDouble :: Integral a => a -> Double + toDouble = fromIntegral -- +#if __GLASGOW_HASKELL__ < 802 allocated = toDouble (bytesAllocated gc1 - bytesAllocated gc0) copied = toDouble (bytesCopied gc1 - bytesCopied gc0) totalWall = wallSeconds gc1 - wallSeconds gc0 @@ -89,16 +95,35 @@ mutatorCPU = mutatorCpuSeconds gc1 - mutatorCpuSeconds gc0 gcWall = gcWallSeconds gc1 - gcWallSeconds gc0 gcCPU = gcCpuSeconds gc1 - gcCpuSeconds gc0 + totalGCs = numGcs gc1 - numGcs gc0 +#else + gc0 = gc rts0 + gc1 = gc rts1 + allocated = toDouble (gcdetails_allocated_bytes gc1 - gcdetails_allocated_bytes gc0) + copied = toDouble (gcdetails_copied_bytes gc1 - gcdetails_copied_bytes gc0) + totalWall = toDouble (elapsed_ns rts1 - elapsed_ns rts0) * 1.0E-9 + totalCPU = toDouble (cpu_ns rts1 - cpu_ns rts0) * 1.0E-9 + mutatorWall = toDouble (mutator_elapsed_ns rts1 - mutator_elapsed_ns rts0) * 1.0E-9 + mutatorCPU = toDouble (mutator_cpu_ns rts1 - mutator_cpu_ns rts0) * 1.0E-9 + gcWall = toDouble (gcdetails_elapsed_ns gc1 - gcdetails_elapsed_ns gc0) * 1.0E-9 + gcCPU = toDouble (gcdetails_cpu_ns gc1 - gcdetails_cpu_ns gc0) * 1.0E-9 + totalGCs = gcs rts1 - gcs rts0 +#endif liftIO . putTraceMsg $ intercalate "\n" [ fmt totalWall totalCPU , printf " %s allocated on the heap" (showFFloatSIBase (Just 1) 1024 allocated "B") - , printf " %s copied during GC (%d collections)" (showFFloatSIBase (Just 1) 1024 copied "B") (numGcs gc1 - numGcs gc0) + , printf " %s copied during GC (%d collections)" (showFFloatSIBase (Just 1) 1024 copied "B") totalGCs , printf " MUT: %s" (elapsed mutatorWall mutatorCPU) , printf " GC: %s" (elapsed gcWall gcCPU) ] -- return res + +#if __GLASGOW_HASKELL__ < 802 +getRTSStatsEnabled :: IO Bool +getRTSStatsEnabled = getGCStatsEnabled +#endif #endif elapsed :: Double -> Double -> String diff --git a/Data/Array/Accelerate/Interpreter.hs b/Data/Array/Accelerate/Interpreter.hs --- a/Data/Array/Accelerate/Interpreter.hs +++ b/Data/Array/Accelerate/Interpreter.hs @@ -42,7 +42,8 @@ module Data.Array.Accelerate.Interpreter ( -- * Interpret an array expression - Arrays, run, run1, + Sugar.Acc, Arrays, + run, run1, runN, -- Internal (hidden) evalPrim, evalPrimConst, evalPrj @@ -61,7 +62,8 @@ import Prelude hiding ( sum ) -- friends -import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST hiding ( Boundary, PreBoundary(..) ) +import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) import Data.Array.Accelerate.Array.Sugar @@ -69,6 +71,7 @@ import Data.Array.Accelerate.Product import Data.Array.Accelerate.Trafo hiding ( Delayed ) import Data.Array.Accelerate.Type +import qualified Data.Array.Accelerate.AST as AST import qualified Data.Array.Accelerate.Array.Representation as R import qualified Data.Array.Accelerate.Smart as Sugar import qualified Data.Array.Accelerate.Trafo as AST @@ -90,18 +93,28 @@ D.dumpSimplStats phase "execute" D.elapsed (evaluate (evalOpenAcc acc Empty)) --- | Prepare and run an embedded array program of one argument +-- | This is 'runN' specialised to an array program of one argument. -- run1 :: (Arrays a, Arrays b) => (Sugar.Acc a -> Sugar.Acc b) -> a -> b -run1 f = \a -> unsafePerformIO (execute a) +run1 = runN + +-- | Prepare and execute an embedded array program. +-- +runN :: Afunction f => f -> AfunctionR f +runN f = go where !acc = convertAfunWith config f !afun = unsafePerformIO $ do D.dumpGraph $!! acc D.dumpSimplStats return acc - execute x = phase "execute" D.elapsed (evaluate (evalOpenAfun afun Empty x)) + !go = eval afun Empty + -- + eval :: DelayedOpenAfun aenv f -> Val aenv -> f + eval (Alam f) aenv = \a -> eval f (aenv `Push` a) + eval (Abody b) aenv = unsafePerformIO $ phase "execute" D.elapsed (evaluate (evalOpenAcc b aenv)) + -- -- | Stream a lazily read list of input arrays through the given program, -- -- collecting results as we go -- -- @@ -177,6 +190,9 @@ evalF :: DelayedFun aenv f -> f evalF fun = evalPreFun evalOpenAcc fun aenv + + evalB :: AST.PreBoundary DelayedOpenAcc aenv t -> Boundary t + evalB bnd = evalPreBoundary evalOpenAcc bnd aenv in case pacc of Avar ix -> prj ix aenv @@ -226,8 +242,8 @@ Scanr' f z acc -> scanr'Op (evalF f) (evalE z) (delayed acc) Scanr1 f acc -> scanr1Op (evalF f) (delayed acc) Permute f def p acc -> permuteOp (evalF f) (manifest def) (evalF p) (delayed acc) - Stencil sten b acc -> stencilOp (evalF sten) b (manifest acc) - Stencil2 sten b1 acc1 b2 acc2-> stencil2Op (evalF sten) b1 (manifest acc1) b2 (manifest acc2) + Stencil sten b acc -> stencilOp (evalF sten) (evalB b) (manifest acc) + Stencil2 sten b1 a1 b2 a2 -> stencil2Op (evalF sten) (evalB b1) (manifest a1) (evalB b2) (manifest a2) -- Array tuple construction and projection -- @@ -626,47 +642,240 @@ stencilOp :: (Stencil sh a stencil, Elt b) => (stencil -> b) - -> Boundary (EltRepr a) + -> Boundary (Array sh a) -> Array sh a -> Array sh b -stencilOp stencil boundary arr +stencilOp stencil bnd arr = fromFunction sh f where - f = stencil . stencilAccess bounded - sh = shape arr - -- - bounded ix = - case bound sh ix boundary of - Left v -> toElt v - Right ix' -> arr ! ix' + sh = shape arr + f = stencil . stencilAccess (bounded bnd arr) stencil2Op :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c) => (stencil1 -> stencil2 -> c) - -> Boundary (EltRepr a) + -> Boundary (Array sh a) -> Array sh a - -> Boundary (EltRepr b) + -> Boundary (Array sh b) -> Array sh b -> Array sh c -stencil2Op stencil boundary1 arr1 boundary2 arr2 +stencil2Op stencil bnd1 arr1 bnd2 arr2 = fromFunction (sh1 `intersect` sh2) f where - sh1 = shape arr1 - sh2 = shape arr2 - f ix = stencil (stencilAccess bounded1 ix) - (stencilAccess bounded2 ix) + sh1 = shape arr1 + sh2 = shape arr2 + f ix = stencil (stencilAccess (bounded bnd1 arr1) ix) + (stencilAccess (bounded bnd2 arr2) ix) - bounded1 ix = - case bound sh1 ix boundary1 of - Left v -> toElt v - Right ix' -> arr1 ! ix' +stencilAccess + :: Stencil sh e stencil + => (sh -> e) + -> sh + -> stencil +stencilAccess = goR stencil + where + -- Base cases, nothing interesting to do here since we know the lower + -- dimension is Z. + -- + goR :: StencilR sh e stencil -> (sh -> e) -> sh -> stencil + goR StencilRunit3 rf ix = + let + z :. i = ix + rf' d = rf (z :. i+d) + in + ( rf' (-1) + , rf' 0 + , rf' 1 + ) - bounded2 ix = - case bound sh2 ix boundary2 of - Left v -> toElt v - Right ix' -> arr2 ! ix' + goR StencilRunit5 rf ix = + let z :. i = ix + rf' d = rf (z :. i+d) + in + ( rf' (-2) + , rf' (-1) + , rf' 0 + , rf' 1 + , rf' 2 + ) + goR StencilRunit7 rf ix = + let z :. i = ix + rf' d = rf (z :. i+d) + in + ( rf' (-3) + , rf' (-2) + , rf' (-1) + , rf' 0 + , rf' 1 + , rf' 2 + , rf' 3 + ) + + goR StencilRunit9 rf ix = + let z :. i = ix + rf' d = rf (z :. i+d) + in + ( rf' (-4) + , rf' (-3) + , rf' (-2) + , rf' (-1) + , rf' 0 + , rf' 1 + , rf' 2 + , rf' 3 + , rf' 4 + ) + + -- Recursive cases. Note that because the stencil pattern is defined with + -- cons ordering, whereas shapes (and indices) are defined as a snoc-list, + -- when we recurse on the stencil structure we must manipulate the + -- _left-most_ index component. + -- + goR (StencilRtup3 s1 s2 s3) rf ix = + let (i, ix') = uncons ix + rf' d ds = rf (cons (i+d) ds) + in + ( goR s1 (rf' (-1)) ix' + , goR s2 (rf' 0) ix' + , goR s3 (rf' 1) ix' + ) + + goR (StencilRtup5 s1 s2 s3 s4 s5) rf ix = + let (i, ix') = uncons ix + rf' d ds = rf (cons (i+d) ds) + in + ( goR s1 (rf' (-2)) ix' + , goR s2 (rf' (-1)) ix' + , goR s3 (rf' 0) ix' + , goR s4 (rf' 1) ix' + , goR s5 (rf' 2) ix' + ) + + goR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) rf ix = + let (i, ix') = uncons ix + rf' d ds = rf (cons (i+d) ds) + in + ( goR s1 (rf' (-3)) ix' + , goR s2 (rf' (-2)) ix' + , goR s3 (rf' (-1)) ix' + , goR s4 (rf' 0) ix' + , goR s5 (rf' 1) ix' + , goR s6 (rf' 2) ix' + , goR s7 (rf' 3) ix' + ) + + goR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) rf ix = + let (i, ix') = uncons ix + rf' d ds = rf (cons (i+d) ds) + in + ( goR s1 (rf' (-4)) ix' + , goR s2 (rf' (-3)) ix' + , goR s3 (rf' (-2)) ix' + , goR s4 (rf' (-1)) ix' + , goR s5 (rf' 0) ix' + , goR s6 (rf' 1) ix' + , goR s7 (rf' 2) ix' + , goR s8 (rf' 3) ix' + , goR s9 (rf' 4) ix' + ) + + -- Add a left-most component to an index + -- + cons :: forall sh. Shape sh => Int -> sh -> (sh :. Int) + cons ix extent = toElt $ go (eltType (undefined::sh)) (fromElt extent) + where + go :: TupleType t -> t -> (t, Int) + go UnitTuple () = ((), ix) + go (PairTuple th tz) (sh, sz) + | SingleTuple t <- tz + , Just Refl <- matchScalarType t (scalarType :: ScalarType Int) + = (go th sh, sz) + go _ _ + = $internalError "cons" "expected index with Int components" + + -- Remove the left-most index of an index, and return the remainder + -- + uncons :: forall sh. Shape sh => sh :. Int -> (Int, sh) + uncons extent = let (i,ix) = go (eltType (undefined::(sh:.Int))) (fromElt extent) + in (i, toElt ix) + where + go :: TupleType (t, Int) -> (t, Int) -> (Int, t) + go (PairTuple UnitTuple _) ((), v) = (v, ()) + go (PairTuple t1@(PairTuple _ t2) _) (v1,v3) + | SingleTuple t <- t2 + , Just Refl <- matchScalarType t (scalarType :: ScalarType Int) + = let (i, v1') = go t1 v1 + in (i, (v1', v3)) + go _ _ + = $internalError "uncons" "expected index with Int components" + + +bounded + :: (Shape sh, Elt e) + => Boundary (Array sh e) + -> Array sh e + -> sh + -> e +bounded bnd arr ix = + if inside (shape arr) ix + then arr ! ix + else + case bnd of + Function f -> f ix + Constant v -> toElt v + _ -> arr ! bound (shape arr) ix + + where + -- Whether the index (second argument) is inside the bounds of the given + -- shape (first argument). + -- + inside :: forall sh. Shape sh => sh -> sh -> Bool + inside sh1 ix1 = go (eltType (undefined::sh)) (fromElt sh1) (fromElt ix1) + where + go :: TupleType t -> t -> t -> Bool + go UnitTuple () () = True + go (PairTuple tsh ti) (sh, sz) (ih,iz) + = if go ti sz iz + then go tsh sh ih + else False + go (SingleTuple t) sz iz + | Just Refl <- matchScalarType t (scalarType :: ScalarType Int) + = if iz < 0 || iz >= sz + then False + else True + -- + | otherwise + = $internalError "inside" "expected index with Int components" + + -- Return the index (second argument), updated to obey the given boundary + -- conditions when outside the bounds of the given shape (first argument) + -- + bound :: forall sh. Shape sh => sh -> sh -> sh + bound sh1 ix1 = toElt $ go (eltType (undefined::sh)) (fromElt sh1) (fromElt ix1) + where + go :: TupleType t -> t -> t -> t + go UnitTuple () () = () + go (PairTuple tsh ti) (sh, sz) (ih, iz) = (go tsh sh ih, go ti sz iz) + go (SingleTuple t) sz iz + | Just Refl <- matchScalarType t (scalarType :: ScalarType Int) + = let i | iz < 0 = case bnd of + Clamp -> 0 + Mirror -> -iz + Wrap -> sz + iz + _ -> $internalError "bound" "unexpected boundary condition" + | iz >= sz = case bnd of + Clamp -> sz - 1 + Mirror -> sz - (iz - sz + 2) + Wrap -> iz - sz + _ -> $internalError "bound" "unexpected boundary condition" + | otherwise = iz + in i + | otherwise + = $internalError "bound" "expected index with Int components" + + -- toSeqOp :: forall slix sl dim co e proxy. (Elt slix, Shape sl, Shape dim, Elt e) -- => SliceIndex (EltRepr slix) -- (EltRepr sl) @@ -678,6 +887,28 @@ -- toSeqOp sliceIndex _ arr = map (sliceOp sliceIndex arr :: slix -> Array sl e) -- (enumSlices sliceIndex (shape arr)) + +-- Stencil boundary conditions +-- --------------------------- + +data Boundary t where + Clamp :: Boundary t + Mirror :: Boundary t + Wrap :: Boundary t + Constant :: Elt t => EltRepr t -> Boundary (Array sh t) + Function :: (Shape sh, Elt e) => (sh -> e) -> Boundary (Array sh e) + + +evalPreBoundary :: EvalAcc acc -> AST.PreBoundary acc aenv t -> Val aenv -> Boundary t +evalPreBoundary evalAcc bnd aenv = + case bnd of + AST.Clamp -> Clamp + AST.Mirror -> Mirror + AST.Wrap -> Wrap + AST.Constant v -> Constant v + AST.Function f -> Function (evalPreFun evalAcc f aenv) + + -- Scalar expression evaluation -- ---------------------------- @@ -845,6 +1076,7 @@ evalPrim (PrimCeiling ta tb) = evalCeiling ta tb evalPrim (PrimAtan2 ty) = evalAtan2 ty evalPrim (PrimIsNaN ty) = evalIsNaN ty +evalPrim (PrimIsInfinite ty) = evalIsInfinite ty evalPrim (PrimLt ty) = evalLt ty evalPrim (PrimGt ty) = evalGt ty evalPrim (PrimLtEq ty) = evalLtEq ty @@ -1034,6 +1266,9 @@ evalIsNaN :: FloatingType a -> (a -> Bool) evalIsNaN ty | FloatingDict <- floatingDict ty = isNaN + +evalIsInfinite :: FloatingType a -> (a -> Bool) +evalIsInfinite ty | FloatingDict <- floatingDict ty = isInfinite -- Methods of Num diff --git a/Data/Array/Accelerate/Language.hs b/Data/Array/Accelerate/Language.hs --- a/Data/Array/Accelerate/Language.hs +++ b/Data/Array/Accelerate/Language.hs @@ -68,8 +68,10 @@ stencil, stencil2, -- ** Stencil specification - Boundary(..), Stencil, + Boundary, Stencil, + clamp, mirror, wrap, function, + -- ** Common stencil types Stencil3, Stencil5, Stencil7, Stencil9, Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5, @@ -106,14 +108,19 @@ ) where -- friends -import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, toIndex, fromIndex, intersect, union) -import Data.Array.Accelerate.Classes +import Data.Array.Accelerate.Array.Sugar hiding ( (!), ignore, shape, size, toIndex, fromIndex, intersect, union ) import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type -import qualified Data.Array.Accelerate.Array.Sugar as Sugar +import qualified Data.Array.Accelerate.Array.Sugar as Sugar +import Data.Array.Accelerate.Classes.Eq +import Data.Array.Accelerate.Classes.Fractional +import Data.Array.Accelerate.Classes.Integral +import Data.Array.Accelerate.Classes.Num +import Data.Array.Accelerate.Classes.Ord + -- standard libraries -import Prelude ( ($), (.) ) +import Prelude ( ($), (.) ) -- Array introduction @@ -279,7 +286,7 @@ -- -- > precondition: shapeSize sh == shapeSize sh' -- --- If the argument array is manifest in memory, 'reshape' is a NOP. If the +-- If the argument array is manifest in memory, 'reshape' is a no-op. If the -- argument is to be fused into a subsequent operation, 'reshape' corresponds to -- an index transformation in the fused code. -- @@ -293,9 +300,9 @@ -- Extraction of sub-arrays -- ------------------------ --- | Index an array with a /generalised/ array index, supplied as the --- second argument. The result is a new array (possibly a singleton) --- containing the selected dimensions (`All`s) in their entirety. +-- | Index an array with a /generalised/ array index, supplied as the second +-- argument. The result is a new array (possibly a singleton) containing the +-- selected dimensions ('All's) in their entirety. -- -- 'slice' is the opposite of 'replicate', and can be used to /cut out/ entire -- dimensions. For example, for the two dimensional array 'mat': @@ -362,10 +369,17 @@ -- Map-like functions -- ------------------ --- | Apply the given function element-wise to an array. +-- | Apply the given function element-wise to an array. Denotationally we have: -- -- > map f [x1, x2, ... xn] = [f x1, f x2, ... f xn] -- +-- >>> let xs = fromList (Z:.10) [0..] +-- >>> xs +-- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9] +-- +-- >>> map (+1) (use xs) +-- Vector (Z :. 10) [1,2,3,4,5,6,7,8,9,10] +-- map :: (Shape sh, Elt a, Elt b) => (Exp a -> Exp b) -> Acc (Array sh a) @@ -376,6 +390,28 @@ -- of the resulting array is the intersection of the extents of the two source -- arrays. -- +-- >>> let xs = fromList (Z:.3:.5) [0..] +-- >>> xs +-- Matrix (Z :. 3 :. 5) +-- [ 0, 1, 2, 3, 4, +-- 5, 6, 7, 8, 9, +-- 10,11,12,13,14] +-- +-- >>> let ys = fromList (Z:.5:.10) [1..] +-- >>> ys +-- Matrix (Z :. 5 :. 10) +-- [ 1, 2, 3, 4, 5, 6, 7, 8, 9,10, +-- 11,12,13,14,15,16,17,18,19,20, +-- 21,22,23,24,25,26,27,28,29,30, +-- 31,32,33,34,35,36,37,38,39,40, +-- 41,42,43,44,45,46,47,48,49,50] +-- +-- >>> zipWith (+) (use xs) (use ys) +-- Matrix (Z :. 3 :. 5) +-- [ 1, 3, 5, 7, 9, +-- 16,18,20,22,24, +-- 31,33,35,37,39] +-- zipWith :: (Shape sh, Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) -> Acc (Array sh a) @@ -558,8 +594,8 @@ => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Array (sh:.Int) a) - -> (Acc (Array (sh:.Int) a), Acc (Array sh a)) -scanl' = unatup2 . Acc $$$ Scanl' + -> Acc (Array (sh:.Int) a, Array sh a) +scanl' = Acc $$$ Scanl' -- | Data.List style left-to-right scan along the innermost dimension without an -- initial value (aka inclusive scan). The array must not be empty. The first @@ -567,7 +603,8 @@ -- -- > scanl1 f e arr = tail (scanl f e arr) -- --- >>> scanl (+) (use $ fromList (Z:.4:.10) [0..]) +-- >>> let mat = fromList (Z:.4:.10) [0..] +-- >>> scanl (+) (use mat) -- Matrix (Z :. 4 :. 10) -- [ 0, 1, 3, 6, 10, 15, 21, 28, 36, 45, -- 10, 21, 33, 46, 60, 75, 91, 108, 126, 145, @@ -595,8 +632,8 @@ => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Array (sh:.Int) a) - -> (Acc (Array (sh:.Int) a), Acc (Array sh a)) -scanr' = unatup2 . Acc $$$ Scanr' + -> Acc (Array (sh:.Int) a, Array sh a) +scanr' = Acc $$$ Scanr' -- | Right-to-left variant of 'scanl1'. -- @@ -620,6 +657,9 @@ -- that are mapped to the magic value 'ignore' by the permutation function are -- dropped. -- +-- The combination function is given the new value being permuted as its first +-- argument, and the current value of the array as its second. +-- -- For example, we can use 'permute' to compute the occurrence count (histogram) -- for an array of values in the range @[0,10)@: -- @@ -634,6 +674,25 @@ -- >>> histogram (use xs) -- Vector (Z :. 10) [2,4,4,3,2,2,0,0,2,1] -- +-- As a second example, note that the dimensionality of the source and +-- destination arrays can differ. In this way, we can use 'permute' to create an +-- identity matrix by overwriting elements along the diagonal: +-- +-- > identity :: Num a => Exp Int -> Acc (Array DIM2 a) +-- > identity n = +-- > let zeros = fill (index2 n n) 0 +-- > ones = fill (index1 n) 1 +-- > in +-- > permute const zeros (\(unindex1 -> i) -> index2 i i) ones +-- +-- >>> identity 5 +-- Matrix (Z :. 5 :. 5) +-- [1,0,0,0,0, +-- 0,1,0,0,0, +-- 0,0,1,0,0, +-- 0,0,0,1,0, +-- 0,0,0,0,1] +-- -- [/Note:/] -- -- Regarding array fusion: @@ -647,6 +706,9 @@ -- -- 3. The array of source values can fuse into the permutation operation. -- +-- 4. If the array of default values is only used once, it will be updated +-- in-place. +-- permute :: (Shape sh, Shape sh', Elt a) => (Exp a -> Exp a -> Exp a) -- ^ combination function @@ -756,8 +818,8 @@ -- -- > s33 :: Stencil3x3 a -> Exp a -- > s33 ((_,t,_) --- ,(l,c,r) --- ,(_,b,_)) = ... +-- > ,(l,c,r) +-- > ,(_,b,_)) = ... -- -- ...where @c@ is again the focal point and @t@, @b@, @l@ and @r@ are the -- elements to the top, bottom, left, and right of the focal point, respectively @@ -781,16 +843,16 @@ -- > gaussian = [0.06136,0.24477,0.38774,0.24477,0.06136] -- > -- > blur :: Num a => Acc (Array DIM2 a) -> Acc (Array DIM2 a) --- > blur = stencil (convolve5x1 gaussian) Clamp --- > . stencil (convolve1x5 gaussian) Clamp +-- > blur = stencil (convolve5x1 gaussian) clamp +-- > . stencil (convolve1x5 gaussian) clamp -- stencil :: (Stencil sh a stencil, Elt b) => (stencil -> Exp b) -- ^ stencil function - -> Boundary a -- ^ boundary condition + -> Boundary (Array sh a) -- ^ boundary condition -> Acc (Array sh a) -- ^ source array -> Acc (Array sh b) -- ^ destination array -stencil = Acc $$$ Stencil +stencil f (Boundary b) a = Acc $ Stencil f b a -- | Map a binary stencil of an array. The extent of the resulting array is the -- intersection of the extents of the two source arrays. This is the stencil @@ -799,14 +861,70 @@ stencil2 :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c) => (stencil1 -> stencil2 -> Exp c) -- ^ binary stencil function - -> Boundary a -- ^ boundary condition #1 + -> Boundary (Array sh a) -- ^ boundary condition #1 -> Acc (Array sh a) -- ^ source array #1 - -> Boundary b -- ^ boundary condition #2 + -> Boundary (Array sh b) -- ^ boundary condition #2 -> Acc (Array sh b) -- ^ source array #2 -> Acc (Array sh c) -- ^ destination array -stencil2 = Acc $$$$$ Stencil2 +stencil2 f (Boundary b1) a1 (Boundary b2) a2 = Acc $ Stencil2 f b1 a1 b2 a2 +-- | Boundary condition where elements of the stencil which would be +-- out-of-bounds are instead clamped to the edges of the array. +-- +-- In the following 3x3 stencil, the out-of-bounds element @b@ will instead +-- return the value at position @c@: +-- +-- > +------------+ +-- > |a | +-- > b|cd | +-- > |e | +-- > +------------+ +-- +clamp :: Boundary (Array sh e) +clamp = Boundary Clamp +-- | Stencil boundary condition where coordinates beyond the array extent are +-- instead mirrored +-- +-- In the following 5x3 stencil, the out-of-bounds element @c@ will instead +-- return the value at position @d@, and similarly the element at @b@ will +-- return the value at @e@: +-- +-- > +------------+ +-- > |a | +-- > bc|def | +-- > |g | +-- > +------------+ +-- +mirror :: Boundary (Array sh e) +mirror = Boundary Mirror + +-- | Stencil boundary condition where coordinates beyond the array extent +-- instead wrap around the array. +-- +-- In the following 3x3 stencil, the out of bounds elements will be read as in +-- the pattern on the right. +-- +-- > a bc +-- > +------------+ +------------+ +-- > d|ef | |ef d| +-- > g|hi | -> |hi g| +-- > | | |bc a| +-- > +------------+ +------------+ +-- +wrap :: Boundary (Array sh e) +wrap = Boundary Wrap + +-- | Stencil boundary condition where the given function is applied to any +-- outlying coordinates. +-- +function + :: (Shape sh, Elt e) + => (Exp sh -> Exp e) + -> Boundary (Array sh e) +function = Boundary . Function + + {-- -- Sequence operations -- ------------------ @@ -923,7 +1041,7 @@ -- In case the operation is being executed on a backend which does not support -- this foreign implementation, the fallback implementation is used instead, -- which itself could be a foreign implementation for a (presumably) different --- backend, or an implementation of pure Accelerate. In this way, multiple +-- backend, or an implementation in pure Accelerate. In this way, multiple -- foreign implementations can be supplied, and will be tested for suitability -- against the target backend in sequence. -- @@ -968,6 +1086,9 @@ -- > (acc1 >-> acc2) arrs = let tmp = acc1 arrs -- > in tmp `seq` acc2 tmp -- +-- For an example use of this operation see the 'Data.Array.Accelerate.compute' +-- function. +-- infixl 1 >-> (>->) :: (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b) -> (Acc b -> Acc c) -> (Acc a -> Acc c) (>->) = Acc $$$ Pipe @@ -978,6 +1099,9 @@ -- | An array-level if-then-else construct. -- +-- Enabling the @RebindableSyntax@ extension will allow you to use the standard +-- if-then-else syntax instead. +-- acond :: Arrays a => Exp Bool -- ^ if-condition -> Acc a -- ^ then-array @@ -1000,8 +1124,16 @@ -- Shapes and indices -- ------------------ --- | Get the innermost dimension of a shape +-- | Get the innermost dimension of a shape. -- +-- The innermost dimension (right-most component of the shape) is the index of +-- the array which varies most rapidly, and corresponds to elements of the array +-- which are adjacent in memory. +-- +-- Another way to think of this is, for example when writing nested loops over +-- an array in C, this index corresponds to the index iterated over by the +-- innermost nested loop. +-- indexHead :: (Slice sh, Elt a) => Exp (sh :. a) -> Exp a indexHead = Exp . IndexHead @@ -1040,6 +1172,9 @@ -- ------------ -- | A scalar-level if-then-else construct. +-- +-- Enabling the @RebindableSyntax@ extension will allow you to use the standard +-- if-then-else syntax instead. -- cond :: Elt t => Exp Bool -- ^ condition diff --git a/Data/Array/Accelerate/Lifetime.hs b/Data/Array/Accelerate/Lifetime.hs --- a/Data/Array/Accelerate/Lifetime.hs +++ b/Data/Array/Accelerate/Lifetime.hs @@ -61,6 +61,7 @@ -- | Construct a new 'Lifetime' from the given value. -- +{-# INLINE newLifetime #-} newLifetime :: a -> IO (Lifetime a) newLifetime a = do ref <- newIORef [] @@ -72,6 +73,7 @@ -- throughout its execution. It is important to not let the value /leak/ outside -- the function, either by returning it or by lazy IO. -- +{-# INLINE withLifetime #-} withLifetime :: Lifetime a -> (a -> IO b) -> IO b withLifetime (Lifetime ref _ a) f = do r <- f a @@ -81,6 +83,7 @@ -- | Ensure that the lifetime is alive at the given place in a sequence of IO -- actions. Does not force the payload. -- +{-# INLINE touchLifetime #-} touchLifetime :: Lifetime a -> IO () touchLifetime (Lifetime ref _ _) = touchIORef ref @@ -138,6 +141,7 @@ -- 'Lifetime' is still reachable, the finalizers may fire, potentially -- invalidating the value. -- +{-# INLINE unsafeGetValue #-} unsafeGetValue :: Lifetime a -> a unsafeGetValue (Lifetime _ _ a) = a @@ -151,6 +155,7 @@ -- Touch an 'IORef', ensuring that it is alive at this point in a sequence of IO -- actions. -- +{-# INLINE touchIORef #-} touchIORef :: IORef a -> IO () touchIORef r = IO $ \s -> case touch# r s of s' -> (# s', () #) diff --git a/Data/Array/Accelerate/Prelude.hs b/Data/Array/Accelerate/Prelude.hs --- a/Data/Array/Accelerate/Prelude.hs +++ b/Data/Array/Accelerate/Prelude.hs @@ -112,17 +112,21 @@ import Data.Typeable ( gcast ) import GHC.Base ( Constraint ) import Prelude ( (.), ($), Maybe(..), const, id, fromInteger, flip, undefined, fail ) -import qualified Prelude as P -- friends import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Sugar hiding ( (!), ignore, shape, size, intersect, toIndex, fromIndex ) -import Data.Array.Accelerate.Classes import Data.Array.Accelerate.Language import Data.Array.Accelerate.Lift import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Classes.Eq +import Data.Array.Accelerate.Classes.FromIntegral +import Data.Array.Accelerate.Classes.Integral +import Data.Array.Accelerate.Classes.Num +import Data.Array.Accelerate.Classes.Ord + import Data.Array.Accelerate.Data.Bits @@ -131,6 +135,17 @@ -- | Pair each element with its index -- +-- >>> let xs = fromList (Z:.5) [0..] +-- >>> indexed (use xs) +-- Vector (Z :. 5) [(Z :. 0,0.0),(Z :. 1,1.0),(Z :. 2,2.0),(Z :. 3,3.0),(Z :. 4,4.0)] +-- +-- >>> let mat = fromList (Z:.3:.4) [0..] +-- >>> indexed (use mat) +-- Matrix (Z :. 3 :. 4) +-- [(Z :. 0 :. 0,0.0),(Z :. 0 :. 1,1.0), (Z :. 0 :. 2,2.0), (Z :. 0 :. 3,3.0), +-- (Z :. 1 :. 0,4.0),(Z :. 1 :. 1,5.0), (Z :. 1 :. 2,6.0), (Z :. 1 :. 3,7.0), +-- (Z :. 2 :. 0,8.0),(Z :. 2 :. 1,9.0),(Z :. 2 :. 2,10.0),(Z :. 2 :. 3,11.0)] +-- indexed :: (Shape sh, Elt a) => Acc (Array sh a) -> Acc (Array sh (sh, a)) indexed xs = zip (generate (shape xs) id) xs @@ -145,25 +160,27 @@ -- | Zip three arrays with the given function, analogous to 'zipWith'. -- -zipWith3 :: (Shape sh, Elt a, Elt b, Elt c, Elt d) - => (Exp a -> Exp b -> Exp c -> Exp d) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) +zipWith3 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d) + => (Exp a -> Exp b -> Exp c -> Exp d) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) zipWith3 f as bs cs = generate (shape as `intersect` shape bs `intersect` shape cs) (\ix -> f (as ! ix) (bs ! ix) (cs ! ix)) -- | Zip four arrays with the given function, analogous to 'zipWith'. -- -zipWith4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e) - => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) +zipWith4 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e) + => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) zipWith4 f as bs cs ds = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds) @@ -171,14 +188,15 @@ -- | Zip five arrays with the given function, analogous to 'zipWith'. -- -zipWith5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) - => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) +zipWith5 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) + => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) zipWith5 f as bs cs ds es = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es) @@ -186,15 +204,16 @@ -- | Zip six arrays with the given function, analogous to 'zipWith'. -- -zipWith6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) - => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) - -> Acc (Array sh g) +zipWith6 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) + => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) + -> Acc (Array sh g) zipWith6 f as bs cs ds es fs = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es @@ -203,16 +222,17 @@ -- | Zip seven arrays with the given function, analogous to 'zipWith'. -- -zipWith7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) - => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) - -> Acc (Array sh g) - -> Acc (Array sh h) +zipWith7 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) + => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) + -> Acc (Array sh g) + -> Acc (Array sh h) zipWith7 f as bs cs ds es fs gs = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es @@ -221,17 +241,18 @@ -- | Zip eight arrays with the given function, analogous to 'zipWith'. -- -zipWith8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) - => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) - -> Acc (Array sh g) - -> Acc (Array sh h) - -> Acc (Array sh i) +zipWith8 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) + => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) + -> Acc (Array sh g) + -> Acc (Array sh h) + -> Acc (Array sh i) zipWith8 f as bs cs ds es fs gs hs = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es @@ -241,18 +262,19 @@ -- | Zip nine arrays with the given function, analogous to 'zipWith'. -- -zipWith9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j) - => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) - -> Acc (Array sh g) - -> Acc (Array sh h) - -> Acc (Array sh i) - -> Acc (Array sh j) +zipWith9 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j) + => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) + -> Acc (Array sh g) + -> Acc (Array sh h) + -> Acc (Array sh i) + -> Acc (Array sh j) zipWith9 f as bs cs ds es fs gs hs is = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es @@ -263,11 +285,12 @@ -- | Zip two arrays with a function that also takes the element index -- -izipWith :: (Shape sh, Elt a, Elt b, Elt c) - => (Exp sh -> Exp a -> Exp b -> Exp c) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) +izipWith + :: (Shape sh, Elt a, Elt b, Elt c) + => (Exp sh -> Exp a -> Exp b -> Exp c) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) izipWith f as bs = generate (shape as `intersect` shape bs) (\ix -> f ix (as ! ix) (bs ! ix)) @@ -275,12 +298,13 @@ -- | Zip three arrays with a function that also takes the element index, -- analogous to 'izipWith'. -- -izipWith3 :: (Shape sh, Elt a, Elt b, Elt c, Elt d) - => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) +izipWith3 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d) + => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) izipWith3 f as bs cs = generate (shape as `intersect` shape bs `intersect` shape cs) (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix)) @@ -288,13 +312,14 @@ -- | Zip four arrays with the given function that also takes the element index, -- analogous to 'zipWith'. -- -izipWith4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e) - => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) +izipWith4 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e) + => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) izipWith4 f as bs cs ds = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds) @@ -303,14 +328,15 @@ -- | Zip five arrays with the given function that also takes the element index, -- analogous to 'zipWith'. -- -izipWith5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) - => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) +izipWith5 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) + => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) izipWith5 f as bs cs ds es = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es) @@ -319,15 +345,16 @@ -- | Zip six arrays with the given function that also takes the element index, -- analogous to 'zipWith'. -- -izipWith6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) - => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) - -> Acc (Array sh g) +izipWith6 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) + => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) + -> Acc (Array sh g) izipWith6 f as bs cs ds es fs = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es @@ -337,16 +364,17 @@ -- | Zip seven arrays with the given function that also takes the element -- index, analogous to 'zipWith'. -- -izipWith7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) - => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) - -> Acc (Array sh g) - -> Acc (Array sh h) +izipWith7 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) + => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) + -> Acc (Array sh g) + -> Acc (Array sh h) izipWith7 f as bs cs ds es fs gs = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es @@ -356,17 +384,18 @@ -- | Zip eight arrays with the given function that also takes the element -- index, analogous to 'zipWith'. -- -izipWith8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) - => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) - -> Acc (Array sh g) - -> Acc (Array sh h) - -> Acc (Array sh i) +izipWith8 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) + => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) + -> Acc (Array sh g) + -> Acc (Array sh h) + -> Acc (Array sh i) izipWith8 f as bs cs ds es fs gs hs = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es @@ -377,18 +406,19 @@ -- | Zip nine arrays with the given function that also takes the element index, -- analogous to 'zipWith'. -- -izipWith9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j) - => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j) - -> Acc (Array sh a) - -> Acc (Array sh b) - -> Acc (Array sh c) - -> Acc (Array sh d) - -> Acc (Array sh e) - -> Acc (Array sh f) - -> Acc (Array sh g) - -> Acc (Array sh h) - -> Acc (Array sh i) - -> Acc (Array sh j) +izipWith9 + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j) + => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> Acc (Array sh c) + -> Acc (Array sh d) + -> Acc (Array sh e) + -> Acc (Array sh f) + -> Acc (Array sh g) + -> Acc (Array sh h) + -> Acc (Array sh i) + -> Acc (Array sh j) izipWith9 f as bs cs ds es fs gs hs is = generate (shape as `intersect` shape bs `intersect` shape cs `intersect` shape ds `intersect` shape es @@ -494,14 +524,14 @@ -- | The converse of 'zip', but the shape of the two results is identical to the -- shape of the argument. -- --- If the argument array is manifest in memory, 'unzip' is a NOP. +-- If the argument array is manifest in memory, 'unzip' is a no-op. -- unzip :: (Shape sh, Elt a, Elt b) => Acc (Array sh (a, b)) -> (Acc (Array sh a), Acc (Array sh b)) unzip arr = (map fst arr, map snd arr) --- | Take an array of triples and return three arrays, analogous to unzip. +-- | Take an array of triples and return three arrays, analogous to 'unzip'. -- unzip3 :: (Shape sh, Elt a, Elt b, Elt c) => Acc (Array sh (a, b, c)) @@ -513,7 +543,7 @@ get3 x = let (_,_,c) = untup3 x in c --- | Take an array of quadruples and return four arrays, analogous to unzip. +-- | Take an array of quadruples and return four arrays, analogous to 'unzip'. -- unzip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d) => Acc (Array sh (a, b, c, d)) @@ -525,7 +555,7 @@ get3 x = let (_,_,c,_) = untup4 x in c get4 x = let (_,_,_,d) = untup4 x in d --- | Take an array of 5-tuples and return five arrays, analogous to unzip. +-- | Take an array of 5-tuples and return five arrays, analogous to 'unzip'. -- unzip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e) => Acc (Array sh (a, b, c, d, e)) @@ -538,7 +568,7 @@ get4 x = let (_,_,_,d,_) = untup5 x in d get5 x = let (_,_,_,_,e) = untup5 x in e --- | Take an array of 6-tuples and return six arrays, analogous to unzip. +-- | Take an array of 6-tuples and return six arrays, analogous to 'unzip'. -- unzip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) => Acc (Array sh (a, b, c, d, e, f)) @@ -553,7 +583,7 @@ get5 x = let (_,_,_,_,e,_) = untup6 x in e get6 x = let (_,_,_,_,_,f) = untup6 x in f --- | Take an array of 7-tuples and return seven arrays, analogous to unzip. +-- | Take an array of 7-tuples and return seven arrays, analogous to 'unzip'. -- unzip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) => Acc (Array sh (a, b, c, d, e, f, g)) @@ -572,7 +602,7 @@ get6 x = let (_,_,_,_,_,f,_) = untup7 x in f get7 x = let (_,_,_,_,_,_,g) = untup7 x in g --- | Take an array of 8-tuples and return eight arrays, analogous to unzip. +-- | Take an array of 8-tuples and return eight arrays, analogous to 'unzip'. -- unzip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) => Acc (Array sh (a, b, c, d, e, f, g, h)) @@ -592,7 +622,7 @@ get7 x = let (_,_,_,_,_,_,g,_) = untup8 x in g get8 x = let (_,_,_,_,_,_,_,h) = untup8 x in h --- | Take an array of 8-tuples and return eight arrays, analogous to unzip. +-- | Take an array of 8-tuples and return eight arrays, analogous to 'unzip'. -- unzip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) => Acc (Array sh (a, b, c, d, e, f, g, h, i)) @@ -629,21 +659,23 @@ -- >>> foldAll (+) 0 (use mat) -- Scalar Z [1225] -- -foldAll :: (Shape sh, Elt a) - => (Exp a -> Exp a -> Exp a) - -> Exp a - -> Acc (Array sh a) - -> Acc (Scalar a) +foldAll + :: (Shape sh, Elt a) + => (Exp a -> Exp a -> Exp a) + -> Exp a + -> Acc (Array sh a) + -> Acc (Scalar a) foldAll f e arr = fold f e (flatten arr) -- | Variant of 'foldAll' that requires the reduced array to be non-empty and --- doesn't need an default value. The first argument must be an /associative/ +-- does not need a default value. The first argument must be an /associative/ -- function. -- -fold1All :: (Shape sh, Elt a) - => (Exp a -> Exp a -> Exp a) - -> Acc (Array sh a) - -> Acc (Scalar a) +fold1All + :: (Shape sh, Elt a) + => (Exp a -> Exp a -> Exp a) + -> Acc (Array sh a) + -> Acc (Scalar a) fold1All f arr = fold1 f (flatten arr) @@ -653,121 +685,185 @@ -- Leave the results of these as scalar arrays to make it clear that these are -- array computations, and thus can not be nested. --- | Check if all elements satisfy a predicate +-- | Check if all elements along the innermost dimension satisfy a predicate. -- +-- >>> let mat = fromList (Z :. 4 :. 10) [1,2,3,4,5,6,7,8,9,10,1,1,1,1,1,2,2,2,2,2,2,4,6,8,10,12,14,16,18,20,1,3,5,7,9,11,13,15,17,19] :: Array DIM2 Int +-- >>> mat +-- Matrix (Z :. 4 :. 10) +-- [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, +-- 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, +-- 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, +-- 1, 3, 5, 7, 9, 11, 13, 15, 17, 19] +-- +-- >>> all even (use mat) +-- Vector (Z :. 4) [False,False,True,False] +-- all :: (Shape sh, Elt e) => (Exp e -> Exp Bool) - -> Acc (Array sh e) - -> Acc (Scalar Bool) + -> Acc (Array (sh:.Int) e) + -> Acc (Array sh Bool) all f = and . map f --- | Check if any element satisfies the predicate +-- | Check if any element along the innermost dimension satisfies the predicate. -- +-- >>> let mat = fromList (Z :. 4 :. 10) [1,2,3,4,5,6,7,8,9,10,1,1,1,1,1,2,2,2,2,2,2,4,6,8,10,12,14,16,18,20,1,3,5,7,9,11,13,15,17,19] :: Array DIM2 Int +-- >>> mat +-- Matrix (Z :. 4 :. 10) +-- [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, +-- 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, +-- 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, +-- 1, 3, 5, 7, 9, 11, 13, 15, 17, 19] +-- +-- >>> any even (use mat) +-- Vector (Z :. 4) [True,True,True,False] +-- any :: (Shape sh, Elt e) => (Exp e -> Exp Bool) - -> Acc (Array sh e) - -> Acc (Scalar Bool) + -> Acc (Array (sh:.Int) e) + -> Acc (Array sh Bool) any f = or . map f --- | Check if all elements are 'True' +-- | Check if all elements along the innermost dimension are 'True'. -- and :: Shape sh - => Acc (Array sh Bool) - -> Acc (Scalar Bool) -and = foldAll (&&) (constant True) + => Acc (Array (sh:.Int) Bool) + -> Acc (Array sh Bool) +and = fold (&&) (constant True) --- | Check if any element is 'True' +-- | Check if any element along the innermost dimension is 'True'. -- or :: Shape sh - => Acc (Array sh Bool) - -> Acc (Scalar Bool) -or = foldAll (||) (constant False) + => Acc (Array (sh:.Int) Bool) + -> Acc (Array sh Bool) +or = fold (||) (constant False) --- | Compute the sum of elements +-- | Compute the sum of elements along the innermost dimension of the array. To +-- find the sum of the entire array, 'flatten' it first. -- +-- >>> let mat = fromList (Z:.2:.5) [0..] +-- Vector (Z :. 2) [10,35] +-- sum :: (Shape sh, Num e) - => Acc (Array sh e) - -> Acc (Scalar e) -sum = foldAll (+) 0 + => Acc (Array (sh:.Int) e) + -> Acc (Array sh e) +sum = fold (+) 0 --- | Compute the product of the elements +-- | Compute the product of the elements along the innermost dimension of the +-- array. To find the product of the entire array, 'flatten' it first. -- -product :: (Shape sh, Num e) - => Acc (Array sh e) - -> Acc (Scalar e) -product = foldAll (*) 1 +-- >>> let mat = fromList (Z:.2:.5) [0..] +-- Vector (Z :. 2) [0,15120] +-- +product + :: (Shape sh, Num e) + => Acc (Array (sh:.Int) e) + -> Acc (Array sh e) +product = fold (*) 1 --- | Yield the minimum element of an array. The array must not be empty. +-- | Yield the minimum element along the innermost dimension of the array. To +-- find find the minimum element of the entire array, 'flatten' it first. -- -minimum :: (Shape sh, Ord e) - => Acc (Array sh e) - -> Acc (Scalar e) -minimum = fold1All min +-- The array must not be empty. See also 'fold1'. +-- +-- >>> let mat = fromList (Z :. 3 :. 4) [1,4,3,8, 0,2,8,4, 7,9,8,8] +-- >>> mat +-- Matrix (Z :. 3 :. 4) +-- [ 1, 4, 3, 8, +-- 0, 2, 8, 4, +-- 7, 9, 8, 8] +-- +-- >>> minimum (use mat) +-- Vector (Z :. 3) [1,0,7] +-- +minimum + :: (Shape sh, Ord e) + => Acc (Array (sh:.Int) e) + -> Acc (Array sh e) +minimum = fold1 min --- | Yield the maximum element of an array. The array must not be empty. +-- | Yield the maximum element along the innermost dimension of the array. To +-- find the maximum element of the entire array, 'flatten' it first. -- -maximum :: (Shape sh, Ord e) - => Acc (Array sh e) - -> Acc (Scalar e) -maximum = fold1All max +-- The array must not be empty. See also 'fold1'. +-- +-- >>> let mat = fromList (Z :. 3 :. 4) [1,4,3,8, 0,2,8,4, 7,9,8,8] +-- >>> mat +-- Matrix (Z :. 3 :. 4) +-- [ 1, 4, 3, 8, +-- 0, 2, 8, 4, +-- 7, 9, 8, 8] +-- +-- >>> maximum (use mat) +-- Vector (Z :. 3) [8,8,9] +-- +maximum + :: (Shape sh, Ord e) + => Acc (Array (sh:.Int) e) + -> Acc (Array sh e) +maximum = fold1 max -- Composite scans -- --------------- --- | Left-to-right prescan (aka exclusive scan). As for 'scan', the first --- argument must be an /associative/ function. Denotationally, we have +-- | Left-to-right pre-scan (aka exclusive scan). As for 'scan', the first +-- argument must be an /associative/ function. Denotationally, we have: -- --- > prescanl f e = Prelude.fst . scanl' f e +-- > prescanl f e = afst . scanl' f e -- -- >>> let vec = fromList (Z:.10) [1..10] -- >>> prescanl (+) 0 (use vec) --- Vector (Z :. 10) [0,0,1,3,6,10,15,21,28,36] +-- Vector (Z :. 10) [0,1,3,6,10,15,21,28,36,45] -- -prescanl :: (Shape sh, Elt a) - => (Exp a -> Exp a -> Exp a) - -> Exp a - -> Acc (Array (sh:.Int) a) - -> Acc (Array (sh:.Int) a) -prescanl f e = P.fst . scanl' f e +prescanl + :: (Shape sh, Elt a) + => (Exp a -> Exp a -> Exp a) + -> Exp a + -> Acc (Array (sh:.Int) a) + -> Acc (Array (sh:.Int) a) +prescanl f e = afst . scanl' f e --- | Left-to-right postscan, a variant of 'scanl1' with an initial value. As +-- | Left-to-right post-scan, a variant of 'scanl1' with an initial value. As -- with 'scanl1', the array must not be empty. Denotationally, we have: -- -- > postscanl f e = map (e `f`) . scanl1 f -- -- >>> let vec = fromList (Z:.10) [1..10] -- >>> postscanl (+) 42 (use vec) --- Vector (Z :. 10) [42,43,45,48,52,57,63,70,78,87] +-- Vector (Z :. 10) [43,45,48,52,57,63,70,78,87,97] -- -postscanl :: (Shape sh, Elt a) - => (Exp a -> Exp a -> Exp a) - -> Exp a - -> Acc (Array (sh:.Int) a) - -> Acc (Array (sh:.Int) a) +postscanl + :: (Shape sh, Elt a) + => (Exp a -> Exp a -> Exp a) + -> Exp a + -> Acc (Array (sh:.Int) a) + -> Acc (Array (sh:.Int) a) postscanl f e = map (e `f`) . scanl1 f --- |Right-to-left prescan (aka exclusive scan). As for 'scan', the first argument must be an --- /associative/ function. Denotationally, we have +-- | Right-to-left pre-scan (aka exclusive scan). As for 'scan', the first +-- argument must be an /associative/ function. Denotationally, we have: -- --- > prescanr f e = Prelude.fst . scanr' f e +-- > prescanr f e = afst . scanr' f e -- -prescanr :: (Shape sh, Elt a) - => (Exp a -> Exp a -> Exp a) - -> Exp a - -> Acc (Array (sh:.Int) a) - -> Acc (Array (sh:.Int) a) -prescanr f e = P.fst . scanr' f e +prescanr + :: (Shape sh, Elt a) + => (Exp a -> Exp a -> Exp a) + -> Exp a + -> Acc (Array (sh:.Int) a) + -> Acc (Array (sh:.Int) a) +prescanr f e = afst . scanr' f e --- |Right-to-left postscan, a variant of 'scanr1' with an initial value. Denotationally, we have +-- | Right-to-left postscan, a variant of 'scanr1' with an initial value. +-- Denotationally, we have: -- -- > postscanr f e = map (e `f`) . scanr1 f -- -postscanr :: (Shape sh, Elt a) - => (Exp a -> Exp a -> Exp a) - -> Exp a - -> Acc (Array (sh:.Int) a) - -> Acc (Array (sh:.Int) a) +postscanr + :: (Shape sh, Elt a) + => (Exp a -> Exp a -> Exp a) + -> Exp a + -> Acc (Array (sh:.Int) a) + -> Acc (Array (sh:.Int) a) postscanr f e = map (`f` e) . scanr1 f @@ -901,7 +997,7 @@ -- index of each segment. -- seg' = map (+1) seg - tails = zipWith (+) seg . P.fst $ scanl' (+) 0 seg' + tails = zipWith (+) seg $ prescanl (+) 0 seg' sums = backpermute (lift (indexTail (shape arr') :. length seg)) (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int @@ -969,8 +1065,7 @@ -> Acc (Segments i) -> Acc (Array (sh:.Int) e) scanl1Seg f arr seg - = P.snd - . unzip + = map snd . scanl1 (segmented f) $ zip (replicate (lift (indexTail (shape arr) :. All)) (mkHeadFlags seg)) arr @@ -1103,7 +1198,7 @@ -- reduction values seg' = map (+1) seg - heads = P.fst $ scanl' (+) 0 seg' + heads = prescanl (+) 0 seg' sums = backpermute (lift (indexTail (shape arr') :. length seg)) (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int @@ -1150,8 +1245,7 @@ -> Acc (Segments i) -> Acc (Array (sh:.Int) e) scanr1Seg f arr seg - = P.snd - . unzip + = map snd . scanr1 (flip (segmented f)) $ zip (replicate (lift (indexTail (shape arr) :. All)) (mkTailFlags seg)) arr @@ -1201,7 +1295,7 @@ = init $ permute (+) zeros (\ix -> index1' (offset ! ix)) ones where - (offset, len) = scanl' (+) 0 seg + (offset, len) = unlift (scanl' (+) 0 seg) zeros = fill (index1' $ the len + 1) 0 ones = fill (index1 $ size offset) 1 @@ -1216,7 +1310,7 @@ = init $ permute (+) zeros (\ix -> index1' (the len - 1 - offset ! ix)) ones where - (offset, len) = scanr' (+) 0 seg + (offset, len) = unlift (scanr' (+) 0 seg) zeros = fill (index1' $ the len + 1) 0 ones = fill (index1 $ size offset) 1 @@ -1262,7 +1356,7 @@ | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM1) = a flatten a - = reshape (index1 $ size a) a + = reshape (index1 (size a)) a -- Enumeration and filling @@ -1270,6 +1364,9 @@ -- | Create an array where all elements are the same value. -- +-- >>> let zeros = fill (Z:.10) 0 +-- Vector (Z :. 10) [0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0] +-- fill :: (Shape sh, Elt e) => Exp sh -> Exp e -> Acc (Array sh e) fill sh c = generate sh (const c) @@ -1402,7 +1499,7 @@ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) = let keep = map p arr - (target, len) = scanl' (+) 0 (map boolToInt keep) + (target, len) = unlift $ scanl' (+) 0 (map boolToInt keep) prj ix = keep!ix ? ( index1 (target!ix), ignore ) dummy = backpermute (index1 (the len)) id arr result = permute const dummy prj arr @@ -1415,8 +1512,8 @@ = let sz = indexTail (shape arr) keep = map p arr - (target, len) = scanl' (+) 0 (map boolToInt keep) - (offset, valid) = scanl' (+) 0 (flatten len) + (target, len) = unlift $ scanl' (+) 0 (map boolToInt keep) + (offset, valid) = unlift $ scanl' (+) 0 (flatten len) prj ix = if keep!ix then index1 $ offset!index1 (toIndex sz (indexTail ix)) + target!ix else ignore @@ -1759,7 +1856,8 @@ -- | Infix version of 'acond'. If the predicate evaluates to 'True', the first -- component of the tuple is returned, else the second. -- --- See also: 'ifThenElse'. +-- Enabling the @RebindableSyntax@ extension will allow you to use the standard +-- if-then-else syntax instead. -- infix 0 ?| (?|) :: Arrays a => Exp Bool -> (Acc a, Acc a) -> Acc a @@ -1768,7 +1866,8 @@ -- | An infix version of 'cond'. If the predicate evaluates to 'True', the first -- component of the tuple is returned, else the second. -- --- See also: 'ifThenElse'. +-- Enabling the @RebindableSyntax@ extension will allow you to use the standard +-- if-then-else syntax instead. -- infix 0 ? (?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t @@ -1806,11 +1905,12 @@ -- | Repeatedly apply a function a fixed number of times -- -iterate :: forall a. Elt a - => Exp Int - -> (Exp a -> Exp a) - -> Exp a - -> Exp a +iterate + :: forall a. Elt a + => Exp Int + -> (Exp a -> Exp a) + -> Exp a + -> Exp a iterate n f z = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a) step (i, acc) = ( i+1, f acc ) @@ -1847,6 +1947,7 @@ fst e = let (x, _::Exp b) = unlift e in x -- |Extract the first component of an array pair. +{-# NOINLINE[1] afst #-} afst :: forall a b. (Arrays a, Arrays b) => Acc (a, b) -> Acc a afst a = let (x, _::Acc b) = unlift a in x @@ -1873,34 +1974,36 @@ -- Shapes and indices -- ------------------ --- |The one index for a rank-0 array. +-- | The one index for a rank-0 array. -- index0 :: Exp Z index0 = lift Z --- |Turn an 'Int' expression into a rank-1 indexing expression. +-- | Turn an 'Int' expression into a rank-1 indexing expression. -- index1 :: Elt i => Exp i -> Exp (Z :. i) index1 i = lift (Z :. i) --- |Turn a rank-1 indexing expression into an 'Int' expression. +-- | Turn a rank-1 indexing expression into an 'Int' expression. -- unindex1 :: Elt i => Exp (Z :. i) -> Exp i unindex1 ix = let Z :. i = unlift ix in i -- | Creates a rank-2 index from two Exp Int`s -- -index2 :: (Elt i, Slice (Z :. i)) - => Exp i - -> Exp i - -> Exp (Z :. i :. i) +index2 + :: (Elt i, Slice (Z :. i)) + => Exp i + -> Exp i + -> Exp (Z :. i :. i) index2 i j = lift (Z :. i :. j) -- | Destructs a rank-2 index to an Exp tuple of two Int`s. -- -unindex2 :: forall i. (Elt i, Slice (Z :. i)) - => Exp (Z :. i :. i) - -> Exp (i, i) +unindex2 + :: forall i. (Elt i, Slice (Z :. i)) + => Exp (Z :. i :. i) + -> Exp (i, i) unindex2 ix = let Z :. i :. j = unlift ix :: Z :. Exp i :. Exp i in lift (i, j) diff --git a/Data/Array/Accelerate/Pretty/Graphviz.hs b/Data/Array/Accelerate/Pretty/Graphviz.hs --- a/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -42,9 +42,8 @@ import qualified Data.HashSet as Set -- friends -import Data.Array.Accelerate.AST ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), Idx(..) ) -import Data.Array.Accelerate.Array.Sugar ( Array, Elt, EltRepr, Tuple(..), Atuple(..), arrays, toElt, strForeign ) -import Data.Array.Accelerate.Type ( Boundary(..) ) +import Data.Array.Accelerate.AST ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), Idx(..) ) +import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, Tuple(..), Atuple(..), arrays, toElt, strForeign ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Trafo.Base import Data.Array.Accelerate.Pretty.Print @@ -249,10 +248,9 @@ Scanr1 f xs -> "scanr1" .$ [ ppF f, ppA xs ] Permute f dfts p xs -> "permute" .$ [ ppF f, ppA dfts, ppF p, ppA xs ] Backpermute sh p xs -> "backpermute" .$ [ ppSh sh, ppF p, ppA xs ] - Stencil sten bndy xs -> "stencil" .$ [ ppF sten, ppB xs bndy, ppA xs ] + Stencil sten bndy xs -> "stencil" .$ [ ppF sten, ppB bndy, ppA xs ] Stencil2 sten bndy1 acc1 bndy2 acc2 - -> "stencil2" .$ [ ppF sten, ppB acc1 bndy1, ppA acc1, - ppB acc2 bndy2, ppA acc2 ] + -> "stencil2" .$ [ ppF sten, ppB bndy1, ppA acc1, ppB bndy2, ppA acc2 ] Aforeign ff _afun xs -> "aforeign" .$ [ return (PDoc (text (strForeign ff)) []), {- ppAf afun, -} ppA xs ] -- Collect{} -> error "Collect" @@ -312,14 +310,14 @@ PDoc d v <- "Delayed" `fmt` [ ppSh sh, ppF f ] return $ PDoc (parens d) v - ppB :: forall sh e. Elt e - => {-dummy-} DelayedOpenAcc aenv (Array sh e) - -> Boundary (EltRepr e) + ppB :: forall sh e. (Shape sh, Elt e) + => PreBoundary DelayedOpenAcc aenv (Array sh e) -> Dot PDoc - ppB _ Clamp = return (PDoc "Clamp" []) - ppB _ Mirror = return (PDoc "Mirror" []) - ppB _ Wrap = return (PDoc "Wrap" []) - ppB _ (Constant e) = return (PDoc (parens $ "Constant" <+> text (show (toElt e :: e))) []) + ppB Clamp = return (PDoc "Clamp" []) + ppB Mirror = return (PDoc "Mirror" []) + ppB Wrap = return (PDoc "Wrap" []) + ppB (Constant e) = return (PDoc (parens $ "Constant" <+> text (show (toElt e :: e))) []) + ppB (Function f) = "Function" `fmt` [ ppF f ] ppF :: DelayedFun aenv t -> Dot PDoc ppF = return . uncurry PDoc . (parens . prettyDelayedFun aenv' &&& fvF) diff --git a/Data/Array/Accelerate/Pretty/Print.hs b/Data/Array/Accelerate/Pretty/Print.hs --- a/Data/Array/Accelerate/Pretty/Print.hs +++ b/Data/Array/Accelerate/Pretty/Print.hs @@ -50,10 +50,9 @@ import Text.PrettyPrint -- friends +import Data.Array.Accelerate.AST hiding ( Val(..), prj ) import Data.Array.Accelerate.Array.Sugar hiding ( tuple ) import Data.Array.Accelerate.Product -import Data.Array.Accelerate.AST hiding ( Val(..), prj ) -import Data.Array.Accelerate.Type -- Pretty printing @@ -115,14 +114,14 @@ ppAF :: PreOpenAfun acc aenv f -> Doc ppAF = parens . prettyPreOpenAfun prettyAcc aenv - ppB :: forall sh e. Elt e - => {-dummy-} acc aenv (Array sh e) - -> Boundary (EltRepr e) + ppB :: forall sh e. (Shape sh, Elt e) + => PreBoundary acc aenv (Array sh e) -> Doc - ppB _ Clamp = text "Clamp" - ppB _ Mirror = text "Mirror" - ppB _ Wrap = text "Wrap" - ppB _ (Constant e) = parens $ text "Constant" <+> text (show (toElt e :: e)) + ppB Clamp = text "clamp" + ppB Mirror = text "mirror" + ppB Wrap = text "wrap" + ppB (Constant e) = parens $ text "constant" <+> text (show (toElt e :: e)) + ppB (Function f) = ppF f -- pretty print a named array operation with its arguments name .$ docs = wrap $ hang (text name) 2 (sep docs) @@ -171,10 +170,9 @@ pp (Permute f dfts p acc) = "permute" .$ [ ppF f, ppA dfts, ppF p, ppA acc ] pp (Backpermute sh p acc) = "backpermute" .$ [ ppSh sh, ppF p, ppA acc ] pp (Aforeign ff _afun acc) = "aforeign" .$ [ text (strForeign ff), {- ppAf afun, -} ppA acc ] - pp (Stencil sten bndy acc) = "stencil" .$ [ ppF sten, ppB acc bndy, ppA acc ] + pp (Stencil sten bndy acc) = "stencil" .$ [ ppF sten, ppB bndy, ppA acc ] pp (Stencil2 sten bndy1 acc1 bndy2 acc2) - = "stencil2" .$ [ ppF sten, ppB acc1 bndy1, ppA acc1, - ppB acc2 bndy2, ppA acc2 ] + = "stencil2" .$ [ ppF sten, ppB bndy1, ppA acc1, ppB bndy2, ppA acc2 ] -- pp (Collect s) = wrap $ hang (text "collect") 2 -- $ encloseSep lbrace rbrace semi @@ -463,6 +461,7 @@ prettyPrim PrimCeiling{} = (False, text "ceiling") prettyPrim PrimAtan2{} = (False, text "atan2") prettyPrim PrimIsNaN{} = (False, text "isNaN") +prettyPrim PrimIsInfinite{} = (False, text "isInfinite") prettyPrim PrimLt{} = (True, text "<") prettyPrim PrimGt{} = (True, text ">") prettyPrim PrimLtEq{} = (True, text "<=") diff --git a/Data/Array/Accelerate/Product.hs b/Data/Array/Accelerate/Product.hs --- a/Data/Array/Accelerate/Product.hs +++ b/Data/Array/Accelerate/Product.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,6 +28,7 @@ TupleIdx(..), IsProduct(..), ProdR(..) ) where + -- |Type-safe projection indices for tuples. -- diff --git a/Data/Array/Accelerate/Smart.hs b/Data/Array/Accelerate/Smart.hs --- a/Data/Array/Accelerate/Smart.hs +++ b/Data/Array/Accelerate/Smart.hs @@ -28,1604 +28,1924 @@ module Data.Array.Accelerate.Smart ( -- * HOAS AST - Acc(..), PreAcc(..), Exp(..), PreExp(..), Boundary(..), Stencil(..), Level, - - -- * Smart constructors for literals - constant, - - -- * Smart constructors and destructors for tuples - tup2, tup3, tup4, tup5, tup6, tup7, tup8, tup9, tup10, tup11, tup12, tup13, tup14, tup15, - untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9, untup10, untup11, untup12, untup13, untup14, untup15, - - atup2, atup3, atup4, atup5, atup6, atup7, atup8, atup9, atup10, atup11, atup12, atup13, atup14, atup15, - unatup2, unatup3, unatup4, unatup5, unatup6, unatup7, unatup8, unatup9, unatup10, unatup11, unatup12, unatup13, unatup14, unatup15, - - -- * Smart constructors for constants - mkMinBound, mkMaxBound, mkPi, - mkSin, mkCos, mkTan, - mkAsin, mkAcos, mkAtan, - mkSinh, mkCosh, mkTanh, - mkAsinh, mkAcosh, mkAtanh, - mkExpFloating, mkSqrt, mkLog, - mkFPow, mkLogBase, - mkTruncate, mkRound, mkFloor, mkCeiling, - mkAtan2, - - -- * Smart constructors for primitive functions - mkAdd, mkSub, mkMul, mkNeg, mkAbs, mkSig, mkQuot, mkRem, mkQuotRem, mkIDiv, mkMod, mkDivMod, - mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR, mkPopCount, mkCountLeadingZeros, mkCountTrailingZeros, - mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq, mkEq, mkNEq, mkMax, mkMin, - mkLAnd, mkLOr, mkLNot, mkIsNaN, - - -- * Smart constructors for type coercion functions - mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkUnsafeCoerce, - - -- * Auxiliary functions - ($$), ($$$), ($$$$), ($$$$$), - - -- Debugging - showPreAccOp, showPreExpOp, - -) where - --- standard library -import Prelude hiding ( exp ) -import Data.List -import Data.Typeable - --- friends -import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Product -import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc - , PreOpenExp(..), OpenExp, PreExp, Exp - , Stencil(..) - , showPreAccOp, showPreExpOp ) -import qualified Data.Array.Accelerate.AST as AST - --- Array computations --- ------------------ - --- | Accelerate is an /embedded language/ that distinguishes between vanilla --- arrays (e.g. in Haskell memory on the CPU) and embedded arrays (e.g. in --- device memory on a GPU), as well as the computations on both of these. Since --- Accelerate is an embedded language, programs written in Accelerate are not --- compiled by the Haskell compiler (GHC). Rather, each Accelerate backend is --- a /runtime compiler/ which generates and executes parallel SIMD code of the --- target language at application /runtime/. --- --- The type constructor 'Acc' represents embedded collective array operations. --- A term of type @Acc a@ is an Accelerate program which, once executed, will --- produce a value of type 'a' (an 'Array' or a tuple of 'Arrays'). Collective --- operations of type @Acc a@ comprise many /scalar expressions/, wrapped in --- type constructor 'Exp', which will be executed in parallel. Although --- collective operations comprise many scalar operations executed in parallel, --- scalar operations /cannot/ initiate new collective operations: this --- stratification between scalar operations in 'Exp' and array operations in --- 'Acc' helps statically exclude /nested data parallelism/, which is difficult --- to execute efficiently on constrained hardware such as GPUs. --- --- For example, to compute a vector dot product we could write: --- --- > dotp :: Num a => Vector a -> Vector a -> Acc (Scalar a) --- > dotp xs ys = --- > let --- > xs' = use xs --- > ys' = use ys --- > in --- > fold (+) 0 ( zipWith (*) xs' ys' ) --- --- The function @dotp@ consumes two one-dimensional arrays ('Vector's) of --- values, and produces a single ('Scalar') result as output. As the return type --- is wrapped in the type 'Acc', we see that it is an embedded Accelerate --- computation - it will be evaluated in the /object/ language of dynamically --- generated parallel code, rather than the /meta/ language of vanilla Haskell. --- --- As the arguments to @dotp@ are plain Haskell arrays, to make these available --- to Accelerate computations they must be embedded with the --- 'Data.Array.Accelerate.Language.use' function. --- --- An Accelerate backend is used to evaluate the embedded computation and return --- the result back to vanilla Haskell. Calling the 'run' function of a backend --- will generate code for the target architecture, compile, and execute it. For --- example, the following backends are available: --- --- * : for execution on multicore CPUs --- * : for execution on NVIDIA CUDA-capable GPUs --- --- See also 'Exp', which encapsulates embedded /scalar/ computations. --- --- [/Fusion:/] --- --- Array computations of type 'Acc' will be subject to /array fusion/; --- Accelerate will combine individual 'Acc' computations into a single --- computation, which reduces the number of traversals over the input data and --- thus improves performance. As such, it is often useful to have some intuition --- on when fusion should occur. --- --- The main idea is to first partition array operations into two categories: --- --- 1. Element-wise operations, such as 'Data.Array.Accelerate.map', --- 'Data.Array.Accelerate.generate', and --- 'Data.Array.Accelerate.backpermute'. Each element of these operations --- can be computed independently of all others. --- --- 2. Collective operations such as 'Data.Array.Accelerate.fold', --- 'Data.Array.Accelerate.scanl', and 'Data.Array.Accelerate.stencil'. To --- compute each output element of these operations requires reading --- multiple elements from the input array(s). --- --- Element-wise operations fuse together whenever the consumer operation uses --- a single element of the input array. Element-wise operations can both fuse --- their inputs into themselves, as well be fused into later operations. Both --- these examples should fuse into a single loop: --- --- > map -> reverse -> reshape -> map -> map --- --- > map -> backpermute -> --- > zipWith -> map --- > generate -> --- --- If the consumer operation uses more than one element of the input array --- (typically, via 'Data.Array.Accelerate.generate' indexing an array multiple --- times), then the input array will be completely evaluated first; no fusion --- occurs in this case, because fusing the first operation into the second --- implies duplicating work. --- --- On the other hand, collective operations can fuse their input arrays into --- themselves, but on output always evaluate to an array; collective operations --- will not be fused into a later step. For example: --- --- > use -> --- > zipWith -> fold |-> map --- > generate -> --- --- Here the element-wise sequence ('Data.Array.Accelerate.use' --- + 'Data.Array.Accelerate.generate' + 'Data.Array.Accelerate.zipWith') will --- fuse into a single operation, which then fuses into the collective --- 'Data.Array.Accelerate.fold' operation. At this point in the program the --- 'Data.Array.Accelerate.fold' must now be evaluated. In the final step the --- 'Data.Array.Accelerate.map' reads in the array produced by --- 'Data.Array.Accelerate.fold'. As there is no fusion between the --- 'Data.Array.Accelerate.fold' and 'Data.Array.Accelerate.map' steps, this --- program consists of two "loops"; one for the 'Data.Array.Accelerate.use' --- + 'Data.Array.Accelerate.generate' + 'Data.Array.Accelerate.zipWith' --- + 'Data.Array.Accelerate.fold' step, and one for the final --- 'Data.Array.Accelerate.map' step. --- --- You can see how many operations will be executed in the fused program by --- 'Show'-ing the 'Acc' program, or by using the debugging option @-ddump-dot@ --- to save the program as a graphviz DOT file. --- --- As a special note, the operations 'Data.Array.Accelerate.unzip' and --- 'Data.Array.Accelerate.reshape', when applied to a real array, are executed --- in constant time, so in this situation these operations will not be fused. --- --- [/Tips:/] --- --- * Since 'Acc' represents embedded computations that will only be executed --- when evaluated by a backend, we can programatically generate these --- computations using the meta language Haskell; for example, unrolling loops --- or embedding input values into the generated code. --- --- * It is usually best to keep all intermediate computations in 'Acc', and --- only 'run' the computation at the very end to produce the final result. --- This enables optimisations between intermediate results (e.g. array --- fusion) and, if the target architecture has a separate memory space as is --- the case of GPUs, to prevent excessive data transfers. --- -newtype Acc a = Acc (PreAcc Acc Exp a) -deriving instance Typeable Acc - - --- The level of lambda-bound variables. The root has level 0; then it increases with each bound --- variable — i.e., it is the same as the size of the environment at the defining occurrence. --- -type Level = Int - --- | Array-valued collective computations without a recursive knot --- -data PreAcc acc exp as where - -- Needed for conversion to de Bruijn form - Atag :: Arrays as - => Level -- environment size at defining occurrence - -> PreAcc acc exp as - - Pipe :: (Arrays as, Arrays bs, Arrays cs) - => (Acc as -> acc bs) - -> (Acc bs -> acc cs) - -> acc as - -> PreAcc acc exp cs - - Aforeign :: (Arrays as, Arrays bs, Foreign asm) - => asm (as -> bs) - -> (Acc as -> Acc bs) - -> acc as - -> PreAcc acc exp bs - - Acond :: Arrays as - => exp Bool - -> acc as - -> acc as - -> PreAcc acc exp as - - Awhile :: Arrays arrs - => (Acc arrs -> acc (Scalar Bool)) - -> (Acc arrs -> acc arrs) - -> acc arrs - -> PreAcc acc exp arrs - - Atuple :: (Arrays arrs, IsAtuple arrs) - => Atuple acc (TupleRepr arrs) - -> PreAcc acc exp arrs - - Aprj :: (Arrays arrs, IsAtuple arrs, Arrays a) - => TupleIdx (TupleRepr arrs) a - -> acc arrs - -> PreAcc acc exp a - - Use :: Arrays arrs - => arrs - -> PreAcc acc exp arrs - - Unit :: Elt e - => exp e - -> PreAcc acc exp (Scalar e) - - Generate :: (Shape sh, Elt e) - => exp sh - -> (Exp sh -> exp e) - -> PreAcc acc exp (Array sh e) - - Reshape :: (Shape sh, Shape sh', Elt e) - => exp sh - -> acc (Array sh' e) - -> PreAcc acc exp (Array sh e) - - Replicate :: (Slice slix, Elt e) - => exp slix - -> acc (Array (SliceShape slix) e) - -> PreAcc acc exp (Array (FullShape slix) e) - - Slice :: (Slice slix, Elt e) - => acc (Array (FullShape slix) e) - -> exp slix - -> PreAcc acc exp (Array (SliceShape slix) e) - - Map :: (Shape sh, Elt e, Elt e') - => (Exp e -> exp e') - -> acc (Array sh e) - -> PreAcc acc exp (Array sh e') - - ZipWith :: (Shape sh, Elt e1, Elt e2, Elt e3) - => (Exp e1 -> Exp e2 -> exp e3) - -> acc (Array sh e1) - -> acc (Array sh e2) - -> PreAcc acc exp (Array sh e3) - - Fold :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Array (sh:.Int) e) - -> PreAcc acc exp (Array sh e) - - Fold1 :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> acc (Array (sh:.Int) e) - -> PreAcc acc exp (Array sh e) - - FoldSeg :: (Shape sh, Elt e, Elt i, IsIntegral i) - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Array (sh:.Int) e) - -> acc (Segments i) - -> PreAcc acc exp (Array (sh:.Int) e) - - Fold1Seg :: (Shape sh, Elt e, Elt i, IsIntegral i) - => (Exp e -> Exp e -> exp e) - -> acc (Array (sh:.Int) e) - -> acc (Segments i) - -> PreAcc acc exp (Array (sh:.Int) e) - - Scanl :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Array (sh :. Int) e) - -> PreAcc acc exp (Array (sh :. Int) e) - - Scanl' :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Array (sh :. Int) e) - -> PreAcc acc exp (Array (sh :. Int) e, Array sh e) - - Scanl1 :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> acc (Array (sh :. Int) e) - -> PreAcc acc exp (Array (sh :. Int) e) - - Scanr :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Array (sh :. Int) e) - -> PreAcc acc exp (Array (sh :. Int) e) - - Scanr' :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Array (sh :. Int) e) - -> PreAcc acc exp (Array (sh :. Int) e, Array sh e) - - Scanr1 :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> acc (Array (sh :. Int) e) - -> PreAcc acc exp (Array (sh :. Int) e) - - Permute :: (Shape sh, Shape sh', Elt e) - => (Exp e -> Exp e -> exp e) - -> acc (Array sh' e) - -> (Exp sh -> exp sh') - -> acc (Array sh e) - -> PreAcc acc exp (Array sh' e) - - Backpermute :: (Shape sh, Shape sh', Elt e) - => exp sh' - -> (Exp sh' -> exp sh) - -> acc (Array sh e) - -> PreAcc acc exp (Array sh' e) - - Stencil :: (Shape sh, Elt a, Elt b, Stencil sh a stencil) - => (stencil -> exp b) - -> Boundary a - -> acc (Array sh a) - -> PreAcc acc exp (Array sh b) - - Stencil2 :: (Shape sh, Elt a, Elt b, Elt c, - Stencil sh a stencil1, Stencil sh b stencil2) - => (stencil1 -> stencil2 -> exp c) - -> Boundary a - -> acc (Array sh a) - -> Boundary b - -> acc (Array sh b) - -> PreAcc acc exp (Array sh c) - - -- Collect :: Arrays arrs - -- => seq arrs - -- -> PreAcc acc seq exp arrs - - -{-- -data PreSeq acc seq exp arrs where - -- Convert the given Haskell-list of arrays to a sequence. - StreamIn :: Arrays a - => [a] - -> PreSeq acc seq exp [a] - - -- Convert the given array to a sequence. - -- Example: - -- slix = Z :. All :. Split :. All :. All :. Split - -- ^ ^ ^ ^ ^ - -- | \ / / | - -- | \___/______/_______ Iteration space. - -- | / / - -- Element________/______/ - -- shape. - -- - ToSeq :: ( Elt e - , Slice slix - , Division slsix - , DivisionSlice slsix ~ slix - , Typeable (FullShape slix) - , Typeable (SliceShape slix) - ) - => slsix - -> acc (Array (FullShape slix) e) - -> PreSeq acc seq exp [Array (SliceShape slix) e] - - -- Apply the given the given function to all elements of the given sequence. - MapSeq :: (Arrays a, Arrays b) - => (Acc a -> acc b) - -> seq [a] - -> PreSeq acc seq exp [b] - - -- Apply a given binary function pairwise to all elements of the given sequences. - -- The length of the result is the length of the shorter of the two argument - -- arrays. - ZipWithSeq :: (Arrays a, Arrays b, Arrays c) - => (Acc a -> Acc b -> acc c) - -> seq [a] - -> seq [b] - -> PreSeq acc seq exp [c] - - -- ScanSeq (+) a0 x. Scan a sequence x by combining each element - -- using the given binary operation (+). (+) must be associative: - -- - -- Forall a b c. (a + b) + c = a + (b + c), - -- - -- and a0 must be the identity element for (+): - -- - -- Forall a. a0 + a = a = a + a0. - -- - ScanSeq :: Elt a - => (Exp a -> Exp a -> exp a) - -> exp a - -> seq [Scalar a] - -> PreSeq acc seq exp [Scalar a] - - -- FoldSeq (+) a0 x. Fold a sequence x by combining each element - -- using the given binary operation (+). (+) must be associative: - -- - -- Forall a b c. (a + b) + c = a + (b + c), - -- - -- and a0 must be the identity element for (+): - -- - -- Forall a. a0 + a = a = a + a0. - -- - FoldSeq :: Elt a - => (Exp a -> Exp a -> exp a) - -> exp a - -> seq [Scalar a] - -> PreSeq acc seq exp (Scalar a) - - -- FoldSeqFlatten f a0 x. A specialized version of FoldSeqAct - -- where reduction with the companion operator corresponds to - -- flattening. f must be semi-associative, with vecotor append (++) - -- as the companion operator: - -- - -- Forall b s1 a2 sh2 a2. - -- f (f b sh1 a1) sh2 a2 = f b (sh1 ++ sh2) (a1 ++ a2). - -- - -- It is common to ignore the shape vectors, yielding the usual - -- semi-associativity law: - -- - -- f b a _ = b + a, - -- - -- for some (+) satisfying: - -- - -- Forall b a1 a2. (b + a1) + a2 = b + (a1 ++ a2). - -- - FoldSeqFlatten :: (Arrays a, Shape sh, Elt e) - => (Acc a -> Acc (Vector sh) -> Acc (Vector e) -> acc a) - -> acc a - -> seq [Array sh e] - -> PreSeq acc seq exp a - - -- Tuple up the results of a sequence computation. Note that the Arrays - -- constraint requires that the elements of the tuple are Arrays, not - -- streams ([]). - Stuple :: (Arrays arrs, IsAtuple arrs) - => Atuple (seq) (TupleRepr arrs) - -> PreSeq acc seq exp arrs - --- |Array-valued sequence computations --- -newtype Seq a = Seq (PreSeq Acc Seq Exp a) - -deriving instance Typeable Seq ---} - - --- Embedded expressions of the surface language --- -------------------------------------------- - --- HOAS expressions mirror the constructors of 'AST.OpenExp', but with the 'Tag' --- constructor instead of variables in the form of de Bruijn indices. Moreover, --- HOAS expression use n-tuples and the type class 'Elt' to constrain element --- types, whereas 'AST.OpenExp' uses nested pairs and the GADT 'TupleType'. --- - --- | The type 'Exp' represents embedded scalar expressions. The collective --- operations of Accelerate 'Acc' consist of many scalar expressions executed in --- data-parallel. --- --- Note that scalar expressions can not initiate new collective operations: --- doing so introduces /nested data parallelism/, which is difficult to execute --- efficiently on constrained hardware such as GPUs, and is thus currently --- unsupported. --- -newtype Exp t = Exp (PreExp Acc Exp t) - -deriving instance Typeable Exp - --- | Scalar expressions to parametrise collective array operations, themselves parameterised over --- the type of collective array operations. --- -data PreExp acc exp t where - -- Needed for conversion to de Bruijn form - Tag :: Elt t - => Level -- environment size at defining occurrence - -> PreExp acc exp t - - -- All the same constructors as 'AST.Exp' - Const :: Elt t - => t - -> PreExp acc exp t - - Tuple :: (Elt t, IsTuple t) - => Tuple exp (TupleRepr t) - -> PreExp acc exp t - - Prj :: (Elt t, IsTuple t, Elt e) - => TupleIdx (TupleRepr t) e - -> exp t - -> PreExp acc exp e - - IndexNil :: PreExp acc exp Z - - IndexCons :: (Slice sl, Elt a) - => exp sl - -> exp a - -> PreExp acc exp (sl:.a) - - IndexHead :: (Slice sl, Elt a) - => exp (sl:.a) - -> PreExp acc exp a - - IndexTail :: (Slice sl, Elt a) - => exp (sl:.a) - -> PreExp acc exp sl - - IndexAny :: Shape sh - => PreExp acc exp (Any sh) - - ToIndex :: Shape sh - => exp sh - -> exp sh - -> PreExp acc exp Int - - FromIndex :: Shape sh - => exp sh - -> exp Int - -> PreExp acc exp sh - - Cond :: Elt t - => exp Bool - -> exp t - -> exp t - -> PreExp acc exp t - - While :: Elt t - => (Exp t -> exp Bool) - -> (Exp t -> exp t) - -> exp t - -> PreExp acc exp t - - PrimConst :: Elt t - => PrimConst t - -> PreExp acc exp t - - PrimApp :: (Elt a, Elt r) - => PrimFun (a -> r) - -> exp a - -> PreExp acc exp r - - Index :: (Shape sh, Elt t) - => acc (Array sh t) - -> exp sh - -> PreExp acc exp t - - LinearIndex :: (Shape sh, Elt t) - => acc (Array sh t) - -> exp Int - -> PreExp acc exp t - - Shape :: (Shape sh, Elt e) - => acc (Array sh e) - -> PreExp acc exp sh - - ShapeSize :: Shape sh - => exp sh - -> PreExp acc exp Int - - Intersect :: Shape sh - => exp sh - -> exp sh - -> PreExp acc exp sh - - Union :: Shape sh - => exp sh - -> exp sh - -> PreExp acc exp sh - - Foreign :: (Elt x, Elt y, Foreign asm) - => asm (x -> y) - -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery. - -> exp x - -> PreExp acc exp y - - --- Smart constructors and destructors for array tuples --- --------------------------------------------------- - -atup2 :: (Arrays a, Arrays b) => (Acc a, Acc b) -> Acc (a, b) -atup2 (a, b) = Acc $ Atuple (NilAtup `SnocAtup` a `SnocAtup` b) - -atup3 :: (Arrays a, Arrays b, Arrays c) => (Acc a, Acc b, Acc c) -> Acc (a, b, c) -atup3 (a, b, c) = Acc $ Atuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c) - -atup4 :: (Arrays a, Arrays b, Arrays c, Arrays d) - => (Acc a, Acc b, Acc c, Acc d) -> Acc (a, b, c, d) -atup4 (a, b, c, d) - = Acc $ Atuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d) - -atup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) - => (Acc a, Acc b, Acc c, Acc d, Acc e) -> Acc (a, b, c, d, e) -atup5 (a, b, c, d, e) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e - -atup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) -> Acc (a, b, c, d, e, f) -atup6 (a, b, c, d, e, f) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c - `SnocAtup` d `SnocAtup` e `SnocAtup` f - -atup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) - -> Acc (a, b, c, d, e, f, g) -atup7 (a, b, c, d, e, f, g) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c - `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g - -atup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) - -> Acc (a, b, c, d, e, f, g, h) -atup8 (a, b, c, d, e, f, g, h) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d - `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h - -atup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) - -> Acc (a, b, c, d, e, f, g, h, i) -atup9 (a, b, c, d, e, f, g, h, i) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d - `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i - -atup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j) - -> Acc (a, b, c, d, e, f, g, h, i, j) -atup10 (a, b, c, d, e, f, g, h, i, j) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e - `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j - -atup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k) - -> Acc (a, b, c, d, e, f, g, h, i, j, k) -atup11 (a, b, c, d, e, f, g, h, i, j, k) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e - `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k - -atup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l) - -> Acc (a, b, c, d, e, f, g, h, i, j, k, l) -atup12 (a, b, c, d, e, f, g, h, i, j, k, l) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f - `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l - -atup13 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m) - -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m) -atup13 (a, b, c, d, e, f, g, h, i, j, k, l, m) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f - `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m - -atup14 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n) - -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -atup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g - `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n - -atup15 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n, Arrays o) - => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o) - -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -atup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) - = Acc $ Atuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g - `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n `SnocAtup` o - -unatup2 :: (Arrays a, Arrays b) => Acc (a, b) -> (Acc a, Acc b) -unatup2 e = - ( Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e ) - -unatup3 :: (Arrays a, Arrays b, Arrays c) => Acc (a, b, c) -> (Acc a, Acc b, Acc c) -unatup3 e = - ( Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e ) - -unatup4 - :: (Arrays a, Arrays b, Arrays c, Arrays d) - => Acc (a, b, c, d) -> (Acc a, Acc b, Acc c, Acc d) -unatup4 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e ) - -unatup5 - :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) - => Acc (a, b, c, d, e) -> (Acc a, Acc b, Acc c, Acc d, Acc e) -unatup5 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e ) - -unatup6 - :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) - => Acc (a, b, c, d, e, f) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) -unatup6 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e ) - -unatup7 - :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) - => Acc (a, b, c, d, e, f, g) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) -unatup7 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e ) - -unatup8 - :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h) - => Acc (a, b, c, d, e, f, g, h) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) -unatup8 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e ) - -unatup9 - :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i) - => Acc (a, b, c, d, e, f, g, h, i) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) -unatup9 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e ) - -unatup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j) - => Acc (a, b, c, d, e, f, g, h, i, j) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j) -unatup10 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e) - -unatup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k) - => Acc (a, b, c, d, e, f, g, h, i, j, k) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k) -unatup11 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e) - -unatup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l) - => Acc (a, b, c, d, e, f, g, h, i, j, k, l) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l) -unatup12 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e) - -unatup13 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m) - => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m) -unatup13 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e) - -unatup14 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n) - => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n) -unatup14 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e) - -unatup15 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n, Arrays o) - => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o) -unatup15 e = - ( Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Aprj` e - , Acc $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Aprj` e - , Acc $ SuccTupIdx ZeroTupIdx `Aprj` e - , Acc $ ZeroTupIdx `Aprj` e) - - - --- Smart constructors for stencil reification --- ------------------------------------------ - --- Stencil reification --- --- In the AST representation, we turn the stencil type from nested tuples of Accelerate expressions --- into an Accelerate expression whose type is a tuple nested in the same manner. This enables us --- to represent the stencil function as a unary function (which also only needs one de Bruijn --- index). The various positions in the stencil are accessed via tuple indices (i.e., projections). - -class (Elt (StencilRepr sh stencil), AST.Stencil sh a (StencilRepr sh stencil)) - => Stencil sh a stencil where - type StencilRepr sh stencil :: * - stencilPrj :: sh{-dummy-} -> a{-dummy-} -> Exp (StencilRepr sh stencil) -> stencil - --- DIM1 -instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e) where - type StencilRepr DIM1 (Exp e, Exp e, Exp e) - = (e, e, e) - stencilPrj _ _ s = (Exp $ Prj tix2 s, - Exp $ Prj tix1 s, - Exp $ Prj tix0 s) -instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e) where - type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e) - = (e, e, e, e, e) - stencilPrj _ _ s = (Exp $ Prj tix4 s, - Exp $ Prj tix3 s, - Exp $ Prj tix2 s, - Exp $ Prj tix1 s, - Exp $ Prj tix0 s) -instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) where - type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) - = (e, e, e, e, e, e, e) - stencilPrj _ _ s = (Exp $ Prj tix6 s, - Exp $ Prj tix5 s, - Exp $ Prj tix4 s, - Exp $ Prj tix3 s, - Exp $ Prj tix2 s, - Exp $ Prj tix1 s, - Exp $ Prj tix0 s) -instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) - where - type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) - = (e, e, e, e, e, e, e, e, e) - stencilPrj _ _ s = (Exp $ Prj tix8 s, - Exp $ Prj tix7 s, - Exp $ Prj tix6 s, - Exp $ Prj tix5 s, - Exp $ Prj tix4 s, - Exp $ Prj tix3 s, - Exp $ Prj tix2 s, - Exp $ Prj tix1 s, - Exp $ Prj tix0 s) - --- DIM(n+1) -instance (Stencil (sh:.Int) a row2, - Stencil (sh:.Int) a row1, - Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row2, row1, row0) where - type StencilRepr (sh:.Int:.Int) (row2, row1, row0) - = (StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row0) - stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s)) -instance (Stencil (sh:.Int) a row1, - Stencil (sh:.Int) a row2, - Stencil (sh:.Int) a row3, - Stencil (sh:.Int) a row4, - Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where - type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5) - = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3, - StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5) - stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s)) -instance (Stencil (sh:.Int) a row1, - Stencil (sh:.Int) a row2, - Stencil (sh:.Int) a row3, - Stencil (sh:.Int) a row4, - Stencil (sh:.Int) a row5, - Stencil (sh:.Int) a row6, - Stencil (sh:.Int) a row7) - => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where - type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7) - = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3, - StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6, - StencilRepr (sh:.Int) row7) - stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s)) -instance (Stencil (sh:.Int) a row1, - Stencil (sh:.Int) a row2, - Stencil (sh:.Int) a row3, - Stencil (sh:.Int) a row4, - Stencil (sh:.Int) a row5, - Stencil (sh:.Int) a row6, - Stencil (sh:.Int) a row7, - Stencil (sh:.Int) a row8, - Stencil (sh:.Int) a row9) - => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where - type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7, row8, row9) - = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3, - StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6, - StencilRepr (sh:.Int) row7, StencilRepr (sh:.Int) row8, StencilRepr (sh:.Int) row9) - stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix8 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix7 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s), - stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s)) - --- Auxiliary tuple index constants --- -tix0 :: TupleIdx (t, s0) s0 -tix0 = ZeroTupIdx - -tix1 :: TupleIdx ((t, s1), s0) s1 -tix1 = SuccTupIdx tix0 - -tix2 :: TupleIdx (((t, s2), s1), s0) s2 -tix2 = SuccTupIdx tix1 - -tix3 :: TupleIdx ((((t, s3), s2), s1), s0) s3 -tix3 = SuccTupIdx tix2 - -tix4 :: TupleIdx (((((t, s4), s3), s2), s1), s0) s4 -tix4 = SuccTupIdx tix3 - -tix5 :: TupleIdx ((((((t, s5), s4), s3), s2), s1), s0) s5 -tix5 = SuccTupIdx tix4 - -tix6 :: TupleIdx (((((((t, s6), s5), s4), s3), s2), s1), s0) s6 -tix6 = SuccTupIdx tix5 - -tix7 :: TupleIdx ((((((((t, s7), s6), s5), s4), s3), s2), s1), s0) s7 -tix7 = SuccTupIdx tix6 - -tix8 :: TupleIdx (((((((((t, s8), s7), s6), s5), s4), s3), s2), s1), s0) s8 -tix8 = SuccTupIdx tix7 - -{-- --- Smart constructors for array tuples in sequence computations --- --------------------------------------------------- - -stup2 :: (Arrays a, Arrays b) => (Seq a, Seq b) -> Seq (a, b) -stup2 (a, b) = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b) - -stup3 :: (Arrays a, Arrays b, Arrays c) => (Seq a, Seq b, Seq c) -> Seq (a, b, c) -stup3 (a, b, c) = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c) - -stup4 :: (Arrays a, Arrays b, Arrays c, Arrays d) - => (Seq a, Seq b, Seq c, Seq d) -> Seq (a, b, c, d) -stup4 (a, b, c, d) - = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d) - -stup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) - => (Seq a, Seq b, Seq c, Seq d, Seq e) -> Seq (a, b, c, d, e) -stup5 (a, b, c, d, e) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e - -stup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f) -> Seq (a, b, c, d, e, f) -stup6 (a, b, c, d, e, f) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c - `SnocAtup` d `SnocAtup` e `SnocAtup` f - -stup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g) - -> Seq (a, b, c, d, e, f, g) -stup7 (a, b, c, d, e, f, g) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c - `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g - -stup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h) - -> Seq (a, b, c, d, e, f, g, h) -stup8 (a, b, c, d, e, f, g, h) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d - `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h - -stup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i) - -> Seq (a, b, c, d, e, f, g, h, i) -stup9 (a, b, c, d, e, f, g, h, i) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d - `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i - -stup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j) - -> Seq (a, b, c, d, e, f, g, h, i, j) -stup10 (a, b, c, d, e, f, g, h, i, j) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e - `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j - -stup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k) - -> Seq (a, b, c, d, e, f, g, h, i, j, k) -stup11 (a, b, c, d, e, f, g, h, i, j, k) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e - `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k - -stup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l) - -> Seq (a, b, c, d, e, f, g, h, i, j, k, l) -stup12 (a, b, c, d, e, f, g, h, i, j, k, l) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f - `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l - -stup13 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m) - -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m) -stup13 (a, b, c, d, e, f, g, h, i, j, k, l, m) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f - `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m - -stup14 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m, Seq n) - -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -stup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g - `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n - -stup15 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n, Arrays o) - => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m, Seq n, Seq o) - -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -stup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) - = Seq $ Stuple $ - NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g - `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n `SnocAtup` o ---} - --- Smart constructor for literals --- - --- | Scalar expression inlet: make a Haskell value available for processing in --- an Accelerate scalar expression. --- --- Note that this embeds the value directly into the expression. Depending on --- the backend used to execute the computation, this might not always be --- desirable. For example, a backend that does external code generation may --- embed this constant directly into the generated code, which means new code --- will need to be generated and compiled every time the value changes. In such --- cases, consider instead lifting scalar values into (singleton) arrays so that --- they can be passed as an input to the computation and thus the value can --- change without the need to generate fresh code. --- -constant :: Elt t => t -> Exp t -constant = Exp . Const - --- Smart constructor and destructors for scalar tuples --- -tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b) -tup2 (a, b) = Exp $ Tuple (NilTup `SnocTup` a `SnocTup` b) - -tup3 :: (Elt a, Elt b, Elt c) => (Exp a, Exp b, Exp c) -> Exp (a, b, c) -tup3 (a, b, c) = Exp $ Tuple (NilTup `SnocTup` a `SnocTup` b `SnocTup` c) - -tup4 :: (Elt a, Elt b, Elt c, Elt d) - => (Exp a, Exp b, Exp c, Exp d) -> Exp (a, b, c, d) -tup4 (a, b, c, d) - = Exp $ Tuple (NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d) - -tup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e) - => (Exp a, Exp b, Exp c, Exp d, Exp e) -> Exp (a, b, c, d, e) -tup5 (a, b, c, d, e) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d `SnocTup` e - -tup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) -> Exp (a, b, c, d, e, f) -tup6 (a, b, c, d, e, f) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d `SnocTup` e `SnocTup` f - -tup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) - -> Exp (a, b, c, d, e, f, g) -tup7 (a, b, c, d, e, f, g) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c - `SnocTup` d `SnocTup` e `SnocTup` f `SnocTup` g - -tup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) - -> Exp (a, b, c, d, e, f, g, h) -tup8 (a, b, c, d, e, f, g, h) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d - `SnocTup` e `SnocTup` f `SnocTup` g `SnocTup` h - -tup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) - -> Exp (a, b, c, d, e, f, g, h, i) -tup9 (a, b, c, d, e, f, g, h, i) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d - `SnocTup` e `SnocTup` f `SnocTup` g `SnocTup` h `SnocTup` i - -tup10 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j) - -> Exp (a, b, c, d, e, f, g, h, i, j) -tup10 (a, b, c, d, e, f, g, h, i, j) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d `SnocTup` e - `SnocTup` f `SnocTup` g `SnocTup` h `SnocTup` i `SnocTup` j - -tup11 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k) - -> Exp (a, b, c, d, e, f, g, h, i, j, k) -tup11 (a, b, c, d, e, f, g, h, i, j, k) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d `SnocTup` e - `SnocTup` f `SnocTup` g `SnocTup` h `SnocTup` i `SnocTup` j `SnocTup` k - -tup12 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l) - -> Exp (a, b, c, d, e, f, g, h, i, j, k, l) -tup12 (a, b, c, d, e, f, g, h, i, j, k, l) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d `SnocTup` e `SnocTup` f - `SnocTup` g `SnocTup` h `SnocTup` i `SnocTup` j `SnocTup` k `SnocTup` l - -tup13 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m) - -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m) -tup13 (a, b, c, d, e, f, g, h, i, j, k, l, m) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d `SnocTup` e `SnocTup` f - `SnocTup` g `SnocTup` h `SnocTup` i `SnocTup` j `SnocTup` k `SnocTup` l `SnocTup` m - -tup14 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n) - -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -tup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d `SnocTup` e `SnocTup` f `SnocTup` g - `SnocTup` h `SnocTup` i `SnocTup` j `SnocTup` k `SnocTup` l `SnocTup` m `SnocTup` n - -tup15 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n, Elt o) - => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o) - -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -tup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) - = Exp $ Tuple $ - NilTup `SnocTup` a `SnocTup` b `SnocTup` c `SnocTup` d `SnocTup` e `SnocTup` f `SnocTup` g - `SnocTup` h `SnocTup` i `SnocTup` j `SnocTup` k `SnocTup` l `SnocTup` m `SnocTup` n `SnocTup` o - -untup2 :: (Elt a, Elt b) => Exp (a, b) -> (Exp a, Exp b) -untup2 e = - ( Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e ) - -untup3 :: (Elt a, Elt b, Elt c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c) -untup3 e = - ( Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup4 :: (Elt a, Elt b, Elt c, Elt d) - => Exp (a, b, c, d) -> (Exp a, Exp b, Exp c, Exp d) -untup4 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e) - => Exp (a, b, c, d, e) -> (Exp a, Exp b, Exp c, Exp d, Exp e) -untup5 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) - => Exp (a, b, c, d, e, f) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) -untup6 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) - => Exp (a, b, c, d, e, f, g) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) -untup7 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) - => Exp (a, b, c, d, e, f, g, h) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) -untup8 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) - => Exp (a, b, c, d, e, f, g, h, i) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) -untup9 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup10 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j) - => Exp (a, b, c, d, e, f, g, h, i, j) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j) -untup10 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup11 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k) - => Exp (a, b, c, d, e, f, g, h, i, j, k) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k) -untup11 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup12 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l) - => Exp (a, b, c, d, e, f, g, h, i, j, k, l) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l) -untup12 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup13 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m) - => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m) -untup13 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup14 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n) - => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n) -untup14 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - -untup15 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n, Elt o) - => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o) -untup15 e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e) - --- Smart constructor for constants --- - -mkMinBound :: (Elt t, IsBounded t) => Exp t -mkMinBound = Exp $ PrimConst (PrimMinBound boundedType) - -mkMaxBound :: (Elt t, IsBounded t) => Exp t -mkMaxBound = Exp $ PrimConst (PrimMaxBound boundedType) - -mkPi :: (Elt r, IsFloating r) => Exp r -mkPi = Exp $ PrimConst (PrimPi floatingType) - - --- Smart constructors for primitive applications --- - --- Operators from Floating - -mkSin :: (Elt t, IsFloating t) => Exp t -> Exp t -mkSin x = Exp $ PrimSin floatingType `PrimApp` x - -mkCos :: (Elt t, IsFloating t) => Exp t -> Exp t -mkCos x = Exp $ PrimCos floatingType `PrimApp` x - -mkTan :: (Elt t, IsFloating t) => Exp t -> Exp t -mkTan x = Exp $ PrimTan floatingType `PrimApp` x - -mkAsin :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAsin x = Exp $ PrimAsin floatingType `PrimApp` x - -mkAcos :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAcos x = Exp $ PrimAcos floatingType `PrimApp` x - -mkAtan :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAtan x = Exp $ PrimAtan floatingType `PrimApp` x - -mkSinh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkSinh x = Exp $ PrimSinh floatingType `PrimApp` x - -mkCosh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkCosh x = Exp $ PrimCosh floatingType `PrimApp` x - -mkTanh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkTanh x = Exp $ PrimTanh floatingType `PrimApp` x - -mkAsinh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAsinh x = Exp $ PrimAsinh floatingType `PrimApp` x - -mkAcosh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAcosh x = Exp $ PrimAcosh floatingType `PrimApp` x - -mkAtanh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAtanh x = Exp $ PrimAtanh floatingType `PrimApp` x - -mkExpFloating :: (Elt t, IsFloating t) => Exp t -> Exp t -mkExpFloating x = Exp $ PrimExpFloating floatingType `PrimApp` x - -mkSqrt :: (Elt t, IsFloating t) => Exp t -> Exp t -mkSqrt x = Exp $ PrimSqrt floatingType `PrimApp` x - -mkLog :: (Elt t, IsFloating t) => Exp t -> Exp t -mkLog x = Exp $ PrimLog floatingType `PrimApp` x - -mkFPow :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t -mkFPow x y = Exp $ PrimFPow floatingType `PrimApp` tup2 (x, y) - -mkLogBase :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t -mkLogBase x y = Exp $ PrimLogBase floatingType `PrimApp` tup2 (x, y) - --- Operators from Num - -mkAdd :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t -mkAdd x y = Exp $ PrimAdd numType `PrimApp` tup2 (x, y) - -mkSub :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t -mkSub x y = Exp $ PrimSub numType `PrimApp` tup2 (x, y) - -mkMul :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t -mkMul x y = Exp $ PrimMul numType `PrimApp` tup2 (x, y) - -mkNeg :: (Elt t, IsNum t) => Exp t -> Exp t -mkNeg x = Exp $ PrimNeg numType `PrimApp` x - -mkAbs :: (Elt t, IsNum t) => Exp t -> Exp t -mkAbs x = Exp $ PrimAbs numType `PrimApp` x - -mkSig :: (Elt t, IsNum t) => Exp t -> Exp t -mkSig x = Exp $ PrimSig numType `PrimApp` x - --- Operators from Integral - -mkQuot :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkQuot x y = Exp $ PrimQuot integralType `PrimApp` tup2 (x, y) - -mkRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkRem x y = Exp $ PrimRem integralType `PrimApp` tup2 (x, y) - -mkQuotRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t) -mkQuotRem x y = untup2 $ Exp $ PrimQuotRem integralType `PrimApp` tup2 (x ,y) - -mkIDiv :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkIDiv x y = Exp $ PrimIDiv integralType `PrimApp` tup2 (x, y) - -mkMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkMod x y = Exp $ PrimMod integralType `PrimApp` tup2 (x, y) - -mkDivMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t) -mkDivMod x y = untup2 $ Exp $ PrimDivMod integralType `PrimApp` tup2 (x ,y) - - --- Operators from Bits and FiniteBits - -mkBAnd :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkBAnd x y = Exp $ PrimBAnd integralType `PrimApp` tup2 (x, y) - -mkBOr :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkBOr x y = Exp $ PrimBOr integralType `PrimApp` tup2 (x, y) - -mkBXor :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkBXor x y = Exp $ PrimBXor integralType `PrimApp` tup2 (x, y) - -mkBNot :: (Elt t, IsIntegral t) => Exp t -> Exp t -mkBNot x = Exp $ PrimBNot integralType `PrimApp` x - -mkBShiftL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -mkBShiftL x i = Exp $ PrimBShiftL integralType `PrimApp` tup2 (x, i) - -mkBShiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -mkBShiftR x i = Exp $ PrimBShiftR integralType `PrimApp` tup2 (x, i) - -mkBRotateL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -mkBRotateL x i = Exp $ PrimBRotateL integralType `PrimApp` tup2 (x, i) - -mkBRotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -mkBRotateR x i = Exp $ PrimBRotateR integralType `PrimApp` tup2 (x, i) - -mkPopCount :: (Elt t, IsIntegral t) => Exp t -> Exp Int -mkPopCount x = Exp $ PrimPopCount integralType `PrimApp` x - -mkCountLeadingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int -mkCountLeadingZeros x = Exp $ PrimCountLeadingZeros integralType `PrimApp` x - -mkCountTrailingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int -mkCountTrailingZeros x = Exp $ PrimCountTrailingZeros integralType `PrimApp` x - - --- Operators from Fractional - -mkFDiv :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t -mkFDiv x y = Exp $ PrimFDiv floatingType `PrimApp` tup2 (x, y) - -mkRecip :: (Elt t, IsFloating t) => Exp t -> Exp t -mkRecip x = Exp $ PrimRecip floatingType `PrimApp` x - --- Operators from RealFrac - -mkTruncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b -mkTruncate x = Exp $ PrimTruncate floatingType integralType `PrimApp` x - -mkRound :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b -mkRound x = Exp $ PrimRound floatingType integralType `PrimApp` x - -mkFloor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b -mkFloor x = Exp $ PrimFloor floatingType integralType `PrimApp` x - -mkCeiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b -mkCeiling x = Exp $ PrimCeiling floatingType integralType `PrimApp` x - --- Operators from RealFloat - -mkAtan2 :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t -mkAtan2 x y = Exp $ PrimAtan2 floatingType `PrimApp` tup2 (x, y) - -mkIsNaN :: (Elt t, IsFloating t) => Exp t -> Exp Bool -mkIsNaN x = Exp $ PrimIsNaN floatingType `PrimApp` x + Acc(..), PreAcc(..), Exp(..), PreExp(..), Boundary(..), PreBoundary(..), Stencil(..), Level, + + -- * Smart constructors for literals + constant, + + -- * Smart constructors and destructors for tuples + tup2, tup3, tup4, tup5, tup6, tup7, tup8, tup9, tup10, tup11, tup12, tup13, tup14, tup15, + untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9, untup10, untup11, untup12, untup13, untup14, untup15, + + atup2, atup3, atup4, atup5, atup6, atup7, atup8, atup9, atup10, atup11, atup12, atup13, atup14, atup15, + unatup2, unatup3, unatup4, unatup5, unatup6, unatup7, unatup8, unatup9, unatup10, unatup11, unatup12, unatup13, unatup14, unatup15, + + -- * Smart constructors for constants + mkMinBound, mkMaxBound, mkPi, + mkSin, mkCos, mkTan, + mkAsin, mkAcos, mkAtan, + mkSinh, mkCosh, mkTanh, + mkAsinh, mkAcosh, mkAtanh, + mkExpFloating, mkSqrt, mkLog, + mkFPow, mkLogBase, + mkTruncate, mkRound, mkFloor, mkCeiling, + mkAtan2, + + -- * Smart constructors for primitive functions + mkAdd, mkSub, mkMul, mkNeg, mkAbs, mkSig, mkQuot, mkRem, mkQuotRem, mkIDiv, mkMod, mkDivMod, + mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR, mkPopCount, mkCountLeadingZeros, mkCountTrailingZeros, + mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq, mkEq, mkNEq, mkMax, mkMin, + mkLAnd, mkLOr, mkLNot, mkIsNaN, mkIsInfinite, + + -- * Smart constructors for type coercion functions + mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkUnsafeCoerce, + + -- * Auxiliary functions + ($$), ($$$), ($$$$), ($$$$$), + + -- Debugging + showPreAccOp, showPreExpOp, + +) where + +-- standard library +import Prelude hiding ( exp ) +import Data.List +import Data.Typeable + +-- friends +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc + , PreOpenExp(..), OpenExp, PreExp, Exp + , Stencil(..), PreBoundary(..), Boundary + , showPreAccOp, showPreExpOp ) +import qualified Data.Array.Accelerate.AST as AST + +-- Array computations +-- ------------------ + +-- | Accelerate is an /embedded language/ that distinguishes between vanilla +-- arrays (e.g. in Haskell memory on the CPU) and embedded arrays (e.g. in +-- device memory on a GPU), as well as the computations on both of these. Since +-- Accelerate is an embedded language, programs written in Accelerate are not +-- compiled by the Haskell compiler (GHC). Rather, each Accelerate backend is +-- a /runtime compiler/ which generates and executes parallel SIMD code of the +-- target language at application /runtime/. +-- +-- The type constructor 'Acc' represents embedded collective array operations. +-- A term of type @Acc a@ is an Accelerate program which, once executed, will +-- produce a value of type 'a' (an 'Array' or a tuple of 'Arrays'). Collective +-- operations of type @Acc a@ comprise many /scalar expressions/, wrapped in +-- type constructor 'Exp', which will be executed in parallel. Although +-- collective operations comprise many scalar operations executed in parallel, +-- scalar operations /cannot/ initiate new collective operations: this +-- stratification between scalar operations in 'Exp' and array operations in +-- 'Acc' helps statically exclude /nested data parallelism/, which is difficult +-- to execute efficiently on constrained hardware such as GPUs. +-- +-- For example, to compute a vector dot product we could write: +-- +-- > dotp :: Num a => Vector a -> Vector a -> Acc (Scalar a) +-- > dotp xs ys = +-- > let +-- > xs' = use xs +-- > ys' = use ys +-- > in +-- > fold (+) 0 ( zipWith (*) xs' ys' ) +-- +-- The function @dotp@ consumes two one-dimensional arrays ('Vector's) of +-- values, and produces a single ('Scalar') result as output. As the return type +-- is wrapped in the type 'Acc', we see that it is an embedded Accelerate +-- computation - it will be evaluated in the /object/ language of dynamically +-- generated parallel code, rather than the /meta/ language of vanilla Haskell. +-- +-- As the arguments to @dotp@ are plain Haskell arrays, to make these available +-- to Accelerate computations they must be embedded with the +-- 'Data.Array.Accelerate.Language.use' function. +-- +-- An Accelerate backend is used to evaluate the embedded computation and return +-- the result back to vanilla Haskell. Calling the 'run' function of a backend +-- will generate code for the target architecture, compile, and execute it. For +-- example, the following backends are available: +-- +-- * : for execution on multicore CPUs +-- * : for execution on NVIDIA CUDA-capable GPUs +-- +-- See also 'Exp', which encapsulates embedded /scalar/ computations. +-- +-- [/Fusion:/] +-- +-- Array computations of type 'Acc' will be subject to /array fusion/; +-- Accelerate will combine individual 'Acc' computations into a single +-- computation, which reduces the number of traversals over the input data and +-- thus improves performance. As such, it is often useful to have some intuition +-- on when fusion should occur. +-- +-- The main idea is to first partition array operations into two categories: +-- +-- 1. Element-wise operations, such as 'Data.Array.Accelerate.map', +-- 'Data.Array.Accelerate.generate', and +-- 'Data.Array.Accelerate.backpermute'. Each element of these operations +-- can be computed independently of all others. +-- +-- 2. Collective operations such as 'Data.Array.Accelerate.fold', +-- 'Data.Array.Accelerate.scanl', and 'Data.Array.Accelerate.stencil'. To +-- compute each output element of these operations requires reading +-- multiple elements from the input array(s). +-- +-- Element-wise operations fuse together whenever the consumer operation uses +-- a single element of the input array. Element-wise operations can both fuse +-- their inputs into themselves, as well be fused into later operations. Both +-- these examples should fuse into a single loop: +-- +-- > map -> reverse -> reshape -> map -> map +-- +-- > map -> backpermute -> +-- > zipWith -> map +-- > generate -> +-- +-- If the consumer operation uses more than one element of the input array +-- (typically, via 'Data.Array.Accelerate.generate' indexing an array multiple +-- times), then the input array will be completely evaluated first; no fusion +-- occurs in this case, because fusing the first operation into the second +-- implies duplicating work. +-- +-- On the other hand, collective operations can fuse their input arrays into +-- themselves, but on output always evaluate to an array; collective operations +-- will not be fused into a later step. For example: +-- +-- > use -> +-- > zipWith -> fold |-> map +-- > generate -> +-- +-- Here the element-wise sequence ('Data.Array.Accelerate.use' +-- + 'Data.Array.Accelerate.generate' + 'Data.Array.Accelerate.zipWith') will +-- fuse into a single operation, which then fuses into the collective +-- 'Data.Array.Accelerate.fold' operation. At this point in the program the +-- 'Data.Array.Accelerate.fold' must now be evaluated. In the final step the +-- 'Data.Array.Accelerate.map' reads in the array produced by +-- 'Data.Array.Accelerate.fold'. As there is no fusion between the +-- 'Data.Array.Accelerate.fold' and 'Data.Array.Accelerate.map' steps, this +-- program consists of two "loops"; one for the 'Data.Array.Accelerate.use' +-- + 'Data.Array.Accelerate.generate' + 'Data.Array.Accelerate.zipWith' +-- + 'Data.Array.Accelerate.fold' step, and one for the final +-- 'Data.Array.Accelerate.map' step. +-- +-- You can see how many operations will be executed in the fused program by +-- 'Show'-ing the 'Acc' program, or by using the debugging option @-ddump-dot@ +-- to save the program as a graphviz DOT file. +-- +-- As a special note, the operations 'Data.Array.Accelerate.unzip' and +-- 'Data.Array.Accelerate.reshape', when applied to a real array, are executed +-- in constant time, so in this situation these operations will not be fused. +-- +-- [/Tips:/] +-- +-- * Since 'Acc' represents embedded computations that will only be executed +-- when evaluated by a backend, we can programatically generate these +-- computations using the meta language Haskell; for example, unrolling loops +-- or embedding input values into the generated code. +-- +-- * It is usually best to keep all intermediate computations in 'Acc', and +-- only 'run' the computation at the very end to produce the final result. +-- This enables optimisations between intermediate results (e.g. array +-- fusion) and, if the target architecture has a separate memory space as is +-- the case of GPUs, to prevent excessive data transfers. +-- +newtype Acc a = Acc (PreAcc Acc Exp a) +deriving instance Typeable Acc + + +-- The level of lambda-bound variables. The root has level 0; then it increases with each bound +-- variable — i.e., it is the same as the size of the environment at the defining occurrence. +-- +type Level = Int + +-- | Array-valued collective computations without a recursive knot +-- +data PreAcc acc exp as where + -- Needed for conversion to de Bruijn form + Atag :: Arrays as + => Level -- environment size at defining occurrence + -> PreAcc acc exp as + + Pipe :: (Arrays as, Arrays bs, Arrays cs) + => (Acc as -> acc bs) + -> (Acc bs -> acc cs) + -> acc as + -> PreAcc acc exp cs + + Aforeign :: (Arrays as, Arrays bs, Foreign asm) + => asm (as -> bs) + -> (Acc as -> Acc bs) + -> acc as + -> PreAcc acc exp bs + + Acond :: Arrays as + => exp Bool + -> acc as + -> acc as + -> PreAcc acc exp as + + Awhile :: Arrays arrs + => (Acc arrs -> acc (Scalar Bool)) + -> (Acc arrs -> acc arrs) + -> acc arrs + -> PreAcc acc exp arrs + + Atuple :: (Arrays arrs, IsAtuple arrs) + => Atuple acc (TupleRepr arrs) + -> PreAcc acc exp arrs + + Aprj :: (Arrays arrs, IsAtuple arrs, Arrays a) + => TupleIdx (TupleRepr arrs) a + -> acc arrs + -> PreAcc acc exp a + + Use :: Arrays arrs + => arrs + -> PreAcc acc exp arrs + + Unit :: Elt e + => exp e + -> PreAcc acc exp (Scalar e) + + Generate :: (Shape sh, Elt e) + => exp sh + -> (Exp sh -> exp e) + -> PreAcc acc exp (Array sh e) + + Reshape :: (Shape sh, Shape sh', Elt e) + => exp sh + -> acc (Array sh' e) + -> PreAcc acc exp (Array sh e) + + Replicate :: (Slice slix, Elt e) + => exp slix + -> acc (Array (SliceShape slix) e) + -> PreAcc acc exp (Array (FullShape slix) e) + + Slice :: (Slice slix, Elt e) + => acc (Array (FullShape slix) e) + -> exp slix + -> PreAcc acc exp (Array (SliceShape slix) e) + + Map :: (Shape sh, Elt e, Elt e') + => (Exp e -> exp e') + -> acc (Array sh e) + -> PreAcc acc exp (Array sh e') + + ZipWith :: (Shape sh, Elt e1, Elt e2, Elt e3) + => (Exp e1 -> Exp e2 -> exp e3) + -> acc (Array sh e1) + -> acc (Array sh e2) + -> PreAcc acc exp (Array sh e3) + + Fold :: (Shape sh, Elt e) + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Array (sh:.Int) e) + -> PreAcc acc exp (Array sh e) + + Fold1 :: (Shape sh, Elt e) + => (Exp e -> Exp e -> exp e) + -> acc (Array (sh:.Int) e) + -> PreAcc acc exp (Array sh e) + + FoldSeg :: (Shape sh, Elt e, Elt i, IsIntegral i) + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Array (sh:.Int) e) + -> acc (Segments i) + -> PreAcc acc exp (Array (sh:.Int) e) + + Fold1Seg :: (Shape sh, Elt e, Elt i, IsIntegral i) + => (Exp e -> Exp e -> exp e) + -> acc (Array (sh:.Int) e) + -> acc (Segments i) + -> PreAcc acc exp (Array (sh:.Int) e) + + Scanl :: (Shape sh, Elt e) + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Array (sh :. Int) e) + -> PreAcc acc exp (Array (sh :. Int) e) + + Scanl' :: (Shape sh, Elt e) + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Array (sh :. Int) e) + -> PreAcc acc exp (Array (sh :. Int) e, Array sh e) + + Scanl1 :: (Shape sh, Elt e) + => (Exp e -> Exp e -> exp e) + -> acc (Array (sh :. Int) e) + -> PreAcc acc exp (Array (sh :. Int) e) + + Scanr :: (Shape sh, Elt e) + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Array (sh :. Int) e) + -> PreAcc acc exp (Array (sh :. Int) e) + + Scanr' :: (Shape sh, Elt e) + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Array (sh :. Int) e) + -> PreAcc acc exp (Array (sh :. Int) e, Array sh e) + + Scanr1 :: (Shape sh, Elt e) + => (Exp e -> Exp e -> exp e) + -> acc (Array (sh :. Int) e) + -> PreAcc acc exp (Array (sh :. Int) e) + + Permute :: (Shape sh, Shape sh', Elt e) + => (Exp e -> Exp e -> exp e) + -> acc (Array sh' e) + -> (Exp sh -> exp sh') + -> acc (Array sh e) + -> PreAcc acc exp (Array sh' e) + + Backpermute :: (Shape sh, Shape sh', Elt e) + => exp sh' + -> (Exp sh' -> exp sh) + -> acc (Array sh e) + -> PreAcc acc exp (Array sh' e) + + Stencil :: (Shape sh, Elt a, Elt b, Stencil sh a stencil) + => (stencil -> exp b) + -> PreBoundary acc exp (Array sh a) + -> acc (Array sh a) + -> PreAcc acc exp (Array sh b) + + Stencil2 :: (Shape sh, Elt a, Elt b, Elt c, Stencil sh a stencil1, Stencil sh b stencil2) + => (stencil1 -> stencil2 -> exp c) + -> PreBoundary acc exp (Array sh a) + -> acc (Array sh a) + -> PreBoundary acc exp (Array sh b) + -> acc (Array sh b) + -> PreAcc acc exp (Array sh c) + + -- Collect :: Arrays arrs + -- => seq arrs + -- -> PreAcc acc seq exp arrs + + +{-- +data PreSeq acc seq exp arrs where + -- Convert the given Haskell-list of arrays to a sequence. + StreamIn :: Arrays a + => [a] + -> PreSeq acc seq exp [a] + + -- Convert the given array to a sequence. + -- Example: + -- slix = Z :. All :. Split :. All :. All :. Split + -- ^ ^ ^ ^ ^ + -- | \ / / | + -- | \___/______/_______ Iteration space. + -- | / / + -- Element________/______/ + -- shape. + -- + ToSeq :: ( Elt e + , Slice slix + , Division slsix + , DivisionSlice slsix ~ slix + , Typeable (FullShape slix) + , Typeable (SliceShape slix) + ) + => slsix + -> acc (Array (FullShape slix) e) + -> PreSeq acc seq exp [Array (SliceShape slix) e] + + -- Apply the given the given function to all elements of the given sequence. + MapSeq :: (Arrays a, Arrays b) + => (Acc a -> acc b) + -> seq [a] + -> PreSeq acc seq exp [b] + + -- Apply a given binary function pairwise to all elements of the given sequences. + -- The length of the result is the length of the shorter of the two argument + -- arrays. + ZipWithSeq :: (Arrays a, Arrays b, Arrays c) + => (Acc a -> Acc b -> acc c) + -> seq [a] + -> seq [b] + -> PreSeq acc seq exp [c] + + -- ScanSeq (+) a0 x. Scan a sequence x by combining each element + -- using the given binary operation (+). (+) must be associative: + -- + -- Forall a b c. (a + b) + c = a + (b + c), + -- + -- and a0 must be the identity element for (+): + -- + -- Forall a. a0 + a = a = a + a0. + -- + ScanSeq :: Elt a + => (Exp a -> Exp a -> exp a) + -> exp a + -> seq [Scalar a] + -> PreSeq acc seq exp [Scalar a] + + -- FoldSeq (+) a0 x. Fold a sequence x by combining each element + -- using the given binary operation (+). (+) must be associative: + -- + -- Forall a b c. (a + b) + c = a + (b + c), + -- + -- and a0 must be the identity element for (+): + -- + -- Forall a. a0 + a = a = a + a0. + -- + FoldSeq :: Elt a + => (Exp a -> Exp a -> exp a) + -> exp a + -> seq [Scalar a] + -> PreSeq acc seq exp (Scalar a) + + -- FoldSeqFlatten f a0 x. A specialized version of FoldSeqAct + -- where reduction with the companion operator corresponds to + -- flattening. f must be semi-associative, with vecotor append (++) + -- as the companion operator: + -- + -- Forall b s1 a2 sh2 a2. + -- f (f b sh1 a1) sh2 a2 = f b (sh1 ++ sh2) (a1 ++ a2). + -- + -- It is common to ignore the shape vectors, yielding the usual + -- semi-associativity law: + -- + -- f b a _ = b + a, + -- + -- for some (+) satisfying: + -- + -- Forall b a1 a2. (b + a1) + a2 = b + (a1 ++ a2). + -- + FoldSeqFlatten :: (Arrays a, Shape sh, Elt e) + => (Acc a -> Acc (Vector sh) -> Acc (Vector e) -> acc a) + -> acc a + -> seq [Array sh e] + -> PreSeq acc seq exp a + + -- Tuple up the results of a sequence computation. Note that the Arrays + -- constraint requires that the elements of the tuple are Arrays, not + -- streams ([]). + Stuple :: (Arrays arrs, IsAtuple arrs) + => Atuple (seq) (TupleRepr arrs) + -> PreSeq acc seq exp arrs + +-- |Array-valued sequence computations +-- +newtype Seq a = Seq (PreSeq Acc Seq Exp a) + +deriving instance Typeable Seq +--} + + +-- Embedded expressions of the surface language +-- -------------------------------------------- + +-- HOAS expressions mirror the constructors of 'AST.OpenExp', but with the 'Tag' +-- constructor instead of variables in the form of de Bruijn indices. Moreover, +-- HOAS expression use n-tuples and the type class 'Elt' to constrain element +-- types, whereas 'AST.OpenExp' uses nested pairs and the GADT 'TupleType'. +-- + +-- | The type 'Exp' represents embedded scalar expressions. The collective +-- operations of Accelerate 'Acc' consist of many scalar expressions executed in +-- data-parallel. +-- +-- Note that scalar expressions can not initiate new collective operations: +-- doing so introduces /nested data parallelism/, which is difficult to execute +-- efficiently on constrained hardware such as GPUs, and is thus currently +-- unsupported. +-- +newtype Exp t = Exp (PreExp Acc Exp t) + +deriving instance Typeable Exp + +-- | Scalar expressions to parametrise collective array operations, themselves parameterised over +-- the type of collective array operations. +-- +data PreExp acc exp t where + -- Needed for conversion to de Bruijn form + Tag :: Elt t + => Level -- environment size at defining occurrence + -> PreExp acc exp t + + -- All the same constructors as 'AST.Exp' + Const :: Elt t + => t + -> PreExp acc exp t + + Tuple :: (Elt t, IsTuple t) + => Tuple exp (TupleRepr t) + -> PreExp acc exp t + + Prj :: (Elt t, IsTuple t, Elt e) + => TupleIdx (TupleRepr t) e + -> exp t + -> PreExp acc exp e + + IndexNil :: PreExp acc exp Z + + IndexCons :: (Slice sl, Elt a) + => exp sl + -> exp a + -> PreExp acc exp (sl:.a) + + IndexHead :: (Slice sl, Elt a) + => exp (sl:.a) + -> PreExp acc exp a + + IndexTail :: (Slice sl, Elt a) + => exp (sl:.a) + -> PreExp acc exp sl + + IndexAny :: Shape sh + => PreExp acc exp (Any sh) + + ToIndex :: Shape sh + => exp sh + -> exp sh + -> PreExp acc exp Int + + FromIndex :: Shape sh + => exp sh + -> exp Int + -> PreExp acc exp sh + + Cond :: Elt t + => exp Bool + -> exp t + -> exp t + -> PreExp acc exp t + + While :: Elt t + => (Exp t -> exp Bool) + -> (Exp t -> exp t) + -> exp t + -> PreExp acc exp t + + PrimConst :: Elt t + => PrimConst t + -> PreExp acc exp t + + PrimApp :: (Elt a, Elt r) + => PrimFun (a -> r) + -> exp a + -> PreExp acc exp r + + Index :: (Shape sh, Elt t) + => acc (Array sh t) + -> exp sh + -> PreExp acc exp t + + LinearIndex :: (Shape sh, Elt t) + => acc (Array sh t) + -> exp Int + -> PreExp acc exp t + + Shape :: (Shape sh, Elt e) + => acc (Array sh e) + -> PreExp acc exp sh + + ShapeSize :: Shape sh + => exp sh + -> PreExp acc exp Int + + Intersect :: Shape sh + => exp sh + -> exp sh + -> PreExp acc exp sh + + Union :: Shape sh + => exp sh + -> exp sh + -> PreExp acc exp sh + + Foreign :: (Elt x, Elt y, Foreign asm) + => asm (x -> y) + -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery. + -> exp x + -> PreExp acc exp y + + +-- Smart constructors and destructors for array tuples +-- --------------------------------------------------- + +atup2 :: (Arrays a, Arrays b) + => (Acc a, Acc b) + -> Acc (a, b) +atup2 (a, b) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + +atup3 :: (Arrays a, Arrays b, Arrays c) + => (Acc a, Acc b, Acc c) + -> Acc (a, b, c) +atup3 (a, b, c) + = Acc $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + +atup4 :: (Arrays a, Arrays b, Arrays c, Arrays d) + => (Acc a, Acc b, Acc c, Acc d) + -> Acc (a, b, c, d) +atup4 (a, b, c, d) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + +atup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) + => (Acc a, Acc b, Acc c, Acc d, Acc e) + -> Acc (a, b, c, d, e) +atup5 (a, b, c, d, e) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + +atup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) + -> Acc (a, b, c, d, e, f) +atup6 (a, b, c, d, e, f) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + +atup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) + -> Acc (a, b, c, d, e, f, g) +atup7 (a, b, c, d, e, f, g) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + +atup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) + -> Acc (a, b, c, d, e, f, g, h) +atup8 (a, b, c, d, e, f, g, h) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + `SnocAtup` h + +atup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) + -> Acc (a, b, c, d, e, f, g, h, i) +atup9 (a, b, c, d, e, f, g, h, i) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + `SnocAtup` h + `SnocAtup` i + +atup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j) + -> Acc (a, b, c, d, e, f, g, h, i, j) +atup10 (a, b, c, d, e, f, g, h, i, j) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + `SnocAtup` h + `SnocAtup` i + `SnocAtup` j + +atup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k) + -> Acc (a, b, c, d, e, f, g, h, i, j, k) +atup11 (a, b, c, d, e, f, g, h, i, j, k) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + `SnocAtup` h + `SnocAtup` i + `SnocAtup` j + `SnocAtup` k + +atup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l) + -> Acc (a, b, c, d, e, f, g, h, i, j, k, l) +atup12 (a, b, c, d, e, f, g, h, i, j, k, l) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + `SnocAtup` h + `SnocAtup` i + `SnocAtup` j + `SnocAtup` k + `SnocAtup` l + +atup13 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m) + -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m) +atup13 (a, b, c, d, e, f, g, h, i, j, k, l, m) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + `SnocAtup` h + `SnocAtup` i + `SnocAtup` j + `SnocAtup` k + `SnocAtup` l + `SnocAtup` m + +atup14 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n) + -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +atup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + `SnocAtup` h + `SnocAtup` i + `SnocAtup` j + `SnocAtup` k + `SnocAtup` l + `SnocAtup` m + `SnocAtup` n + +atup15 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n, Arrays o) + => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o) + -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) +atup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + = Acc + $ Atuple + $ NilAtup `SnocAtup` a + `SnocAtup` b + `SnocAtup` c + `SnocAtup` d + `SnocAtup` e + `SnocAtup` f + `SnocAtup` g + `SnocAtup` h + `SnocAtup` i + `SnocAtup` j + `SnocAtup` k + `SnocAtup` l + `SnocAtup` m + `SnocAtup` n + `SnocAtup` o + +unatup2 :: (Arrays a, Arrays b) + => Acc (a, b) + -> (Acc a, Acc b) +unatup2 e = + ( Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup3 :: (Arrays a, Arrays b, Arrays c) + => Acc (a, b, c) + -> (Acc a, Acc b, Acc c) +unatup3 e = + ( Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup4 + :: (Arrays a, Arrays b, Arrays c, Arrays d) + => Acc (a, b, c, d) + -> (Acc a, Acc b, Acc c, Acc d) +unatup4 e = + ( Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup5 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) + => Acc (a, b, c, d, e) + -> (Acc a, Acc b, Acc c, Acc d, Acc e) +unatup5 e = + ( Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup6 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) + => Acc (a, b, c, d, e, f) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) +unatup6 e = + ( Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup7 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) + => Acc (a, b, c, d, e, f, g) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) +unatup7 e = + ( Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup8 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h) + => Acc (a, b, c, d, e, f, g, h) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) +unatup8 e = + ( Acc $ tix7 `Aprj` e + , Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup9 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i) + => Acc (a, b, c, d, e, f, g, h, i) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) +unatup9 e = + ( Acc $ tix8 `Aprj` e + , Acc $ tix7 `Aprj` e + , Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup10 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j) + => Acc (a, b, c, d, e, f, g, h, i, j) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j) +unatup10 e = + ( Acc $ tix9 `Aprj` e + , Acc $ tix8 `Aprj` e + , Acc $ tix7 `Aprj` e + , Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup11 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k) + => Acc (a, b, c, d, e, f, g, h, i, j, k) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k) +unatup11 e = + ( Acc $ tix10 `Aprj` e + , Acc $ tix9 `Aprj` e + , Acc $ tix8 `Aprj` e + , Acc $ tix7 `Aprj` e + , Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup12 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l) + => Acc (a, b, c, d, e, f, g, h, i, j, k, l) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l) +unatup12 e = + ( Acc $ tix11 `Aprj` e + , Acc $ tix10 `Aprj` e + , Acc $ tix9 `Aprj` e + , Acc $ tix8 `Aprj` e + , Acc $ tix7 `Aprj` e + , Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup13 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m) + => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m) +unatup13 e = + ( Acc $ tix12 `Aprj` e + , Acc $ tix11 `Aprj` e + , Acc $ tix10 `Aprj` e + , Acc $ tix9 `Aprj` e + , Acc $ tix8 `Aprj` e + , Acc $ tix7 `Aprj` e + , Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup14 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n) + => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n) +unatup14 e = + ( Acc $ tix13 `Aprj` e + , Acc $ tix12 `Aprj` e + , Acc $ tix11 `Aprj` e + , Acc $ tix10 `Aprj` e + , Acc $ tix9 `Aprj` e + , Acc $ tix8 `Aprj` e + , Acc $ tix7 `Aprj` e + , Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + +unatup15 + :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n, Arrays o) + => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o) +unatup15 e = + ( Acc $ tix14 `Aprj` e + , Acc $ tix13 `Aprj` e + , Acc $ tix12 `Aprj` e + , Acc $ tix11 `Aprj` e + , Acc $ tix10 `Aprj` e + , Acc $ tix9 `Aprj` e + , Acc $ tix8 `Aprj` e + , Acc $ tix7 `Aprj` e + , Acc $ tix6 `Aprj` e + , Acc $ tix5 `Aprj` e + , Acc $ tix4 `Aprj` e + , Acc $ tix3 `Aprj` e + , Acc $ tix2 `Aprj` e + , Acc $ tix1 `Aprj` e + , Acc $ tix0 `Aprj` e ) + + +-- Smart constructors for stencils +-- ------------------------------- + +-- | Boundary condition specification for stencil operations +-- +newtype Boundary t = Boundary (PreBoundary Acc Exp t) + +data PreBoundary acc exp t where + Clamp :: PreBoundary acc exp t + Mirror :: PreBoundary acc exp t + Wrap :: PreBoundary acc exp t + + Constant :: Elt e + => e + -> PreBoundary acc exp (Array sh e) + + Function :: (Shape sh, Elt e) + => (Exp sh -> exp e) + -> PreBoundary acc exp (Array sh e) + + +-- Stencil reification +-- +-- In the AST representation, we turn the stencil type from nested tuples of Accelerate expressions +-- into an Accelerate expression whose type is a tuple nested in the same manner. This enables us +-- to represent the stencil function as a unary function (which also only needs one de Bruijn +-- index). The various positions in the stencil are accessed via tuple indices (i.e., projections). +-- +class (Elt (StencilRepr sh stencil), AST.Stencil sh a (StencilRepr sh stencil)) => Stencil sh a stencil where + type StencilRepr sh stencil :: * + stencilPrj :: {-dummy-} sh + -> {-dummy-} a + -> Exp (StencilRepr sh stencil) + -> stencil + +-- DIM1 +instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e) where + type StencilRepr DIM1 (Exp e, Exp e, Exp e) + = (e, e, e) + stencilPrj _ _ s = (Exp $ Prj tix2 s, + Exp $ Prj tix1 s, + Exp $ Prj tix0 s) + +instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e) where + type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e) + = (e, e, e, e, e) + stencilPrj _ _ s = (Exp $ Prj tix4 s, + Exp $ Prj tix3 s, + Exp $ Prj tix2 s, + Exp $ Prj tix1 s, + Exp $ Prj tix0 s) + +instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) where + type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) + = (e, e, e, e, e, e, e) + stencilPrj _ _ s = (Exp $ Prj tix6 s, + Exp $ Prj tix5 s, + Exp $ Prj tix4 s, + Exp $ Prj tix3 s, + Exp $ Prj tix2 s, + Exp $ Prj tix1 s, + Exp $ Prj tix0 s) + +instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) + where + type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) + = (e, e, e, e, e, e, e, e, e) + stencilPrj _ _ s = (Exp $ Prj tix8 s, + Exp $ Prj tix7 s, + Exp $ Prj tix6 s, + Exp $ Prj tix5 s, + Exp $ Prj tix4 s, + Exp $ Prj tix3 s, + Exp $ Prj tix2 s, + Exp $ Prj tix1 s, + Exp $ Prj tix0 s) + +-- DIM(n+1) +instance (Stencil (sh:.Int) a row2, + Stencil (sh:.Int) a row1, + Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row2, row1, row0) where + type StencilRepr (sh:.Int:.Int) (row2, row1, row0) + = (StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row0) + stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s)) + +instance (Stencil (sh:.Int) a row1, + Stencil (sh:.Int) a row2, + Stencil (sh:.Int) a row3, + Stencil (sh:.Int) a row4, + Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where + type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5) + = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3, + StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5) + stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s)) + +instance (Stencil (sh:.Int) a row1, + Stencil (sh:.Int) a row2, + Stencil (sh:.Int) a row3, + Stencil (sh:.Int) a row4, + Stencil (sh:.Int) a row5, + Stencil (sh:.Int) a row6, + Stencil (sh:.Int) a row7) + => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where + type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7) + = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3, + StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6, + StencilRepr (sh:.Int) row7) + stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s)) + +instance (Stencil (sh:.Int) a row1, + Stencil (sh:.Int) a row2, + Stencil (sh:.Int) a row3, + Stencil (sh:.Int) a row4, + Stencil (sh:.Int) a row5, + Stencil (sh:.Int) a row6, + Stencil (sh:.Int) a row7, + Stencil (sh:.Int) a row8, + Stencil (sh:.Int) a row9) + => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where + type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7, row8, row9) + = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3, + StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6, + StencilRepr (sh:.Int) row7, StencilRepr (sh:.Int) row8, StencilRepr (sh:.Int) row9) + stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix8 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix7 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s), + stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s)) + +-- Auxiliary tuple index constants +-- +tix0 :: TupleIdx (t, s0) s0 +tix0 = ZeroTupIdx + +tix1 :: TupleIdx ((t, s1), s0) s1 +tix1 = SuccTupIdx tix0 + +tix2 :: TupleIdx (((t, s2), s1), s0) s2 +tix2 = SuccTupIdx tix1 + +tix3 :: TupleIdx ((((t, s3), s2), s1), s0) s3 +tix3 = SuccTupIdx tix2 + +tix4 :: TupleIdx (((((t, s4), s3), s2), s1), s0) s4 +tix4 = SuccTupIdx tix3 + +tix5 :: TupleIdx ((((((t, s5), s4), s3), s2), s1), s0) s5 +tix5 = SuccTupIdx tix4 + +tix6 :: TupleIdx (((((((t, s6), s5), s4), s3), s2), s1), s0) s6 +tix6 = SuccTupIdx tix5 + +tix7 :: TupleIdx ((((((((t, s7), s6), s5), s4), s3), s2), s1), s0) s7 +tix7 = SuccTupIdx tix6 + +tix8 :: TupleIdx (((((((((t, s8), s7), s6), s5), s4), s3), s2), s1), s0) s8 +tix8 = SuccTupIdx tix7 + +tix9 :: TupleIdx ((((((((((t, s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s9 +tix9 = SuccTupIdx tix8 + +tix10 :: TupleIdx (((((((((((t, s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s10 +tix10 = SuccTupIdx tix9 + +tix11 :: TupleIdx ((((((((((((t, s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s11 +tix11 = SuccTupIdx tix10 + +tix12 :: TupleIdx (((((((((((((t, s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s12 +tix12 = SuccTupIdx tix11 + +tix13 :: TupleIdx ((((((((((((((t, s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s13 +tix13 = SuccTupIdx tix12 + +tix14 :: TupleIdx (((((((((((((((t, s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s14 +tix14 = SuccTupIdx tix13 + +{-- +-- Smart constructors for array tuples in sequence computations +-- --------------------------------------------------- + +stup2 :: (Arrays a, Arrays b) => (Seq a, Seq b) -> Seq (a, b) +stup2 (a, b) = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b) + +stup3 :: (Arrays a, Arrays b, Arrays c) => (Seq a, Seq b, Seq c) -> Seq (a, b, c) +stup3 (a, b, c) = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c) + +stup4 :: (Arrays a, Arrays b, Arrays c, Arrays d) + => (Seq a, Seq b, Seq c, Seq d) -> Seq (a, b, c, d) +stup4 (a, b, c, d) + = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d) + +stup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) + => (Seq a, Seq b, Seq c, Seq d, Seq e) -> Seq (a, b, c, d, e) +stup5 (a, b, c, d, e) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e + +stup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f) -> Seq (a, b, c, d, e, f) +stup6 (a, b, c, d, e, f) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c + `SnocAtup` d `SnocAtup` e `SnocAtup` f + +stup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g) + -> Seq (a, b, c, d, e, f, g) +stup7 (a, b, c, d, e, f, g) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c + `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g + +stup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h) + -> Seq (a, b, c, d, e, f, g, h) +stup8 (a, b, c, d, e, f, g, h) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d + `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h + +stup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i) + -> Seq (a, b, c, d, e, f, g, h, i) +stup9 (a, b, c, d, e, f, g, h, i) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d + `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i + +stup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j) + -> Seq (a, b, c, d, e, f, g, h, i, j) +stup10 (a, b, c, d, e, f, g, h, i, j) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e + `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j + +stup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k) + -> Seq (a, b, c, d, e, f, g, h, i, j, k) +stup11 (a, b, c, d, e, f, g, h, i, j, k) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e + `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k + +stup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l) + -> Seq (a, b, c, d, e, f, g, h, i, j, k, l) +stup12 (a, b, c, d, e, f, g, h, i, j, k, l) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f + `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l + +stup13 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m) + -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m) +stup13 (a, b, c, d, e, f, g, h, i, j, k, l, m) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f + `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m + +stup14 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m, Seq n) + -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +stup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g + `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n + +stup15 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n, Arrays o) + => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m, Seq n, Seq o) + -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) +stup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + = Seq $ Stuple $ + NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g + `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n `SnocAtup` o +--} + +-- Smart constructor for literals +-- + +-- | Scalar expression inlet: make a Haskell value available for processing in +-- an Accelerate scalar expression. +-- +-- Note that this embeds the value directly into the expression. Depending on +-- the backend used to execute the computation, this might not always be +-- desirable. For example, a backend that does external code generation may +-- embed this constant directly into the generated code, which means new code +-- will need to be generated and compiled every time the value changes. In such +-- cases, consider instead lifting scalar values into (singleton) arrays so that +-- they can be passed as an input to the computation and thus the value can +-- change without the need to generate fresh code. +-- +constant :: Elt t => t -> Exp t +constant = Exp . Const + +-- Smart constructor and destructors for scalar tuples +-- +tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b) +tup2 (a, b) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + +tup3 :: (Elt a, Elt b, Elt c) + => (Exp a, Exp b, Exp c) + -> Exp (a, b, c) +tup3 (a, b, c) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + +tup4 :: (Elt a, Elt b, Elt c, Elt d) + => (Exp a, Exp b, Exp c, Exp d) + -> Exp (a, b, c, d) +tup4 (a, b, c, d) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + +tup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e) + => (Exp a, Exp b, Exp c, Exp d, Exp e) + -> Exp (a, b, c, d, e) +tup5 (a, b, c, d, e) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + +tup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) + -> Exp (a, b, c, d, e, f) +tup6 (a, b, c, d, e, f) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + +tup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) + -> Exp (a, b, c, d, e, f, g) +tup7 (a, b, c, d, e, f, g) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + +tup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) + -> Exp (a, b, c, d, e, f, g, h) +tup8 (a, b, c, d, e, f, g, h) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + `SnocTup` h + +tup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) + -> Exp (a, b, c, d, e, f, g, h, i) +tup9 (a, b, c, d, e, f, g, h, i) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + `SnocTup` h + `SnocTup` i + +tup10 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j) + -> Exp (a, b, c, d, e, f, g, h, i, j) +tup10 (a, b, c, d, e, f, g, h, i, j) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + `SnocTup` h + `SnocTup` i + `SnocTup` j + +tup11 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k) + -> Exp (a, b, c, d, e, f, g, h, i, j, k) +tup11 (a, b, c, d, e, f, g, h, i, j, k) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + `SnocTup` h + `SnocTup` i + `SnocTup` j + `SnocTup` k + +tup12 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l) + -> Exp (a, b, c, d, e, f, g, h, i, j, k, l) +tup12 (a, b, c, d, e, f, g, h, i, j, k, l) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + `SnocTup` h + `SnocTup` i + `SnocTup` j + `SnocTup` k + `SnocTup` l + +tup13 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m) + -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m) +tup13 (a, b, c, d, e, f, g, h, i, j, k, l, m) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + `SnocTup` h + `SnocTup` i + `SnocTup` j + `SnocTup` k + `SnocTup` l + `SnocTup` m + +tup14 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n) + -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +tup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + `SnocTup` h + `SnocTup` i + `SnocTup` j + `SnocTup` k + `SnocTup` l + `SnocTup` m + `SnocTup` n + +tup15 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n, Elt o) + => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o) + -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) +tup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + = Exp + $ Tuple + $ NilTup `SnocTup` a + `SnocTup` b + `SnocTup` c + `SnocTup` d + `SnocTup` e + `SnocTup` f + `SnocTup` g + `SnocTup` h + `SnocTup` i + `SnocTup` j + `SnocTup` k + `SnocTup` l + `SnocTup` m + `SnocTup` n + `SnocTup` o + +untup2 :: (Elt a, Elt b) => Exp (a, b) -> (Exp a, Exp b) +untup2 e = + ( Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup3 :: (Elt a, Elt b, Elt c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c) +untup3 e = + ( Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup4 :: (Elt a, Elt b, Elt c, Elt d) + => Exp (a, b, c, d) + -> (Exp a, Exp b, Exp c, Exp d) +untup4 e = + ( Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e) + => Exp (a, b, c, d, e) + -> (Exp a, Exp b, Exp c, Exp d, Exp e) +untup5 e = + ( Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) + => Exp (a, b, c, d, e, f) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) +untup6 e = + ( Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) + => Exp (a, b, c, d, e, f, g) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) +untup7 e = + ( Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) + => Exp (a, b, c, d, e, f, g, h) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) +untup8 e = + ( Exp $ tix7 `Prj` e + , Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) + => Exp (a, b, c, d, e, f, g, h, i) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) +untup9 e = + ( Exp $ tix8 `Prj` e + , Exp $ tix7 `Prj` e + , Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup10 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j) + => Exp (a, b, c, d, e, f, g, h, i, j) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j) +untup10 e = + ( Exp $ tix9 `Prj` e + , Exp $ tix8 `Prj` e + , Exp $ tix7 `Prj` e + , Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup11 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k) + => Exp (a, b, c, d, e, f, g, h, i, j, k) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k) +untup11 e = + ( Exp $ tix10 `Prj` e + , Exp $ tix9 `Prj` e + , Exp $ tix8 `Prj` e + , Exp $ tix7 `Prj` e + , Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup12 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l) + => Exp (a, b, c, d, e, f, g, h, i, j, k, l) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l) +untup12 e = + ( Exp $ tix11 `Prj` e + , Exp $ tix10 `Prj` e + , Exp $ tix9 `Prj` e + , Exp $ tix8 `Prj` e + , Exp $ tix7 `Prj` e + , Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup13 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m) + => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m) +untup13 e = + ( Exp $ tix12 `Prj` e + , Exp $ tix11 `Prj` e + , Exp $ tix10 `Prj` e + , Exp $ tix9 `Prj` e + , Exp $ tix8 `Prj` e + , Exp $ tix7 `Prj` e + , Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup14 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n) + => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n) +untup14 e = + ( Exp $ tix13 `Prj` e + , Exp $ tix12 `Prj` e + , Exp $ tix11 `Prj` e + , Exp $ tix10 `Prj` e + , Exp $ tix9 `Prj` e + , Exp $ tix8 `Prj` e + , Exp $ tix7 `Prj` e + , Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + +untup15 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n, Elt o) + => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o) +untup15 e = + ( Exp $ tix14 `Prj` e + , Exp $ tix13 `Prj` e + , Exp $ tix12 `Prj` e + , Exp $ tix11 `Prj` e + , Exp $ tix10 `Prj` e + , Exp $ tix9 `Prj` e + , Exp $ tix8 `Prj` e + , Exp $ tix7 `Prj` e + , Exp $ tix6 `Prj` e + , Exp $ tix5 `Prj` e + , Exp $ tix4 `Prj` e + , Exp $ tix3 `Prj` e + , Exp $ tix2 `Prj` e + , Exp $ tix1 `Prj` e + , Exp $ tix0 `Prj` e ) + + +-- Smart constructor for constants +-- + +mkMinBound :: (Elt t, IsBounded t) => Exp t +mkMinBound = Exp $ PrimConst (PrimMinBound boundedType) + +mkMaxBound :: (Elt t, IsBounded t) => Exp t +mkMaxBound = Exp $ PrimConst (PrimMaxBound boundedType) + +mkPi :: (Elt r, IsFloating r) => Exp r +mkPi = Exp $ PrimConst (PrimPi floatingType) + + +-- Smart constructors for primitive applications +-- + +-- Operators from Floating + +mkSin :: (Elt t, IsFloating t) => Exp t -> Exp t +mkSin x = Exp $ PrimSin floatingType `PrimApp` x + +mkCos :: (Elt t, IsFloating t) => Exp t -> Exp t +mkCos x = Exp $ PrimCos floatingType `PrimApp` x + +mkTan :: (Elt t, IsFloating t) => Exp t -> Exp t +mkTan x = Exp $ PrimTan floatingType `PrimApp` x + +mkAsin :: (Elt t, IsFloating t) => Exp t -> Exp t +mkAsin x = Exp $ PrimAsin floatingType `PrimApp` x + +mkAcos :: (Elt t, IsFloating t) => Exp t -> Exp t +mkAcos x = Exp $ PrimAcos floatingType `PrimApp` x + +mkAtan :: (Elt t, IsFloating t) => Exp t -> Exp t +mkAtan x = Exp $ PrimAtan floatingType `PrimApp` x + +mkSinh :: (Elt t, IsFloating t) => Exp t -> Exp t +mkSinh x = Exp $ PrimSinh floatingType `PrimApp` x + +mkCosh :: (Elt t, IsFloating t) => Exp t -> Exp t +mkCosh x = Exp $ PrimCosh floatingType `PrimApp` x + +mkTanh :: (Elt t, IsFloating t) => Exp t -> Exp t +mkTanh x = Exp $ PrimTanh floatingType `PrimApp` x + +mkAsinh :: (Elt t, IsFloating t) => Exp t -> Exp t +mkAsinh x = Exp $ PrimAsinh floatingType `PrimApp` x + +mkAcosh :: (Elt t, IsFloating t) => Exp t -> Exp t +mkAcosh x = Exp $ PrimAcosh floatingType `PrimApp` x + +mkAtanh :: (Elt t, IsFloating t) => Exp t -> Exp t +mkAtanh x = Exp $ PrimAtanh floatingType `PrimApp` x + +mkExpFloating :: (Elt t, IsFloating t) => Exp t -> Exp t +mkExpFloating x = Exp $ PrimExpFloating floatingType `PrimApp` x + +mkSqrt :: (Elt t, IsFloating t) => Exp t -> Exp t +mkSqrt x = Exp $ PrimSqrt floatingType `PrimApp` x + +mkLog :: (Elt t, IsFloating t) => Exp t -> Exp t +mkLog x = Exp $ PrimLog floatingType `PrimApp` x + +mkFPow :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t +mkFPow x y = Exp $ PrimFPow floatingType `PrimApp` tup2 (x, y) + +mkLogBase :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t +mkLogBase x y = Exp $ PrimLogBase floatingType `PrimApp` tup2 (x, y) + +-- Operators from Num + +mkAdd :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t +mkAdd x y = Exp $ PrimAdd numType `PrimApp` tup2 (x, y) + +mkSub :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t +mkSub x y = Exp $ PrimSub numType `PrimApp` tup2 (x, y) + +mkMul :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t +mkMul x y = Exp $ PrimMul numType `PrimApp` tup2 (x, y) + +mkNeg :: (Elt t, IsNum t) => Exp t -> Exp t +mkNeg x = Exp $ PrimNeg numType `PrimApp` x + +mkAbs :: (Elt t, IsNum t) => Exp t -> Exp t +mkAbs x = Exp $ PrimAbs numType `PrimApp` x + +mkSig :: (Elt t, IsNum t) => Exp t -> Exp t +mkSig x = Exp $ PrimSig numType `PrimApp` x + +-- Operators from Integral + +mkQuot :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t +mkQuot x y = Exp $ PrimQuot integralType `PrimApp` tup2 (x, y) + +mkRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t +mkRem x y = Exp $ PrimRem integralType `PrimApp` tup2 (x, y) + +mkQuotRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t) +mkQuotRem x y = untup2 $ Exp $ PrimQuotRem integralType `PrimApp` tup2 (x ,y) + +mkIDiv :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t +mkIDiv x y = Exp $ PrimIDiv integralType `PrimApp` tup2 (x, y) + +mkMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t +mkMod x y = Exp $ PrimMod integralType `PrimApp` tup2 (x, y) + +mkDivMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t) +mkDivMod x y = untup2 $ Exp $ PrimDivMod integralType `PrimApp` tup2 (x ,y) + + +-- Operators from Bits and FiniteBits + +mkBAnd :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t +mkBAnd x y = Exp $ PrimBAnd integralType `PrimApp` tup2 (x, y) + +mkBOr :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t +mkBOr x y = Exp $ PrimBOr integralType `PrimApp` tup2 (x, y) + +mkBXor :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t +mkBXor x y = Exp $ PrimBXor integralType `PrimApp` tup2 (x, y) + +mkBNot :: (Elt t, IsIntegral t) => Exp t -> Exp t +mkBNot x = Exp $ PrimBNot integralType `PrimApp` x + +mkBShiftL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +mkBShiftL x i = Exp $ PrimBShiftL integralType `PrimApp` tup2 (x, i) + +mkBShiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +mkBShiftR x i = Exp $ PrimBShiftR integralType `PrimApp` tup2 (x, i) + +mkBRotateL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +mkBRotateL x i = Exp $ PrimBRotateL integralType `PrimApp` tup2 (x, i) + +mkBRotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +mkBRotateR x i = Exp $ PrimBRotateR integralType `PrimApp` tup2 (x, i) + +mkPopCount :: (Elt t, IsIntegral t) => Exp t -> Exp Int +mkPopCount x = Exp $ PrimPopCount integralType `PrimApp` x + +mkCountLeadingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int +mkCountLeadingZeros x = Exp $ PrimCountLeadingZeros integralType `PrimApp` x + +mkCountTrailingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int +mkCountTrailingZeros x = Exp $ PrimCountTrailingZeros integralType `PrimApp` x + + +-- Operators from Fractional + +mkFDiv :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t +mkFDiv x y = Exp $ PrimFDiv floatingType `PrimApp` tup2 (x, y) + +mkRecip :: (Elt t, IsFloating t) => Exp t -> Exp t +mkRecip x = Exp $ PrimRecip floatingType `PrimApp` x + +-- Operators from RealFrac + +mkTruncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b +mkTruncate x = Exp $ PrimTruncate floatingType integralType `PrimApp` x + +mkRound :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b +mkRound x = Exp $ PrimRound floatingType integralType `PrimApp` x + +mkFloor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b +mkFloor x = Exp $ PrimFloor floatingType integralType `PrimApp` x + +mkCeiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b +mkCeiling x = Exp $ PrimCeiling floatingType integralType `PrimApp` x + +-- Operators from RealFloat + +mkAtan2 :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t +mkAtan2 x y = Exp $ PrimAtan2 floatingType `PrimApp` tup2 (x, y) + +mkIsNaN :: (Elt t, IsFloating t) => Exp t -> Exp Bool +mkIsNaN x = Exp $ PrimIsNaN floatingType `PrimApp` x + +mkIsInfinite :: (Elt t, IsFloating t) => Exp t -> Exp Bool +mkIsInfinite x = Exp $ PrimIsInfinite floatingType `PrimApp` x -- FIXME: add missing operations from Floating, RealFrac & RealFloat diff --git a/Data/Array/Accelerate/Trafo.hs b/Data/Array/Accelerate/Trafo.hs --- a/Data/Array/Accelerate/Trafo.hs +++ b/Data/Array/Accelerate/Trafo.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,10 +21,16 @@ -- * HOAS -> de Bruijn conversion Phase(..), phases, - convertAcc, convertAccWith, + -- ** Array computations + convertAcc, convertAccWith, + + -- ** Array functions + Afunction, AfunctionR, convertAfun, convertAfunWith, - -- convertSeq, convertSeqWith, + -- ** Sequence computations + -- convertSeq, convertSeqWith, + -- * Fusion module Data.Array.Accelerate.Trafo.Fusion, -- DelayedSeq(..), Extend(..), @@ -33,6 +40,9 @@ -- * Term equality Match(..), (:~:)(..), + + -- ** Auxiliary + matchDelayedOpenAcc, hashDelayedOpenAcc, ) where diff --git a/Data/Array/Accelerate/Trafo/Algebra.hs b/Data/Array/Accelerate/Trafo/Algebra.hs --- a/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/Data/Array/Accelerate/Trafo/Algebra.hs @@ -147,6 +147,7 @@ PrimFloor ta tb -> evalFloor ta tb x env PrimCeiling ta tb -> evalCeiling ta tb x env PrimIsNaN ty -> evalIsNaN ty x env + PrimIsInfinite ty -> evalIsInfinite ty x env PrimLt ty -> evalLt ty x env PrimGt ty -> evalGt ty x env PrimLtEq ty -> evalLtEq ty x env @@ -601,6 +602,9 @@ evalIsNaN :: FloatingType a -> a :-> Bool evalIsNaN ty | FloatingDict <- floatingDict ty = eval1 isNaN + +evalIsInfinite :: FloatingType a -> a :-> Bool +evalIsInfinite ty | FloatingDict <- floatingDict ty = eval1 isInfinite -- Relational & Equality diff --git a/Data/Array/Accelerate/Trafo/Base.hs b/Data/Array/Accelerate/Trafo/Base.hs --- a/Data/Array/Accelerate/Trafo/Base.hs +++ b/Data/Array/Accelerate/Trafo/Base.hs @@ -36,6 +36,7 @@ DelayedAfun, DelayedOpenAfun, DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun, -- DelayedSeq(..), DelayedOpenSeq, + matchDelayedOpenAcc, hashDelayedOpenAcc, -- Environments Gamma(..), incExp, prjExp, lookupExp, @@ -57,6 +58,7 @@ -- friends import Data.Array.Accelerate.AST hiding ( Val(..) ) +import Data.Array.Accelerate.Analysis.Hash import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Sugar ( Array, Arrays, Shape, Elt ) import Data.Array.Accelerate.Error @@ -183,9 +185,9 @@ {-# INLINEABLE hashAcc #-} {-# INLINEABLE matchAcc #-} {-# INLINEABLE prettyAcc #-} - hashAcc = hashDelayed - matchAcc = matchDelayed - prettyAcc = prettyDelayed + hashAcc = hashDelayedOpenAcc + matchAcc = matchDelayedOpenAcc + prettyAcc = prettyDelayedOpenAcc instance NFData (DelayedOpenAfun aenv t) where rnf = rnfPreOpenAfun rnfDelayedOpenAcc @@ -196,24 +198,24 @@ -- instance NFData (DelayedSeq t) where -- rnf = rnfDelayedSeq -hashDelayed :: HashAcc DelayedOpenAcc -hashDelayed (Manifest pacc) = hash "Manifest" `hashWithSalt` hashPreOpenAcc hashAcc pacc -hashDelayed Delayed{..} = hash "Delayed" `hashE` extentD `hashF` indexD `hashF` linearIndexD +hashDelayedOpenAcc :: HashAcc DelayedOpenAcc +hashDelayedOpenAcc (Manifest pacc) = $(hashQ "Manifest") `hashWithSalt` hashPreOpenAcc hashAcc pacc +hashDelayedOpenAcc Delayed{..} = $(hashQ "Delayed") `hashE` extentD `hashF` indexD `hashF` linearIndexD where hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc -matchDelayed :: MatchAcc DelayedOpenAcc -matchDelayed (Manifest pacc1) (Manifest pacc2) +matchDelayedOpenAcc :: MatchAcc DelayedOpenAcc +matchDelayedOpenAcc (Manifest pacc1) (Manifest pacc2) = matchPreOpenAcc matchAcc hashAcc pacc1 pacc2 -matchDelayed (Delayed sh1 ix1 lx1) (Delayed sh2 ix2 lx2) +matchDelayedOpenAcc (Delayed sh1 ix1 lx1) (Delayed sh2 ix2 lx2) | Just Refl <- matchPreOpenExp matchAcc hashAcc sh1 sh2 , Just Refl <- matchPreOpenFun matchAcc hashAcc ix1 ix2 , Just Refl <- matchPreOpenFun matchAcc hashAcc lx1 lx2 = Just Refl -matchDelayed _ _ +matchDelayedOpenAcc _ _ = Nothing rnfDelayedOpenAcc :: DelayedOpenAcc aenv t -> () @@ -242,18 +244,18 @@ -- -- > let a0 = <...> in map f a0 -- -prettyDelayed :: PrettyAcc DelayedOpenAcc -prettyDelayed wrap aenv acc = case acc of - Manifest pacc -> prettyPreOpenAcc prettyDelayed wrap aenv pacc +prettyDelayedOpenAcc :: PrettyAcc DelayedOpenAcc +prettyDelayedOpenAcc wrap aenv acc = case acc of + Manifest pacc -> prettyPreOpenAcc prettyDelayedOpenAcc wrap aenv pacc Delayed sh f _ | Shape a <- sh , Just Refl <- match f (Lam (Body (Index a (Var ZeroIdx)))) - -> prettyDelayed wrap aenv a + -> prettyDelayedOpenAcc wrap aenv a | otherwise -> wrap $ hang (text "Delayed") 2 - $ sep [ prettyPreExp prettyDelayed parens aenv sh - , parens (prettyPreFun prettyDelayed aenv f) + $ sep [ prettyPreExp prettyDelayedOpenAcc parens aenv sh + , parens (prettyPreFun prettyDelayedOpenAcc aenv f) ] diff --git a/Data/Array/Accelerate/Trafo/Fusion.hs b/Data/Array/Accelerate/Trafo/Fusion.hs --- a/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/Data/Array/Accelerate/Trafo/Fusion.hs @@ -197,8 +197,8 @@ Scanr1 f a -> Scanr1 (cvtF f) (delayed fuseAcc a) Scanr' f z a -> Scanr' (cvtF f) (cvtE z) (delayed fuseAcc a) Permute f d p a -> Permute (cvtF f) (manifest fuseAcc d) (cvtF p) (delayed fuseAcc a) - Stencil f x a -> Stencil (cvtF f) x (manifest fuseAcc a) - Stencil2 f x a y b -> Stencil2 (cvtF f) x (manifest fuseAcc a) y (manifest fuseAcc b) + Stencil f x a -> Stencil (cvtF f) (cvtB x) (manifest fuseAcc a) + Stencil2 f x a y b -> Stencil2 (cvtF f) (cvtB x) (manifest fuseAcc a) (cvtB y) (manifest fuseAcc b) -- Collect s -> Collect (cvtS s) where @@ -233,6 +233,13 @@ cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t cvtE = convertOpenExp fuseAcc + cvtB :: Boundary aenv t -> PreBoundary DelayedOpenAcc aenv t + cvtB Clamp = Clamp + cvtB Mirror = Mirror + cvtB Wrap = Wrap + cvtB (Constant v) = Constant v + cvtB (Function f) = Function (cvtF f) + convertOpenExp :: Bool -> OpenExp env aenv t -> DelayedOpenExp env aenv t convertOpenExp fuseAcc exp = case exp of @@ -435,8 +442,8 @@ Scanr1 f a -> embed (into Scanr1 (cvtF f)) a Scanr' f z a -> embed (into2 Scanr' (cvtF f) (cvtE z)) a Permute f d p a -> embed2 (into2 permute (cvtF f) (cvtF p)) d a - Stencil f x a -> lift (into (stencil x) (cvtF f)) a - Stencil2 f x a y b -> lift2 (into (stencil2 x y) (cvtF f)) a b + Stencil f x a -> lift (into2 Stencil (cvtF f) (cvtB x)) a + Stencil2 f x a y b -> lift2 (into3 stencil2 (cvtF f) (cvtB x) (cvtB y)) a b where -- If fusion is not enabled, force terms to the manifest representation @@ -460,18 +467,24 @@ -- Helpers to shuffle the order of arguments to a constructor -- permute f p d a = Permute f d p a - stencil x f a = Stencil f x a - stencil2 x y f a b = Stencil2 f x a y b + stencil2 f x y a b = Stencil2 f x a y b -- Conversions for closed scalar functions and expressions. This just -- applies scalar simplifications. -- - cvtF :: PreFun acc aenv t -> PreFun acc aenv t + cvtF :: PreFun acc aenv' t -> PreFun acc aenv' t cvtF = simplify - cvtE :: Elt t =>PreExp acc aenv' t -> PreExp acc aenv' t + cvtE :: Elt t => PreExp acc aenv' t -> PreExp acc aenv' t cvtE = simplify + cvtB :: PreBoundary acc aenv' t -> PreBoundary acc aenv' t + cvtB Clamp = Clamp + cvtB Mirror = Mirror + cvtB Wrap = Wrap + cvtB (Constant c) = Constant c + cvtB (Function f) = Function (cvtF f) + -- Helpers to embed and fuse delayed terms -- into :: Sink f => (f env' a -> b) -> f env a -> Extend acc env env' -> b @@ -481,6 +494,10 @@ => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend acc env env' -> c into2 op a b env = op (sink env a) (sink env b) + into3 :: (Sink f1, Sink f2, Sink f3) + => (f1 env' a -> f2 env' b -> f3 env' c -> d) -> f1 env a -> f2 env b -> f3 env c -> Extend acc env env' -> d + into3 op a b c env = op (sink env a) (sink env b) (sink env c) + fuse :: Arrays as => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs) -> acc aenv as @@ -859,16 +876,16 @@ compute' :: (Kit acc, Arrays arrs) => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs compute' cc = case simplify cc of - Done v -> Avar v - Yield sh f -> Generate sh f + Done v -> Avar v + Yield sh f -> Generate sh f Step sh p f v - | Just Refl <- match sh (arrayShape v) + | Just Refl <- match sh (simplify (arrayShape v)) , Just Refl <- isIdentity p - , Just Refl <- isIdentity f -> Avar v - | Just Refl <- match sh (arrayShape v) - , Just Refl <- isIdentity p -> Map f (avarIn v) - | Just Refl <- isIdentity f -> Backpermute sh p (avarIn v) - | otherwise -> Transform sh p f (avarIn v) + , Just Refl <- isIdentity f -> Avar v + | Just Refl <- match sh (simplify (arrayShape v)) + , Just Refl <- isIdentity p -> Map f (avarIn v) + | Just Refl <- isIdentity f -> Backpermute sh p (avarIn v) + | otherwise -> Transform sh p f (avarIn v) -- Evaluate a delayed computation and tie the recursive knot @@ -1359,8 +1376,8 @@ Scanr1 f a -> Scanr1 (cvtF f) (cvtA a) Scanr' f z a -> Scanr' (cvtF f) (cvtE z) (cvtA a) Permute f d p a -> Permute (cvtF f) (cvtA d) (cvtF p) (cvtA a) - Stencil f x a -> Stencil (cvtF f) x (cvtA a) - Stencil2 f x a y b -> Stencil2 (cvtF f) x (cvtA a) y (cvtA b) + Stencil f x a -> Stencil (cvtF f) (cvtB x) (cvtA a) + Stencil2 f x a y b -> Stencil2 (cvtF f) (cvtB x) (cvtA a) (cvtB y) (cvtA b) -- Collect seq -> Collect (cvtSeq seq) where @@ -1372,6 +1389,13 @@ cvtF :: PreFun acc aenv s -> PreFun acc aenv s cvtF = replaceF sh' f' avar + + cvtB :: PreBoundary acc aenv s -> PreBoundary acc aenv s + cvtB Clamp = Clamp + cvtB Mirror = Mirror + cvtB Wrap = Wrap + cvtB (Constant c) = Constant c + cvtB (Function f) = Function (cvtF f) cvtAT :: Atuple (acc aenv) s -> Atuple (acc aenv) s cvtAT NilAtup = NilAtup diff --git a/Data/Array/Accelerate/Trafo/Sharing.hs b/Data/Array/Accelerate/Trafo/Sharing.hs --- a/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/Data/Array/Accelerate/Trafo/Sharing.hs @@ -56,7 +56,7 @@ import Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc , PreOpenExp(..), OpenExp, PreExp, Exp - , Stencil(..) + , PreBoundary(..), Boundary, Stencil(..) , showPreAccOp, showPreExpOp ) import qualified Data.Array.Accelerate.AST as AST import qualified Data.Array.Accelerate.Debug as Debug @@ -301,13 +301,13 @@ Backpermute newDim perm acc -> AST.Backpermute (cvtE newDim) (cvtF1 perm) (cvtA acc) Stencil stencil boundary acc -> AST.Stencil (convertSharingStencilFun1 config acc alyt aenv' stencil) - (convertBoundary boundary) + (convertSharingBoundary config alyt aenv' boundary) (cvtA acc) Stencil2 stencil bndy1 acc1 bndy2 acc2 -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv' stencil) - (convertBoundary bndy1) + (convertSharingBoundary config alyt aenv' bndy1) (cvtA acc1) - (convertBoundary bndy2) + (convertSharingBoundary config alyt aenv' bndy2) (cvtA acc2) -- Collect seq -> AST.Collect (convertSharingSeq config alyt EmptyLayout aenv' [] seq) @@ -517,11 +517,23 @@ -- | Convert a boundary condition -- -convertBoundary :: Elt e => Boundary e -> Boundary (EltRepr e) -convertBoundary Clamp = Clamp -convertBoundary Mirror = Mirror -convertBoundary Wrap = Wrap -convertBoundary (Constant e) = Constant (fromElt e) +convertSharingBoundary + :: forall aenv t. + Config + -> Layout aenv aenv + -> [StableSharingAcc] + -> PreBoundary ScopedAcc ScopedExp t + -> AST.PreBoundary AST.OpenAcc aenv t +convertSharingBoundary config alyt aenv = cvt + where + cvt :: PreBoundary ScopedAcc ScopedExp t -> AST.Boundary aenv t + cvt bndy = + case bndy of + Clamp -> AST.Clamp + Mirror -> AST.Mirror + Wrap -> AST.Wrap + Constant v -> AST.Constant $ fromElt v + Function f -> AST.Function $ convertSharingFun1 config alyt aenv f -- Smart constructors to represent AST forms @@ -1237,6 +1249,20 @@ traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int) traverseExp = makeOccMapExp config accOccMap + traverseBoundary + :: Level + -> PreBoundary Acc Exp t + -> IO (PreBoundary UnscopedAcc RootExp t, Int) + traverseBoundary lvl bndy = + case bndy of + Clamp -> return (Clamp, 0) + Mirror -> return (Mirror, 0) + Wrap -> return (Wrap, 0) + Constant v -> return (Constant v, 0) + Function f -> do + (f', h) <- traverseFun1 lvl f + return (Function f', h) + -- traverseSeq :: forall arrs. Typeable arrs -- => Level -> Seq arrs -- -> IO (RootSeq arrs, Int) @@ -1346,15 +1372,18 @@ return (Backpermute e' p' acc', h1 `max` h2 `max` h3 + 1) Stencil s bnd acc -> reconstruct $ do (s' , h1) <- makeOccMapStencil1 config accOccMap acc lvl s - (acc', h2) <- traverseAcc lvl acc - return (Stencil s' bnd acc', h1 `max` h2 + 1) + (bnd', h2) <- traverseBoundary lvl bnd + (acc', h3) <- traverseAcc lvl acc + return (Stencil s' bnd' acc', h1 `max` h2 `max` h3 + 1) Stencil2 s bnd1 acc1 bnd2 acc2 -> reconstruct $ do (s' , h1) <- makeOccMapStencil2 config accOccMap acc1 acc2 lvl s - (acc1', h2) <- traverseAcc lvl acc1 - (acc2', h3) <- traverseAcc lvl acc2 - return (Stencil2 s' bnd1 acc1' bnd2 acc2', - h1 `max` h2 `max` h3 + 1) + (bnd1', h2) <- traverseBoundary lvl bnd1 + (acc1', h3) <- traverseAcc lvl acc1 + (bnd2', h4) <- traverseBoundary lvl bnd2 + (acc2', h5) <- traverseAcc lvl acc2 + return (Stencil2 s' bnd1' acc1' bnd2' acc2', + h1 `max` h2 `max` h3 `max` h4 `max` h5 + 1) -- Collect s -> reconstruct $ do -- (s', h) <- traverseSeq lvl s -- return (Collect s', h + 1) @@ -2185,17 +2214,20 @@ (accCount1 +++ accCount2 +++ accCount3) Stencil st bnd acc -> let (st' , accCount1) = scopesStencil1 acc st - (acc', accCount2) = scopesAcc acc + (bnd', accCount2) = scopesBoundary bnd + (acc', accCount3) = scopesAcc acc in - reconstruct (Stencil st' bnd acc') (accCount1 +++ accCount2) + reconstruct (Stencil st' bnd' acc') (accCount1 +++ accCount2 +++ accCount3) Stencil2 st bnd1 acc1 bnd2 acc2 -> let (st' , accCount1) = scopesStencil2 acc1 acc2 st - (acc1', accCount2) = scopesAcc acc1 - (acc2', accCount3) = scopesAcc acc2 + (bnd1', accCount2) = scopesBoundary bnd1 + (acc1', accCount3) = scopesAcc acc1 + (bnd2', accCount4) = scopesBoundary bnd2 + (acc2', accCount5) = scopesAcc acc2 in - reconstruct (Stencil2 st' bnd1 acc1' bnd2 acc2') - (accCount1 +++ accCount2 +++ accCount3) + reconstruct (Stencil2 st' bnd1' acc1' bnd2' acc2') + (accCount1 +++ accCount2 +++ accCount3 +++ accCount4 +++ accCount5) -- Collect seq -> let -- (seq', accCount1) = scopesSeq seq -- in @@ -2406,7 +2438,18 @@ where (body, counts) = scopesExp (stencilFun undefined undefined) + scopesBoundary :: PreBoundary UnscopedAcc RootExp t + -> (PreBoundary ScopedAcc ScopedExp t, NodeCounts) + scopesBoundary bndy = + case bndy of + Clamp -> (Clamp, noNodeCounts) + Mirror -> (Mirror, noNodeCounts) + Wrap -> (Wrap, noNodeCounts) + Constant v -> (Constant v, noNodeCounts) + Function f -> let (body, counts) = scopesFun1 f + in (Function body, counts) + determineScopesExp :: Config -> OccMap Acc @@ -2794,6 +2837,7 @@ -- environment for de Bruijn conversion will have a duplicate entry, and hence, be of the wrong -- size, which is fatal. (The 'buildInitialEnv*' functions will already bail out.) -- +{-# NOINLINE recoverSharingAcc #-} recoverSharingAcc :: Typeable a => Config @@ -2801,7 +2845,6 @@ -> [Level] -- The tags of newly introduced free array variables -> Acc a -> (ScopedAcc a, [StableSharingAcc]) -{-# NOINLINE recoverSharingAcc #-} recoverSharingAcc config alvl avars acc = let (acc', occMap) = unsafePerformIO -- to enable stable pointers; this is safe as explained above @@ -2810,6 +2853,7 @@ determineScopesAcc config avars occMap acc' +{-# NOINLINE recoverSharingExp #-} recoverSharingExp :: Typeable e => Config @@ -2817,7 +2861,6 @@ -> [Level] -- The tags of newly introduced free scalar variables -> Exp e -> (ScopedExp e, [StableSharingExp]) -{-# NOINLINE recoverSharingExp #-} recoverSharingExp config lvl fvar exp = let (rootExp, accOccMap) = unsafePerformIO $ do @@ -2834,12 +2877,12 @@ {-- +{-# NOINLINE recoverSharingSeq #-} recoverSharingSeq :: Typeable e => Config -> Seq e -> (ScopedSeq e, [StableSharingSeq]) -{-# NOINLINE recoverSharingSeq #-} recoverSharingSeq config seq = let (rootSeq, accOccMap) = unsafePerformIO $ do diff --git a/Data/Array/Accelerate/Trafo/Simplify.hs b/Data/Array/Accelerate/Trafo/Simplify.hs --- a/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/Data/Array/Accelerate/Trafo/Simplify.hs @@ -37,6 +37,7 @@ -- friends import Data.Array.Accelerate.AST hiding ( prj ) +import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Analysis.Shape import Data.Array.Accelerate.Error import Data.Array.Accelerate.Product @@ -45,7 +46,7 @@ import Data.Array.Accelerate.Trafo.Shrink import Data.Array.Accelerate.Trafo.Substitution import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Array.Sugar ( Elt, Shape, Slice, toElt, fromElt, (:.)(..) +import Data.Array.Accelerate.Array.Sugar ( Array, Elt(eltType), Shape, Slice, toElt, fromElt, Z(..), (:.)(..) , Tuple(..), IsTuple, fromTuple, TupleRepr, shapeToList ) import qualified Data.Array.Accelerate.Debug as Stats @@ -237,7 +238,7 @@ (v, fx) = evalPrimApp env f x' Index a sh -> Index a <$> cvtE sh LinearIndex a i -> LinearIndex a <$> cvtE i - Shape a -> pure $ Shape a + Shape a -> shape a ShapeSize sh -> shapeSize (cvtE sh) Intersect s t -> cvtE s `intersect` cvtE t Union s t -> cvtE s `union` cvtE t @@ -391,6 +392,13 @@ indexTail (_, IndexCons sl _) = Stats.ruleFired "indexTail/indexCons" $ yes sl indexTail sh = IndexTail <$> sh + shape :: forall sh t. (Shape sh, Elt t) => acc aenv (Array sh t) -> (Any, PreOpenExp acc env aenv sh) + shape _ + | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::Z)) + = Stats.ruleFired "shape/Z" $ yes (Const (fromElt Z)) + shape a + = pure $ Shape a + shapeSize :: forall sh. Shape sh => (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) shapeSize (_, Const c) = Stats.ruleFired "shapeSize/const" $ yes (Const (product (shapeToList (toElt c :: sh)))) shapeSize sh = ShapeSize <$> sh @@ -671,6 +679,7 @@ PrimFloor f i -> travFloatingType f +++ travIntegralType i PrimCeiling f i -> travFloatingType f +++ travIntegralType i PrimIsNaN t -> travFloatingType t + PrimIsInfinite t -> travFloatingType t PrimAtan2 t -> travFloatingType t PrimLt t -> travScalarType t PrimGt t -> travScalarType t diff --git a/Data/Array/Accelerate/Trafo/Substitution.hs b/Data/Array/Accelerate/Trafo/Substitution.hs --- a/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/Data/Array/Accelerate/Trafo/Substitution.hs @@ -260,6 +260,16 @@ {-# INLINEABLE weaken #-} weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) +instance RebuildableAcc acc => Sink (PreBoundary acc) where + {-# INLINEABLE weaken #-} + weaken k bndy = + case bndy of + Clamp -> Clamp + Mirror -> Mirror + Wrap -> Wrap + Constant c -> Constant c + Function f -> Function (weaken k f) + instance Sink OpenAcc where {-# INLINEABLE weaken #-} weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) @@ -495,8 +505,8 @@ Scanr1 f a -> Scanr1 <$> rebuildFun k (pure . IE) av f <*> k av a Permute f1 a1 f2 a2 -> Permute <$> rebuildFun k (pure . IE) av f1 <*> k av a1 <*> rebuildFun k (pure . IE) av f2 <*> k av a2 Backpermute sh f a -> Backpermute <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av f <*> k av a - Stencil f b a -> Stencil <$> rebuildFun k (pure . IE) av f <*> pure b <*> k av a - Stencil2 f b1 a1 b2 a2 -> Stencil2 <$> rebuildFun k (pure . IE) av f <*> pure b1 <*> k av a1 <*> pure b2 <*> k av a2 + Stencil f b a -> Stencil <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b <*> k av a + Stencil2 f b1 a1 b2 a2 -> Stencil2 <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b1 <*> k av a1 <*> rebuildBoundary k av b2 <*> k av a2 -- Collect seq -> Collect <$> rebuildSeq k av seq Aforeign ff afun as -> Aforeign ff afun <$> k av as @@ -523,6 +533,21 @@ case atup of NilAtup -> pure NilAtup SnocAtup t a -> SnocAtup <$> rebuildAtup k av t <*> k av a + +{-# INLINEABLE rebuildBoundary #-} +rebuildBoundary + :: (Applicative f, SyntacticAcc fa) + => RebuildAcc acc + -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t')) + -> PreBoundary acc aenv t + -> f (PreBoundary acc aenv' t) +rebuildBoundary k av bndy = + case bndy of + Clamp -> pure Clamp + Mirror -> pure Mirror + Wrap -> pure Wrap + Constant v -> pure (Constant v) + Function f -> Function <$> rebuildFun k (pure . IE) av f {-- {-# INLINEABLE rebuildSeq #-} diff --git a/Data/Array/Accelerate/Type.hs b/Data/Array/Accelerate/Type.hs --- a/Data/Array/Accelerate/Type.hs +++ b/Data/Array/Accelerate/Type.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -83,6 +82,7 @@ CLLong, CULLong, CFloat, CDouble) -- in the future, CHalf + -- Scalar types -- ------------ @@ -104,6 +104,7 @@ NonNumDict :: ( Bounded a, Enum a, Eq a, Ord a, Show a, Storable a ) => NonNumDict a + -- Scalar type representation -- @@ -212,10 +213,6 @@ show (NumScalarType ty) = show ty show (NonNumScalarType ty) = show ty -instance Show (TupleType a) where - show UnitTuple = "()" - show (SingleTuple scalarTy) = show scalarTy - show (PairTuple a b) = "("++show a++", "++show b++")" -- Querying scalar type representations -- @@ -592,7 +589,12 @@ SingleTuple :: ScalarType a -> TupleType a PairTuple :: TupleType a -> TupleType b -> TupleType (a, b) +instance Show (TupleType a) where + show UnitTuple = "()" + show (SingleTuple scalarTy) = show scalarTy + show (PairTuple a b) = "("++show a++", "++show b++")" + -- Type-level bit sizes -- -------------------- @@ -643,23 +645,11 @@ 64 -> [t| 64 |] _ -> error "I don't know what architecture I am" ) - type instance BitSize CULong = $( case finiteBitSize (undefined::CULong) of 32 -> [t| 32 |] 64 -> [t| 64 |] _ -> error "I don't know what architecture I am" ) - --- Stencil support --- --------------- - --- |Boundary condition specification for stencil operations. --- -data Boundary a = Clamp -- ^clamp coordinates to the extent of the array - | Mirror -- ^mirror coordinates beyond the array extent - | Wrap -- ^wrap coordinates around on each dimension - | Constant a -- ^use a constant value for outlying coordinates - deriving (Show, Read) {- -- Vector GPU data types diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,240 @@ +An Embedded Language for Accelerated Array Computations +======================================================= + +[![Build Status](https://travis-ci.org/AccelerateHS/accelerate.svg?branch=master)](https://travis-ci.org/AccelerateHS/accelerate) +[![Hackage](https://img.shields.io/hackage/v/accelerate.svg)](https://hackage.haskell.org/package/accelerate) + +`Data.Array.Accelerate` defines an embedded language of array computations for high-performance computing in Haskell. Computations on multi-dimensional, regular arrays are expressed in the form of parameterised collective operations (such as maps, reductions, and permutations). These computations are online-compiled and executed on a range of architectures. + +For more details, see our papers: + + * [Accelerating Haskell Array Codes with Multicore GPUs][CKLM+11] + * [Optimising Purely Functional GPU Programs][MCKL13] ([slides][MCKL13-slides]) + * [Embedding Foreign Code][CMCK14] + * [Type-safe Runtime Code Generation: Accelerate to LLVM][MCGN15] ([slides][MCGN15-slides]) ([video][MCGN15-video]) + +There are also slides from some fairly recent presentations: + + * [Embedded Languages for High-Performance Computing in Haskell][Embedded] + * [GPGPU Programming in Haskell with Accelerate][YLJ13-slides] ([video][YLJ13-video]) ([workshop][YLJ13-workshop]) + +Chapter 6 of Simon Marlow's book [Parallel and Concurrent Programming in Haskell][Mar13] contains a tutorial introduction to Accelerate. + +[Trevor's PhD thesis][Trevor-thesis] details the design and implementation of frontend optimisations and CUDA backend. + + +**Table of Contents** + +- [An Embedded Language for Accelerated Array Computations](#an-embedded-language-for-accelerated-array-computations) + - [A simple example](#a-simple-example) + - [Availability](#availability) + - [Additional components](#additional-components) + - [Requirements](#requirements) + - [Documentation](#documentation) + - [Examples](#examples) + - [Mailing list and contacts](#mailing-list-and-contacts) + - [Citing Accelerate](#citing-accelerate) + - [What's missing?](#whats-missing) + +A simple example +---------------- + +As a simple example, consider the computation of a dot product of two vectors of single-precision floating-point numbers: + + dotp :: Acc (Vector Float) -> Acc (Vector Float) -> Acc (Scalar Float) + dotp xs ys = fold (+) 0 (zipWith (*) xs ys) + +Except for the type, this code is almost the same as the corresponding Haskell code on lists of floats. The types indicate that the computation may be online-compiled for performance; for example, using `Data.Array.Accelerate.LLVM.PTX.run` it may be on-the-fly off-loaded to a GPU. + +Availability +------------ + +Package accelerate is available from + + * Hackage: [accelerate][Hackage] - install with `cabal install accelerate` + * GitHub: [AccelerateHS/accelerate][GitHub] - get the source with `git clone https://github.com/AccelerateHS/accelerate.git`. The easiest way to compile the source distributions is via the Haskell [stack](https://docs.haskellstack.org/en/stable/README/) tool. + +Additional components +--------------------- + +The following supported add-ons are available as separate packages: + + * [accelerate-llvm-native][accelerate-llvm-native]: Backend targeting multicore CPUs + * [accelerate-llvm-ptx][accelerate-llvm-ptx]: Backend targeting CUDA-enabled NVIDIA GPUs. Requires a GPU with compute capability 2.0 or greater (see the [table on Wikipedia][wiki-cc]) + * [accelerate-examples][accelerate-examples]: Computational kernels and applications showcasing the use of Accelerate as well as a regression test suite (supporting function and performance testing) + * [accelerate-io][accelerate-io]: Fast conversion between Accelerate arrays and other array formats (for example, Repa and Vector) + * [accelerate-fft][accelerate-fft]: Fast Fourier transform implementation, with FFI bindings to optimised implementations + * [accelerate-blas][accelerate-blas]: BLAS and LAPACK operations, with FFI bindings to optimised implementations + * [accelerate-bignum][accelerate-bignum]: Fixed-width large integer arithmetic + * [colour-accelerate][colour-accelerate]: Colour representations in Accelerate (RGB, sRGB, HSV, and HSL) + * [gloss-accelerate][gloss-accelerate]: Generate [gloss][gloss] pictures from Accelerate + * [gloss-raster-accelerate][gloss-raster-accelerate]: Parallel rendering of raster images and animations + * [lens-accelerate][lens-accelerate]: [Lens][lens] operators for Accelerate types + * [linear-accelerate][linear-accelerate]: [Linear][linear] vector spaces in Accelerate + * [mwc-random-accelerate][mwc-random-accelerate]: Generate Accelerate arrays filled with high quality pseudorandom numbers + * [numeric-prelude-accelerate][numeric-prelude-accelerate]: Lifting the [numeric-prelude][numeric-prelude] to Accelerate + +Install them from Hackage with `cabal install PACKAGENAME`. + + +Documentation +------------- + + * Haddock documentation is included and linked with the individual package releases on [Hackage][Hackage]. + * Haddock documentation for in-development components can be found [here](http://tmcdonell-bot.github.io/accelerate-travis-buildbot/). + * The idea behind the HOAS (higher-order abstract syntax) to de-Bruijn conversion used in the library is [described separately][HOAS-conv]. + +Examples +-------- + +### accelerate-examples + +The [accelerate-examples][accelerate-examples] package provides a range of computational kernels and a few complete applications. To install these from Hackage, issue `cabal install accelerate-examples`. The examples include: + + * An implementation of [canny edge detection][wiki-canny] + * An interactive [mandelbrot set][wiki-mandelbrot] generator + * An [N-body simulation][wiki-nbody] of gravitational attraction between solid particles + * An implementation of the [PageRank][wiki-pagerank] algorithm + * A simple [ray-tracer][wiki-raytracing] + * A particle based simulation of stable fluid flows + * A cellular automata simulation + * A "password recovery" tool, for dictionary lookup of MD5 hashes + +[![Mandelbrot](http://i.imgur.com/5Tbsp1j.jpg "accelerate-mandelbrot")](http://i.imgur.com/RgXRqsc.jpg) +[![Raytracer](http://i.imgur.com/7ohhKm9.jpg "accelerate-ray")](http://i.imgur.com/ZNEGEJK.jpg) + + + + +### LULESH + +[LULESH-accelerate][lulesh-accelerate] is in implementation of the Livermore Unstructured Lagrangian Explicit Shock Hydrodynamics (LULESH) mini-app. [LULESH][LULESH] represents a typical hydrodynamics code such as [ALE3D][ALE3D], but is a highly simplified application, hard-coded to solve the Sedov blast problem on an unstructured hexahedron mesh. + +![LULESH mesh](https://codesign.llnl.gov/images/sedov-3d-LLNL.png) + + +### Λ ○ λ (Lol) + +Λ ○ λ ([Lol][lol]) is a general-purpose library for ring-based lattice cryptography. Lol has applications in, for example, symmetric-key somewhat-homomorphic encryption schemes. The [lol-accelerate][lol-accelerate] package provides an Accelerate backend for Lol. + + +### Additional examples + +Accelerate users have also built some substantial applications of their own. +Please feel free to add your own examples! + + * Henning Thielemann, [patch-image](http://hackage.haskell.org/package/patch-image): Combine a collage of overlapping images + * apunktbau, [bildpunkt](https://github.com/abau/bildpunkt): A ray-marching distance field renderer + * klarh, [hasdy](https://github.com/klarh/hasdy): Molecular dynamics in Haskell using Accelerate + * Alexandros Gremm used Accelerate as part of the [2014 CSCS summer school](http://user.cscs.ch/blog/2014/cscs_usi_summer_school_2014_30_june_10_july_2014_in_serpiano_tessin/index.html) ([code](https://github.com/agremm/cscs)) + + +Mailing list and contacts +------------------------- + + * Mailing list: [`accelerate-haskell@googlegroups.com`](mailto:accelerate-haskell@googlegroups.com) (discussions on both use and development are welcome) + * Sign up for the mailing list at the [Accelerate Google Groups page][Google-Group]. + * Bug reports and issues tracking: [GitHub project page][Issues]. + +The maintainers of Accelerate are Manuel M T Chakravarty and Trevor L McDonell . + + +Citing Accelerate +----------------- + +If you use Accelerate for academic research, you are encouraged (though not +required) to cite the following papers ([BibTeX](http://www.cse.unsw.edu.au/~tmcdonell/papers/accelerate.bib)): + + * Manuel M. T. Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell, and Vinod Grover. + [Accelerating Haskell Array Codes with Multicore GPUs][CKLM+11]. + In _DAMP '11: Declarative Aspects of Multicore Programming_, ACM, 2011. + + * Trevor L. McDonell, Manuel M. T. Chakravarty, Gabriele Keller, and Ben Lippmeier. + [Optimising Purely Functional GPU Programs][MCKL13]. + In _ICFP '13: The 18th ACM SIGPLAN International Conference on Functional Programming_, ACM, 2013. + + * Robert Clifton-Everest, Trevor L. McDonell, Manuel M. T. Chakravarty, and Gabriele Keller. + [Embedding Foreign Code][CMCK14]. + In _PADL '14: The 16th International Symposium on Practical Aspects of Declarative Languages_, Springer-Verlag, LNCS, 2014. + + * Trevor L. McDonell, Manuel M. T. Chakravarty, Vinod Grover, and Ryan R. Newton. + [Type-safe Runtime Code Generation: Accelerate to LLVM][MCGN15]. + In _Haskell '15: The 8th ACM SIGPLAN Symposium on Haskell_, ACM, 2015. + +Accelerate is primarily developed by academics, so citations matter a lot to us. +As an added benefit, you increase Accelerate's exposure and potential user (and +developer!) base, which is a benefit to all users of Accelerate. Thanks in advance! + + +What's missing? +--------------- + +Here is a list of features that are currently missing: + + * Preliminary API (parts of the API may still change in subsequent releases) + + + + [CKLM+11]: http://www.cse.unsw.edu.au/~chak/papers/CKLM+11.html + [MCKL13]: http://www.cse.unsw.edu.au/~chak/papers/MCKL13.html + [MCKL13-slides]: https://speakerdeck.com/tmcdonell/optimising-purely-functional-gpu-programs + [CMCK14]: http://www.cse.unsw.edu.au/~chak/papers/CMCK14.html + [MCGN15]: http://www.cse.unsw.edu.au/~chak/papers/MCGN15.html + [MCGN15-slides]: https://speakerdeck.com/tmcdonell/type-safe-runtime-code-generation-accelerate-to-llvm + [MCGN15-video]: https://www.youtube.com/watch?v=snXhXA5noVc + [HIW'09]: https://wiki.haskell.org/HaskellImplementorsWorkshop + [Mar13]: http://chimera.labs.oreilly.com/books/1230000000929 + [Embedded]: https://speakerdeck.com/mchakravarty/embedded-languages-for-high-performance-computing-in-haskell + [Hackage]: http://hackage.haskell.org/package/accelerate + [accelerate-cuda]: https://github.com/AccelerateHS/accelerate-cuda + [accelerate-examples]: https://github.com/AccelerateHS/accelerate-examples + [accelerate-io]: https://github.com/AccelerateHS/accelerate-io + [accelerate-fft]: https://github.com/AccelerateHS/accelerate-fft + [accelerate-blas]: https://github.com/tmcdonell/accelerate-blas + [accelerate-backend-kit]: https://github.com/AccelerateHS/accelerate-backend-kit + [accelerate-buildbot]: https://github.com/AccelerateHS/accelerate-buildbot + [accelerate-repa]: https://github.com/blambo/accelerate-repa + [accelerate-opencl]: https://github.com/hiPERFIT/accelerate-opencl + [accelerate-cabal]: https://github.com/AccelerateHS/accelerate/accelerate.cabal + [accelerate-cuda-cabal]: https://github.com/AccelerateHS/accelerate-cuda/accelerate-cuda.cabal + [accelerate-llvm]: https://github.com/AccelerateHS/accelerate-llvm + [accelerate-llvm-native]: https://github.com/AccelerateHS/accelerate-llvm + [accelerate-llvm-ptx]: https://github.com/AccelerateHS/accelerate-llvm + [accelerate-bignum]: https://github.com/tmcdonell/accelerate-bignum + [GitHub]: https://github.com/AccelerateHS/accelerate + [Wiki]: https://github.com/AccelerateHS/accelerate/wiki + [Issues]: https://github.com/AccelerateHS/accelerate/issues + [Google-Group]: http://groups.google.com/group/accelerate-haskell + [HOAS-conv]: http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ + [repa]: http://hackage.haskell.org/package/repa + [wiki-cc]: https://en.wikipedia.org/wiki/CUDA#Supported_GPUs + [YLJ13-video]: http://youtu.be/ARqE4yT2Z0o + [YLJ13-slides]: https://speakerdeck.com/tmcdonell/gpgpu-programming-in-haskell-with-accelerate + [YLJ13-workshop]: https://speakerdeck.com/tmcdonell/gpgpu-programming-in-haskell-with-accelerate-workshop + [wiki-canny]: https://en.wikipedia.org/wiki/Canny_edge_detector + [wiki-mandelbrot]: https://en.wikipedia.org/wiki/Mandelbrot_set + [wiki-nbody]: https://en.wikipedia.org/wiki/N-body + [wiki-raytracing]: https://en.wikipedia.org/wiki/Ray_tracing + [wiki-pagerank]: https://en.wikipedia.org/wiki/Pagerank + [Trevor-thesis]: http://www.cse.unsw.edu.au/~tmcdonell/papers/TrevorMcDonell_PhD_submission.pdf + [colour-accelerate]: https://github.com/tmcdonell/colour-accelerate + [gloss]: https://hackage.haskell.org/package/gloss + [gloss-accelerate]: https://github.com/tmcdonell/gloss-accelerate + [gloss-raster-accelerate]: https://github.com/tmcdonell/gloss-raster-accelerate + [lens]: https://hackage.haskell.org/package/lens + [lens-accelerate]: https://github.com/tmcdonell/lens-accelerate + [linear]: https://hackage.haskell.org/package/linear + [linear-accelerate]: https://github.com/tmcdonell/linear-accelerate + [mwc-random-accelerate]: https://github.com/tmcdonell/mwc-random-accelerate + [numeric-prelude]: https://hackage.haskell.org/package/numeric-prelude + [numeric-prelude-accelerate]: https://github.com/tmcdonell/numeric-prelude-accelerate + [LULESH]: https://codesign.llnl.gov/lulesh.php + [ALE3D]: https://wci.llnl.gov/simulation/computer-codes/ale3d + [lulesh-accelerate]: https://github.com/tmcdonell/lulesh-accelerate + [lol]: https://hackage.haskell.org/package/lol + [lol-accelerate]: https://github.com/tmcdonell/lol-accelerate + diff --git a/accelerate.cabal b/accelerate.cabal --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,5 +1,5 @@ Name: accelerate -Version: 1.0.0.0 +Version: 1.1.0.0 Cabal-version: >= 1.8 Tested-with: GHC >= 7.8 Build-type: Simple @@ -39,10 +39,6 @@ greater. See the following table for supported GPUs: . - * @accelerate-cuda@: Backend targeting CUDA-enabled NVIDIA GPUs. Requires - a GPU with compute compatibility 1.2 or greater. /NOTE: This backend is - being deprecated in favour of @accelerate-llvm-ptx@./ - . * @accelerate-examples@: Computational kernels and applications showcasing the use of Accelerate as well as a regression test suite, supporting function and performance testing. @@ -129,7 +125,9 @@ Category: Compilers/Interpreters, Concurrency, Data, Parallelism Stability: Experimental -Extra-source-files: changelog.md +Extra-source-files: + README.md + CHANGELOG.md Flag debug Default: False @@ -154,6 +152,8 @@ . * @flush-cache@: Clear any persistent caches on program startup (False). . + * @force-recomp@: Force recompilation of array programs (False). + . * @fast-math@: Allow algebraically equivalent transformations which may change floating point results (e.g., reassociate) (True). . @@ -206,8 +206,13 @@ Description: Enable hooks for monitoring the running application using EKG. Implies @debug@ mode. In order to view the metrics, your application will need to - initialise the EKG server like so: + call @Data.Array.Accelerate.Debug.beginMonitoring@ before running any + Accelerate computations. This will launch the server on the local machine at + port 8000. . + Alternatively, if you wish to configure the EKG monitoring server you can + initialise it like so: + . > import Data.Array.Accelerate.Debug > > import System.Metrics @@ -223,7 +228,7 @@ > ... . Note that, as with any program utilising EKG, in order to collect Haskell GC - statistics collection, you must either run the program with: + statistics, you must either run the program with: . > +RTS -T -RTS . @@ -246,7 +251,7 @@ Library Build-depends: - base >= 4.7 && < 4.10 + base >= 4.7 && < 4.11 , base-orphans >= 0.3 , containers >= 0.3 , deepseq >= 1.3 @@ -278,6 +283,7 @@ -- For backend development Data.Array.Accelerate.AST + Data.Array.Accelerate.Analysis.Hash Data.Array.Accelerate.Analysis.Match Data.Array.Accelerate.Analysis.Shape Data.Array.Accelerate.Analysis.Stencil @@ -303,6 +309,7 @@ Other-modules: Data.Atomic + Data.Array.Accelerate.Analysis.Hash.TH Data.Array.Accelerate.Array.Lifted Data.Array.Accelerate.Array.Remote.Nursery Data.Array.Accelerate.Classes @@ -383,6 +390,10 @@ if impl(ghc >= 8.0) ghc-options: -freduction-depth=35 + if impl(ghc < 7.10) + build-depends: + th-lift-instances >= 0.1 + -- Don't add the extensions list here. Instead, place individual LANGUAGE -- pragmas in the files that require a specific extension. This means the -- project loads in GHCi, and avoids extension clashes. @@ -395,7 +406,7 @@ source-repository this Type: git - Tag: 1.0.0.0 + Tag: 1.1.0.0 Location: git://github.com/AccelerateHS/accelerate.git -- vim: nospell diff --git a/changelog.md b/changelog.md deleted file mode 100644 --- a/changelog.md +++ /dev/null @@ -1,90 +0,0 @@ -1.0.0.0 - - * Many API and internal changes - - * Bug fixes and other enhancements - -0.15.0.0 - - * Bug fixes and performance improvements. - -0.14.0.0 - - * New iteration constructs. - - * Additional Prelude-like functions. - - * Improved code generation and fusion optimisation. - - * Concurrent kernel execution in the CUDA backend. - - * Bug fixes. - -0.13.0.0 - - * New array fusion optimisation. - - * New foreign function interface for array and scalar expressions. - - * Additional Prelude-like functions. - - * New example programs. - - * Bug fixes and performance improvements. - -0.12.0.0 - - * Full sharing recovery in scalar expressions and array computations. - - * Two new example applications in package `accelerate-examples`: Real-time - Canny edge detection and an interactive fluid flow simulator (both including - a graphical frontend). - - * Bug fixes. - -0.11.0.0 - - * New Prelude-like functions `zip*`, `unzip*`, `fill`, `enumFrom*`, `tail`, - `init`, `drop`, `take`, `slit`, `gather*`, `scatter*`, and `shapeSize`. - - * New simplified AST (in package `accelerate-backend-kit`) for backend writers - who want to avoid the complexities of the type-safe AST. - -0.10.0.0 - - * Complete sharing recovery for scalar expressions (but currently disabled by - default). - - * Also bug fixes in array sharing recovery and a few new convenience - functions. - -0.9.0.0 - - * Streaming computations - - * Precompilation - - * Repa-style array indices - - * Additional collective operations supported by the CUDA backend: `stencil`s, - more `scan`s, rank-polymorphic `fold`, `generate`. - - * Conversions to other array formats - - * Bug fixes - -0.8.1.0 - - * Bug fixes and some performance tweaks. - -0.8.0.0 - - * More collective operations supported by the CUDA backend: `replicate`, - `slice` and `foldSeg`. Frontend and interpreter support for `stencil`. - - * Bug fixes. - -0.7.1.0 - - * Initial release of the CUDA backend -